#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(..),
#if MIN_VERSION_base(4,8,0)
Applicative, (<$>), foldMap, Monoid,
#endif
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
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup((<>)))
#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
import Data.String (IsString(..))
#endif
import Data.Array (Ix, Array)
import qualified Data.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 = pure
xs >>= f = foldl' add empty xs
where add ys x = ys >< f x
(>>) = (*>)
instance Applicative Seq where
pure = singleton
xs *> ys = cycleN (length xs) ys
fs <*> xs@(Seq xsFT) = case viewl fs of
EmptyL -> empty
firstf :< fs' -> case viewr fs' of
EmptyR -> fmap firstf xs
Seq fs''FT :> lastf -> case rigidify xsFT of
RigidEmpty -> empty
RigidOne (Elem x) -> fmap ($x) fs
RigidTwo (Elem x1) (Elem x2) ->
Seq $ ap2FT firstf fs''FT lastf (x1, x2)
RigidThree (Elem x1) (Elem x2) (Elem x3) ->
Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)
RigidFull r@(Rigid s pr _m sf) -> Seq $
Deep (s * length fs)
(fmap (fmap firstf) (nodeToDigit pr))
(aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)
(fmap (fmap lastf) (nodeToDigit sf))
ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)
ap2FT firstf fs lastf (x,y) =
Deep (size fs * 2 + 4)
(Two (Elem $ firstf x) (Elem $ firstf y))
(mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)
(Two (Elem $ lastf x) (Elem $ lastf y))
ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)
ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)
(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))) fs)
(Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
data Rigidified a = RigidEmpty
| RigidOne a
| RigidTwo a a
| RigidThree a a a
| RigidFull (Rigid a)
#ifdef TESTING
deriving Show
#endif
data Rigid a = Rigid !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)
#ifdef TESTING
deriving Show
#endif
data Thin a = EmptyTh
| SingleTh a
| DeepTh !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)
#ifdef TESTING
deriving Show
#endif
data Digit12 a = One12 a | Two12 a a
#ifdef TESTING
deriving Show
#endif
type Digit23 a = Node a
aptyMiddle
:: (c -> d)
-> (c -> d)
-> ((a -> b) -> c -> d)
-> FingerTree (Elem (a -> b))
-> Rigid c
-> FingerTree (Node d)
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr (DeepTh sm prm mm sfm) sf)
= Deep (sm + s * (size fs + 1))
(fmap (fmap firstf) (digit12ToDigit prm))
(aptyMiddle (fmap firstf)
(fmap lastf)
(fmap . map23)
fs
(Rigid s (squashL pr prm) mm (squashR sfm sf)))
(fmap (fmap lastf) (digit12ToDigit sfm))
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr EmptyTh sf)
= deep
(One (fmap firstf sf))
(mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
(One (fmap lastf pr))
where converted = node2 pr sf
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr (SingleTh q) sf)
= deep
(Two (fmap firstf q) (fmap firstf sf))
(mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
(Two (fmap lastf pr) (fmap lastf q))
where converted = node3 pr q sf
digit12ToDigit :: Digit12 a -> Digit a
digit12ToDigit (One12 a) = One a
digit12ToDigit (Two12 a b) = Two a b
squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
squashL m (One12 n) = node2 m n
squashL m (Two12 n1 n2) = node3 m n1 n2
squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
squashR (One12 n) m = node2 n m
squashR (Two12 n1 n2) m = node3 n1 n2 m
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)
rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)
rigidify Empty = RigidEmpty
rigidify (Single q) = RigidOne q
rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf
rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf
rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf
rigidify (Deep s (One a) m sf) = case viewLTree m of
Just2 (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf
Just2 (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf
Nothing2 -> case sf of
One b -> RigidTwo a b
Two b c -> RigidThree a b c
Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)
Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)
rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)
rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)
rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)
rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)
rigidifyRight s pr m (One e) = case viewRTree m of
Just2 m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)
Just2 m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)
Nothing2 -> case pr of
Node2 _ a b -> RigidThree a b e
Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)
thin :: Sized a => FingerTree a -> Thin a
thin Empty = EmptyTh
thin (Single a) = SingleTh a
thin (Deep s pr m sf) =
case pr of
One a -> thin12 s (One12 a) m sf
Two a b -> thin12 s (Two12 a b) m sf
Three a b c -> thin12 s (One12 a) (node2 b c `consTree` m) sf
Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf
thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a
thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)
thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)
thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)
thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)
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
#if !(MIN_VERSION_base(4,9,0))
mappend = (><)
#else
mappend = (<>)
instance Semigroup (Seq a) where
(<>) = (><)
#endif
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 :: 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 :: 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 = pure
m >>= k = State $ \ s -> case runState m s of
(s', x) -> runState (k x) s'
instance Applicative (State s) where
pure x = State $ \ s -> (s, x)
(<*>) = 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
_ -> case n `quotRem` 3 of
(q,0) -> deepA three (applicativeTree (q 2) mSize' n3) three
(q,1) -> deepA two (applicativeTree (q 1) mSize' n3) two
(q,_) -> deepA three (applicativeTree (q 1) mSize' n3) two
where
one = fmap One m
two = liftA2 Two m m
three = liftA3 Three 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"
cycleN :: Int -> Seq a -> Seq a
cycleN n xs
| n < 0 = error "cycleN takes a nonnegative integer argument"
| n == 0 = empty
| n == 1 = xs
cycleN n (Seq xsFT) = case rigidify xsFT of
RigidEmpty -> empty
RigidOne (Elem x) -> replicate n x
RigidTwo x1 x2 -> Seq $
Deep (n*2) pair
(runIdentity $ applicativeTree (n2) 2 (Identity (node2 x1 x2)))
pair
where pair = Two x1 x2
RigidThree x1 x2 x3 -> Seq $
Deep (n*3) triple
(runIdentity $ applicativeTree (n2) 3 (Identity (node3 x1 x2 x3)))
triple
where triple = Three x1 x2 x3
RigidFull r@(Rigid s pr _m sf) -> Seq $
Deep (n*s)
(nodeToDigit pr)
(cycleNMiddle (n2) r)
(nodeToDigit sf)
cycleNMiddle
:: Int
-> Rigid c
-> FingerTree (Node c)
STRICT_1_OF_2(cycleNMiddle)
cycleNMiddle n
(Rigid s pr (DeepTh sm prm mm sfm) sf)
= Deep (sm + s * (n + 1))
(digit12ToDigit prm)
(cycleNMiddle n
(Rigid s (squashL pr prm) mm (squashR sfm sf)))
(digit12ToDigit sfm)
cycleNMiddle n
(Rigid s pr EmptyTh sf)
= deep
(One sf)
(runIdentity $ applicativeTree n s (Identity converted))
(One pr)
where converted = node2 pr sf
cycleNMiddle n
(Rigid s pr (SingleTh q) sf)
= deep
(Two q sf)
(runIdentity $ applicativeTree n s (Identity converted))
(Two pr q)
where converted = node3 pr q sf
(<|) :: 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 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem 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)
where
_ = Data.Array.rangeSize (Data.Array.bounds 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 => (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 => (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
#ifdef __GLASGOW_HASKELL__
instance IsString (Seq Char) where
fromString = fromList
#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)