Dyad

Haskell

Maarten Fokkinga の Dyads。使い道は謎。

{-# LANGUAGE Arrows, MultiParamTypeClasses, FunctionalDependencies, TypeOperators  #-}

module Main where

import Prelude 
import Control.Arrow
import qualified Control.Category as Cat
import Control.Monad
import Control.Monad.Identity
import Control.Comonad
import Data.Maybe

--------------------------   Maarten Fokkinga's Dyads  ---------------------------------------------
-------------------------- from category-extras-0.53.5 ---------------------------------------------

class (Cat.Category r, Cat.Category s) => CFunctor f r s | f r -> s,  f s -> r where
  cmap :: r a b -> s (f a) (f b)

class (CFunctor f (~>) (~>), CFunctor g (~>) (~>)) => CDistributes f g (~>) where
  cdist :: f (g a) ~> g (f a)

class CFunctor m (~>) (~>) => CBind m (~>) where
  cjoin :: m (m a) ~> m a
  cbind :: (a ~> m b) -> (m a ~> m b)

  cjoin = cbind Cat.id
  cbind f = (Cat..) cjoin (cmap f)

class CFunctor w (~>) (~>) => CExtend w (~>) where
  cduplicate :: w a ~> w (w a)
  cextend :: (w a ~> b) -> (w a ~> w b)

  cduplicate = cextend Cat.id
  cextend f = (Cat..) (cmap f) cduplicate

class (CDistributes w m (~>), CDistributes m w (~>), CExtend w (~>), CBind m (~>)) => CDyad w m (~>) where
  cdyid :: w a ~> m a

newtype DiKleisli w m (~>) a b = DiKleisli { runDiKleisli :: w a ~> m b }

instance CDyad w m k => Cat.Category (DiKleisli w m k) where
  DiKleisli g . DiKleisli f = DiKleisli ((Cat..) (cbind g) ((Cat..) cdist (cextend f)))
  id = DiKleisli cdyid

-----------------------------------------------------------------------------------------------------




-------------------------------------------some instances--------------------------------------------

instance CFunctor ([]) (->) (->) where cmap = fmap 
instance CFunctor Maybe (->) (->) where cmap = fmap
instance CFunctor Identity (->) (->) where cmap = fmap


instance CDistributes ([]) ([]) (->) where cdist = id

instance CDistributes Maybe ([]) (->) where
  cdist Nothing = []
  cdist (Just as) = fmap return as

instance CDistributes ([]) Maybe (->) where
  cdist as = mapM (return . fromJust) as

instance CDistributes Identity ([]) (->) where
  cdist (Identity a) = fmap return a

instance CDistributes ([]) Identity (->) where
  cdist as = mapM (return . runIdentity) as


instance CBind ([]) (->) where cjoin = join

instance CExtend ([]) (->) where cduplicate = duplicate
instance CExtend Maybe (->) where cduplicate = duplicate
instance CExtend Identity (->) where cduplicate = duplicate


instance CDyad Maybe ([]) (->) where
  cdyid Nothing = []
  cdyid (Just a) = [a]

instance CDyad ([]) ([]) (->) where
  cdyid = id

instance CDyad Identity ([]) (->) where
  cdyid (Identity a) = [a]


-- てすと、
-- F a -> G b と F b -> G c の composition
-- F は Identity の場合 G は Monad、I a -> M b と I b -> M c の composition は monad comosition 
main = (print $ runDiKleisli ( DiKleisli foo >>> DiKleisli bar ) (Just 2)) >>
       (print $ runDiKleisli ( DiKleisli foo' >>> DiKleisli bar' ) [3, 4, 5]) >>
       (print $ runDiKleisli ( DiKleisli foo'' >>> DiKleisli bar'' ) (Identity 6))
  where foo :: Maybe Int -> [String]
        foo Nothing = []
        foo (Just a) = [ show (a+1), show (a*2) ]

        bar :: Maybe String -> [Int]
        bar Nothing = []
        bar (Just a) = [ read a ]

        foo' :: [Int] -> [String]
        foo' = fmap (\x -> show (x+1))

        bar' :: [String] -> [Int]
        bar' = fmap (read)

        foo'' :: Identity Int -> [String]
        foo'' (Identity a) = [ show (a+1), show (a*2) ]

        bar'' :: Identity String -> [Int]
        bar'' (Identity a) = [ read a ]

Template Haskellで遊ぶ

Haskell

Ross Patersonの論文に面白いデータ構造「homogeneous functions」があって：

type Pair a = (a, a)
data BalTree a = Zero a | Succ (BalTree (Pair a)) deriving (Show)

-- the homogeneous functions
data Hom a b = ( a -> b ) :&: Hom (Pair a) (Pair b)

instance Cat.Category (Hom) where
  id = Cat.id
  (g :&: gs) . (f :&: fs) = (g . f) :&: ((Cat..) gs fs)

instance Arrow Hom where
  arr f = f :&: arr (f *** f)
  first (f :&: fs) = (f *** id) :&: (arr transpose >>> first fs >>> arr transpose)
    where transpose ((a, b), (c, d)) = ((a, c), (b, d))

apply :: Hom a b -> BalTree a -> BalTree b
apply (f :&: fs) (Zero x) = Zero (f x)
apply (f :&: fs) (Succ t) = Succ (apply fs t)

BalTreeは平衡二分木。しかしここの例では直接BalTreeいじるんではなく、Hom、つまりアルゴリズム自体を作成してからBalTreeに適用するって感じ：

butterfly :: (Pair b -> Pair b) -> Hom b b
butterfly f = id :&: proc(o, e) -> do
                           o' <- butterfly f -< o
                           e' <- butterfly f -< e
                           returnA -< f (o', e')

rev :: Hom a a
rev = butterfly swap

bisort :: Ord a => Hom a a
bisort = butterfly cmp 
  where cmp (x, y) = (min x y, max x y)

main = do print $ apply rev (Succ (Succ (Zero ((1,2),(3,4)))))
          print $ apply bisort (Succ (Succ (Zero ((1,4),(3,2)))))

いや〜高階関数を自在に操る人って凄いよね〜憧れるよね〜
しかしBalTree自身は使いにくいだけど…なぜかというとBalTreeはData.Treeのような再帰構造ではない、BalTree中身のを参照したい時に唯一な方法はパターンマッチ、例えばリストに変換したい場合：

toList :: BalTree a -> [a]
toList (Zero a0) = [a0]
toList (Succ (Zero (a0, a1))) = [a0, a1]
toList (Succ (Succ (Zero ((a0, a1), (a2, a3))))) = [a0, a1, a2, a3]
...

逆も同じ、ガードで全てのパターンを手で書くしかない：

toBTree :: [a] -> BalTree a
toBTree as = case length as of x | x == 2^0 -> Zero (as!!0)
                                 | x == 2^1 -> Succ (Zero (as!!0, as!!1)) 
...

「全パターン手で書くなんてありえねぇ！」のあなたにTemplate Haskellというc++ templateやboost.preprocessorみたいなメタプログラミングのフレームワークがある。これを使ってリストとBalTreeの変換関数を試して書いた：

---------------------------
-- Main.hs
---------------------------

import BalanceTree

bTree2List' = $(bTree2List 5) -- 2^0 2^1 ... 2^5までのパターンを列挙する
list2bTree' = $(list2bTree 5)

main = print $ list2bTree' [2,1,6,3,8,5,4,7] >>= mapply bisort >>= bTree2List'
  where mapply f d = return (apply f d)

---------------------------
-- BalanceTree.hs
---------------------------

{-# LANGUAGE TemplateHaskell #-}

module BalanceTree ( 
  Pair(..),
  BalTree(Zero, Succ),
  bTree2List,
  list2bTree
) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

type Pair a = (a, a)
data BalTree a = Zero a | Succ (BalTree (Pair a)) deriving (Show)

-- $(bTree2List Int) -> ExpQ : BalTree a -> Maybe [a]
bTree2List :: Integer -> ExpQ
bTree2List n = [| \tree -> $(caseE [| tree |] alts) |]
  where alts = map (\x -> match (pat x) (normalB $ rhs x) [] ) [0..n] ++ [match wildP (normalB $ conE $ mkName "Nothing") []]
        pat n' = btreecon n' n'
        btreecon gn n' | n' == 0 = conP (mkName "Zero") [ let list = buildPairN (map varP (names gn)) gn in if gn == 0 then head list else tupP list ]
                       | otherwise = conP (mkName "Succ") [ btreecon gn (n'-1) ]
        buildPairN as n' | n' == 0 =  as
                         | otherwise = buildPairN (buildPair as) (n'-1)
        buildPair [] = []
        buildPair (a:b:as) = tupP [a,b] : buildPair as
        rhs n' = appE (conE $ mkName "Just") (listE $ map varE $ names n')
        names n' = [ mkName ("a" ++ show i) | i <- [0 .. 2^n'-1] ]

-- $(list2bTree Int) -> ExpQ : [a] -> Maybe (BalTree a)
list2bTree :: Integer -> ExpQ
list2bTree n = [| \list -> $(caseE (appE (varE $ mkName "length") [| list |]) [alt [| list |]]) |]
  where alt list = match (varP $ mkName "x") 
                         (guardedB $ guardExpr list ++ [normalGE (varE $ mkName "otherwise") (conE $ mkName "Nothing")])
                         []
        guardExpr list = map ( \x -> normalGE (infixE (Just $ varE $ mkName "x") (varE $ mkName "==") (Just $ litE $ IntegerL (2^x)))
                                     (appE (conE $ mkName "Just") (btreecon list x x))
                             ) [0..n]
        btreecon list gn n' | n' == 0 = appE (conE $ mkName "Zero") (let list' = buildPairN (vary list gn) gn in if gn == 0 then head list' else tupE list')
                            | otherwise = appE (conE $ mkName "Succ") (btreecon list gn (n'-1))
        buildPairN as n' | n' == 0 =  as
                         | otherwise = buildPairN (buildPair as) (n'-1)
        buildPair [] = []
        buildPair (a:b:as) = tupE [a,b] : buildPair as  
        vary list n' = [ infixE (Just list) (varE $ mkName "!!") (Just $ litE $ IntegerL i) | i <- [0 .. 2^n'-1] ]

メタプログラミング共通の問題点なんだけど、まずは読めない、と、その前に読みたくない。まぁこの辺本来ならコンパイラの仕事だからしょうがないかもしれないね。

Arrowの話をしよう　(2)不動点と再帰

学習/備忘 Haskell/Category theory

   今回圏論の話は出ません。

   関数型言語勉強の中に、不動点コンビネータは避けては通れない道ですね。不動点とかなんとなく難しい印象がありますが、意外に簡単です。以下は定義(Wikipediaから)：

関数　f　の不動点とは、関数　f(x) = x　を満たすような　x　のことという。
不動点コンビネータ　fix　とは、下記のように関数　f　の不動点を返すような高階関数　fix　のこと。

fix(f) = f(fix(f))

   不動点は中学の連立方程式の知識さえあれば誰でも計算できるんだろう：

f(x) = x
f(x) = 42 => x = 42

f(x) = x
f(x) = x^2 => x^2 - x = 0 => x(x - 1) = 0 => x = 0 or x = 1

   そして不動点コンビネータはこの不動点を計算してくれる関数のこと。全然難しくないでしょう？
   Haskellでは遅延評価のおかげで不動点コンビネータの定義式通りに書けます：

fix f = f (fix f)

   遅延評価のない厳格言語だったらこの関数を実行すると括弧中の式をまず評価され、無限展開になってしまう。遅延評価凄いですね〜
   そして予想通り、　fix f　 は　f　 の不動点を返してくれます：

fix (\x -> 5)                            -- = 5
fix (\x -> 3.142*2)                      -- = 6.284
abs' (-1) where abs' = fix (\x -> abs)   -- = 1

   では、

fix (\x -> x*x)

   は何を返してくれるかな〜？ 勿論　(0, 1)　や　[0, 1]　などではありません（本当にそうだったらそれはそれで凄いですけど）。先の例で、　f　はパラメータと関係ない固定値を返す定数関数だから、　f (fix f)　の　(...)　部分を展開しなくても済みましたが（それも遅延評価のお陰）、今の例では　f (...)　だけ見ると、なにを返すのが分からないから、仕方なく　(...)　の部分も展開するしかない。しかし　(...)　は(fix f = f (fix f))であることがわかったと、今度は更に中の括弧を展開しなければならない、ということで、無限ループになってしまう。じゃ意味ないじゃない？いいえ、実はこの中にある可能性を秘めっています――もし　f　は更に関数を返し、この関数が　f　のパラメータを含めた場合はどうなるかな？

fix (\x ->\n -> x + n ) -- 関数　\n -> x + n　を返す。

   こうすると、　x　は　f　から独立してしまい、言い換えば　x　の意味を関数定義する時点で解釈しなければならなくなってしまう。この場合だと、コンパイラが取れるのは　x　を関数として解釈するか素直に展開してループを気付くかの二択、まぁどっちでもエラーになるんでしょう。さて、この　x　は何かを忘れた人のために、　x　は　fix f　です。つまり上記の例に返してくれた関数は：

\n -> x + n 
= \n -> fix f + n 
= \n -> fix (\x ->\n -> x + n ) + n 
= \n -> (\n' -> x + n') + n

   同じ構造をまた現れました。気付いたと思いますが、そう、この特性を利用して、無名関数の再帰を実現できます。

-- 階乗の例
fix (\f -> \n -> if n > 1 then n * f (n-1) else 1)

-- 展開すると
\n -> if n > 1 
      then n * ((\n' -> if n' > 1 then n' * f (n'-1) else 1) (n-1))
      else 1

   面白いでしょう？ちなみに遅延評価のない厳格言語で不動点コンビネータの定義は、さきお話したテクニックで：

def fix( f ):
    return lambda x: f((fix(f)))(x)

   のようにクロージャを返すのが一般的です。余談ですが、不動点コンビネータといえばかの有名な「Yコンビネータ」がありますが、あれは実用的なものではありません。不動点コンビネータ　fix　の定義の中に、自分名前を使って再帰してますが、Yコンビネータは名前再帰使わずに不動点コンビネータを実装したとのことです。
   さて、ここから本題に入りましょう、つまり、Arrowの再帰です。すべてのArrowが再帰できるわけでありません。再帰できるのはArrowLoopクラスのインスタンスを定義したArrowだけです。

class Arrow a => ArrowLoop a where
  loop :: a (b, d) (c, d) -> a b c

   またタプルか…しょうがない、そのうち慣れると信じましょう〜さて、幸い一番簡単なArrow(->)はArrowLoopのインスタンスなので、定義を見てみよう：

instance ArrowLoop (->) where
  loop f = let ~(c, d) = f (b, d) in c

   また珍妙なやつが出てきやがって…そもそも　let　文中の　d　はなんだ？入力のどこにもねぇぞ…
   実はHaskellの　let　文中に、バインド先の変数は後方へ循環参照することができます。先紹介した関数　fix　、Data.Functionはこう定義した：

fix f = let x = f x in x

   これ展開すると私たち定義の　fix　と同じになります：

fix f = f (f (f ...)

   つまり：

let x = f x in x = fix f
                 = fix (\x -> f x)
                 = let y = fix (\x -> f x) in y

   のように循環参照を剥げます。では、loop　も同じやり方でやって見ましょう：

loop f = let ~(c, d) = f (b, d) in c
       = let (c, _) = fix (\ ~(_, d) -> f (b, d)) in c
       = fst $ fix (\ ~x -> f (b, snd x))
       = fst $ f (b, snd (fix (\ ~x -> f (b, snd x)))
       = fst $ f (b, snd $ f (b, snd ...) )

   なるほど、loop　が　f　の出力タプルの二番目要素を入力タプルの二番目に繋げってるということですね。イメージとしては下図のように：

   つまり、入力と出力の二番目要素は　loop　内部再帰の橋渡しをしっており、ループの停止条件は出力の二番目要素に入力の二番目要素を含まれない時になります。以下は階乗の例のArrow版：

loop (\(n, f) -> (f n, \n -> if n > 1 then n * f (n-1) else 1))

   最初の例と比べるとちょっと面白い事が見えてます。最初の例(fix版)に再帰ごとに変わるのが　n　に対して、Arrow版では変わるのが　f　です。
   さて、このまま生　loop　を使ってもいいが、もっと一般的な使い方があります。再帰　let　と　fix、mdo/do rec　と　mfix　の関係のように、loop　を書く為の構文も存在しています。階乗の例はこうにも書けます：

proc n -> do rec v <- returnA -< f n
                 f <- returnA -< (\n -> if n > 1 then n * f (n-1) else 1)
             returnA -< v

   この記法で書くとfが内部変数ってことをすぐわかり、主観的ですが慣れると結構書きやすいと思います。因みに　rec　ブロック展開するとこんな感じです：

proc n -> do v <- loop (\(n, f) -> (f n, \n -> if n > 1 then n * f (n-1) else 1)) -< n
             returnA -< v

   この簡単な例だと別にどっちでもいいが、loop　の内部少しでも複雑すると眼に見える差が出て来ます。次の例はRoss Patersonの論文『A New Notation for Arrows』中のsynchronous circuits:
   次のリセットつきカウンターの実装について考えてみよう：

   Arrowでの実装は非常にストレートで：

class ArrowLoop a => ArrowCircuit a where
  delay :: b -> a b b
  
counter :: ArrowCircuit a => a Bool Int
counter = proc reset -> do
            rec output <- returnA -< if reset then 0 else next
                next <- delay 0 -< output + 1
            returnA -< output

   まず　delay　をメンバー関数としてArrowCircuitクラスを定義し、あとは回路図のまんまです。
   ここもし　rec　ブロックを使わずに生　loop　を使うとこうなります：
   中間変数が増えるほど面倒さも増えるのがわかります。

counter = proc reset -> do 
            output <- loop (proc (reset, (next, output)) -> do
                                                     output <- returnA -< if reset then 0 else next
                                                     next <- delay 0 -< output + 1
                                                     returnA -< (output, (next, output)) ) -< reset
            returnA -< output

   ついでにcounter example完全なコードもここに貼ります：

{-# LANGUAGE Arrows #-}

module Main where

import Prelude
import Control.Arrow
import qualified Control.Category as Cat

class ArrowLoop a => ArrowCircuit a where
  delay :: b -> a b b

counter = proc reset -> do
            rec output <- returnA -< if reset then 0 else next
                next <- delay 0 -< output + 1
            returnA -< output

type Seq a = [a]

newtype SeqMap b c = SM { runSM :: Seq b -> Seq c }

instance Cat.Category SeqMap where
  id = Cat.id
  SM g . SM f = SM ((Cat..) g f)

mapSeq = map
zipSeq (a, b) = zip a b
unzipSeq = unzip

instance Arrow SeqMap where
  arr f = SM (mapSeq f)
  first (SM f) = SM ( zipSeq . first f . unzipSeq  )

instance ArrowLoop SeqMap where
  loop (SM f) = SM (\as -> 
            let (bs, cs) = unzipSeq . f . zipSeq $ (as, (stream cs)) in bs)
    where stream ~(x:xs) = x:stream xs
-- this example code in the thesis will cause infinite loop
-- loop (SM f) = SM (loop (unzipSeq . f . zipSeq))

instance ArrowCircuit SeqMap where
  delay x = SM ((:) x)

main = print $ runSM counter (map b "ffffffffttfftt")
  where b 't' = True
        b 'f' = False

   今回はここまで。つづく？

Arrowの話をしよう　(1)ArrowとArrow記法

学習/備忘 Haskell/Category theory

Q: そんなタイトルで大丈夫か？
A: 大丈夫だ、問題ない。

Q: Arrowってなに？
A: あれは今から36万…いや、1万4千年前だったか…まぁいい、私にとってはつい昨日の出来事だが、君たちにとっては多分明日の出来事だ。彼には72通りの名前があるから、なんて呼べばいいのか…確か最初に会ったときは、Morphism…


...


こめんなさい…今のは真っ赤な嘘です…

    http://www.haskell.org/arrows/
    から引用：

Arrows are a new abstract view of computation, defined by John Hughes [Hug00]. They serve much the same purpose as monads -- providing a common structure for libraries -- but are more general.

    その通り、実際Arrowとモナドの関係が近いと示す例は簡単に挙げられます：
    add関数のモナド版：

addM :: Monad m => m Int -> m Int -> m Int
addM a b = do a' <- a
              b' <- b
              return (a' + b')

--output: Just 42
main = print $ addM (Just 10) (Just 32)

    add関数のArrow版、GHCの拡張Arrow記法使用：

{-# LANGUAGE Arrows #-}

addA :: Arrow a => a b Int -> a b Int -> a b Int
addA a b = proc v -> do a' <- a -< v
                        b' <- b -< v
                        returnA -< (a' + b')

--output the same: Just 42
main = print $ runKleisli (addA (Kleisli (\_->Just 10)) (Kleisli (\_->Just 32))) "dummy"

    さらに面白いのは：

main = -- 「ArrowMonad (Kleisli (\_->Just 10)」はモナド 
       return (addM (ArrowMonad (Kleisli (\_->Just 10))) (ArrowMonad (Kleisli (\_->Just 32)))) >>  
       -- 「Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 10))))」 はArrow 
       return (addA (Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 10))))) (Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 32)))))) >>
       -- 「ArrowMonad (Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 10)))))」はモナド 
       return (addM (ArrowMonad (Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 10)))))) (ArrowMonad (Kleisli (\_->(ArrowMonad (Kleisli (\_->Just 32))))))) >>
       --  無限ループって怖くね？
       return ()

    この関係が圏論の言葉で「随伴(adjunction)」と言います。すべてのArrowとモナドはこの関係を満たすわけではないので、上のはちょっと特殊な一例です。話しが少し脱線したので、最初に戻りましょう――じゃArrowってなに？答える前に、まずArrowの定義を見ましょう：

class Category a => Arrow a where
        -- | Lift a function to an arrow.
        arr :: (b -> c) -> a b c

        first :: a b c -> a (b,d) (c,d)

        second :: a b c -> a (d,b) (d,c)
        second f = arr swap >>> first f >>> arr swap
                        where   swap :: (x,y) -> (y,x)
                                swap ~(x,y) = (y,x)

        (***) :: a b c -> a b' c' -> a (b,b') (c,c')
        f *** g = first f >>> second g

        (&&&) :: a b c -> a b c' -> a b (c,c')
        f &&& g = arr (\b -> (b,b)) >>> f *** g

    最初に注目させたいのは「Category a => Arrow a」の部分、そう、ArrowはCategoryのサブクラス、その本質は圏です。って事は、Arrowまずは圏の法則(idとcomposition-association)を守なければなりません。

class Category cat where
        -- | the identity morphism
        id :: cat a a
        -- | morphism composition
        (.) :: cat b c -> cat a b -> cat a c

    これからは主に一番単純なArrow(->)で説明します。Arrow(->)のobjectは普通の関数で、一番理解しやすいのではないかと思ってますから。

instance Category (->) where
        id = Prelude.id
        (.) = (Prelude..)

-- 下記圏の法則を満たす：
-- id . f = f = f . id
-- (f . g) . h = f . (g . h)

    モナド則がモナドにとっては大事なことのように、圏の法則は(->)に限らず、全てのArrowにとって非常に重要なので、ぜひ覚えてください。
    次はArrowのメンバー関数を見ましょう：arrとfirst以外にデフォルトの実装があり、Arrowを定義するに最小限の実装はarrとfirstの実装となります。まずはarr:

arr :: (b -> c) -> a b c

    arrは普通関数をArrowのobjectに変換するメソードです。「a b c」のような形式はArrowのobjectの一般形式です。例えばArrow(->)のArrow形式は「(->) b c」と頭の中に変換するといい。注意してほしいのは「『a b c』は『b->c』の糖衣構文」のような思考方式に囚われないでください。(->)は非常に特殊なArrowなのでそう見えなくもないが、違います。確かにArrowのobjectは関数だが、必ずにも変換前の関数と一致するわけではありません（てか一致するケースが(->)だけ）。例えばArrow(Kleisli m)のobjectは「b->c」ではなく「b->m c」です：

newtype Kleisli m b c = Kleisli { runKleisli :: b -> m c }

    arrの話しに戻ります。arrは普通関数をArrowのobjectに変換、或いはマッピングするってことは、arrは(圏論の意味で)functorです。なのでfunctorの法則を満たさなければならない：

arr Prelude.id = Category.id
arr (f . g) = arr f . arr g

    これも圏の法則と同じ重要なのでぜひ覚えてください。因みに、Arrow(->)のarrは普通関数を自分自身へマッピングするfunctor: 「I -> I」です。ここまで来たら、「Arrowってなに?」の答えは自然に出てきたんでしょう：

モナドが   f:\hspace{10}a\to Fb   のような関数を結合するための計算構造とするなら、
Arrowは   f:\hspace{10}Fa\to Gb   のような関数を結合するための計算構造である。

    これまでの説明で圏論的なArrowはもう完成されたが、実際使うにはいくつの足りないところがあります。例えば:

foo :: Arrow a => a b c -> a c d -> a b d
foo f g = f >>> g

    のような形の関数だとfとgをは簡単に結合できるが(因みに「>>>」は「.」の逆順です。f >>> g = g . f)、冒頭のaddAのような形の関数はどうすればいいんだろう？出来ればモナドのbind演算子「>>=」みたいのがほしいな〜っと皆そう考えてるっしょ。もう最初からネタバレしたと思うが、答えは：出来ます。firstとその仲間はまさにその為の存在です。まず「>>=」の型定義を思い出しましょう：

(>>=) :: Monad m => m a -> (a -> m b) -> m b

    もしArrowがbind関数があれば、パッと考えられるのは：

bind :: Arrow a => a b c -> ( (c -> d) -> a b d ) -> a b d

    くらいだろう…まぁさておき、まずfirstとやらを見てみましょう：

first :: a b c -> a (b,d) (c,d)
second :: a b c -> a (d,b) (d,c)

(***) :: a b c -> a b' c' -> a (b,b') (c,c')
(&&&) :: a b c -> a b c' -> a b (c,c')

first: 入力と出力はtupleの新しいArrowを返す。この新しいArrowの(fst 入力)と(fst 出力)は元のArrowと一緒、(snd 出力)は(id (snd 入力))である。
second: firstのミラーイメージ。
(***): 二つArrowを一つに統合する。
(&&&): 二つArrowの入力を一つにする。

    使い道はともかく、tupleばかりなんで、上のbindの定義もtupleに合わせた方がいいでしょう…まぁ実際もそうだけどね。bindの定義：

bind :: Arrow a => a b c -> a (b,c) d -> a b d
u `bind` f = arr id &&& u >>> f

    この関数さえあれば、だれもaddAなんか簡単に書けるのではないでしょうか：

addA a b = (arr (\v -> v) >>> a) `bind`
           ( 
             (arr (\(v, a') -> v) >>> b) `bind` 
              arr (\((v, a'), b') -> (a' + b'))
　　　　　 )

    っておい、全然簡単じゃねぇし。
    その通り、全然面倒くさいです。だから頭のいい人たちがArrowの専用記法を作りました：

proc p -> e1 -< e2 = arr (\p -> e2) >>> e1                   -- 1
proc p -> e1 -<< e2 = arr (\p -> (e1, e2)) >>> app           -- 2
proc p -> c1 `op` c2 = (proc p -> c1) `op` (proc p -> c2)    -- 3
proc p -> \p' -> c = proc (p, p') -> c                       -- 4

    ついでにモナドのreturnをシミュレーションするためにreturnAも定義しました：

returnA :: Arrow a => a b b
returnA = arr id

    というわけで、私たちのaddAもこれらの記法で直します：

addA a b = (arr (\v -> v) >>> a) `bind`
           ( 
             (arr (\(v, a') -> v) >>> b) `bind` 
              arr (\((v, a'), b') -> (a' + b'))
　　　　　 )

--------↓↓↓↓↓↓↓↓-----------

--ルール1
addA a b = ( proc v -> a -< v ) `bind`
           (
             (proc (v, a') -> b -< v ) `bind`
              proc ((v, a'), b') -> returnA -< (a' + b')
           )

--------↓↓↓↓↓↓↓↓-----------

--ルール4
--コンパイル通らない
addA a b = ( proc v -> a -< v ) `bind` 
           (
             (proc (v, a') -> b -< v ) `bind` 
              proc (v, a') -> \b' -> returnA -< (a' + b')
           )  

--------↓↓↓↓↓↓↓↓-----------

--ルール3
addA a b = ( proc v -> a -< v ) `bind` 
           ( proc (v, a') -> (b -< v) `bind` 
                             \b' -> returnA -< (a' + b') )

--------↓↓↓↓↓↓↓↓-----------

--ルール4
--コンパイル通らない
addA a b = ( proc v -> a -< v ) `bind` 
           ( proc v -> \a' -> (b -< v) `bind` 
                              \b' -> returnA -< (a' + b') )

--------↓↓↓↓↓↓↓↓-----------

--ルール3
--最終形態ではない、私はまだ1回の変身を残しています
addA a b = proc v -> (a -< v) `bind` \a' ->
                     (b -< v) `bind` \b' -> 
                     returnA -< (a' + b')

--------↓↓↓↓↓↓↓↓-----------

--Arrow do記法
addA a b = proc v -> do a' <- a -< v
                        b' <- b -< v
                        returnA -< (a' + b')

    というわけですね。おわかりいただけただろうか？
(つづく？)

参考資料：

  1. [Hug00] John Hughes, Generalising Monads to Arrows, in Science of Computer Programming 37, pp67-111, May 2000.
  2. [Pat01] Ross Paterson, A New Notation for Arrows, in ICFP 2001, Firenze, Italy, pp229-240
  3. http://www.haskell.org/ghc/docs/7.0.2/html/users_guide/arrow-notation.html

return2について

Haskell

mclh46さんの記事のreturn2についていろいろと考えました。そして「つまりreturn2は二択returnのことですね」と勝手に結論を付けました。ならば最近見ているControl.Arrowの中にもこういう選択的な機能をサポートする関数があります。

(|||) :: a b d -> a c d -> a (Either b c) d

これを使って何かできないかな？と思い、とりあえず適当に：

return2 :: Bool -> a -> Maybe a
return2 x = (genSum x >>> id ||| id)
  where genSum t a | t == True = Left (Just a)
                   | otherwise = Right Nothing

うん、動きますが、Maybe限定の特殊ケースなのでよろしくない。例えばListを返したい場合はJust a → [a]とNothing → のようにいちいち修正しなければならない。ここでMaybeとの共通点について考えれば、そう、答えはMonadPlusクラスです。

--Monads that also support choice and failure. 
class Monad m => MonadPlus m where
  ...

つまり、こうすればOKですね：

return2 :: (MonadPlus m) => Bool -> a -> m a
return2 x = (genSum x >>> id ||| id)
  where genSum t a | t == True = Left (return a)
                   | otherwise = Right mzero

テスト：

import Control.Arrow
import Control.Monad

stockA = 3
stockB = 0
priceA = 100
priceB = 200

--一番効率な実装はこれです、ながとさんありがとう
--return2 :: (MonadPlus m) => Bool -> a -> m a
--return2 True v = return v
--return2 _    _ = mzero

return2 :: (MonadPlus m) => Bool -> a -> m a
return2 x = (genSum x >>> id ||| id)
  where genSum t a | t == True = Left (return a)
                   | otherwise = Right mzero

main :: IO()
main = print (getA::Maybe Integer) >> print (getB::Maybe Integer) >>
       print (getA'::[Integer])    >> print (getB'::[Integer])
  where getA = return2 (stockA > 0) priceA
        getB = return2 (stockB > 0) priceB
        getA' = return2 (stockA > 0) priceA
        getB' = return2 (stockB > 0) priceB

Output:

Just 100
Nothing
[100]
[]

FizzBuzzをArrowで

Haskell

元ネタ：

とにかく書いてみた。もう何番煎じ？

import Control.Arrow  

fizzbuzz = mapM_ (putStrLn . ((fizz &&& buzz >>> chain) &&& nofb >>> chain))
              where fizz x | x `mod` 3 == 0 = "Fizz"
                           | otherwise      = ""
                    buzz x | x `mod` 5 == 0 = "Buzz"
                           | otherwise      = ""
                    nofb x | x `mod` 3 == 0 = ""
                           | x `mod` 5 == 0 = ""
                           | otherwise      = show x
                    chain                   = uncurry(++)

モナドも、コモナドも、あるんだよ（後篇）

学習/備忘 Haskell/Category theory

前篇のつづき、コモナドを話す前にまずDualityについて復習しよう：

圏論にて、ある物の双対(Dual)を次のように定義する：

dual\hspace{5}A A
dual\hspace{5}x x
dual(f:\hspace{10}A\to B) dual\hspace{5}f:\hspace{10}B\to A
dual(f\hspace{5};\hspace{5}g) dual\hspace{5}g\hspace{5};\hspace{5}dual\hspace{5}f
dual(id{\tiny A}) id{\tiny A}

この定義はつまり確定的に明らかであること：矢印をひっくり返すだけ簡単な仕事です。

ある構造xxxに対して、中の要素をすべてdualをかけ、得た新し構造を圏論の言葉で言うとco-xxxである。

例：
ニート　<=>　コ会社員
全裸待機　<=>　コ正装出撃
非リア　<=>　コリア充
など

???「これから毎日「コ」を付けろうぜ？」
(◕‿‿◕)「…わけがわからないよ」

まぁということで、モナドの定義をすべて対を取ればコモナドになるわけだ。

co-Kleisli category、\cal{K}^{op}は下記要素で構成される：

\cal{K}^{op}のobject a a
\cal{K}^{op}のmorphism g:\hspace{10}a\to{\tiny \cal{K}^{op}}b g:Ga\to b
f\hspace{5};{\tiny \cal{K}^{op}}\hspace{5}g \mu^{op}\hspace{5};\hspace{5}Gf\hspace{5};\hspace{5}g
id\tiny K^{op},Ga \eta^{op}\tiny Ga

\mu^{op} と \eta^{op} は：

\mu^{op}:\hspace{10}G\to GG
\eta^{op}:\hspace{10}G\to I

下記法則を従う：

\mu^{op}\hspace{5};\hspace{5}G\mu^{op}\hspace{10}=\hspace{10}\mu^{op}\hspace{5};\hspace{5}\mu^{op}G
\mu^{op}\hspace{5};\hspace{5}G\eta^{op}\hspace{10}=\hspace{10}\mu^{op}\hspace{5};\hspace{5}\eta^{op}G\hspace{10}=\hspace{10}idG

コモナド(comonad)とはtriple(G,\hspace{5}\mu^{op},\hspace{5}\eta^{op})のこと。

GHCのコモナドはhackageDBから配布されてる。定義を見てみよう：

class Functor w => Extend w where
  duplicate :: w a -> w (w a)

class Extend w => Comonad w where
  extract :: w a -> a

(=>=) :: Extend w => (w a -> b) -> (w b -> c) -> w a -> c

つまり：

duplicate <=> \mu^{op}
extract <=> \eta^{op}
(=>=) <=> ;{\tiny \cal{K}^{op}}

Haskellのコモナドは下記の法則を従わなければならない：

-- 1

f =>= extract   = f
extract =>= f   = f
(f =>= g) =>= h = f =>= (g =>= h)

-- あるいは

-- 2

extract . duplicate      = id
fmap extract . duplicate = id
duplicate . duplicate    = fmap duplicate . duplicate

1と2は同じなのは前篇で証明出来たので、略する。

以上、モナドとコモナドの全部でした。
結論：コモナド地味すぎ。