#if __GLASGOW_HASKELL__
#endif
#if __GLASGOW_HASKELL__ >= 703
#endif
#if __GLASGOW_HASKELL__ >= 708
#endif
#include "containers.h"
module Data.Sequence (
#if !defined(TESTING)
Seq,
#else
Seq(..), Elem(..), FingerTree(..), Node(..), Digit(..),
#endif
empty,
singleton,
(<|),
(|>),
(><),
fromList,
fromFunction,
fromArray,
replicate,
replicateA,
replicateM,
iterateN,
unfoldr,
unfoldl,
null,
length,
ViewL(..),
viewl,
ViewR(..),
viewr,
scanl,
scanl1,
scanr,
scanr1,
tails,
inits,
takeWhileL,
takeWhileR,
dropWhileL,
dropWhileR,
spanl,
spanr,
breakl,
breakr,
partition,
filter,
sort,
sortBy,
unstableSort,
unstableSortBy,
index,
adjust,
update,
take,
drop,
splitAt,
elemIndexL,
elemIndicesL,
elemIndexR,
elemIndicesR,
findIndexL,
findIndicesL,
findIndexR,
findIndicesR,
foldlWithIndex,
foldrWithIndex,
mapWithIndex,
reverse,
zip,
zipWith,
zip3,
zipWith3,
zip4,
zipWith4,
#if TESTING
Sized(..),
deep,
node2,
node3,
#endif
) where
import Prelude hiding (
Functor(..),
null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
import qualified Data.List
import Control.Applicative (Applicative(..), (<$>), Alternative,
WrappedMonad(..), liftA, liftA2, liftA3)
import qualified Control.Applicative as Applicative (Alternative(..))
import Control.DeepSeq (NFData(rnf))
import Control.Monad (MonadPlus(..), ap)
import Data.Monoid (Monoid(..))
import Data.Functor (Functor(..))
import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)
#if MIN_VERSION_base(4,8,0)
import Data.Foldable (foldr')
#endif
import Data.Traversable
import Data.Typeable
#ifdef __GLASGOW_HASKELL__
import GHC.Exts (build)
import Text.Read (Lexeme(Ident), lexP, parens, prec,
readPrec, readListPrec, readListPrecDefault)
import Data.Data
#endif
import Data.Array (Ix, Array)
#ifdef __GLASGOW_HASKELL__
import qualified GHC.Arr
#endif
#if __GLASGOW_HASKELL__ >= 708
import Data.Coerce
import qualified GHC.Exts
#else
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity(..))
#endif
infixr 5 `consTree`
infixl 5 `snocTree`
infixr 5 `appendTree0`
infixr 5 ><
infixr 5 <|, :<
infixl 5 |>, :>
class Sized a where
size :: a -> Int
newtype Seq a = Seq (FingerTree (Elem a))
instance Functor Seq where
fmap = fmapSeq
#ifdef __GLASGOW_HASKELL__
x <$ s = replicate (length s) x
#endif
fmapSeq :: (a -> b) -> Seq a -> Seq b
fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
#ifdef __GLASGOW_HASKELL__
#endif
#if __GLASGOW_HASKELL__ >= 709
#endif
instance Foldable Seq where
foldMap f (Seq xs) = foldMap (foldMap f) xs
foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
foldl f z (Seq xs) = foldl (foldl f) z xs
foldr1 f (Seq xs) = getElem (foldr1 f' xs)
where f' (Elem x) (Elem y) = Elem (f x y)
foldl1 f (Seq xs) = getElem (foldl1 f' xs)
where f' (Elem x) (Elem y) = Elem (f x y)
#if MIN_VERSION_base(4,8,0)
length = length
null = null
#endif
instance Traversable Seq where
traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
instance NFData a => NFData (Seq a) where
rnf (Seq xs) = rnf xs
instance Monad Seq where
return = singleton
xs >>= f = foldl' add empty xs
where add ys x = ys >< f x
(>>) = (*>)
instance Applicative Seq where
pure = singleton
Seq Empty <*> xs = xs `seq` empty
fs <*> Seq Empty = fs `seq` empty
fs <*> Seq (Single (Elem x)) = fmap ($ x) fs
fs <*> xs
| length fs < 4 = foldl' add empty fs
where add ys f = ys >< fmap f xs
fs <*> xs | length xs < 4 = apShort fs xs
fs <*> xs = apty fs xs
xs *> ys = replicateSeq (length xs) ys
apShort :: Seq (a -> b) -> Seq a -> Seq b
apShort (Seq fs) xs = Seq $ case toList xs of
[a,b] -> ap2FT fs (a,b)
[a,b,c] -> ap3FT fs (a,b,c)
_ -> error "apShort: not 2-3"
ap2FT :: FingerTree (Elem (a->b)) -> (a,a) -> FingerTree (Elem b)
ap2FT fs (x,y) = Deep (size fs * 2)
(Two (Elem $ firstf x) (Elem $ firstf y))
(mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) m)
(Two (Elem $ lastf x) (Elem $ lastf y))
where
(Elem firstf, m, Elem lastf) = trimTree fs
ap3FT :: FingerTree (Elem (a->b)) -> (a,a,a) -> FingerTree (Elem b)
ap3FT fs (x,y,z) = Deep (size fs * 3)
(Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
(mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) m)
(Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
where
(Elem firstf, m, Elem lastf) = trimTree fs
apty :: Seq (a -> b) -> Seq a -> Seq b
apty (Seq fs) (Seq xs@Deep{}) = Seq $
Deep (s' * size fs)
(fmap (fmap firstf) pr')
(aptyMiddle (fmap firstf) (fmap lastf) fmap fs' xs')
(fmap (fmap lastf) sf')
where
(Elem firstf, fs', Elem lastf) = trimTree fs
xs'@(Deep s' pr' _m' sf') = rigidify xs
apty _ _ = error "apty: expects a Deep constructor"
aptyMiddle
:: Sized c =>
(c -> d)
-> (c -> d)
-> ((a -> b) -> c -> d)
-> FingerTree (Elem (a -> b))
-> FingerTree c
-> FingerTree (Node d)
aptyMiddle firstf
lastf
map23
fs
(Deep s pr (Deep sm prm mm sfm) sf)
= Deep (sm + s * (size fs + 1))
(fmap (fmap firstf) prm)
(aptyMiddle (fmap firstf)
(fmap lastf)
(\f -> fmap (map23 f))
fs
(Deep s (squashL pr prm) mm (squashR sfm sf)))
(fmap (fmap lastf) sfm)
aptyMiddle firstf
lastf
map23
fs
(Deep s pr m sf)
= (fmap (fmap firstf) m `snocTree` fmap firstf (digitToNode sf))
`appendTree0` middle `appendTree0`
(fmap lastf (digitToNode pr) `consTree` fmap (fmap lastf) m)
where middle = case trimTree $ mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs of
(firstMapped, restMapped, lastMapped) ->
Deep (size firstMapped + size restMapped + size lastMapped)
(nodeToDigit firstMapped) restMapped (nodeToDigit lastMapped)
converted = case m of
Empty -> Node2 s lconv rconv
Single q -> Node3 s lconv q rconv
Deep{} -> error "aptyMiddle: impossible"
lconv = digitToNode pr
rconv = digitToNode sf
aptyMiddle _ _ _ _ _ = error "aptyMiddle: expected Deep finger tree"
digitToNode :: Sized a => Digit a -> Node a
digitToNode (Two a b) = node2 a b
digitToNode (Three a b c) = node3 a b c
digitToNode _ = error "digitToNode: not representable as a node"
type Digit23 = Digit
type Digit12 = Digit
squashL :: Sized a => Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
squashL (Two a b) (One n) = Two (node2 a b) n
squashL (Two a b) (Two n1 n2) = Three (node2 a b) n1 n2
squashL (Three a b c) (One n) = Two (node3 a b c) n
squashL (Three a b c) (Two n1 n2) = Three (node3 a b c) n1 n2
squashL _ _ = error "squashL: wrong digit types"
squashR :: Sized a => Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
squashR (One n) (Two a b) = Two n (node2 a b)
squashR (Two n1 n2) (Two a b) = Three n1 n2 (node2 a b)
squashR (One n) (Three a b c) = Two n (node3 a b c)
squashR (Two n1 n2) (Three a b c) = Three n1 n2 (node3 a b c)
squashR _ _ = error "squashR: wrong digit types"
mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
mapMulFT _ _ Empty = Empty
mapMulFT _mul f (Single a) = Single (f a)
mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)
mapMulNode :: Int -> (a -> b) -> Node a -> Node b
mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b)
mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)
trimTree :: Sized a => FingerTree a -> (a, FingerTree a, a)
trimTree Empty = error "trim: empty tree"
trimTree Single{} = error "trim: singleton"
trimTree t = case splitTree 0 t of
Split _ hd r ->
case splitTree (size r 1) r of
Split m tl _ -> (hd, m, tl)
rigidify :: Sized a => FingerTree a -> FingerTree a
rigidify (Deep s pr@Two{} m sf@Three{}) = Deep s pr (thin m) sf
rigidify (Deep s pr@Three{} m sf@Three{}) = Deep s pr (thin m) sf
rigidify (Deep s pr@Two{} m sf@Two{}) = Deep s pr (thin m) sf
rigidify (Deep s pr@Three{} m sf@Two{}) = Deep s pr (thin m) sf
rigidify (Deep s (Four a b c d) m sf) =
rigidify $ Deep s (Two a b) (node2 c d `consTree` m) sf
rigidify (Deep s pr m (Four a b c d)) =
rigidify $ Deep s pr (m `snocTree` node2 a b) (Two c d)
rigidify (Deep s (One a) Empty (Three b c d)) = Deep s (Two a b) Empty (Two c d)
rigidify (Deep s (One a) m sf) = rigidify $ case viewLTree m of
Just2 (Node2 _ b c) m' -> Deep s (Three a b c) m' sf
Just2 (Node3 _ b c d) m' -> Deep s (Two a b) (node2 c d `consTree` m') sf
Nothing2 -> error "rigidify: small tree"
rigidify (Deep s (Three a b c) Empty (One d)) = Deep s (Two a b) Empty (Two c d)
rigidify (Deep s pr m (One e)) = rigidify $ case viewRTree m of
Just2 m' (Node2 _ a b) -> Deep s pr m' (Three a b e)
Just2 m' (Node3 _ a b c) -> Deep s pr (m' `snocTree` node2 a b) (Two c e)
Nothing2 -> error "rigidify: small tree"
rigidify Empty = error "rigidify: empty tree"
rigidify Single{} = error "rigidify: singleton"
thin :: Sized a => FingerTree a -> FingerTree a
thin Empty = Empty
thin (Single a) = Single a
thin t@(Deep s pr m sf) =
case pr of
One{} -> thin12 t
Two{} -> thin12 t
Three a b c -> thin $ Deep s (One a) (node2 b c `consTree` m) sf
Four a b c d -> thin $ Deep s (Two a b) (node2 c d `consTree` m) sf
thin12 :: Sized a => FingerTree a -> FingerTree a
thin12 (Deep s pr m sf@One{}) = Deep s pr (thin m) sf
thin12 (Deep s pr m sf@Two{}) = Deep s pr (thin m) sf
thin12 (Deep s pr m (Three a b c)) = Deep s pr (thin $ m `snocTree` node2 a b) (One c)
thin12 (Deep s pr m (Four a b c d)) = Deep s pr (thin $ m `snocTree` node2 a b) (Two c d)
thin12 _ = error "thin12 expects a Deep FingerTree."
instance MonadPlus Seq where
mzero = empty
mplus = (><)
instance Alternative Seq where
empty = empty
(<|>) = (><)
instance Eq a => Eq (Seq a) where
xs == ys = length xs == length ys && toList xs == toList ys
instance Ord a => Ord (Seq a) where
compare xs ys = compare (toList xs) (toList ys)
#if TESTING
instance Show a => Show (Seq a) where
showsPrec p (Seq x) = showsPrec p x
#else
instance Show a => Show (Seq a) where
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (toList xs)
#endif
instance Read a => Read (Seq a) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $ prec 10 $ do
Ident "fromList" <- lexP
xs <- readPrec
return (fromList xs)
readListPrec = readListPrecDefault
#else
readsPrec p = readParen (p > 10) $ \ r -> do
("fromList",s) <- lex r
(xs,t) <- reads s
return (fromList xs,t)
#endif
instance Monoid (Seq a) where
mempty = empty
mappend = (><)
INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
#if __GLASGOW_HASKELL__
instance Data a => Data (Seq a) where
gfoldl f z s = case viewl s of
EmptyL -> z empty
x :< xs -> z (<|) `f` x `f` xs
gunfold k z c = case constrIndex c of
1 -> z empty
2 -> k (k (z (<|)))
_ -> error "gunfold"
toConstr xs
| null xs = emptyConstr
| otherwise = consConstr
dataTypeOf _ = seqDataType
dataCast1 f = gcast1 f
emptyConstr, consConstr :: Constr
emptyConstr = mkConstr seqDataType "empty" [] Prefix
consConstr = mkConstr seqDataType "<|" [] Infix
seqDataType :: DataType
seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
#endif
data FingerTree a
= Empty
| Single a
| Deep !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
#if TESTING
deriving Show
#endif
instance Sized a => Sized (FingerTree a) where
size Empty = 0
size (Single x) = size x
size (Deep v _ _ _) = v
instance Foldable FingerTree where
foldMap _ Empty = mempty
foldMap f (Single x) = f x
foldMap f (Deep _ pr m sf) =
foldMap f pr `mappend` (foldMap (foldMap f) m `mappend` foldMap f sf)
foldr _ z Empty = z
foldr f z (Single x) = x `f` z
foldr f z (Deep _ pr m sf) =
foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
foldl _ z Empty = z
foldl f z (Single x) = z `f` x
foldl f z (Deep _ pr m sf) =
foldl f (foldl (foldl f) (foldl f z pr) m) sf
foldr1 _ Empty = error "foldr1: empty sequence"
foldr1 _ (Single x) = x
foldr1 f (Deep _ pr m sf) =
foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
foldl1 _ Empty = error "foldl1: empty sequence"
foldl1 _ (Single x) = x
foldl1 f (Deep _ pr m sf) =
foldl f (foldl (foldl f) (foldl1 f pr) m) sf
instance Functor FingerTree where
fmap _ Empty = Empty
fmap f (Single x) = Single (f x)
fmap f (Deep v pr m sf) =
Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
instance Traversable FingerTree where
traverse _ Empty = pure Empty
traverse f (Single x) = Single <$> f x
traverse f (Deep v pr m sf) =
Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
traverse f sf
instance NFData a => NFData (FingerTree a) where
rnf (Empty) = ()
rnf (Single x) = rnf x
rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m
deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
deep pr m sf = Deep (size pr + size m + size sf) pr m sf
pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
pullL s m sf = case viewLTree m of
Nothing2 -> digitToTree' s sf
Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
pullR s pr m = case viewRTree m of
Nothing2 -> digitToTree' s pr
Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
deepL Nothing m sf = pullL (size m + size sf) m sf
deepL (Just pr) m sf = deep pr m sf
deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
deepR pr m Nothing = pullR (size m + size pr) pr m
deepR pr m (Just sf) = deep pr m sf
data Digit a
= One a
| Two a a
| Three a a a
| Four a a a a
#if TESTING
deriving Show
#endif
instance Foldable Digit where
foldMap f (One a) = f a
foldMap f (Two a b) = f a `mappend` f b
foldMap f (Three a b c) = f a `mappend` (f b `mappend` f c)
foldMap f (Four a b c d) = f a `mappend` (f b `mappend` (f c `mappend` f d))
foldr f z (One a) = a `f` z
foldr f z (Two a b) = a `f` (b `f` z)
foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
foldl f z (One a) = z `f` a
foldl f z (Two a b) = (z `f` a) `f` b
foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
foldr1 _ (One a) = a
foldr1 f (Two a b) = a `f` b
foldr1 f (Three a b c) = a `f` (b `f` c)
foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
foldl1 _ (One a) = a
foldl1 f (Two a b) = a `f` b
foldl1 f (Three a b c) = (a `f` b) `f` c
foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
instance Functor Digit where
fmap f (One a) = One (f a)
fmap f (Two a b) = Two (f a) (f b)
fmap f (Three a b c) = Three (f a) (f b) (f c)
fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
instance Traversable Digit where
traverse f (One a) = One <$> f a
traverse f (Two a b) = Two <$> f a <*> f b
traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
instance NFData a => NFData (Digit a) where
rnf (One a) = rnf a
rnf (Two a b) = rnf a `seq` rnf b
rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
instance Sized a => Sized (Digit a) where
size = foldl1 (+) . fmap size
digitToTree :: Sized a => Digit a -> FingerTree a
digitToTree (One a) = Single a
digitToTree (Two a b) = deep (One a) Empty (One b)
digitToTree (Three a b c) = deep (Two a b) Empty (One c)
digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
digitToTree' :: Int -> Digit a -> FingerTree a
digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
digitToTree' n (One a) = n `seq` Single a
data Node a
= Node2 !Int a a
| Node3 !Int a a a
#if TESTING
deriving Show
#endif
instance Foldable Node where
foldMap f (Node2 _ a b) = f a `mappend` f b
foldMap f (Node3 _ a b c) = f a `mappend` (f b `mappend` f c)
foldr f z (Node2 _ a b) = a `f` (b `f` z)
foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
foldl f z (Node2 _ a b) = (z `f` a) `f` b
foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
instance Functor Node where
fmap f (Node2 v a b) = Node2 v (f a) (f b)
fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
instance Traversable Node where
traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
instance NFData a => NFData (Node a) where
rnf (Node2 _ a b) = rnf a `seq` rnf b
rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c
instance Sized (Node a) where
size (Node2 v _ _) = v
size (Node3 v _ _ _) = v
node2 :: Sized a => a -> a -> Node a
node2 a b = Node2 (size a + size b) a b
node3 :: Sized a => a -> a -> a -> Node a
node3 a b c = Node3 (size a + size b + size c) a b c
nodeToDigit :: Node a -> Digit a
nodeToDigit (Node2 _ a b) = Two a b
nodeToDigit (Node3 _ a b c) = Three a b c
newtype Elem a = Elem { getElem :: a }
#if TESTING
deriving Show
#endif
instance Sized (Elem a) where
size _ = 1
instance Functor Elem where
#if __GLASGOW_HASKELL__ >= 708
fmap = coerce
#else
fmap f (Elem x) = Elem (f x)
#endif
instance Foldable Elem where
foldMap f (Elem x) = f x
foldr f z (Elem x) = f x z
foldl f z (Elem x) = f z x
instance Traversable Elem where
traverse f (Elem x) = Elem <$> f x
instance NFData a => NFData (Elem a) where
rnf (Elem x) = rnf x
#if !MIN_VERSION_base(4,8,0)
newtype Identity a = Identity {runIdentity :: a}
instance Functor Identity where
fmap f (Identity x) = Identity (f x)
instance Applicative Identity where
pure = Identity
Identity f <*> Identity x = Identity (f x)
#endif
newtype State s a = State {runState :: s -> (s, a)}
instance Functor (State s) where
fmap = liftA
instance Monad (State s) where
return x = State $ \ s -> (s, x)
m >>= k = State $ \ s -> case runState m s of
(s', x) -> runState (k x) s'
instance Applicative (State s) where
pure = return
(<*>) = ap
execState :: State s a -> s -> a
execState m x = snd (runState m x)
applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
applicativeTree n mSize m = mSize `seq` case n of
0 -> pure Empty
1 -> fmap Single m
2 -> deepA one emptyTree one
3 -> deepA two emptyTree one
4 -> deepA two emptyTree two
5 -> deepA three emptyTree two
6 -> deepA three emptyTree three
7 -> deepA four emptyTree three
8 -> deepA four emptyTree four
_ -> case n `quotRem` 3 of
(q,0) -> deepA three (applicativeTree (q 2) mSize' n3) three
(q,1) -> deepA four (applicativeTree (q 2) mSize' n3) three
(q,_) -> deepA four (applicativeTree (q 2) mSize' n3) four
where
one = fmap One m
two = liftA2 Two m m
three = liftA3 Three m m m
four = liftA3 Four m m m <*> m
deepA = liftA3 (Deep (n * mSize))
mSize' = 3 * mSize
n3 = liftA3 (Node3 mSize') m m m
emptyTree = pure Empty
empty :: Seq a
empty = Seq Empty
singleton :: a -> Seq a
singleton x = Seq (Single (Elem x))
replicate :: Int -> a -> Seq a
replicate n x
| n >= 0 = runIdentity (replicateA n (Identity x))
| otherwise = error "replicate takes a nonnegative integer argument"
replicateA :: Applicative f => Int -> f a -> f (Seq a)
replicateA n x
| n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
| otherwise = error "replicateA takes a nonnegative integer argument"
replicateM :: Monad m => Int -> m a -> m (Seq a)
replicateM n x
| n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
| otherwise = error "replicateM takes a nonnegative integer argument"
replicateSeq :: Int -> Seq a -> Seq a
replicateSeq n s
| n < 0 = error "replicateSeq takes a nonnegative integer argument"
| n == 0 = empty
| otherwise = go n s
where
go 1 xs = xs
go k xs | even k = kxs
| otherwise = xs >< kxs
where kxs = go (k `quot` 2) $! (xs >< xs)
(<|) :: a -> Seq a -> Seq a
x <| Seq xs = Seq (Elem x `consTree` xs)
consTree :: Sized a => a -> FingerTree a -> FingerTree a
consTree a Empty = Single a
consTree a (Single b) = deep (One a) Empty (One b)
consTree a (Deep s (Four b c d e) m sf) = m `seq`
Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
consTree a (Deep s (Three b c d) m sf) =
Deep (size a + s) (Four a b c d) m sf
consTree a (Deep s (Two b c) m sf) =
Deep (size a + s) (Three a b c) m sf
consTree a (Deep s (One b) m sf) =
Deep (size a + s) (Two a b) m sf
(|>) :: Seq a -> a -> Seq a
Seq xs |> x = Seq (xs `snocTree` Elem x)
snocTree :: Sized a => FingerTree a -> a -> FingerTree a
snocTree Empty a = Single a
snocTree (Single a) b = deep (One a) Empty (One b)
snocTree (Deep s pr m (Four a b c d)) e = m `seq`
Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
snocTree (Deep s pr m (Three a b c)) d =
Deep (s + size d) pr m (Four a b c d)
snocTree (Deep s pr m (Two a b)) c =
Deep (s + size c) pr m (Three a b c)
snocTree (Deep s pr m (One a)) b =
Deep (s + size b) pr m (Two a b)
(><) :: Seq a -> Seq a -> Seq a
Seq xs >< Seq ys = Seq (appendTree0 xs ys)
appendTree0 :: Sized a => FingerTree a -> FingerTree a -> FingerTree a
appendTree0 Empty xs =
xs
appendTree0 xs Empty =
xs
appendTree0 (Single x) xs =
x `consTree` xs
appendTree0 xs (Single x) =
xs `snocTree` x
appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
addDigits0 :: Sized a => FingerTree (Node a) -> Digit a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a)
addDigits0 m1 (One a) (One b) m2 =
appendTree1 m1 (node2 a b) m2
addDigits0 m1 (One a) (Two b c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (One a) (Three b c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (One a) (Four b c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (One c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (Two a b) (Two c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Two a b) (Three c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (Four c d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Three a b c) (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Three a b c) (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Four a b c d) (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Four a b c d) (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree1 Empty a xs =
a `consTree` xs
appendTree1 xs a Empty =
xs `snocTree` a
appendTree1 (Single x) a xs =
x `consTree` a `consTree` xs
appendTree1 xs a (Single x) =
xs `snocTree` a `snocTree` x
appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits1 m1 (One a) b (One c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits1 m1 (One a) b (Two c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (One a) b (Three c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (One a) b (Four c d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (Two a b) c (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Two a b) c (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Three a b c) d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Three a b c) d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Four a b c d) e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree2 Empty a b xs =
a `consTree` b `consTree` xs
appendTree2 xs a b Empty =
xs `snocTree` a `snocTree` b
appendTree2 (Single x) a b xs =
x `consTree` a `consTree` b `consTree` xs
appendTree2 xs a b (Single x) =
xs `snocTree` a `snocTree` b `snocTree` x
appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits2 m1 (One a) b c (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits2 m1 (One a) b c (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (One a) b c (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (One a) b c (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (Two a b) c d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Two a b) c d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Three a b c) d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree3 Empty a b c xs =
a `consTree` b `consTree` c `consTree` xs
appendTree3 xs a b c Empty =
xs `snocTree` a `snocTree` b `snocTree` c
appendTree3 (Single x) a b c xs =
x `consTree` a `consTree` b `consTree` c `consTree` xs
appendTree3 xs a b c (Single x) =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits3 m1 (One a) b c d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits3 m1 (One a) b c d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (One a) b c d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (One a) b c d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (Two a b) c d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (One h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree4 Empty a b c d xs =
a `consTree` b `consTree` c `consTree` d `consTree` xs
appendTree4 xs a b c d Empty =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
appendTree4 (Single x) a b c d xs =
x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
appendTree4 xs a b c d (Single x) =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits4 m1 (One a) b c d e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits4 m1 (One a) b c d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (One a) b c d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) c d e f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) d e f g (One h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
unfoldr f = unfoldr' empty
where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
unfoldl f = unfoldl' empty
where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
iterateN :: Int -> (a -> a) -> a -> Seq a
iterateN n f x
| n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
| otherwise = error "iterateN takes a nonnegative integer argument"
null :: Seq a -> Bool
null (Seq Empty) = True
null _ = False
length :: Seq a -> Int
length (Seq xs) = size xs
data Maybe2 a b = Nothing2 | Just2 a b
data ViewL a
= EmptyL
| a :< Seq a
#if __GLASGOW_HASKELL__
deriving (Eq, Ord, Show, Read, Data)
#else
deriving (Eq, Ord, Show, Read)
#endif
INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
instance Functor ViewL where
fmap _ EmptyL = EmptyL
fmap f (x :< xs) = f x :< fmap f xs
instance Foldable ViewL where
foldr _ z EmptyL = z
foldr f z (x :< xs) = f x (foldr f z xs)
foldl _ z EmptyL = z
foldl f z (x :< xs) = foldl f (f z x) xs
foldl1 _ EmptyL = error "foldl1: empty view"
foldl1 f (x :< xs) = foldl f x xs
instance Traversable ViewL where
traverse _ EmptyL = pure EmptyL
traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
viewl :: Seq a -> ViewL a
viewl (Seq xs) = case viewLTree xs of
Nothing2 -> EmptyL
Just2 (Elem x) xs' -> x :< Seq xs'
viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
viewLTree Empty = Nothing2
viewLTree (Single a) = Just2 a Empty
viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s size a) m sf)
viewLTree (Deep s (Two a b) m sf) =
Just2 a (Deep (s size a) (One b) m sf)
viewLTree (Deep s (Three a b c) m sf) =
Just2 a (Deep (s size a) (Two b c) m sf)
viewLTree (Deep s (Four a b c d) m sf) =
Just2 a (Deep (s size a) (Three b c d) m sf)
data ViewR a
= EmptyR
| Seq a :> a
#if __GLASGOW_HASKELL__
deriving (Eq, Ord, Show, Read, Data)
#else
deriving (Eq, Ord, Show, Read)
#endif
INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
instance Functor ViewR where
fmap _ EmptyR = EmptyR
fmap f (xs :> x) = fmap f xs :> f x
instance Foldable ViewR where
foldMap _ EmptyR = mempty
foldMap f (xs :> x) = foldMap f xs `mappend` f x
foldr _ z EmptyR = z
foldr f z (xs :> x) = foldr f (f x z) xs
foldl _ z EmptyR = z
foldl f z (xs :> x) = foldl f z xs `f` x
foldr1 _ EmptyR = error "foldr1: empty view"
foldr1 f (xs :> x) = foldr f x xs
#if MIN_VERSION_base(4,8,0)
null EmptyR = True
null (_ :> _) = False
length = foldr' (\_ k -> k+1) 0
#endif
instance Traversable ViewR where
traverse _ EmptyR = pure EmptyR
traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
viewr :: Seq a -> ViewR a
viewr (Seq xs) = case viewRTree xs of
Nothing2 -> EmptyR
Just2 xs' (Elem x) -> Seq xs' :> x
viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
viewRTree Empty = Nothing2
viewRTree (Single z) = Just2 Empty z
viewRTree (Deep s pr m (One z)) = Just2 (pullR (s size z) pr m) z
viewRTree (Deep s pr m (Two y z)) =
Just2 (Deep (s size z) pr m (One y)) z
viewRTree (Deep s pr m (Three x y z)) =
Just2 (Deep (s size z) pr m (Two x y)) z
viewRTree (Deep s pr m (Four w x y z)) =
Just2 (Deep (s size z) pr m (Three w x y)) z
scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
scanl1 :: (a -> a -> a) -> Seq a -> Seq a
scanl1 f xs = case viewl xs of
EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
x :< xs' -> scanl f x xs'
scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
scanr1 :: (a -> a -> a) -> Seq a -> Seq a
scanr1 f xs = case viewr xs of
EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
xs' :> x -> scanr f x xs'
index :: Seq a -> Int -> a
index (Seq xs) i
| 0 <= i && i < size xs = case lookupTree i xs of
Place _ (Elem x) -> x
| otherwise = error "index out of bounds"
data Place a = Place !Int a
#if TESTING
deriving Show
#endif
lookupTree :: Sized a => Int -> FingerTree a -> Place a
lookupTree _ Empty = error "lookupTree of empty tree"
lookupTree i (Single x) = Place i x
lookupTree i (Deep totalSize pr m sf)
| i < spr = lookupDigit i pr
| i < spm = case lookupTree (i spr) m of
Place i' xs -> lookupNode i' xs
| otherwise = lookupDigit (i spm) sf
where
spr = size pr
spm = totalSize size sf
lookupNode :: Sized a => Int -> Node a -> Place a
lookupNode i (Node2 _ a b)
| i < sa = Place i a
| otherwise = Place (i sa) b
where
sa = size a
lookupNode i (Node3 _ a b c)
| i < sa = Place i a
| i < sab = Place (i sa) b
| otherwise = Place (i sab) c
where
sa = size a
sab = sa + size b
lookupDigit :: Sized a => Int -> Digit a -> Place a
lookupDigit i (One a) = Place i a
lookupDigit i (Two a b)
| i < sa = Place i a
| otherwise = Place (i sa) b
where
sa = size a
lookupDigit i (Three a b c)
| i < sa = Place i a
| i < sab = Place (i sa) b
| otherwise = Place (i sab) c
where
sa = size a
sab = sa + size b
lookupDigit i (Four a b c d)
| i < sa = Place i a
| i < sab = Place (i sa) b
| i < sabc = Place (i sab) c
| otherwise = Place (i sabc) d
where
sa = size a
sab = sa + size b
sabc = sab + size c
update :: Int -> a -> Seq a -> Seq a
update i x = adjust (const x) i
adjust :: (a -> a) -> Int -> Seq a -> Seq a
adjust f i (Seq xs)
| 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
| otherwise = Seq xs
adjustTree :: Sized a => (Int -> a -> a) ->
Int -> FingerTree a -> FingerTree a
adjustTree _ _ Empty = error "adjustTree of empty tree"
adjustTree f i (Single x) = Single (f i x)
adjustTree f i (Deep s pr m sf)
| i < spr = Deep s (adjustDigit f i pr) m sf
| i < spm = Deep s pr (adjustTree (adjustNode f) (i spr) m) sf
| otherwise = Deep s pr m (adjustDigit f (i spm) sf)
where
spr = size pr
spm = spr + size m
adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
adjustNode f i (Node2 s a b)
| i < sa = Node2 s (f i a) b
| otherwise = Node2 s a (f (i sa) b)
where
sa = size a
adjustNode f i (Node3 s a b c)
| i < sa = Node3 s (f i a) b c
| i < sab = Node3 s a (f (i sa) b) c
| otherwise = Node3 s a b (f (i sab) c)
where
sa = size a
sab = sa + size b
adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
adjustDigit f i (One a) = One (f i a)
adjustDigit f i (Two a b)
| i < sa = Two (f i a) b
| otherwise = Two a (f (i sa) b)
where
sa = size a
adjustDigit f i (Three a b c)
| i < sa = Three (f i a) b c
| i < sab = Three a (f (i sa) b) c
| otherwise = Three a b (f (i sab) c)
where
sa = size a
sab = sa + size b
adjustDigit f i (Four a b c d)
| i < sa = Four (f i a) b c d
| i < sab = Four a (f (i sa) b) c d
| i < sabc = Four a b (f (i sab) c) d
| otherwise = Four a b c (f (i sabc) d)
where
sa = size a
sab = sa + size b
sabc = sab + size c
mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'
where
mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b
mapWithIndexTree _ s Empty = s `seq` Empty
mapWithIndexTree f s (Single xs) = Single $ f s xs
mapWithIndexTree f s (Deep n pr m sf) = sPspr `seq` sPsprm `seq`
Deep n
(mapWithIndexDigit f s pr)
(mapWithIndexTree (mapWithIndexNode f) sPspr m)
(mapWithIndexDigit f sPsprm sf)
where
sPspr = s + size pr
sPsprm = s + n size sf
mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b
mapWithIndexDigit f s (One a) = One (f s a)
mapWithIndexDigit f s (Two a b) = sPsa `seq` Two (f s a) (f sPsa b)
where
sPsa = s + size a
mapWithIndexDigit f s (Three a b c) = sPsa `seq` sPsab `seq`
Three (f s a) (f sPsa b) (f sPsab c)
where
sPsa = s + size a
sPsab = sPsa + size b
mapWithIndexDigit f s (Four a b c d) = sPsa `seq` sPsab `seq` sPsabc `seq`
Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)
where
sPsa = s + size a
sPsab = sPsa + size b
sPsabc = sPsab + size c
mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b
mapWithIndexNode f s (Node2 ns a b) = sPsa `seq` Node2 ns (f s a) (f sPsa b)
where
sPsa = s + size a
mapWithIndexNode f s (Node3 ns a b c) = sPsa `seq` sPsab `seq`
Node3 ns (f s a) (f sPsa b) (f sPsab c)
where
sPsa = s + size a
sPsab = sPsa + size b
#ifdef __GLASGOW_HASKELL__
#endif
fromFunction :: Int -> (Int -> a) -> Seq a
fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"
| len == 0 = empty
| otherwise = Seq $ create (lift_elem f) 1 0 len
where
create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a
create b s i trees = i `seq` s `seq` case trees of
1 -> Single $ b i
2 -> Deep (2*s) (One (b i)) Empty (One (b (i+s)))
3 -> Deep (3*s) (createTwo i) Empty (One (b (i+2*s)))
4 -> Deep (4*s) (createTwo i) Empty (createTwo (i+2*s))
5 -> Deep (5*s) (createThree i) Empty (createTwo (i+3*s))
6 -> Deep (6*s) (createThree i) Empty (createThree (i+3*s))
_ -> case trees `quotRem` 3 of
(trees', 1) -> Deep (trees*s) (createTwo i)
(create mb (3*s) (i+2*s) (trees'1))
(createTwo (i+(2+3*(trees'1))*s))
(trees', 2) -> Deep (trees*s) (createThree i)
(create mb (3*s) (i+3*s) (trees'1))
(createTwo (i+(3+3*(trees'1))*s))
(trees', _) -> Deep (trees*s) (createThree i)
(create mb (3*s) (i+3*s) (trees'2))
(createThree (i+(3+3*(trees'2))*s))
where
createTwo j = Two (b j) (b (j + s))
createThree j = Three (b j) (b (j + s)) (b (j + 2*s))
mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))
lift_elem :: (Int -> a) -> (Int -> Elem a)
#if __GLASGOW_HASKELL__ >= 708
lift_elem g = coerce g
#else
lift_elem g = Elem . g
#endif
fromArray :: Ix i => Array i a -> Seq a
#ifdef __GLASGOW_HASKELL__
fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)
#else
fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)
#endif
take :: Int -> Seq a -> Seq a
take i = fst . splitAt' i
drop :: Int -> Seq a -> Seq a
drop i = snd . splitAt' i
splitAt :: Int -> Seq a -> (Seq a, Seq a)
splitAt i (Seq xs) = (Seq l, Seq r)
where (l, r) = split i xs
splitAt' :: Int -> Seq a -> (Seq a, Seq a)
splitAt' i (Seq xs) = case split i xs of
(l, r) -> (Seq l, Seq r)
split :: Int -> FingerTree (Elem a) ->
(FingerTree (Elem a), FingerTree (Elem a))
split i Empty = i `seq` (Empty, Empty)
split i xs
| size xs > i = case splitTree i xs of
Split l x r -> (l, consTree x r)
| otherwise = (xs, Empty)
data Split t a = Split t a t
#if TESTING
deriving Show
#endif
splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
splitTree _ Empty = error "splitTree of empty tree"
splitTree i (Single x) = i `seq` Split Empty x Empty
splitTree i (Deep _ pr m sf)
| i < spr = case splitDigit i pr of
Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
| i < spm = case splitTree im m of
Split ml xs mr -> case splitNode (im size ml) xs of
Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
| otherwise = case splitDigit (i spm) sf of
Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
where
spr = size pr
spm = spr + size m
im = i spr
splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
splitNode i (Node2 _ a b)
| i < sa = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
sa = size a
splitNode i (Node3 _ a b c)
| i < sa = Split Nothing a (Just (Two b c))
| i < sab = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
sa = size a
sab = sa + size b
splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
splitDigit i (One a) = i `seq` Split Nothing a Nothing
splitDigit i (Two a b)
| i < sa = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
sa = size a
splitDigit i (Three a b c)
| i < sa = Split Nothing a (Just (Two b c))
| i < sab = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
sa = size a
sab = sa + size b
splitDigit i (Four a b c d)
| i < sa = Split Nothing a (Just (Three b c d))
| i < sab = Split (Just (One a)) b (Just (Two c d))
| i < sabc = Split (Just (Two a b)) c (Just (One d))
| otherwise = Split (Just (Three a b c)) d Nothing
where
sa = size a
sab = sa + size b
sabc = sab + size c
tails :: Seq a -> Seq (Seq a)
tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
inits :: Seq a -> Seq (Seq a)
inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
tailsDigit :: Digit a -> Digit (Digit a)
tailsDigit (One a) = One (One a)
tailsDigit (Two a b) = Two (Two a b) (One b)
tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
initsDigit :: Digit a -> Digit (Digit a)
initsDigit (One a) = One (One a)
initsDigit (Two a b) = Two (One a) (Two a b)
initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
tailsNode :: Node a -> Node (Digit a)
tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
initsNode :: Node a -> Node (Digit a)
initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
tailsTree _ Empty = Empty
tailsTree f (Single x) = Single (f (Single x))
tailsTree f (Deep n pr m sf) =
Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
(tailsTree f' m)
(fmap (f . digitToTree) (tailsDigit sf))
where
f' ms = let Just2 node m' = viewLTree ms in
fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
initsTree _ Empty = Empty
initsTree f (Single x) = Single (f (Single x))
initsTree f (Deep n pr m sf) =
Deep n (fmap (f . digitToTree) (initsDigit pr))
(initsTree f' m)
(fmap (f . deep pr m) (initsDigit sf))
where
f' ms = let Just2 m' node = viewRTree ms in
fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i 1)) i x) (const z) xs (length xs 1)
foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
listToMaybe' :: [a] -> Maybe a
listToMaybe' = foldr (\ x _ -> Just x) Nothing
takeWhileL :: (a -> Bool) -> Seq a -> Seq a
takeWhileL p = fst . spanl p
takeWhileR :: (a -> Bool) -> Seq a -> Seq a
takeWhileR p = fst . spanr p
dropWhileL :: (a -> Bool) -> Seq a -> Seq a
dropWhileL p = snd . spanl p
dropWhileR :: (a -> Bool) -> Seq a -> Seq a
dropWhileR p = snd . spanr p
spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanl p = breakl (not . p)
spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanr p = breakr (not . p)
breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
where flipPair (x, y) = (y, x)
partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
partition p = foldl part (empty, empty)
where
part (xs, ys) x
| p x = (xs |> x, ys)
| otherwise = (xs, ys |> x)
filter :: (a -> Bool) -> Seq a -> Seq a
filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
elemIndexL :: Eq a => a -> Seq a -> Maybe Int
elemIndexL x = findIndexL (x ==)
elemIndexR :: Eq a => a -> Seq a -> Maybe Int
elemIndexR x = findIndexR (x ==)
elemIndicesL :: Eq a => a -> Seq a -> [Int]
elemIndicesL x = findIndicesL (x ==)
elemIndicesR :: Eq a => a -> Seq a -> [Int]
elemIndicesR x = findIndicesR (x ==)
findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
findIndexL p = listToMaybe' . findIndicesL p
findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
findIndexR p = listToMaybe' . findIndicesR p
findIndicesL :: (a -> Bool) -> Seq a -> [Int]
#if __GLASGOW_HASKELL__
findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
foldrWithIndex g n xs)
#else
findIndicesL p xs = foldrWithIndex g [] xs
where g i x is = if p x then i:is else is
#endif
findIndicesR :: (a -> Bool) -> Seq a -> [Int]
#if __GLASGOW_HASKELL__
findIndicesR p xs = build (\ c n ->
let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
#else
findIndicesR p xs = foldlWithIndex g [] xs
where g is i x = if p x then i:is else is
#endif
fromList :: [a] -> Seq a
fromList = Seq . mkTree 1 . map_elem
where
mkTree :: (Sized a) => Int -> [a] -> FingerTree a
STRICT_1_OF_2(mkTree)
mkTree _ [] = Empty
mkTree _ [x1] = Single x1
mkTree s [x1, x2] = Deep (2*s) (One x1) Empty (One x2)
mkTree s [x1, x2, x3] = Deep (3*s) (One x1) Empty (Two x2 x3)
mkTree s (x1:x2:x3:x4:xs) = case getNodes (3*s) x4 xs of
(ns, sf) -> case mkTree (3*s) ns of
m -> m `seq` Deep (3*size x1 + size m + size sf) (Three x1 x2 x3) m sf
getNodes :: Int -> a -> [a] -> ([Node a], Digit a)
STRICT_1_OF_3(getNodes)
getNodes _ x1 [] = ([], One x1)
getNodes _ x1 [x2] = ([], Two x1 x2)
getNodes _ x1 [x2, x3] = ([], Three x1 x2 x3)
getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)
where (ns, d) = getNodes s x4 xs
map_elem :: [a] -> [Elem a]
#if __GLASGOW_HASKELL__ >= 708
map_elem xs = coerce xs
#else
map_elem xs = Data.List.map Elem xs
#endif
#if __GLASGOW_HASKELL__ >= 708
instance GHC.Exts.IsList (Seq a) where
type Item (Seq a) = a
fromList = fromList
fromListN = fromList2
toList = toList
#endif
reverse :: Seq a -> Seq a
reverse (Seq xs) = Seq (reverseTree id xs)
reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
reverseTree _ Empty = Empty
reverseTree f (Single x) = Single (f x)
reverseTree f (Deep s pr m sf) =
Deep s (reverseDigit f sf)
(reverseTree (reverseNode f) m)
(reverseDigit f pr)
reverseDigit :: (a -> a) -> Digit a -> Digit a
reverseDigit f (One a) = One (f a)
reverseDigit f (Two a b) = Two (f b) (f a)
reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
reverseNode :: (a -> a) -> Node a -> Node a
reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b
splitMap splt' = go
where
go f s (Seq xs) = Seq $ splitMapTree splt' (\s' (Elem a) -> Elem (f s' a)) s xs
splitMapTree :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> FingerTree a -> FingerTree b
splitMapTree _ _ _ Empty = Empty
splitMapTree _ f s (Single xs) = Single $ f s xs
splitMapTree splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTree splt (splitMapNode splt f) ms m) (splitMapDigit splt f sfs sf)
where
(prs, r) = splt (size pr) s
(ms, sfs) = splt (n size pr size sf) r
splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b
splitMapDigit _ f s (One a) = One (f s a)
splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)
where
(first, s') = splt (size a) s
(middle, fourth) = splt (size b + size c) s'
(second, third) = splt (size b) middle
splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b
splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
getSingleton :: Seq a -> a
getSingleton (Seq (Single (Elem a))) = a
getSingleton (Seq Empty) = error "getSingleton: Empty"
getSingleton _ = error "getSingleton: Not a singleton."
zip :: Seq a -> Seq b -> Seq (a, b)
zip = zipWith (,)
zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
zipWith f s1 s2 = zipWith' f s1' s2'
where
minLen = min (length s1) (length s2)
s1' = take minLen s1
s2' = take minLen s2
zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
zipWith' f s1 s2 = splitMap splitAt' (\s a -> f a (getSingleton s)) s2 s1
zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
zip3 = zipWith3 (,,)
zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'
where
minLen = minimum [length s1, length s2, length s3]
s1' = take minLen s1
s2' = take minLen s2
s3' = take minLen s3
zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3
zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
zip4 = zipWith4 (,,,)
zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
where
minLen = minimum [length s1, length s2, length s3, length s4]
s1' = take minLen s1
s2' = take minLen s2
s3' = take minLen s3
s4' = take minLen s4
sort :: Ord a => Seq a -> Seq a
sort = sortBy compare
sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
unstableSort :: Ord a => Seq a -> Seq a
unstableSort = unstableSortBy compare
unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
unstableSortBy cmp (Seq xs) =
fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
fromList2 :: Int -> [a] -> Seq a
fromList2 n = execState (replicateA n (State ht))
where
ht (x:xs) = (xs, x)
ht [] = error "fromList2: short list"
data PQueue e = PQueue e (PQL e)
data PQL e = Nil | !(PQueue e) :& PQL e
infixr 8 :&
#if TESTING
instance Functor PQueue where
fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
instance Functor PQL where
fmap f (q :& qs) = fmap f q :& fmap f qs
fmap _ Nil = Nil
instance Show e => Show (PQueue e) where
show = unlines . draw . fmap show
draw :: PQueue String -> [String]
draw (PQueue x ts0) = x : drawSubTrees ts0
where
drawSubTrees Nil = []
drawSubTrees (t :& Nil) =
"|" : shift "`- " " " (draw t)
drawSubTrees (t :& ts) =
"|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
shift first other = Data.List.zipWith (++) (first : repeat other)
#endif
unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
unrollPQ cmp = unrollPQ'
where
unrollPQ' (PQueue x ts) = x:mergePQs0 ts
(<>) = mergePQ cmp
mergePQs0 Nil = []
mergePQs0 (t :& Nil) = unrollPQ' t
mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
mergePQs t ts = t `seq` case ts of
Nil -> unrollPQ' t
t1 :& Nil -> unrollPQ' (t <> t1)
t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
toPQ _ _ Empty = Nothing
toPQ _ f (Single x) = Just (f x)
toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
where
fDigit digit = case fmap f digit of
One a -> a
Two a b -> a <> b
Three a b c -> a <> b <> c
Four a b c d -> (a <> b) <> (c <> d)
(<>) = mergePQ cmp
fNode = fDigit . nodeToDigit
pr' = fDigit pr
sf' = fDigit sf
mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
| cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
| otherwise = PQueue x1 (q2 :& ts1)