１．スイッチ
スイッチはある一つの信号関数を他の信号関数で置き換えるものである。スイッチが生じるのは、スイッチング・イベントの発生元で、最初のイベントが発生したときである。スイッチの型シグネチャは次のようになっている。
switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
switchを図で示すと次のようになる。
最初の入力SF a (b, Event c)は、イベントの発生元となる初期の信号関数である。二番目はイベントの発生によってこれから利用される信号関数を発生する関数である。三番目は出力となる信号関数である。出力はイベントが生じないときはそのまま、イベントが生じたときは新しいものである。
Switchの型シグネチャは次のように読む。Switchは、最初の入力で信号関数sfを、二番目の入力で信号関数発生器sfg を得る。そして、sfは型(b, Event c)の値を生成する。信号関数発生器への入力は型cである。従って、sfでイベントが発生したときは、初期の信号関数は信号関数発生器が生成したものへとスイッチする。イベントが発生するまでは、信号関数は元のままである。
これを用いると飛び跳ねるボールは次のようになる。
bouncingBall :: Pos -> SF() (Pos,Vel) bouncingBall y0 = bbAux yo 0.0 where bbAux y0 v0 = switch (falligBall’ yo vo) $ \(y,v) -> bbAux y (-v)
２．インパルス関数
ボールが床に衝突したとき、速度の向きを変えることは、物理的な現象を正確に表しているとは言えない。Yampaではより正確に表すためにディラク・インパルスを用意している。これは次のようになっている。
impulseIntegral :: VectorSpace a k => SF (a, Event a) a
２．切り離し（デカップル）
dSwitchはイベントが生じたとき、新しい信号関数で置き換えるのではなく、古い信号関数から得られる。型シグネチャは次のようになっている。
dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
現時点での出力はその時点で生じたスイッチング・イベントに依存していたり、独立であったりする。
３．その他のスイッチ
その他いくつかのスイッチが用意されている。rSwitchの型シグネチャは次のようになっている。
rSwitch, drSwitch :: SF a b -> SF (a, Event (SF a b)) b
rSwitchは次の図で示される。
rSwitchは外来的なスイッチと称せられる。信号関数は入力・出力を分析することなしにスイッチする。
これは、型aを入力とし、型bを出力とする一つの信号関数を受け取る。rSwitchは出力bを生み出す新たな信号関数を生成するが、その入力はこれまでのaに加えて、イベントEvent (SF a b))である。ここで、イベントの値が取る型は入力の型と一致する。即ち、イベントが発生した時はいつでも、信号関数はイベントの値にスイッチする。しかし、SFの型はSF (a, Event (SF a b))である。
次にrSwitchを用いたプログラムを示す。ここでの例は、分時計である。この時計には通常の時計と同じように0から11までの文字があり、針が5秒刻みでこの文字の上を回り一分間で一周するものとする。プログラムでは、文字の上に針が来た時の位置を信号関数dialで表す。即ち、0の文字のところはdial0、1の文字のところはdial1、同じように、11の文字のところはdial1を用意している。このように用意した信号関数に、5秒ごとにイベント発生し、針が次の文字盤に移ることとする。プログラムは次のようになる。
{-# LANGUAGE Arrows #-} import FRP.Yampa import Control.Concurrent import FRP.Yampa.Vector3 import FRP.Yampa.Utilities import Unsafe.Coerce import Data.IORef import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize) import qualified Graphics.UI.GLUT as G(Vector3(..)) type Pos = (Double, Double) type R = GLdouble cycler :: Time -> [SF a b] -> SF a b cycler int sfs = proc inp -> do event <- afterEach $ zip (repeat int) sfs -< () rSwitch (head sfs) -< (inp, event) dial :: Pos -> SF () Pos dial pos = proc inp -> do returnA -< pos dial0 = dial (0, 10) dial1 = dial (5, 8.66) dial2 = dial (8.66, 5) dial3 = dial (10, 0) dial4 = dial (8.66, (-5)) dial5 = dial (5, (-8.66)) dial6 = dial (0, (-10)) dial7 = dial ((-5), (-8.66)) dial8 = dial ((-8.66), (-5)) dial9 = dial ((-10), 0) dial10 = dial ((-8.66), 5) dial11 = dial ((-5), 8.66) clock = cycler 5 $ cycle [dial0, dial1, dial2, dial3, dial4, dial5, dial6, dial7, dial8, dial9, dial10, dial11] initGL :: IO () initGL = do getArgsAndInitialize createWindow "Shooting Game" initialDisplayMode $= [ WithDepthBuffer, DoubleBuffered ] depthFunc $= Just Less clearColor $= Color4 0 0 0 0 light (Light 0) $= Enabled lighting $= Enabled lightModelAmbient $= Color4 0.5 0.5 0.5 1 diffuse (Light 0) $= Color4 1 1 1 1 blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) reshapeCallback $= Just resizeScene return () resizeScene :: Size -> IO () resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero resizeScene s@(Size width height) = do -- putStrLn "resizeScene" viewport $= (Position 0 0, s) matrixMode $= Projection loadIdentity perspective 45 (w2/h2) 1 1000 matrixMode $= Modelview 0 where w2 = half width h2 = half height half z = realToFrac z / 2 clearAndRender :: Pos -> IO () clearAndRender pos = do clear [ ColorBuffer, DepthBuffer ] loadIdentity renderPlayer $ vector3 (unsafeCoerce (fst pos)) (unsafeCoerce (snd pos)) (-30) flush where size2 :: R size2 = (fromInteger $ 6)/2 green = Color4 0.8 1.0 0.7 0.9 :: Color4 R greenG = Color4 0.8 1.0 0.7 1.0 :: Color4 R red = Color4 1.0 0.7 0.8 1.0 :: Color4 R renderShapeAt s p = preservingMatrix $ do translate $ G.Vector3 (0.5 - size2 + vector3X p) (0.5 - size2 + vector3Y p) (0.5 - size2 + vector3Z p) renderObject Solid s renderObstacle = (color green >>) . (renderShapeAt $ Cube 1) renderPlayer = (color red >>) . (renderShapeAt $ Sphere' 0.5 20 20) renderGoal = (color greenG >>) . (renderShapeAt $ Sphere' 0.5 20 20) main :: IO () main = do oldTime <- newIORef (0 :: Int) rh <- reactInit (initGL >> return NoEvent) (\_ _ b -> b >> return False) simulate displayCallback $= return () idleCallback $= Just (idle oldTime rh) oldTime' <- get elapsedTime writeIORef oldTime oldTime' mainLoop idle :: IORef Int -> ReactHandle (Event ()) (IO ()) -> IO () idle oldTime rh = do newTime' <- get elapsedTime oldTime' <- get oldTime let dt = (fromIntegral $ newTime' - oldTime')/1000 react rh (dt, Nothing) writeIORef oldTime newTime' return () simulate :: SF (Event ()) (IO ()) simulate = discardInputs >>> update >>> draw discardInputs :: SF (Event ()) () discardInputs = arr $ const () update :: SF () Pos update = proc () -> do pos <- clock -< () returnA -< pos draw :: SF Pos (IO ()) draw = arr clearAndRender
上記のプログラムでは、zipのところで、イベントが起きる間隔(この場合は5秒)とその時の文字盤の位置が与えられる。即ち、[(5,dial0),(5,dial1),(5,dial2),(5,dial3)..]が与えられる、イベントが生じるように仕組まれる。上記のプログラムを実行すると次のようになる(なお。この映像ではイベントは5秒毎ではなく1秒ごとに発生する）。
これまでのスイッチは、switchあるいはdSwitchを用いて簡単に定義できる。しかし、並列スイッチに対しては、この他に凍結された信号関数を利用できるようにするスイッチagingを必要とする。それらの中で、基本的なスイッチageは次のとおりである。
age :: SF a b -> SF a (b, SF a b)
関数ageは、信号関数SF a bを受け取り、信号関数SF a (b, SF a b)を出力する。出力される信号関数は、その出力が(b, SF a b)である。この出力に含まれているSF a bは凍結されている信号関数であり、これを利用可能としている(凍結は次のような場面で利用されている。DIVE virtual reality environment(Blom 2009)で実装されている例：現実世界と同じように仮想世界で連続的に操作するが、過去に戻りたくなった時、即ちundoを行うとき、凍結した信号関数を取りだしている）。
例えば、ageは次のkSwitchを定義するとき使われる。
kSwitchは次の図で示される。
kSwitchをswitchを用いて表すと次のようになる。
kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b kSwitch sf1 sfe k = switch sf (\(c, sf1’) -> k sf1’ c) where sf :: SF a (b, Event (c, SF a b)) sf = (identity &&& sfe sf1) >>> arr (\(a, b, sf1’)) -> ((a, b), (b, sf1’))) >>> first sfe >>> arr (\(e, (b, sf1’)) -> (b, e `attach` sf1’))
kSwitchは本質的なイベントと称せられる。それは、適当なスイッチがどれであるのかを判断するために、信号関数の内容を調べるためである。kSwitchは三つの引数sf,analyzer,mappingを取る。sfは標準的な信号関数で、入力の型がa、出力の型がbである。analyzerはsfの入力と出力を取る関数で、型がcであるイベントによって発火したりしなかったりする。発火しないときは何も起こらず、信号関数はsfのように振舞う。発火したときはsfとイベントの値がmappingに渡される。mappingはスイッチすべき新しい信号関数を決定する。
前の記事で説明した複数投石のプログラムをkSwitchで記述すると次のようになる（なお、switchの部分はコメントになっているので、比較すると違いが分かる）。
{-# LANGUAGE Arrows #-} import FRP.Yampa import Control.Concurrent import FRP.Yampa.Vector3 import FRP.Yampa.Utilities import Unsafe.Coerce import Data.IORef import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize) import qualified Graphics.UI.GLUT as G(Vector3(..)) type Pos = (Double, Double) type Vel = (Double, Double) type R = GLdouble fallingBall :: (Pos, Vel) -> SF () (Pos, Vel) fallingBall (pos0, vel0) = proc input -> do vel <- (vel0 ^+^) ^<< integral -< (0, -9.81) pos <- (pos0 ^+^) ^<< integral -< vel returnA -< (pos, vel) throwingStone :: (Pos, Vel) -> SF () (Pos, Vel) throwingStone (pos0, vel0) = kSwitch (fallingBall (pos0, vel0)) trigger cont where trigger = proc (_, (pos, vel)) -> do event <- edge -< (snd pos) <= 0 returnA -<event `tag` (pos, vel) cont old event = (\(pos',vel') -> throwingStone (pos', ((fst vel'), (- (snd vel')) * 0.6))) event {- throwingStone :: (Pos, Vel) -> SF () (Pos, Vel) throwingStone (pos0, vel0) = switch (bb (pos0, vel0)) (\ (pos, vel) -> throwingStone (pos, ((fst vel), (- (snd vel)) * 0.6))) where bb (pos0', vel0') = proc input -> do (pos, vel) <- fallingBall (pos0', vel0') -< input event <- edge -< snd pos <= 0 returnA -< ((pos, vel), event `tag` (pos, vel)) -} bird :: (Pos, Vel) -> SF () (Pos, Vel) bird (pos0, vel0) = proc input -> do vel <- (vel0 ^+^) ^<< integral -< (0, 0) pos <- (pos0 ^+^) ^<< integral -< vel returnA -< (pos, vel) initGL :: IO () initGL = do getArgsAndInitialize createWindow "Shooting Game" initialDisplayMode $= [ WithDepthBuffer, DoubleBuffered ] depthFunc $= Just Less clearColor $= Color4 0 0 0 0 light (Light 0) $= Enabled lighting $= Enabled lightModelAmbient $= Color4 0.5 0.5 0.5 1 diffuse (Light 0) $= Color4 1 1 1 1 blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) reshapeCallback $= Just resizeScene return () resizeScene :: Size -> IO () resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero resizeScene s@(Size width height) = do -- putStrLn "resizeScene" viewport $= (Position 0 0, s) matrixMode $= Projection loadIdentity perspective 45 (w2/h2) 1 1000 matrixMode $= Modelview 0 where w2 = half width h2 = half height half z = realToFrac z / 2 clearAndRender :: ((Pos, Vel), (Pos, Vel), (Pos, Vel)) -> IO () clearAndRender ((pos1, vel1), (pos2, vel2), (pos3, vel3)) = do clear [ ColorBuffer, DepthBuffer ] loadIdentity renderPlayer $ vector3 (unsafeCoerce (fst pos1)) (unsafeCoerce (snd pos1)) (-30) renderPlayer $ vector3 (unsafeCoerce (fst pos2)) (unsafeCoerce (snd pos2)) (-30) renderPlayer $ vector3 (unsafeCoerce (fst pos3)) (unsafeCoerce (snd pos3)) (-30) flush where size2 :: R size2 = (fromInteger $ 6)/2 green = Color4 0.8 1.0 0.7 0.9 :: Color4 R greenG = Color4 0.8 1.0 0.7 1.0 :: Color4 R red = Color4 1.0 0.7 0.8 1.0 :: Color4 R renderShapeAt s p = preservingMatrix $ do translate $ G.Vector3 (0.5 - size2 + vector3X p) (0.5 - size2 + vector3Y p) (0.5 - size2 + vector3Z p) renderObject Solid s renderObstacle = (color green >>) . (renderShapeAt $ Cube 1) renderPlayer = (color red >>) . (renderShapeAt $ Sphere' 0.5 20 20) renderGoal = (color greenG >>) . (renderShapeAt $ Sphere' 0.5 20 20) main :: IO () main = do oldTime <- newIORef (0 :: Int) rh <- reactInit (initGL >> return NoEvent) (\_ _ b -> b >> return False) simulate displayCallback $= return () idleCallback $= Just (idle oldTime rh) oldTime' <- get elapsedTime writeIORef oldTime oldTime' mainLoop idle :: IORef Int -> ReactHandle (Event ()) (IO ()) -> IO () idle oldTime rh = do newTime' <- get elapsedTime oldTime' <- get oldTime let dt = (fromIntegral $ newTime' - oldTime')/1000 react rh (dt, Nothing) writeIORef oldTime newTime' return () simulate :: SF (Event ()) (IO ()) simulate = discardInputs >>> update >>> draw discardInputs :: SF (Event ()) () discardInputs = arr $ const () update :: SF () ((Pos, Vel), (Pos, Vel), (Pos, Vel)) update = proc () -> do (pos1, vel1) <- throwingStone (((-8), 0), (1, 15)) -< () (pos2, vel2) <- throwingStone (((-8), 0), (4, 17)) -< () (pos3, vel3) <- bird (((-8), 10), (4, 0)) -< () returnA -< ((pos1, vel1), (pos2, vel2), (pos3, vel3)) draw :: SF ((Pos, Vel), (Pos, Vel), (Pos, Vel)) (IO ()) draw = arr clearAndRender
集合のagingは次のようになる。
agePar :: Functor col -> (forall sf . (a -> col sf -> col (b, sf))) -> col (SF b c) -> SF a (col c, col (SF b c))
これはpSwitchとdpSwitchを定義するのに使われる。
pSwitchは次の図で示される。
