From b096402a92595dfe5a29718c69413d13ad602fa9 Mon Sep 17 00:00:00 2001 From: Alfonso Garcia-Caro Date: Wed, 30 Sep 2020 20:23:23 +0900 Subject: [PATCH] New FsharpMap/Set implementations --- src/fable-library/Map.fs | 1232 ++++++++++++++++++++-------------- src/fable-library/Set.fs | 1350 +++++++++++++++++++++----------------- 2 files changed, 1501 insertions(+), 1081 deletions(-) diff --git a/src/fable-library/Map.fs b/src/fable-library/Map.fs index e66b41625b..2d21dd7fa5 100644 --- a/src/fable-library/Map.fs +++ b/src/fable-library/Map.fs @@ -1,345 +1,450 @@ -//---------------------------------------------------------------------------- -// Copyright (c) 2002-2012 Microsoft Corporation. -// -// This source code is subject to terms and conditions of the Apache License, Version 2.0. A -// copy of the license can be found in the License.html file at the root of this distribution. -// By using this source code in any fashion, you are agreeing to be bound -// by the terms of the Apache License, Version 2.0. -// -// You must not remove this notice, or any other, from this software. -//---------------------------------------------------------------------------- - -// Root of the distribution is at: https://github.com/fsharp/fsharp -// Modified Map implementation for FunScript/Fable +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. module Map -open System.Collections open System.Collections.Generic -open Fable.Collections -open Fable.Core - -// [] -// [] -type MapTree<'Key,'Value when 'Key : comparison > = - | MapEmpty - | MapOne of 'Key * 'Value - | MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * 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 MapTree<'Key, 'Value>(k: 'Key, v: 'Value) = + member _.Key = k + member _.Value = v + +[] +[] +[] +type MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Value>, right: MapTree<'Key, 'Value>, h: int) = + inherit MapTree<'Key,'Value>(k, v) + + member _.Left = left + member _.Right = right + member _.Height = h [] -[] module MapTree = - let rec sizeAux acc m = - match m with - | MapEmpty -> acc - | MapOne _ -> acc + 1 - | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r + let empty = null - let size x = sizeAux 0 x + let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m - let empty = MapEmpty + let rec sizeAux acc (m:MapTree<'Key, 'Value>) = + if isEmpty m then + acc + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> sizeAux (sizeAux (acc+1) mn.Left) mn.Right + | _ -> acc + 1 - let height = function - | MapEmpty -> 0 - | MapOne _ -> 1 - | MapNode(_,_,_,_,h) -> h + let size x = sizeAux 0 x - let isEmpty m = - match m with - | MapEmpty -> true - | _ -> false +// #if TRACE_SETS_AND_MAPS +// let mutable traceCount = 0 +// let mutable numOnes = 0 +// let mutable numNodes = 0 +// let mutable numAdds = 0 +// let mutable numRemoves = 0 +// let mutable numLookups = 0 +// let mutable numUnions = 0 +// let mutable totalSizeOnNodeCreation = 0.0 +// let mutable totalSizeOnMapAdd = 0.0 +// let mutable totalSizeOnMapLookup = 0.0 +// let mutable largestMapSize = 0 +// let mutable largestMapStackTrace = Unchecked.defaultof<_> + +// let report() = +// traceCount <- traceCount + 1 +// if traceCount % 1000000 = 0 then +// System.Console.WriteLine( +// "#MapOne = {0}, #MapNode = {1}, #Add = {2}, #Remove = {3}, #Unions = {4}, #Lookups = {5}, avMapTreeSizeOnNodeCreation = {6}, avMapSizeOnCreation = {7}, avMapSizeOnLookup = {8}", +// numOnes, numNodes, numAdds, numRemoves, numUnions, numLookups, +// (totalSizeOnNodeCreation / float (numNodes + numOnes)), (totalSizeOnMapAdd / float numAdds), +// (totalSizeOnMapLookup / float numLookups)) +// System.Console.WriteLine("#largestMapSize = {0}, largestMapStackTrace = {1}", largestMapSize, largestMapStackTrace) + +// let MapOne n = +// report() +// numOnes <- numOnes + 1 +// totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 +// MapTree n + +// let MapNode (x, l, v, r, h) = +// report() +// numNodes <- numNodes + 1 +// let n = MapTreeNode (x, l, v, r, h) +// totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (size n) +// n +// #endif + + let inline height (m: MapTree<'Key, 'Value>) = + if isEmpty m then 0 + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> mn.Height + | _ -> 1 + + [] + let tolerance = 2 + + let mk l k v r : MapTree<'Key, 'Value> = + let hl = height l + let hr = height r + let m = if hl < hr then hr else hl + if m = 0 then // m=0 ~ isEmpty l && isEmpty r + MapTree(k,v) + else + MapTreeNode(k,v,l,r,m+1) :> MapTree<'Key, 'Value> // new map is higher by 1 than the highest - 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) + let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = + value :?> MapTreeNode<'Key,'Value> - let rebalance t1 k v t2 = + let rebalance t1 (k: 'Key) (v: 'Value) t2 : MapTree<'Key, 'Value> = 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" + if t2h > t1h + tolerance then (* right is heavier than left *) + let t2' = asNode(t2) + (* one of the nodes must have height > height t1 + 1 *) + if height t2'.Left > t1h + 1 then (* balance left: combination *) + let t2l = asNode(t2'.Left) + mk (mk t1 k v t2l.Left) t2l.Key t2l.Value (mk t2l.Right t2'.Key t2'.Value t2'.Right) + else (* rotate left *) + mk (mk t1 k v t2'.Left) t2'.Key t2'.Value t2'.Right 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 "re balance" - else - mk t1l t1k t1v (mk t1r k v t2) - | _ -> failwith "rebalance" + if t1h > t2h + tolerance then (* left is heavier than right *) + let t1' = asNode(t1) + (* one of the nodes must have height > height t2 + 1 *) + if height t1'.Right > t2h + 1 then + (* balance right: combination *) + let t1r = asNode(t1'.Right) + mk (mk t1'.Left t1'.Key t1'.Value t1r.Left) t1r.Key t1r.Value (mk t1r.Right k v t2) + else + mk t1'.Left t1'.Key t1'.Value (mk t1'.Right k v t2) 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) - elif c = 0 then MapOne(k,v) - else MapNode (k,v,m,MapEmpty,2) - | MapNode(k2,v2,l,r,h) -> - 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) - else rebalance l k2 v2 (add comparer k v r) - - let rec find (comparer: IComparer<'Value>) k m = - match m with - | MapEmpty -> failwith "key not found" - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then v2 - else failwith "key not found" - | 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 k v (acc1,acc2) = - if f k v then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2) - - let rec partitionAux (comparer: IComparer<'Value>) f 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 f s (empty,empty) - - let filter1 (comparer: IComparer<'Value>) f k v acc = if f k v then add comparer k v acc else acc - - let rec filterAux (comparer: IComparer<'Value>) f 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 f s empty - - let rec spliceOutSuccessor m = - match m with - | MapEmpty -> failwith "internal error: Map.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,r with - | MapEmpty,_ -> r - | _,MapEmpty -> l - | _ -> - let sk,sv,r' = spliceOutSuccessor r - mk l sk sv r' - else rebalance l k2 v2 (remove comparer k r) - - 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 iter f m = - match m with - | MapEmpty -> () - | MapOne(k2,v2) -> f k2 v2 - | MapNode(k2,v2,l,r,_) -> iter f l; f k2 v2; iter f r - - let rec tryPick f m = - match m with - | MapEmpty -> None - | MapOne(k2,v2) -> f k2 v2 - | MapNode(k2,v2,l,r,_) -> - match tryPick f l with - | Some _ as res -> res - | None -> - match f k2 v2 with + let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Value> = + if isEmpty m then MapTree(k,v) + else + let c = comparer.Compare(k,m.Key) + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> + else rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) + | _ -> + if c < 0 then MapTreeNode (k,v,empty,m,2) :> MapTree<'Key, 'Value> + elif c = 0 then MapTree(k,v) + else MapTreeNode (k,v,m,empty,2) :> MapTree<'Key, 'Value> + + let rec tryGetValue (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then false, Unchecked.defaultof<'Value> + else + let c = comparer.Compare(k, m.Key) + if c = 0 then true, m.Value + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + tryGetValue comparer k (if c < 0 then mn.Left else mn.Right) + | _ -> false, Unchecked.defaultof<'Value> + + let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + match tryGetValue comparer k m with + | true, v -> v + | false, _ -> raise (KeyNotFoundException()) + + let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + match tryGetValue comparer k m with + | true, v -> Some v + | false, _ -> None + + let partition1 (comparer: IComparer<'Key>) (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<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = + if isEmpty m then acc + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let acc = partitionAux comparer f mn.Right acc + let acc = partition1 comparer f mn.Key mn.Value acc + partitionAux comparer f mn.Left acc + | _ -> partition1 comparer f m.Key m.Value acc + + let partition (comparer: IComparer<'Key>) f m = + partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) + + let filter1 (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) k v acc = + if f.Invoke (k, v) then add comparer k v acc else acc + + let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = + if isEmpty m then acc + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let acc = filterAux comparer f mn.Left acc + let acc = filter1 comparer f mn.Key mn.Value acc + filterAux comparer f mn.Right acc + | _ -> filter1 comparer f m.Key m.Value acc + + let filter (comparer: IComparer<'Key>) f m = + filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty + + let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = + if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if isEmpty mn.Left then mn.Key, mn.Value, mn.Right + else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right + | _ -> m.Key, m.Value, empty + + let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then empty + else + let c = comparer.Compare(k, m.Key) + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then + if isEmpty mn.Left then mn.Right + elif isEmpty mn.Right then mn.Left + else + let sk, sv, r' = spliceOutSuccessor mn.Right + mk mn.Left sk sv r' + else rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) + | _ -> + if c = 0 then empty else m + + let rec change (comparer: IComparer<'Key>) k (u: 'Value option -> 'Value option) (m: MapTree<'Key, 'Value>) : MapTree<'Key,'Value> = + if isEmpty m then + match u None with + | None -> m + | Some v -> MapTree (k, v) + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let c = comparer.Compare(k, mn.Key) + if c < 0 then + rebalance (change comparer k u mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then + match u (Some mn.Value) with + | None -> + if isEmpty mn.Left then mn.Right + elif isEmpty mn.Right then mn.Left + else + let sk, sv, r' = spliceOutSuccessor mn.Right + mk mn.Left sk sv r' + | Some v -> MapTreeNode (k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key,'Value> + else + rebalance mn.Left mn.Key mn.Value (change comparer k u mn.Right) + | _ -> + let c = comparer.Compare(k, m.Key) + if c < 0 then + match u None with + | None -> m + | Some v -> MapTreeNode (k, v, empty, m, 2) :> MapTree<'Key,'Value> + elif c = 0 then + match u (Some m.Value) with + | None -> empty + | Some v -> MapTree (k, v) + else + match u None with + | None -> m + | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> + + let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then false + else + let c = comparer.Compare(k, m.Key) + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if c < 0 then mem comparer k mn.Left + else (c = 0 || mem comparer k mn.Right) + | _ -> c = 0 + + let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then () + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right + | _ -> f.Invoke (m.Key, m.Value) + + let iter f m = + iterOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then None + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + match tryPickOpt f mn.Left with + | Some _ as res -> res + | None -> + match f.Invoke (mn.Key, mn.Value) with | Some _ as res -> res | None -> - tryPick f r - - let rec exists f m = - match m with - | MapEmpty -> false - | MapOne(k2,v2) -> f k2 v2 - | MapNode(k2,v2,l,r,_) -> exists f l || f k2 v2 || exists f r - - let rec forall f m = - match m with - | MapEmpty -> true - | MapOne(k2,v2) -> f k2 v2 - | MapNode(k2,v2,l,r,_) -> forall f l && f k2 v2 && forall f r - - let rec map f m = - match m with - | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k,f v) - | MapNode(k,v,l,r,h) -> - let l2 = map f l - let v2 = f v - let r2 = map f r - MapNode(k,v2,l2, r2,h) - - let rec mapi f m = - match m with - | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k,f k v) - | MapNode(k,v,l,r,h) -> - let l2 = mapi f l - let v2 = f k v - let r2 = mapi f r - MapNode(k,v2, l2, r2,h) - - let rec foldBack f m x = - match m with - | MapEmpty -> x - | MapOne(k,v) -> f k v x - | MapNode(k,v,l,r,_) -> - let x = foldBack f r x - let x = f k v x - foldBack f l x - - let rec fold f x m = - match m with - | MapEmpty -> x - | MapOne(k,v) -> f x k v - | MapNode(k,v,l,r,_) -> - let x = fold f x l - let x = f x k v - fold f x r - - let rec foldFromTo (comparer: IComparer<'Value>) lo hi f 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 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 comparer lo hi f l x else x - let x = if cLoKey <= 0 && cKeyHi <= 0 then f k v x else x - let x = if cKeyHi < 0 then foldFromTo comparer lo hi f r x else x - x - - let foldSection (comparer: IComparer<'Value>) lo hi f m x = - if comparer.Compare(lo,hi) = 1 then x else foldFromTo comparer lo hi f m x - - 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) - - let toList m = + tryPickOpt f mn.Right + | _ -> f.Invoke (m.Key, m.Value) + + let tryPick f m = + tryPickOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then false + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> existsOpt f mn.Left || f.Invoke (mn.Key, mn.Value) || existsOpt f mn.Right + | _ -> f.Invoke (m.Key, m.Value) + + let exists f m = + existsOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then true + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> forallOpt f mn.Left && f.Invoke (mn.Key, mn.Value) && forallOpt f mn.Right + | _ -> f.Invoke (m.Key, m.Value) + + + let forall f m = + forallOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec map (f:'Value -> 'Result) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Result> = + if isEmpty m then empty + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let l2 = map f mn.Left + let v2 = f mn.Value + let r2 = map f mn.Right + MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> + | _ -> MapTree (m.Key, f m.Value) + + let rec mapiOpt (f: OptimizedClosures.FSharpFunc<'Key, 'Value, 'Result>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then empty + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let l2 = mapiOpt f mn.Left + let v2 = f.Invoke (mn.Key, mn.Value) + let r2 = mapiOpt f mn.Right + MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> + | _ -> MapTree (m.Key, f.Invoke (m.Key, m.Value)) + + let mapi f m = + mapiOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + if isEmpty m then x + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let x = foldBackOpt f mn.Right x + let x = f.Invoke (mn.Key, mn.Value, x) + foldBackOpt f mn.Left x + | _ -> f.Invoke (m.Key, m.Value, x) + + let foldBack f m x = + foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x + + let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x (m: MapTree<'Key, 'Value>) = + if isEmpty m then x + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let x = foldOpt f x mn.Left + let x = f.Invoke (x, mn.Key, mn.Value) + foldOpt f x mn.Right + | _ -> f.Invoke (x, m.Key, m.Value) + + let fold f x m = + foldOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) x m + + let foldSectionOpt (comparer: IComparer<'Key>) lo hi (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + if isEmpty m then x + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let cLoKey = comparer.Compare(lo, mn.Key) + let cKeyHi = comparer.Compare(mn.Key, hi) + let x = if cLoKey < 0 then foldFromTo f mn.Left x else x + let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (mn.Key, mn.Value, x) else x + let x = if cKeyHi < 0 then foldFromTo f mn.Right x else x + x + | _ -> + let cLoKey = comparer.Compare(lo, m.Key) + let cKeyHi = comparer.Compare(m.Key, hi) + let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x + x + + if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x + + let foldSection (comparer: IComparer<'Key>) lo hi f m x = + foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x + + let toList (m: MapTree<'Key, 'Value>) = + let rec loop (m: MapTree<'Key, 'Value>) acc = + if isEmpty m then acc + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) + | _ -> (m.Key, m.Value) :: acc loop m [] - let ofList comparer l = Seq.fold (fun acc (k,v) -> add comparer k v acc) empty l + let toArray (m: MapTree<'Key, 'Value>): ('Key * 'Value)[] = + 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 + let (x, y) = e.Current mkFromEnumerator comparer (add comparer x y acc) e else acc - let ofArray comparer (arr : array<_>) = + let ofArray comparer (arr : array<'Key * 'Value>) = let mutable res = empty - for i = 0 to arr.Length - 1 do - let x,y = arr.[i] + 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 - + 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 copyToArray m (arr: _[]) i = let mutable j = i - s |> iter (fun x y -> arr.[j] <- KeyValuePair(x,y); j <- j + 1) - + m |> iter (fun x y -> arr.[j] <- KeyValuePair(x, y); j <- j + 1) /// Imperative left-to-right iterators. [] - 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 } + 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 = + let rec collapseLHS (stack:MapTree<'Key, 'Value> list) = match stack with - | [] -> [] - | MapEmpty :: rest -> collapseLHS rest - | MapOne _ :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) + | [] -> [] + | m :: rest -> + if isEmpty m then collapseLHS rest + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) + | _ -> stack - let mkIterator s = { stack = collapseLHS [s]; started = false } + let mkIterator m = + { stack = collapseLHS [m]; started = false } let notStarted() = failwith "enumeration not started" @@ -348,36 +453,40 @@ module MapTree = let current i = if i.started then match i.stack with - | MapOne (k,v) :: _ -> KeyValuePair<_,_>(k,v) - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" + | [] -> alreadyFinished() + | m :: _ -> + match m with + | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for current" + | _ -> new KeyValuePair<_, _>(m.Key, m.Value) 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: Map iterator, unexpected stack for moveNext" + | m :: rest -> + match m with + | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for moveNext" + | _ -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty else - i.started <- true; (* The first call to MoveNext "starts" the enumeration. *) + i.started <- true (* The first call to MoveNext "starts" the enumeration. *) not i.stack.IsEmpty - type mkIEnumerator'<'Key,'Value when 'Key: comparison>(s) = - let mutable i = mkIterator s - interface IEnumerator> with - member __.Current = current i - interface IEnumerator with - member __.Current = box (current i) - member __.MoveNext() = moveNext i - member __.Reset() = i <- mkIterator s - interface System.IDisposable with - member __.Dispose() = () + let mkIEnumerator m = + let mutable i = mkIterator m + { 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 m - let mkIEnumerator s = new mkIEnumerator'<_,_>(s) :> _ IEnumerator + interface System.IDisposable with + member __.Dispose() = ()} let toSeq s = let en = mkIEnumerator s @@ -386,90 +495,185 @@ module MapTree = then Some(en.Current, en) else None) -/// Fable uses JS Map to represent .NET Dictionary. However when keys are non-primitive, -/// we need to disguise an F# map as a mutable map. Thus, this interface matches JS Map prototype. -/// See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Map - -// type IMutableMap<'Key,'Value> = -// inherit IEnumerable> -// abstract size: int -// abstract clear: unit -> unit -// abstract delete: 'Key -> bool -// abstract entries: unit -> KeyValuePair<'Key,'Value> seq -// abstract get: 'Key -> 'Value -// abstract has: 'Key -> bool -// abstract keys: unit -> 'Key seq -// abstract set: 'Key * 'Value -> IMutableMap<'Key,'Value> -// abstract values: unit -> 'Value seq - -[] -type Map<[]'Key,[]'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key,'Value>) = - member internal __.Comparer = comparer - member internal __.Tree = tree - - member __.Add(k,v) : Map<'Key,'Value> = - new Map<'Key,'Value>(comparer,MapTree.add comparer k v tree) - member __.IsEmpty = MapTree.isEmpty tree - member __.Item - with get(k : 'Key) = - MapTree.find comparer k tree - - [] - member __.TryGetValue(k: 'Key, defValue: 'Value ref) = - match MapTree.tryFind comparer k tree with - | Some v -> defValue := v; true - | None -> false - - member __.TryPick(f) = MapTree.tryPick f tree - member __.Exists(f) = MapTree.exists f tree - member __.Filter(f): Map<'Key,'Value> = - new Map<'Key,'Value>(comparer, MapTree.filter comparer f tree) - member __.ForAll(f) = MapTree.forall f tree - member __.Fold f acc = +[] +[] +[] +type Map<[]'Key, []'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key, 'Value>) = + + // [] + // This type is logically immutable. This field is only mutated during deserialization. + // let mutable comparer = comparer + + // [] + // This type is logically immutable. This field is only mutated during deserialization. + // let mutable tree = tree + + // // This type is logically immutable. This field is only mutated during serialization and deserialization. + // // + // // WARNING: The compiled name of this field may never be changed because it is part of the logical + // // WARNING: permanent serialization format for this type. + // let mutable serializedData = null + + // 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 = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<'Key, 'Value>(comparer, MapTree.empty) + + // [] + // member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = + // ignore context + // serializedData <- MapTree.toArray tree |> Array.map (fun (k, v) -> KeyValuePair(k, v)) + + // Do not set this to null, since concurrent threads may also be serializing the data + //[] + //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = + // serializedData <- null + + // [] + // member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = + // ignore context + // comparer <- LanguagePrimitives.FastGenericComparer<'Key> + // tree <- serializedData |> Array.map (fun (KeyValue(k, v)) -> (k, v)) |> MapTree.ofArray comparer + // serializedData <- null + + static member Empty : Map<'Key, 'Value> = + empty + + static member Create(ie : IEnumerable<_>) : Map<'Key, 'Value> = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofSeq comparer ie) + + new (elements : seq<_>) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofSeq comparer elements) + + // [] + member internal m.Comparer = comparer + + // [] + member internal m.Tree = tree + + member m.Add(key, value) : Map<'Key, 'Value> = +// #if TRACE_SETS_AND_MAPS +// MapTree.report() +// MapTree.numAdds <- MapTree.numAdds + 1 +// let size = MapTree.size m.Tree + 1 +// MapTree.totalSizeOnMapAdd <- MapTree.totalSizeOnMapAdd + float size +// if size > MapTree.largestMapSize then +// MapTree.largestMapSize <- size +// MapTree.largestMapStackTrace <- System.Diagnostics.StackTrace().ToString() +// #endif + new Map<'Key, 'Value>(comparer, MapTree.add comparer key value tree) + + member m.Change(key, f) : Map<'Key, 'Value> = + new Map<'Key, 'Value>(comparer, MapTree.change comparer key f tree) + + // [] + member m.IsEmpty = MapTree.isEmpty tree + + member m.Item + with get(key : 'Key) = +// #if TRACE_SETS_AND_MAPS +// MapTree.report() +// MapTree.numLookups <- MapTree.numLookups + 1 +// MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) +// #endif + MapTree.find comparer key tree + + member m.TryPick f = + MapTree.tryPick f tree + + member m.Exists predicate = + MapTree.exists predicate tree + + member m.Filter predicate = + new Map<'Key, 'Value>(comparer, MapTree.filter comparer predicate tree) + + member m.ForAll predicate = + MapTree.forall predicate tree + + member m.Fold f acc = MapTree.foldBack f tree acc - member __.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = MapTree.foldSection comparer lo hi f tree acc + member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = + MapTree.foldSection comparer lo hi f tree acc - member __.Iterate f = MapTree.iter f tree + member m.Iterate f = + MapTree.iter f tree - member __.MapRange f = new Map<'Key,'b>(comparer,MapTree.map f tree) + member m.MapRange (f:'Value->'Result) = + new Map<'Key, 'Result>(comparer, MapTree.map f tree) - member __.Map f = new Map<'Key,'b>(comparer,MapTree.mapi f tree) + member m.Map f = + new Map<'Key, 'b>(comparer, MapTree.mapi f tree) - member __.Partition(f) : Map<'Key,'Value> * Map<'Key,'Value> = - let r1,r2 = MapTree.partition comparer f tree in - new Map<'Key,'Value>(comparer,r1), new Map<'Key,'Value>(comparer,r2) + member m.Partition predicate : Map<'Key, 'Value> * Map<'Key, 'Value> = + let r1, r2 = MapTree.partition comparer predicate tree + new Map<'Key, 'Value>(comparer, r1), new Map<'Key, 'Value>(comparer, r2) - member __.Count = MapTree.size tree + member m.Count = + MapTree.size tree - member __.ContainsKey(k) = - MapTree.mem comparer k tree + member m.ContainsKey key = +// #if TRACE_SETS_AND_MAPS +// MapTree.report() +// MapTree.numLookups <- MapTree.numLookups + 1 +// MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) +// #endif + MapTree.mem comparer key tree - member __.Remove(k) : Map<'Key,'Value> = - new Map<'Key,'Value>(comparer,MapTree.remove comparer k tree) + member m.Remove key = + new Map<'Key, 'Value>(comparer, MapTree.remove comparer key tree) - member __.TryFind(k) = - MapTree.tryFind comparer k tree + [] + member __.TryGetValue(key: 'Key, value: 'Value ref) = + match MapTree.tryGetValue comparer key tree with + | true, v -> value := v; true + | false, _ -> false - member __.ToList() = MapTree.toList tree + member m.TryFind key = +// #if TRACE_SETS_AND_MAPS +// MapTree.report() +// MapTree.numLookups <- MapTree.numLookups + 1 +// MapTree.totalSizeOnMapLookup <- MapTree.totalSizeOnMapLookup + float (MapTree.size tree) +// #endif + MapTree.tryFind comparer key tree - override this.ToString() = - let toStr (kv: KeyValuePair<'Key,'Value>) = System.String.Format("({0}, {1})", kv.Key, kv.Value) - let str = (this |> Seq.map toStr |> String.concat "; ") - "map [" + str + "]" + member m.ToList() = + MapTree.toList tree + + member m.ToArray() = + MapTree.toArray tree - override this.GetHashCode() = + static member ofList l : Map<'Key, 'Value> = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofList comparer l) + + member this.ComputeHashCode() = let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 - let e = MapTree.mkIEnumerator this.Tree - while e.MoveNext() do - let (KeyValue(x,y)) = e.Current + for (KeyValue(x, y)) in this do res <- combineHash res (hash x) res <- combineHash res (Unchecked.hash y) - abs res + res - override this.Equals(that) = - (this :> System.IComparable).CompareTo(that) = 0 + override this.GetHashCode() = this.ComputeHashCode() + + override this.Equals that = + match that with + | :? Map<'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 = e1.Current + let e2c = e2.Current + ((e1c.Key = e2c.Key) && (Unchecked.equals e1c.Value e2c.Value) && loop()))) + loop() + | _ -> false interface IEnumerable> with member __.GetEnumerator() = MapTree.mkIEnumerator tree @@ -477,26 +681,19 @@ type Map<[]'Key,[ System.Collections.IEnumerator) - interface System.IComparable with member m.CompareTo(obj: obj) = - let m2 = obj :?> Map<'Key,'Value> - let mutable res = 0 - let mutable finished = false - use e1 = MapTree.mkIEnumerator m.Tree - use e2 = MapTree.mkIEnumerator m2.Tree - while not finished && res = 0 do - match e1.MoveNext(), e2.MoveNext() with - | false, false -> finished <- true - | true, false -> res <- 1 - | false, true -> res <- -1 - | true, true -> - let kvp1 = e1.Current - let kvp2 = e2.Current - let c = comparer.Compare(kvp1.Key, kvp2.Key) - res <- if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value - res - interface IMutableMap<'Key,'Value> with + match obj with + | :? Map<'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" "not comparable" + + interface Fable.Collections.IMutableMap<'Key,'Value> with member this.size = this.Count member __.clear() = failwith "Map cannot be mutated" member __.delete(_) = failwith "Map cannot be mutated" @@ -507,140 +704,199 @@ type Map<[]'Key,[ Seq.map (fun kv -> kv.Value) -let isEmpty (m:Map<_,_>) = m.IsEmpty + // 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 m.Keys = ([| for kvp in m -> kvp.Key |] :> ICollection<'Key>) + + // // REVIEW: this implementation could avoid copying the Values to an array + // member m.Values = ([| for kvp in m -> kvp.Value |] :> ICollection<'Value>) + + // member m.Add(k, v) = ignore(k, v); raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) -let add k v (m:Map<_,_>) = m.Add(k,v) + // member m.ContainsKey k = m.ContainsKey k + + // member m.TryGetValue(k, r) = m.TryGetValue(k, &r) + + // member m.Remove(k : 'Key) = ignore k; (raise (NotSupportedException(SR.GetString(SR.mapCannotBeMutated))) : bool) + + // interface ICollection> 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 m.Contains x = m.ContainsKey x.Key && Unchecked.equals m.[x.Key] x.Value + + // member __.CopyTo(arr, i) = MapTree.copyToArray tree arr i + + // member __.IsReadOnly = true + + // member m.Count = m.Count + + // interface IReadOnlyCollection> with + // member m.Count = m.Count + + // interface IReadOnlyDictionary<'Key, 'Value> with + + // member m.Item with get key = m.[key] + + // member m.Keys = seq { for kvp in m -> kvp.Key } + + // member m.TryGetValue(key, value: byref<'Value>) = m.TryGetValue(key, &value) + + // member m.Values = seq { for kvp in m -> kvp.Value } + + // member m.ContainsKey key = m.ContainsKey key + + override this.ToString() = + let toStr (kv: KeyValuePair<'Key,'Value>) = System.String.Format("({0}, {1})", kv.Key, kv.Value) + let str = (this |> Seq.map toStr |> String.concat "; ") + "map [" + str + "]" -let find k (m:Map<_,_>) = m.[k] +// [] +// [] +// module Map = -let tryFind k (m:Map<_,_>) = m.TryFind(k) +// [] +let isEmpty (table: Map<_, _>) = + table.IsEmpty -let remove k (m:Map<_,_>) = m.Remove(k) +// [] +let add key value (table: Map<_, _>) = + table.Add (key, value) -let containsKey k (m:Map<_,_>) = m.ContainsKey(k) +// [] +let change key f (table: Map<_, _>) = + table.Change (key, f) -let iterate f (m:Map<_,_>) = m.Iterate(f) +// [] +let find key (table: Map<_, _>) = + table.[key] -let tryPick f (m:Map<_,_>) = m.TryPick(f) +// [] +let tryFind key (table: Map<_, _>) = + table.TryFind key -let pick f (m:Map<_,_>) = match tryPick f m with None -> failwith "key not found" | Some res -> res +// [] +let remove key (table: Map<_, _>) = + table.Remove key -let exists f (m:Map<_,_>) = m.Exists(f) +// [] +let containsKey key (table: Map<_, _>) = + table.ContainsKey key -let filter f (m:Map<_,_>) = m.Filter(f) +// [] +let iterate action (table: Map<_, _>) = + table.Iterate action -let partition f (m:Map<_,_>) = m.Partition(f) +// [] +let tryPick chooser (table: Map<_, _>) = + table.TryPick chooser -let forAll f (m:Map<_,_>) = m.ForAll(f) +// [] +let pick chooser (table: Map<_, _>) = + match tryPick chooser table with + | None -> raise (KeyNotFoundException()) + | Some res -> res -let mapRange f (m:Map<_,_>) = m.MapRange(f) +// [] +let exists predicate (table: Map<_, _>) = + table.Exists predicate -let map f (m:Map<_,_>) = m.Map(f) +// [] +let filter predicate (table: Map<_, _>) = + table.Filter predicate -let fold<'Key,'T,'State when 'Key : comparison> f (z:'State) (m:Map<'Key,'T>) = - MapTree.fold f z m.Tree +// [] +let partition predicate (table: Map<_, _>) = + table.Partition predicate -let foldBack<'Key,'T,'State when 'Key : comparison> f (m:Map<'Key,'T>) (z:'State) = - MapTree.foldBack f m.Tree z +// [] +let forAll predicate (table: Map<_, _>) = + table.ForAll predicate -let toSeq (m:Map<'a,'b>) = - MapTree.toSeq m.Tree +// [] +let map mapping (table: Map<_, _>) = + table.Map mapping -let findKey f (m : Map<_,_>) = - m.Tree |> MapTree.tryPick (fun k v -> - if f k v then Some k else None) - |> function Some k -> k | None -> failwith "Key not found" +// [] +let fold<'Key, 'T, 'State when 'Key : comparison> folder (state:'State) (table: Map<'Key, 'T>) = + MapTree.fold folder state table.Tree -let tryFindKey f (m : Map<_,_>) = - m.Tree |> MapTree.tryPick (fun k v -> - if f k v then Some k else None) +// [] +let foldBack<'Key, 'T, 'State when 'Key : comparison> folder (table: Map<'Key, 'T>) (state:'State) = + MapTree.foldBack folder table.Tree state -let ofList (l: ('Key * 'Value) list) ([] comparer: IComparer<'Key>) = - new Map<_,_>(comparer, MapTree.ofList comparer l) +// [] +let toSeq (table: Map<_, _>) = + table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) -let ofSeq (l: ('Key * 'Value) seq) ([] comparer: IComparer<'Key>) = - new Map<_,_>(comparer, MapTree.ofSeq comparer l) +// [] +let findKey predicate (table : Map<_, _>) = + table |> Seq.pick (fun kvp -> let k = kvp.Key in if predicate k kvp.Value then Some k else None) -let ofArray (array: ('Key * 'Value) array) ([] comparer: IComparer<'Key>) = - new Map<_,_>(comparer, MapTree.ofArray comparer array) +// [] +let tryFindKey predicate (table : Map<_, _>) = + table |> Seq.tryPick (fun kvp -> let k = kvp.Key in if predicate k kvp.Value then Some k else None) -let toList (m:Map<_,_>) = m.ToList() +// [] +let ofList (elements: ('Key * 'Value) list) = + Map<_, _>.ofList elements -let toArray (m:Map<'Key,'Value>) = - let res = Array.Helpers.allocateArray m.Count - MapTree.copyToArray m.Tree res 0 - res +// [] +let ofSeq elements = + Map<_, _>.Create elements -let empty<'Key,'Value when 'Key : comparison> ([] comparer: IComparer<'Key>) = - new Map<'Key,'Value>(comparer, MapTree.MapEmpty) +// [] +let ofArray (elements: ('Key * 'Value) array) = + let comparer = LanguagePrimitives.FastGenericComparer<'Key> + new Map<_, _>(comparer, MapTree.ofArray comparer elements) -// let private createMutablePrivate (comparer: IComparer<'Key>) tree' = -// let mutable tree = tree' -// { new IMutableMap<'Key,'Value> with -// member __.size = MapTree.size tree -// member __.clear () = -// tree <- MapEmpty -// member __.delete x = -// if MapTree.mem comparer x tree -// then tree <- MapTree.remove comparer x tree; true -// else false -// member __.entries () = -// MapTree.toSeq tree -// member __.get k = -// MapTree.find comparer k tree -// member __.has x = -// MapTree.mem comparer x tree -// member __.keys () = -// MapTree.toSeq tree |> Seq.map (fun kv -> kv.Key) -// member this.set(k, v) = -// tree <- MapTree.add comparer k v tree -// this -// member __.values () = -// MapTree.toSeq tree |> Seq.map (fun kv -> kv.Value) -// interface IEnumerable<_> with -// member __.GetEnumerator() = -// MapTree.mkIEnumerator tree -// interface IEnumerable with -// member __.GetEnumerator() = -// upcast MapTree.mkIEnumerator tree -// } +// [] +let toList (table: Map<_, _>) = + table.ToList() -/// Emulate JS Map with custom comparer for non-primitive values +// [] +let toArray (table: Map<_, _>) = + table.ToArray() -// let createMutable (source: ('Key*'Value) seq) ([] comparer: IComparer<'Key>) = -// MapTree.ofSeq comparer source -// |> createMutablePrivate comparer +// [] +let empty<'Key, 'Value when 'Key : comparison> = + Map<'Key, 'Value>.Empty -let createMutable (source: KeyValuePair<'Key, 'Value> seq) ([] comparer: IEqualityComparer<'Key>) = - let map = MutableMap(source, comparer) - map :> IMutableMap<_,_> +let createMutable (source: KeyValuePair<'Key, 'Value> seq) ([] comparer: IEqualityComparer<'Key>) = + let map = Fable.Collections.MutableMap(source, comparer) + map :> Fable.Collections.IMutableMap<_,_> -// let groupBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IComparer<'Key>): ('Key * 'T seq) seq = -let groupBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IEqualityComparer<'Key>): ('Key * 'T seq) seq = - let dict: IMutableMap<_,ResizeArray<'T>> = createMutable Seq.empty comparer +let groupBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IEqualityComparer<'Key>): ('Key * 'T seq) seq = + let dict: Fable.Collections.IMutableMap<_,ResizeArray<'T>> = createMutable Seq.empty comparer // Build the groupings for v in xs do let key = projection v - if dict.has(key) - then dict.get(key).Add(v) + if dict.has(key) then dict.get(key).Add(v) else dict.set(key, ResizeArray [v]) |> ignore // Mapping shouldn't be necessary because KeyValuePair compiles // as a tuple, but let's do it just in case the implementation changes dict |> Seq.map (fun kv -> kv.Key, upcast kv.Value) -// let countBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IComparer<'Key>): ('Key * int) seq = -let countBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IEqualityComparer<'Key>): ('Key * int) seq = +let countBy (projection: 'T -> 'Key) (xs: 'T seq) ([] comparer: IEqualityComparer<'Key>): ('Key * int) seq = let dict = createMutable Seq.empty comparer for value in xs do let key = projection value - if dict.has(key) - then dict.set(key, dict.get(key) + 1) + if dict.has(key) then dict.set(key, dict.get(key) + 1) else dict.set(key, 1) |> ignore dict |> Seq.map (fun kv -> kv.Key, kv.Value) -let count (m:Map<'Key,'Value>) = m.Count +// [] +let count (table: Map<_, _>) = + table.Count \ No newline at end of file diff --git a/src/fable-library/Set.fs b/src/fable-library/Set.fs index 0e9e3187fd..aaf2ca30c7 100644 --- a/src/fable-library/Set.fs +++ b/src/fable-library/Set.fs @@ -1,739 +1,903 @@ -//---------------------------------------------------------------------------- -// Copyright (c) 2002-2012 Microsoft Corporation. -// -// This source code is subject to terms and conditions of the Apache License, Version 2.0. A -// copy of the license can be found in the License.html file at the root of this distribution. -// By using this source code in any fashion, you are agreeing to be bound -// by the terms of the Apache License, Version 2.0. -// -// You must not remove this notice, or any other, from this software. -//---------------------------------------------------------------------------- - -// Root of the distribution is at: https://github.com/fsharp/fsharp -// Modified Set implementation for FunScript/Fable +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. module Set open System.Collections open System.Collections.Generic -open Fable.Collections -open Fable.Core - -(* A classic functional language implementation of binary trees *) - -// [] -// [] -type SetTree<'T> when 'T : comparison = - | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int - | SetOne of 'T // height = 1 - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) - // REVIEW: performance rumour has it that the data held in SetNode and SetOne should be - // exactly one cache line on typical architectures. They are currently - // ~6 and 3 words respectively. + +// A functional language implementation of binary trees + +[] +[] +type SetTree<'T>(k: 'T) = + member _.Key = k + +[] +[] +[] +type SetTreeNode<'T>(v:'T, left:SetTree<'T>, right: SetTree<'T>, h: int) = + inherit SetTree<'T>(v) + + member _.Left = left + member _.Right = right + member _.Height = h [] -[] -module internal SetTree = - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) - | SetOne(_) -> acc+1 - | SetEmpty -> acc +module SetTree = + + let empty = null + + let inline isEmpty (t:SetTree<'T>) = isNull t + + let rec countAux (t:SetTree<'T>) acc = + if isEmpty t then + acc + else + match t with + | :? SetTreeNode<'T> as tn -> countAux tn.Left (countAux tn.Right (acc+1)) + | _ -> acc+1 let count s = countAux s 0 - let SetOne n = SetTree.SetOne n - let SetNode (x,l,r,h) = SetTree.SetNode(x,l,r,h) - - let height t = - match t with - | SetEmpty -> 0 - | SetOne _ -> 1 - | SetNode (_,_,_,h) -> h - - let tolerance = 2 - - let mk l k r = - match l,r with - | SetEmpty,SetEmpty -> SetOne (k) - | _ -> - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) - - let rebalance t1 k t2 = + +// #if TRACE_SETS_AND_MAPS +// let mutable traceCount = 0 +// let mutable numOnes = 0 +// let mutable numNodes = 0 +// let mutable numAdds = 0 +// let mutable numRemoves = 0 +// let mutable numLookups = 0 +// let mutable numUnions = 0 +// let mutable totalSizeOnNodeCreation = 0.0 +// let mutable totalSizeOnSetAdd = 0.0 +// let mutable totalSizeOnSetLookup = 0.0 + +// let report() = +// traceCount <- traceCount + 1 +// if traceCount % 10000 = 0 then +// System.Console.WriteLine( +// "#SetOne = {0}, #SetNode = {1}, #Add = {2}, #Remove = {3}, #Unions = {4}, #Lookups = {5}, avSetSizeOnNodeCreation = {6}, avSetSizeOnSetCreation = {7}, avSetSizeOnSetLookup = {8}", +// numOnes, numNodes, numAdds, numRemoves, numUnions, numLookups, +// (totalSizeOnNodeCreation / float (numNodes + numOnes)), +// (totalSizeOnSetAdd / float numAdds), +// (totalSizeOnSetLookup / float numLookups)) + +// let SetTree n = +// report() +// numOnes <- numOnes + 1 +// totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 +// SetTree n + +// let SetTreeNode (x, l, r, h) = +// report() +// numNodes <- numNodes + 1 +// let n = SetTreeNode (x, l, r, h) +// totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n) +// n +// #endif + + let inline height (t:SetTree<'T>) = + if isEmpty t then 0 + else + match t with + | :? SetTreeNode<'T> as tn -> tn.Height + | _ -> 1 + +// #if CHECKED +// let rec checkInvariant (t:SetTree<'T>) = +// // A good sanity check, loss of balance can hit perf +// if isEmpty t then true +// else +// match t with +// | :? SetTreeNode<'T> as tn -> +// let h1 = height tn.Left +// let h2 = height tn.Right +// (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant tn.Left && checkInvariant tn.Right +// | _ -> true +// #endif + + [] + let private tolerance = 2 + + let mk l k r : SetTree<'T> = + let hl = height l + let hr = height r + let m = if hl < hr then hr else hl + if m = 0 then // m=0 ~ isEmpty l && isEmpty r + SetTree k + else + SetTreeNode (k, l, r, m+1) :> SetTree<'T> + + let inline private asNode(value:SetTree<'T>) : SetTreeNode<'T> = + value :?> SetTreeNode<'T> + + let rebalance t1 v t2 = let t1h = height t1 let t2h = height t2 if t2h > t1h + tolerance then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - if height t2l > t1h + 1 then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) - | _ -> failwith "rebalance" - else // rotate left - mk (mk t1 k t2l) t2k t2r - | _ -> failwith "rebalance" + let t2' = asNode(t2) + // one of the nodes must have height > height t1 + 1 + if height t2'.Left > t1h + 1 then // balance left: combination + let t2l = asNode(t2'.Left) + mk (mk t1 v t2l.Left) t2l.Key (mk t2l.Right t2'.Key t2'.Right) + else // rotate left + mk (mk t1 v t2'.Left) t2.Key t2'.Right else if t1h > t2h + tolerance then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - if height t1r > t2h + 1 then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - mk (mk t1l t1k t1rl) t1rk (mk t1rr k t2) - | _ -> failwith "rebalance" - else - mk t1l t1k (mk t1r k t2) - | _ -> failwith "rebalance" - else mk t1 k t2 - - let rec add (comparer: IComparer<'T>) k t = - match t with - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k l) k2 r - elif c = 0 then t - else rebalance l k2 (add comparer k r) - | SetOne(k2) -> - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k,k2) - if c < 0 then SetNode (k,SetEmpty,t,2) - elif c = 0 then t - else SetNode (k,t,SetEmpty,2) - | SetEmpty -> SetOne(k) - - let rec balance comparer t1 k t2 = + let t1' = asNode(t1) + // one of the nodes must have height > height t2 + 1 + if height t1'.Right > t2h + 1 then + // balance right: combination + let t1r = asNode(t1'.Right) + mk (mk t1'.Left t1.Key t1r.Left) t1r.Key (mk t1r.Right v t2) + else + mk t1'.Left t1'.Key (mk t1'.Right v t2) + else mk t1 v t2 + + let rec add (comparer: IComparer<'T>) k (t:SetTree<'T>) : SetTree<'T> = + if isEmpty t then SetTree k + else + let c = comparer.Compare(k, t.Key) + match t with + | :? SetTreeNode<'T> as tn -> + if c < 0 then rebalance (add comparer k tn.Left) tn.Key tn.Right + elif c = 0 then t + else rebalance tn.Left tn.Key (add comparer k tn.Right) + | _ -> + // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated + let c = comparer.Compare(k, t.Key) + if c < 0 then SetTreeNode (k, empty, t, 2) :> SetTree<'T> + elif c = 0 then t + else SetTreeNode (k, t, empty, 2) :> SetTree<'T> + + let rec balance comparer (t1:SetTree<'T>) k (t2:SetTree<'T>) = // Given t1 < k < t2 where t1 and t2 are "balanced", - // return a balanced tree for . + // return a balanced tree for . // Recall: balance means subtrees heights differ by at most "tolerance" - match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> - // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) - // Either (a) h1,h2 differ by at most 2 - no rebalance needed. - // (b) h1 too small, i.e. h1+2 < h2 - // (c) h2 too small, i.e. h2+2 < h1 - if h1+tolerance < h2 then - // case: b, h1 too small - // push t1 into low side of t2, may increase height by 1 so rebalance - rebalance (balance comparer t1 k t21) k2 t22 - elif h2+tolerance < h1 then - // case: c, h2 too small - // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t11 k1 (balance comparer t12 k t2) - else - // case: a, h1 and h2 meet balance requirement - mk t1 k t2 + if isEmpty t1 then add comparer k t2 // drop t1 = empty + elif isEmpty t2 then add comparer k t1 // drop t2 = empty + else + match t1 with + | :? SetTreeNode<'T> as t1n -> + match t2 with + | :? SetTreeNode<'T> as t2n -> + // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) + // Either (a) h1, h2 differ by at most 2 - no rebalance needed. + // (b) h1 too small, i.e. h1+2 < h2 + // (c) h2 too small, i.e. h2+2 < h1 + if t1n.Height + tolerance < t2n.Height then + // case: b, h1 too small + // push t1 into low side of t2, may increase height by 1 so rebalance + rebalance (balance comparer t1 k t2n.Left) t2n.Key t2n.Right + elif t2n.Height + tolerance < t1n.Height then + // case: c, h2 too small + // push t2 into high side of t1, may increase height by 1 so rebalance + rebalance t1n.Left t1n.Key (balance comparer t1n.Right k t2) + else + // case: a, h1 and h2 meet balance requirement + mk t1 k t2 + | _ -> add comparer k (add comparer t2.Key t1) + | _ -> add comparer k (add comparer t1.Key t2) - let rec split (comparer : IComparer<'T>) pivot t = + let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'T>) = // Given a pivot and a set t - // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } - match t with - | SetNode(k1,t11,t12,_) -> - let c = comparer.Compare(pivot,k1) - if c < 0 then // pivot t1 - let t11Lo,havePivot,t11Hi = split comparer pivot t11 - t11Lo,havePivot,balance comparer t11Hi k1 t12 - elif c = 0 then // pivot is k1 - t11,true,t12 - else // pivot t2 - let t12Lo,havePivot,t12Hi = split comparer pivot t12 - balance comparer t11 k1 t12Lo,havePivot,t12Hi - | SetOne k1 -> - let c = comparer.Compare(k1,pivot) - if c < 0 then t ,false,SetEmpty // singleton under pivot - elif c = 0 then SetEmpty,true ,SetEmpty // singleton is pivot - else SetEmpty,false,t // singleton over pivot - | SetEmpty -> - SetEmpty,false,SetEmpty - - let rec spliceOutSuccessor t = - match t with - | SetEmpty -> failwith "internal error: Set.spliceOutSuccessor" - | SetOne (k2) -> k2,SetEmpty - | SetNode (k2,l,r,_) -> - match l with - | SetEmpty -> k2,r - | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' k2 r - - let rec remove (comparer: IComparer<'T>) k t = - match t with - | SetEmpty -> t - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then SetEmpty - else t - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 r - elif c = 0 then - match l,r with - | SetEmpty,_ -> r - | _,SetEmpty -> l - | _ -> - let sk,r' = spliceOutSuccessor r - mk l sk r' - else rebalance l k2 (remove comparer k r) - - let rec mem (comparer: IComparer<'T>) k t = - match t with - | SetNode(k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then mem comparer k l - elif c = 0 then true - else mem comparer k r - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) - | SetEmpty -> false - - let rec iter f t = - match t with - | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r - | SetOne(k2) -> f k2 - | SetEmpty -> () - - let rec foldBack f m x = - match m with - | SetNode(k,l,r,_) -> foldBack f l (f k (foldBack f r x)) - | SetOne(k) -> f k x - | SetEmpty -> x - - let rec fold f x m = - match m with - | SetNode(k,l,r,_) -> - let x = fold f x l in - let x = f x k - fold f x r - | SetOne(k) -> f x k - | SetEmpty -> x - - let rec forall f m = - match m with - | SetNode(k2,l,r,_) -> f k2 && forall f l && forall f r - | SetOne(k2) -> f k2 - | SetEmpty -> true - - let rec exists f m = - match m with - | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r - | SetOne(k2) -> f k2 - | SetEmpty -> false - - let isEmpty m = match m with | SetEmpty -> true | _ -> false - - let subset comparer a b = forall (fun x -> mem comparer x b) a - - let psubset comparer a b = forall (fun x -> mem comparer x b) a && exists (fun x -> not (mem comparer x a)) b - - let rec filterAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = if f k then add comparer k acc else acc - filterAux comparer f l (filterAux comparer f r acc) - | SetOne(k) -> if f k then add comparer k acc else acc - | SetEmpty -> acc - - let filter comparer f s = filterAux comparer f s SetEmpty - - let rec diffAux comparer m acc = - match m with - | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) - | SetOne(k) -> remove comparer k acc - | SetEmpty -> acc + // Return { x in t s.t. x < pivot }, pivot in t?, { x in t s.t. x > pivot } + if isEmpty t then empty, false, empty + else + match t with + | :? SetTreeNode<'T> as tn -> + let c = comparer.Compare(pivot, tn.Key) + if c < 0 then // pivot t1 + let t11Lo, havePivot, t11Hi = split comparer pivot tn.Left + t11Lo, havePivot, balance comparer t11Hi tn.Key tn.Right + elif c = 0 then // pivot is k1 + tn.Left, true, tn.Right + else // pivot t2 + let t12Lo, havePivot, t12Hi = split comparer pivot tn.Right + balance comparer tn.Left tn.Key t12Lo, havePivot, t12Hi + | _ -> + let c = comparer.Compare(t.Key, pivot) + if c < 0 then t, false, empty // singleton under pivot + elif c = 0 then empty, true, empty // singleton is pivot + else empty, false, t // singleton over pivot + + let rec spliceOutSuccessor (t:SetTree<'T>) = + if isEmpty t then failwith "internal error: Set.spliceOutSuccessor" + else + match t with + | :? SetTreeNode<'T> as tn -> + if isEmpty tn.Left then tn.Key, tn.Right + else let k3, l' = spliceOutSuccessor tn.Left in k3, mk l' tn.Key tn.Right + | _ -> t.Key, empty + + let rec remove (comparer: IComparer<'T>) k (t:SetTree<'T>) = + if isEmpty t then t + else + let c = comparer.Compare(k, t.Key) + match t with + | :? SetTreeNode<'T> as tn -> + if c < 0 then rebalance (remove comparer k tn.Left) tn.Key tn.Right + elif c = 0 then + if isEmpty tn.Left then tn.Right + elif isEmpty tn.Right then tn.Left + else + let sk, r' = spliceOutSuccessor tn.Right + mk tn.Left sk r' + else rebalance tn.Left tn.Key (remove comparer k tn.Right) + | _ -> + if c = 0 then empty + else t + + let rec mem (comparer: IComparer<'T>) k (t:SetTree<'T>) = + if isEmpty t then false + else + let c = comparer.Compare(k, t.Key) + match t with + | :? SetTreeNode<'T> as tn -> + if c < 0 then mem comparer k tn.Left + elif c = 0 then true + else mem comparer k tn.Right + | _ -> (c = 0) + + let rec iter f (t:SetTree<'T>) = + if isEmpty t then () + else + match t with + | :? SetTreeNode<'T> as tn -> iter f tn.Left; f tn.Key; iter f tn.Right + | _ -> f t.Key + + let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) (t:SetTree<'T>) x = + if isEmpty t then x + else + match t with + | :? SetTreeNode<'T> as tn -> foldBackOpt f tn.Left (f.Invoke(tn.Key, (foldBackOpt f tn.Right x))) + | _ -> f.Invoke(t.Key, x) + + let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m x + + let rec foldOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) x (t:SetTree<'T>) = + if isEmpty t then x + else + match t with + | :? SetTreeNode<'T> as tn -> + let x = foldOpt f x tn.Left in + let x = f.Invoke(x, tn.Key) + foldOpt f x tn.Right + | _ -> f.Invoke(x, t.Key) + + let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) x m + + let rec forall f (t:SetTree<'T>) = + if isEmpty t then true + else + match t with + | :? SetTreeNode<'T> as tn -> f tn.Key && forall f tn.Left && forall f tn.Right + | _ -> f t.Key + + let rec exists f (t:SetTree<'T>) = + if isEmpty t then false + else + match t with + | :? SetTreeNode<'T> as tn -> f tn.Key || exists f tn.Left || exists f tn.Right + | _ -> f t.Key + + let subset comparer a b = + forall (fun x -> mem comparer x b) a + + let properSubset comparer a b = + forall (fun x -> mem comparer x b) a && exists (fun x -> not (mem comparer x a)) b + + let rec filterAux comparer f (t:SetTree<'T>) acc = + if isEmpty t then acc + else + match t with + | :? SetTreeNode<'T> as tn -> + let acc = if f tn.Key then add comparer tn.Key acc else acc + filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) + | _ -> if f t.Key then add comparer t.Key acc else acc + + let filter comparer f s = filterAux comparer f s empty + + let rec diffAux comparer (t:SetTree<'T>) acc = + if isEmpty acc then acc + else + if isEmpty t then acc + else + match t with + | :? SetTreeNode<'T> as tn -> diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) + | _ -> remove comparer t.Key acc let diff comparer a b = diffAux comparer b a - let rec union comparer t1 t2 = + let rec union comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = // Perf: tried bruteForce for low heights, but nothing significant - match t1,t2 with - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) - // Divide and Quonquer: - // Suppose t1 is largest. - // Split t2 using pivot k1 into lo and hi. - // Union disjoint subproblems and then combine. - if h1 > h2 then - let lo,_,hi = split comparer k1 t2 in - balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) - else - let lo,_,hi = split comparer k2 t1 in - balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) - | SetEmpty,t -> t - | t,SetEmpty -> t - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 - - let rec intersectionAux comparer b m acc = - match m with - | SetNode(k,l,r,_) -> - let acc = intersectionAux comparer b r acc - let acc = if mem comparer k b then add comparer k acc else acc - intersectionAux comparer b l acc - | SetOne(k) -> - if mem comparer k b then add comparer k acc else acc - | SetEmpty -> acc - - let intersection comparer a b = intersectionAux comparer b a SetEmpty - - let partition1 comparer f k (acc1,acc2) = if f k then (add comparer k acc1,acc2) else (acc1,add comparer k acc2) - - let rec partitionAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k acc - partitionAux comparer f l acc - | SetOne(k) -> partition1 comparer f k acc - | SetEmpty -> acc - - let partition comparer f (s:SetTree<'a>) = - let seed = SetTree<'a>.SetEmpty, SetTree<'a>.SetEmpty - partitionAux comparer f s seed - - // It's easier to get many less-important algorithms right using this active pattern - let (|MatchSetNode|MatchSetEmpty|) s = - match s with - | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) - | SetEmpty -> MatchSetEmpty - - let rec minimumElementAux s n = - match s with - | SetNode(k,l,_,_) -> minimumElementAux l k - | SetOne(k) -> k - | SetEmpty -> n - - and minimumElementOpt s = - match s with - | SetNode(k,l,_,_) -> Some(minimumElementAux l k) - | SetOne(k) -> Some k - | SetEmpty -> None - - and maximumElementAux s n = - match s with - | SetNode(k,_,r,_) -> maximumElementAux r k - | SetOne(k) -> k - | SetEmpty -> n - - and maximumElementOpt s = - match s with - | SetNode(k,_,r,_) -> Some(maximumElementAux r k) - | SetOne(k) -> Some(k) - | SetEmpty -> None + if isEmpty t1 then t2 + elif isEmpty t2 then t1 + else + match t1 with + | :? SetTreeNode<'T> as t1n -> + match t2 with + | :? SetTreeNode<'T> as t2n -> // (t1l < k < t1r) AND (t2l < k2 < t2r) + // Divide and Conquer: + // Suppose t1 is largest. + // Split t2 using pivot k1 into lo and hi. + // Union disjoint subproblems and then combine. + if t1n.Height > t2n.Height then + let lo, _, hi = split comparer t1n.Key t2 in + balance comparer (union comparer t1n.Left lo) t1n.Key (union comparer t1n.Right hi) + else + let lo, _, hi = split comparer t2n.Key t1 in + balance comparer (union comparer t2n.Left lo) t2n.Key (union comparer t2n.Right hi) + | _ -> add comparer t2.Key t1 + | _ -> add comparer t1.Key t2 + + let rec intersectionAux comparer b (t:SetTree<'T>) acc = + if isEmpty t then acc + else + match t with + | :? SetTreeNode<'T> as tn -> + let acc = intersectionAux comparer b tn.Right acc + let acc = if mem comparer tn.Key b then add comparer tn.Key acc else acc + intersectionAux comparer b tn.Left acc + | _ -> + if mem comparer t.Key b then add comparer t.Key acc else acc + + let intersection comparer a b = intersectionAux comparer b a empty + + let partition1 comparer f k (acc1, acc2) = if f k then (add comparer k acc1, acc2) else (acc1, add comparer k acc2) + + let rec partitionAux comparer f (t:SetTree<'T>) acc = + if isEmpty t then acc + else + match t with + | :? SetTreeNode<'T> as tn -> + let acc = partitionAux comparer f tn.Right acc + let acc = partition1 comparer f tn.Key acc + partitionAux comparer f tn.Left acc + | _ -> partition1 comparer f t.Key acc + + let partition comparer f s = partitionAux comparer f s (empty, empty) + + let rec minimumElementAux (t:SetTree<'T>) n = + if isEmpty t then n + else + match t with + | :? SetTreeNode<'T> as tn -> minimumElementAux tn.Left tn.Key + | _ -> t.Key + + and minimumElementOpt (t:SetTree<'T>) = + if isEmpty t then None + else + match t with + | :? SetTreeNode<'T> as tn -> Some(minimumElementAux tn.Left tn.Key) + | _ -> Some t.Key + + and maximumElementAux (t:SetTree<'T>) n = + if isEmpty t then n + else + match t with + | :? SetTreeNode<'T> as tn -> maximumElementAux tn.Right tn.Key + | _ -> t.Key + + and maximumElementOpt (t:SetTree<'T>) = + if isEmpty t then None + else + match t with + | :? SetTreeNode<'T> as tn -> Some(maximumElementAux tn.Right tn.Key) + | _ -> Some t.Key let minimumElement s = match minimumElementOpt s with - | Some(k) -> k + | Some k -> k | None -> failwith "Set contains no elements" let maximumElement s = match maximumElementOpt s with - | Some(k) -> k + | Some k -> k | None -> failwith "Set contains no elements" - - //-------------------------------------------------------------------------- // Imperative left-to-right iterators. - //-------------------------------------------------------------------------- - [] - type SetIterator<'T> when 'T : comparison = { - mutable stack: SetTree<'T> list; // invariant: always collapseLHS result - mutable started : bool // true when MoveNext has been called - } + type SetIterator<'T> when 'T: comparison = + { mutable stack: SetTree<'T> list; // invariant: always collapseLHS result + mutable started: bool // true when MoveNext has been called + } // collapseLHS: // a) Always returns either [] or a list starting with SetOne. // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = + let rec collapseLHS (stack: SetTree<'T> list) = match stack with - | [] -> [] - | SetEmpty :: rest -> collapseLHS rest - | SetOne _ :: _ -> stack - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) + | [] -> [] + | x :: rest -> + if isEmpty x then collapseLHS rest + else + match x with + | :? SetTreeNode<'T> as xn-> collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) + | _ -> stack let mkIterator s = { stack = collapseLHS [s]; started = false } let notStarted() = failwith "Enumeration not started" + let alreadyFinished() = failwith "Enumeration already started" let current i = if i.started then match i.stack with - | SetOne k :: _ -> k - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Set iterator, unexpected stack for current" + | k :: _ -> k.Key + | [] -> alreadyFinished() else notStarted() let rec moveNext i = if i.started then match i.stack with - | SetOne _ :: rest -> - i.stack <- collapseLHS rest; - not i.stack.IsEmpty | [] -> false - | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" + | t :: rest -> + match t with + | :? SetTreeNode<'T> -> failwith "Please report error: Set iterator, unexpected stack for moveNext" + | _ -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty else - i.started <- true; // The first call to MoveNext "starts" the enumeration. + i.started <- true; // The first call to MoveNext "starts" the enumeration. not i.stack.IsEmpty - type mkIEnumerator<'a when 'a : comparison>(s) = - let mutable i = mkIterator s - interface IEnumerator<'a> with - member __.Current = current i - interface IEnumerator with - member __.Current = box (current i) - member __.MoveNext() = moveNext i - member __.Reset() = i <- mkIterator s - interface System.IDisposable with - member __.Dispose() = () - let mkIEnumerator s = - new mkIEnumerator<_>(s) :> IEnumerator<_> - - let toSeq s = - let en = mkIEnumerator s - en |> Seq.unfold (fun en -> - if en.MoveNext() - then Some(en.Current, en) - else None) - - //-------------------------------------------------------------------------- - // Set comparison. This can be expensive. - //-------------------------------------------------------------------------- - - let rec compareStacks (comparer: IComparer<'T>) l1 l2 = - match l1,l2 with - | [],[] -> 0 - | [],_ -> -1 - | _ ,[] -> 1 - | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (SetEmpty :: t1) (n2r :: t2) - | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) - | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (SetEmpty :: SetOne(n1k) :: t1) l2 - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,SetEmpty,n1r,0) :: t1) l2 - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (SetEmpty :: SetOne(n2k) :: t2) - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,SetEmpty,n2r,0) :: t2) - - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] - - let choose s = minimumElement s - - let rec loop m acc = - match m with - | SetNode(k,l,r,_) -> loop l (k :: loop r acc) - | SetOne(k) -> k ::acc - | SetEmpty -> acc - - let toList s = - loop s [] + let mutable i = mkIterator s + { new IEnumerator<_> with + member __.Current = current i + interface IEnumerator with + member __.Current = box (current i) + member __.MoveNext() = moveNext i + member __.Reset() = i <- mkIterator s + interface System.IDisposable with + member __.Dispose() = () } + + /// Set comparison. Note this can be expensive. + let rec compareStacks (comparer: IComparer<'T>) (l1:SetTree<'T> list) (l2:SetTree<'T> list) : int = + let cont() = + match l1, l2 with + | (x1 :: t1), _ when not (isEmpty x1) -> + match x1 with + | :? SetTreeNode<'T> as x1n -> + compareStacks comparer (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 + | _ -> compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 + | _, (x2 :: t2) when not (isEmpty x2) -> + match x2 with + | :? SetTreeNode<'T> as x2n -> + compareStacks comparer l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) + | _ -> compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) + | _ -> failwith "unexpected state in SetTree.compareStacks" + + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | (x1 :: t1), (x2 :: t2) -> + if isEmpty x1 then + if isEmpty x2 then compareStacks comparer t1 t2 + else cont() + elif isEmpty x2 then cont() + else + match x1 with + | :? SetTreeNode<'T> as x1n -> + if isEmpty x1n.Left then + match x2 with + | :? SetTreeNode<'T> as x2n -> + if isEmpty x2n.Left then + let c = comparer.Compare(x1n.Key, x2n.Key) + if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) + else cont() + | _ -> + let c = comparer.Compare(x1n.Key, x2.Key) + if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) + else cont() + | _ -> + match x2 with + | :? SetTreeNode<'T> as x2n -> + if isEmpty x2n.Left then + let c = comparer.Compare(x1.Key, x2n.Key) + if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) + else cont() + | _ -> + let c = comparer.Compare(x1.Key, x2.Key) + if c <> 0 then c else compareStacks comparer t1 t2 + + let compare comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + if isEmpty t1 then + if isEmpty t2 then 0 + else -1 + else + if isEmpty t2 then 1 + else compareStacks comparer [t1] [t2] + + let choose s = + minimumElement s + + let toList (t:SetTree<'T>) = + let rec loop (t':SetTree<'T>) acc = + if isEmpty t' then acc + else + match t' with + | :? SetTreeNode<'T> as tn -> loop tn.Left (tn.Key :: loop tn.Right acc) + | _ -> t'.Key :: acc + loop t [] let copyToArray s (arr: _[]) i = let mutable j = i iter (fun x -> arr.[j] <- x; j <- j + 1) s - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = + let toArray s = + let n = (count s) + let res = Array.Helpers.allocateArray n + copyToArray s res 0 + res + + let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = if e.MoveNext() then mkFromEnumerator comparer (add comparer e.Current acc) e else acc - let ofSeq comparer (c : IEnumerable<_>) = + let ofSeq comparer (c: IEnumerable<_>) = use ie = c.GetEnumerator() - mkFromEnumerator comparer SetEmpty ie - - let ofArray comparer (arr: _[]) = - let mutable acc = SetEmpty - for i = 0 to arr.Length - 1 do - acc <- add comparer arr.[i] acc - acc - -[] -type Set<[]'T when 'T : comparison>(comparer:IComparer<'T>, tree: SetTree<'T>) = - member internal __.Comparer = comparer - member internal __.Tree : SetTree<'T> = tree - - member s.Add(x) : Set<'T> = - new Set<'T>(s.Comparer, SetTree.add s.Comparer x s.Tree) - - member s.Remove(x) : Set<'T> = - new Set<'T>(s.Comparer, SetTree.remove s.Comparer x s.Tree) - - member s.Count = SetTree.count s.Tree - - member s.Contains(x) = SetTree.mem s.Comparer x s.Tree - - member s.Iterate(x) = SetTree.iter x s.Tree - - member s.Fold f z = SetTree.fold (fun x z -> f z x) z s.Tree - - member s.IsEmpty = SetTree.isEmpty s.Tree - - member s.Partition f : Set<'T> * Set<'T> = - match s.Tree with - | SetEmpty -> s,s - | _ -> let t1,t2 = SetTree.partition s.Comparer f s.Tree in new Set<_>(s.Comparer,t1), new Set<_>(s.Comparer,t2) + mkFromEnumerator comparer empty ie + + let ofArray comparer l = + Array.fold (fun acc k -> add comparer k acc) empty l + +[] +[] +[] +// [] +// [>)>] +// [] +// [] +type Set<[]'T when 'T: comparison >(comparer:IComparer<'T>, tree: SetTree<'T>) = + + // [] + // NOTE: This type is logically immutable. This field is only mutated during deserialization. + // let mutable comparer = comparer + + // [] + // NOTE: This type is logically immutable. This field is only mutated during deserialization. + // let mutable tree = tree + + // NOTE: This type is logically immutable. This field is only mutated during serialization and deserialization. + // WARNING: The compiled name of this field may never be changed because it is part of the logical + // WARNING: permanent serialization format for this type. + // let mutable serializedData = null + + // 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). + + // [] + // member __.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = + // ignore context + // serializedData <- SetTree.toArray tree + + // Do not set this to null, since concurrent threads may also be serializing the data + //[] + //member __.OnSerialized(context: System.Runtime.Serialization.StreamingContext) = + // serializedData <- null + + // [] + // member __.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = + // ignore context + // comparer <- LanguagePrimitives.FastGenericComparer<'T> + // tree <- SetTree.ofArray comparer serializedData + // serializedData <- null + + // [] + member internal set.Comparer = comparer + + member internal set.Tree: SetTree<'T> = tree + + // [] + static member Empty comparer: Set<'T> = + Set<'T>(comparer, SetTree.empty) + + member s.Add value: Set<'T> = +// #if TRACE_SETS_AND_MAPS +// SetTree.report() +// SetTree.numAdds <- SetTree.numAdds + 1 +// SetTree.totalSizeOnSetAdd <- SetTree.totalSizeOnSetAdd + float (SetTree.count s.Tree) +// #endif + Set<'T>(s.Comparer, SetTree.add s.Comparer value s.Tree ) + + member s.Remove value: Set<'T> = +// #if TRACE_SETS_AND_MAPS +// SetTree.report() +// SetTree.numRemoves <- SetTree.numRemoves + 1 +// #endif + Set<'T>(s.Comparer, SetTree.remove s.Comparer value s.Tree) + + member s.Count = + SetTree.count s.Tree + + member s.Contains value = +// #if TRACE_SETS_AND_MAPS +// SetTree.report() +// SetTree.numLookups <- SetTree.numLookups + 1 +// SetTree.totalSizeOnSetLookup <- SetTree.totalSizeOnSetLookup + float (SetTree.count s.Tree) +// #endif + SetTree.mem s.Comparer value s.Tree + + member s.Iterate x = + SetTree.iter x s.Tree + + member s.Fold f z = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f + SetTree.fold (fun x z -> f.Invoke(z, x)) z s.Tree + + // [] + member s.IsEmpty = + SetTree.isEmpty s.Tree + + member s.Partition f : Set<'T> * Set<'T> = + if SetTree.isEmpty s.Tree then s,s + else + let t1, t2 = SetTree.partition s.Comparer f s.Tree in Set(s.Comparer, t1), Set(s.Comparer, t2) member s.Filter f : Set<'T> = - match s.Tree with - | SetEmpty -> s - | _ -> new Set<_>(s.Comparer, SetTree.filter s.Comparer f s.Tree) + if SetTree.isEmpty s.Tree then s + else + Set(s.Comparer, SetTree.filter s.Comparer f s.Tree) - member s.Map(f, [] comparer: IComparer<'U>): Set<'U> = - new Set<_>(comparer, SetTree.fold (fun acc k -> SetTree.add comparer (f k) acc) (SetTree<_>.SetEmpty) s.Tree) + member s.Map(f, [] comparer: IComparer<'U>) : Set<'U> = + Set(comparer, SetTree.fold (fun acc k -> SetTree.add comparer (f k) acc) (SetTree.empty) s.Tree) - member s.Exists f = SetTree.exists f s.Tree + member s.Exists f = + SetTree.exists f s.Tree - member s.ForAll f = SetTree.forall f s.Tree + member s.ForAll f = + SetTree.forall f s.Tree - [] + [] [] - static member (-) (a: Set<'T>, b: Set<'T>) = - match a.Tree with - | SetEmpty -> a (* 0 - B = 0 *) - | _ -> - match b.Tree with - | SetEmpty -> a (* A - 0 = A *) - | _ -> new Set<_>(a.Comparer, SetTree.diff a.Comparer a.Tree b.Tree) - - [] + static member (-) (set1: Set<'T>, set2: Set<'T>) = + if SetTree.isEmpty set1.Tree then set1 (* 0 - B = 0 *) + else + if SetTree.isEmpty set2.Tree then set1 (* A - 0 = A *) + else Set(set1.Comparer, SetTree.diff set1.Comparer set1.Tree set2.Tree) + + [] [] - static member (+) (a: Set<'T>, b: Set<'T>) = - match b.Tree with - | SetEmpty -> a (* A U 0 = A *) - | _ -> - match a.Tree with - | SetEmpty -> b (* 0 U B = B *) - | _ -> new Set<_>(a.Comparer, SetTree.union a.Comparer a.Tree b.Tree) + static member (+) (set1: Set<'T>, set2: Set<'T>) = +// #if TRACE_SETS_AND_MAPS +// SetTree.report() +// SetTree.numUnions <- SetTree.numUnions + 1 +// #endif + if SetTree.isEmpty set2.Tree then set1 (* A U 0 = A *) + else + if SetTree.isEmpty set1.Tree then set2 (* 0 U B = B *) + else Set(set1.Comparer, SetTree.union set1.Comparer set1.Tree set2.Tree) static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = - match b.Tree with - | SetEmpty -> b (* A INTER 0 = 0 *) - | _ -> - match a.Tree with - | SetEmpty -> a (* 0 INTER B = 0 *) - | _ -> new Set<_>(a.Comparer,SetTree.intersection a.Comparer a.Tree b.Tree) + if SetTree.isEmpty b.Tree then b (* A INTER 0 = 0 *) + else + if SetTree.isEmpty a.Tree then a (* 0 INTER B = 0 *) + else Set(a.Comparer, SetTree.intersection a.Comparer a.Tree b.Tree) - static member IntersectionMany(sets:seq>) : Set<'T> = - Seq.reduce (fun s1 s2 -> Set<_>.Intersection(s1,s2)) sets + // static member Union(sets:seq>) : Set<'T> = + // Seq.fold (fun s1 s2 -> s1 + s2) Set<'T>.Empty sets - static member Equality(a: Set<'T>, b: Set<'T>) = (SetTree.compare a.Comparer a.Tree b.Tree = 0) + static member Intersection(sets:seq>) : Set<'T> = + Seq.reduce (fun s1 s2 -> Set.Intersection(s1, s2)) sets - static member Compare(a: Set<'T>, b: Set<'T>) = SetTree.compare a.Comparer a.Tree b.Tree + static member Equality(a: Set<'T>, b: Set<'T>) = + (SetTree.compare a.Comparer a.Tree b.Tree = 0) + static member Compare(a: Set<'T>, b: Set<'T>) = + SetTree.compare a.Comparer a.Tree b.Tree + + // [] member x.Choose = SetTree.choose x.Tree + // [] member x.MinimumElement = SetTree.minimumElement x.Tree + // [] member x.MaximumElement = SetTree.maximumElement x.Tree - member x.IsSubsetOf(y: Set<'T>) = SetTree.subset x.Comparer x.Tree y.Tree - member x.IsSupersetOf(y: Set<'T>) = SetTree.subset x.Comparer y.Tree x.Tree - member x.IsProperSubsetOf(y: Set<'T>) = SetTree.psubset x.Comparer x.Tree y.Tree - member x.IsProperSupersetOf(y: Set<'T>) = SetTree.psubset x.Comparer y.Tree x.Tree - // member x.ToList () = SetTree.toList x.Tree - // member x.ToArray () = SetTree.toArray x.Tree + member x.IsSubsetOf(otherSet: Set<'T>) = + SetTree.subset x.Comparer x.Tree otherSet.Tree - override this.ToString() = - "set [" + (Seq.map (fun x -> x.ToString()) this |> String.concat "; ") + "]" + member x.IsSupersetOf(otherSet: Set<'T>) = + SetTree.subset x.Comparer otherSet.Tree x.Tree + + member x.IsProperSubsetOf(otherSet: Set<'T>) = + SetTree.properSubset x.Comparer x.Tree otherSet.Tree + + member x.IsProperSupersetOf(otherSet: Set<'T>) = + SetTree.properSubset x.Comparer otherSet.Tree x.Tree - override this.GetHashCode() = + member x.ToList () = SetTree.toList x.Tree + + member x.ToArray () = SetTree.toArray x.Tree + + member this.ComputeHashCode() = let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 - let e = SetTree.mkIEnumerator this.Tree - while e.MoveNext() do - res <- combineHash res (hash e.Current) + for x in this do + res <- combineHash res (hash x) abs res - override this.Equals(that: obj) = - SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) = 0 + override this.GetHashCode() = this.ComputeHashCode() + + override this.Equals that = + match that with + | :? Set<'T> 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 || ((e1.Current = e2.Current) && loop())) + loop() + | _ -> false interface System.IComparable with member this.CompareTo(that: obj) = SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) + // interface ICollection<'T> with + // member s.Add x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) + + // member s.Clear() = raise (new System.NotSupportedException("ReadOnlyCollection")) + + // member s.Remove x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) + + // member s.Contains x = SetTree.mem s.Comparer x s.Tree + + // member s.CopyTo(arr, i) = SetTree.copyToArray s.Tree arr i + + // member s.IsReadOnly = true + + // member s.Count = s.Count + + // interface IReadOnlyCollection<'T> with + // member s.Count = s.Count + interface IEnumerable<'T> with member s.GetEnumerator() = SetTree.mkIEnumerator s.Tree interface IEnumerable with override s.GetEnumerator() = (SetTree.mkIEnumerator s.Tree :> IEnumerator) -let isEmpty (s: Set<'T>) = s.IsEmpty + // new (elements : seq<'T>) = + // let comparer = LanguagePrimitives.FastGenericComparer<'T> + // Set(comparer, SetTree.ofSeq comparer elements) -let contains x (s: Set<'T>) = s.Contains(x) + // static member Create(elements : seq<'T>) = Set<'T>(elements) -let add x (s: Set<'T>) = s.Add(x) + // static member FromArray(arr : 'T array) : Set<'T> = + // let comparer = LanguagePrimitives.FastGenericComparer<'T> + // Set(comparer, SetTree.ofArray comparer arr) -let singleton (x: 'T) ([] comparer: IComparer<'T>) : Set<'T> = - new Set<'T>(comparer, SetOne x) + override this.ToString() = + "set [" + (Seq.map (fun x -> x.ToString()) this |> String.concat "; ") + "]" -let remove x (s: Set<'T>) = s.Remove(x) -let union (s1: Set<'T>) (s2: Set<'T>) = s1 + s2 +// [] +// [] +// module Set = -let unionMany (sets: seq>) ([] comparer: IComparer<'T>) : Set<'T> = - Seq.fold (( + )) (new Set<_>(comparer, SetEmpty)) sets +// [] +let isEmpty (set: Set<'T>) = set.IsEmpty -let intersect (s1: Set<'T>) (s2: Set<'T>) = Set<'T>.Intersection(s1,s2) +// [] +let contains element (set: Set<'T>) = set.Contains element -let intersectMany sets = Set<_>.IntersectionMany(sets) +// [] +let add value (set: Set<'T>) = set.Add value -let iterate f (s : Set<'T>) = s.Iterate(f) +// [] +let singleton (value: 'T) ([] comparer: IComparer<'T>) : Set<'T> = + Set<'T>.Empty(comparer).Add value -let empty<'T when 'T : comparison> ([] comparer: IComparer<'T>) : Set<'T> = - new Set<'T>(comparer, SetEmpty) +// [] +let remove value (set: Set<'T>) = set.Remove value -let forAll f (s: Set<'T>) = s.ForAll f +// [] +let union (set1: Set<'T>) (set2: Set<'T>) = set1 + set2 -let exists f (s: Set<'T>) = s.Exists f +// [] +let unionMany (sets: seq>) ([] comparer: IComparer<'T>) = + Seq.fold (fun s1 s2 -> s1 + s2) (Set<'T>.Empty comparer) sets -let filter f (s: Set<'T>) = s.Filter f +// [] +let intersect (set1: Set<'T>) (set2: Set<'T>) = Set<'T>.Intersection(set1, set2) -let partition f (s: Set<'T>) = s.Partition f +// [] +let intersectMany (sets: seq>) = Set.Intersection sets -let fold<'T,'State when 'T : comparison> f (z: 'State) (s: Set<'T>) = SetTree.fold f z s.Tree +// [] +let iterate action (set: Set<'T>) = set.Iterate action -let foldBack<'T,'State when 'T : comparison> f (s: Set<'T>) (z:'State) = SetTree.foldBack f s.Tree z +// [] +let empty<'T when 'T : comparison> ([] comparer: IComparer<'T>): Set<'T> = Set<'T>.Empty comparer -let map f (s: Set<'T>) ([] comparer: IComparer<'U>): Set<'U> = s.Map(f, comparer) +// [] +let forAll predicate (set: Set<'T>) = set.ForAll predicate -let count (s: Set<'T>) = s.Count +// [] +let exists predicate (set: Set<'T>) = set.Exists predicate -let minimumElement (s: Set<'T>) = s.MinimumElement +// [] +let filter predicate (set: Set<'T>) = set.Filter predicate -let maximumElement (s: Set<'T>) = s.MaximumElement +// [] +let partition predicate (set: Set<'T>) = set.Partition predicate -let ofList (li: 'T list) ([] comparer: IComparer<'T>) : Set<'T> = - new Set<_>(comparer, SetTree.ofSeq comparer li) +// [] +let fold<'T, 'State when 'T : comparison> folder (state:'State) (set: Set<'T>) = SetTree.fold folder state set.Tree -let ofArray (arr: 'T array) ([] comparer: IComparer<'T>) : Set<'T> = - new Set<_>(comparer, SetTree.ofArray comparer arr) +// [] +let foldBack<'T, 'State when 'T : comparison> folder (set: Set<'T>) (state:'State) = SetTree.foldBack folder set.Tree state -let toList (s: Set<'T>) = SetTree.toList s.Tree +// [] +let map mapping (set: Set<'T>) ([] comparer: IComparer<'U>) = set.Map(mapping, comparer) -let toArray (s: Set<'T>) = - let res = Array.Helpers.allocateArray (count s) - SetTree.copyToArray s.Tree res 0 - res +// [] +let count (set: Set<'T>) = set.Count -let toSeq (s: Set<'T>) = - SetTree.toSeq s.Tree +// [] +let ofList elements ([] comparer: IComparer<'T>) = + Set(comparer, SetTree.ofSeq comparer elements) -let ofSeq (elements: seq<'T>) ([] comparer: IComparer<'T>) = - new Set<_>(comparer, SetTree.ofSeq comparer elements) +// [] +let ofArray (array: 'T array) ([] comparer: IComparer<'T>) = + Set(comparer, SetTree.ofArray comparer array) -let difference (x: Set<'T>) (y: Set<'T>) = x - y +// [] +let toList (set: Set<'T>) = set.ToList() -let isSubset (x: Set<'T>) (y: Set<'T>) = x.IsSubsetOf(y) +// [] +let toArray (set: Set<'T>) = set.ToArray() -let isSuperset (x: Set<'T>) (y: Set<'T>) = x.IsSupersetOf(y) +// [] +let toSeq (set: Set<'T>) = (set:> seq<'T>) -let isProperSubset (x: Set<'T>) (y: Set<'T>) = x.IsProperSubsetOf(y) +// [] +let ofSeq (elements: seq<_>) ([] comparer: IComparer<'T>) = + Set(comparer, SetTree.ofSeq comparer elements) -let isProperSuperset (x: Set<'T>) (y: Set<'T>) = x.IsProperSupersetOf(y) +// [] +let difference (set1: Set<'T>) (set2: Set<'T>) = set1 - set2 -let minElement (s: Set<'T>) = s.MinimumElement +// [] +let isSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set1.Tree set2.Tree -let maxElement (s: Set<'T>) = s.MaximumElement +// [] +let isSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set2.Tree set1.Tree -// let create (l: seq<'T>) = Set<_>.Create(l) +// [] +let isProperSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set1.Tree set2.Tree -/// Fable uses JS Set to represent .NET HashSet. However when keys are non-primitive, -/// we need to disguise an F# set as a mutable set. Thus, this interface matches JS Set prototype. -/// See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Set +// [] +let isProperSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set2.Tree set1.Tree -// type IMutableSet<'T> = -// inherit IEnumerable<'T> -// abstract size: int -// abstract add: 'T -> IMutableSet<'T> -// /// Convenience method (not in JS Set prototype) to check if the element has actually been added -// abstract add_: 'T -> bool -// abstract clear: unit -> unit -// abstract delete: 'T -> bool -// abstract has: 'T -> bool -// abstract keys: unit -> 'T seq -// abstract values: unit -> 'T seq -// abstract entries: unit -> ('T * 'T) seq +// [] +let minElement (set: Set<'T>) = set.MinimumElement -// let private createMutablePrivate (comparer: IComparer<'T>) tree' = -// let mutable tree = tree' -// { new IMutableSet<'T> with -// member __.size = SetTree.count tree -// member this.add x = -// tree <- SetTree.add comparer x tree -// this -// member __.add_ x = -// if SetTree.mem comparer x tree -// then false -// else tree <- SetTree.add comparer x tree; true -// member __.clear () = -// tree <- SetEmpty -// member __.delete x = -// if SetTree.mem comparer x tree -// then tree <- SetTree.remove comparer x tree; true -// else false -// member __.has x = -// SetTree.mem comparer x tree -// member __.keys () = -// SetTree.toSeq tree -// member __.values () = -// SetTree.toSeq tree -// member __.entries () = -// SetTree.toSeq tree |> Seq.map (fun v -> (v, v)) -// interface IEnumerable<_> with -// member __.GetEnumerator() = -// SetTree.mkIEnumerator tree -// interface IEnumerable with -// member __.GetEnumerator() = -// upcast SetTree.mkIEnumerator tree -// } +// [] +let maxElement (set: Set<'T>) = set.MaximumElement -/// Emulate JS Set with custom comparer for non-primitive values +let createMutable (source: seq<'T>) ([] comparer: IEqualityComparer<'T>) = + let set = Fable.Collections.MutableSet(source, comparer) + set :> Fable.Collections.IMutableSet<_> -// let createMutable (source: seq<'T>) ([] comparer: IComparer<'T>) = -// SetTree.ofSeq comparer source -// |> createMutablePrivate comparer - -let createMutable (source: seq<'T>) ([] comparer: IEqualityComparer<'T>) = - let set = MutableSet(source, comparer) - set :> IMutableSet<_> - -let distinct (xs: seq<'T>) ([] comparer: IEqualityComparer<'T>) = +let distinct (xs: seq<'T>) ([] comparer: IEqualityComparer<'T>) = seq { - let set = MutableSet(Seq.empty, comparer) + let set = Fable.Collections.MutableSet(Seq.empty, comparer) for x in xs do if set.Add(x) then yield x } -let distinctBy (projection: 'T -> 'Key) (xs: seq<'T>) ([] comparer: IEqualityComparer<'Key>) = +let distinctBy (projection: 'T -> 'Key) (xs: seq<'T>) ([] comparer: IEqualityComparer<'Key>) = seq { - let set = MutableSet(Seq.empty, comparer) + let set = Fable.Collections.MutableSet(Seq.empty, comparer) for x in xs do if set.Add(projection x) then yield x @@ -741,27 +905,27 @@ let distinctBy (projection: 'T -> 'Key) (xs: seq<'T>) ([] comparer: IEqu // Helpers to replicate HashSet methods -let unionWith (s1: IMutableSet<'T>) (s2: 'T seq) = +let unionWith (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) = (s1, s2) ||> Seq.fold (fun acc x -> acc.add x) -let intersectWith (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let intersectWith (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = let s2 = ofSeq s2 comparer for x in s1 do if not(s2.Contains x) then s1.delete x |> ignore -let exceptWith (s1: IMutableSet<'T>) (s2: 'T seq) = +let exceptWith (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) = for x in s2 do s1.delete x |> ignore -let isSubsetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isSubsetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isSubset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isSupersetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isSupersetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isSuperset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isProperSubsetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isProperSubsetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isProperSubset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isProperSupersetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isProperSupersetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isProperSuperset (ofSeq s1 comparer) (ofSeq s2 comparer)