-----------------------------------------------------------------------------
-- |
-- Module      :  FRP.UISF.Widget
-- Copyright   :  (c) Daniel Winograd-Cort 2014
-- License     :  see the LICENSE file in the distribution
--
-- Maintainer  :  dwc@cs.yale.edu
-- Stability   :  experimental
--
-- These are the default, built-in widgets for UISF.

{-# LANGUAGE RecursiveDo, Arrows, TupleSections #-}
{-# OPTIONS_HADDOCK prune #-}

module FRP.UISF.Widget where

import FRP.UISF.Widget.Construction
import FRP.UISF.Graphics
import FRP.UISF.UITypes
import FRP.UISF.UISF
import FRP.UISF.AuxFunctions

import Control.Arrow
import Data.Char (isSpace)


------------------------------------------------------------
-- * Widgets
------------------------------------------------------------

----------------
-- Text Label --
----------------
-- | Labels are always left aligned and vertically centered.
label :: UITexty s => s -> UISF a a
label s = mkBasicWidget layout draw
  where
    (minw, minh) = (textWidth s + padding * 2, textHeight s + padding * 2)
    layout = makeLayout (Fixed minw) (Fixed minh)
    draw ((x, y), (w, h)) = withColor Black $ text (x + padding, y + (h `div` 2) - 8) s

-----------------
-- Display Box --
-----------------
-- | DisplayField is an output widget showing the instantaneous value of
--  a signal of Strings.  It will show the String over how ever much 
--  space it has available to it.  The static argument will decide what 
--  to cut off in the case where it does not have space to show the 
--  entire String: if given True, it will prefer the older characters 
--  (cutting off later text), and if given False, it will prefer the 
--  newer characters (cutting off older ones.
displayField :: UITexty s => WrapSetting -> UISF s ()
displayField wrap = arr toUIText >>> mkWidget (toUIText "") layout (\v v' _ _ -> ((), v, v /= v')) draw 
  where
    minh = textHeight "" + padding * 2
    layout = makeLayout (Stretchy $ padding * 2) (Stretchy minh)
    draw b@((x,y), (w, h)) _ s = 
      let th = textHeight s
          w' = w - padding * 2
          (pts', texts) = prepText wrap 1 ((x+padding,y+padding), (w-padding*2, h-padding*2)) s
          pts = map (\(x,y) -> (x+padding,y+padding)) pts'
      in withColor Black (textLines $ zip pts $ map (fst . textWithinPixels w') texts)
         // shadowBox pushed b 
         // withColor White (rectangleFilled b)


-- | DisplayStr is an output widget showing the instantaneous value of
--   a signal of strings.
displayStr :: UISF String ()
displayStr = setLayout layout $ displayField NoWrap
  where layout = makeLayout (Stretchy $ padding * 2) (Fixed $ textHeight "" + padding * 2)



-- | display is a widget that takes any show-able value and displays it.
display :: Show a => UISF a ()
display = arr show >>> displayStr

-- | withDisplay is a widget modifier that modifies the given widget 
--   so that it also displays its output value.
withDisplay :: Show b => UISF a b -> UISF a b
withDisplay sf = proc a -> do
  b <- sf -< a
  display -< b
  returnA -< b


--------------
-- Text Box --
--------------
-- | The textbox widget creates a one line field where users can 
--  enter text.  It supports mouse clicks and typing as well as the 
--  left, right, end, home, delete, and backspace special keys.
--
--  The value displayed can be generated by mouse and keyboard events, 
--  but it can also be set programmatically by providing the widget's 
--  input stream with an event containing the value to display.  By 
--  using rec and delay, one can update the contents based on e.g. 
--  other widgets.
--
--  The static argument provides the textbox with initial text.
textbox :: UITexty s => s -> UISF (SEvent s) String
textbox s = (setLayout layout . textField CharWrap) s >>> arr uitextToString
  where layout = makeLayout (Stretchy $ padding * 2) (Fixed $ textHeight "" + padding * 2)

{-# DEPRECATED textboxE "As of UISF-0.4.0.0, use textbox instead" #-}
textboxE :: UITexty s => s -> UISF (SEvent s) String
textboxE = textbox

-- | The textbox' variant of textbox contains no internal state about 
--  the text it displays.  Thus, it must be paired with rec and delay 
--  and used bidirectionally to be effective.
textbox' :: UITexty s => UISF s UIText
textbox' = setLayout layout $ textField' CharWrap
  where layout = makeLayout (Stretchy $ padding * 2) (Fixed $ textHeight "" + padding * 2)

-- | TextFields are like textboxes but can support multiple lines.  By 
--  default, they are stretchy in the vertical dimension.
textField :: UITexty s => WrapSetting -> s -> UISF (SEvent s) UIText
textField wrap startingVal = proc ms -> do
  rec s  <- delay $ toUIText startingVal -< ts
      ts <- textField' wrap -< maybe s toUIText ms
  returnA -< ts

-- | A variant of textField that contains no internal state about the 
--  text it displays.
textField' :: UITexty s => WrapSetting -> UISF s UIText
textField' wrap = focusable $ mkWidget (toUIText "",0) layout process draw 
  where
    paddedRect :: Rect -> Rect
    paddedRect ((x,y), (w, h)) = ((x+padding,y+padding), (w-padding*2, h-padding*2))
    layout = makeLayout (Stretchy $ padding * 2) (Stretchy $ textHeight "" + padding * 2)
    draw b@((x,y), (w, h)) inFocus (s,i) = 
      let texth = textHeight s
          w' = w - padding * 2
          b' = paddedRect b
          (pts, texts) = prepText wrap 1 b' s
          (i',j) = calcLine (i,0) (map uitextToString texts)
          texts' = drop (j + 1 - length pts) texts
          j' = min j (length pts - 1)
          cursory = y + padding + j'*texth
          cursorx = x + 1+padding + textWidth (takeUIText i' $ texts !! j)
          cpt1 = (cursorx, cursory)
          cpt2 = (cursorx, cursory+texth)
      in withColor Black (textLines $ zip pts $ map (fst . textWithinPixels w') texts')
         // whenG (inFocus && inside cpt1 b' && inside cpt2 b') 
                  (withColor Gray $ line cpt1 cpt2)
         // shadowBox pushed b 
         // withColor White (rectangleFilled b)
    calcLine ij [] = ij
    calcLine (i,j) [s] = if i < length s then (i,j) else case reverse s of
      '\n':_ -> (0,j+1)
      _ -> (i,j)
    calcLine (i,j) (s:ss) = let i' = i - length s in if i' >= 0 then calcLine (i',j+1) ss else (i,j)
    trimTailWS :: UIText -> UIText
    trimTailWS (UIText uit) = case reverse uit of
      [] -> UIText uit
      ((c,f,str):uit') -> case reverse str of
        [] -> trimTailWS $ UIText $ reverse uit'
        (ch:s') -> if isSpace ch then UIText $ reverse ((c,f,reverse s'):uit')
                   else UIText uit
    process str state@(_,i) b@((x,y),(w,_)) evt = (snew, (snew,inew), state /= (snew,inew))
      where 
        s = toUIText str
        texth = textHeight s
        (pts, texts) = prepText wrap 1 (paddedRect b) s
        strings = map uitextToString texts
        (i',j) = calcLine (i,0) strings
        (snew,inew) = case evt of
          (Key c _ True)             -> let (t,d) = splitUIText i s 
                                        in (t `appendUIText` toUIText [c] `appendUIText` d, i+1)
          (SKey KeyEnter     _ True) -> let (t,d) = splitUIText i s 
                                        in (t `appendUIText` toUIText "\n" `appendUIText` d, i+1) 
          (SKey KeyBackspace _ True) -> let (t,d) = splitUIText (i-1) s 
                                        in (t `appendUIText` dropUIText 1 d, max (i-1) 0)
          (SKey KeyDelete    _ True) -> let (t,d) = splitUIText i s 
                                        in (t `appendUIText` dropUIText 1 d, i)
          (SKey KeyLeft      _ True) -> (s, max (i-1) 0)
          (SKey KeyRight     _ True) -> (s, min (i+1) (uitextLen s))
          -- For KeyUp, we are on the jth line moving to the (j-1)th line.
          -- We add up the first (j-2) lines and then add the number of characters 
          -- in line (j-1) that take up the same pixel width as the number at i' in 
          -- the jth line.
          -- Note that because j is 0-indexed, we add 1 whenever we do a take.
          (SKey KeyUp        _ True) -> (s, if j <= 0 then 0 else
            sum (map length $ take (j-1) strings) +
            (uitextLen $ fst $ textWithinPixels (textWidth $ takeUIText i' (texts!!j)) 
                            $ trimTailWS (texts!!(j-1))))
          -- KeyDown is the same as KeyUp but in the other direction.
          (SKey KeyDown      _ True) -> (s, if j >= length texts - 1 then uitextLen s else
            sum (map length $ take (j+1) strings) + 
            (uitextLen $ fst $ textWithinPixels (textWidth $ takeUIText i' (texts!!j)) 
                            $ trimTailWS (texts!!(j+1))))
          (SKey KeyEnd       _ True) -> (s, uitextLen s)
          (SKey KeyHome      _ True) -> (s, 0)
          (Button (bx,by) LeftButton True) -> (s,
            let j' = ((by - y) `div` texth) + max 0 (j - length pts)
            in if j' >= length texts then uitextLen s 
               else sum (map length $ take j' strings) + 
                    (uitextLen $ fst $ textWithinPixels (bx - x) $ trimTailWS (texts!!j')))
          _  -> (s, max 0 $ min i $ uitextLen s)




-----------
-- Title --
-----------
-- | Title frames a UI by borders, and displays a static title text.
title :: UITexty s => s -> UISF a b -> UISF a b
title str (UISF fl f) = UISF layout h where
  (tw, th) = (textWidth str, textHeight str)
  drawit ((x, y), (w, h)) = 
    withColor Black (text (x + 10, y) str) 
    // withColor bg (rectangleFilled ((x + 8, y), (tw + 4, th))) 
    // shadowBox marked ((x, y + 8), (w, h - 8))
  layout ctx = let l = fl ctx in l { wMin = max (wMin l) tw, hFixed = hFixed l + th + 10 }
  h (CTX flow bbx@((x,y), (w,h)) cj,foc,t,inp, a) = 
    let ctx' = CTX flow ((x + 6, y + th+2), (w - 12, h - th - 10)) cj
    in do (db, foc', g, cd, b, uisf) <- f (ctx', foc, t, inp, a)
          return (db, foc', drawit bbx // g, cd, b, title str uisf)


-- | spacer is an empty widget that will take up empty space without 
--  requesting any space.  This can be useful for lining up other 
--  widgets, for instance if one wants the borders from titles to align 
--  even when the titles are bordering widgets of slightly different 
--  sizes.
spacer :: UISF a a
spacer = mkBasicWidget (Layout 0 0 0 0 0 0 1) (const nullGraphic)


------------
-- Button --
------------
-- | A button is a focusable input widget with a state of being on or off.  
--  It can be activated with either a button press, the enter key, or the 
--  space key.  Buttons also show a static label.
-- 
--  The regular button is down as long as the mouse button or key press is 
--  down and then returns to up.
button :: UITexty s => s -> UISF () Bool
button l = focusable $ 
  mkWidget False d process draw
  where
    (tw, th) = (textWidth l, textHeight l)
    (minw, minh) = (tw + padding * 2, th + padding * 2)
    d = makeLayout (Stretchy minw) (Fixed minh)
    draw b@((x,y), (w,h)) inFocus down = 
      let x' = x + (w - tw) `div` 2 + if down then 0 else -1
          y' = y + (h - th) `div` 2 + if down then 0 else -1
      in withColor Black (text (x', y') l) 
         // whenG inFocus (shadowBox marked b)
         // shadowBox (if down then pushed else popped) b
    process _ s b evt = (s', s', s /= s')
      where 
        s' = case evt of
          Button pt LeftButton down | pt `inside` b -> case (s, down) of
            (False, True) -> True
            (True, False) -> False
            _ -> s
          MouseMove pt       -> (pt `inside` b) && s
          SKey KeyEnter _ down -> down
          Key ' ' _ down -> down
          _ -> s


-- | The sticky button, on the other hand, once 
-- pressed, remains depressed until is is clicked again to be released.
-- Thus, it looks like a button, but it behaves more like a checkbox.
stickyButton :: UITexty s => s -> UISF () Bool
stickyButton l = constA Nothing >>> stickyButtonS l

-- | This variant of stickyButton is settable by its input stream.
stickyButtonS :: UITexty s => s -> UISF (SEvent Bool) Bool
stickyButtonS l = arr (fmap $ \b -> if b then 1 else 0) >>> cycleboxS d lst 0 where
  (tw, th) = (textWidth l, textHeight l)
  (minw, minh) = (tw + padding * 2, th + padding * 2)
  d = makeLayout (Stretchy minw) (Fixed minh)
  draw down b@((x,y), (w,h)) inFocus = 
    let x' = x + (w - tw) `div` 2 + if down then 0 else -1
        y' = y + (h - th) `div` 2 + if down then 0 else -1
    in withColor Black (text (x', y') l) 
       // whenG inFocus (shadowBox marked b)
       // shadowBox (if down then pushed else popped) b
  lst = [(draw False, False),(draw True, True)]


---------------
-- Check Box --
---------------
-- | Checkbox allows selection or deselection of an item.
--   It has a static label as well as an initial state.
checkbox :: UITexty s => s -> Bool -> UISF () Bool
checkbox l state = constA Nothing >>> checkboxS l state

-- | This variant of checkbox is settable by its input stream.
checkboxS :: UITexty s => s -> Bool -> UISF (SEvent Bool) Bool
checkboxS l state = proc eb -> do
  rec s  <- delay state -< s'
      e  <- edge <<< toggle state d draw -< s
      let s' = maybe (maybe s (const $ not s) e) id eb
  returnA -< s'
  where
    (tw, th) = (textWidth l, textHeight l)
    (minw, minh) = (tw + padding * 2, th + padding * 2)
    d = makeLayout (Stretchy minw) (Fixed minh)
    draw ((x,y), (_w,h)) inFocus down = 
      let x' = x + padding + 16 
          y' = y + (h - th) `div` 2
          b = ((x + padding + 2, y + h `div` 2 - 6), (12, 12))
      in  withColor Black (text (x', y') l) 
          // whenG inFocus (shadowBox marked b)
          // whenG down 
             (withColor DarkBeige $ polyline 
               [(x + padding + 5, y + h `div` 2),
                (x + padding + 7, y + h `div` 2 + 3),
                (x + padding + 11, y + h `div` 2 - 2)])
          // shadowBox pushed b 
          // withColor White (rectangleFilled b)


---------------------
-- Check Box Group --
---------------------
-- | The checkGroup widget creates a group of 'checkbox'es that all send 
--   their outputs to the same output stream. It takes a static list of 
--   labels for the check boxes and assumes they all start unchecked.
--   
--   The output stream is a list of each a value that was paired with a 
--   String value for which the check box is checked.
checkGroup :: [(String, a)] -> UISF () [a]
checkGroup sas = constA (repeat Nothing) >>> checkGroupS sas

checkGroupS :: [(String, a)] -> UISF [SEvent Bool] [a]
checkGroupS sas = let (s, a) = unzip sas in
  concatA (zipWith checkboxS s (repeat False)) >>>
  arr (map fst . filter snd . zip a)


-------------------
-- Radio Buttons --
-------------------
-- | Radio button presents a list of choices and only one of them can be 
-- selected at a time.  It takes a static list of choices (as Strings) 
-- and the index of the initially selected one, and the widget itself 
-- returns the continuous stream representing the index of the selected 
-- choice.
radio :: UITexty s => [s] -> Int -> UISF () Int
radio labels i = constA Nothing >>> radioS labels i

-- | This variant of radio is settable by its input stream.
radioS :: UITexty s => [s] -> Int -> UISF (SEvent Int) Int
radioS labels i = proc ei -> do
  rec s   <- delay i -< s''
      s'  <- aux 0 labels -< s
      let s'' = maybe (maybe s id s') id ei
  returnA -< s''
  where
    --aux :: Int -> [String] -> UISF Int (SEvent Int)
    aux _ [] = arr (const Nothing)
    aux j (l:ls) = proc n -> do
      u <- edge <<< toggle (i == j) d draw -< n == j
      v <- aux (j + 1) ls -< n
      returnA -< maybe v (const $ Just j) u
      where
        (tw, th) = (textWidth l, textHeight l)
        (minw, minh) = (tw + padding * 2, th + padding * 2)
        d = makeLayout (Stretchy minw) (Fixed minh)
        draw ((x,y), (_w,h)) inFocus down = 
          let xT = x + padding + 16 
              yT = y + (h - th) `div` 2
              xC = x + padding + 2
              yC = y + (th `div` 2)
          in  withColor Black (text (xT, yT) l) 
              // withColor DarkBeige (circleOutline (xC, yC) 5)
              // withColor White (arc ((xC-5, yC-5), (11, 11)) 0 360)
              // whenG down    (withColor DarkBeige (circleFilled (xC, yC) 3))
              // whenG inFocus (withColor MediumBeige (circleOutline (xC, yC) 7))

--------------
-- List Box --
--------------


-- | The listbox widget creates a box with selectable entries.
--  It takes two static values indicating the initial list 
--  of data to display and the initial index selected (use -1 for no 
--  selection).  It takes two event streams that can be used to 
--  independently set the list and index.  The output stream is the 
--  currently selected index.
--
--  Note that the index can be greater than the length 
--  of the list (simply indicating no choice selected).
listbox :: (Eq a, Show a) => [a] -> Int -> UISF (SEvent [a], SEvent Int) Int
listbox sDB sI = proc (eDB, eI) -> do
  rec let db' = maybe db id eDB
      db <- delay sDB -< db'
      i' <- delay sI  -< i
      i  <- listbox'  -< (db', maybe i' id eI)
  returnA -< i

-- | This variant of listbox does not keep its list or index stored 
--  internally and thus accepts a stream of those values.  As such, 
--  it requires no static initializing parameters.  This can be useful 
--  when the list or index are being updated frequently.
listbox' :: (Eq a, Show a) => UISF ([a], Int) Int
listbox' = focusable $ mkWidget ([], -1) layout process draw
  where
    layout = makeLayout (Stretchy 80) (Stretchy lineheight)
    -- takes the rectangle to draw in and a tuple of the list of choices and the index selected
    lineheight = textHeight ""
    --draw :: Show a => Rect -> ([a], Int) -> Graphic
    draw rect@((x,y'),(w,_h)) _ (lst, i) = 
        genTextGraphic (y'+2) i lst --shadowbox is 2 pixels wide, so we add 2 to y
        // shadowBox pushed rect 
        // withColor White (rectangleFilled rect)
        where
          trimText v = fst $ textWithinPixels (w - padding * 2) (show v)
          genTextGraphic _ _ [] = nullGraphic
          genTextGraphic y i (v:vs) = (if i == 0
                then withColor White (text (x + padding, y + padding) (trimText v))
                     // withColor Blue (rectangleFilled ((x+2,y),(w-4,lineheight)))
                      --shadowbox is 2 pixels wide, so we add 2 to x and subtract 4 from w
                else withColor Black (text (x + padding, y + padding) (trimText v))) 
                // genTextGraphic (y+lineheight) (i - 1) vs
    process :: Eq a => ([a], Int) -> ([a], Int) -> Rect -> UIEvent -> (Int, ([a], Int), Bool)
    process (lst,i) olds bbx e = (i', (lst, i'), olds /= (lst, i'))
        where
        i' = case e of
          Button pt LeftButton True -> boundCheck $ pt2index pt
          SKey KeyDown _ True   -> min (i+1) (length lst - 1)
          SKey KeyUp   _ True   -> max (i-1) 0
          SKey KeyHome _ True   -> 0
          SKey KeyEnd  _ True   -> length lst - 1
          _ -> boundCheck i
        ((_,y),_) = bbx
        pt2index (_px,py) = (py-y) `div` lineheight
        boundCheck j = if j >= length lst then -1 else j


----------------
-- *** Sliders
----------------

-- $ Sliders are input widgets that allow the user to choose a value within 
-- a given range.  They come in both continuous and discrete flavors as well 
-- as in both vertical and horizontal layouts.
-- 
-- Sliders take a boundary argument giving the minimum and maximum possible 
-- values for the output as well as an initial value.  In addition, discrete 
-- (or integral) sliders take a step size as their first argument.

hSlider, vSlider :: RealFrac a => (a, a) -> a -> UISF () a
-- | Horizontal Continuous Slider
hSlider a b = constA Nothing >>> hSliderS a b
-- | Vertical Continuous Slider
vSlider a b = constA Nothing >>> vSliderS a b

hiSlider, viSlider :: Integral a => a -> (a, a) -> a -> UISF () a
-- | Horizontal Discrete Slider
hiSlider a b c = constA Nothing >>> hiSliderS a b c
-- | Vertical Discrete Slider
viSlider a b c = constA Nothing >>> viSliderS a b c


-- $ Sliders also come in a programmatically updatable variety.

hSliderS, vSliderS :: RealFrac a => (a, a) -> a -> UISF (SEvent a) a
-- | Settable Horizontal Continuous Slider
hSliderS = slider True
-- | Settable Vertical Continuous Slider
vSliderS = slider False

hiSliderS, viSliderS :: Integral a => a -> (a, a) -> a -> UISF (SEvent a) a
-- | Settable Horizontal Discrete Slider
hiSliderS = iSlider True
-- | Settable Vertical Discrete Slider
viSliderS = iSlider False

slider :: RealFrac a => Bool -> (a, a) -> a -> UISF (SEvent a) a
slider hori (min, max) = mkSlider hori v2p p2v jump
  where
    v2p v w = truncate ((v - min) / (max - min) * fromIntegral w)
    p2v p w =  
      let v = min + (fromIntegral (p - padding) / fromIntegral w * (max - min))
      in if v < min then min else if v > max then max else v
    jump d w v = 
      let v' = v + fromIntegral d * (max - min) * 16 / fromIntegral w
      in if v' < min then min else if v' > max then max else v'

iSlider :: Integral a => Bool -> a -> (a, a) -> a -> UISF (SEvent a) a
iSlider hori step (min, max) = mkSlider hori v2p p2v jump
  where
    v2p v w = w * fromIntegral (v - min) `div` fromIntegral (max - min)
    p2v p w =  
      let v = min + fromIntegral (round (fromIntegral (max - min) * 
              fromIntegral (p - padding) / fromIntegral w))
      in if v < min then min else if v > max then max else v
    jump d _w v = 
      let v' = v + step * fromIntegral d 
      in if v' < min then min else if v' > max then max else v'


---------------------
-- *** Graphs
---------------------

---------------------
-- Real Time Graph --
---------------------
-- | The realtimeGraph widget creates a graph of the data with trailing values.  
-- It takes a dimension parameter, the length of the history of the graph 
-- measured in time, and a color for the graphed line.
-- The signal function then takes an input stream of 
-- (value,time) event pairs, but since there can be zero or more points 
-- at once, we use [] rather than 'SEvent' for the type.
-- The values in the (value,time) event pairs should be between -1 and 1.
realtimeGraph :: RealFrac a => Layout -> DeltaT -> Color -> UISF [(a,Time)] ()
realtimeGraph layout hist color = arr ((),) >>> first accumTime >>>
  mkWidget ([(0,0)],0) layout process draw
  where draw _              _ ([],        _) = nullGraphic
        draw ((x,y), (w,h)) _ (lst@(_:_), t) = translateGraphic (x,y) $ 
          withColor color $ polyline (map (adjust t) lst)
          where adjust t (i,t0) = (truncate $ fromIntegral w * (hist + t0 - t) / hist,
                                   buffer + truncate (fromIntegral (h - 2*buffer) * (1 + i)/2))
                buffer = truncate $ fromIntegral h / 10
        removeOld _ [] = []
        removeOld t ((i,t0):is) = if t0+hist>=t then (i,t0):is else removeOld t is
        process (t,is) (lst,_) _ _ = ((), (removeOld t (lst ++ is), t), True) 



---------------
-- Histogram --
---------------
-- | The histogram widget creates a histogram of the input map.  It assumes 
-- that the elements are to be displayed linearly and evenly spaced.  Also, 
-- the values to be plotted must be between 0 and 1 (inclusive).
histogram :: RealFrac a => Layout -> UISF (SEvent [a]) ()
histogram layout = 
  mkWidget Nothing layout process draw
  where process Nothing Nothing  _ _ = ((), Nothing, False)
        process Nothing (Just a) _ _ = ((), Just a, False) --TODO check if this should be True
        process (Just a) _       _ _ = ((), Just a, True)
        draw (xy, (w, h)) _ (Just lst@(_:_)) = translateGraphic xy $ polyline $ mkPts lst
          where mkPts l  = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l)
                xs n     = let k = n-1 in 0 : map (\x -> truncate $ fromIntegral (w*x) / fromIntegral k) [1..k]
                adjust i = buffer + truncate (fromIntegral (h - 2*buffer) * (1 - i))
                normalize lst = map (max 0 . min 1) lst
                buffer = min 12 $ truncate $ fromIntegral h / 10
        draw _ _ _ = nullGraphic

-- | The histogramWithScale widget creates a histogram and an x coordinate scale.
histogramWithScale :: RealFrac a => Layout -> UISF (SEvent [(a,String)]) ()
histogramWithScale layout = 
  mkWidget Nothing layout process draw
  where process Nothing Nothing  _ _ = ((), Nothing, False)
        process Nothing (Just a) _ _ = ((), Just a, False) --TODO check if this should be True
        process (Just a) _       _ _ = ((), Just a, True)
        draw (xy, (w, h)) _ (Just lst@(_:_)) = translateGraphic xy $ mkScale strLst // (polyline $ mkPts aLst)
          where (aLst, strLst) = unzip lst
                mkPts l  = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l)
                xs n     = let k  = n-1
                               w' = w - leftbuffer - rightbuffer
                           in leftbuffer : map (\x -> leftbuffer + (truncate $ fromIntegral (w'*x) / fromIntegral k)) [1..k]
                adjust i = topbuffer + truncate (fromIntegral (h - topbuffer - bottombuffer) * (1 - i))
                normalize lst = map (max 0 . min 1) lst
                topbuffer = min 12 $ truncate $ fromIntegral h / 10
                bottombuffer = 20
                leftbuffer = 4 + (8 * length (head strLst)) `div` 2
                rightbuffer = 4 + (8 * length (last strLst)) `div` 2
                mkScale l = foldl (\pg (x,s) -> withColor Black (text (x-((8*length s) `div` 2), h-16) s) // pg) 
                                  nullGraphic $ zip (xs $ length l) l
        draw _ _ _ = nullGraphic


------------------------------------------------------------
-- *** Virtual Real Estate
------------------------------------------------------------

-- | The scrollable function puts sub-widgets into a virtual canvas that 
--  can be scrolled using sliders that appear when necessary.  The first 
--  argument is the actual layout of the scrollable area, and the second 
--  argument is the size of the virtual canvas.
scrollable :: Layout -> Dimension -> UISF a b -> UISF a b
scrollable layout (w,h) sf = withCTX $ proc ((CTX flow (asdf, (w',h')) _),a) -> do
  (| bottomUp (do
    ws <- if w > w' then hSlider (0,1) 0 -< ()
                    else returnA -< 0
    (| rightLeft (do
      hs <- if h > h' then vSlider (0,1) 0 -< ()
                      else returnA -< 0
      transform sf -< (flow, ws, hs, a) ) |) ) |)
  where
    transform (UISF fl f) = UISF (const layout) fun where
      fun (CTX flow' bbx'@((x',y'), (w',h')) cj',foc,t,inp, (flow, ws, hs, a)) = do
        (db, foc', g, cd, b, uisf) <- f (ctx', foc, t, update inp, a)
        return (db, foc', restrict g, cd, b, transform uisf)
          where
            xoff = max 0 $ round $ (fromIntegral (w-w')) * ws
            yoff = max 0 $ round $ (fromIntegral (h-h')) * hs
            ctx' = CTX flow ((x',y'), (w,h)) cj'
            update (MouseMove p) = MouseMove $ adjustPoint p bbx' (w,h) (xoff,yoff)
            update (Button p@(x,y) mb isDown) = Button (adjustPoint p bbx' (w,h) (xoff,yoff)) mb isDown
            update e = e
            restrict g = boundGraphic bbx' $ translateGraphic (0-xoff,0-yoff) g
            compareRange :: Ord a => a -> (a,a) -> Ordering
            compareRange x (l,u) = case (x < l, x > u) of
              (True, _) -> LT
              (False, True) -> GT
              _ -> EQ
            adjustPoint (x,y) ((x',y'), (w',h')) (w,h) (xoff,yoff) = (xu,yu) where
              xu = case compareRange x (x', x'+w') of
                      LT -> x - xoff
                      EQ -> x + xoff
                      GT -> x + w - w'
              yu = case compareRange y (y', y'+h') of
                      LT -> y - yoff
                      EQ -> y + yoff
                      GT -> y + h - h'


------------------------------------------------------------
-- *** Custom Graphics
------------------------------------------------------------

-- | Canvas displays any graphics. The input is a signal of graphics
-- events because we only want to redraw the screen when the input
-- is there.
canvas :: Dimension -> UISF (SEvent Graphic) ()
canvas (w, h) = mkWidget nullGraphic layout process draw 
  where
    layout = makeLayout (Fixed w) (Fixed h)
    draw ((x,y),(w,h)) _ = translateGraphic (x,y)
    process (Just g) _ _ _ = ((), g, True)
    process Nothing  g _ _ = ((), g, False)

-- | canvas' uses a layout and a graphic generator.  This allows it to 
-- behave similarly to 'canvas', but it can adjust in cases with stretchy layouts.
canvas' :: Layout -> (a -> Dimension -> Graphic) -> UISF (SEvent a) ()
canvas' layout draw = mkWidget Nothing layout process drawit
  where
    drawit (pt, dim) _ = maybe nullGraphic (\a -> translateGraphic pt $ draw a dim)
    process (Just a) _ _ _ = ((), Just a, True)
    process Nothing  a _ _ = ((), a, False)