Applicative.hs

{-# OPTIONS #-}

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

module Examples.Applicative where

import Control.Applicative
import Control.Monad.Fix (fix)

import Graphics.UI.Phooey.Applicative

-- For oPair etc
import Control.DataDriven (Sink,Updater)
import Data.Monoid

h :: UI String
h = pure "Hello World!"

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

uia,uib :: UI Upd
uia = stringDisplay <*> h
uib = showDisplay <*> sl0 3


ui1 :: UI Upd
ui1 = title "Shopping List" $ fruit <**> total

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

fruit = liftA2 (+) apples bananas

-- With overloading, we could say
-- fruit = apples + bananas

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


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

lo,hi :: UI Int
lo = title "lo" $ sl0 2
hi = title "hi" $ sl0 8

val :: UI Int
val = title "val" $ isliderDyn (pair lo hi) 5

-- Note that the "val" title is around the lo & hi sliders as well.  I
-- guess that layout reflects the purpose of the lo & hi sliders.  I don't
-- know how to get a "val" title on just the dynamically-bounded slider.
ui2 :: UI Upd
ui2 = (fact <$> val) <**> title "factorial" showDisplay

-- minor variation
ui2' = val <**>
       pure fact <**>
       title "factorial" showDisplay

-- Variation

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


o1 :: UI (Snk (Int -> Int -> Int))
o1 = oLambda apples (oLambda bananas total)

ui4 :: UI Upd
ui4 = o1 <*> pure (+)

-- Experiments.  None of these functions is specific to UI

-- iPair :: Applicative ui => ui a -> ui b -> ui (a,b)
-- iPair = liftA2 (,) -- fromLeft

-- oPair :: (Applicative ui, Applicative src, Monoid (Updater src))
--       => ui (Sink src a) -> ui (Sink src b) -> ui (Sink src (a,b))
-- oPair = liftA2 oPair'  -- fromLeft

-- -- Suggested use: m = src ()
-- oLambda :: Applicative ui
--         => ui a -> ui (b -> m) -> ui ((a->b) -> m)
-- oLambda = liftA2 oLambda'  -- fromTop

-- -- Monoid variant for oPair

-- oPairM :: (Applicative ui, Monoid m)
--        => ui (a -> m) -> ui (b -> m) -> ui ((a,b) -> m)
-- oPairM = liftA2 oPairM'

-- oPairM' :: Monoid m => (a -> m) -> (b -> m) -> ((a,b) -> m)
-- oPairM' oa ob (a,b) = oa a `mappend` ob b  -- fromLeft

iPair :: UI a -> UI b -> UI (a,b)
iPair a b = fromLeft (liftA2 (,) a b)

oPair :: (Monoid (Updater src), Applicative src)  -- e.g., src == IO
      => UI (Sink src a) -> UI (Sink src b) -> UI (Sink src (a,b))
oPair a b = fromLeft (liftA2 oPair' a b)

oPair' :: (Monoid (Updater src), Applicative src)
       => Sink src a -> Sink src b -> Sink src (a,b)
oPair' oa ob (a,b) = oa a `mappend` ob b

-- Suggested use: m = src ()
oLambda :: UI a -> UI (b -> m) -> UI ((a->b) -> m)
oLambda a b = fromTop (liftA2 oLambda' a b)

oLambda' :: a -> (b -> m) -> ((a->b) -> m)
oLambda' ia ob f = ob (f ia)


o2 :: UI (Snk ((Int,Int) -> Int))
o2 = oLambda (iPair apples bananas) total

ui5 :: UI Upd
ui5 = o2 <*> pure (uncurry (+))

o3 :: UI (Snk ((Int,Int) -> (Int,Int))) 
o3 = oLambda (iPair sli sli) (oPair slo slo)
 where
   sli = sl0 5
   slo = isliderDisplay (0,10)

ui6 :: UI Upd
ui6 = o3 <*> pure (\ (a,b) -> (b,a))


---- Recursive:

-- ffix :: Functor f => f (a->a) -> f a
-- ffix = fmap fix

-- or
-- ffix :: (m a -> m a) -> m a
-- ffix = fix

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

ui7 :: UI (Int,Int)
ui7 = fix f
 where f :: UI (Int,Int) -> UI (Int,Int)
       f bounds = liftA2 (,)
                    (isliderDyn (pair (pure  0) hi) 3)
                    (isliderDyn (pair lo (pure 10)) 8)
        where
          ~(lo,hi) = unPair bounds

ui8 :: UI Upd
ui8 = total <*> fmap (uncurry (+)) ui7

ui9 :: UI Upd
ui9 = fix f *> pure mempty
 where f :: UI Int -> UI Int
       f val = isliderDyn (pair ((subtract 5) <$> val) ((+ 5) <$> val)) 10