Commit d2a09b20 authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'optimiseSets' into 'master'

small optimisation Data.Set: change order of cases (Bin first as more common than Tip) & avoid memory allocations

See merge request !320
parents 1c181eee 1d7c4049
Pipeline #41192 passed with stage
in 1 minute and 48 seconds
......@@ -41,31 +41,31 @@ gLexOrd{|Set|} eLexOrd x y = gLexOrd{|* -> *|} eLexOrd (toAscList x) (toAscList
instance Foldable Set where
foldr :: (a .b -> .b) .b !(Set a) -> .b
foldr _ z Tip = z
foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
foldr _ z _ = z
foldr` :: (a .b -> .b) !.b !(Set a) -> .b
foldr` _ z Tip = z
foldr` f z (Bin _ x l r) = foldr` f (f x (foldr` f z r)) l
foldr` _ z _ = z
foldl :: (.b -> .(a -> .b)) .b !(Set a) -> .b
foldl _ z Tip = z
foldl f z (Bin _ x l r) = foldl f (f (foldl f z l) x) r
foldl _ z _ = z
foldl` :: (.b -> .(a -> .b)) !.b !(Set a) -> .b
foldl` _ z Tip = z
foldl` f z (Bin _ x l r) = foldl` f (f (foldl` f z l) x) r
foldl` _ z _ = z
/*--------------------------------------------------------------------
* Query
*--------------------------------------------------------------------*/
member :: !a !(Set a) -> Bool | < a
member x Tip = False
member x (Bin _ y l r)
| x < y = member x l
| x > y = member x r
| otherwise = True
| x < y = member x l
| x > y = member x r
| otherwise = True
member x _ = False
/*--------------------------------------------------------------------
* Construction
......@@ -82,37 +82,36 @@ singleton x = Bin 1 x Tip Tip
*--------------------------------------------------------------------*/
insert :: !a !.(Set a) -> Set a | < a
insert x Tip = singleton x
insert x (Bin sz y l r)
| x < y = balanceL y (insert x l) r
| x > y = balanceR y l (insert x r)
| otherwise = Bin sz x l r
insert x t=:(Bin sz y l r)
| x < y = balanceL y (insert x l) r
| x > y = balanceR y l (insert x r)
| otherwise = t
insert x _ = singleton x
insertR :: !a !(Set a) -> Set a | < a
insertR x Tip = singleton x
insertR x t=:(Bin _ y l r)
| x < y = balanceL y (insertR x l) r
| x > y = balanceR y l (insertR x r)
| otherwise = t
| x < y = balanceL y (insertR x l) r
| x > y = balanceR y l (insertR x r)
| otherwise = t
insertR x _ = singleton x
delete :: !a !.(Set a) -> Set a | < a
delete x Tip = Tip
delete x (Bin _ y l r)
| x < y = balanceR y (delete x l) r
| x > y = balanceL y l (delete x r)
| otherwise = glue l r
| x < y = balanceR y (delete x l) r
| x > y = balanceL y l (delete x r)
| otherwise = glue l r
delete x tip = tip
/*--------------------------------------------------------------------
* Subset
*--------------------------------------------------------------------*/
isSubsetOfX :: !(Set a) !(Set a) -> Bool | < a
isSubsetOfX Tip _ = True
isSubsetOfX _ Tip = False
isSubsetOfX (Bin _ x l r) t
#! (lt, found, gt) = splitMember x t
= found && isSubsetOfX l lt && isSubsetOfX r gt
isSubsetOfX _ _ = abort "error in isSubsetOfX\n"
| t =: Tip = False
#! (lt, found, gt) = splitMember x t
= found && isSubsetOfX l lt && isSubsetOfX r gt
isSubsetOfX _ _ = True
/*--------------------------------------------------------------------
* Minimal, Maximal
......@@ -166,14 +165,16 @@ splitS x (Bin _ y l r)
difference :: !(Set a) !(Set a) -> Set a | < a
difference Tip _ = Tip
difference t1 Tip = t1
difference t1 (Bin _ x l2 r2) = case split x t1 of
(l1, r1)
| size l1l2 + size r1r2 == size t1 -> t1
| otherwise -> merge l1l2 r1r2
where
l1l2 = difference l1 l2
r1r2 = difference r1 r2
difference t1 t2 =
case t2 of
Bin _ x l2 r2 -> case split x t1 of
(l1, r1)
| size l1l2 + size r1r2 == size t1 -> t1
| otherwise -> merge l1l2 r1r2
where
l1l2 = difference l1 l2
r1r2 = difference r1 r2
_ -> t1
/*--------------------------------------------------------------------
* Intersection
......@@ -205,18 +206,18 @@ hedgeInt blo bhi (Bin _ x l r) t2
*--------------------------------------------------------------------*/
filter :: !(a -> Bool) !(Set a) -> Set a | < a
filter _ Tip = Tip
filter p (Bin _ x l r)
| p x = link x (filter p l) (filter p r)
| otherwise = merge (filter p l) (filter p r)
| p x = link x (filter p l) (filter p r)
| otherwise = merge (filter p l) (filter p r)
filter _ tip = tip
partition :: !(a -> Bool) !(Set a) -> (!Set a, !Set a) | < a
partition _ Tip = (Tip,Tip)
partition p (Bin _ x l r)
#! (l1,l2) = partition p l
#! (r1,r2) = partition p r
| p x = (link x l1 r1,merge l2 r2)
| otherwise = (merge l1 r1,link x l2 r2)
partition _ t = (t, t)
/*--------------------------------------------------------------------
* Lists
......@@ -297,26 +298,26 @@ filterLt (JustS b) t = filter` b t
*--------------------------------------------------------------------*/
split :: !a !(Set a) -> (!Set a, !Set a) | < a
split _ Tip = (Tip,Tip)
split x (Bin _ y l r)
| x < y
#! (lt, gt) = split x l
= (lt, link y gt r)
| x > y
#! (lt,gt) = split x r
= (link y l lt,gt)
| otherwise = (l, r)
| x < y
#! (lt, gt) = split x l
= (lt, link y gt r)
| x > y
#! (lt,gt) = split x r
= (link y l lt,gt)
| otherwise = (l, r)
split _ t = (t, t)
splitMember :: !a !(Set a) -> (!Set a, !Bool, !Set a) | < a
splitMember _ Tip = (Tip, False, Tip)
splitMember x (Bin _ y l r)
| x < y
#! (lt, found, gt) = splitMember x l
= (lt, found, link y gt r)
| x > y
#! (lt, found, gt) = splitMember x r
= (link y l lt, found, gt)
| otherwise = (l, True, r)
| x < y
#! (lt, found, gt) = splitMember x l
= (lt, found, link y gt r)
| x > y
#! (lt, found, gt) = splitMember x r
= (link y l lt, found, gt)
| otherwise = (l, True, r)
splitMember _ t = (t, False, t)
/*--------------------------------------------------------------------
Utility functions that maintain the balance properties of the tree.
......@@ -351,34 +352,32 @@ splitMember x (Bin _ y l r)
* Join
*--------------------------------------------------------------------*/
link :: !a !(Set a) !(Set a) -> Set a
link x Tip r = insertMin x r
link x l Tip = insertMax x l
link x l=:(Bin sizeL y ly ry) r=:(Bin sizeR z lz rz)
| delta*sizeL < sizeR = balanceL z (link x l lz) rz
| delta*sizeR < sizeL = balanceR y ly (link x ry r)
| otherwise = bin x l r
link _ _ _ = abort "error in link\n"
| delta*sizeL < sizeR = balanceL z (link x l lz) rz
| delta*sizeR < sizeL = balanceR y ly (link x ry r)
| otherwise = bin x l r
link x Tip r = insertMin x r
link x l _ = insertMax x l
// insertMin and insertMax don't perform potentially expensive comparisons.
insertMax :: !a !(Set a) -> Set a
insertMax x Tip = singleton x
insertMax x (Bin _ y l r) = balanceR y l (insertMax x r)
insertMax x _ = singleton x
insertMin :: !a !(Set a) -> Set a
insertMin x Tip = singleton x
insertMin x (Bin _ y l r) = balanceL y (insertMin x l) r
insertMin x _ = singleton x
/*--------------------------------------------------------------------
* [merge l r]: merges two trees.
*--------------------------------------------------------------------*/
merge :: !(Set a) !(Set a) -> Set a
merge Tip r = r
merge l Tip = l
merge l=:(Bin sizeL x lx rx) r=:(Bin sizeR y ly ry)
| delta*sizeL < sizeR = balanceL y (merge l ly) ry
| delta*sizeR < sizeL = balanceR x lx (merge rx r)
| otherwise = glue l r
merge _ _ = abort "error in merge\n"
merge Tip r = r
merge l _ = l
/*--------------------------------------------------------------------
* [glue l r]: glues two trees together.
......@@ -473,49 +472,47 @@ ratio :== 2
// right subtree might have been deleted from.
balanceL :: !a !(Set a) !(Set a) -> Set a
balanceL x l r = case r of
Tip -> case l of
Tip -> Bin 1 x Tip Tip
(Bin _ _ Tip Tip) -> Bin 2 x l Tip
(Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
(Bin _ lx ll=:(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
(Bin ls lx ll=:(Bin lls _ _ _) lr=:(Bin lrs lrx lrl lrr))
| lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
| otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
(Bin rs _ _ _) -> case l of
Tip -> Bin (1+rs) x Tip r
(Bin ls lx ll lr)
| ls > delta*rs -> case (ll, lr) of
(Bin lls _ _ _, Bin lrs lrx lrl lrr)
| lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
| otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
(_, _) -> abort "Failure in Data.Map.balanceL"
| otherwise -> Bin (1+ls+rs) x l r
Bin rs _ _ _ -> case l of
Bin ls lx ll lr
| ls > delta*rs
# (Bin lls _ _ _ ) = ll
# (Bin lrs lrx lrl lrr) = lr
| lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
| otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
| otherwise -> Bin (1+ls+rs) x l r
_ -> Bin (1+rs) x Tip r
_ -> case l of
Bin ls lx ll=:(Bin lls _ _ _) lr=:(Bin lrs lrx lrl lrr)
| lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
| otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
Bin _ lx ll=:(Bin _ _ _ _) Tip -> Bin 3 lx ll (Bin 1 x Tip Tip)
Bin _ _ _ _ -> Bin 2 x l Tip
_ -> Bin 1 x Tip Tip
// balanceR is called when right subtree might have been inserted to or when
// left subtree might have been deleted from.
balanceR :: !a !(Set a) !(Set a) -> Set a
balanceR x l r = case l of
Tip -> case r of
Tip -> Bin 1 x Tip Tip
(Bin _ _ Tip Tip) -> Bin 2 x Tip r
(Bin _ rx Tip rr=:(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
(Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
(Bin rs rx rl=:(Bin rls rlx rll rlr) rr=:(Bin rrs _ _ _))
| rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
| otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
(Bin ls _ _ _) -> case r of
Tip -> Bin (1+ls) x l Tip
(Bin rs rx rl rr)
| rs > delta*ls -> case (rl, rr) of
(Bin rls rlx rll rlr, Bin rrs _ _ _)
| rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
| otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
(_, _) -> abort "Failure in Data.Map.balanceR"
| otherwise -> Bin (1+ls+rs) x l r
Bin ls _ _ _ -> case r of
Bin rs rx rl rr
| rs > delta*ls
# (Bin rls rlx rll rlr) = rl
# (Bin rrs _ _ _ ) = rr
| rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
| otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
| otherwise -> Bin (1+ls+rs) x l r
_ -> Bin (1+ls) x l Tip
_ -> case r of
Bin rs rx rl=:(Bin rls rlx rll rlr) rr=:(Bin rrs _ _ _)
| rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
| otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
Bin _ rx Tip rr=:(Bin _ _ _ _) -> Bin 3 rx (Bin 1 x Tip Tip) rr
Bin _ rx (Bin _ rlx _ _) Tip-> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
Bin _ _ _ _ -> Bin 2 x Tip r
_ -> Bin 1 x Tip Tip
// rotate
rotateL :: !a !(Set a) !(Set a) -> Set a
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment