AvlTree-4.3: src/Data/Tree/AVL/Internals/HPush.hs
-- |
-- Copyright : (c) Adrian Hey 2004,2005
-- License : BSD3
--
-- Functions for pushing elements into trees of known height.
module Data.Tree.AVL.Internals.HPush
(pushHL,pushHR,pushHL_,pushHR_,
) where
import Data.Tree.AVL.Internals.Types(AVL(..))
import GHC.Base
#include "ghcdefs.h"
-- | A version of 'Data.Tree.AVL.pushL' for an AVL tree of known height.
-- Returns an AVL tree of known height.
-- It's OK if height is relative, with fixed offset. In this case the height of the result
-- will have the same fixed offset.
{-# INLINE pushHL #-}
pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT)
pushHL e t h = pushHL_ (Z E e E) t h
-- | A version of 'Data.Tree.AVL.pushR' for an AVL tree of known height.
-- Returns an AVL tree of known height.
-- It's OK if height is relative, with fixed offset. In this case the height of the result
-- will have the same fixed offset.
{-# INLINE pushHR #-}
pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT)
pushHR t h e = pushHR_ t h (Z E e E)
-- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height,
-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.
-- In this case the height of the result will have the same fixed offset.
--
-- Complexity: O(log n)
pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT)
pushHL_ t0 t h = case t of
E -> UBT2(t0, INCINT1(h)) -- Relative Heights
N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h)
P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h)
Z l e r -> let t_ = putZL l e r
in case t_ of
Z _ _ _ -> UBT2(t_, h )
P _ _ _ -> UBT2(t_, INCINT1(h))
_ -> error "pushHL_: Bug0" -- impossible
where
----------------------------- LEVEL 2 ---------------------------------
-- putNL, putZL, putPL --
-----------------------------------------------------------------------
-- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P)
putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0
putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N l' e r
putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N l' e r
putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes
in case l' of
Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0
_ -> error "pushHL_: Bug1" -- impossible
-- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N)
putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1
putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z l' e r
putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z l' e r
putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes
in case l' of
Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
N _ _ _ -> error "pushHL_: Bug2" -- impossible
_ -> P l' e r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1
-------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------
-- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N)
putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1
putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P l' e r
putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P l' e r
putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- putPLL --
-----------------------------------------------------------------------
-- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N)
{-# INLINE putPLL #-}
putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!!
putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P (Z ll' le lr) e r
putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P (Z ll' le lr) e r
putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes
in case ll' of
Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change
N _ _ _ -> error "pushHL_: Bug4" -- impossible
_ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height,
-- returning an AVL tree of known height. It's OK if height is relative, with fixed offset.
-- In this case the height of the result will have the same fixed offset.
--
-- Complexity: O(log n)
pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT)
pushHR_ t h t0 = case t of
E -> UBT2(t0, INCINT1(h)) -- Relative Heights
N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h)
P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h)
Z l e r -> let t_ = putZR l e r
in case t_ of
Z _ _ _ -> UBT2(t_, h )
N _ _ _ -> UBT2(t_, INCINT1(h))
_ -> error "pushHR_: Bug0" -- impossible
where
----------------------------- LEVEL 2 ---------------------------------
-- putNR, putZR, putPR --
-----------------------------------------------------------------------
-- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P)
putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1
putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z l e r'
putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z l e r'
putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes
in case r' of
Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1
_ -> error "pushHR_: Bug1" -- impossible
-- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N)
putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0
putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P l e r'
putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P l e r'
putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes
in case r' of
Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0
_ -> error "pushHR_: Bug2" -- impossible
-------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------
-- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P)
putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1
putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N l e r'
putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N l e r'
putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P)
----------------------------- LEVEL 3 ---------------------------------
-- putNRR --
-----------------------------------------------------------------------
-- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P)
{-# INLINE putNRR #-}
putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!!
putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N l e (Z rl re rr')
putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N l e (Z rl re rr')
putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes
in case rr' of
Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change
N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
_ -> error "pushHR_: Bug4" -- impossible