AvlTree-4.3: src/Data/Tree/AVL/List.hs
-- |
-- Copyright : (c) Adrian Hey 2004,2005
-- License : BSD3
--
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Tree.AVL.List
(-- * List related utilities for AVL trees
-- ** Converting AVL trees to Lists (fixed element order).
-- | These functions are lazy and allow normal lazy list processing
-- style to be used (without necessarily converting the entire tree
-- to a list in one gulp).
asListL,toListL,asListR,toListR,
-- ** Converting Lists to AVL trees (fixed element order)
asTreeLenL,asTreeL,
asTreeLenR,asTreeR,
-- ** Converting unsorted Lists to sorted AVL trees
asTree,
-- ** \"Pushing\" unsorted Lists in sorted AVL trees
pushList,
-- * Some analogues of common List functions
reverse,map,map',
mapAccumL ,mapAccumR ,
mapAccumL' ,mapAccumR' ,
replicate,
filter,mapMaybe,
filterViaList,mapMaybeViaList,
partition,
traverseAVL,
-- ** Folds
-- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no
-- significant difference between left and right folds in AVL trees, other
-- than which side of the tree each starts with.
-- Therefore this library provides strict and lazy versions of both.
foldr,foldr',foldr1,foldr1',foldr2,foldr2',
foldl,foldl',foldl1,foldl1',foldl2,foldl2',
-- ** (GHC Only)
mapAccumL'',mapAccumR'', foldrInt#,
-- * Some clones of common List functions
-- | These are a cure for the horrible @O(n^2)@ complexity the noddy Data.List definitions.
nub,nubBy,
-- * \"Flattening\" AVL trees
-- | These functions can be improve search times by reducing a tree of given size to
-- the minimum possible height.
flatten,
flatReverse,flatMap,flatMap',
) where
import Prelude (seq, (+), (-), odd, error)
import Data.Eq ((==))
import Data.Bool (Bool(..), (||))
import Data.Int (Int)
import Data.Foldable (length)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord, compare, Ordering)
import Data.COrdering
import Data.Tree.AVL.Internals.Types(AVL(..))
import Data.Tree.AVL.Utils(empty)
import Data.Tree.AVL.Size(size)
import Data.Tree.AVL.Push(push)
import Data.Tree.AVL.BinPath(findEmptyPath,insertPath)
import Data.Tree.AVL.Internals.HJoin(spliceH,joinH)
import Data.Bits(shiftR,(.&.))
import qualified Data.List as List (foldl',map)
import Control.Applicative hiding (empty)
import GHC.Base(Int#,(-#))
#include "ghcdefs.h"
-- | List AVL tree contents in left to right order.
-- The resulting list in ascending order if the tree is sorted.
--
-- Complexity: O(n)
asListL :: AVL e -> [e]
asListL avl = toListL avl []
-- | Join the AVL tree contents to an existing list in left to right order.
-- This is a ++ free function which behaves as if defined thusly..
--
-- > avl `toListL` as = (asListL avl) ++ as
--
-- Complexity: O(n)
toListL :: AVL e -> [e] -> [e]
toListL E es = es
toListL (N l e r) es = toListL' l e r es
toListL (Z l e r) es = toListL' l e r es
toListL (P l e r) es = toListL' l e r es
toListL' :: AVL e -> e -> AVL e -> [e] -> [e]
toListL' l e r es = toListL l (e:(toListL r es))
-- | List AVL tree contents in right to left order.
-- The resulting list in descending order if the tree is sorted.
--
-- Complexity: O(n)
asListR :: AVL e -> [e]
asListR avl = toListR avl []
-- | Join the AVL tree contents to an existing list in right to left order.
-- This is a ++ free function which behaves as if defined thusly..
--
-- > avl `toListR` as = (asListR avl) ++ as
--
-- Complexity: O(n)
toListR :: AVL e -> [e] -> [e]
toListR E es = es
toListR (N l e r) es = toListR' l e r es
toListR (Z l e r) es = toListR' l e r es
toListR (P l e r) es = toListR' l e r es
toListR' :: AVL e -> e -> AVL e -> [e] -> [e]
toListR' l e r es = toListR r (e:(toListR l es))
-- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function
-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)
-- stack use. See 'foldr'' for a strict version.
--
-- It behaves as if defined..
--
-- > foldr f a avl = foldr f a (asListL avl)
--
-- For example, the 'asListL' function could be defined..
--
-- > asListL = foldr (:) []
--
-- Complexity: O(n)
foldr :: (e -> a -> a) -> a -> AVL e -> a
foldr f = foldU where
foldU a E = a
foldU a (N l e r) = foldV a l e r
foldU a (Z l e r) = foldV a l e r
foldU a (P l e r) = foldV a l e r
foldV a l e r = foldU (f e (foldU a r)) l
-- | The strict version of 'foldr', which is useful for functions which are strict in their second
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldr' :: (e -> a -> a) -> a -> AVL e -> a
foldr' f = foldU where
foldU a E = a
foldU a (N l e r) = foldV a l e r
foldU a (Z l e r) = foldV a l e r
foldU a (P l e r) = foldV a l e r
foldV a l e r = let a' = foldU a r
a'' = f e a'
in a' `seq` a'' `seq` foldU a'' l
-- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function
-- anyway). Using this version with a function that is strict in it's second argument will result in O(n)
-- stack use. See 'foldr1'' for a strict version.
--
-- > foldr1 f avl = foldr1 f (asListL avl)
--
-- This function raises an error if the tree is empty.
--
-- Complexity: O(n)
foldr1 :: (e -> e -> e) -> AVL e -> e
foldr1 f = foldU where
foldU E = error "foldr1: Empty Tree"
foldU (N l e r) = foldV l e r -- r can't be E
foldU (Z l e r) = foldW l e r -- r might be E
foldU (P l e r) = foldW l e r -- r might be E
-- Use this when r can't be E
foldV l e r = foldr f (f e (foldU r)) l
-- Use this when r might be E
foldW l e E = foldr f e l
foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E
foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E
foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E
-- Common code for foldW (Z and P cases)
foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l
-- | The strict version of 'foldr1', which is useful for functions which are strict in their second
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldr1' :: (e -> e -> e) -> AVL e -> e
foldr1' f = foldU where
foldU E = error "foldr1': Empty Tree"
foldU (N l e r) = foldV l e r -- r can't be E
foldU (Z l e r) = foldW l e r -- r might be E
foldU (P l e r) = foldW l e r -- r might be E
-- Use this when r can't be E
foldV l e r = let a = foldU r
a' = f e a
in a `seq` a' `seq` foldr' f a' l
-- Use this when r might be E
foldW l e E = foldr' f e l
foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E
a' = f e a
in a `seq` a' `seq` foldr' f a' l
foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E
foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E
-- Common code for foldW (Z and P cases)
foldX l e rl re rr = let a = foldW rl re rr
a' = f e a
in a `seq` a' `seq` foldr' f a' l
-- | This fold is a hybrid between 'foldr' and 'foldr1'. As with 'foldr1', it requires
-- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies
-- a function to it (second function argument) and uses the result instead. This allows
-- a more flexible type for the main folding function (same type as that used by 'foldr').
-- As with 'foldr' and 'foldr1', this function is lazy, so it's best not to use it with functions
-- that are strict in their second argument. See 'foldr2'' for a strict version.
--
-- Complexity: O(n)
foldr2 :: (e -> a -> a) -> (e -> a) -> AVL e -> a
foldr2 f g = foldU where
foldU E = error "foldr2: Empty Tree"
foldU (N l e r) = foldV l e r -- r can't be E
foldU (Z l e r) = foldW l e r -- r might be E
foldU (P l e r) = foldW l e r -- r might be E
-- Use this when r can't be E
foldV l e r = foldr f (f e (foldU r)) l
-- Use this when r might be E
foldW l e E = foldr f (g e) l
foldW l e (N rl re rr) = foldr f (f e (foldV rl re rr)) l -- rr can't be E
foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E
foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E
-- Common code for foldW (Z and P cases)
foldX l e rl re rr = foldr f (f e (foldW rl re rr)) l
-- | The strict version of 'foldr2', which is useful for functions which are strict in their second
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldr2' :: (e -> a -> a) -> (e -> a) -> AVL e -> a
foldr2' f g = foldU where
foldU E = error "foldr2': Empty Tree"
foldU (N l e r) = foldV l e r -- r can't be E
foldU (Z l e r) = foldW l e r -- r might be E
foldU (P l e r) = foldW l e r -- r might be E
-- Use this when r can't be E
foldV l e r = let a = foldU r
a' = f e a
in a `seq` a' `seq` foldr' f a' l
-- Use this when r might be E
foldW l e E = let a = g e in a `seq` foldr' f a l
foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E
a' = f e a
in a `seq` a' `seq` foldr' f a' l
foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E
foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E
-- Common code for foldW (Z and P cases)
foldX l e rl re rr = let a = foldW rl re rr
a' = f e a
in a `seq` a' `seq` foldr' f a' l
-- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function
-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)
-- stack use. See 'foldl'' for a strict version.
--
-- > foldl f a avl = foldl f a (asListL avl)
--
-- For example, the 'asListR' function could be defined..
--
-- > asListR = foldl (flip (:)) []
--
-- Complexity: O(n)
foldl :: (a -> e -> a) -> a -> AVL e -> a
foldl f = foldU where
foldU a E = a
foldU a (N l e r) = foldV a l e r
foldU a (Z l e r) = foldV a l e r
foldU a (P l e r) = foldV a l e r
foldV a l e r = foldU (f (foldU a l) e) r
-- | The strict version of 'foldl', which is useful for functions which are strict in their first
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldl' :: (a -> e -> a) -> a -> AVL e -> a
foldl' f = foldU where
foldU a E = a
foldU a (N l e r) = foldV a l e r
foldU a (Z l e r) = foldV a l e r
foldU a (P l e r) = foldV a l e r
foldV a l e r = let a' = foldU a l
a'' = f a' e
in a' `seq` a'' `seq` foldU a'' r
-- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function
-- anyway). Using this version with a function that is strict in it's first argument will result in O(n)
-- stack use. See 'foldl1'' for a strict version.
--
-- > foldl1 f avl = foldl1 f (asListL avl)
--
-- This function raises an error if the tree is empty.
--
-- Complexity: O(n)
foldl1 :: (e -> e -> e) -> AVL e -> e
foldl1 f = foldU where
foldU E = error "foldl1: Empty Tree"
foldU (N l e r) = foldW l e r -- l might be E
foldU (Z l e r) = foldW l e r -- l might be E
foldU (P l e r) = foldV l e r -- l can't be E
-- Use this when l can't be E
foldV l e r = foldl f (f (foldU l) e) r
-- Use this when l might be E
foldW E e r = foldl f e r
foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E
-- Common code for foldW (Z and P cases)
foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r
-- | The strict version of 'foldl1', which is useful for functions which are strict in their first
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldl1' :: (e -> e -> e) -> AVL e -> e
foldl1' f = foldU where
foldU E = error "foldl1': Empty Tree"
foldU (N l e r) = foldW l e r -- l might be E
foldU (Z l e r) = foldW l e r -- l might be E
foldU (P l e r) = foldV l e r -- l can't be E
-- Use this when l can't be E
foldV l e r = let a = foldU l
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- Use this when l might be E
foldW E e r = foldl' f e r
foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- Common code for foldW (Z and P cases)
foldX ll le lr e r = let a = foldW ll le lr
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- | This fold is a hybrid between 'foldl' and 'foldl1'. As with 'foldl1', it requires
-- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies
-- a function to it (second function argument) and uses the result instead. This allows
-- a more flexible type for the main folding function (same type as that used by 'foldl').
-- As with 'foldl' and 'foldl1', this function is lazy, so it's best not to use it with functions
-- that are strict in their first argument. See 'foldl2'' for a strict version.
--
-- Complexity: O(n)
foldl2 :: (a -> e -> a) -> (e -> a) -> AVL e -> a
foldl2 f g = foldU where
foldU E = error "foldl2: Empty Tree"
foldU (N l e r) = foldW l e r -- l might be E
foldU (Z l e r) = foldW l e r -- l might be E
foldU (P l e r) = foldV l e r -- l can't be E
-- Use this when l can't be E
foldV l e r = foldl f (f (foldU l) e) r
-- Use this when l might be E
foldW E e r = foldl f (g e) r
foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (P ll le lr) e r = foldl f (f (foldV ll le lr) e) r -- ll can't be E
-- Common code for foldW (Z and P cases)
foldX ll le lr e r = foldl f (f (foldW ll le lr) e) r
-- | The strict version of 'foldl2', which is useful for functions which are strict in their first
-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy
-- version gives (when used with strict functions) to O(log n).
--
-- Complexity: O(n)
foldl2' :: (a -> e -> a) -> (e -> a) -> AVL e -> a
foldl2' f g = foldU where
foldU E = error "foldl2': Empty Tree"
foldU (N l e r) = foldW l e r -- l might be E
foldU (Z l e r) = foldW l e r -- l might be E
foldU (P l e r) = foldV l e r -- l can't be E
-- Use this when l can't be E
foldV l e r = let a = foldU l
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- Use this when l might be E
foldW E e r = let a = g e in a `seq` foldl' f a r
foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E
foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- Common code for foldW (Z and P cases)
foldX ll le lr e r = let a = foldW ll le lr
a' = f a e
in a `seq` a' `seq` foldl' f a' r
-- | This is a specialised version of 'foldr'' for use with an
-- /unboxed/ Int accumulator.
--
-- Complexity: O(n)
foldrInt# :: (e -> UINT -> UINT) -> UINT -> AVL e -> UINT
foldrInt# f = foldU where
foldU a E = a
foldU a (N l e r) = foldV a l e r
foldU a (Z l e r) = foldV a l e r
foldU a (P l e r) = foldV a l e r
foldV a l e r = foldU (f e (foldU a r)) l
-- | The AVL equivalent of 'Data.List.mapAccumL' on lists.
-- It behaves like a combination of 'map' and 'foldl'.
-- It applies a function to each element of a tree, passing an accumulating parameter from
-- left to right, and returning a final value of this accumulator together with the new tree.
--
-- Using this version with a function that is strict in it's first argument will result in
-- O(n) stack use. See 'mapAccumL'' for a strict version.
--
-- Complexity: O(n)
mapAccumL :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumL f z ta = case mapAL z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAL z_ E = UBT2(z_,E)
mapAL z_ (N la a ra) = mapAL' z_ N la a ra
mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra
mapAL z_ (P la a ra) = mapAL' z_ P la a ra
{-# INLINE mapAL' #-}
mapAL' z' c la a ra = case mapAL z' la of
UBT2(zl,lb) -> let (za,b) = f zl a
in case mapAL za ra of
UBT2(zr,rb) -> UBT2(zr, c lb b rb)
-- | This is a strict version of 'mapAccumL', which is useful for functions which
-- are strict in their first argument. The advantage of this version is that it reduces
-- the stack use from the O(n) that the lazy version gives (when used with strict functions)
-- to O(log n).
--
-- Complexity: O(n)
mapAccumL' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumL' f z ta = case mapAL z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAL z_ E = UBT2(z_,E)
mapAL z_ (N la a ra) = mapAL' z_ N la a ra
mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra
mapAL z_ (P la a ra) = mapAL' z_ P la a ra
{-# INLINE mapAL' #-}
mapAL' z' c la a ra = case mapAL z' la of
UBT2(zl,lb) -> case f zl a of
(za,b) -> case mapAL za ra of
UBT2(zr,rb) -> UBT2(zr, c lb b rb)
-- | The AVL equivalent of 'Data.List.mapAccumR' on lists.
-- It behaves like a combination of 'map' and 'foldr'.
-- It applies a function to each element of a tree, passing an accumulating parameter from
-- right to left, and returning a final value of this accumulator together with the new tree.
--
-- Using this version with a function that is strict in it's first argument will result in
-- O(n) stack use. See 'mapAccumR'' for a strict version.
--
-- Complexity: O(n)
mapAccumR :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumR f z ta = case mapAR z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAR z_ E = UBT2(z_,E)
mapAR z_ (N la a ra) = mapAR' z_ N la a ra
mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra
mapAR z_ (P la a ra) = mapAR' z_ P la a ra
{-# INLINE mapAR' #-}
mapAR' z' c la a ra = case mapAR z' ra of
UBT2(zr,rb) -> let (za,b) = f zr a
in case mapAR za la of
UBT2(zl,lb) -> UBT2(zl, c lb b rb)
-- | This is a strict version of 'mapAccumR', which is useful for functions which
-- are strict in their first argument. The advantage of this version is that it reduces
-- the stack use from the O(n) that the lazy version gives (when used with strict functions)
-- to O(log n).
--
-- Complexity: O(n)
mapAccumR' :: (z -> a -> (z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumR' f z ta = case mapAR z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAR z_ E = UBT2(z_,E)
mapAR z_ (N la a ra) = mapAR' z_ N la a ra
mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra
mapAR z_ (P la a ra) = mapAR' z_ P la a ra
{-# INLINE mapAR' #-}
mapAR' z' c la a ra = case mapAR z' ra of
UBT2(zr,rb) -> case f zr a of
(za,b) -> case mapAR za la of
UBT2(zl,lb) -> UBT2(zl, c lb b rb)
-- These two functions attempt to make the strict mapAccums more efficient and reduce heap
-- burn rate with ghc by using an accumulating function that returns an unboxed pair.
-- | Similar to 'mapAccumL'' but uses an unboxed pair in the
-- accumulating function.
--
-- Complexity: O(n)
mapAccumL''
:: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumL'' f z ta = case mapAL z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAL z_ E = UBT2(z_,E)
mapAL z_ (N la a ra) = mapAL' z_ N la a ra
mapAL z_ (Z la a ra) = mapAL' z_ Z la a ra
mapAL z_ (P la a ra) = mapAL' z_ P la a ra
{-# INLINE mapAL' #-}
mapAL' z' c la a ra = case mapAL z' la of
UBT2(zl,lb) -> case f zl a of
UBT2(za,b) -> case mapAL za ra of
UBT2(zr,rb) -> UBT2(zr, c lb b rb)
-- | Similar to 'mapAccumR'' but uses an unboxed pair in the
-- accumulating function.
--
-- Complexity: O(n)
mapAccumR''
:: (z -> a -> UBT2(z, b)) -> z -> AVL a -> (z, AVL b)
mapAccumR'' f z ta = case mapAR z ta of
UBT2(zt,tb) -> (zt,tb)
where mapAR z_ E = UBT2(z_,E)
mapAR z_ (N la a ra) = mapAR' z_ N la a ra
mapAR z_ (Z la a ra) = mapAR' z_ Z la a ra
mapAR z_ (P la a ra) = mapAR' z_ P la a ra
{-# INLINE mapAR' #-}
mapAR' z' c la a ra = case mapAR z' ra of
UBT2(zr,rb) -> case f zr a of
UBT2(za,b) -> case mapAR za la of
UBT2(zl,lb) -> UBT2(zl, c lb b rb)
--------------------------------------
-- | Convert a list of known length into an AVL tree, such that the head of the list becomes
-- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list
-- is sorted in ascending order).
--
-- If the actual length of the list is not the same as the supplied length then
-- an error will be raised.
--
-- Complexity: O(n)
asTreeLenL :: Int -> [e] -> AVL e
asTreeLenL n es = case subst (replicate n ()) es of
UBT2(tree,es_) -> case es_ of
[] -> tree
_ -> error "asTreeLenL: List too long."
where
-- Substitute template values for real values taken from the list
subst E as = UBT2(E,as)
subst (N l _ r) as = subst' N l r as
subst (Z l _ r) as = subst' Z l r as
subst (P l _ r) as = subst' P l r as
{-# INLINE subst' #-}
subst' f l r as = case subst l as of
UBT2(l_,xs) -> case xs of
a:as' -> case subst r as' of
UBT2(r_,as__) -> let t_ = f l_ a r_
in t_ `seq` UBT2(t_,as__)
[] -> error "asTreeLenL: List too short."
-- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied
-- as an argument.
--
-- Complexity: O(n)
asTreeL :: [e] -> AVL e
asTreeL es = asTreeLenL (length es) es
-- | Convert a list of known length into an AVL tree, such that the head of the list becomes
-- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list
-- is sorted in descending order).
--
-- If the actual length of the list is not the same as the supplied length then
-- an error will be raised.
--
-- Complexity: O(n)
asTreeLenR :: Int -> [e] -> AVL e
asTreeLenR n es = case subst (replicate n ()) es of
UBT2(tree,es_) -> case es_ of
[] -> tree
_ -> error "asTreeLenR: List too long."
where
-- Substitute template values for real values taken from the list
subst E as = UBT2(E,as)
subst (N l _ r) as = subst' N l r as
subst (Z l _ r) as = subst' Z l r as
subst (P l _ r) as = subst' P l r as
{-# INLINE subst' #-}
subst' f l r as = case subst r as of
UBT2(r_,xs) -> case xs of
a:as' -> case subst l as' of
UBT2(l_,as__) -> let t_ = f l_ a r_
in t_ `seq` UBT2(t_,as__)
[] -> error "asTreeLenR: List too short."
-- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied
-- as an argument.
--
-- Complexity: O(n)
asTreeR :: [e] -> AVL e
asTreeR es = asTreeLenR (length es) es
-- | Reverse an AVL tree (swaps and reverses left and right sub-trees).
-- The resulting tree is the mirror image of the original.
--
-- Complexity: O(n)
reverse :: AVL e -> AVL e
reverse E = E
reverse (N l e r) = let l' = reverse l
r' = reverse r
in l' `seq` r' `seq` P r' e l'
reverse (Z l e r) = let l' = reverse l
r' = reverse r
in l' `seq` r' `seq` Z r' e l'
reverse (P l e r) = let l' = reverse l
r' = reverse r
in l' `seq` r' `seq` N r' e l'
-- | Apply a function to every element in an AVL tree. This function preserves the tree shape.
-- There is also a strict version of this function ('map'').
--
-- N.B. If the tree is sorted the result of this operation will only be sorted if
-- the applied function preserves ordering (for some suitable ordering definition).
--
-- Complexity: O(n)
map :: (a -> b) -> AVL a -> AVL b
map f = mp where
mp E = E
mp (N l a r) = let l' = mp l
r' = mp r
in l' `seq` r' `seq` N l' (f a) r'
mp (Z l a r) = let l' = mp l
r' = mp r
in l' `seq` r' `seq` Z l' (f a) r'
mp (P l a r) = let l' = mp l
r' = mp r
in l' `seq` r' `seq` P l' (f a) r'
-- | Similar to 'map', but the supplied function is applied strictly.
--
-- Complexity: O(n)
map' :: (a -> b) -> AVL a -> AVL b
map' f = mp' where
mp' E = E
mp' (N l a r) = let l' = mp' l
r' = mp' r
b = f a
in b `seq` l' `seq` r' `seq` N l' b r'
mp' (Z l a r) = let l' = mp' l
r' = mp' r
b = f a
in b `seq` l' `seq` r' `seq` Z l' b r'
mp' (P l a r) = let l' = mp' l
r' = mp' r
b = f a
in b `seq` l' `seq` r' `seq` P l' b r'
-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical.
--
-- Complexity: O(log n)
replicate :: Int -> e -> AVL e
replicate m e = rep m where -- Functional spaghetti follows :-)
rep n | odd n = repOdd n -- n is odd , >=1
rep n = repEvn n -- n is even, >=0
-- n is known to be odd (>=1), so left and right sub-trees are identical
repOdd n = let sub = rep (n `shiftR` 1) in sub `seq` Z sub e sub
-- n is known to be even (>=0)
repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too
repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even)
nr = nl - 1 -- size of right subtree (even or odd)
in if odd nr
then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2)
r = repOdd nr
in l `seq` r `seq` Z l e r
else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2)
r = repEvn nr
in l `seq` r `seq` Z l e r
-- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..
repP2 0 = E
repP2 1 = Z E e E
repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2
nr = nl - 1 -- nr is one less that an exact power of 2
l = repP2 nl
r = repP2M1 nr
in l `seq` r `seq` P l e r -- BF=+1
-- n is one less than an exact power of 2, I.E. 0,1,3,7,15..
repP2M1 0 = E
repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub
-- | Flatten an AVL tree, preserving the ordering of the tree elements.
--
-- Complexity: O(n)
flatten :: AVL e -> AVL e
flatten t = asTreeLenL (size t) (asListL t)
-- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant
-- factor overhead than 'reverse'.
--
-- Complexity: O(n)
flatReverse :: AVL e -> AVL e
flatReverse t = asTreeLenL (size t) (asListR t)
-- | Similar to 'map', but the resulting tree is flat.
-- This function has higher constant factor overhead than 'map'.
--
-- Complexity: O(n)
flatMap :: (a -> b) -> AVL a -> AVL b
flatMap f t = asTreeLenL (size t) (List.map f (asListL t))
-- | Same as 'flatMap', but the supplied function is applied strictly.
--
-- Complexity: O(n)
flatMap' :: (a -> b) -> AVL a -> AVL b
flatMap' f t = asTreeLenL (size t) (mp' f (asListL t)) where
mp' _ [] = []
mp' g (a:as) = let b = g a in b `seq` (b : mp' f as)
-- | Remove all AVL tree elements which do not satisfy the supplied predicate.
-- Element ordering is preserved. The resulting tree is flat.
-- See 'filter' for an alternative implementation which is probably more efficient.
--
-- Complexity: O(n)
filterViaList :: (e -> Bool) -> AVL e -> AVL e
filterViaList p t = filter' [] 0 (asListR t) where
filter' se n [] = asTreeLenL n se
filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es
else filter' se n es
-- | Remove all AVL tree elements which do not satisfy the supplied predicate.
-- Element ordering is preserved.
--
-- Complexity: O(n)
filter :: forall e. (e -> Bool) -> AVL e -> AVL e
filter p t0 = case filter_ L(0) t0 of UBT3(_,t_,_) -> t_ -- Work with relative heights!!
where
filter_ :: UINT -> AVL e -> UBT3(Bool, AVL e, UINT)
filter_ h t = case t of
E -> UBT3(False,E,h)
N l e r -> f l DECINT2(h) e r DECINT1(h)
Z l e r -> f l DECINT1(h) e r DECINT1(h)
P l e r -> f l DECINT1(h) e r DECINT2(h)
where f l hl e r hr = case filter_ hl l of
UBT3(bl,l_,hl_) -> case filter_ hr r of
UBT3(br,r_,hr_) -> if p e
then if bl || br
then case spliceH l_ hl_ e r_ hr_ of
UBT2(t_,h_) -> UBT3(True,t_,h_)
else UBT3(False,t,h)
else case joinH l_ hl_ r_ hr_ of
UBT2(t_,h_) -> UBT3(True,t_,h_)
-- | Partition an AVL tree using the supplied predicate. The first AVL tree in the
-- resulting pair contains all elements for which the predicate is True, the second
-- contains all those for which the predicate is False. Element ordering is preserved.
-- Both of the resulting trees are flat.
--
-- Complexity: O(n)
partition :: (e -> Bool) -> AVL e -> (AVL e, AVL e)
partition p t = part 0 [] 0 [] (asListR t) where
part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT
avlF = asTreeLenL nF lstF
in (avlT,avlF) -- Non strict in avlT, avlF !!
part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es
else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es
-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.
-- Element ordering is preserved. The resulting tree is flat.
-- See 'mapMaybe' for an alternative implementation which is probably more efficient.
--
-- Complexity: O(n)
mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b
mapMaybeViaList f t = mp' [] 0 (asListR t) where
mp' sb n [] = asTreeLenL n sb
mp' sb n (a:as) = case f a of
Just b -> let n'=n+1 in n' `seq` mp' (b:sb) n' as
Nothing -> mp' sb n as
-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'.
-- Element ordering is preserved.
--
-- Complexity: O(n)
mapMaybe :: forall a b. (a -> Maybe b) -> AVL a -> AVL b
mapMaybe f t0 = case mapMaybe_ L(0) t0 of UBT2(t_,_) -> t_ -- Work with relative heights!!
where
mapMaybe_ :: UINT -> AVL a -> UBT2(AVL b, UINT)
mapMaybe_ h t = case t of
E -> UBT2(E,h)
N l a r -> m l DECINT2(h) a r DECINT1(h)
Z l a r -> m l DECINT1(h) a r DECINT1(h)
P l a r -> m l DECINT1(h) a r DECINT2(h)
where m l hl a r hr = case mapMaybe_ hl l of
UBT2(l_,hl_) -> case mapMaybe_ hr r of
UBT2(r_,hr_) -> case f a of
Just b -> spliceH l_ hl_ b r_ hr_
Nothing -> joinH l_ hl_ r_ hr_
-- | Invokes 'pushList' on the empty AVL tree.
--
-- Complexity: O(n.(log n))
asTree :: (e -> e -> COrdering e) -> [e] -> AVL e
asTree c = pushList c empty
{-# INLINE asTree #-}
-- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison.
--
-- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size.
pushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e
pushList c avl = List.foldl' addElem avl
where addElem t e = push (c e) e t
-- | A fast alternative implementation for 'Data.List.nub'.
-- Deletes all but the first occurrence of an element from the input list.
--
-- Complexity: O(n.(log n))
nub :: Ord a => [a] -> [a]
nub = nubBy compare
{-# INLINE nub #-}
-- | A fast alternative implementation for 'Data.List.nubBy'.
-- Deletes all but the first occurrence of an element from the input list.
--
-- Complexity: O(n.(log n))
nubBy :: (a -> a -> Ordering) -> [a] -> [a]
nubBy c = nubbit E where
nubbit _ [] = []
nubbit avl (a:as) = case findEmptyPath (c a) avl of
L(-1) -> nubbit avl as -- Already encountered
p -> let avl' = insertPath p a avl -- First encounter
in avl' `seq` (a : nubbit avl' as)
-- | This is the non-overloaded version of the 'Data.Traversable.traverse' method for AVL trees.
traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b)
traverseAVL _f E = pure E
traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r
traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r
traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r