From 1e61853dbd4b9fc6ecc58ad655990ea5e971fa13 Mon Sep 17 00:00:00 2001 From: ross Date: Thu, 14 Jul 2005 11:59:27 +0000 Subject: [PATCH] [project @ 2005-07-14 11:59:27 by ross] Data.Sequence: general purpose finite sequences (as discussed on the libraries list in May 2005). --- Data/Sequence.hs | 1076 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1076 insertions(+) create mode 100644 Data/Sequence.hs diff --git a/Data/Sequence.hs b/Data/Sequence.hs new file mode 100644 index 0000000..6ffded0 --- /dev/null +++ b/Data/Sequence.hs @@ -0,0 +1,1076 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Sequence +-- Copyright : (c) Ross Paterson 2005 +-- License : BSD-style +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- General purpose finite sequences. +-- Apart from being finite and having strict operations, sequences +-- also differ from lists in supporting a wider variety of operations +-- efficiently. +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /i/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- The implementation uses 2-3 finger trees annotated with sizes, +-- as described in section 4.2 of +-- +-- * Ralf Hinze and Ross Paterson, +-- \"Finger trees: a simple general-purpose data structure\", +-- submitted to /Journal of Functional Programming/. +-- +-- +-- /Note/: Many of these operations have the same names as similar +-- operations on lists in the "Prelude". The ambiguity may be resolved +-- using either qualification or the @hiding@ clause. +-- +----------------------------------------------------------------------------- + +module Data.Sequence ( + Seq, + -- * Construction + empty, -- :: Seq a + singleton, -- :: a -> Seq a + (<|), -- :: a -> Seq a -> Seq a + (|>), -- :: Seq a -> a -> Seq a + (><), -- :: Seq a -> Seq a -> Seq a + -- * Deconstruction + -- ** Queries + null, -- :: Seq a -> Bool + length, -- :: Seq a -> Int + -- ** Views + ViewL(..), + viewl, -- :: Seq a -> ViewL a + ViewR(..), + viewr, -- :: Seq a -> ViewR a + -- ** Indexing + index, -- :: Seq a -> Int -> a + adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a + update, -- :: Int -> a -> Seq a -> Seq a + take, -- :: Int -> Seq a -> Seq a + drop, -- :: Int -> Seq a -> Seq a + splitAt, -- :: Int -> Seq a -> (Seq a, Seq a) + -- * Lists + fromList, -- :: [a] -> Seq a + toList, -- :: Seq a -> [a] + -- * Folds + -- ** Right associative + foldr, -- :: (a -> b -> b) -> b -> Seq a -> b + foldr1, -- :: (a -> a -> a) -> Seq a -> a + foldr', -- :: (a -> b -> b) -> b -> Seq a -> b + foldrM, -- :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b + -- ** Left associative + foldl, -- :: (a -> b -> a) -> a -> Seq b -> a + foldl1, -- :: (a -> a -> a) -> Seq a -> a + foldl', -- :: (a -> b -> a) -> a -> Seq b -> a + foldlM, -- :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a + -- * Transformations + reverse, -- :: Seq a -> Seq a +#if TESTING + valid, +#endif + ) where + +import Prelude hiding ( + null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, + reverse) +import qualified Prelude (foldr) +import qualified Data.List (foldl', intersperse) +import Data.FunctorM +import Data.Typeable + +#if TESTING +import Control.Monad (liftM, liftM2, liftM3, liftM4) +import Test.QuickCheck +#endif + +#if __GLASGOW_HASKELL__ +import Data.Generics.Basics (Data(..), mkNorepType) +#endif + +infixr 5 `consTree` +infixl 5 `snocTree` + +infixr 5 >< +infixr 5 <|, :< +infixl 5 |>, :> + +class Sized a where + size :: a -> Int + +------------------------------------------------------------------------ +-- Random access sequences +------------------------------------------------------------------------ + +-- | General-purpose finite sequences. +newtype Seq a = Seq (FingerTree (Elem a)) + +instance Functor Seq where + fmap f (Seq xs) = Seq (fmap (fmap f) xs) + +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 _ xs = showChar '<' . + flip (Prelude.foldr ($)) (Data.List.intersperse (showChar ',') + (map shows (toList xs))) . + showChar '>' +#endif + +instance FunctorM Seq where + fmapM f = foldlM f' empty + where f' ys x = do + y <- f x + return $! (ys |> y) + fmapM_ f = foldlM f' () + where f' _ x = f x >> return () + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Seq,seqTc,"Seq") + +#if __GLASGOW_HASKELL__ +instance Data a => Data (Seq a) where + gfoldl f z xs = z fromList `f` toList xs + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "Data.Sequence.Seq" +#endif + +-- Finger trees + +data FingerTree a + = Empty + | Single a + | Deep {-# UNPACK #-} !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 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) + +{-# INLINE deep #-} +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 + +-- Digits + +data Digit a + = One a + | Two a a + | Three a a a + | Four a a a a +#if TESTING + deriving Show +#endif + +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 Sized a => Sized (Digit a) where + size xs = foldlDigit (\ i x -> i + size x) 0 xs + +{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-} +{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-} +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) + +-- Nodes + +data Node a + = Node2 {-# UNPACK #-} !Int a a + | Node3 {-# UNPACK #-} !Int a a a +#if TESTING + deriving Show +#endif + +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 Sized (Node a) where + size (Node2 v _ _) = v + size (Node3 v _ _ _) = v + +{-# INLINE node2 #-} +node2 :: Sized a => a -> a -> Node a +node2 a b = Node2 (size a + size b) a b + +{-# INLINE node3 #-} +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 + +-- Elements + +newtype Elem a = Elem { getElem :: a } + +instance Sized (Elem a) where + size _ = 1 + +instance Functor Elem where + fmap f (Elem x) = Elem (f x) + +#ifdef TESTING +instance (Show a) => Show (Elem a) where + showsPrec p (Elem x) = showsPrec p x +#endif + +------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------ + +-- | /O(1)/. The empty sequence. +empty :: Seq a +empty = Seq Empty + +-- | /O(1)/. A singleton sequence. +singleton :: a -> Seq a +singleton x = Seq (Single (Elem x)) + +-- | /O(1)/. Add an element to the left end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(<|) :: a -> Seq a -> Seq a +x <| Seq xs = Seq (Elem x `consTree` xs) + +{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-} +{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-} +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 + +-- | /O(1)/. Add an element to the right end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(|>) :: Seq a -> a -> Seq a +Seq xs |> x = Seq (xs `snocTree` Elem x) + +{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-} +{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-} +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) + +-- | /O(log(min(n1,n2)))/. Concatenate two sequences. +(><) :: Seq a -> Seq a -> Seq a +Seq xs >< Seq ys = Seq (appendTree0 xs ys) + +-- The appendTree/addDigits gunk below is machine generated + +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 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem 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 + +------------------------------------------------------------------------ +-- Deconstruction +------------------------------------------------------------------------ + +-- | /O(1)/. Is this the empty sequence? +null :: Seq a -> Bool +null (Seq Empty) = True +null _ = False + +-- | /O(1)/. The number of elements in the sequence. +length :: Seq a -> Int +length (Seq xs) = size xs + +-- Views + +data Maybe2 a b = Nothing2 | Just2 a b + +-- | View of the left end of a sequence. +data ViewL a + = EmptyL -- ^ empty sequence + | a :< Seq a -- ^ leftmost element and the rest of the sequence +#ifndef __HADDOCK__ + deriving (Eq, Show) +#else +instance Eq a => Eq (ViewL a) +instance Show a => Show (ViewL a) +#endif + + +instance Functor ViewL where + fmap _ EmptyL = EmptyL + fmap f (x :< xs) = f x :< fmap f xs + +-- | /O(1)/. Analyse the left end of a sequence. +viewl :: Seq a -> ViewL a +viewl (Seq xs) = case viewLTree xs of + Nothing2 -> EmptyL + Just2 (Elem x) xs' -> x :< Seq xs' + +{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-} +{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-} +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 (case viewLTree m of + Nothing2 -> digitToTree sf + Just2 b m' -> Deep (s - size a) (nodeToDigit b) 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) + +-- | View of the right end of a sequence. +data ViewR a + = EmptyR -- ^ empty sequence + | Seq a :> a -- ^ the sequence minus the rightmost element, + -- and the rightmost element +#ifndef __HADDOCK__ + deriving (Eq, Show) +#else +instance Eq a => Eq (ViewR a) +instance Show a => Show (ViewR a) +#endif + +instance Functor ViewR where + fmap _ EmptyR = EmptyR + fmap f (xs :> x) = fmap f xs :> f x + +-- | /O(1)/. Analyse the right end of a sequence. +viewr :: Seq a -> ViewR a +viewr (Seq xs) = case viewRTree xs of + Nothing2 -> EmptyR + Just2 xs' (Elem x) -> Seq xs' :> x + +{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-} +{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-} +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 (case viewRTree m of + Nothing2 -> digitToTree pr + Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) 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 + +-- Indexing + +-- | /O(log(min(i,n-i)))/. The element at the specified position +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 {-# UNPACK #-} !Int a +#if TESTING + deriving Show +#endif + +{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-} +{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-} +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 _ pr m sf) + | vpr > 0 = lookupDigit i pr + | vm > 0 = case lookupTree vpr m of + Place i' xs -> lookupNode i' xs + | otherwise = lookupDigit vm sf + where vpr = i + size pr + vm = vpr + size m + +{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-} +{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-} +lookupNode :: Sized a => Int -> Node a -> Place a +lookupNode i (Node2 _ a b) + | va > 0 = Place i a + | otherwise = Place va b + where va = i + size a +lookupNode i (Node3 _ a b c) + | va > 0 = Place i a + | vab > 0 = Place va b + | otherwise = Place vab c + where va = i + size a + vab = va + size b + +{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-} +{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-} +lookupDigit :: Sized a => Int -> Digit a -> Place a +lookupDigit i (One a) = Place i a +lookupDigit i (Two a b) + | va > 0 = Place i a + | otherwise = Place va b + where va = i + size a +lookupDigit i (Three a b c) + | va > 0 = Place i a + | vab > 0 = Place va b + | otherwise = Place vab c + where va = i + size a + vab = va + size b +lookupDigit i (Four a b c d) + | va > 0 = Place i a + | vab > 0 = Place va b + | vabc > 0 = Place vab c + | otherwise = Place vabc d + where va = i + size a + vab = va + size b + vabc = vab + size c + +-- | /O(log(min(i,n-i)))/. Replace the element at the specified position +update :: Int -> a -> Seq a -> Seq a +update i x = adjust (const x) i + +-- | /O(log(min(i,n-i)))/. Update the element at the specified position +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 + +{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-} +{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-} +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) + | vpr > 0 = Deep s (adjustDigit f i pr) m sf + | vm > 0 = Deep s pr (adjustTree (adjustNode f) vpr m) sf + | otherwise = Deep s pr m (adjustDigit f vm sf) + where vpr = i + size pr + vm = vpr + size m + +{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-} +{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-} +adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a +adjustNode f i (Node2 s a b) + | va > 0 = Node2 s (f i a) b + | otherwise = Node2 s a (f va b) + where va = i + size a +adjustNode f i (Node3 s a b c) + | va > 0 = Node3 s (f i a) b c + | vab > 0 = Node3 s a (f va b) c + | otherwise = Node3 s a b (f vab c) + where va = i + size a + vab = va + size b + +{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-} +{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-} +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) + | va > 0 = Two (f i a) b + | otherwise = Two a (f va b) + where va = i + size a +adjustDigit f i (Three a b c) + | va > 0 = Three (f i a) b c + | vab > 0 = Three a (f va b) c + | otherwise = Three a b (f vab c) + where va = i + size a + vab = va + size b +adjustDigit f i (Four a b c d) + | va > 0 = Four (f i a) b c d + | vab > 0 = Four a (f va b) c d + | vabc > 0 = Four a b (f vab c) d + | otherwise = Four a b c (f vabc d) + where va = i + size a + vab = va + size b + vabc = vab + size c + +-- Splitting + +-- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence. +take :: Int -> Seq a -> Seq a +take i = fst . splitAt i + +-- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@. +drop :: Int -> Seq a -> Seq a +drop i = snd . splitAt i + +-- | /O(log(min(i,n-i)))/. Split a sequence at a given position. +splitAt :: Int -> Seq a -> (Seq a, Seq a) +splitAt i (Seq xs) = (Seq l, Seq r) + where (l, r) = split i xs + +split :: Int -> FingerTree (Elem a) -> + (FingerTree (Elem a), FingerTree (Elem a)) +split i Empty = i `seq` (Empty, Empty) +split i xs + | size xs > i = (l, consTree x r) + | otherwise = (xs, Empty) + where Split l x r = splitTree (-i) xs + +data Split t a = Split t a t +#if TESTING + deriving Show +#endif + +{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-} +{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-} +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) + | vpr > 0 = case splitDigit i pr of + Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf) + | vm > 0 = case splitTree vpr m of + Split ml xs mr -> case splitNode (vpr + size ml) xs of + Split l x r -> Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = case splitDigit vm sf of + Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) + where vpr = i + size pr + vm = vpr + size m + +{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-} +{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-} +deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a +deepL Nothing m sf = case viewLTree m of + Nothing2 -> digitToTree sf + Just2 a m' -> deep (nodeToDigit a) m' sf +deepL (Just pr) m sf = deep pr m sf + +{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-} +{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-} +deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a +deepR pr m Nothing = case viewRTree m of + Nothing2 -> digitToTree pr + Just2 m' a -> deep pr m' (nodeToDigit a) +deepR pr m (Just sf) = deep pr m sf + +{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-} +{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-} +splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a +splitNode i (Node2 _ a b) + | va > 0 = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where va = i + size a +splitNode i (Node3 _ a b c) + | va > 0 = Split Nothing a (Just (Two b c)) + | vab > 0 = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where va = i + size a + vab = va + size b + +{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-} +{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-} +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) + | va > 0 = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where va = i + size a +splitDigit i (Three a b c) + | va > 0 = Split Nothing a (Just (Two b c)) + | vab > 0 = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where va = i + size a + vab = va + size b +splitDigit i (Four a b c d) + | va > 0 = Split Nothing a (Just (Three b c d)) + | vab > 0 = Split (Just (One a)) b (Just (Two c d)) + | vabc > 0 = Split (Just (Two a b)) c (Just (One d)) + | otherwise = Split (Just (Three a b c)) d Nothing + where va = i + size a + vab = va + size b + vabc = vab + size c + +------------------------------------------------------------------------ +-- Lists +------------------------------------------------------------------------ + +-- | /O(n)/. Create a sequence from a finite list of elements. +fromList :: [a] -> Seq a +fromList = Data.List.foldl' (|>) empty + +-- | /O(n)/. List of elements of the sequence. +toList :: Seq a -> [a] +toList = foldr (:) [] + +------------------------------------------------------------------------ +-- Folds +------------------------------------------------------------------------ + +-- | /O(n*t)/. Fold over the elements of a sequence, +-- associating to the right. +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldr f z (Seq xs) = foldrTree f' z xs + where f' (Elem x) y = f x y + +foldrTree :: (a -> b -> b) -> b -> FingerTree a -> b +foldrTree _ z Empty = z +foldrTree f z (Single x) = x `f` z +foldrTree f z (Deep _ pr m sf) = + foldrDigit f (foldrTree (flip (foldrNode f)) (foldrDigit f z sf) m) pr + +foldrDigit :: (a -> b -> b) -> b -> Digit a -> b +foldrDigit f z (One a) = a `f` z +foldrDigit f z (Two a b) = a `f` (b `f` z) +foldrDigit f z (Three a b c) = a `f` (b `f` (c `f` z)) +foldrDigit f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z))) + +foldrNode :: (a -> b -> b) -> b -> Node a -> b +foldrNode f z (Node2 _ a b) = a `f` (b `f` z) +foldrNode f z (Node3 _ a b c) = a `f` (b `f` (c `f` z)) + +-- | /O(n*t)/. A variant of 'foldr' that has no base case, +-- and thus may only be applied to non-empty sequences. +foldr1 :: (a -> a -> a) -> Seq a -> a +foldr1 f (Seq xs) = getElem (foldr1Tree f' xs) + where f' (Elem x) (Elem y) = Elem (f x y) + +foldr1Tree :: (a -> a -> a) -> FingerTree a -> a +foldr1Tree _ Empty = error "foldr1: empty sequence" +foldr1Tree _ (Single x) = x +foldr1Tree f (Deep _ pr m sf) = + foldrDigit f (foldrTree (flip (foldrNode f)) (foldr1Digit f sf) m) pr + +foldr1Digit :: (a -> a -> a) -> Digit a -> a +foldr1Digit f (One a) = a +foldr1Digit f (Two a b) = a `f` b +foldr1Digit f (Three a b c) = a `f` (b `f` c) +foldr1Digit f (Four a b c d) = a `f` (b `f` (c `f` d)) + +-- | /O(n*t)/. Fold over the elements of a sequence, +-- associating to the left. +foldl :: (a -> b -> a) -> a -> Seq b -> a +foldl f z (Seq xs) = foldlTree f' z xs + where f' x (Elem y) = f x y + +foldlTree :: (a -> b -> a) -> a -> FingerTree b -> a +foldlTree _ z Empty = z +foldlTree f z (Single x) = z `f` x +foldlTree f z (Deep _ pr m sf) = + foldlDigit f (foldlTree (foldlNode f) (foldlDigit f z pr) m) sf + +foldlDigit :: (a -> b -> a) -> a -> Digit b -> a +foldlDigit f z (One a) = z `f` a +foldlDigit f z (Two a b) = (z `f` a) `f` b +foldlDigit f z (Three a b c) = ((z `f` a) `f` b) `f` c +foldlDigit f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d + +foldlNode :: (a -> b -> a) -> a -> Node b -> a +foldlNode f z (Node2 _ a b) = (z `f` a) `f` b +foldlNode f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c + +-- | /O(n*t)/. A variant of 'foldl' that has no base case, +-- and thus may only be applied to non-empty sequences. +foldl1 :: (a -> a -> a) -> Seq a -> a +foldl1 f (Seq xs) = getElem (foldl1Tree f' xs) + where f' (Elem x) (Elem y) = Elem (f x y) + +foldl1Tree :: (a -> a -> a) -> FingerTree a -> a +foldl1Tree _ Empty = error "foldl1: empty sequence" +foldl1Tree _ (Single x) = x +foldl1Tree f (Deep _ pr m sf) = + foldlDigit f (foldlTree (foldlNode f) (foldl1Digit f pr) m) sf + +foldl1Digit :: (a -> a -> a) -> Digit a -> a +foldl1Digit f (One a) = a +foldl1Digit f (Two a b) = a `f` b +foldl1Digit f (Three a b c) = (a `f` b) `f` c +foldl1Digit f (Four a b c d) = ((a `f` b) `f` c) `f` d + +------------------------------------------------------------------------ +-- Derived folds +------------------------------------------------------------------------ + +-- | /O(n*t)/. Fold over the elements of a sequence, +-- associating to the right, but strictly. +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldr' f z xs = foldl f' id xs z + where f' k x z = k $! f x z + +-- | /O(n*t)/. Monadic fold over the elements of a sequence, +-- associating to the right, i.e. from right to left. +foldrM :: Monad m => (a -> b -> m b) -> b -> Seq a -> m b +foldrM f z xs = foldl f' return xs z + where f' k x z = f x z >>= k + +-- | /O(n*t)/. Fold over the elements of a sequence, +-- associating to the left, but strictly. +foldl' :: (a -> b -> a) -> a -> Seq b -> a +foldl' f z xs = foldr f' id xs z + where f' x k z = k $! f z x + +-- | /O(n*t)/. Monadic fold over the elements of a sequence, +-- associating to the left, i.e. from left to right. +foldlM :: Monad m => (a -> b -> m a) -> a -> Seq b -> m a +foldlM f z xs = foldr f' return xs z + where f' x k z = f z x >>= k + +------------------------------------------------------------------------ +-- Reverse +------------------------------------------------------------------------ + +-- | /O(n)/. The reverse of a sequence. +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) + +#if TESTING + +------------------------------------------------------------------------ +-- QuickCheck +------------------------------------------------------------------------ + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = liftM Seq arbitrary + coarbitrary (Seq x) = coarbitrary x + +instance Arbitrary a => Arbitrary (Elem a) where + arbitrary = liftM Elem arbitrary + coarbitrary (Elem x) = coarbitrary x + +instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where + arbitrary = sized arb + where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a) + arb 0 = return Empty + arb 1 = liftM Single arbitrary + arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary + + coarbitrary Empty = variant 0 + coarbitrary (Single x) = variant 1 . coarbitrary x + coarbitrary (Deep _ pr m sf) = + variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf + +instance (Arbitrary a, Sized a) => Arbitrary (Node a) where + arbitrary = oneof [ + liftM2 node2 arbitrary arbitrary, + liftM3 node3 arbitrary arbitrary arbitrary] + + coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b + coarbitrary (Node3 _ a b c) = + variant 1 . coarbitrary a . coarbitrary b . coarbitrary c + +instance Arbitrary a => Arbitrary (Digit a) where + arbitrary = oneof [ + liftM One arbitrary, + liftM2 Two arbitrary arbitrary, + liftM3 Three arbitrary arbitrary arbitrary, + liftM4 Four arbitrary arbitrary arbitrary arbitrary] + + coarbitrary (One a) = variant 0 . coarbitrary a + coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b + coarbitrary (Three a b c) = + variant 2 . coarbitrary a . coarbitrary b . coarbitrary c + coarbitrary (Four a b c d) = + variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d + +------------------------------------------------------------------------ +-- Valid trees +------------------------------------------------------------------------ + +class Valid a where + valid :: a -> Bool + +instance Valid (Elem a) where + valid _ = True + +instance Valid (Seq a) where + valid (Seq xs) = valid xs + +instance (Sized a, Valid a) => Valid (FingerTree a) where + valid Empty = True + valid (Single x) = valid x + valid (Deep s pr m sf) = + s == size pr + size m + size sf && valid pr && valid m && valid sf + +instance (Sized a, Valid a) => Valid (Node a) where + valid (Node2 s a b) = s == size a + size b && valid a && valid b + valid (Node3 s a b c) = + s == size a + size b + size c && valid a && valid b && valid c + +instance Valid a => Valid (Digit a) where + valid (One a) = valid a + valid (Two a b) = valid a && valid b + valid (Three a b c) = valid a && valid b && valid c + valid (Four a b c d) = valid a && valid b && valid c && valid d + +#endif -- 1.7.10.4