UITypes.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  FRP.UISF.UIMonad
-- Copyright   :  (c) Daniel Winograd-Cort 2014
-- License     :  see the LICENSE file in the distribution
--
-- Maintainer  :  dwc@cs.yale.edu
-- Stability   :  experimental

{-# LANGUAGE RecursiveDo #-}

module FRP.UISF.UITypes where

import FRP.UISF.SOE
import FRP.UISF.AuxFunctions (mergeE)

------------------------------------------------------------
-- * UI Types
------------------------------------------------------------

-- $uitypes
-- Widgets are arrows that map multiple inputs to multiple outputs.  
-- Additionally, they have a relatively static layout argument that, 
-- while it can change over time, is not dependent on any of its 
-- inputs at any given moment.
--
-- On the input end, a widget will accept:
--
--  - a graphical context, 
--
--  - some information about which widget is in focus (for the purposes 
--    of routing key presses and mouse clicks and potentially for drawing 
--    the widget differently), 
--
--  - and the current time.
--
-- On the output end, a widget will produce from these inputs:
-- 
--  - an indicator of whether the widget needs to be redrawn,
-- 
--  - any focus information that needs to be conveyed to future widgets, 
-- 
--  - the graphics to render to display this widget,
-- 
--  - and any new ThreadIds to keep track of (for proper shutdown when finished).
--
-- Additionally, as widgets are generic arrows, there will be a parameterized 
-- inputs and output type.
--
-- In this file, we will declare the various types to make creating the overall 
-- UI possible.  For the widget type itself, see UISF in FRP.UISF.UISF.


------------------------------------------------------------
-- * Control Data
------------------------------------------------------------

-- | The control data is simply a list of Thread Ids.
type TerminationProc = Maybe (IO ())

-- | No new thread ids.
nullTP :: TerminationProc
nullTP = Nothing

-- | A method for merging to control data objects.
mergeTP :: TerminationProc -> TerminationProc -> TerminationProc
mergeTP = mergeE (>>)


------------------------------------------------------------
-- * Rendering Context
------------------------------------------------------------

-- | A rendering context specifies the following:

data CTX = CTX 
  { flow   :: Flow 
        -- ^ A layout direction to flow widgets. 
  
  , bounds :: Rect 
        -- ^ 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.
  
  , isConjoined :: Bool 
        -- ^ A flag to tell whether we are in a conjoined state or not.  
        -- A conjoined context will duplicate itself for subcomponents 
        -- rather than splitting.  This can be useful for making compound 
        -- widgets when one widget takes up space and the other performs 
        -- some side effect having to do with that space.
  } deriving Show

-- | Flow determines widget ordering.
data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show)
-- | A dimension specifies size.
type Dimension = (Int, Int)
-- | A rectangle has a corner point and a dimension.
type Rect = (Point, Dimension)


------------------------------------------------------------
-- * UI Layout
------------------------------------------------------------

-- $ctc The layout of a widget provides data to calculate its actual size
-- in a given context.  
-- Layout calculation makes use of lazy evaluation to do everything in one pass.  
-- Although the UI function maps from Context to Layout, all of the fields of 
-- Layout must be independent of the Context so that they are avaiable before 
-- the UI function is even evaluated.

-- | Layouts for individual widgets typically come in a few standard flavors, 
--   so we have this convenience function for their creation.
--   This function takes layout information for first the horizontal 
--   dimension and then the vertical.
makeLayout :: LayoutType ->     -- ^ Horizontal Layout information
              LayoutType ->     -- ^ Vertical Layout information
              Layout
makeLayout (Fixed h) (Fixed v) = Layout 0 0 h v 0 0
makeLayout (Stretchy minW) (Fixed v) = Layout 1 0 0 v minW 0
makeLayout (Fixed h) (Stretchy minH) = Layout 0 1 h 0 0 minH
makeLayout (Stretchy minW) (Stretchy minH) = Layout 1 1 0 0 minW minH

-- | A dimension can either be:
data LayoutType = 
        Stretchy { minSize :: Int }
        -- ^ Stretchy with a minimum size in pixels
      | Fixed { fixedSize :: Int }
        -- ^ Fixed with a size measured in pixels

-- | The null layout is useful for \"widgets\" that do not appear or 
--   take up space on the screen.
nullLayout = Layout 0 0 0 0 0 0


-- | More complicated layouts can be manually constructed with direct 
-- access to the Layout data type.
--
-- 1. hFill and vFill specify how much stretching space (in comparative 
--    units) in the horizontal and vertical directions should be 
--    allocated for this widget.
-- 
-- 2. hFixed and vFixed specify how much non-stretching space (in pixels) 
--    of width and height should be allocated for this widget.
-- 
-- 3. minW and minH specify minimum values (in pixels) of width and height 
--    for the widget's stretchy dimensions.

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



------------------------------------------------------------
-- * Context and Layout Functions
------------------------------------------------------------

---------------
-- divideCTX --
---------------
-- | Divides the CTX among the two given layouts.

divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX)
divideCTX ctx@(CTX a ((x, y), (w, h)) c) 
          ~(Layout wFill  hFill  wFixed  hFixed  wMin  hMin) 
          ~(Layout wFill' hFill' wFixed' hFixed' wMin' hMin') =
  if c then (ctx, ctx) else
  case a of
    TopDown   -> (CTX a ((x, y),                 (w1T, h1T)) c, 
                  CTX a ((x, y + h1T),           (w2T, h2T)) c)
    BottomUp  -> (CTX a ((x, y + h - h1T),       (w1T, h1T)) c, 
                  CTX a ((x, y + h - h1T - h2T), (w2T, h2T)) c)
    LeftRight -> (CTX a ((x, y),                 (w1L, h1L)) c, 
                  CTX a ((x + w1L, y),           (w2L, h2L)) c)
    RightLeft -> (CTX a ((x + w - w1L, y),       (w1L, h1L)) c, 
                  CTX a ((x + w - w1L - w2L, y), (w2L, h2L)) c)
  where
    -- The commented out code here forces the contexts to match exactly 
    -- what the layout requests.  The code in place matches to the first 
    -- layout and then gives the rest of the context to the second.
    -- A more robust design may require a special "filler" layout that 
    -- is not stretchy but will accept any leftover pixels.  We could 
    -- then have a filler widget that is essentially (arr id) with this 
    -- special layout.
    wportion fill = div' (fill * (w - wFixed - wFixed')) (wFill + wFill')
    (w1L,w2L) = let w1 = wFixed  + max wMin  (wportion wFill)
                    w2 = wFixed' + max wMin' (wportion wFill')
                in (w1, w-w1) --if w1+w2 > w then (w1, w-w1) else (w1, w2)
    h1L = h --max hMin  (if hFill  == 0 then hFixed  else h)
    h2L = h --max hMin' (if hFill' == 0 then hFixed' else h)
    hportion fill = div' (fill * (h - hFixed - hFixed')) (hFill + hFill')
    (h1T,h2T) = let h1 = hFixed  + max hMin  (hportion hFill)
                    h2 = hFixed' + max hMin' (hportion hFill')
                in (h1, h-h1) --if h1+h2 > h then (h1, h-h1) else (h1, h2)
    w1T = w --max wMin  (if wFill  == 0 then wFixed  else w)
    w2T = w --max wMin' (if wFill' == 0 then wFixed' else w)
    div' b 0 = 0
    div' b d = div b d


-----------------
-- mergeLayout --
-----------------
-- | Merge two layouts into one.

mergeLayout :: Flow -> Layout -> Layout -> Layout
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


------------------------------------------------------------
-- * Graphics and System State
------------------------------------------------------------

-- | Merging two graphics can be achieved with overGraphic, but 
-- the mergeGraphic function additionally constrains the graphics 
-- based on their layouts and the context.
-- TODO: Make sure this works as well as it should
mergeGraphics :: CTX -> (Graphic, Layout) -> (Graphic, Layout) -> Graphic
mergeGraphics ctx (g1, l1) (g2, l2) = case (l1 == nullLayout, l2 == nullLayout) of
  (True,  True)  -> nullGraphic
  (True,  False) -> g2
  (False, True)  -> g1
  (False, False) -> overGraphic g2 g1


-- The Focus and DirtyBit types are for system state.

-- | The Focus type helps focusable widgets communicate with each 
-- other about which widget is in focus.  It consists of a WidgetID 
-- and a FocusInfo.
type Focus = (WidgetID, FocusInfo)

-- | The WidgetID for any given widget is dynamic based 
-- on how many focusable widgets are active at the moment.  It is designed 
-- basically as a counter that focusable widgets will automatically (via the 
-- focusable function) increment.
type WidgetID = Int

-- | The FocusInfo means one of the following:
data FocusInfo = 
        HasFocus
        -- ^ Indicates that this widget is a subwidget of 
        --   a widget that is in focus.  Thus, this widget too is in focus, and 
        --   this widget should pass HasFocus forward.
      | NoFocus 
        -- ^ Indicates that there is no focus information to 
        --   communicate between widgets.
      | SetFocusTo WidgetID
        -- ^ Indicates that the widget whose id is given 
        --   should take focus.  That widget should then pass NoFocus onward.
  deriving (Show, Eq)

-- | The dirty bit is a bit to indicate if the widget needs to be redrawn.
type DirtyBit = Bool