Tape.hs

{- |
Module      :  Data.Stream.Tape
Description :  Two-way infinite streams, akin to a Turing machine's tape.
Copyright   :  Copyright (c) 2014 Kenneth Foner

Maintainer  :  kenneth.foner@gmail.com
Stability   :  experimental
Portability :  non-portable

This module implements two-way infinite streams with a focused element, akin to a Turing machine's tape. This structure
is also known by the name of a list zipper (although in this case it's a list zipper with the additional criterion that
the list is infinite in both directions).
-}

{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE FlexibleInstances #-}

module Data.Stream.Tape where

import Control.Comonad
import Control.Arrow
import Control.Applicative
import Data.Distributive

import Data.Stream ( Stream(..) )
import qualified Data.Stream as S

import Prelude hiding ( iterate , take )

-- | A @Tape@ is like a Turing-machine tape: infinite in both directions, with a focus in the middle.
data Tape a = Tape { viewL :: Stream a -- ^ the side of the @Tape@ left of @focus@
                   , focus :: a        -- ^ the focused element
                   , viewR :: Stream a -- ^ the side of the @Tape@ right of @focus@
                   } deriving ( Functor )

-- | Produce a @Tape@ from a seed value, ala unfoldr for lists, or unfold for @Stream@s.
unfold :: (c -> (a,c)) -- ^ leftwards unfolding function
       -> (c -> a)     -- ^ function giving the focus value from the seed
       -> (c -> (a,c)) -- ^ rightwards unfolding function
       -> c            -- ^ seed value
       -> Tape a
unfold prev center next =
   Tape <$> S.unfold prev <*> center <*> S.unfold next

-- | Produce a @Tape@ consisting of the infinite iteration of two functions to a starting focus value,
--   ala iterate for lists or @Stream@s.
iterate :: (a -> a) -- ^ leftwards iteration function
        -> (a -> a) -- ^ rightwards iteration function
        -> a        -- ^ focus value
        -> Tape a
iterate prev next =
   unfold (dup . prev) id (dup . next)
   where dup a = (a,a)

-- | Given an enumerable type, produce the @Tape@ where the left side is the sequence of predecessors,
--   and the right side is the sequence of successors.
enumerate :: (Enum a) => a -> Tape a
enumerate = iterate pred succ

-- | Tapes form a comonad, where extract gives the focus element and duplicate gives a /diagonalized/ 
--   @Tape (Tape a)@ such that @extract . extract . moveL . duplicate == extract . moveL@ and likewise
--   for @moveR@. 
instance Comonad Tape where
   extract (Tape _ c _) = c
   duplicate = iterate moveL moveR

-- | Applying one tape to another moves them together. This is like the @Applicative@ instances for
--   @ZipList@ and @Stream@.
instance ComonadApply Tape where
   (Tape ls c rs) <@> (Tape ls' c' rs') =
      Tape (ls <*> ls') (c c') (rs <*> rs')

-- | A tape is @Applicative@, where the @\<*\>@ is equivalent to its @ComonadApply@ instance (required
--   by law), and a pure value is the tape consisting of copies of that value in both directions.
instance Applicative Tape where
   (<*>) = (<@>)
   pure  = Tape <$> pure <*> id <*> pure

-- | Tapes are @Distributive@ because we can replicate their structure on the outside of a functor by
--   sending movement commands through the functor via @fmap moveL@ and @fmap moveR@, and using
--   @fmap focus@ to remove the extra structure inside the functor. As stated in the Distributive
--   documentation, this can only work if all Tapes have the same cardinality of holes, and if there
--   is no extra information to propagate from outside the functor -- hence, an @Indexed@ tape can't
--   be made into a @Distributive@, as there's no way to extract the index from the functor.
instance Distributive Tape where
   distribute =
      unfold (fmap (focus . moveL) &&& fmap moveL)
             (fmap focus)
             (fmap (focus . moveR) &&& fmap moveR)

-- | The functions @moveR@ and @moveL@ move the focus on the tape right and left, respectively.
moveL, moveR :: Tape a -> Tape a
moveL (Tape (Cons l ls) c rs) = Tape ls l (Cons c rs)
moveR (Tape ls c (Cons r rs)) = Tape (Cons c ls) r rs

-- | Gives a @Tape@ containing infinite copies of the given element.
tapeOf :: a -> Tape a
tapeOf = pure