{-# 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