Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment