From d758f8eb907404b57e0e33e77749950a53fc01b8 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 27 Sep 2020 18:45:24 +0200 Subject: [PATCH] FSharp.Compiler.Service: update tagged collections with new implementation from FSharp.Core Copied implementation from FSharp.Core Differences are: * TaggedCollections used fat leaves (Left/Right/Height present always). There are 2xN objects in the tree, of which N are leaves. Fat leaves give 20 (24 aligned) x N. More memory, worse memory locality, more GC are not good for perf. * TaggedCollections did not use optimized closures. Not sure if they are useful, but in many cases it's noop if f' was already in the right shape. Copying the source opens the possibility to move MapTree and SetTree code to separate files and reuse a single implementation in both places. --- src/utils/TaggedCollections.fs | 1482 +++++++++++++++----------------- 1 file changed, 706 insertions(+), 776 deletions(-) diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 479b8def82..0d7386324d 100644 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -10,404 +10,332 @@ namespace Internal.Utilities.Collections.Tagged open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open System.Collections.Generic - - [] [] - type SetTree<'T> = - | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int -#if ONE - | SetOne of 'T // height = 1 -#endif - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) + [] + type internal SetTree<'T>(k: 'T) = + member _.Key = k + [] + [] + [] + type internal SetTreeNode<'T>(v:'T, left:SetTree<'T>, right: SetTree<'T>, h: int) = + inherit SetTree<'T>(v) - // CONSIDER: SetTree<'T> = SetEmpty | SetNode of 'T * SetTree<'T> * SetTree<'T> * int - // with SetOne = SetNode of (x,null,null,1) + member _.Left = left + member _.Right = right + member _.Height = h [] module SetTree = - let empty = SetEmpty + let empty = null - let height t = - match t with - | SetEmpty -> 0 -#if ONE - | SetOne _ -> 1 -#endif - | SetNode (_,_,_,h) -> h + let inline isEmpty (t:SetTree<'T>) = isNull t + + let rec countAux (t:SetTree<'T>) acc = + if isEmpty t then + acc + else + match t with + | :? SetTreeNode<'T> as tn -> countAux tn.Left (countAux tn.Right (acc+1)) + | _ -> acc+1 + + let count s = countAux s 0 + + let 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 = - // A good sanity check, loss of balance can hit perf - match t with - | SetEmpty -> true - | SetOne _ -> true - | SetNode (k,t1,t2,h) -> - let h1 = height t1 in - let h2 = height t2 in - (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 -#else - let inline SetOne(x) = SetNode(x,SetEmpty,SetEmpty,1) + 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 tolerance = 2 - let mk l hl k r hr = -#if ONE - if hl = 0 && hr = 0 then SetOne (k) + 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 -#endif - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) + SetTreeNode (k, l, r, m+1) :> SetTree<'T> + + let inline private asNode(value:SetTree<'T>) : SetTreeNode<'T> = + value :?> SetTreeNode<'T> - let rebalance t1 k t2 = + let rebalance t1 v t2 = let t1h = height t1 - let t2h = height t2 + let t2h = height t2 if t2h > t1h + tolerance then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - let t2lh = height t2l - if t2lh > t1h + 1 then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - let l = mk t1 t1h k t2ll (height t2ll) - let r = mk t2lr (height t2lr) t2k t2r (height t2r) - mk l (height l) t2lk r (height r) - | _ -> failwith "rebalance" - else // rotate left - let l = mk t1 t1h k t2l t2lh - mk l (height l) t2k t2r (height t2r) - | _ -> failwith "rebalance" + let t2' = asNode(t2) + // one of the nodes must have height > height t1 + 1 + if height t2'.Left > t1h + 1 then // balance left: combination + let t2l = asNode(t2'.Left) + mk (mk t1 v t2l.Left) t2l.Key (mk t2l.Right t2'.Key t2'.Right) + else // rotate left + mk (mk t1 v t2'.Left) t2.Key t2'.Right else - if t1h > t2h + tolerance then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - let t1rh = height t1r - if t1rh > t2h + 1 then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - let l = mk t1l (height t1l) t1k t1rl (height t1rl) - let r = mk t1rr (height t1rr) k t2 t2h - mk l (height l) t1rk r (height r) - | _ -> failwith "rebalance" - else - let r = mk t1r t1rh k t2 t2h - mk t1l (height t1l) t1k r (height r) - | _ -> failwith "rebalance" - else mk t1 t1h k t2 t2h - - 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) -#if ONE - | 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) -#endif - | 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 . + 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>) = + // Given t1 < k < t2 where t1 and t2 are "balanced", + // return a balanced tree for . // Recall: balance means subtrees heights differ by at most "tolerance" - match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty -#if ONE - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) -#endif - | SetNode(k1,t11,t12,t1h),SetNode(k2,t21,t22,t2h) -> - // 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 t1h+tolerance < t2h 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 t2h+tolerance < t1h 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 t1h k t2 t2h + if isEmpty t1 then add comparer k t2 // drop t1 = empty + elif isEmpty t2 then add comparer k t1 // drop t2 = empty + else + match t1 with + | :? SetTreeNode<'T> as t1n -> + match t2 with + | :? SetTreeNode<'T> as t2n -> + // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) + // Either (a) h1, h2 differ by at most 2 - no rebalance needed. + // (b) h1 too small, i.e. h1+2 < h2 + // (c) h2 too small, i.e. h2+2 < h1 + if t1n.Height + tolerance < t2n.Height then + // case: b, h1 too small + // push t1 into low side of t2, may increase height by 1 so rebalance + rebalance (balance comparer t1 k t2n.Left) t2n.Key t2n.Right + elif t2n.Height + tolerance < t1n.Height then + // case: c, h2 too small + // push t2 into high side of t1, may increase height by 1 so rebalance + rebalance t1n.Left t1n.Key (balance comparer t1n.Right k t2) + else + // case: a, h1 and h2 meet balance requirement + mk t1 k t2 + | _ -> add comparer k (add comparer t2.Key t1) + | _ -> add comparer k (add comparer t1.Key t2) - let rec split (comparer : IComparer<'T>) pivot t = + let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'T>) = // Given a pivot and a set t - // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } - match t with - | SetNode(k1,t11,t12,_) -> - let c = comparer.Compare(pivot,k1) - if c < 0 then // pivot t1 - let t11_lo,havePivot,t11_hi = split comparer pivot t11 - t11_lo,havePivot,balance comparer t11_hi k1 t12 - elif c = 0 then // pivot is k1 - t11,true,t12 - else // pivot t2 - let t12_lo,havePivot,t12_hi = split comparer pivot t12 - balance comparer t11 k1 t12_lo,havePivot,t12_hi -#if ONE - | 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 -#endif - | SetEmpty -> - SetEmpty,false,SetEmpty + // 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 = - match t with - | SetEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" -#if ONE - | SetOne (k2) -> k2,empty -#endif - | SetNode (k2,l,r,_) -> - match l with - | SetEmpty -> k2,r - | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' (height l') k2 r (height r) - - let rec remove (comparer: IComparer<'T>) k t = - match t with - | SetEmpty -> t -#if ONE - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then empty - else t -#endif - | 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 (height l) sk r' (height r') - else rebalance l k2 (remove comparer k r) - - let rec contains (comparer: IComparer<'T>) k t = - match t with - | SetNode(k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then contains comparer k l - elif c = 0 then true - else contains comparer k r -#if ONE - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) -#endif - | SetEmpty -> false - - let rec iter f t = - match t with - | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> () + 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 contains (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 contains comparer k tn.Left + elif c = 0 then true + else contains 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 // Fold, left-to-right. // // NOTE: This differs from the behaviour of Map.fold which folds right-to-left. - let rec fold f m x = - match m with - | SetNode(k,l,r,_) -> fold f r (f k (fold f l x)) -#if ONE - | SetOne(k) -> f k x -#endif - | SetEmpty -> x - - let rec forAll f m = - match m with - | SetNode(k2,l,r,_) -> f k2 && forAll f l && forAll f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> true - - let rec exists f m = - match m with - | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> false - - let isEmpty m = match m with | SetEmpty -> true | _ -> false + let rec fold f (t:SetTree<'T>) x = + if isEmpty t then x + else + match t with + | :? SetTreeNode<'T> as tn -> fold f tn.Right (f tn.Key (fold f tn.Left x)) + | _ -> f t.Key x - let subset comparer a b = forAll (fun x -> contains comparer x b) a + 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 elementsAux m acc = - match m with - | SetNode(k2,l,r,_) -> k2 :: (elementsAux l (elementsAux r acc)) -#if ONE - | SetOne(k2) -> k2 :: acc -#endif - | SetEmpty -> acc + 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 elements a = elementsAux a [] + let subset comparer a b = + forall (fun x -> contains comparer x b) a - 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) -#if ONE - | SetOne(k) -> if f k then add comparer k acc else acc -#endif - | SetEmpty -> acc + 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 m acc = - match m with - | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) -#if ONE - | SetOne(k) -> remove comparer k acc -#endif - | SetEmpty -> acc + let rec diffAux comparer (t:SetTree<'T>) acc = + if isEmpty acc then acc + else + if isEmpty t then acc + else + match t with + | :? SetTreeNode<'T> as tn -> diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) + | _ -> remove comparer t.Key acc let diff comparer a b = diffAux comparer b a - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) -#if ONE - | SetOne(k) -> acc+1 -#endif - | SetEmpty -> acc - - let count s = countAux s 0 - - let rec union comparer t1 t2 = + let rec union comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = // Perf: tried bruteForce for low heights, but nothing significant - match t1,t2 with - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) - // Divide and Conquer: - // 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 -#if ONE - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 -#endif + 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 m acc = - match m with - | SetNode(k,l,r,_) -> - let acc = intersectionAux comparer b r acc - let acc = if contains comparer k b then add comparer k acc else acc - intersectionAux comparer b l acc -#if ONE - | SetOne(k) -> - if contains comparer k b then add comparer k acc else acc -#endif - | SetEmpty -> acc + 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 contains comparer tn.Key b then add comparer tn.Key acc else acc + intersectionAux comparer b tn.Left acc + | _ -> + if contains 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 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 -#if ONE - | SetOne(k) -> partition1 comparer f k acc -#endif - | SetEmpty -> acc - - let partition comparer f s = partitionAux comparer f s (empty,empty) + let partition1 comparer f k (acc1, acc2) = if f k then (add comparer k acc1, acc2) else (acc1, add comparer k acc2) - // 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) -#if ONE - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) -#endif - | SetEmpty -> MatchSetEmpty - - let rec nextElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c < 0 then nextElemCont comparer k l (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(minimumElementOpt r) - else nextElemCont comparer k r cont - | MatchSetEmpty -> cont(None) - - and nextElem comparer k s = nextElemCont comparer k s (fun res -> res) - - and prevElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c > 0 then prevElemCont comparer k r (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(maximumElementOpt r) - else prevElemCont comparer k l cont - | MatchSetEmpty -> cont(None) - - and prevElem comparer k s = prevElemCont comparer k s (fun res -> res) + 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) - and minimumElementAux s n = - match s with - | SetNode(k,l,_,_) -> minimumElementAux l k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n + 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 s = - match s with - | SetNode(k,l,_,_) -> Some(minimumElementAux l k) -#if ONE - | SetOne(k) -> Some k -#endif - | SetEmpty -> None + 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 s n = - match s with - | SetNode(k,_,r,_) -> maximumElementAux r k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n + 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 s = - match s with - | SetNode(k,_,r,_) -> Some(maximumElementAux r k) -#if ONE - | SetOne(k) -> Some(k) -#endif - | SetEmpty -> None + and maximumElementOpt (t:SetTree<'T>) = + if isEmpty t then None + else + match t with + | :? SetTreeNode<'T> as tn -> Some(maximumElementAux tn.Right tn.Key) + | _ -> Some t.Key let minimumElement s = match minimumElementOpt s with @@ -419,7 +347,6 @@ namespace Internal.Utilities.Collections.Tagged | Some(k) -> k | None -> failwith "maximumElement" - //-------------------------------------------------------------------------- // Imperative left-to-right iterators. //-------------------------------------------------------------------------- @@ -429,16 +356,15 @@ namespace Internal.Utilities.Collections.Tagged // collapseLHS: // a) Always returns either [] or a list starting with SetOne. // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = + let rec collapseLHS (stack: SetTree<'T> list) = match stack with - | [] -> [] - | SetEmpty :: rest -> collapseLHS rest -#if ONE - | SetOne k :: rest -> stack -#else - | SetNode(_,SetEmpty,SetEmpty,_) :: _ -> stack -#endif - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) + | [] -> [] + | x :: rest -> + if isEmpty x then collapseLHS rest + else + match x with + | :? SetTreeNode<'T> as xn-> collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) + | _ -> stack // invariant: always collapseLHS result let mutable stack = collapseLHS [s] @@ -448,34 +374,27 @@ namespace Internal.Utilities.Collections.Tagged let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) - member i.Current = + member _.Current = if started then match stack with -#if ONE - | SetOne k :: _ -> k -#else - | SetNode( k,_,_,_) :: _ -> k -#endif - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Set iterator, unexpected stack for current" + | k :: _ -> k.Key + | [] -> alreadyFinished() else notStarted() - member i.MoveNext() = - if started then - match stack with -#if ONE - | SetOne _ :: rest -> -#else - | SetNode _ :: rest -> -#endif - stack <- collapseLHS rest; - not stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" - else - started <- true; // The first call to MoveNext "starts" the enumeration. - not stack.IsEmpty + member _.MoveNext() = + if started then + match stack with + | [] -> false + | t :: rest -> + match t with + | :? SetTreeNode<'T> -> failwith "Please report error: Set iterator, unexpected stack for moveNext" + | _ -> + stack <- collapseLHS rest + not stack.IsEmpty + else + started <- true; // The first call to MoveNext "starts" the enumeration. + not stack.IsEmpty let toSeq s = let mutable i = SetIterator s @@ -492,57 +411,73 @@ namespace Internal.Utilities.Collections.Tagged // 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 -#if ONE - | (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 (empty :: 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) -#endif - | (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) -#if ONE - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (empty :: SetOne(n1k) :: t1) l2 -#endif - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,empty,n1r,0) :: t1) l2 -#if ONE - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (empty :: SetOne(n2k) :: t2) -#endif - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,empty,n2r,0) :: t2) - - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] + let rec compareStacks (comparer: IComparer<'T>) (l1:SetTree<'T> list) (l2:SetTree<'T> list) : int = + let cont() = + match l1, l2 with + | (x1 :: t1), _ when not (isEmpty x1) -> + match x1 with + | :? SetTreeNode<'T> as x1n -> + compareStacks comparer (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 + | _ -> compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 + | _, (x2 :: t2) when not (isEmpty x2) -> + match x2 with + | :? SetTreeNode<'T> as x2n -> + compareStacks comparer l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) + | _ -> compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) + | _ -> failwith "unexpected state in SetTree.compareStacks" + + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | (x1 :: t1), (x2 :: t2) -> + if isEmpty x1 then + if isEmpty x2 then compareStacks comparer t1 t2 + else cont() + elif isEmpty x2 then cont() + else + match x1 with + | :? SetTreeNode<'T> as x1n -> + if isEmpty x1n.Left then + match x2 with + | :? SetTreeNode<'T> as x2n -> + if isEmpty x2n.Left then + let c = comparer.Compare(x1n.Key, x2n.Key) + if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) + else cont() + | _ -> + let c = comparer.Compare(x1n.Key, x2.Key) + if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) + else cont() + | _ -> + match x2 with + | :? SetTreeNode<'T> as x2n -> + if isEmpty x2n.Left then + let c = comparer.Compare(x1.Key, x2n.Key) + if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) + else cont() + | _ -> + let c = comparer.Compare(x1.Key, x2.Key) + if c <> 0 then c else compareStacks comparer t1 t2 + + let compare comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + if isEmpty t1 then + if isEmpty t2 then 0 + else -1 + else + if isEmpty t2 then 1 + else compareStacks comparer [t1] [t2] let choose s = minimumElement s - let toList s = - let rec loop m x = - match m with - | SetNode(k,l,r,_) -> loop l (k :: (loop r x)) -#if ONE - | SetOne(k) -> k :: x -#endif - | SetEmpty -> x - loop s [] + let toList (t:SetTree<'T>) = + let rec loop (t':SetTree<'T>) acc = + if isEmpty t' then acc + else + match t' with + | :? SetTreeNode<'T> as tn -> loop tn.Left (tn.Key :: loop tn.Right acc) + | _ -> t'.Key :: acc + loop t [] let copyToArray s (arr: _[]) i = let mutable j = i @@ -592,48 +527,41 @@ namespace Internal.Utilities.Collections.Tagged member s.IsEmpty = SetTree.isEmpty tree member s.Partition f : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s,s - | _ -> - let t1,t2 = SetTree.partition comparer f tree + if SetTree.isEmpty s.Tree then s,s + else + let t1, t2 = SetTree.partition s.Comparer f s.Tree refresh s t1, refresh s t2 member s.Filter f : Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s - | _ -> SetTree.filter comparer f tree |> refresh s + if SetTree.isEmpty s.Tree then s + else + SetTree.filter comparer f tree |> refresh s member s.Exists f = SetTree.exists f tree - member s.ForAll f = SetTree.forAll f tree + member s.ForAll f = SetTree.forall f tree static member (-) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Difference(a,b) static member (+) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Union(a,b) static member Intersection((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> b // A INTER 0 = 0 - | _ -> - match a.Tree with - | SetEmpty -> a // 0 INTER B = 0 - | _ -> SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a + if SetTree.isEmpty b.Tree then b (* A INTER 0 = 0 *) + else + if SetTree.isEmpty a.Tree then a (* 0 INTER B = 0 *) + else SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a static member Union(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> a // A U 0 = A - | _ -> - match a.Tree with - | SetEmpty -> b // 0 U B = B - | _ -> SetTree.union a.Comparer a.Tree b.Tree |> refresh a + if SetTree.isEmpty b.Tree then a (* A U 0 = A *) + else + if SetTree.isEmpty a.Tree then b (* 0 U B = B *) + else SetTree.union a.Comparer a.Tree b.Tree |> refresh a static member Difference(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match a.Tree with - | SetEmpty -> a // 0 - B = 0 - | _ -> - match b.Tree with - | SetEmpty -> a // A - 0 = A - | _ -> SetTree.diff a.Comparer a.Tree b.Tree |> refresh a + if SetTree.isEmpty a.Tree then a (* 0 - B = 0 *) + else + if SetTree.isEmpty b.Tree then a (* A - 0 = A *) + else SetTree.diff a.Comparer a.Tree b.Tree |> refresh a static member Equality(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = (SetTree.compare a.Comparer a.Tree b.Tree = 0) @@ -697,317 +625,325 @@ namespace Internal.Utilities.Collections.Tagged Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) - [] [] - type MapTree<'Key,'T> = - | MapEmpty -#if ONE - | MapOne of 'Key * 'T -#endif - | MapNode of 'Key * 'T * MapTree<'Key,'T> * MapTree<'Key,'T> * int + [] + type internal MapTree<'Key, 'Value>(k: 'Key, v: 'Value) = + member _.Key = k + member _.Value = v + + [] + [] + [] + type internal MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Value>, right: MapTree<'Key, 'Value>, h: int) = + inherit MapTree<'Key,'Value>(k, v) + + member _.Left = left + member _.Right = right + member _.Height = h [] module MapTree = - let empty = MapEmpty + let empty = null - let inline height x = - match x with - | MapEmpty -> 0 -#if ONE - | MapOne _ -> 1 -#endif - | MapNode(_,_,_,_,h) -> h + let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m + + 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 inline isEmpty m = - match m with - | MapEmpty -> true - | _ -> false + let size x = sizeAux 0 x - let inline mk l k v r = -#if ONE - match l,r with - | MapEmpty,MapEmpty -> MapOne(k,v) - | _ -> -#endif - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - MapNode(k,v,l,r,m+1) + let inline height (m: MapTree<'Key, 'Value>) = + if isEmpty m then 0 + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> mn.Height + | _ -> 1 + + let mk l k v r : MapTree<'Key, 'Value> = + let hl = height l + let hr = height r + let m = max hl hr + if m = 0 then // m=0 ~ isEmpty l && isEmpty r + MapTree(k,v) + else + MapTreeNode(k,v,l,r,m+1) :> MapTree<'Key, 'Value> - let rebalance t1 k v t2 = + let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = + value :?> MapTreeNode<'Key,'Value> + + let rebalance t1 (k: 'Key) (v: 'Value) t2 : MapTree<'Key, 'Value> = let t1h = height t1 - let t2h = height t2 - if t2h > t1h + 2 then // right is heavier than left - match t2 with - | MapNode(t2k,t2v,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - if height t2l > t1h + 1 then // balance left: combination - match t2l with - | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> - mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) - | _ -> failwith "rebalance" - else // rotate left - mk (mk t1 k v t2l) t2k t2v t2r - | _ -> failwith "rebalance" + let t2h = height t2 + if t2h > t1h + 2 then (* right is heavier than left *) + let t2' = asNode(t2) + (* one of the nodes must have height > height t1 + 1 *) + if height t2'.Left > t1h + 1 then (* balance left: combination *) + let t2l = asNode(t2'.Left) + mk (mk t1 k v t2l.Left) t2l.Key t2l.Value (mk t2l.Right t2'.Key t2'.Value t2'.Right) + else (* rotate left *) + mk (mk t1 k v t2'.Left) t2'.Key t2'.Value t2'.Right else - if t1h > t2h + 2 then // left is heavier than right - match t1 with - | MapNode(t1k,t1v,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - if height t1r > t2h + 1 then - // balance right: combination - match t1r with - | MapNode(t1rk,t1rv,t1rl,t1rr,_) -> - mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2) - | _ -> failwith "rebalance" - else - mk t1l t1k t1v (mk t1r k v t2) - | _ -> failwith "rebalance" + if t1h > t2h + 2 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 sizeAux acc m = - match m with - | MapEmpty -> acc -#if ONE - | MapOne _ -> acc + 1 -#endif - | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r -#if ONE -#else - let MapOne(k,v) = MapNode(k,v,MapEmpty,MapEmpty,1) -#endif - - let count x = sizeAux 0 x - - let rec add (comparer: IComparer<'T>) k v m = - match m with - | MapEmpty -> MapOne(k,v) -#if ONE - | MapOne(k2,v2) -> - 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) -#endif - | 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 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 indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index satisfying the predicate was not found in the collection")) - let rec find (comparer: IComparer<'T>) k m = - match m with - | MapEmpty -> indexNotFound() -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then v2 - else indexNotFound() -#endif - | 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<'T>) k m = - match m with - | MapEmpty -> None -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then Some v2 - else None -#endif - | 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<'T>) 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<'T>) f s acc = - match s with - | MapEmpty -> acc -#if ONE - | MapOne(k,v) -> partition1 comparer f k v acc -#endif - | 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 rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then false + else + let c = comparer.Compare(k, m.Key) + if c = 0 then v <- m.Value; true + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) + | _ -> false + + let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let mutable v = Unchecked.defaultof<'Value> + if tryGetValue comparer k &v m then + v + else + indexNotFound() - let partition (comparer: IComparer<'T>) f s = partitionAux comparer f s (empty,empty) + let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let mutable v = Unchecked.defaultof<'Value> + if tryGetValue comparer k &v m then + Some v + else + None - let filter1 (comparer: IComparer<'T>) f k v acc = if f k v then add comparer k v acc else acc + 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 filterAux (comparer: IComparer<'T>) f s acc = - match s with - | MapEmpty -> acc -#if ONE - | MapOne(k,v) -> filter1 comparer f k v acc -#endif - | 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<'T>) f s = filterAux comparer f s empty - - let rec spliceOutSuccessor m = - match m with - | MapEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" -#if ONE - | MapOne(k2,v2) -> k2,v2,MapEmpty -#endif - | 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<'T>) k m = - match m with - | MapEmpty -> empty -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then MapEmpty else m -#endif - | 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 containsKey (comparer: IComparer<'T>) k m = - match m with - | MapEmpty -> false -#if ONE - | MapOne(k2,v2) -> (comparer.Compare(k,k2) = 0) -#endif - | MapNode(k2,_,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then containsKey comparer k l - else (c = 0 || containsKey comparer k r) - - let rec iter f m = - match m with - | MapEmpty -> () -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif - | MapNode(k2,v2,l,r,_) -> iter f l; f k2 v2; iter f r + 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 rec first f m = - match m with - | MapEmpty -> None -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif - | MapNode(k2,v2,l,r,_) -> - match first f l with - | Some _ as res -> res - | None -> - match f k2 v2 with - | Some _ as res -> res - | None -> first f r - - let rec exists f m = - match m with - | MapEmpty -> false -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif - | MapNode(k2,v2,l,r,_) -> f k2 v2 || exists f l || exists f r + let partition (comparer: IComparer<'Key>) f m = + partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) - let rec forAll f m = - match m with - | MapEmpty -> true -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif - | MapNode(k2,v2,l,r,_) -> f k2 v2 && forAll f l && forAll f r + 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 map f m = - match m with - | MapEmpty -> empty -#if ONE - | MapOne(k,v) -> MapOne(k,f v) -#endif - | MapNode(k,v,l,r,h) -> let v2 = f v in MapNode(k,v2,map f l, map f r,h) + 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 rec mapi f m = - match m with - | MapEmpty -> empty -#if ONE - | MapOne(k,v) -> MapOne(k,f k v) -#endif - | MapNode(k,v,l,r,h) -> let v2 = f k v in MapNode(k,v2, mapi f l, mapi f r,h) + let filter (comparer: IComparer<'Key>) f m = + filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty + + let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = + if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if isEmpty mn.Left then mn.Key, mn.Value, mn.Right + else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right + | _ -> m.Key, m.Value, empty + + let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then empty + else + let c = comparer.Compare(k, m.Key) + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then + if isEmpty mn.Left then mn.Right + elif isEmpty mn.Right then mn.Left + else + let sk, sv, r' = spliceOutSuccessor mn.Right + mk mn.Left sk sv r' + else rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) + | _ -> + if c = 0 then empty else m + + let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + if isEmpty m then false + else + let c = comparer.Compare(k, m.Key) + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + if c < 0 then mem comparer k mn.Left + else (c = 0 || mem comparer k mn.Right) + | _ -> c = 0 + + let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then () + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right + | _ -> f.Invoke (m.Key, m.Value) + + let iter f m = + iterOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m + + let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = + if isEmpty m then None + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + match tryPickOpt f mn.Left with + | Some _ as res -> res + | None -> + match f.Invoke (mn.Key, mn.Value) with + | Some _ as res -> res + | None -> + 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 // Fold, right-to-left. // // NOTE: This differs from the behaviour of Set.fold which folds left-to-right. - let rec fold f m x = - match m with - | MapEmpty -> x -#if ONE - | MapOne(k,v) -> f k v x -#endif - | MapNode(k,v,l,r,_) -> fold f l (f k v (fold f r x)) - let foldSection (comparer: IComparer<'T>) lo hi f m x = - let rec fold_from_to f m x = + let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + if isEmpty m then x + else match m with - | MapEmpty -> x -#if ONE - | MapOne(k,v) -> - let clo_k = comparer.Compare(lo,k) - let ck_hi = comparer.Compare(k,hi) - let x = if clo_k <= 0 && ck_hi <= 0 then f k v x else x - x -#endif - | MapNode(k,v,l,r,_) -> - let clo_k = comparer.Compare(lo,k) - let ck_hi = comparer.Compare(k,hi) - let x = if clo_k < 0 then fold_from_to f l x else x - let x = if clo_k <= 0 && ck_hi <= 0 then f k v x else x - let x = if ck_hi < 0 then fold_from_to f r x else x - x - - if comparer.Compare(lo,hi) = 1 then x else fold_from_to f m x - - let rec foldMap (comparer: IComparer<'T>) f m z acc = - match m with - | MapEmpty -> acc,z -#if ONE - | MapOne(k,v) -> - let v',z = f k v z - add comparer k v' acc,z -#endif - | MapNode(k,v,l,r,_) -> - let acc,z = foldMap comparer f r z acc - let v',z = f k v z - let acc = add comparer k v' acc - foldMap comparer f l z acc - - let toList m = fold (fun k v acc -> (k,v) :: acc) m [] + | :? 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 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 rec foldMapOpt (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) z acc = + if isEmpty m then acc,z + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> + let acc,z = foldMapOpt comparer f mn.Right z acc + let v',z = f.Invoke(mn.Key, mn.Value, z) + let acc = add comparer mn.Key v' acc + foldMapOpt comparer f mn.Left z acc + | _ -> + let v',z = f.Invoke(m.Key, m.Value, z) + add comparer m.Key v' acc,z + + let foldMap (comparer: IComparer<'Key>) f (m: MapTree<'Key, 'Value>) z acc = + foldMapOpt comparer (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m z acc + + let toList m = foldBack (fun k v acc -> (k,v) :: acc) m [] let toArray m = m |> toList |> Array.ofList let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) empty l - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = if e.MoveNext() then let (x,y) = e.Current @@ -1024,21 +960,20 @@ namespace Internal.Utilities.Collections.Tagged /// Imperative left-to-right iterators. - type MapIterator<'Key,'T>(s:MapTree<'Key,'T>) = + type MapIterator<'Key,'Value>(s:MapTree<'Key,'Value>) = // collapseLHS: // a) Always returns either [] or a list starting with SetOne. // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = + let rec collapseLHS (stack:MapTree<'Key, 'Value> list) = match stack with - | [] -> [] - | MapEmpty :: rest -> collapseLHS rest -#if ONE - | MapOne _ :: _ -> stack -#else - | (MapNode(_,_,MapEmpty,MapEmpty,_)) :: _ -> stack -#endif - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) - + | [] -> [] + | m :: rest -> + if isEmpty m then collapseLHS rest + else + match m with + | :? MapTreeNode<'Key, 'Value> as mn -> collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) + | _ -> stack + /// invariant: always collapseLHS result let mutable stack = collapseLHS [s] /// true when MoveNext has been called @@ -1047,35 +982,30 @@ namespace Internal.Utilities.Collections.Tagged let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) - member i.Current = + member _.Current = if started then match stack with -#if ONE - | MapOne (k,v) :: _ -> new KeyValuePair<_,_>(k,v) -#else - | (MapNode(k,v,MapEmpty,MapEmpty,_)) :: _ -> new KeyValuePair<_,_>(k,v) -#endif - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" + | [] -> alreadyFinished() + | m :: _ -> + match m with + | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for current" + | _ -> new KeyValuePair<_, _>(m.Key, m.Value) else notStarted() - member i.MoveNext() = - if started then - match stack with -#if ONE - | MapOne _ :: rest -> -#else - | (MapNode(_,_,MapEmpty,MapEmpty,_)) :: rest -> -#endif - stack <- collapseLHS rest; - not stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" - else - // The first call to MoveNext "starts" the enumeration. - started <- true; - not stack.IsEmpty + member _.MoveNext() = + if started then + match stack with + | [] -> false + | m :: rest -> + match m with + | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for moveNext" + | _ -> + stack <- collapseLHS rest + not stack.IsEmpty + else + started <- true (* The first call to MoveNext "starts" the enumeration. *) + not stack.IsEmpty let toSeq s = let mutable i = MapIterator(s) @@ -1103,11 +1033,11 @@ namespace Internal.Utilities.Collections.Tagged member m.Add(k,v) = refresh m (MapTree.add comparer k v tree) member m.IsEmpty = MapTree.isEmpty tree member m.Item with get(k : 'Key) = MapTree.find comparer k tree - member m.First(f) = MapTree.first f tree + member m.First(f) = MapTree.tryPick f tree member m.Exists(f) = MapTree.exists f tree member m.Filter(f) = MapTree.filter comparer f tree |> refresh m - member m.ForAll(f) = MapTree.forAll f tree - member m.Fold f acc = MapTree.fold f tree acc + member m.ForAll(f) = MapTree.forall f tree + member m.Fold f acc = MapTree.foldBack f tree acc member m.FoldSection lo hi f acc = MapTree.foldSection comparer lo hi f tree acc member m.FoldAndMap f z = let tree,z = MapTree.foldMap comparer f tree z MapTree.empty @@ -1118,8 +1048,8 @@ namespace Internal.Utilities.Collections.Tagged member m.Partition(f) = let r1,r2 = MapTree.partition comparer f tree refresh m r1, refresh m r2 - member m.Count = MapTree.count tree - member m.ContainsKey(k) = MapTree.containsKey comparer k tree + member m.Count = MapTree.size tree + member m.ContainsKey(k) = MapTree.mem comparer k tree member m.Remove(k) = refresh m (MapTree.remove comparer k tree) member m.TryFind(k) = MapTree.tryFind comparer k tree member m.ToList() = MapTree.toList tree