A simple Graphical User Interface with concepts borrowed from Phooey
by Conal Elliot.

> module Euterpea.UI.UIMonad where

> import Euterpea.UI.SOE 
> import qualified Euterpea.UI.SOE as SOE
> import System.IO
> import Data.IORef
> import Control.Concurrent
> import Control.Monad.Fix
> import qualified Graphics.UI.GLFW as GLFW 

> import qualified Codec.Midi as Midi
> import Sound.PortMidi hiding (time)
> import Euterpea.MidiIO
> import Euterpea.UI.Signal

A UI widget runs under a given context, with its internal system
states, and maps input signals to outputs, which consists of 3 parts:
a signal of actions (to render graphics or sounds), its layout and a
parametrized output type.

> newtype UI a = UI 
>   { unUI :: CTX -> Signal (Input, Sys) -> 
>             (Signal (Action, Sys), (Layout, a)) }


Rendering Context
=================

A rendering context specifies the following:
 
1. A layout direction to flow widgets. 
 
2. A rectangle bound of current drawing area to render a UI
   component. It specifies the max size of a widget, not the
   actual size. It's up to each individual widget to decide
   where in this bound to put itself.

3. A unique widget ID for the current UI component that
   receives this context.

4. A function that inject inputs into system event queue.
   This is needed to implement some input widgets.

> data CTX = CTX 
>   { flow   :: Flow
>   , bounds :: Rect
>   , uid    :: WidgetID
>   , inject :: Input -> IO ()
>   }

> data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show)
> type Dimension = (Int, Int)
> type Rect = (Point, Dimension)


UI Layout
=========

The layout of a widget provides data to calculate its actual size
in a given context.

> data Layout = Layout
>   { hFill  :: Int
>   , vFill  :: Int
>   , hFixed :: Int
>   , vFixed :: Int
>   , minW   :: Int
>   , minH   :: Int
>   } deriving (Eq, Show)

1. hFill/vFill specify how much stretching space (in units) in
   horizontal/vertical direction should be allocated for this widget.

2. hSize/vSize specify how much non-stretching space (width/height in
   pixels) should be allocated for this widget. 

Layout calculation makes use of lazy evaluation to do it in one pass.
Although the UI function maps from Context to Layout, both hFill/vFill
and hSize/vSize must be fixed and independent of the Context.
Therefore they are avaiable before the UI function is even evaluated.

Context and Layout Functions
============================

Divide CTX according to the ratio of a widget's layout and the overall
layout of the widget that receives this CTX.

> divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX)
> divideCTX (CTX a ((x, y), (w, h)) i f) 
>           ~(Layout m n u v minw minh) ~(Layout m' n' u' v' minw' minh') =
>   case a of
>     TopDown   -> (CTX a ((x, y), (w, h')) i f, 
>                   CTX a ((x, y + h'), (w, h - h')) i f)
>     BottomUp  -> (CTX a ((x, y + h - h'), (w, h')) i f, 
>                   CTX a ((x, y), (w, h - h')) i f)
>     LeftRight -> (CTX a ((x, y), (w', h)) i f, 
>                   CTX a ((x + w', y), (w - w', h)) i f)
>     RightLeft -> (CTX a ((x + w - w', y), (w', h)) i f, 
>                   CTX a ((x, y), (w - w', h)) i f)
>   where
>     w' = min (w - (minw' - minw)) $ max minw $ (m * div' (w - u') m' + u)
>     h' = min (h - (minh' - minh)) $ max minh $ (n * div' (h - v') n' + v)
>     div' b 0 = 0
>     div' b d = div b d

Calculate the actual size of a widget given the context and its layout.

> computeBBX :: CTX -> Layout -> Rect
> computeBBX (CTX a ((x, y), (w, h)) i _) ~(Layout m n u v minw minh) = 
>   case a of
>     TopDown   -> ((x, y), (w', h')) 
>     BottomUp  -> ((x, y + h - h'), (w', h'))
>     LeftRight -> ((x, y), (w', h'))
>     RightLeft -> ((x + w - w', y), (w', h'))
>   where
>     w' = max minw $ (if m == 0 then u else w)
>     h' = max minh $ (if n == 0 then v else h)

Merge two layouts into one.

> mergeLayout a (Layout n m u v minw minh) (Layout n' m' u' v' minw' minh') = 
>   case a of
>     TopDown   -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh')
>     BottomUp  -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh')
>     LeftRight -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh')
>     RightLeft -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh')
>   where
>     max' 0 0 = 0
>     max' _ _ = 1

Null layout.

> nullLayout = Layout 0 0 0 0 0 0

Layout functions are UI transformers that modifies the flow in the
context.

> topDown,bottomUp,leftRight,rightLeft  :: UI a -> UI a
> topDown   = modifyFlow (\ctx -> ctx {flow = TopDown})
> bottomUp  = modifyFlow (\ctx -> ctx {flow = BottomUp})
> leftRight = modifyFlow (\ctx -> ctx {flow = LeftRight})
> rightLeft = modifyFlow (\ctx -> ctx {flow = RightLeft})

> modifyFlow h (UI f) = UI g where g ctx = f (h ctx)

Set fixed size (in pixels) for UI widget. 

> setSize :: Dimension -> UI a -> UI a
> setSize (w, h) (UI f) = UI aux
>   where
>     aux ctx@(CTX i bbx myid m) inp = 
>       let (z, (l, v)) = f (CTX i (computeBBX ctx d) myid m) inp 
>           d = Layout 0 0 0 0 w h 
>       in (z, (d, v))

Add space padding around a widget.

> pad :: (Int, Int, Int, Int) -> UI a -> UI a
> pad (w,n,e,s) (UI f) = UI aux
>   where
>     aux ctx@(CTX i _ myid m) inp = 
>       let (z, (l, v)) = f (CTX i ((x + w, y + n),(bw,bh)) myid m) inp 
>           d = l { hFixed = hFixed l + w + e, vFixed = vFixed l + n + s }
>           ((x,y),(bw,bh)) = computeBBX ctx d
>       in (z, (d, v))

Widget ID
=========

Widget ID is actually 2-dimensional because we want to support both
sequential composition and nested wrappers. In the latter case
a simple ID number wouldn't suffice.

> newtype WidgetID = WidgetID [Int] deriving (Eq, Show)

> firstWidgetID = WidgetID [0]
> popWidgetID (WidgetID (i:is)) = WidgetID is
> popWidgetID _ = error "can't pop empty WidgetID" 
> pushWidgetID (WidgetID is) = WidgetID (0:is)
> nextWidgetID (WidgetID (i:is)) = WidgetID ((i + 1) : is)
> nextWidgetID _ = error "can't get the next of empty WidgetID"

Input, Action, and System State
===============================

Input is a union of user events and Midi events, and in addition,
a timer event is needed to drive time based computations.
 
> data Input 
>   = UIEvent SOE.Event 
>   | Timer Time 
>   | MidiEvent DeviceID Midi.Message
>   deriving Show

Actions include both Graphics and Sound output. Even though both
are indeed just IO monads, we separate them because Sound output
must be immediately delivered, while graphics can wait until
next screen refresh.

> type Action = (Graphic, Sound)
> type Sound = IO ()
> mergeAction (g, s) (g', s') = (overGraphic g' g, s >> s')
> nullSound = return () :: Sound

System state is hidden from input and output, but shared among
UI widgets.

> data Sys = Sys 
>   { dirty     :: Bool                -- whether a redraw is needed 
>   , focus     :: Maybe WidgetID      -- currently focused widget
>   , nextFocus :: Maybe WidgetID      -- next focus widget
>   } deriving Show

Monadic Instances
=================

We use Monad compositions to compose two UIs in sequence.

Alternatively we could use Arrows or Applicative Functors to do the
same, so the choice of Monad here is somewhat arbitary.

> cross f g x = (f x, g x)

> instance Monad UI where
>   return i = UI (const aux)
>     where
>       aux = lift (\(_, s) -> ((nullGraphic, return ()), s)) 
>             `cross` const (nullLayout, i)

>   (UI m) >>= f = UI (\ctx inp -> 
>     let (ctx1, ctx')    = divideCTX ctx l1 layout
>         (ctx2, _)       = divideCTX ctx' l2 l2
>         (o1, (l1, r1))  = m (ctx1 { uid = pushWidgetID (uid ctx)}) inp
>         (action1, sys1) = unzipS o1 
>         (o2, (l2, r2))  = unUI (f r1) 
>                             (ctx2 { uid = nextWidgetID (uid ctx) })
>                             (zipS (fstS inp) sys1)
>         (action2, sys2) = unzipS o2
>         action          = lift2 mergeAction action1 action2
>         layout          = mergeLayout (flow ctx) l1 l2 
>     in (zipS action sys2, (layout, r2)))

UIs are also instances of MonadFix so that we can define value
level recursion.

> instance MonadFix UI where
>   mfix f = UI aux
>     where
>       aux ctx inp = (out, (layout, r))
>         where (out, (layout, r)) = unUI (f r) ctx inp

Execute UI Program
==================

> defaultSize :: Dimension
> defaultSize = (300, 300)
> defaultCTX :: Dimension -> CTX
> defaultCTX size = CTX TopDown ((0,0), size) firstWidgetID (\_ -> return ())
> defaultSys :: Sys
> defaultSys = Sys True Nothing Nothing

> runUI = runUIEx defaultSize

> runUIEx :: Dimension -> String -> UI a -> IO ()
> runUIEx windowSize title (UI prog) = runGraphics $ do
>   initialize
>   w <- openWindowEx title (Just (0,0)) (Just windowSize) drawBufferedGraphic
>   (events, addEv) <- makeStream
>   pollEvents <- windowUser w addEv
>   -- poll events before we start to make sure event queue isn't empty
>   pollEvents
>   let inp = Signal events
>       (out, (l, _)) = prog ((defaultCTX windowSize) { inject = addEv }) 
>                            (zipS inp (initS defaultSys sys))
>       (action, sys') = unzipS out
>       sys = lift (\(Sys t f n) -> Sys False (maybe f Just n) Nothing) sys'
>       render drawit' (inp:inps) ((graphic, sound) : xs) (Sys dirty f n : ys) = do
>         -- always output sound
>         sound
>         -- and delay graphical output when event queue is not empty
>         setGraphic' w graphic
>         let drawit = dirty || drawit'
>         f `seq` n `seq` case inp of
>           -- Timer only comes in when we are done processing user events
>           Timer _ -> do 
>             -- output graphics 
>             if drawit then setDirty w else return ()
>             quit <- pollEvents
>             if quit 
>               then return ()
>               else render False inps xs ys 
>           _ -> render drawit inps xs ys
>       render _ [] _ _ = return ()
>   render True (unS inp) (unS action) (unS sys')
>   -- wait a little while before all Midi messages are flushed
>   GLFW.sleep 0.5
>   terminateMidi
>   closeWindow w

> windowUser w addEv = timeGetTime >>= return . addEvents
>   where
>   addEvents t0 = do 
>     quit <- loop
>     t <- timeGetTime
>     let rt = t - t0
>     addEv (Timer rt)
>     return quit
>   loop = do
>     mev <- maybeGetWindowEvent w
>     case mev of
>       Nothing -> return False
>       Just e  -> case e of
>         Key '\033' True -> return True
>         Key '\00'  True -> return True
>         Closed          -> return True
>         _               -> addEv (UIEvent e) >> loop

> makeStream :: IO ([a], a -> IO ())
> makeStream = do
>   ch <- newChan
>   contents <- getChanContents ch
>   return (contents, writeChan ch)