module Dataflow

open Microsoft.FSharp.Math
open System.Collections
open System.Collections.Generic

module Guts =
    open System
    open System.Collections.Generic

    [<Interface>]
    type ICell =
        abstract Invalidate : unit -> bool
        abstract NotifyCalled : ICell -> unit
        abstract NotifyRemoved : ICell -> unit
        abstract WeakReference : WeakReference<ICell>
        abstract AfterInvalidate : unit -> unit
        abstract InvalidateIf : unit -> bool
        abstract BarfOnCycle : bool
        abstract Compute : unit -> unit
    and Integrity() =
        let mutable stack : ICell list = []
        let mutable toBe : ICell list = []
        let mutable thunks : (unit -> unit) list = []
        member o.Push (callee : ICell) =
            //match List.tryFind (fun x -> Object.ReferenceEquals(x, callee)) stack with
            if 1 < List.sumBy (fun x -> if Object.ReferenceEquals(x, callee) then 1 else 0) stack
            then match callee.BarfOnCycle with
                 | true -> sprintf "cycle detected on cell %A" callee |> failwith
                 | false -> false
            else stack <- callee :: stack
                 true
        member o.DetermineCaller callee =
            let getFirst xs =
                match xs with
                | x :: xs -> Some x
                | [] -> None
            let rec fn rest =
                match rest with
                | [] -> failwith "corrupt stack!"
                | x :: xs when Object.ReferenceEquals(callee, x) -> xs, getFirst xs
                | _ :: xs -> fn xs
            let stack', caller = fn stack
            stack <- stack'
            caller
        member o.DetermineCallerSingle() =
            match stack with
            | x :: _ -> Some x
            | [] -> None
        member o.EvalLater c =
            toBe <- c :: toBe
        member o.MakeBe() =
            o.EvalCells()
            o.EvalThunks()
        member private o.EvalCells() =
            match toBe with
            | [] -> ()
            | x::xs -> x.Compute(); toBe <- xs; o.EvalCells()
        member private o.EvalThunks() =
            match thunks with
            | [] -> ()
            | x :: xs -> x(); thunks <- xs; o.EvalThunks()

        member o.EvalThunkLater fn =
            thunks <- fn :: thunks

    [<AbstractClass>]
    type 'T BaseCell(isLazy : bool, integrity : Integrity) as o =
        let inner : ICell HashSet = HashSet()
        let callers : ICell WeakReference HashSet = HashSet(WeakReferenceComparer.Singleton : IEqualityComparer<WeakReference<ICell>>)
        do if not isLazy then integrity.EvalLater o
        abstract BarfOnCycle : bool
        member val Handlers : ('T -> unit) ResizeArray = ResizeArray()
        member o.RecomputeCallers() =
            for i in callers do
                match i.TryGetTarget() with
                | true, c -> if c.Invalidate() then c.AfterInvalidate()
                | _, _ -> ()
        abstract IsForcing : bool
        default o.IsForcing = false
        interface ICell with
            member o.Invalidate () =
                let ret = (o :> ICell).InvalidateIf()
                if ret then
                    o.IsCached <- false
                    for i in callers do
                        match i.TryGetTarget() with
                        | true, v -> v.Invalidate () |> ignore
                        | _, _ -> ()
                ret
            member o.AfterInvalidate () =
                if not isLazy
                then o.GetValue () |> ignore
                for i in callers |> Seq.toList do
                    match i.TryGetTarget() with
                    | true, v -> v.AfterInvalidate (); if o.IsForcing then v.Compute()
                    | _, _ -> ()
            member o.NotifyCalled c =
                inner.Add c |> ignore
            member o.NotifyRemoved c =
                inner.Remove c |> ignore
            member o.WeakReference = WeakReference<ICell>(o)
            member o.InvalidateIf () = true
            member o.BarfOnCycle = o.BarfOnCycle
            member o.Compute () = o.GetValue() |> ignore
        abstract ComputeValue : unit -> 'T
        member o.IsLazy with get () = isLazy
        member o.CacheValue () =
            let oldInner = HashSet(inner)
            inner.Clear()
            o.CachedValue <- o.ComputeValue ()
            o.IsCached <- true
            let removed = HashSet(inner)
            removed.ExceptWith(oldInner)
            for i in removed do
                i.NotifyRemoved o
            let predicate (x : WeakReference<ICell>) = match x.TryGetTarget() with
                                                       | true, d -> removed.Contains(d)
                                                       | _, _ -> true
            Predicate predicate |> callers.RemoveWhere |> ignore
            let cnt = o.Handlers.Count
            let value = o.CachedValue
            for i in 0 .. cnt - 1 do
                let handler = o.Handlers.[i]
                integrity.EvalThunkLater <| fun () -> handler value
        member val IsCached = false with get, set
        member val CachedValue = Unchecked.defaultof<'T> with get, set
        member o.NotifyCaller (caller : ICell) =
            caller.NotifyCalled o
            caller.WeakReference |> callers.Add |> ignore
        member o.GetValue () =
            if not o.IsCached
            then match (if integrity.Push o
                            then o.CacheValue ()
                                 true
                            else false) with
                 | true ->  match integrity.DetermineCaller o with
                            | Some x -> o.NotifyCaller x
                            | None -> ()
                 | false -> ()
            else match integrity.DetermineCallerSingle() with
                 | Some x -> o.NotifyCaller x
                 | None -> ()
            o.CachedValue
        override o.Finalize() =
            for i in inner do
                i.NotifyRemoved o
    and WeakReferenceComparer private() =
        interface IEqualityComparer<WeakReference<ICell>> with
            member o.Equals(x, y) =
                match x.TryGetTarget(), y.TryGetTarget() with
                | (true, x), (true, y) when Object.ReferenceEquals(x, y) -> true
                | _, _ -> false
            member o.GetHashCode(x) =
                match x.TryGetTarget() with
                | true, x -> x.GetHashCode()
                | false, _ -> 0
        static member val Singleton = WeakReferenceComparer() :> IEqualityComparer<WeakReference<ICell>>

    type 'T InputCell(integrity, initialValue : 'T) as o =
        inherit BaseCell<'T>(true, integrity)
        do o.CachedValue <- initialValue
           o.IsCached <- true
        override o.ComputeValue () = o.CachedValue
        member o.SetValue value =
            if not <| Object.Equals(value, o.CachedValue) then
                o.CachedValue <- value
                if (o :> ICell).Invalidate ()
                then (o :> ICell).AfterInvalidate ()
        override o.BarfOnCycle = false

    type 'T Event(integrity, initialValue) =
        inherit BaseCell<'T>(false, integrity)
        let mutable resetValue = initialValue
        override o.ComputeValue () = resetValue
        override o.IsForcing = true
        member o.Fire value =
            resetValue <- value
            try if (o :> ICell).Invalidate ()
                then (o :> ICell).AfterInvalidate ()
            finally resetValue <- initialValue
        override o.BarfOnCycle = true

    type Filter<'T, 'C, 'S>(cell : 'C BaseCell, initialState : 'S, filter : 'S -> 'S * bool, map : 'S -> 'T, integrity : Integrity) =
        inherit BaseCell<'T>(false, integrity)
        let mutable state = initialState
        let mutable didFire = true
        override o.ComputeValue () =
            let c = cell.GetValue()
            let state', didFire' = filter state
            state <- state'
            map state
        interface ICell with
            override o.InvalidateIf () =
                let c = cell.CachedValue
                let state', didFire' = filter state
                state <- state'
                didFire <- didFire'
                didFire
        override o.BarfOnCycle = true

    type 'U Container(cell : 'U BaseCell) =
        member val Cell = cell with get, set
    and 'T M =
        | Return of 'T BaseCell
        | Done of 'T
        | Delay of (unit -> 'T M)
        | Wrapper of 'T Container
        member o.eval () =
            match o with
            | Return c -> c.GetValue ()
            | Done v -> v
            | Delay k -> (k()).eval()
            | Wrapper w -> w.Cell.GetValue()
        member o.value = o.eval()
        member private o._set1 c value =
            match c with
            | Return w -> o._set2 w value
            | Wrapper w -> o._set2 w.Cell value
            | _ -> failwith "can't happen"
        member private o._set2 c value =
            match c with
                | :? InputCell<'T> as c -> c.SetValue value
                | :? Event<'T> as c -> c.Fire value
                | _ -> failwith "can't happen"
        member o.set (value : 'T) =
            o._set1 o value
        member o.cell
            with get () =
                match o with
                | Wrapper w -> w.Cell
                | Return c -> c
                | _ -> failwith "can't happen"
        member o.force() =
            match o with
            | Wrapper w -> if (w.Cell :> ICell).Invalidate()
                           then (w.Cell :> ICell).AfterInvalidate()
            | Return c -> if (c :> ICell).Invalidate()
                          then (c :> ICell).AfterInvalidate()
            | _ -> failwith "can't happen"
        member o.replace (cell : 'T M) =
            match o with
            | Wrapper w -> let old = w.Cell in w.Cell <- cell.cell; old.RecomputeCallers()
            | _ -> failwith "not a wrapper"
        member o.Handlers =
            o.cell.Handlers

    type 'T Formula(isLazy : bool, fn : unit -> 'T, integrity) =
        inherit BaseCell<'T>(isLazy, integrity)
        override o.ComputeValue () = fn ()
        override o.BarfOnCycle = true

    type BaseFormulaBuilder(integrity, isLazy) =
        let bind (k : 'a -> 'b M) (v : 'a M) : 'b M =
            v.eval () |> k
        member o.Bind(v, k) = bind k v
        member o.Return (v : 'a) = Done v
        member o.Zero () = Done ()
        member o.Combine (a : 'a M, b : 'b M) = a.eval () |> ignore; b
        member o.Delay (k : unit -> 'a M) : 'a M = Delay k
        member o.ReturnFrom (m : 'a M) : 'a M = m
        member o.While (cond : unit -> bool, body : unit M) : unit M =
            while cond () do
                body.eval ()
            Done ()
        member o.For(seq : 'a seq, f : 'a -> unit M) : unit M =
            for i in seq do
                (f i).eval() |> ignore
            Done ()
        member o.TryWith (f : 'a M, p : exn -> 'a M) : 'a M =
            try f.eval () |> Done
            with | ex -> p ex
        member o.TryFinally (f : 'a M, p : unit -> unit) : 'a M =
            try f.eval () |> Done
            finally p ()
        member o.Using (v : 'a, f : 'a -> 'b M) : 'b M when 'U :> IDisposable =
            using v f
        member o.Run (m : 'a M) : 'a M =
            Wrapper(Container(Formula(isLazy, (fun () -> m.eval ()), integrity)))

    type FormulaBuilder(integrity) =
        inherit BaseFormulaBuilder(integrity, true)

    type StrictFormulaBuiler(integrity) =
        inherit BaseFormulaBuilder(integrity, false)

    type 'T XList =
        inherit IList<'T>
        abstract AddRange : 'T seq -> unit

    type 'T ListWrapper(sequence : 'T ResizeArray, cell : 'T SequenceCell) =
        let update() =
            if (cell :> ICell).Invalidate()
            then (cell :> ICell).AfterInvalidate()
        interface IList<'T> with
            member o.Count = sequence.Count
            member o.IsReadOnly = false
            member o.Item
                with get i = sequence.[i]
                and set i v = sequence.[i] <- v; update()
            member o.Add value = sequence.Add value;
            member o.Clear () = sequence.Clear (); update()
            member o.Contains value = sequence.Contains value
            member o.CopyTo(ary, int) = sequence.CopyTo(ary, int)
            member o.GetEnumerator () = (sequence :> 'T IList).GetEnumerator ()
            member o.RemoveAt i = sequence.RemoveAt i; update()
            member o.Remove v = let ret = sequence.Remove v in update(); ret
            member o.Insert(i, v) = sequence.Insert(i, v); update()
            member o.IndexOf v = sequence.IndexOf v
        interface IEnumerable with
            member o.GetEnumerator () = (sequence :> IEnumerable).GetEnumerator ()
        interface XList<'T> with
            member o.AddRange xs = sequence.AddRange xs; update()
    and 'T SequenceCell(integrity) as self =
        inherit BaseCell<'T XList>(true, integrity)
        let wrapper = ListWrapper(ResizeArray<'T>(), self)
        override o.ComputeValue () = (wrapper :> 'T XList)
        override o.BarfOnCycle = true

type 'T Cell = 'T Guts.M
type 'T ListCell = 'T Guts.XList Guts.M

type Sheet() =
    let integrity = Guts.Integrity()
    let wrap (cell : 'T Guts.BaseCell) =
        Guts.Wrapper(Guts.Container(cell))
    member o.Input x = Guts.InputCell(integrity, x) |> wrap
    member o.Formula = Guts.FormulaBuilder(integrity)
    member o.StrictFormula = Guts.StrictFormulaBuiler(integrity)
    member o.Event x = Guts.Event(integrity, x) |> wrap
    member o.Filter c state filter map = Guts.Filter(c, state, filter, map, integrity) |> wrap
    member o.Delta (delta : 'a) (c : 'a Guts.M) =
        let ops = GlobalAssociations.GetNumericAssociation<'a>()
        let cell = c.cell
        o.Filter cell
                 ops.Zero
                 (fun state -> let value = cell.GetValue()
                               if ops.Abs(ops.Subtract(value, state)) >= delta
                               then value, true
                               else state, false)
                 (fun x -> x)
    member o.List () : 'T Guts.XList Guts.M = Guts.SequenceCell(integrity) |> wrap
    member o.MakeBe() = integrity.MakeBe()