Reactive Bananaで学ぶリアクティブ・プログラミング（４）

６．時間

Reactive Bananaでは時間は連続的であるが、ここで説明しているモデルでは、時間は離散的である。

モデルでは、時間は0で始まる自然数を用いて、次の様に定めている。

-- | Natural numbers (poorly represented).
type Nat = Int

-- | The FRP model used in this library is actually a model with continuous time.
--
-- However, it can be shown that this model is observationally
-- equivalent to a particular model with (seemingly) discrete time steps,
-- which is implemented here.
-- The main reason for doing this is to be able to handle recursion correctly.
-- Details will be explained elsewhere.
type Time = Nat -- begins at t = 0

春の小川の曲を弾くためのイベントplayは、前回の記事で次のように表した。

Prelude> :load "Music.hs"
[1 of 2] Compiling Model            ( Model.hs, interpreted )
[2 of 2] Compiling Main             ( Music.hs, interpreted )
Ok, modules loaded: Model, Main.
*Main> play
E {unE = [Just So,Nothing,Just Mi,Just Fa,Just So,Nothing,Just La,Nothing,Just So,Nothing,Just Mi,Just Fa,Just So,Nothing,Just Do5,Nothing,Just La,Nothing,Just So,Nothing,Just Mi,Nothing,Nothing,Just Do,Just Re,Nothing,Nothing,Nothing,Nothing,Nothing,Just Rest,Nothing,Just So,Nothing,Just La,Just So,Just Mi,Nothing,Just So,Nothing,Just Do5,Nothing,Just Re5,Just Do5,Just La,Nothing,Just Do5,Nothing,Just So,Nothing,Just Mi5,Nothing,Just Re5,Nothing,Nothing,Just So,Just Do5,Nothing,Nothing,Nothing,Nothing,Nothing,Just Rest,Nothing]}

これは、時間0ではソを打鍵し、時間1では何もせず、時間2ではミを打鍵し、時間3ではファを打鍵し、時間4ではソを打鍵することを表している。

７．振舞い

イベントplayを実行することで、即ち、ピアノの鍵盤を打つことで、一つの曲が得られる。リアクティブ・プログラミングでは、時間とともに変わっていくこのような性質を振舞い（ビヘイビア）と呼んでいる。

振舞いは、無限に続くかもしれない値のリストとして、モデルでは次のように定義している。イベントと振舞いの違いは、イベントの方は値をMaybe型にしたリストであるのに対して、振舞いの方は値のリストである。これは、イベントはいつも起こるとは限らずある特定の時間に起こるのに対して、振舞いはどのような時間でも常に定まっていなければならないことによる。

-- | Behavior is modeled by an /infinite/ list of values.
-- It is isomorphic to @Time -> a@.
newtype Behavior a = B { unB :: [a] } deriving (Show)

ピアノで鍵盤をたたくと、曲となって音が流れる。ここで、一つの制約をすることにする。即ち、次の鍵盤が打鍵されるまで、直前に打鍵された音階が続くものとする。また、Restは休止音符を表しているが、これが来ると無音となることにする。

打鍵したときの音階が次の打鍵まで続くようにする関数は、stepperである。ここでは、モデルで与えられているstepperを少し改良して用いる。stepperは、ある時間での振舞いの値を教えてくれる。

stepper :: a -> Event a -> Moment (Behavior a)
stepper i e = M $ \time -> B $ replicate 1 $ step i  (unE e) !! time
    where
    step i ~(x:xs) = i : step next xs
        where next = case x of
                        Just i  -> i
                        Nothing -> i

stepperの関数において、iは初期値である。eはイベントである。

上記で、Momentというデータ型を使用しているが、これはある時間での値を教えてくれる。次のように定義されている。

newtype Moment a = M { unM :: Time -> a }

それでは、stepperを用いて、playが奏でる曲musicを次のように定義する。初期値は音の出ない鍵盤を打つこと,すなわち、Restとする。

music = stepper Rest play

時間は、８分音符が一単位となっているので、それぞれの時間でどのような音が奏でられているかを調べると次のようになる。

*Main> :load "Music.hs"
[1 of 2] Compiling Model            ( Model.hs, interpreted )
[2 of 2] Compiling Main             ( Music.hs, interpreted )
Ok, modules loaded: Model, Main.
*Main> unM music 0
B {unB = [Rest]}
*Main> 
*Main> unM music 1
B {unB = [So]}
*Main> unM music 2
B {unB = [So]}
*Main> unM music 3
B {unB = [Mi]}
*Main> unM music 4
B {unB = [Fa]}
*Main> unM music 5
B {unB = [So]}
*Main> unM music 6
B {unB = [So]}
*Main> unM music 7
B {unB = [La]}
*Main> unM music 8
B {unB = [La]}
*Main> unM music 9
B {unB = [So]}
*Main> unM music 10
B {unB = [So]}
*Main> unM music 11
B {unB = [Mi]}
*Main> unM music 12
B {unB = [Fa]}
*Main> unM music 13
B {unB = [So]}
*Main> unM music 14
B {unB = [So]}
*Main> unM music 15
B {unB = [Do5]}
*Main> unM music 16
B {unB = [Do5]}
*Main> unM music 17
B {unB = [La]}
*Main> unM music 18
B {unB = [La]}
*Main> unM music 19
B {unB = [So]}
*Main> unM music 20
B {unB = [So]}
*Main> unM music 21
B {unB = [Mi]}
*Main> unM music 22
B {unB = [Mi]}
*Main> unM music 23
B {unB = [Mi]}
*Main> unM music 24
B {unB = [Do]}
*Main> unM music 25
B {unB = [Re]}
*Main> unM music 26
B {unB = [Re]}
*Main> unM music 27
B {unB = [Re]}
*Main> unM music 29
B {unB = [Re]}
*Main> unM music 30
B {unB = [Re]}
*Main> unM music 31
B {unB = [Rest]}
*Main> unM music 32
B {unB = [Rest]}

時間１にはソ、時間１にもソ、時間１にはミ、時間１にはファが奏でられていることが分かる。

８．プログラム

プログラムを掲載すると次のようになる。

import Model

data Scale = Do | Re | Mi | Fa | So | La | Si | Do5 | Re5 | Mi5 | Fa5 | So5 | La5 | Si5 | Rest deriving (Show, Read, Eq, Ord)


score1 = [ Just So,  Nothing, Just Mi,  Just Fa,  Just So,  Nothing, Just La,   Nothing]  

score2 = [ Just So,  Nothing, Just Mi,  Just Fa,  Just So,  Nothing, Just Do5,  Nothing]  

score3 = [ Just La,  Nothing, Just So,  Nothing,  Just Mi,  Nothing, Nothing,   Just Do]  

score4 = [ Just Re,  Nothing, Nothing,  Nothing,  Nothing,  Nothing, Just Rest, Nothing]  

score5 = [ Just So,  Nothing, Just La,  Just So,  Just Mi,  Nothing, Just So,   Nothing]  

score6 = [ Just Do5, Nothing, Just Re5, Just Do5, Just La,  Nothing, Just Do5,  Nothing]  

score7 = [ Just So,  Nothing, Just Mi5, Nothing,  Just Re5, Nothing, Nothing,   Just So]  

score8 = [ Just Do5, Nothing, Nothing,  Nothing,  Nothing,  Nothing, Just Rest, Nothing]

play = E $ score1 ++ score2 ++ score3 ++ score4 ++ score5 ++ score6 ++ score7 ++ score8

music = stepper Rest play

また、モデルのプログラムは、元々のものに、stepperの関数が変えてあるが次のようになる。

{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
module Model (
    -- * Synopsis
    -- | Model implementation for learning and testing.

    -- * Overview
    -- $overview

    -- * Core Combinators
    -- ** Event and Behavior
    Nat, Time,
    Event(..), Behavior(..),
    interpret,
    -- ** First-order
    module Control.Applicative,
    never, unionWith, filterJust, apply,
    -- ** Moment and accumulation
    Moment(..), accumE, stepper,
    -- ** Higher-order
    valueB, observeE, switchE, switchB,
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix

{-$overview

This module reimplements the key FRP types and functions from the module
"Reactive.Banana.Combinators" in a way that is hopefully easier to understand.
Thereby, this model also specifies the semantics of the library.
Of course, the real implementation is much more efficient than this model here.

To understand the model in detail, look at the source code!
(If there is no link to the source code at every type signature,
then you have to run cabal with --hyperlink-source flag.)

This model is /authoritative/:
Event functions that have been constructed using the same combinators
/must/ give the same results when run with the @interpret@ function
from either the module "Reactive.Banana.Combinators"
or the module "Reactive.Banana.Model".
This must also hold for recursive and partial definitions
(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).

-}

{-----------------------------------------------------------------------------
    Event and Behavior
------------------------------------------------------------------------------}
-- | Natural numbers (poorly represented).
type Nat = Int

-- | The FRP model used in this library is actually a model with continuous time.
--
-- However, it can be shown that this model is observationally
-- equivalent to a particular model with (seemingly) discrete time steps,
-- which is implemented here.
-- The main reason for doing this is to be able to handle recursion correctly.
-- Details will be explained elsewhere.
type Time = Nat -- begins at t = 0

-- | Event is modeled by an /infinite/ list of 'Maybe' values.
-- It is isomorphic to @Time -> Maybe a@.
--
-- 'Nothing' indicates that no occurrence happens,
-- while 'Just' indicates that an occurrence happens.
newtype Event a = E { unE :: [Maybe a] } deriving (Show)

-- | Behavior is modeled by an /infinite/ list of values.
-- It is isomorphic to @Time -> a@.
newtype Behavior a = B { unB :: [a] } deriving (Show)

interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret f as =
    take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing)

{-----------------------------------------------------------------------------
    First-order
------------------------------------------------------------------------------}
instance Functor Event where
    fmap f (E xs) = E (fmap (fmap f) xs)

instance Functor Behavior where
    fmap f (B xs) = B (fmap f xs)

instance Applicative Behavior where
    pure x          = B $ repeat x
    (B f) <*> (B x) = B $ zipWith ($) f x

never :: Event a
never = E $ repeat Nothing

unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith f (E xs) (E ys) = E $ zipWith combine xs ys
    where
    combine (Just x) (Just y) = Just $ f x y
    combine (Just x) Nothing  = Just x
    combine Nothing  (Just y) = Just y
    combine Nothing  Nothing  = Nothing

filterJust :: Event (Maybe a) -> Event a
filterJust = E . fmap join . unE

apply :: Behavior (a -> b) -> Event a -> Event b
apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE

{-----------------------------------------------------------------------------
    Moment and accumulation
------------------------------------------------------------------------------}
newtype Moment a = M { unM :: Time -> a }

instance Functor     Moment where fmap f = M . fmap f . unM
instance Applicative Moment where
    pure   = M . const
    (<*>)  = ap
instance Monad Moment where
    return = pure
    (M m) >>= k = M $ \time -> unM (k $ m time) time

instance MonadFix Moment where
    mfix f = M $ mfix (unM . f)

-- Forget all event occurences before a particular time
forgetE :: Time -> Event a -> [Maybe a]
forgetE time (E xs) = drop time xs

{-
stepper :: a -> Event a -> Moment (Behavior a)
stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)
    where
    step i ~(x:xs) = i : step next xs
        where next = case x of
                        Just i  -> i
                        Nothing -> i
-}
stepper :: a -> Event a -> Moment (Behavior a)
stepper i e = M $ \time -> B $ replicate 1 $ step i  (unE e) !! time
    where
    step i ~(x:xs) = i : step next xs
        where next = case x of
                        Just i  -> i
                        Nothing -> i


-- Expressed using recursion and the other primitives
-- FIXME: Strictness!
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE a e1 = mdo
    let e2 = ((\a f -> f a) <$> b) `apply` e1
    b <- stepper a e2
    return e2

{-----------------------------------------------------------------------------
    Higher-order
------------------------------------------------------------------------------}
valueB :: Behavior a -> Moment a
valueB (B b) = M $ \time -> b !! time

observeE :: Event (Moment a) -> Event a
observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE

switchE :: Event (Event a) -> Moment (Event a)
switchE es = M $ \t -> E $
    replicate t Nothing ++ switch (unE never) (forgetE t (forgetDiagonalE es))
    where
    switch (x:xs) (Nothing : ys) = x : switch xs ys
    switch (x: _) (Just xs : ys) = x : switch (tail xs) ys

forgetDiagonalE :: Event (Event a) -> Event [Maybe a]
forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE

switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB b e = diagonalB <$> stepper b e

diagonalB :: Behavior (Behavior a) -> Behavior a
diagonalB = B . zipWith (\time xs -> xs !! time) [0..] . map unB . unB