Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Moore for Less
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Comonad
import Data.Bifunctor
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Functor.Rep
import Data.Monoid
import Data.Profunctor.Unsafe
data Moore a b where
Moore :: Representable k => k b -> (a -> k (Rep k)) -> Rep k -> Moore a b
instance Functor (Moore a) where
fmap f (Moore k u b) = Moore (fmap f k) u b
instance Applicative (Moore a) where
pure a = Moore (Identity a) (\_ -> Identity ()) ()
Moore kf uf sf <*> Moore ka ua sa =
Moore (Compose ((<$> ka) <$> kf)) (\x -> Compose $ (\y -> (,) y <$> ua x) <$> uf x) (sf, sa)
instance Comonad (Moore a) where
extract (Moore k _ s) = index k s
duplicate (Moore k u s) = Moore (tabulate (Moore k u)) u s
extend f (Moore k u s) = Moore (tabulate (f . Moore k u)) u s
instance ComonadApply (Moore a) where
(<@>) = (<*>)
instance Profunctor Moore where
dimap f g (Moore k u s) = Moore (g <$> k) (u . f) s
newtype Tab f = Tab { getTab :: f (Rep f) }
instance Representable f => Monoid (Tab f) where
mempty = Tab $ tabulate id
mappend (Tab fs) (Tab gs) = Tab (index gs <$> fs)
feed :: Foldable f => Moore a b -> f a -> Moore a b
feed (Moore k u s) as = Moore k u (index (getTab $ foldMap (Tab #. u) as) s)
step :: Moore a b -> a -> b
step (Moore k u s) a = index k (index (u a) s)
data Cofree f a where
Cofree :: Representable k => k a -> k (f (Rep k)) -> Rep k -> Cofree f a
instance Functor (Cofree f) where
fmap f (Cofree k u s) = Cofree (fmap f k) u s
instance Comonad (Cofree f) where
extract (Cofree k _ s) = index k s
duplicate (Cofree k u s) = Cofree (tabulate (Cofree k u)) u s
type Transducer a b = forall f. Representable f => (b -> Tab f) -> a -> Tab f
transduce :: Moore b c -> Transducer a b -> Moore a c
transduce (Moore k u s) t = Moore k (getTab #. t (Tab #. u)) s
newtype Set f = Set { getSet :: f Bool }
instance Representable f => Monoid (Set f) where
mempty = Set $ tabulate (const False)
mappend (Set as) (Set bs) = Set $ tabulate $ \i -> index as i || index bs i
singleton :: (Representable f, Eq (Rep f)) => Rep f -> Set f
singleton i = Set $ tabulate (i==)
insert :: (Representable f, Eq (Rep f)) => Rep f -> Set f -> Set f
insert i (Set is) = Set $ tabulate $ \j -> index is j || (i==j)
contains :: Representable f => Set f -> Rep f -> Bool
contains (Set is) i = index is i
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment