-- | -- Module : Data.Edison.Seq.BinaryRandList -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Binary Random-Access lists. All functions have the standard running -- times from "Data.Edison.Seq" except the following: -- -- * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop @O( log n )@ -- -- * copy, inBounds @O( i )@ -- -- * append, reverseOnto @O( n1 + log n2 )@ -- -- * take, splitAt @O( i + log n )@ -- -- * subseq @O( log n + len )@ -- -- * zip @O( min( n1, n2 ) + log max( n1, n2 ) )@ -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 10.1.2. module Data.Edison.Seq.BinaryRandList ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import Control.Monad.Identity import Data.Maybe import qualified Data.Edison.Seq as S ( Sequence(..) ) import Data.Edison.Seq.Defaults import Data.Monoid import Control.Monad import Test.QuickCheck -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.BinaryRandList" data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a)) deriving (Eq) -- not exported, rewrite as bit ops? --even n = (n `mod` 2) == 0 --odd n = (n `mod` 2) <> 0 half :: (Integral a) => a -> a half n = n `div` 2 mkEven :: Seq (a, a) -> Seq a mkEven E = E mkEven ps = Even ps empty = E singleton x = Odd x E lcons x E = Odd x E lcons x (Even ps) = Odd x ps lcons x (Odd y ps) = Even (lcons (x,y) ps) append xs E = xs append xs ys@(Even pys) = case xs of E -> ys Even pxs -> Even (append pxs pys) Odd x pxs -> Odd x (append pxs pys) append xs ys@(Odd _ _) = foldr lcons ys xs copy n x | n <= 0 = E | otherwise = cp n x where cp :: Int -> a -> Seq a cp n x | odd n = Odd x (cp (half n) (x,x)) | n == 0 = E | otherwise = Even (cp (half n) (x,x)) lview E = fail "BinaryRandList.lview: empty sequence" lview (Even ps) = case lview ps of Just ((x,y), ps') -> return (x, Odd y ps') Nothing -> error "BinaryRandList.lview: bug!" lview (Odd x ps) = return (x, mkEven ps) lhead E = error "BinaryRandList.lhead: empty sequence" lhead (Even ps) = fst (lhead ps) lhead (Odd x _) = x lheadM E = fail "BinaryRandList.lheadM: empty sequence" lheadM (Even ps) = return (fst (lhead ps)) lheadM (Odd x _) = return (x) ltail E = error "BinaryRandList.ltail: empty sequence" ltail (Even ps) = case lview ps of Just ((_,y), ps') -> Odd y ps' Nothing -> error "BinaryRandList.ltail: bug!" ltail (Odd _ ps) = mkEven ps ltailM E = fail "BinaryRandList.ltailM: empty sequence" ltailM (Even ps) = case lview ps of Just ((_,y), ps') -> return (Odd y ps') Nothing -> error "BinaryRandList.ltailM: bug!" ltailM (Odd _ ps) = return (mkEven ps) rhead E = error "BinaryRandList.rhead: empty sequence" rhead (Even ps) = snd (rhead ps) rhead (Odd x E) = x rhead (Odd _ ps) = snd (rhead ps) rheadM E = fail "BinaryRandList.rheadM: empty sequence" rheadM (Even ps) = return (snd (rhead ps)) rheadM (Odd x E) = return x rheadM (Odd _ ps) = return (snd (rhead ps)) null E = True null _ = False size E = 0 size (Even ps) = 2 * size ps size (Odd _ ps) = 1 + 2 * size ps map _ E = E map f (Even ps) = Even (map (\(x,y) -> (f x,f y)) ps) map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps) fold = foldr fold' = foldr' fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (Even ps) = foldr (\(x,y) e -> f x (f y e)) e ps foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps) foldr' _ e E = e foldr' f e (Even ps) = foldr' (\(x,y) e -> f x $! f y $! e) e ps foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps) foldl _ e E = e foldl f e (Even ps) = foldl (\e (x,y) -> f (f e x) y) e ps foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps foldl' _ e E = e foldl' f e (Even ps) = foldl' (\e (x,y) -> f (f e x) y) e ps foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps reduce1 _ E = error "BinaryRandList.reduce1: empty seq" reduce1 f (Even ps) = reduce1 f (map (uncurry f) ps) reduce1 _ (Odd x E) = x reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps)) reduce1' _ E = error "BinaryRandList.reduce1': empty seq" reduce1' f (Even ps) = reduce1' f (map (uncurry f) ps) reduce1' _ (Odd x E) = x reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps)) inBounds i xs = (i >= 0) && inb xs i where inb :: Seq a -> Int -> Bool inb E _ = False inb (Even ps) i = inb ps (half i) inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1)) lookup i xs = runIdentity (lookupM i xs) lookupM i xs | i < 0 = fail "BinaryRandList.lookup: bad subscript" | otherwise = lookFun nothing xs i return where nothing = fail "BinaryRandList.lookup: not found" lookupWithDefault d i xs | i < 0 = d | otherwise = lookFun d xs i id -- not exported lookFun :: b -> Seq a -> Int -> (a -> b) -> b lookFun d E _ _ = d lookFun d (Even ps) i f | even i = lookFun d ps (half i) (f . fst) | otherwise = lookFun d ps (half i) (f . snd) lookFun d (Odd x ps) i f | odd i = lookFun d ps (half (i-1)) (f . fst) | i == 0 = f x | otherwise = lookFun d ps (half (i-1)) (f . snd) adjust f i xs | i < 0 = xs | otherwise = adj f i xs where adj :: (a -> a) -> Int -> Seq a -> Seq a adj _ _ E = E adj f i (Even ps) | even i = Even (adj (mapFst f) (half i) ps) | otherwise = Even (adj (mapSnd f) (half i) ps) adj f i (Odd x ps) | odd i = Odd x (adj (mapFst f) (half (i-1)) ps) | i == 0 = Odd (f x) ps | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps) -- not exported mapFst :: (t -> t2) -> (t, t1) -> (t2, t1) mapFst f (x,y) = (f x,y) mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2) mapSnd f (x,y) = (x,f y) take n xs = if n <= 0 then E else tak n xs where tak :: Int -> Seq a -> Seq a tak 0 _ = E tak _ E = E tak i (Even ps) | even i = Even (tak (half i) ps) tak i (Odd x ps) | odd i = Odd x (tak (half (i-1)) ps) tak i xs = takeUsingLists i xs -- drop is O(log^2 n) instead of O(log n)?? drop n xs = if n <= 0 then xs else drp n xs where drp :: Int -> Seq a -> Seq a drp 0 xs = xs drp _ E = E drp i (Even ps) | even i = mkEven (drp (half i) ps) | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps))) drp i (Odd _ ps) | odd i = mkEven (drp (half (i-1)) ps) | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps))) strict l@E = l strict l@(Even l') = strict l' `seq` l strict l@(Odd _ l') = strict l' `seq` l strictWith _ l@E = l strictWith f l@(Even l') = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l -- structural invariants are enforced by the type system structuralInvariant = const True -- the remaining functions all use defaults rcons = rconsUsingFoldr rview = rviewDefault rtail = rtailUsingLview rtailM = rtailMUsingLview concat = concatUsingFoldr reverse = reverseUsingReverseOnto reverseOnto = reverseOntoUsingFoldl fromList = fromListUsingCons toList = toListUsingFoldr concatMap = concatMapUsingFoldr foldr1 = foldr1UsingLview foldr1' = foldr1'UsingLview foldl1 = foldl1UsingFoldl foldl1' = foldl1'UsingFoldl' reducer = reducerUsingReduce1 reducel = reducelUsingReduce1 reducer' = reducer'UsingReduce1' reducel' = reducel'UsingReduce1' update = updateUsingAdjust mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldlWithIndex = foldlWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex' = foldlWithIndex'UsingLists splitAt = splitAtDefault filter = filterUsingFoldr partition = partitionUsingFoldr subseq = subseqDefault takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview -- for zips, could optimize by calculating which one is shorter and -- retaining its shape zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists unzip = unzipUsingLists unzip3 = unzip3UsingLists unzipWith = unzipWithUsingLists unzipWith3 = unzipWith3UsingLists -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance App.Alternative Seq where empty = empty (<|>) = append instance App.Applicative Seq where pure = return x <*> y = do x' <- x y' <- y return (x' y') instance Monad Seq where return = singleton xs >>= k = concatMap k xs instance MonadPlus Seq where mplus = append mzero = empty -- instance Eq (Seq a) is derived instance Ord a => Ord (Seq a) where compare = defaultCompare instance Show a => Show (Seq a) where showsPrec = showsPrecUsingToList instance Read a => Read (Seq a) where readsPrec = readsPrecUsingFromList instance Arbitrary a => Arbitrary (Seq a) where arbitrary = do xs <- arbitrary return (fromList xs) instance CoArbitrary a => CoArbitrary (Seq a) where coarbitrary E = variant 0 coarbitrary (Even ps) = variant 1 . coarbitrary ps coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps instance Monoid (Seq a) where mempty = empty mappend = append