diff --git a/.gitignore b/.gitignore index fbcd049..9ff4a38 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +**/*DotSettings.user bin/Release bin/Debug bin/Fable @@ -30,4 +31,4 @@ symbolCache.db /tmp/ /.fsdocs /output -/.idea \ No newline at end of file +/.idea diff --git a/FSharp.Data.Adaptive.sln b/FSharp.Data.Adaptive.sln index 414660c..fa25163 100644 --- a/FSharp.Data.Adaptive.sln +++ b/FSharp.Data.Adaptive.sln @@ -26,6 +26,14 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Scratch", "src\Demo\Scratch EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "PublishTrimmedTest", "src\Demo\PublishTrimmedTest\PublishTrimmedTest.fsproj", "{11280471-7178-4DC3-9BAD-18411B1AE62B}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Data.Adaptive.Experimental", "src\FSharp.Data.Adaptive.Experimental\FSharp.Data.Adaptive.Experimental.fsproj", "{3875D681-E153-4691-AA21-A06DFDEF4529}" +EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{A6FD5D71-7873-4703-B399-5956FA11ED11}" + ProjectSection(SolutionItems) = preProject + RELEASE_NOTES.md = RELEASE_NOTES.md + paket.dependencies = paket.dependencies + EndProjectSection +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -72,6 +80,10 @@ Global {11280471-7178-4DC3-9BAD-18411B1AE62B}.Debug|Any CPU.Build.0 = Debug|Any CPU {11280471-7178-4DC3-9BAD-18411B1AE62B}.Release|Any CPU.ActiveCfg = Release|Any CPU {11280471-7178-4DC3-9BAD-18411B1AE62B}.Release|Any CPU.Build.0 = Release|Any CPU + {3875D681-E153-4691-AA21-A06DFDEF4529}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {3875D681-E153-4691-AA21-A06DFDEF4529}.Debug|Any CPU.Build.0 = Debug|Any CPU + {3875D681-E153-4691-AA21-A06DFDEF4529}.Release|Any CPU.ActiveCfg = Release|Any CPU + {3875D681-E153-4691-AA21-A06DFDEF4529}.Release|Any CPU.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/paket.dependencies b/paket.dependencies index 24acb21..d97773c 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -3,7 +3,7 @@ redirects: off storage: none framework: auto-detect -nuget FSharp.Core >= 4.7.0 lowest_matching: true +nuget FSharp.Core >= 6.0.0 lowest_matching: true nuget System.Reflection.Emit.Lightweight >= 4.6.0 lowest_matching: true nuget Aardvark.Build ~> 1.0.18 diff --git a/paket.lock b/paket.lock index a88cc0a..c9c6fba 100644 --- a/paket.lock +++ b/paket.lock @@ -45,7 +45,7 @@ NUGET FsCheck.NUnit (2.14.6) FsCheck (2.14.6) NUnit (>= 3.10.1 < 3.13.1) - FSharp.Core (4.7.2) + FSharp.Core (6.0) FsUnit (3.4.1) FSharp.Core (>= 4.2.3) NETStandard.Library (>= 2.0.3) diff --git a/src/CSharp.Data.Adaptive/CSharp.Data.Adaptive.fsproj b/src/CSharp.Data.Adaptive/CSharp.Data.Adaptive.fsproj index 6402c71..ba50cf6 100644 --- a/src/CSharp.Data.Adaptive/CSharp.Data.Adaptive.fsproj +++ b/src/CSharp.Data.Adaptive/CSharp.Data.Adaptive.fsproj @@ -1,7 +1,7 @@  - netstandard2.0;net5.0;net6.0 + netstandard2.0;net6.0 true link true diff --git a/src/Demo/CSharpInterop/Program.cs b/src/Demo/CSharpInterop/Program.cs index 6cc2bfa..edc2699 100644 --- a/src/Demo/CSharpInterop/Program.cs +++ b/src/Demo/CSharpInterop/Program.cs @@ -10,6 +10,14 @@ namespace CSharpInterop { public class Program { + static void ArrTest() + { + var arr = ArrModule.empty().Add(100).Add(23); + Console.WriteLine($"{arr}"); + + + } + static void Scratch() { DefaultEqualityComparer.SetProvider(DefaultEqualityComparer.System); @@ -114,7 +122,8 @@ static void Scratch() public static void Main() { - Scratch(); + ArrTest(); + //Scratch(); //BenchmarkRunner.Run(); } diff --git a/src/Demo/Scratch/ABag.fs b/src/Demo/Scratch/ABag.fs index d31ca41..7fb7e20 100644 --- a/src/Demo/Scratch/ABag.fs +++ b/src/Demo/Scratch/ABag.fs @@ -224,7 +224,7 @@ module ABag = let mapping = OptimizedClosures.FSharpFunc<_,_,_>.Adapt mapping ofReader <| fun () -> let cache = IdCache<'K>() - let inline mapDelta (ops : HashMapDelta<'K, 'V>) = + let mapDelta (ops : HashMapDelta<'K, 'V>) = ops |> HashMapDelta.toHashMap |> Seq.choose (fun (k, op) -> @@ -447,7 +447,7 @@ module ABag = | Set nv -> let newbag = mapping nv - let inline newReader() = + let newReader() = let newReader = newbag.GetReader() let newCache = IdCache() newReader.Tag <- newCache diff --git a/src/Demo/Scratch/Arr.fs b/src/Demo/Scratch/Arr.fs new file mode 100644 index 0000000..8de972f --- /dev/null +++ b/src/Demo/Scratch/Arr.fs @@ -0,0 +1,38 @@ +module Arr + +open FSharp.Data.Adaptive + +let run() = + + + + + let test = Arr.ofArray [|1..20|] + + let a = Arr.ofList [1;2;3;4] + let b = Arr.ofList [1;2;5;6;4;10;20] + let c = Arr.ofList [5;4] + + + printfn "%A" a + printfn "%A" (a.Split 3) + + let dab = Arr.computeDelta (=) a b + let dbc = Arr.computeDelta (=) b c + let dac = Arr.computeDelta (=) a c + + + printfn "a: %0A" (Arr.toArray a) + printfn "b: %0A" (Arr.toArray b) + printfn "c: %0A" (Arr.toArray c) + + printfn "a->b: %A" (dab |> ArrDelta.toArray |> Array.map (fun op -> op.Index, op.Count, Arr.toArray op.Elements)) + printfn "b->c: %A" (dbc |> ArrDelta.toArray |> Array.map (fun op -> op.Index, op.Count, Arr.toArray op.Elements)) + printfn "a->c: %A" (dac |> ArrDelta.toArray |> Array.map (fun op -> op.Index, op.Count, Arr.toArray op.Elements)) + + printfn "b(a): %0A" (Arr.applyDelta a dab |> Arr.toArray) + printfn "c(a): %0A" (Arr.applyDelta a dac |> Arr.toArray) + printfn "c(b): %0A" (Arr.applyDelta b dbc |> Arr.toArray) + + printfn "ac1: %0A" (ArrDelta.combine dab dbc |> ArrDelta.toArray |> Array.map (fun op -> op.Index, op.Count, Arr.toArray op.Elements)) + printfn "ac1: %0A" (Arr.applyDelta a (ArrDelta.combine dab dbc) |> Arr.toArray) \ No newline at end of file diff --git a/src/Demo/Scratch/Program.fs b/src/Demo/Scratch/Program.fs index bcd12ba..12be1c2 100644 --- a/src/Demo/Scratch/Program.fs +++ b/src/Demo/Scratch/Program.fs @@ -3,7 +3,86 @@ open System.Collections.Generic open FSharp.Data.Adaptive open FSharp.Data.Traceable +type IComponent<'a> = + abstract member ElementType : System.Type + +type Pos = + interface IComponent with + member x.ElementType = typeof + +type Vel = + interface IComponent with + member x.ElementType = typeof + +type Memory() = + let mutable mem : HashMap = HashMap.empty + let mutable slot = 0 + let mutable cap = 1024 + let mutable count = 0 + + member x.Alloc(attributes : HashMap) = + let id = slot + slot <- slot + 1 + if id >= cap then + mem <- mem |> HashMap.map (fun _ v -> + failwith "realloc" + ) + + for (k, value) in attributes do + match HashMap.tryFind k mem with + | Some arr -> arr.SetValue(value, id) + | None -> + let arr = System.Array.CreateInstance(value.GetType(), cap) + arr.SetValue(value, id) + mem <- HashMap.add k arr mem + + count <- count + 1 + id + + member x.Count = count + + member x.Get(name : System.Type) = + mem.[name] + + member x.Get<'a, 'b when 'a :> IComponent<'b>>() = + mem.[typeof<'a>] :?> array<'b> + + +let simulate (dt : float) (mem : Memory) = + let pos = mem.Get() + let vel = mem.Get() + + for i in 0 .. mem.Count - 1 do + pos.[i] <- pos.[i] + vel.[i] * dt + +let mem = Memory() + +let o0 = + mem.Alloc ( + HashMap.ofList [ + typeof, 0.0 + typeof, 1.0 + ] + ) + + +let o1 = + mem.Alloc ( + HashMap.ofList [ + typeof, 2.0 + typeof, -1.0 + ] + ) + +for i in 0 .. 10 do + simulate 0.01 mem + +printfn "%A" (mem.Get()) + +AArrTest.run() +//Arr.run() //ABag.run() //Observable.run() //LookupAll.example() -AListSub.run() \ No newline at end of file +//AListSub.run() +//Arr.run() \ No newline at end of file diff --git a/src/Demo/Scratch/Scratch.fsproj b/src/Demo/Scratch/Scratch.fsproj index 243cf7a..1b82194 100644 --- a/src/Demo/Scratch/Scratch.fsproj +++ b/src/Demo/Scratch/Scratch.fsproj @@ -17,9 +17,11 @@ + + diff --git a/src/FSharp.Data.Adaptive.Experimental/AdaptiveArray/Arr.fs b/src/FSharp.Data.Adaptive.Experimental/AdaptiveArray/Arr.fs new file mode 100644 index 0000000..4622c42 --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/AdaptiveArray/Arr.fs @@ -0,0 +1,989 @@ +namespace FSharp.Data.Adaptive + +#nowarn "7331" + +open System +open System.Diagnostics +open FSharp.Data.Adaptive.ComputeListDeltaHelpers + +module ArrNodeImplementationAggregate = + + type Aggregator<'a, 's> = + { + View : 'a -> 's + Add : OptimizedClosures.FSharpFunc<'s, 's, 's> + Zero : 's + } + + + [] + type AggregateNode<'a, 's> = + val mutable public Height : byte + val mutable public Value : 'a + + new(h, v) = { Height = h; Value = v } + + type AggregateInner<'a, 's> = + inherit AggregateNode<'a, 's> + val mutable public Left : AggregateNode<'a, 's> + val mutable public Right : AggregateNode<'a, 's> + val mutable public Count : int + val mutable public Aggregate : 's + + static member inline GetCount(node : AggregateNode<'a, 's>) = + if isNull node then 0 + elif node.Height = 1uy then 1 + else (node :?> AggregateInner<'a, 's>).Count + + static member inline GetHeight(node : AggregateNode<'a, 's>) = + if isNull node then 0uy + else node.Height + + static member inline GetAggregate(a : Aggregator<'a, 's>, n : AggregateNode<'a, 's>) = + if isNull n then a.Zero + elif n.Height = 1uy then a.View n.Value + else + let n = n :?> AggregateInner<'a, 's> + n.Aggregate + + static member inline FixHeightAndCount(inner : AggregateInner<'a, 's>) = + let lc = AggregateInner.GetCount inner.Left + let rc = AggregateInner.GetCount inner.Right + let lh = if lc > 0 then inner.Left.Height else 0uy + let rh = if rc > 0 then inner.Right.Height else 0uy + inner.Count <- 1 + lc + rc + inner.Height <- 1uy + max lh rh + + static member New(a : Aggregator<'a, 's>, l : AggregateNode<'a, 's>, value : 'a, r : AggregateNode<'a, 's>) : AggregateNode<'a, 's> = + if isNull l && isNull r then AggregateNode(1uy, value) + else + let h = 1uy + max (AggregateInner.GetHeight l) (AggregateInner.GetHeight r) + let c = 1 + AggregateInner.GetCount l + AggregateInner.GetCount r + AggregateInner<'a, 's>(a, h, value, l, r, c) :> AggregateNode<_,_> + + new(a : Aggregator<'a, 's>, h : byte, v : 'a, l : AggregateNode<'a, 's>, r : AggregateNode<'a, 's>, c : int) = + let va = a.Add.Invoke(a.Add.Invoke(AggregateInner.GetAggregate(a, l), a.View v), AggregateInner.GetAggregate(a, r)) + { inherit AggregateNode<'a, 's>(h, v); Left = l; Right = r; Count = c; Aggregate = va } + + module AggregateNode = + let empty<'a, 's> : AggregateNode<'a, 's> = null + + let inline height (n : AggregateNode<'a, 's>) = + if isNull n then 0uy + else n.Height + + let inline aggregate (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if isNull n then a.Zero + elif n.Height = 1uy then a.View n.Value + else + let n = n :?> AggregateInner<'a, 's> + n.Aggregate + + let inline isEmpty (n : AggregateNode<'a, 's>) = + isNull n + + let inline count (n : AggregateNode<'a, 's>) = + if isNull n then 0 + elif n.Height = 1uy then 1 + else (n :?> AggregateInner<'a, 's>).Count + + + let inline balance (n : AggregateInner<'a, 's>) = + int (height n.Right) - int (height n.Left) + + let rec binary (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (v : 'a) (r : AggregateNode<'a, 's>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> AggregateInner<'a, 's> + let rb = balance r + if rb > 0 then + // right right + binary + a + (binary a l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> AggregateInner<'a, 's> + binary a + (binary a l v rl.Left) + rl.Value + (binary a rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> AggregateInner<'a, 's> + let lb = balance l + if lb < 0 then + // left left + binary a + l.Left + l.Value + (binary a l.Right v r) + else + // left right + let lr = l.Right :?> AggregateInner<'a, 's> + binary a + (binary a l.Left l.Value lr.Left) + lr.Value + (binary a lr.Right v r) + + elif lh = 0uy && rh = 0uy then AggregateNode(1uy, v) + else AggregateInner(a, 1uy + max lh rh, v, l, r, 1 + lc + rc) :> AggregateNode<_, _> + + let inline unsafeInner a l v r = AggregateInner.New(a, l, v, r) + + let unsafeBinary (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (v : 'a) (r : AggregateNode<'a, 's>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> AggregateInner<'a, 's> + let rb = balance r + if rb > 0 then + // right right + unsafeInner a + (unsafeInner a l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> AggregateInner<'a, 's> + unsafeInner a + (unsafeInner a l v rl.Left) + rl.Value + (unsafeInner a rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> AggregateInner<'a, 's> + let lb = balance l + if lb < 0 then + // left left + unsafeInner a + l.Left + l.Value + (unsafeInner a l.Right v r) + else + // left right + let lr = l.Right :?> AggregateInner<'a, 's> + unsafeInner a + (unsafeInner a l.Left l.Value lr.Left) + lr.Value + (unsafeInner a lr.Right v r) + + elif lh = 0uy && rh = 0uy then AggregateNode(1uy, v) + else AggregateInner(a, 1uy + max lh rh, v, l, r, 1 + lc + rc) :> AggregateNode<_,_> + + + + let rec unsafeRemoveMin (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if n.Height = 1uy then + struct(n.Value, null) + else + let n = n :?> AggregateInner<'a, 's> + if isNull n.Left then + struct(n.Value, n.Right) + else + let struct(value, newLeft) = unsafeRemoveMin a n.Left + let node = unsafeBinary a newLeft n.Value n.Right + struct(value, node) + + let rec unsafeRemoveMax (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if n.Height = 1uy then + struct(n.Value, null) + else + let n = n :?> AggregateInner<'a, 's> + if isNull n.Right then + struct(n.Value, n.Left) + else + let struct(value, newRight) = unsafeRemoveMax a n.Right + let node = unsafeBinary a n.Left n.Value newRight + struct(value, node) + + + let rec join (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (r : AggregateNode<'a, 's>) = + if isNull l then r + elif isNull r then l + else + let lh = l.Height + let rh = r.Height + if lh > rh then + let struct(v, ln) = unsafeRemoveMax a l + binary a ln v r + else + let struct(v, rn) = unsafeRemoveMin a r + binary a l v rn + + let rec insertAt (a : Aggregator<'a, 's>) (index : int) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + if index = 0 then binary a null value n + else binary a n value null + else + let n = n :?> AggregateInner<'a, 's> + let c = count n.Left + if index <= c then + binary a (insertAt a index value n.Left) n.Value n.Right + else + binary a n.Left n.Value (insertAt a (index - c - 1) value n.Right) + + let rec set (a : Aggregator<'a, 's>) (index : int) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + null + elif n.Height = 1uy then + if index = 0 then AggregateNode(1uy, value) + else n + else + let n = n :?> AggregateInner<'a, 's> + let c = count n.Left + if index < c then + let newLeft = set a index value n.Left + binary a newLeft n.Value n.Right + elif index > c then + let newRight = set a (index - c - 1) value n.Right + binary a n.Left n.Value newRight + else + binary a n.Left value n.Right + + let rec append (a : Aggregator<'a, 's>) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + binary a n value null + else + let n = n :?> AggregateInner<'a, 's> + binary a n.Left n.Value (append a value n.Right) + + let rec prepend (a : Aggregator<'a, 's>) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + binary a null value n + else + let n = n :?> AggregateInner<'a, 's> + binary a (prepend a value n.Left) n.Value n.Right + + + let rec skip (a : Aggregator<'a, 's>) (n : int) (node : AggregateNode<'a, 's>) = + if n <= 0 then node + elif isNull node || node.Height = 1uy then + null + else + let node = node :?> AggregateInner<'a, 's> + if n >= node.Count then + null + else + let lc = count node.Left + if n < lc then binary a (skip a n node.Left) node.Value node.Right + elif n = lc then prepend a node.Value node.Right + else skip a (n - lc - 1) node.Right + + let rec take (a : Aggregator<'a, 's>) (n : int) (node : AggregateNode<'a, 's>) = + if n <= 0 then null + elif isNull node || node.Height = 1uy then + node + else + let node = node :?> AggregateInner<'a, 's> + if n >= node.Count then + node + else + let lc = count node.Left + if n <= lc then take a n node.Left + elif n = lc then append a node.Value node.Left + else binary a node.Left node.Value (take a (n - lc - 1) node.Right) + + let rec sub (a : Aggregator<'a, 's>) (l : int) (r : int) (node : AggregateNode<'a, 's>) = + + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then node + else null + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + sub a l r node.Left + elif l > lc then + sub a (l - lc - 1) (r - lc - 1) node.Right + elif l = lc then + prepend a node.Value (take a (r - l) node.Right) + elif r = lc then + append a node.Value (skip a l node.Left) + else + binary a (skip a l node.Left) node.Value (take a (r - lc) node.Right) + + + let join3 (agg : Aggregator<'a, 's>) (a : AggregateNode<'a, 's>) (b : AggregateNode<'a, 's>) (c : AggregateNode<'a, 's>) = + join agg a (join agg b c) // TODO!!! + + let rec removeRange (a : Aggregator<'a, 's>) (l : int) (r : int) (node : AggregateNode<'a, 's>) = + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then null + else node + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + binary a (removeRange a l r node.Left) node.Value node.Right + elif l > lc then + binary a node.Left node.Value (removeRange a (l - lc - 1) (r - lc - 1) node.Right) + elif l = lc then + join a node.Left (skip a (r - l) node.Right) + elif r = lc then + join a (take a l node.Left) node.Right + else + let na = take a l node.Left + let nb = skip a (r - lc) node.Right + join a na nb + + let rec tryRemove (a : Aggregator<'a, 's>) (index : int) (node : AggregateNode<'a, 's>) = + if isNull node then + None + elif node.Height = 1uy then + if index = 0 then Some (null, node.Value) + else None + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + + if index < lc then + match tryRemove a index node.Left with + | Some (rest, v) -> + Some (binary a rest node.Value node.Right, v) + | None -> + None + elif index > lc then + match tryRemove a (index - lc - 1) node.Right with + | Some (rest, v) -> + Some (binary a node.Left node.Value rest, v) + | None -> + None + else + Some (join a node.Left node.Right, node.Value) + + + let rec insertRange (a : Aggregator<'a, 's>) (index : int) (repl : AggregateNode<'a, 's>) (node : AggregateNode<'a, 's>) = + if isNull node then + repl + elif node.Height = 1uy then + if index <= 0 then append a node.Value repl + else prepend a node.Value repl + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if index < lc then + binary a (insertRange a index repl node.Left) node.Value node.Right + elif index = lc then + let lh = height node.Left + let rh = height node.Right + if lh < rh then + let l = append a node.Value node.Left + join a (join a l repl) node.Right + else + let r = prepend a node.Value node.Right + join a node.Left (join a repl r) + else + binary a node.Left node.Value (insertRange a (index - lc - 1) repl node.Right) + + let rec replaceRange (a : Aggregator<'a, 's>) (l : int) (r : int) (repl : AggregateNode<'a, 's>) (node : AggregateNode<'a, 's>) = + if isNull node then + repl + elif node.Height = 1uy then + if l <= 0 && r >= 0 then repl + elif r < 0 then append a node.Value repl + else prepend a node.Value repl + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + binary a (replaceRange a l r repl node.Left) node.Value node.Right + elif l > lc then + binary a node.Left node.Value (replaceRange a (l - lc - 1) (r - lc - 1) repl node.Right) + elif l = lc then + join3 a node.Left repl (skip a (r - l) node.Right) + elif r = lc then + join3 a (take a l node.Left) repl node.Right + else + let na = take a l node.Left + let nb = skip a (r - lc) node.Right + join3 a na repl nb + + let rec tryAt (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then None + elif n.Height = 1uy then + if i = 0 then Some n.Value + else None + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAt i n.Left + elif i > lc then + tryAt (i - lc - 1) n.Right + else + Some n.Value + + let rec tryAtV (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then ValueNone + elif n.Height = 1uy then + if i = 0 then ValueSome n.Value + else ValueNone + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAtV i n.Left + elif i > lc then + tryAtV (i - lc - 1) n.Right + else + ValueSome n.Value + + + let rec tryAggregateAtIncl (a : Aggregator<'a, 's>) (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then + None + elif n.Height = 1uy then + if i = 0 then Some (a.View n.Value) + else None + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAggregateAtIncl a i n.Left + elif i > lc then + match tryAggregateAtIncl a (i - lc - 1) n.Right with + | None -> None + | Some rv -> + let lv = a.Add.Invoke(aggregate a n.Left, a.View n.Value) + Some (a.Add.Invoke(lv, rv)) + else + a.Add.Invoke(aggregate a n.Left, a.View n.Value) |> Some + + + + let rec exists (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then false + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> AggregateInner<'a, 's> + exists predicate n.Left || predicate n.Value || exists predicate n.Right + + let rec forall (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then true + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> AggregateInner<'a, 's> + forall predicate n.Left && predicate n.Value && forall predicate n.Right + + let rec tryFindIndex (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then None + elif n.Height = 1uy then + if predicate n.Value then + Some 0 + else + None + else + let n = n :?> AggregateInner<'a, 's> + + match tryFindIndex predicate n.Left with + | Some i -> Some i + | None -> + let lc = count n.Left + if predicate n.Value then + Some lc + else + match tryFindIndex predicate n.Right with + | Some i -> + Some (i + lc + 1) + | None -> + None + + let rec copyTo (index : int) (dst : 'a[]) (n : AggregateNode<'a, 's>) = + if not (isNull n) then + if n.Height = 1uy then dst.[index] <- n.Value + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + copyTo index dst n.Left + dst.[index + lc] <- n.Value + copyTo (index + lc + 1) dst n.Right + + let rec toList (acc : list<'a>) (node : AggregateNode<'a, 's>) = + if isNull node then + acc + elif node.Height = 1uy then + node.Value :: acc + else + let n = node :?> AggregateInner<'a, 's> + toList (n.Value :: toList acc n.Right) n.Left + + let toArray (n : AggregateNode<'a, 's>) = + let c = count n + let a = Array.zeroCreate c + copyTo 0 a n + a + + [] + type AggregateArr<'a, 's> internal(a : Aggregator<'a, 's>, store : AggregateNode<'a, 's>) = + static member Empty(a : Aggregator<'a, 's>) : AggregateArr<'a, 's> = AggregateArr<'a, 's>(a, null) + + member internal x.Store = store + member x.IsEmpty = AggregateNode.isEmpty store + member x.Length = AggregateNode.count store + + member x.InsertAt(index : int, value : 'a) = AggregateArr(a, AggregateNode.insertAt a index value store) + member x.Prepend(value : 'a) = AggregateArr(a, AggregateNode.prepend a value store) + member x.Append(value : 'a) = AggregateArr(a, AggregateNode.append a value store) + member x.Add(value : 'a) = x.Append(value) + member x.Set(i : int, value : 'a) = + if i < 0 || i >= x.Length then raise <| IndexOutOfRangeException() + else AggregateArr(a, AggregateNode.set a i value store) + member x.RemoveAt(index : int) = AggregateArr(a, AggregateNode.removeRange a index index store) + + member x.Skip(n : int) = + if n <= 0 then x + elif n >= x.Length then AggregateArr.Empty a + else AggregateArr(a, AggregateNode.skip a n store) + + member x.Take(n : int) = + if n <= 0 then AggregateArr.Empty a + elif n < x.Length then AggregateArr(a, AggregateNode.take a n store) + else x + + + member x.Sub(offset : int, count : int) = + AggregateArr(a, AggregateNode.sub a offset (offset + count - 1) store) + + member x.TryRemove(index : int) = + match AggregateNode.tryRemove a index store with + | Some (node, value) -> + Some(AggregateArr(a, node), value) + | None -> + None + member x.GetSlice(min : option, max : option) = + match min with + | Some min -> + match max with + | Some max -> + x.Sub(min, 1 + max - min) + | None -> + x.Skip min + | None -> + match max with + | Some max -> + x.Take(max + 1) + | None -> + x + + member x.TryGetAggregateAt(i : int) = + AggregateNode.tryAggregateAtIncl a i store + + member x.TryGetAggregateAtExcl(i : int) = + if i = 0 then + if isNull store then None + else Some a.Zero + else + AggregateNode.tryAggregateAtIncl a (i - 1) store + + member x.ToArray() = + AggregateNode.toArray store + + member x.Item + with get(i : int) = + match AggregateNode.tryAt i store with + | Some v -> v + | None -> failwith "index out of range" + + let test() = + + let a = { View = List.length; Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)); Zero = 0 } + + let thing = AggregateArr.Empty(a).Add([1;2;3]).Add([4;5;6]).Add([2]).Add([10]) + + thing.TryGetAggregateAtExcl(0) |> printfn "%A" + thing.TryGetAggregateAtExcl(1) |> printfn "%A" + thing.TryGetAggregateAtExcl(2) |> printfn "%A" + thing.TryGetAggregateAtExcl(3) |> printfn "%A" + thing.TryGetAggregateAtExcl(4) |> printfn "%A" + + + let thing = thing.Skip(1) + + thing.TryGetAggregateAtExcl(0) |> printfn "%A" + thing.TryGetAggregateAtExcl(1) |> printfn "%A" + thing.TryGetAggregateAtExcl(2) |> printfn "%A" + thing.TryGetAggregateAtExcl(3) |> printfn "%A" + + + let a = { View = id; Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)); Zero = 0 } + + let thing = AggregateArr.Empty(a).Add(1).Add(2).Add(3).Add(4).Add(5) + + printfn "%A" (thing.ToArray()) + match thing.TryRemove(1) with + | Some (a, b) -> + printfn "%A" (a.ToArray()) + printfn "%A" b + | None -> + printfn "out of bounds" + + +module Old = + open FSharp.Data.Traceable + type IArrayReader<'a> = IOpReader, arrdelta<'a>> + + type IAdaptiveArray<'a> = + abstract IsConstant : bool + abstract Content : aval> + abstract History : option, arrdelta<'a>>> + abstract GetReader : unit -> IArrayReader<'a> + + and aarr<'a> = IAdaptiveArray<'a> + + + /// Changeable adaptive list that allows mutation by user-code and implements alist. + [] + type ChangeableArray<'T>(elements: arr<'T>) = + let history = + let h = History(Arr.trace) + h.Perform(Arr.trace.tcomputeDelta Arr.empty elements) |> ignore + h + + let perform (op : ArrOperation<'T>) = + history.Perform (ArrDelta.single op) + + override x.ToString() = + history.State |> Seq.map (sprintf "%A") |> String.concat "; " |> sprintf "carr [%s]" + + /// is the list currently empty? + member x.IsEmpty = history.State.IsEmpty + + /// the number of elements currently in the list. + member x.Length = history.State.Length + + member x.Value + with get() = history.State + and set v = history.Perform (Arr.trace.tcomputeDelta history.State v) |> ignore + + member x.Add(value : 'T) = + perform { Index = history.State.Length; Count = 0; Elements = Arr.single value } |> ignore + + member x.Prepend(value : 'T) = + perform { Index = 0; Count = 0; Elements = Arr.single value } |> ignore + + member x.Insert(index : int, value : 'T) = + if index < 0 || index > history.State.Length then raise <| IndexOutOfRangeException() + perform { Index = index; Count = 0; Elements = Arr.single value } |> ignore + + member x.Remove(index : int) = + if index < 0 || index >= history.State.Length then raise <| IndexOutOfRangeException() + perform { Index = index; Count = 1; Elements = Arr.empty } |> ignore + + interface IAdaptiveArray<'T> with + member x.GetReader() = history.NewReader() + member x.Content = history :> aval<_> + member x.IsConstant = false + member x.History = Some history + + + module AArr = + module Readers = + /// Efficient implementation for a constant adaptive array. + [] + type ConstantArray<'T>(content : Lazy>) = + let value = AVal.delay (fun () -> content.Value) + + member x.Content = value + + member x.GetReader() = + History.Readers.ConstantReader<_,_>( + Arr.trace, + lazy (Arr.computeDelta DefaultEqualityComparer.Instance Arr.empty content.Value), + content + ) :> IArrayReader<_> + + interface IAdaptiveArray<'T> with + member x.IsConstant = true + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = None + + /// Core implementation for a dependent array. + [] + type AdaptiveArrayImpl<'T>(createReader : unit -> IOpReader>) = + let history = History(createReader, Arr.trace) + + /// Gets a new reader to the set. + member x.GetReader() : IArrayReader<'T> = + history.NewReader() + + /// Current content of the set as aval. + member x.Content = + history :> aval<_> + + interface IAdaptiveArray<'T> with + member x.IsConstant = false + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = Some history + + /// Efficient implementation for an empty adaptive array. + [] + type EmptyArray<'T> private() = + static let instance = EmptyArray<'T>() :> aarr<_> + let content = AVal.constant Arr.empty + let reader = History.Readers.EmptyReader, arrdelta<'T>>(Arr.trace) :> IArrayReader<'T> + static member Instance = instance + + member x.Content = content + member x.GetReader() = reader + + interface IAdaptiveArray<'T> with + member x.IsConstant = true + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = None + + + type MapReader<'a, 'b>(input : IArrayReader<'a>, mapping : 'a -> 'b) = + inherit AbstractReader>(ArrDelta.empty) + + override x.Compute(t : AdaptiveToken) = + let ops = input.GetChanges t + ops |> ArrDelta.map mapping + + type CollectReader<'a, 'b>(input : IArrayReader<'a>, mapping : 'a -> aarr<'b>) = + inherit AbstractReader>(ArrDelta.empty) + + static let aggregate = + { + ArrNodeImplementationAggregate.Zero = 0 + ArrNodeImplementationAggregate.Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)) + ArrNodeImplementationAggregate.View = fun (v : arr<'b>) -> v.Length + } + + let mutable readers = IndexList.empty> + let mutable prefix = ArrNodeImplementationAggregate.AggregateArr(aggregate, null) + let dirtyLock = obj() + let mutable dirtyReaders = IndexList.empty> + + override x.InputChangedObject(_, o) = + match o with + | :? IArrayReader<'b> as o -> + match o.Tag with + | :? FSharp.Data.Adaptive.Index as i -> + lock dirtyLock (fun () -> + dirtyReaders <- IndexList.set i o dirtyReaders + ) + | _ -> + () + | _ -> + () + + + override x.Compute(t : AdaptiveToken) = + let ops = input.GetChanges t + + let ops = + ops |> ArrDelta.map (fun op -> + mapping(op).GetReader() + ) + + let mutable res = ArrDelta.empty + + let emit (op : ArrOperation<_>) = + res <- ArrDelta.combine res (arrdelta (Arr.single op)) + + let emitArr (op : arr>) = + for e in op do emit e + + + let mutable dirtyReaders = + lock dirtyLock (fun () -> + let v = dirtyReaders + dirtyReaders <- IndexList.empty + v + ) + + + for o in ops do + for r in 1 .. o.Count do + match readers.TryGetIndex o.Index with + | Some idx -> + match readers.TryRemove idx with + | Some (reader, rest) -> + lock reader.Outputs (fun () -> reader.Outputs.Remove x |> ignore) + readers <- rest + dirtyReaders <- IndexList.remove idx dirtyReaders + + match prefix.TryGetAggregateAtExcl o.Index with + | Some offset -> + match prefix.TryRemove(o.Index) with + | Some (rest, removed) -> + prefix <- rest + let cnt = removed.Length + emit { Index = offset; Count = cnt; Elements = Arr.empty } + | None -> + () + | None -> + () + + | None -> + printfn "ERROR: reader must exist" + | None -> + printfn "ERROR: reader at %d must exist" o.Index + + let mutable index = o.Index + for newReader in o.Elements do + let before = + match readers.TryGetIndex (index - 1) with + | Some idx -> idx + | None -> Index.zero + + let idx = readers.NewIndexAfter before + newReader.Tag <- idx + readers <- IndexList.set idx newReader readers + prefix <- prefix.InsertAt(index, Arr.empty) + dirtyReaders <- IndexList.set idx newReader dirtyReaders + index <- index + 1 + + for ridx, reader in IndexList.toSeqIndexed dirtyReaders do + + let ri = readers.IndexOf ridx + + if ri >= 0 && ri < prefix.Length then + match prefix.TryGetAggregateAtExcl ri with + | Some offset -> + let op = reader.GetChanges t + op.ToArr() + |> Arr.map (fun op -> { op with Index = op.Index + offset }) + |> emitArr + + prefix <- prefix.Set(ri, reader.State) + + + + | None -> + printfn "ERROR: no offset" + else + printfn "ERROR: no reader for index" + + res + + + + + + /// Creates a constant set using the creation function. + let constant (value : unit -> arr<'T>) = + Readers.ConstantArray(lazy value()) :> aarr<_> + + /// Creates an aset using the given reader-creator. + let ofReader (create : unit -> #IOpReader>) = + Readers.AdaptiveArrayImpl(fun () -> create() :> IOpReader<_>) :> aarr<_> + + /// The empty aset. + [] + let empty<'T> : aarr<'T> = + Readers.EmptyArray<'T>.Instance + + /// A constant aset holding a single value. + let single (value : 'T) = + constant (fun () -> Arr.single value) + + /// Creates an aset holding the given values. + let ofSeq (elements : seq<'T>) = + constant (fun () -> Arr.ofSeq elements) + + /// Creates an aset holding the given values. + let ofList (elements : list<'T>) = + constant (fun () -> Arr.ofList elements) + + /// Creates an aset holding the given values. + let ofArray (elements : 'T[]) = + constant (fun () -> Arr.ofArray elements) + + /// Creates an aval providing access to the current content of the set. + let toAVal (set : aarr<'T>) = + set.Content + + let map (mapping : 'a -> 'b) (a : aarr<'a>) = + if a.IsConstant then + constant( fun () -> Arr.map mapping (AVal.force a.Content)) + else + ofReader <| fun () -> + Readers.MapReader(a.GetReader(), mapping) + + let collect (mapping : 'a -> aarr<'b>) (a : aarr<'a>) = + if false && a.IsConstant then + failwith "TODO" + else + ofReader <| fun () -> + Readers.CollectReader(a.GetReader(), mapping) + + + + module AArrTest = + let run() = + let a = ChangeableArray(Arr.ofList [1;2;6;8;3;4]) + let even = ChangeableArray(Arr.ofList [2]) + let odd = ChangeableArray(Arr.ofList [1]) + + let result = + a |> AArr.collect (fun v -> + if v % 2 = 0 then even + else odd + ) + + let r = result.GetReader() + + let print() = + let ops = r.GetChanges AdaptiveToken.Top + let state = r.State + + printfn " %A" ops + printfn " %A" state + + printfn "initial" + print() + + transact (fun () -> + a.Value <- Arr.add 5 a.Value + ) + printfn "add(5)" + print() + + transact (fun () -> + even.Value <- Arr.ofList [4;4] + ) + printfn "even <- [|4;4|]" + print() + + transact (fun () -> + even.Remove 0 + ) + printfn "even.Remove 0" + print() + + + + + + + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/AsyncAdaptive.fs b/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/AsyncAdaptive.fs new file mode 100644 index 0000000..cbcf1b8 --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/AsyncAdaptive.fs @@ -0,0 +1,191 @@ +namespace FSharp.Data.Adaptive + +open System.Threading +open System.Threading.Tasks + +type asyncaval<'a> = + inherit IAdaptiveObject + abstract GetTask : AdaptiveToken -> CancelableTask<'a> + +module AsyncAVal = + + type ConstantVal<'a>(value : Task<'a>) = + inherit ConstantObject() + + interface asyncaval<'a> with + member x.GetTask _ = CancelableTask(id, value) + + [] + type AbstractVal<'a>() = + inherit AdaptiveObject() + abstract Compute : AdaptiveToken -> CancelableTask<'a> + + member x.GetTask token = + x.EvaluateAlways token x.Compute + + interface asyncaval<'a> with + member x.GetTask t = x.GetTask t + + let constant (value : 'a) = + ConstantVal(Task.FromResult value) :> asyncaval<_> + + let ofTask (value : Task<'a>) = + ConstantVal(value) :> asyncaval<_> + + let ofCancelableTask (value : CancelableTask<'a>) = + ConstantVal(value.Task) :> asyncaval<_> + + let force (v : asyncaval<'a>) = + v.GetTask AdaptiveToken.Top + + let toAVal (defaultValue : 'a) (value : asyncaval<'a>) = + let mutable valueDirty = 1 + let l = obj() + let mutable latest = defaultValue + let mutable lastTask : Task = null + let mutable version = 0 + + { new AVal.AbstractVal<'a>() with + override x.InputChangedObject(_, _) = + valueDirty <- 1 + + override x.Compute(t) = + if isNull lastTask || lastTask.IsCompleted then + if Interlocked.Exchange(&valueDirty, 0) = 1 then + let vv = Interlocked.Increment(&version) + let t = value.GetTask(t) + lastTask <- + task { + let! v = t.Task + if vv = version then + lock l (fun () -> latest <- v) + transact x.MarkOutdated + } + lock l (fun () -> latest) + } + + let ofAVal (value : aval<'a>) = + if value.IsConstant then + ConstantVal(Task.FromResult(AVal.force value)) :> asyncaval<_> + else + { new AbstractVal<'a>() with + member x.Compute t = + let real = Task.FromResult(value.GetValue t) + CancelableTask(id, real) + } :> asyncaval<_> + + let map (mapping : 'a -> CancellationToken -> Task<'b>) (input : asyncaval<'a>) = + let mutable cache : option> = None + { new AbstractVal<'b>() with + member x.Compute t = + if x.OutOfDate || Option.isNone cache then + let ref = + RefCountingTaskCreator(fun ct -> + let it = input.GetTask t + let s = ct.Register(fun () -> it.Cancel()) + task { + try + let! i = it.Task + return! mapping i ct + finally + s.Dispose() + } + ) + cache <- Some ref + ref.New() + else + cache.Value.New() + } :> asyncaval<_> + + let map2 (mapping : 'a -> 'b -> CancellationToken -> Task<'c>) (ca : asyncaval<'a>) (cb : asyncaval<'b>) = + let mutable cache : option> = None + { new AbstractVal<'c>() with + member x.Compute t = + if x.OutOfDate || Option.isNone cache then + let ref = + RefCountingTaskCreator(fun ct -> + let ta = ca.GetTask t + let tb = cb.GetTask t + let s = ct.Register(fun () -> ta.Cancel(); tb.Cancel()) + task { + try + let! va = ta.Task + let! vb = tb.Task + return! mapping va vb ct + finally + s.Dispose() + } + ) + cache <- Some ref + ref.New() + else + cache.Value.New() + } :> asyncaval<_> + + let bind (mapping : 'a -> CancellationToken -> asyncaval<'b>) (value : asyncaval<'a>) = + let mutable cache : option<_> = None + let mutable innerCache : option<_> = None + let mutable inputChanged = 0 + let inners : ref>> = ref HashSet.empty + + { new AbstractVal<'b>() with + override x.InputChangedObject(_, o) = + if System.Object.ReferenceEquals(o, value) then + inputChanged <- 1 + lock inners (fun () -> + for i in inners.Value do i.Outputs.Remove x |> ignore + inners.Value <- HashSet.empty + ) + + member x.Compute t = + if x.OutOfDate then + if Interlocked.Exchange(&inputChanged, 0) = 1 || Option.isNone cache then + let outerTask = + RefCountingTaskCreator(fun ct -> + let it = value.GetTask t + let s = ct.Register(fun () -> it.Cancel()) + task { + try + let! i = it.Task + let inner = mapping i ct + return inner + finally + s.Dispose() + } + ) + cache <- Some outerTask + + let outerTask = cache.Value + let ref = + RefCountingTaskCreator(fun ct -> + let innerCellTask = outerTask.New() + let s = ct.Register(fun () -> innerCellTask.Cancel()) + task { + try + let! inner = innerCellTask.Task + let innerTask = inner.GetTask t + lock inners (fun () -> inners.Value <- HashSet.add inner inners.Value) + let s2 = + ct.Register(fun () -> + innerTask.Cancel() + lock inners (fun () -> inners.Value <- HashSet.remove inner inners.Value) + inner.Outputs.Remove x |> ignore + ) + try + let! innerValue = innerTask.Task + return innerValue + finally + s2.Dispose() + finally + s.Dispose() + } + ) + + innerCache <- Some ref + + ref.New() + else + innerCache.Value.New() + + } :> asyncaval<_> + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/CancelableTask.fs b/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/CancelableTask.fs new file mode 100644 index 0000000..4233087 --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/AsyncAdaptive/CancelableTask.fs @@ -0,0 +1,70 @@ +namespace FSharp.Data.Adaptive + +open System.Threading +open System.Threading.Tasks + +type CancelableTask<'a>(cancel : unit -> unit, real : Task<'a>) = + let cts = new CancellationTokenSource() + + let output = + if real.IsCompleted then + real + else + let tcs = new TaskCompletionSource<'a>() + let s = + cts.Token.Register(fun () -> + tcs.TrySetCanceled() |> ignore + ) + real.ContinueWith(fun (t : Task<'a>) -> + s.Dispose() + if t.IsFaulted then + tcs.TrySetException(t.Exception) + elif t.IsCanceled then + tcs.TrySetCanceled() + else + tcs.TrySetResult(t.Result) + ) |> ignore + + tcs.Task + + + member x.Cancel() = + cancel() + cts.Cancel() + + member x.Task = + output + +type internal RefCountingTaskCreator<'a>(create : CancellationToken -> Task<'a>) = + + let mutable refCount = 0 + let mutable cache : option> = None + let mutable cancel : CancellationTokenSource = null + + member private x.RemoveRef() = + lock x (fun () -> + if refCount = 1 then + refCount <- 0 + cancel.Cancel() + cancel.Dispose() + cancel <- null + cache <- None + else + refCount <- refCount - 1 + ) + + member x.New() = + lock x (fun () -> + match cache with + | Some cache -> + refCount <- refCount + 1 + CancelableTask(x.RemoveRef, cache) + | None -> + cancel <- new CancellationTokenSource() + let task = create cancel.Token + cache <- Some task + refCount <- refCount + 1 + CancelableTask(x.RemoveRef, task) + ) + + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive.Experimental/Batch/BatchMap.fs b/src/FSharp.Data.Adaptive.Experimental/Batch/BatchMap.fs new file mode 100644 index 0000000..aa29d93 --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/Batch/BatchMap.fs @@ -0,0 +1,90 @@ +namespace FSharp.Data.Adaptive + +open FSharp.Data.Traceable + +[] +module BatchMapExtensions = + module AMap = + let batchMap (mapping : HashMap<'k, 'a> -> HashMap<'k, 'b>) (input : amap<'k, 'a>) = + AMap.ofReader (fun () -> + let r = input.GetReader() + { new AbstractReader>(HashMapDelta.empty) with + member x.Compute(token : AdaptiveToken) = + let old = r.State + let ops = r.GetChanges token + + let removes = + HashMap.MapDelta(old, HashMapDelta.toHashMap ops, fun _k old op -> + match op with + | Remove -> + match old with + | ValueSome _ -> ValueSome Remove + | _ -> ValueNone + | _ -> + ValueNone + ) + + let insertsAndUpdates = + HashMap.MapDelta(old, HashMapDelta.toHashMap ops, fun _k old op -> + match op with + | Set v -> + match old with + | ValueSome o when DefaultEquality.equals o v -> + ValueNone + | _ -> + ValueSome v + | Remove -> + ValueNone + ) + + let newBs = + mapping insertsAndUpdates + |> HashMap.map (fun _ v -> Set v) + + let outOps = HashMap.union removes newBs + HashMapDelta.ofHashMap outOps + } + ) + + module AList = + let batchMap (mapping : IndexList<'a> -> IndexList<'b>) (input : alist<'a>) = + AList.ofReader (fun () -> + let r = input.GetReader() + { new AbstractReader>(IndexListDelta.empty) with + member x.Compute(token : AdaptiveToken) = + let old = r.State + let ops = r.GetChanges token + + let removes = + ops.Content |> MapExt.chooseV (fun idx op -> + match op with + | Remove -> + if old.Content.ContainsKey idx then ValueSome Remove + else ValueNone + | _ -> + ValueNone + + ) + + let insertsAndUpdates = + ops.Content |> MapExt.chooseV (fun idx op -> + match op with + | Set v -> + match MapExt.tryFindV idx old.Content with + | ValueSome o when DefaultEquality.equals o v -> + ValueNone + | _ -> + ValueSome v + + | Remove -> + ValueNone + + ) + + let newBs = + let r = mapping (IndexList.ofMap insertsAndUpdates) + r.Content |> MapExt.map (fun _ v -> Set v) + let outOps = MapExt.union removes newBs + IndexListDelta.ofMap outOps + } + ) diff --git a/src/FSharp.Data.Adaptive.Experimental/FSharp.Data.Adaptive.Experimental.fsproj b/src/FSharp.Data.Adaptive.Experimental/FSharp.Data.Adaptive.Experimental.fsproj new file mode 100644 index 0000000..f7ef96b --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/FSharp.Data.Adaptive.Experimental.fsproj @@ -0,0 +1,20 @@ + + + + netstandard2.1;net6.0 + true + ..\..\bin\$(Configuration)\ + + + + + + + + + + + + + + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive.Experimental/paket.references b/src/FSharp.Data.Adaptive.Experimental/paket.references new file mode 100644 index 0000000..a2c5ba7 --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/paket.references @@ -0,0 +1,3 @@ +FSharp.Core +System.Reflection.Emit.Lightweight +Aardvark.Build \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive.Experimental/paket.template b/src/FSharp.Data.Adaptive.Experimental/paket.template new file mode 100644 index 0000000..06d1a4c --- /dev/null +++ b/src/FSharp.Data.Adaptive.Experimental/paket.template @@ -0,0 +1,14 @@ +type project +authors fsprojects +owners fsprojects +projectUrl https://github.com/fsprojects/FSharp.Data.Adaptive +licenseUrl https://raw.githubusercontent.com/fsprojects/FSharp.Data.Adaptive/master/LICENSE +description + FSharp.Data.Adaptive provides an incremental evaluation system inspired by Adapton, DeltaML and many others + for FSharp. The implementation provides incremental datastructures for refs/sets/lists/maps. +include-pdbs true +files + ./**/*.fs => fable + ./**/*.fsi => fable + ./**/*.fsproj => fable + !./obj/**/* \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fs b/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fs new file mode 100644 index 0000000..b4b393d --- /dev/null +++ b/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fs @@ -0,0 +1,974 @@ +namespace FSharp.Data.Adaptive + +open System +open FSharp.Data.Traceable +open FSharp.Data.Adaptive + + +module private ArrNodeImplementationAggregate = + + type Aggregator<'a, 's> = + { + View : 'a -> 's + Add : OptimizedClosures.FSharpFunc<'s, 's, 's> + Zero : 's + } + + + [] + type AggregateNode<'a, 's> = + val mutable public Height : byte + val mutable public Value : 'a + + new(h, v) = { Height = h; Value = v } + + type AggregateInner<'a, 's> = + inherit AggregateNode<'a, 's> + val mutable public Left : AggregateNode<'a, 's> + val mutable public Right : AggregateNode<'a, 's> + val mutable public Count : int + val mutable public Aggregate : 's + + static member inline GetCount(node : AggregateNode<'a, 's>) = + if isNull node then 0 + elif node.Height = 1uy then 1 + else (node :?> AggregateInner<'a, 's>).Count + + static member inline GetHeight(node : AggregateNode<'a, 's>) = + if isNull node then 0uy + else node.Height + + static member inline GetAggregate(a : Aggregator<'a, 's>, n : AggregateNode<'a, 's>) = + if isNull n then a.Zero + elif n.Height = 1uy then a.View n.Value + else + let n = n :?> AggregateInner<'a, 's> + n.Aggregate + + static member inline FixHeightAndCount(inner : AggregateInner<'a, 's>) = + let lc = AggregateInner.GetCount inner.Left + let rc = AggregateInner.GetCount inner.Right + let lh = if lc > 0 then inner.Left.Height else 0uy + let rh = if rc > 0 then inner.Right.Height else 0uy + inner.Count <- 1 + lc + rc + inner.Height <- 1uy + max lh rh + + static member New(a : Aggregator<'a, 's>, l : AggregateNode<'a, 's>, value : 'a, r : AggregateNode<'a, 's>) : AggregateNode<'a, 's> = + if isNull l && isNull r then AggregateNode(1uy, value) + else + let h = 1uy + max (AggregateInner.GetHeight l) (AggregateInner.GetHeight r) + let c = 1 + AggregateInner.GetCount l + AggregateInner.GetCount r + AggregateInner<'a, 's>(a, h, value, l, r, c) :> AggregateNode<_,_> + + new(a : Aggregator<'a, 's>, h : byte, v : 'a, l : AggregateNode<'a, 's>, r : AggregateNode<'a, 's>, c : int) = + let va = a.Add.Invoke(a.Add.Invoke(AggregateInner.GetAggregate(a, l), a.View v), AggregateInner.GetAggregate(a, r)) + { inherit AggregateNode<'a, 's>(h, v); Left = l; Right = r; Count = c; Aggregate = va } + + module AggregateNode = + let empty<'a, 's> : AggregateNode<'a, 's> = null + + let inline height (n : AggregateNode<'a, 's>) = + if isNull n then 0uy + else n.Height + + let inline aggregate (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if isNull n then a.Zero + elif n.Height = 1uy then a.View n.Value + else + let n = n :?> AggregateInner<'a, 's> + n.Aggregate + + let inline isEmpty (n : AggregateNode<'a, 's>) = + isNull n + + let inline count (n : AggregateNode<'a, 's>) = + if isNull n then 0 + elif n.Height = 1uy then 1 + else (n :?> AggregateInner<'a, 's>).Count + + + let inline balance (n : AggregateInner<'a, 's>) = + int (height n.Right) - int (height n.Left) + + let rec binary (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (v : 'a) (r : AggregateNode<'a, 's>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> AggregateInner<'a, 's> + let rb = balance r + if rb > 0 then + // right right + binary + a + (binary a l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> AggregateInner<'a, 's> + binary a + (binary a l v rl.Left) + rl.Value + (binary a rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> AggregateInner<'a, 's> + let lb = balance l + if lb < 0 then + // left left + binary a + l.Left + l.Value + (binary a l.Right v r) + else + // left right + let lr = l.Right :?> AggregateInner<'a, 's> + binary a + (binary a l.Left l.Value lr.Left) + lr.Value + (binary a lr.Right v r) + + elif lh = 0uy && rh = 0uy then AggregateNode(1uy, v) + else AggregateInner(a, 1uy + max lh rh, v, l, r, 1 + lc + rc) :> AggregateNode<_, _> + + let inline unsafeInner a l v r = AggregateInner.New(a, l, v, r) + + let unsafeBinary (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (v : 'a) (r : AggregateNode<'a, 's>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> AggregateInner<'a, 's> + let rb = balance r + if rb > 0 then + // right right + unsafeInner a + (unsafeInner a l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> AggregateInner<'a, 's> + unsafeInner a + (unsafeInner a l v rl.Left) + rl.Value + (unsafeInner a rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> AggregateInner<'a, 's> + let lb = balance l + if lb < 0 then + // left left + unsafeInner a + l.Left + l.Value + (unsafeInner a l.Right v r) + else + // left right + let lr = l.Right :?> AggregateInner<'a, 's> + unsafeInner a + (unsafeInner a l.Left l.Value lr.Left) + lr.Value + (unsafeInner a lr.Right v r) + + elif lh = 0uy && rh = 0uy then AggregateNode(1uy, v) + else AggregateInner(a, 1uy + max lh rh, v, l, r, 1 + lc + rc) :> AggregateNode<_,_> + + + + let rec unsafeRemoveMin (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if n.Height = 1uy then + struct(n.Value, null) + else + let n = n :?> AggregateInner<'a, 's> + if isNull n.Left then + struct(n.Value, n.Right) + else + let struct(value, newLeft) = unsafeRemoveMin a n.Left + let node = unsafeBinary a newLeft n.Value n.Right + struct(value, node) + + let rec unsafeRemoveMax (a : Aggregator<'a, 's>) (n : AggregateNode<'a, 's>) = + if n.Height = 1uy then + struct(n.Value, null) + else + let n = n :?> AggregateInner<'a, 's> + if isNull n.Right then + struct(n.Value, n.Left) + else + let struct(value, newRight) = unsafeRemoveMax a n.Right + let node = unsafeBinary a n.Left n.Value newRight + struct(value, node) + + + let rec join (a : Aggregator<'a, 's>) (l : AggregateNode<'a, 's>) (r : AggregateNode<'a, 's>) = + if isNull l then r + elif isNull r then l + else + let lh = l.Height + let rh = r.Height + if lh > rh then + let struct(v, ln) = unsafeRemoveMax a l + binary a ln v r + else + let struct(v, rn) = unsafeRemoveMin a r + binary a l v rn + + let rec insertAt (a : Aggregator<'a, 's>) (index : int) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + if index = 0 then binary a null value n + else binary a n value null + else + let n = n :?> AggregateInner<'a, 's> + let c = count n.Left + if index <= c then + binary a (insertAt a index value n.Left) n.Value n.Right + else + binary a n.Left n.Value (insertAt a (index - c - 1) value n.Right) + + let rec set (a : Aggregator<'a, 's>) (index : int) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + null + elif n.Height = 1uy then + if index = 0 then AggregateNode(1uy, value) + else n + else + let n = n :?> AggregateInner<'a, 's> + let c = count n.Left + if index < c then + let newLeft = set a index value n.Left + binary a newLeft n.Value n.Right + elif index > c then + let newRight = set a (index - c - 1) value n.Right + binary a n.Left n.Value newRight + else + binary a n.Left value n.Right + + let rec append (a : Aggregator<'a, 's>) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + binary a n value null + else + let n = n :?> AggregateInner<'a, 's> + binary a n.Left n.Value (append a value n.Right) + + let rec prepend (a : Aggregator<'a, 's>) (value : 'a) (n : AggregateNode<'a, 's>) = + if isNull n then + AggregateNode(1uy, value) + elif n.Height = 1uy then + binary a null value n + else + let n = n :?> AggregateInner<'a, 's> + binary a (prepend a value n.Left) n.Value n.Right + + + let rec skip (a : Aggregator<'a, 's>) (n : int) (node : AggregateNode<'a, 's>) = + if n <= 0 then node + elif isNull node || node.Height = 1uy then + null + else + let node = node :?> AggregateInner<'a, 's> + if n >= node.Count then + null + else + let lc = count node.Left + if n < lc then binary a (skip a n node.Left) node.Value node.Right + elif n = lc then prepend a node.Value node.Right + else skip a (n - lc - 1) node.Right + + let rec take (a : Aggregator<'a, 's>) (n : int) (node : AggregateNode<'a, 's>) = + if n <= 0 then null + elif isNull node || node.Height = 1uy then + node + else + let node = node :?> AggregateInner<'a, 's> + if n >= node.Count then + node + else + let lc = count node.Left + if n <= lc then take a n node.Left + elif n = lc then append a node.Value node.Left + else binary a node.Left node.Value (take a (n - lc - 1) node.Right) + + let rec sub (a : Aggregator<'a, 's>) (l : int) (r : int) (node : AggregateNode<'a, 's>) = + + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then node + else null + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + sub a l r node.Left + elif l > lc then + sub a (l - lc - 1) (r - lc - 1) node.Right + elif l = lc then + prepend a node.Value (take a (r - l) node.Right) + elif r = lc then + append a node.Value (skip a l node.Left) + else + binary a (skip a l node.Left) node.Value (take a (r - lc) node.Right) + + + let join3 (agg : Aggregator<'a, 's>) (a : AggregateNode<'a, 's>) (b : AggregateNode<'a, 's>) (c : AggregateNode<'a, 's>) = + join agg a (join agg b c) // TODO!!! + + let rec removeRange (a : Aggregator<'a, 's>) (l : int) (r : int) (node : AggregateNode<'a, 's>) = + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then null + else node + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + binary a (removeRange a l r node.Left) node.Value node.Right + elif l > lc then + binary a node.Left node.Value (removeRange a (l - lc - 1) (r - lc - 1) node.Right) + elif l = lc then + join a node.Left (skip a (r - l) node.Right) + elif r = lc then + join a (take a l node.Left) node.Right + else + let na = take a l node.Left + let nb = skip a (r - lc) node.Right + join a na nb + + let rec tryRemove (a : Aggregator<'a, 's>) (index : int) (node : AggregateNode<'a, 's>) = + if isNull node then + None + elif node.Height = 1uy then + if index = 0 then Some (null, node.Value) + else None + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + + if index < lc then + match tryRemove a index node.Left with + | Some (rest, v) -> + Some (binary a rest node.Value node.Right, v) + | None -> + None + elif index > lc then + match tryRemove a (index - lc - 1) node.Right with + | Some (rest, v) -> + Some (binary a node.Left node.Value rest, v) + | None -> + None + else + Some (join a node.Left node.Right, node.Value) + + + let rec insertRange (a : Aggregator<'a, 's>) (index : int) (repl : AggregateNode<'a, 's>) (node : AggregateNode<'a, 's>) = + if isNull node then + repl + elif node.Height = 1uy then + if index <= 0 then append a node.Value repl + else prepend a node.Value repl + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if index < lc then + binary a (insertRange a index repl node.Left) node.Value node.Right + elif index = lc then + let lh = height node.Left + let rh = height node.Right + if lh < rh then + let l = append a node.Value node.Left + join a (join a l repl) node.Right + else + let r = prepend a node.Value node.Right + join a node.Left (join a repl r) + else + binary a node.Left node.Value (insertRange a (index - lc - 1) repl node.Right) + + let rec replaceRange (a : Aggregator<'a, 's>) (l : int) (r : int) (repl : AggregateNode<'a, 's>) (node : AggregateNode<'a, 's>) = + if isNull node then + repl + elif node.Height = 1uy then + if l <= 0 && r >= 0 then repl + elif r < 0 then append a node.Value repl + else prepend a node.Value repl + else + let node = node :?> AggregateInner<'a, 's> + let lc = count node.Left + if r < lc then + binary a (replaceRange a l r repl node.Left) node.Value node.Right + elif l > lc then + binary a node.Left node.Value (replaceRange a (l - lc - 1) (r - lc - 1) repl node.Right) + elif l = lc then + join3 a node.Left repl (skip a (r - l) node.Right) + elif r = lc then + join3 a (take a l node.Left) repl node.Right + else + let na = take a l node.Left + let nb = skip a (r - lc) node.Right + join3 a na repl nb + + let rec tryAt (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then None + elif n.Height = 1uy then + if i = 0 then Some n.Value + else None + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAt i n.Left + elif i > lc then + tryAt (i - lc - 1) n.Right + else + Some n.Value + + let rec tryAtV (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then ValueNone + elif n.Height = 1uy then + if i = 0 then ValueSome n.Value + else ValueNone + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAtV i n.Left + elif i > lc then + tryAtV (i - lc - 1) n.Right + else + ValueSome n.Value + + + let rec tryAggregateAtIncl (a : Aggregator<'a, 's>) (i : int) (n : AggregateNode<'a, 's>) = + if isNull n then + None + elif n.Height = 1uy then + if i = 0 then Some (a.View n.Value) + else None + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + if i < lc then + tryAggregateAtIncl a i n.Left + elif i > lc then + match tryAggregateAtIncl a (i - lc - 1) n.Right with + | None -> None + | Some rv -> + let lv = a.Add.Invoke(aggregate a n.Left, a.View n.Value) + Some (a.Add.Invoke(lv, rv)) + else + a.Add.Invoke(aggregate a n.Left, a.View n.Value) |> Some + + + + let rec exists (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then false + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> AggregateInner<'a, 's> + exists predicate n.Left || predicate n.Value || exists predicate n.Right + + let rec forall (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then true + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> AggregateInner<'a, 's> + forall predicate n.Left && predicate n.Value && forall predicate n.Right + + let rec tryFindIndex (predicate : 'a -> bool) (n : AggregateNode<'a, 's>) = + if isNull n then None + elif n.Height = 1uy then + if predicate n.Value then + Some 0 + else + None + else + let n = n :?> AggregateInner<'a, 's> + + match tryFindIndex predicate n.Left with + | Some i -> Some i + | None -> + let lc = count n.Left + if predicate n.Value then + Some lc + else + match tryFindIndex predicate n.Right with + | Some i -> + Some (i + lc + 1) + | None -> + None + + let rec copyTo (index : int) (dst : 'a[]) (n : AggregateNode<'a, 's>) = + if not (isNull n) then + if n.Height = 1uy then dst.[index] <- n.Value + else + let n = n :?> AggregateInner<'a, 's> + let lc = count n.Left + copyTo index dst n.Left + dst.[index + lc] <- n.Value + copyTo (index + lc + 1) dst n.Right + + let rec toList (acc : list<'a>) (node : AggregateNode<'a, 's>) = + if isNull node then + acc + elif node.Height = 1uy then + node.Value :: acc + else + let n = node :?> AggregateInner<'a, 's> + toList (n.Value :: toList acc n.Right) n.Left + + let toArray (n : AggregateNode<'a, 's>) = + let c = count n + let a = Array.zeroCreate c + copyTo 0 a n + a + + [] + type AggregateArr<'a, 's> internal(a : Aggregator<'a, 's>, store : AggregateNode<'a, 's>) = + static member Empty(a : Aggregator<'a, 's>) : AggregateArr<'a, 's> = AggregateArr<'a, 's>(a, null) + + member internal x.Store = store + member x.IsEmpty = AggregateNode.isEmpty store + member x.Length = AggregateNode.count store + + member x.InsertAt(index : int, value : 'a) = AggregateArr(a, AggregateNode.insertAt a index value store) + member x.Prepend(value : 'a) = AggregateArr(a, AggregateNode.prepend a value store) + member x.Append(value : 'a) = AggregateArr(a, AggregateNode.append a value store) + member x.Add(value : 'a) = x.Append(value) + member x.Set(i : int, value : 'a) = + if i < 0 || i >= x.Length then raise <| IndexOutOfRangeException() + else AggregateArr(a, AggregateNode.set a i value store) + member x.RemoveAt(index : int) = AggregateArr(a, AggregateNode.removeRange a index index store) + + member x.Skip(n : int) = + if n <= 0 then x + elif n >= x.Length then AggregateArr.Empty a + else AggregateArr(a, AggregateNode.skip a n store) + + member x.Take(n : int) = + if n <= 0 then AggregateArr.Empty a + elif n < x.Length then AggregateArr(a, AggregateNode.take a n store) + else x + + + member x.Sub(offset : int, count : int) = + AggregateArr(a, AggregateNode.sub a offset (offset + count - 1) store) + + member x.TryRemove(index : int) = + match AggregateNode.tryRemove a index store with + | Some (node, value) -> + Some(AggregateArr(a, node), value) + | None -> + None + member x.GetSlice(min : option, max : option) = + match min with + | Some min -> + match max with + | Some max -> + x.Sub(min, 1 + max - min) + | None -> + x.Skip min + | None -> + match max with + | Some max -> + x.Take(max + 1) + | None -> + x + + member x.TryGetAggregateAt(i : int) = + AggregateNode.tryAggregateAtIncl a i store + + member x.TryGetAggregateAtExcl(i : int) = + if i = 0 then + if isNull store then None + else Some a.Zero + else + AggregateNode.tryAggregateAtIncl a (i - 1) store + + member x.ToArray() = + AggregateNode.toArray store + + member x.Item + with get(i : int) = + match AggregateNode.tryAt i store with + | Some v -> v + | None -> failwith "index out of range" + + let test() = + + let a = { View = List.length; Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)); Zero = 0 } + + let thing = AggregateArr.Empty(a).Add([1;2;3]).Add([4;5;6]).Add([2]).Add([10]) + + thing.TryGetAggregateAtExcl(0) |> printfn "%A" + thing.TryGetAggregateAtExcl(1) |> printfn "%A" + thing.TryGetAggregateAtExcl(2) |> printfn "%A" + thing.TryGetAggregateAtExcl(3) |> printfn "%A" + thing.TryGetAggregateAtExcl(4) |> printfn "%A" + + + let thing = thing.Skip(1) + + thing.TryGetAggregateAtExcl(0) |> printfn "%A" + thing.TryGetAggregateAtExcl(1) |> printfn "%A" + thing.TryGetAggregateAtExcl(2) |> printfn "%A" + thing.TryGetAggregateAtExcl(3) |> printfn "%A" + + + let a = { View = id; Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)); Zero = 0 } + + let thing = AggregateArr.Empty(a).Add(1).Add(2).Add(3).Add(4).Add(5) + + printfn "%A" (thing.ToArray()) + match thing.TryRemove(1) with + | Some (a, b) -> + printfn "%A" (a.ToArray()) + printfn "%A" b + | None -> + printfn "out of bounds" + + + + +/// An adaptive reader for aarr that allows to pull operations and exposes its current state. +type IArrayReader<'T> = + IOpReader, arrdelta<'T>> + +/// Adaptive array datastructure. +[] +type IAdaptiveArray<'T> = + /// Is the array constant? + abstract member IsConstant : bool + + /// The current content of the array as aval. + abstract member Content : aval> + + /// Gets a new reader to the array. + abstract member GetReader : unit -> IArrayReader<'T> + + /// Gets the underlying History instance for the alist (if any) + abstract member History : option, arrdelta<'T>>> + +/// Adaptive list datastructure. +type aarr<'T> = IAdaptiveArray<'T> + + +/// Functional operators for the alist<_> type. +[] +module AArr = + /// Efficient implementation for a constant adaptive array. + [] + type ConstantArray<'T>(content : Lazy>) = + let value = AVal.delay (fun () -> content.Value) + + member x.Content = value + + member x.GetReader() = + History.Readers.ConstantReader<_,_>( + Arr.trace, + lazy (Arr.computeDelta DefaultEqualityComparer.Instance Arr.empty content.Value), + content + ) :> IArrayReader<_> + + interface IAdaptiveArray<'T> with + member x.IsConstant = true + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = None + + /// Core implementation for a dependent array. + [] + type AdaptiveArray<'T>(createReader : unit -> IOpReader>) = + let history = History(createReader, Arr.trace) + + /// Gets a new reader to the set. + member x.GetReader() : IArrayReader<'T> = + history.NewReader() + + /// Current content of the set as aval. + member x.Content = + history :> aval<_> + + interface IAdaptiveArray<'T> with + member x.IsConstant = false + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = Some history + + /// Efficient implementation for an empty adaptive array. + [] + type EmptyArray<'T> private() = + static let instance = EmptyArray<'T>() :> aarr<_> + let content = AVal.constant Arr.empty + let reader = History.Readers.EmptyReader, arrdelta<'T>>(Arr.trace) :> IArrayReader<'T> + static member Instance = instance + + member x.Content = content + member x.GetReader() = reader + + interface IAdaptiveArray<'T> with + member x.IsConstant = true + member x.GetReader() = x.GetReader() + member x.Content = x.Content + member x.History = None + + module Readers = + type MapReader<'T1, 'T2>(reader : IArrayReader<'T1>, mapping : 'T1 -> 'T2) = + inherit AbstractReader>(ArrDelta.empty) + + override x.Compute(token : AdaptiveToken) = + let delta = reader.GetChanges(token) + ArrDelta.map mapping delta + + type CollectReader<'a, 'b>(input : IArrayReader<'a>, mapping : 'a -> aarr<'b>) = + inherit AbstractReader>(ArrDelta.empty) + + static let aggregate = + { + ArrNodeImplementationAggregate.Zero = 0 + ArrNodeImplementationAggregate.Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)) + ArrNodeImplementationAggregate.View = fun (v : arr<'b>) -> v.Length + } + + let mutable readers = IndexList.empty> + let mutable prefix = ArrNodeImplementationAggregate.AggregateArr(aggregate, null) + let dirtyLock = obj() + let mutable dirtyReaders = IndexList.empty> + + override x.InputChangedObject(_, o) = + match o with + | :? IArrayReader<'b> as o -> + match o.Tag with + | :? FSharp.Data.Adaptive.Index as i -> + lock dirtyLock (fun () -> + dirtyReaders <- IndexList.set i o dirtyReaders + ) + | _ -> + () + | _ -> + () + + + override x.Compute(t : AdaptiveToken) = + let ops = input.GetChanges t + + let ops = + ops |> ArrDelta.map (fun op -> + mapping(op).GetReader() + ) + + let mutable res = ArrDelta.empty + + let emit (op : ArrOperation<_>) = + res <- ArrDelta.combine res (arrdelta (Arr.single op)) + + let emitArr (op : arr>) = + for e in op do emit e + + + let mutable dirtyReaders = + lock dirtyLock (fun () -> + let v = dirtyReaders + dirtyReaders <- IndexList.empty + v + ) + + + for o in ops do + for r in 1 .. o.Count do + match readers.TryGetIndex o.Index with + | Some idx -> + match readers.TryRemove idx with + | Some (reader, rest) -> + lock reader.Outputs (fun () -> reader.Outputs.Remove x |> ignore) + readers <- rest + dirtyReaders <- IndexList.remove idx dirtyReaders + + match prefix.TryGetAggregateAtExcl o.Index with + | Some offset -> + match prefix.TryRemove(o.Index) with + | Some (rest, removed) -> + prefix <- rest + let cnt = removed.Length + emit { Index = offset; Count = cnt; Elements = Arr.empty } + | None -> + () + | None -> + () + + | None -> + printfn "ERROR: reader must exist" + | None -> + printfn "ERROR: reader at %d must exist" o.Index + + let mutable index = o.Index + for newReader in o.Elements do + let before = + match readers.TryGetIndex (index - 1) with + | Some idx -> idx + | None -> Index.zero + + let idx = readers.NewIndexAfter before + newReader.Tag <- idx + readers <- IndexList.set idx newReader readers + prefix <- prefix.InsertAt(index, Arr.empty) + dirtyReaders <- IndexList.set idx newReader dirtyReaders + index <- index + 1 + + for ridx, reader in IndexList.toSeqIndexed dirtyReaders do + + let ri = readers.IndexOf ridx + + if ri >= 0 && ri < prefix.Length then + match prefix.TryGetAggregateAtExcl ri with + | Some offset -> + let op = reader.GetChanges t + op.ToArr() + |> Arr.map (fun op -> { op with Index = op.Index + offset }) + |> emitArr + + prefix <- prefix.Set(ri, reader.State) + + + + | None -> + printfn "ERROR: no offset" + else + printfn "ERROR: no reader for index" + + res + + type ChooseReader<'a, 'b>(input : IArrayReader<'a>, mapping : 'a -> option<'b>) = + inherit AbstractReader>(ArrDelta.empty) + + static let aggregate = + { + ArrNodeImplementationAggregate.Zero = 0 + ArrNodeImplementationAggregate.Add = OptimizedClosures.FSharpFunc<_,_,_>.Adapt((+)) + ArrNodeImplementationAggregate.View = function Some _ -> 1 | None -> 0 + } + + let mutable prefix = ArrNodeImplementationAggregate.AggregateArr(aggregate, null) + + + override x.Compute(t : AdaptiveToken) = + let ops = input.GetChanges t + let ops = ops |> ArrDelta.map mapping + + let mutable res = ArrDelta.empty + + let emit (op : ArrOperation<_>) = + res <- ArrDelta.combine res (arrdelta (Arr.single op)) + + + for o in ops do + let offset = + match prefix.TryGetAggregateAtExcl o.Index with + | Some offset -> offset + | None -> 0 + let mutable srcIndex = o.Index + let mutable dstIndex = offset + let offset = () + + for r in 1 .. o.Count do + match prefix.TryRemove(o.Index) with + | Some (rest, removed) -> + prefix <- rest + match removed with + | Some _ -> + emit { Index = dstIndex; Count = 1; Elements = Arr.empty } + | None -> + () + | None -> + () + + for e in o.Elements do + prefix <- prefix.InsertAt(srcIndex, e) + match e with + | Some e -> + emit { Index = dstIndex; Count = 0; Elements = Arr.single e } + dstIndex <- dstIndex + 1 + | None -> + () + srcIndex <- srcIndex + 1 + + res + + let force (array : aarr<'a>) = + array.Content |> AVal.force + + /// The empty aarr. + [] + let empty<'T> : aarr<'T> = + EmptyArray<'T>.Instance + + /// A constant aarr holding a single value. + let single (value : 'T) : aarr<'T> = + ConstantArray(Lazy<_>.CreateFromValue(Arr.single value)) :> aarr<_> + + /// Creates an aarr holding the given values. + let ofSeq (elements: seq<'T>) : aarr<'T> = + ConstantArray(Lazy<_>.CreateFromValue(Arr.ofSeq elements)) :> aarr<_> + + + /// Creates an aarr holding the given values. + let ofList (elements: list<'T>) : aarr<'T> = + ConstantArray(Lazy<_>.CreateFromValue(Arr.ofList elements)) :> aarr<_> + + /// Creates an aarr holding the given values. + let ofArray (elements: 'T[]) : aarr<'T> = + ConstantArray(Lazy<_>.CreateFromValue(Arr.ofArray elements)) :> aarr<_> + + /// Creates an aarr holding the given values. + let ofArr (elements: arr<'T>) : aarr<'T> = + ConstantArray(Lazy<_>.CreateFromValue(elements)) :> aarr<_> + + /// Creates an aarr using the given reader-creator. + let ofReader (create : (unit -> #IOpReader>)) : aarr<'T> = + AdaptiveArray<'T>(fun () -> create() :> IOpReader>) :> aarr<'T> + + /// Adaptively applies the given mapping function to all elements and returns a new aarr containing the results. + let map (mapping : 'T1 -> 'T2) (input : aarr<'T1>) : aarr<'T2> = + if input.IsConstant then + ConstantArray(Lazy>(fun () -> force input |> Arr.map mapping)) :> aarr<_> + else + ofReader <| fun () -> Readers.MapReader(input.GetReader(), mapping) + + /// Adaptively applies the given mapping function to all elements and returns a new aarr containing the results. + let choose (mapping : 'T1 -> option<'T2>) (input : aarr<'T1>) : aarr<'T2> = + if input.IsConstant then + ConstantArray(Lazy>(fun () -> force input |> Arr.choose mapping)) :> aarr<_> + else + ofReader <| fun () -> + Readers.ChooseReader(input.GetReader(), mapping) + + let collect (mapping : 'T1 -> aarr<'T2>) (input : aarr<'T1>) : aarr<'T2> = + if input.IsConstant then + let arrs = input |> force |> Arr.map mapping + if arrs |> Arr.forall (fun a -> a.IsConstant) then + ConstantArray(Lazy>(fun () -> arrs |> Arr.collect force)) :> aarr<_> + else + // TODO: better implementation? + ofReader <| fun () -> + let set = ofArr arrs + Readers.CollectReader(set.GetReader(), id) + + else + ofReader <| fun () -> + Readers.CollectReader(input.GetReader(), mapping) + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fsi b/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fsi new file mode 100644 index 0000000..caf88ca --- /dev/null +++ b/src/FSharp.Data.Adaptive/AdaptiveArray/AdaptiveArray.fsi @@ -0,0 +1,62 @@ +namespace FSharp.Data.Adaptive + +open System +open FSharp.Data.Traceable +open FSharp.Data.Adaptive + +/// An adaptive reader for aarr that allows to pull operations and exposes its current state. +type IArrayReader<'T> = + IOpReader, arrdelta<'T>> + +/// Adaptive array datastructure. +[] +type IAdaptiveArray<'T> = + /// Is the array constant? + abstract member IsConstant : bool + + /// The current content of the array as aval. + abstract member Content : aval> + + /// Gets a new reader to the array. + abstract member GetReader : unit -> IArrayReader<'T> + + /// Gets the underlying History instance for the alist (if any) + abstract member History : option, arrdelta<'T>>> + +/// Adaptive list datastructure. +type aarr<'T> = IAdaptiveArray<'T> + + +/// Functional operators for the alist<_> type. +[] +module AArr = + + /// The empty aarr. + [] + val empty<'T> : aarr<'T> + + /// A constant aarr holding a single value. + val single : value: 'T -> aarr<'T> + + /// Creates an aarr holding the given values. + val ofSeq : elements: seq<'T> -> aarr<'T> + + /// Creates an aarr holding the given values. + val ofList : elements: list<'T> -> aarr<'T> + + /// Creates an aarr holding the given values. + val ofArray : elements: 'T[] -> aarr<'T> + + /// Creates an aarr holding the given values. + val ofArr : elements: arr<'T> -> aarr<'T> + + /// Creates an aarr using the given reader-creator. + val ofReader : create: (unit -> #IOpReader>) -> aarr<'T> + + /// Adaptively applies the given mapping function to all elements and returns a new aarr containing the results. + val map : mapping: ('T1 -> 'T2) -> input: aarr<'T1> -> aarr<'T2> + + val choose : mapping: ('T1 -> option<'T2>) -> input: aarr<'T1> -> aarr<'T2> + + + val collect : mapping: ('T1 -> aarr<'T2>) -> input: aarr<'T1> -> aarr<'T2> \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fs b/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fs new file mode 100644 index 0000000..f9c2313 --- /dev/null +++ b/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fs @@ -0,0 +1,96 @@ +namespace FSharp.Data.Adaptive + +open System.Collections.Generic +open FSharp.Data.Traceable + +/// Changeable adaptive array that allows mutation by user-code and implements aarr. +[] +type ChangeableArray<'T>(state : arr<'T>) = + let history = History, arrdelta<'T>>(Arr.trace) + + do history.Perform (ArrDelta.single { Index = 0; Count = 0; Elements = state }) |> ignore + + /// is the array currently empty? + member x.IsEmpty = history.State.IsEmpty + + /// the number of elements currently in the array. + member x.Length = history.State.Length + + /// Gets or sets the value for the array. + member x.Value + with get() = + history.State + and set (v : arr<'T>) = + let delta = Arr.computeDelta DefaultEqualityComparer.Instance history.State v + history.Perform delta |> ignore + + member x.Clear() = + let delta = ArrDelta.single { Index = 0; Count = history.State.Length; Elements = Arr.empty } + history.Perform delta |> ignore + + member x.Add (item : 'T) = + let delta = ArrDelta.single { Index = history.State.Length; Count = 0; Elements = Arr.single item } + history.Perform delta |> ignore + + member x.Insert (index : int, value : 'T) = + if index < 0 || index > history.State.Length then raise <| System.IndexOutOfRangeException() + let delta = ArrDelta.single { Index = index; Count = 0; Elements = Arr.single value } + history.Perform delta |> ignore + + member x.RemoveAt(index : int) = + if index < 0 || index >= history.State.Length then raise <| System.IndexOutOfRangeException() + let delta = ArrDelta.single { Index = index; Count = 1; Elements = Arr.empty } + history.Perform delta |> ignore + + member x.CopyTo(array, arrayIndex) = history.State.CopyTo(array, arrayIndex) + + member x.Item + with get (index : int) = + history.State.[index] + and set (index : int) (value : 'T) = + let delta = ArrDelta.single { Index = index; Count = 1; Elements = Arr.single value } + history.Perform delta |> ignore + + new(elements : seq<'T>) = ChangeableArray<'T>(Arr.ofSeq elements) + new() = ChangeableArray<'T>(Arr.empty) + + member x.GetEnumerator() = history.State.GetEnumerator() + + interface System.Collections.IEnumerable with + member x.GetEnumerator() = history.State.GetEnumerator() + + interface System.Collections.Generic.IEnumerable<'T> with + member x.GetEnumerator() = history.State.GetEnumerator() + + interface System.Collections.Generic.ICollection<'T> with + member x.Add(item) = x.Add item + member x.Clear() = x.Clear() + member x.Contains(item) = history.State |> Arr.exists (fun v -> DefaultEquality.equals v item) + member x.CopyTo(array, arrayIndex) = x.CopyTo(array, arrayIndex) + member x.Remove(item) = + match Arr.tryFindIndex (fun v -> DefaultEquality.equals v item) history.State with + | Some index -> x.RemoveAt index; true + | None -> false + member x.Count = x.Length + member x.IsReadOnly = false + + interface System.Collections.Generic.IList<'T> with + member x.IndexOf(item) = + match Arr.tryFindIndex (fun v -> DefaultEquality.equals v item) history.State with + | Some index -> index + | None -> -1 + member x.Insert(index,item) = x.Insert(index, item) + member x.RemoveAt(index) = x.RemoveAt(index) + member x.Item + with get(i : int) = x.[i] + and set (i : int) (value : 'T) = x.[i] <- value + + interface IAdaptiveArray<'T> with + member x.IsConstant = false + member x.GetReader() = history.NewReader() + member x.Content = history :> aval<_> + member x.History = Some history + + +/// Changeable adaptive array that allows mutation by user-code and implements aarr. +type carr<'T> = ChangeableArray<'T> \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fsi b/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fsi new file mode 100644 index 0000000..f5560ad --- /dev/null +++ b/src/FSharp.Data.Adaptive/AdaptiveArray/ChangeableArray.fsi @@ -0,0 +1,34 @@ +namespace FSharp.Data.Adaptive + +open System.Collections.Generic +open FSharp.Data.Traceable + +/// Changeable adaptive array that allows mutation by user-code and implements aarr. +[] +type ChangeableArray<'T> = + interface IAdaptiveArray<'T> + interface System.Collections.Generic.IEnumerable<'T> + interface System.Collections.Generic.ICollection<'T> + interface System.Collections.Generic.IList<'T> + + /// is the array currently empty? + member IsEmpty : bool + + /// the number of elements currently in the array. + member Length : int + + /// Gets or sets the value for the array. + member Value : arr<'T> with get, set + + member Clear : unit -> unit + member Add : 'T -> unit + member Insert : index: int * value: 'T -> unit + member RemoveAt : index: int -> unit + member Item : int -> 'T with get, set + + new : unit -> ChangeableArray<'T> + new : arr<'T> -> ChangeableArray<'T> + new : seq<'T> -> ChangeableArray<'T> + +/// Changeable adaptive array that allows mutation by user-code and implements aarr. +type carr<'T> = ChangeableArray<'T> \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/AssemblyInfo.fs b/src/FSharp.Data.Adaptive/AssemblyInfo.fs index a8e16fc..cc5fdf2 100644 --- a/src/FSharp.Data.Adaptive/AssemblyInfo.fs +++ b/src/FSharp.Data.Adaptive/AssemblyInfo.fs @@ -3,5 +3,6 @@ open System.Runtime.CompilerServices [] +[] [] do() \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/Core/Transaction.fs b/src/FSharp.Data.Adaptive/Core/Transaction.fs index bebd423..3745b58 100644 --- a/src/FSharp.Data.Adaptive/Core/Transaction.fs +++ b/src/FSharp.Data.Adaptive/Core/Transaction.fs @@ -181,7 +181,12 @@ type Transaction() = e.AllInputsProcessed(x) else + // WPF Synchronization-Context inlines code in contending locks. + // https://stackoverflow.com/questions/8431221/why-did-entering-a-lock-on-a-ui-thread-trigger-an-onpaint-event + // Therefore we treat the "inlined" code as if it were running on a different thread (without a current transaction) + Transaction.RunningTransaction <- ValueNone e.EnterWrite() + Transaction.RunningTransaction <- ValueSome x try outputCount <- 0 diff --git a/src/FSharp.Data.Adaptive/Datastructures/Arr.fs b/src/FSharp.Data.Adaptive/Datastructures/Arr.fs new file mode 100644 index 0000000..3f51cb1 --- /dev/null +++ b/src/FSharp.Data.Adaptive/Datastructures/Arr.fs @@ -0,0 +1,1443 @@ +namespace FSharp.Data.Adaptive + +#nowarn "7331" + +open System +open System.Diagnostics +open FSharp.Data.Adaptive.ComputeListDeltaHelpers + +module internal ArrNodeImplementation = + + [] + type Node<'a> = + val mutable public Height : byte + val mutable public Value : 'a + + new(h, v) = { Height = h; Value = v } + + type Inner<'a> = + inherit Node<'a> + val mutable public Left : Node<'a> + val mutable public Right : Node<'a> + val mutable public Count : int + + static member inline GetCount(node : Node<'a>) = + if isNull node then 0 + elif node.Height = 1uy then 1 + else (node :?> Inner<'a>).Count + + static member inline GetHeight(node : Node<'a>) = + if isNull node then 0uy + else node.Height + + static member inline FixHeightAndCount(inner : Inner<'a>) = + let lc = Inner.GetCount inner.Left + let rc = Inner.GetCount inner.Right + let lh = if lc > 0 then inner.Left.Height else 0uy + let rh = if rc > 0 then inner.Right.Height else 0uy + inner.Count <- 1 + lc + rc + inner.Height <- 1uy + max lh rh + + static member New(l : Node<'a>, value : 'a, r : Node<'a>) = + if isNull l && isNull r then Node(1uy, value) + else + let h = 1uy + max (Inner.GetHeight l) (Inner.GetHeight r) + let c = 1 + Inner.GetCount l + Inner.GetCount r + Inner(h, value, l, r, c) :> Node<_> + + new(h, v, l, r, c) = { inherit Node<'a>(h, v); Left = l; Right = r; Count = c } + + module Node = + + let inline empty<'a> : Node<'a> = null + + let inline height (n : Node<'a>) = + if isNull n then 0uy + else n.Height + + let inline isEmpty (n : Node<'a>) = + if isNull n then true + else false + + let inline count (n : Node<'a>) = + if isNull n then 0 + elif n.Height = 1uy then 1 + else (n :?> Inner<'a>).Count + + + let rec copyTo (index : int) (dst : 'a[]) (n : Node<'a>) = + if not (isNull n) then + if n.Height = 1uy then dst.[index] <- n.Value + else + let n = n :?> Inner<'a> + let lc = count n.Left + copyTo index dst n.Left + dst.[index + lc] <- n.Value + copyTo (index + lc + 1) dst n.Right + + let rec toList (acc : list<'a>) (node : Node<'a>) = + if isNull node then + acc + elif node.Height = 1uy then + node.Value :: acc + else + let n = node :?> Inner<'a> + toList (n.Value :: toList acc n.Right) n.Left + + let toArray (n : Node<'a>) = + let c = count n + let a = Array.zeroCreate c + copyTo 0 a n + a + + let inline balance (n : Inner<'a>) = + int (height n.Right) - int (height n.Left) + + let rec ofArray (data : 'a[]) (l : int) (r : int) = + if l > r then + null + elif l = r then + Node(1uy, data.[l]) + else + let m = (l + r) / 2 + let lt = ofArray data l (m - 1) + let rt = ofArray data (m + 1) r + Inner(1uy + max (height lt) (height rt), data.[m], lt, rt, 1 + count lt + count rt) :> Node<_> + + + let rec init (cnt : int) (offset : int) (initializer : int -> 'a) = + if cnt <= 0 then + null + elif cnt = 1 then + Node(1uy, initializer offset) + else + let lc = (cnt - 1) / 2 + let rc = cnt - 1 - lc + + let lt = init lc offset initializer + let v = initializer (offset + lc) + let rt = init rc (offset + lc + 1) initializer + Inner(1uy + max (height lt) (height rt), v, lt, rt, cnt) :> Node<_> + + + + #if NET6_0_OR_GREATER + let rec ofSpan (span : System.ReadOnlySpan<'a>) = + if span.Length = 0 then + null + elif span.Length = 1 then + Node(1uy, span.[0]) + else + let m = span.Length / 2 + let lt = ofSpan (span.Slice(0, m)) + let rt = ofSpan (span.Slice(m+1)) + Inner(1uy + max (height lt) (height rt), span.[m], lt, rt, 1 + count lt + count rt) :> Node<_> + + #endif + + let rec binary (l : Node<'a>) (v : 'a) (r : Node<'a>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> Inner<'a> + let rb = balance r + if rb > 0 then + // right right + binary + (binary l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> Inner<'a> + binary + (binary l v rl.Left) + rl.Value + (binary rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> Inner<'a> + let lb = balance l + if lb < 0 then + // left left + binary + l.Left + l.Value + (binary l.Right v r) + else + // left right + let lr = l.Right :?> Inner<'a> + binary + (binary l.Left l.Value lr.Left) + lr.Value + (binary lr.Right v r) + + elif lh = 0uy && rh = 0uy then Node(1uy, v) + else Inner(1uy + max lh rh, v, l, r, 1 + lc + rc) :> Node<_> + + let inline unsafeInner l v r = Inner.New(l, v, r) + + let unsafeBinary (l : Node<'a>) (v : 'a) (r : Node<'a>) = + let lc = count l + let rc = count r + let lh = if lc > 0 then l.Height else 0uy + let rh = if rc > 0 then r.Height else 0uy + + let b = int rh - int lh + if b > 2 then + // rh > lh + 2 + let r = r :?> Inner<'a> + let rb = balance r + if rb > 0 then + // right right + unsafeInner + (unsafeInner l v r.Left) + r.Value + r.Right + else + // right left + let rl = r.Left :?> Inner<'a> + unsafeInner + (unsafeInner l v rl.Left) + rl.Value + (unsafeInner rl.Right r.Value r.Right) + + elif b < -2 then + // lh > rh + 2 + let l = l :?> Inner<'a> + let lb = balance l + if lb < 0 then + // left left + unsafeInner + l.Left + l.Value + (unsafeInner l.Right v r) + else + // left right + let lr = l.Right :?> Inner<'a> + unsafeInner + (unsafeInner l.Left l.Value lr.Left) + lr.Value + (unsafeInner lr.Right v r) + + elif lh = 0uy && rh = 0uy then Node(1uy, v) + else Inner(1uy + max lh rh, v, l, r, 1 + lc + rc) :> Node<_> + + + let rec unsafeRemoveMin (n : Node<'a>) = + if n.Height = 1uy then + struct(n.Value, Unchecked.defaultof<_>) + else + let n = n :?> Inner<'a> + if isNull n.Left then + struct(n.Value, n.Right) + else + let struct(value, newLeft) = unsafeRemoveMin n.Left + let node = unsafeBinary newLeft n.Value n.Right + struct(value, node) + + let rec unsafeRemoveMax (n : Node<'a>) = + if n.Height = 1uy then + struct(n.Value, null) + else + let n = n :?> Inner<'a> + if isNull n.Right then + struct(n.Value, n.Left) + else + let struct(value, newRight) = unsafeRemoveMax n.Right + let node = unsafeBinary n.Left n.Value newRight + struct(value, node) + + + let rec join (l : Node<'a>) (r : Node<'a>) = + if isNull l then r + elif isNull r then l + else + let lh = l.Height + let rh = r.Height + if lh > rh then + let struct(v, ln) = unsafeRemoveMax l + binary ln v r + else + let struct(v, rn) = unsafeRemoveMin r + binary l v rn + + let rec insert (index : int) (value : 'a) (n : Node<'a>) = + if isNull n then + Node(1uy, value) + elif n.Height = 1uy then + if index = 0 then binary null value n + else binary n value null + else + let n = n :?> Inner<'a> + let c = count n.Left + if index <= c then + binary (insert index value n.Left) n.Value n.Right + else + binary n.Left n.Value (insert (index - c - 1) value n.Right) + + let rec unsafeSet (index : int) (value : 'a) (n : Node<'a>) = + if isNull n then + null + elif n.Height = 1uy then + if index = 0 then Node(1uy, value) + else n + else + let n = n :?> Inner<'a> + let c = count n.Left + if index < c then + binary (unsafeSet index value n.Left) n.Value n.Right + elif index > c then + binary n.Left n.Value (unsafeSet (index - c - 1) value n.Right) + else + binary n.Left value n.Right + + let rec append (value : 'a) (n : Node<'a>) = + if isNull n then + Node(1uy, value) + elif n.Height = 1uy then + binary n value null + else + let n = n :?> Inner<'a> + binary n.Left n.Value (append value n.Right) + + let rec prepend (value : 'a) (n : Node<'a>) = + if isNull n then + Node(1uy, value) + elif n.Height = 1uy then + binary null value n + else + let n = n :?> Inner<'a> + binary (prepend value n.Left) n.Value n.Right + + let rec skip (n : int) (node : Node<'a>) = + if n <= 0 then node + elif isNull node || node.Height = 1uy then + null + else + let node = node :?> Inner<'a> + if n >= node.Count then + null + else + let lc = count node.Left + if n < lc then binary (skip n node.Left) node.Value node.Right + elif n = lc then prepend node.Value node.Right + else skip (n - lc - 1) node.Right + + let rec take (n : int) (node : Node<'a>) = + if n <= 0 then null + elif isNull node || node.Height = 1uy then + node + else + let node = node :?> Inner<'a> + if n >= node.Count then + node + else + let lc = count node.Left + if n < lc then take n node.Left + elif n = lc then node.Left + else binary node.Left node.Value (take (n - lc - 1) node.Right) + + + let rec split (n : int) (node : Node<'a>) = + if n <= 0 then + null, node + elif isNull node || node.Height = 1uy then + node, null + else + let node = node :?> Inner<'a> + if n >= node.Count then + node, null + else + let lc = count node.Left + if n < lc then + let ll, lr = split n node.Left + ll, binary lr node.Value node.Right + elif n = lc then + node.Left, prepend node.Value node.Right + else + let rl, rr = split (n - lc - 1) node.Right + binary node.Left node.Value rl, rr + + + let rec sub (l : int) (r : int) (node : Node<'a>) = + + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then node + else null + else + let node = node :?> Inner<'a> + let lc = count node.Left + if r < lc then + sub l r node.Left + elif l > lc then + sub (l - lc - 1) (r - lc - 1) node.Right + elif l = lc then + prepend node.Value (take (r - l) node.Right) + elif r = lc then + append node.Value (skip l node.Left) + else + binary (skip l node.Left) node.Value (take (r - lc) node.Right) + + let join3 (a : Node<'a>) (b : Node<'a>) (c : Node<'a>) = + if isNull a then join b c + elif isNull b then join a c + elif isNull c then join a b + elif a.Height = 1uy then + join (prepend a.Value b) c + elif b.Height = 1uy then + if a.Height < c.Height then join (append b.Value a) c + else join a (prepend b.Value c) + elif c.Height = 1uy then + join a (append c.Value b) + else + join a (join b c) // TODO!!! + + let rec removeRange (l : int) (r : int) (node : Node<'a>) = + if isNull node then + null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then null + else node + else + let node = node :?> Inner<'a> + let lc = count node.Left + if r < lc then + binary (removeRange l r node.Left) node.Value node.Right + elif l > lc then + binary node.Left node.Value (removeRange (l - lc - 1) (r - lc - 1) node.Right) + elif l = lc then + join node.Left (skip (r - l) node.Right) + elif r = lc then + join (take l node.Left) node.Right + else + let a = take l node.Left + let b = skip (r - lc) node.Right + join a b + + let rec insertRange (index : int) (repl : Node<'a>) (node : Node<'a>) = + if isNull node then + repl + elif node.Height = 1uy then + if index <= 0 then append node.Value repl + else prepend node.Value repl + else + let node = node :?> Inner<'a> + let lc = count node.Left + if index < lc then + binary (insertRange index repl node.Left) node.Value node.Right + elif index = lc then + let r = prepend node.Value node.Right + join3 node.Left repl r + else + binary node.Left node.Value (insertRange (index - lc - 1) repl node.Right) + + let rec replaceRange (l : int) (r : int) (repl : Node<'a>) (node : Node<'a>) = + if isNull node then + repl + elif node.Height = 1uy then + if l <= 0 && r >= 0 then repl + elif r < 0 then append node.Value repl + else prepend node.Value repl + else + let node = node :?> Inner<'a> + let lc = count node.Left + if r < lc then + binary (replaceRange l r repl node.Left) node.Value node.Right + elif l > lc then + binary node.Left node.Value (replaceRange (l - lc - 1) (r - lc - 1) repl node.Right) + elif l = lc then + join3 node.Left repl (skip (r - l) node.Right) + elif r = lc then + join3 (take l node.Left) repl node.Right + else + let a = take l node.Left + let b = skip (r - lc) node.Right + join3 a repl b + + + let rec updateRange (l : int) (r : int) (repl : Node<'a> -> Node<'a>) (node : Node<'a>) = + if isNull node then + repl null + elif node.Height = 1uy then + if l <= 0 && r >= 0 then repl node + elif r < 0 then append node.Value (repl null) + else prepend node.Value (repl null) + else + let node = node :?> Inner<'a> + let lc = count node.Left + if r < lc then + binary (updateRange l r repl node.Left) node.Value node.Right + elif l > lc then + binary node.Left node.Value (updateRange (l - lc - 1) (r - lc - 1) repl node.Right) + elif l = lc then + let old = prepend node.Value (take (r - l) node.Right) + join3 node.Left (repl old) (skip (r - l) node.Right) + elif r = lc then + let old = append node.Value (skip l node.Left) + join3 (take l node.Left) (repl old) node.Right + else + let a = take l node.Left + let b = skip (r - lc) node.Right + + let inner = + binary (skip l node.Left) node.Value (take (r - lc) node.Right) + + join3 a (repl inner) b + + + let rec tryAt (i : int) (n : Node<'a>) = + if isNull n then None + elif n.Height = 1uy then + if i = 0 then Some n.Value + else None + else + let n = n :?> Inner<'a> + let lc = count n.Left + if i < lc then + tryAt i n.Left + elif i > lc then + tryAt (i - lc - 1) n.Right + else + Some n.Value + + let rec tryAtV (i : int) (n : Node<'a>) = + if isNull n then ValueNone + elif n.Height = 1uy then + if i = 0 then ValueSome n.Value + else ValueNone + else + let n = n :?> Inner<'a> + let lc = count n.Left + if i < lc then + tryAtV i n.Left + elif i > lc then + tryAtV (i - lc - 1) n.Right + else + ValueSome n.Value + + + let rec unsafeAt (i : int) (n : Node<'a>) = + if isNull n then Unchecked.defaultof<'a> + elif n.Height = 1uy then + if i = 0 then n.Value + else Unchecked.defaultof<'a> + else + let n = n :?> Inner<'a> + let lc = count n.Left + if i < lc then + unsafeAt i n.Left + elif i > lc then + unsafeAt (i - lc - 1) n.Right + else + n.Value + + + let rec exists (predicate : 'a -> bool) (n : Node<'a>) = + if isNull n then false + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> Inner<'a> + exists predicate n.Left || predicate n.Value || exists predicate n.Right + + let rec forall (predicate : 'a -> bool) (n : Node<'a>) = + if isNull n then true + elif n.Height = 1uy then predicate n.Value + else + let n = n :?> Inner<'a> + forall predicate n.Left && predicate n.Value && forall predicate n.Right + + let rec fold (folder : 's -> 'a -> 's) (state : 's) (n : Node<'a>) = + if isNull n then + state + elif n.Height = 1uy then + folder state n.Value + else + let n = n :?> Inner<'a> + let s1 = fold folder state n.Left + let s2 = folder s1 n.Value + fold folder s2 n.Right + + let rec pairwise (lastValue : voption<'a>) (n : Node<'a>) = + if isNull n then + null, lastValue + elif n.Height = 1uy then + match lastValue with + | ValueSome l -> Node(1uy, (l, n.Value)), ValueSome n.Value + | ValueNone -> null, ValueSome n.Value + else + let n = n :?> Inner<'a> + let l, lv = pairwise lastValue n.Left + + let ownValue = + match lv with + | ValueSome lv -> ValueSome (lv, n.Value) + | ValueNone -> ValueNone + + let r, rv = pairwise (ValueSome n.Value) n.Right + + let newNode = + match ownValue with + | ValueSome o -> binary l o r + | ValueNone -> join l r + + newNode, rv + + + let rec mapPairwise (lastValue : voption<'a>) (mapping : 'a -> 'a -> 'b) (n : Node<'a>) = + if isNull n then + null, lastValue + elif n.Height = 1uy then + match lastValue with + | ValueSome l -> Node(1uy, mapping l n.Value), ValueSome n.Value + | ValueNone -> null, ValueSome n.Value + else + let n = n :?> Inner<'a> + let l, lv = mapPairwise lastValue mapping n.Left + + let ownValue = + match lv with + | ValueSome lv -> ValueSome (mapping lv n.Value) + | ValueNone -> ValueNone + + let r, rv = mapPairwise (ValueSome n.Value) mapping n.Right + + let newNode = + match ownValue with + | ValueSome o -> binary l o r + | ValueNone -> join l r + + newNode, rv + + let rec reverse (n : Node<'a>) = + if isNull n then + null + elif n.Height = 1uy then + n + else + let n = n :?> Inner<'a> + Inner(n.Height, n.Value, reverse n.Right, reverse n.Left, n.Count) :> Node<_> + + let rec foldr (folder : 'a -> 's -> 's) (n : Node<'a>) (state : 's) = + if isNull n then + state + elif n.Height = 1uy then + folder n.Value state + else + let n = n :?> Inner<'a> + let s1 = foldr folder n.Right state + let s2 = folder n.Value s1 + foldr folder n.Left s2 + + let rec tryPick (mapping : 'a -> option<'b>) (n : Node<'a>) = + if isNull n then + None + elif n.Height = 1uy then + mapping n.Value + else + let n = n :?> Inner<'a> + match tryPick mapping n.Left with + | None -> + match mapping n.Value with + | None -> + tryPick mapping n.Right + | res -> + res + | res -> + res + + let rec tryPickV (mapping : 'a -> voption<'b>) (n : Node<'a>) = + if isNull n then + ValueNone + elif n.Height = 1uy then + mapping n.Value + else + let n = n :?> Inner<'a> + match tryPickV mapping n.Left with + | ValueNone -> + match mapping n.Value with + | ValueNone -> + tryPickV mapping n.Right + | res -> + res + | res -> + res + + let rec tryFindIndex (predicate : 'a -> bool) (n : Node<'a>) = + if isNull n then None + elif n.Height = 1uy then + if predicate n.Value then + Some 0 + else + None + else + let n = n :?> Inner<'a> + + match tryFindIndex predicate n.Left with + | Some i -> Some i + | None -> + let lc = count n.Left + if predicate n.Value then + Some lc + else + match tryFindIndex predicate n.Right with + | Some i -> + Some (i + lc + 1) + | None -> + None + + let rec map (mapping : 'a -> 'b) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then Node(1uy, mapping n.Value) + else + let n = n :?> Inner<'a> + let l = map mapping n.Left + let v = mapping n.Value + let r = map mapping n.Right + Inner(n.Height, v, l, r, n.Count) :> Node<_> + + let rec mapi (i : int) (mapping : int -> 'a -> 'b) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then Node(1uy, mapping i n.Value) + else + let n = n :?> Inner<'a> + let o = i + count n.Left + let l = mapi i mapping n.Left + let v = mapping o n.Value + let r = mapi (o + 1) mapping n.Right + Inner(n.Height, v, l, r, n.Count) :> Node<_> + + let rec iter (action : 'a -> unit) (n : Node<'a>) = + if isNull n then + () + elif n.Height = 1uy then + action n.Value + else + let n = n :?> Inner<'a> + iter action n.Left + action n.Value + iter action n.Right + + let rec iteri (offset : int) (action : int -> 'a -> unit) (n : Node<'a>) = + if isNull n then + () + elif n.Height = 1uy then + action offset n.Value + else + let n = n :?> Inner<'a> + let ro = offset + count n.Left + iteri offset action n.Left + action ro n.Value + iteri (ro + 1) action n.Right + + let rec choose (mapping : 'a -> option<'b>) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + match mapping n.Value with + | Some value -> Node(1uy, value) + | None -> null + else + let n = n :?> Inner<'a> + let l = choose mapping n.Left + let value = mapping n.Value + let r = choose mapping n.Right + match value with + | Some value -> + binary l value r + | None -> + join l r + + let rec choosei (offset : int) (mapping : int -> 'a -> option<'b>) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + match mapping offset n.Value with + | Some value -> Node(1uy, value) + | None -> null + else + let n = n :?> Inner<'a> + let ro = offset + count n.Left + let l = choosei offset mapping n.Left + let value = mapping ro n.Value + let r = choosei (ro + 1) mapping n.Right + match value with + | Some value -> + binary l value r + | None -> + join l r + + let rec filter (predicate : 'a -> bool) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + if predicate n.Value then n + else null + else + let n = n :?> Inner<'a> + let l = filter predicate n.Left + let takeSelf = predicate n.Value + let r = filter predicate n.Right + if takeSelf then + binary l n.Value r + else + join l r + + let rec filteri (offset : int) (predicate : int -> 'a -> bool) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + if predicate offset n.Value then n + else null + else + let n = n :?> Inner<'a> + let ro = offset + count n.Left + let l = filteri offset predicate n.Left + let takeSelf = predicate ro n.Value + let r = filteri (ro + 1) predicate n.Right + if takeSelf then + binary l n.Value r + else + join l r + + let rec partition (predicate : 'a -> bool) (n : Node<'a>) = + if isNull n then + null, null + elif n.Height = 1uy then + if predicate n.Value then n, null + else null, n + else + let n = n :?> Inner<'a> + let lt, lf = partition predicate n.Left + let takeSelf = predicate n.Value + let rt, rf = partition predicate n.Right + if takeSelf then + binary lt n.Value rt, join lf rf + else + join lt rt, binary lf n.Value rf + + + let rec collect (mapping : 'a -> Node<'b>) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + mapping n.Value + else + let n = n :?> Inner<'a> + let l = collect mapping n.Left + let s = mapping n.Value + let r = collect mapping n.Right + match count s with + | 0 -> join l r + | 1 -> binary l s.Value r + | _ -> join3 l s r + + let rec collecti (offset : int) (mapping : int -> 'a -> Node<'b>) (n : Node<'a>) = + if isNull n then null + elif n.Height = 1uy then + mapping offset n.Value + else + let n = n :?> Inner<'a> + let ro = offset + count n.Left + let l = collecti offset mapping n.Left + let s = mapping ro n.Value + let r = collecti (ro + 1) mapping n.Right + match count s with + | 0 -> join l r + | 1 -> binary l s.Value r + | _ -> join3 l s r + + let rec concat (n : Node>) = + if isNull n then null + elif n.Height = 1uy then + n.Value + else + let n = n :?> Inner> + let l = concat n.Left + let s = n.Value + let r = concat n.Right + match count s with + | 0 -> join l r + | 1 -> binary l s.Value r + | _ -> join3 l s r + + let rec map2 (mapping : 'a -> 'b -> 'c) (a : Node<'a>) (b : Node<'b>) = + if isNull a then + if isNull b then null + else failwith "zipWith: different lengths" + elif a.Height = 1uy then + if b.Height = 1uy then Node(1uy, mapping a.Value b.Value) + else failwith "zipWith: different lengths" + else + let a = a :?> Inner<'a> + let b = b :?> Inner<'b> + + let ca = count a.Left + let cb = count b.Left + if ca = cb then + let l = map2 mapping a.Left b.Left + let v = mapping a.Value b.Value + let r = map2 mapping a.Right b.Right + Inner(a.Height, v, l, r, a.Count) :> Node<_> + else + let bl, br = split ca b + let struct(v, br) = unsafeRemoveMin br + let l = map2 mapping a.Left bl + let v = mapping a.Value v + let r = map2 mapping a.Right br + Inner(a.Height, v, l, r, a.Count) :> Node<_> + + + + let inline combineHash (a: int) (b: int) = + uint32 a ^^^ uint32 b + 0x9e3779b9u + ((uint32 a) <<< 6) + ((uint32 a) >>> 2) |> int + + let rec hash (valueHash : 'a -> int) (acc : int) (node : Node<'a>) = + if isNull node then + acc + elif node.Height = 1uy then + combineHash acc (valueHash node.Value) + else + let node = node :?> Inner<'a> + let a = hash valueHash acc node.Left + let b = combineHash a (valueHash node.Value) + hash valueHash b node.Right + + + let rec equals (valueEquals : 'a -> 'a -> bool) (a : Node<'a>) (b : Node<'a>) = + if count a <> count b then + false + else + if isNull a then + if isNull b then true + else false + elif a.Height = 1uy then + if b.Height = 1uy then valueEquals a.Value b.Value + else false + else + let a = a :?> Inner<'a> + let b = b :?> Inner<'a> + let ca = count a.Left + let cb = count b.Left + if ca = cb then + valueEquals a.Value b.Value && + equals valueEquals a.Left b.Left && + equals valueEquals a.Right b.Right + else + let bl, br = split ca b + if isNull br then + false + else + let struct(v, br) = unsafeRemoveMin br + valueEquals a.Value v && + equals valueEquals a.Left bl && + equals valueEquals a.Right br + +open ArrNodeImplementation + +/// A persitent array-like structure that allows lookup/insertion/deletion of entries in O(log N). +[>); CompiledName("FSharpArr`1"); CustomEquality; NoComparison>] +type arr<'a> internal(store : Node<'a>) = + member internal x.Store = store + + /// Creates an empty arr. + static member Empty : arr<'a> = arr<'a> null + + /// Creates an arr with a single element. + static member Single(value : 'a) = arr(Node<'a>(1uy, value)) + + /// Creates an arr from an array. + static member FromArray(elements : 'a[]) : arr<'a> = arr (Node.ofArray elements 0 (elements.Length - 1)) + + #if NET6_0_OR_GREATER + + /// Creates an arr from a ReadOnlySpan. + static member FromSpan(elements : System.ReadOnlySpan<'a>) = arr (Node.ofSpan elements) + + /// Creates an arr from a Span. + static member FromSpan(elements : System.Span<'a>) = arr (Node.ofSpan (System.Span.op_Implicit elements)) + + /// Creates an arr from a Memory. + static member FromMemory(elements : System.Memory<'a>) = arr (Node.ofSpan (System.Span.op_Implicit elements.Span)) + + /// Creates an arr from a ReadOnlyMemory. + static member FromMemory(elements : System.ReadOnlyMemory<'a>) = arr (Node.ofSpan elements.Span) + #endif + + override x.GetHashCode() = + Node.hash DefaultEquality.hash 0 store + + override x.Equals(o : obj) = + match o with + | :? arr<'a> as o -> Node.equals DefaultEquality.equals store o.Store + | _ -> false + + /// Concatenates multiple arrs into a single arr. + static member Concat([] arrs : arr<'a>[]) = + if arrs.Length = 0 then arr.Empty + elif arrs.Length = 1 then arrs.[0] + else + arr.FromArray(arrs).Store + |> Node.collect (fun (a : arr<'a>) -> a.Store) + |> arr<'a> + + /// Is the arr empty? + member x.IsEmpty = Node.isEmpty store + + /// The number of elements in the arr. + member x.Length = Node.count store + + /// Creates a new arr with an inserted element at the specified index. + member x.Insert(index : int, value : 'a) = arr(Node.insert index value store) + + /// Creates a new arr with an inserted element at the end. + member x.Add(value : 'a) = arr(Node.append value store) + + /// Creates a new arr with an inserted element at the beginning. + member x.Prepend(value : 'a) = arr(Node.prepend value store) + + /// Creates a new arr with an inserted element at the end. + member x.Append(value : 'a) = arr(Node.append value store) + + + /// Creates a new arr by skipping the first n elements. + /// returns an empty arr if n is greater than the length of the arr. + member x.Skip(n : int) = + if n <= 0 then x + elif n >= x.Length then arr.Empty + else arr(Node.skip n store) + + /// Creates a new arr by taking the first n elements. + /// returns the full arr if n is greater than the length of the arr. + member x.Take(n : int) = + if n <= 0 then arr.Empty + elif n < x.Length then arr(Node.take n store) + else x + + /// Splits the arr into two parts at the specified index. + /// the two parts are equivalent to calling Take and Skip with the same index. + member x.Split(n : int) = + if n <= 0 then arr.Empty, x + elif n >= x.Length then x, arr.Empty + else + let l, r = Node.split n store + arr(l), arr(r) + + /// Creates a new arr by taking the elements in the given range. + member x.Sub(offset : int, count : int) = + arr(Node.sub offset (offset + count - 1) store) + + /// F# style slicing. + member x.GetSlice(min : option, max : option) = + match min with + | Some min -> + match max with + | Some max -> + x.Sub(min, 1 + max - min) + | None -> + x.Skip min + | None -> + match max with + | Some max -> + x.Take(max + 1) + | None -> + x + + /// Creates a new arr by removing the elements in the given range. + member x.RemoveRange(offset : int, count : int) = + arr(Node.removeRange offset (offset + count - 1) store) + + /// Creates a new arr by replacing the elements in the given range with the given elements. + member x.ReplaceRange(offset : int, count : int, replacement : arr<'a>) = + if count <= 0 then arr(Node.insertRange offset replacement.Store store) + else arr(Node.replaceRange offset (offset + count - 1) replacement.Store store) + + /// Creates a new arr by replacing the elements in the given range with the given elements. + member x.UpdateRange(offset : int, count : int, replacement : arr<'a> -> arr<'a>) = + arr(Node.updateRange offset (offset + count - 1) (fun r -> replacement(arr r).Store) store) + + /// Copies the elements to a standard .NET array. + member x.ToArray() = + let res = Array.zeroCreate x.Length + Node.copyTo 0 res store + res + + /// Copies the elements to a standard F# list. + member x.ToList() = + Node.toList [] store + + /// Copies the elements to a standard .NET array at the specified index. + member this.CopyTo(array,arrayIndex) = + Node.copyTo arrayIndex array store + + /// pretty print for arr + override x.ToString() = + if Node.count store > 10 then Node.toArray (Node.take 10 store) |> Seq.map (sprintf "%A") |> String.concat "; " |> sprintf "arr [%s; ...]" + else Node.toArray store |> Seq.map (sprintf "%A") |> String.concat "; " |> sprintf "arr [%s]" + + member private x.AsString = x.ToString() + + /// Standard enumerator for the arr. + member x.GetEnumerator() = new ArrEnumerator<'a>(store) + + /// Creates a new arr by replacing the element at the specified index. + member x.Set(index : int, value : 'a) = + if index >= 0 && index < x.Length then + arr(Node.unsafeSet index value store) + else + raise <| IndexOutOfRangeException() + + /// Gets the element at the specified index. + member x.Item + with get(i : int) = + match Node.tryAtV i store with + | ValueSome v -> v + | ValueNone -> raise <| IndexOutOfRangeException() + + + interface System.Collections.IEnumerable with + member x.GetEnumerator() = new ArrEnumerator<'a>(store) :> _ + + interface System.Collections.Generic.IEnumerable<'a> with + member x.GetEnumerator() = new ArrEnumerator<'a>(store) :> _ + + interface System.Collections.Generic.ICollection<'a> with + member this.Add(_item) = failwith "readonly" + member this.Clear() = failwith "readonly" + member this.Contains(item) = Node.exists (Unchecked.equals item) store + member this.CopyTo(array,arrayIndex) = this.CopyTo(array, arrayIndex) + member this.Remove(_item) = failwith "readonly" + member this.Count = this.Length + member this.IsReadOnly = true + + interface System.Collections.Generic.IList<'a> with + member this.Insert(_index,_item) = failwith "readonly" + member this.RemoveAt(_index) = failwith "readonly" + member this.IndexOf(item) = + match Node.tryFindIndex (Unchecked.equals item) store with + | Some idx -> idx + | None -> -1 + member this.Item + with get index = this.[index] + and set _ _ = failwith "readonly" + + interface System.Collections.Generic.IReadOnlyCollection<'a> with + member this.Count = this.Length + + interface System.Collections.Generic.IReadOnlyList<'a> with + member this.Item + with get index = this.[index] + +/// Enumerator for arr. +and [] ArrEnumerator<'a> = + struct + val mutable internal Root : Node<'a> + val mutable internal Head : struct(Node<'a> * bool) + val mutable internal Tail : list * bool)> + val mutable internal CurrentNode : Node<'a> + + member x.MoveNext() = + let struct(n, deep) = x.Head + if not (isNull n) then + + if n.Height > 1uy && deep then + let inner = n :?> Inner<'a> + + if isNull inner.Left then + if isNull inner.Right then + if x.Tail.IsEmpty then + x.Head <- Unchecked.defaultof<_> + x.Tail <- [] + else + x.Head <- x.Tail.Head + x.Tail <- x.Tail.Tail + else + x.Head <- struct(inner.Right, true) + + x.CurrentNode <- n + true + else + x.Head <- struct(inner.Left, true) + if isNull inner.Right then + x.Tail <- struct(n, false) :: x.Tail + else + x.Tail <- struct(n, false) :: struct(inner.Right, true) :: x.Tail + x.MoveNext() + else + x.CurrentNode <- n + if x.Tail.IsEmpty then + x.Head <- Unchecked.defaultof<_> + x.Tail <- [] + else + x.Head <- x.Tail.Head + x.Tail <- x.Tail.Tail + true + + else + false + + + member x.Reset() = + x.Head <- if isNull x.Root then Unchecked.defaultof<_> else struct(x.Root, true) + x.Tail <- [] + x.CurrentNode <- null + + member x.Dispose() = + x.Root <- null + x.CurrentNode <- null + x.Head <- Unchecked.defaultof<_> + x.Tail <- [] + + member x.Current = + x.CurrentNode.Value + + interface System.Collections.IEnumerator with + member x.MoveNext() = x.MoveNext() + member x.Reset() = x.Reset() + member x.Current = x.Current :> obj + + interface System.Collections.Generic.IEnumerator<'a> with + member x.Current = x.Current + member x.Dispose() = x.Dispose() + + internal new(root : Node<'a>) = + { + Root = root + Head = if isNull root then Unchecked.defaultof<_> else struct(root, true) + Tail = [] + CurrentNode = null + } + end + +/// Debugger proxy for arr. +and internal ArrProxy<'a>(arr : arr<'a>) = + let items = arr.Take(10000).ToArray() + + [] + member x.Length = arr.Length + + [] + member x.Items = items + +/// The Arr module contains functions for creating and manipulating the `arr` data structure. +[] +module Arr = + + /// Empty arr. + let inline empty<'a> : arr<'a> = arr.Empty + + /// Singleton arr. + let inline single (value : 'a) = arr.Single(value) + + /// Creates an arr from a sequence. + let inline ofSeq (seq : seq<'a>) = + match seq with + | :? arr<'a> as arr -> arr + | _ -> arr.FromArray (Seq.toArray seq) + + /// Creates an arr from a list. + let inline ofList (array : list<'a>) = arr.FromArray (List.toArray array) + + /// Creates an arr from an array. + let inline ofArray (array : 'a[]) = arr.FromArray array + + #if NET6_0_OR_GREATER + /// Creates an arr from a Span. + let inline ofSpan (array : System.Span<'a>) = arr.FromSpan array + + /// Creates an arr from a Memory. + let inline ofMemory (array : System.Memory<'a>) = arr.FromMemory array + #endif + + /// Number of Elements in the arr. + let inline length (a : arr<'a>) = a.Length + + /// Inserts an element at the specified index (s.t. `arr.[index] = value` after the operation). + /// Note that the index must be in the range `[0, length arr]`. + let inline insert (index : int) (value : 'a) (arr : arr<'a>) = arr.Insert(index, value) + + /// Appends an element to the end of the arr. + let inline add (value : 'a) (arr : arr<'a>) = arr.Add value + + /// Appends an element to the end of the arr. + let inline append (value : 'a) (arr : arr<'a>) = arr.Append value + + /// Inserts an element at the beginning of the arr. + let inline prepend (value : 'a) (arr : arr<'a>) = arr.Prepend value + + /// Replaces the element at the specified index. + let inline set (index : int) (value : 'a) (arr : arr<'a>) = arr.Set(index, value) + + /// seq representation of the arr. + let inline toSeq (arr : arr<'a>) = arr :> seq<_> + + /// all elements from the arr. + let inline toList (arr : arr<'a>) = arr.ToList() + + /// all elements from the arr. + let inline toArray (arr : arr<'a>) = arr.ToArray() + + /// Creates a new arr by taking the first n elements. + /// returns the full arr if n is greater than the length of the arr. + let inline take (n : int) (arr : arr<'a>) = arr.Take n + + /// Creates a new arr by skipping the first n elements. + /// returns an empty arr if n is greater than the length of the arr. + let inline skip (n : int) (arr : arr<'a>) = arr.Skip n + + /// Creates a new arr by taking the elements in the given range. + let inline sub (index : int) (count : int) (arr : arr<'a>) = arr.Sub(index, count) + + /// Splits the arr into two parts at the specified index. + /// the two parts are equivalent to calling take and skip with the same index. + let inline split (index : int) (arr : arr<'a>) = arr.Split(index) + + /// Concatenates multiple arrs into a single arr. + let inline concat (arrs : seq>) = arr.Concat(Seq.toArray arrs) + + /// removes the first element of an array and returns it together with the rest of the array. + let uncons (array : arr<'a>) = + if array.Length > 0 then + let struct(value, rest) = Node.unsafeRemoveMin array.Store + value, arr(rest) + else + raise <| IndexOutOfRangeException() + + /// removes the last element of an array and returns it together with the rest of the array. + let unsnoc (array : arr<'a>) = + if array.Length > 0 then + let struct(value, rest) = Node.unsafeRemoveMax array.Store + value, arr(rest) + else + raise <| IndexOutOfRangeException() + + /// creates a new arr by applying `mapping` to all elements. + let map (mapping : 'a -> 'b) (array : arr<'a>) = + array.Store |> Node.map mapping |> arr + + /// creates a new arr by applying `mapping` to all elements. + let mapi (mapping : int -> 'a -> 'b) (array : arr<'a>) = + array.Store |> Node.mapi 0 mapping |> arr + + /// creates a new arr by applying `mapping` and removing None values. + let choose (mapping : 'a -> option<'b>) (array : arr<'a>) = + array.Store |> Node.choose mapping |> arr + + /// creates a new arr by applying `mapping` and removing None values. + let choosei (mapping : int -> 'a -> option<'b>) (array : arr<'a>) = + array.Store |> Node.choosei 0 mapping |> arr + + /// filters the arr based on the given predicate. + let filter (predicate : 'a -> bool) (array : arr<'a>) = + array.Store |> Node.filter predicate |> arr + + /// filters the arr based on the given predicate. + let filteri (predicate : int -> 'a -> bool) (array : arr<'a>) = + array.Store |> Node.filteri 0 predicate |> arr + + let partition (predicate : 'a -> bool) (array : arr<'a>) = + let l, r = array.Store |> Node.partition predicate + arr(l), arr(r) + + /// creates a new arr by applying `mapping` to all elements and concerting the results. + let collect (mapping : 'a -> arr<'b>) (array : arr<'a>) = + array.Store |> Node.collect (fun v -> mapping(v).Store) |> arr + + /// creates a new arr by applying `mapping` to all elements and concerting the results. + let collecti (mapping : int -> 'a -> arr<'b>) (array : arr<'a>) = + array.Store |> Node.collecti 0 (fun i v -> (mapping i v).Store) |> arr + + /// iterates over the arr and invokes the action for each element. + let iter (action : 'a -> unit) (array : arr<'a>) = + Node.iter action array.Store + + /// iterates over the arr and invokes the action for each element. + let iteri (action : int -> 'a -> unit) (array : arr<'a>) = + Node.iteri 0 action array.Store + + /// Tests if any element in the arr satisfies the given predicate. + let exists (predicate : 'a -> bool) (array : arr<'a>) = + Node.exists predicate array.Store + + /// Tests if all elements in the arr satisfy the given predicate. + let forall (predicate : 'a -> bool) (array : arr<'a>) = + Node.forall predicate array.Store + + /// folds the arr from left to right. + let fold (folder : 's -> 'a -> 's) (seed : 's) (array : arr<'a>) = + Node.fold folder seed array.Store + + /// folds the arr from right to left. + let foldBack (folder : 'a -> 's -> 's) (array : arr<'a>) (seed : 's) = + Node.foldr folder array.Store seed + + let inline sum (array : arr< ^a >) = + fold (+) LanguagePrimitives.GenericZero array + + let inline product (array : arr< ^a >) = + fold (*) LanguagePrimitives.GenericOne array + + let inline average (array : arr< ^a >) = + let s = fold (+) LanguagePrimitives.GenericZero array + LanguagePrimitives.DivideByInt s array.Length + + let min< 'a when 'a : comparison> (array : arr<'a>) = + let node = array.Store + if isNull node then + raise <| ArgumentException("The input array is empty.") + elif node.Height = 1uy then + node.Value + else + let s = Node.fold min node.Value node + Node.fold min s node + + let max< 'a when 'a : comparison> (array : arr<'a>) = + let node = array.Store + if isNull node then + raise <| ArgumentException("The input array is empty.") + elif node.Height = 1uy then + node.Value + else + let s = Node.fold max node.Value node + Node.fold max s node + + let indexed (array : arr<'a>) = + array |> mapi (fun i v -> (i, v)) + + let init (count : int) (initializer : int -> 'a) = + Node.init count 0 initializer |> arr + + let item (index : int) (arr : arr<'a>) = + arr.[index] + + let tryItem (index : int) (arr : arr<'a>) = + Node.tryAt index arr.Store + + let tryPick (mapping : 'a -> option<'b>) (arr : arr<'a>) = + Node.tryPick mapping arr.Store + + let tryPickV (mapping : 'a -> voption<'b>) (arr : arr<'a>) = + Node.tryPickV mapping arr.Store + + let tryFindIndex (predicate : 'a -> bool) (arr : arr<'a>) = + Node.tryFindIndex predicate arr.Store + + let pairwise (array : arr<'a>) = + let node, _ = Node.pairwise ValueNone array.Store + arr(node) + + let pairwiseV (array : arr<'a>) = + let node, _ = Node.mapPairwise ValueNone (fun a b -> struct(a, b)) array.Store + arr(node) + + let rev (array : arr<'a>) = + array.Store |> Node.reverse |> arr + + let zip (a : arr<'a>) (b : arr<'b>) = + Node.map2 (fun a b -> a,b) a.Store b.Store |> arr + + let map2 (mapping : 'a -> 'b -> 'c) (a : arr<'a>) (b : arr<'b>) = + Node.map2 mapping a.Store b.Store |> arr \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/Datastructures/ArrDelta.fs b/src/FSharp.Data.Adaptive/Datastructures/ArrDelta.fs new file mode 100644 index 0000000..ef8b5b1 --- /dev/null +++ b/src/FSharp.Data.Adaptive/Datastructures/ArrDelta.fs @@ -0,0 +1,481 @@ +namespace FSharp.Data.Adaptive + +#nowarn "7331" + +open System +open System.Diagnostics + +open ArrNodeImplementation +open FSharp.Data.Adaptive.ComputeListDeltaHelpers + +/// ArrOperation represents an operation on an arr. +/// The Operations replaces the range given by Index and Count with the Elements. +/// Note that 'Insert' and 'Delete' operations are represented as ArrOperation with Count = 0 and Elements = [] respectively. +[] +type ArrOperation<'a> = { Index : int; Count : int; Elements : arr<'a> } with + member inline x.MinIndex = x.Index + member inline x.MaxIndex = x.Index + x.Count - 1 + member inline x.Balance = x.Elements.Length - x.Count + member inline x.IsEmpty = x.Count <= 0 && x.Elements.Length <= 0 + + member private x.AsString = x.ToString() + + override x.ToString() = + if x.Elements.IsEmpty && x.Count <= 0 then + "nop" + elif x.Elements.IsEmpty then + if x.Count = 1 then + sprintf "del(%d)" x.Index + else + sprintf "del(%d, %d)" x.Index x.Count + elif x.Count = 0 then + sprintf "ins(%d, %A)" x.Index x.Elements + else + sprintf "splice(%d, %d, %A)" x.Index x.Count x.Elements + + static member TryMerge(a : ArrOperation<'a>, b : ArrOperation<'a>) = + + let ai0 = a.Index + let ai1 = ai0 + a.Elements.Length - 1 + let b0 = b.Index + let bn1 = b0 + b.Count - 1 + + + + if b0 = ai1 + 1 then + // directly adjacent + Some { a with Count = a.Count + b.Count; Elements = arr(Node.join a.Elements.Store b.Elements.Store) } + + + elif b0 >= ai0 && b0 <= ai1 then + if bn1 <= ai1 then + // b is contained in a + let newElements = + let idx = b0 - ai0 + if b.Count = 0 then Node.insertRange idx b.Elements.Store a.Elements.Store + elif b.Elements.IsEmpty then Node.removeRange idx (idx + b.Count - 1) a.Elements.Store + else Node.replaceRange idx (idx + b.Count - 1) b.Elements.Store a.Elements.Store + Some { a with Elements = arr newElements } + else + // b starts in a + let rest = Node.take (b0 - ai0) a.Elements.Store + let overflowCount = bn1 - ai1 + Some { a with Count = a.Count + overflowCount; Elements = arr(Node.join rest b.Elements.Store) } + + elif b0 < ai0 && bn1 >= ai0 then + if bn1 <= ai1 then + // b ends in a + + // splice(3, 1, [a;b;c]) + splice(1, 4, [x;y]) + // 1 2 3 4 5 6 7 8 9 0 + // 1 2 3 a b c 5 6 7 8 9 0 + // 1 x y c 5 6 7 8 9 0 + + let delCnt = bn1 - ai0 + 1 + let newElements = Node.join b.Elements.Store (Node.skip delCnt a.Elements.Store) + Some { b with Count = b.Count + a.Count - delCnt; Elements = arr newElements } + + + // let br = { b with Count = b.Count - delCnt } + // + // Some { a with Elements = arr newElements } + else + // b contains a + + // splice(3, 1, [a;b]) + splice(0, 10, [x;y;Z]) + + // 1 2 3 4 5 6 7 8 9 0 + // 1 2 3 a b 5 6 7 8 9 0 + // x y z 0 + + let ba = a.Elements.Length - a.Count + Some { b with Count = b.Count - ba } + + else + None + + + static member TryMergeV(a : ArrOperation<'a>, b : ArrOperation<'a>) = + + let ai0 = a.Index + let ai1 = ai0 + a.Elements.Length - 1 + let b0 = b.Index + let bn1 = b0 + b.Count - 1 + + + + if b0 = ai1 + 1 then + // directly adjacent + ValueSome { a with Count = a.Count + b.Count; Elements = arr(Node.join a.Elements.Store b.Elements.Store) } + + + elif b0 >= ai0 && b0 <= ai1 then + if bn1 <= ai1 then + // b is contained in a + let newElements = + let idx = b0 - ai0 + if b.Count = 0 then Node.insertRange idx b.Elements.Store a.Elements.Store + elif b.Elements.IsEmpty then Node.removeRange idx (idx + b.Count - 1) a.Elements.Store + else Node.replaceRange idx (idx + b.Count - 1) b.Elements.Store a.Elements.Store + ValueSome { a with Elements = arr newElements } + else + // b starts in a + let rest = Node.take (b0 - ai0) a.Elements.Store + let overflowCount = bn1 - ai1 + ValueSome { a with Count = a.Count + overflowCount; Elements = arr(Node.join rest b.Elements.Store) } + + elif b0 < ai0 && bn1 >= ai0 then + if bn1 <= ai1 then + // b ends in a + + // splice(3, 1, [a;b;c]) + splice(1, 4, [x;y]) + // 1 2 3 4 5 6 7 8 9 0 + // 1 2 3 a b c 5 6 7 8 9 0 + // 1 x y c 5 6 7 8 9 0 + + let delCnt = bn1 - ai0 + 1 + let newElements = Node.join b.Elements.Store (Node.skip delCnt a.Elements.Store) + ValueSome { b with Count = b.Count + a.Count - delCnt; Elements = arr newElements } + + + // let br = { b with Count = b.Count - delCnt } + // + // Some { a with Elements = arr newElements } + else + // b contains a + + // splice(3, 1, [a;b]) + splice(0, 10, [x;y;Z]) + + // 1 2 3 4 5 6 7 8 9 0 + // 1 2 3 a b 5 6 7 8 9 0 + // x y z 0 + + let ba = a.Elements.Length - a.Count + ValueSome { b with Count = b.Count - ba } + + else + ValueNone + + +/// arrdelta holds a sequence of minimal ArrOperations that represent the difference between two arrs. +[>); StructuredFormatDisplay("{AsString}"); CustomEquality; NoComparison>] +type arrdelta<'a> internal(store : Node>) = + member internal x.Store = store + member x.Length = Node.count store + + override x.GetHashCode() = + Node.hash DefaultEquality.hash 0 store + + override x.Equals(o) = + match o with + | :? arrdelta<'a> as o -> Node.equals DefaultEquality.equals store o.Store + | _ -> false + + new(delta : arr>) = arrdelta(delta.Store) + + override x.ToString() = + if Node.count store > 20 then + Node.toArray store |> Seq.map (sprintf "%A") |> String.concat "; " |> sprintf "arrdelta [%s; ...]" + else + Node.toArray store |> Seq.map (sprintf "%A") |> String.concat "; " |> sprintf "arrdelta [%s]" + + member private x.AsString = x.ToString() + + member x.ToArr() = arr(store) + + member x.GetEnumerator() = new ArrEnumerator>(store) + + interface System.Collections.IEnumerable with + member x.GetEnumerator() = new ArrEnumerator>(store) :> _ + + interface System.Collections.Generic.IEnumerable> with + member x.GetEnumerator() = new ArrEnumerator>(store) :> _ + +/// Debugger proxy for arrdelta +and internal ArrDeltaProxy<'a>(delta : arrdelta<'a>) = + let items = delta.ToArr().Take(10000).ToArray() + [] + member x.Items = items + +module ArrDelta = + + let isEmpty (d : arrdelta<'a>) = d.Length = 0 + + let empty<'a> : arrdelta<'a> = arrdelta null + + let single (value : ArrOperation<'a>) = arrdelta(Node(1uy, value)) + + let toSeq (a : arrdelta<'a>) = a :> seq<_> + let toList (a : arrdelta<'a>) = Node.toList [] a.Store + let toArray (a : arrdelta<'a>) = Node.toArray a.Store + + let ofArr (a : arr>) = arrdelta(a.Store) + + module internal Node = + + let rec binary (l : Node>) (op : ArrOperation<'a>) (r : Node>) = + if isNull l then + if isNull r then + if op.IsEmpty then null + else Node(1uy, op) + else + let struct(r0, rr) = Node.unsafeRemoveMin r + match ArrOperation.TryMergeV(op, r0) with + | ValueSome op -> + binary null op rr + | ValueNone -> + if op.IsEmpty then r + else Node.binary null op r + + elif isNull r then + let struct(ln, ll) = Node.unsafeRemoveMax l + match ArrOperation.TryMergeV(ln, op) with + | ValueSome op -> + binary ll op null + | ValueNone -> + if op.IsEmpty then l + else Node.binary l op null + else + let struct(r0, rr) = Node.unsafeRemoveMin r + let struct(ln, ll) = Node.unsafeRemoveMax l + + match ArrOperation.TryMergeV(ln, op) with + | ValueSome op -> + match ArrOperation.TryMergeV(op, r0) with + | ValueSome op -> + binary ll op rr + | ValueNone -> + binary ll op r + | ValueNone -> + match ArrOperation.TryMergeV(op, r0) with + | ValueSome op -> + binary l op rr + | ValueNone -> + if op.IsEmpty then Node.join l r + else Node.binary l op r + + let rec insert (op : ArrOperation<'a>) (n : Node>) = + if op.IsEmpty then + n, true + else + if isNull n then + Node(1uy, op), true + + elif n.Height = 1uy then + match ArrOperation.TryMergeV(n.Value, op) with + | ValueSome res -> + if res.IsEmpty then null, true + else Node(1uy, res), true + | ValueNone -> + if op.Index < n.Value.Index then + Node(1uy, { n.Value with Index = n.Value.Index + op.Balance }), false + else + binary null n.Value (Node(1uy, op)), true + else + let n = n :?> Inner> + + if op.MaxIndex < n.Value.Index then + let r = Node.map (fun x -> { x with Index = x.Index + op.Balance }) n.Right + let s = { n.Value with Index = n.Value.Index + op.Balance } + let l, rest = insert op n.Left + binary l s r, rest + else + let r, rest = insert op n.Right + match rest with + | false -> + match ArrOperation.TryMergeV(n.Value, op) with + | ValueSome res -> + if res.IsEmpty then Node.join n.Left r, true + else binary n.Left res r, true + | ValueNone -> + if op.Index < n.Value.Index then + let l, rest = insert op n.Left + binary l { n.Value with Index = n.Value.Index + op.Balance } r, rest + else + let l, newRest = insert n.Value n.Left + binary l op r, newRest + | true -> + binary n.Left n.Value r, true + + + + + + + + + let combine (a : arrdelta<'a>) (b : arrdelta<'a>) : arrdelta<'a> = + let mutable res = a.Store + for op in b do + let r, rest = Node.insert op res + res <- + match rest with + | false -> + if op.IsEmpty then r + else Node.binary null op r + | true -> r + arrdelta res + // + // + // use mutable ea = a.GetEnumerator() + // use mutable eb = b.GetEnumerator() + // + // let mutable va = ea.MoveNext() + // let mutable vb = eb.MoveNext() + // + // let mutable abalance = 0 + // + // let mutable pending : option> = None + // let mutable final = Arr.empty + // + // let inline flush() = + // match pending with + // | Some last -> + // if last.Count > 0 || last.Elements.Length > 0 then final <- Arr.add last final + // pending <- None + // | None -> + // () + // + // let append c = + // match pending with + // | Some last -> + // + // + // if last.Index = c.Index then + // let n = { Index = last.Index; Count = last.Count + (c.Count - last.Elements.Length); Elements = arr (Node.join c.Elements.Store (Node.skip c.Count last.Elements.Store)) } + // pending <- Some n + // else + // let l = last.Index + // let h = last.Index + last.Elements.Length - 1 + // + // if c.Index = h + 1 then + // let newOp = + // { Index = last.Index; Count = last.Count + c.Count; Elements = arr(Node.join last.Elements.Store c.Elements.Store) } + // pending <- Some newOp + // + // elif c.Index >= l && c.Index <= h then + // let li = c.Index - l + // let remLocal = last.Elements.Length - li + // let remRest = c.Count - remLocal + // + // let newLastElements = last.Elements.ReplaceRange(li, remLocal, c.Elements) + // pending <- Some { Index = last.Index; Count = last.Count + remRest; Elements = newLastElements } + // + // else + // flush() + // pending <- Some c + // | None -> + // pending <- Some c + // + // while va && vb do + // let a0 = { ea.Current with Index = ea.Current.Index + abalance } + // let b0 = eb.Current + // + // if a0.Index <= b0.Index then + // append a0 + // va <- ea.MoveNext() + // else + // append b0 + // abalance <- abalance + b0.Balance + // vb <- eb.MoveNext() + // + // while va do + // let a0 = { ea.Current with Index = ea.Current.Index + abalance } + // append a0 + // va <- ea.MoveNext() + // + // while vb do + // let b0 = eb.Current + // append b0 + // vb <- eb.MoveNext() + // + // flush() + // + // arrdelta final + + let map (mapping : 'a -> 'b) (delta : arrdelta<'a>) = + delta.Store |> Node.map (fun op -> + { Index = op.Index; Count = op.Count; Elements = op.Elements |> Arr.map mapping } + ) |> arrdelta + + let mapOp (mapping : ArrOperation<'a> -> ArrOperation<'b>) (delta : arrdelta<'a>) = + delta.Store |> Node.map (fun op -> + mapping op + ) |> arrdelta + +[] +module ``ArrDelta Extensions`` = + + module Arr = + let computeDelta (cmp : System.Collections.Generic.IEqualityComparer<'a>) (src : arr<'a>) (dst : arr<'a>) : arrdelta<'a> = + let srcArr = Arr.toArray src + let dstArr = Arr.toArray dst + + let mutable steps = + if srcArr.Length = 0 && dstArr.Length = 0 then DeltaOperationList.DeltaOperationList.Empty + else DeltaOperationList.ofArrayMyersComparer cmp srcArr dstArr + + let mutable si = 0 + let mutable di = 0 + let mutable balance = 0 + let mutable delta = Arr.empty> + + while not steps.IsNil do + let struct(h, t) = steps.UnsafeUnconsV() + + match h with + | DeltaOperation.Equal -> + // step both => no delta + steps <- t + si <- si + 1 + di <- di + 1 + | _ -> + + let mutable remCnt = 0 + let mutable addCnt = 0 + let mutable struct(h, t) = steps.UnsafeUnconsV() + steps <- t + + while h <> DeltaOperation.Equal do + if h = DeltaOperation.Remove then remCnt <- remCnt + 1 + else addCnt <- addCnt + 1 + + if steps.IsNil then + h <- DeltaOperation.Equal + else + let struct(hh, tt) = steps.UnsafeUnconsV() + if hh <> DeltaOperation.Equal then + h <- hh + steps <- tt + else + h <- DeltaOperation.Equal + + + let op = { Index = si + balance; Count = remCnt; Elements = dst.Sub(di, addCnt) } + si <- si + remCnt + di <- di + addCnt + delta <- delta.Add(op) + balance <- balance + addCnt - remCnt + + arrdelta delta + + let applyDeltaAndGetEffective (cmp : System.Collections.Generic.IEqualityComparer<'a>) (state : arr<'a>) (delta : arrdelta<'a>) = + let mutable effective = ArrDelta.empty + let mutable res = state + for op in delta do + res <- + res.UpdateRange(op.Index, op.Count, fun old -> + let real = + computeDelta cmp old op.Elements + |> ArrDelta.mapOp (fun oo -> { oo with Index = oo.Index + op.Index }) + effective <- ArrDelta.combine effective real + op.Elements + ) + res, effective + + let applyDelta (state : arr<'a>) (delta : arrdelta<'a>) = + let mutable res = state + for op in delta do + res <- res.ReplaceRange(op.Index, op.Count, op.Elements) + res + \ No newline at end of file diff --git a/src/FSharp.Data.Adaptive/Datastructures/Deltas.fs b/src/FSharp.Data.Adaptive/Datastructures/Deltas.fs index 9fc3663..31a51e1 100644 --- a/src/FSharp.Data.Adaptive/Datastructures/Deltas.fs +++ b/src/FSharp.Data.Adaptive/Datastructures/Deltas.fs @@ -144,6 +144,80 @@ module ComputeListDeltaHelpers = result + /// inspired by this [paper](https://neil.fraser.name/writing/diff/myers.pdf) + let ofArrayMyersComparer (cmp : System.Collections.Generic.IEqualityComparer<'a>) (src : 'a[]) (dst : 'a[]) : DeltaOperationList = + let max = src.Length + dst.Length + let vs = Array.zeroCreate (2 * max + 1) + let ps = Array.zeroCreate vs.Length + + let inline setv (k : int) value = + vs.[k + max] <- value + + let inline getv (k : int) = + vs.[k + max] + + let inline setp (k : int) value = + ps.[k + max] <- value + + let inline getp (k : int) = + ps.[k + max] + + let mutable x = 0 + let mutable y = 0 + let mutable d = 0 + let mutable result = Unchecked.defaultof<_> + + let eSrc = src.Length - 1 + let eDst = dst.Length - 1 + + let inline equal x y = + // reversed arrays + cmp.Equals(src.[eSrc - x], dst.[eDst - y]) + + while d <= max do + let mutable k = -d + while k <= d do + let down = k = -d || (k <> d && getv (k-1) < getv (k+1)) + + let mutable p = Unchecked.defaultof<_> + if down then + x <- getv (k+1) + p <- getp (k+1) + else + x <- getv(k-1) + 1 + p <- getp(k-1) + + y <- x - k + let kPrev = if down then k + 1 else k - 1 + + let xStart = getv kPrev + let yStart = xStart - kPrev + + let xMid = if down then xStart else xStart + 1 + let yMid = xMid - k + + if xStart >= 0 && xMid <> xStart then p <- p.Prepend DeltaOperation.Remove + elif yStart >= 0 && yMid <> yStart then p <- p.Prepend DeltaOperation.Add + + while x < src.Length && y < dst.Length && equal x y do + x <- x + 1 + y <- y + 1 + p <- p.Prepend DeltaOperation.Equal + + setv k x + setp k p + if x >= src.Length && y >= dst.Length then + // terminate + result <- p + d <- max + k <- max + + k <- k + 2 + d <- d + 1 + + result + + /// Differentiation extensions for several immutable datastructures. diff --git a/src/FSharp.Data.Adaptive/Datastructures/HashCollections.fs b/src/FSharp.Data.Adaptive/Datastructures/HashCollections.fs index 12f5e92..124bd03 100644 --- a/src/FSharp.Data.Adaptive/Datastructures/HashCollections.fs +++ b/src/FSharp.Data.Adaptive/Datastructures/HashCollections.fs @@ -794,6 +794,29 @@ module internal HashImplementation = restDelta struct(result, state) + + let rec mapDelta + (cmp : IEqualityComparer<'K>) + (apply : OptimizedClosures.FSharpFunc<'K, voption<'V>, 'D, voption<'DOut>>) + (mapping : OptimizedClosures.FSharpFunc<'K, 'D, voption<'DOut>>) + (delta : MapLinked<'K, 'D>) + (state : MapLinked<'K, 'V>) = + + if isNull state then + chooseV mapping delta + elif isNull delta then + null + else + let struct(wasExisting, st) = tryRemove cmp delta.Key state + let op = apply.Invoke(delta.Key, wasExisting, delta.Value) + let restDelta = mapDelta cmp apply mapping delta.MapNext st + + match op with + | ValueSome op -> + MapLinked(delta.Key, op, restDelta) + | ValueNone -> + restDelta + module SetNode = @@ -2950,6 +2973,117 @@ module internal HashImplementation = struct(result, state) + + let rec mapDelta + (cmp : IEqualityComparer<'K>) + (apply : OptimizedClosures.FSharpFunc<'K, voption<'V>, 'D, voption<'DOut>>) + (mapping : OptimizedClosures.FSharpFunc<'K, 'D, voption<'DOut>>) + (state : SetNode<'K>) + (delta : SetNode<'K>) = + + if isNull delta then + null + + elif isNull state then + chooseV mapping delta + + elif delta.IsLeaf then + let d = delta :?> MapLeaf<'K, 'D> + if state.IsLeaf then + let s = state :?> MapLeaf<'K, 'V> + if s.Hash = d.Hash then + // TODO: avoid allocating Linkeds here + let lstate = MapLinked(s.Key, s.Value, s.MapNext) + let ldelta = MapLinked(d.Key, d.Value, d.MapNext) + let ldelta = MapLinked.mapDelta cmp apply mapping ldelta lstate + + if isNull ldelta then null + else MapLeaf(d.Hash, ldelta.Key, ldelta.Value, ldelta.MapNext) :> SetNode<_> + else + chooseV mapping delta + + else + // delta in state + let s = state :?> Inner<'K> + match matchPrefixAndGetBit d.Hash s.Prefix s.Mask with + | 0u -> + let l = s.Left + mapDelta cmp apply mapping l delta + | 1u -> + let r = s.Right + mapDelta cmp apply mapping r delta + | _ -> + chooseV mapping delta + + elif state.IsLeaf then + // state in delta + let s = state :?> MapLeaf<'K, 'V> + let d = delta :?> Inner<'K> + + match matchPrefixAndGetBit s.Hash d.Prefix d.Mask with + | 0u -> + let ls = state + let rs = null + let ld = mapDelta cmp apply mapping ls d.Left + let rd = mapDelta cmp apply mapping rs d.Right + newInner d.Prefix d.Mask ld rd + | 1u -> + let ls = null + let rs = state + let ld = mapDelta cmp apply mapping ls d.Left + let rd = mapDelta cmp apply mapping rs d.Right + newInner d.Prefix d.Mask ld rd + | _ -> + chooseV mapping delta + + + else + let d = delta :?> Inner<'K> + let s = state :?> Inner<'K> + + let cc = compareMasks d.Mask s.Mask + if cc > 0 then + // delta in state + match matchPrefixAndGetBit d.Prefix s.Prefix s.Mask with + | 0u -> + let l = s.Left + mapDelta cmp apply mapping l delta + | 1u -> + let r = s.Right + mapDelta cmp apply mapping r delta + | _ -> + chooseV mapping delta + + elif cc < 0 then + // state in delta + match matchPrefixAndGetBit s.Prefix d.Prefix d.Mask with + | 0u -> + let ls = state + let rs = null + let ld = mapDelta cmp apply mapping ls d.Left + let rd = mapDelta cmp apply mapping rs d.Right + newInner d.Prefix d.Mask ld rd + | 1u -> + let ls = null + let rs = state + let ld = mapDelta cmp apply mapping ls d.Left + let rd = mapDelta cmp apply mapping rs d.Right + newInner d.Prefix d.Mask ld rd + | _ -> + chooseV mapping delta + + elif s.Prefix = d.Prefix then + let ls = s.Left + let rs = s.Right + let ld = mapDelta cmp apply mapping ls d.Left + let rd = mapDelta cmp apply mapping rs d.Right + newInner d.Prefix d.Mask ld rd + + else + chooseV mapping delta + + + open HashImplementation [] @@ -3690,6 +3824,15 @@ and [(a.Comparer, delta) state, delta + [] + static member MapDelta(a : HashMap<'K, 'V>, b : HashMap<'K, 'T>, mapping : 'K -> voption<'V> -> 'T -> voption<'U>) = + let mapping = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt mapping + let mapNoState = OptimizedClosures.FSharpFunc<_,_,_>.Adapt (fun k op -> mapping.Invoke(k, ValueNone, op)) + let state = a.Root + let delta = MapNode.mapDelta a.Comparer mapping mapNoState state b.Root + let delta = HashMap<'K, 'U>(a.Comparer, delta) + delta + [] member x.Choose2V(other : HashMap<'K, 'T>, mapping : 'K -> voption<'V> -> voption<'T> -> voption<'U>) = let mapping = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt mapping diff --git a/src/FSharp.Data.Adaptive/Datastructures/IndexList.fs b/src/FSharp.Data.Adaptive/Datastructures/IndexList.fs index 9fb9251..74f738e 100644 --- a/src/FSharp.Data.Adaptive/Datastructures/IndexList.fs +++ b/src/FSharp.Data.Adaptive/Datastructures/IndexList.fs @@ -286,21 +286,19 @@ type IndexList< [] 'T> internal(l : Index, h : Index, con /// Applies the mapping function to all elements of the list and returns a new list containing all Some entries. member x.Choose(mapping : Index -> 'T -> option<'T2>) = - let res = MapExt.choose mapping content + let res, imin, imax = content.ChooseWithMinMax(mapping) if res.IsEmpty then IndexList.Empty else - // TODO: min/max could be maintained during mapping - IndexList(res.GetMinKey(), res.GetMaxKey(), res) + IndexList(imin, imax, res) /// Filters the list using the given predicate. member x.Filter(predicate : Index -> 'T -> bool) = - let res = MapExt.filter predicate content + let res, imin, imax = content.FilterWithMinMax predicate if res.IsEmpty then IndexList.Empty else - // TODO: min/max could be maintained during mapping - IndexList(res.GetMinKey(), res.GetMaxKey(), res) + IndexList(imin, imax, res) /// Tries to find the smallest index for the given element. member x.TryFind(element : 'T) : option = diff --git a/src/FSharp.Data.Adaptive/Datastructures/MapExt.fs b/src/FSharp.Data.Adaptive/Datastructures/MapExt.fs index 93e9ec5..b15b419 100644 --- a/src/FSharp.Data.Adaptive/Datastructures/MapExt.fs +++ b/src/FSharp.Data.Adaptive/Datastructures/MapExt.fs @@ -816,7 +816,6 @@ module internal MapExtImplementation = | None -> unsafeJoin node.Left node.Right - let rec copyToV (array : struct('Key * 'Value)[]) (index : int) (node : Node<'Key, 'Value>) = if isNull node then index @@ -1061,6 +1060,31 @@ module internal MapExtImplementation = | Some s -> binary l node.Key s r | None -> join l r + let rec chooseWithMinMax (mapping : OptimizedClosures.FSharpFunc<'Key, 'Value, option<'T>>) (node : Node<'Key, 'Value>) = + if isNull node then + null, Unchecked.defaultof<'Key>, Unchecked.defaultof<'Key> + elif node.Height = 1uy then + match mapping.Invoke(node.Key, node.Value) with + | Some v -> Node(node.Key, v), node.Key, node.Key + | None -> null, Unchecked.defaultof<'Key>, Unchecked.defaultof<'Key> + else + let node = node :?> Inner<'Key, 'Value> + let l, lmin, lmax = chooseWithMinMax mapping node.Left + let s = mapping.Invoke(node.Key, node.Value) + let r, rmin, rmax = chooseWithMinMax mapping node.Right + match s with + | Some s -> + let min = if not (isNull l) then lmin else node.Key + let max = if not (isNull r) then rmax else node.Key + binary l node.Key s r, min, max + | None -> + if isNull l then + r, rmin, rmax + elif isNull r then + l, lmin, lmax + else + join l r, lmin, rmax + let rec filter (predicate : OptimizedClosures.FSharpFunc<'Key, 'Value, bool>) (node : Node<'Key, 'Value>) = if isNull node then null @@ -1076,6 +1100,31 @@ module internal MapExtImplementation = let r = filter predicate node.Right if s then binary l node.Key node.Value r else join l r + + let rec filterWithMinMax (predicate : OptimizedClosures.FSharpFunc<'Key, 'Value, bool>) (node : Node<'Key, 'Value>) = + if isNull node then + null, Unchecked.defaultof<'Key>, Unchecked.defaultof<'Key> + elif node.Height = 1uy then + if predicate.Invoke(node.Key, node.Value) then + node, node.Key, node.Key + else + null, Unchecked.defaultof<'Key>, Unchecked.defaultof<'Key> + else + let node = node :?> Inner<'Key, 'Value> + let l, lmin, lmax = filterWithMinMax predicate node.Left + let s = predicate.Invoke(node.Key, node.Value) + let r, rmin, rmax = filterWithMinMax predicate node.Right + if s then + let min = if not (isNull l) then lmin else node.Key + let max = if not (isNull r) then rmax else node.Key + binary l node.Key node.Value r, min, max + else + if isNull l then + r, rmin, rmax + elif isNull r then + l, lmin, lmax + else + join l r, lmin, rmax let rec tryPickBack (mapping : OptimizedClosures.FSharpFunc<'Key, 'Value, option<'T>>) (node : Node<'Key, 'Value>) = if isNull node then @@ -3318,10 +3367,20 @@ type internal MapExt<'Key, 'Value when 'Key : comparison>(comparer : IComparer<' let mapping = OptimizedClosures.FSharpFunc<_,_,_>.Adapt mapping MapExt(comparer, MapExtImplementation.choose mapping root) + member x.ChooseWithMinMax(mapping : 'Key -> 'Value -> option<'T>) = + let mapping = OptimizedClosures.FSharpFunc<_,_,_>.Adapt mapping + let r, kmin, kmax = MapExtImplementation.chooseWithMinMax mapping root + MapExt(comparer, r), kmin, kmax + member x.Filter(predicate : 'Key -> 'Value -> bool) = let predicate = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate MapExt(comparer, MapExtImplementation.filter predicate root) + member x.FilterWithMinMax(predicate : 'Key -> 'Value -> bool) = + let mapping = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate + let r, kmin, kmax = MapExtImplementation.filterWithMinMax mapping root + MapExt(comparer, r), kmin, kmax + member x.TryPick(mapping : 'Key -> 'Value -> option<'T>) = let mapping = OptimizedClosures.FSharpFunc<_,_,_>.Adapt mapping MapExtImplementation.tryPick mapping root diff --git a/src/FSharp.Data.Adaptive/FSharp.Data.Adaptive.fsproj b/src/FSharp.Data.Adaptive/FSharp.Data.Adaptive.fsproj index a8c0ef0..98404f1 100644 --- a/src/FSharp.Data.Adaptive/FSharp.Data.Adaptive.fsproj +++ b/src/FSharp.Data.Adaptive/FSharp.Data.Adaptive.fsproj @@ -2,7 +2,7 @@ Library - netstandard2.0;net5.0;net6.0 + netstandard2.0;net6.0 true link @@ -44,6 +44,8 @@ + + @@ -74,6 +76,10 @@ + + + + diff --git a/src/FSharp.Data.Adaptive/Traceable/Instances.fs b/src/FSharp.Data.Adaptive/Traceable/Instances.fs index a23b510..1e152e9 100644 --- a/src/FSharp.Data.Adaptive/Traceable/Instances.fs +++ b/src/FSharp.Data.Adaptive/Traceable/Instances.fs @@ -107,3 +107,57 @@ module IndexList = /// The traceable instance for HashSet. let trace<'T> = Traceable<'T>.Instance + +module ArrDelta = + [] + let monoid<'a> : Monoid> = + { + mempty = ArrDelta.empty + misEmpty = ArrDelta.isEmpty + mappend = ArrDelta.combine + } + + +module Arr = + /// Type for caching the Traceable<_> instance for IndexList<_> + type private Traceable<'T> private() = + static let trace : Traceable, arrdelta<'T>> = + { + tempty = Arr.empty + tcomputeDelta = Arr.computeDelta DefaultEqualityComparer.Instance + tapplyDelta = Arr.applyDeltaAndGetEffective DefaultEqualityComparer.Instance + tmonoid = ArrDelta.monoid + tsize = fun _ -> 0 + tprune = None + } + static member Instance = trace + + + [] + let trace<'a> = Traceable<'a>.Instance + + let private traceCache = System.Collections.Generic.Dictionary() + + let getTrace (cmp : System.Collections.Generic.IEqualityComparer<'T>) = + lock traceCache (fun () -> + match traceCache.TryGetValue cmp with + | (true, (:? Traceable, arrdelta<'T>> as traceable)) -> + traceable + | _ -> + let traceable = + { + tempty = Arr.empty + tcomputeDelta = Arr.computeDelta cmp + tapplyDelta = fun m d -> Arr.applyDeltaAndGetEffective cmp m d + tmonoid = ArrDelta.monoid + tsize = fun _ -> 0 + tprune = None + } + traceCache.[cmp] <- traceable + traceable + ) + + + + + diff --git a/src/Test/FSharp.Data.Adaptive.Reference/AdaptiveArray.fs b/src/Test/FSharp.Data.Adaptive.Reference/AdaptiveArray.fs new file mode 100644 index 0000000..f8da6e4 --- /dev/null +++ b/src/Test/FSharp.Data.Adaptive.Reference/AdaptiveArray.fs @@ -0,0 +1,100 @@ +namespace FSharp.Data.Adaptive.Reference + +open FSharp.Data.Adaptive +open FSharp.Data.Adaptive.Reference + +/// The reference implementation for IIndexListReader. +type IArrayReader<'T> = FSharp.Data.Adaptive.Reference.IOpReader, arrdelta<'T>> + +/// The reference implementation for alist. +type IAdaptiveArray<'T> = + abstract member GetReader: unit -> IArrayReader<'T> + abstract member Content: FSharp.Data.Adaptive.Reference.aval> + +and aarr<'T> = IAdaptiveArray<'T> + +/// A simple reader using computeDelta for getting deltas. +type internal AArrReader<'T>(list: aarr<'T>) = + + let mutable last = Arr.empty + + member x.State = + last + + member x.GetChanges(t : FSharp.Data.Adaptive.Reference.AdaptiveToken) = + let c = list.Content.GetValue t + let ops = Arr.computeDelta DefaultEqualityComparer.Instance last c + last <- c + ops + + interface IOpReader> with + member x.GetChanges t = x.GetChanges t + + interface IOpReader, arrdelta<'T>> with + member x.State = x.State + + +/// A reference implementation for clist. +type ChangeableArray<'T>(value: arr<'T>) = + let mutable content = value + + // the current content as aval<_> + let contentRef = + { new aval> with + member x.GetValue _ = content + } + + /// Gets or sets the current immutable state of the set. + member x.Value + with get() = content + and set v = content <- v + + interface IAdaptiveArray<'T> with + member x.Content = contentRef + member x.GetReader() = AArrReader(x) :> IArrayReader<_> + + /// Creates a new empty cset. + new() = carr<'T>(IndexList.empty) + + /// Creates a new cset with all the given values. + new(es: seq<'T>) = carr(IndexList.ofSeq es) + +and carr<'T> = ChangeableArray<'T> + + +/// Functional operators for the alist reference-implementation. +module AArr = + + /// Creates an alist from the given aval. + let internal ofRef (r: aval>) = + { new aarr<'T> with + member x.Content = r + member x.GetReader() = AArrReader(x) :> IArrayReader<_> + } + + /// The empty alist. + let empty<'T> = ofRef (AVal.constant Arr.empty<'T>) + + /// A constant alist containing a single value + let single (value: 'T) = ofRef (AVal.constant (Arr.single value)) + + /// Creates a constant alist from the given values. + let ofSeq (values: seq<'T>) = ofRef (AVal.constant (Arr.ofSeq values)) + + /// Creates a constant alist from the given values. + let ofList (values: list<'T>) = ofRef (AVal.constant (Arr.ofList values)) + + /// Creates a constant alist from the given values. + let ofArray (values: array<'T>) = ofRef (AVal.constant (Arr.ofArray values)) + + /// Creates a constant alist from the given values. + let ofArr (values: arr<'T>) = ofRef (AVal.constant values) + + let map (mapping: 'T1 -> 'T2) (list: aarr<'T1>) = + list.Content |> AVal.map (Arr.map mapping) |> ofRef + + let choose (mapping: 'T1 -> option<'T2>) (list: aarr<'T1>) = + list.Content |> AVal.map (Arr.choose mapping) |> ofRef + + let collect (mapping: 'T1 -> aarr<'T2>) (list: aarr<'T1>) = + list.Content |> AVal.map (Arr.collect (fun v -> mapping(v).Content.GetValue(AdaptiveToken.Top))) |> ofRef \ No newline at end of file diff --git a/src/Test/FSharp.Data.Adaptive.Reference/FSharp.Data.Adaptive.Reference.fsproj b/src/Test/FSharp.Data.Adaptive.Reference/FSharp.Data.Adaptive.Reference.fsproj index 3c379bb..628e644 100644 --- a/src/Test/FSharp.Data.Adaptive.Reference/FSharp.Data.Adaptive.Reference.fsproj +++ b/src/Test/FSharp.Data.Adaptive.Reference/FSharp.Data.Adaptive.Reference.fsproj @@ -16,6 +16,7 @@ + diff --git a/src/Test/FSharp.Data.Adaptive.Tests/AArr.fs b/src/Test/FSharp.Data.Adaptive.Tests/AArr.fs new file mode 100644 index 0000000..a5d452e --- /dev/null +++ b/src/Test/FSharp.Data.Adaptive.Tests/AArr.fs @@ -0,0 +1,194 @@ +module AArr + +open NUnit.Framework +open FsCheck +open FSharp.Data.Adaptive +open FSharp.Data.Traceable +open FsUnit +open FsCheck.NUnit +open FSharp.Data +open Generators + + +[ |]); Timeout(60000)>] +let ``[AArr] reference impl``() ({ areal = real; aref = ref; aexpression = str; achanges = changes } : VArr) = + printfn "VALIDATE" + + + let str b = + let m, str = str b + String.concat "\r\n" [ + for (k,v) in Map.toSeq m do + yield sprintf "let %s = %s" k v + yield str + ] + + printfn "%s" (Generators.Generators.indent (Generators.Generators.indent (str false))) + let r = real.GetReader() + + let check (beforeChangeStr : string) (beforeChange : list) (latestChanges : list) = + r.GetChanges AdaptiveToken.Top |> ignore + let vReal = real.Content.GetValue AdaptiveToken.Top + let vRef = ref.Content.GetValue Reference.AdaptiveToken.Top + + let lReal = Arr.toArray vReal + let lRef = Arr.toArray vRef + + let equal = + lReal.Length = lRef.Length && + (lReal, lRef) ||> Array.forall2 (=) + + if equal then + vRef + else + let real = vReal |> Seq.map string |> String.concat "; " |> sprintf "[%s]" + let ref = vRef |> Seq.map string |> String.concat "; " |> sprintf "[%s]" + + let inputs = changes() |> List.map (fun i -> i.cell) + + let message = + String.concat "\r\n" [ + yield "ERROR" + yield "BEFORE" + //yield! beforeChangeStr.Split("\r\n") |> Array.map Generators.indent + + yield "CURRENT" + yield! (str true).Split([|"\r\n"|], System.StringSplitOptions.None) |> Array.map Generators.indent + + yield sprintf "real: %s" real + yield sprintf "ref: %s" ref + + yield "before" + for i in beforeChange do + yield sprintf " %A" i + + //yield "inputs" + //for i in inputs do + // yield sprintf " %A" i + + //yield "latest changes" + //for c in latestChanges do + // yield " " + c + ] + failwith message + //printfn " VALUE => %A" vRef + + let mutable lastValue = check "" [] [] + + let run = + gen { + let mutable effective = 0 + + while effective < 20 do + let all = changes() + match all with + | [] -> + effective <- System.Int32.MaxValue + | _ -> + let! some = + all + |> List.map (fun g -> g.change) + |> Gen.subListOf + |> Gen.filter (List.isEmpty >> not) + + let beforeChange = + all |> List.map (fun c -> c.cell |> string) + + let beforeChangeStr = str true + let! changeAll = Gen.collect id some + let latestChange = + transact (fun () -> + changeAll |> List.map (fun c -> c()) + ) + let v = check beforeChangeStr beforeChange latestChange + if not (DefaultEquality.equals v lastValue) then + + printfn " change %d => %A" effective v + lastValue <- v + + + + effective <- effective + 1 + } + + Gen.eval 15 (Random.newSeed()) run + +[] +let ``[CArr] Value`` ((NonEmptyArray things) : NonEmptyArray>) = + let (NonEmptyArray v0) = things.[0] + + let mutable value = Arr.ofArray v0 + let test = carr value + test.Value |> should equal value + + for i in 1 .. things.Length - 1 do + let (NonEmptyArray v0) = things.[i] + value <- Arr.ofArray v0 + transact(fun () -> test.Value <- value) + test.Value |> should equal value + +[] +let ``[CArr] Add`` (NonEmptyArray (things : int[])) (NonEmptyArray (adds : int[]))= + + let reff = System.Collections.Generic.List things + let res = carr things + + for a in adds do + reff.Add a + res.Add a + reff |> Seq.toList |> should equal (Seq.toList res.Value) + +[] +let ``[CArr] Insert`` (NonEmptyArray (things : int[])) (NonEmptyArray (inserts : (uint32 * int)[]))= + + let reff = System.Collections.Generic.List things + let res = carr things + + for (i, a) in inserts do + let i = int (i % (uint32 reff.Count + 1u)) + reff.Insert(i, a) + res.Insert(i, a) + reff |> Seq.toList |> should equal (Seq.toList res.Value) + + +[] +let ``[CArr] Set`` (NonEmptyArray (things : int[])) (NonEmptyArray (updates : (uint32 * int)[]))= + + let reff = System.Collections.Generic.List things + let res = carr things + + for (i, a) in updates do + let i = int (i % (uint32 reff.Count)) + reff.[i] <- a + res.[i] <- a + reff |> Seq.toList |> should equal (Seq.toList res.Value) + + +[] +let ``[CArr] RemoveAt`` (NonEmptyArray (things : int[])) (NonEmptyArray (removes : uint32[]))= + + let reff = System.Collections.Generic.List things + let res = carr things + + for i in removes do + if reff.Count = 0 then + reff.Add (int i) + res.Add (int i) + else + let i = int (i % (uint32 reff.Count)) + reff.RemoveAt i + res.RemoveAt i + reff |> Seq.toList |> should equal (Seq.toList res.Value) + + +[] +let ``[CArr] Clear`` (NonEmptyArray (things : int[])) = + + let reff = System.Collections.Generic.List things + let res = carr things + + reff |> Seq.toList |> should equal (Seq.toList res.Value) + res.Clear() + reff.Clear() + reff |> Seq.toList |> should equal (Seq.toList res.Value) + diff --git a/src/Test/FSharp.Data.Adaptive.Tests/Arr.fs b/src/Test/FSharp.Data.Adaptive.Tests/Arr.fs new file mode 100644 index 0000000..c82f469 --- /dev/null +++ b/src/Test/FSharp.Data.Adaptive.Tests/Arr.fs @@ -0,0 +1,791 @@ +module Arr + +open System +open NUnit.Framework +open FsUnit +open FsCheck +open FsCheck.NUnit +open FSharp.Data.Adaptive +open FSharp.Data.Traceable + +[] +let ``[Arr] empty`` () = + let a = Arr.empty + a.Length |> should equal 0 + a.IsEmpty |> should equal true + a |> Seq.toList |> should equal List.empty + +[] +let ``[Arr] single`` () = + let a = Arr.single 5 + a.Length |> should equal 1 + a.IsEmpty |> should equal false + a |> Seq.toList |> should equal [5] + + +[] +let ``[Arr] ofSeq`` (input : list) = + let a = Arr.ofSeq input + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] ofList`` (input : list) = + let a = Arr.ofList input + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] ofArray`` (input : list) = + let a = Arr.ofArray (List.toArray input) + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] fromReadonlySpan`` (input : list) = + let array = List.toArray input + let a = arr.FromSpan (System.ReadOnlySpan(array)) + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] fromSpan`` (input : list) = + let array = List.toArray input + let a = arr.FromSpan (System.Span(array)) + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] fromMemory`` (input : list) = + let array = List.toArray input + let a = arr.FromMemory (System.Memory(array)) + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] fromReadonlyMemory`` (input : list) = + let array = List.toArray input + let a = arr.FromMemory (System.ReadOnlyMemory(array)) + a.Length |> should equal input.Length + a |> Seq.toList |> should equal input + +[] +let ``[Arr] insert`` (input : list) (pos : uint32) = + + let idx = int (pos % uint32 (input.Length + 1)) + let value = 7654321 + let res = Arr.ofList input |> Arr.insert idx value + + let ref = + if idx <= 0 then + value :: input + elif idx >= input.Length then + List.append input [value] + else + List.indexed input |> List.collect (fun (i, v) -> + if i = idx then [value; v] + else [v] + ) + + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] set`` (NonEmptyArray (input : int[])) (pos : uint32) = + + let idx = int (pos % uint32 input.Length) + let value = 7654321 + let res = Arr.ofArray input |> Arr.set idx value + + let ref = + Array.indexed input |> Array.map (fun (i, v) -> + if i = idx then value + else v + ) |> Array.toList + + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] add`` (input : list) (value : int) = + let a = Arr.ofList input + + let res = Arr.add value a + let ref = List.append input [value] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] append`` (input : list) (value : int) = + let a = Arr.ofList input + + let res = Arr.append value a + let ref = List.append input [value] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] prepend`` (input : list) (value : int) = + let a = Arr.ofList input + + let res = Arr.prepend value a + let ref = value :: input + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] concat`` (input : list>) = + let a = input |> List.map Arr.ofList |> Arr.ofList + + let res = Arr.concat a + let ref = List.concat input + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + + +[] +let ``[Arr] take`` (input : list) (n : int) = + let a = Arr.ofList input + let n = abs n + let res = a |> Arr.take n + let ref = input |> List.truncate n + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] skip`` (input : list) (n : int) = + let a = Arr.ofList input + let n = abs n + let res = a |> Arr.skip n + let ref = + try input |> List.skip n + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + + +[] +let ``[Arr] sub`` (NonEmptyArray (arr : int[])) (pos : uint32) (cnt : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + let cnt = int (cnt % uint32 (input.Length - idx)) + + let a = Arr.ofList input + let res = a |> Arr.sub idx cnt + let ref = + try input |> List.skip idx |> List.truncate cnt + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] slice (minmax)`` (NonEmptyArray (arr : int[])) (pos : uint32) (cnt : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + let cnt = int (cnt % uint32 (input.Length - idx)) + + let a = Arr.ofList input + let res = a.[idx .. idx + cnt - 1] + let ref = + try input.[idx .. idx + cnt - 1] + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] slice (min)`` (NonEmptyArray (arr : int[])) (pos : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + + let a = Arr.ofList input + let res = a.[idx .. ] + let ref = + try input.[idx .. ] + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] slice (max)`` (NonEmptyArray (arr : int[])) (pos : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + + let a = Arr.ofList input + let res = a.[ .. idx] + let ref = + try input.[ .. idx] + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] slice (empty)`` (NonEmptyArray (arr : int[])) = + let input = List.ofArray arr + + let a = Arr.ofList input + let res = a.[*] + let ref = + try input.[*] + with _ -> [] + + res.Length |> should equal ref.Length + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] split`` (NonEmptyArray (arr : int[])) (pos : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + + let a = Arr.ofList input + let resa, resb = a |> Arr.split idx + let refa = List.take idx input + let refb = List.skip idx input + + resa.Length |> should equal refa.Length + resb.Length |> should equal refb.Length + resa |> Seq.toList |> should equal refa + resb |> Seq.toList |> should equal refb + +[] +let ``[Arr] uncons`` (NonEmptyArray (arr : int[])) = + let input = Array.toList arr + let arr = Arr.ofList input + let (a, rest) = Arr.uncons arr + a |> should equal (List.head input) + rest |> Seq.toList |> should equal (List.tail input) + +[] +let ``[Arr] item`` (NonEmptyArray (input : int[])) (pos : uint32) = + let input = Array.toList input + let idx = int (pos % uint32 input.Length) + let arr = Arr.ofList input + arr.[idx] |> should equal input.[idx] + +[] +let ``[Arr] map`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.map ((+) 1) + let ref = input |> List.map ((+) 1) + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] mapi`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.mapi (fun i v -> i + v) + let ref = input |> List.mapi (fun i v -> i + v) + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] choose`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.choose (fun v -> if v % 3 = 0 then Some v else None) + let ref = input |> List.choose (fun v -> if v % 3 = 0 then Some v else None) + res |> Seq.toList |> should equal ref + + +[] +let ``[Arr] choosei`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.choosei (fun i v -> if v % 3 = 0 then Some (i, v) else None) + let ref = input |> List.indexed |> List.choose (fun (i, v) -> if v % 3 = 0 then Some (i, v) else None) + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] filter`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.filter (fun v -> v % 3 = 0) + let ref = input |> List.filter (fun v -> v % 3 = 0) + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] filteri`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.filteri (fun i v -> v % 3 = 0 || i % 2 = 0) + let ref = input |> List.indexed |> List.filter (fun (i, v) -> v % 3 = 0 || i % 2 = 0) |> List.map snd + res |> Seq.toList |> should equal ref + +[] +let ``[Arr] partition`` (input : list) = + let arr = Arr.ofList input + let res1, res2 = arr |> Arr.partition (fun v -> v % 3 = 0) + let ref1, ref2 = input |> List.partition (fun v -> v % 3 = 0) + res1 |> Seq.toList |> should equal ref1 + res2 |> Seq.toList |> should equal ref2 + + +[] +let ``[Arr] collect`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.collect (fun v -> Arr.ofList [v; v*2]) + let ref = input |> List.collect (fun v -> [v; v*2]) + res |> Seq.toList |> should equal ref + + +[] +let ``[Arr] collecti`` (input : list) = + let arr = Arr.ofList input + let res = arr |> Arr.collecti (fun i v -> Arr.ofList [i; v; v*2]) + let ref = input |> List.indexed |> List.collect (fun (i, v) -> [i; v; v*2]) + res |> Seq.toList |> should equal ref + + +[] +let ``[Arr] iter`` (input : list) = + let arr = Arr.ofList input + + let mutable res = FSharp.Core.CompilerServices.ListCollector() + + arr |> Arr.iter (fun v -> res.Add (v*2)) + let ref = input |> List.map (fun v -> v*2) + res.Close() |> should equal ref + +[] +let ``[Arr] iteri`` (input : list) = + let arr = Arr.ofList input + + let mutable res = FSharp.Core.CompilerServices.ListCollector() + + arr |> Arr.iteri (fun i v -> res.Add (i, v*2)) + let ref = input |> List.mapi (fun i v -> i, v*2) + res.Close() |> should equal ref + + + +[] +let ``[Arr] removeRange`` (NonEmptyArray (arr : int[])) (pos : uint32) (cnt : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + let cnt = int (cnt % uint32 (input.Length - idx)) + + let arr = Arr.ofList input + + let rec removeRange (l : list<'a>) = + let mutable res = FSharp.Core.CompilerServices.ListCollector() + let mutable i = 0 + for e in l do + if i < idx || i >= idx + cnt then + res.Add e + i <- i + 1 + res.Close() + + arr.RemoveRange(idx, cnt) + |> Seq.toList + |> should equal (removeRange input) + + +[] +let ``[Arr] replaceRange`` (NonEmptyArray (arr : int[])) (NonEmptyArray (repl : int[])) (pos : uint32) (cnt : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + let cnt = int (cnt % uint32 (input.Length - idx)) + + let arr = Arr.ofList input + let repl = Array.toList repl + + let rec replaceRange (l : list) = + if idx = l.Length then + List.append l repl + else + let mutable res = FSharp.Core.CompilerServices.ListCollector() + let mutable i = 0 + for e in l do + if i = idx then + for ee in repl do res.Add ee + + if i < idx || i >= idx + cnt then + res.Add e + + i <- i + 1 + res.Close() + + let res = arr.ReplaceRange(idx, cnt, Arr.ofList repl) + let reff = replaceRange input + + res.Length |> should equal (arr.Length - cnt + repl.Length) + + let resl = res |> Seq.toList + + resl |> should equal reff + + +[] +let ``[Arr] updateRange`` (NonEmptyArray (arr : int[])) (pos : uint32) (cnt : uint32) = + let input = List.ofArray arr + let idx = int (pos % uint32 input.Length) + let cnt = int (cnt % uint32 (input.Length - idx)) + + let arr = Arr.ofList input + //let repl = Array.toList repl + + let mutable last = [] + + let mappingList (l : list) = + last <- l + [1] @ (List.map ((+) 1) l) @ [2;3] + + let mappingArr (l : arr) = + l |> Arr.toList |> should equal last + Arr.prepend 1 (Arr.map ((+)1) l) |> Arr.append 2 |> Arr.append 3 + + let rec updateRange (mapping : list -> list) (l : list) = + if idx = l.Length then + List.append l (mapping []) + else + let repl = mapping l.[idx .. idx + cnt - 1] + let mutable res = FSharp.Core.CompilerServices.ListCollector() + let mutable i = 0 + for e in l do + if i = idx then + for ee in repl do res.Add ee + + if i < idx || i >= idx + cnt then + res.Add e + + i <- i + 1 + res.Close() + + let reff = updateRange mappingList input + let res = arr.UpdateRange(idx, cnt, mappingArr) + + let resl = res |> Seq.toList + resl |> should equal reff + + +[] +let ``[Arr] toList`` (input : list) = + let mutable res = Arr.empty + for e in input do res <- res.Add e + res |> Arr.toList |> should equal input + +[] +let ``[Arr] toArray`` (input : list) = + let mutable res = Arr.empty + for e in input do res <- res.Add e + res |> Arr.toArray |> Array.toList |> should equal input + +[] +let ``[Arr] toSeq`` (input : list) = + let mutable res = Arr.empty + for e in input do res <- res.Add e + res |> Arr.toSeq |> Seq.toList |> should equal input + +[] +let ``[Arr] asSeq`` (input : list) = + let mutable res = Arr.empty + for e in input do res <- res.Add e + res |> Seq.toList |> should equal input + +[] +let ``[Arr] fold`` (input : list) = + let input = input |> List.map (function NonEmptyString str -> str) + let arr = Arr.ofList input + + let res = arr |> Arr.fold (+) "123" + let reff = input |> List.fold (+) "123" + res |> should equal reff + +[] +let ``[Arr] foldBack`` (input : list) = + let input = input |> List.map (function NonEmptyString str -> str) + let arr = Arr.ofList input + + let res = Arr.foldBack (+) arr "123" + let reff = List.foldBack (+) input "123" + res |> should equal reff + +[] +let ``[Arr] init`` (cnt : uint32) = + let reff = List.init (int cnt % 5000) id + let res = Arr.init (int cnt % 5000) id + res |> Arr.toList |> should equal reff + +[] +let ``[Arr] tryItem`` (cnt : uint32) = + let count = int (cnt % 5000u) + let idx = int (cnt % uint32 (max 1 count)) + let res = Arr.init (int cnt % 5000) id + let reff = + if idx >= 0 && idx < res.Length then Some idx + else None + + res |> Arr.tryItem idx |> should equal reff + +[] +let ``[Arr] exists`` (NonEmptyArray list) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.exists (fun v -> v % 7 = 0) + let reff = list |> List.exists (fun v -> v % 7 = 0) + res |> should equal reff + +[] +let ``[Arr] forall`` (NonEmptyArray list) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.forall (fun v -> v % 3 = 0) + let reff = list |> List.forall (fun v -> v % 3 = 0) + res |> should equal reff + + +[] +let ``[Arr] pairwise`` (NonEmptyArray (list : array)) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.pairwise + let reff = list |> List.pairwise + res |> Arr.toList |> should equal reff + +[] +let ``[Arr] rev`` (NonEmptyArray (list : array)) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.rev + let reff = list |> List.rev + res |> Arr.toList |> should equal reff + + +[] +let ``[Arr] tryPick`` (NonEmptyArray list) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.tryPick (fun v -> if v % 7 = 0 then Some v else None) + let reff = list |> List.tryPick (fun v -> if v % 7 = 0 then Some v else None) + res |> should equal reff + + +[] +let ``[Arr] tryPickV`` (NonEmptyArray list) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.tryPickV (fun v -> if v % 7 = 0 then ValueSome v else ValueNone) + let reff = list |> List.tryPick (fun v -> if v % 7 = 0 then Some v else None) + let res = + match res with + | ValueSome v -> Some v + | _ -> None + + res |> should equal reff + +[] +let ``[Arr] tryFindIndex`` (NonEmptyArray list) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.tryFindIndex (fun v -> v % 7 = 0) + let reff = list |> List.tryFindIndex (fun v -> v % 7 = 0) + res |> should equal reff + + +[] +let ``[Arr] min`` (NonEmptyArray (list : int[])) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.min + let reff = list |> List.min + res |> should equal reff + +[] +let ``[Arr] max`` (NonEmptyArray (list : int[])) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.max + let reff = list |> List.max + res |> should equal reff + +[] +let ``[Arr] sum`` (NonEmptyArray (list : int[])) = + let list = list |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.sum + let reff = list |> List.sum + res |> should equal reff + +[] +let ``[Arr] average`` (NonEmptyArray (list : NormalFloat[])) = + let list = list |> Array.map (function NormalFloat v -> v) |> Array.toList + let arr = Arr.ofList list + + let res = arr |> Arr.average + let reff = list |> List.average + res |> should equal reff + + + +[] +let ``[ArrOperation] TryMerge`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) (NonEmptyArray (c : int[])) = + + let a = Arr.ofArray a + let b = Arr.ofArray b + let c = Arr.ofArray c + let ab = Arr.computeDelta DefaultEqualityComparer.Instance a b + let bc = Arr.computeDelta DefaultEqualityComparer.Instance b c + + match Seq.tryHead ab with + | Some ab0 -> + match Seq.tryHead bc with + | Some bc0 -> + match ArrOperation.TryMerge(ab0, bc0) with + | Some ac0 -> + let oab = ArrDelta.single ab0 + let obc = ArrDelta.single bc0 + let oac = ArrDelta.single ac0 + + + let reff = Arr.applyDelta (Arr.applyDelta a oab) obc + let res = Arr.applyDelta a oac + + res |> should equal reff + + | None -> + () + + | None -> + () + | None -> + () + + +let minimize (delta : arrdelta<'a>) = + let mutable output = Arr.empty + let mutable pending = None + + for op in delta do + if not op.IsEmpty then + match pending with + | Some p -> + match ArrOperation.TryMerge(p, op) with + | Some res -> + pending <- Some res + | None -> + output <- Arr.append p output + pending <- Some op + | None -> + pending <- Some op + + let res = + match pending with + | Some p -> Arr.append p output + | None -> output + ArrDelta.ofArr res + + +[] +let ``[ArrDelta] combine minimal`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) (NonEmptyArray (c : int[])) = + + let a = Arr.ofArray a + let b = Arr.ofArray b + let c = Arr.ofArray c + + let ab = Arr.computeDelta DefaultEqualityComparer.Instance a b + let bc = Arr.computeDelta DefaultEqualityComparer.Instance b c + + let abc = ArrDelta.combine ab bc + let abc1 = minimize abc + abc |> should equal abc1 + +[] +let ``[ArrDelta] combine sorted`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) (NonEmptyArray (c : int[])) = + + let a = Arr.ofArray a + let b = Arr.ofArray b + let c = Arr.ofArray c + + let ab = Arr.computeDelta DefaultEqualityComparer.Instance a b + let bc = Arr.computeDelta DefaultEqualityComparer.Instance b c + + let abc = ArrDelta.combine ab bc + + use mutable e = abc.GetEnumerator() + if e.MoveNext() then + let mutable last = e.Current + while e.MoveNext() do + e.Current.Index |> should (be greaterThan) last.Index + last <- e.Current + + + +[] +let ``[ArrDelta] combine correct`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) (NonEmptyArray (c : int[])) = + + // let sa = System.Collections.Generic.HashSet(a) + // for i in 0 .. b.Length - 1 do + // while sa.Contains b.[i] do b.[i] <- b.[i] + 1 + // + // sa.UnionWith b + // for i in 0 .. c.Length - 1 do + // while sa.Contains c.[i] do c.[i] <- c.[i] + 1 + // + let a = Arr.ofArray a + let b = Arr.ofArray b + let c = Arr.ofArray c + + let ab = Arr.computeDelta DefaultEqualityComparer.Instance a b + let bc = Arr.computeDelta DefaultEqualityComparer.Instance b c + let ac = Arr.computeDelta DefaultEqualityComparer.Instance a c + + let abc = ArrDelta.combine ab bc + + let res = Arr.applyDelta a abc + res |> should equal c + +[] +let ``[Arr] apply/computeDelta`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) = + let a = Arr.ofArray a + let b = Arr.ofArray b + + let d = Arr.computeDelta DefaultEqualityComparer.Instance a b + let b1, d1 = Arr.applyDeltaAndGetEffective DefaultEqualityComparer.Instance a d + let b2 = Arr.applyDelta a d + + b1 |> should equal b + b2 |> should equal b + d1 |> should equal d + + +[] +let ``[Arr] applyDeltaAndGetEffective cancellation`` (NonEmptyArray (a : int[])) = + let a = Arr.ofArray a + + let op = ArrDelta.single { Index = 0; Count = a.Length; Elements = a } + let a1, d = Arr.applyDeltaAndGetEffective DefaultEqualityComparer.Instance a op + + a1 |> should equal a + d |> should equal ArrDelta.empty + + + +[] +let ``[Arr] applyDeltaAndGetEffective preserves effective`` (NonEmptyArray (a : int[])) (NonEmptyArray (b : int[])) = + let a = Arr.ofArray a + let b = Arr.ofArray b + + let op = Arr.computeDelta DefaultEqualityComparer.Instance a b + let a1, d = Arr.applyDeltaAndGetEffective DefaultEqualityComparer.Instance a op + + a1 |> should equal b + d |> should equal op + + + + \ No newline at end of file diff --git a/src/Test/FSharp.Data.Adaptive.Tests/FSharp.Data.Adaptive.Tests.fsproj b/src/Test/FSharp.Data.Adaptive.Tests/FSharp.Data.Adaptive.Tests.fsproj index 8e86046..21ed311 100644 --- a/src/Test/FSharp.Data.Adaptive.Tests/FSharp.Data.Adaptive.Tests.fsproj +++ b/src/Test/FSharp.Data.Adaptive.Tests/FSharp.Data.Adaptive.Tests.fsproj @@ -41,12 +41,15 @@ + + + diff --git a/src/Test/FSharp.Data.Adaptive.Tests/Program.fs b/src/Test/FSharp.Data.Adaptive.Tests/Program.fs index 31af4c4..a42bf8d 100644 --- a/src/Test/FSharp.Data.Adaptive.Tests/Program.fs +++ b/src/Test/FSharp.Data.Adaptive.Tests/Program.fs @@ -47,8 +47,12 @@ let ``[AList] sub``() = [] let main _args = - - ASet.``[ASet] mapA/flattenA/chooseA async``() + //Arr.``[ArrDelta] combine sorted`` (NonEmptyArray [|1|]) (NonEmptyArray [|0; 1; 0|]) (NonEmptyArray [|0|]) + //Arr.``[ArrOperation] TryMerge`` (NonEmptyArray [|-4; 0|]) (NonEmptyArray [|-4; 1|]) (NonEmptyArray [|0|]) + //Arr.``[ArrDelta] combine correct`` (NonEmptyArray [|0; 0|]) (NonEmptyArray [|0; 3; 0; 1|]) (NonEmptyArray [|3|]) + //(NonEmptyArray [|0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0|], NonEmptyArray [|1|], 99u, 0u) + //Arr.``[Arr] replaceRange`` (NonEmptyArray [|0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0|]) (NonEmptyArray [|1|]) 99u 0u |> ignore + //ASet.``[ASet] mapA/flattenA/chooseA async``() //``[AList] sub``(); diff --git a/src/Test/FSharp.Data.Adaptive.Tests/Utilities/Generators.fs b/src/Test/FSharp.Data.Adaptive.Tests/Utilities/Generators.fs index b1b0fed..de68dee 100644 --- a/src/Test/FSharp.Data.Adaptive.Tests/Utilities/Generators.fs +++ b/src/Test/FSharp.Data.Adaptive.Tests/Utilities/Generators.fs @@ -100,6 +100,8 @@ type refmap<'a, 'b> = Reference.amap<'a, 'b> type realmap<'a, 'b> = Adaptive.amap<'a, 'b> type reflist<'a> = Reference.alist<'a> type reallist<'a> = Adaptive.alist<'a> +type refarr<'a> = Reference.aarr<'a> +type realarr<'a> = Adaptive.aarr<'a> type ChangeGen = @@ -140,6 +142,14 @@ type VList<'a> = lchanges : unit -> list } +type VArr<'a> = + { + areal : realarr<'a> + aref : refarr<'a> + aexpression : bool -> Map * string + achanges : unit -> list + } + module Generators = let rand = Random() @@ -1616,6 +1626,211 @@ module Generators = list.lchanges } + module Arr = + let mutable cid = 0 + + let create a b s c = + { + areal = a + aref = b + aexpression = s + achanges = c + } + + + + let init<'a>() = + gen { + let id = System.Threading.Interlocked.Increment(&cid) + let! value = Arb.generate> + + let real = Adaptive.carr value + let ref = Reference.carr value + + let change = + { + cell = (real, id) :> obj + change = + gen { + let! newValue = Arb.generate> + return fun () -> + real.Value <- newValue + ref.Value <- newValue + sprintf "C%d <- %A" id newValue + + } + } + + return + create + (real :> Adaptive.aarr<_>) + (ref :> Reference.aarr<_>) + (function + | false -> + Map.empty, sprintf "c%d" id + | true -> + let c = real.Value |> Seq.map (sprintf "%A") |> String.concat "; " + let m = Map.ofList [sprintf "c%d" id, sprintf "carr [%s]" c] + m, sprintf "c%d" id + ) + (fun () -> [change]) + } + + let constant<'a>() = + gen { + let! value = Arb.generate> + let id = System.Threading.Interlocked.Increment(&cid) + + return + create + (Adaptive.AArr.ofArr value) + (Reference.AArr.ofArr value) + (function + | false -> Map.empty, sprintf "%A" value + | true -> + let m = Map.ofList [sprintf "v%d" id, sprintf "AArr.ofList [%s]" (value |> Seq.map (sprintf "%A") |> String.concat "; ")] + m, sprintf "v%d" id + ) + (fun () -> []) + } + + // let ofAVal<'a> () = + // gen { + // let! a = Arb.generate>> |> Gen.scaleSize (fun v -> 0) + // return + // create + // (a.real |> Adaptive.AArr.ofAVal) + // (a.ref |> Reference.AArr.ofRef) + // (fun _ -> Map.empty, sprintf "ofAVal\r\n%s" (indent a.expression)) + // (fun () -> a.changes()) + // } + + + let map<'a, 'b>() = + gen { + let mySize = ref 0 + let! value = Arb.generate<_> |> Gen.scaleSize (fun s -> mySize := s; s - 2) + //let! f = Arb.generate<'a -> 'b> |> Gen.scaleSize (fun _ -> 50) + let table, f = randomFunction<'a, 'b> (!mySize / 2) + + let mapping v = f(v) + + return + create + (Adaptive.AArr.map mapping value.areal) + (Reference.AArr.map mapping value.aref) + (function + | false -> + let m, v = value.aexpression false + m, sprintf "map (\r\n%s\r\n)" (indent v) + | true -> + let realContent = value.aref.Content |> Reference.AVal.force + let mi, input = value.aexpression true + + let table = + realContent + |> Seq.map (fun v -> sprintf "| %A -> %A" v (mapping v)) + |> String.concat "\r\n" + + mi, sprintf "%s\r\n|> AArr.map (\r\n function\r\n%s\r\n)" (indent input) (indent table) + ) + value.achanges + } + + + let collect<'a, 'b>() = + gen { + let mySize = ref 0 + let! value = + Arb.generate<_> |> Gen.scaleSize (fun s -> + mySize := 0 + //if s <= 1 then 0 + //else int (sqrt (float s)) + !mySize + ) + //let! f = Arb.generate<'a -> 'b> |> Gen.scaleSize (fun _ -> 50) + let innerSize = !mySize + let table, mapping = randomFunction<'a, VArr<'b>> innerSize + + //let cache = Cache>(mapping) + + let getChanges() = + (Reference.AVal.force value.aref.Content) + |> Arr.toList + |> FSharp.Collections.List.collect (fun v -> table.Invoke(v).achanges()) + |> FSharp.Collections.List.append (value.achanges()) + + let mapping (input : 'a) = mapping input + return + create + (Adaptive.AArr.collect (fun a -> (mapping a).areal) value.areal) + (Reference.AArr.collect (fun a -> (mapping a).aref) value.aref) + (function + | false -> + let m, v = value.aexpression false + m, sprintf "collect (\r\n%s\r\n)" (indent v) + | true -> + let realContent = value.aref.Content |> Reference.AVal.force + let it, input = value.aexpression true + + let maps, kv = + realContent + |> Arr.toList + |> FSharp.Collections.List.map (fun v -> + let m, b = (mapping v).aexpression true + m, (v,b) + ) + |> List.unzip + //|> String.concat "\r\n" + + let table = + kv + |> FSharp.Collections.List.map (fun (k,v) -> sprintf "| %A ->\r\n %s" k v) + |> String.concat "\r\n" + + let res = + maps + |> Seq.map (Map.toSeq >> HashMap.ofSeq) + |> Seq.fold HashMap.union (HashMap.ofSeq (Map.toSeq it)) + |> Map.ofSeq + + res, sprintf "%s\r\n |> AArr.collect (\r\n function\r\n%s\r\n )" input (indent (indent table)) + ) + getChanges + } + + + let choose<'a, 'b>() = + gen { + let mySize = ref 0 + let! value = Arb.generate<_> |> Gen.scaleSize (fun s -> mySize := s; s - 2) + //let! f = Arb.generate<'a -> 'b> |> Gen.scaleSize (fun _ -> 50) + let table, f = randomFunction<'a, option<'b>> (!mySize / 2) + + let mapping v = f(v) + + return + create + (Adaptive.AArr.choose mapping value.areal) + (Reference.AArr.choose mapping value.aref) + (function + | false -> + let m, v = value.aexpression false + m, sprintf "choose (\r\n%s\r\n)" (indent v) + | true -> + let realContent = value.aref.Content |> Reference.AVal.force + let mi, input = value.aexpression true + + let table = + realContent + |> Seq.map (fun v -> sprintf "| %A -> %A" v (mapping v)) + |> String.concat "\r\n" + + mi, sprintf "%s\r\n|> AArr.choose (\r\n function\r\n%s\r\n)" (indent input) (indent table) + ) + value.achanges + } + [] type StupidHash(v : int) = @@ -1673,6 +1888,15 @@ type AdaptiveGenerators() = Seq.empty } + + static member FSharpArr<'a>() = + { new Arbitrary>() with + member x.Generator = + Arb.generate> |> Gen.map Arr.ofList + member x.Shrinker _ = + Seq.empty + } + static member Val<'a>() = { new Arbitrary>() with member x.Generator = @@ -1943,6 +2167,58 @@ type AdaptiveGenerators() = Seq.empty } + + static member Arr<'a>() = + { new Arbitrary>() with + member x.Generator = + Gen.sized (fun size -> + gen { + let! kind = + if size = 0 then + Gen.frequency [ + 1, Gen.constant "constant" + 5, Gen.constant "carr" + ] + else + Gen.frequency [ + yield 1, Gen.constant "constant" + yield 3, Gen.constant "carr" + yield 3, Gen.constant "map" + yield 3, Gen.constant "collect" + yield 3, Gen.constant "choose" + ] + match kind with + | "constant" -> + return! Generators.Arr.constant<'a>() + | "carr" -> + return! Generators.Arr.init<'a>() + | "map" -> + let! t = Gen.elements relevantTypes + return! + t |> visit { new TypeVisitor<_> with + member __.Accept<'z>() = Generators.Arr.map<'z, 'a>() + } + | "collect" -> + let! t = Gen.elements relevantTypes + return! + t |> visit { new TypeVisitor<_> with + member __.Accept<'z>() = Generators.Arr.collect<'z, 'a>() + } + | "choose" -> + let! t = Gen.elements relevantTypes + return! + t |> visit { new TypeVisitor<_> with + member __.Accept<'z>() = Generators.Arr.choose<'z, 'a>() + } + | kind -> + return failwithf "unknown operation: %s" kind + } + ) + member x.Shrinker _ = + Seq.empty + } + + static member Map<'a, 'b>() = { new Arbitrary>() with member x.Generator =