Skip to content

Instantly share code, notes, and snippets.

@dsyme

dsyme/MinIncremental.fs

Last active September 20, 2019 14:44
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save dsyme/6c04b9297e1c1f2fa9f2b74b3364abe4 to your computer and use it in GitHub Desktop.
Save dsyme/6c04b9297e1c1f2fa9f2b74b3364abe4 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
MinIncremental.fs
#if COMPILED
namespace MinIncremental
#endif
#nowarn "9"
#nowarn "51"
open System
open System.Collections
open System.Collections.Generic
open System.Collections.Concurrent
open System.Diagnostics
//open System.Linq
open System.Threading
open System.Runtime.CompilerServices
open System.Runtime.InteropServices
[<AutoOpen>]
module Prelude =
let mutable private currentId = 0
let newId() = Interlocked.Increment &currentId
let inc (a:byref<int>) = a <- a + 1
let dec (a:byref<int>) = a <- a - 1
let inline isNull (a : 'a) =
match a with
| null -> true
| _ -> false
let inline private refequals<'a when 'a : not struct> (a : 'a) (b : 'a) = Object.ReferenceEquals(a,b)
let inline (==) (a : 'a) (b : 'a) = refequals a b
let inline (!=) (a : 'a) (b : 'a) = refequals a b |> not
/// <summary>
/// represents a simple priority queue using user-given compare function
/// </summary>
type PriorityQueue<'a>(cmp : 'a -> 'a -> int) =
// we simply use the Aardvark.Base implementation here.
// to ensure that all compare-functions used are identical
// we wrap the base implementation in PriorityQueue.
let store = List<'a>()
let cmpFun = System.Func<'a,'a, int>(cmp)
/// <summary>
/// Adds an element to the heap, and maintains the heap condition.
/// For default comparison functions the smallest item is on top of
/// the heap.
/// </summary>
let HeapEnqueue(heap: List<'a>, element: 'a) : unit =
let mutable i = heap.Count
heap.Add(element)
let mutable fin = false
while not fin && i > 0 do
let i2 = (i - 1) / 2
if (cmp element heap.[i2] > 0) then
fin <- true
else
heap.[i] <- heap.[i2]
i <- i2
heap.[i] <- element
/// <summary>
/// Removes and returns the item at the top of the heap (i.e. the
/// 0th position of the list). For default comparison functions this
/// is the smallest element.
/// </summary>
let HeapDequeue(heap: List<'T>, compare: Func<'T, 'T, int>) : 'T =
let mutable result = heap.[0]
let mutable count = heap.Count
if (count = 1) then
heap.Clear()
result
else
failwith "tbd"
(*
count <- count - 1
let element = heap.[count];
heap.RemoveAt(count)
int i = 0, i1 = 1;
// at least one child
while (i1 < count) do
int i2 = i1 + 1;
int ni = (i2 < count // two children?
&& compare(heap[i1], heap[i2]) > 0)
? i2 : i1; // smaller child
if (compare(heap[ni], element) > 0) then
fin <- true
else
heap[i] = heap[ni];
i = ni; i1 = 2 * i + 1;
}
heap.[i] = element;
result;
*)
/// <summary>
/// enqueues a new element
/// </summary>
member x.Enqueue (v : 'a) =
HeapEnqueue(store, v)
/// <summary>
/// dequeues the min element from the queue and
/// fails if the queue is empty
/// </summary>
member x.Dequeue() =
HeapDequeue(store, cmpFun)
/// <summary>
/// returns the number of elements currently contained in the queue
/// </summary>
member x.Count =
store.Count
/// <summary>
/// returns the current minimal value (according to cmp) contained
/// and fails if the queue is empty.
/// </summary>
member x.Min = store.[0]
/// implements a queue with "uncomparable" duplicates.
/// This is helpful since regular heap implementation cannot
/// deal with a large number of duplicated keys efficiently.
/// Note: the duplicated values will be returned in the order they were enqueued
type DuplicatePriorityQueue<'a, 'k when 'k : comparison>(extract : 'a -> 'k) =
let q = PriorityQueue<'k> compare
let values = Dictionary<'k, Queue<'a>>()
let mutable count = 0
let mutable currentQueue = Unchecked.defaultof<_>
/// <summary>
/// enqueues a new element
/// </summary>
member x.Enqueue(v : 'a) =
let k = extract v
count <- count + 1
if values.TryGetValue(k, &currentQueue) then
currentQueue.Enqueue v
else
let inner = Queue<'a>()
inner.Enqueue v
values.[k] <- inner
q.Enqueue k
/// <summary>
/// dequeues the current minimal value (and its key)
/// </summary>
member x.Dequeue(key : byref<'k>) =
let k = q.Min
if values.TryGetValue(k, &currentQueue) then
let res = currentQueue.Dequeue()
count <- count - 1
if currentQueue.Count = 0 then
q.Dequeue() |> ignore
values.Remove k |> ignore
key <- k
res
else
failwith "inconsistent state in DuplicatePriorityQueue"
/// <summary>
/// returns the number of elements currently contained in the queue
/// </summary>
member x.Count =
count
[<Struct>]
type Symbol(id: int) =
// interface IEquatable<Symbol>
// interface IComparable<Symbol>
// interface IComparable
static member Create(str: string): Symbol = SymbolManager.GetSymbol(str)
static member Empty : Symbol = Unchecked.defaultof<_>
/// Returns true if the Symbol is negative.
/// For details on negative symbols see the
/// unary minus operator.
member x.IsNegative = id < 0
/// Returns true if the Symbol is not negative.
/// For details on negative symbols see the
/// unary minus operator.
member x.IsPositive = id > 0
member x.IsNotEmpty = id <> 0
member x.IsEmpty = (id = 0)
and SymbolManager() =
static let s_stringDict = new Dictionary<string, int>(1024)
static let s_guidDict = new Dictionary<Guid, int>(1024)
static let s_allStrings = new List<string>(1024)
static let s_allGuids = new List<Guid>(1024)
static let s_lock = new SpinLock()
static do
s_allStrings.Add(String.Empty)
s_allGuids.Add(Guid.Empty)
static member GetSymbol(str: string) : Symbol =
if (String.IsNullOrEmpty(str)) then Unchecked.defaultof<_> else
let mutable id = 0
let hash = str.GetHashCode() // hashcode computation outside spinlock
let mutable locked = false
try
s_lock.Enter(&locked);
if (not (s_stringDict.TryGetValue(str, &id))) then
id <- s_allStrings.Count
s_stringDict.Add(str, hash)
s_allStrings.Add(str)
s_allGuids.Add(Guid.Empty)
finally
if (locked) then
s_lock.Exit()
new Symbol(id)
static member GetString(id: int): string =
let mutable locked = false
if (id > 0) then
try
s_lock.Enter(&locked);
s_allStrings.[id];
finally
if (locked) then
s_lock.Exit()
elif (id < 0) then
let mutable str : string = null
try
s_lock.Enter(&locked);
str <- s_allStrings.[-id];
finally
if (locked) then s_lock.Exit();
"-" + str;
else
String.Empty;
[<AutoOpen>]
module Threading =
let startThread (f : unit -> unit) =
let t = new Thread(ThreadStart f)
t.IsBackground <- true
t.Start()
t
type Interlocked with
static member Change(location : byref<'a>, f : 'a -> 'a) =
let mutable initial = location
let mutable computed = f initial
while Interlocked.CompareExchange(&location, computed, initial) != initial do
initial <- location
computed <- f initial
computed
[<AllowNullLiteral>]
type IWeakable<'a when 'a : not struct> =
abstract member Weak : WeakReference<'a>
#nowarn "9"
/// <summary>
/// IAdaptiveObject represents the core interface for all
/// adaptive objects and contains everything necessary for
/// tracking OutOfDate flags and managing in-/outputs in the
/// dependency tree.
///
/// Since eager evalutation might be desirable in some scenarios
/// the interface also contains a Level representing the execution
/// order when evaluating inside a transaction and a function called
/// Mark allowing implementations to actually perform the evaluation.
/// Mark returns a bool since eager evaluation might cause the change
/// propagation process to exit early (if the actual value was unchanged)
/// In order to make adaptive objects easily identifiable all adaptive
/// objects must also provide a globally unique id (Id)
/// </summary>
[<AllowNullLiteral>]
type IAdaptiveObject =
inherit IWeakable<IAdaptiveObject>
/// the globally unique id for the adaptive object
abstract member Id : int
/// Rhe level for an adaptive object represents the
/// maximal distance from an input cell in the depdency graph.
/// Note that this level is entirely managed by the system
/// and shall not be accessed directly by users of the system.
abstract member Level : int with get, set
/// <summary>
/// Mark allows a specific implementation to
/// evaluate the cell during the change propagation process.
/// </summary>
abstract member Mark : unit -> bool
/// <summary>
/// the outOfDate flag for the object is true
/// whenever the object has been marked and shall
/// be set to false by specific implementations.
/// Note that this flag shall only be accessed when holding
/// a lock on the adaptive object (allowing for concurrency)
/// </summary>
abstract member OutOfDate : bool with get, set
abstract member Reevaluate : bool with get, set
/// <summary>
/// the adaptive inputs for the object
/// </summary>
abstract member Inputs : seq<IAdaptiveObject>
/// <summary>
/// the adaptive outputs for the object which are recommended
/// to be represented by Weak references in order to allow for
/// unused parts of the graph to be garbage collected.
/// </summary>
abstract member Outputs : VolatileCollection
abstract member InputChanged : obj * IAdaptiveObject -> unit
abstract member AllInputsProcessed : obj -> unit
abstract member ReaderCount : int with get, set
and [<StructLayout(LayoutKind.Explicit)>] MultiPtr =
struct
[<FieldOffset(0)>]
val mutable public Single : WeakReference<IAdaptiveObject>
[<FieldOffset(0)>]
val mutable public Array : WeakReference<IAdaptiveObject>[]
[<FieldOffset(0)>]
val mutable public Set : HashSet<WeakReference<IAdaptiveObject>>
end
/// <summary>
/// Collection of WeakReferences using a switching internal representation: Single(0-1), List (2-8), HashSet(>8)
/// This collection has improved performance to VolatileCollectionOld in cases where there are 0 or 1 references
/// NOTE: using mode switch omits using types checks to determine used implementation
/// using matches instead of downcasts uses OpCode "isinst" instead of "unbox.any" and avoids code to be able to throw exception
/// </summary>
and VolatileCollection() =
let mutable handles : MultiPtr = Unchecked.defaultof<_>
let mutable count : int = 0 // Note: could replace mode, but would require Array or HashSet to be dropped on Consume
let mutable mode : byte = 0uy // using mode to avoid "expensive" type checks
// NOTE: myIndexOf > Array.IndexOf<_>(arr, value, 0, count) > Array.IndexOf(arr, value, 0, count)
let myIndexOf(arr : WeakReference<_>[], v : WeakReference<_>, count : int) : int =
let mutable i = 0
let mutable search = true
while search && i < count do
if Object.ReferenceEquals(arr.[i], v) then
search <- false
else
i <- i + 1
if search then
-1
else
i
member x.IsEmpty =
count = 0
member x.Count =
count
member x.Consume(res : byref<array<IAdaptiveObject>>) : int =
let mutable length = 0
if not (isNull handles.Single) then
let mutable v : IAdaptiveObject = Unchecked.defaultof<_>
if mode = 0uy then
if res.Length < 1 then
res <- Array.zeroCreate 8
if handles.Single.TryGetTarget(&v) then
res.[0] <- v
length <- 1
handles.Single <- Unchecked.defaultof<_>
elif mode = 1uy then
let arr = handles.Array
if res.Length < count then
res <- Array.zeroCreate 8
for i in 0..count-1 do
if arr.[i].TryGetTarget(&v) then
res.[length] <- v
length <- length + 1
arr.[i] <- Unchecked.defaultof<_>
else
let set = handles.Set
if res.Length < set.Count then
res <- Array.zeroCreate (set.Count * 3 / 2)
for ref in set do
if ref.TryGetTarget(&v) then
res.[length] <- v
length <- length + 1
set.Clear()
count <- 0
length
member x.Add(value : IAdaptiveObject) : bool =
let value = value.Weak
if mode = 0uy then
if isNull handles.Single then
handles.Single <- value
count <- 1
true
elif Object.ReferenceEquals(handles.Single, value) then
false
else
let arr = Array.zeroCreate 8
arr.[0] <- handles.Single
arr.[1] <- value
handles.Array <- arr
mode <- 1uy
count <- 2
true
elif mode = 1uy then
let arr = handles.Array
if myIndexOf(arr, value, count) >= 0 then
false
elif count = 8 then
let set = HashSet arr
set.Add(value) |> ignore
handles.Set <- set
mode <- 2uy
count <- 9
true
else
arr.[count] <- value
count <- count + 1
true
else
if handles.Set.Add(value) then
count <- count + 1
true
else
false
member x.Remove(value : IAdaptiveObject) : bool =
let mutable res = false
if count > 0 then
let value = value.Weak
if mode = 0uy then
if Object.ReferenceEquals(handles.Single, value) then
handles.Single <- null
count <- 0
res <- true
elif mode = 1uy then
let arr = handles.Array;
let i = myIndexOf(arr, value, count)
if i >= 0 then
for j in i..count-2 do
arr.[j] <- arr.[j+1]
count <- count - 1
res <- true
else
if handles.Set.Remove value then
count <- count - 1
res <- true
res
member x.Clear() =
handles.Single <- null
count <- 0
mode <- 0uy
//#endnowarn "9"
[<AbstractClass; Sealed; Extension>]
type AdaptiveObjectExtensions private() =
static let equality =
{ new IEqualityComparer<IAdaptiveObject> with
member x.GetHashCode(o : IAdaptiveObject) =
System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode(o)
member x.Equals(l : IAdaptiveObject, r : IAdaptiveObject) =
System.Object.ReferenceEquals(l,r)
}
static member EqualityComparer = equality
[<Extension>]
static member EnterWrite(o : IAdaptiveObject) =
Monitor.Enter o
while o.ReaderCount > 0 do
Monitor.Wait o |> ignore
[<Extension>]
static member ExitWrite(o : IAdaptiveObject) =
Monitor.Exit o
[<Extension>]
static member IsOutdatedCaller(o : IAdaptiveObject) =
Monitor.IsEntered o && o.OutOfDate
[<Struct>]
type AdaptiveToken =
val public Caller : IAdaptiveObject
val public Locked : HashSet<IAdaptiveObject>
member inline x.EnterRead(o : IAdaptiveObject) =
Monitor.Enter o
member inline x.ExitFaultedRead(o : IAdaptiveObject) =
Monitor.Exit o
member inline x.Downgrade(o : IAdaptiveObject) =
if not o.Reevaluate && x.Locked.Add o then
o.ReaderCount <- o.ReaderCount + 1
Monitor.Exit o
member inline x.ExitRead(o : IAdaptiveObject) =
if x.Locked.Remove o then
lock o (fun () ->
let rc = o.ReaderCount - 1
o.ReaderCount <- rc
if rc = 0 then Monitor.PulseAll o
)
member inline x.Release() =
for o in x.Locked do
lock o (fun () ->
let rc = o.ReaderCount - 1
o.ReaderCount <- rc
if rc = 0 then Monitor.PulseAll o
)
x.Locked.Clear()
member inline x.WithCaller (c : IAdaptiveObject) =
AdaptiveToken(c, x.Locked)
member inline x.WithTag (t : obj) =
AdaptiveToken(x.Caller, x.Locked)
member inline x.Isolated =
AdaptiveToken(x.Caller, HashSet())
static member inline Top = AdaptiveToken(null, HashSet())
static member inline Empty = Unchecked.defaultof<AdaptiveToken>
new(caller : IAdaptiveObject, locked : HashSet<IAdaptiveObject>) =
{
Caller = caller
Locked = locked
}
/// <summary>
/// LevelChangedException is internally used by the system
/// to handle level changes during the change propagation.
/// </summary>
exception LevelChangedException of changedObject : IAdaptiveObject * newLevel : int * distanceFromRoot : int
type TrackAllThreadLocal<'a>(creator : unit -> 'a) =
let mutable values : Map<int, 'a> = Map.empty
let create() =
let v = creator()
Threading.Interlocked.Change(&values, Map.add Threading.Thread.CurrentThread.ManagedThreadId v) |> ignore
v
let inner = new Threading.ThreadLocal<'a>(create)
member x.Value
with get() = inner.Value
and set v =
inner.Value <- v
Threading.Interlocked.Change(&values, Map.add Threading.Thread.CurrentThread.ManagedThreadId v) |> ignore
member x.Values =
values |> Map.toSeq |> Seq.map snd
member x.Dispose() =
values <- Map.empty
inner.Dispose()
interface IDisposable with
member x.Dispose() = x.Dispose()
/// <summary>
/// Transaction holds a set of adaptive objects which
/// have been changed and shall therefore be marked as outOfDate.
/// Commit "propagates" these changes into the dependency-graph, takes
/// care of the correct execution-order and acquires appropriate locks
/// for all objects affected.
/// </summary>
type Transaction() =
// each thread may have its own running transaction
[<ThreadStatic; DefaultValue>]
static val mutable private RunningTransaction : option<Transaction>
[<ThreadStatic; DefaultValue>]
static val mutable private CurrentTransaction : option<Transaction>
#if DEBUG
let mutable isDisposed = false
#endif
// // each thread may have its own running transaction
// static let running = new TrackAllThreadLocal<option<Transaction>>(fun () -> None)
//
// we use a duplicate-queue here since we expect levels to be very similar
let q = DuplicatePriorityQueue<IAdaptiveObject, int>(fun o -> o.Level)
let causes = ConcurrentDictionary<IAdaptiveObject, HashSet<IAdaptiveObject>>()
// the contained set is useful for determinig if an element has
// already been enqueued
let contained = HashSet<IAdaptiveObject>()
let mutable current : IAdaptiveObject = null
let mutable currentLevel = 0
let mutable finalizers : list<unit->unit> = []
let runFinalizers () =
let fs = Interlocked.Exchange(&finalizers, [])
for f in fs do f()
member x.AddFinalizer (f : unit->unit) =
Interlocked.Change(&finalizers, (fun a -> f::a) ) |> ignore
member x.IsContained (e: IAdaptiveObject) = contained.Contains e
static member Running
with get() = Transaction.RunningTransaction
and set r = Transaction.RunningTransaction <- r
static member Current
with get() = Transaction.CurrentTransaction
and set r = Transaction.CurrentTransaction <- r
static member HasRunning =
Transaction.RunningTransaction.IsSome
static member RunningLevel =
match Transaction.RunningTransaction with
| Some t -> t.CurrentLevel
| _ -> Int32.MaxValue - 1
member x.CurrentLevel = currentLevel
/// enqueues an adaptive object for marking
member x.Enqueue(e : IAdaptiveObject) =
#if DEBUG
if isDisposed then failwith "Invalid Enqueue! Transaction already disposed."
#endif
if contained.Add e then
q.Enqueue e
member x.Enqueue(e : IAdaptiveObject, cause : option<IAdaptiveObject>) =
#if DEBUG
if isDisposed then failwith "Invalid Enqueue! Transaction already disposed."
#endif
if contained.Add e then
q.Enqueue e
match cause with
| Some cause ->
match causes.TryGetValue e with
| (true, set) ->
set.Add cause |> ignore
| _ ->
let set = HashSet [cause]
causes.[e] <- set
| None -> ()
member x.CurrentAdapiveObject =
if isNull current then None
else Some current
/// <summary>
/// performs the entire marking process causing
/// all affected objects to be made consistent with
/// the enqueued changes.
/// </summary>
member x.Commit() =
#if DEBUG
if isDisposed then failwith "Invalid Commit Transaction already disposed."
#endif
// cache the currently running transaction (if any)
// and make ourselves current.
let old = Transaction.RunningTransaction
Transaction.RunningTransaction <- Some x
let mutable level = 0
let myCauses = ref null
let mutable markCount = 0
let mutable traverseCount = 0
let mutable levelChangeCount = 0
let mutable outputCount = 0
let mutable outputs = Array.zeroCreate 8
while q.Count > 0 do
// dequeue the next element (having the minimal level)
let e = q.Dequeue(&currentLevel)
current <- e
traverseCount <- traverseCount + 1
outputCount <- 0
// since we're about to access the outOfDate flag
// for this object we must acquire a lock here.
// Note that the transaction will at most hold one
// lock at a time.
//Monitor.Enter e
if e.IsOutdatedCaller() then
e.AllInputsProcessed(x)
else
e.EnterWrite()
try
// if the element is already outOfDate we
// do not traverse the graph further.
if e.OutOfDate then
e.AllInputsProcessed(x)
else
// if the object's level has changed since it
// was added to the queue we re-enqueue it with the new level
// Note that this may of course cause runtime overhead and
// might even change the asymptotic runtime behaviour of the entire
// system in the worst case but we opted for this approach since
// it is relatively simple to implement.
if currentLevel <> e.Level then
q.Enqueue e
else
if causes.TryRemove(e, &myCauses.contents) then
!myCauses |> Seq.iter (fun i -> e.InputChanged(x,i))
// however if the level is consistent we may proceed
// by marking the object as outOfDate
e.OutOfDate <- true
e.AllInputsProcessed(x)
markCount <- markCount + 1
try
// here mark and the callbacks are allowed to evaluate
// the adaptive object but must expect any call to AddOutput to
// raise a LevelChangedException whenever a level has been changed
if e.Mark() then
// if everything succeeded we return all current outputs
// which will cause them to be enqueued
outputCount <- e.Outputs.Consume(&outputs)
else
// if Mark told us not to continue we're done here
()
with LevelChangedException(obj, objLevel, distance) ->
// if the level was changed either by a callback
// or Mark we re-enqueue the object with the new level and
// mark it upToDate again (since it would otherwise not be processed again)
e.Level <- max e.Level (objLevel + distance)
e.OutOfDate <- false
levelChangeCount <- levelChangeCount + 1
q.Enqueue e
finally
e.ExitWrite()
// finally we enqueue all returned outputs
for i in 0..outputCount - 1 do
let o = outputs.[i]
o.InputChanged(x,e)
x.Enqueue o
contained.Remove e |> ignore
current <- null
// when the commit is over we restore the old
// running transaction (if any)
Transaction.RunningTransaction <- old
currentLevel <- 0
member x.Dispose() =
runFinalizers()
#if DEBUG
isDisposed <- true
#endif
interface IDisposable with
member x.Dispose() = x.Dispose()
/// <summary>
/// defines a base class for all adaptive objects implementing
/// IAdaptiveObject.
/// </summary>
[<AllowNullLiteral>]
type AdaptiveObject =
class
[<DefaultValue>]
static val mutable private time : IAdaptiveObject
[<DefaultValue; ThreadStatic>]
static val mutable private EvaluationDepthValue : int
val mutable public Id : int
val mutable public OutOfDateValue : bool
val mutable public LevelValue : int
val mutable public Outputs : VolatileCollection
val mutable public WeakThis : WeakReference<IAdaptiveObject>
val mutable public ReaderCountValue : int
val mutable public Reevaluate : bool
/// used for reseting EvaluationDepth in eager evaluation
static member internal UnsaveEvaluationDepth
with get() = AdaptiveObject.EvaluationDepthValue
and set v = AdaptiveObject.EvaluationDepthValue <- v
member x.Level
with inline get() = if x.Reevaluate then 0 else x.LevelValue
and inline set v = if not x.Reevaluate then x.LevelValue <- v
member x.OutOfDate
with inline get() =
x.Reevaluate || x.OutOfDateValue
and inline set v =
if not x.Reevaluate then
x.OutOfDateValue <- v
new() =
{ Id = newId(); OutOfDateValue = true;
LevelValue = 0; Outputs = VolatileCollection(); WeakThis = null;
ReaderCountValue = 0; Reevaluate = false }
static member inline private markTime() =
let time = AdaptiveObject.time
if not (isNull time) then
Monitor.Enter time
if not time.Outputs.IsEmpty then
let mutable outputs = Array.zeroCreate 8
let outputCount = time.Outputs.Consume(&outputs)
Monitor.Exit time
let t = new Transaction()
for i in 0..outputCount-1 do
let o = outputs.[i]
t.Enqueue(o)
t.Commit()
t.Dispose()
else
Monitor.Exit time
member this.evaluate (token : AdaptiveToken) (f : AdaptiveToken -> 'a) =
let caller = token.Caller
let depth = AdaptiveObject.EvaluationDepthValue
let mutable res = Unchecked.defaultof<_>
token.EnterRead this
this.Reevaluate <- false
try
AdaptiveObject.EvaluationDepthValue <- depth + 1
// this evaluation is performed optimistically
// meaning that the "top-level" object needs to be allowed to
// pull at least one value on every path.
// This property must therefore be maintained for every
// path in the entire system.
let r = f(token.WithCaller this)
this.OutOfDate <- false
// if the object's level just got greater than or equal to
// the level of the running transaction (if any)
// we raise an exception since the evaluation
// could be inconsistent atm.
// the only exception to that is the top-level object itself
let maxAllowedLevel =
if depth > 1 then Transaction.RunningLevel - 1
else Transaction.RunningLevel
if this.Level > maxAllowedLevel then
//printfn "%A tried to pull from level %A but has level %A" top.Id level top.Level
// all greater pulls would be from the future
raise <| LevelChangedException(this, this.Level, depth - 1)
res <- r
if not (isNull caller) then
if this.Reevaluate then
caller.Reevaluate <- true
caller.InputChanged(this, this)
caller.AllInputsProcessed(this)
else
this.Outputs.Add caller |> ignore
caller.Level <- max caller.Level (this.Level + 1)
with _ ->
AdaptiveObject.EvaluationDepthValue <- depth
token.ExitFaultedRead this
reraise()
AdaptiveObject.EvaluationDepthValue <- depth
// downgrade to read
token.Downgrade this
if isNull caller then
token.Release()
if depth = 0 && not Transaction.HasRunning then
AdaptiveObject.markTime()
res
static member Time : IAdaptiveObject =
if isNull AdaptiveObject.time then
AdaptiveObject.time <- AdaptiveObject() :> IAdaptiveObject
AdaptiveObject.time
/// <summary>
/// utility function for evaluating an object if
/// it is marked as outOfDate. If the object is actually
/// outOfDate the given function is executed and otherwise
/// the given default value is returned.
/// Note that this function takes care of appropriate locking
/// </summary>
member x.EvaluateIfNeeded (token : AdaptiveToken) (otherwise : 'a) (f : AdaptiveToken -> 'a) =
x.evaluate token (fun token ->
if x.OutOfDate then
f token
else
otherwise
)
/// <summary>
/// utility function for evaluating an object even if it
/// is not marked as outOfDate.
/// Note that this function takes care of appropriate locking
/// </summary>
member x.EvaluateAlways (token : AdaptiveToken) (f : AdaptiveToken -> 'a) =
x.evaluate token f
abstract member Mark : unit -> bool
default x.Mark () = true
abstract member InputChanged : obj * IAdaptiveObject -> unit
default x.InputChanged(t,ip) = ()
abstract member AllInputsProcessed : obj -> unit
default x.AllInputsProcessed(t) = ()
abstract member Inputs : seq<IAdaptiveObject>
[<System.ComponentModel.Browsable(false)>]
default x.Inputs = Seq.empty
override x.GetHashCode() = x.Id
override x.Equals o =
match o with
| :? IAdaptiveObject as o -> x.Id = o.Id
| _ -> false
member x.Weak =
let o = x.WeakThis
if isNull o then
let r = new WeakReference<IAdaptiveObject>(x)
x.WeakThis <- r
r
else
o
interface IWeakable<IAdaptiveObject> with
member x.Weak = x.Weak
interface IAdaptiveObject with
member x.Id = x.Id
member x.OutOfDate
with get() = x.OutOfDate
and set v = x.OutOfDate <- v
member x.Reevaluate
with get() = x.Reevaluate
and set v = x.Reevaluate <- v
member x.Outputs = x.Outputs
member x.Inputs = x.Inputs
member x.Level
with get() = x.Level
and set l = x.Level <- l
member x.Mark () =
x.Mark ()
member x.InputChanged(o,ip) = x.InputChanged(o, ip)
member x.AllInputsProcessed(o) = x.AllInputsProcessed(o)
member x.ReaderCount
with get() = x.ReaderCountValue
and set v = x.ReaderCountValue <- v
end
/// <summary>
/// defines a base class for all adaptive objects implementing
/// IAdaptiveObject and providing dirty-inputs for evaluation.
/// </summary>
[<AllowNullLiteral>]
type DirtyTrackingAdaptiveObject<'a when 'a :> IAdaptiveObject> =
inherit AdaptiveObject
val mutable public Scratch : ConcurrentDictionary<obj, HashSet<'a>>
val mutable public Dirty : HashSet<'a>
override x.InputChanged(t,o) =
match o with
| :? 'a as o ->
lock x.Scratch (fun () ->
let set =
match x.Scratch.TryGetValue t with
| true, v -> v
| false, _ ->
let a = HashSet()
x.Scratch.[t] <- a
a
set.Add o |> ignore
)
| _ -> ()
override x.AllInputsProcessed(t) =
match lock x.Scratch (fun () -> x.Scratch.TryRemove t) with
| (true, s) -> x.Dirty.UnionWith s
| _ -> ()
member x.EvaluateAlways' (token : AdaptiveToken) (compute : AdaptiveToken -> HashSet<'a> -> 'b) =
x.EvaluateAlways token (fun token ->
let d = x.Dirty
x.Dirty <- HashSet()
let res = compute token d
res
)
new() = { Scratch = ConcurrentDictionary(); Dirty = HashSet() }
/// <summary>
/// defines a base class for all adaptive objects which are
/// actually constant.
/// Note that this class provides "dummy" implementations
/// for all memebers defined in IAdaptiveObject and does not
/// keep track of in-/outputs.
/// </summary>
[<AbstractClass>]
type ConstantObject() =
let mutable weakThis : WeakReference<IAdaptiveObject> = null
let mutable readerCount = 0
interface IWeakable<IAdaptiveObject> with
member x.Weak =
let w = weakThis
if isNull w then
let w = WeakReference<IAdaptiveObject>(x)
weakThis <- w
w
else
weakThis
interface IAdaptiveObject with
member x.Id = -1
member x.Level
with get() = 0
and set l = failwith "cannot set level for constant"
member x.Mark() = false
member x.OutOfDate
with get() = false
and set o = failwith "cannot mark constant outOfDate"
member x.Reevaluate
with get() = false
and set o = failwith "cannot mark constant outOfDate"
member x.Inputs = Seq.empty
member x.Outputs = VolatileCollection()
member x.InputChanged(o,ip) = ()
member x.AllInputsProcessed(o) = ()
member x.ReaderCount
with get() = readerCount
and set v = readerCount <- v
[<AutoOpen>]
module Marking =
// since changeable inputs need a transaction
// for enqueing their changes we use a thread local
// current transaction which basically allows for
// an implicit argument.
//let internal current = new Threading.ThreadLocal<option<Transaction>>(fun () -> None)
/// <summary>
/// returns the currently running transaction or (if none)
/// the current transaction for the calling thread
/// </summary>
let getCurrentTransaction() =
match Transaction.Running with
| Some r -> Some r
| None ->
match Transaction.Current with
| Some c -> Some c
| None -> None
let inline setCurrentTransaction t =
Transaction.Current <- t
/// <summary>
/// executes a function "inside" a newly created
/// transaction and commits the transaction
/// </summary>
let transact (f : unit -> 'a) =
use t = new Transaction()
let old = Transaction.Current
Transaction.Current <- Some t
let r = f()
Transaction.Current <- old
t.Commit()
r
// defines some extension utilites for
// IAdaptiveObjects
type IAdaptiveObject with
/// <summary>
/// utility for marking adaptive object as outOfDate.
/// Note that this function will actually enqueue the
/// object to the current transaction and will fail if
/// no current transaction can be found.
/// However objects which are already outOfDate might
/// also be "marked" when not having a current transaction.
/// </summary>
member x.MarkOutdated (cause : option<IAdaptiveObject>) =
match getCurrentTransaction() with
| Some t -> t.Enqueue(x, cause)
| None ->
lock x (fun () ->
if x.OutOfDate then ()
elif x.Outputs.IsEmpty then x.OutOfDate <- true
else failwith "cannot mark object without transaction"
)
member x.MarkOutdated (cause : option<IAdaptiveObject>, fin : option<unit -> unit>) =
match getCurrentTransaction() with
| Some t ->
t.Enqueue(x, cause)
match fin with
| Some fin -> t.AddFinalizer(fin)
| None -> ()
| None ->
lock x (fun () ->
if x.OutOfDate then ()
elif x.Outputs.IsEmpty then x.OutOfDate <- true
else failwith "cannot mark object without transaction"
)
match fin with
| Some fin -> fin()
| None -> ()
member x.MarkOutdated () =
x.MarkOutdated None
member x.MarkOutdated (fin : option<unit -> unit>) =
x.MarkOutdated(None, fin)
/// <summary>
/// utility for adding an output to the object.
/// Note that this will cause the output to be marked
/// using MarkOutdated and may therefore only be used
/// on objects being outOfDate or inside a transaction.
/// </summary>
member x.AddOutput(m : IAdaptiveObject) =
m.MarkOutdated ( Some x )
/// <summary>
/// utility for removing an output from the object
/// </summary>
member x.RemoveOutput (m : IAdaptiveObject) =
lock x (fun () -> x.Outputs.Remove m |> ignore)
[<AutoOpen>]
module CallbackExtensions =
let private undyingMarkingCallbacks = System.Runtime.CompilerServices.ConditionalWeakTable<IAdaptiveObject,HashSet<obj>>()
type private CallbackObject(inner : IAdaptiveObject, callback : CallbackObject -> unit) as this =
let modId = newId()
let mutable level = inner.Level + 1
let mutable live = 1
//let mutable scope = Ag.getContext()
let mutable inner = inner
let mutable weakThis = null
let mutable readerCount = 0
do lock inner (fun () -> inner.Outputs.Add this |> ignore)
do lock undyingMarkingCallbacks (fun () -> undyingMarkingCallbacks.GetOrCreateValue(inner).Add this |> ignore )
member x.Mark() =
// let old = AdaptiveSystemState.pushReadLocks()
// try
if live = 1 then
//Ag.useScope scope (fun () ->
callback x
//)
// finally
// AdaptiveSystemState.popReadLocks old
false
interface IWeakable<IAdaptiveObject> with
member x.Weak =
let w = weakThis
if isNull w then
let w = WeakReference<IAdaptiveObject>(x)
weakThis <- w
w
else
weakThis
interface IAdaptiveObject with
member x.Id = modId
member x.Level
with get() = System.Int32.MaxValue - 1
and set l = ()
member x.Mark() =
x.Mark()
member x.OutOfDate
with get() = false
and set o = ()
member x.Reevaluate
with get() = false
and set o = ()
member x.Inputs = Seq.singleton inner
member x.Outputs = VolatileCollection()
member x.InputChanged(o,ip) = ()
member x.AllInputsProcessed(o) = ()
member x.ReaderCount
with get() = readerCount
and set c = readerCount <- c
member x.Dispose() =
if Interlocked.Exchange(&live, 0) = 1 then
lock undyingMarkingCallbacks (fun () ->
match undyingMarkingCallbacks.TryGetValue(inner) with
| (true,v) ->
v.Remove x |> ignore
if v.Count = 0 then undyingMarkingCallbacks.Remove inner |> ignore
| _ -> ()
)
inner.RemoveOutput x
match inner with
| :? IDisposable as d -> d.Dispose()
| _ -> ()
//scope <- Unchecked.defaultof<_>
inner <- null
interface IDisposable with
member x.Dispose() = x.Dispose()
type IAdaptiveObject with
/// <summary>
/// utility for adding a "persistent" callback to
/// the object. returns a disposable "subscription" which
/// allows to destroy the callback.
/// </summary>
member x.AddMarkingCallback(f : unit -> unit) =
let res =
new CallbackObject(x, fun self ->
lock x (fun _ ->
try
f ()
finally
x.Outputs.Add self |> ignore
)
)
lock x (fun () -> x.Outputs.Add res |> ignore)
res :> IDisposable //{ new IDisposable with member __.Dispose() = live := false; x.MarkingCallbacks.Remove !self |> ignore}
/// <summary>
/// utility for adding a "persistent" callback to
/// the object. returns a disposable "subscription" which
/// allows to destroy the callback.
/// </summary>
member x.AddVolatileMarkingCallback(f : unit -> unit) =
let res =
new CallbackObject(x, fun self ->
try
f ()
self.Dispose()
with :? LevelChangedException as ex ->
lock x (fun () -> x.Outputs.Add self |> ignore)
raise ex
)
lock x (fun () -> x.Outputs.Add res |> ignore)
res :> IDisposable //{ new IDisposable with member __.Dispose() = live := false; x.MarkingCallbacks.Remove !self |> ignore}
member x.AddEvaluationCallback(f : AdaptiveToken -> unit) =
let res =
new CallbackObject(x, fun self ->
try
f AdaptiveToken.Top
finally
lock x (fun () -> x.Outputs.Add self |> ignore)
)
res.Mark() |> ignore
res :> IDisposable //{ new IDisposable with member __.Dispose() = live := false; x.MarkingCallbacks.Remove !self |> ignore}
/// <summary>
/// defines a base class for all decorated mods
/// </summary>
type AdaptiveDecorator(o : IAdaptiveObject) =
let mutable o = o
let id = newId()
let mutable weakThis = null
let mutable readerCount = 0
member x.Id = id
member x.OutOfDate
with get() = o.OutOfDate
and set v = o.OutOfDate <- v
member x.Outputs = o.Outputs
member x.Inputs = o.Inputs
member x.Level
with get() = o.Level
and set l = o.Level <- l
member x.Mark() = o.Mark()
override x.GetHashCode() = id
override x.Equals o =
match o with
| :? IAdaptiveObject as o -> x.Id = id
| _ -> false
interface IWeakable<IAdaptiveObject> with
member x.Weak =
let w = weakThis
if isNull w then
let w = WeakReference<IAdaptiveObject>(x)
weakThis <- w
w
else
weakThis
interface IAdaptiveObject with
member x.Id = id
member x.OutOfDate
with get() = o.OutOfDate
and set v = o.OutOfDate <- v
member x.Reevaluate
with get() = o.Reevaluate
and set v = o.Reevaluate <- v
member x.Outputs = o.Outputs
member x.Inputs = o.Inputs
member x.Level
with get() = o.Level
and set l = o.Level <- l
member x.Mark () = o.Mark()
member x.InputChanged(t,ip) = o.InputChanged (t,ip)
member x.AllInputsProcessed(t) = o.AllInputsProcessed(t)
member x.ReaderCount
with get() = readerCount
and set c = readerCount <- c
(*
type VolatileDirtySet<'a, 'b when 'a :> IAdaptiveObject and 'a : equality and 'a : not struct>(eval : 'a -> 'b) =
static let empty = ref HSet.empty
let mutable set : ref<hset<'a>> = ref HSet.empty
member x.Evaluate() =
let local = !Interlocked.Exchange(&set, empty)
try
local
|> HSet.toList
|> List.filter (fun o -> lock o (fun () -> o.OutOfDate))
|> List.map (fun o -> eval o)
with :? LevelChangedException as l ->
Interlocked.Change(&set, fun s -> ref (HSet.union local !s)) |> ignore
raise l
member x.Push(i : 'a) =
lock i (fun () ->
if i.OutOfDate then
Interlocked.Change(&set, fun s -> ref (HSet.add i !s)) |> ignore
)
member x.Add(i : 'a) =
x.Push(i)
member x.Remove(i : 'a) =
Interlocked.Change(&set, fun s -> ref (HSet.remove i !s)) |> ignore
member x.Clear() =
Interlocked.Exchange(&set, empty) |> ignore
*)
type MutableVolatileDirtySet<'a, 'b when 'a :> IAdaptiveObject and 'a : equality and 'a : not struct>(eval : 'a -> 'b) =
let lockObj = obj()
let set = HashSet<'a>()
member x.Evaluate() =
lock lockObj (fun () ->
let res = set |> Seq.toList
set.Clear()
res |> List.filter (fun o -> lock o (fun () -> o.OutOfDate))
|> List.map (fun o -> eval o)
)
member x.Push(i : 'a) =
lock lockObj (fun () ->
lock i (fun () ->
if i.OutOfDate then
set.Add i |> ignore
)
)
member x.Add(i : 'a) =
x.Push(i)
member x.Remove(i : 'a) =
lock lockObj (fun () ->
set.Remove i |> ignore
)
member x.Clear() =
lock lockObj (fun () ->
set.Clear()
)
(*
type VolatileTaggedDirtySet<'a, 'b, 't when 'a :> IAdaptiveObject and 'a : equality and 'a : not struct>(eval : 'a -> 'b) =
static let empty = ref HSet.empty
let mutable set : ref<hset<'a>> = empty
let tagDict = Dictionary<'a, HashSet<'t>>()
member x.Evaluate() =
lock tagDict (fun () ->
let local = !Interlocked.Exchange(&set, empty)
try
local |> HSet.toList
|> List.filter (fun o -> lock o (fun () -> o.OutOfDate))
|> List.map (fun o ->
match tagDict.TryGetValue o with
| (true, tags) -> o, Seq.toList tags
| _ -> o, []
)
|> List.map (fun (o, tags) -> eval o, tags)
with :? LevelChangedException as l ->
Interlocked.Change(&set, fun s -> ref (HSet.union local !s)) |> ignore
raise l
)
member x.Push(i : 'a) =
lock tagDict (fun () ->
lock i (fun () ->
if i.OutOfDate && tagDict.ContainsKey i then
Interlocked.Change(&set, fun s -> ref (HSet.add i !s)) |> ignore
)
)
member x.Add(tag : 't, i : 'a) =
lock tagDict (fun () ->
match tagDict.TryGetValue i with
| (true, set) ->
set.Add tag |> ignore
false
| _ ->
tagDict.[i] <- HashSet [tag]
x.Push i
true
)
member x.Remove(tag : 't, i : 'a) =
lock tagDict (fun () ->
match tagDict.TryGetValue i with
| (true, tags) ->
if tags.Remove tag then
if tags.Count = 0 then
Interlocked.Change(&set, fun s -> ref (HSet.remove i !s)) |> ignore
true
else
false
else
failwithf "[VolatileTaggedDirtySet] could not remove tag %A for element %A" tag i
| _ ->
failwithf "[VolatileTaggedDirtySet] could not remove element: %A" i
)
member x.Clear() =
lock tagDict (fun () ->
tagDict.Clear()
Interlocked.Exchange(&set, empty) |> ignore
)
*)
type MutableVolatileTaggedDirtySet<'a, 'b, 't when 'a :> IAdaptiveObject and 'a : equality and 'a : not struct>(eval : 'a -> 'b) =
let set = HashSet<'a>()
let tagDict = Dictionary<'a, HashSet<'t>>()
member x.Evaluate() =
lock tagDict (fun () ->
try
let result =
set |> Seq.toList
|> List.filter (fun o -> lock o (fun () -> o.OutOfDate))
|> List.choose (fun o ->
match tagDict.TryGetValue o with
| (true, tags) -> Some(o, Seq.toList tags)
| _ -> None
)
|> List.map (fun (o, tags) -> eval o, tags)
set.Clear()
result
with :? LevelChangedException as l ->
raise l
)
member x.Push(i : 'a) =
lock tagDict (fun () ->
lock i (fun () ->
if i.OutOfDate && tagDict.ContainsKey i then
set.Add i |> ignore
)
)
member x.Add(tag : 't, i : 'a) =
lock tagDict (fun () ->
match tagDict.TryGetValue i with
| (true, set) ->
set.Add tag |> ignore
false
| _ ->
tagDict.[i] <- HashSet [tag]
x.Push i
true
)
member x.Remove(tag : 't, i : 'a) =
lock tagDict (fun () ->
match tagDict.TryGetValue i with
| (true, tags) ->
if tags.Remove tag then
if tags.Count = 0 then
set.Remove i |> ignore
true
else
false
else
failwithf "[VolatileTaggedDirtySet] could not remove tag %A for element %A" tag i
| _ ->
failwithf "[VolatileTaggedDirtySet] could not remove element: %A" i
)
member x.Clear() =
lock tagDict (fun () ->
tagDict.Clear()
set.Clear()
)
/// <summary>
/// IMod is the non-generic base interface for
/// modifiable cells. This is needed due to the
/// lack of existential types in the .NET.
/// </summary>
[<AllowNullLiteral>]
type IMod =
inherit IAdaptiveObject
/// <summary>
/// returns whether or not the cell's content
/// will remain constant.
/// </summary>
abstract member IsConstant : bool
/// <summary>
/// returns the cell's content and evaluates
/// the respective computation if needed.
/// </summary>
abstract member GetValue : AdaptiveToken -> obj
/// <summary>
/// IMod<'a> represents the base interface for
/// modifiable cells and provides a method for
/// getting the cell's current content.
/// </summary>
[<AllowNullLiteral>]
type IMod<'a> =
inherit IMod
/// <summary>
/// returns the cell's content and evaluates
/// the respective computation if needed.
/// </summary>
abstract member GetValue : AdaptiveToken -> 'a
type IDisposableMod =
inherit IMod
inherit IDisposable
type IDisposableMod<'a> =
inherit IMod<'a>
inherit IDisposableMod
/// <summary>
/// ModRef<'a> represents a changeable input
/// cell which can be changed by the user and
/// implements IMod<'a>
/// </summary>
type IModRef<'a> =
inherit IMod<'a>
/// Gets or sets the refs value.
/// Note: can only be set inside an active transaction.
abstract member Value : 'a with get,set
abstract member UnsafeCache : 'a with get,set
[<CLIEvent>]
abstract member Changed : IEvent<EventHandler<EventArgs>, EventArgs>
type IVersioned =
abstract member Version : int
type IVersionedSet<'a> =
inherit ISet<'a>
inherit IVersioned
type IVersionedDictionary<'k, 'v> =
inherit IDictionary<'k, 'v>
inherit IVersioned
module ChangeTracker =
type private ChangeTracker<'a>() =
static let getVersion (a : 'a) =
(a |> unbox<IVersioned>).Version
static let createSimpleTracker : (option<'a -> 'a -> bool>) -> 'a -> bool =
fun eq ->
let eq = defaultArg eq (fun a b -> System.Object.Equals(a,b))
let old = ref None
fun n ->
match !old with
| None ->
old := Some n
true
| Some o ->
if eq o n then
false
else
old := Some n
true
static let createTracker : (option<'a -> 'a -> bool>) -> 'a -> bool =
if typeof<IVersioned>.IsAssignableFrom typeof<'a> then
fun eq ->
let eq = defaultArg eq (fun a b -> System.Object.Equals(a,b))
let old = ref None
fun n ->
let v = getVersion n
match !old with
| None ->
old := Some (n, v)
true
| Some (o,ov) ->
if ov = v && eq o n then
false
else
old := Some (n, v)
true
else createSimpleTracker
static let createVersionOnlyTracker : unit -> 'a -> bool =
if typeof<IVersioned>.IsAssignableFrom typeof<'a> then
fun () ->
let old = ref None
fun n ->
let v = getVersion n
match !old with
| None ->
old := Some v
true
| Some ov ->
if ov = v then
false
else
old := Some v
true
else
fun () n -> false
static member CreateTracker eq = createTracker eq
static member CreateDefaultTracker() = createTracker None
static member CreateCustomTracker eq = createTracker (Some eq)
static member CreateVersionOnlyTracker() = createVersionOnlyTracker ()
let track<'a> : 'a -> bool =
ChangeTracker<'a>.CreateDefaultTracker()
let trackCustom<'a> (eq : option<'a -> 'a -> bool>) : 'a -> bool =
ChangeTracker<'a>.CreateTracker eq
let trackVersion<'a> : 'a -> bool =
ChangeTracker<'a>.CreateVersionOnlyTracker()
/// <summary>
/// ModRef<'a> represents a changeable input
/// cell which can be changed by the user and
/// implements IMod<'a>
/// </summary>
type ModRef<'a>(value : 'a) =
inherit AdaptiveObject()
let mutable value = value
let mutable cache = value
let tracker = ChangeTracker.trackVersion<'a>
let mutable changed = None
let getChanged() =
match changed with
| None ->
let c = Event<EventHandler<EventArgs>, EventArgs>()
changed <- Some c
c
| Some c ->
c
member x.UnsafeCache
with get() = value
and set v = value <- v
member x.Value
with get() = value
and set v =
if tracker v || not <| Object.Equals(v, value) then
value <- v
let fin =
match changed with
| Some c -> Some (fun () -> c.Trigger(x, EventArgs.Empty))
| None -> None
x.MarkOutdated(fin)
member x.GetValue(token : AdaptiveToken) =
x.EvaluateAlways token (fun token ->
if x.OutOfDate then
cache <- value
cache
)
[<CLIEvent>]
member x.Changed =
getChanged().Publish
override x.ToString() =
sprintf "{ value = %A }" value
interface IMod with
member x.IsConstant = false
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'a> with
member x.GetValue(caller) = x.GetValue(caller)
interface IModRef<'a> with
member x.Value
with get () = x.Value
and set v = x.Value <- v
member x.UnsafeCache
with get() = x.UnsafeCache
and set v = x.UnsafeCache <- v
[<CLIEvent>]
member x.Changed = x.Changed
// ConstantMod<'a> represents a constant mod-cell
// and implements IMod<'a> (making use of the core
// class ConstantObject). Note that ConstantMod<'a> allows
// computations to be delayed (which is useful if the
// creation of the value is computationally expensive)
// Note that constant cells are considered equal whenever
// their content is equal. Therefore equality checks will
// force the evaluation of a constant cell.
type ConstantMod<'a> =
class
inherit ConstantObject
val mutable private value : Lazy<'a>
member x.Value =
x.value.Value
member x.GetValue(token : AdaptiveToken) =
x.value.Value
interface IMod with
member x.IsConstant = true
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'a> with
member x.GetValue(caller) = x.GetValue(caller)
override x.GetHashCode() =
let v = x.value.Value :> obj
if isNull v then 0
else v.GetHashCode()
override x.Equals o =
if Object.ReferenceEquals(x, o) then
true
else
match o with
| :? IMod<'a> as o when o.IsConstant ->
System.Object.Equals(x.value.Value, o.GetValue(Unchecked.defaultof<AdaptiveToken>))
| _ -> false
override x.ToString() =
x.value.Value.ToString()
new(value : 'a) = ConstantMod<'a>(System.Lazy<'a>.CreateFromValue value)
new(compute : unit -> 'a) = ConstantMod<'a>( lazy (compute()) )
new(l : Lazy<'a>) = { value = l }
end
/// DefaultingModRef<'a> represents a mod ref with an adaptive
/// default value. The resulting IMod corresponds to the default
/// value unless a custom value is set to the ref.
/// By calling Reset (), the initial behaviour can be restored,
/// i.e. the resulting value is dependent on the adaptive default
/// value.
type DefaultingModRef<'a>(computed : IMod<'a>) =
inherit AdaptiveObject()
let mutable cache = Unchecked.defaultof<'a>
let mutable isComputed = true
let mutable tracker = ChangeTracker.trackVersion<'a>
let mutable changedEvt = None
let getChanged() =
match changedEvt with
| None ->
let c = Event<EventHandler<EventArgs>, EventArgs>()
changedEvt <- Some c
c
| Some c ->
c
member x.GetValue(token) =
x.EvaluateAlways token (fun token ->
if x.OutOfDate && isComputed then
let v = computed.GetValue(token)
cache <- v
v
else
cache
)
member x.Reset() =
if not isComputed then
tracker <- ChangeTracker.trackVersion<'a>
isComputed <- true
let fin =
match changedEvt with
| Some c -> Some (fun () -> c.Trigger(x, EventArgs.Empty))
| None -> None
x.MarkOutdated(fin)
member x.Value
with get() =
if isComputed then x.GetValue(AdaptiveToken.Top)
else cache
and set v =
let changed =
if isComputed then
computed.RemoveOutput x
isComputed <- false
x.Level <- 0
true
else
tracker v || not <| Object.Equals(v, cache)
if changed then
cache <- v
let fin =
match changedEvt with
| Some c -> Some (fun () -> c.Trigger(x, EventArgs.Empty))
| None -> None
x.MarkOutdated(fin)
member x.UnsafeCache
with get() = cache
and set v =
if isComputed then
computed.RemoveOutput x
isComputed <- false
x.Level <- 0
cache <- v
[<CLIEvent>]
member x.Changed =
getChanged().Publish
override x.ToString() =
if isComputed then sprintf "%A" computed
else sprintf "{ value = %A }" cache
interface IMod with
member x.IsConstant = false
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'a> with
member x.GetValue(caller) = x.GetValue(caller)
interface IModRef<'a> with
member x.Value
with get () = x.Value
and set v = x.Value <- v
member x.UnsafeCache
with get() = x.UnsafeCache
and set v = x.UnsafeCache <- v
[<CLIEvent>]
member x.Changed = x.Changed
/// <summary>
/// defines functions for composing mods and
/// managing evaluation order, etc.
/// </summary>
module Mod =
let private modEvaluateProbe = Symbol.Create "[Mod] evaluation"
let private modComputeProbe = Symbol.Create "[Mod] compute"
(*
// the attribute system needs to know how to "unpack"
// modifiable cells for inherited attributes.
// we therefore need to register a function doing that
[<OnAardvarkInit>]
let initialize() =
Report.BeginTimed "initializing mod system"
Aardvark.Base.Ag.unpack <- fun o ->
match o with
| :? IMod as o -> o.GetValue(AdaptiveToken.Top)
| _ -> o
Report.End() |> ignore
open System.Reflection
*)
[<AbstractClass>]
type AbstractMod<'a> =
class
inherit AdaptiveObject
val mutable public cache : 'a
// val mutable public scope : Ag.Scope
abstract member Compute : AdaptiveToken -> 'a
member x.GetValue(token) =
x.EvaluateAlways token (fun token ->
if x.OutOfDate then
//Ag.useScope x.scope (fun () ->
x.cache <- x.Compute(token)
//)
x.cache
)
override x.Mark () =
x.cache <- Unchecked.defaultof<_>
true
override x.ToString() =
if x.OutOfDate then sprintf "{ cache = %A (outOfDate) }" x.cache
else sprintf "{ value = %A }" x.cache
interface IMod with
member x.IsConstant = false
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'a> with
member x.GetValue(caller) = x.GetValue(caller)
new() =
{ cache = Unchecked.defaultof<'a>; (* scope = Ag.getContext() *) }
end
[<AbstractClass>]
type AbstractDirtyTrackingMod<'i, 'a when 'i :> IAdaptiveObject> =
class
inherit DirtyTrackingAdaptiveObject<'i>
val mutable public cache : 'a
//val mutable public scope : Ag.Scope
abstract member Compute : AdaptiveToken * HashSet<'i> -> 'a
member x.GetValue(token) =
x.EvaluateAlways' token (fun (token : AdaptiveToken) (dirty : HashSet<'i>) ->
if x.OutOfDate then
//Ag.useScope x.scope (fun () ->
x.cache <- x.Compute(token,dirty)
//)
x.cache
)
override x.Mark () =
x.cache <- Unchecked.defaultof<_>
true
override x.ToString() =
if x.OutOfDate then sprintf "{ cache = %A (outOfDate) }" x.cache
else sprintf "{ value = %A }" x.cache
interface IMod with
member x.IsConstant = false
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'a> with
member x.GetValue(caller) = x.GetValue(caller)
new() =
{ cache = Unchecked.defaultof<'a> (* ; scope = Ag.getContext() *) }
end
[<AbstractClass>]
type AbstractModWithFinalizer<'a>() =
inherit AbstractMod<'a>()
abstract member Release : unit -> unit
default x.Release() = ()
override x.Finalize() =
try
x.Release()
x.cache <- Unchecked.defaultof<_> // TODO: not sure whether this makes things worse or better
//x.scope <- Ag.emptyScope
with e ->
()
// LazyMod<'a> (as the name suggests) implements IMod<'a>
// and will be evaluated lazily (if not forced to be eager
// by a callback or subsequent eager computations)
type LazyMod<'a> =
class
inherit AbstractMod<'a>
val mutable public inputs : seq<IAdaptiveObject>
val mutable public compute : AdaptiveToken -> 'a
override x.Inputs = x.inputs
override x.Compute(token) = x.compute(token)
new(inputs : seq<IAdaptiveObject>, compute) =
{ inputs = inputs; compute = compute }
end
// EagerMod<'a> re-uses LazyMod<'a> and extends it with
// a Mark function evaluating the cell whenever it is marked
// as outOfDate. Since eager mods might want to "cancel"
// the change propagation process when equal values are
// observed EagerMod can also be created with a custom
// equality function.
type internal EagerMod<'a>(input : IMod<'a>, eq : option<'a -> 'a -> bool>) as this =
inherit LazyMod<'a>(Seq.singleton (input :> IAdaptiveObject), fun s -> input.GetValue(s))
let hasChanged = ChangeTracker.trackCustom<'a> eq
do hasChanged (this.GetValue(AdaptiveToken.Top)) |> ignore
member x.Input = input
override x.Mark() =
base.Mark() |> ignore
let oldState = AdaptiveObject.UnsaveEvaluationDepth
AdaptiveObject.UnsaveEvaluationDepth <- 0
let newValue = x.GetValue(AdaptiveToken.Top)
AdaptiveObject.UnsaveEvaluationDepth <- oldState
x.OutOfDate <- false
if hasChanged newValue then
x.cache <- newValue
true
else
false
new(compute) = EagerMod(compute, None)
// LaterMod<'a> is a special construct for forcing lazy
// evaluation for a specific cell. Note that this needs to
// be "transparent" (knowning its input) since we need to
// be able to undo the effect.
type internal LaterMod<'a>(input : IMod<'a>) =
inherit LazyMod<'a>(Seq.singleton (input :> IAdaptiveObject), fun s -> input.GetValue(s))
override x.Inputs = Seq.singleton (input :> IAdaptiveObject)
member x.Input = input
// TimeMod represents a changeable cell which will always
// be outdated as soon as control-flow leaves the mod system.
// Its value will always be the time when pulled.
// NOTE that this cannot be implemented using the other mod-types
// since caching (of the current time) is not desired here.
type internal TimeMod private() =
inherit AdaptiveObject()
static let instance = TimeMod() :> IMod<DateTime>
static member Instance = instance
member x.GetValue(token : AdaptiveToken) =
let ti = AdaptiveObject.Time
x.EvaluateAlways token (fun token ->
lock ti (fun () -> ti.Outputs.Add x |> ignore)
DateTime.Now
)
interface IMod with
member x.IsConstant = false
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<DateTime> with
member x.GetValue(caller) = x.GetValue(caller)
type internal DecoratorMod<'b>(m : IMod, f : obj -> 'b) =
inherit AdaptiveDecorator(m)
member x.GetValue(token : AdaptiveToken) =
m.GetValue(token) |> f
interface IMod with
member x.IsConstant = m.IsConstant
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'b> with
member x.GetValue(caller) = x.GetValue(caller)
type internal DecoratorMod<'a, 'b>(m : IMod<'a>, f : 'a -> 'b) =
inherit AdaptiveDecorator(m)
member x.GetValue(token : AdaptiveToken) =
m.GetValue(token) |> f
interface IMod with
member x.IsConstant = m.IsConstant
member x.GetValue(caller) = x.GetValue(caller) :> obj
interface IMod<'b> with
member x.GetValue(caller) = x.GetValue(caller)
type internal MapMod<'a, 'b>(inner : IMod<'a>, f : 'a -> 'b) =
inherit AbstractMod<'b>()
member x.Inner = inner
member x.F = f
override x.Inputs =
Seq.singleton (inner :> IAdaptiveObject)
override x.Compute(token) =
inner.GetValue token |> f
type internal Map2Mod<'a, 'b, 'c>(a : IMod<'a>, b : IMod<'b>, f : 'a -> 'b -> 'c) =
inherit AbstractMod<'c>()
member x.Left = a
member x.Right = b
member x.F = f
override x.Inputs =
Seq.ofList [a :> IAdaptiveObject; b :> IAdaptiveObject]
override x.Compute(token) =
f (a.GetValue token) (b.GetValue token)
type internal BindMod<'a, 'b>(m : IMod<'a>, f : 'a -> IMod<'b>) =
inherit AbstractMod<'b>()
let mutable inner : option<'a * IMod<'b>> = None
let mutable mChanged = 1
override x.Inputs =
seq {
yield m :> IAdaptiveObject
match inner with
| Some (_,i) -> yield i :> IAdaptiveObject
| None -> ()
}
override x.InputChanged(t, i) =
if i.Id = m.Id then
mChanged <- 1
override x.Compute(token) =
// whenever the result is outOfDate we
// need to pull the input's value
// Note that the input is not necessarily outOfDate at this point
let v = m.GetValue token
let changed = System.Threading.Interlocked.Exchange(&mChanged, 0)
//let cv = hasChanged v
let mChanged = changed <> 0
match inner with
// if the function argument has not changed
// since the last execution we expect f to return
// the identical cell
| Some (v', inner) when not mChanged ->
// since the inner cell might be outOfDate we
// simply pull its value and don't touch any in-/outputs.
inner.GetValue token
| _ ->
// whenever the argument's value changed we need to
// re-execute the function and store the new inner cell.
let i = f v :> IMod<_>
let old = inner
inner <- Some (v, i)
match old with
// if there was an old inner cell which
// is different from the new one we
// remove the resulting cell from the old
// outputs and add it to the new ones.
| Some (_,old) when old <> i ->
old.RemoveOutput x |> ignore
// in any other case the graph remained
// constant and we don't change a thing.
| _ -> ()
// finally we pull the value from the
// new inner cell.
i.GetValue token
(*
type internal Bind2Mod<'a, 'b, 'c>(ma : IMod<'a>, mb : IMod<'b>, f : 'a -> 'b -> IMod<'c>) =
inherit AbstractMod<'c>()
static let empty = ref HSet.empty
let mutable inner : option<'a * 'b * IMod<'c>> = None
let mutable changedInputs = empty
override x.Inputs =
seq {
yield ma :> IAdaptiveObject
yield mb :> IAdaptiveObject
match inner with
| Some (_,_,i) -> yield i :> IAdaptiveObject
| None -> ()
}
override x.InputChanged(t, i) =
System.Threading.Interlocked.Change(&changedInputs, fun s -> ref (HSet.add i !s)) |> ignore
override x.Compute(token) =
let changed = !System.Threading.Interlocked.Exchange(&changedInputs, empty)
let a = ma.GetValue token
let b = mb.GetValue token
let ca = HSet.contains (ma :> IAdaptiveObject) changed
let cb = HSet.contains (mb :> IAdaptiveObject) changed
match inner with
| Some (va, vb, inner) when not ca && not cb ->
inner.GetValue token
| _ ->
let i = f a b :> IMod<_>
let old = inner
inner <- Some (a, b, i)
match old with
| Some (_,_,old) when old <> i ->
old.RemoveOutput x |> ignore
| _ -> ()
i.GetValue token
*)
type internal DynamicMod<'a>(f : unit -> IMod<'a>) =
inherit AbstractMod<'a>()
let inner = lazy (f())
override x.Inputs =
if inner.IsValueCreated then Seq.singleton (inner.Value :> IAdaptiveObject)
else Seq.empty
override x.Compute(token) =
inner.Value.GetValue token
let private scoped (f : 'a -> 'b) = f
//let private scoped (f : 'a -> 'b) =
// let scope = Ag.getContext()
// fun v -> Ag.useScope scope (fun () -> f v)
let private callbackTable = ConditionalWeakTable<IMod, ConcurrentDictionary<IDisposable, int>>()
/// <summary>
/// creates a custom modifiable cell using the given
/// compute function. If no inputs are added to the
/// cell it will actually be constant.
/// However the system will not statically assume the
/// cell to be constant in any case.
/// </summary>
let custom (compute : AdaptiveToken -> 'a) : IMod<'a> =
LazyMod(Seq.empty, compute) :> IMod<_>
/// <summary>
/// registers a callback for execution whenever the
/// cells value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// Note that this function does not hold on to the created disposable, i.e.
/// if the disposable as well as the source dies, the callback dies as well.
/// If you use callbacks to propagate changed to other mods by using side-effects
/// (which you should not do), use registerCallbackKeepDisposable in order to
/// create a gc to the fresh disposable.
/// registerCallbackKeepDisposable only destroys the callback, iff the associated
/// disposable is disposed.
/// </summary>
let unsafeRegisterCallbackNoGcRoot (f : 'a -> unit) (m : IMod<'a>) =
let result =
m.AddEvaluationCallback(fun self ->
m.GetValue(self) |> f
)
let set = callbackTable.GetOrCreateValue(m)
set.TryAdd (result, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
result.Dispose()
set.TryRemove result |> ignore
}
[<Obsolete("use unsafeRegisterCallbackNoGcRoot or unsafeRegisterCallbackKeepDisposable instead")>]
let registerCallback f m = unsafeRegisterCallbackNoGcRoot f m
let private undyingCallbacks = ConcurrentDictionary<IDisposable, int>()
/// <summary>
/// registers a callback for execution whenever the
/// set's value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// In contrast to registerCallbackNoGcRoot, this function holds on to the
/// fresh disposable, i.e. even if the input set goes out of scope,
/// the disposable still forces the complete computation to exist.
/// When disposing the assosciated disposable, the gc root disappears and
/// the computation can be collected.
/// </summary>
let unsafeRegisterCallbackKeepDisposable f m =
let d = unsafeRegisterCallbackNoGcRoot f m
undyingCallbacks.TryAdd (d, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
d.Dispose()
undyingCallbacks.TryRemove d |> ignore
}
/// <summary>
/// changes the value of the given cell. Note that this
/// function may only be used inside a current transaction.
/// </summary>
let change (m : IModRef<'a>) (value : 'a) =
m.Value <- value
/// <summary>
/// changes the value of the given cell after the current evaluation
/// phase has finished
/// </summary>
let changeAfterEvaluation (m : IModRef<'a>) (value : 'a) =
m.UnsafeCache <- value
AdaptiveObject.Time.Outputs.Add m |> ignore
/// <summary>
/// initializes a new constant cell using the given value.
/// </summary>
let constant (v : 'a) =
ConstantMod<'a>(v) :> IMod<_>
/// <summary>
/// initializes a new modifiable input cell using the given value.
/// </summary>
let init (v : 'a) =
ModRef v
/// see DefaultingModRef
let initDefault (initial : IMod<'a>) =
DefaultingModRef initial
/// <summary>
/// initializes a new constant cell using the given lazy value.
/// </summary>
let delay (f : unit -> 'a) =
ConstantMod<'a> (scoped f) :> IMod<_>
/// <summary>
/// adaptively applies a function to a cell's value
/// resulting in a new dependent cell.
/// </summary>
let map (f : 'a -> 'b) (m : IMod<'a>) =
if m.IsConstant then
let f = scoped f
delay (fun () -> m.GetValue(AdaptiveToken.Empty) |> f)
else
MapMod(m, f) :> IMod<_>
/// <summary>
/// adaptively applies a function to two cell's values
/// resulting in a new dependent cell.
/// </summary>
let map2 (f : 'a -> 'b -> 'c) (m1 : IMod<'a>) (m2 : IMod<'b>)=
match m1.IsConstant, m2.IsConstant with
| (true, true) ->
delay (fun () -> f (m1.GetValue(AdaptiveToken.Empty)) (m2.GetValue(AdaptiveToken.Empty)))
| (true, false) ->
MapMod(m2, fun b -> f (m1.GetValue(AdaptiveToken.Empty)) b) :> IMod<_>
| (false, true) ->
MapMod(m1, fun a -> f a (m2.GetValue(AdaptiveToken.Empty))) :> IMod<_>
| (false, false) ->
Map2Mod(m1, m2, f) :> IMod<_>
/// <summary>
/// creates a custom modifiable cell using the given
/// compute function and adds all given inputs to the
/// resulting cell.
/// </summary>
[<Obsolete("Use Mod.custom insteand: explicit input tracking is no longer neccesary")>]
let mapCustom (f : AdaptiveToken -> 'a) (inputs : list<#IAdaptiveObject>) =
LazyMod(List.map (fun a -> a :> IAdaptiveObject) inputs, f) :> IMod<_>
/// <summary>
/// adaptively applies a function to a cell's value
/// without creating a new cell (maintaining equality, id, etc.)
/// NOTE: this combinator assumes that the given function
/// is really cheap (e.g. field-access, cast, etc.)
/// </summary>
let mapFast (f : 'a -> 'b) (m : IMod<'a>) =
DecoratorMod<'a, 'b>(m, f) :> IMod<_>
/// <summary>
/// adaptively applies a function to a cell's value
/// without creating a new cell (maintaining equality, id, etc.)
/// NOTE: this combinator assumes that the given function
/// is really cheap (e.g. field-access, cast, etc.)
/// </summary>
let mapFastObj (f : obj -> 'b) (m : IMod) =
DecoratorMod<'b>(m, f) :> IMod<_>
/// <summary>
/// adaptively casts a value to the desired type
/// and fails if the cast is invalid.
/// NOTE that this does not create a new cell but instead
/// "decorates" the given cell.
/// </summary>
let inline cast (m : IMod) : IMod<'b> =
mapFastObj unbox m
/// <summary>
/// creates a modifiable cell using the given inputs
/// and compute function (being evaluated whenever any of
/// the inputs changes.
/// </summary>
let mapN (f : seq<'a> -> 'b) (inputs : seq<#IMod<'a>>) =
let inputs : list<IMod<'a>> = Seq.toList (Seq.cast inputs)
custom (fun token ->
let values = inputs |> List.map (fun i -> i.GetValue token)
f values
)
//MapNMod(Seq.toList (Seq.cast inputs), List.toSeq >> f) :> IMod<_>
// let objs = inputs |> Seq.cast |> Seq.toList
// objs |> mapCustom (fun s ->
// let values = inputs |> Seq.map (fun m -> m.GetValue s) |> Seq.toList
// f values
// )
/// <summary>
/// adaptively applies a function to a cell's value
/// and returns a new dependent cell holding the inner
/// cell's content.
/// </summary>
let bind (f : 'a -> #IMod<'b>) (m : IMod<'a>) =
if m.IsConstant then
m.GetValue(AdaptiveToken.Empty) |> f :> IMod<_>
else
BindMod(m, fun v -> f v :> _) :> IMod<_>
/// <summary>
/// adaptively applies a function to two cell's values
/// and returns a new dependent cell holding the inner
/// cell's content.
/// </summary>
let bind2 (f : 'a -> 'b -> #IMod<'c>) (ma : IMod<'a>) (mb : IMod<'b>) =
match ma.IsConstant, mb.IsConstant with
| (true, true) ->
f (ma.GetValue(AdaptiveToken.Empty)) (mb.GetValue(AdaptiveToken.Empty)) :> IMod<_>
| (false, true) ->
bind (fun a -> (f a (mb.GetValue(AdaptiveToken.Empty))) :> IMod<_>) ma
| (true, false) ->
bind (fun b -> (f (ma.GetValue(AdaptiveToken.Empty)) b) :> IMod<_>) mb
| (false, false) ->
failwith "TBD"
//Bind2Mod(ma, mb, fun a b -> (f a b) :> _) :> IMod<_>
/// <summary>
/// creates a dynamic cell using the given function
/// while maintaining lazy evaluation.
/// </summary>
let dynamic (f : unit -> IMod<'a>) =
DynamicMod(f) :> IMod<_>
/// <summary>
/// forces the evaluation of a cell and returns its current value
/// </summary>
let force (m : IMod<'a>) =
m.GetValue(AdaptiveToken.Top)
/// <summary>
/// creates a new cell forcing the evaluation of the
/// given one during change propagation (making it eager)
/// </summary>
let rec onPush (m : IMod<'a>) =
if m.IsConstant then
m.GetValue(AdaptiveToken.Empty) |> ignore
m
else
match m with
| :? LaterMod<'a> as m -> onPush m.Input
| :? EagerMod<'a> -> m
| _ ->
let res = EagerMod(m)
res.GetValue(AdaptiveToken.Top) |> ignore
res :> IMod<_>
/// <summary>
/// creates a new cell forcing the evaluation of the
/// given one during change propagation (making it eager)
/// using a
/// </summary>
let rec onPushCustomEq (eq : 'a -> 'a -> bool) (m : IMod<'a>) =
if m.IsConstant then
m.GetValue(AdaptiveToken.Empty) |> ignore
m
else
match m with
| :? LaterMod<'a> as m -> onPush m.Input
| :? EagerMod<'a> -> m
| _ ->
let res = EagerMod(m, Some eq)
res :> IMod<_>
/// <summary>
/// creates a new cell forcing the evaluation of the
/// given one to be lazy (on demand)
/// NOTE: onPull does not maintain equality
/// for constant-cells
/// </summary>
let rec onPull (m : IMod<'a>) =
if m.IsConstant then
LaterMod(m) :> IMod<_>
else
match m with
| :? EagerMod<'a> as m ->
onPull m.Input
| _ -> m
/// <summary>
/// creates a new cell by starting the given async computation.
/// until the computation is completed the cell will contain None.
/// as soon as the computation is finished it will contain the resulting value.
/// </summary>
let asyncTask (task : System.Threading.Tasks.Task<'a>) : IMod<option<'a>> =
if task.IsCompleted then
constant (Some task.Result)
else
let r = init None
let a = task.GetAwaiter()
a.OnCompleted(fun () ->
transact (fun () ->
let v = a.GetResult()
change r (Some v)
)
)
r :> IMod<_>
/// <summary>
/// creates a new cell by starting the given async computation.
/// until the computation is completed the cell will contain None.
/// as soon as the computation is finished it will contain the resulting value.
/// </summary>
let async (a : Async<'a>) : IMod<option<'a>> =
let task = a |> Async.StartAsTask
asyncTask task
/// <summary>
/// creates a new cell by starting the given async computation.
/// until the computation is completed the cell will contain the default value.
/// as soon as the computation is finished it will contain the resulting value.
/// </summary>
let asyncWithDefault (defaultValue : 'a) (a : Async<'a>) : IMod<'a> =
let task = a |> Async.StartAsTask
if task.IsCompleted then
constant task.Result
else
let r = init defaultValue
let a = task.GetAwaiter()
a.OnCompleted(fun () ->
transact (fun () ->
let v = a.GetResult()
change r v
)
)
r :> IMod<_>
/// <summary>
/// creates a new cell starting the given async computation when a value is requested for the first time.
/// until the computation is completed the cell will contain None.
/// as soon as the computation is finished it will contain the resulting value.
/// </summary>
let lazyAsync (run : Async<'a>) : IMod<option<'a>> =
let task : ref<option<System.Threading.Tasks.Task<'a>>> = ref None
let res = ref Unchecked.defaultof<_>
res :=
custom (fun s ->
match !task with
| Some t ->
if t.IsCompleted then
let res = t.Result
Some res
else
None
| None ->
let t = Async.StartAsTask run
task := Some t
t.GetAwaiter().OnCompleted(fun () -> transact (fun () -> res.Value.MarkOutdated()))
None
)
!res
/// <summary>
/// creates a new cell starting the given async computation when a value is requested for the first time.
/// until the computation is completed the cell will contain the default value.
/// as soon as the computation is finished it will contain the resulting value.
/// </summary>
let lazyAsyncWithDefault (defaultValue : 'a) (run : Async<'a>) : IMod<'a> =
let task : ref<option<System.Threading.Tasks.Task<'a>>> = ref None
let res = ref Unchecked.defaultof<_>
res :=
custom (fun s ->
match !task with
| Some t ->
if t.IsCompleted then
let res = t.Result
res
else
defaultValue
| None ->
let t = Async.StartAsTask run
task := Some t
t.GetAwaiter().OnCompleted(fun () -> transact (fun () -> res.Value.MarkOutdated()))
defaultValue
)
!res
/// <summary>
/// creates a new cell by starting the given async computation.
/// upon evaluation of the cell it will wait until the async computation has finished
/// </summary>
let start (run : Async<'a>) =
let task = run |> Async.StartAsTask
if task.IsCompleted then
constant task.Result
else
custom (fun s ->
task.Result
)
let useCurrent<'a when 'a :> IDisposable> (f : AdaptiveToken -> 'a) : IMod<'a> =
let current = ref None
custom (fun self ->
match !current with
| None ->
let v = f self
current := Some v
v
| Some v ->
v.Dispose()
let v = f self
current := Some v
v
)
/// <summary>
/// a changeable cell which will always be outdated when control-flow leaves
/// the mod-system. Its value will always hold the current time (DateTime.Now)
/// </summary>
let time = TimeMod.Instance
[<Obsolete("Use Mod.init instead")>]
let inline initMod (v : 'a) = init v
[<Obsolete("Use Mod.constant instead")>]
let inline initConstant (v : 'a) = constant v
[<Obsolete("Use Mod.onPush instead")>]
let inline always (m : IMod<'a>) = onPush m
[<Obsolete("Use Mod.onPull instead")>]
let inline later (m : IMod<'a>) = onPull m
[<AutoOpen>]
module ModExtensions =
// reflect the type argument used by a given
// mod-type or return None if no mod type.
let rec private extractModTypeArg (t : Type) (typedef : Type) =
if t.IsGenericType && t.GetGenericTypeDefinition() = typedef then
Some (t.GetGenericArguments().[0])
else
let iface = t.GetInterface(typedef.FullName)
if isNull iface then None
else extractModTypeArg iface typedef
/// <summary>
/// matches all types implementing IMod<'a> and
/// extracts typeof<'a> using reflection.
/// </summary>
let (|ModRefOf|_|) (t : Type) =
match extractModTypeArg t typedefof<ModRef<_>> with
| Some t -> ModRefOf t |> Some
| None -> None
let (|ModOf|_|) (t : Type) =
match extractModTypeArg t typedefof<IMod<_>> with
| Some t -> ModOf t |> Some
| None -> None
type IOpReader<'ops> =
inherit IAdaptiveObject
inherit IDisposable
abstract member GetOperations : AdaptiveToken -> 'ops
type IOpReader<'state, 'ops> =
inherit IOpReader<'ops>
abstract member State : 'state
type Monoid<'a> =
{
/// determines whether the given value is empty
misEmpty : 'a -> bool
/// the empty element
mempty : 'a
/// appends to values
mappend : 'a -> 'a -> 'a
}
type Traceable<'s, 'ops> =
{
/// the monoid instance for 'ops
tops : Monoid<'ops>
/// the empty state
tempty : 's
/// applies the given operations to the state and
/// returns the new state accompanied by (possibly) reduced ops (removing useless ops)
tapply : 's -> 'ops -> 's * 'ops
/// differentiates two states and returns the needed ops
tcompute : 's -> 's -> 'ops
/// determines whether or not a history should be pruned although it is still referntiable.
/// the first argument is the base-state for that history and the second argument is the number
/// of ops that would need to be applied.
/// when returning true the history implementation will discard the history and reproduce it on demand using
/// the above compute function.
tcollapse : 's -> 'ops -> bool
}
[<AbstractClass>]
type AbstractReader<'ops>(t : Monoid<'ops>) =
inherit AdaptiveObject()
abstract member Release : unit -> unit
abstract member Compute : AdaptiveToken -> 'ops
abstract member Apply : 'ops -> 'ops
default x.Apply o = o
member x.GetOperations(token : AdaptiveToken) =
x.EvaluateAlways token (fun token ->
if x.OutOfDate then
//Ag.useScope scope (fun () ->
x.Compute token |> x.Apply
//)
else
t.mempty
)
member x.Dispose() =
x.Release()
x.Outputs.Clear()
interface IDisposable with
member x.Dispose() = x.Dispose()
interface IOpReader<'ops> with
member x.GetOperations c = x.GetOperations c
[<AbstractClass>]
type AbstractReader<'s, 'ops>(t : Traceable<'s, 'ops>) =
inherit AbstractReader<'ops>(t.tops)
let mutable state = t.tempty
override x.Apply o =
let (s, o) = t.tapply state o
state <- s
o
member x.State = state
interface IOpReader<'s, 'ops> with
member x.State = state
[<AbstractClass>]
type AbstractDirtyReader<'t, 'ops when 't :> IAdaptiveObject>(t : Monoid<'ops>) =
inherit DirtyTrackingAdaptiveObject<'t>()
abstract member Release : unit -> unit
abstract member Compute : AdaptiveToken * HashSet<'t> -> 'ops
abstract member Apply : 'ops -> 'ops
default x.Apply o = o
member x.GetOperations(token : AdaptiveToken) =
x.EvaluateAlways' token (fun token dirty ->
if x.OutOfDate then
//Ag.useScope scope (fun () ->
x.Compute(token, dirty) |> x.Apply
//)
else
t.mempty
)
member x.Dispose() =
x.Release()
x.Outputs.Clear()
interface IDisposable with
member x.Dispose() = x.Dispose()
interface IOpReader<'ops> with
member x.GetOperations c = x.GetOperations c
type DisposeThread private() =
static let queue = new BlockingCollection<IDisposable>()
static let runner =
startThread (fun () ->
while true do
let v = queue.Take()
try v.Dispose()
with e ->
// Log.warn "disposal of %A faulted: %A" v e
()
)
static member Dispose(d : 'a) =
queue.Add(d :> IDisposable)
type LazyWithFinalizer<'a when 'a :> IDisposable>(create : unit -> 'a) =
let mutable value = Unchecked.defaultof<'a>
let mutable created = false
member x.Value =
if created then
value
else
lock x (fun () ->
if created then
value
else
value <- create()
created <- true
value
)
override x.Finalize() =
if created then
DisposeThread.Dispose(value)
created <- false
value <- Unchecked.defaultof<_>
[<AllowNullLiteral>]
type RelevantNode<'s, 'a> =
class
val mutable public Prev : RelevantNode<'s, 'a>
val mutable public Next : RelevantNode<'s, 'a>
val mutable public RefCount : int
val mutable public BaseState : 's
val mutable public Value : 'a
new(p, s, v, n) = { Prev = p; Next = n; RefCount = 0; BaseState = s; Value = v }
end
[<AllowNullLiteral>]
type History<'s, 'op> private(input : option<LazyWithFinalizer<IOpReader<'op>>>, t : Traceable<'s, 'op>, finalize : 'op -> unit) =
inherit AdaptiveObject()
let mutable state : 's = t.tempty
let mutable first : RelevantNode<'s, 'op> = null
let mutable last : RelevantNode<'s, 'op> = null
let mutable count : int = 0
let rec tryCollapse (node : RelevantNode<'s, 'op>) =
if t.tcollapse node.BaseState node.Value then
let next = node.Next
let prev = node.Prev
finalize node.Value
node.Value <- Unchecked.defaultof<_>
node.Prev <- null
node.Next <- null
node.RefCount <- -1
count <- count - 1
if isNull next then last <- prev
else next.Prev <- prev
if isNull prev then first <- next
else prev.Next <- next
tryCollapse next
let append (op : 'op) =
// only append non-empty ops
if not (t.tops.misEmpty op) then
// apply the op to the state
let s, op = t.tapply state op
state <- s
// if op got empty do not append it
if not (t.tops.misEmpty op) then
// it last is null no reader is interested in ops.
// therefore we simply discard them here
if not (isNull last) then
// last is non-null and no one pulled it yet
// so we can append our op to it
last.Value <- t.tops.mappend last.Value op
tryCollapse first
else
finalize op
true
else
false
else
false
let addRefToLast() =
if isNull last then
// if there is no last (the history is empty) we append
// a new empty last with no ops and set its refcount to 1
let n = RelevantNode(null, state, t.tops.mempty, null)
n.RefCount <- 1
last <- n
first <- n
count <- count + 1
n
else
if t.tops.misEmpty last.Value then
// if last has no ops we can reuse it here
last.RefCount <- last.RefCount + 1
last
else
// if last contains ops we just consumed it and therefore
// need a new empty last
let n = RelevantNode(last, state, t.tops.mempty, null)
last.Next <- n
last <- n
n.RefCount <- 1
count <- count + 1
n
let mergeIntoLast (node : RelevantNode<'s, 'op>) =
if node.RefCount = 1 then
let res = node.Value
let next = node.Next
let prev = node.Prev
finalize node.Value
node.Value <- Unchecked.defaultof<_>
node.Prev <- null
node.Next <- null
node.RefCount <- -1
count <- count - 1
if isNull next then last <- prev
else next.Prev <- prev
if isNull prev then
first <- next
res, next
else
prev.Next <- next
prev.Value <- t.tops.mappend prev.Value res
res, next
else
node.RefCount <- node.RefCount - 1
node.Value, node.Next
let isInvalid (node : RelevantNode<'s, 'op>) =
isNull node || node.RefCount < 0
let isValid (node : RelevantNode<'s, 'op>) =
not (isNull node) && node.RefCount >= 0
member private x.Update (self : AdaptiveToken) =
if x.OutOfDate then
match input with
| Some c ->
let v = c.Value.GetOperations self
append v |> ignore
| None ->
()
member x.State = state
member x.Trace = t
member x.Perform(op : 'op) =
lock x (fun () ->
let changed = append op
if changed then x.MarkOutdated()
changed
)
member x.Remove(token : RelevantNode<'s, 'op>) =
lock x (fun () ->
if isValid token then
mergeIntoLast token |> ignore
)
member x.Read(token : AdaptiveToken, old : RelevantNode<'s, 'op>, oldState : 's) =
x.EvaluateAlways token (fun token ->
x.Update token
if isInvalid old then
let ops = t.tcompute oldState state
let node = addRefToLast()
node, ops
else
let mutable res = t.tops.mempty
let mutable current = old
while not (isNull current) do
let (o,c) = mergeIntoLast current
res <- t.tops.mappend res o
current <- c
let node = addRefToLast()
node, res
)
member x.GetValue(token : AdaptiveToken) =
x.EvaluateAlways token (fun token ->
x.Update token
state
)
member x.ReaderCount = count
member x.NewReader() =
new HistoryReader<'s, 'op>(x) :> IOpReader<'s, 'op>
new (t : Traceable<'s, 'op>, finalize : 'op -> unit) = History<'s, 'op>(None, t, finalize)
new (input : unit -> IOpReader<'op>, t : Traceable<'s, 'op>, finalize : 'op -> unit) = History<'s, 'op>(Some (LazyWithFinalizer input), t, finalize)
new (t : Traceable<'s, 'op>) = History<'s, 'op>(None, t, ignore)
new (input : unit -> IOpReader<'op>, t : Traceable<'s, 'op>) = History<'s, 'op>(Some (LazyWithFinalizer input), t, ignore)
interface IMod with
member x.IsConstant = false
member x.GetValue c = x.GetValue c :> obj
interface IMod<'s> with
member x.GetValue c = x.GetValue c
and HistoryReader<'s, 'op>(h : History<'s, 'op>) =
inherit AdaptiveObject()
let mutable h = h
let trace = h.Trace
let mutable node : RelevantNode<'s, 'op> = null
let mutable state = trace.tempty
member x.GetOperations(token : AdaptiveToken) =
x.EvaluateAlways token (fun token ->
if x.OutOfDate && not (h |> isNull) then
let nt, ops = h.Read(token, node, state)
node <- nt
state <- h.State
ops
else
trace.tops.mempty
)
member private x.Dispose(disposing : bool) =
if disposing then GC.SuppressFinalize x
let h = Interlocked.Exchange(&h,null)
if not (h |> isNull) then
lock h (fun () ->
h.Outputs.Remove x |> ignore
h.Remove node
)
node <- null
state <- trace.tempty
else ()
override x.Finalize() =
DisposeThread.Dispose {
new IDisposable with
member __.Dispose() = x.Dispose false
}
member x.Dispose() = x.Dispose true
interface IOpReader<'op> with
member x.Dispose() = x.Dispose()
member x.GetOperations c = x.GetOperations c
interface IOpReader<'s, 'op> with
member x.State = state
module History =
module Readers =
type EmptyReader<'s, 'ops>(t : Traceable<'s, 'ops>) =
inherit ConstantObject()
interface IOpReader<'ops> with
member x.Dispose() = ()
member x.GetOperations(caller) = t.tops.mempty
interface IOpReader<'s, 'ops> with
member x.State = t.tempty
type ConstantReader<'s, 'ops>(t : Traceable<'s, 'ops>, ops : Lazy<'ops>, finalState : Lazy<'s>) =
inherit ConstantObject()
let mutable state = t.tempty
let mutable initial = true
interface IOpReader<'ops> with
member x.Dispose() = ()
member x.GetOperations(caller) =
lock x (fun () ->
if initial then
initial <- false
state <- finalState.Value
ops.Value
else
t.tops.mempty
)
interface IOpReader<'s, 'ops> with
member x.State = state
let ofReader (t : Traceable<'s, 'ops>) (newReader : unit -> IOpReader<'ops>) =
History<'s, 'ops>(newReader, t)
module private HMapList =
let rec alter (k : 'k) (f : option<'v> -> option<'v>) (l : list<'k * 'v>) =
match l with
| [] ->
match f None with
| None -> []
| Some v -> [k,v]
| (k1, v1) :: rest ->
if Unchecked.equals k k1 then
match f (Some v1) with
| None -> rest
| Some v2 -> (k1, v2) :: rest
else
(k1, v1) :: alter k f rest
let rec alter' (cnt : byref<int>) (k : 'k) (f : option<'v> -> option<'v>) (l : list<'k * 'v>) =
match l with
| [] ->
match f None with
| None -> []
| Some v ->
cnt <- cnt + 1
[k,v]
| (k1, v1) :: rest ->
if Unchecked.equals k k1 then
match f (Some v1) with
| None ->
cnt <- cnt - 1
rest
| Some v2 -> (k1, v2) :: rest
else
(k1, v1) :: alter' &cnt k f rest
let rec update (k : 'k) (f : option<'v> -> 'v) (l : list<'k * 'v>) =
match l with
| [] ->
let v = f None
[k,v]
| (k1, v1) :: rest ->
if Unchecked.equals k k1 then
let v2 = f (Some v1)
(k1, v2) :: rest
else
(k1, v1) :: update k f rest
let rec add (cnt : byref<int>) (k : 'k) (v : 'v) (l : list<'k * 'v>) =
match l with
| [] ->
cnt <- cnt + 1
[k,v]
| (k1, v1) :: rest ->
if Unchecked.equals k k1 then
(k1, v) :: rest
else
(k1, v1) :: add &cnt k v rest
let rec remove (cnt : byref<int>) (k : 'k) (l : list<'k * 'v>) =
match l with
| [] -> []
| (k1, v1) :: rest ->
if Unchecked.equals k k1 then
cnt <- cnt - 1
rest
else
(k1, v1) :: remove &cnt k rest
let rec tryRemove (k : 'k) (l : list<'k * 'v>) =
match l with
| [] -> None
| (k1,v1) :: rest ->
if Unchecked.equals k k1 then
Some (v1, rest)
else
match tryRemove k rest with
| None -> None
| Some(v,rest) -> Some(v, (k1,v1)::rest)
let rec unionWith (f : 'k -> 'v -> 'v -> 'v) (l : list<'k * 'v>) (r : list<'k * 'v>) =
let newL =
l |> List.map (fun (lk, lv) ->
let other = r |> List.tryFind (fun (rk, rv) -> Unchecked.equals rk lk)
match other with
| Some (_,rv) -> (lk, f lk lv rv)
| None -> lk, lv
)
let newR =
r |> List.filter (fun (rk,_) ->
l |> List.forall (fun (lk,_) -> not (Unchecked.equals lk rk))
)
newL @ newR
let rec mergeWith (f : 'k -> option<'a> -> option<'b> -> 'c) (l : list<'k * 'a>) (r : list<'k * 'b>) =
let newL =
l |> List.choose (fun (lk, lv) ->
let other = r |> List.tryFind (fun (rk, rv) -> Unchecked.equals rk lk)
match other with
| Some (_,rv) ->
Some (lk, f lk (Some lv) (Some rv))
| None ->
Some (lk, f lk (Some lv) None)
)
let newR =
r |> List.choose (fun (rk,rv) ->
if l |> List.forall (fun (lk,_) -> not (Unchecked.equals lk rk)) then
Some(rk, f rk None (Some rv))
else
None
)
newL @ newR
let rec mergeWithOption (f : 'k -> option<'a> -> option<'b> -> option<'c>) (l : list<'k * 'a>) (r : list<'k * 'b>) =
let newL =
l |> List.choose (fun (lk, lv) ->
let other = r |> List.tryFind (fun (rk, rv) -> Unchecked.equals rk lk)
match other with
| Some (_,rv) ->
match f lk (Some lv) (Some rv) with
| Some r -> Some (lk, r)
| None -> None
| None ->
match f lk (Some lv) None with
| Some r -> Some (lk, r)
| None -> None
)
let newR =
r |> List.choose (fun (rk,rv) ->
if l |> List.forall (fun (lk,_) -> not (Unchecked.equals lk rk)) then
match f rk None (Some rv) with
| Some r -> Some(rk, r)
| None -> None
else
None
)
newL @ newR
let rec mergeWithOption' (f : 'k -> option<'a> -> option<'b> -> option<'c>) (l : list<'k * 'a>) (r : list<'k * 'b>) =
let newL =
l |> List.choose (fun (lk,lv) ->
let other = r |> List.tryFind (fun (rk,_) -> Unchecked.equals rk lk) |> Option.map snd
match f lk (Some lv) other with
| Some r -> Some (lk, r)
| None -> None
)
let newR =
r |> List.choose (fun (rk, rv) ->
if l |> List.forall (fun (lk,_) -> not (Unchecked.equals lk rk)) then
match f rk None (Some rv) with
| Some r -> Some(rk, r)
| None -> None
else
None
)
match newL with
| [] ->
match newR with
| [] -> None
| _ -> Some newR
| _ ->
match newR with
| [] -> Some newL
| _ -> Some (newL @ newR)
let rec equals (l : list<'k * 'a>) (r : list<'k * 'a>) =
let mutable r = r
let mutable eq = true
use e = (l :> seq<_>).GetEnumerator()
while eq && e.MoveNext() do
let (lk, lv) = e.Current
match tryRemove lk r with
| Some(rv, nr) ->
r <- nr
eq <- Unchecked.equals lv rv
| _ ->
eq <- false
eq && List.isEmpty r
//if List.length l = List.length r then
// l |> List.forall (fun (lk,lv) ->
// r |> List.exists (fun (rk,rv) -> Unchecked.equals lk rk && Unchecked.equals lv rv)
// )
//else
// false
//[<CustomPickler>]
type intmap<'T> =
| Nil
| Tip of int * 'T
| Bin of int * int * intmap<'T> * intmap<'T>
member x.FoldBackWithKey f z =
let rec go z =
function
| Nil -> z
| Tip(kx, x) -> f kx x z
| Bin(_, _, l, r) -> go (go z r) l
match x with
| Bin(_, m, l, r) ->
if m < 0 then go (go z l) r // put negative numbers before.
else go (go z r) l
| _ -> go z x
member x.ToList() = x.FoldBackWithKey (fun k x xs -> (k, x) :: xs) []
member x.ToSeq() =
match x with
| Nil -> Seq.empty
| Tip(k,v) -> Seq.singleton (k,v)
| Bin(_,_,l,r) -> Seq.append (l.ToSeq()) (Seq.delay r.ToSeq)
member x.Count =
match x with
| Nil -> 0
| Tip _ -> 1
| Bin(_,_,l,r) -> l.Count + r.Count
(*
static member private CreatePickler(r : IPicklerResolver) =
let pint = r.Resolve<int>()
let parr = r.Resolve<array<int * 'T>>()
let vp = r.Resolve<'T>()
let read (rs : ReadState) =
let cnt = pint.Read rs "count"
let arr = parr.Read rs "items"
IntMap.ofArray arr
let write (ws : WriteState) (m : intmap<'T>) =
pint.Write ws "count" m.Count
parr.Write ws "items" (IntMap.toArray m)
let clone (cs : CloneState) (m : intmap<'T>) =
m |> IntMap.map (fun v -> vp.Clone cs v)
let accept (vs : VisitState) (m : intmap<'T>) =
for (k,v) in m do pint.Accept vs k; vp.Accept vs v
Pickler.FromPrimitives(read, write, clone, accept)
*)
interface IEnumerable<int * 'T> with
member x.GetEnumerator() =
new IntMapEnumerator<_>(x) :> _
interface System.Collections.IEnumerable with
member x.GetEnumerator() =
new IntMapEnumerator<_>(x) :> _
and private IntMapEnumerator<'a>(m : intmap<'a>) =
let mutable stack = [m]
let mutable current = Unchecked.defaultof<_>
let rec moveNext() =
match stack with
| [] -> false
| h :: rest ->
stack <- rest
match h with
| Nil ->
moveNext()
| Tip(k,v) ->
current <- (k,v)
true
| Bin(_,_,l,r) ->
stack <- l :: r :: stack
moveNext()
interface IEnumerator with
member x.MoveNext() = moveNext()
member x.Current = current :> obj
member x.Reset() =
stack <- [m]
current <- Unchecked.defaultof<_>
interface IEnumerator<int * 'a> with
member x.Current = current
member x.Dispose() =
stack <- []
current <- Unchecked.defaultof<_>
module IntMap =
let inline private maskW i m = int (i &&& (~~~ (m - 1ul) ^^^ m))
let inline private mask i m = maskW (uint32 i) (uint32 m)
let inline private match' i p m = mask i m = p
let inline private nomatch i p m = mask i m <> p
let inline private zero i m = (uint32 i) &&& (uint32 m) = 0ul
let inline private shorter m1 m2 = (uint32 m1) > (uint32 m2)
let inline private highestBitMask x0 =
let x1 = x0 ||| (x0 >>> 1)
let x2 = x1 ||| (x1 >>> 2)
let x3 = x2 ||| (x2 >>> 4)
let x4 = x3 ||| (x3 >>> 8)
let x5 = x4 ||| (x4 >>> 16)
let x6 = x5 ||| (x5 >>> 32) // for 64 bit platforms
x6 ^^^ (x6 >>> 1)
let inline private branchMask p1 p2 = int (highestBitMask (uint32 p1 ^^^ uint32 p2))
let inline private join p1 t1 p2 t2 =
let m = branchMask p1 p2
let p = mask p1 m
if zero p1 m then Bin(p, m, t1, t2)
else Bin(p, m, t2, t1)
let inline private bin p m l r =
match l, r with
| (l, Nil) -> l
| (Nil, r) -> r
| (l, r) -> Bin(p, m, l, r)
///O(1). Map is empty. Credit: Haskell.org
let isEmpty =
function
| Nil -> true
| _ -> false
// ///O(1). Number of elements in the map. Credit: Haskell.org
// let rec size =
// function
// | Bin(_, _, _, _,cnt) -> cnt
// | Tip _ -> 1
// | Nil -> 0
///O(min(n,W)). Lookup the value at a key in the map. Returns 'T option. Credit: Haskell.org
let rec tryFind k =
function
| Bin(p, m, l, r) ->
if nomatch k p m then None
elif zero k m then tryFind k l
else tryFind k r
| Tip(kx, x) ->
if k = kx then Some x
else None
| _ -> None
///O(min(n,W)). Is the key a member of the map? Credit: Haskell.org
let rec exists k =
function
| Bin(p, m, l, r) ->
if nomatch k p m then false
elif zero k m then exists k l
else exists k r
| Tip(kx, _) -> k = kx
| _ -> false
///O(log n). Is the key not a member of the map? Credit: Haskell.org
let notExists k m = not <| exists k m
///O(min(n,W)). Lookup the value at a key in the map. Credit: Haskell.org
let rec find k m =
let notFound() = failwith <| sprintf "intmap.find: key %d is not an element of the map" k
match m with
| Bin(p, m, l, r) ->
if nomatch k p m then notFound()
else if zero k m then find k l
else find k r
| Tip(kx, x) when k = kx -> x
| _ -> notFound()
///O(min(n,W)). The expression (findWithDefault def k map) returns the value at key k or returns def when the key is not an element of the map. Credit: Haskell.org
let rec findWithDefault def k =
function
| Bin(p, m, l, r) ->
if nomatch k p m then def
elif zero k m then findWithDefault def k l
else findWithDefault def k r
| Tip(kx, x) when k = kx -> x
| _ -> def
let rec private unsafeFindMax =
function
| Nil -> None
| Tip(ky, y) -> Some(ky, y)
| Bin(_, _, _, r) -> unsafeFindMax r
///O(log n). Find largest key smaller than the given one and return the corresponding (key, value) pair. Credit: Haskell.org
let tryFindLT k t =
let rec go def =
function
| Bin(p, m, l, r) ->
if nomatch k p m then
if k < p then unsafeFindMax def else unsafeFindMax r
elif zero k m then go def l
else go l r
| Tip(ky, y) ->
if k <= ky then unsafeFindMax def
else Some(ky, y)
| _ -> unsafeFindMax def
match t with
| Bin(_, m, l, r) when m < 0 -> if k >= 0 then go r l else go Nil r
| _ -> go Nil t
let rec private unsafeFindMin =
function
| Nil -> None
| Tip(ky, y) -> Some(ky, y)
| Bin(_, _, l, _) -> unsafeFindMin l
///O(log n). Find smallest key greater than the given one and return the corresponding (key, value) pair. Credit: Haskell.org
let tryFindGT k t =
let rec go def =
function
| Bin(p, m, l, r) ->
if nomatch k p m then
if k < p then unsafeFindMin l else unsafeFindMin def
elif zero k m then go r l
else go def r
| Tip(ky, y) ->
if k >= ky then unsafeFindMin def
else Some(ky, y)
| _ -> unsafeFindMin def
match t with
| Bin(_, m, l, r) when m < 0 -> if k >= 0 then go Nil l else go l r
| _ -> go Nil t
///O(log n). Find largest key smaller or equal to the given one and return the corresponding (key, value) pair. Credit: Haskell.org
let tryFindLE k t =
let rec go def =
function
| Bin(p, m, l, r) ->
if nomatch k p m then
if k < p then unsafeFindMax def else unsafeFindMax r
elif zero k m then go def l
else go l r
| Tip(ky, y) ->
if k < ky then unsafeFindMax def
else Some(ky, y)
| _ -> unsafeFindMax def
match t with
| Bin(_, m, l, r) when m < 0 -> if k >= 0 then go r l else go Nil r
| _ -> go Nil t
///O(log n). Find smallest key greater or equal to the given one and return the corresponding (key, value) pair Credit: Haskell.org
let tryFindGE k t =
let rec go def =
function
| Bin(p, m, l, r) ->
if nomatch k p m then
if k < p then unsafeFindMin l else unsafeFindMin def
elif zero k m then go r l
else go def r
| Tip(ky, y) ->
if k > ky then unsafeFindMin def
else Some(ky, y)
| _ -> unsafeFindMin def
match t with
| Bin(_, m, l, r) when m < 0 -> if k >= 0 then go Nil l else go l r
| _ -> go Nil t
///O(1). The empty map. Credit: Haskell.org
let empty = Nil
///O(1). A map of one element. Credit: Haskell.org
let inline singleton k x = Tip(k, x)
///O(min(n,W)). Insert a new key/value pair in the map. If the key is already present in the map, the associated value is replaced with the supplied value, i.e. insert is equivalent to insertWith const. Credit: Haskell.org
let rec insert k x t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then join k (Tip(k, x)) p t
elif zero k m then Bin(p, m, insert k x l, r)
else Bin(p, m, l, insert k x r)
| Tip(ky, _) ->
if k = ky then Tip(k, x)
else join k (Tip(k, x)) ky t
| _ -> Tip(k, x)
///O(min(n,W)). Insert with a combining function. insertWithKey f key value mp will insert the pair (key, value) into mp if key does not exist in the map. If the key does exist, the function will insert f key new_value old_value. Credit: Haskell.org
let rec insertWithKey f k x t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then join k (Tip(k, x)) p t
elif zero k m then Bin(p, m, insertWithKey f k x l, r)
else Bin(p, m, l, insertWithKey f k x r)
| Tip(ky, y) ->
if k = ky then Tip(k, f k x y)
else join k (Tip(k, x)) ky t
| _ -> Tip(k, x)
///O(min(n,W)). Insert with a combining function. insertWith f key value mp will insert the pair (key, value) into mp if key does not exist in the map. If the key does exist, the function will insert f new_value old_value. Credit: Haskell.org
let insertWith f k x t = insertWithKey (fun _ x' y' -> f x' y') k x t
///O(min(n,W)). The expression (insertLookupWithKey f k x map) is a pair where the first element is equal to (lookup k map) and the second element equal to (insertWithKey f k x map). Credit: Haskell.org
let rec insertTryFindWithKey f k x t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then (None, join k (Tip(k, x)) p t)
elif zero k m then
let found, l = insertTryFindWithKey f k x l
(found, Bin(p, m, l, r))
else
let found, r = insertTryFindWithKey f k x r
(found, Bin(p, m, l, r))
| Tip(ky, y) ->
if k = ky then (Some y, Tip(k, f k x y))
else (None, join k (Tip(k, x)) ky t)
| _ -> (None, Tip(k, x))
///O(min(n,W)). Delete a key and its value from the map. When the key is not a member of the map, the original map is returned. Credit: Haskell.org
let rec delete k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then t
elif zero k m then bin p m (delete k l) r
else bin p m l (delete k r)
| Tip(ky, _) ->
if k = ky then Nil
else t
| _ -> Nil
///O(min(n,W)). The expression (update f k map) updates the value x at k (if it is in the map). If (f k x) is Nothing, the element is deleted. If it is (Just y), the key k is bound to the new value y. Credit: Haskell.org
let rec updateWithKey f k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then t
elif zero k m then bin p m (updateWithKey f k l) r
else bin p m l (updateWithKey f k r)
| Tip(ky, y) ->
if k = ky then
match f k y with
| Some y -> Tip(ky, y)
| None -> Nil
else
t
| _ -> Nil
///O(min(n,W)). The expression (update f k map) updates the value x at k (if it is in the map). If (f x) is Nothing, the element is deleted. If it is (Just y), the key k is bound to the new value y. Credit: Haskell.org
let update f k m = updateWithKey (fun _ x -> f x) k m
///O(min(n,W)). Adjust a value at a specific key. When the key is not a member of the map, the original map is returned. Credit: Haskell.org
let adjustWithKey f k m = updateWithKey (fun k' x -> Some (f k' x)) k m
///O(min(n,W)). Adjust a value at a specific key. When the key is not a member of the map, the original map is returned. Credit: Haskell.org
let adjust f k m = adjustWithKey (fun _ x -> f x) k m
///O(min(n,W)). Lookup and update. Credit: Haskell.org
let rec updateTryFindWithKey f k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then
(None, t)
elif zero k m then
let (found, l) = updateTryFindWithKey f k l
(found, bin p m l r)
else
let (found, r) = updateTryFindWithKey f k r
(found, bin p m l r)
| Tip(ky, y) ->
if k = ky then
match f k y with
| Some y' -> (Some y, Tip(ky, y'))
| None -> (Some y, Nil)
else
(None, t)
| _ -> (None, Nil)
///O(log n). The expression (alter f k map) alters the value x at k, or absence thereof. alter can be used to insert, delete, or update a value in an intmap. Credit: Haskell.org
let rec alter f k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then
match f None with
| None -> t
| Some x -> join k (Tip(k, x)) p t
elif zero k m then
bin p m (alter f k l) r
else
bin p m l (alter f k r)
| Tip(ky, y) ->
if k = ky then
match f (Some y) with
| Some x -> Tip(ky, x)
| None -> Nil
else
match f None with
| Some x -> join k (Tip(k, x)) ky t
| None -> t
| _ ->
match f None with
| Some x -> Tip(k, x)
| None -> Nil
let inline private mergeWithKey' bin' f g1 g2 =
let inline maybeJoin p1 t1 p2 t2 =
match t1, t2 with
| Nil, t2 -> t2
| t1, Nil -> t1
| _ -> join p1 t1 p2 t2
let rec merge1 p1 m1 t1 l1 r1 p2 m2 t2 =
if nomatch p2 p1 m1 then maybeJoin p1 (g1 t1) p2 (g2 t2)
elif zero p2 m1 then bin' p1 m1 (go l1 t2) (g1 r1)
else bin' p1 m1 (g1 l1) (go r1 t2)
and merge2 p1 t1 p2 m2 t2 l2 r2 =
if nomatch p1 p2 m2 then maybeJoin p1 (g1 t1) p2 (g2 t2)
elif zero p1 m2 then bin' p2 m2 (go t1 l2) (g2 r2)
else bin' p2 m2 (g2 l2) (go t1 r2)
and go t1 t2 =
match t1 with
| Bin(p1, m1, l1, r1) ->
match t2 with
| Bin(p2, m2, l2, r2) ->
if shorter m1 m2 then merge1 p1 m1 t1 l1 r1 p2 m2 t2
elif shorter m2 m1 then merge2 p1 t1 p2 m2 t2 l2 r2
elif p1 = p2 then bin' p1 m1 (go l1 l2) (go r1 r2)
else maybeJoin p1 (g1 t1) p2 (g2 t2)
| Tip (k2', _) ->
let rec merge t2 k2 t1 =
match t1 with
| Bin(p1, m1, l1, r1) ->
if nomatch k2 p1 m1 then maybeJoin p1 (g1 t1) k2 (g2 t2)
else if zero k2 m1 then bin' p1 m1 (merge t2 k2 l1) (g1 r1)
else bin' p1 m1 (g1 l1) (merge t2 k2 r1)
| Tip(k1, _) ->
if k1 = k2 then f t1 t2
else maybeJoin k1 (g1 t1) k2 (g2 t2)
| _ -> g2 t2
merge t2 k2' t1
| _ -> g1 t1
| Tip(k1', _) ->
let rec merge t1 k1 t2 =
match t2 with
| Bin(p2, m2, l2, r2) ->
if nomatch k1 p2 m2 then maybeJoin k1 (g1 t1) p2 (g2 t2)
elif zero k1 m2 then bin' p2 m2 (merge t1 k1 l2) (g2 r2)
else bin' p2 m2 (g2 l2) (merge t1 k1 r2)
| Tip(k2, _) ->
if k1 = k2 then f t1 t2
else maybeJoin k1 (g1 t1) k2 (g2 t2)
| _ -> g1 t1
merge t1 k1' t2
| _ -> g2 t2
go
///Refer to Haskell documentation. Unexpected code growth or corruption of the data structure can occure from wrong use. Credit: Haskell.org
let mergeWithKey f g1 g2 =
let combine (Tip(k1, x1)) (Tip(_, x2)) =
match f k1 x1 x2 with
| None -> Nil
| Some x -> Tip(k1, x)
mergeWithKey' bin combine g1 g2
let inline konst a _ = a
let append m1 m2 = mergeWithKey' (fun x y m1' m2' -> Bin(x, y, m1', m2')) konst id id m1 m2
let appendWithKey f m1 m2 =
mergeWithKey' (fun x y m1' m2' -> Bin(x, y, m1', m2')) (fun (Tip(k1, x1)) (Tip(_, x2)) -> Tip(k1, f k1 x1 x2)) id id m1 m2
let appendWith f m1 m2 = appendWithKey (fun _ x y -> f x y) m1 m2
let concat xs = List.fold append empty xs
let concatWith f xs = List.fold (appendWith f) empty xs
///O(n+m). Difference between two maps (based on keys). Credit: Haskell.org
let difference m1 m2 = mergeWithKey (fun _ _ _ -> None) id (konst Nil) m1 m2
///O(n+m). Difference with a combining function. When two equal keys are encountered, the combining function is applied to the key and both values. If it returns Nothing, the element is discarded (proper set difference). If it returns (Just y), the element is updated with a new value y. Credit: Haskell.org
let differenceWithKey f m1 m2 = mergeWithKey f id (konst Nil) m1 m2
///O(n+m). Difference with a combining function. Credit: Haskell.org
let differenceWith f m1 m2 = differenceWithKey (fun _ x y -> f x y) m1 m2
///O(n+m). The (left-biased) intersection of two maps (based on keys). Credit: Haskell.org
let intersection m1 m2 = mergeWithKey' bin konst (konst Nil) (konst Nil) m1 m2
///O(n+m). The intersection with a combining function. Credit: Haskell.org
let intersectionWithKey f m1 m2 =
mergeWithKey' bin (fun (Tip(k1, x1)) (Tip(_, x2)) -> Tip(k1, f k1 x1 x2)) (konst Nil) (konst Nil) m1 m2
///O(n+m). The intersection with a combining function. Credit: Haskell.org
let intersectionWith f m1 m2 = intersectionWithKey (fun _ x y -> f x y) m1 m2
///O(log n). Update the value at the minimal key. Credit: Haskell.org
let updateMinWithKey f t =
let rec go f =
function
| Bin(p, m, l, r) -> bin p m (go f l) r
| Tip(k, y) ->
match f k y with
| Some y -> Tip(k, y)
| None -> Nil
| Nil -> failwith "updateMinWithKey Nil"
match t with
| Bin(p, m, l, r) when m < 0 -> bin p m l (go f r)
| _ -> go f t
///O(log n). Update the value at the maximal key. Credit: Haskell.org
let updateMaxWithKey f t =
let rec go f =
function
| Bin(p, m, l, r) -> bin p m l (go f r)
| Tip(k, y) ->
match f k y with
| Some y -> Tip(k, y)
| None -> Nil
| Nil -> failwith "updateMaxWithKey Nil"
match t with
| Bin(p, m, l, r) when m < 0 -> bin p m (go f l) r
| _ -> go f t
///O(log n). Retrieves the maximal (key,value) couple of the map, and the map stripped from that element. fails (in the monad) when passed an empty map. Credit: Haskell.org
let maxViewWithKey t =
let rec go =
function
| Bin(p, m, l, r) -> let (result, r) = go r in (result, bin p m l r)
| Tip(k, y) -> ((k, y), Nil)
| Nil -> failwith "maxViewWithKey Nil"
match t with
| Nil -> None
| Bin(p, m, l, r) when m < 0 -> let (result, l) = go l in Some(result, bin p m l r)
| _ -> Some(go t)
///O(log n). Retrieves the minimal (key,value) couple of the map, and the map stripped from that element. fails (in the monad) when passed an empty map. Credit: Haskell.org
let minViewWithKey t =
let rec go =
function
| Bin(p, m, l, r) -> let (result, l) = go l in (result, bin p m l r)
| Tip(k, y) -> ((k,y), Nil)
| Nil -> failwith "minViewWithKey Nil"
match t with
| Nil -> None
| Bin(p, m, l, r) when m < 0 -> let (result, r) = go r in Some(result, bin p m l r)
| _ -> Some(go t)
///O(log n). Update the value at the maximal key. Credit: Haskell.org
let updateMax f = updateMaxWithKey (konst f)
///O(log n). Update the value at the minimal key. Credit: Haskell.org
let updateMin f = updateMinWithKey (konst f)
let private first f (x, y) = (f x, y)
///O(min(n,W)). Retrieves the maximal key of the map, and the map stripped of that element, or Nothing if passed an empty map. Credit: Haskell.org
let maxView t = Option.map (first snd) (maxViewWithKey t)
///O(min(n,W)). Retrieves the minimal key of the map, and the map stripped of that element, or Nothing if passed an empty map. Credit: Haskell.org
let minView t = Option.map (first snd) (minViewWithKey t)
///O(log n). Retrieves the maximal key of the map, and the map stripped from that element. Credit: Haskell.org
let deleteFindMax t =
match maxViewWithKey <| t with
| Some x -> x
| _ -> failwith "deleteFindMax: empty map has no maximal element"
///O(log n). Retrieves the minimal key of the map, and the map stripped from that element. Credit: Haskell.org
let deleteFindMin t =
match minViewWithKey <| t with
| Some x -> x
| _ -> failwith "deleteFindMin: empty map has no minimal element"
///O(log n). The minimal key of the map. Credit: Haskell.org
let findMin t =
let rec go =
function
| Tip(k, v) -> (k, v)
| Bin(_, _, l, _) -> go l
| _ -> failwith "findMin Nil"
match t with
| Bin(_, m, l, r) -> if m < 0 then go r else go l
| Tip(k, v) -> (k, v)
| _ -> failwith "findMin: empty map has no minimal element"
///O(log n). The maximal key of the map. Credit: Haskell.org
let findMax t =
let rec go =
function
| Tip(k, v) -> (k, v)
| Bin(_, _, _, r) -> go r
| _ -> failwith "findMax Nil"
match t with
| Bin(_, m, l, r) -> if m < 0 then go l else go r
| Tip(k, v) -> (k, v)
| _ -> failwith "findMax: empty map has no maximal element"
///O(log n). Delete the minimal key. Credit: Haskell.org
let deleteMin t =
match minView <| t with
| Some x -> snd x
| _ -> Nil
///O(log n). Delete the maximal key. Credit: Haskell.org
let deleteMax t =
match maxView <| t with
| Some x -> snd x
| _ -> Nil
///O(n). Map a function over all values in the map. Credit: Haskell.org
let rec mapWithKey f =
function
| Bin(p, m, l, r) -> Bin(p, m, mapWithKey f l, mapWithKey f r)
| Tip(k, x) -> Tip(k, f k x)
| Nil -> Nil
///O(n). Map a function over all values in the map. Credit: Haskell.org
let rec map<'a, 'b> (f : 'a -> 'b) (m : intmap<'a>) : intmap<'b> =
match m with
| Bin(p, m, l, r) -> Bin(p, m, map f l, map f r)
| Tip(k, x) -> Tip(k, f x)
| Nil -> Nil
let rec private mapAccumL f a =
function
| Bin(p, m, l, r) ->
let (a1,l) = mapAccumL f a l
let (a2,r) = mapAccumL f a1 r
(a2, Bin(p, m, l, r))
| Tip(k, x) -> let (a,x) = f a k x in (a,Tip(k, x))
| Nil -> (a, Nil)
///O(n). The function mapAccum threads an accumulating argument through the map in ascending order of keys. Credit: Haskell.org
let mapAccumWithKey f a t = mapAccumL f a t
///O(n). The function mapAccumWithKey threads an accumulating argument through the map in ascending order of keys. Credit: Haskell.org
let mapAccum f = mapAccumWithKey (fun a' _ x -> f a' x)
///O(n). Filter all keys/values that satisfy some predicate. Credit: Haskell.org
let rec filterWithKey predicate =
function
| Bin(p, m, l, r) -> bin p m (filterWithKey predicate l) (filterWithKey predicate r)
| Tip(k, x) -> if predicate k x then Tip(k, x) else Nil
| _ -> Nil
///O(n). Filter all values that satisfy some predicate. Credit: Haskell.org
let filter p m = filterWithKey (fun _ x -> p x) m
///O(n). partition the map according to some predicate. The first map contains all elements that satisfy the predicate, the second all elements that fail the predicate. See also split. Credit: Haskell.org
let rec partitionWithKey predicate t =
match t with
| Bin(p, m, l, r) ->
let (l1, l2) = partitionWithKey predicate l
let (r1, r2) = partitionWithKey predicate r
(bin p m l1 r1, bin p m l2 r2)
| Tip(k, x) -> if predicate k x then (t, Nil) else (Nil, t)
| _ -> (Nil, Nil)
///O(n). partition the map according to some predicate. The first map contains all elements that satisfy the predicate, the second all elements that fail the predicate. See also split. Credit: Haskell.org
let partition p m = partitionWithKey (fun _ x -> p x) m
///O(n). Map keys/values and collect the Just results. Credit: Haskell.org
let rec mapOptionWithKey f =
function
| Bin(p, m, l, r) -> bin p m (mapOptionWithKey f l) (mapOptionWithKey f r)
| Tip(k, x) ->
match f k x with
| Some y -> Tip(k, y)
| None -> Nil
| Nil -> Nil
///O(n). Map keys/values and collect the Just results. Credit: Haskell.org
let rec mapOptionWithKey2 (f : int -> 'a -> option<'b * 'c>) : intmap<'a> -> intmap<'b> * intmap<'c> =
function
| Bin(p, m, l, r) ->
let la, lb = mapOptionWithKey2 f l
let ra, rb = mapOptionWithKey2 f r
bin p m la ra,
bin p m lb rb
| Tip(k, x) ->
match f k x with
| Some (a,b) -> Tip(k, a), Tip(k, b)
| None -> Nil, Nil
| Nil -> Nil, Nil
///O(n). Map values and collect the Just results. Credit: Haskell.org
let mapOption f = mapOptionWithKey (fun _ x -> f x)
///O(n). Map keys/values and separate the Left and Right results. Credit: Haskell.org
let rec mapChoiceWithKey f =
function
| Bin(p, m, l, r) ->
let (l1, l2) = mapChoiceWithKey f l
let (r1, r2) = mapChoiceWithKey f r
(bin p m l1 r1, bin p m l2 r2)
| Tip(k, x) ->
match f k x with
| Choice1Of2 y -> (Tip(k, y), Nil)
| Choice2Of2 z -> (Nil, Tip(k, z))
| Nil -> (Nil, Nil)
///O(n). Map values and separate the Left and Right results. Credit: Haskell.org
let mapChoice f = mapChoiceWithKey (fun _ x -> f x)
///O(log n). The expression (split k map) is a pair (map1,map2) where all keys in map1 are lower than k and all keys in map2 larger than k. Any key equal to k is found in neither map1 nor map2. Credit: Haskell.org
let split k t =
let rec go k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then
if k > p then (t, Nil) else (Nil, t)
elif zero k m then
let (lt, gt) = go k l
(lt, append gt r)
else
let (lt, gt) = go k r
(append l lt, gt)
| Tip(ky, _) ->
if k > ky then (t, Nil)
else if k < ky then (Nil, t)
else (Nil, Nil)
| _ -> (Nil, Nil)
match t with
| Bin(_, m, l, r) when m < 0 ->
if k >= 0 // handle negative numbers.
then let (lt, gt) = go k l in let lt = append r lt in (lt, gt)
else let (lt, gt) = go k r in let gt = append gt l in (lt, gt)
| _ -> go k t
///O(log n). Performs a split but also returns whether the pivot key was found in the original map. Credit: Haskell.org
let splitTryFind k t =
let rec go k t =
match t with
| Bin(p, m, l, r) ->
if nomatch k p m then
if k > p then (t, None, Nil) else (Nil, None, t)
elif zero k m then
let (lt, fnd, gt) = go k l
let gt = append gt r
(lt, fnd, gt)
else
let (lt, fnd, gt) = go k r
let lt = append l lt
(lt, fnd, gt)
| Tip(ky, y) ->
if k > ky then (t, None, Nil)
elif k < ky then (Nil, None, t)
else (Nil, Some y, Nil)
| _ -> (Nil, None, Nil)
match t with
| Bin(_, m, l, r) when m < 0 ->
if k >= 0 // handle negative numbers.
then let (lt, fnd, gt) = go k l in let lt = append r lt in (lt, fnd, gt)
else let (lt, fnd, gt) = go k r in let gt = append gt l in (lt, fnd, gt)
| _ -> go k t
///O(n). FoldBack the values in the map, such that fold f z == Prelude.foldr f z . elems. Credit: Haskell.org
let foldBack f z =
let rec go z =
function
| Tip(_, x) -> f x z
| Bin(_, _, l, r) -> go (go z r) l
| _ -> z
fun t ->
match t with
| Bin(_, m, l, r) ->
if m < 0 then go (go z l) r // put negative numbers before.
else go (go z r) l
| _ -> go z t
///O(n). Fold the values in the map, such that fold f z == Prelude.foldr f z . elems. Credit: Haskell.org
let fold f z =
let rec go z =
function
| Tip(_, x) -> f z x
| Bin(_, _, l, r) -> go (go z l) r
| _ -> z
fun t ->
match t with
| Bin(_, m, l, r) ->
if m < 0 then go (go z r) l // put negative numbers before.
else go (go z l) r
| _ -> go z t
///O(n). FoldBack the keys and values in the map, such that foldWithKey f z == Prelude.foldr (uncurry f) z . toAscList. Credit: Haskell.org
let inline foldBackWithKey f z = fun (t: _ intmap) -> t.FoldBackWithKey f z
///O(n). Fold the keys and values in the map, such that foldWithKey f z == Prelude.foldr (uncurry f) z . toAscList. Credit: Haskell.org
let foldWithKey f z =
let rec go z =
function
| Tip(kx, x) -> f z kx x
| Bin(_, _, l, r) -> go (go z l) r
| Nil -> z
fun t ->
match t with
| Bin(_, m, l, r) ->
if m < 0 then go (go z r) l // put negative numbers before.
else go (go z l) r
| _ -> go z t
///O(n). Return all elements of the map in the ascending order of their keys. Credit: Haskell.org
let values m = foldBack (fun a b -> List.Cons(a,b)) [] m
///O(n). Return all keys of the map in ascending order. Credit: Haskell.org
let keys m = foldBackWithKey (fun k _ ks -> k :: ks) [] m
///O(n). Convert the map to a list of key/value pairs. Credit: Haskell.org
let inline toList (m: _ intmap) = m.ToList()
///O(n). Convert the map to a seq of key/value pairs. Credit: Haskell.org
let toSeq (m : intmap<'a>) = m.ToSeq()
///O(n). Convert the map to an array of key/value pairs. Credit: Haskell.org
let toArray m = m |> toList |> List.toArray
///O(n*min(n,W)). Create a map from a list of key/value pairs. Credit: Haskell.org
let ofList xs =
let ins t (k, x) = insert k x t
List.fold ins empty xs
///O(n*min(n,W)). Build a map from a list of key/value pairs with a combining function. See also fromAscListWithKey'. Credit: Haskell.org
let ofListWithKey f xs =
let ins t (k, x) = insertWithKey f k x t
List.fold ins empty xs
///O(n*min(n,W)). Create a map from a list of key/value pairs with a combining function. See also fromAscListWith. Credit: Haskell.org
let ofListWith f xs = ofListWithKey (fun _ x y -> f x y) xs
///O(1). Create a map from a single key/value pair.
let single k x = Tip(k, x)
///O(n*min(n,W)). Create a map from a seq of key/value pairs. Credit: Haskell.org
let ofSeq xs = xs |> List.ofSeq |> ofList
///O(n*min(n,W)). Build a map from a seq of key/value pairs with a combining function. See also fromAscListWithKey'. Credit: Haskell.org
let ofSeqWithKey f xs = xs |> List.ofSeq |> ofListWithKey f
///O(n*min(n,W)). Create a map from a seq of key/value pairs with a combining function. See also fromAscListWith. Credit: Haskell.org
let ofSeqWith f xs = xs |> List.ofSeq |> ofListWith f
///O(n*min(n,W)). Create a map from an array of key/value pairs. Credit: Haskell.org
let ofArray xs = xs |> List.ofArray |> ofList
///O(n*min(n,W)). Build a map from an array of key/value pairs with a combining function. See also fromAscListWithKey'. Credit: Haskell.org
let ofArrayWithKey f xs = xs |> List.ofArray |> ofListWithKey f
///O(n*min(n,W)). Create a map from an array of key/value pairs with a combining function. See also fromAscListWith. Credit: Haskell.org
let ofArrayWith f xs = xs |> List.ofArray |> ofListWith f
///O(n*min(n,W)). mapKeys f s is the map obtained by applying f to each key of s. The size of the result may be smaller if f maps two or more distinct keys to the same new key. In this case the value at the greatest of the original keys is retained. Credit: Haskell.org
let mapKeys f = ofList << foldBackWithKey (fun k x xs -> (f k, x) :: xs) []
///O(n*log n). mapKeysWith c f s is the map obtained by applying f to each key of s. The size of the result may be smaller if f maps two or more distinct keys to the same new key. In this case the associated values will be combined using c. Credit: Haskell.org
let mapKeysWith c f = ofListWith c << foldBackWithKey (fun k x xs -> (f k, x) :: xs) []
///O(n+m). The expression (isSubmapOfBy f m1 m2) returns True if all keys in m1 are in m2, and when f returns True when applied to their respective values. Credit: Haskell.org
let rec isSubmapOfBy predicate t1 t2 =
match t1 with
| Bin(p1, m1, l1, r1) ->
match t2 with
| Bin(p2, m2, l2, r2) ->
if shorter m1 m2 then false
elif shorter m2 m1 then
match' p1 p2 m2 &&
(if zero p1 m2 then isSubmapOfBy predicate t1 l2
else isSubmapOfBy predicate t1 r2)
else
p1 = p2 && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2
| _ -> false
| Tip(k, x) ->
match tryFind k t2 with
| Some y -> predicate x y
| None -> false
| _ -> true
///O(n+m). Is this a submap? Defined as (isSubmapOf = isSubmapOfBy (==)). Credit: Haskell.org
let isSubmapOf m1 m2 = isSubmapOfBy (=) m1 m2
type private Ordering =
| GT
| LT
| EQ
let rec private submapCmp predicate t1 t2 =
let submapCmpLt p1 r1 t1 p2 m2 l2 r2 =
if nomatch p1 p2 m2 then GT
elif zero p1 m2 then submapCmp predicate t1 l2
else submapCmp predicate t1 r2
let submapCmpEq l1 r1 l2 r2 =
match (submapCmp predicate l1 l2, submapCmp predicate r1 r2) with
| (GT,_ ) -> GT
| (_ ,GT) -> GT
| (EQ,EQ) -> EQ
| _ -> LT
match t1 with
| Bin(p1, m1, l1, r1) ->
match t2 with
| Bin(p2, m2, l2, r2) ->
if shorter m1 m2 then GT
elif shorter m2 m1 then submapCmpLt p1 r1 t1 p2 m2 l2 r2
elif p1 = p2 then submapCmpEq l1 r1 l2 r2
else GT // disjoint
| _ -> GT
| Tip(kx, x) ->
match t2 with
| Tip(ky, y) ->
if (kx = ky) && predicate x y then EQ
else GT// disjoint
| _ ->
match tryFind kx t2 with
| Some y when predicate x y -> LT
| _ -> GT // disjoint
| _ ->
match t2 with
| Nil -> EQ
| _ -> LT
///O(n+m). Is this a proper submap? (ie. a submap but not equal). The expression (isProperSubmapOfBy f m1 m2) returns True when m1 and m2 are not equal, all keys in m1 are in m2, and when f returns True when applied to their respective values. Credit: Haskell.org
let isProperSubmapOfBy predicate t1 t2 =
match submapCmp predicate t1 t2 with
| LT -> true
| _ -> false
///O(n+m). Is this a proper submap? (ie. a submap but not equal). Defined as (isProperSubmapOf = isProperSubmapOfBy (==)). Credit: Haskell.org
let isProperSubmapOf m1 m2 = isProperSubmapOfBy (=) m1 m2
///Compares two UIntMaps and calls back:
///del for any key-value-pair that is in m1 and not in m2, and
///add for any key-value-pair that is in m2 and not in m1, and
///change for any key-value-pair is in both, but has changed.
///Untouched sub-trees that are reference-equal are not touched.
let computeDelta (change : int -> 'a -> 'a -> option<'b>) (del : intmap<'a> -> intmap<'b>) (add : intmap<'a> -> intmap<'b>) =
let inline ifChanged (Tip(k1, x1)) (Tip(_, x2)) =
match change k1 x1 x2 with
| None -> Nil
| Some x -> Tip(k1, x)
let inline maybeJoin p1 t1 p2 t2 =
match t1, t2 with
| Nil, t2 -> t2
| t1, Nil -> t1
| _ -> join p1 t1 p2 t2
let rec merge1 p1 m1 t1 l1 r1 p2 t2 =
if nomatch p2 p1 m1 then maybeJoin p1 (del t1) p2 (add t2)
elif zero p2 m1 then bin p1 m1 (go l1 t2) (del r1)
else bin p1 m1 (del l1) (go r1 t2)
and merge2 p1 t1 p2 m2 t2 l2 r2 =
if nomatch p1 p2 m2 then maybeJoin p1 (del t1) p2 (add t2)
elif zero p1 m2 then bin p2 m2 (go t1 l2) (add r2)
else bin p2 m2 (add l2) (go t1 r2)
and go t1 t2 =
if t1 == t2 then
Nil
else
match t1 with
| Bin(p1, m1, l1, r1) ->
match t2 with
| Bin(p2, m2, l2, r2) ->
if shorter m1 m2 then merge1 p1 m1 t1 l1 r1 p2 t2
elif shorter m2 m1 then merge2 p1 t1 p2 m2 t2 l2 r2
elif p1 = p2 then bin p1 m1 (go l1 l2) (go r1 r2)
else maybeJoin p1 (del t1) p2 (add t2)
| Tip (k2', _) ->
let rec merge t2 k2 t1 =
match t1 with
| Bin(p1, m1, l1, r1) ->
if nomatch k2 p1 m1 then maybeJoin p1 (del t1) k2 (add t2)
elif zero k2 m1 then bin p1 m1 (merge t2 k2 l1) (del r1)
else bin p1 m1 (del l1) (merge t2 k2 r1)
| Tip(k1, _) ->
if k1 = k2 then ifChanged t1 t2
else maybeJoin k1 (del t1) k2 (add t2)
| _ -> add t2
merge t2 k2' t1
| _ -> del t1
| Tip(k1', _) ->
let rec merge t1 k1 t2 =
match t2 with
| Bin(p2, m2, l2, r2) ->
if nomatch k1 p2 m2 then maybeJoin k1 (del t1) p2 (add t2)
elif zero k1 m2 then bin p2 m2 (merge t1 k1 l2) (add r2)
else bin p2 m2 (add l2) (merge t1 k1 r2)
| Tip(k2, _) ->
if k1 = k2 then ifChanged t1 t2
else maybeJoin k1 (del t1) k2 (add t2)
| _ -> del t1
merge t1 k1' t2
| _ -> add t2
go
let rec equals (valueEqual : 'a -> 'a -> bool) (l : intmap<'a>) (r : intmap<'a>) =
if System.Object.ReferenceEquals(l, r) then
true
else
match l, r with
| Nil, Nil ->
true
| Tip(lh,l), Tip(rh,r) ->
lh = rh && valueEqual l r
| Bin(lp, lm, ll, lr), Bin(rp, rm, rl, rr) ->
lp = rp && lm = rm && equals valueEqual ll rl && equals valueEqual lr rr
| _ ->
false
[<Struct; CustomEquality; NoComparison>]
[<StructuredFormatDisplay("{AsString}")>]
type hmap<'k, [<EqualityConditionalOn>] 'v>(cnt : int, store : intmap<list<'k * 'v>>) =
static let empty = hmap<'k, 'v>(0, IntMap.empty)
static member Empty = empty
(*
static member private CreatePickler (r : IPicklerResolver) =
let pint = r.Resolve<int>()
let parr = r.Resolve<array<'k * 'v>>()
let kp = r.Resolve<'k>()
let vp = r.Resolve<'v>()
let read (rs : ReadState) =
let cnt = pint.Read rs "count"
let arr = parr.Read rs "items"
hmap<'k, 'v>.OfArray arr
let write (ws : WriteState) (m : hmap<'k, 'v>) =
pint.Write ws "count" m.Count
parr.Write ws "items" (m.ToArray())
let clone (cs : CloneState) (m : hmap<'k, 'v>) =
let mutable res = hmap<'k, 'v>.Empty
for (k,v) in m do
res <- res.Add(kp.Clone cs k, vp.Clone cs v)
res
let accept (vs : VisitState) (m : hmap<'k, 'v>) =
for (k,v) in m do kp.Accept vs k; vp.Accept vs v
Pickler.FromPrimitives(read, write, clone, accept)
*)
member x.Store = store
member x.IsEmpty = cnt = 0
member x.Count = cnt
// Add or Replace or Delete
member x.Alter (key : 'k, f : option<'v> -> option<'v>) =
let hash = Unchecked.hash key
match store |> IntMap.tryFind hash with
| Some old ->
let mutable cnt = cnt
let newList = HMapList.alter' &cnt key f old
if Unchecked.equals newList old then
x // if same -> Nop
else
match newList with
| [] -> hmap(cnt, store |> IntMap.delete hash)
| l -> hmap(cnt, store |> IntMap.insert hash l)
| None ->
match f None with
| Some res -> hmap(cnt + 1, IntMap.insert hash [key, res] store)
| None -> x // nop
// Add or Replace
member x.Update (key : 'k, f : option<'v> -> 'v) =
let hash = Unchecked.hash key
match store |> IntMap.tryFind hash with
| Some old ->
let newList = HMapList.update key f old
if Unchecked.equals newList old then
x // if same -> Nop
else
hmap(cnt, store |> IntMap.insert hash newList )
| None ->
let v = f None
hmap(cnt + 1, IntMap.insert hash [key, v] store)
member x.Add (key : 'k, value : 'v) =
let hash = Unchecked.hash key
let mutable cnt = cnt
let newMap =
store |> IntMap.alter (fun l ->
match l with
| None ->
cnt <- cnt + 1
Some [key,value]
| Some l ->
Some (HMapList.add &cnt key value l)
) hash
hmap(cnt, newMap)
member x.Remove (key : 'k) =
let mutable cnt = cnt
let hash = Unchecked.hash key
let newMap =
store |> IntMap.update (fun l ->
match HMapList.remove &cnt key l with
| [] -> None
| l -> Some l
) hash
hmap(cnt, newMap)
member x.ContainsKey (key : 'k) =
let hash = Unchecked.hash key
match IntMap.tryFind hash store with
| Some l -> l |> List.exists (fun (k,_) -> Unchecked.equals k key)
| None -> false
member x.Map(mapping : 'k -> 'v -> 'b) =
let newStore =
store
|> IntMap.map (fun l -> l |> List.map (fun (k,v) -> (k, mapping k v)))
hmap(cnt, newStore)
member x.ChooseTup(mapping : 'k -> 'v -> option<'b * 'c>) =
let mutable cnt = 0
let mapping (k : 'k, v : 'v) =
match mapping k v with
| Some b ->
cnt <- cnt + 1
Some (k,b)
| None ->
None
let a, b =
store
|> IntMap.mapOptionWithKey2 (fun _ l ->
match List.choose mapping l with
| [] -> None
| l ->
let ll = l |> List.map (fun (k,(l,_)) -> k, l)
let rl = l |> List.map (fun (k,(_,r)) -> k, r)
Some (ll, rl)
)
hmap(cnt, a), hmap(cnt, b)
member x.Choose(mapping : 'k -> 'v -> option<'b>) =
let mutable cnt = 0
let mapping (k : 'k, v : 'v) =
match mapping k v with
| Some b ->
cnt <- cnt + 1
Some (k,b)
| None ->
None
let newStore =
store
|> IntMap.mapOption (fun l ->
match List.choose mapping l with
| [] -> None
| l ->
Some l
)
hmap(cnt, newStore)
member x.Filter(predicate : 'k -> 'v -> bool) =
let mutable cnt = 0
let predicate (k, v) =
if predicate k v then
cnt <- cnt + 1
true
else
false
let newStore =
store |> IntMap.mapOption (fun l ->
match l |> List.filter predicate with
| [] -> None
| l -> Some l
)
hmap(cnt, newStore)
member x.Iter(iter : 'k -> 'v -> unit) =
store |> IntMap.toSeq |> Seq.iter (fun (_,l) ->
l |> List.iter (fun (k,v) -> iter k v)
)
member x.Exists(predicate : 'k -> 'v -> bool) =
store |> IntMap.toSeq |> Seq.exists (fun (_,v) ->
v |> List.exists (fun (k,v) -> predicate k v)
)
member x.Forall(predicate : 'k -> 'v -> bool) =
store |> IntMap.toSeq |> Seq.forall (fun (_,v) ->
v |> List.forall (fun (k,v) -> predicate k v)
)
member x.Fold(seed : 's, folder : 's -> 'k -> 'v -> 's) =
store |> IntMap.fold (fun s l ->
l |> List.fold (fun s (k,v) -> folder s k v) s
) seed
member x.UnionWith(other : hmap<'k, 'v>, f : 'k -> 'v -> 'v -> 'v) =
let mutable cnt = cnt + other.Count
let f k l r =
cnt <- cnt - 1
f k l r
let newStore =
IntMap.appendWith (HMapList.unionWith f) store other.Store
hmap(cnt, newStore)
member x.Choose2(other : hmap<'k, 'a>, f : 'k -> option<'v> -> option<'a> -> option<'c>) =
let mutable cnt = 0
let f k l r =
match f k l r with
| Some r ->
cnt <- cnt + 1
Some r
| None ->
None
let both (hash : int) (l : list<'k * 'v>) (r : list<'k * 'a>) =
match HMapList.mergeWithOption f l r with
| [] -> None
| l -> Some l
let onlyLeft (l : intmap<list<'k * 'v>>) =
l |> IntMap.mapOption (fun l ->
match l |> List.choose (fun (lk, lv) -> match f lk (Some lv) None with | Some r -> Some (lk,r) | None -> None) with
| [] -> None
| l -> Some l
)
let onlyRight (r : intmap<list<'k * 'a>>) =
r |> IntMap.mapOption (fun r ->
match r |> List.choose (fun (rk, rv) -> match f rk None (Some rv) with | Some r -> Some (rk,r) | None -> None) with
| [] -> None
| r -> Some r
)
let newStore =
IntMap.mergeWithKey both onlyLeft onlyRight store other.Store
hmap(cnt, newStore)
member x.Map2(other : hmap<'k, 'a>, f : 'k -> option<'v> -> option<'a> -> 'c) =
let mutable cnt = 0
let f k l r =
cnt <- cnt + 1
f k l r
let both (hash : int) (l : list<'k * 'v>) (r : list<'k * 'a>) =
match HMapList.mergeWith f l r with
| [] -> None
| l -> Some l
let onlyLeft (l : intmap<list<'k * 'v>>) =
l |> IntMap.mapOption (fun l ->
match l |> List.map (fun (lk, lv) -> lk, f lk (Some lv) None) with
| [] -> None
| l -> Some l
)
let onlyRight (r : intmap<list<'k * 'a>>) =
r |> IntMap.mapOption (fun r ->
match r |> List.map (fun (rk, rv) -> rk, f rk None (Some rv)) with
| [] -> None
| r -> Some r
)
let newStore =
IntMap.mergeWithKey both onlyLeft onlyRight store other.Store
hmap(cnt, newStore)
member x.Union(other : hmap<'k, 'v>) =
x.UnionWith(other, fun _ _ r -> r)
member x.TryRemove(key : 'k) =
let hash = Unchecked.hash key
let mutable removed = None
let newStore =
store |> IntMap.update (fun o ->
match HMapList.tryRemove key o with
| Some(v,l) ->
removed <- Some v
match l with
| [] -> None
| l -> Some l
| None -> Some o
) hash
match removed with
| Some rem -> Some(rem, hmap(cnt - 1, newStore))
| None -> None
member x.TryFind(key : 'k) =
let hash = Unchecked.hash key
match IntMap.tryFind hash store with
| Some l ->
l |> List.tryPick (fun (k,v) ->
if Unchecked.equals k key then
Some v
else
None
)
| None ->
None
member x.Find(key : 'k) =
match x.TryFind key with
| Some v -> v
| None -> raise <| System.Collections.Generic.KeyNotFoundException()
member x.Item
with get (key : 'k) = x.Find key
member x.ToSeq() =
store |> IntMap.toSeq |> Seq.collect snd
member x.ToList() =
store |> IntMap.toList |> List.collect snd
member x.ToArray() =
x.ToSeq() |> Seq.toArray
static member Single (k : 'k) (v : 'v) =
let hash = Unchecked.hash k
hmap(1, IntMap.single hash [(k, v)])
static member OfSeq (seq : seq<'k * 'v>) =
let mutable res = empty
for (k,v) in seq do
res <- res.Add(k,v)
res
static member OfList (list : list<'k * 'v>) =
hmap.OfSeq list
static member OfArray (list : array<'k * 'v>) =
hmap.OfSeq list
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
x.ToSeq() |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"hmap [" + content + suffix + "]"
override x.GetHashCode() =
match store with
| Nil -> 0
| _ -> store |> Seq.fold (fun s (h,vs) -> vs |> List.fold (fun s (_,v) -> s ^^^ (Unchecked.hash v)) h) 0
override x.Equals o =
match o with
| :? hmap<'k, 'v> as o ->
IntMap.equals HMapList.equals store o.Store
| _ ->
false
member private x.AsString = x.ToString()
interface IEnumerable with
member x.GetEnumerator() =
new HMapEnumerator<_,_>(store) :> _
interface IEnumerable<'k * 'v> with
member x.GetEnumerator() =
new HMapEnumerator<_,_>(store) :> _
and hdeltamap<'k, 'v> = hmap<'k, ElementOperation<'v>>
and ElementOperation<'a> =
| Set of 'a
| Remove
and private HMapEnumerator<'k, 'v>(m : intmap<list<'k * 'v>>) =
let mutable stack = [m]
let mutable inner = []
let mutable current = Unchecked.defaultof<_>
let rec moveNext() =
match inner with
| [] ->
match stack with
| [] -> false
| h :: s ->
stack <- s
match h with
| Tip(k,v) ->
match v with
| [] -> failwith "asdasdsadasd"
| v :: rest ->
current <- v
inner <- rest
true
| Nil ->
moveNext()
| Bin(_,_,l,r) ->
stack <- l :: r :: stack
moveNext()
| h :: rest ->
current <- h
inner <- rest
true
member x.MoveNext() =
moveNext()
member x.Current = current
member x.Reset() =
stack <- [m]
inner <- []
current <- Unchecked.defaultof<_>
member x.Dispose() =
stack <- []
inner <- []
current <- Unchecked.defaultof<_>
interface IEnumerator with
member x.MoveNext() = x.MoveNext()
member x.Current = x.Current :> obj
member x.Reset() = x.Reset()
interface IEnumerator<'k * 'v> with
member x.Current = x.Current
member x.Dispose() = x.Dispose()
module MapExtImplementation =
[<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
[<NoEquality; NoComparison>]
type MapTree<'Key,'Value> =
| MapEmpty
| MapOne of 'Key * 'Value
| MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * int * int
// REVIEW: performance rumour has it that the data held in MapNode and MapOne should be
// exactly one cache line. It is currently ~7 and 4 words respectively.
type MapExtReference<'v> =
| NonExisting of index : int
| Existing of index : int * value : 'v
type internal EnumeratorEnumerable<'a>(get : unit -> IEnumerator<'a>) =
interface System.Collections.IEnumerable with
member x.GetEnumerator() = get() :> System.Collections.IEnumerator
interface IEnumerable<'a> with
member x.GetEnumerator() = get()
module MapTree =
let empty = MapEmpty
let height = function
| MapEmpty -> 0
| MapOne _ -> 1
| MapNode(_,_,_,_,h,_) -> h
let size = function
| MapEmpty -> 0
| MapOne _ -> 1
| MapNode(_,_,_,_,_,s) -> s
let isEmpty m =
match m with
| MapEmpty -> true
| _ -> false
let mk l k v r =
match l,r with
| MapEmpty,MapEmpty -> MapOne(k,v)
| _ ->
let hl = height l
let hr = height r
let m = if hl < hr then hr else hl
MapNode(k,v,l,r,m+1, 1 + size l + size r)
let rebalance t1 k v t2 =
let t1h = height t1
let t2h = height t2
if t2h > t1h + 2 then (* right is heavier than left *)
match t2 with
| MapNode(t2k,t2v,t2l,t2r,_,_) ->
(* one of the nodes must have height > height t1 + 1 *)
if height t2l > t1h + 1 then (* balance left: combination *)
match t2l with
| MapNode(t2lk,t2lv,t2ll,t2lr,_,_) ->
mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r)
| _ -> failwith "rebalance"
else (* rotate left *)
mk (mk t1 k v t2l) t2k t2v t2r
| _ -> failwith "rebalance"
else
if t1h > t2h + 2 then (* left is heavier than right *)
match t1 with
| MapNode(t1k,t1v,t1l,t1r,_,_) ->
(* one of the nodes must have height > height t2 + 1 *)
if height t1r > t2h + 1 then
(* balance right: combination *)
match t1r with
| MapNode(t1rk,t1rv,t1rl,t1rr,_,_) ->
mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2)
| _ -> failwith "rebalance"
else
mk t1l t1k t1v (mk t1r k v t2)
| _ -> failwith "rebalance"
else mk t1 k v t2
let rec add (comparer: IComparer<'Value>) k v m =
match m with
| MapEmpty -> MapOne(k,v)
| MapOne(k2,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then MapNode (k,v,MapEmpty,m,2, 2)
elif c = 0 then MapOne(k,v)
else MapNode (k,v,m,MapEmpty,2, 2)
| MapNode(k2,v2,l,r,h,s) ->
let c = comparer.Compare(k,k2)
if c < 0 then rebalance (add comparer k v l) k2 v2 r
elif c = 0 then MapNode(k,v,l,r,h,s)
else rebalance l k2 v2 (add comparer k v r)
let rec find (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty -> raise (KeyNotFoundException())
| MapOne(k2,v2) ->
let c = comparer.Compare(k,k2)
if c = 0 then v2
else raise (KeyNotFoundException())
| MapNode(k2,v2,l,r,_,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then find comparer k l
elif c = 0 then v2
else find comparer k r
let rec tryFind (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty -> None
| MapOne(k2,v2) ->
let c = comparer.Compare(k,k2)
if c = 0 then Some v2
else None
| MapNode(k2,v2,l,r,_,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then tryFind comparer k l
elif c = 0 then Some v2
else tryFind comparer k r
let partition1 (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v (acc1,acc2) =
if f.Invoke(k, v) then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2)
let rec partitionAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc =
match s with
| MapEmpty -> acc
| MapOne(k,v) -> partition1 comparer f k v acc
| MapNode(k,v,l,r,_,_) ->
let acc = partitionAux comparer f r acc
let acc = partition1 comparer f k v acc
partitionAux comparer f l acc
let partition (comparer: IComparer<'Value>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (empty,empty)
let filter1 (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v acc = if f.Invoke(k, v) then add comparer k v acc else acc
let rec filterAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc =
match s with
| MapEmpty -> acc
| MapOne(k,v) -> filter1 comparer f k v acc
| MapNode(k,v,l,r,_,_) ->
let acc = filterAux comparer f l acc
let acc = filter1 comparer f k v acc
filterAux comparer f r acc
let filter (comparer: IComparer<'Value>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s empty
let rec spliceOutSuccessor m =
match m with
| MapEmpty -> failwith "internal error: MapExt.spliceOutSuccessor"
| MapOne(k2,v2) -> k2,v2,MapEmpty
| MapNode(k2,v2,l,r,_,_) ->
match l with
| MapEmpty -> k2,v2,r
| _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r
let rec remove (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty -> empty
| MapOne(k2,_) ->
let c = comparer.Compare(k,k2)
if c = 0 then MapEmpty else m
| MapNode(k2,v2,l,r,_,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then rebalance (remove comparer k l) k2 v2 r
elif c = 0 then
match l with
| MapEmpty -> r
| _ ->
match r with
| MapEmpty -> l
| _ ->
let sk,sv,r' = spliceOutSuccessor r
mk l sk sv r'
else
rebalance l k2 v2 (remove comparer k r)
let rec tryRemove (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty -> None
| MapOne(k2,v) ->
let c = comparer.Compare(k,k2)
if c = 0 then Some (v, MapEmpty) else None
| MapNode(k2,v2,l,r,_,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then
match tryRemove comparer k l with
| Some (v,l) ->
Some (v, rebalance l k2 v2 r)
| None ->
None
elif c = 0 then
match l with
| MapEmpty -> Some(v2, r)
| _ ->
match r with
| MapEmpty -> Some(v2, l)
| _ ->
let sk,sv,r' = spliceOutSuccessor r
Some(v2, mk l sk sv r')
else
match tryRemove comparer k r with
| Some (v,r) ->
Some (v, rebalance l k2 v2 r)
| None ->
None
let rec tryRemoveMin m =
match m with
| MapEmpty ->
None
| MapOne(k2,v) ->
Some (k2, v, MapEmpty)
| MapNode(k2,v2,l,r,_,_) ->
match tryRemoveMin l with
| Some (k,v,rest) ->
match rest with
| MapEmpty -> Some (k,v,r)
| _ -> Some (k,v, rebalance rest k2 v2 r)
| None ->
Some(k2, v2, r)
let rec tryRemoveMax m =
match m with
| MapEmpty ->
None
| MapOne(k2,v) ->
Some (k2, v, MapEmpty)
| MapNode(k2,v2,l,r,_,_) ->
match tryRemoveMax r with
| Some (k,v,rest) ->
match rest with
| MapEmpty -> Some (k,v,l)
| _ -> Some (k,v, rebalance l k2 v2 rest)
| None ->
Some(k2, v2, l)
let rec alter (comparer : IComparer<'Value>) k f m =
match m with
| MapEmpty ->
match f None with
| Some v -> MapOne(k,v)
| None -> MapEmpty
| MapOne(k2, v2) ->
let c = comparer.Compare(k,k2)
if c = 0 then
match f (Some v2) with
| Some v3 -> MapOne(k2, v3)
| None -> MapEmpty
else
match f None with
| None ->
MapOne(k2, v2)
| Some v3 ->
if c > 0 then MapNode (k2,v2,MapEmpty,MapOne(k, v3),2, 2)
else MapNode(k2, v2, MapOne(k, v3), MapEmpty, 2, 2)
| MapNode(k2, v2, l, r, h, cnt) ->
let c = comparer.Compare(k, k2)
if c = 0 then
match f (Some v2) with
| Some v3 ->
MapNode(k2, v3, l, r, h, cnt)
| None ->
match l with
| MapEmpty -> r
| _ ->
match r with
| MapEmpty -> l
| _ ->
let sk,sv,r' = spliceOutSuccessor r
mk l sk sv r'
elif c > 0 then
rebalance l k2 v2 (alter comparer k f r)
else
rebalance (alter comparer k f l) k2 v2 r
let rec join left k v right =
let lh = height left
let rh = height right
if lh > rh + 2 then
match left with
| MapNode(k2,v2,l,r,_,_) ->
// the join-result can at most be one level higher than r
// therefore rebalance is sufficient here
rebalance l k2 v2 (join r k v right)
| _ ->
failwith "join"
elif rh > lh + 2 then
match right with
| MapNode(k2,v2,l,r,_,_) ->
// the join-result can at most be one level higher than l
// therefore rebalance is sufficient here
rebalance (join left k v l) k2 v2 r
| _ ->
failwith "join"
else
mk left k v right
let rec split (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty ->
MapEmpty, None, MapEmpty
| MapOne(k2,v2) ->
let c = comparer.Compare(k, k2)
if c < 0 then MapEmpty, None, MapOne(k2,v2)
elif c = 0 then MapEmpty, Some(v2), MapEmpty
else MapOne(k2,v2), None, MapEmpty
| MapNode(k2,v2,l,r,_,_) ->
let c = comparer.Compare(k, k2)
if c > 0 then
let rl, res, rr = split comparer k r
join l k2 v2 rl, res, rr
elif c = 0 then
l, Some(v2), r
else
let ll, res, lr = split comparer k l
ll, res, join lr k2 v2 r
let rec getReference (comparer: IComparer<'Value>) (current : int) k m =
match m with
| MapEmpty ->
NonExisting current
| MapOne(key,v) ->
let c = comparer.Compare(k, key)
if c > 0 then NonExisting (current + 1)
elif c < 0 then NonExisting current
else Existing(current, v)
| MapNode(key,v,l,r,_,s) ->
let c = comparer.Compare(k, key)
if c > 0 then getReference comparer (current + size l + 1) k r
elif c < 0 then getReference comparer current k l
else Existing(current+size l, v)
let rec unionWithOpt (comparer: IComparer<'Value>) (f : OptimizedClosures.FSharpFunc<_,_,_>) l r =
match l, r with
| MapEmpty, r -> r
| l, MapEmpty -> l
| MapOne(k,v), r ->
r |> alter comparer k (fun o ->
match o with
| None -> v |> Some
| Some o -> f.Invoke(v, o) |> Some
)
| l, MapOne(k,v) ->
l |> alter comparer k (fun o ->
match o with
| None -> v |> Some
| Some o -> f.Invoke(o, v) |> Some
)
| MapNode(k,v,ll,lr,_,_),r ->
let rs, self, rg = split comparer k r
let v =
match self with
| Some rv -> f.Invoke(v, rv)
| None -> v
join (unionWithOpt comparer f ll rs) k v (unionWithOpt comparer f lr rg)
let unionWith(comparer: IComparer<'Value>) f l r =
unionWithOpt comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) l r
let rec stupidHeight m =
match m with
| MapEmpty -> 0
| MapOne _ -> 1
| MapNode(_,_,l,r,_,_) -> max (stupidHeight l) (stupidHeight r) + 1
let rec stupidCount m =
match m with
| MapEmpty -> 0
| MapOne _ -> 1
| MapNode(_,_,l,r,_,_) ->
1 + stupidCount l + stupidCount r
let rec validateAux (comparer: IComparer<'Value>) (min : option<_>) (max : option<_>) m =
match m with
| MapNode(k,v,l,r,h,c) ->
let lh = height l
let rh = height r
if Option.isSome min && comparer.Compare(k, min.Value) <= 0 then failwith "invalid order"
if Option.isSome max && comparer.Compare(k, max.Value) >= 0 then failwith "invalid order"
if stupidCount m <> c then failwith "invalid count"
if stupidHeight l <> lh then failwith "invalid height"
if stupidHeight r <> rh then failwith "invalid height"
if abs (lh - rh) > 2 then failwith "imbalanced"
validateAux comparer min (Some k) l
validateAux comparer (Some k) max r
| MapOne(k,v) ->
if Option.isSome min && comparer.Compare(k, min.Value) <= 0 then failwith "invalid order"
if Option.isSome max && comparer.Compare(k, max.Value) >= 0 then failwith "invalid order"
| MapEmpty ->
()
let validate (comparer: IComparer<'Value>) m =
validateAux comparer None None m
let rec mem (comparer: IComparer<'Value>) k m =
match m with
| MapEmpty -> false
| MapOne(k2,_) -> (comparer.Compare(k,k2) = 0)
| MapNode(k2,_,l,r,_,_) ->
let c = comparer.Compare(k,k2)
if c < 0 then mem comparer k l
else (c = 0 || mem comparer k r)
let rec iterOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> ()
| MapOne(k2,v2) -> f.Invoke(k2, v2)
| MapNode(k2,v2,l,r,_,_) -> iterOpt f l; f.Invoke(k2, v2); iterOpt f r
let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec tryPickOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> None
| MapOne(k2,v2) -> f.Invoke(k2, v2)
| MapNode(k2,v2,l,r,_,_) ->
match tryPickOpt f l with
| Some _ as res -> res
| None ->
match f.Invoke(k2, v2) with
| Some _ as res -> res
| None ->
tryPickOpt f r
let tryPick f m = tryPickOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec tryPickOptBack (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> None
| MapOne(k2,v2) -> f.Invoke(k2, v2)
| MapNode(k2,v2,l,r,_,_) ->
match tryPickOptBack f r with
| Some _ as res -> res
| None ->
match f.Invoke(k2, v2) with
| Some _ as res -> res
| None ->
tryPickOptBack f l
let tryPickBack f m = tryPickOptBack (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec existsOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> false
| MapOne(k2,v2) -> f.Invoke(k2, v2)
| MapNode(k2,v2,l,r,_,_) -> existsOpt f l || f.Invoke(k2, v2) || existsOpt f r
let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec forallOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> true
| MapOne(k2,v2) -> f.Invoke(k2, v2)
| MapNode(k2,v2,l,r,_,_) -> forallOpt f l && f.Invoke(k2, v2) && forallOpt f r
let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec map f m =
match m with
| MapEmpty -> empty
| MapOne(k,v) -> MapOne(k,f v)
| MapNode(k,v,l,r,h,c) ->
let l2 = map f l
let v2 = f v
let r2 = map f r
MapNode(k,v2,l2, r2,h,c)
let rec mapiOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> empty
| MapOne(k,v) -> MapOne(k, f.Invoke(k, v))
| MapNode(k,v,l,r,h,c) ->
let l2 = mapiOpt f l
let v2 = f.Invoke(k, v)
let r2 = mapiOpt f r
MapNode(k,v2, l2, r2,h,c)
let mapi f m = mapiOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec mapiMonotonicAux (f:OptimizedClosures.FSharpFunc<_,_,_>) m =
match m with
| MapEmpty -> empty
| MapOne(k,v) ->
let (k2, v2) = f.Invoke(k, v)
MapOne(k2, v2)
| MapNode(k,v,l,r,h,c) ->
let l2 = mapiMonotonicAux f l
let k2, v2 = f.Invoke(k, v)
let r2 = mapiMonotonicAux f r
MapNode(k2,v2, l2, r2,h,c)
let mapiMonotonic f m = mapiMonotonicAux (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec chooseiOpt (f:OptimizedClosures.FSharpFunc<'k,'a,option<'b>>) m =
match m with
| MapEmpty -> empty
| MapOne(k,v) ->
match f.Invoke(k,v) with
| Some v -> MapOne(k,v)
| None -> MapEmpty
| MapNode(k,v,l,r,h,c) ->
let l' = chooseiOpt f l
let s' = f.Invoke(k,v)
let r' = chooseiOpt f r
match s' with
| None ->
match l' with
| MapEmpty -> r'
| _ ->
match r' with
| MapEmpty -> l'
| _ ->
let k,v,r' = spliceOutSuccessor r'
join l' k v r'
| Some v ->
join l' k v r'
let choosei f m = chooseiOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m
let rec tryMinAux acc m =
match m with
| MapEmpty -> acc
| MapOne(k,v) -> Some (k,v)
| MapNode(k,v,l,_,_,_) -> tryMinAux (Some (k,v)) l
let rec tryMin m = tryMinAux None m
let rec tryMaxAux acc m =
match m with
| MapEmpty -> acc
| MapOne(k,v) -> Some (k,v)
| MapNode(k,v,_,r,_,_) -> tryMaxAux (Some (k,v)) r
let rec tryMax m = tryMaxAux None m
let rec neighboursAux (comparer: IComparer<'Value>) k l r m =
match m with
| MapEmpty -> l, None, r
| MapOne(k2,v2) ->
let c = comparer.Compare(k, k2)
if c > 0 then Some(k2,v2), None, r
elif c = 0 then l, Some(k2,v2), r
else l, None, Some(k2,v2)
| MapNode(k2,v2,l2,r2,_,_) ->
let c = comparer.Compare(k, k2)
if c > 0 then
let l = Some(k2, v2)
neighboursAux comparer k l r r2
elif c = 0 then
let l =
match tryMax l2 with
| None -> l
| l -> l
let r =
match tryMin r2 with
| None -> r
| r -> r
l,Some(k2, v2),r
else
let r = Some(k2, v2)
neighboursAux comparer k l r l2
let neighbours (comparer: IComparer<'Value>) k m =
neighboursAux comparer k None None m
let rec neighboursiAux idx l r m =
match m with
| MapEmpty ->
l, None, r
| MapOne(k2,v2) ->
if idx > 0 then Some(k2,v2), None, r
elif idx = 0 then l, Some(k2,v2), r
else l, None, Some(k2,v2)
| MapNode(k2,v2,l2,r2,_,cnt) ->
if idx < 0 then
None, None, tryMin m
elif idx >= cnt then
tryMax m, None, None
else
let lc = size l2
if idx < lc then
let r = Some(k2, v2)
neighboursiAux idx l r l2
elif idx = lc then
let l =
match tryMax l2 with
| None -> l
| l -> l
let r =
match tryMin r2 with
| None -> r
| r -> r
l, Some(k2, v2), r
else
let l = Some(k2, v2)
neighboursiAux (idx-lc-1) l r r2
let neighboursi idx m =
neighboursiAux idx None None m
let rec tryAt i m =
match m with
| MapEmpty ->
None
| MapOne(k,v) ->
if i = 0 then Some (k,v)
else None
| MapNode(k,v,l,r,_,c) ->
if i < 0 || i >= c then
None
else
let ls = size l
if i = ls then
Some (k,v)
elif i < ls then
tryAt i l
else
tryAt (i - ls - 1) r
let rec map2 (comparer: IComparer<'Value>) f l r =
match l, r with
| MapEmpty, r -> mapi (fun i rv -> f i None (Some rv)) r
| l, MapEmpty -> mapi (fun i lv -> f i (Some lv) None) l
| MapOne(k,v), r ->
let mutable found = false
let res =
r |> mapi (fun i rv ->
if i = k then
found <- true
f i (Some v) (Some rv)
else
f i None (Some rv)
)
if found then res
else res |> add comparer k (f k (Some v) None)
| l, MapOne(k,v) ->
let mutable found = false
let res =
l |> mapi (fun i lv ->
if i = k then
found <- true
f i (Some lv) (Some v)
else
f i None (Some v)
)
if found then res
else res |> add comparer k (f k None (Some v))
| MapNode(k,v,ll,lr,_,_),r ->
let rs, self, rg = split comparer k r
let v =
match self with
| Some rv -> f k (Some v) (Some rv)
| None -> f k (Some v) None
join (map2 comparer f ll rs) k v (map2 comparer f lr rg)
let rec choose2 (comparer: IComparer<'Value>) f l r =
match l, r with
| MapEmpty, r -> choosei (fun i rv -> f i None (Some rv)) r
| l, MapEmpty -> choosei (fun i lv -> f i (Some lv) None) l
| MapOne(k,v), r ->
let mutable found = false
let res =
r |> choosei (fun i rv ->
if i = k then
found <- true
f i (Some v) (Some rv)
else
f i None (Some rv)
)
if found then
res
else
match f k (Some v) None with
| Some v -> add comparer k v res
| None -> res
| l, MapOne(k,v) ->
let mutable found = false
let res =
l |> choosei (fun i lv ->
if i = k then
found <- true
f i (Some lv) (Some v)
else
f i (Some lv) None
)
if found then
res
else
match f k None (Some v) with
| Some v -> add comparer k v res
| None -> res
| MapNode(k,v,ll,lr,_,_),r ->
let rs, self, rg = split comparer k r
let v =
match self with
| Some rv -> f k (Some v) (Some rv)
| None -> f k (Some v) None
let l = choose2 comparer f ll rs
let r = choose2 comparer f lr rg
match v with
| Some v ->
join l k v r
| None ->
match l with
| MapEmpty -> r
| _ ->
match r with
| MapEmpty -> l
| _ ->
let k,v,r = spliceOutSuccessor r
join l k v r
let rec intersectWithAux (f:OptimizedClosures.FSharpFunc<'a,'b,'c>) (comparer: IComparer<'k>) (l : MapTree<'k, 'a>) (r : MapTree<'k, 'b>) : MapTree<'k, 'c> =
match l with
| MapEmpty ->
MapEmpty
| MapOne(k,lv) ->
match tryFind comparer k r with
| Some rv -> MapOne(k, f.Invoke(lv, rv))
| None -> MapEmpty
| MapNode(k,v,l1,r1,_,_) ->
let a, s, b = split comparer k r
match s with
| Some s ->
let v = f.Invoke(v,s)
rebalance (intersectWithAux f comparer l1 a) k v (intersectWithAux f comparer r1 b)
| None ->
let l = intersectWithAux f comparer l1 a
let r = intersectWithAux f comparer r1 b
match l with
| MapEmpty -> r
| _ ->
match r with
| MapEmpty -> l
| _ ->
let k,v,r' = spliceOutSuccessor r
rebalance l k v r'
let intersectWith (f : 'a -> 'b -> 'c) (comparer : IComparer<'k>) (l : MapTree<'k, 'a>) (r : MapTree<'k, 'b>) =
let lc = size l
let rc = size r
if lc <= rc then
intersectWithAux (OptimizedClosures.FSharpFunc<_,_,_>.Adapt f) comparer l r
else
intersectWithAux (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(fun a b -> f b a)) comparer r l
let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x =
match m with
| MapEmpty -> x
| MapOne(k,v) -> f.Invoke(k,v,x)
| MapNode(k,v,l,r,_,_) ->
let x = foldBackOpt f r x
let x = f.Invoke(k,v,x)
foldBackOpt f l x
let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) m x
let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) x m =
match m with
| MapEmpty -> x
| MapOne(k,v) -> f.Invoke(x,k,v)
| MapNode(k,v,l,r,_,_) ->
let x = foldOpt f x l
let x = f.Invoke(x,k,v)
foldOpt f x r
let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) x m
let foldSectionOpt (comparer: IComparer<'Value>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x =
let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x =
match m with
| MapEmpty -> x
| MapOne(k,v) ->
let cLoKey = comparer.Compare(lo,k)
let cKeyHi = comparer.Compare(k,hi)
let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke(k, v, x) else x
x
| MapNode(k,v,l,r,_,_) ->
let cLoKey = comparer.Compare(lo,k)
let cKeyHi = comparer.Compare(k,hi)
let x = if cLoKey < 0 then foldFromTo f l x else x
let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke(k, v, x) else x
let x = if cKeyHi < 0 then foldFromTo f r x else x
x
if comparer.Compare(lo,hi) = 1 then x else foldFromTo f m x
let foldSection (comparer: IComparer<'Value>) lo hi f m x =
foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) m x
let toList m =
let rec loop m acc =
match m with
| MapEmpty -> acc
| MapOne(k,v) -> (k,v)::acc
| MapNode(k,v,l,r,_,_) -> loop l ((k,v)::loop r acc)
loop m []
let toArray m = m |> toList |> Array.ofList
let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) empty l
let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) =
if e.MoveNext() then
let (x,y) = e.Current
mkFromEnumerator comparer (add comparer x y acc) e
else acc
let ofArray comparer (arr : array<_>) =
let mutable res = empty
for (x,y) in arr do
res <- add comparer x y res
res
let ofSeq comparer (c : seq<'Key * 'T>) =
match c with
| :? array<'Key * 'T> as xs -> ofArray comparer xs
| :? list<'Key * 'T> as xs -> ofList comparer xs
| _ ->
use ie = c.GetEnumerator()
mkFromEnumerator comparer empty ie
let copyToArray s (arr: _[]) i =
let j = ref i
s |> iter (fun x y -> arr.[!j] <- KeyValuePair(x,y); j := !j + 1)
/// Imperative left-to-right iterators.
[<NoEquality; NoComparison>]
type MapIterator<'Key,'Value when 'Key : comparison > =
{ /// invariant: always collapseLHS result
mutable stack: MapTree<'Key,'Value> list;
/// true when MoveNext has been called
mutable started : bool }
// collapseLHS:
// a) Always returns either [] or a list starting with MapOne.
// b) The "fringe" of the set stack is unchanged.
let rec collapseLHS stack =
match stack with
| [] -> []
| MapEmpty :: rest -> collapseLHS rest
| MapOne _ :: _ -> stack
| (MapNode(k,v,l,r,_,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest)
let mkIterator s = { stack = collapseLHS [s]; started = false }
let notStarted() = raise (InvalidOperationException("enumeration not started"))
let alreadyFinished() = raise (InvalidOperationException("enumeration finished"))
let current i =
if i.started then
match i.stack with
| MapOne (k,v) :: _ -> new KeyValuePair<_,_>(k,v)
| [] -> alreadyFinished()
| _ -> failwith "Please report error: MapExt iterator, unexpected stack for current"
else
notStarted()
let rec moveNext i =
if i.started then
match i.stack with
| MapOne _ :: rest ->
i.stack <- collapseLHS rest
not i.stack.IsEmpty
| [] -> false
| _ -> failwith "Please report error: MapExt iterator, unexpected stack for moveNext"
else
i.started <- true (* The first call to MoveNext "starts" the enumeration. *)
not i.stack.IsEmpty
let mkIEnumerator s =
let i = ref (mkIterator s)
{ new IEnumerator<_> with
member __.Current = current !i
interface System.Collections.IEnumerator with
member __.Current = box (current !i)
member __.MoveNext() = moveNext !i
member __.Reset() = i := mkIterator s
interface System.IDisposable with
member __.Dispose() = ()}
type MapTreeEnumerator<'k, 'v when 'k : comparison>(m : MapTree<'k, 'v>) =
let mutable stack = [m]
let mutable current = Unchecked.defaultof<'k * 'v>
let rec move () =
match stack with
| [] ->
false
| MapEmpty :: rest ->
stack <- rest
move()
| MapOne(key,value) :: rest ->
stack <- rest
current <- (key, value)
true
| MapNode(k,v,l,r,_,_) :: rest ->
stack <- l :: (MapOne(k,v)) :: r :: rest
move()
interface System.Collections.IEnumerator with
member x.MoveNext() = move()
member x.Reset() =
stack <- [m]
current <- Unchecked.defaultof<'k * 'v>
member x.Current = current :> obj
interface IEnumerator<'k * 'v> with
member x.Dispose() =
stack <- []
current <- Unchecked.defaultof<'k * 'v>
member x.Current = current
type MapTreeBackwardEnumerator<'k, 'v when 'k : comparison>(m : MapTree<'k, 'v>) =
let mutable stack = [m]
let mutable current = Unchecked.defaultof<'k * 'v>
let rec move () =
match stack with
| [] ->
false
| MapEmpty :: rest ->
stack <- rest
move()
| MapOne(key,value) :: rest ->
stack <- rest
current <- (key, value)
true
| MapNode(k,v,l,r,_,_) :: rest ->
stack <- r :: (MapOne(k,v)) :: l :: rest
move()
interface System.Collections.IEnumerator with
member x.MoveNext() = move()
member x.Reset() =
stack <- [m]
current <- Unchecked.defaultof<'k * 'v>
member x.Current = current :> obj
interface IEnumerator<'k * 'v> with
member x.Dispose() =
stack <- []
current <- Unchecked.defaultof<'k * 'v>
member x.Current = current
open MapExtImplementation
[<System.Diagnostics.DebuggerTypeProxy(typedefof<MapDebugView<_,_>>)>]
[<System.Diagnostics.DebuggerDisplay("Count = {Count}")>]
[<Sealed>]
[<StructuredFormatDisplay("{AsString}")>]
type MapExt<[<EqualityConditionalOn>]'Key,[<EqualityConditionalOn;ComparisonConditionalOn>]'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key,'Value>) =
static let defaultComparer = LanguagePrimitives.FastGenericComparer<'Key>
// We use .NET generics per-instantiation static fields to avoid allocating a new object for each empty
// set (it is just a lookup into a .NET table of type-instantiation-indexed static fields).
static let empty = new MapExt<'Key,'Value>(defaultComparer, MapTree<_,_>.MapEmpty)
(*
static member private CreatePickler (r : IPicklerResolver) =
let pint = r.Resolve<int>()
let parr = r.Resolve<array<'Key * 'Value>>()
let kp = r.Resolve<'Key>()
let vp = r.Resolve<'Value>()
let read (rs : ReadState) =
let cnt = pint.Read rs "count"
let arr = parr.Read rs "items"
MapExt<'Key, 'Value>(defaultComparer, MapTree.ofArray defaultComparer arr)
let write (ws : WriteState) (m : MapExt<'Key, 'Value>) =
pint.Write ws "count" m.Count
parr.Write ws "items" (m.ToArray())
let clone (cs : CloneState) (m : MapExt<'Key, 'Value>) =
m.MapMonotonic (fun k v -> kp.Clone cs k, vp.Clone cs v)
let accept (vs : VisitState) (m : MapExt<'Key, 'Value>) =
for kv in m do kp.Accept vs kv.Key; vp.Accept vs kv.Value
Pickler.FromPrimitives(read, write, clone, accept)
*)
static member Empty : MapExt<'Key,'Value> = empty
static member Create(ie : IEnumerable<_>) : MapExt<'Key,'Value> =
let comparer = LanguagePrimitives.FastGenericComparer<'Key>
new MapExt<_,_>(comparer,MapTree.ofSeq comparer ie)
static member Create() : MapExt<'Key,'Value> = empty
new(ie : seq<_>) =
let comparer = LanguagePrimitives.FastGenericComparer<'Key>
new MapExt<_,_>(comparer,MapTree.ofSeq comparer ie)
[<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
member internal m.Comparer = comparer
//[<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
member internal m.Tree = tree
member m.Add(k,v) : MapExt<'Key,'Value> =
new MapExt<'Key,'Value>(comparer,MapTree.add comparer k v tree)
[<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
member m.IsEmpty = MapTree.isEmpty tree
member m.Item
with get(k : 'Key) = MapTree.find comparer k tree
member x.Keys =
let mutable s = Set.empty
for (KeyValue(k,_)) in x do s <- s.Add k
s
member x.Values =
x |> Seq.map (fun (KeyValue(_,v)) -> v)
member x.TryAt i = MapTree.tryAt i tree
member x.Neighbours k = MapTree.neighbours comparer k tree
member x.NeighboursAt i = MapTree.neighboursi i tree
member m.TryPick(f) = MapTree.tryPick f tree
member m.TryPickBack(f) = MapTree.tryPickBack f tree
member m.Exists(f) = MapTree.exists f tree
member m.Filter(f) : MapExt<'Key,'Value> = new MapExt<'Key,'Value>(comparer ,MapTree.filter comparer f tree)
member m.ForAll(f) = MapTree.forall f tree
member m.Fold f acc = MapTree.foldBack f tree acc
member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = MapTree.foldSection comparer lo hi f tree acc
member m.Iterate f = MapTree.iter f tree
member m.MapRange f = new MapExt<'Key,'b>(comparer,MapTree.map f tree)
member m.MapExt f = new MapExt<'Key,'b>(comparer,MapTree.mapi f tree)
member m.MapMonotonic<'Key2, 'Value2 when 'Key2 : comparison> (f : 'Key -> 'Value -> 'Key2 * 'Value2) : MapExt<'Key2,'Value2> = new MapExt<'Key2,'Value2>(LanguagePrimitives.FastGenericComparer<'Key2>, MapTree.mapiMonotonic f tree)
member x.GetReference key =
MapTree.getReference comparer 0 key tree
member x.TryIndexOf key =
match MapTree.getReference comparer 0 key tree with
| Existing(i,_) -> Some i
| _ -> None
member x.TryRemoveMin() =
match MapTree.tryRemoveMin tree with
| Some (k,v,t) -> Some(k,v, MapExt(comparer, t))
| None -> None
member x.TryRemoveMax() =
match MapTree.tryRemoveMax tree with
| Some (k,v,t) -> Some(k,v, MapExt(comparer, t))
| None -> None
member m.Map2(other:MapExt<'Key,'Value2>, f) =
new MapExt<'Key,'Result>(comparer, MapTree.map2 comparer f tree other.Tree)
member m.Choose2(other:MapExt<'Key,'Value2>, f) =
new MapExt<'Key,'Result>(comparer, MapTree.choose2 comparer f tree other.Tree)
member m.Choose(f) =
new MapExt<'Key, 'Value2>(comparer, MapTree.choosei f tree)
member m.Alter(k, f) = new MapExt<'Key, 'Value>(comparer, MapTree.alter comparer k f tree)
member m.Partition(f) : MapExt<'Key,'Value> * MapExt<'Key,'Value> =
let r1,r2 = MapTree.partition comparer f tree in
new MapExt<'Key,'Value>(comparer,r1), new MapExt<'Key,'Value>(comparer,r2)
member m.Count = MapTree.size tree
member x.TryMinKey = MapTree.tryMin tree |> Option.map fst
member x.TryMaxKey = MapTree.tryMax tree |> Option.map fst
member x.TryMinValue = MapTree.tryMin tree |> Option.map snd
member x.TryMaxValue = MapTree.tryMax tree |> Option.map snd
member x.Split (k) =
let l, self, r = MapTree.split comparer k tree
MapExt<'Key, 'Value>(comparer, l), self, MapExt<'Key, 'Value>(comparer, r)
member x.UnionWith (other : MapExt<_,_>, resolve) =
if x.IsEmpty then other
elif other.IsEmpty then x
else new MapExt<'Key, 'Value>(comparer, MapTree.unionWith comparer resolve tree other.Tree)
member x.IntersectWith(other : MapExt<_,_>, resolve) =
if x.IsEmpty || other.IsEmpty then MapExt<_,_>.Empty
else new MapExt<'Key, _>(comparer, MapTree.intersectWith resolve comparer tree other.Tree)
member x.Intersect(other : MapExt<_,_>) =
if x.IsEmpty || other.IsEmpty then MapExt<_,_>.Empty
else new MapExt<'Key, _>(comparer, MapTree.intersectWith (fun l r -> (l,r)) comparer tree other.Tree)
member x.Validate() =
MapTree.validate comparer tree
member m.ContainsKey(k) =
MapTree.mem comparer k tree
member m.Remove(k) : MapExt<'Key,'Value> =
new MapExt<'Key,'Value>(comparer,MapTree.remove comparer k tree)
member m.TryRemove(k) : option<'Value * MapExt<'Key,'Value>> =
match MapTree.tryRemove comparer k tree with
| Some (v, t) ->
Some(v, new MapExt<'Key,'Value>(comparer, t))
| None ->
None
member m.TryFind(k) =
MapTree.tryFind comparer k tree
member m.ToList() = MapTree.toList tree
member m.ToArray() = MapTree.toArray tree
static member ofList(l) : MapExt<'Key,'Value> =
let comparer = LanguagePrimitives.FastGenericComparer<'Key>
new MapExt<_,_>(comparer,MapTree.ofList comparer l)
member this.ComputeHashCode() =
let combineHash x y = (x <<< 1) + y + 631
let mutable res = 0
for (KeyValue(x,y)) in this do
res <- combineHash res (hash x)
res <- combineHash res (Unchecked.hash y)
abs res
override this.Equals(that) =
if System.Object.ReferenceEquals(this, that) then
true
else
match that with
| :? MapExt<'Key,'Value> as that ->
use e1 = (this :> seq<_>).GetEnumerator()
use e2 = (that :> seq<_>).GetEnumerator()
let rec loop () =
let m1 = e1.MoveNext()
let m2 = e2.MoveNext()
(m1 = m2) && (not m1 || let e1c, e2c = e1.Current, e2.Current in ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop()))
loop()
| _ -> false
override this.GetHashCode() = this.ComputeHashCode()
member x.GetForwardEnumerator() = new MapTree.MapTreeEnumerator<'Key, 'Value>(tree) :> IEnumerator<_>
member x.GetBackwardEnumerator() = new MapTree.MapTreeBackwardEnumerator<'Key, 'Value>(tree) :> IEnumerator<_>
interface IEnumerable<KeyValuePair<'Key, 'Value>> with
member __.GetEnumerator() = MapTree.mkIEnumerator tree
interface System.Collections.IEnumerable with
member __.GetEnumerator() = (MapTree.mkIEnumerator tree :> System.Collections.IEnumerator)
interface IDictionary<'Key, 'Value> with
member m.Item
with get x = m.[x]
and set x v = ignore(x,v); raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)"))
// REVIEW: this implementation could avoid copying the Values to an array
member s.Keys = ([| for kvp in s -> kvp.Key |] :> ICollection<'Key>)
// REVIEW: this implementation could avoid copying the Values to an array
member s.Values = ([| for kvp in s -> kvp.Value |] :> ICollection<'Value>)
member s.Add(k,v) = ignore(k,v); raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)"))
member s.ContainsKey(k) = s.ContainsKey(k)
member s.TryGetValue(k,r) = if s.ContainsKey(k) then (r <- s.[k]; true) else false
member s.Remove(k : 'Key) = ignore(k); (raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)")) : bool)
interface ICollection<KeyValuePair<'Key, 'Value>> with
member __.Add(x) = ignore(x); raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)"));
member __.Clear() = raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)"));
member __.Remove(x) = ignore(x); raise (NotSupportedException("SR.GetString(SR.mapCannotBeMutated)"));
member s.Contains(x) = s.ContainsKey(x.Key) && Unchecked.equals s.[x.Key] x.Value
member __.CopyTo(arr,i) = MapTree.copyToArray tree arr i
member s.IsReadOnly = true
member s.Count = s.Count
interface System.IComparable with
member m.CompareTo(obj: obj) =
match obj with
| :? MapExt<'Key,'Value> as m2->
Seq.compareWith
(fun (kvp1 : KeyValuePair<_,_>) (kvp2 : KeyValuePair<_,_>)->
let c = comparer.Compare(kvp1.Key,kvp2.Key) in
if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value)
m m2
| _ ->
invalidArg "obj" ("SR.GetString(SR.notComparable)")
override x.ToString() =
let suffix = if x.Count > 4 then "; ..." else ""
let content = Seq.truncate 4 x |> Seq.map (fun (KeyValue t) -> sprintf "%A" t) |> String.concat "; "
"map [" + content + suffix + "]"
member private x.AsString = x.ToString()
and
[<Sealed>]
MapDebugView<'Key,'Value when 'Key : comparison>(v: MapExt<'Key,'Value>) =
[<DebuggerBrowsable(DebuggerBrowsableState.RootHidden)>]
member x.Items = v |> Seq.truncate 10000 |> Seq.toArray
[<RequireQualifiedAccess>]
module MapExt =
[<CompiledName("IsEmpty")>]
let isEmpty (m:MapExt<_,_>) = m.IsEmpty
[<CompiledName("Keys")>]
let keys (m:MapExt<_,_>) = m.Keys
[<CompiledName("Values")>]
let values (m:MapExt<_,_>) = m.Values
[<CompiledName("Add")>]
let add k v (m:MapExt<_,_>) = m.Add(k,v)
[<CompiledName("Find")>]
let find k (m:MapExt<_,_>) = m.[k]
[<CompiledName("TryFind")>]
let tryFind k (m:MapExt<_,_>) = m.TryFind(k)
[<CompiledName("Remove")>]
let remove k (m:MapExt<_,_>) = m.Remove(k)
[<CompiledName("TryRemove")>]
let tryRemove k (m:MapExt<_,_>) = m.TryRemove(k)
[<CompiledName("TryRemoveMin")>]
let tryRemoveMin (m:MapExt<_,_>) = m.TryRemoveMin()
[<CompiledName("TryRemoveMax")>]
let tryRemoveMax (m:MapExt<_,_>) = m.TryRemoveMax()
[<CompiledName("ContainsKey")>]
let containsKey k (m:MapExt<_,_>) = m.ContainsKey(k)
[<CompiledName("Iterate")>]
let iter f (m:MapExt<_,_>) = m.Iterate(f)
[<CompiledName("TryPick")>]
let tryPick f (m:MapExt<_,_>) = m.TryPick(f)
[<CompiledName("TryPickBack")>]
let tryPickBack f (m:MapExt<_,_>) = m.TryPickBack(f)
[<CompiledName("Pick")>]
let pick f (m:MapExt<_,_>) = match tryPick f m with None -> raise (KeyNotFoundException()) | Some res -> res
[<CompiledName("Exists")>]
let exists f (m:MapExt<_,_>) = m.Exists(f)
[<CompiledName("Filter")>]
let filter f (m:MapExt<_,_>) = m.Filter(f)
[<CompiledName("Partition")>]
let partition f (m:MapExt<_,_>) = m.Partition(f)
[<CompiledName("ForAll")>]
let forall f (m:MapExt<_,_>) = m.ForAll(f)
let mapRange f (m:MapExt<_,_>) = m.MapRange(f)
[<CompiledName("MapExt")>]
let map f (m:MapExt<_,_>) = m.MapExt(f)
[<CompiledName("Fold")>]
let fold<'Key,'T,'State when 'Key : comparison> f (z:'State) (m:MapExt<'Key,'T>) = MapTree.fold f z m.Tree
[<CompiledName("FoldBack")>]
let foldBack<'Key,'T,'State when 'Key : comparison> f (m:MapExt<'Key,'T>) (z:'State) = MapTree.foldBack f m.Tree z
[<CompiledName("ToSeq")>]
let toSeq (m:MapExt<_,_>) = m |> Seq.map (fun kvp -> kvp.Key, kvp.Value)
[<CompiledName("ToSeqBack")>]
let toSeqBack (m : MapExt<_,_>) = new EnumeratorEnumerable<_>(m.GetBackwardEnumerator) :> seq<_>
[<CompiledName("FindKey")>]
let findKey f (m : MapExt<_,_>) = m |> toSeq |> Seq.pick (fun (k,v) -> if f k v then Some(k) else None)
[<CompiledName("TryFindKey")>]
let tryFindKey f (m : MapExt<_,_>) = m |> toSeq |> Seq.tryPick (fun (k,v) -> if f k v then Some(k) else None)
[<CompiledName("OfList")>]
let ofList (l: ('Key * 'Value) list) = MapExt<_,_>.ofList(l)
[<CompiledName("OfSeq")>]
let ofSeq l = MapExt<_,_>.Create(l)
[<CompiledName("OfSeq")>]
let singleton k v = MapExt<_,_>(LanguagePrimitives.FastGenericComparer<_>,MapOne(k,v))
[<CompiledName("OfArray")>]
let ofArray (array: ('Key * 'Value) array) =
let comparer = LanguagePrimitives.FastGenericComparer<'Key>
new MapExt<_,_>(comparer,MapTree.ofArray comparer array)
[<CompiledName("ToList")>]
let toList (m:MapExt<_,_>) = m.ToList()
[<CompiledName("ToArray")>]
let toArray (m:MapExt<_,_>) = m.ToArray()
[<CompiledName("Empty")>]
let empty<'Key,'Value when 'Key : comparison> = MapExt<'Key,'Value>.Empty
[<CompiledName("Count")>]
let count (m:MapExt<_,_>) = m.Count
[<CompiledName("TryMin")>]
let tryMin (m:MapExt<_,_>) = m.TryMinKey
[<CompiledName("Min")>]
let min (m:MapExt<_,_>) =
match m.TryMinKey with
| Some min -> min
| None -> raise <| ArgumentException("The input sequence was empty.")
[<CompiledName("TryMax")>]
let tryMax (m:MapExt<_,_>) = m.TryMaxKey
[<CompiledName("Max")>]
let max (m:MapExt<_,_>) =
match m.TryMaxKey with
| Some min -> min
| None -> raise <| ArgumentException("The input sequence was empty.")
[<CompiledName("TryItem")>]
let tryItem i (m:MapExt<_,_>) = m.TryAt i
[<CompiledName("TryItem")>]
let item i (m:MapExt<_,_>) =
match m.TryAt i with
| Some t -> t
| None -> raise <| IndexOutOfRangeException()
[<CompiledName("Alter")>]
let alter k f (m:MapExt<_,_>) = m.Alter(k, f)
[<CompiledName("MapMonotonic")>]
let mapMonotonic f (m:MapExt<_,_>) = m.MapMonotonic(f)
[<CompiledName("Split")>]
let split k (m:MapExt<_,_>) = m.Split k
[<CompiledName("TryIndexOf")>]
let tryIndexOf i (m:MapExt<_,_>) = m.TryIndexOf i
[<CompiledName("GetReference")>]
let reference i (m:MapExt<_,_>) = m.GetReference i
[<CompiledName("Union")>]
let union (l:MapExt<_,_>) r = l.UnionWith (r, fun _ r -> r)
[<CompiledName("UnionWith")>]
let unionWith f (l:MapExt<_,_>) r = l.UnionWith (r, f)
[<CompiledName("IntersectWith")>]
let intersectWith f (l:MapExt<_,_>) r = l.IntersectWith (r, f)
[<CompiledName("Intersect")>]
let intersect (l:MapExt<_,_>) r = l.Intersect r
[<CompiledName("Map2")>]
let map2 f (l:MapExt<_,_>) r = l.Map2 (r, f)
[<CompiledName("Choose")>]
let choose f (l:MapExt<_,_>) = l.Choose (f)
[<CompiledName("Choose2")>]
let choose2 f (l:MapExt<_,_>) r = l.Choose2 (r, f)
[<CompiledName("Neighbours")>]
let neighbours k (m:MapExt<_,_>) = m.Neighbours k
[<CompiledName("NeighboursAt")>]
let neighboursAt i (m:MapExt<_,_>) = m.NeighboursAt i
(*
module Lens =
let item (key : 'k) =
{ new Lens<_, _>() with
member x.Get s =
tryFind key s
member x.Set(s,r) =
match r with
| Some r -> add key r s
| None -> remove key s
member x.Update(s,f) =
alter key f s
}
*)
module HMap =
/// <summary>The empty map.</summary>
[<GeneralizableValue>]
let empty<'k, 'v> = hmap<'k, 'v>.Empty
let inline single (k : 'k) (v : 'v) =
hmap.Single k v
/// <summary>
/// Returns a new map made from the given bindings. <para />
/// O(n * min(n,32))
/// </summary>
let inline ofSeq (seq : seq<'k * 'v>) =
hmap.OfSeq seq
/// <summary>
/// Returns a new map made from the given bindings. <para />
/// O(n * min(n,32))
/// </summary>
let inline ofMap (map : Map<'k, 'v>) =
map |> Map.toSeq |> ofSeq
/// <summary>
/// Returns a new map made from the given bindings. <para />
/// O(n * min(n,32))
/// </summary>
let inline ofMapExt (map : MapExt<'k, 'v>) =
map |> MapExt.toSeq |> ofSeq
/// <summary>
/// Returns a new map made from the given bindings. <para />
/// O(n * min(n,32))
/// </summary>
let inline ofList (list : list<'k * 'v>) =
hmap.OfList list
/// <summary>
/// Returns a new map made from the given bindings. <para />
/// O(n * min(n,32))
/// </summary>
let inline ofArray (arr : array<'k * 'v>) =
hmap.OfArray arr
/// <summary>
/// Views the collection as an enumerable sequence of pairs. <para />
/// O(n)
/// </summary>
let inline toSeq (map : hmap<'k, 'v>) =
map.ToSeq()
/// <summary>
/// Returns a list of all key-value pairs in the mapping. <para />
/// O(n)
/// </summary>
let inline toList (map : hmap<'k, 'v>) =
map.ToList()
/// <summary>
/// Returns an array of all key-value pairs in the mapping. <para />
/// O(n)
/// </summary>
let inline toArray (map : hmap<'k, 'v>) =
map.ToArray()
/// <summary>
/// Returns a map of all key-value pairs in the mapping. <para />
/// O(n)
/// </summary>
let inline toMap (map : hmap<'k, 'v>) =
let mutable res = Map.empty
for (k,v) in map do
res <- Map.add k v res
res
/// <summary>
/// Returns a map of all key-value pairs in the mapping. <para />
/// O(n)
/// </summary>
let inline toMapExt (map : hmap<'k, 'v>) =
let mutable res = MapExt.empty
for (k,v) in map do
res <- MapExt.add k v res
res
/// <summary>
/// Returns a new map with the binding added to the given map.
/// If a binding with the given key already exists in the input map, the existing binding is replaced by the new binding in the result map. <para />
/// O(min(n,32))
/// </summary>
let inline add (key : 'k) (value : 'v) (map : hmap<'k, 'v>) =
map.Add(key, value)
/// <summary>
/// Removes an element from the domain of the map. No exception is raised if the element is not present. <para />
/// O(min(n,32))
/// </summary>
let inline remove (key : 'k) (map : hmap<'k, 'v>) =
map.Remove(key)
// O(min(n,32))
let inline alter (key : 'k) (mapping : option<'v> -> option<'v>) (map : hmap<'k, 'v>) =
map.Alter(key, mapping)
// O(min(n,32))
let inline update (key : 'k) (mapping : option<'v> -> 'v) (map : hmap<'k, 'v>) =
map.Update(key, mapping)
// O(n+m)
let inline unionWith (resolve : 'k -> 'v -> 'v -> 'v) (l : hmap<'k, 'v>) (r : hmap<'k, 'v>) =
l.UnionWith(r, resolve)
// O(n+m)
let inline union (l : hmap<'k, 'v>) (r : hmap<'k, 'v>) =
l.Union r
// O(min(n,32))
let inline tryRemove (key : 'k) (map : hmap<'k, 'v>) =
map.TryRemove key
/// <summary>
/// Builds a new collection whose elements are the results of applying the given function
/// to each of the elements of the collection. The key passed to the
/// function indicates the key of element being transformed. <para />
/// O(n)
/// </summary>
let inline map (mapping : 'k -> 'a -> 'b) (map : hmap<'k, 'a>) =
map.Map(mapping)
// O(n)
let inline choose (mapping : 'k -> 'a -> option<'b>) (map : hmap<'k, 'a>) =
map.Choose mapping
// O(n)
let inline filter (predicate : 'k -> 'v -> bool) (map : hmap<'k, 'v>) =
map.Filter predicate
// O(n)
let inline iter (iter : 'k -> 'v -> unit) (map : hmap<'k, 'v>) =
map.Iter iter
// O(n)
let inline fold (folder : 's -> 'k -> 'v -> 's) (seed : 's) (map : hmap<'k, 'v>) =
map.Fold(seed, folder)
// O(n)
let inline exists (predicate : 'k -> 'v -> bool) (map : hmap<'k, 'v>) =
map.Exists(predicate)
// O(n)
let inline forall (predicate : 'k -> 'v -> bool) (map : hmap<'k, 'v>) =
map.Forall(predicate)
// O(n+m)
let inline map2 (mapping : 'k -> option<'a> -> option<'b> -> 'c) (l : hmap<'k, 'a>) (r : hmap<'k, 'b>) =
l.Map2(r, mapping)
// O(n+m)
let inline choose2 (mapping : 'k -> option<'a> -> option<'b> -> option<'c>) (l : hmap<'k, 'a>) (r : hmap<'k, 'b>) =
l.Choose2(r, mapping)
// O(min(n,32))
let inline tryFind (key : 'k) (map : hmap<'k, 'v>) =
map.TryFind key
// O(min(n,32))
let inline find (key : 'k) (map : hmap<'k, 'v>) =
map.Find key
// O(min(n,32))
let inline containsKey (key : 'k) (map : hmap<'k, 'v>) =
map.ContainsKey key
// O(1)
let inline count (map : hmap<'k, 'v>) = map.Count
// O(1)
let inline isEmpty (map : hmap<'k, 'v>) = map.IsEmpty
(*
module Lens =
let item (key : 'k) =
{ new Lens<_, _>() with
member x.Get s =
tryFind key s
member x.Set(s,r) =
match r with
| Some r -> add key r s
| None -> remove key s
member x.Update(s,f) =
alter key f s
}
*)
type SetCmp =
| Distinct = 0
| ProperSubset = 1
| ProperSuperset = 2
| Overlap = 3
| Equal = 4
[<Struct>]
type SetOperation<'a>(value : 'a, cnt : int) =
member x.Value = value
member x.Count = cnt
member x.Inverse = SetOperation(value, -cnt)
override x.ToString() =
if cnt = 1 then sprintf "Add(%A)" value
elif cnt = -1 then sprintf "Rem(%A)" value
elif cnt > 0 then sprintf "Add%d(%A)" cnt value
elif cnt < 0 then sprintf "Rem%d(%A)" -cnt value
else "Nop"
module SetOperation =
let inline create (cnt : int) (v : 'a) = SetOperation(v, cnt)
let inline add (v : 'a) = SetOperation(v, 1)
let inline rem (v : 'a) = SetOperation(v, -1)
let inline inverse (d : SetOperation<'a>) = d.Inverse
let map (f : 'a -> 'b) (d : SetOperation<'a>) = SetOperation<'b>(f d.Value, d.Count)
[<AutoOpen>]
module SetDeltaExtensions =
let inline Add(v : 'a) = SetOperation(v, 1)
let inline Rem(v : 'a) = SetOperation(v, -1)
type SetOperation<'a> with
static member inline Add v = SetOperation(v, 1)
static member inline Rem v = SetOperation(v, -1)
let inline (|Add|Rem|) (d : SetOperation<'a>) =
if d.Count > 0 then Add(d.Count, d.Value)
else Rem(-d.Count, d.Value)
[<Struct; CustomEquality; NoComparison>]
[<StructuredFormatDisplay("{AsString}")>]
type hdeltaset<'a>(store : hmap<'a, int>) =
static let monoid =
{
mempty = hdeltaset<'a>(HMap.empty)
mappend = fun l r -> l.Combine r
misEmpty = fun s -> s.IsEmpty
}
static member Empty = hdeltaset<'a>(HMap.empty)
static member Monoid = monoid
member private x.Store = store
member x.Count = store.Count
member x.IsEmpty = store.IsEmpty
member x.Add (op : SetOperation<'a>) =
if op.Count <> 0 then
store |> HMap.alter op.Value (fun o ->
let n = defaultArg o 0 + op.Count
if n = 0 then None
else Some n
)
|> hdeltaset
else
x
member x.Remove (op : SetOperation<'a>) =
x.Add op.Inverse
member x.Combine (other : hdeltaset<'a>) =
if store.IsEmpty then
other
elif other.IsEmpty then
x
elif store.Count * 5 < other.Count then
let mutable big = other
for d in x do
big <- big.Add d
big
elif other.Count * 5 < store.Count then
let mutable big = x
for d in other do
big <- big.Add d
big
else
HMap.choose2 (fun k l r ->
let r = Option.defaultValue 0 l + Option.defaultValue 0 r
if r <> 0 then Some r
else None
) store other.Store
|> hdeltaset
member x.Map (f : SetOperation<'a> -> SetOperation<'b>) =
let mutable res = hdeltaset<'b>.Empty
for (k,v) in store do
res <- res.Add (f (SetOperation(k,v)))
res
member x.Choose (f : SetOperation<'a> -> option<SetOperation<'b>>) =
let mutable res = hdeltaset<'b>.Empty
for (k,v) in store do
match f (SetOperation(k,v)) with
| Some r -> res <- res.Add r
| _ -> ()
res
member x.Filter (f : SetOperation<'a> -> bool) =
store |> HMap.filter (fun k v -> SetOperation(k,v) |> f) |> hdeltaset
member x.Collect (f : SetOperation<'a> -> hdeltaset<'b>) =
let mutable res = hdeltaset<'b>.Empty
for (k,v) in store do
res <- res.Combine (f (SetOperation(k,v)))
res
member x.Iter (f : SetOperation<'a> -> unit) =
store |> HMap.iter (fun k v ->
f (SetOperation(k,v))
)
member x.Fold (seed : 's, f : 's -> SetOperation<'a> -> 's) =
store |> HMap.fold (fun s k v ->
f s (SetOperation(k,v))
) seed
member x.Exists (f : SetOperation<'a> -> bool) =
store |> HMap.exists (fun k v -> f (SetOperation(k,v)))
member x.Forall (f : SetOperation<'a> -> bool) =
store |> HMap.forall (fun k v -> f (SetOperation(k,v)))
member x.ToSeq() =
store |> HMap.toSeq |> Seq.map SetOperation
member x.ToList() =
store |> HMap.toList |> List.map SetOperation
member x.ToArray() =
x.ToSeq() |> Seq.toArray
member x.ToMap() = store
static member OfSeq (seq : seq<SetOperation<'a>>) =
let mutable res = hdeltaset<'a>.Empty
for e in seq do
res <- res.Add e
res
static member OfList (list : list<SetOperation<'a>>) =
list |> hdeltaset.OfSeq
static member OfArray (arr : array<SetOperation<'a>>) =
arr |> hdeltaset.OfSeq
override x.GetHashCode() = store.GetHashCode()
override x.Equals o =
match o with
| :? hdeltaset<'a> as o -> store.Equals(o.Store)
| _ -> false
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
x.ToSeq() |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"hdeltaset [" + content + suffix + "]"
member private x.AsString = x.ToString()
interface IEnumerable with
member x.GetEnumerator() = new HDeltaSetEnumerator<_>(store) :> _
interface IEnumerable<SetOperation<'a>> with
member x.GetEnumerator() = new HDeltaSetEnumerator<_>(store) :> _
and private HDeltaSetEnumerator<'a>(store : hmap<'a, int>) =
let e = (store :> seq<_>).GetEnumerator()
member x.Current =
let (v,c) = e.Current
SetOperation(v,c)
interface IEnumerator with
member x.MoveNext() = e.MoveNext()
member x.Current = x.Current :> obj
member x.Reset() = e.Reset()
interface IEnumerator<SetOperation<'a>> with
member x.Dispose() = e.Dispose()
member x.Current = x.Current
module HDeltaSet =
let inline monoid<'a> = hdeltaset<'a>.Monoid
let inline empty<'a> = hdeltaset<'a>.Empty
let inline isEmpty (set : hdeltaset<'a>) = set.IsEmpty
let inline count (set : hdeltaset<'a>) = set.Count
let inline single (op : SetOperation<'a>) =
hdeltaset(HMap.single op.Value op.Count)
let inline ofSeq (seq : seq<SetOperation<'a>>) =
hdeltaset.OfSeq seq
let inline ofList (list : list<SetOperation<'a>>) =
hdeltaset.OfList list
let inline ofArray (arr : array<SetOperation<'a>>) =
hdeltaset.OfArray arr
let inline ofHMap (map : hmap<'a, int>) =
hdeltaset map
let inline toSeq (set : hdeltaset<'a>) =
set.ToSeq()
let inline toList (set : hdeltaset<'a>) =
set.ToList()
let inline toArray (set : hdeltaset<'a>) =
set.ToArray()
let inline toHMap (set : hdeltaset<'a>) =
set.ToMap()
let inline add (value : SetOperation<'a>) (set : hdeltaset<'a>) =
set.Add value
let inline remove (value : SetOperation<'a>) (set : hdeltaset<'a>) =
set.Remove value
let inline combine (l : hdeltaset<'a>) (r : hdeltaset<'a>) =
l.Combine r
let inline map (f : SetOperation<'a> -> SetOperation<'b>) (set : hdeltaset<'a>) =
set.Map f
let inline choose (f : SetOperation<'a> -> option<SetOperation<'b>>) (set : hdeltaset<'a>) =
set.Choose f
let inline filter (f : SetOperation<'a> -> bool) (set : hdeltaset<'a>) =
set.Filter f
let inline collect (f : SetOperation<'a> -> hdeltaset<'b>) (set : hdeltaset<'a>) =
set.Collect f
let inline iter (iterator : SetOperation<'a> -> unit) (set : hdeltaset<'a>) =
set.Iter iterator
let inline exists (predicate : SetOperation<'a> -> bool) (set : hdeltaset<'a>) =
set.Exists predicate
let inline forall (predicate : SetOperation<'a> -> bool) (set : hdeltaset<'a>) =
set.Forall predicate
let inline fold (folder : 's -> SetOperation<'a> -> 's) (seed : 's) (set : hdeltaset<'a>) =
set.Fold(seed, folder)
[<Struct; StructuralEquality; NoComparison>]
[<StructuredFormatDisplay("{AsString}")>]
type hrefset<'a>(store : hmap<'a, int>) =
static let trace =
{
tops = hdeltaset<'a>.Monoid
tempty = hrefset<'a>(HMap.empty)
tapply = fun s d -> s.ApplyDelta d
tcompute = fun l r -> l.ComputeDelta r
tcollapse = fun _ _ -> false
}
static let traceNoRefCount =
{
tops = hdeltaset<'a>.Monoid
tempty = hrefset<'a>(HMap.empty)
tapply = fun s d -> s.ApplyDeltaNoRefCount d
tcompute = fun l r -> l.ComputeDelta r
tcollapse = fun _ _ -> false
}
static member Empty = hrefset<'a>(HMap.empty)
static member Trace = trace
static member TraceNoRefCount = traceNoRefCount
member x.IsEmpty = store.IsEmpty
member x.Count = store.Count
member private x.Store = store
member x.Contains (value : 'a) =
HMap.containsKey value store
member x.GetRefCount (value : 'a) =
HMap.tryFind value store |> Option.defaultValue 0
member x.Add(value : 'a) =
store
|> HMap.update value (fun o ->
match o with
| Some o -> o + 1
| None -> 1
)
|> hrefset
member x.Remove(value : 'a) =
store
|> HMap.alter value (fun o ->
match o with
| Some 1 -> None
| Some c -> Some (c - 1)
| None -> None
)
|> hrefset
member x.Alter(value : 'a, f : int -> int) =
store
|> HMap.alter value (fun o ->
let o = defaultArg o 0
let n = f o
if n > 0 then
Some n
else
None
)
|> hrefset
member x.Union(other : hrefset<'a>) =
HMap.map2 (fun k l r ->
match l, r with
| Some l, Some r -> l + r
| Some l, None -> l
| None, Some r -> r
| None, None -> 0
) store other.Store
|> hrefset
member x.Difference(other : hrefset<'a>) =
HMap.choose2 (fun k l r ->
let newRefCount =
match l, r with
| Some l, Some r -> l - r
| Some l, None -> l
| None, Some r -> 0
| None, None -> 0
if newRefCount > 0 then Some newRefCount
else None
) store other.Store
|> hrefset
member x.Intersect(other : hrefset<'a>) =
HMap.choose2 (fun k l r ->
match l, r with
| Some l, Some r -> Some (min l r)
| _ -> None
) store other.Store
|> hrefset
member x.UnionWith(other : hrefset<'a>, f : int -> int -> int) =
HMap.map2 (fun k l r ->
match l, r with
| Some l, Some r -> f l r
| Some l, None -> f l 0
| None, Some r -> f 0 r
| None, None -> f 0 0
) store other.Store
|> hrefset
member x.ToHMap() =
store
member x.ToSeq() =
store.ToSeq() |> Seq.map fst
member x.ToList() =
store.ToList() |> List.map fst
member x.ToArray() =
x.ToSeq() |> Seq.toArray
member x.Map(mapping : 'a -> 'b) =
let mutable res = HMap.empty
for (k,v) in HMap.toSeq store do
let k = mapping k
res <- res |> HMap.update k (fun o -> defaultArg o 0 + v)
hrefset res
member x.Choose(mapping : 'a -> option<'b>) =
let mutable res = HMap.empty
for (k,v) in HMap.toSeq store do
match mapping k with
| Some k ->
res <- res |> HMap.update k (fun o -> defaultArg o 0 + v)
| None ->
()
hrefset res
member x.Filter(predicate : 'a -> bool) =
store |> HMap.filter (fun k _ -> predicate k) |> hrefset
member x.Collect(mapping : 'a -> hrefset<'b>) =
let mutable res = hrefset<'b>.Empty
for (k,ro) in store.ToSeq() do
let r = mapping k
if ro = 1 then
res <- res.Union r
else
res <- res.UnionWith(r, fun li ri -> li + ro * ri)
res
member x.Iter (iterator : 'a -> unit) =
store |> HMap.iter (fun k _ -> iterator k)
member x.Exists (predicate : 'a -> bool) =
store |> HMap.exists (fun k _ -> predicate k)
member x.Forall (predicate : 'a -> bool) =
store |> HMap.forall (fun k _ -> predicate k)
member x.Fold (seed : 's, folder : 's -> 'a -> 's) =
store |> HMap.fold (fun s k _ -> folder s k) seed
static member OfSeq (seq : seq<'a>) =
let mutable res = hrefset<'a>.Empty
for e in seq do
res <- res.Add e
res
static member OfList (list : list<'a>) =
hrefset<'a>.OfSeq list
static member OfArray (arr : 'a[]) =
hrefset<'a>.OfSeq arr
static member OfHMap (map : hmap<'a, int>) =
hrefset map
member x.ComputeDelta(other : hrefset<'a>) =
// O(1)
if store.Store == other.Store.Store then
HDeltaSet.empty
// O(other)
elif store.IsEmpty then
other.Store |> HMap.map (fun _ _ -> 1) |> HDeltaSet.ofHMap
// O(N)
elif other.IsEmpty then
store |> HMap.map (fun _ _ -> -1) |> HDeltaSet.ofHMap
// O(N + other)
else
let mutable cnt = 0
let del (l : list<'a * int>) =
l |> List.map (fun (v,_) -> inc &cnt; v, -1)
let add (l : list<'a * int>) =
l |> List.map (fun (v,_) -> inc &cnt; v, 1)
let both (hash : int) (l : list<'a * int>) (r : list<'a * int>) =
HMapList.mergeWithOption' (fun v l r ->
match l, r with
| Some l, None -> inc &cnt; Some -1
| None, Some r -> inc &cnt; Some 1
| _ -> None
) l r
let store = IntMap.computeDelta both (IntMap.map del) (IntMap.map add) store.Store other.Store.Store
hdeltaset (hmap(cnt, store))
member x.ApplyDelta (deltas : hdeltaset<'a>) =
// O(1)
if deltas.IsEmpty then
x, deltas
// O(Delta)
elif store.IsEmpty then
let mutable maxDelta = 0
let state = deltas |> HDeltaSet.toHMap |> HMap.filter (fun _ d -> maxDelta <- max maxDelta d; d > 0)
let delta =
if maxDelta > 1 then state |> HMap.map (fun _ _ -> 1)
else state
hrefset state, hdeltaset delta
// O(Delta * log N)
elif deltas.Count * 5 < store.Count then
let mutable res = store
let effective =
deltas |> HDeltaSet.choose (fun d ->
let mutable delta = Unchecked.defaultof<SetOperation<'a>>
let value = d.Value
res <- res |> HMap.alter value (fun cnt ->
let o = defaultArg cnt 0
let n = o + d.Count
if n > 0 && o = 0 then
delta <- Add(value)
elif n = 0 && o > 0 then
delta <- Rem(value)
if n <= 0 then None
else Some n
)
if delta.Count <> 0 then Some delta
else None
)
hrefset res, effective
// O(Delta + N)
else
let mutable effective = HDeltaSet.empty
let deltas = HDeltaSet.toHMap deltas
let newStore =
HMap.choose2 (fun k s d ->
match d with
| Some d ->
let o = Option.defaultValue 0 s
let n = d + o
if o = 0 && n > 0 then
effective <- HDeltaSet.add (Add k) effective
elif o > 0 && n = 0 then
effective <- HDeltaSet.add (Rem k) effective
if n <= 0 then None
else Some n
| None ->
s
) store deltas
hrefset newStore, effective
member x.ApplyDeltaNoRefCount (deltas : hdeltaset<'a>) =
// O(1)
if deltas.IsEmpty then
x, deltas
// O(Delta)
elif store.IsEmpty then
let state = deltas |> HDeltaSet.toHMap |> HMap.choose (fun _ d -> if d > 0 then Some 1 else None)
hrefset state, hdeltaset state
// O(Delta * log N)
elif deltas.Count * 5 < store.Count then
let mutable res = store
let effective =
deltas |> HDeltaSet.choose (fun d ->
let mutable delta = Unchecked.defaultof<SetOperation<'a>>
let value = d.Value
res <- res |> HMap.alter value (fun cnt ->
let o = defaultArg cnt 0
let n =
if d.Count > 0 then 1
elif d.Count < 0 then 0
else o
if n > 0 && o = 0 then
delta <- Add(value)
elif n = 0 && o > 0 then
delta <- Rem(value)
if n <= 0 then None
else Some n
)
if delta.Count <> 0 then Some delta
else None
)
hrefset res, effective
// O(Delta + N)
else
let mutable effective = HDeltaSet.empty
let deltas = HDeltaSet.toHMap deltas
let newStore =
HMap.choose2 (fun k s d ->
match d with
| Some d ->
let o = Option.defaultValue 0 s
let n = if d > 0 then 1 elif d < 0 then 0 else o
if o = 0 && n > 0 then
effective <- HDeltaSet.add (Add k) effective
elif o > 0 && n = 0 then
effective <- HDeltaSet.add (Rem k) effective
if n <= 0 then None
else Some n
| None ->
s
) store deltas
hrefset newStore, effective
static member Compare(l : hrefset<'a>, r : hrefset<'a>) =
let i = l.Intersect r
let b = i.Count
let lo = l.Count - b
let ro = r.Count - b
match lo, b, ro with
| 0, _, 0 -> SetCmp.Equal
| _, 0, _ -> SetCmp.Distinct
| a, _, 0 -> SetCmp.ProperSuperset
| 0, _, a -> SetCmp.ProperSubset
| _, _, _ -> SetCmp.Overlap
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
x.ToSeq() |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"hrefset [" + content + suffix + "]"
member private x.AsString = x.ToString()
interface IEnumerable with
member x.GetEnumerator() = new HRefSetEnumerator<_>(store) :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = new HRefSetEnumerator<_>(store) :> _
and private HRefSetEnumerator<'a>(store : hmap<'a, int>) =
let e = (store :> seq<_>).GetEnumerator()
member x.Current =
let (v,_) = e.Current
v
interface IEnumerator with
member x.MoveNext() = e.MoveNext()
member x.Current = x.Current :> obj
member x.Reset() = e.Reset()
interface IEnumerator<'a> with
member x.Dispose() = e.Dispose()
member x.Current = x.Current
module HRefSet =
let inline empty<'a> = hrefset<'a>.Empty
let single v = hrefset (HMap.single v 1)
// O(1)
let inline toHMap (set : hrefset<'a>) = set.ToHMap()
// O(n)
let inline toSeq (set : hrefset<'a>) = set.ToSeq()
// O(n)
let inline toList (set : hrefset<'a>) = set.ToList()
// O(n)
let inline toArray (set : hrefset<'a>) = set.ToArray()
// O(1)
let inline ofHMap (map : hmap<'a, int>) = hrefset.OfHMap map
// O(n)
let inline ofSeq (seq : seq<'a>) = hrefset.OfSeq seq
// O(n)
let inline ofList (list : list<'a>) = hrefset.OfList list
// O(n)
let inline ofArray (arr : 'a[]) = hrefset.OfArray arr
// O(1)
let inline isEmpty (set : hrefset<'a>) =
set.IsEmpty
// O(1)
let inline count (set : hrefset<'a>) =
set.Count
let inline refcount (value : 'a) (set : hrefset<'a>) =
set.GetRefCount value
let inline contains (value : 'a) (set : hrefset<'a>) =
set.Contains value
// O(min(n,32))
let inline add (value : 'a) (set : hrefset<'a>) =
set.Add value
// O(min(n,32))
let inline remove (value : 'a) (set : hrefset<'a>) =
set.Remove value
// O(n + m)
let inline union (l : hrefset<'a>) (r : hrefset<'a>) =
l.Union r
// O(n + m)
let inline difference (l : hrefset<'a>) (r : hrefset<'a>) =
l.Difference r
// O(n + m)
let inline intersect (l : hrefset<'a>) (r : hrefset<'a>) =
l.Intersect r
let inline alter (value : 'a) (f : int -> int) (set : hrefset<'a>) =
set.Alter(value, f)
// O(n)
let inline map (mapping : 'a -> 'b) (set : hrefset<'a>) =
set.Map mapping
// O(n)
let inline choose (mapping : 'a -> option<'b>) (set : hrefset<'a>) =
set.Choose mapping
// O(n)
let inline filter (predicate : 'a -> bool) (set : hrefset<'a>) =
set.Filter predicate
// O(sum ni)
let inline collect (mapping : 'a -> hrefset<'b>) (set : hrefset<'a>) =
set.Collect mapping
// O(n)
let inline iter (iterator : 'a -> unit) (set : hrefset<'a>) =
set.Iter iterator
// O(n)
let inline exists (predicate : 'a -> bool) (set : hrefset<'a>) =
set.Exists predicate
// O(n)
let inline forall (predicate : 'a -> bool) (set : hrefset<'a>) =
set.Forall predicate
// O(n)
let inline fold (folder : 's -> 'a -> 's) (seed : 's) (set : hrefset<'a>) =
set.Fold(seed, folder)
let inline trace<'a> = hrefset<'a>.Trace
let inline traceNoRefCount<'a> = hrefset<'a>.TraceNoRefCount
// O(n + m)
let inline computeDelta (src : hrefset<'a>) (dst : hrefset<'a>) =
src.ComputeDelta dst
// O(|delta| * min(32, n))
let inline applyDelta (set : hrefset<'a>) (delta : hdeltaset<'a>) =
set.ApplyDelta delta
// O(|delta| * min(32, n))
let inline applyDeltaNoRefCount (set : hrefset<'a>) (delta : hdeltaset<'a>) =
set.ApplyDeltaNoRefCount delta
// O(n + m)
let compare (l : hrefset<'a>) (r : hrefset<'a>) =
hrefset.Compare(l,r)
(*
module Lens =
let refcount (key : 'k) =
{ new Lens<_, _>() with
member x.Get s =
refcount key s
member x.Set(s,r) =
alter key (fun _ -> r) s
member x.Update(s,f) =
alter key f s
}
let contains (key : 'k) =
{ new Lens<_, _>() with
member x.Get s =
contains key s
member x.Set(s,r) =
match r with
| true -> alter key (max 1) s
| false -> alter key (min 0) s
member x.Update(s,f) =
alter key (fun o -> if f(o>0) then max o 1 else min o 0) s
}
*)
type ISetReader<'a> = IOpReader<hrefset<'a>, hdeltaset<'a>>
type aset<'a> =
abstract member IsConstant : bool
abstract member Content : IMod<hrefset<'a>>
abstract member GetReader : unit -> ISetReader<'a>
[<StructuredFormatDisplay("{AsString}")>]
[<CompiledName("ChangeableSet")>]
type cset<'a>(initial : seq<'a>) =
let history = History HRefSet.traceNoRefCount
do initial |> Seq.map Add |> HDeltaSet.ofSeq |> history.Perform |> ignore
member x.Add(v : 'a) =
lock x (fun () ->
let op = HDeltaSet.single (Add v)
history.Perform op
)
member x.AddRange (items : seq<'a>) =
lock x (fun () ->
let ops = HDeltaSet.ofSeq (items |> Seq.map (fun v -> Add v))
history.Perform ops
)
member x.Remove(v : 'a) =
lock x (fun () ->
let op = HDeltaSet.single (Rem v)
history.Perform op
)
member x.Contains (v : 'a) =
history.State |> HRefSet.contains v
member x.Count =
history.State.Count
member x.UnionWith (other : seq<'a>) =
lock x (fun () ->
let op = other |> Seq.map Add |> HDeltaSet.ofSeq
history.Perform op |> ignore
)
member x.ExceptWith (other : seq<'a>) =
lock x (fun () ->
let op = other |> Seq.map Rem |> HDeltaSet.ofSeq
history.Perform op |> ignore
)
member x.IntersectWith (other : seq<'a>) =
lock x (fun () ->
let other = HRefSet.ofSeq other
let op = HRefSet.computeDelta (HRefSet.difference history.State other) HRefSet.empty
history.Perform op |> ignore
)
member x.SymmetricExceptWith (other : seq<'a>) =
let other = HRefSet.ofSeq other
lock x (fun () ->
let add = HRefSet.computeDelta HRefSet.empty (HRefSet.difference other history.State)
let rem = HRefSet.computeDelta (HRefSet.intersect other history.State) HRefSet.empty
let op = HDeltaSet.combine add rem
history.Perform op |> ignore
)
member x.Clear() =
lock x (fun () ->
let op = HRefSet.computeDelta history.State HRefSet.empty
history.Perform op |> ignore
)
member x.CopyTo(arr : 'a[], index : int) =
let mutable index = index
for e in x do
arr.[index] <- e
index <- index + 1
interface ICollection<'a> with
member x.Add(v) = x.Add v |> ignore
member x.Clear() = x.Clear()
member x.Remove(v) = x.Remove v
member x.Contains(v) = x.Contains v
member x.CopyTo(arr,i) = x.CopyTo(arr, i)
member x.IsReadOnly = false
member x.Count = x.Count
interface ISet<'a> with
member x.Add v = x.Add v
member x.ExceptWith o = x.ExceptWith o
member x.UnionWith o = x.UnionWith o
member x.IntersectWith o = x.IntersectWith o
member x.SymmetricExceptWith o = x.SymmetricExceptWith o
member x.IsSubsetOf o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.ProperSubset | SetCmp.Equal -> true
| _ -> false
member x.IsProperSubsetOf o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.ProperSubset -> true
| _ -> false
member x.IsSupersetOf o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.ProperSuperset | SetCmp.Equal -> true
| _ -> false
member x.IsProperSupersetOf o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.ProperSuperset -> true
| _ -> false
member x.Overlaps o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.Distinct -> false
| _ -> true
member x.SetEquals o =
match HRefSet.compare history.State (HRefSet.ofSeq o) with
| SetCmp.Equal -> true
| _ -> false
interface aset<'a> with
member x.IsConstant = false
member x.Content = history :> IMod<_>
member x.GetReader() = history.NewReader()
interface IEnumerable with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator() :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator() :> _
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
history.State |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"cset [" + content + suffix + "]"
member private x.AsString = x.ToString()
new() = cset<'a>(Seq.empty)
[<RequireQualifiedAccess>]
module CSet =
let inline empty<'a> = cset<'a>()
let inline ofSet (set : hrefset<'a>) = cset(set)
let inline ofSeq (seq : seq<'a>) = cset(seq)
let inline ofList (list : list<'a>) = cset(list)
let inline ofArray (list : array<'a>) = cset(list)
let inline add (v : 'a) (set : cset<'a>) = set.Add v
let inline remove (v : 'a) (set : cset<'a>) = set.Remove v
let inline clear (set : cset<'a>) = set.Clear()
let inline unionWith (other : seq<'a>) (set : cset<'a>) = set.UnionWith other
let inline exceptWith (other : seq<'a>) (set : cset<'a>) = set.ExceptWith other
let inline intersectWith (other : seq<'a>) (set : cset<'a>) = set.IntersectWith other
let inline symmetricExceptWith (other : seq<'a>) (set : cset<'a>) = set.SymmetricExceptWith other
module private HSetList =
let rec add (cnt : byref<int>) (value : 'a) (list : list<'a>) =
match list with
| [] ->
cnt <- cnt + 1
[value]
| h :: tail ->
if Unchecked.equals h value then
list
else
h :: add &cnt value tail
let rec remove (cnt : byref<int>) (value : 'a) (list : list<'a>) =
match list with
| [] ->
None
| h :: tail ->
if Unchecked.equals h value then
cnt <- cnt - 1
match tail with
| [] -> None
| _ -> Some tail
else
match remove &cnt value tail with
| Some t -> Some (h :: t)
| None -> Some [h]
let rec union (dupl : byref<int>) (l : list<'a>) (r : list<'a>) =
let mutable d = dupl
let newR =
r |> List.filter (fun r ->
if l |> List.exists (Unchecked.equals r) then
d <- d + 1
false
else
true
)
dupl <- d
l @ newR
let rec difference (cnt : byref<int>) (l : list<'a>) (r : list<'a>) =
match l with
| [] ->
None
| h :: tail ->
if List.exists (Unchecked.equals h) r then
difference &cnt tail r
else
cnt <- cnt + 1
match difference &cnt tail r with
| Some t -> Some (h :: t)
| None -> Some [h]
let rec intersect (cnt : byref<int>) (l : list<'a>) (r : list<'a>) =
match l with
| [] ->
None
| h :: tail ->
if List.exists (Unchecked.equals h) r then
cnt <- cnt + 1
match intersect &cnt tail r with
| Some t -> Some (h :: t)
| None -> Some [h]
else
intersect &cnt tail r
let rec mergeWithOption (f : 'a -> bool -> bool -> option<'c>) (l : list<'a>) (r : list<'a>) =
let newL =
l |> List.choose (fun lk ->
let other = r |> List.exists (fun rk -> Unchecked.equals rk lk)
match f lk true other with
| Some r -> Some (lk, r)
| None -> None
)
let newR =
r |> List.choose (fun rk ->
if l |> List.forall (fun lk -> not (Unchecked.equals lk rk)) then
match f rk false true with
| Some r -> Some(rk, r)
| None -> None
else
None
)
match newL with
| [] ->
match newR with
| [] -> None
| _ -> Some newR
| _ ->
match newR with
| [] -> Some newL
| _ -> Some (newL @ newR)
let rec equals (l : list<'a>) (r : list<'a>) =
let mutable r = r
let mutable c = 0
use e = (l :> seq<_>).GetEnumerator()
while c = 0 && e.MoveNext() do
let l = e.Current
c <- 1
r <- remove &c l r |> Option.defaultValue []
c = 0 && List.isEmpty r
[<Struct; NoComparison; CustomEquality>]
[<StructuredFormatDisplay("{AsString}")>]
type hset<'a>(cnt : int, store : intmap<list<'a>>) =
static let empty = hset(0, IntMap.empty)
static member Empty : hset<'a> = empty
(*
static member private CreatePickler (r : IPicklerResolver) =
let pint = r.Resolve<int>()
let pv = r.Resolve<'a>()
let parr = r.Resolve<'a[]>()
let read (rs : ReadState) =
let cnt = pint.Read rs "count"
let elements = parr.Read rs "elements"
hset<'a>.OfArray elements
let write (ws : WriteState) (s : hset<'a>) =
pint.Write ws "count" s.Count
parr.Write ws "elements" (s.ToArray())
let clone (cs : CloneState) (m : hset<'a>) =
let mutable res = empty
for e in m do res <- res.Add(pv.Clone cs e)
res
let accept (vs : VisitState) (m : hset<'a>) =
for v in m do pv.Accept vs v
Pickler.FromPrimitives(read, write, clone, accept)
*)
member private x.Store = store
member x.Count = cnt
member x.IsEmpty = cnt = 0
member x.Add (value : 'a) =
let hash = Unchecked.hash value
let mutable cnt = cnt
let newStore =
store |> IntMap.alter (fun o ->
match o with
| None ->
cnt <- cnt + 1
Some [value]
| Some old ->
HSetList.add &cnt value old |> Some
) hash
hset(cnt, newStore)
member x.Remove (value : 'a) =
let hash = Unchecked.hash value
let mutable cnt = cnt
let newStore =
store |> IntMap.alter (fun o ->
match o with
| None -> None
| Some old -> HSetList.remove &cnt value old
) hash
hset(cnt, newStore)
member x.Contains (value : 'a) =
let hash = Unchecked.hash value
match IntMap.tryFind hash store with
| Some l -> l |> List.exists (Unchecked.equals value)
| None -> false
member x.Alter(key : 'a, f : bool -> bool) =
let hash = Unchecked.hash key
let mutable cnt = cnt
let newStore =
store |> IntMap.alter (fun ol ->
match ol with
| None ->
if f false then
cnt <- cnt + 1
Some [key]
else
None
| Some ol ->
let mutable was = List.exists (Unchecked.equals key) ol
let should = f was
if should && not was then
cnt <- cnt + 1
Some (key :: ol)
elif not should && was then
cnt <- cnt - 1
match List.filter (Unchecked.equals key >> not) ol with
| [] -> None
| l -> Some l
else
Some ol
) hash
hset(cnt, newStore)
member x.Map (mapping : 'a -> 'b) =
let mutable res = hset.Empty
for e in x.ToSeq() do
res <- res.Add(mapping e)
res
member x.ChooseHMap(mapping : 'a -> option<'b>) =
let mutable cnt = 0
let mapStore =
store |> IntMap.mapOption (fun k ->
let store =
k |> List.choose (fun k ->
match mapping k with
| Some v -> inc &cnt; Some (k,v)
| None -> None
)
if List.isEmpty store then None
else Some store
)
hmap<'a, 'b>(cnt, mapStore)
member x.MapHMap(mapping : 'a -> 'b) =
let mapStore = store |> IntMap.map (List.map (fun k -> (k, mapping k)))
hmap<'a, 'b>(cnt, mapStore)
member x.Choose (mapping : 'a -> option<'b>) =
let mutable res = hset.Empty
for e in x.ToSeq() do
match mapping e with
| Some e ->
res <- res.Add(e)
| None ->
()
res
member x.Filter (predicate : 'a -> bool) =
let mutable cnt = 0
let predicate v =
if predicate v then
cnt <- cnt + 1
true
else
false
let newStore =
store |> IntMap.mapOption (fun l ->
match List.filter predicate l with
| [] -> None
| l -> Some l
)
hset(cnt, newStore)
member x.Collect (mapping : 'a -> hset<'b>) =
let mutable res = hset<'b>.Empty
for (_,l) in IntMap.toSeq store do
for e in l do
res <- res.Union (mapping e)
res
member x.Iter (iter : 'a -> unit) =
store |> IntMap.toSeq |> Seq.iter (fun (_,l) -> l |> List.iter iter)
member x.Exists (predicate : 'a -> bool) =
store |> IntMap.toSeq |> Seq.exists (fun (_,l) -> l |> List.exists predicate)
member x.Forall (predicate : 'a -> bool) =
store |> IntMap.toSeq |> Seq.forall (fun (_,l) -> l |> List.forall predicate)
member x.Fold (seed : 's, folder : 's -> 'a -> 's) =
store |> IntMap.toSeq |> Seq.fold (fun s (_,l) ->
l |> List.fold folder s
) seed
member x.Union (other : hset<'a>) : hset<'a> =
let mutable dupl = 0
let newStore = IntMap.appendWith (fun l r -> HSetList.union &dupl l r) store other.Store
hset(cnt + other.Count - dupl, newStore)
member x.Difference (other : hset<'a>) : hset<'a> =
let mutable cnt = 0
let newStore =
IntMap.mergeWithKey
(fun k ll rl -> HSetList.difference &cnt ll rl)
(fun l -> cnt <- l |> IntMap.fold (fun s l -> s + List.length l) cnt; l)
(fun r -> IntMap.empty)
store
other.Store
hset(cnt, newStore)
member x.Intersect (other : hset<'a>) : hset<'a> =
let mutable cnt = 0
let newStore =
IntMap.mergeWithKey
(fun k ll rl -> HSetList.intersect &cnt ll rl)
(fun l -> IntMap.empty)
(fun r -> IntMap.empty)
store
other.Store
hset(cnt, newStore)
member x.ToSeq() =
store |> IntMap.toSeq |> Seq.collect snd
member x.ToList() =
store |> IntMap.toList |> List.collect snd
member x.ToArray() =
x.ToSeq() |> Seq.toArray
member x.Choose2(other : hset<'a>, f : 'a -> bool-> bool -> option<'v>) =
let mutable cnt = 0
let f k l r =
match f k l r with
| Some v ->
cnt <- cnt + 1
Some v
| None ->
None
let both (hash : int) (l : list<'a>) (r : list<'a>) =
HSetList.mergeWithOption f l r
let onlyLeft (l : intmap<list<'a>>) =
l |> IntMap.mapOption (fun l ->
match l |> List.choose (fun lk -> match f lk true false with | Some v -> Some(lk,v) | None -> None) with
| [] -> None
| l -> Some l
)
let onlyRight (r : intmap<list<'a>>) =
r |> IntMap.mapOption (fun r ->
match r |> List.choose (fun rk -> match f rk false true with | Some v -> Some(rk,v) | None -> None) with
| [] -> None
| r -> Some r
)
let newStore =
IntMap.mergeWithKey both onlyLeft onlyRight store other.Store
hmap(cnt, newStore)
member x.ComputeDelta(other : hset<'a>) =
if store == other.Store then
HDeltaSet.empty
else
let mutable cnt = 0
let del (l : list<'a>) =
l |> List.map (fun v -> inc &cnt; v, -1)
let add (l : list<'a>) =
l |> List.map (fun v -> inc &cnt; v, 1)
let both (hash : int) (l : list<'a>) (r : list<'a>) =
HSetList.mergeWithOption (fun v l r ->
if l && not r then inc &cnt; Some -1
elif r && not l then inc &cnt; Some 1
else None
) l r
let store = IntMap.computeDelta both (IntMap.map del) (IntMap.map add) store other.Store
hdeltaset (hmap(cnt, store))
static member OfSeq (seq : seq<'a>) =
let mutable res = empty
for e in seq do
res <- res.Add e
res
static member OfList (list : list<'a>) =
hset.OfSeq list
static member OfArray (arr : array<'a>) =
hset.OfSeq arr
override x.GetHashCode() =
match store with
| Nil -> 0
| _ -> store |> Seq.fold (fun s (h,l) -> hash s + hash h) 0
override x.Equals(o) =
match o with
| :? hset<'a> as o ->
IntMap.equals HSetList.equals store o.Store
| _ ->
false
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
x.ToSeq() |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"hset [" + content + suffix + "]"
member private x.AsString = x.ToString()
interface IEnumerable with
member x.GetEnumerator() = new HSetEnumerator<_>(store) :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = new HSetEnumerator<_>(store) :> _
and private HSetEnumerator<'a>(store : intmap<list<'a>>) =
let mutable stack = [store]
let mutable inner = []
let mutable current = Unchecked.defaultof<'a>
let rec moveNext() =
match inner with
| [] ->
match stack with
| [] -> false
| h :: rest ->
stack <- rest
match h with
| Nil ->
moveNext()
| Tip(_,vs) ->
match vs with
| v :: rest ->
current <- v
inner <- rest
true
| [] ->
moveNext()
| Bin(_,_,l,r) ->
stack <- l :: r :: stack
moveNext()
| h :: rest ->
current <- h
inner <- rest
true
interface IEnumerator with
member x.MoveNext() = moveNext()
member x.Current = current :> obj
member x.Reset() =
stack <- [store]
inner <- []
current <- Unchecked.defaultof<_>
interface IEnumerator<'a> with
member x.Current = current
member x.Dispose() =
stack <- []
inner <- []
current <- Unchecked.defaultof<_>
module HSet =
/// <summary>The empty set.</summary>
[<GeneralizableValue>]
let empty<'a> = hset<'a>.Empty
let inline ofSeq (seq : seq<'a>) =
hset.OfSeq seq
let inline ofList (list : list<'a>) =
hset.OfList list
let inline ofArray (arr : 'a[]) =
hset.OfArray arr
let inline toSeq (set : hset<'a>) =
set.ToSeq()
let inline toList (set : hset<'a>) =
set.ToList()
let inline toArray (set : hset<'a>) =
set.ToArray()
let inline add (value : 'a) (set : hset<'a>) =
set.Add value
let inline remove (value : 'a) (set : hset<'a>) =
set.Remove value
let inline alter (value : 'a) (mapping : bool -> bool) (set : hset<'a>) =
set.Alter(value, mapping)
let inline union (l : hset<'a>) (r : hset<'a>) =
l.Union r
let inline unionMany (sets : seq<hset<'a>>) =
sets |> Seq.fold union empty
let inline difference (l : hset<'a>) (r : hset<'a>) =
l.Difference r
let inline intersect (l : hset<'a>) (r : hset<'a>) =
l.Intersect r
let inline map (mapping : 'a -> 'b) (set : hset<'a>) =
set.Map mapping
let inline choose (mapping : 'a -> option<'b>) (set : hset<'a>) =
set.Choose mapping
let inline mapHMap (mapping : 'a -> 'b) (set : hset<'a>) =
set.MapHMap mapping
let inline chooseHMap (mapping : 'a -> option<'b>) (set : hset<'a>) =
set.ChooseHMap mapping
let inline filter (predicate : 'a -> bool) (set : hset<'a>) =
set.Filter predicate
let inline collect (mapping : 'a -> hset<'b>) (set : hset<'a>) =
set.Collect mapping
let inline iter (mapping : 'a -> unit) (set : hset<'a>) =
set.Iter mapping
let inline exists (predicate : 'a -> bool) (set : hset<'a>) =
set.Exists predicate
let inline forall (predicate : 'a -> bool) (set : hset<'a>) =
set.Forall predicate
let inline fold (folder : 's -> 'a -> 's) (seed : 's) (set : hset<'a>) =
set.Fold(seed, folder)
let inline isEmpty (set : hset<'a>) =
set.IsEmpty
let inline count (set : hset<'a>) =
set.Count
let inline contains (value : 'a) (set : hset<'a>) =
set.Contains value
let inline computeDelta (l : hset<'a>) (r : hset<'a>) =
l.ComputeDelta r
(*
module Lens =
let contains (key : 'k) =
{ new Lens<_, _>() with
member x.Get s =
contains key s
member x.Set(s,r) =
match r with
| true -> add key s
| false -> remove key s
member x.Update(s,f) =
alter key f s
}
*)
[<AutoOpen>]
module ``HMap Extensions`` =
type hmap<'k, 'v> with
member x.Keys = hset<'k>(x.Count, x.Store |> IntMap.map (List.map fst))
member x.Values = x |> Seq.map snd
module HMap =
let inline keys (m : hmap<'k, 'v>) = m.Keys
let inline values (m : hmap<'k, 'v>) = m.Values
/// <summary>
/// Cache represents a cached function which can be
/// invoked and revoked. invoke increments the reference
/// count for a specific argument (possibly causing the
/// function to be executed) whereas revoke decreases the
/// reference count and removes the cache entry whenever
/// the reference count is 0.
/// </summary>
type Cache<'a, 'b>(f : 'a -> 'b) =
let cache = Dictionary<obj, 'b * ref<int>>(1)
let mutable nullCache = None
/// <summary>
/// Clear removes all entries from the Cache and
/// executes a function for all removed cache entries.
/// this function is helpful if the contained values
/// are (for example) disposable resources.
/// </summary>
member x.Clear(remove : 'b -> unit) =
for (KeyValue(_,(v,_))) in cache do
remove v
cache.Clear()
match nullCache with
| Some (v,_) ->
remove v
nullCache <- None
| None -> ()
/// <summary>
/// invoke returns the function value associated
/// with the given argument (possibly executing the function)
/// and increases the associated reference count.
/// </summary>
member x.Invoke (v : 'a) =
if isNull (v :> obj) then
match nullCache with
| Some (r, ref) ->
ref := !ref + 1
r
| None ->
let r = f v
nullCache <- Some(r, ref 1)
r
else
match cache.TryGetValue v with
| (true, (r, ref)) ->
ref := !ref + 1
r
| _ ->
let r = f v
cache.[v] <- (r, ref 1)
r
/// <summary>
/// revoke returns the function value associated
/// with the given argument and decreases its reference count.
/// </summary>
member x.RevokeAndGetDeleted (v : 'a) =
if isNull (v :> obj) then
match nullCache with
| Some (r, ref) ->
ref := !ref - 1
if !ref = 0 then
nullCache <- None
(true, r)
else
(false, r)
| None -> failwithf "cannot revoke null"
else
match cache.TryGetValue v with
| (true, (r, ref)) ->
ref := !ref - 1
if !ref = 0 then
cache.Remove v |> ignore
(true, r)
else
(false, r)
| _ -> failwithf "cannot revoke unknown value: %A" v
member x.RevokeAndGetDeletedTotal (v : 'a) =
if isNull (v :> obj) then
match nullCache with
| Some (r, ref) ->
ref := !ref - 1
if !ref = 0 then
nullCache <- None
Some (true, r)
else
Some(false, r)
| None ->
//Log.warn "cannot revoke null";
None
else
match cache.TryGetValue v with
| (true, (r, ref)) ->
ref := !ref - 1
if !ref = 0 then
cache.Remove v |> ignore
Some(true, r)
else
Some(false, r)
| _ ->
//Log.warn "cannot revoke unknown value: %A" v;
None
member x.Revoke (v : 'a) =
x.RevokeAndGetDeleted v |> snd
member x.Values = cache.Values |> Seq.map fst
//new(f : 'a -> 'b) = Cache(fun a -> f a)
[<StructuredFormatDisplay("{AsString}")>]
[<CompiledName("MutableSet")>]
type mset<'a>(initial : hset<'a>) =
let history = History HRefSet.traceNoRefCount
do initial |> Seq.map Add |> HDeltaSet.ofSeq |> history.Perform |> ignore
let mutable current = initial
member x.Update(values : hset<'a>) =
if not (Object.Equals(values, current)) then
let ops = HSet.computeDelta current values
current <- values
if not (HDeltaSet.isEmpty ops) then
history.Perform ops |> ignore
member private x.AsString = x.ToString()
override x.ToString() = current.ToString()
member x.Content = history :> IMod<_>
member x.Value
with get() = current
and set v = x.Update v
interface IEnumerable with
member x.GetEnumerator() = (current :> IEnumerable).GetEnumerator()
interface IEnumerable<'a> with
member x.GetEnumerator() = (current :> seq<_>).GetEnumerator()
interface aset<'a> with
member x.IsConstant = false
member x.GetReader() = history.NewReader()
member x.Content = history :> IMod<_>
module MSet =
let empty<'a> : mset<'a> = mset(HSet.empty)
let inline ofHSet (s : hset<'a>) = mset(s)
let inline ofSeq (s : seq<'a>) = mset(HSet.ofSeq s)
let inline ofList (s : list<'a>) = mset(HSet.ofList s)
let inline ofArray (s : 'a[]) = mset(HSet.ofArray s)
let inline toSeq (s : mset<'a>) = s :> seq<_>
let inline toList (s : mset<'a>) = s.Value |> HSet.toList
let inline toArray (s : mset<'a>) = s.Value |> HSet.toArray
let inline toHSet (s : mset<'a>) = s.Value
let inline value (m : mset<'a>) = m.Value
let inline toMod (m : mset<'a>) = m.Content
let inline change (m : mset<'a>) (value : hset<'a>) = m.Update value
[<RequireQualifiedAccess>]
module ASet =
[<AutoOpen>]
module Implementation =
type EmptyReader<'a> private() =
inherit ConstantObject()
static let instance = new EmptyReader<'a>() :> IOpReader<_,_>
static member Instance = instance
interface IOpReader<hdeltaset<'a>> with
member x.Dispose() =
()
member x.GetOperations caller =
HDeltaSet.empty
interface IOpReader<hrefset<'a>, hdeltaset<'a>> with
member x.State = HRefSet.empty
type EmptySet<'a> private() =
let content = Mod.constant HRefSet.empty
static let instance = EmptySet<'a>() :> aset<_>
static member Instance = instance
interface aset<'a> with
member x.IsConstant = true
member x.Content = content
member x.GetReader() = EmptyReader.Instance
type ConstantSet<'a>(content : Lazy<hrefset<'a>>) =
let deltas = lazy ( content.Value |> Seq.map Add |> HDeltaSet.ofSeq)
let mcontent = ConstantMod<hrefset<'a>>(content) :> IMod<_>
interface aset<'a> with
member x.IsConstant = true
member x.GetReader() = new History.Readers.ConstantReader<_,_>(HRefSet.trace, deltas, content) :> ISetReader<_>
member x.Content = mcontent
new(content : hrefset<'a>) = ConstantSet<'a>(System.Lazy<hrefset<_>>.CreateFromValue content)
type AdaptiveSet<'a>(newReader : unit -> IOpReader<hdeltaset<'a>>) =
let h = History.ofReader HRefSet.trace newReader
interface aset<'a> with
member x.IsConstant = false
member x.Content = h :> IMod<_>
member x.GetReader() = h.NewReader()
let inline unexpected() =
failwith "[ASet] deltas are expected to be unique"
let inline aset (f : unit-> #IOpReader<hdeltaset<'a>>) =
//let scope = Ag.getContext()
AdaptiveSet<'a>(fun () -> f () :> IOpReader<_>) :> aset<_>
let inline constant (l : Lazy<hrefset<'a>>) =
ConstantSet<'a>(l) :> aset<_>
[<AutoOpen>]
module Readers =
type MapReader<'a, 'b>(input : aset<'a>, f : 'a -> 'b) =
inherit AbstractReader<hdeltaset<'b>>(HDeltaSet.monoid)
let cache = Cache f
let r = input.GetReader()
override x.Release() =
r.Dispose()
cache.Clear ignore
override x.Compute(token) =
r.GetOperations token |> HDeltaSet.map (fun d ->
match d with
| Add(1, v) -> Add(cache.Invoke v)
| Rem(1, v) -> Rem(cache.Revoke v)
| _ -> unexpected()
)
type MapUseReader<'a, 'b when 'b :> IDisposable>(input : aset<'a>, f : 'a -> 'b) =
inherit AbstractReader<hdeltaset<'b>>(HDeltaSet.monoid)
let cache = Cache f
let r = input.GetReader()
override x.Release() =
r.Dispose()
override x.Compute(token) =
r.GetOperations token |> HDeltaSet.map (fun d ->
match d with
| Add(1, v) ->
Add(cache.Invoke v)
| Rem(1, v) ->
let del, value = cache.RevokeAndGetDeleted v
if del then value.Dispose()
Rem(value)
| _ ->
unexpected()
)
type ChooseReader<'a, 'b>(input : aset<'a>, f : 'a -> option<'b>) =
inherit AbstractReader<hdeltaset<'b>>(HDeltaSet.monoid)
let cache = Cache f
let r = input.GetReader()
override x.Release() =
r.Dispose()
cache.Clear ignore
override x.Compute(token) =
r.GetOperations token |> HDeltaSet.choose (fun d ->
match d with
| Add(1, v) ->
match cache.Invoke v with
| Some v -> Some (Add v)
| None -> None
| Rem(1, v) ->
match cache.Revoke v with
| Some v -> Some (Rem v)
| None -> None
| _ ->
unexpected()
)
type FilterReader<'a>(input : aset<'a>, f : 'a -> bool) =
inherit AbstractReader<hdeltaset<'a>>(HDeltaSet.monoid)
let cache = Cache f
let r = input.GetReader()
override x.Release() =
r.Dispose()
cache.Clear ignore
override x.Compute(token) =
r.GetOperations token |> HDeltaSet.choose (fun d ->
match d with
| Add(1, v) ->
if cache.Invoke v then Some (Add v)
else None
| Rem(1, v) ->
if cache.Revoke v then Some (Rem v)
else None
| _ ->
unexpected()
)
type UnionReader<'a>(input : aset<aset<'a>>) =
inherit AbstractDirtyReader<ISetReader<'a>, hdeltaset<'a>>(HDeltaSet.monoid)
let r = input.GetReader()
let cache = Cache(fun (a : aset<'a>) -> a.GetReader())
override x.Release() =
r.Dispose()
cache.Clear (fun r -> r.Dispose())
override x.Compute(token,dirty) =
let mutable deltas =
r.GetOperations token |> HDeltaSet.collect (fun d ->
match d with
| Add(1, v) ->
let r = cache.Invoke v
dirty.Remove r |> ignore
r.GetOperations token
| Rem(1, v) ->
let deleted, r = cache.RevokeAndGetDeleted v
dirty.Remove r |> ignore
if deleted then
let ops = HRefSet.computeDelta r.State HRefSet.empty
r.Dispose()
ops
else
r.GetOperations token
| _ -> unexpected()
)
for d in dirty do
deltas <- HDeltaSet.combine deltas (d.GetOperations token)
deltas
type UnionFixedReader<'a>(input : hrefset<aset<'a>>) =
inherit AbstractDirtyReader<ISetReader<'a>, hdeltaset<'a>>(HDeltaSet.monoid)
let mutable initial = true
let input = input |> HRefSet.map (fun s -> s.GetReader())
override x.Release() =
for i in input do
i.Dispose()
override x.Compute(token,dirty) =
if initial then
initial <- false
input |> HRefSet.fold (fun deltas r -> HDeltaSet.combine deltas (r.GetOperations token)) HDeltaSet.empty
else
dirty |> Seq.fold (fun deltas r -> HDeltaSet.combine deltas (r.GetOperations token)) HDeltaSet.empty
type DifferenceReader<'a>(l : aset<'a>, r : aset<'a>) =
inherit AbstractReader<hdeltaset<'a>>(HDeltaSet.monoid)
let l = l.GetReader()
let r = r.GetReader()
override x.Release() =
l.Dispose()
r.Dispose()
override x.Compute(token) =
let lops = l.GetOperations token
let rops = r.GetOperations token
let rops = HDeltaSet.map SetOperation.inverse rops
HDeltaSet.combine lops rops
type CollectReader<'a, 'b>(input : aset<'a>, f : 'a -> aset<'b>) =
inherit AbstractDirtyReader<ISetReader<'b>, hdeltaset<'b>>(HDeltaSet.monoid)
let r = input.GetReader()
let cache = Cache(fun a -> (f a).GetReader())
override x.Release() =
r.Dispose()
cache.Clear (fun r -> r.Dispose())
override x.Compute(token,dirty) =
let mutable deltas =
r.GetOperations token |> HDeltaSet.collect (fun d ->
match d with
| Add(1, v) ->
let r = cache.Invoke v
dirty.Remove r |> ignore
r.GetOperations token
| Rem(1, v) ->
match cache.RevokeAndGetDeletedTotal v with
| Some (deleted,r) ->
dirty.Remove r |> ignore
if deleted then
let ops = HRefSet.computeDelta r.State HRefSet.empty
r.Dispose()
ops
else
r.GetOperations token
| None ->
//Log.warn "serious hate occured"
HDeltaSet.empty
| _ -> unexpected()
)
for d in dirty do
deltas <- HDeltaSet.combine deltas (d.GetOperations token)
deltas
type CollectSetReader<'a, 'b>(input : aset<'a>, f : 'a -> hrefset<'b>) =
inherit AbstractReader<hdeltaset<'b>>(HDeltaSet.monoid)
let r = input.GetReader()
let cache = Cache f
override x.Release() =
r.Dispose()
cache.Clear ignore
override x.Compute(token) =
r.GetOperations token |> HDeltaSet.collect (fun d ->
match d with
| Add(1,v) ->
HRefSet.computeDelta HRefSet.empty (cache.Invoke v)
| Rem(1,v) ->
HRefSet.computeDelta (cache.Revoke v) HRefSet.empty
| _ ->
unexpected()
)
type ModSetReader<'a>(input : IMod<hrefset<'a>>) =
inherit AbstractReader<hdeltaset<'a>>(HDeltaSet.monoid)
let mutable old = HRefSet.empty
override x.Release() =
lock input (fun () -> input.Outputs.Remove x |> ignore)
override x.Compute(token) =
let n = input.GetValue token
let deltas = HRefSet.computeDelta old n
old <- n
deltas
type ModValueReader<'a>(input : IMod<'a>) =
inherit AbstractReader<hdeltaset<'a>>(HDeltaSet.monoid)
let mutable old = None
override x.Release() =
lock input (fun () -> input.Outputs.Remove x |> ignore)
old <- None
override x.Compute(token) =
let n = input.GetValue token
let delta =
match old with
| None -> HDeltaSet.ofList [Add n]
| Some o when Object.Equals(o, n) -> HDeltaSet.empty
| Some o -> HDeltaSet.ofList [Rem o; Add n]
old <- Some n
delta
type BindReader<'a, 'b>(input : IMod<'a>, f : 'a -> aset<'b>) =
inherit AbstractReader<hdeltaset<'b>>(HDeltaSet.monoid)
let mutable inputChanged = true
let mutable old : option<'a * ISetReader<'b>> = None
override x.InputChanged(t : obj, i : IAdaptiveObject) =
inputChanged <- inputChanged || Object.ReferenceEquals(i, input)
override x.Release() =
lock input (fun () -> input.Outputs.Remove x |> ignore)
match old with
| Some (_,r) ->
r.Dispose()
old <- None
| _ ->
()
override x.Compute(token) =
let v = input.GetValue token
match old with
| Some(_,ro) when inputChanged ->
inputChanged <- false
let rem = HRefSet.computeDelta ro.State HRefSet.empty
ro.Dispose()
let r = (f v).GetReader()
old <- Some(v, r)
let add = r.GetOperations token
HDeltaSet.combine rem add
| Some(vo, ro) ->
ro.GetOperations token
| None ->
let r = (f v).GetReader()
old <- Some(v, r)
r.GetOperations token
type CustomReader<'a>(compute : AdaptiveToken -> hrefset<'a> -> hdeltaset<'a>) =
inherit AbstractReader<hrefset<'a>, hdeltaset<'a>>(HRefSet.trace)
override x.Release() =
()
override x.Compute(token) =
compute token x.State
(*
type FlattenReader<'a>(input : aset<IMod<'a>>) =
inherit AbstractDirtyReader<IMod<'a>, hdeltaset<'a>>(HDeltaSet.monoid)
let r = input.GetReader()
let mutable initial = true
let cache = ConcurrentDictionary<IMod<'a>, 'a>()
member x.Invoke(token : AdaptiveToken, m : IMod<'a>) =
let v = m.GetValue token
cache.[m] <- v
v
member x.Invoke2(token : AdaptiveToken, m : IMod<'a>) =
let o = cache.[m]
let v = m.GetValue token
cache.[m] <- v
o, v
member x.Revoke(m : IMod<'a>, dirty : HashSet<_>) =
match cache.TryRemove m with
| (true, v) ->
lock m (fun () -> m.Outputs.Remove x |> ignore )
dirty.Remove m |> ignore
v
| _ ->
failwith "[ASet] cannot remove unknown object"
override x.Release() =
for m in r.State do
lock m (fun () -> m.Outputs.Remove x |> ignore)
r.Dispose()
override x.Compute(token, dirty) =
let mutable deltas =
r.GetOperations token |> HDeltaSet.map (fun d ->
match d with
| Add(1,m) -> Add(x.Invoke(token, m))
| Rem(1,m) -> Rem(x.Revoke(m, dirty))
| _ -> unexpected()
)
for d in dirty do
let o, n = x.Invoke2(token, d)
if not <| Object.Equals(o,n) then
deltas <- HDeltaSet.combine deltas (HDeltaSet.ofList [Add n; Rem o])
deltas
type MapMReader<'a, 'b>(input : aset<'a>, f : 'a -> IMod<'b>) =
inherit AbstractDirtyReader<IMod<'b>, hdeltaset<'b>>(HDeltaSet.monoid)
let r = input.GetReader()
let f = Cache f
let mutable initial = true
let cache = ConcurrentDictionary<IMod<'b>, ref<int * 'b>>()
member x.Invoke(token : AdaptiveToken, v : 'a) =
let m = f.Invoke v
let v = m.GetValue token
let r = cache.GetOrCreate(m, fun _ -> ref (0, v))
r := (fst !r + 1, v)
v
member x.Invoke2(token : AdaptiveToken, m : IMod<'b>) =
let r = cache.[m]
let v = m.GetValue token
let (rc, o) = !r
r := (rc, v)
o, v
member x.Revoke(v : 'a, dirty : HashSet<_>) =
let m = f.Revoke v
match cache.TryGetValue m with
| (true, r) ->
let (cnt, v) = !r
if cnt = 1 then
cache.Remove m |> ignore
dirty.Remove m |> ignore
lock m (fun () -> m.Outputs.Remove x |> ignore )
v
else
r := (cnt - 1, v)
v
| _ ->
failwith "[ASet] cannot remove unknown object"
override x.Release() =
f.Clear ignore
for (KeyValue(m,_)) in cache do
lock m (fun () -> m.Outputs.Remove x |> ignore)
cache.Clear()
r.Dispose()
override x.Compute(token, dirty) =
let mutable deltas =
r.GetOperations token |> HDeltaSet.map (fun d ->
match d with
| Add(1,m) -> Add(x.Invoke(token,m))
| Rem(1,m) -> Rem(x.Revoke(m, dirty))
| _ -> unexpected()
)
for d in dirty do
let o, n = x.Invoke2(token, d)
if not <| Object.Equals(o,n) then
deltas <- HDeltaSet.combine deltas (HDeltaSet.ofList [Add n; Rem o])
deltas
type ChooseMReader<'a, 'b>(input : aset<'a>, f : 'a -> IMod<option<'b>>) =
inherit AbstractDirtyReader<IMod<option<'b>>, hdeltaset<'b>>(HDeltaSet.monoid)
let r = input.GetReader()
let f = Cache f
let mutable initial = true
let cache = ConcurrentDictionary<IMod<option<'b>>, ref<int * option<'b>>>()
member x.Invoke(token : AdaptiveToken, v : 'a) =
let m = f.Invoke v
let v = m.GetValue token
let r = cache.GetOrCreate(m, fun _ -> ref (0, None))
r := (fst !r + 1, v)
v
member x.Invoke2(token : AdaptiveToken, m : IMod<option<'b>>) =
match cache.TryGetValue m with
| (true, r) ->
let (rc, o) = !r
let v = m.GetValue token
r := (rc, v)
o, v
| _ ->
None, None
member x.Revoke(v : 'a) =
let m = f.Revoke v
match cache.TryGetValue m with
| (true, r) ->
let (rc, v) = !r
if rc = 1 then
cache.Remove m |> ignore
lock m (fun () -> m.Outputs.Remove x |> ignore )
else
r := (rc - 1, v)
v
| _ ->
failwith "[ASet] cannot remove unknown object"
override x.Release() =
f.Clear ignore
for (KeyValue(m,_)) in cache do
lock m (fun () -> m.Outputs.Remove x |> ignore)
cache.Clear()
r.Dispose()
override x.Compute(token, dirty) =
let mutable deltas =
r.GetOperations token |> HDeltaSet.choose (fun d ->
match d with
| Add(1,m) ->
match x.Invoke(token,m) with
| Some v -> Some (Add v)
| None -> None
| Rem(1,m) ->
match x.Revoke m with
| Some v -> Some (Rem v)
| None -> None
| _ ->
unexpected()
)
for d in dirty do
let change =
match x.Invoke2(token, d) with
| None, None ->
HDeltaSet.empty
| None, Some v ->
HDeltaSet.single (Add v)
| Some o, None ->
HDeltaSet.single (Rem o)
| Some o, Some n ->
if Object.Equals(o, n) then
HDeltaSet.empty
else
HDeltaSet.ofList [Rem o; Add n]
deltas <- HDeltaSet.combine deltas change
deltas
*)
// =====================================================================================
// CREATORS (of*)
// =====================================================================================
/// the empty aset
let empty<'a> = EmptySet<'a>.Instance
/// creates a new aset containing only the given element
let single (v : 'a) =
ConstantSet(HRefSet.single v) :> aset<_>
/// creates a new aset using the given set content
let ofSet (set : hrefset<'a>) =
ConstantSet(set) :> aset<_>
/// create a new aset using all distinct entries from the sequence
let ofSeq (seq : seq<'a>) =
seq |> HRefSet.ofSeq |> ofSet
/// create a new aset using all distinct entries from the list
let ofList (list : list<'a>) =
list |> HRefSet.ofList |> ofSet
/// create a new aset using all distinct entries from the array
let ofArray (arr : 'a[]) =
arr |> HRefSet.ofArray |> ofSet
/// creates set which will always contain the elements given by the mod-cell
let ofMod (m : IMod<hrefset<'a>>) =
if m.IsConstant then
constant <| lazy ( Mod.force m )
else
aset <| fun scope -> new ModSetReader<'a>(m)
/// creates a singleton set which will always contain the latest value of the given mod-cell
let ofModSingle (m : IMod<'a>) =
if m.IsConstant then
constant <| lazy ( m |> Mod.force |> HRefSet.single )
else
aset <| fun scope -> new ModValueReader<'a>(m)
// =====================================================================================
// VIEWS (to*)
// =====================================================================================
/// creates a set from the current state of the aset
let toSet (set : aset<'a>) =
set.Content |> Mod.force
/// creates a seq from the current state of the aset
let toSeq (set : aset<'a>) =
set.Content |> Mod.force :> seq<_>
/// creates a list from the current state of the aset
let toList (set : aset<'a>) =
set.Content |> Mod.force |> HRefSet.toList
/// creates an array from the current state of the aset
let toArray (set : aset<'a>) =
set.Content |> Mod.force |> HRefSet.toArray
/// creates a mod-cell containing the set's content as set
let toMod (s : aset<'a>) =
s.Content
// =====================================================================================
// OPERATIONS
// =====================================================================================
let union (l : aset<'a>) (r : aset<'a>) =
if l.IsConstant && r.IsConstant then
constant <| lazy ( HRefSet.union (Mod.force l.Content) (Mod.force r.Content) )
else
aset <| fun scope -> new UnionFixedReader<'a>(HRefSet.ofList [l; r])
let difference (l : aset<'a>) (r : aset<'a>) =
if l.IsConstant && r.IsConstant then
constant <| lazy ( HRefSet.difference (Mod.force l.Content) (Mod.force r.Content) )
else
aset <| fun scope -> new DifferenceReader<'a>(l, r)
let unionMany' (sets : seq<aset<'a>>) =
let sets = HRefSet.ofSeq sets
if sets |> Seq.forall (fun s -> s.IsConstant) then
constant <| lazy ( sets |> HRefSet.collect (fun s -> s.Content |> Mod.force) )
else
aset <| fun scope -> new UnionFixedReader<'a>(sets)
let unionMany (sets : aset<aset<'a>>) =
if sets.IsConstant then
sets.Content |> Mod.force |> unionMany'
else
aset <| fun scope -> new UnionReader<'a>(sets)
// =====================================================================================
// PROJECTIONS
// =====================================================================================
/// creates a new aset whose elements are the result of applying the given function to each of the elements of the given set
let map (mapping : 'a -> 'b) (set : aset<'a>) =
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.map mapping )
else
aset <| fun scope -> new MapReader<'a, 'b>(set, mapping)
let mapUse<'a, 'b when 'b :> IDisposable> (mapping : 'a -> 'b) (set : aset<'a>) : aset<'b> =
aset <| fun scope -> new MapUseReader<'a, 'b>(set, mapping)
/// applies the given function to each element of the given aset. returns an aset comprised of the results x for each element
/// where the function returns Some(x)
let choose (chooser : 'a -> option<'b>) (set : aset<'a>) =
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.choose chooser )
else
aset <| fun scope -> new ChooseReader<'a, 'b>(set, chooser)
/// creates a new aset containing only the elements of the given one for which the given predicate returns true
let filter (predicate : 'a -> bool) (set : aset<'a>) =
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.filter predicate )
else
aset <| fun scope -> new FilterReader<'a>(set, predicate)
/// applies the given function to each element of the given aset. unions all the results and returns the combined aset
let collect (mapping : 'a -> aset<'b>) (set : aset<'a>) =
if set.IsConstant then
set.Content |> Mod.force |> HRefSet.map mapping |> unionMany'
else
aset <| fun scope -> new CollectReader<'a, 'b>(set, mapping)
/// applies the given function to each element of the given aset. unions all the results and returns the combined aset
let collect' (mapping : 'a -> #seq<'b>) (set : aset<'a>) =
let mapping = mapping >> HRefSet.ofSeq
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.collect mapping )
else
aset <| fun scope -> new CollectSetReader<'a, 'b>(set, mapping)
// =====================================================================================
// MOD INTEROP
// =====================================================================================
//let flattenM (set : aset<IMod<'a>>) =
// if set.IsConstant && set.Content |> Mod.force |> Seq.forall (fun m -> m.IsConstant) then
// constant <| lazy (set.Content |> Mod.force |> HRefSet.map Mod.force)
// else
// aset <| fun scope -> new FlattenReader<'a>(set)
//let mapM (mapping : 'a -> IMod<'b>) (set : aset<'a>) =
// if set.IsConstant then
// set.Content |> Mod.force |> HRefSet.map mapping |> ofSet |> flattenM
// else
// aset <| fun scope -> new MapMReader<'a, 'b>(set, mapping)
//let chooseM (mapping : 'a -> IMod<option<'b>>) (set : aset<'a>) =
// aset <| fun scope -> new ChooseMReader<'a, 'b>(set, mapping)
//let filterM (predicate : 'a -> IMod<bool>) (set : aset<'a>) =
// set |> chooseM (fun a ->
// a |> predicate |> Mod.map (fun v -> if v then Some a else None)
// )
let bind (mapping : 'a -> aset<'b>) (m : IMod<'a>) =
if m.IsConstant then
mapping (Mod.force m)
else
aset <| fun scope -> new BindReader<'a, 'b>(m, mapping)
let bind2 (mapping : 'a -> 'b -> aset<'c>) (a : IMod<'a>) (b : IMod<'b>) =
match a.IsConstant, b.IsConstant with
| true, true ->
mapping (Mod.force a) (Mod.force b)
| true, false ->
let mapping = mapping (Mod.force a)
b |> bind mapping
| false, true ->
let mapping =
let b = Mod.force b
fun a -> mapping a b
a |> bind mapping
| false, false ->
let tup = Mod.map2 (fun a b -> (a,b)) a b
tup |> bind (fun (a,b) -> mapping a b)
// =====================================================================================
// FOLDS
// =====================================================================================
let foldHalfGroup (add : 's -> 'a -> 's) (trySub : 's -> 'a -> option<'s>) (zero : 's) (s : aset<'a>) =
let r = s.GetReader()
let mutable res = zero
let rec traverse (d : list<SetOperation<'a>>) =
match d with
| [] -> true
| d :: rest ->
match d with
| Add(1,v) ->
res <- add res v
traverse rest
| Rem(1,v) ->
match trySub res v with
| Some s ->
res <- s
traverse rest
| None ->
false
| _ ->
failwithf "[ASet] unexpected delta: %A" d
Mod.custom (fun self ->
let ops = r.GetOperations self
let worked = traverse (HDeltaSet.toList ops)
if not worked then
res <- r.State |> HRefSet.fold add zero
res
)
let fold (f : 's -> 'a -> 's) (seed : 's) (s : aset<'a>) =
foldHalfGroup f (fun _ _ -> None) seed s
let foldGroup (add : 's -> 'a -> 's) (sub : 's -> 'a -> 's) (zero : 's) (s : aset<'a>) =
foldHalfGroup add (fun a b -> Some (sub a b)) zero s
let contains (value : 'a) (set : aset<'a>) =
let add (missing : hset<'a>) (v : 'a) =
HSet.remove v missing
let rem (missing : hset<'a>) (v : 'a) =
if Unchecked.equals v value then HSet.add v missing
else missing
set
|> foldGroup add rem (HSet.ofList [value])
|> Mod.map HSet.isEmpty
let containsAll (seq : seq<'a>) (set : aset<'a>) =
let all = HSet.ofSeq seq
let add (missing : hset<'a>) (value : 'a) =
HSet.remove value missing
let rem (missing : hset<'a>) (value : 'a) =
if HSet.contains value all then HSet.add value missing
else missing
foldGroup add rem all set |> Mod.map HSet.isEmpty
let containsAny (seq : seq<'a>) (set : aset<'a>) =
let all = HSet.ofSeq seq
let add (contained : hset<'a>) (value : 'a) =
if HSet.contains value all then HSet.add value contained
else contained
let rem (contained : hset<'a>) (value : 'a) =
HSet.remove value contained
foldGroup add rem HSet.empty set |> Mod.map (not << HSet.isEmpty)
let count (set : aset<'a>) =
set.Content |> Mod.map HRefSet.count
/// Adaptively calculates the sum of all elements in the set
let inline sum (s : aset<'a>) = foldGroup (+) (-) LanguagePrimitives.GenericZero s
/// Adaptively calculates the product of all elements in the set
let inline product (s : aset<'a>) = foldGroup (*) (/) LanguagePrimitives.GenericOne s
/// creates a new aset using the given reader-creator
let create (f : unit -> #IOpReader<hdeltaset<'a>>) =
aset f
let custom (f : AdaptiveToken -> hrefset<'a> -> hdeltaset<'a>) =
aset <| fun scope -> new CustomReader<'a>(f)
/// <summary>
/// registers a callback for execution whenever the
/// set's value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// Note that this function does not hold on to the created disposable, i.e.
/// if the disposable as well as the source dies, the callback dies as well.
/// If you use callbacks to propagate changed to other mods by using side-effects
/// (which you should not do), use registerCallbackKeepDisposable in order to
/// create a gc to the fresh disposable.
/// registerCallbackKeepDisposable only destroys the callback, iff the associated
/// disposable is disposed.
/// </summary>
let private callbackTable = ConditionalWeakTable<obj, ConcurrentDictionary<IDisposable, int>>()
let unsafeRegisterCallbackNoGcRoot (f : list<SetOperation<'a>> -> unit) (set : aset<'a>) =
let m = set.GetReader()
let result =
m.AddEvaluationCallback(fun self ->
m.GetOperations(self) |> HDeltaSet.toList |> f
)
let callbackSet = callbackTable.GetOrCreateValue(set)
callbackSet.TryAdd (result, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
result.Dispose()
callbackSet.TryRemove result |> ignore
}
[<Obsolete("use unsafeRegisterCallbackNoGcRoot or unsafeRegisterCallbackKeepDisposable instead")>]
let registerCallback f set = unsafeRegisterCallbackNoGcRoot f set
let private undyingCallbacks = ConcurrentDictionary<IDisposable, int>()
/// <summary>
/// registers a callback for execution whenever the
/// set's value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// In contrast to registerCallbackNoGcRoot, this function holds on to the
/// fresh disposable, i.e. even if the input set goes out of scope,
/// the disposable still forces the complete computation to exist.
/// When disposing the assosciated disposable, the gc root disappears and
/// the computation can be collected.
/// </summary>
let unsafeRegisterCallbackKeepDisposable (f : list<SetOperation<'a>> -> unit) (set : aset<'a>) =
let d = unsafeRegisterCallbackNoGcRoot f set
undyingCallbacks.TryAdd (d, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
d.Dispose()
undyingCallbacks.TryRemove d |> ignore
}
[<AbstractClass>]
type Index() =
abstract member CompareTo : obj -> int
abstract member After : unit -> Index
abstract member Before : unit -> Index
abstract member Between : Index -> Index
[<CompilerMessage("Next is considered harmful", 4321, IsError=false, IsHidden=true)>]
abstract member Next : Index
default x.GetHashCode() = System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode(x)
default x.Equals o = System.Object.ReferenceEquals(x,o)
interface IComparable with
member x.CompareTo(o : obj) = x.CompareTo o
interface IComparable<Index> with
member x.CompareTo(o : Index) = x.CompareTo o
module Index =
[<StructuredFormatDisplay("{AsString}")>]
type private Value =
class
val mutable public Root : Value
val mutable public Prev : Value
val mutable public Next : Value
val mutable public Tag : uint64
val mutable public RefCount : int
static member private Relabel(start : Value) =
let all = List<Value>()
let distance (l : Value) (r : Value) =
if l = r then UInt64.MaxValue
else r.Tag - l.Tag
// distance start start.Next == 1
let mutable current = start.Next
all.Add start.Next
Monitor.Enter start.Next
let mutable cnt = 1UL
while distance start current < 1UL + cnt * cnt do
current <- current.Next
cnt <- cnt + 1UL
all.Add current
Monitor.Enter current
let space = distance start current
// the last node does not get relabeled
current <- current.Prev
all.RemoveAt (all.Count - 1)
Monitor.Exit current.Next
cnt <- cnt - 1UL
let step = space / (1UL + cnt)
let mutable current = start.Tag + step
for n in all do
n.Tag <- current
current <- current + step
Monitor.Exit n
step
member x.Key = x.Tag - x.Root.Tag
member x.InsertAfter() =
lock x (fun () ->
let next = x.Next
let mutable distance =
if next = x then UInt64.MaxValue
else next.Tag - x.Tag
if distance = 1UL then
distance <- Value.Relabel x
let key = x.Tag + (distance / 2UL)
let res = Value(x.Root, Prev = x, Next = x.Next, Tag = key)
next.Prev <- res
x.Next <- res
res
)
member x.Delete() =
let prev = x.Prev
Monitor.Enter prev
if prev.Next <> x then
Monitor.Exit prev
x.Delete()
else
Monitor.Enter x
try
if x.RefCount = 1 then
prev.Next <- x.Next
x.Next.Prev <- prev
x.RefCount <- 0
else
x.RefCount <- x.RefCount - 1
finally
Monitor.Exit x
Monitor.Exit prev
member x.AddRef() =
lock x (fun () ->
x.RefCount <- x.RefCount + 1
)
member x.CompareTo(o : Value) =
match Monitor.TryEnter x, Monitor.TryEnter o with
| true, true ->
try
compare x.Key o.Key
finally
Monitor.Exit x
Monitor.Exit o
| true, false ->
Monitor.Exit x
x.CompareTo o
| false, true ->
Monitor.Exit o
x.CompareTo o
| false, false ->
x.CompareTo o
interface IComparable with
member x.CompareTo (o : obj) =
match o with
| :? Value as o -> x.CompareTo o
| _ -> failwithf "[Real] cannot compare real to %A" o
override x.GetHashCode() = System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode(x)
override x.Equals o = System.Object.ReferenceEquals(x,o)
override x.ToString() = sprintf "%f" (float x.Key / float UInt64.MaxValue)
member private x.AsString = x.ToString()
new(root : Value) = { Root = root; Prev = Unchecked.defaultof<_>; Next = Unchecked.defaultof<_>; Tag = 0UL; RefCount = 0 }
end
[<StructuredFormatDisplay("{AsString}")>]
type private GCReal(real : Value) =
inherit Index()
do real.AddRef()
static let queue = new System.Collections.Concurrent.BlockingCollection<Value>()
static let runner =
startThread (fun () ->
while true do
let e = queue.Take()
e.Delete()
)
member private x.Value = real
override x.After() =
lock real (fun () ->
if real.Next <> real.Root then GCReal real.Next :> Index
else GCReal (real.InsertAfter()) :> Index
)
override x.Before() =
let prev = real.Prev
Monitor.Enter prev
if prev.Next <> real then
Monitor.Exit prev
x.Before()
else
try
if prev = real.Root then
prev.InsertAfter() |> GCReal :> Index
else
prev |> GCReal :> Index
finally
Monitor.Exit prev
override l.Between(r : Index) =
let l = l.Value
let r = (unbox<GCReal> r).Value
Monitor.Enter l
try
if l.Next = r then l.InsertAfter() |> GCReal :> Index
else l.Next |> GCReal :> Index
finally
Monitor.Exit l
override x.Finalize() =
queue.Add real
override x.CompareTo (o : obj) =
match o with
| :? GCReal as o -> real.CompareTo(o.Value)
| _ -> failwithf "[Real] cannot compare real to %A" o
override x.GetHashCode() = real.GetHashCode()
override x.Equals o =
match o with
| :? GCReal as o -> real.Equals o.Value
| _ -> false
override x.ToString() = real.ToString()
member private x.AsString = x.ToString()
override x.Next =
lock real (fun () ->
GCReal real.Next :> Index
)
new() =
let r = Value(Unchecked.defaultof<_>)
r.Root <- r
r.Next <- r
r.Prev <- r
GCReal(r)
let zero = GCReal() :> Index
let after (r : Index) = r.After()
let before (r : Index) = r.Before()
let between (l : Index) (r : Index) = l.Between r
[<StructuredFormatDisplay("{AsString}")>]
[<Struct; StructuralEquality; NoComparison>]
type pdeltalist< [<EqualityConditionalOn>] 'a>(content : MapExt<Index, ElementOperation<'a>>) =
static let monoid : Monoid<pdeltalist<'a>> =
{
misEmpty = fun l -> l.IsEmpty
mempty = pdeltalist<'a>(MapExt.empty)
mappend = fun l r -> l.Combine r
}
static member Monoid = monoid
static member Empty = pdeltalist<'a>(MapExt.empty)
member private x.Content = content
member x.Count = content.Count
member x.IsEmpty = content.IsEmpty
member x.Add(i : Index, op : ElementOperation<'a>) =
pdeltalist(MapExt.add i op content)
member x.Remove(i : Index) =
pdeltalist(MapExt.remove i content)
member x.ToSeq() = content |> MapExt.toSeq
member x.ToList() = content |> MapExt.toList
member x.ToArray() = content |> MapExt.toArray
member x.Combine(r : pdeltalist<'a>) =
if x.IsEmpty then r
elif r.IsEmpty then x
else MapExt.unionWith (fun l r -> r) x.Content r.Content |> pdeltalist
member x.Map(f : Index -> ElementOperation<'a> -> ElementOperation<'b>) =
pdeltalist(MapExt.map f content)
member x.Choose(f : Index -> ElementOperation<'a> -> option<ElementOperation<'b>>) =
pdeltalist(MapExt.choose f content)
member x.MapMonotonic(f : Index -> ElementOperation<'a> -> Index * ElementOperation<'b>) =
pdeltalist(MapExt.mapMonotonic f content)
member x.Filter(f : Index -> ElementOperation<'a> -> bool) =
pdeltalist(MapExt.filter f content)
override x.ToString() =
let suffix =
if content.Count > 4 then "; ..."
else ""
let content =
content |> Seq.truncate 4 |> Seq.map (fun (KeyValue(i,op)) ->
match op with
| Set v -> sprintf "set(%A,%A)" i v
| Remove -> sprintf "rem(%A)" i
) |> String.concat "; "
"pdeltalist [" + content + suffix + "]"
member private x.AsString = x.ToString()
member x.Collect (f : Index -> ElementOperation<'a> -> pdeltalist<'b>) =
let mutable res = pdeltalist<'b>.Empty
for (KeyValue(i,v)) in content do
res <- res.Combine(f i v)
res
module PDeltaList =
let empty<'a> = pdeltalist<'a>.Empty
let inline isEmpty (l : pdeltalist<'a>) = l.IsEmpty
let inline add (i : Index) (v : ElementOperation<'a>) (l : pdeltalist<'a>) = l.Add(i, v)
let inline remove (i : Index) (l : pdeltalist<'a>) = l.Remove(i)
let ofMap (m : MapExt<Index, ElementOperation<'a>>) = pdeltalist(m)
let single (i : Index) (op : ElementOperation<'a>) = pdeltalist(MapExt.singleton i op)
let ofSeq (s : seq<Index * ElementOperation<'a>>) = pdeltalist(MapExt.ofSeq s)
let ofList (s : list<Index * ElementOperation<'a>>) = pdeltalist(MapExt.ofList s)
let ofArray (s : array<Index * ElementOperation<'a>>) = pdeltalist(MapExt.ofArray s)
let inline toSeq (l : pdeltalist<'a>) = l.ToSeq()
let inline toList (l : pdeltalist<'a>) = l.ToList()
let inline toArray (l : pdeltalist<'a>) = l.ToArray()
let inline mapMonotonic (mapping : Index -> ElementOperation<'a> -> Index * ElementOperation<'b>) (l : pdeltalist<'a>) =
l.MapMonotonic mapping
let inline map (mapping : Index -> ElementOperation<'a> -> ElementOperation<'b>) (l : pdeltalist<'a>) =
l.Map mapping
let inline choose (mapping : Index -> ElementOperation<'a> -> option<ElementOperation<'b>>) (l : pdeltalist<'a>) =
l.Choose mapping
let inline combine (l : pdeltalist<'a>) (r : pdeltalist<'a>) =
l.Combine(r)
let inline collect (mapping : Index -> ElementOperation<'a> -> pdeltalist<'b>) (l : pdeltalist<'a>) =
l.Collect mapping
let inline filter (predicate : Index -> ElementOperation<'a> -> bool) (l : pdeltalist<'a>) =
l.Filter predicate
type private MonoidInstance<'a>() =
static let instance : Monoid<pdeltalist<'a>> =
{
misEmpty = isEmpty
mempty = empty
mappend = combine
}
static member Instance = instance
let monoid<'a> = MonoidInstance<'a>.Instance
[<Struct; StructuralEquality; NoComparison>]
[<StructuredFormatDisplay("{AsString}")>]
type plist< [<EqualityConditionalOn>] 'a>(l : Index, h : Index, content : MapExt<Index, 'a>) =
static let empty = plist<'a>(Index.zero, Index.zero, MapExt.empty)
static let trace =
{
tops = PDeltaList.monoid
tempty = empty
tapply = fun a b -> a.Apply(b)
tcompute = fun l r -> plist.ComputeDeltas(l,r)
tcollapse = fun _ _ -> false
}
static member Empty = empty
static member Trace = trace
(*
static member private CreatePickler(r : IPicklerResolver) =
let pint = r.Resolve<int>()
let pv = r.Resolve<'a>()
let parr = r.Resolve<'a[]>()
let read (rs : ReadState) =
let cnt = pint.Read rs "count"
let elements = parr.Read rs "elements"
let mutable res = empty
for e in elements do res <- res.Append(e)
res
let write (ws : WriteState) (s : plist<'a>) =
pint.Write ws "count" s.Count
parr.Write ws "elements" (s.AsArray)
let clone (cs : CloneState) (s : plist<'a>) =
s.Map(fun _ v -> pv.Clone cs v)
let accept (vs : VisitState) (s : plist<'a>) =
s |> Seq.iter (pv.Accept vs)
Pickler.FromPrimitives(read, write, clone, accept)
*)
member x.MinIndex = l
member x.MaxIndex = h
member x.Count = content.Count
member x.Content = content
member x.Apply(deltas : pdeltalist<'a>) : plist<'a> * pdeltalist<'a> =
if deltas.Count = 0 then
x, deltas
else
let mutable res = x
let finalDeltas =
deltas |> PDeltaList.filter (fun i op ->
match op with
| Remove ->
res <- res.Remove i
true
| Set v ->
match res.TryGet i with
| Some o when Object.Equals(o,v) ->
false
| _ ->
res <- res.Set(i,v)
true
)
res, finalDeltas
static member ComputeDeltas(l : plist<'a>, r : plist<'a>) : pdeltalist<'a> =
match l.Count, r.Count with
| 0, 0 ->
PDeltaList.empty
| 0, _ ->
r.Content |> MapExt.map (fun i v -> Set v) |> PDeltaList.ofMap
| _, 0 ->
l.Content |> MapExt.map (fun i v -> Remove) |> PDeltaList.ofMap
| _, _ ->
if l.Content == r.Content then
PDeltaList.empty
else
// TODO: one small???
let merge (k : Index) (l : option<'a>) (r : option<'a>) =
match l, r with
| Some l, Some r when Unchecked.equals l r ->
None
| _, Some r ->
Some (Set r)
| Some l, None ->
Some Remove
| None, None ->
None
MapExt.choose2 merge l.Content r.Content |> PDeltaList.ofMap
member x.TryGet (i : Index) =
MapExt.tryFind i content
member x.TryGet (i : int) =
match MapExt.tryItem i content with
| Some (_,v) -> Some v
| None -> None
member x.Item
with get(i : Index) = MapExt.find i content
// O(log(n))
member x.Item
with get(i : int) = MapExt.item i content |> snd
member x.Append(v : 'a) =
if content.Count = 0 then
let t = Index.after Index.zero
plist(t, t, MapExt.ofList [t, v])
else
let t = Index.after h
plist(l, t, MapExt.add t v content)
member x.Prepend(v : 'a) =
if content.Count = 0 then
let t = Index.after Index.zero
plist(t, t, MapExt.ofList [t, v])
else
let t = Index.before l
plist(t, h, MapExt.add t v content)
member x.Set(key : Index, value : 'a) =
if content.Count = 0 then
plist(key, key, MapExt.ofList [key, value])
elif key < l then
plist(key, h, MapExt.add key value content)
elif key > h then
plist(l, key, MapExt.add key value content)
else
plist(l, h, MapExt.add key value content)
member x.Set(i : int, value : 'a) =
match MapExt.tryItem i content with
| Some (id,_) -> x.Set(id, value)
| None -> x
member x.Update(i : int, f : 'a -> 'a) =
match MapExt.tryItem i content with
| Some (id,v) ->
let newContent = MapExt.add id (f v) content
plist(l, h, newContent)
| None ->
x
member x.InsertAt(i : int, value : 'a) =
if i < 0 || i > content.Count then
x
else
let l, s, r = MapExt.neighboursAt i content
let r =
match s with
| Some s -> Some s
| None -> r
let index =
match l, r with
| Some (before,_), Some (after,_) -> Index.between before after
| None, Some (after,_) -> Index.before after
| Some (before,_), None -> Index.after before
| None, None -> Index.after Index.zero
x.Set(index, value)
member x.InsertBefore(i : Index, value : 'a) =
let str = Guid.NewGuid() |> string
let l, s, r = MapExt.neighbours i content
match s with
| None ->
x.Set(i, value)
| Some _ ->
let index =
match l with
| Some (before,_) -> Index.between before i
| None -> Index.before i
x.Set(index, value)
member x.InsertAfter(i : Index, value : 'a) =
let str = Guid.NewGuid() |> string
let l, s, r = MapExt.neighbours i content
match s with
| None ->
x.Set(i, value)
| Some _ ->
let index =
match r with
| Some (after,_) -> Index.between i after
| None -> Index.after i
x.Set(index, value)
member x.TryGetIndex(i : int) =
match MapExt.tryItem i content with
| Some (id,_) -> Some id
| None -> None
member x.Remove(key : Index) =
let c = MapExt.remove key content
if c.Count = 0 then empty
elif l = key then plist(MapExt.min c, h, c)
elif h = key then plist(l, MapExt.max c, c)
else plist(l, h, c)
member x.RemoveAt(i : int) =
match MapExt.tryItem i content with
| Some (id, _) -> x.Remove id
| _ -> x
member x.Map<'b>(mapping : Index -> 'a -> 'b) : plist<'b> =
plist(l, h, MapExt.map mapping content)
member x.Choose(mapping : Index -> 'a -> option<'b>) =
let res = MapExt.choose mapping content
if res.IsEmpty then
plist<'b>.Empty
else
plist(MapExt.min res, MapExt.max res, res)
member x.Filter(predicate : Index -> 'a -> bool) =
let res = MapExt.filter predicate content
if res.IsEmpty then
plist<'a>.Empty
else
plist(MapExt.min res, MapExt.max res, res)
// O(n)
member x.TryFind(item : 'a) : option<Index> =
match content |> MapExt.toSeq |> Seq.tryFind (fun (k,v) -> Unchecked.equals v item) with
| Some (k, v) -> Some k
| _ -> None
// O(n)
member x.Remove(item : 'a) : plist<'a> =
match x.TryFind(item) with
| Some index -> x.Remove(index)
| None -> x
member x.AsSeqBackward =
content |> MapExt.toSeqBack |> Seq.map snd
member x.AsListBackward =
x.AsSeqBackward |> Seq.toList
member x.AsArrayBackward =
x.AsSeqBackward |> Seq.toArray
member x.AsSeq =
content |> MapExt.toSeq |> Seq.map snd
member x.AsList =
content |> MapExt.toList |> List.map snd
member x.AsArray =
content |> MapExt.toArray |> Array.map snd
member x.AsMap =
content
override x.ToString() =
content |> MapExt.toSeq |> Seq.map (snd >> sprintf "%A") |> String.concat "; " |> sprintf "plist [%s]"
member private x.AsString = x.ToString()
member x.CopyTo(arr : 'a[], i : int) =
let mutable i = i
content |> MapExt.iter (fun k v -> arr.[i] <- v; i <- i + 1)
member x.IndexOf(item : 'a) =
x |> Seq.tryFindIndex (Unchecked.equals item) |> Option.defaultValue -1
member x.IndexOf(index : Index) =
MapExt.tryIndexOf index content |> Option.defaultValue -1
interface ICollection<'a> with
member x.Add(v) = raise (NotSupportedException("plist cannot be mutated"))
member x.Clear() = raise (NotSupportedException("plist cannot be mutated"))
member x.Remove(v) = raise (NotSupportedException("plist cannot be mutated"))
member x.Contains(v) = content |> MapExt.exists (fun _ vi -> Unchecked.equals vi v)
member x.CopyTo(arr,i) = x.CopyTo(arr, i)
member x.IsReadOnly = true
member x.Count = x.Count
interface IList<'a> with
member x.RemoveAt(i) = raise (NotSupportedException("plist cannot be mutated"))
member x.IndexOf(item : 'a) = x.IndexOf item
member x.Item
with get(i : int) = x.[i]
and set (i : int) (v : 'a) = raise (NotSupportedException("plist cannot be mutated"))
member x.Insert(i,v) = raise (NotSupportedException("plist cannot be mutated"))
interface IEnumerable with
member x.GetEnumerator() = new PListEnumerator<'a>((content :> seq<_>).GetEnumerator()) :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = new PListEnumerator<'a>((content :> seq<_>).GetEnumerator()) :> _
and private PListEnumerator<'a>(r : IEnumerator<KeyValuePair<Index, 'a>>) =
member x.Current =
r.Current.Value
interface IEnumerator with
member x.MoveNext() = r.MoveNext()
member x.Current = x.Current :> obj
member x.Reset() = r.Reset()
interface IEnumerator<'a> with
member x.Current = x.Current
member x.Dispose() = r.Dispose()
module PList =
let empty<'a> = plist<'a>.Empty
let inline isEmpty (list : plist<'a>) = list.Count = 0
let inline count (list : plist<'a>) = list.Count
let inline append (v : 'a) (list : plist<'a>) = list.Append v
let inline prepend (v : 'a) (list : plist<'a>) = list.Prepend v
let inline set (id : Index) (v : 'a) (list : plist<'a>) = list.Set(id, v)
let inline setAt (index : int) (v : 'a) (list : plist<'a>) = list.Set(index, v)
let inline remove (id : Index) (list : plist<'a>) = list.Remove(id)
let inline removeAt (index : int) (list : plist<'a>) = list.RemoveAt(index)
let inline insertAt (index : int) (value : 'a) (list : plist<'a>) = list.InsertAt(index, value)
let inline insertAfter (index : Index) (value : 'a) (list : plist<'a>) = list.InsertAfter(index, value)
let inline insertBefore (index : Index) (value : 'a) (list : plist<'a>) = list.InsertBefore(index, value)
let inline tryAt (index : int) (list : plist<'a>) = list.TryGet index
let inline tryGet (index : Index) (list : plist<'a>) = list.TryGet index
let inline tryFirstIndex (list : plist<'a>) = list.Content.TryMinKey
let inline tryLastIndex (list : plist<'a>) = list.Content.TryMaxKey
let inline firstIndex (list : plist<'a>) = tryFirstIndex list |> Option.get
let inline lastIndex (list : plist<'a>) = tryLastIndex list |> Option.get
let inline tryFirst (list : plist<'a>) = list.Content.TryMinValue
let inline tryLast (list : plist<'a>) = list.Content.TryMaxValue
let inline first (list : plist<'a>) = tryFirst list |> Option.get
let inline last (list : plist<'a>) = tryLast list |> Option.get
let tryFindIndex (element : 'a) (list : plist<'a>) = list.Content |> MapExt.tryPick (fun k v -> if v = element then Some k else None)
let tryFindIndexBack (element : 'a) (list : plist<'a>) = list.Content |> MapExt.tryPickBack (fun k v -> if v = element then Some k else None)
let findIndex (element : 'a) (list : plist<'a>) = tryFindIndex element list |> Option.get
let findIndexBack (element : 'a) (list : plist<'a>) = tryFindIndexBack element list |> Option.get
let exists (f : Index -> 'a -> bool) (list : plist<'a>) = list.Content |> Seq.exists (fun kv -> f kv.Key kv.Value)
let forall (f : Index -> 'a -> bool) (list : plist<'a>) = list.Content |> Seq.forall (fun kv -> f kv.Key kv.Value)
let tryFind (predicate : Index -> 'a -> bool) (list : plist<'a>) = list.Content |> MapExt.tryPick (fun k v -> if predicate k v then Some v else None)
let tryFindBack (predicate : Index -> 'a -> bool) (list : plist<'a>) = list.Content |> MapExt.tryPickBack (fun k v -> if predicate k v then Some v else None)
let find (predicate : Index -> 'a -> bool) (list : plist<'a>) = tryFind predicate list |> Option.get
let findBack (predicate : Index -> 'a -> bool) (list : plist<'a>) = tryFindBack predicate list |> Option.get
let tryPick (predicate : Index -> 'a -> option<'b>) (list : plist<'a>) = list.Content |> MapExt.tryPick predicate
let tryPickBack (predicate : Index -> 'a -> option<'b>) (list : plist<'a>) = list.Content |> MapExt.tryPickBack predicate
let concat2 (l : plist<'a>) (r : plist<'a>) =
if l.Count = 0 then r
elif r.Count = 0 then l
elif l.MaxIndex < r.MinIndex then
plist<'a>(l.MinIndex, r.MaxIndex, MapExt.union l.Content r.Content)
elif r.MaxIndex < l.MinIndex then
plist<'a>(r.MinIndex, l.MaxIndex, MapExt.union l.Content r.Content)
elif l.Count < r.Count then
let mutable res = r
for lv in l.AsSeqBackward do
res <- res.Prepend(lv)
res
else
let mutable res = l
for rv in r.AsSeq do
res <- res.Append(rv)
res
let concat (s : #seq<plist<'a>>) =
s |> Seq.fold concat2 empty
let ofMap (m : MapExt<Index, 'a>) =
if MapExt.isEmpty m then
empty
else
let min = m.TryMinKey
let max = m.TryMaxKey
plist<'a>(min.Value, max.Value, m)
let alter (index : Index) (mapping : option<'a> -> option<'a>) (l : plist<'a>) =
MapExt.alter index mapping l.Content |> ofMap
let alterAt (i : int) (mapping : option<'a> -> option<'a>) (list : plist<'a>) =
if i < -1 || i > list.Count then
list
else
let l, s, r = MapExt.neighboursAt i list.Content
match s with
| Some (si, sv) ->
match mapping (Some sv) with
| Some r ->
plist<'a>(list.MinIndex, list.MaxIndex, MapExt.add si r list.Content)
| None ->
let m = MapExt.remove si list.Content
let min = match l with | None -> MapExt.tryMin m |> Option.get | Some _ -> list.MinIndex
let max = match r with | None -> MapExt.tryMax m |> Option.get | Some _ -> list.MaxIndex
plist<'a>(min, max, m)
| None ->
match mapping None with
| Some res ->
let mutable minChanged = false
let mutable maxChanged = false
let idx =
match l, r with
| None, None ->
minChanged <- true
maxChanged <- true
Index.zero
| Some (l,_), None ->
maxChanged <- true
Index.after l
| None, Some (r,_) ->
minChanged <- true
Index.before r
| Some (l,_), Some (r,_) ->
Index.between l r
let min = if minChanged then idx else list.MinIndex
let max = if maxChanged then idx else list.MaxIndex
plist<'a>(min, max, MapExt.add idx res list.Content)
| None ->
list
let update (index : Index) (mapping : 'a -> 'a) (l : plist<'a>) =
alter index (Option.map mapping) l
let updateAt (index : int) (mapping : 'a -> 'a) (l : plist<'a>) =
alterAt index (Option.map mapping) l
let split (index : Index) (list : plist<'a>) =
let (l,s,r) = list.Content.Split(index)
match MapExt.isEmpty l, MapExt.isEmpty r with
| true, true -> empty, s, empty
| true, false ->
let rmin = r.TryMinKey |> Option.defaultValue Index.zero
empty, s, plist<'a>(rmin, list.MaxIndex, r)
| false, true ->
let lmax = l.TryMaxKey |> Option.defaultValue Index.zero
plist<'a>(list.MinIndex, lmax, l), s, empty
| false, false ->
let lmax = l.TryMaxKey |> Option.defaultValue Index.zero
let rmin = r.TryMinKey |> Option.defaultValue Index.zero
plist<'a>(list.MinIndex, lmax, l), s, plist<'a>(rmin, list.MaxIndex, r)
let splitAt (index : int) (list : plist<'a>) =
if index < 0 then
empty, None, list
elif index >= list.Count then
list, None, empty
else
let index,_ = list.Content.TryAt(index) |> Option.get
split index list
let take (n : int) (list : plist<'a>) =
if n <= 0 then empty
elif n > list.Count then list
else
let l,_,_ = splitAt n list
l
let skip (n : int) (list : plist<'a>) =
if n <= 0 then list
elif n > list.Count then empty
else
let _,_,r = splitAt (n - 1) list
r
let single (v : 'a) =
let t = Index.after Index.zero
plist(t, t, MapExt.ofList [t, v])
let inline toSeq (list : plist<'a>) = list :> seq<_>
let inline toList (list : plist<'a>) = list.AsList
let inline toArray (list : plist<'a>) = list.AsArray
let inline toSeqBack (list : plist<'a>) = list.AsSeqBackward :> seq<_>
let inline toListBack (list : plist<'a>) = list.AsListBackward
let inline toArrayBack (list : plist<'a>) = list.AsArrayBackward
let inline toMap (list : plist<'a>) = list.AsMap
let ofSeq (seq : seq<'a>) =
let mutable res = empty
for e in seq do res <- append e res
res
let collecti (mapping : Index -> 'a -> plist<'b>) (l : plist<'a>) = l.Map(mapping) |> concat
let collect (mapping : 'a -> plist<'b>) (l : plist<'a>) = l.Map(fun _ v -> mapping v) |> concat
let inline ofList (list : list<'a>) = ofSeq list
let inline ofArray (arr : 'a[]) = ofSeq arr
let inline mapi (mapping : Index -> 'a -> 'b) (list : plist<'a>) = list.Map mapping
let inline map (mapping : 'a -> 'b) (list : plist<'a>) = list.Map (fun _ v -> mapping v)
let inline choosei (mapping : Index -> 'a -> option<'b>) (list : plist<'a>) = list.Choose mapping
let inline choose (mapping : 'a -> option<'b>) (list : plist<'a>) = list.Choose (fun _ v -> mapping v)
let inline filteri (predicate : Index -> 'a -> bool) (list : plist<'a>) = list.Filter predicate
let inline filter (predicate : 'a -> bool) (list : plist<'a>) = list.Filter (fun _ v -> predicate v)
let sortBy (mapping : 'a -> 'b) (l : plist<'a>) =
let arr = l.AsArray
Array.sortInPlaceBy mapping arr
ofArray arr
let sortWith (compare : 'a -> 'a -> int) (l : plist<'a>) =
let arr = l.AsArray
Array.sortInPlaceWith compare arr
ofArray arr
let inline computeDelta (l : plist<'a>) (r : plist<'a>) = plist.ComputeDeltas(l, r)
let inline applyDelta (l : plist<'a>) (d : pdeltalist<'a>) = l.Apply(d)
let trace<'a> = plist<'a>.Trace
(*
module Lens =
let item (i : int) : Lens<plist<'a>, 'a> =
{ new Lens<_, _>() with
member x.Get s =
s.[i]
member x.Set(s,r) =
s.Set(i, r)
member x.Update(s,f) =
s.Update(i, f)
}
*)
type IListReader<'a> = IOpReader<plist<'a>, pdeltalist<'a>>
[<CompiledName("IAdaptiveList")>]
type alist<'a> =
abstract member IsConstant : bool
abstract member Content : IMod<plist<'a>>
abstract member GetReader : unit -> IListReader<'a>
[<StructuredFormatDisplay("{AsString}")>]
[<CompiledName("ChangeableList")>]
type clist<'a>(initial : seq<'a>) =
let history = History PList.trace
do
let mutable last = Index.zero
let ops =
initial |> Seq.map (fun v ->
let t = Index.after last
last <- t
t, Set v
)
|> PDeltaList.ofSeq
history.Perform ops |> ignore
member x.Count =
lock x (fun () -> history.State.Count)
member x.Clear() =
lock x (fun () ->
if x.Count > 0 then
let deltas = history.State.Content |> MapExt.map (fun k v -> Remove) |> PDeltaList.ofMap
history.Perform deltas |> ignore
)
member x.Append(v : 'a) =
lock x (fun () ->
let t = Index.after history.State.MaxIndex
history.Perform (PDeltaList.ofList [t, Set v]) |> ignore
t
)
member x.Prepend(v : 'a) =
lock x (fun () ->
let t = Index.before history.State.MinIndex
history.Perform (PDeltaList.ofList [t, Set v]) |> ignore
t
)
member x.Remove(i : Index) =
lock x (fun () ->
history.Perform (PDeltaList.ofList [i, Remove])
)
member x.RemoveAt(i : int) =
lock x (fun () ->
let (id,_) = history.State.Content |> MapExt.item i
x.Remove id |> ignore
)
member x.IndexOf(v : 'a) =
lock x (fun () ->
history.State
|> Seq.tryFindIndex (Unchecked.equals v)
|> Option.defaultValue -1
)
member x.Remove(v : 'a) =
lock x (fun () ->
match x.IndexOf v with
| -1 -> false
| i -> x.RemoveAt i; true
)
member x.Contains(v : 'a) =
lock x (fun () -> history.State) |> Seq.exists (Unchecked.equals v)
member x.Insert(i : int, value : 'a) =
lock x (fun () ->
if i < 0 || i > history.State.Content.Count then
raise <| IndexOutOfRangeException()
let l, s, r = MapExt.neighboursAt i history.State.Content
let r =
match s with
| Some s -> Some s
| None -> r
let index =
match l, r with
| Some (before,_), Some (after,_) -> Index.between before after
| None, Some (after,_) -> Index.before after
| Some (before,_), None -> Index.after before
| None, None -> Index.after Index.zero
history.Perform (PDeltaList.ofList [index, Set value]) |> ignore
)
member x.CopyTo(arr : 'a[], i : int) =
let state = lock x (fun () -> history.State )
state.CopyTo(arr, i)
member x.Item
with get (i : int) =
let state = lock x (fun () -> history.State)
state.[i]
and set (i : int) (v : 'a) =
lock x (fun () ->
let k = history.State.Content |> MapExt.tryItem i
match k with
| Some (id,_) -> history.Perform(PDeltaList.ofList [id, Set v]) |> ignore
| None -> ()
)
member x.Item
with get (i : Index) =
let state = lock x (fun () -> history.State)
state.[i]
and set (i : Index) (v : 'a) =
lock x (fun () ->
history.Perform(PDeltaList.ofList [i, Set v]) |> ignore
)
member x.AppendMany(elements : seq<'a>) =
lock x (fun () ->
let mutable deltas = PDeltaList.empty
let mutable l = history.State.MaxIndex
for e in elements do
let t = Index.after l
deltas <- PDeltaList.add t (Set e) deltas
l <- t
history.Perform deltas |> ignore
)
member x.PrependMany(elements : seq<'a>) =
lock x (fun () ->
let mutable deltas = PDeltaList.empty
let mutable l = Index.before history.State.MinIndex
for e in elements do
let t = Index.between l history.State.MinIndex
deltas <- PDeltaList.add t (Set e) deltas
l <- t
history.Perform deltas |> ignore
)
override x.ToString() =
let suffix =
if x.Count > 5 then "; ..."
else ""
let content =
history.State |> Seq.truncate 5 |> Seq.map (sprintf "%A") |> String.concat "; "
"clist [" + content + suffix + "]"
member private x.AsString = x.ToString()
new() = clist(Seq.empty)
interface alist<'a> with
member x.IsConstant = false
member x.Content = history :> IMod<_>
member x.GetReader() = history.NewReader()
interface ICollection<'a> with
member x.Add(v) = x.Append v |> ignore
member x.Clear() = x.Clear()
member x.Remove(v) = x.Remove v
member x.Contains(v) = x.Contains v
member x.CopyTo(arr,i) = x.CopyTo(arr, i)
member x.IsReadOnly = false
member x.Count = x.Count
interface IList<'a> with
member x.RemoveAt(i) = x.RemoveAt i
member x.IndexOf(item : 'a) = x.IndexOf item
member x.Item
with get(i : int) = x.[i]
and set (i : int) (v : 'a) = x.[i] <- v
member x.Insert(i,v) = x.Insert(i,v) |> ignore
interface IEnumerable with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator() :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator() :> _
[<RequireQualifiedAccess>]
module CList =
let empty<'a> = clist<'a>()
let clear (l : clist<'a>) = l.Clear()
let append (v : 'a) (l : clist<'a>) = l.Append v
let prepend (v : 'a) (l : clist<'a>) = l.Prepend v
let remove (i : Index) (l : clist<'a>) = l.Remove i
let removeAt (index : int) (l : clist<'a>) = l.RemoveAt index
let indexOf (v : 'a) (l : clist<'a>) = l.IndexOf v
let removeElement (v : 'a) (l : clist<'a>) = l.Remove v
let contains (v : 'a) (l : clist<'a>) = l.Contains v
let insert (index : int) (v : 'a) (l : clist<'a>) = l.Insert(index,v)
let getIndex (index : int) (l : clist<'a>) = l.Item index
let get (i : Index) (l : clist<'a>) = l.Item i
let setIndex (index : int) (v : 'a) (l : clist<'a>) = l.[index] <- v
let set (i : Index) (v : 'a) (l : clist<'a>) = l.[i] <- v
let ofSeq (l : seq<'a>) : clist<'a> = clist(l)
[<CompiledName("ChangeableOrderedSet")>]
type corderedset<'a when 'a : equality>(initial : seq<'a>) =
let setHistory = History HRefSet.traceNoRefCount
let history = History PList.trace
let indices = ConcurrentDictionary<'a, Index>()
let addRange(values : seq<'a>) =
let mutable last = history.State.MaxIndex
let values =
values
|> Seq.toList
|> List.choose (fun v ->
match indices.TryGetValue v with
| (true, i) -> None
| _ ->
let i = Index.after last
last <- i
indices.TryAdd(v, i) |> ignore
Some (i, v)
)
match values with
| [] ->
()
| l ->
history.Perform (values |> Seq.map (fun (i,v) -> i, Set v) |> PDeltaList.ofSeq) |> ignore
setHistory.Perform (values |> Seq.map (snd >> Add) |> HDeltaSet.ofSeq ) |> ignore
do addRange initial
member x.Count = setHistory.State.Count
member x.Add(value : 'a) =
lock x (fun () ->
match indices.TryGetValue value with
| (true, i) ->
false
| _ ->
let i = Index.after history.State.MaxIndex
indices.[value] <- i
history.Perform (PDeltaList.single i (Set value)) |> ignore
setHistory.Perform (HDeltaSet.single (Add value))
)
member x.AddRange(values : seq<'a>) =
lock x (fun () -> addRange values)
member x.Remove(value : 'a) =
lock x (fun () ->
match indices.TryRemove value with
| (true, i) ->
history.Perform (PDeltaList.single i Remove) |> ignore
setHistory.Perform (HDeltaSet.single (Rem value))
| _ ->
false
)
member x.InsertAfter(anchor : 'a, value : 'a) =
lock x (fun () ->
match indices.TryGetValue anchor with
| (true, ai) ->
match indices.TryGetValue value with
| (true, vi) ->
false
| _ ->
// TODO: more efficient ways of doing that
let _, _, r = history.State.Content |> MapExt.split ai
let index =
match MapExt.tryMin r with
| Some ri -> Index.between ai ri
| None -> Index.after ai
indices.[value] <- index
history.Perform (PDeltaList.single index (Set value)) |> ignore
setHistory.Perform (HDeltaSet.single (Add value))
| _ ->
raise <| KeyNotFoundException()
)
member x.InsertBefore(anchor : 'a, value : 'a) =
lock x (fun () ->
match indices.TryGetValue anchor with
| (true, ai) ->
match indices.TryGetValue value with
| (true, vi) ->
false
| _ ->
// TODO: more efficient ways of doing that
let l, _, _ = history.State.Content |> MapExt.split ai
let index =
match MapExt.tryMax l with
| Some li -> Index.between li ai
| None -> Index.before ai
indices.[value] <- index
history.Perform (PDeltaList.single index (Set value)) |> ignore
setHistory.Perform (HDeltaSet.single (Add value))
| _ ->
raise <| KeyNotFoundException()
)
member x.InsertAfter(anchor : 'a, values : seq<'a>) =
lock x (fun () ->
let values =
values
|> Seq.filter (fun v -> not (indices.ContainsKey v))
|> Seq.toList
match values with
| [] -> ()
| values ->
match indices.TryGetValue anchor with
| (true, ai) ->
// TODO: more efficient ways of doing that
let _, _, r = history.State.Content |> MapExt.split ai
let index =
let mutable last = ai
let ai = ()
match MapExt.tryMin r with
| Some ri ->
fun () ->
let res = Index.between last ri
last <- res
res
| None ->
fun () ->
let res = Index.after last
last <- res
res
let deltaList = values |> List.map (fun v -> let i = index() in indices.[v] <- i; i, Set v) |> PDeltaList.ofList
let deltaSet = values |> List.map Add |> HDeltaSet.ofList
history.Perform deltaList |> ignore
setHistory.Perform deltaSet |> ignore
| _ ->
raise <| KeyNotFoundException()
)
member x.InsertBefore(anchor : 'a, values : seq<'a>) =
lock x (fun () ->
let values =
values
|> Seq.filter (fun v -> not (indices.ContainsKey v))
|> Seq.toList
match values with
| [] -> ()
| values ->
match indices.TryGetValue anchor with
| (true, ai) ->
// TODO: more efficient ways of doing that
let l, _, _ = history.State.Content |> MapExt.split ai
let index =
match MapExt.tryMax l with
| Some li ->
let mutable last = li
fun () ->
let res = Index.between last ai
last <- res
res
| None ->
let mutable last = Index.zero
fun () ->
let res = Index.between last ai
last <- res
res
let deltaList = values |> List.map (fun v -> let i = index() in indices.[v] <- i; i, Set v) |> PDeltaList.ofList
let deltaSet = values |> List.map Add |> HDeltaSet.ofList
history.Perform deltaList |> ignore
setHistory.Perform deltaSet |> ignore
| _ ->
raise <| KeyNotFoundException()
)
member x.TryGetNext(value : 'a) =
lock x (fun () ->
match indices.TryGetValue(value) with
| (true, t) ->
if history.State.MaxIndex <> t then
let l, s, r = MapExt.neighbours t history.State.Content
match r with
| Some (ni,_) -> history.State.TryGet(ni)
| _ -> None
else
None
| _ -> None
)
member x.TryGetPrev(value : 'a) =
lock x (fun () ->
match indices.TryGetValue(value) with
| (true, t) ->
if history.State.MinIndex <> t then
let l, s, r = MapExt.neighbours t history.State.Content
match l with
| Some (pi,_) -> history.State.TryGet(pi)
| _ -> None
else
None
| _ -> None
)
member x.Clear() =
lock x (fun () ->
indices.Clear()
history.Perform (plist.ComputeDeltas(history.State, plist.Empty)) |> ignore
setHistory.Perform (HRefSet.computeDelta setHistory.State HRefSet.empty) |> ignore
)
member x.Contains(item : 'a) =
lock x (fun () ->
indices.ContainsKey(item)
)
new() = corderedset(Seq.empty)
interface aset<'a> with
member x.IsConstant = false
member x.GetReader() = setHistory.NewReader()
member x.Content = setHistory :> IMod<_>
interface alist<'a> with
member x.IsConstant = false
member x.GetReader() = history.NewReader()
member x.Content = history :> IMod<_>
interface IEnumerable with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator() :> _
interface IEnumerable<'a> with
member x.GetEnumerator() = (history.State :> seq<_>).GetEnumerator()
[<RequireQualifiedAccess>]
module COrderedSet =
let empty<'a> = corderedset<_>()
let ofSeq (l : seq<'a>) : corderedset<'a> = corderedset(l)
[<StructuredFormatDisplay("{AsString}")>]
[<CompiledName("MutableList")>]
type mlist<'a>(initial : plist<'a>) =
let history = History PList.trace
do
let delta = plist.ComputeDeltas(PList.empty, initial)
history.Perform delta |> ignore
let mutable current = initial
member x.Update(values : plist<'a>) =
if not (Object.Equals(values, current)) then
let delta = plist.ComputeDeltas(current, values)
current <- values
if not (PDeltaList.isEmpty delta) then
history.Perform delta |> ignore
member private x.AsString = x.ToString()
override x.ToString() = current.ToString()
member x.Content = history :> IMod<_>
member x.Value
with get() = current
and set v = x.Update v
interface IEnumerable with
member x.GetEnumerator() = (current :> IEnumerable).GetEnumerator()
interface IEnumerable<'a> with
member x.GetEnumerator() = (current :> seq<_>).GetEnumerator()
interface alist<'a> with
member x.IsConstant = false
member x.Content = history :> IMod<_>
member x.GetReader() = history.NewReader()
module MList =
let empty<'a> : mlist<'a> = mlist(PList.empty)
let inline ofPList (s : plist<'a>) = mlist(s)
let inline ofSeq (s : seq<'a>) = mlist(PList.ofSeq s)
let inline ofList (s : list<'a>) = mlist(PList.ofList s)
let inline ofArray (s : 'a[]) = mlist(PList.ofArray s)
let inline toSeq (s : mlist<'a>) = s :> seq<_>
let inline toList (s : mlist<'a>) = s.Value |> PList.toList
let inline toArray (s : mlist<'a>) = s.Value |> PList.toArray
let inline toPList (s : mlist<'a>) = s.Value
let inline value (m : mlist<'a>) = m.Value
let inline toMod (m : mlist<'a>) = m.Content
let inline change (m : mlist<'a>) (value : plist<'a>) = m.Update value
[<RequireQualifiedAccess>]
module AList =
module Comparer =
let ofFunction (cmp : 'a -> 'a -> int) =
let cmp = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(cmp)
{ new IComparer<'a> with
member x.Compare(l,r) = cmp.Invoke(l,r)
}
[<AutoOpen>]
module Implementation =
type EmptyReader<'a> private() =
inherit ConstantObject()
static let instance = new EmptyReader<'a>() :> IOpReader<_,_>
static member Instance = instance
interface IOpReader<pdeltalist<'a>> with
member x.Dispose() =
()
member x.GetOperations caller =
PDeltaList.empty
interface IOpReader<plist<'a>, pdeltalist<'a>> with
member x.State = PList.empty
type EmptyList<'a> private() =
let content = Mod.constant PList.empty
static let instance = EmptyList<'a>() :> alist<_>
static member Instance = instance
interface alist<'a> with
member x.IsConstant = true
member x.Content = content
member x.GetReader() = EmptyReader.Instance
type ConstantList<'a>(content : Lazy<plist<'a>>) =
let deltas = lazy ( plist.ComputeDeltas(PList.empty, content.Value) )
let mcontent = ConstantMod<plist<'a>>(content) :> IMod<_>
interface alist<'a> with
member x.IsConstant = true
member x.GetReader() = new History.Readers.ConstantReader<_,_>(PList.trace, deltas, content) :> IListReader<_>
member x.Content = mcontent
new(content : plist<'a>) = ConstantList<'a>(System.Lazy<plist<_>>.CreateFromValue content)
type AdaptiveList<'a>(newReader : unit -> IOpReader<pdeltalist<'a>>) =
let h = History.ofReader PList.trace newReader
interface alist<'a> with
member x.IsConstant = false
member x.Content = h :> IMod<_>
member x.GetReader() = h.NewReader()
let inline alist (f : unit -> #IOpReader<pdeltalist<'a>>) =
//let scope = Ag.getContext()
AdaptiveList<'a>(fun () -> f () :> IOpReader<_>) :> alist<_>
let inline constant (l : Lazy<plist<'a>>) =
ConstantList<'a>(l) :> alist<_>
[<AutoOpen>]
module Readers =
open System.Collections.Generic
[<AutoOpen>]
module Helpers =
(*
type IndexMapping<'k>(comparer : IComparer<'k>) =
let comparer =
{ new IComparer<'k * Index> with
member x.Compare((l,_),(r,_)) =
comparer.Compare(l,r)
}
let store = SortedSetExt<'k * Index>(comparer)
member x.Invoke(k : 'k) =
let (l,s,r) = store.FindNeighbours((k, Unchecked.defaultof<_>))
let s = if s.HasValue then Some s.Value else None
match s with
| Some(_,i) ->
i
| None ->
let l = if l.HasValue then Some l.Value else None
let r = if r.HasValue then Some r.Value else None
let l =
match s with
| Some s -> Some s
| None -> l
let result =
match l, r with
| None, None -> Index.after Index.zero
| Some(_,l), None -> Index.after l
| None, Some(_,r) -> Index.before r
| Some (_,l), Some(_,r) -> Index.between l r
store.Add((k, result)) |> ignore
result
member x.Revoke(k : 'k) =
let (l,s,r) = store.FindNeighbours((k, Unchecked.defaultof<_>))
if s.HasValue then
store.Remove s.Value |> ignore
let (_,s) = s.Value
Some s
else
None
//failwith "[AList] removing unknown index"
member x.Clear() =
store.Clear()
*)
type IndexCache<'a, 'b when 'a: equality>(f : Index -> 'a -> 'b, release : 'b -> unit) =
let store = ConcurrentDictionary<Index, 'a * 'b>()
//
// member x.Invoke(i : Index, a : 'a) =
// match store.TryGetValue(i) with
// | (true, (oa, res)) ->
// if Unchecked.equals oa a then
// res
// else
// release res
// let res = f i a
// store.[i] <- (a, res)
// res
// | _ ->
// let res = f i a
// store.[i] <- (a, res)
// res
member x.InvokeAndGetOld(i : Index, a : 'a) =
match store.TryGetValue(i) with
| (true, (oa, old)) ->
if Unchecked.equals oa a then
None, old
else
let res = f i a
store.[i] <- (a, res)
Some old, res
| _ ->
let res = f i a
store.[i] <- (a, res)
None, res
member x.Revoke(i : Index) =
match store.TryRemove i with
| (true, (oa,ob)) ->
release ob
Some ob
| _ ->
None //failwithf "[AList] cannot revoke unknown index %A" i
member x.Clear() =
store.Values |> Seq.iter (snd >> release)
store.Clear()
new(f : Index -> 'a -> 'b) = IndexCache(f, ignore)
type Unique<'b when 'b : comparison>(value : 'b) =
static let mutable currentId = 0
static let newId() = System.Threading.Interlocked.Increment(&currentId)
let id = newId()
member x.Value = value
member private x.Id = id
override x.ToString() = value.ToString()
override x.GetHashCode() = Unchecked.hash value + id
override x.Equals o =
match o with
| :? Unique<'b> as o -> Unchecked.equals value o.Value && id = o.Id
| _ -> false
interface IComparable with
member x.CompareTo o =
match o with
| :? Unique<'b> as o ->
let c = compare value o.Value
if c = 0 then compare id o.Id
else c
| _ ->
failwith "uncomparable"
type MapReader<'a, 'b>(input : alist<'a>, mapping : Index -> 'a -> 'b) =
inherit AbstractReader<pdeltalist<'b>>(PDeltaList.monoid)
let r = input.GetReader()
override x.Release() =
r.Dispose()
override x.Compute(token) =
r.GetOperations token |> PDeltaList.map (fun i op ->
match op with
| Remove -> Remove
| Set v -> Set (mapping i v)
)
type MapUseReader<'a, 'b when 'a : equality>(input : alist<'a>, mapping : 'a -> 'b, dispose : 'b -> unit) =
inherit AbstractReader<pdeltalist<'b>>(PDeltaList.monoid)
let cache = ConcurrentDictionary<'a,'b * ref<int>>()
let r = input.GetReader()
let invoke (deads : HashSet<_>) v =
let b, r = cache.[v] //GetOrCreate(v, fun v ->
//mapping v, ref 0
// )
incr r
deads.Remove v |> ignore
b
let revoke (deads : HashSet<_>) v =
match cache.TryGetValue v with
| (true,(b,r)) ->
decr r
if !r = 0 then deads.Add v |> ignore
| _ ->
//Log.warn "leak????"
()
override x.Release() =
cache.Values |> Seq.iter (dispose << fst)
cache.Clear()
r.Dispose()
override x.Compute(token) =
let oldState = r.State
let removed = HashSet<_>()
let inputOps = r.GetOperations token
let ops =
inputOps |> PDeltaList.choose (fun i op ->
match op with
| Remove ->
match PList.tryGet i oldState with
| Some v ->
revoke removed v
Some Remove
| None ->
None
| Set v ->
match PList.tryGet i oldState with
| None ->
()
| Some oldA ->
revoke removed oldA
invoke removed v |> Set |> Some
)
for a in removed do
match cache.TryRemove a with
| (true,(b,r)) ->
if !r <> 0 then failwith "[AList.mapUse] non zero refcount"
dispose b
| _ ->
//failwith "[AList.mapUse] tried to remove non existing"
()
ops
type ChooseReader<'a, 'b when 'a : equality>(input : alist<'a>, mapping : Index -> 'a -> option<'b>) =
inherit AbstractReader<pdeltalist<'b>>(PDeltaList.monoid)
let r = input.GetReader()
let mapping = IndexCache mapping
override x.Release() =
mapping.Clear()
r.Dispose()
override x.Compute(token) =
r.GetOperations token |> PDeltaList.choose (fun i op ->
match op with
| Remove ->
match mapping.Revoke(i) with
| Some _ -> Some Remove
| _ -> None
| Set v ->
let o, n = mapping.InvokeAndGetOld(i, v)
match n with
| Some res -> Some (Set res)
| None ->
match o with
| Some (Some o) -> Some Remove
| _ -> None
)
type FilterReader<'a when 'a : equality>(input : alist<'a>, mapping : Index -> 'a -> bool) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let r = input.GetReader()
let mapping = IndexCache mapping
override x.Release() =
mapping.Clear()
r.Dispose()
override x.Compute(token) =
r.GetOperations token |> PDeltaList.choose (fun i op ->
match op with
| Remove ->
match mapping.Revoke(i) with
| Some true -> Some Remove
| _ -> None
| Set v ->
let o, n = mapping.InvokeAndGetOld(i, v)
match n with
| true ->
Some (Set v)
| false ->
match o with
| Some true -> Some Remove
| _ -> None
)
(*
type MultiReader<'a>(mapping : IndexMapping<Index * Index>, list : alist<'a>, release : alist<'a> -> unit) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let targets = HashSet<Index>()
let mutable reader = None
let getReader() =
match reader with
| Some r -> r
| None ->
let r = list.GetReader()
reader <- Some r
r
member x.AddTarget(oi : Index) =
if targets.Add oi then
getReader().State.Content
|> MapExt.mapMonotonic (fun ii v -> mapping.Invoke(oi, ii), Set v)
|> PDeltaList.ofMap
else
PDeltaList.empty
member x.RemoveTarget(dirty : HashSet<MultiReader<'a>>, oi : Index) =
if targets.Remove oi then
match reader with
| Some r ->
let result =
r.State.Content
|> MapExt.toSeq
|> Seq.choose (fun (ii, v) ->
match mapping.Revoke(oi,ii) with
| Some v -> Some (v, Remove)
| None -> None
)
|> PDeltaList.ofSeq
if targets.Count = 0 then
dirty.Remove x |> ignore
x.Dispose()
result
| None ->
//failwith "[AList] invalid reader state"
PDeltaList.empty
else
PDeltaList.empty
override x.Release() =
match reader with
| Some r ->
release(list)
r.Dispose()
reader <- None
| None -> ()
override x.Compute(token) =
match reader with
| Some r ->
let ops = r.GetOperations token
ops |> PDeltaList.collect (fun ii op ->
match op with
| Remove ->
targets
|> Seq.choose (fun oi ->
match mapping.Revoke(oi, ii) with
| Some i -> Some(i, Remove)
| None -> None
)
|> PDeltaList.ofSeq
| Set v ->
targets
|> Seq.map (fun oi -> mapping.Invoke(oi, ii), Set v)
|> PDeltaList.ofSeq
)
| None ->
PDeltaList.empty
type CollectReader<'a, 'b>(input : alist<'a>, f : Index -> 'a -> alist<'b>) =
inherit AbstractDirtyReader<MultiReader<'b>, pdeltalist<'b>>(PDeltaList.monoid)
let mapping = IndexMapping<Index * Index>(LanguagePrimitives.FastGenericComparer)
let cache = Dictionary<Index, 'a * alist<'b>>()
let readers = Dictionary<alist<'b>, MultiReader<'b>>()
let input = input.GetReader()
let removeReader (l : alist<'b>) =
readers.Remove l |> ignore
let getReader (l : alist<'b>) =
match readers.TryGetValue l with
| (true, r) -> r
| _ ->
let r = new MultiReader<'b>(mapping, l, removeReader)
readers.Add(l, r)
r
member x.Invoke (dirty : HashSet<MultiReader<'b>>, i : Index, v : 'a) =
match cache.TryGetValue(i) with
| (true, (oldValue, oldList)) ->
if Unchecked.equals oldValue v then
dirty.Add (getReader(oldList)) |> ignore
PDeltaList.empty
else
let newList = f i v
cache.[i] <- (v, newList)
let newReader = getReader(newList)
let rem = getReader(oldList).RemoveTarget(dirty, i)
let add = newReader.AddTarget i
dirty.Add newReader |> ignore
PDeltaList.combine rem add
| _ ->
let newList = f i v
cache.[i] <- (v, newList)
let newReader = getReader(newList)
let add = newReader.AddTarget i
dirty.Add newReader |> ignore
add
member x.Revoke (dirty : HashSet<MultiReader<'b>>, i : Index) =
match cache.TryGetValue i with
| (true, (v,l)) ->
let r = getReader l
cache.Remove i |> ignore
r.RemoveTarget(dirty, i)
| _ ->
PDeltaList.empty
override x.Release() =
mapping.Clear()
cache.Clear()
readers.Values |> Seq.toArray |> Array.iter (fun r -> r.Dispose())
readers.Clear()
input.Dispose()
override x.Compute(token, dirty) =
let mutable result =
input.GetOperations token |> PDeltaList.collect (fun i op ->
match op with
| Remove -> x.Revoke(dirty, i)
| Set v -> x.Invoke(dirty, i, v)
)
for d in dirty do
result <- PDeltaList.combine result (d.GetOperations token)
result
type ConcatReader<'a>(input : alist<alist<'a>>) =
inherit AbstractDirtyReader<MultiReader<'a>, pdeltalist<'a>>(PDeltaList.monoid)
let cache = Dictionary<Index, alist<'a>>()
let mapping = IndexMapping<Index * Index>(LanguagePrimitives.FastGenericComparer)
let readers = Dictionary<alist<'a>, MultiReader<'a>>()
let input = input.GetReader()
let removeReader (l : alist<'a>) =
readers.Remove l |> ignore
let getReader (l : alist<'a>) =
match readers.TryGetValue l with
| (true, r) -> r
| _ ->
let r = new MultiReader<'a>(mapping, l, removeReader)
readers.Add(l, r)
r
member x.Invoke (dirty : HashSet<MultiReader<'a>>, i : Index, newList : alist<'a>) =
match cache.TryGetValue(i) with
| (true, oldList) ->
if oldList = newList then
dirty.Add (getReader(oldList)) |> ignore
PDeltaList.empty
else
cache.[i] <- newList
let newReader = getReader(newList)
let add = newReader.AddTarget i
let rem = getReader(oldList).RemoveTarget(dirty, i)
dirty.Add newReader |> ignore
PDeltaList.combine add rem
| _ ->
cache.[i] <- newList
let newReader = getReader(newList)
let add = newReader.AddTarget i
dirty.Add newReader |> ignore
add
member x.Revoke (dirty : HashSet<MultiReader<'a>>, i : Index) =
match cache.TryGetValue i with
| (true, l) ->
let r = getReader l
cache.Remove i |> ignore
r.RemoveTarget(dirty, i)
| _ ->
failwithf "[AList] cannot remove %A from outer list" i
override x.Release() =
mapping.Clear()
cache.Clear()
readers.Values |> Seq.iter (fun r -> r.Dispose())
readers.Clear()
input.Dispose()
override x.Compute(token, dirty) =
let mutable result =
input.GetOperations token |> PDeltaList.collect (fun i op ->
match op with
| Remove -> x.Revoke(dirty,i)
| Set v -> x.Invoke(dirty, i, v)
)
for d in dirty do
result <- PDeltaList.combine result (d.GetOperations token)
result
type ConcatListReader<'a>(inputs : plist<alist<'a>>) =
inherit AbstractDirtyReader<MultiReader<'a>, pdeltalist<'a>>(PDeltaList.monoid)
let mapping = IndexMapping<Index * Index>(LanguagePrimitives.FastGenericComparer)
let readers = Dictionary<alist<'a>, MultiReader<'a>>()
let removeReader (l : alist<'a>) =
readers.Remove l |> ignore
let getReader (l : alist<'a>) =
match readers.TryGetValue l with
| (true, r) -> r
| _ ->
let r = new MultiReader<'a>(mapping, l, removeReader)
readers.Add(l, r)
r
do inputs.Content |> MapExt.iter (fun oi l -> getReader(l).AddTarget oi |> ignore)
let mutable initial = true
override x.Release() =
mapping.Clear()
readers.Values |> Seq.toArray |> Array.iter (fun r -> r.Dispose())
readers.Clear()
readers.Clear()
override x.Compute(token, dirty) =
if initial then
initial <- false
readers.Values |> Seq.fold (fun d r -> PDeltaList.combine d (r.GetOperations token)) PDeltaList.empty
else
dirty |> Seq.fold (fun d r -> PDeltaList.combine d (r.GetOperations token)) PDeltaList.empty
type SetSortByReader<'a, 'b when 'b : comparison>(input : aset<'a>, mapping : 'a -> 'b) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let reader = input.GetReader()
let indices = IndexMapping<Unique<'b>>(LanguagePrimitives.FastGenericComparer<Unique<'b>>)
let mapping = Cache (mapping >> Unique)
override x.Release() =
indices.Clear()
mapping.Clear(ignore)
reader.Dispose()
override x.Compute(token) =
reader.GetOperations token
|> HDeltaSet.toSeq
|> Seq.choose (fun d ->
match d with
| Add(1,v) ->
let k = mapping.Invoke v
let i = indices.Invoke k
Some (i, Set v)
| Rem(1,v) ->
let k = mapping.Revoke v
let i = indices.Revoke k
match i with
| Some i -> Some (i, Remove)
| None -> None
| _ ->
failwith ""
)
|> PDeltaList.ofSeq
type SetSortWithReader<'a>(input : aset<'a>, comparer : IComparer<'a>) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let reader = input.GetReader()
let indices = IndexMapping<'a>(comparer)
override x.Release() =
indices.Clear()
reader.Dispose()
override x.Compute(token) =
reader.GetOperations token
|> HDeltaSet.toSeq
|> Seq.choose (fun d ->
match d with
| Add(1,v) ->
let i = indices.Invoke v
Some (i, Set v)
| Rem(1,v) ->
match indices.Revoke v with
| Some i -> Some(i, Remove)
| None -> None
| _ ->
failwith ""
)
|> PDeltaList.ofSeq
*)
type ToListReader<'a>(input : aset<'a>) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let reader = input.GetReader()
let mutable last = Index.zero
let newIndex (v : 'a) =
let i = Index.after last
last <- i
i
let newIndex = Cache newIndex
override x.Release() =
newIndex.Clear(ignore)
reader.Dispose()
last <- Index.zero
override x.Compute(token) =
reader.GetOperations token
|> HDeltaSet.toSeq
|> Seq.map (fun d ->
match d with
| Add(1,v) ->
let i = newIndex.Invoke v
i, Set v
| Rem(1,v) ->
let i = newIndex.Revoke v
i, Remove
| _ ->
failwith ""
)
|> PDeltaList.ofSeq
type ToSetReader<'a>(input : alist<'a>) =
inherit AbstractReader<hdeltaset<'a>>(HDeltaSet.monoid)
let reader = input.GetReader()
override x.Release() =
reader.Dispose()
override x.Compute(token) =
let oldContent = reader.State.Content
reader.GetOperations token
|> PDeltaList.toSeq
|> Seq.collect (fun (i,op) ->
match op with
| Set v ->
match MapExt.tryFind i oldContent with
| Some o ->
if Unchecked.equals o v then
Seq.empty
else
Seq.ofList [Add v; Rem o]
| _ ->
Seq.singleton (Add v)
| Remove ->
match MapExt.tryFind i oldContent with
| Some v -> Seq.singleton (Rem v)
// it is unknown if the reader has seen the corresponding Set/Add, therefore it's a valid case (in the current AList
// implementation with operations Set and Rem) that something is removed that is not present in the reader state
| _ -> Seq.empty
)
|> HDeltaSet.ofSeq
(*
type ListSortByReader<'a, 'b when 'b : comparison>(input : alist<'a>, mapping : Index -> 'a -> 'b) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let reader = input.GetReader()
let indices = IndexMapping<'b * Index>(LanguagePrimitives.FastGenericComparer<_>)
let mapping = IndexCache (fun i v -> mapping i v, i)
override x.Release() =
mapping.Clear()
reader.Dispose()
override x.Compute(token) =
let oldContent = reader.State.Content
reader.GetOperations token
|> PDeltaList.collect (fun ii op ->
match op with
| Set v ->
let oldB, b = mapping.InvokeAndGetOld(ii,v)
let i = indices.Invoke(b)
match oldB with
| Some oldB ->
match indices.Revoke oldB with
| Some oi ->
PDeltaList.ofList [oi, Remove; i, Set v]
| None ->
PDeltaList.ofList [i, Set v]
| None ->
PDeltaList.single i (Set v)
| Remove ->
match mapping.Revoke(ii) with
| Some b ->
match indices.Revoke b with
| Some i -> PDeltaList.single i Remove
| None -> PDeltaList.empty
| None ->
PDeltaList.empty
)
type ListSortWithReader<'a>(input : alist<'a>, comparer : IComparer<'a>) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let comparer =
{ new IComparer<'a * Index> with
member x.Compare((lv,li), (rv, ri)) =
let c = comparer.Compare(lv, rv)
if c = 0 then compare li ri
else c
}
let reader = input.GetReader()
let indices = IndexMapping<'a * Index>(comparer)
override x.Release() =
indices.Clear()
reader.Dispose()
override x.Compute(token) =
let oldContent = reader.State.Content
reader.GetOperations token
|> PDeltaList.collect (fun i op ->
match op with
| Set v ->
match MapExt.tryFind i oldContent with
| Some o ->
if Unchecked.equals o v then
PDeltaList.empty
else
let oi = indices.Revoke(o, i)
let i = indices.Invoke(v, i)
match oi with
| Some oi ->
PDeltaList.ofList [oi, Remove; i, Set v]
| None ->
PDeltaList.ofList [i, Set v]
| None ->
let i = indices.Invoke(v, i)
PDeltaList.single i (Set v)
| Remove ->
let v = oldContent |> MapExt.find i
let i = indices.Revoke(v, i)
match i with
| Some i -> PDeltaList.single i Remove
| None -> PDeltaList.empty
)
*)
type BindReader<'a, 'b>(input : IMod<'a>, f : 'a -> alist<'b>) =
inherit AbstractReader<pdeltalist<'b>>(PDeltaList.monoid)
let mutable inputChanged = 1
let mutable reader : option<'a * IListReader<'b>> = None
override x.InputChanged(t : obj, o : IAdaptiveObject) =
if Object.ReferenceEquals(input, o) then
inputChanged <- 1
override x.Release() =
match reader with
| Some(_,r) ->
r.Dispose()
reader <- None
| None ->
()
override x.Compute(token) =
let v = input.GetValue token
let inputChanged = System.Threading.Interlocked.Exchange(&inputChanged, 0)
match reader with
| Some (oldA, oldReader) when inputChanged = 0 || Unchecked.equals v oldA ->
oldReader.GetOperations token
| _ ->
let r = f(v).GetReader()
let deltas =
let addNew = r.GetOperations token
match reader with
| Some(_,old) ->
let remOld = plist.ComputeDeltas(old.State, PList.empty)
old.Dispose()
PDeltaList.combine remOld addNew
| None ->
addNew
reader <- Some (v,r)
deltas
type IndexedMod<'a>(index : Index, m : IMod<'a>) =
inherit Mod.AbstractMod<Index * 'a>()
let mutable index = index
let mutable lastValue = None
member x.Index = index
member x.LastValue = lastValue
member x.Dispose() =
x.Outputs.Clear()
override x.Compute(token) =
let v = m.GetValue token
lastValue <- Some v
(index, v)
type ChooseMReader<'a, 'b when 'a : equality>(input : alist<'a>, f : Index -> 'a -> IMod<option<'b>>) =
inherit AbstractDirtyReader<IndexedMod<option<'b>>, pdeltalist<'b>>(PDeltaList.monoid)
let input = input.GetReader()
let cache = IndexCache((fun i v -> IndexedMod(i, f i v)), fun m -> m.Dispose())
member private x.invoke (dirty : HashSet<_>) (i : Index) (v : 'a) =
let o, n = cache.InvokeAndGetOld(i, v)
dirty.Add n |> ignore
match o with
| Some o ->
dirty.Remove o |> ignore
o.Outputs.Remove x |> ignore
match o.LastValue with
| Some l -> PDeltaList.single i Remove
| None -> PDeltaList.empty
| None ->
PDeltaList.empty
member private x.revoke (dirty : HashSet<_>) (i : Index) =
let o = cache.Revoke(i)
match o with
| Some o ->
dirty.Remove o |> ignore
o.Outputs.Remove x |> ignore
match o.LastValue with
| Some l -> PDeltaList.single o.Index Remove
| None -> PDeltaList.empty
| None ->
PDeltaList.empty
override x.Release() =
input.Dispose()
cache.Clear()
override x.Compute(token, dirty) =
let deltas = input.GetOperations token
let mutable res = PDeltaList.empty
for (i,d) in deltas |> PDeltaList.toSeq do
match d with
| Set v -> res <- PDeltaList.combine res (x.invoke dirty i v)
| Remove -> res <- PDeltaList.combine res (x.revoke dirty i)
for d in dirty do
let i, v = d.GetValue token
match v with
| Some v ->
res <- PDeltaList.combine res (PDeltaList.single i (Set v))
| None ->
()
res
type OfModSingleReader<'a>(input : IMod<'a>) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let index = Index.after Index.zero
let mutable old = None
override x.Release() =
input.Outputs.Remove x |> ignore
old <- None
override x.Compute(token) =
let v = input.GetValue token
match old with
| Some o when Unchecked.equals o v ->
PDeltaList.empty
| _ ->
old <- Some v
PDeltaList.single index (Set v)
type OfModReader<'a>(input : IMod<plist<'a>>) =
inherit AbstractReader<pdeltalist<'a>>(PDeltaList.monoid)
let mutable state = PList.empty
override x.Release() =
input.Outputs.Remove x |> ignore
override x.Compute(token) =
let v = input.GetValue token
let delta = plist.ComputeDeltas(state, v)
state <- v
delta
interface IOpReader<plist<'a>, pdeltalist<'a>> with
member x.State = state
/// the empty alist
let empty<'a> = EmptyList<'a>.Instance
/// creates a new alist containing only the given element
let single (v : 'a) =
ConstantList(PList.single v) :> alist<_>
/// creates a new alist using the given list
let ofPList (l : plist<'a>) =
ConstantList(l) :> alist<_>
/// creates a new alist using the given sequence
let ofSeq (s : seq<'a>) =
s |> PList.ofSeq |> ofPList
/// creates a new alist using the given sequence
let ofList (l : list<'a>) =
l |> PList.ofList |> ofPList
/// creates a new alist using the given sequence
let ofArray (l : 'a[]) =
l |> PList.ofArray |> ofPList
let toPList (list : alist<'a>) =
list.Content |> Mod.force
let toSeq (list : alist<'a>) =
list.Content |> Mod.force :> seq<_>
let toList (list : alist<'a>) =
list.Content |> Mod.force |> PList.toList
let toArray (list : alist<'a>) =
list.Content |> Mod.force |> PList.toArray
(*
let concat' (lists : plist<alist<'a>>) =
// TODO: when all constant -> result constant
alist <| fun scope -> new ConcatListReader<'a>(lists)
let concat (lists : alist<alist<'a>>) =
if lists.IsConstant then
concat' (Mod.force lists.Content)
else
alist <| fun scope -> new ConcatReader<'a>(lists)
*)
let mapi (mapping : Index -> 'a -> 'b) (list : alist<'a>) =
if list.IsConstant then
constant <| lazy (list.Content |> Mod.force |> PList.mapi mapping)
else
alist <| fun scope -> new MapReader<'a, 'b>(list, mapping)
let map (mapping : 'a -> 'b) (list : alist<'a>) =
mapi (fun _ v -> mapping v) list
let choosei (mapping : Index -> 'a -> option<'b>) (list : alist<'a>) =
if list.IsConstant then
constant <| lazy (list.Content |> Mod.force |> PList.choosei mapping)
else
alist <| fun scope -> new ChooseReader<'a, 'b>(list, mapping)
let choose (mapping : 'a -> option<'b>) (list : alist<'a>) =
choosei (fun _ v -> mapping v) list
let filteri (predicate : Index -> 'a -> bool) (list : alist<'a>) =
if list.IsConstant then
constant <| lazy (list.Content |> Mod.force |> PList.filteri predicate)
else
alist <| fun scope -> new FilterReader<'a>(list, predicate)
let filter (predicate : 'a -> bool) (list : alist<'a>) =
filteri (fun _ v -> predicate v) list
(*
let collecti (mapping : Index -> 'a -> alist<'b>) (list : alist<'a>) =
if list.IsConstant then
concat' (list.Content |> Mod.force |> PList.mapi mapping)
else
alist <| fun scope -> new CollectReader<'a, 'b>(list, mapping)
*)
//let collect (mapping : 'a -> alist<'b>) (list : alist<'a>) =
// collecti (fun _ v -> mapping v) list
let toASet (l : alist<'a>) =
ASet.Implementation.aset <| fun scope -> new ToSetReader<'a>(l)
let ofASet (set : aset<'a>) =
alist <| fun scope -> new ToListReader<'a>(set)
//let sortBy (f : 'a -> 'b) (list : alist<'a>) =
// alist <| fun scope -> new ListSortByReader<'a, 'b>(list, fun _ v -> f v)
//let sortWith (cmp : 'a -> 'a -> int) (list : alist<'a>) =
// let cmp = Comparer.ofFunction cmp
// alist <| fun scope -> new ListSortWithReader<'a>(list, cmp)
//let sort<'a when 'a : comparison> (list : alist<'a>) =
// let cmp = LanguagePrimitives.FastGenericComparer<'a>
// alist <| fun scope -> new ListSortWithReader<'a>(list, cmp)
let toMod (l : alist<'a>) =
l.Content
//let append (l : alist<'a>) (r : alist<'a>) =
// // TODO: better impl
// [l;r] |> PList.ofList |> concat'
let bind (mapping : 'a -> alist<'b>) (m : IMod<'a>) : alist<'b> =
if m.IsConstant then
m |> Mod.force |> mapping
else
alist <| fun scope -> new BindReader<_,_>(m, mapping)
let bind2 (mapping : 'a -> 'b -> alist<'c>) (a : IMod<'a>) (b : IMod<'b>) : alist<'c> =
match a.IsConstant, b.IsConstant with
| true, true ->
mapping (Mod.force a) (Mod.force b)
| true, false ->
let mapping = mapping (Mod.force a)
b |> bind mapping
| false, true ->
let mapping =
let b = Mod.force b
fun a -> mapping a b
a |> bind mapping
| false, false ->
let tup = Mod.map2 (fun a b -> (a,b)) a b
tup |> bind (fun (a,b) -> mapping a b)
let chooseiM (mapping : Index -> 'a -> IMod<option<'b>>) (list : alist<'a>) : alist<'b> =
alist <| fun scope -> new ChooseMReader<'a, 'b>(list, mapping)
let chooseM (mapping : 'a -> IMod<option<'b>>) (list : alist<'a>) : alist<'b> =
chooseiM (fun _ v -> mapping v) list
let filteriM (f : Index -> 'a -> IMod<bool>) (list : alist<'a>) : alist<'a> =
list |> chooseiM (fun i v -> f i v |> Mod.map (fun c -> if c then Some v else None))
let filterM (f : 'a -> IMod<bool>) (list : alist<'a>) : alist<'a> =
filteriM (fun _ v -> f v) list
let count (l : alist<_>) = l |> toMod |> Mod.map PList.count
let ofModSingle (m : IMod<'a>) : alist<'a> =
if m.IsConstant then
constant <| lazy (m |> Mod.force |> PList.single)
else
alist <| fun scope -> new OfModSingleReader<'a>(m)
let ofMod (m : IMod<plist<'a>>) : alist<'a> =
if m.IsConstant then
constant <| lazy (m |> Mod.force)
else
alist <| fun scope -> new OfModReader<_>(m)
// maps a list to an output list whereby each output list item is gets disposed if it disappears from the list
// 'b needs to be equatable in order to cache moves of list items.
let mapDispose (mapping : 'a -> 'b) (dispose : 'b -> unit) (list : alist<'a>) =
alist <| fun scope -> new MapUseReader<'a, 'b>(list, mapping, dispose)
// maps a list to an output list whereby each output list item is gets disposed if it disappears from the list
// 'b needs to be equatable in order to cache moves of list items.
let mapUse<'a,'b when 'a: equality and 'b : equality and 'b :> IDisposable> (mapping : 'a -> 'b) (list : alist<'a>) =
mapDispose mapping (fun b -> b.Dispose()) list
/// <summary>
/// registers a callback for execution whenever the
/// set's value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// Note that this function does not hold on to the created disposable, i.e.
/// if the disposable as well as the source dies, the callback dies as well.
/// If you use callbacks to propagate changed to other mods by using side-effects
/// (which you should not do), use registerCallbackKeepDisposable in order to
/// create a gc to the fresh disposable.
/// registerCallbackKeepDisposable only destroys the callback, iff the associated
/// disposable is disposed.
/// </summary>
let private callbackTable = ConditionalWeakTable<obj, ConcurrentDictionary<IDisposable, int>>()
let unsafeRegisterCallbackNoGcRoot (f : list<Index * ElementOperation<'a>> -> unit) (list : alist<'a>) =
let m = list.GetReader()
let result =
m.AddEvaluationCallback(fun self ->
m.GetOperations(self) |> PDeltaList.toList |> f
)
let callbackSet = callbackTable.GetOrCreateValue(list)
callbackSet.TryAdd (result, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
result.Dispose()
callbackSet.TryRemove result |> ignore
}
[<Obsolete("use unsafeRegisterCallbackNoGcRoot or unsafeRegisterCallbackKeepDisposable instead")>]
let registerCallback f set = unsafeRegisterCallbackNoGcRoot f set
let private undyingCallbacks = ConcurrentDictionary<IDisposable, int>()
/// <summary>
/// registers a callback for execution whenever the
/// set's value might have changed and returns a disposable
/// subscription in order to unregister the callback.
/// Note that the callback will be executed immediately
/// once here.
/// In contrast to registerCallbackNoGcRoot, this function holds on to the
/// fresh disposable, i.e. even if the input set goes out of scope,
/// the disposable still forces the complete computation to exist.
/// When disposing the assosciated disposable, the gc root disappears and
/// the computation can be collected.
/// </summary>
let unsafeRegisterCallbackKeepDisposable (f : list<Index * ElementOperation<'a>> -> unit) (list : alist<'a>) =
let d = unsafeRegisterCallbackNoGcRoot f list
undyingCallbacks.TryAdd (d, 0) |> ignore
{ new IDisposable with
member x.Dispose() =
d.Dispose()
undyingCallbacks.TryRemove d |> ignore
}
[<AutoOpen>]
module ``ASet -> AList interop`` =
[<RequireQualifiedAccess>]
module ASet =
//let sortBy (f : 'a -> 'b) (set : aset<'a>) =
// alist <| fun scope -> new SetSortByReader<'a, 'b>(set, f)
//let sortWith (cmp : 'a -> 'a -> int) (set : aset<'a>) =
// let cmp = AList.Comparer.ofFunction cmp
// alist <| fun scope -> new SetSortWithReader<'a>(set, cmp)
//let sort<'a when 'a : comparison> (set : aset<'a>) =
// let cmp = LanguagePrimitives.FastGenericComparer<'a>
// alist <| fun scope -> new SetSortWithReader<'a>(set, cmp)
let toAList (set : aset<'a>) =
AList.ofASet set
let ofAList (l : alist<'a>) =
AList.toASet l
module HDeltaMap =
let combine (l : hdeltamap<'k, 'v>) (r : hdeltamap<'k, 'v>) : hdeltamap<'k, 'v> =
// O(1)
if l.Store == r.Store then
l
// O(1)
elif l.Count = 0 then r
// O(1)
elif r.Count = 0 then l
// O(N * log M)
elif l.Count * 5 < r.Count then
let mutable res = r
for (k,v) in l do
res <- HMap.alter k (function None -> Some v | Some r -> Some r) res
res
// O(M * log N)
elif r.Count * 5 < l.Count then
let mutable res = l
for (k,v) in r do
res <- HMap.add k v res
res
// O(M + N)
else
let merge (key : 'k) (l : ElementOperation<'v>) (r : ElementOperation<'v>) =
r
HMap.unionWith merge l r
let empty : hdeltamap<'k, 'v> = HMap.empty
let monoid<'k, 'v> : Monoid<hdeltamap<'k, 'v>> =
{
mempty = empty
misEmpty = HMap.isEmpty
mappend = combine
}
[<AutoOpen>]
module ``HMap delta`` =
module HMap =
let computeDelta (l : hmap<'k, 'v>) (r : hmap<'k, 'v>) : hdeltamap<'k, 'v> =
if l.Store == r.Store then
HMap.empty
elif l.Count = 0 && r.Count = 0 then
HMap.empty
elif l.Count = 0 then
r |> HMap.map (fun _ v -> Set v)
elif r.Count = 0 then
l |> HMap.map (fun _ _ -> Remove)
else
// TODO: one small???
let merge (key : 'k) (l : option<'v>) (r : option<'v>) =
match l, r with
| None, None -> None
| Some l, None -> Some Remove
| None, Some r -> Some (Set r)
| Some l, Some r ->
if Unchecked.equals l r then None
else Some (Set r)
HMap.choose2 merge l r
let applyDelta (m : hmap<'k, 'v>) (delta : hdeltamap<'k, 'v>) =
if delta.Count = 0 then
m, delta
elif m.Count = 0 then
delta.ChooseTup(fun _ op ->
match op with
| Set v -> Some (v, Set v)
| _ -> None
)
else
let mutable effective = HMap.empty
let mutable m = m
for (k,v) in delta do
m <- m.Alter(k, fun o ->
match o, v with
| Some o, Remove ->
effective <- HMap.add k Remove effective
None
| None, Remove ->
None
| None, Set n ->
effective <- HMap.add k (Set n) effective
Some n
| Some o, Set n ->
if not (Unchecked.equals o n) then
effective <- HMap.add k (Set n) effective
Some n
)
m, effective
let trace<'k, 'v> : Traceable<hmap<'k, 'v>, hdeltamap<'k, 'v>> =
{
tempty = HMap.empty
tops = HDeltaMap.monoid
tapply = applyDelta
tcompute = computeDelta
tcollapse = fun _ _ -> false
}
type IMapReader<'k, 'v> = IOpReader<hmap<'k, 'v>, hdeltamap<'k, 'v>>
[<CompiledName("IAdaptiveMap")>]
type amap<'k, 'v> =
abstract member IsConstant : bool
abstract member GetReader : unit -> IMapReader<'k, 'v>
abstract member Content : IMod<hmap<'k, 'v>>
[<StructuredFormatDisplay("{AsString}")>]
[<CompiledName("MutableMap")>]
type mmap<'k, 'v>(initial : hmap<'k, 'v>) =
let history = History HMap.trace
do
let delta = HMap.computeDelta HMap.empty initial
history.Perform delta |> ignore
let mutable current = initial
member x.Update(values : hmap<'k, 'v>) =
let delta = HMap.computeDelta current values
current <- values
if not (HMap.isEmpty delta) then
history.Perform delta |> ignore
member private x.AsString = x.ToString()
override x.ToString() = current.ToString()
member x.Content = history :> IMod<_>
member x.Value
with get() = current
and set v = x.Update v
interface IEnumerable with
member x.GetEnumerator() = (current :> IEnumerable).GetEnumerator()
interface IEnumerable<'k * 'v> with
member x.GetEnumerator() = (current :> seq<_>).GetEnumerator()
interface amap<'k, 'v> with
member x.IsConstant = false
member x.Content = history :> IMod<_>
member x.GetReader() = history.NewReader()
module MMap =
let empty<'k, 'v> : mmap<'k, 'v> = mmap(HMap.empty)
let inline ofHMap (s : hmap<'k, 'v>) = mmap(s)
let inline ofSeq (s : seq<'k * 'v>) = mmap(HMap.ofSeq s)
let inline ofList (s : list<'k * 'v>) = mmap(HMap.ofList s)
let inline ofArray (s : ('k * 'v)[]) = mmap(HMap.ofArray s)
let inline toSeq (s : mmap<'k, 'v>) = s :> seq<_>
let inline toList (s : mmap<'k, 'v>) = s.Value |> HMap.toList
let inline toArray (s : mmap<'k, 'v>) = s.Value |> HMap.toArray
let inline toHMap (s : mmap<'k, 'v>) = s.Value
let inline value (m : mmap<'k, 'v>) = m.Value
let inline toMod (m : mmap<'k, 'v>) = m.Content
let inline change (m : mmap<'k, 'v>) (value : hmap<'k, 'v>) = m.Update value
[<CompiledName("ChangeableMap")>]
type cmap<'k, 'v>(initial : seq<'k * 'v>) =
let history = History<hmap<'k, 'v>, hdeltamap<'k, 'v>>(HMap.trace)
do initial |> Seq.map (fun (k,v) -> k, Set v) |> HMap.ofSeq |> history.Perform |> ignore
member x.Count =
history.State.Count
member x.Item
with get (key : 'k) =
history.State.Find(key)
and set (key : 'k) (value : 'v) =
lock x (fun () ->
match HMap.tryFind key history.State with
| Some o when Unchecked.equals o value ->
()
| _ ->
history.Perform(HMap.single key (Set value)) |> ignore
)
member x.TryFind(k : 'k) =
history.State.TryFind k
member x.Remove(key : 'k) =
lock x (fun () ->
history.Perform(HMap.single key Remove)
)
member x.RemoveRange(key : seq<'k>) =
lock x (fun () ->
let ops = HMap.ofSeq (key |> Seq.map (fun k -> (k, Remove)))
history.Perform(ops)
)
member x.Add(key : 'k, value : 'v) =
lock x (fun () ->
if history.State.ContainsKey key then
raise <| System.ArgumentException("A value with the same key already exists.")
history.Perform(HMap.single key (Set value)) |> ignore
)
member x.AddRange(items : seq<('k * 'v)>) =
lock x (fun () ->
let ops = HMap.ofSeq (items |> Seq.map (fun (k,v) -> (k, (Set v))))
history.Perform(ops) |> ignore
)
member x.Clear() =
lock x (fun () ->
history.Perform(history.State |> HMap.map (fun k v -> Remove)) |> ignore
)
member x.TryGetValue(key : 'k, [<Out>] value : byref<'v>) =
match HMap.tryFind key history.State with
| Some v ->
value <- v
true
| None ->
false
member x.ContainsKey(key : 'k) =
history.State.ContainsKey key
new() = cmap(Seq.empty)
interface ICollection<KeyValuePair<'k, 'v>> with
member x.Contains(kvp : KeyValuePair<'k, 'v>) =
match x.TryGetValue kvp.Key with
| (true, v) -> Unchecked.equals v kvp.Value
| _ -> false
member x.Count = x.Count
member x.IsReadOnly = false
member x.Add(kvp : KeyValuePair<'k, 'v>) = x.Add(kvp.Key, kvp.Value)
member x.Remove(kvp : KeyValuePair<'k, 'v>) = x.Remove(kvp.Key)
member x.Clear() = x.Clear()
member x.CopyTo(arr : KeyValuePair<'k, 'v>[], index : int) =
let mutable index = index
for (k,v) in history.State do
arr.[index] <- KeyValuePair(k,v)
index <- index + 1
interface IDictionary<'k, 'v> with
member x.Keys = history.State |> Seq.map fst |> Seq.toArray :> _
member x.Values = history.State |> Seq.map snd |> Seq.toArray :> _
member x.Item
with get k = x.[k]
and set k v = x.[k] <- v
member x.ContainsKey k = x.ContainsKey k
member x.Add(k,v) = x.Add(k,v)
member x.Remove(k) = x.Remove(k)
member x.TryGetValue(k,v) = x.TryGetValue(k, &v)
interface IEnumerable with
member x.GetEnumerator() = (history.State |> Seq.map KeyValuePair).GetEnumerator() :> _
interface IEnumerable<KeyValuePair<'k, 'v>> with
member x.GetEnumerator() = (history.State |> Seq.map KeyValuePair).GetEnumerator()
interface amap<'k, 'v> with
member x.IsConstant = false
member x.GetReader() = history.NewReader()
member x.Content = history :> IMod<_>
[<RequireQualifiedAccess>]
module CMap =
let empty<'a,'b> = cmap<'a,'b>()
let find (k : 'k) (m : cmap<'k,'v>) = m.[k]
let tryFind (k : 'k) (m : cmap<'k,'v>) = m.TryFind(k)
let remove (k : 'k) (m : cmap<'k,'v>) = m.Remove k
let add (k : 'k) (v : 'v) (m : cmap<'k,'v>) = m.Add(k,v)
let clear (m : cmap<'k,'v>) = m.Clear()
let count (m : cmap<'k,'v>) = m.Count
[<AutoOpen>]
module AMapImplementation =
type EmptyReader<'a, 'b> private() =
inherit ConstantObject()
static let instance = new EmptyReader<'a, 'b>() :> IOpReader<_,_>
static member Instance = instance
interface IOpReader<hdeltamap<'a, 'b>> with
member x.Dispose() =
()
member x.GetOperations caller =
HDeltaMap.empty
interface IOpReader<hmap<'a, 'b>, hdeltamap<'a, 'b>> with
member x.State = HMap.empty
type EmptyMap<'a, 'b> private() =
let content = Mod.constant HMap.empty
static let instance = EmptyMap<'a, 'b>() :> amap<_,_>
static member Instance = instance
override x.ToString() = HMap.empty.ToString()
interface amap<'a, 'b> with
member x.IsConstant = true
member x.Content = content
member x.GetReader() = EmptyReader.Instance
type ConstantMap<'a, 'b>(content : Lazy<hmap<'a, 'b>>) =
let deltas = lazy ( HMap.computeDelta HMap.empty content.Value )
let mcontent = ConstantMod<hmap<'a, 'b>>(content) :> IMod<_>
interface amap<'a, 'b> with
member x.IsConstant = true
member x.GetReader() = new History.Readers.ConstantReader<_,_>(HMap.trace, deltas, content) :> IMapReader<_,_>
member x.Content = mcontent
override x.ToString() = content.Value.ToString()
new(content : hmap<'a, 'b>) = ConstantMap<'a, 'b>(System.Lazy<hmap<'a, 'b>>.CreateFromValue content)
[<RequireQualifiedAccess>]
module AMap =
type AdaptiveMap<'a, 'b>(newReader : unit -> IOpReader<hdeltamap<'a, 'b>>) =
let h = History.ofReader HMap.trace newReader
interface amap<'a, 'b> with
member x.IsConstant = false
member x.Content = h :> IMod<_>
member x.GetReader() = h.NewReader()
let inline amap (f : unit -> #IOpReader<hdeltamap<'a, 'b>>) =
AdaptiveMap<'a, 'b>(fun () -> f () :> IOpReader<_>) :> amap<_,_>
let inline constant (l : Lazy<hmap<'a, 'b>>) =
ConstantMap<'a, 'b>(l) :> amap<_,_>
module Readers =
type MapReader<'k, 'a, 'b>(input : amap<'k, 'a>, f : 'k -> 'a -> 'b) =
inherit AbstractReader<hdeltamap<'k, 'b>>(HDeltaMap.monoid)
let reader = input.GetReader()
override x.Release() =
reader.Dispose()
override x.Compute(token) =
let ops = reader.GetOperations token
ops |> HMap.map (fun k op ->
match op with
| Set v -> Set (f k v)
| Remove -> Remove
)
type ChooseReader<'k, 'a, 'b when 'k : equality>(input : amap<'k, 'a>, f : 'k -> 'a -> option<'b>) =
inherit AbstractReader<hdeltamap<'k, 'b>>(HDeltaMap.monoid)
let reader = input.GetReader()
let cache = ConcurrentDictionary<'k, bool>()
override x.Release() =
reader.Dispose()
override x.Compute(token) =
let ops = reader.GetOperations token
ops |> HMap.choose (fun k op ->
match op with
| Set v ->
match f k v with
| Some n ->
cache.[k] <- true
Some (Set n)
| None ->
let wasExisting =
match cache.TryGetValue k with
| (true, v) -> v
| _ -> false
cache.[k] <- false
if wasExisting then
Some Remove
else
None
| Remove ->
match cache.TryRemove k with
| (true, wasExisting) ->
if wasExisting then Some Remove
else None
| _ ->
None
//failwithf "[AMap] could not remove entry %A" k
)
type KeyedMod<'k, 'a>(key : 'k, m : IMod<'a>) =
inherit Mod.AbstractMod<'k * 'a>()
let mutable last = None
member x.Key = key
member x.UnsafeLast =
last
override x.Compute(token) =
let v = m.GetValue(token)
last <- Some v
key, v
type ChooseMReader<'k, 'a, 'b>(input : amap<'k, 'a>, f : 'k -> 'a -> IMod<option<'b>>) =
inherit AbstractDirtyReader<KeyedMod<'k, option<'b>>, hdeltamap<'k, 'b>>(HDeltaMap.monoid)
let reader = input.GetReader()
let cache = ConcurrentDictionary<'k, KeyedMod<'k, option<'b>>>()
override x.Release() =
reader.Dispose()
cache.Clear()
override x.Compute(token, dirty) =
let ops = reader.GetOperations token
let mutable ops =
ops |> HMap.choose (fun k op ->
match op with
| Set v ->
let mutable o = Unchecked.defaultof<_>
let hadOld = cache.TryGetValue(k, &o)
if hadOld then
o.Outputs.Remove x |> ignore
dirty.Remove o |> ignore
let n = KeyedMod(k, f k v)
cache.[k] <- n
let _,v = n.GetValue(token)
match v with
| Some v -> Some (Set v)
| None ->
if hadOld then Some Remove
else None
| Remove ->
match cache.TryRemove k with
| (true, o) ->
o.Outputs.Remove x |> ignore
dirty.Remove o |> ignore
match o.UnsafeLast with
| None | Some None ->
None
| Some _ ->
Some Remove
| _ ->
None
//failwith "[AMap] invalid state"
)
for m in dirty do
let last = m.UnsafeLast
let k, v = m.GetValue(token)
match last, v with
| None, None -> ()
| None, Some v -> ops <- HMap.add k (Set v) ops
| Some None, None -> ()
| Some (Some _), None -> ops <- HMap.add k Remove ops
| Some None, Some v -> ops <- HMap.add k (Set v) ops
| Some (Some _), Some v -> ops <- HMap.add k (Set v) ops
ops
type MapMReader<'k, 'x, 'a>(input : amap<'k, 'x>, f : 'k -> 'x -> IMod<'a>) =
inherit AbstractDirtyReader<IMod<'k * 'a>, hdeltamap<'k, 'a>>(HDeltaMap.monoid)
let reader = input.GetReader()
let cache = ConcurrentDictionary<'k, IMod<'k * 'a>>()
override x.Compute(token, dirty) =
let ops = reader.GetOperations token
let mutable ops =
ops |> HMap.choose (fun k op ->
match op with
| Set v ->
let mutable o = Unchecked.defaultof<_>
if cache.TryGetValue(k, &o) then
o.Outputs.Remove x |> ignore
dirty.Remove o |> ignore
let n = f k v |> Mod.map (fun v -> k, v)
cache.[k] <- n
let _,v = n.GetValue(token)
Some (Set v)
| Remove ->
let (worked, o) = cache.TryRemove k
if not worked then
None
else
o.Outputs.Clear()
dirty.Remove o |> ignore
Some Remove
)
for m in dirty do
let k, v = m.GetValue(token)
ops <- HMap.add k (Set v) ops
ops
override x.Release() =
reader.Dispose()
cache.Clear()
type UpdateReader<'k, 'a>(input : amap<'k, 'a>, keys : hset<'k>, f : 'k -> option<'a> -> 'a) =
inherit AbstractReader<hdeltamap<'k, 'a>>(HDeltaMap.monoid)
let reader = input.GetReader()
let mutable missing = keys
override x.Compute(token) =
let ops = reader.GetOperations(token)
let state = reader.State
let presentOps =
ops |> HMap.map (fun k op ->
match op with
| Set v ->
if HSet.contains k keys then
missing <- HSet.remove k missing
Set (f k (Some v))
else
Set v
| Remove ->
if HSet.contains k keys then
missing <- HSet.add k missing
Remove
)
let additionalOps =
missing
|> HSet.toSeq
|> Seq.map (fun k -> k, Set (f k None))
|> HMap.ofSeq
missing <- HSet.empty
HDeltaMap.combine presentOps additionalOps
override x.Release() =
missing <- keys
reader.Dispose()
type UnionWithReader<'k, 'a>(l : amap<'k, 'a>, r : amap<'k, 'a>, f : 'k -> 'a -> 'a -> 'a) =
inherit AbstractReader<hdeltamap<'k, 'a>>(HDeltaMap.monoid)
let l = l.GetReader()
let r = r.GetReader()
override x.Compute(token) =
let lops = l.GetOperations token
let rops = r.GetOperations token
let merge (key : 'k) (lop : option<ElementOperation<'a>>) (rop : option<ElementOperation<'a>>) : ElementOperation<'a> =
let lv =
match lop with
| Some (Set lv) -> Some lv
| Some (Remove) -> None
| None -> HMap.tryFind key l.State
let rv =
match rop with
| Some (Set rv) -> Some rv
| Some (Remove) -> None
| None -> HMap.tryFind key r.State
match lv, rv with
| None, None -> Remove
| Some l, None -> Set l
| None, Some r -> Set r
| Some l, Some r -> Set (f key l r)
HMap.map2 merge lops rops
override x.Release() =
l.Dispose()
r.Dispose()
type Choose2Reader<'k, 'a, 'b, 'c>(l : amap<'k, 'a>, r : amap<'k, 'b>, f : 'k -> option<'a> -> option<'b> -> option<'c>) =
inherit AbstractReader<hdeltamap<'k, 'c>>(HDeltaMap.monoid)
let l = l.GetReader()
let r = r.GetReader()
override x.Compute(token) =
let lops = l.GetOperations token
let rops = r.GetOperations token
let merge (key : 'k) (lop : option<ElementOperation<'a>>) (rop : option<ElementOperation<'b>>) : ElementOperation<'c> =
let lv =
match lop with
| Some (Set lv) -> Some lv
| Some (Remove) -> None
| None -> HMap.tryFind key l.State
let rv =
match rop with
| Some (Set rv) -> Some rv
| Some (Remove) -> None
| None -> HMap.tryFind key r.State
match lv, rv with
| None, None -> Remove
| _ ->
match f key lv rv with
| Some c -> Set c
| None -> Remove
HMap.map2 merge lops rops
override x.Release() =
l.Dispose()
r.Dispose()
type MapSetReader<'a, 'b>(set : aset<'a>, f : 'a -> 'b) =
inherit AbstractReader<hdeltamap<'a, 'b>>(HDeltaMap.monoid)
let r = set.GetReader()
override x.Compute(token) =
r.GetOperations token
|> HDeltaSet.toHMap
|> HMap.choose (fun key v ->
if v > 0 then Some (Set (f key))
elif v < 0 then Some Remove
else None
)
override x.Release() =
r.Dispose()
type OfASetReader<'a, 'b>(set : aset<'a * 'b>) =
inherit AbstractReader<hmap<'a, hset<'b>>, hdeltamap<'a, hset<'b>>>(HMap.trace)
let r = set.GetReader()
override x.Compute(token) =
let mutable state = x.State
let mutable deltas = HMap.empty
let ops = r.GetOperations token
for op in ops do
match op with
| Add (_,(a,b)) ->
state <-
state |> HMap.update a (fun ob ->
let newState =
match ob with
| None -> HSet.ofList [b]
| Some ob -> HSet.add b ob
deltas <- HMap.add a (Set newState) deltas
newState
)
| Rem(_,(a,b)) ->
state <-
state |> HMap.alter a (fun ob ->
match ob with
| None ->
//Log.warn "[AMap] strange"
None
| Some ob ->
let newSet = HSet.remove b ob
if HSet.isEmpty newSet then
deltas <- HMap.add a Remove deltas
else
deltas <- HMap.add a (Set newSet) deltas
Some newSet
)
deltas
override x.Release() =
r.Dispose()
type GroupByReader<'a, 'b, 'c>(set : aset<'a>, f : 'a -> 'b * 'c) =
inherit AbstractReader<hmap<'b, hset<'c>>, hdeltamap<'b, hset<'c>>>(HMap.trace)
let r = set.GetReader()
let f = Cache f
override x.Compute(token) =
let mutable state = x.State
let mutable deltas = HMap.empty
let ops = r.GetOperations token
for op in ops do
match op with
| Add(_,a) ->
let (b,c) = f.Invoke a
state <-
state |> HMap.update b (fun oc ->
let newState =
match oc with
| None -> HSet.ofList [c]
| Some oc -> HSet.add c oc
deltas <- HMap.add b (Set newState) deltas
newState
)
| Rem(_,a) ->
let (b,c) = f.Revoke a
state <-
state |> HMap.alter b (fun oc ->
match oc with
| None ->
//Log.warn "[AMap] strange"
None
| Some oc ->
let newSet = HSet.remove c oc
if HSet.isEmpty newSet then
deltas <- HMap.add b Remove deltas
else
deltas <- HMap.add b (Set newSet) deltas
Some newSet
)
deltas
override x.Release() =
r.Dispose()
f.Clear ignore
type OfModReader<'a, 'b>(input : IMod<hmap<'a, 'b>>) =
inherit AbstractReader<hmap<'a, 'b>, hdeltamap<'a, 'b>>(HMap.trace)
override x.Compute(token) =
input.GetValue token
|> HMap.computeDelta x.State
override x.Release() =
()
type BindReader<'a, 'k, 'v>(input : IMod<'a>, f : 'a -> amap<'k, 'v>) =
inherit AbstractReader<hdeltamap<'k, 'v>>(HDeltaMap.monoid)
let mutable oldValue : option<'a * IMapReader<'k, 'v>> = None
override x.Compute(token) =
let v = input.GetValue token
match oldValue with
| Some (ov, r) when Unchecked.equals ov v ->
r.GetOperations(token)
| _ ->
let rem =
match oldValue with
| Some (_, oldReader) ->
let res = HMap.computeDelta oldReader.State HMap.empty
oldReader.Dispose()
oldReader.Outputs.Remove x |> ignore
res
| _ ->
HMap.empty
let newMap = f v
let newReader = newMap.GetReader()
oldValue <- Some(v, newReader)
let add = newReader.GetOperations token
HDeltaMap.combine rem add
override x.Release() =
match oldValue with
| Some (_,r) ->
r.Dispose()
oldValue <- None
| None ->
()
let empty<'k, 'v> = EmptyMap<'k, 'v>.Instance
let ofHMap (map : hmap<'k, 'v>) = ConstantMap(map) :> amap<_,_>
let ofSeq (seq : seq<'k * 'v>) = ConstantMap(HMap.ofSeq seq) :> amap<_,_>
let ofList (list : list<'k * 'v>) = ConstantMap(HMap.ofList list) :> amap<_,_>
let ofArray (arr : array<'k * 'v>) = ConstantMap(HMap.ofArray arr) :> amap<_,_>
let map (mapping : 'k -> 'a -> 'b) (map : amap<'k, 'a>) =
if map.IsConstant then
constant <| lazy ( map.Content |> Mod.force |> HMap.map mapping )
else
amap <| fun scope -> new Readers.MapReader<'k, 'a, 'b>(map, mapping)
let choose (mapping : 'k -> 'a -> option<'b>) (map : amap<'k, 'a>) =
if map.IsConstant then
constant <| lazy ( map.Content |> Mod.force |> HMap.choose mapping )
else
amap <| fun scope -> new Readers.ChooseReader<'k, 'a, 'b>(map, mapping)
let filter (predicate : 'k -> 'a -> bool) (map : amap<'k, 'a>) =
choose (fun k v -> if predicate k v then Some v else None) map
let toMod (map : amap<'k, 'v>) = map.Content
let toASet (m : amap<'k, 'v>) : aset<'k * 'v> =
ASet.create (fun scope ->
let r = m.GetReader()
{ new AbstractReader<hdeltaset<'k * 'v>>(HDeltaSet.monoid) with
member x.Compute(token) =
let oldState = r.State
let ops = r.GetOperations token
let mutable deltas = HDeltaSet.empty
for (k,op) in ops do
match op with
| Set v ->
match HMap.tryFind k oldState with
| Some ov ->
deltas <- HDeltaSet.add (Rem(k,ov)) deltas
| None ->
()
deltas <- HDeltaSet.add (Add(k, v)) deltas
| Remove ->
// NOTE: As it is not clear at what point the toASet computation has been evaluated last, it is
// a valid case that something is removed that is not present in the current local state.
deltas <-
match HMap.tryFind k oldState with
| Some ov ->
HDeltaSet.add (Rem (k, ov)) deltas
| None ->
deltas
deltas
member x.Release() =
r.Dispose()
}
)
let bind (mapping : 'a -> amap<'k, 'v>) (m : IMod<'a>) =
if m.IsConstant then
mapping (Mod.force m)
else
amap <| fun scope -> new Readers.BindReader<'a, 'k, 'v>(m, mapping)
let mapM (mapping : 'k -> 'a -> IMod<'b>) (map : amap<'k, 'a>) =
amap <| fun scope -> new Readers.MapMReader<'k, 'a, 'b>(map, mapping)
let reduce (map : amap<'k, 'a>) =
map
let reduceM (map : amap<'k, IMod<'a>>) =
mapM (fun k v -> v) map
let chooseM (mapping : 'k -> 'a -> IMod<option<'b>>) (map : amap<'k, 'a>) =
amap <| fun scope -> new Readers.ChooseMReader<'k, 'a, 'b>(map, mapping)
let filterM (predicate : 'k -> 'a -> IMod<bool>) (map : amap<'k, 'a>) =
chooseM (fun k v -> predicate k v |> Mod.map (function true -> Some v | false -> None)) map
let flatten (map : amap<'k, option<'a>>) : amap<'k, 'a> =
choose (fun k v -> v) map
let flattenM (map : amap<'k, IMod<option<'a>>>) : amap<'k, 'a> =
chooseM (fun k v -> v) map
let mapSet (f : 'a -> 'b) (set : aset<'a>) : amap<'a, 'b> =
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.toHMap |> HMap.map (fun k _ -> f k) )
else
amap <| fun scope -> new Readers.MapSetReader<'a, 'b>(set, f)
let ofASet (set : aset<'a * 'b>) : amap<'a, hset<'b>> =
if set.IsConstant then
constant <| lazy ( set.Content |> Mod.force |> HRefSet.toList |> List.groupBy (fun (a,_) -> a :> obj) |> List.map (fun (k,kvs) -> unbox<'a> k, kvs |> List.map snd |> HSet.ofList ) |> HMap.ofList )
else
amap <| fun scope -> new Readers.OfASetReader<'a, 'b>(set)
let single (k : 'k) (v : 'v) = (k,v) |> ASet.single |> ofASet
let chooseSet (f : 'a -> option<'b>) (set : aset<'a>) : amap<'a, 'b> =
set |> mapSet f |> flatten
let mapSetM (f : 'a -> IMod<'b>) (set : aset<'a>) : amap<'a, 'b> =
set |> mapSet f |> reduceM
let chooseSetM (f : 'a -> IMod<option<'b>>) (set : aset<'a>) : amap<'a, 'b> =
set |> mapSet f |> flattenM
let ofMod (m : IMod<hmap<'a, 'b>>) : amap<'a, 'b> =
if m.IsConstant then
constant <| lazy (Mod.force m)
else
amap <| fun scope -> new Readers.OfModReader<'a, 'b>(m)
let updateMany (keys : hset<'k>) (f : 'k -> option<'v> -> 'v) (m : amap<'k, 'v>) =
amap <| fun scope -> new Readers.UpdateReader<'k, 'v>(m, keys, f)
let unionWith (f : 'k -> 'a -> 'a -> 'a) (l : amap<'k, 'a>) (r : amap<'k, 'a>) =
if l.IsConstant && r.IsConstant then
constant <| lazy ( HMap.unionWith f (Mod.force l.Content) (Mod.force r.Content) )
else
amap <| fun scope -> new Readers.UnionWithReader<'k, 'a>(l, r, f)
let union (l : amap<'k, 'a>) (r : amap<'k, 'a>) =
unionWith (fun _ _ a -> a) l r
let unionSet (maps : aset<amap<'k, 'v>>) =
maps |> ASet.collect toASet |> ofASet |> map (fun (k) (v) -> v |> Seq.collect (fun x -> x) |> HSet.ofSeq)
let choose2 (mapping : 'k -> option<'a> -> option<'b> -> option<'c>) (l : amap<'k, 'a>) (r : amap<'k, 'b>) =
if l.IsConstant && r.IsConstant then
constant <| lazy ( HMap.choose2 mapping (Mod.force l.Content) (Mod.force r.Content) )
else
amap <| fun scope -> new Readers.Choose2Reader<'k, 'a, 'b, 'c>(l, r, mapping)
let map2 (mapping : 'k -> option<'a> -> option<'b> -> 'c) (l : amap<'k, 'a>) (r : amap<'k, 'b>) =
choose2 (fun k l r -> Some (mapping k l r)) l r
let tryFind (key : 'k) (m : amap<'k, 'v>) =
let reader = m.GetReader()
let mutable last = None
Mod.custom (fun token ->
let ops = reader.GetOperations token
match HMap.tryFind key ops with
| Some Remove ->
last <- None
None
| Some (Set v) ->
last <- Some v
Some v
| None ->
last
)
let find (key : 'k) (m : amap<'k, 'v>) =
let reader = m.GetReader()
let mutable last = None
Mod.custom (fun token ->
let ops = reader.GetOperations token
match HMap.tryFind key ops with
| Some Remove ->
failwith "[AMap] key not found"
| Some (Set v) ->
last <- Some v
v
| None ->
match last with
| Some v -> v
| None -> failwith "[AMap] key not found"
)
let findWithDefault (key : 'k) (def : 'v) (m : amap<'k, 'v>) =
let reader = m.GetReader()
let mutable last = def
Mod.custom (fun token ->
let ops = reader.GetOperations token
match HMap.tryFind key ops with
| Some Remove ->
last <- def
def
| Some (Set v) ->
last <- v
v
| None ->
last
)
[<AutoOpen>]
module ``ASet -> AMap interop`` =
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module ASet =
let groupBy (f : 'a -> 'g) (s : aset<'a>) : amap<'g, hset<'a>> =
if s.IsConstant then
AMap.constant <| lazy ( s.Content |> Mod.force |> Seq.groupBy (fun v -> f v :> obj) |> Seq.map (fun (g,vs) -> unbox<'g> g, HSet.ofSeq vs) |> HMap.ofSeq )
else
AMap.amap <| function scope -> new AMap.Readers.GroupByReader<'a, 'g, 'a>(s, fun v -> f v, v)
let groupBy' (f : 'a -> 'g * 'b) (s : aset<'a>) : amap<'g, hset<'b>> =
if s.IsConstant then
AMap.constant <| lazy ( s.Content |> Mod.force |> Seq.map f |> Seq.groupBy (fun (g,_) -> g :> obj) |> Seq.map (fun (g,vs) -> unbox<'g> g, vs |> Seq.map snd |> HSet.ofSeq) |> HMap.ofSeq )
else
AMap.amap <| function scope -> new AMap.Readers.GroupByReader<'a, 'g, 'b>(s, f)
[<AutoOpen>]
module AMapBuilderExperiments =
type AMapBuilder() =
member x.Yield(kvp : 'k * 'v) =
AMap.ofList [kvp]
member x.Combine(l : amap<'k, 'v>, r : amap<'k, 'v>) : amap<'k, 'v> =
AMap.union l r
member x.Bind(m : IMod<'a>, f : 'a -> amap<'k, 'v>) =
m |> AMap.bind f
member x.Zero() =
AMap.empty
member x.Delay(f : unit -> amap<'k, 'v>) =
f()
member x.YieldFrom(m : hmap<'k, 'v>) =
AMap.ofHMap m
member x.YieldFrom(m : Map<'k, 'v>) =
AMap.ofHMap (HMap.ofSeq (Map.toSeq m))
member x.YieldFrom(m : seq<'k * 'v>) =
AMap.ofHMap (HMap.ofSeq m)
member x.YieldFrom(m : amap<'k, 'v>) =
m
type RestrictedAMapBuilder<'k, 'v>() =
abstract member Resolve : 'k * 'v * 'v -> 'v
default x.Resolve(_,_,r) = r
member x.Yield(kvp : 'k * 'v) =
AMap.ofList [kvp]
member x.Combine(l : amap<'k, 'v>, r : amap<'k, 'v>) : amap<'k, 'v> =
AMap.union l r
member x.Bind(m : IMod<'a>, f : 'a -> amap<'k, 'v>) =
m |> AMap.bind f
member x.Zero() =
AMap.empty
member x.Delay(f : unit -> amap<'k, 'v>) =
f()
member x.YieldFrom(m : hmap<'k, 'v>) =
AMap.ofHMap m
member x.YieldFrom(m : seq<'k * 'v>) =
AMap.ofHMap (HMap.ofSeq m)
member x.YieldFrom(m : amap<'k, 'v>) =
m
let amap = AMapBuilder()
module Test =
let m1 = Mod.constant 1
let m2 = Mod.constant 2
let ten = HMap.ofList [ for i in 1 .. 10 -> (i, i*i) ]
ten.Store
let ten2 = HMap.toMapExt ten
let t = HDeltaSet.ofList [ SetOperation.rem 1; SetOperation.add 1; SetOperation.add 2]
HDeltaSet.count t
let ten3 = HRefSet.ofList [ 1 .. 10 ]
let ten3b = HRefSet.ofList [ 1 .. 20 ]
ten3.ComputeDelta ten3b
//ten.Remove(4)
//ten.
//m1 + m2
//m1.Id
//m1.Level
//m1.IsConstant
(*
[<AutoOpen>]
module EvaluationUtilities =
let evaluateTopLevel (f : unit -> 'a) : 'a =
let ctx = Ag.getContext()
Ag.setContext Ag.emptyScope
let currentTransaction = Transaction.Running
Transaction.Running <- None
try
f ()
finally
Ag.setContext ctx
Transaction.Running <- currentTransaction
*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment