モナディック関数型リアクティブプログラミング(mFRP)の実装のひとつmoffyの紹介
Haskell advent calendar 2023の22日目の記事です。
はじめに
モナディック関数型リアクティブプログラミング(monadic functional reactive programming, mFRP)の1つの実装であるパッケージmoffyを紹介していく。
- サンプルコードの実行には基本的にStackを使用する
- Stackを使わなくてもHackageからパッケージを集めれば動かせる(はず)
- はじめの例では、多くの環境で実行可能なように標準入力と標準出力を使った例で説明する
モナディック関数型リアクティブプログラミングとは何なのか
関数型リアクティブプログラミング(FRP)
FRPの説明でよく引き合いに出されるのは、表計算ソフトのセルの間で定義される計算だ。
+-------+---------+---------+---
| | A | B |
+-------+---------+---------+---
| 1 | x | |
+-------+---------+---------+---
| 2 | y | |
+-------+---------+---------+---
| 3 | A1 + A2 | |
+-------+---------+---------+---
| 4 | | |
+-------+---------+---------+---
| 5 | | |
上記のようにA3のマスの値がA1 + A2で定義されていたとする。そうすると、A1 = 8, A2 = 13だと
+-------+---------+---------+---
| | A | B |
+-------+---------+---------+---
| 1 | 8 | |
+-------+---------+---------+---
| 2 | 13 | |
+-------+---------+---------+---
| 3 | 21 | |
+-------+---------+---------+---
| 4 | | |
+-------+---------+---------+---
| 5 | | |
このように、A3のマスの値は8 + 13 = 21で21になる。ここで、A2が25に変更されたとする。すると
+-------+---------+---------+---
| | A | B |
+-------+---------+---------+---
| 1 | 8 | |
+-------+---------+---------+---
| 2 | 25 | |
+-------+---------+---------+---
| 3 | 33 | |
+-------+---------+---------+---
| 4 | | |
+-------+---------+---------+---
| 5 | | |
このように、A3のマスの値は8 + 25 = 33で33になる。これは、「A2のマスの値の変更」というイベントが伝搬していき、A3のマスの値の変化を引き起こしたというモデルで考えることもできる。
[マスA1] [マスA2] [マスA2の13から25への変化]
| | ||
+-----+ +-----+ ||
| | \/
V V [マスA3の21から33への変化]
[マスA3]
左の図のような「値の変化が波及していく関係」が前提となり、マスA2の値の変化がマスA3の値の変化を引き起こすというモデルだ。でも別の形のメンタルモデルも作れる。それぞれのマスの値が時系列のなかで変化していくわけだけど、それを一本のひものようなものと考える。そして、そのひも同士の関係を定義していくというモデルだ。上記の表計算ソフトの例だと、つぎのようになる。
[マスA1] [マスA2] [マスA3]
| | |
| | |
| + | = |
| | |
[8] [13] [21]
| | |
| | |
| [25] [33]
| | |
| | |
[マスA1]が時間の流れとともに変化していく、その変化の履歴の全体をひとつのモノと考え、同じように[マスA2]や[マスA3]についても、変化の全体をモノとして考える。そのとき[マスA1]の変化の履歴の全体と[マスA2]の変化の履歴の全体と、[マスA3]のそれとのあいだに足し算の関係がある。そのような「変化の履歴の全体」の間の関係を定義するというモデルを考えることができる。もしも、未来がすべて決まっていると仮定すれば、このような「履歴の全体」は時間の関数として表すことができる。
type History a = T -> a
そして、このHistory a型の値の間で演算することで新しいHistory型の値を定義することができる。つまり、型Historyはアプリカティブである。
historyA3 = (+) <$> historyA1 <*> histroyA3
となる。これは実際にHaskellのコードとして書くとこができる。
% stack new zenn-use-moffy
% cd zenn-use-moffy
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Determinism where
type T = Double
type History a = T -> a
historyA1, historyA2, historyA3 :: History Int
historyA1 = pure 8
historyA2 t
| t < 10 = 13
| otherwise = 25
historyA3 = (+) <$> historyA1 <*> historyA2
ここでは、時刻10にマスA2の値が13から25に変化したとしている。対話環境で試してみよう。
% stack ghci
...
ghci> historyA3 7
21
ghci> historyA3 9
21
ghci> historyA3 10
33
ghci> historyA3 15
33
人間は神ではない。未来のことはわからないので、こういう「すっきりとした実装」をすることは不可能だ。ただ、中身は何であれ「変化の履歴の全体」をアプリカティブとして定義することはできる。「変化の履歴の全体」をこれからはシグナルと呼ぶことにする。
モナディック関数型リアクティブプログラミング
シグナルを「時刻を引数とする関数」としてモデル化した場合、シグナルには始まりも終わりもない。永遠に続く。でも、実際にコードを書く場合には「永遠」をあつかうよりも、始まりと終わりがあったほうがいい。始まって終わるような一定の生存期間のあるモノを積み重ねていくほうが、コードは書きやすい。順番に変化していくものを並べていくというモデルに調度いい抽象がある。それはモナドだ。時系列を縦軸にして、それぞれのシグナルが横方向に並んでいることを考える。すると、縦方向にはモナドであり、横方向にはアプリカティブであるような構造を考えることができる。
^ ^
| |
A |
| |
| C
V ~~op~~ |
^ |
| |
B |
| |
| |
V V
AとBとはモナドとして結合され、その結果がさらにアプリカティブとしてCと組み合わされる。
op <$%> (A >> B) <*%> C
<$>や<*>の代わりに<$%>と<*%>としたのは、AとBを結合したモナドとは異なるレベルでのアプリカティブとなっているからだ。それぞれのシグナルのモナドとしての時系列上での積み重ねと、アプリカティブとしての横方向での組み立てとは、入れ子にすることができる。終わりがあり、その結果として縦方向に積み重ねることができるのがmFRPのFRPとは異なる特徴の1つだ。
パッケージmoffy
mFRPは以下の論文で紹介されている。
Monadic Functional Reactive Programming
パッケージmoffyはこの論文で紹介されている実装を、実用面を考えて、いくつかの点で拡張したものだ。
- イベントを決め打ちではなく指定できるようにした
- さらに、イベントは複数を組み合わせて使えるようにした
type Evs = Ev1 :- Ev2 :- 'Nil
- さらに、イベントは複数を組み合わせて使えるようにした
- FTCQueueによるパフォーマンスの改善
- 論文Reflection without Remorseで紹介されている
- 論文で書かれている
first x xのような場合にxを2回評価してしまうという問題を解決した
足し算の例
パッケージmoffyでは、イベントを発生させる部分と結果を描画する部分とを好きに指定することができる。GUIライブラリを使用することもできるが、まずは「どこでも動く」標準入力と標準出力を使った例を書いてみよう。つぎのような仕様とする。
- a, bのふたつの整数を入力とし、それらを加算したものを出力とする
- はじめは出力はない
- 文字'a'のあとに数字1文字が入力されたら、その数字の値を整数としてaの値とする
- 同様に文字'b'のあとに数字1文字を入力することで値bを入力する
- a, bのふたつの値がそろったら結果の値を出力する
- a, bの値の入力の順は問わない
- a, bの値は一度入力されたあとも何度でも変更できる
- 変更のたびに新しい結果が表示される
パッケージmoffyが使えるようにstack.yamlとpackage.yamlとを編集する。
...
resolver: nightly-2023-12-19
...
resolverをnightly-2023-12-19にする。
...
dependencies:
- base >= 4.7 && < 5
- moffy
- type-set
- type-flip
...
executables:
...
simple:
main: simple.hs
other-modules: []
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- zenn-use-moffy
...
dependenciesにmoffy, type-set, type-flipを追加している。また、app/simple.hsをソースコードとするsimpleを実行可能形式としてビルドするように、その項目を追加した。
まずは必要な言語拡張とモジュールとを導入する。
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Main (main) where
import Prelude hiding (repeat, break)
import Control.Monad
import Control.Moffy
import Control.Moffy.Run
import Control.Exception (bracket)
import Data.Type.Set
import Data.Type.Flip
import Data.OneOrMoreApp
import Data.Bool
import Data.Char
import System.IO qualified as IO
キーの押下をキャッチするイベントの型Keyを定義する。
data Key = KeyReq deriving (Show, Eq, Ord)
numbered [t| Key |]
instance Request Key where data Occurred Key = OccKey Char deriving Show
型Keyは値KeyReqだけを持つ型として定義した。これは「イベントを発生させる部分」に対して、「イベントを要求する」ための値だ。この値で「どんなイベントが欲しいか」を指定することができる。
numberedはTemplateHaskellの機能を利用して型に数値を対応づけている。型の集合を定義するときに型の順番を決めるのに必要になる。型に対して通し番号をつけることはできないので、ランダムな数値を対応づけている。
3行目では型KeyをRequestクラスのインスタンスにしている。Requestクラスのインスタンスにすることで、Keyイベントを要求する型Keyに対して、実際に生じたイベントを表す型Occurred Keyを定義している。型Occuured Keyは値構築子OccKeyを持ち、それはChar型の値を引数として取る。
これでKey型の値KeyReqによってKeyイベントを要求し、Char型の値を持つOccuured Key型の値をイベントとして受け取る用意ができた。Keyイベントを受け取ってChar型の値を返すモノであるkeyを定義しよう。
key :: React s (Singleton Key) Char
key = await KeyReq \(OccKey c) -> c
新しくReactという型が出てきた。これは何だろうか。これは0個以上のイベントを受け取り値を返すモナドである。keyはKeyReqによってイベントを要求し発生したイベントからChar型の値を取り出して返すモナドである。
React型の取る型引数の一番目の型変数sは無視していい。第二引数はこのリアクトが反応するイベントを示す。ここではKeyイベントのみに反応するので、Singleton Keyとなっている。Singleton aはa型のみを含む型の集合だ。このリアクトkeyから2つのリアクトを定義する。
pressOn :: Char -> React s (Singleton Key) ()
pressOn c = key >>= bool (pressOn c) (pure ()) . (c ==)
digit :: React s (Singleton Key) Int
digit = key >>= \c -> bool digit (pure . read $ c : "") (isDigit c)
リアクトpressOnはリアクトkeyの返す文字が文字cならばpure ()で終了するが、そうでない場合はpressOn cをくりかえす。つまり、文字cに対応するキーが押されるまで待機するリアクトだ。リアクトdigitは同様に数字キーが押されるのを待つ。こちらのリアクトは押された数字に対応する整数を返す。これらを使うことで、特定のキーを押したあとに数字キーを押すことで「値の設定」ができるシグナルを定義することができる。
sigX :: Char -> Sig s (Singleton Key) Int ()
sigX c = repeat $ pressOn c >> digit
pressOn c >> digitは文字cに対応するキーを押下したあとに、数字キーを押したときに、それに対応する整数を返すリアクトだ。関数repeatはリアクトからシグナルを生成する関数だ。リアクトによるイベントのキャッチをくりかえし、そのたびにリアクトの返り値を自身の値とするようなシグナルを生成する。これを使って最終的に求める動作をするシグナルを定義することができる。
sigC :: Sig s (Sintleton Key) Int ()
sigC = void $ ((+) <$%> sigX 'a' <*%> sigX 'b') `break` pressOn 'q'
演算子<$%>や<*%>は右から2番目の値についてのアプリカティブ演算子だ。
ghci> :module Data.Type.Flip
ghci> :type (<$%>)
(<$%>) :: Functor (Flip t c) => (a -> b) -> t a c -> t b c
ghci> :type (<*%>)
(<*%>) :: Applicative (Flip t c) => t (a -> b) c -> t a c -> t b c
Flipは型引数の順を入れ替える。つまりFlip t c a == t a cだ。シグナルsigCの定義の中心部は(+) <$%> sigX 'a' <*%> sigX 'b'だ。この部分で'a'のあとに数字キーにより値が設定されるシグナルaと、同様に'b'によって値が設定されるシグナルbとの加算を値とするシグナルが定義されている。関数repeatによって生成されたシグナルは終了しないので、関数breakによってリアクトpressOn 'q'が終了したときに全体も終了するようにしている。あとは、シグナルsigCを走らせればいい。これには関数interpretが使える。型を見てみよう。
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Run
ghci> :module + Data.Type.Set
ghci> :type interpret
interpret
:: (Monad m, Adjustable es es') =>
Handle m es' -> (a -> m ()) -> Sig s es a r -> m r
ghci> :info Handle
type Handle :: (* -> *) -> Set (*) -> *
type Handle m es = EvReqs es -> m (EvOccs es)
interpret hdl outp sigのように使う。ここでhdlは「イベントを要求する値を引数として、実際に起きるイベントを返すモナド」であり、outpはシグナルの持つ値を出力するモナドである。hdlやoutpに当たるモナドを定義する。
handle :: Handle IO (Singleton Key)
handle = const $ Singleton . OccKey <$> getChar
output :: Int -> IO ()
output c = putStrLn $ "\na + b = " ++ show c
また、これは本質的な話ではないが標準入力のバッファリングをしないようにするための関数を定義する。
withNoBuffering :: IO.Handle -> IO a -> IO a
withNoBuffering h act = bracket
(IO.hGetBuffering h <* IO.hSetBuffering h IO.NoBuffering)
(IO.hSetBuffering h)
(const act)
あとは、関数interpretを使って定義したシグナルsigCに対して、イベントをあたえ、値を表示してやればいい。
main :: IO ()
main = withNoBuffering IO.stdin run >> putStrLn ""
run :: IO ()
run = interpret handle output sigC
コンパイルして試してみよう。
% stack build
% stack exec simple
a8b3
a + b = 11
b5
a + b = 13
b8
a + b = 16
a2
a + b = 10
q
完成したコードは app/simple.hs にある。「getCharの結果によってガードで処理を分岐させて...」といったコードよりかは、いくぶんきれいでモジュール化されたコードになっているように思う。
moffyのAPIについてすこし
関数emitとwaitForについて説明する。
emit :: a -> Sig s es a ()
waitFor :: React s es r -> Sig s es a r
emitはシグナルの値を設定する関数だ。そして、waitForは引数であるリアクトが終了するまで、シグナルを生かしておく関数だ。
foo = do
emit 123
waitFor click
emit 321
waitFor click
うえのように定義されたシグナルfooははじめの値が123で、一度clickが生じると値は321に変更され、もう一度clickが生じると終了する。
長方形を描画する例
Monadic Functional Reactive Programming
上の論文の例をmoffyで実装する。動かすにはGTK3またはGTK4が必要だ。パッケージmoffy-samples-gtk3-runまたはmoffy-samples-gtk4-runを使う。stack.yamlのextra-depsに使用するバージョンを記載する。ここではGTK3のほうで説明するがGTK4でも、ほぼ同様だ。
...
extra-deps:
- moffy-samples-gtk3-run-0.1.0.7
...
このパッケージに含まれるControl.Moffy.Samples.Boxes.Run.Gtk3.runBoxesは長方形を描画するためのシグナルを動かす関数だ。GTK3を使っている。package.yamlのdependenciesにmoffy-samples-eventsとmoffy-samples-gtk3-runとextra-data-yjを追加する。
...
dependencies:
- base >= 4.7 && < 5
- moffy
- type-set
- type-flip
- moffy-samples-events
- moffy-samples-gtk3-run
- extra-data-yj
...
モジュールBoxesを書いていこう。必要なモジュールを導入する。
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Boxes where
import Prelude hiding (until, cycle, repeat)
import Control.Arrow qualified as A
import Control.Monad
import Control.Moffy
import Control.Moffy.Event.Time
import Control.Moffy.Samples.Event.Mouse qualified as Mouse
import Control.Moffy.Samples.Boxes.Viewable
import Data.Type.Set
import Data.Type.Flip
import Data.Or
import Data.List.NonEmpty (fromList)
import Data.List.Infinite (Infinite(..), cycle)
import Data.Bool
前に定義したpressOnと同様のclickOnを定義する。それを使って、左、中央、右クリックを検出するリアクトを定義しておこう。
clickOn :: Mouse.Button -> React s (Singleton Mouse.Down) ()
clickOn b = bool (clickOn b) (pure ()) . (== b) =<< Mouse.down
leftClick, middleClick, rightClick :: React s (Singleton Mouse.Down) ()
leftClick = clickOn Mouse.ButtonPrimary
middleClick = clickOn Mouse.ButtonMiddle
rightClick = clickOn Mouse.ButtonSecondary
同様にマウスのボタンを離したときに発生するイベントを待つリアクトを定義する。
releaseOn :: Mouse.Button -> React s (Singleton Mouse.Up) ()
releaseOn b = bool (releaseOn b) (pure ()) . (== b) =<< Mouse.up
leftUp, middleUp, rightUp :: React s (Singleton Mouse.Up) ()
leftUp = releaseOn Mouse.ButtonPrimary
middleUp = releaseOn Mouse.ButtonMiddle
rightUp = releaseOn Mouse.ButtonSecondary
試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> runBoxes $ waitFor leftClick
ウィンドウが表示される。そのウィンドウ上で左クリックすると終了する。続けて、つぎのようにしてみる。
ghci> runBoxes . waitFor $ rightClick >> leftClick
今度は右クリックしたあとに左クリックすると終了する。
ghci> runBoxes $ waitFor rightUp
右ボタンを押下したあとに、ボタンを離したときに終了する。ここで関数firstについて見てみよう。
first :: Firstable es es' a b =>
React s es a -> React s es' b -> React s (es :+: es') (Or a b)
これは2つのリアクトを同時に動かして、どちらかが終了するまで待ち、先に終わったほうの値をOr a b型の値として返す。型Orはつぎのように定義されている。
data Or a b = L a | R b | LR a b
firstでは左が先に終わるか右が先に終わるか、同時に終わるかなので、返り値はこのようになっている。型クラスFirstableは実装の都合で必要なものなので気にしないでいい。firstを利用して左側のリアクトが先に終わったらTrueを、そうでないならFalseを返すようなリアクトを返す関数を定義する。
before :: Firstable es es' a b =>
React s es a -> React s es' b -> React s (es :+: es') Bool
a `before` b = (<$> a `first` b) \case L _ -> True; _ -> False
ここでsleepを見てみる。
Control.Moffy.Event.Time:Sleep
sleep :: DiffTime -> React s (Singleton TryWait) ()
DiffTime型の値で指定した秒数だけ待つリアクトだ。これらを使うとダブルクリックを待つリアクトが定義できる。
doubler :: React s (Mouse.Down :- Singleton TryWait) ()
doubler = do
adjust rightClick
r <- rightClick `before` sleep 0.2
if r then pure () else doubler
これは、つぎのように動作する。
- 右クリックを待つ
- 右クリックまたは0.2秒経過するのを待つ
- 右クリックと0.2秒経過とのどちらが早かったかで
- もしも右クリックのほうがはやければダブルクリックが終了したということ(
pure ()) - そうでなければ、ダブルクリックを待つ(
doubler)
- もしも右クリックのほうがはやければダブルクリックが終了したということ(
関数adjustは型を合わせるために必要だ。
doubler :: React s (Mouse.Down :- Singleton TryWait) ()
rightClick :: React s (Singleton Mouse.Down) ()
関数adjustで型Singleton Mouse.Downの部分を上のMouse.Down :- Singleton TryWaitに合わせている。試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> runBoxes $ waitFor doubler
表示されたウィンドウ上で右ダブルクリックするとウィンドウが閉じて終了する。
長方形を作る
つぎに、Control.Moffy.Samples.Event.Mouse.positionを見てみよう。
Control.Moffy.Samples.Event.Mouse
position :: Sig s (Singleton Move) Point r
これはマウスカーソルの位置を値として持つシグナルだ。これを使うと、指定した位置を左上の点とし、マウスカーソルの位置を右下の点とする長方形を描画することができる。
curRect :: Point -> Sig s (Singleton Mouse.Move) Rect ()
curRect p1 = Rect p1 <$%> Mouse.position
Rect p1 p2で左上の点がp1であり右下の点がp2であるような長方形を表す。なので、Rect p1 <$%> Mouse.positionとすることで左上が点p1であり右下が現在のカーソルの位置であるような長方形を持つシグナルになる。試してみよう。runBoxesが出力する値は[Box]型の値だ。
data Box = Box Rect Color
なので、表示するためにはRect型の値を[Box]型の値にしてやる必要がある。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) . (`Box` Red) <$%> curRect (100, 100)
ウィンドウ内でカーソルを動かすと、それに合わせて赤い長方形が変形するはずだ。終了するにはウィンドウを右上(あるいは左上)のxで閉じてやればいい。今度はシグナルelapsedを見てみよう。
Control.Moffy.Event.Time:Elapsed
elapsed :: Sig s (Singleton DeltaTime) DiffTime r
これは経過時間を値として持つシグナルだ。これを使うと長方形にアニメーションがつけられる。
wiggleRect :: Rect -> Sig s (Singleton DeltaTime) Rect ()
wiggleRect (Rect lu rd) = rectAtTime <$%> elapsed where
rectAtTime t = let dx = sin (realToFrac t * 5) * 15 in
Rect ((+ dx) `A.first` lu) ((+ dx) `A.first` rd)
経過時間からsin関数でdxを計算し、それをx座標に加算することで、横方向の振動というアニメーションを追加している。試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) . (`Box` Red) <$%> wiggleRect (Rect (150, 100) (300, 200))
赤い長方形が左右にゆらゆらゆれる。ウィンドウを閉じて終了させよう。ここで関数atを見てみよう。
at :: Firstable es es' (ISig s (es :+: es') a r) r' =>
Sig s es a r -> React s es' r' ->
React s (es :+: es') (Either r (Maybe a, r'))
この関数はsig `at` reactのように使い、シグナルsigのリアクトreactの終了時の値を返すリアクトを生成する。リアクトの返す値の型が多少複雑だけど、つぎのようになっている。
-
reactが終了する前にsigが終了した場合-
Left rの形でシグナルsigのモナドとしての返り値を返す
-
-
reactが終了したときにsigがまだ終了したいない場合-
reactが終了した時点でまだsigに値がないとき-
(Nothing, r')の形でreactの返り値だけ返す
-
-
reactが終了した時点で、sigに値があるとき-
(Just a, r')の形でsigのその時点での値と、reactの返り値を返す
-
-
Either r (Maybe a, r')型の返り値は、あつかいがめんどうなので、ちょっとした変換関数が用意してある。
atResult :: (r -> String) -> (r' -> String) -> Either r (Maybe a, r') ->
Either String a
この関数を使うと、より単純に
-
reactが終了した時点でsigの値が- 存在しなければ
Left "error-message" - 存在していれば
Right x
- 存在しなければ
のような単純な形に変換できる。これで左クリックしたときのカーソルの位置を取り出すことができる。
firstPoint :: React s (Mouse.Move :- Singleton Mouse.Down) Point
firstPoint = let err = const "never occur" in
either error id . atResult err err <$> Mouse.position `at` leftClick
シグナルMouse.positionはリアクトleftClickの終了時には必ず値を持つので、atの結果が値を持たないような場合にはerror "never occur"で例外を発生させるようにした。もし、これが発生したとしたら、何らかのバグがあるということだ。エラー処理ではない本質的な部分はMouse.position `at` leftClickだ。leftClickのときのマウスカーソルの位置を返すリアクトだ。つぎに関数untilを見てみよう。
until :: firstable es es' (ISig s (es :+: es') a r) r' =>
Sig s es a r -> Ract s es' r' -> Sig s (es :+: es') a (either r (a, r'))
sig `until` reactのように使い、シグナルsigに値が生じたあとリアクトreactが終了したらシグナルsigを終了させる。また、新たに生成されたシグナルの返り値として、リアクトreactが終了した時点でのシグナルsigの値とreactの返り値とをタプルにしたものを返す。reactが終了する前にsigが終了してしまったときには、Left rの形でsigのモナドとしての返り値を返す。関数untilを使って「左ボタンを離すまでのあいだカーソルの位置に対応する長方形を表示する」ような処理を書くことができる。
completeRect :: Point -> Sig s (Mouse.Move :- Singleton Mouse.Up) Rect Rect
completeRect p1 = (const $ error "never occur") `either` fst
<$> curRect p1 `until` leftUp
ここでもエラー処理を無視すると本質的な部分はcurRect p1 `until` leftUpであり、シグナルcurRectを左ボタンをはなすことで終了するような処理になる。リアクトfirstPointとシグナルcompleteRectを使うことでマウスのドラッグで長方形を描く処理が作れる。
defineRect :: Sig s (Mouse.Move :- Mouse.Down :- Singleton Mouse.Up) Rect Rect
defineRect = adjustSig . completeRect =<< waitFor (adjust firstPoint)
adjustSigやadjustは型を合わせるためにある。本質的な部分はcompleteRect =<< waitFor firstPointだ。試してみよう。
% stack ghci
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) . (`Box` Red) <$%> defineRect
ウィンドウ内で左ボタンを押下してドラッグすると長方形が表示される。左ボタンをはなすと終了する。
長方形の色を変える
中クリックで、つぎつぎに色を変えていき右クリックで終了するようなシグナルを定義する。色のリストは無限リストで表現しようと思う。ふつうのリスト型を使ってもいいのだが、美学的に無限リスト専用のリスト型を利用しようと思う。
data Infinite a = a :~ Infinite a
無限リストはNonEmpty型のリストから関数cycleで生成できる。
% stack ghci
ghci> :module + Data.List.NonEmpty
ghci> :module + Data.List.Infinite
ghci> Data.List.Infinite.take (100 :: Int) . Data.List.Infinite.cycle $ fromList "hello"
"hellohellohellohellohello...hellohello"
色の無限リストを定義する。
colorList :: Infinite BColor
colorList = cycle $ fromList [Red .. Magenta]
中クリックごとに色をつぎつぎに変えていき右クリックで終了するシグナルを定義する。
cycleColor :: Sig s (Singleton Mouse.Down) BColor ()
cycleColor = go colorList where
go (h :~ t) = do
emit h
bool (pure ()) (go t)
=<< waitFor (middleClick `before` rightClick)
試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) . (Box $ Rect (150, 100) (300, 200)) <$%> cycleColor
中クリックのたびに長方形の色が変化し右クリックで終了する。色を変化させているあいだは、「まだ長方形の色を指定している途中です」という気持ちを示すために、長方形をゆらゆらさせる。これはwiggleRectとcycleColorを組み合わせればいい。
chooseBoxColor :: Rect -> Sig s (Mouse.Down :- Singleton DeltaTime) Box ()
chooseBoxColor r = Box <$%> adjustSig (wiggleRect r) <*%> adjustSig cycleColor
Box型の値構築子BoxがBox rect colorのように長方形と色を引数に取ることを思い出そう。adjustSigは型を合わせるためにあるので、本質的な部分はBox <$%> wiggleRect <*%> cycleColorとなる。 試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) <$%> chooseBoxColor (Rect (150, 100) (300, 200))
中クリックでゆれている長方形の色が変わっていく。右クリックで終了する。つぎに、関数findを見てみよう。
find :: (a -> Bool) -> Sig s es a r -> React s es (Either a r)
関数findは与えられたシグナルの値が条件を満たすまで待つリアクトを生成する。これを使って、シグナルの値が与えられた長方形の内部の点になるまで待つリアクトを作る。
posInside :: Rect -> Sig s evs Point y -> React s evs ()
posInside rct = void . find (`inside` rct)
where inside (x, y) (Rect (l, u) (r, d)) =
(l <= x && x <= r || r <= x && x <= l) &&
(u <= y && y <= d || d <= y && y <= u)
ここで、関数indexByを見る。
indexBy ::
Firstable es es' (ISig s (es :+: es') a r) (ISig s (es :+: es') b r') =>
Sig s es a r -> Sig s es' b r' ->
Sig s (es :+: es') (a, b) (Either r (Maybe a, r'))
Firstableから始まる型制約は無視していい。シグナルを2つ引数に取り、後のほうのシグナルの値が出力された時の1つ目のシグナルの値を取り出す。関数indexByとposInsideを使うと、長方形内でのダブルクリックを待つリアクトが作れる。
drClickOn :: Rect -> React s (Mouse.Move :- Mouse.Down :- Singleton TryWait) ()
drClickOn rct = posInside rct
$ fst <$%> Mouse.position `indexBy` repeat doubler
試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> rect = Rect (150, 100) (300, 200)
ghci> runBoxes $ emit [Box rect Red] >> waitFor (drClickOn rect)
赤い長方形が表示される。長方形内を右ダブルクリックすると終了する。ここまで定義してきたシグナルを組み合わせて、ひとつのボックスが生まれてから終了するまでを表現するシグナルを定義できる。
- 左ドラッグで長方形の位置と大きさが決まる
- 左ボタンを離すと次は色を決めるフェーズに移行する
- このとき、「まだ色が決まってないよ」という気持ちで、長方形は左右にゆれる
- 中クリックで色が変わる
- 右クリックでボックスが決定する
- ボックス内で右ダブルクリックすることでボックスは終了する
box :: Sig s
(Mouse.Move :- Mouse.Down :- Mouse.Up :- DeltaTime :- Singleton TryWait)
Box ()
box = do
b <- (`Box` Red) <$%> adjustSig defineRect
adjustSig $ chooseBoxColor b
waitFor . adjust $ drClickOn b
試してみよう。
% stack ghci
ghci> :module + Control.Moffy.Samples.Boxes.Viewable
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runBoxes $ (: []) <$%> box
ボックスを作り色を決めてみよう。右クリックで色を決めたあとに長方形内で右ダブルクリックをすると終了する。これで、「ひとつのボックス」について、「生まれてから終了するまで」を表現するシグナルを作ることができた。複数のボックスを描画できるようにするにはどうしたらいいだろうか。一般的に複数の「生まれては終了するシグナル」を表現するシグナルを考える。
- あるシグナルにおける最初のエミットまで待ち、そのシグナルの残りの部分そのものをエミットする。これをくりかえす ... (1)
- エミットされた複数の「シグナルの残りの部分」を並行して走らせる ... (2)
という二段階で考える。(1)の関数を見てみよう。
spawn :: Sig s es a r -> Sig s es (ISig s es a r) r'
型ISigという新しい型が出てきた。上で見てきた「残りの部分」はemitを待ったあとの残りの部分なので、はじめから値を持っている。初めから値を持っているシグナルを表す型が型ISigだ。関数spawnはそのような「必ず初期化されているシグナル」を次々に出力するシグナルを生成する。さらに(2)の関数を見てみよう。
parList :: ((es :+: es) ~ es, Mergeable es es es) =>
Sig s es (ISig s es a r) r' -> Sig s es [a] ([r], r')
ISig型のシグナルを出力するシグナルから、ISig型のシグナルが出力するa型の値のリストを出力するシグナルを生成する。リストは、もともとのシグナルが新しい値を出力するたびにそれが要素に加わり、終了するたびにそれがリストから消されていくという動きをする。
boxes :: Sig s
(Mouse.Move :- Mouse.Down :- Mouse.Up :- DeltaTime :- Singleton TryWait)
[Box] ()
boxes = void $ parList (spawn box)
全体のコードはBoxesにある。
試してみよう。
% stack ghci
ghci> :module + Control.Moffy.Samples.Boxes.Run.Gtk3
ghci> runBoxes boxes
複数のボックスが並行して描画される。
- 左ボタンを押しながらドラッグすると赤い長方形ができる
- できた長方形は左右にゆらゆらゆれる
- 中クリックで色が変わる
- 右クリックで色が決まる
- 長方形内で右ダブルクリックすると長方形が消える
このような一連の流れが並行して動作する。
- 右クリックしないで長方形をどんどん作ると色が決まっていない長方形が複数できる
- どれもゆらゆらゆれている
- 中クリックですべての長方形の色が変わる
- 新しい長方形を作る前に中クリックを何回かすると、次の長方形とは色がずれる
- 右ダブルクリックするとクリックした点を含むすべての長方形が消える
ウィンドウを閉じると終了する。
"Who to follow"推薦ボックスの例
リアクティブプログラミングとは何だったのか
あなたか求めていたリアクティブプログラミング入門
上記の記事であつかっている例を実装してみる。
- もともとの題材がFRPに向いているわけではない
- そもそもクライアントサイドでFRPに向いている題材があるのかという話も
- 実装の仕方も、わりとムリヤリRPを使っている感じがある
- 中心となる部分は記事のやりかたに寄せた
- 周辺的な部分をすこし拡張した
- 画像の読み込み中にプログレスバーを出すようにした
- ユーザー情報の読み込み数の上限に達したときに、いつまで待つかを表示するようにした
- もとのコードではクライアント側の話なのでクリックなどは、もともとあるものを使っている
- ローカルな環境でありかつツールキット特有の話を避けたいので、クリックなども手づくりする
定数などを定義する
package.yamlのdependenciesに以下のパッケージを追加する。
- bytestring
- text
- time
- unordered-containers
- hashable
- aeson
- JuicyPixels
...
dependencies:
- base >= 4.7 && < 5
- moffy
...
- extra-data-yj
- bytestring
- text
- time
- unordered-containers
- hashable
- aeson
- JuicyPixels
...
必要なモジュールを導入し、定数などを定義する。
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections, OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Followbox where
import Prelude hiding (break, repeat, scanl)
import Control.Monad (void, forever, (<=<))
import Control.Moffy
import Control.Moffy.Event.Lock
import Control.Moffy.Samples.Event.Random
import Control.Moffy.Samples.Event.Mouse qualified as Mouse
import Control.Moffy.Samples.Event.Area
import Control.Moffy.Samples.Viewable.Basic
import Control.Moffy.Samples.Followbox.Event
import Control.Moffy.Samples.Followbox.Clickable
import Control.Moffy.Samples.Followbox.ViewType
import Control.Moffy.Samples.Followbox.TypeSynonym (ErrorMessage)
import Data.Type.Set
import Data.Type.Flip ((<$%>), (<*%>))
import Data.OneOfThem
import Data.HashMap.Strict qualified as HM
import Data.Bool
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Char8 qualified as BSC
import Data.Text qualified as T
import Data.Time (utcToLocalTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Aeson (Object, Value(..), eitherDecode)
import Data.Aeson.KeyMap (toHashMap)
import Text.Read (readMaybe)
import Codec.Picture qualified as P
userMax :: Int
userMax = 2 ^ (27 :: Int)
titlePos, refreshPos, resetTimePos :: Position
titlePos = (50, 44)
refreshPos = (600, 65)
resetTimePos = (100, 470)
defaultFont :: FontName
defaultFont = "sans"
middleSize, largeSize :: FontSize
middleSize = 30; largeSize = 40
avatarSizeX, avatarSizeY :: Double
(avatarSizeX, avatarSizeY) = (80, 80)
avatarPos, namePos :: Int -> Position
avatarPos n = (100, 120 + 120 * fromIntegral n)
namePos n = (210, 150 + 120 * fromIntegral n)
crossSize :: Double
crossSize = largeSize / 2
crossPos :: Int -> Position
crossPos n = (500, 162 + 120 * fromIntegral n)
crossMargin :: Double
crossMargin = 5
crossArea :: Int -> (Position, Position)
crossArea (crossPos -> (l, t)) = (
(l - crossMargin, t - crossMargin),
(r + crossMargin, b + crossMargin) )
where (r, b) = (l + crossSize, t + crossSize)
barColor :: Color
barColor = Color 0x32 0xcd 0x32
nameColor :: Color
nameColor = Color 0x00 0xcd 0x00
noRateLimitRemaining,
noRateLimitReset, noAvatarAddress, noLoginName :: (Error, String)
noRateLimitRemaining = (NoRateLimitRemaining, "No X-RateLimit-Remaining header")
noRateLimitReset = (NoRateLimitReset, "No X-RateLimit-Reset header")
noAvatarAddress = (NoAvatarAddress, "No Avatar Address")
noLoginName = (NoLoginName, "No Login Name")
必要なモジュールを導入し、いくつかの定数を定義した。タイポなどがないことの確認のためにbuildしておこう。
% stack build
定数は以下のようになっている。
- 読み込むページの最初のユーザーIDの最大値
- 表示する文字やリンクの位置
- 表示する文字のフォントやサイズ
- 表示するアバター画像のサイズと位置
- 表示するユーザー名の位置
- ユーザーを入れ替えるためにクリックする「x」の
- 大きさと位置
- 表示される領域より外側でクリックが有効となる縁の幅
- クリックが有効な範囲
- プログレスバーの色
- ユーザ名の色
- 受け取ったJSONに必要な項目がなかったときのエラー値
表示される値を組み立てるツール
最終的に定義されるシグナルは表示部によって表示される値を持つ。そのような値を組み立てるツールを定義する。
text :: Color -> FontSize -> Position -> T.Text -> View
text c fs p = View . (: []) . expand . Singleton . Text' c defaultFont fs p
line :: Color -> LineWidth -> Position -> Position -> View
line c w p q = View . (: []) . expand . Singleton $ Line' c w p q
image :: Position -> Png -> View
image p = View . (: []) . expand . Singleton . Image' p
ここで型Viewは次のようになっている。
newtype View = View [View1]
type View1 = OneOfThem (VText :- Line :- Image :- 'Nil)
型OneOfThemはある種のEither型の拡張である。型引数として型の集合を取り、それに含まれる型のうちのどれかの型の値を持つような型だ。値構築子Singletonによって、OneOfThem (Foo :- 'Nil)のような「型引数に単一の型を含む集合」を取るようなOneOfThem型の値が作られる。それを関数expandで拡張することで、OneOfThem (Foo :- Bar :- Baz :- 'Nil)のような型の値を作ることができる。ここでは表示部によって表示できる形で、文字列、直線、画像を生成するツールを定義している。
JSONのオブジェクトを取得するリアクト
ランダムなユーザーIDから始まる複数のユーザーの情報を含むページをJSONのオブジェクトとして取得するリアクトを定義する。
getObjs :: ReactF s (Either String [Object])
getObjs = do
n <- adjust $ getRandomR (0, userMax)
(hdr, bdy) <- adjust . httpGet $ api n
case (rmng hdr, rst hdr) of
(Just rmn, _) | rmn > (0 :: Int) -> pure $ eitherDecode bdy
(Just _, Just t) -> sleep t >> getObjs
(Just _, Nothing) -> err noRateLimitReset >> getObjs
(Nothing, _) -> err noRateLimitRemaining >> getObjs
where
api = ("https://api.github.com/users?since=" <>) . T.pack . show @Int
rmng = (read . BSC.unpack <$>) . lookup "X-RateLimit-Remaining"
rst = ut <=< lookup "X-RateLimit-Reset"
ut = (posixSecondsToUTCTime . fromInteger <$>) . readMaybe . BSC.unpack
err = adjust . uncurry raiseError
sleep t = adjust (beginSleep t) >> adjust endSleep
関数getObjsが複雑になってしまっているのは、APIの使用回数の制限に対応しているからだ。ユーザー認証なしでGitHubのAPIをたたく場合、1時間に60回という制限がある。わりとすぐにひっかかってしまう制限なので、それには対応するコードとした。このリアクトについて説明する。まず型ReactFは次のように定義されている。
Control.Moffy.Samples.Followbox.Event: Followbox Event
type ReactF s r = React s FollowboxEv r
type FollowboxEv = SetArea :- GetArea :-
GetThreadId :- LockEv :+: RandomEv :+: ... :- 'Nil
必要なイベントをまとめたFollowboxEvを型Reactの型引数に指定した型シノニムだ。do記法のなかの1行目から見てみよう。
n <- adjust $ getRandomR (0, userMax)
関数adjustは型を合わせているだけだ。getRandomRは次のような型になっている。
Control.Moffy.Samples.Event.Random: Get Random
getRandomR :: Random a => (a, a) -> React s RandomEv a
リアクトgetRandomRは「イベントを発生させる部分」であるハンドルにStdGen型の乱数の種を要求し、それを使ってランダムな値を生成する。また、更新された乱数の種を保存するようにハンドルに頼む。これらは、「イベントの要求」と「イベントの発生」という仕組みを流用して実装されている。リアクトは「純粋」でありIOを含まないため、そのような仕組みが必要になる。つぎの行も同様の仕組みを使っている。
(hdr, bdy) <- adjust . httpGet $ api n
ハンドルに、URLで指定したページの取得を「イベントの要求」の仕組みで依頼し「イベントの発生」という形でページを受け取る。
Control.Moffy.Samples.Followbox.Event: Http Get
それから取得したページのヘッダーによって分岐させている。
case (rmng hdr, rst hdr) of
(Just rmn, _) | rmn > (0 :: Int) -> pure $ eitherDecode body
(Just _, Just t) -> sleep t >> getObjs
(Just _, Nothing) -> err noRateLimitReset >> getObjs
(Nothing, _) -> err noRateLimitRemaining >> getObjs
この分岐は「APIの利用回数の制限」に関連した分岐だ。まず、読み込める回数の残りが1以上であれば、ユーザーのリストは取得できたということなので、関数eitherDecodeでJSONオブジェクトとしてパースする。そうでない場合には、回数制限がリセットされる時刻まで待ち、再度リアクトgetObjsを走らせる。回数制限がリセットされる時刻などが得られらなかったときにはerrによってエラー情報をハンドルにわたす。ハンドル側はエラーイベントを発生させる。リアクトgetObjsは成功すればJSONオブジェクトをEither String型にくるんで返す。試すのに次のような補助関数を作成する。
multiLine :: Show a => Int -> a -> View
multiLine n = text (Color 0 0 0) 15 (15, 15) . T.pack . unlines . sep . show
where
sep "" = []
sep cs = take n cs : sep (drop n cs)
試してみよう。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Followbox.Run.Gtk3
ghci> :module + Control.Monad
ghci> runFollowbox "" . void $ (emit =<< waitFor (multiLine 120 <$> getObjs)) >> waitFor never
["51"]
複数のユーザーの情報を含むJSONのオブジェクトが表示される。より使いやすいgetObj'を定義する。
getObjs' :: ReactF s [Object]
getObjs' = getObjs >>= \case
Left em -> adjust (raiseError NotJson em) >> getObjs'
Right [] -> adjust (raiseError EmptyJson "Empty JSON") >> getObjs'
Right os -> pure os
JSONオブジェクトのリストとしてパースできなかった場合と、リストが空である場合にエラーイベントを発生させるようハンドルに依頼する。
ユーザーのアバター画像とログイン名を取得するシグナル
ユーザーのアバター画像とログイン名を取得する。基本的にはリアクトの返り値として取得すれば十分であるが、画像の取得と変換に、それなりに時間がかかるのでプログレスバーを表示したい。そのため、リアクトではなく「いま何枚目の画像を取得しているか」を値として持つシグナルを定義したい。1人のユーザーに対しては数値1をシグナルの値とし、複数のユーザーに対してはそれらを加算すればいい。
avatar :: T.Text -> SigF s Int (Either (Error, ErrorMessage) Png)
avatar url = emit 1 >> waitFor (epng . convert . snd <$> adjust (httpGet url))
where
epng = either
(Left . (NoAvatar ,))
(Right . Png avatarSizeX avatarSizeY)
convert img = LBS.toStrict . P.encodePng . P.convertRGB8
<$> P.decodeImage (LBS.toStrict img)
ローカル関数convertはバイト列を画像として読み込みPNG形式のバイト列に変換する。epngはエラーメッセージにはError型の値NoAvatarを追加し、エラーではなければサイズを追加しPng型のデータに加工している。シグナルavatarは与えられたURLの内容をPNG形式のデータとして返す。その時に1をシグナルの値として出力している。これを使って、複数のユーザーのアバター画像とログイン名を取得するシグナルを定義する。
users :: SigF s Int [(Png, T.Text)]
users = waitFor (mapM ex2 <$> getObjs') >>= err \(unzip -> (avs, nms)) ->
sequence <$> ssum (avatar `mapM` avs) >>= err (pure . (`zip` nms))
where
ex2 (toHashMap -> o) = (,)
<$> extract "avatar_url" o noAvatarAddress
<*> extract "login" o noLoginName
ssum = scanl (+) 0
err = either \e -> waitFor (adjust (uncurry raiseError e)) >> users
extract k o e =
case HM.lookup k o of Just (String v) -> Right v; _ -> Left e
ext2はJSONオブジェクトからキー"avatar_url"と"login"に対応する値を取り出す。errは値の取り出しに失敗した場合の処理を行う。アバター画像のURLとログイン名のリストをunzipでそれぞれ別の2つのリストにしてから、アバター画像を生成したうえで再度zipでまとめている。ssumはPNG画像を生成するシグナルから出力される値を、それぞれの時点での合計に変換している。関数scanlはつぎのような型になっている。
scanl :: (b -> a -> b) -> b -> Sig s es a r -> Sig s es b r
プログレスバーを表示用データに変換する関数を定義する。
bar :: Int -> View
bar p = line barColor 50 (80, 300) (80 + fromIntegral p * 25, 300)
ユーザーのアバター画像とログイン名を表示用データに変換する。
userView :: Int -> (Png, T.Text) -> View
userView n (avt, nm) =
image (avatarPos n) avt <>
text nameColor largeSize (namePos n) nm <>
cross n
cross :: Int -> View
cross (crossPos -> (l, t)) = line white 4 lt rb <> line white 4 lb rt
where
(lt, lb, rt, rb) = ((l, t), (l, b), (r, t), (r, b))
(r, b) = (l + crossSize, t + crossSize)
関数crossは「x」の表示に使う。ここではクリックできないが、あとでクリックできるようにする。ユーザーのリストからいくつかピックアップして表示用データにする関数を定義する。
userViewPick :: Int -> [Int] -> [(Png, T.Text)] -> View
userViewPick _ [] _ = View []
userViewPick p (i : is) pns =
userView p (pns !! i) <> userViewPick (p + 1) is pns
試してみる。
% stack ghci
ghci> :module + Control.Moffy
ghci> :module + Control.Moffy.Samples.Followbox.Run.Gtk3
ghci> :module + Data.Type.Flip
ghci> runFollowbox "" $ (emit . userViewPick 0 [5, 10, 23] =<< (bar <$%> users)) >> waitFor never
プログレスバーが表示されたあとユーザーのアバター画像とログイン名が表示される。
候補の表示とその入れ替え
3人の候補を表示しユーザーのクリックによって、それらの候補を入れ替える。まずは、ウィンドウ上の特定のエリアのクリックを取得するリアクトを定義する。
leftClick :: React s (Singleton Mouse.Down) ()
leftClick = bool leftClick (pure ()) . (== Mouse.ButtonPrimary) =<< Mouse.down
clickArea :: (Point, Point) -> ReactF s ()
clickArea ((l, u), (r, d)) = void . adjust
. find inside $ fst <$%> repeat Mouse.move `indexBy` repeat leftClick
where inside (x, y) = l <= x && x <= r && u <= y && y <= d
長方形を描画する例で見たのと同様だ。マウスのカーソルの位置についてindexByで左クリックした時点のものだけを取り出して、さらにfindで特定のエリア内でクリックされたという事象を待つようにする。Refreshボタンの押下を処理するシグナルを定義する。
refresh :: Clickable s -> SigF s (Maybe (Either Int [(Png, T.Text)])) ()
refresh rfs = forever do
emit Nothing
us <- Just . Left <$%> users
emit . Just $ Right us
waitFor . adjust $ click rfs
emit Nothingで画面を空にする。シグナルusersでアバター画像とログイン名を取得する。取得しているあいだはLeft値として画像の読み込みの進行状況を出力する。アバター画像とログイン名をRight値として出力する。click rfsはRefreshボタンの押下を待つリアクトだ。この全体を永遠にくりかえす。
close :: LockId -> Int -> SigF s Int ()
close lck i = forever do
emit =<< waitFor
(withLock lck (adjust $ getRandomR (0, 29) :: ReactF s Int))
waitFor . clickArea $ crossArea i
1人のユーザーの情報を閉じる処理だ。シグナルcloseは複数のユーザーのリストから1人を選ぶためのランダムなインデックスを値として持つ。イベントは並行に処理されているすべてのリアクトやシグナルに同時に与えられるため、何も考えずに実装すると3つの領域に同じユーザーが並んでしまう。それを避けるためにwithLockによって、排他処理をしている。
field :: SigF s View ()
field = do
rfs <- waitFor $ link refreshPos "Refresh"
lck <- waitFor $ adjust newLockId
let frame = title <> view rfs
emit frame
(frame <>) <$%> ((\a b c -> a <> b <> c)
<$%> (chooseUser 0 <$%> refresh rfs <*%> close lck 0)
<*%> (chooseUser 1 <$%> refresh rfs <*%> close lck 1)
<*%> (chooseUser 2 <$%> refresh rfs <*%> close lck 2))
where
title = text white largeSize titlePos "Who to follow"
link p t = clickableText p
<$> adjust (withTextExtents defaultFont middleSize t)
chooseUser :: Int -> Maybe (Either Int [(Png, T.Text)]) -> Int -> View
chooseUser _ (Just (Left i)) _ = bar i
chooseUser n (Just (Right us)) i = userView n (us !! (i `mod` length us))
chooseUser _ Nothing _ = View []
シグナルfieldが、Followboxのほぼ完成形だ。do記法内のはじめの3行はRefreshボタンとロック用の値、そしてアプリケーションのフレームを用意しているだけだ。4行目からは、まずemit frameで空のフレームだけを表示する。その後もフレームは常に表示されるので(frame <>) <$%>によって、全体に付加している。refresh rfsはRefreshボタンの押下によってユーザーのリストを入れ替える処理を行い、clock lck xは「x」印による個々のユーザの入れ替えを担当する。chooseUserはrefresh rfsのその時の値によって、プログレスバーの表示、個々のユーザーの表示、表示を消すといった処理をする。これでほぼ出来上がりだ。
% stack ghci
ghci> :module + Control.Moffy.Samples.Followbox.Run.Gtk3
ghci> runFollowbox "" field
Refreshボタンをクリックするとプログレスバーが表示され新しいユーザーリストが読み込まれる。
いつまで待てばいいかを表示
最後に「おまけ」として、もしもAPIの制限を超えてしまったときに、「いつまで待てばいいか」を表示するようにする。
resetTime :: SigF s View ()
resetTime = forever do
emit $ View []
emit =<< waitFor do
(t, tz) <- (,) <$> adjust checkBeginSleep <*> adjust getTimeZone
pure . text white middleSize resetTimePos . T.pack
$ "Wait until " <> show (utcToLocalTime tz t)
waitFor $ adjust endSleep
followbox :: SigF s View ()
followbox = (<>) <$%> field <*%> resetTime
checkBeginSleepはBeginSleepイベントを捕捉する。そこで得られた時刻を表示するようになっている。
% stack ghci
ghci> :module + Control.Moffy.Samples.Followbox.Run.Gtk3
ghci> runFollowbox "" followbox
コードの全体はFollowboxにある。
Refreshを1時間以内に60回クリックすると次のように表示される。
Followboxのまとめ
一通り実装したがいくつか注釈がある。
- シグナルやリアクトは純粋なのでIOについては、「イベントの要求」「イベントの発生」という仕組みを流用した
- シグナル同士の演算もまた純粋である必要があり、多少もともとのコードと挙動が異なっているところがある
- ユーザーのリストから個々のユーザーを選ぶためのランダムな整数はRefreshボタンによって更新されない
mFRPは何に使えるか
GUIプログラムを書くとき、つぎのような感じのコードを書きたくなる。
update :: State -> Input -> State
view :: State -> View
input :: IO Input
output :: View -> IO ()
run :: State -> IO ()
run s0 = do
output $ view s0
i <- input
run (update s0 i)
純粋な関数updateにユーザーの入力を与えることによって状態を更新していくということだ。そうすることで全体を次のような2つの部分に分けることができる。
- 状態変化や入出力はあるが単純な部分
- 複雑だけど純粋な部分
そのような2つの部分に分けることで、どちらも「まあまあ、あつかいやすい」感じになる。この場合のState型の値や関数updateの部分がシグナルに対応する。そのような純粋な部分を、それぞれがイベントを受けとる複数の部品を組み合わせて作ることができる。
なので、GUIライブラリに依存しない、たとえばテトリスのロジックの部分だけを独立して実装できるとか、そういう用途が考えられるかもしれない。使うときは「イベントを発生させる部分」と「描画の部分」を別に作ってやればいいといった感じで。
まとめ
モナディック関数型リアクティブプログラミングの一実装であるmoffyについて紹介した。
Discussion