-----------------------------------------------------------------------------
-- |
-- 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 (
  -- * UI Types
  -- $uitypes
  TerminationProc(..), nullTP, mergeTP,
  -- * Rendering Context
  CTX(..), Flow(..),
  -- * UI Layout
  makeLayout, LayoutType(..), nullLayout, Layout(..),
  -- * Context and Layout Functions
  divideCTX, mergeLayout, 
  -- * Graphics
  mergeGraphics,
  -- * System State
  DirtyBit, Focus, WidgetID, FocusInfo(..),
  -- * UIEvent
  UIEvent(..),
  Key(..),
  SpecialKey(..),
  MouseButton(..),
  -- * Key State Checks
  hasShiftModifier, hasCtrlModifier, hasAltModifier,
  isKeyPressed,
  -- * Framework Connections
  -- $frameworkconnections
  updateKeyState
  ) where

import FRP.UISF.Graphics
import Data.IORef
import Data.List (delete)
import System.IO.Unsafe (unsafePerformIO)

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

{- $uitypes
In this module, we will declare the various types to make creating the 
overall UI possible.  We will discuss the ideas for widgets in some 
detail, but for specifics on the type of a widget (the 'UISF' type), 
see the UISF type in "FRP.UISF.UISF", and for information on specific 
widgets, see "FRP.UISF.Widget".

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.

 - an event with data relating to UI actions.

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 a procedure to run upon termination (for proper shutdown when finished).

Additionally, as widgets are generic arrows, there will be a parameterized 
input and output types.

-}

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

-- | The termination procedure is simply a potential IO action.
type TerminationProc = Maybe (IO ())

-- | The null termination procedure is no action.
nullTP :: TerminationProc
nullTP = Nothing

-- | A method for merging two termination procedures.
mergeTP :: TerminationProc -> TerminationProc -> TerminationProc
mergeTP Nothing     Nothing     = Nothing
mergeTP le@(Just _) Nothing     = le
mergeTP Nothing     re@(Just _) = re
mergeTP (Just l)    (Just r)    = Just (l >> r)


------------------------------------------------------------
-- * 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)


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

-- $ 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 w) (Fixed h) = Layout 0 0 w h 0 0 0
makeLayout (Stretchy wMin) (Fixed h) = Layout 1 0 0 h wMin 0 0
makeLayout (Fixed w) (Stretchy hMin) = Layout 0 1 w 0 0 hMin 0
makeLayout (Stretchy wMin) (Stretchy hMin) = Layout 1 1 0 0 wMin hMin 0

-- | 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 = NullLayout --Layout 0 0 0 0 0 0 0


-- | More complicated layouts can be manually constructed with direct 
-- access to the Layout data type.
--
-- 1. wStretch and hStretch specify how much stretching space (in comparative 
--    units) in the width and height should be allocated for this widget.
-- 
-- 2. wFixed and hFixed specify how much non-stretching space (in pixels) 
--    of width and height should be allocated for this widget.
-- 
-- 3. wMin and hMin specify minimum values (in pixels) of width and height 
--    for the widget's stretchy dimensions.
--
-- 4. lFill specifies how much expanding space (in comparative units) this 
--    widget should fill out in excess space that would otherwise be unused.

data Layout = NullLayout | Layout
  { wStretch :: Int
  , hStretch :: Int
  , wFixed   :: Int
  , hFixed   :: Int
  , wMin     :: Int
  , hMin     :: Int
  , lFill    :: 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) l1 l2 = if c then (ctx,ctx) else case (l1,l2) of
  (NullLayout, _) -> (CTX a ((0,0),(0,0)) c, ctx)
  (_, NullLayout) -> (ctx, CTX a ((0,0),(0,0)) c)
  ((Layout wStretch  hStretch  wFixed  hFixed  wMin  hMin  lFill), 
   (Layout wStretch' hStretch' wFixed' hFixed' wMin' hMin' lFill')) ->
      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
        (w1L,w2L,w1T,w2T) = calc w wStretch wStretch' wFixed wFixed' wMin wMin' lFill lFill'
        (h1T,h2T,h1L,h2L) = calc h hStretch hStretch' hFixed hFixed' hMin hMin' lFill lFill'
        calc len stretch stretch' fixed fixed' lmin lmin' fill fill' = (st1, st2, fi1, fi2) where
          portion s = div' (s * (len - fixed - fixed')) (stretch + stretch')
          (st1,st2) = let u = min len $ fixed  + max lmin  (portion stretch)
                          v =           fixed' + max lmin' (portion stretch')
                          por f = div' (f * (len - u - v)) (fill + fill')
                      in if u+v > len then (u, len-u) else (u + por fill, v + por fill')
          fi1 = if fill  > 0 then len else max lmin  (if stretch  == 0 then fixed  else len)
          fi2 = if fill' > 0 then len else max lmin' (if stretch' == 0 then fixed' else len)
        div' b 0 = 0
        div' b d = div b d


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

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


------------------------------------------------------------
-- * Graphics
------------------------------------------------------------

-- | 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, l2) of
  (NullLayout,  NullLayout)  -> nullGraphic
  (NullLayout,  _) -> g2
  (_, NullLayout)  -> g1
  (_, _) -> overGraphic g2 g1


------------------------------------------------------------
-- * System State
------------------------------------------------------------
-- $ The DirtyBit and Focus types are for system state.

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

-- | 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.
      | DenyFocus
        -- ^ Any widget that sees this value should recognize that 
        --   they are no longer in focus.  This is useful for nested focus.
  deriving (Show, Eq)


------------------------------------------------------------
-- * UIEvent
------------------------------------------------------------


-- | The UIEvent data type captures the various types of events that 
--  the UI can produce.  These are covered by regular keys, special 
--  keys, mouse button presses, and mouse movement.  Any key event 
--  is accompanied by a list of 'Key's that were down when the given 
--  event took place.
data UIEvent = 
  -- | A Key UIEvent indicates that the user has typed a regular key 
  --  on his/her keyboard.  These will either be upper or lowercase 
  --  characters.
    Key {
      char :: Char,
      modifiers :: [Key],
      isDown :: Bool
    }
  -- | A SKey UIEvent indicates that the user has typed a special 
  --  key.  These are Enter, Backspace, Tab, Delete, etc.  See 
  --  'SpecialKey' for more.
  | SKey {
      skey :: SpecialKey,
      modifiers :: [Key],
      isDown :: Bool
    }
  -- | A Button UIEvent indicates that the user has pressed a mouse 
  --  button.
  | Button {
     pt :: Point,
     mbutton :: MouseButton,
     isDown :: Bool
    }
  -- | Every time the mouse moves, a MouseMove UIEvent will fire.
  | MouseMove {
      pt :: Point
    }
  -- | The NoUIEvent fires when nothing else is going on.  It is 
  --  important that this happens to allow interaction-independent 
  --  processing to continue (e.g. timers, animations, etc.).
  | NoUIEvent
 deriving (Eq,Show)


-------------------
-- Key state
-------------------
{- $frameworkconnections
The 'updateKeyState' function is for use by the GUI framework.  It is 
not intended for use unless one wants to build their own framework.

The key state is kept around so that it is easy to check if a given 
key or button is currently pressed down.  Unfortunately, I've coded it 
as a global IORef, which means I'm using unsafePerformIO.
-}

-- | The global IORef storing the state of all current key presses.
keyState :: IORef [Key]
keyState = unsafePerformIO $ newIORef []

-- | This should be called by the GUI engine (GLUT) whenever the user 
--  presses or releases a key/button.  As long as it is called every 
--  time, it will keep an accurate key state.
updateKeyState :: Key   -- ^ The Key pressed/released.
               -> Bool  -- ^ True if pressed, False if released.
               -> IO [Key]  -- ^ The updated key state.
updateKeyState k s = case s of
    True  -> atomicModifyIORef keyState (dup . add)
    False -> atomicModifyIORef keyState (dup . remove)
  where
    add ks = if k `elem` ks then ks else k:ks
    remove ks = delete k ks
    dup x = (x,x)

-- | This is a convenience function that tests whether either of the 
--  right or left shift keys is in the given list.
hasShiftModifier :: [Key] -> Bool
hasShiftModifier ks = elem (SpecialKey KeyShiftL) ks || elem (SpecialKey KeyShiftR) ks

-- | This is a convenience function that tests whether either of the 
--  right or left control keys is in the given list.
hasCtrlModifier :: [Key] -> Bool
hasCtrlModifier ks = elem (SpecialKey KeyCtrlL) ks || elem (SpecialKey KeyCtrlR) ks

-- | This is a convenience function that tests whether either of the 
--  right or left alt keys is in the given list.
hasAltModifier :: [Key] -> Bool
hasAltModifier ks = elem (SpecialKey KeyAltL) ks || elem (SpecialKey KeyAltR) ks

-- | Checks the global key state to determine whether the given key is 
--  currently pressed down.
isKeyPressed :: Key -> IO Bool
isKeyPressed k = do
    ks <- readIORef keyState
    return $ elem k ks





-- | A Key can either be a character, a special key, or a mouse button.
data Key
   = Char Char
   | SpecialKey SpecialKey
   | MouseButton MouseButton
   deriving ( Eq, Ord, Show )

-- | A special key is any non-standard character key.  According to 
--  GLUT, 'KeyUnknown' should never be used, probably because it will 
--  be treated as a weird Char instead of a SpecialKey.
data SpecialKey
   = KeyF1
   | KeyF2
   | KeyF3
   | KeyF4
   | KeyF5
   | KeyF6
   | KeyF7
   | KeyF8
   | KeyF9
   | KeyF10
   | KeyF11
   | KeyF12
   | KeyLeft
   | KeyUp
   | KeyRight
   | KeyDown
   | KeyPageUp
   | KeyPageDown
   | KeyHome
   | KeyEnd
   | KeyInsert
   | KeyNumLock
   | KeyBegin
   | KeyDelete
   | KeyShiftL
   | KeyShiftR
   | KeyCtrlL
   | KeyCtrlR
   | KeyAltL
   | KeyAltR
   | KeyEnter
   | KeyTab
   | KeyEsc
   | KeyBackspace
   | KeyUnknown Int
   deriving ( Eq, Ord, Show )

-- | The standard mouse buttons are represented, but for specialty mice, 
--  one can also use the 'AdditionalButton' value.
data MouseButton
   = LeftButton
   | MiddleButton
   | RightButton
   | WheelUp
   | WheelDown
   | AdditionalButton Int
   deriving ( Eq, Ord, Show )