{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Data.Cycle (Cycle , goLeft, goRight, goLR , getValue, leftValue, rightValue, nthValue , takeLR, dropLR , cycleToInfiniteList , zipCycle, zipCycleWith ) where import Data.Functor import Data.Collections import Data.Collections.BaseInstances import Data.Maybe (fromJust) import Data.Monoid import Control.Monad import Control.Applicative import Prelude hiding (null, foldl, foldr, take, reverse, head, tail, drop) import qualified Prelude data DList a = MkDList (DList a) a (DList a) -- | A cyclic doubly linked list. -- -- To create a new Cycle, use -- 'Data.Collections.fromList', 'Data.Collections.fromFoldable' or any of -- the insertion functions from 'Data.Collections.Unfoldable'. Elements -- are inserted in front of the current position. -- -- To get the length of the list, use 'Data.Collections.size'. -- To extract all cycle elements, use 'Data.Collections.toList'. You can -- also create an infinite list with 'cycleToInfiniteList'. -- -- 'Data.Collections.take', 'Data.Collections.drop' and 'Data.Collections.splitAt' -- also accept negative values for working backwards (see 'takeLR' and 'dropLR' -- for details). -- -- In general, any function @f@ working on -- @[a]@ can be adapted for @Cycle a@ by writing @fromList . f . toList@. -- -- The 'Monad', 'Functor', 'Applicative', 'Alternative', 'Monoid' and -- 'Foldable' instances work -- like the default instances for lists. data Cycle a = MkCycle Int (DList a) dGoLeft :: DList a -> DList a dGoLeft (MkDList l _ _) = l -- | Move focus to the element on the left of the current position. goLeft :: Cycle a -> Cycle a goLeft c = MkCycle (cycleLength c) (dGoLeft $ cycleDList c) dGoRight :: DList a -> DList a dGoRight (MkDList _ _ r) = r -- | Move focus to the element on the right of the current position. -- -- > goLeft . goRight == id goRight :: Cycle a -> Cycle a goRight c = MkCycle (cycleLength c) (dGoRight $ cycleDList c) -- | Move @abs n@ steps to the left (@n \< 0@) or right (@n > 0@) or don't move -- at all (@n == 0@). goLR :: Int -> Cycle a -> Cycle a goLR n c = (iterate f c) !! idx where idx = if n >= 0 then n else negate n f = if n >= 0 then goRight else goLeft dGetValue :: DList a -> a dGetValue (MkDList _ v _) = v -- | Get the value at the current position. 'error' if @null c@. getValue :: Cycle a -> a getValue c = if null c then error "getValue: empty cycle" else dGetValue $ cycleDList c -- | Get value on the left. 'error' if @null c@. leftValue :: Cycle a -> a leftValue = getValue . goLeft -- | Get value on the right. 'error' if @null c@. rightValue :: Cycle a -> a rightValue = getValue . goRight -- | Get nth value to the left (@n \< 0@) or right (@n > 0@) or -- the current value (@n == 0@). 'error' if @null c@. -- -- > nthValue = flip (!) nthValue :: Int -> Cycle a -> a nthValue n c | n < 0 = nthValueLeft (negate n) c | otherwise = nthValueRight n c nthValueLeft :: Int -> Cycle a -> a nthValueLeft 0 c = getValue c nthValueLeft n c | n > 0 = nthValueLeft (n-1) (goLeft c) | n < 0 = undefined nthValueRight :: Int -> Cycle a -> a nthValueRight 0 c = getValue c nthValueRight n c | n > 0 = nthValueRight (n-1) (goRight c) | n < 0 = undefined cycleLength :: Cycle a -> Int cycleLength (MkCycle n _) = n cycleDList :: Cycle a -> DList a cycleDList (MkCycle _ d) = d -- same as listDList, but remember size -- this makes it possible to implement cycleToList and to guard -- getValue against empty list listCycle :: [a] -> Cycle a listCycle xs = MkCycle (length xs) (listDList xs) -- create a cyclic doubly linked list from a list -- for explanation, see: http://www.haskell.org/haskellwiki/Tying_the_Knot listDList :: [a] -> DList a listDList [] = error "listDList: empty list" listDList xs = let (firstDList, lastDList) = go lastDList xs firstDList in firstDList where go :: DList a -> [a] -> DList a -> (DList a, DList a) go leftDList [] rightDList = (rightDList, leftDList) go leftDList (x:xs) rightDList = let thisDList = MkDList leftDList x nextDList (nextDList, lastDList) = go thisDList xs rightDList in (thisDList, lastDList) -- creates an infinite list from a DList dToList :: DList a -> [a] dToList (MkDList _ v r) = v : dToList r -- creates a finite list of length (cycleLength c) cycleToList :: Cycle a -> [a] cycleToList c = Prelude.take (cycleLength c) (cycleToInfiniteList c) -- | Convert to an infinite list starting with the current value -- and moving to the right. cycleToInfiniteList :: Cycle a -> [a] cycleToInfiniteList c = dToList $ cycleDList c dTakeRight :: Int -> DList a -> [a] dTakeRight n c = if n < 0 then undefined else go n c where go 0 _ = [] go n c = dGetValue c : go (n-1) (dGoRight c) dTakeLeft :: Int -> DList a -> [a] dTakeLeft n c = if n < 0 then undefined else go n c where go 0 _ = [] go n c = dGetValue c : go (n-1) (dGoLeft c) takeRight :: Int -> Cycle a -> [a] takeRight n c = dTakeRight n (cycleDList c) takeLeft :: Int -> Cycle a -> [a] takeLeft n c = dTakeLeft n (cycleDList c) -- | Take @abs n@ values starting at the current one and moving -- to the right (@n > 0@) or left (@n \< 0@). @n@ can be arbitrary -- big. -- -- > take n = fromList . takeLR n takeLR :: Int -> Cycle a -> [a] takeLR n c | null c = [] | n < 0 = takeLeft (negate n) c | otherwise = takeRight n c -- | Drop @abs n@ values starting at the current one and moving -- to the right (@n > 0@) or left (@n \< 0@). @n@ can be arbitrary -- big. -- -- > drop n = fromList . dropLR n dropLR :: Int -> Cycle a -> [a] dropLR n c | n < 0 = reverse $ dropLR (negate n) $ reverse c | otherwise = drop n $ toList c instance Functor DList where fmap fn c = MkDList (fmap fn $ dGoLeft c) (fn $ dGetValue c) (fmap fn $ dGoRight c) instance Functor Cycle where fmap fn c = MkCycle (cycleLength c) (fmap fn (cycleDList c)) instance Applicative Cycle where pure = singleton fs <*> xs = fromList (toList fs <*> toList xs) instance Alternative Cycle where empty = Data.Collections.empty xs <|> ys = fromList (toList xs <|> toList ys) instance Monad Cycle where return = pure xs >>= fn = fromList $ toList xs >>= (toList . fn) instance Unfoldable (Cycle a) a where -- inserts before current position insert x c = listCycle $ x : cycleToList c empty = listCycle [] singleton x = listCycle [x] insertMany f c = foldr insert c f insertManySorted = insertMany instance Foldable (Cycle a) a where foldr f z = foldr f z . cycleToList size = cycleLength null = (==0) . size isSingleton = (==1) . size instance Collection (Cycle a) a where filter pred c = listCycle $ Prelude.filter pred $ cycleToList c -- | Combine two cycles by applying a binary function to all element -- pairs. Like 'Data.List.zipWith'. zipCycleWith :: (a -> b -> c) -> Cycle a -> Cycle b -> Cycle c zipCycleWith fn c1 c2 = fromList $ zipWith fn (toList c1) (toList c2) -- | > zipCycle = zipCycleWith (,) zipCycle :: Cycle a -> Cycle b -> Cycle (a, b) zipCycle = zipCycleWith (,) instance Show a => Show (Cycle a) where show c = "fromList " ++ show (toList c) instance Monoid (Cycle a) where mempty = Data.Collections.empty xs `mappend` ys = insertMany xs ys instance Sequence (Cycle a) a where take n = fromList . takeLR n drop n = fromList . dropLR n reverse = fromList . reverse . toList front c = if null c then Nothing else Just (getValue c, drop 1 c) back c = let s = size c in if s == 0 then Nothing else Just (take (s-1) c, nthValue (s-1) c) cons = insert snoc c x = reverse $ insert x $ reverse c a `isPrefix` b = toList a `isPrefix` toList b splitAt n c = (take n c, drop n c) instance Indexed (Cycle a) Int a where index k c = nthValue k c adjust f k c = let c' = goLR k c vs = toList c' xs = f (head vs) : tail vs c'' = fromList xs in goLR (-k) c'' inDomain k c = not (null c) c // a = foldr (\(k,v) c' -> adjust (const v) k c') c a instance Eq a => Eq (Cycle a) where xs == ys = toList xs == toList ys