{-# LANGUAGE TypeSynonymInstances, RecursiveDo #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}


----------------------------------------------------------------------
-- |
-- Module      :  Examples.Monad
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- 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

-- reactive
import Data.Reactive

-- Phooey
import Graphics.UI.Phooey.Monad
import Graphics.UI.Phooey.WinEvents

{----------------------------------------------------------
    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"

-- More explicit implementation of the same.
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
             showDisplay (0 `accumR` e)

-- Point-free variation
counter' :: UI ()
counter' = title "Counter" $ fromLeft $
           showDisplay =<< (0 `accumR`) <$> upDown

-- 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
              showDisplay $ fmap getSum (monoidR ud)


{----------------------------------------------------------
    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 = title "keys pressed" $ stringDisplay $ fmap reverse chars
  where chars = "" `accumR` fmap (:) key
     

-- 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 = title "result" $ showDisplay $ fmap fst states
 where
   states = startCS `accumR` fmap cmd key


---- Redo with monoids

-- With the @String@ monoid
testKeys2 :: UI ()
testKeys2 = title "Calculator key test - monoid version" $
            do key <- calcKeys
               let str = monoidR (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
           let endos = monoidR (fmap (Endo . cmd) key)
               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,t3,t5,t6,t7]

-- basic counter
t0 = do up <- button (+1) "up"
        showDisplay $ 0 `accumR` up

-- "up" only works the first time
t1 = do up <- button (+1) "up"
        showDisplay $ 0 `accumR` once up

-- -- "up" works until "stop"
-- t2 = do stop <- button () "stop"
--         up   <- button (+1) "up"
--         showDisplay $ 0 `accumR` (up `before` stop)

-- two buttons: each increments
t3 = do poke <- button () "poke me"
        dont <- button () "don't poke me"
        showDisplay $ countR (poke `mappend` dont)

-- style variation
t3' = do buttons <- button () "poke me" `mappend` button () "don't poke me"
         showDisplay $ countR buttons

-- up/down
t5 = do up   <- button (+1)         "up"
        down <- button (subtract 1) "down"
        showDisplay $ 0 `accumR` (up `mappend` down)

-- value pairs
t6 = do up <- button (+1) "up"
        let e = 0 `accumE` up
        showDisplay $ 0 `stepper` e
        let e' = withPrevE e
        showDisplay $ (10,10) `stepper` e'

-- prime withPrev with 0
t7 = do up <- button (+1) "up"
        let e = 0 `accumE` up
        showDisplay $ 0 `stepper` e
        let e' = withPrevE (pure 0 `mappend` e)
        showDisplay $ (10,10) `stepper` e'

t8 = do y <- button () "yes"
        n <- button () "no"
        showDisplay $ flipFlop y n

t9  = testWidget (leftDragAccum WX.vecZero) >>= showDisplay

t10 = testWidget mbMouse >>= showDisplay
t11 = testWidget clickPos >>= showDisplay

clickPos :: WioS (Maybe Point)
clickPos win = do ld <- leftDown win
                  mp <- mbMouse win
                  return $ Nothing `stepper` (ld `snapshot_` mp)

clickT :: WioS Int
clickT win = do ld <- leftDown win
                return $ 0 `stepper` (ld `snapshot_` t)
 where
    t = 1 `stepper` pure 2

t12 = testWidget clickT >>= showDisplay
t13 = showDisplay $ 1 `stepper` pure 2
t14 = showDisplay $ 1 `stepper` (pure () `snapshot_` pure 2)