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)
data Cycle a = MkCycle Int (DList a)
dGoLeft :: DList a -> DList a
dGoLeft (MkDList l _ _) = l
goLeft :: Cycle a -> Cycle a
goLeft c = MkCycle (cycleLength c) (dGoLeft $ cycleDList c)
dGoRight :: DList a -> DList a
dGoRight (MkDList _ _ r) = r
goRight :: Cycle a -> Cycle a
goRight c = MkCycle (cycleLength c) (dGoRight $ cycleDList c)
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
getValue :: Cycle a -> a
getValue c = if null c
then error "getValue: empty cycle"
else dGetValue $ cycleDList c
leftValue :: Cycle a -> a
leftValue = getValue . goLeft
rightValue :: Cycle a -> a
rightValue = getValue . goRight
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 (n1) (goLeft c)
| n < 0 = undefined
nthValueRight :: Int -> Cycle a -> a
nthValueRight 0 c = getValue c
nthValueRight n c
| n > 0 = nthValueRight (n1) (goRight c)
| n < 0 = undefined
cycleLength :: Cycle a -> Int
cycleLength (MkCycle n _) = n
cycleDList :: Cycle a -> DList a
cycleDList (MkCycle _ d) = d
listCycle :: [a] -> Cycle a
listCycle xs = MkCycle (length xs) (listDList xs)
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)
dToList :: DList a -> [a]
dToList (MkDList _ v r) = v : dToList r
cycleToList :: Cycle a -> [a]
cycleToList c = Prelude.take (cycleLength c) (cycleToInfiniteList c)
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 (n1) (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 (n1) (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)
takeLR :: Int -> Cycle a -> [a]
takeLR n c
| n < 0 = takeLeft (negate n) c
| otherwise = takeRight n c
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
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
zipCycleWith :: (a -> b -> c) -> Cycle a -> Cycle b -> Cycle c
zipCycleWith fn c1 c2 = fromList $ zipWith fn (toList c1) (toList c2)
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 (s1) c, nthValue (s1) 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