From b2d408f40f3d520e574dba2dcdb8cacfa326e561 Mon Sep 17 00:00:00 2001 From: Alfonso Garcia-Caro Date: Wed, 30 Sep 2020 14:41:30 +0900 Subject: [PATCH] Revert Map and Set --- src/fable-library/Map.fs | 1232 ++++++++++++++-------------------- src/fable-library/Set.fs | 1350 +++++++++++++++++--------------------- 2 files changed, 1081 insertions(+), 1501 deletions(-) diff --git a/src/fable-library/Map.fs b/src/fable-library/Map.fs index 2d21dd7fa5..e66b41625b 100644 --- a/src/fable-library/Map.fs +++ b/src/fable-library/Map.fs @@ -1,450 +1,345 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +//---------------------------------------------------------------------------- +// 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 module Map +open System.Collections open System.Collections.Generic - -[] -[] -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 +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. [] +[] module MapTree = - let empty = null + let rec sizeAux acc m = + match m with + | MapEmpty -> acc + | MapOne _ -> acc + 1 + | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r - let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m + let size x = sizeAux 0 x - 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 empty = MapEmpty - let size x = sizeAux 0 x + let height = function + | MapEmpty -> 0 + | MapOne _ -> 1 + | MapNode(_,_,_,_,h) -> h -// #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 isEmpty m = + match m with + | MapEmpty -> true + | _ -> false - let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = - value :?> MapTreeNode<'Key,'Value> + 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 rebalance t1 (k: 'Key) (v: 'Value) t2 : MapTree<'Key, 'Value> = + let rebalance t1 k v t2 = let t1h = height t1 let t2h = height t2 - 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 + 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<'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 + if t2h > t1h + 2 then (* right is heavier than left *) + match t2 with + | MapNode(t2k,t2v,t2l,t2r,_) -> + (* one of the nodes must have height > height t1 + 1 *) + if height t2l > t1h + 1 then (* balance left: combination *) + match t2l with + | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> + mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) + | _ -> failwith "rebalance" + else (* rotate left *) + mk (mk t1 k v t2l) t2k t2v t2r + | _ -> failwith "rebalance" else - 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 + 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 - 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 + mk t1l t1k t1v (mk t1r k v t2) + | _ -> failwith "rebalance" + else mk t1 k v t2 - 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 + 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 | Some _ as res -> res | None -> - 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 + 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 = loop m [] - 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 ofList comparer l = Seq.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<'Key * 'Value>) = + let ofArray comparer (arr : array<_>) = let mutable res = empty - for (x, y) in arr do + for i = 0 to arr.Length - 1 do + let x,y = arr.[i] 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 m (arr: _[]) i = + let copyToArray s (arr: _[]) i = let mutable j = i - m |> iter (fun x y -> arr.[j] <- KeyValuePair(x, y); j <- j + 1) + s |> 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:MapTree<'Key, 'Value> list) = + let rec collapseLHS stack = match stack with - | [] -> [] - | 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 + | [] -> [] + | MapEmpty :: rest -> collapseLHS rest + | MapOne _ :: _ -> stack + | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) - let mkIterator m = - { stack = collapseLHS [m]; started = false } + let mkIterator s = { stack = collapseLHS [s]; started = false } let notStarted() = failwith "enumeration not started" @@ -453,40 +348,36 @@ module MapTree = let current i = if i.started then match i.stack with - | [] -> alreadyFinished() - | m :: _ -> - match m with - | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for current" - | _ -> new KeyValuePair<_, _>(m.Key, m.Value) + | MapOne (k,v) :: _ -> KeyValuePair<_,_>(k,v) + | [] -> alreadyFinished() + | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else notStarted() let rec moveNext i = if i.started then match i.stack with + | MapOne _ :: rest -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty | [] -> false - | 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 + | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" 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 - 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 + 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() = () - interface System.IDisposable with - member __.Dispose() = ()} + let mkIEnumerator s = new mkIEnumerator'<_,_>(s) :> _ IEnumerator let toSeq s = let en = mkIEnumerator s @@ -495,185 +386,90 @@ module MapTree = then Some(en.Current, en) else None) -[] -[] -[] -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 = +/// 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 = MapTree.foldBack f tree acc - member m.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = - MapTree.foldSection comparer lo hi f tree acc - - member m.Iterate f = - MapTree.iter f tree - - member m.MapRange (f:'Value->'Result) = - new Map<'Key, 'Result>(comparer, MapTree.map f tree) + member __.FoldSection (lo:'Key) (hi:'Key) f (acc:'z) = MapTree.foldSection comparer lo hi f tree acc - member m.Map f = - new Map<'Key, 'b>(comparer, MapTree.mapi f tree) + member __.Iterate f = MapTree.iter f tree - 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 __.MapRange f = new Map<'Key,'b>(comparer,MapTree.map f tree) - member m.Count = - MapTree.size tree + member __.Map f = new Map<'Key,'b>(comparer,MapTree.mapi f 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 __.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.Remove key = - new Map<'Key, 'Value>(comparer, MapTree.remove comparer key tree) + member __.Count = MapTree.size tree - [] - member __.TryGetValue(key: 'Key, value: 'Value ref) = - match MapTree.tryGetValue comparer key tree with - | true, v -> value := v; true - | false, _ -> false + member __.ContainsKey(k) = + MapTree.mem comparer k 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 + member __.Remove(k) : Map<'Key,'Value> = + new Map<'Key,'Value>(comparer,MapTree.remove comparer k tree) - member m.ToList() = - MapTree.toList tree + member __.TryFind(k) = + MapTree.tryFind comparer k tree - member m.ToArray() = - MapTree.toArray tree + member __.ToList() = MapTree.toList tree - static member ofList l : Map<'Key, 'Value> = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofList comparer l) + 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 this.ComputeHashCode() = + override this.GetHashCode() = let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 - for (KeyValue(x, y)) in this do + let e = MapTree.mkIEnumerator this.Tree + while e.MoveNext() do + let (KeyValue(x,y)) = e.Current res <- combineHash res (hash x) res <- combineHash res (Unchecked.hash y) - res + abs res - 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 + override this.Equals(that) = + (this :> System.IComparable).CompareTo(that) = 0 interface IEnumerable> with member __.GetEnumerator() = MapTree.mkIEnumerator tree @@ -681,19 +477,26 @@ type Map<[]'Key, [ System.Collections.IEnumerator) + interface System.IComparable with member m.CompareTo(obj: obj) = - 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 + 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 member this.size = this.Count member __.clear() = failwith "Map cannot be mutated" member __.delete(_) = failwith "Map cannot be mutated" @@ -704,199 +507,140 @@ type Map<[]'Key, [ Seq.map (fun kv -> kv.Value) - // 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 isEmpty (m:Map<_,_>) = m.IsEmpty - // 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 add k v (m:Map<_,_>) = m.Add(k,v) -// [] -// [] -// module Map = +let find k (m:Map<_,_>) = m.[k] -// [] -let isEmpty (table: Map<_, _>) = - table.IsEmpty +let tryFind k (m:Map<_,_>) = m.TryFind(k) -// [] -let add key value (table: Map<_, _>) = - table.Add (key, value) +let remove k (m:Map<_,_>) = m.Remove(k) -// [] -let change key f (table: Map<_, _>) = - table.Change (key, f) +let containsKey k (m:Map<_,_>) = m.ContainsKey(k) -// [] -let find key (table: Map<_, _>) = - table.[key] +let iterate f (m:Map<_,_>) = m.Iterate(f) -// [] -let tryFind key (table: Map<_, _>) = - table.TryFind key +let tryPick f (m:Map<_,_>) = m.TryPick(f) -// [] -let remove key (table: Map<_, _>) = - table.Remove key +let pick f (m:Map<_,_>) = match tryPick f m with None -> failwith "key not found" | Some res -> res -// [] -let containsKey key (table: Map<_, _>) = - table.ContainsKey key +let exists f (m:Map<_,_>) = m.Exists(f) -// [] -let iterate action (table: Map<_, _>) = - table.Iterate action +let filter f (m:Map<_,_>) = m.Filter(f) -// [] -let tryPick chooser (table: Map<_, _>) = - table.TryPick chooser +let partition f (m:Map<_,_>) = m.Partition(f) -// [] -let pick chooser (table: Map<_, _>) = - match tryPick chooser table with - | None -> raise (KeyNotFoundException()) - | Some res -> res +let forAll f (m:Map<_,_>) = m.ForAll(f) -// [] -let exists predicate (table: Map<_, _>) = - table.Exists predicate +let mapRange f (m:Map<_,_>) = m.MapRange(f) -// [] -let filter predicate (table: Map<_, _>) = - table.Filter predicate +let map f (m:Map<_,_>) = m.Map(f) -// [] -let partition predicate (table: Map<_, _>) = - table.Partition predicate +let fold<'Key,'T,'State when 'Key : comparison> f (z:'State) (m:Map<'Key,'T>) = + MapTree.fold f z m.Tree -// [] -let forAll predicate (table: Map<_, _>) = - table.ForAll predicate +let foldBack<'Key,'T,'State when 'Key : comparison> f (m:Map<'Key,'T>) (z:'State) = + MapTree.foldBack f m.Tree z -// [] -let map mapping (table: Map<_, _>) = - table.Map mapping +let toSeq (m:Map<'a,'b>) = + MapTree.toSeq m.Tree -// [] -let fold<'Key, 'T, 'State when 'Key : comparison> folder (state:'State) (table: Map<'Key, 'T>) = - MapTree.fold folder state table.Tree +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 foldBack<'Key, 'T, 'State when 'Key : comparison> folder (table: Map<'Key, 'T>) (state:'State) = - MapTree.foldBack folder table.Tree state +let tryFindKey f (m : Map<_,_>) = + m.Tree |> MapTree.tryPick (fun k v -> + if f k v then Some k else None) -// [] -let toSeq (table: Map<_, _>) = - table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) +let ofList (l: ('Key * 'Value) list) ([] comparer: IComparer<'Key>) = + new Map<_,_>(comparer, MapTree.ofList 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 ofSeq (l: ('Key * 'Value) seq) ([] comparer: IComparer<'Key>) = + new Map<_,_>(comparer, MapTree.ofSeq comparer l) -// [] -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 ofArray (array: ('Key * 'Value) array) ([] comparer: IComparer<'Key>) = + new Map<_,_>(comparer, MapTree.ofArray comparer array) -// [] -let ofList (elements: ('Key * 'Value) list) = - Map<_, _>.ofList elements +let toList (m:Map<_,_>) = m.ToList() -// [] -let ofSeq elements = - Map<_, _>.Create elements +let toArray (m:Map<'Key,'Value>) = + let res = Array.Helpers.allocateArray m.Count + MapTree.copyToArray m.Tree res 0 + res -// [] -let ofArray (elements: ('Key * 'Value) array) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofArray comparer elements) +let empty<'Key,'Value when 'Key : comparison> ([] comparer: IComparer<'Key>) = + new Map<'Key,'Value>(comparer, MapTree.MapEmpty) -// [] -let toList (table: Map<_, _>) = - table.ToList() +// 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 toArray (table: Map<_, _>) = - table.ToArray() +/// Emulate JS Map with custom comparer for non-primitive values -// [] -let empty<'Key, 'Value when 'Key : comparison> = - Map<'Key, 'Value>.Empty +// let createMutable (source: ('Key*'Value) seq) ([] comparer: IComparer<'Key>) = +// MapTree.ofSeq comparer source +// |> createMutablePrivate comparer -let createMutable (source: KeyValuePair<'Key, 'Value> seq) ([] comparer: IEqualityComparer<'Key>) = - let map = Fable.Collections.MutableMap(source, comparer) - map :> Fable.Collections.IMutableMap<_,_> +let createMutable (source: KeyValuePair<'Key, 'Value> seq) ([] comparer: IEqualityComparer<'Key>) = + let map = MutableMap(source, comparer) + map :> IMutableMap<_,_> -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 +// 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 // 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: IEqualityComparer<'Key>): ('Key * int) seq = +// 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 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 (table: Map<_, _>) = - table.Count \ No newline at end of file +let count (m:Map<'Key,'Value>) = m.Count diff --git a/src/fable-library/Set.fs b/src/fable-library/Set.fs index aaf2ca30c7..0e9e3187fd 100644 --- a/src/fable-library/Set.fs +++ b/src/fable-library/Set.fs @@ -1,903 +1,739 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +//---------------------------------------------------------------------------- +// 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 module Set open System.Collections open System.Collections.Generic - -// 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 +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. [] -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 +[] +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 let count s = countAux s 0 - -// #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 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 = let t1h = height t1 let t2h = height t2 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 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 + 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" else 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 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>) = + 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 = // 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" - 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) + 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 - let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'T>) = + let rec split (comparer : IComparer<'T>) pivot 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 } - 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 + // 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 let diff comparer a b = diffAux comparer b a - let rec union comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + let rec union comparer t1 t2 = // Perf: tried bruteForce for low heights, but nothing significant - 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 + 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 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: SetTree<'T> list) = + let rec collapseLHS stack = match stack with - | [] -> [] - | 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 + | [] -> [] + | SetEmpty :: rest -> collapseLHS rest + | SetOne _ :: _ -> stack + | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) 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 - | k :: _ -> k.Key - | [] -> alreadyFinished() + | SetOne k :: _ -> k + | [] -> alreadyFinished() + | _ -> failwith "Please report error: Set iterator, unexpected stack for current" 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 - | 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 + | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" 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 - let mkIEnumerator 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] + 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 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 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 copyToArray s (arr: _[]) i = let mutable j = i iter (fun x -> arr.[j] <- x; j <- j + 1) s - 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<_>) = + 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 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) + 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) member s.Filter f : Set<'T> = - if SetTree.isEmpty s.Tree then s - else - Set(s.Comparer, SetTree.filter s.Comparer f s.Tree) + match s.Tree with + | SetEmpty -> s + | _ -> new Set<_>(s.Comparer, SetTree.filter s.Comparer f 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.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.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 (-) (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 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 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 (+) (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 Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = - 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) + 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) - // static member Union(sets:seq>) : Set<'T> = - // Seq.fold (fun s1 s2 -> s1 + s2) Set<'T>.Empty sets + static member IntersectionMany(sets:seq>) : Set<'T> = + Seq.reduce (fun s1 s2 -> Set<_>.Intersection(s1,s2)) sets - static member Intersection(sets:seq>) : Set<'T> = - Seq.reduce (fun s1 s2 -> Set.Intersection(s1, s2)) sets + static member Equality(a: Set<'T>, b: Set<'T>) = (SetTree.compare a.Comparer a.Tree b.Tree = 0) - 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 - 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(otherSet: Set<'T>) = - SetTree.subset x.Comparer x.Tree otherSet.Tree - - 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 - - member x.ToList () = SetTree.toList 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.ToArray () = SetTree.toArray x.Tree + override this.ToString() = + "set [" + (Seq.map (fun x -> x.ToString()) this |> String.concat "; ") + "]" - member this.ComputeHashCode() = + override this.GetHashCode() = let combineHash x y = (x <<< 1) + y + 631 let mutable res = 0 - for x in this do - res <- combineHash res (hash x) + let e = SetTree.mkIEnumerator this.Tree + while e.MoveNext() do + res <- combineHash res (hash e.Current) abs res - 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 + override this.Equals(that: obj) = + SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) = 0 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) - // new (elements : seq<'T>) = - // let comparer = LanguagePrimitives.FastGenericComparer<'T> - // Set(comparer, SetTree.ofSeq comparer elements) +let isEmpty (s: Set<'T>) = s.IsEmpty - // static member Create(elements : seq<'T>) = Set<'T>(elements) +let contains x (s: Set<'T>) = s.Contains(x) - // static member FromArray(arr : 'T array) : Set<'T> = - // let comparer = LanguagePrimitives.FastGenericComparer<'T> - // Set(comparer, SetTree.ofArray comparer arr) +let add x (s: Set<'T>) = s.Add(x) - override this.ToString() = - "set [" + (Seq.map (fun x -> x.ToString()) this |> String.concat "; ") + "]" +let singleton (x: 'T) ([] comparer: IComparer<'T>) : Set<'T> = + new Set<'T>(comparer, SetOne x) +let remove x (s: Set<'T>) = s.Remove(x) -// [] -// [] -// module Set = +let union (s1: Set<'T>) (s2: Set<'T>) = s1 + s2 -// [] -let isEmpty (set: Set<'T>) = set.IsEmpty +let unionMany (sets: seq>) ([] comparer: IComparer<'T>) : Set<'T> = + Seq.fold (( + )) (new Set<_>(comparer, SetEmpty)) sets -// [] -let contains element (set: Set<'T>) = set.Contains element +let intersect (s1: Set<'T>) (s2: Set<'T>) = Set<'T>.Intersection(s1,s2) -// [] -let add value (set: Set<'T>) = set.Add value +let intersectMany sets = Set<_>.IntersectionMany(sets) -// [] -let singleton (value: 'T) ([] comparer: IComparer<'T>) : Set<'T> = - Set<'T>.Empty(comparer).Add value +let iterate f (s : Set<'T>) = s.Iterate(f) -// [] -let remove value (set: Set<'T>) = set.Remove value +let empty<'T when 'T : comparison> ([] comparer: IComparer<'T>) : Set<'T> = + new Set<'T>(comparer, SetEmpty) -// [] -let union (set1: Set<'T>) (set2: Set<'T>) = set1 + set2 +let forAll f (s: Set<'T>) = s.ForAll f -// [] -let unionMany (sets: seq>) ([] comparer: IComparer<'T>) = - Seq.fold (fun s1 s2 -> s1 + s2) (Set<'T>.Empty comparer) sets +let exists f (s: Set<'T>) = s.Exists f -// [] -let intersect (set1: Set<'T>) (set2: Set<'T>) = Set<'T>.Intersection(set1, set2) +let filter f (s: Set<'T>) = s.Filter f -// [] -let intersectMany (sets: seq>) = Set.Intersection sets +let partition f (s: Set<'T>) = s.Partition f -// [] -let iterate action (set: Set<'T>) = set.Iterate action +let fold<'T,'State when 'T : comparison> f (z: 'State) (s: Set<'T>) = SetTree.fold f z s.Tree -// [] -let empty<'T when 'T : comparison> ([] comparer: IComparer<'T>): Set<'T> = Set<'T>.Empty comparer +let foldBack<'T,'State when 'T : comparison> f (s: Set<'T>) (z:'State) = SetTree.foldBack f s.Tree z -// [] -let forAll predicate (set: Set<'T>) = set.ForAll predicate +let map f (s: Set<'T>) ([] comparer: IComparer<'U>): Set<'U> = s.Map(f, comparer) -// [] -let exists predicate (set: Set<'T>) = set.Exists predicate +let count (s: Set<'T>) = s.Count -// [] -let filter predicate (set: Set<'T>) = set.Filter predicate +let minimumElement (s: Set<'T>) = s.MinimumElement -// [] -let partition predicate (set: Set<'T>) = set.Partition predicate +let maximumElement (s: Set<'T>) = s.MaximumElement -// [] -let fold<'T, 'State when 'T : comparison> folder (state:'State) (set: Set<'T>) = SetTree.fold folder state set.Tree +let ofList (li: 'T list) ([] comparer: IComparer<'T>) : Set<'T> = + new Set<_>(comparer, SetTree.ofSeq comparer li) -// [] -let foldBack<'T, 'State when 'T : comparison> folder (set: Set<'T>) (state:'State) = SetTree.foldBack folder set.Tree state +let ofArray (arr: 'T array) ([] comparer: IComparer<'T>) : Set<'T> = + new Set<_>(comparer, SetTree.ofArray comparer arr) -// [] -let map mapping (set: Set<'T>) ([] comparer: IComparer<'U>) = set.Map(mapping, comparer) +let toList (s: Set<'T>) = SetTree.toList s.Tree -// [] -let count (set: Set<'T>) = set.Count +let toArray (s: Set<'T>) = + let res = Array.Helpers.allocateArray (count s) + SetTree.copyToArray s.Tree res 0 + res -// [] -let ofList elements ([] comparer: IComparer<'T>) = - Set(comparer, SetTree.ofSeq comparer elements) +let toSeq (s: Set<'T>) = + SetTree.toSeq s.Tree -// [] -let ofArray (array: 'T array) ([] comparer: IComparer<'T>) = - Set(comparer, SetTree.ofArray comparer array) +let ofSeq (elements: seq<'T>) ([] comparer: IComparer<'T>) = + new Set<_>(comparer, SetTree.ofSeq comparer elements) -// [] -let toList (set: Set<'T>) = set.ToList() +let difference (x: Set<'T>) (y: Set<'T>) = x - y -// [] -let toArray (set: Set<'T>) = set.ToArray() +let isSubset (x: Set<'T>) (y: Set<'T>) = x.IsSubsetOf(y) -// [] -let toSeq (set: Set<'T>) = (set:> seq<'T>) +let isSuperset (x: Set<'T>) (y: Set<'T>) = x.IsSupersetOf(y) -// [] -let ofSeq (elements: seq<_>) ([] comparer: IComparer<'T>) = - Set(comparer, SetTree.ofSeq comparer elements) +let isProperSubset (x: Set<'T>) (y: Set<'T>) = x.IsProperSubsetOf(y) -// [] -let difference (set1: Set<'T>) (set2: Set<'T>) = set1 - set2 +let isProperSuperset (x: Set<'T>) (y: Set<'T>) = x.IsProperSupersetOf(y) -// [] -let isSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set1.Tree set2.Tree +let minElement (s: Set<'T>) = s.MinimumElement -// [] -let isSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set2.Tree set1.Tree +let maxElement (s: Set<'T>) = s.MaximumElement -// [] -let isProperSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set1.Tree set2.Tree +// let create (l: seq<'T>) = Set<_>.Create(l) -// [] -let isProperSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set2.Tree set1.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 minElement (set: Set<'T>) = set.MinimumElement +// 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 maxElement (set: Set<'T>) = set.MaximumElement +// 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 createMutable (source: seq<'T>) ([] comparer: IEqualityComparer<'T>) = - let set = Fable.Collections.MutableSet(source, comparer) - set :> Fable.Collections.IMutableSet<_> +/// Emulate JS Set with custom comparer for non-primitive values -let distinct (xs: seq<'T>) ([] comparer: IEqualityComparer<'T>) = +// 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>) = seq { - let set = Fable.Collections.MutableSet(Seq.empty, comparer) + let set = 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 = Fable.Collections.MutableSet(Seq.empty, comparer) + let set = MutableSet(Seq.empty, comparer) for x in xs do if set.Add(projection x) then yield x @@ -905,27 +741,27 @@ let distinctBy (projection: 'T -> 'Key) (xs: seq<'T>) ([] com // Helpers to replicate HashSet methods -let unionWith (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) = +let unionWith (s1: IMutableSet<'T>) (s2: 'T seq) = (s1, s2) ||> Seq.fold (fun acc x -> acc.add x) -let intersectWith (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let intersectWith (s1: 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: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) = +let exceptWith (s1: IMutableSet<'T>) (s2: 'T seq) = for x in s2 do s1.delete x |> ignore -let isSubsetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isSubsetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isSubset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isSupersetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isSupersetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isSuperset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isProperSubsetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isProperSubsetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isProperSubset (ofSeq s1 comparer) (ofSeq s2 comparer) -let isProperSupersetOf (s1: Fable.Collections.IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = +let isProperSupersetOf (s1: IMutableSet<'T>) (s2: 'T seq) ([] comparer: IComparer<'T>) = isProperSuperset (ofSeq s1 comparer) (ofSeq s2 comparer)