アローの例題

ArrowExample.hs

{-
参考記事：
https://qiita.com/Lugendre/items/6b4a8c8a9c85fcdcb292
https://qiita.com/waddlaw/items/49874f4cf9b680e4b015
-}
{-# LANGUAGE Arrows #-}
module ArrowExample where

import Prelude hiding (id, (.))
import Control.Category (Category(..))
import Control.Arrow (Arrow(..), ArrowLoop(..), returnA)


-- 単純オートマトン
newtype Auto a b = A (a -> (b, Auto a b))

instance Category Auto where
  id        = undefined
  A g . A f = A (\b -> let (c, f') = f b
                           (d, g') = g c
                       in  (d, g' . f'))
{-  A f >>> A g = A (\b -> let (c, f') = f b
                             (d, g') = g c
                         in  (d, f' >>> g')) -}
--f >>> g = g . f

instance Arrow Auto where
  arr f       = A (\b -> (f b, arr f))
  first (A f) = A (\(b, d) -> let (c, f') = f b
                              in  ((c, d), first f'))
instance ArrowLoop Auto where
  loop (A f) = A (\b -> let (~(c, d), f') = f (b, d)
                        in (c, loop f'))


-- アローサーキット
class ArrowLoop a => ArrowCircuit a where
  delay :: b -> a b b

instance ArrowCircuit Auto where
  delay b = A (\b' -> (b, delay b'))

counter :: ArrowCircuit a => a Bool Int
counter =
  proc reset -> do
    rec output <- returnA  -< if reset then 0 else next
        next   <- delay 10 -< output + 1 -- 10は初期値
    returnA -< output

runAuto :: Auto b c -> [b] -> [c]
runAuto (A f) [] = []
runAuto (A f) (b : bs) = let (c, f') = f b in (c : runAuto f' bs)

-- *ArrowExample> runAuto counter [False, False, False, True, True, False, False]
-- [10,11,12,0,0,1,2]

Kleisli.hs

{-
参考記事：
https://qiita.com/Lugendre/items/6b4a8c8a9c85fcdcb292
https://qiita.com/waddlaw/items/49874f4cf9b680e4b015
-}
{-# LANGUAGE Arrows #-}
module Main where

import Control.Arrow (returnA, Kleisli(..))


mainLoop :: Kleisli IO ([String], Int) Int
mainLoop =
  proc (strs, n) ->
    if null strs
      then returnA -< n
      else do
        _  <- Kleisli (\_   -> putStrLn "mainLoop start.") -< strs
        _  <- Kleisli (\str -> putStrLn $ "go " ++ str)    -< head strs
        n2 <- mainLoop                                     -< (tail strs, n + 1)
        returnA                                            -< n2

main :: IO Int
main = runKleisli mainLoop (["zero", "first", "second", "third"], 0)

{-
*Main> main
mainLoop start.
go zero
mainLoop start.
go first
mainLoop start.
go second
mainLoop start.
go third
4
-}

MyArrow.hs

{-
参考記事：
https://haxis-fx.hatenadiary.org/entry/20110726/1311657175
-}
{-# LANGUAGE Arrows #-}
module MyArrow where


import Control.Arrow (returnA, arr, loop)


fact1 :: Int -> Int
fact1 = loop (\(n, f) -> (f n, \n -> if n > 1 then n * f (n-1) else 1))

fact2 :: Int -> Int
fact2 = proc n -> do
          rec v <- id -< f n
              f <- id -< (\n -> if n > 1 then n * f (n-1) else 1)
          returnA -< v


myCycle :: [a] -> [a]
myCycle = proc x -> do
            rec
              u <- arr (uncurry (++)) -< (x, u)
              --y <- id                -< u
              --v <- arr (uncurry (++)) -< (u, x)
            returnA -< u


r s b = if b then s else ""
fb = proc x -> do a <- (==0).(`mod`3) -< x
                  b <- (==0).(`mod`5) -< x
                  c <- r "Fizz" -< a
                  d <- r "Buzz" -< b
                  e <- arr (uncurry (++)) -< (c, d)
                  f <- (=="") -< e
                  g <- arr (uncurry r) -< (show x, f)
                  arr (uncurry (++)) -< (g, e)
main = mapM_ (putStrLn . fb) [1..50]