読者です 読者をやめる 読者になる 読者になる

bitterharvest’s diary

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

Reactive-banana 紹介(7)

8.Animation

Reactive Bananaの基本的な機能の説明が続いたので、Functional Reactive Programming (FRP)の応用分野の一つであるアニメーション・プログラムの解説をしよう。とは、言ってもとても簡単なプログラムである。Reactive Bananaのロゴをカーソルがあるところに近づけるというプログラムである。画面は以下のようだが、ロゴがカーソルに向かって動き回るというのがこのプログラムである。

f:id:bitterharvest:20151216102805p:plain

8.1 ユーザ・インタフェース

例によって、ユーザ・インタフェースを最初に用意する。今回の画面は、白地のパネルにロゴを張ることにすると、フレーム、パネルは次のように定義できる。

    ff <- frame [ text       := "It's functional programming time"
                , bgcolor    := white
                , resizeable := False ]
    pp <- panel ff [ ]
    set ff [ layout  := minsize (sz width height) $ widget pp ]

また、フレームの書き換え時間を、これはネットワークをモニタする時間にもなるが、20ミリ秒と定義しておく。

    t <- timer ff [ interval := 20 ]

8.2イベント・ネットワークの構築

イベント・ネットワークは前の記事で説明した通り、入力、イベント・グラフ、出力から構成される。それでは、これらを順を追って説明しよう。

入力

まず、入力は(フレーム書き換えの)タイマーとマウスからになるので、次のようにする。

            etick  <- event0 t command  -- frame timer
            emouse <- event1 pp mouse   -- mouse events

イベント・グラフ

次はイベント・グラフである。これには、マウスの位置、ロゴ(spriteと呼ぶ)の位置、ロゴの描写が含まれる。

最初にマウスの位置を表すイベント・グラフを考える。マウスの位置はイベントとして離散的に入力される。これから、ある時間でのマウスの位置を知るためには、離散的に入力された位置の点列から、連続な時間で定義された位置に変更する必要がある。これには前に説明したstepperを用いる。
f:id:bitterharvest:20151205095344p:plain

従って、連続的な時間に対して、マウスの位置は次のように変化する。

stepper (point 0 0) (filterJust $ justMotion <$> emouse)

ところで、イベントでの位置はデータ型Pointで与えられるが、計算をベクトルで行うために、位置をデータ型Vectorで表したい。この変換は関数fromPointが行ってくれる。しかし、stepperはモナドであるため、モナドに包まれたPointをVectorに変換するためにはfmap fromPointで行う必要がある。これを全ての時間に対して行うためには、

fmap (fmap fromPoint)  (stepper (point 0 0) (filterJust $ justMotion <$> emouse))

となる。最初のfmapを中置関数<$>を用いて表すと

fmap fromPoint <$> (stepper (point 0 0) (filterJust $ justMotion <$> emouse))

となる。
従って、マウスの位置を表すイベント・グラフは次のようになる。

            (bmouse :: Behavior Vector) <-
                fmap fromPoint <$> stepper (point 0 0)
                    (filterJust $ justMotion <$> emouse)

なお、fromPointerは次のように定義されている。

type Vector = Vector2 Double

fromPoint :: Point -> Vector
fromPoint pt = vector (fromIntegral (pointX pt)) (fromIntegral (pointY pt))

また、マウスの位置を得るために用いたjustMotionは次のように定義されている。

justMotion :: EventMouse -> Maybe Point
justMotion (MouseMotion pt _) = Just pt
justMotion _                  = Nothing

それでは、ロゴの位置をイベント・グラフで表すことにする。このプログラムでは、フレームの書き換え時間(20ミリ秒)が、モニターしている時間間隔である。現在の時点でモニターしたカーソルの位置(\(\vec{mouse}\))はロゴ(\(\vec{pos}\))の位置から離れていたとする。この時、次のモニターの時間が来たときに、先ほどのカーソルの位置にロゴを移動したい。このためには、1ミリ秒当たり、\( \frac{\vec{mouse}- \vec{pos}}{20} \)の速度で進めばよい。
これには、次のBehavior APIを利用すればよい。
f:id:bitterharvest:20151216132755p:plain

上の図の(*)のところを速度とすればよいことが分かる。そこで、速度をspeedupで表すと次のように表すことができる。

                bvelocity :: Behavior Vector
                bvelocity =
                    (\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45)
                    <$> bposition <*> bmouse
                    where
                    speedup v = v `vecScale` (vecLengthDouble v / 20)

上のプログラムで、vec 0 45とあるのは、ロゴの左、真ん中の少し上にカーソルが来るようにするための調整値である。

この速度を用いて、次のロゴの位置を求めると以下のようになる。

            (bposition :: Behavior Vector)
                <- accumB (vec 0 0) $
                    (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos)
                    <$> bvelocity <@ etick

なお、<@はEvent & Behavior APIで次のような働きをする。
f:id:bitterharvest:20151216132737p:plain

また、上記のプログラムで(vec 0 0)はロゴの初期位置であり、posは現在のモニター時点での位置である。現在の位置は、accumBで移動距離の累積を計算しそれより求められている。
accumBの関数がなかなかわかりにくいのでが、次のような例があるので、これから推察するとよい。

accumB "x" [(time1,(++"y")),(time2,(++"z"))]
   = stepper "x" [(time1,"xy"),(time2,"xyz")]

上記のプログラムで、初期値は"x"である。次の時間time1では、これに"y"が追加される。さらに、次の時間では、さらに"z"が追加される。
これと同じように、最初の場所に(vec 0 0)、次のモニター時間が来たときに、その時に進んだ距離が足され、さらに次のモニター時間で、さらに進んだ時間が足されるという操作が行われていると考えるとよい。

また、clipToFrameはロゴがフレームからはみ出さないようにする。プログラムは次のようになっている。

                clipToFrame v = vec
                        (clip 0 x (fromIntegral $ width  - bitmapWidth ))
                        (clip 0 y (fromIntegral $ height - bitmapHeight))
                    where
                    x = vecX v; y = vecY v
                    clip a x b = max a (min x b)

イベント・グラフの最後はロゴの描写である。これはロゴのビットマップをもらってposのところに描く。

                clipToFrame v = vec
                        (clip 0 x (fromIntegral $ width  - bitmapWidth ))
                        (clip 0 y (fromIntegral $ height - bitmapHeight))
                    where
                    x = vecX v; y = vecY v
                    clip a x b = max a (min x b)

また、ビットマップは次で与えられる。

sprite :: Bitmap ()
sprite = bitmap $ getDataFile "banana.png"

出力

出力は次のようになる。

            sink pp [on paint :== drawSprite . toPoint <$> bposition]
            reactimate $ repaint pp <$ etick

8.3 プログラム

プログラムはこのホームページで公表されているが、転載しよう。

{-----------------------------------------------------------------------------
    reactive-banana-wx
    
    Example: A simple animation.
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-}
    -- allows pattern signatures like
    -- do
    --     (b :: Behavior Int) <- stepper 0 ...
{-# LANGUAGE RecursiveDo #-}
    -- allows recursive do notation
    -- mdo
    --     ...

import Graphics.UI.WX hiding (Event, Vector)
import Reactive.Banana
import Reactive.Banana.WX

import Paths (getDataFile)

{-----------------------------------------------------------------------------
    Constants
------------------------------------------------------------------------------}
height, width :: Int
height   = 400
width    = 400

dt :: Double
dt = 20 * ms where ms = 1e-3

sprite :: Bitmap ()
sprite = bitmap $ getDataFile "banana.png"

bitmapWidth, bitmapHeight :: Int
bitmapWidth  = 128
bitmapHeight = 128

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = start $ do
    ff <- frame [ text       := "It's functional programming time"
                , bgcolor    := white
                , resizeable := False ]

    t  <- timer ff [ interval := ceiling (dt * 1e3) ]    
    pp <- panel ff [ ]
    set ff [ layout  := minsize (sz width height) $ widget pp ]
    
    -- event network
    let networkDescription :: MomentIO ()
        networkDescription = mdo
            etick  <- event0 t command  -- frame timer
            emouse <- event1 pp mouse   -- mouse events
            
            -- mouse pointer position
            (bmouse :: Behavior Vector) <-
                fmap fromPoint <$> stepper (point 0 0)
                    (filterJust $ justMotion <$> emouse)

            let
                -- sprite velocity
                bvelocity :: Behavior Vector
                bvelocity =
                    (\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45)
                    <$> bposition <*> bmouse
                    where
                    speedup v = v `vecScale` (vecLengthDouble v / 20)
                
            -- sprite position
            (bposition :: Behavior Vector)
                <- accumB (vec 0 0) $
                    (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos)
                    <$> bvelocity <@ etick
            
            let
                clipToFrame v = vec
                        (clip 0 x (fromIntegral $ width  - bitmapWidth ))
                        (clip 0 y (fromIntegral $ height - bitmapHeight))
                    where
                    x = vecX v; y = vecY v
                    clip a x b = max a (min x b)
                
                drawSprite :: Point -> DC a -> b -> IO ()
                drawSprite pos dc _view = drawBitmap dc sprite pos True []
        
            -- animate the sprite
            sink pp [on paint :== drawSprite . toPoint <$> bposition]
            reactimate $ repaint pp <$ etick
    
    network <- compile networkDescription    
    actuate network

{-----------------------------------------------------------------------------
    2D Geometry
------------------------------------------------------------------------------}
type Vector = Vector2 Double

fromPoint :: Point -> Vector
fromPoint pt = vector (fromIntegral (pointX pt)) (fromIntegral (pointY pt))

toPoint :: Vector -> Point
toPoint v = point (ceiling (vecX v)) (ceiling (vecY v))

{-----------------------------------------------------------------------------
    wx stuff
------------------------------------------------------------------------------}
justMotion :: EventMouse -> Maybe Point
justMotion (MouseMotion pt _) = Just pt
justMotion _                  = Nothing