MealyのArrowApply law 検証

ArrowApplyMealy.hs

{-# LANGUAGE BangPatterns, Arrows #-}
module Main where

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Control.Monad.Identity
import qualified Data.Machine as Mc
import Data.Machine ((~>))
import Data.Machine.Mealy

-- 引数の10倍を初期値として0になるまで入力値を引いていく
mealyA :: Int -> Mealy Int Int
mealyA i = unfoldMealy go (i*10)
  where
    go s x = let !s' = max (s - x) 0 in (s', s')

-- 現在値に定数を掛けて入力値を足して定数で剰余
mealyB :: Mealy Int Int
mealyB = unfoldMealy go 0
  where
    go s x = let s' = (s * 7 + x) `mod` 11 in (s', s')

testMealy :: Mealy a b -> [a] -> [b]
testMealy x l = Mc.run (Mc.source l ~> Mc.auto x) 

main :: IO ()
main =
  do
    -- law1 === id
    putStrLn "** Law 1 **"
    let in1 = [(x, 2*x) | x <- [1..10]]
        law1 = first (arr (\x -> arr (\y -> (x,y)))) >>> app
    print $ in1
    putStrLn "----"
    print $ testMealy law1 in1

    putStrLn "**  Law 2 **"
    let in2 = [(mealyA x, 2*x) | x <- [1..10]]
        law2l g = first (arr (g >>>)) >>> app
        law2r g = second g >>> app
    print $ testMealy (law2l mealyB) in2
    putStrLn "----"
    print $ testMealy (law2r mealyB) in2

    putStrLn "**  Law 3 **"
    let law3l h = first (arr (>>> h)) >>> app
        law3r h = app >>> h
    print $ testMealy (law3l mealyB) in2
    putStrLn "----"
    print $ testMealy (law3r mealyB) in2

{-
** Law 1 **
[(1,2),(2,4),(3,6),(4,8),(5,10),(6,12),(7,14),(8,16),(9,18),(10,20)]
----
[(1,2),(2,4),(3,6),(4,8),(5,10),(6,12),(7,14),(8,16),(9,18),(10,20)]
**  Law 2 **
[8,11,21,23,33,42,42,43,49,55]
----
[8,11,21,23,33,42,42,43,49,55]
**  Law 3 **
[8,8,7,0,3,1,1,0,9,9]
----
[8,4,2,1,5,9,0,8,1,7]
-}