phooey-1.4: src/Examples/Monad.hs
{-# LANGUAGE TypeSynonymInstances, RecursiveDo #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}
----------------------------------------------------------------------
-- |
-- Module : Examples.Monad
-- Copyright : (c) Conal Elliott 2007
-- License : LGPL
--
-- Maintainer : conal@conal.net
-- Stability : experimental
-- Portability : RecursiveDo
--
-- Monadic-style Phooey examples. Use 'runUI' or 'runNamedUI'.
----------------------------------------------------------------------
module Examples.Monad where
import Control.Applicative
import Data.Monoid
import Char (isDigit,ord)
import Maybe (fromJust)
import System.Time
-- mtl
import Control.Monad.Trans
-- wxHaskell
import Graphics.UI.WX hiding (Event,(.+.),key,button,smallButton,row)
import qualified Graphics.UI.WX as WX
-- TypeCompose
import Control.Compose (Unop,Binop)
import Data.Title
-- DataDriven
import Data.Event
import Data.Source
-- Phooey
import Graphics.UI.Phooey.Monad
{----------------------------------------------------------
Simplest examples
----------------------------------------------------------}
h :: UIS String
h = return (pure "Hello World!")
strs :: UIS String
strs = choices (words "Make things as simple as possible but not simpler") "simple"
strsU :: UI ()
strsU = stringDisplay =<< strs
strLen :: UI ()
strLen = do str <- strs
showDisplay (fmap length str)
uia,uib :: UI ()
uia = stringDisplay =<< h
uib = showDisplay =<< islider (0,10) 3
shopping1 :: UI ()
shopping1 = title "Shopping List" $
do a <- title "apples" $ islider (0,10) 3
b <- title "bananas" $ islider (0,10) 7
title "total" $ showDisplay (liftA2 (+) a b)
area1 :: UI ()
area1 = do w <- title "width" $ fslider (0,10) (3 :: Float)
h <- title "height" $ fslider (0,10) 7
title "area" $ showDisplay (liftA2 (*) w h)
sqrt1 :: UI ()
sqrt1 = do x <- title "x" $ fslider (0,10) (3 :: Float)
title "square root" $ fsliderDisplay (0,4) (sqrt <$> x)
---- Refactoring
sl0 :: IWidget Int
sl0 = islider (0,10)
apples, bananas :: UIS Int
apples = title "apples" $ sl0 3
bananas = title "bananas" $ sl0 7
total :: Num a => OWidget a
total = title "total" . showDisplay
shopping2 :: UI ()
shopping2 = title "Shopping List" $
do a <- apples
b <- bananas
total (liftA2 (+) a b)
-- Sum UIs
infixl 6 .+.
(.+.) :: Num a => UIS a -> UIS a -> UIS a
(.+.) = liftA2 (liftA2 (+))
fruit :: UIS Int
fruit = apples .+. bananas
shopping3 :: UI ()
shopping3 = title "Shopping List" $ fruit >>= total
-- Small variation: title the fruit instead of the total
shopping3' :: UI ()
shopping3' = title "Shopping List" fruit >>= total
-- In the two examples above, visual layout is implicitly chosen to be
-- top-down, following the order in which the components are declared in
-- the arrow expressions. This choice may be overridden, as in the
-- following examples.
shoppingB = fromBottom shopping3
shoppingL = fromLeft shopping3
shoppingR = fromRight shopping3
-- Mix & match layout
shopping4 = fromBottom $
title "Shopping List" $
fromRight fruit >>= total
{----------------------------------------------------------
Subtotals -- suggested by Mads Lindstroem
----------------------------------------------------------}
-- more items
shovels, rakes, tools :: UIS Int
shovels = title "shovels" $ sl0 2
rakes = title "rakes" $ sl0 5
tools = shovels .+. rakes
basket1 :: UI ()
basket1 = title "Shopping List" $
do f <- fruit
title "Fruit" $ showDisplay f
t <- tools
title "Tools" $ showDisplay t
title "Basket" $ showDisplay $ liftA2 (+) f t
-- Abstract out the pattern above. Display and pass along an
-- "intermediate result", following an idea of Mads.
ir :: Show a => String -> UIS a -> UIS a
ir str ui = do x <- ui
title str $ showDisplay x
return x
-- with ir
basket2 :: UI ()
basket2 = title "Shopping List" $
do f <- ir "Fruit" fruit
t <- ir "Tools" tools
title "Basket" $ showDisplay $ liftA2 (+) f t
-- refactored
basket3 :: UI ()
basket3 = title "Shopping List" $
ir "Fruit" fruit .+. ir "Tools" tools
>>= title "Basket" . showDisplay
-- A handy pattern: vertical arrangement with title & subtotal.
subtotal :: Show a => String -> UIS a -> UIS a
subtotal ttl ui = fromTop $ title ttl $ ir "subtotal" ui
-- Place shopping sub-lists and grand total alongside each other
basket4 :: UI ()
basket4 = title "Shopping List" $
fromLeft $ subtotal "Fruit" fruit .+. subtotal "Tools" tools
>>= title "Grand total" . showDisplay
{----------------------------------------------------------
Classic up/down counter example. See
<http://haskell.org/haskellwiki/Phooey#Counter>
----------------------------------------------------------}
-- Value-changer. Increment on "up" & decrement on "down"
upDown :: Num a => UIE (a -> a)
upDown = smallButton (+1) "up" `mappend` smallButton (subtract 1) "down"
upDown' :: Num a => UIE (a -> a)
upDown' = do up <- smallButton (+1) "up"
down <- smallButton (subtract 1) "down"
return (up `mappend` down)
-- The counter.
counter :: UI ()
counter = title "Counter" $ fromLeft $
do e <- upDown
-- Apply each increment/decrement cumulatively
0 `accumS` e >>= showDisplay
-- Note: I could purely accumulate the @a -> a@, and even do so very
-- elegantly as the endomorphism monoid ('Endo'), so as not to have to
-- specify the identity ('mempty') and composition ('mappend'). Whenever the
-- endomorphism changes, it would get applied to the initial value, which
-- would be frightfully expensive. In a sense, the approach above
-- exploits associativity of composition for efficiency.
--
-- Mitch Wand used this associativity trick very effectively in his paper
-- "Continuation-Based Program Transformation Strategies". He also came
-- up with alternative representations for the continuations. Oh! I
-- could do that here. The continuation is adding a number. Use the
-- 'Sum' monoid instead of 'Endo', and we'll have an efficient, evaluated
-- representation of that continuation, namely a single number to be
-- added.
upDown2 :: Num a => UIE (Sum a)
upDown2 = smallButton (Sum 1) "up" `mappend` smallButton (Sum (-1)) "down"
counter2 :: UI ()
counter2 = title "Counter" $ fromLeft $
do ud <- upDown2
n <- (fmap.fmap) getSum (monoidS ud)
showDisplay n
{----------------------------------------------------------
Calculator, from "Lightweight GUIs for Functional Programming".
See <http://haskell.org/haskellwiki/Phooey#Calculator>
----------------------------------------------------------}
-- Single calculator key
key :: Char -> UIE Char
key c = button' c [ outerSize := sz 50 50, text := [c] ]
-- Handy
mconcatMap :: Monoid b => (a -> b) -> [a] -> b
mconcatMap f = mconcat . map f
-- Row of keys. Uses the Monoid instances for UI and Event
row :: [Char] -> UIE Char
row = fromLeft . mconcatMap key
-- Rows of keys.
rows :: [[Char]] -> UIE Char
rows = fromTop . mconcatMap row
-- The whole keyboard. Four rows of four keys each
calcKeys :: UIE Char
calcKeys = rows [ "123+"
, "456-"
, "789*"
, "C0=/" ]
-- Test calcKeys, accumulating the string of keys pressed. Each char c
-- gets replaced by (c :), which get successively applied via 'accumS'.
testKeys :: UI ()
testKeys = title "Calculator key test" $
calcKeys >>= showKeys
showKeys :: Event Char -> UI ()
showKeys key =
do chars <- "" `accumS` fmap (:) key
title "keys pressed" $ stringDisplay $ fmap reverse chars
-- -- Test calcKeys, accumulating the string of keys pressed. Each char c
-- -- gets replaced by (c :), which get successively applied via 'accumS'.
-- testKeys :: UI ()
-- testKeys = title "Calculator key test" $
-- do key <- calcKeys
-- chars <- "" `accumS` fmap (:) key
-- title "chars" $ stringDisplay $ fmap reverse chars
-- The calculator state is a number being formed and a continuation.
type CState = (Int, Unop Int)
-- Start state
startCS :: CState
startCS = (0, id)
-- Interpret a character as a state transition.
cmd :: Char -> Unop CState
cmd 'C' _ = startCS
cmd '=' (d,k) = (k d, const (k d))
cmd c (d,k) | isDigit c = (10*d + ord c - ord '0', k)
| otherwise = (0, op c (k d))
-- TODO: Try formulating the state as a monoid. Use Endo for the
-- continuation and for the state transition.
-- Operation associated with a key
op :: Char -> Binop Int
op c = fromJust (lookup c ops)
where
ops :: [(Char, Binop Int)]
ops = [('+',(+)), ('-',(-)), ('*',(*)), ('/',div)]
-- The calculator
calc :: UI ()
calc = title "Calculator" $
do key <- calcKeys
showKeys key
showCalc key
showCalc :: Event Char -> UI ()
showCalc key = do states <- startCS `accumS` fmap cmd key
title "result" $ showDisplay $ fmap fst states
-- -- The calculator
-- calc :: UI ()
-- calc = title "Calculator" $
-- do e <- calcF
-- states <- startCS `accumS` e
-- title "result" $ showDisplay $ fmap fst states
---- Redo with monoids
-- With the @String@ monoid
testKeys2 :: UI ()
testKeys2 = title "Calculator key test - monoid version" $
do key <- calcKeys
str <- monoidS (fmap (:[]) key)
title "chars" $ stringDisplay str
-- Hm. I think the strings get combined in the worst possible way, by
-- repeated snoc'ing, which is probably on the same order as the Endo
-- composition.
-- With the @Endo CState@ monoid
calc2 :: UI ()
calc2 = title "Calculator - monoid version" $
do key <- calcKeys
endos <- monoidS (fmap (Endo . cmd) key)
let n = fmap (fst . ($ startCS) . appEndo) endos
title "result" $ showDisplay n
-- As mentioned above, I expect this @calc2@ to be very wasteful,
-- accumulating and re-applying longer & longer composition chains as it
-- goes. Applying Mitch Wand's lovely trick, what's a data representation
-- for the subset of @CState -> CState@ that comes from compositions of
-- @cmd@?
-- Timed polling
calendarTime :: Double -> UI (Source CalendarTime)
calendarTime secs = timedPoll secs (getClockTime >>= toCalendarTime)
clock :: UI ()
clock = (fmap.fmap) calendarTimeToString (calendarTime 1) >>= stringDisplay
---- Tests: move to Test.hs
{----------------------------------------------------------
Tests
----------------------------------------------------------}
test = mapM_ runUI [t0,t1,t2,t3,t4,t5,t6]
-- basic counter
t0 = do up <- button (+1) "up"
n <- 0 `accumS` up
showDisplay n
-- "up" only works the first time
t1 = do up <- button (+1) "up"
n <- 0 `accumS` once up
showDisplay n
-- "up" works until "stop"
t2 = do stop <- button () "stop"
up <- button (+1) "up"
n <- 0 `accumS` (up `before` stop)
showDisplay n
-- two buttons: each increments
t3 = do poke <- button () "poke me"
dont <- button () "don't poke me"
ec <- countE (poke `mappend` dont)
n <- 0 `stepper` ec
showDisplay n
-- different rendering of t0
-- TODO: rewrite accumS this way. or explain why not.
t4 = do up <- button (+1) "up"
ec <- 0 `accumE` up
n <- 0 `stepper` ec
showDisplay n
-- up/down
t5 = do up <- button (+1) "up"
down <- button (subtract 1) "down"
ec <- 0 `accumE` (up `mappend` down)
n <- 0 `stepper` ec
showDisplay n
-- value pairs
t6 = do up <- button (+1) "up"
e <- 0 `accumE` up
showDisplay =<< 0 `stepper` e
e' <- withPrevE e
showDisplay =<< (10,10) `stepper` e'
-- prime withPrev with 0
t7 = do up <- button (+1) "up"
e <- 0 `accumE` up
showDisplay =<< 0 `stepper` e
e' <- withPrevE (pure 0 `mappend` e)
showDisplay =<< (10,10) `stepper` e'