module FRP.UISF.Widget.Construction where
import FRP.UISF.Graphics
import FRP.UISF.UITypes
import FRP.UISF.UISF
import FRP.UISF.AuxFunctions (SEvent, delay, constA)
import Control.Arrow
import Data.Maybe (fromMaybe)
padding :: Int
padding = 3
bg :: Color
bg = LightBeige
(//) :: Graphic -> Graphic -> Graphic
(//) = overGraphic
whenG :: Bool -> Graphic -> Graphic
whenG True g = g
whenG False _ = nullGraphic
inside :: Point -> Rect -> Bool
inside (u, v) ((x, y), (w, h)) = u >= x && v >= y && u < x + w && v < y + h
mkWidget :: s
-> Layout
-> (a -> s -> Rect -> UIEvent ->
(b, s, DirtyBit))
-> (Rect -> Bool -> s -> Graphic)
-> UISF a b
mkWidget i layout comp draw = proc a -> do
rec s <- delay i -< s'
(b, s') <- mkUISF layout aux -< (a, s)
returnA -< b
where
aux (ctx,f,t,e,(a,s)) = (db, f, g, nullTP, (b, s'))
where
rect = bounds ctx
(b, s', db) = comp a s rect e
g = draw rect (snd f == HasFocus) s'
mkBasicWidget :: Layout
-> (Rect -> Graphic)
-> UISF a a
mkBasicWidget layout draw = mkUISF layout $ \(ctx, f, _, _, a) ->
(False, f, draw $ bounds ctx, nullTP, a)
toggle :: (Eq s) => s
-> Layout
-> (Rect -> Bool -> s -> Graphic)
-> UISF s Bool
toggle iState layout draw = focusable $
mkWidget iState layout process draw
where
process s s' _ e = (on, s, s /= s')
where
on = case e of
Button _ LeftButton True -> True
SKey KeyEnter _ True -> True
Key ' ' _ True -> True
_ -> False
mkSlider :: Eq a => Bool
-> (a -> Int -> Int)
-> (Int -> Int -> a)
-> (Int -> Int -> a -> a)
-> a
-> UISF (SEvent a) a
mkSlider hori val2pos pos2val jump val0 = focusable $
mkWidget (val0, Nothing) d process draw
where
rotP p@(x,y) ((bx,by),_) = if hori then p else (bx + y by, by + x bx)
rotR r@(p,(w,h)) bbx = if hori then r else (rotP p bbx, (h,w))
(minw, minh) = (16 + padding * 2, 16 + padding * 2)
(tw, th) = (16, 8)
d = if hori then makeLayout (Stretchy minw) (Fixed minh)
else makeLayout (Fixed minh) (Stretchy minw)
val2pt val ((bx,by), (bw,_bh)) =
let p = val2pos val (bw padding * 2 tw)
in (bx + p + padding, by + 8 th `div` 2 + padding)
bar ((x,y),(w,_h)) = ((x + padding + tw `div` 2, y + 6 + padding),
(w tw padding * 2, 4))
draw b inFocus (val, _) =
let p@(mx,my) = val2pt val (rotR b b)
in shadowBox popped (rotR (p, (tw, th)) b)
// whenG inFocus (shadowBox marked $ rotR (p, (tw2, th2)) b)
// withColor bg (rectangleFilled $ rotR ((mx + 2, my + 2), (tw 4, th 4)) b)
// shadowBox pushed (rotR (bar (rotR b b)) b)
process ea (val, s) b evt = (val', (val', s'), val /= val')
where
(val', s') = case ea of
Just a -> (a, s)
Nothing -> case evt of
Button pt' LeftButton down -> let pt = rotP pt' bbx in
case (pt `inside` target, down) of
(True, True) -> (val, Just (ptDiff pt val))
(_, False) -> (val, Nothing)
(False, True) | pt `inside` bar' -> (clickonbar pt, s)
_ -> (val, s)
MouseMove pt' -> let pt = rotP pt' bbx in
case s of
Just pd -> (pt2val pd pt, Just pd)
Nothing -> (val, s)
SKey KeyLeft _ True -> if hori then (jump (1) bw val, s) else (val, s)
SKey KeyRight _ True -> if hori then (jump 1 bw val, s) else (val, s)
SKey KeyUp _ True -> if hori then (val, s) else (jump (1) bw val, s)
SKey KeyDown _ True -> if hori then (val, s) else (jump 1 bw val, s)
SKey KeyHome _ True -> (pos2val 0 (bw 2 * padding tw), s)
SKey KeyEnd _ True -> (pos2val bw (bw 2 * padding tw), s)
_ -> (val, s)
bbx@((bx,_by),(bw,_bh)) = rotR b b
bar' = let ((x,y),(w,h)) = bar bbx in ((x,y4),(w,h+8))
target = (val2pt val bbx, (tw, th))
ptDiff (x,_) val =
let (x', y') = val2pt val bbx
in (x' + tw `div` 2 x, y' + th `div` 2 x)
pt2val (dx, _dy) (x,_y) = pos2val (x + dx bx tw `div` 2) (bw 2 * padding tw)
clickonbar (x',_y') =
let (x,_y) = val2pt val bbx
in jump (if x' < x then 1 else 1) bw val
cyclebox :: Layout -> [(Rect -> Bool -> Graphic, b)] -> Int -> UISF () b
cyclebox d lst start = constA Nothing >>> cycleboxS d lst start
cycleboxS :: Layout -> [(Rect -> Bool -> Graphic, b)] -> Int -> UISF (SEvent Int) b
cycleboxS d lst start = focusable $
mkWidget start d process draw
where
len = length lst
incr i = (i+1) `mod` len
draw b inFocus i = (fst (lst!!i)) b inFocus
process ei i b evt = (snd (lst!!i'), i', i /= i')
where
j = fromMaybe i ei
i' = case evt of
Button _ LeftButton True -> incr j
SKey KeyEnter _ True -> incr j
Key ' ' _ True -> incr j
_ -> j
focusable :: UISF a b -> UISF a b
focusable (UISF layout f) = proc x -> do
rec hasFocus <- delay False -< hasFocus'
(y, hasFocus') <- UISF layout (h f) -< (x, hasFocus)
returnA -< y
where
h fun (ctx, (myid,focus),t, inp, (a, hasFocus)) = do
let (f, hasFocus') = case (focus, hasFocus, inp) of
(HasFocus, _, _) -> (HasFocus, True)
(SetFocusTo n, _, _) | n == myid -> (NoFocus, True)
(DenyFocus, _, _) -> (DenyFocus, False)
(_, _, Button pt _ True) -> (NoFocus, pt `inside` bounds ctx)
(_, True, SKey KeyTab ms True) -> if hasShiftModifier ms
then (SetFocusTo (myid1), False)
else (SetFocusTo (myid+1), False)
(_, _, _) -> (focus, hasFocus)
focus' = if hasFocus' then HasFocus else DenyFocus
inp' = if hasFocus' then (case inp of
SKey KeyTab _ _ -> NoUIEvent
_ -> inp)
else (case inp of
Button _ _ True -> NoUIEvent
Key _ _ _ -> NoUIEvent
SKey _ _ _ -> NoUIEvent
_ -> inp)
redraw = hasFocus /= hasFocus'
(db, _, g, cd, b, UISF newLayout fun') <- fun (ctx, (myid,focus'), t, inp', a)
return (db || redraw, (myid+1,f), g, cd, (b, hasFocus'), UISF newLayout (h fun'))
isInFocus :: UISF () Bool
isInFocus = getFocusData >>> arr ((== HasFocus) . snd)
shadowBox :: (Color,Color,Color,Color) -> Rect -> Graphic
shadowBox (to,ti,bi,bo) ((x, y), (w, h)) =
withColor to (line (x, y) (x, y + h 1)
// line (x, y) (x + w 2, y))
// withColor bo (line (x + 1, y + h 1) (x + w 1, y + h 1)
// line (x + w 1, y) (x + w 1, y + h 1))
// withColor ti (line (x + 1, y + 1) (x + 1, y + h 2)
// line (x + 1, y + 1) (x + w 3, y + 1))
// withColor bi (line (x + 2, y + h 2) (x + w 2, y + h 2)
// line (x + w 2, y + 1) (x + w 2, y + h 2))
pushed, popped, marked :: (Color,Color,Color,Color)
pushed = (MediumBeige, DarkBeige, VLightBeige, White)
popped = (VLightBeige, White, MediumBeige, DarkBeige)
marked = (MediumBeige, White, MediumBeige, White)