９．Bar Tab
知っている人は少ないと思われる用語だが、アメリカでレストランで食事をしようとする時に、Bar Tabという言葉に出くわす。日本だと、レストランで食事をしようとする時は、そのまま席に招かれる。しかし、アメリカでは、食事をする前に、バーで飲物といっても多くの場合は酒だが飲んでから、その後、席について食事という場合も多い。バーで酒を飲むとき、支払いの仕方に二通りある。現金払いと付け払いだ。現金払いの時は、飲物が出てくるたびに支払いをするが、付け払いの場合には、最後に一括で支払いをすることになる。後者の場合、飲んだものの明細が示されるが、これがBar Tabである。
このような部面に出くわした時に、困らないようにするために、次のフレーズを覚えておくとよいだろう。
"Would you like to open a tab?" （つけで支払いますか。）
"I'll pay cash on delivery." （その都度、現金で支払います。）
"May I close may tab?" （勘定を締めてください。）
さて、今回は、Bar Tabを作成することを考える。Bar Tabは注文するたびに明細が一つ増える。また、間違って記入した場合にはこれを取消すことができる（但し、ここでは簡単にするために最後の明細だけを取り消せるものとする）。また、合計金額も同時に表示する。但し、明細のいずれかに金額が入っていないときは、合計金額は表示されない。出来上がりは次のようになる。
９．１ ユーザ・インタフェース
今回は、多くのウィジェットを用いてユーザ・インタフェースを作成する。
まず、用意するのはフレームである。これはfと名前を付けプログラムの中で利用できるようにする。フレームにはBar Tabと表示するようにしよう。
また、Tabの合計を示すSum:と合計金額を表示するためのスタティック・テキストを用意する。これらは、msg, totalと名前を付けプログラムの中で利用できるようにする。
さらに、明細を増やすためのボタンと、減らすためのボタンを用意し、これらには、add, removeと名前を付けプログラムの中で利用できるようにする。
プログラムは次のようになる。
f <- frame [text := "Bar Tab"] msg <- staticText f [ text := "Sum:" ] total <- staticText f [] add <- button f [text := "Add"] remove <- button f [text := "Remove"]
９．２ イベント・ネットワークの構築
それでは、入力、イベント・グラフ、出力からなるイベント・ネットワークを構築しよう。
入力
入力は、ボタンが押された時に生じる。明細を増やすものと減らすものとの二つのボタンを用意すればよい。それぞれは、eAdd,eRemoveと呼べるようにする。
eAdd <- event0 add command eRemove <- event0 remove command
イベント・グラフ
次はイベント・グラフの作成である。これは、ボタンが押された時の振舞いを決めればよい。そこで、それぞれのボタンが押された時のイベント・グラフを作成し、それらをあわせることで求めている振舞いを作成しよう。
最初に、明細を追加するためのボタンが押された時のイベント・グラフを考える。これは、ボタンが押された時、空のエントリーを作成する。空のエントリーは次のプログラムで用意される。これは、文字の入力ができる箱（エントリー）とその中の文字（初期値は空）のタプルを定める。これは、ボタンなどと同様にウィジェットである。
let newEntry :: MomentIO (TextCtrl (), Behavior String) newEntry = do wentry <- liftIO $ entry f [] bentry <- behaviorText wentry "" return (wentry, bentry)
なお、behaviorTextは次のように定義されている。簡単に言うと、文字が変わるごとにイベントが生じる。すなわち、明細に新たに数字が与えられるたびに、イベントが生じ、結果として、入力された数字が表示される。さらには、後で示すが、新たな合計が計算されることとなる。
behaviorText :: TextCtrl w -> String -> MomentIO (Behavior String) behaviorText w s = stepper s =<< eventText w eventText :: TextCtrl w -> MomentIO (Event String) eventText w = do addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 onText) fromAddHandler $ filterIO (const $ WXCore.textCtrlIsModified w) $ mapIO (const $ get w text) addHandler
また、エントリーの作成はnewEntryを用いて次のように行われる。
eNewEntry <- execute $ newEntry <$ eAdd
なお、<$は以下を意味する。
次に、明細を削除するためのボタンが押された時のイベント・グラフを考える。これは、明細が存在するときのみ、意味があるので、イベント・ネットは次のようになる。
let eDoRemove = whenE (not . null <$> bEntries) eRemove
ボタンが押された時のイベントは、エントリーに料金を書き込む処理を行うエントリーの追加と、最後のエントリーを消去するエントリーの削除のイベントを足したものになる。これは次のようになる。なお、initはリストの最後の要素を取り除いたリストを返す。これにより、明細の最後が削除される。
(eEntries :: Event [(TextCtrl (), Behavior String)]) <- accumE [] $ unions [ (\x -> (++ [x])) <$> eNewEntry , init <$ eDoRemove ]
関数stepperを用いてイベントを振舞いに変えると次のようになる。
bEntries <- stepper [] eEntries
なお、stepperは次の関数である。
出力
エントリーに関係する出力を定義する。エントリーの追加は、eNewEntryを定めたときに、executeで実行している。このため、エントリーの削除のボタンが押された時に、エントリーが減るようにすればよいので、次のようになる。なお、eDoRemoveでエントリーは一つ減るが、表示の方は残骸が残っているので、visibleを偽にする（エントリーはタプルで構成されていて、最初の要素は制御になっているので、ここの部分で表示しないようにする）。
reactimate $ ((\w -> set w [ visible := False]) . fst . last) <$> bEntries <@ eDoRemove
次に出力を求めよう。
最初にエントリーから金額を抜き出す関数を考える。各エントリーはタプルで構成され、最初の要素はエントリーの制御に関するもの、二番目の要素は内容、即ち、料金が入っている。そこで、それぞれの二番目の要素を抜き出せばよいので、次のようになる。
ePrices :: Event [Behavior Number] ePrices = map (fmap readNumber . snd) <$> eEntries
次に、フレーム上に書き込むボタン、エントリなどのレイアウトを定める。これには、タプルの最初の要素を用いる。
bLayout :: Behavior Layout bLayout = mkLayout . map fst <$> bEntries
ボタン、エントリーなどの物理的な大きさは次のように定める。
mkLayout entries = margin 10 $ column 10 $ [row 10 [widget add, widget remove]] ++ map widget entries ++ [row 10 [widget msg, minsize (sz 40 20) $ widget total]]
最後に合計金額は次のようになる。
bTotal :: Behavior Number bTotal = switchB (pure Nothing) $ (fmap sum . sequenceA) <$> ePrices
これらを用いて、合計とレイアウトの出力は以下のようになる。
sink total [text :== showNumber <$> bTotal] sink f [layout :== bLayout]
９．３ プログラム全体
プログラムは、このホームページに掲載されいるが、転載する。
{----------------------------------------------------------------------------- reactive-banana-wx Example: Bar tab with a variable number of widgets ------------------------------------------------------------------------------} {-# LANGUAGE ScopedTypeVariables #-} -- allows pattern signatures like -- do -- (b :: Behavior Int) <- stepper 0 ... {-# LANGUAGE RecursiveDo #-} -- allows recursive do notation -- mdo -- ... {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} import Data.Maybe (listToMaybe) import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX import Data.Traversable (sequenceA) {----------------------------------------------------------------------------- Main ------------------------------------------------------------------------------} main :: IO () main = start $ do f <- frame [text := "Bar Tab"] msg <- staticText f [ text := "Sum:" ] total <- staticText f [] add <- button f [text := "Add"] remove <- button f [text := "Remove"] let networkDescription :: MomentIO () networkDescription = mdo eAdd <- event0 add command eRemove <- event0 remove command let newEntry :: MomentIO (TextCtrl (), Behavior String) newEntry = do wentry <- liftIO $ entry f [] bentry <- behaviorText wentry "" return (wentry, bentry) eNewEntry <- execute $ newEntry <$ eAdd let eDoRemove = whenE (not . null <$> bEntries) eRemove (eEntries :: Event [(TextCtrl (), Behavior String)]) <- accumE [] $ unions [ (\x -> (++ [x])) <$> eNewEntry , init <$ eDoRemove ] bEntries <- stepper [] eEntries reactimate $ ((\w -> set w [ visible := False]) . fst . last) <$> bEntries <@ eDoRemove let ePrices :: Event [Behavior Number] ePrices = map (fmap readNumber . snd) <$> eEntries bLayout :: Behavior Layout bLayout = mkLayout . map fst <$> bEntries mkLayout entries = margin 10 $ column 10 $ [row 10 [widget add, widget remove]] ++ map widget entries ++ [row 10 [widget msg, minsize (sz 40 20) $ widget total]] bTotal :: Behavior Number bTotal = switchB (pure Nothing) $ (fmap sum . sequenceA) <$> ePrices sink total [text :== showNumber <$> bTotal] sink f [layout :== bLayout] network <- compile networkDescription actuate network {----------------------------------------------------------------------------- Utilities ------------------------------------------------------------------------------} type Number = Maybe Double instance Num Number where (+) = liftA2 (+) (-) = liftA2 (-) (*) = liftA2 (*) abs = fmap abs signum = fmap signum fromInteger = pure . fromInteger readNumber :: Read a => String -> Maybe a readNumber s = listToMaybe [x | (x,"") <- reads s] showNumber :: Maybe Double -> String
