bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

ゲームの中で信号関数を自在に扱う:スイッチ

1.スイッチ

スイッチはある一つの信号関数を他の信号関数で置き換えるものである。スイッチが生じるのは、スイッチング・イベントの発生元で、最初のイベントが発生したときである。スイッチの型シグネチャは次のようになっている。

switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b

switchを図で示すと次のようになる。
f:id:bitterharvest:20141019105504p:plain
最初の入力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)

2.インパルス関数

ボールが床に衝突したとき、速度の向きを変えることは、物理的な現象を正確に表しているとは言えない。Yampaではより正確に表すためにディラク・インパルスを用意している。これは次のようになっている。

impulseIntegral :: VectorSpace a k => SF (a, Event a) a

2.切り離し(デカップル)

dSwitchはイベントが生じたとき、新しい信号関数で置き換えるのではなく、古い信号関数から得られる。型シグネチャは次のようになっている。

dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b

現時点での出力はその時点で生じたスイッチング・イベントに依存していたり、独立であったりする。

3.その他のスイッチ

その他いくつかのスイッチが用意されている。rSwitchの型シグネチャは次のようになっている。

rSwitch, drSwitch :: SF a b -> SF (a, Event (SF a b)) b

rSwitchは次の図で示される。
f:id:bitterharvest:20141026140024j:plain
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は次の図で示される。
f:id:bitterharvest:20141026140237j:plain
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は次の図で示される。
f:id:bitterharvest:20141026140119j:plain