Grapefruit電卓
Grapefruitが気になってしょうがないので、おもちゃの電卓を書いてみた。
GrapefruitはFRPライブラリの一つで、定期的なポーリングを必要としないpush型の設計でありながら、push型FRPにありがちな問題をいくつか解消しているのが売りらしい。
- ループのある回路を正しく扱える
- 同時に発生した複数のイベントを正しく扱える
- シグナルを第一級の値として使える*1
説明を読んでいる限りでは、GUIの書き方としてかなり理想に近いように思える。
コード
{-# LANGUAGE Arrows #-} import Control.Applicative as Applicative import Control.Arrow as Arrow import Control.Monad.State import Control.Monad.Cont import Control.Monad.Trans import Data.Monoid import Data.Maybe import Data.Ratio import FRP.Grapefruit.Signal as Signal import FRP.Grapefruit.Signal.Discrete as DSignal hiding(map) import FRP.Grapefruit.Signal.Segmented as SSignal import FRP.Grapefruit.Record as Record import Graphics.UI.Grapefruit.Comp as UIComp import Graphics.UI.Grapefruit.Item as UIItem import Graphics.UI.Grapefruit.Circuit as UICircuit import Graphics.UI.Grapefruit.Backend.Std as StdUIBackend import Graphics.UI.Grapefruit.GTK import Text.Printf -- 回路全体 mainCircuit :: (StdUIBackend uiBackend) => UICircuit Window uiBackend era () (DSignal era ()) mainCircuit = proc _ -> do X :& Closure ::= closure `With` _ <- window `with` boxed Vertical boxContent -< X :& Title ::= pure "toy calc" `With` () returnA -< closure -- トップレベルウィンドウの内部の回路 boxContent :: (StdUIBackend uiBackend) => UICircuit Widget uiBackend era () () boxContent = proc _ -> do rec X <- just label -< X :& Text ::= txt let txt = fmap showState $ SSignal.scan initialState nextState cmd cmd <- signalerMatrix mat -< () returnA -< () where mat = map (map $ uncurry $ simpleButton) [ [("C", Clear), ("AC", AllClear), ("=", Equal)] , [dig 7, dig 8, dig 9, ("/", Op Slash)] , [dig 4, dig 5, dig 6, ("*", Op Star)] , [dig 1, dig 2, dig 3, ("-", Op Minus)] , [dig 0, ("+/-", Sign), (".", Dot), ("+", Op Plus)] ] dig n = (show n, Digit n) -- シグナルを生成するUI回路を縦横に並べる signalerMatrix :: (StdUIBackend backend) => [[UICircuit Widget backend era () (DSignal era a)]] -> UICircuit Widget backend era () (DSignal era a) signalerMatrix tbl = tie Vertical $ map (tie Horizontal) tbl where tie ori xs = boxed ori $ arr (const mempty) >>> foldA mappend xs -- UI回路をboxに入れる boxed :: (StdUIBackend backend, UIComp uiComp) => Orientation -> UICircuit Widget backend era i o -> uiComp Widget backend era i o boxed ori content = arr (X `With`) |>> body >>| arr (\(X `With` r) -> r) where body = StdUIBackend.box ori `with` content -- ラベルが一定のボタン simpleButton :: (StdUIBackend backend, UIComp uiComp) => String -> a -> uiComp Widget backend era () (DSignal era a) simpleButton label val = (arr $ const $ X :& Text ::= pure label) |>> just pushButton >>| (arr $ \(X :& Push ::= p) -> fmap (const val) p) foldA :: (Arrow a) => (acc -> c -> acc) -> [a () c] -> a acc acc foldA f [] = arr id foldA f (x:xs) = proc acc -> do v <- x -< () foldA f xs -< f acc v -- 電卓のロジック。やけに長い -- 明示的な状態遷移表を書いてもいいが、Continuationモナドを使って手続き的に書いてみた data Command = Digit Int | Op Op | Dot | Sign | Equal | Clear | AllClear deriving (Show, Eq) data Op = Plus | Minus | Star | Slash deriving (Show, Eq) data CalcState = CS String (Command -> CalcState) type CalcProc = StateT String (Cont CalcState) showState :: CalcState -> String showState (CS s _) = s initialState :: CalcState initialState = runCont (evalStateT calcMain "") $ error "unexpected termination of calc process" nextState :: CalcState -> Command -> CalcState nextState (CS _ f) = f getCommand :: CalcProc Command getCommand = do current <- get lift $ Cont $ \k -> CS current k display :: CalcNum -> CalcProc () display = put . showNum calcMain :: CalcProc () calcMain = display 0 >> getNum >>= loop where loop (n0, c) = case c of AllClear -> calcMain Equal -> getNumWith n0 >>= loop Op op -> do display n0 (n1, c1) <- getNum loop (evalOp op n0 n1, c1) evalOp :: Op -> CalcNum -> CalcNum -> CalcNum evalOp op = case op of Plus -> (+) Minus -> (-) Star -> (*) Slash -> (/) getNum :: CalcProc (CalcNum, Command) getNum = getCommand >>= handleNum False 0 getNumWith :: CalcNum -> CalcProc (CalcNum, Command) getNumWith n = do display n c <- getCommand case c of Sign -> getNumWith (-n) Op _ -> return (n, c) Equal -> return (n, c) _ -> handleNum False 0 c handleNum :: Bool -> Integer -> Command -> CalcProc (CalcNum, Command) handleNum negative n c = case c of Digit k -> go negative $ 10 * n + fromIntegral k Clear -> go False 0 Sign -> go (not negative) n Dot -> getNumDot negative n _ -> return (fromIntegral $ eval negative n, c) where go negative n = do put $ show $ eval negative n getCommand >>= handleNum negative n eval negative n = if negative then -n else n getNumDot :: Bool -> Integer -> CalcProc (CalcNum, Command) getNumDot = loop (0::Int) 0 where loop pos frac negative int = do put $ if pos == 0 then printf "%d." (sgn int) else printf "%d.%0*d" (sgn int) pos frac c <- getCommand case c of Digit k -> loop (pos+1) (10*frac + fromIntegral k) negative int Clear -> display 0 >> getNum Sign -> loop pos frac (not negative) int Dot -> loop pos frac negative int _ -> return (value, c) where value = sgn (fromInteger int + fromInteger frac * 0.1^pos) sgn :: (Num a) => a -> a sgn = if negative then negate else id type CalcNum = Rational showNum :: CalcNum -> String showNum z = show int ++ frac where int = truncate z fracv = abs $ z - fromIntegral int frac = if fracv == 0 then "" else tail $ printf "%f" (fromRational fracv :: Double) -- main。ここで初めてGTKへの依存が導入される main = run GTK mainCircuit
こういう感じになる。
感想
- UI部分のコードが長ったらしい。特にレコード操作
- 型名が長ったらしい*2
- 上記のコードは、mainを除いて一切GUIバックエンド(GTK)に依存しない形になっている。それ自体は良いのだが、GTKの機能を直接呼ぼう思うと相当面倒なようだ(標準のpushButtonなどが使えない)
- boxを使うとレイアウトの微調整ができない。電卓のボタンが均一の大きさにならないのはかなり格好悪い
総じてGUI部分が使いにくい印象だった。ここはまだ概念実証の段階なのかもしれない。一方、コアであるFRP部分は良さそうだが、電卓では単純すぎて詳しいことが分からない。
おまけ
Hackageからダウンロードしたままでは手元のGHC 6.12.3でビルドできなかったので、以下の変更を加えた。
diff -ur grapefruits-orig/grapefruit-frp-0.0.0.0/grapefruit-frp.cabal grapefruits/grapefruit-frp-0.0.0.0/grapefruit-frp.cabal --- grapefruits-orig/grapefruit-frp-0.0.0.0/grapefruit-frp.cabal 2009-02-13 22:27:08.000000000 +0900 +++ grapefruits/grapefruit-frp-0.0.0.0/grapefruit-frp.cabal 2010-10-23 19:40:44.000000000 +0900 @@ -24,8 +24,8 @@ Library Build-Depends: arrows >= 0.2 && < 0.5, base >= 3.0 && < 4.1, - containers >= 0.1 && < 0.3, - TypeCompose >= 0.3 && < 0.7 + containers >= 0.1 && < 0.4, + TypeCompose >= 0.3 && < 0.9 Extensions: Arrows CPP EmptyDataDecls diff -ur grapefruits-orig/grapefruit-frp-0.0.0.0/src/FRP/Grapefruit/Signal/Continuous.hs grapefruits/grapefruit-frp-0.0.0.0/src/FRP/Grapefruit/Signal/Continuous.hs --- grapefruits-orig/grapefruit-frp-0.0.0.0/src/FRP/Grapefruit/Signal/Continuous.hs 2009-02-13 22:27:08.000000000 +0900 +++ grapefruits/grapefruit-frp-0.0.0.0/src/FRP/Grapefruit/Signal/Continuous.hs 2010-10-23 19:43:42.000000000 +0900 @@ -1,3 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes #-} {-| This module is about continuous signals. diff -ur grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal/Discrete.hs grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal/Discrete.hs --- grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal/Discrete.hs 2009-02-13 22:27:08.000000000 +0900 +++ grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal/Discrete.hs 2010-10-23 19:42:22.000000000 +0900 @@ -1,3 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes #-} module Internal.Signal.Discrete ( -- * Discrete signal type diff -ur grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal/Segmented.hs grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal/Segmented.hs --- grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal/Segmented.hs 2009-02-13 22:27:08.000000000 +0900 +++ grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal/Segmented.hs 2010-10-23 19:42:43.000000000 +0900 @@ -1,3 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes #-} module Internal.Signal.Segmented ( -- * Segmented signal type diff -ur grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal.hs grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal.hs --- grapefruits-orig/grapefruit-frp-0.0.0.0/src/Internal/Signal.hs 2009-02-13 22:27:08.000000000 +0900 +++ grapefruits/grapefruit-frp-0.0.0.0/src/Internal/Signal.hs 2010-10-23 19:41:48.000000000 +0900 @@ -1,3 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes #-} module Internal.Signal ( -- * Signals diff -ur grapefruits-orig/type-equality-check-0.0.0.0/type-equality-check.cabal grapefruits/type-equality-check-0.0.0.0/type-equality-check.cabal --- grapefruits-orig/type-equality-check-0.0.0.0/type-equality-check.cabal 2009-01-23 09:35:37.000000000 +0900 +++ grapefruits/type-equality-check-0.0.0.0/type-equality-check.cabal 2010-10-23 21:49:07.000000000 +0900 @@ -1,6 +1,6 @@ Name: type-equality-check Version: 0.0.0.0 -Cabal-Version: >= 1.2 && < 1.8 +Cabal-Version: >= 1.2 && < 1.9 Build-Type: Simple License: BSD3 License-File: LICENSE
