diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 479b8def82b..0d7386324de 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