Moore machines as lenses

moorelens.hs

{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}

import Control.Lens -- from `lens`
import Control.Monad.State.Lazy

moore :: MonadState s m => Lens s s b a -> Traversal as bs a b -> as -> m bs
moore l trav = trav (\a -> l <<.= a)

runMoore :: Lens s s b a -> s -> [a] -> [b]
runMoore l s fa = evalState (moore l traverse fa) s

mooreLensFromFunction :: (a -> b) -> Lens b b b a
mooreLensFromFunction f = lens id (\_ a -> f a)


serialWiring :: Lens (b, c) (a, b) c a
serialWiring = lens get put
  where
    get :: (b, c) -> c
    get (b, c) = c
    put :: (b, c) -> a -> (a, b)
    put (b, c) a = (a, b)

serial :: Lens s t b c -> Lens s' t' a b -> Lens (s, s') (t, t') a c
serial l r = alongside l r . serialWiring


plus :: Lens Integer Integer Integer (Integer, Integer)
plus = mooreLensFromFunction (uncurry (+))

innerBox :: Lens (Integer, Integer) (Integer, Integer) (Integer, Integer) ((Integer, Integer), Integer)
innerBox = alongside plus id

fibWiring :: Lens (Integer, Integer) ((Integer, Integer), Integer) Integer ()
fibWiring = lens (\(plusOut, idOut) -> plusOut) (\(plusOut, idOut) fibIn -> ((plusOut, idOut), plusOut))

fibLens :: Lens (Integer, Integer) (Integer, Integer) Integer ()
fibLens = innerBox . fibWiring

fib :: [Integer]
fib = runMoore fibLens (1, 1) (repeat ())


data NotState = S | T

notLens :: Lens NotState NotState Bool Bool
notLens = lens get put
  where
    get :: NotState -> Bool
    get S = False
    get T = True
    put :: NotState -> Bool -> NotState
    put S True = S
    put S False = T
    put T True = S
    put T False = T

data DetectState = R | U | V | W

detect011Lens :: Lens DetectState DetectState Bool Bool
detect011Lens = lens get put
  where
    get :: DetectState -> Bool
    get W = True
    get _ = False
    put :: DetectState -> Bool -> DetectState
    put R False = U
    put R True = R
    put U False = U
    put U True = V
    put V False = U
    put V True = W
    put W True = R
    put W False = U

detect100Lens :: Lens (NotState, DetectState) (NotState, DetectState) Bool Bool
detect100Lens = notLens `serial` detect011Lens