Moore for Less

Moore.hs

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