WalkGraphsWithPairing.hs

{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}

module Graph where

import Control.Comonad

-- we need to separate `a` and `b` because `a` is covariant while `b` is contravariant => this is actually a profuctor
data PointedGraph moves b a = PointedGraph
  { _position :: a
  , _move     :: moves -> b -> a
  }

instance Show a => Show (PointedGraph moves b a) where
  show (PointedGraph position move) = "Position is " ++ show position

-- in a stream you can either stay where you are or advance by one
stream :: PointedGraph Bool Int Int
stream = PointedGraph 0 streamMove
  where
    streamMove True  n = n + 1
    streamMove False n = n

instance Functor (PointedGraph moves b) where
  fmap f (PointedGraph position move) = PointedGraph (f position) ((f .) . move)

instance Comonad (PointedGraph moves b) where
  extract (PointedGraph position _)         = position
  duplicate pg@(PointedGraph position move) = PointedGraph pg (\moves b -> PointedGraph (move moves b) move)

-- `GraphMove` describes the possible moves
-- `Stay `a says that we remain in `a`
-- `Move m b next` say that the apply move `m` to move from a position `b`
data GraphMove moves b a
  = Stay a
  | Move moves b (GraphMove moves b a)

advanceThree :: GraphMove Bool Int Int
advanceThree = Move True 0 (Move True 1 (Move True 2 (Stay 3)))

instance Functor (GraphMove moves b) where
  fmap f (Stay a)         = Stay (f a)
  fmap f (Move moves b a) = Move moves b $ fmap f a

instance Applicative (GraphMove moves b) where
  pure a = Stay a
  (Stay f)         <*> (Stay a)           = Stay (f a)
  (Stay f)         <*> (Move moves b a)   = Move moves b $ fmap f a
  (Move moves b f) <*> (Stay a)           = Move moves b $ f <*> pure a
  (Move moves b f) <*> (Move moves' b' a) = Move moves b $ f <*> a

instance Monad (GraphMove moves b) where
  (Stay a)         >>= f = f a
  (Move moves b a) >>= f = Move moves b $ a >>= f

class Pairing f g | f -> g, g -> f where
  pair :: (a -> b -> c) -> f a -> g b -> c

instance Pairing (GraphMove moves b) (PointedGraph moves b) where
  pair f (Stay a)         (PointedGraph position move) = f a position
  pair f (Move moves b a) (PointedGraph position move) = pair f a (PointedGraph (move moves b) move)

walk :: (Comonad w, Pairing m w) => w a -> m b -> w a
walk space movement = pair (\_ newSpace -> newSpace) movement (duplicate space)