Monad.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Examples.Monad
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- Portability :  portable
-- 
-- Monadic-style Phooey examples.  Use 'runUI'
----------------------------------------------------------------------

module Examples.Monad where

import Control.Applicative
import Control.Monad (liftM2)
import Control.Monad.Fix
import Data.Monoid (mappend,mempty)

import Graphics.UI.Phooey.Monad


-- h :: UI (Source String)
-- h = return (pure "Hello World!")

-- uia,uib :: UI (Source ())
-- uia = stringDisplay =<< h
-- uib = showDisplay =<< sl0 3


ui1 :: UI (Source ())
ui1 = title "Shopping List" $
      do a <- title "apples"  $ islider (0,10) 3
         b <- title "bananas" $ islider (0,10) 7
         title "total" $ showDisplay (liftA2 (+) a b)

-- Refactoring

sl0 :: IWidget Int
sl0 = islider (0,10)

apples, bananas :: UI (Source Int)
apples  = title "apples"  $ sl0 3
bananas = title "bananas" $ sl0 7

total :: Num a => OWidget a
total = title "total" . showDisplay

ui1x :: UI (Source ())
ui1x = title "Shopping List" $
       do a <- apples
          b <- bananas
          total (liftA2 (+) a b)

fruit :: UI (Source Int)
fruit = liftM2 (liftA2 (+)) apples bananas

ui1y :: UI (Source ())
ui1y = 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.

uiB1  = fromBottom  ui1
uiL1  = fromLeft    ui1
uiR1  = fromRight   ui1


ui3 = fromBottom $
      title "Shopping  List" $
      fromRight fruit >>= total


-- Experiments with multiple displays
uix = do n <- sl0 3
         liftM2 mappend
                (showDisplay (liftA (*2) n))
                (showDisplay (liftA (*3) n))

-- Dynamic

ui2 :: UI (Source ())
ui2 = do  l <- title "lo"    $ sl0 3
          h <- title "hi"    $ sl0 8
          v <- title "val"   $ isliderDyn (pair l h) 5
          title "factorial"  $ showDisplay (liftA fact v)

fact :: Int -> Int
fact n = product [1 .. n]

-- Refactor

lo,hi :: UI (Source Int)
lo = title "lo" $ sl0 3
hi = title "hi" $ sl0 8

bounds :: UI (Source (Int,Int))
bounds = liftM2 pair lo hi

val :: UI (Source Int)
val = do b <- bounds
         title "val" $ isliderDyn b 5

-- Alternative style, in which the "val" title is around the lo & hi
-- sliders as well.  This layout reflects the purpose of the lo & hi
-- sliders.

val' = title "val" $
       do b <- bounds
          isliderDyn b 5

ui2' = do v <- val'
          title "factorial"  $ showDisplay (liftA fact v)


-- Recursive

uir1 :: UI (Source ())
uir1 = mdo l <- title "lo"   $ isliderDyn (pair (pure 0) h) 3
           h <- title "hi"   $ isliderDyn (pair l (pure 10)) 8
           v <- title "val"  $ isliderDyn (pair l h) 5
           title "factorial" $ showDisplay (liftA fact v)

-- Refactor

boundsR :: UI (Source (Int,Int))
boundsR = mfix boundsF
 where
   boundsF lh = liftM2 pair
                  (title "lo" $ isliderDyn (pair (pure 0) h) 3)
                  (title "hi" $ isliderDyn (pair l (pure 10)) 8)
     where
       (l,h) = unPair lh

unPair :: Functor f => f (a, b) -> (f a, f b)
unPair p = (fmap fst p, fmap snd p)

valR :: UI (Source Int)
valR = do b <- boundsR
          title "val" $ isliderDyn b 5

uir1' = do v <- valR
           title "factorial"  $ showDisplay (liftA fact v)


uir2 = mdo v <- title "val" (isliderDyn (liftA (plusMinus 5) v) 6)
           title "squared" (showDisplay (liftA square v))
 where
   plusMinus n x = (x-n,x+n)
   square y      = y*y

pair :: Applicative f => f a -> f b -> f (a,b)
pair = liftA2 (,)