module FRP.UISF.Widget where
import FRP.UISF.SOE
import FRP.UISF.UIMonad
import FRP.UISF.UISF
import FRP.UISF.AuxFunctions (SEvent, Time, timer, edge, delay, constA, concatA)
import Control.Arrow
padding :: Int
padding = 3
(//) :: Graphic -> Graphic -> Graphic
(//) = overGraphic
whenG :: Bool -> Graphic -> Graphic
whenG b g = if b then g else nullGraphic
label :: String -> UISF a a
label s = mkBasicWidget layout draw
where
(minw, minh) = (length s * 8 + padding * 2, 16 + padding * 2)
layout = makeLayout (Fixed minw) (Fixed minh)
draw ((x, y), (w, h)) = withColor Black $ text (x + padding, y + padding) s
displayStr :: UISF String ()
displayStr = mkWidget "" d (\v v' _ _ -> ((), v, v /= v')) draw
where
minh = 16 + padding * 2
d = makeLayout (Stretchy 8) (Fixed minh)
draw b@((x,y), (w, _h)) _ s =
let n = (w padding * 2) `div` 8
in withColor Black (text (x + padding, y + padding) (take n s))
// box pushed b
// withColor White (block b)
display :: Show a => UISF a ()
display = arr show >>> displayStr
withDisplay :: Show b => UISF a b -> UISF a b
withDisplay sf = proc a -> do
b <- sf -< a
display -< b
returnA -< b
textbox :: UISF String String
textbox = focusable $
conjoin $ proc s -> do
inFocus <- isInFocus -< ()
k <- getEvents -< ()
ctx <- getCTX -< ()
rec let (s', i) = if inFocus then update s iPrev ctx k else (s, iPrev)
iPrev <- delay 0 -< i
displayStr -< seq i s'
inf <- delay False -< inFocus
b <- if inf then timer -< 0.5 else returnA -< Nothing
b' <- edge -< not inFocus
rec willDraw <- delay True -< willDraw'
let willDraw' = maybe willDraw (const $ not willDraw) b
canvas' displayLayout drawCursor -< case (inFocus, b, b', i == iPrev) of
(True, Just _, _, _) -> Just (willDraw, i)
(True, _, _, False) -> Just (willDraw, i)
(False, _, Just _, _) -> Just (False, i)
_ -> Nothing
returnA -< s'
where
minh = 16 + padding * 2
displayLayout = makeLayout (Stretchy 8) (Fixed minh)
update s i _ (Key c _ True) = (take i s ++ [c] ++ drop i s, i+1)
update s i _ (SKey BACKSPACE _ True) = (take (i1) s ++ drop i s, max (i1) 0)
update s i _ (SKey DEL _ True) = (take i s ++ drop (i+1) s, i)
update s i _ (SKey LEFT _ True) = (s, max (i1) 0)
update s i _ (SKey RIGHT _ True) = (s, min (i+1) (length s))
update s _i _ (SKey END _ True) = (s, length s)
update s _i _ (SKey HOME _ True) = (s, 0)
update s _i c (Button (x,_) True True) = (s, min (length s) $ (x xoffset c) `div` 8)
update s i _ _ = (s, max 0 $ min i $ length s)
drawCursor (False, _) _ = nullGraphic
drawCursor (True, i) (w,_h) =
let linew = padding + i*8
in if linew > w then nullGraphic else withColor Black $
line (linew, padding) (linew, 16+padding)
xoffset = fst . fst . bounds
textboxE :: String -> UISF (SEvent String) String
textboxE startingVal = proc ms -> do
rec s' <- delay startingVal -< ts
let s = maybe s' id ms
ts <- textbox -< maybe s id ms
returnA -< ts
title :: String -> UISF a b -> UISF a b
title l uisf = compressUISF (modsf uisf)
where
(tw, th) = (length l * 8, 16)
drawit ((x, y), (w, h)) g =
withColor Black (text (x + 10, y) l)
// withColor' bg (block ((x + 8, y), (tw + 4, th)))
// box marked ((x, y + 8), (w, h 16))
// g
modsf sf a (CTX _ bbx@((x,y), (w,h)) _,f,t,inp) = do
(l,db,f',action,ts,(v,nextSF)) <- expandUISF sf a (CTX TopDown ((x + 4, y + 20), (w 8, h 32))
False, f, t, inp)
let d = l { hFixed = hFixed l + 8, vFixed = vFixed l + 36,
minW = max (tw + 20) (minW l), minH = max 36 (minH l) }
return (d, db, f', first (drawit bbx) action, ts, (v,compressUISF (modsf nextSF)))
button :: String -> UISF () Bool
button = genButton False
stickyButton :: String -> UISF () Bool
stickyButton = genButton True
genButton :: Bool -> String -> UISF () Bool
genButton sticky l = focusable $
mkWidget False d (if sticky then processSticky else processRegular) draw
where
(tw, th) = (8 * length l, 16)
(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 (box marked b)
// box (if down then pushed else popped) b
processRegular _ s b evt = (s', s', s /= s')
where
s' = case evt of
Button _ True down -> case (s, down) of
(False, True) -> True
(True, False) -> False
_ -> s
MouseMove pt -> (pt `inside` b) && s
SKey ENTER _ down -> down
Key ' ' _ down -> down
_ -> s
processSticky _ s _ evt = (s', s', s /= s')
where
s' = case evt of
Button _ True True -> not s
SKey ENTER _ True -> not s
Key ' ' _ True -> not s
_ -> s
checkbox :: String -> Bool -> UISF () Bool
checkbox l state = proc _ -> do
rec s <- delay state -< s'
e <- edge <<< toggle state d draw -< s
let s' = maybe s (const $ not s) e
returnA -< s'
where
(tw, th) = (8 * length l, 16)
(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 (box marked b)
// whenG down
(withColor' gray3 $ polyline
[(x + padding + 5, y + h `div` 2),
(x + padding + 7, y + h `div` 2 + 3),
(x + padding + 11, y + h `div` 2 2)])
// box pushed b
// withColor White (block b)
checkGroup :: [(String, a)] -> UISF () [a]
checkGroup sas = let (s, a) = unzip sas in
constA (repeat ()) >>>
concatA (zipWith checkbox s (repeat False)) >>>
arr (map fst . filter snd . zip a)
radio :: [String] -> Int -> UISF () Int
radio labels i = proc _ -> do
rec s <- delay i -< s''
s' <- aux 0 labels -< s
let s'' = maybe s id s'
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) = (8 * length l, 16)
(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
in withColor Black (text (x', y') l)
// whenG down (circle gray3 (x,y) (5,6) (9,10))
// circle gray3 (x,y) (2,3) (12,13)
// circle gray0 (x,y) (2,3) (13,14)
// whenG inFocus (circle gray2 (x,y) (0,0) (14,15))
listbox :: (Eq a, Show a) => UISF ([a], Int) Int
listbox = focusable $ mkWidget ([], 1) layout process draw >>> delay (1)
where
layout = makeLayout (Stretchy 80) (Stretchy 16)
lineheight = 16
draw rect@(_,(w,_h)) _ (lst, i) =
genTextGraphic rect i lst
// box pushed rect
// withColor White (block rect)
where
n = (w padding * 2) `div` 8
genTextGraphic _ _ [] = nullGraphic
genTextGraphic ((x,y),(w,h)) i (v:vs) = (if i == 0
then withColor White (text (x + padding, y + padding) (take n (show v)))
// withColor Blue (block ((x,y),(w,lineheight)))
else withColor Black (text (x + padding, y + padding) (take n (show v))))
// genTextGraphic ((x,y+lineheight),(w,hlineheight)) (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 True True -> boundCheck $ pt2index pt
SKey DOWN _ True -> min (i+1) (length lst 1)
SKey UP _ True -> max (i1) 0
SKey HOME _ True -> 0
SKey END _ True -> length lst 1
_ -> boundCheck i
((_,y),_) = bbx
pt2index (_px,py) = (pyy) `div` lineheight
boundCheck j = if j >= length lst then 1 else j
hSlider, vSlider :: RealFrac a => (a, a) -> a -> UISF () a
hSlider = slider True
vSlider = slider False
hiSlider, viSlider :: Integral a => a -> (a, a) -> a -> UISF () a
hiSlider = iSlider True
viSlider = iSlider False
slider :: RealFrac a => Bool -> (a, a) -> a -> UISF () 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 () 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'
realtimeGraph :: RealFrac a => Layout -> Time -> Color -> UISF [(a,Time)] ()
realtimeGraph layout hist color = arr ((),) >>> first getTime >>>
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 :: 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)
process (Just a) _ _ _ = ((), Just a, True)
draw (xy, (w, h)) _ = translateGraphic xy . mymap (polyline . mkPts)
where mkPts l = zip (xs $ length l) (map adjust . normalize . reverse $ l)
xs n = reverse $ map truncate [0,(fromIntegral w / fromIntegral (n1))..(fromIntegral w)]
adjust i = buffer + truncate (fromIntegral (h 2*buffer) * (1 i))
normalize lst = map (/m) lst where m = maximum lst
buffer = truncate $ fromIntegral h / 10
mymap :: ([a] -> Graphic) -> SEvent [a] -> Graphic
mymap f (Just lst@(_:_)) = f lst
mymap _ _ = nullGraphic
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 aux -< (a, s)
returnA -< b
where
aux (a,s) (ctx,f,t,e) = (layout, db, f, justGraphicAction g, nullCD, (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 $ \a (ctx, f, _, _) ->
(layout, False, f, justGraphicAction (draw $ bounds ctx), nullCD, 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 _ True True -> True
SKey ENTER _ True -> True
Key ' ' _ True -> True
_ -> False
mkSlider :: Eq a => Bool
-> (a -> Int -> Int)
-> (Int -> Int -> a)
-> (Int -> Int -> a -> a)
-> a
-> UISF () 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 box popped (rotR (p, (tw, th)) b)
// whenG inFocus (box marked $ rotR (p, (tw2, th2)) b)
// withColor' bg (block $ rotR ((mx + 2, my + 2), (tw 4, th 4)) b)
// box pushed (rotR (bar (rotR b b)) b)
process _ (val, s) b evt = (val', (val', s'), val /= val')
where
(val', s') = case evt of
Button pt' True 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
_ -> (val, s)
MouseMove pt' -> let pt = rotP pt' bbx in
case s of
Just pd -> (pt2val pd pt, Just pd)
Nothing -> (val, s)
SKey LEFT _ True -> if hori then (jump (1) bw val, s) else (val, s)
SKey RIGHT _ True -> if hori then (jump 1 bw val, s) else (val, s)
SKey UP _ True -> if hori then (val, s) else (jump (1) bw val, s)
SKey DOWN _ True -> if hori then (val, s) else (jump 1 bw val, s)
SKey HOME _ True -> (pos2val 0 (bw 2 * padding tw), s)
SKey END _ 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
val' = jump (if x' < x then 1 else 1) bw val
in (val', s)
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' :: 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)
focusable :: UISF a b -> UISF a b
focusable widget = proc x -> do
rec hasFocus <- delay False -< hasFocus'
(y, hasFocus') <- compressUISF (h widget) -< (x, hasFocus)
returnA -< y
where
h w (a, hasFocus) (ctx, (myid,focus),t, inp) = do
lshift <- isKeyPressed LSHIFT
rshift <- isKeyPressed RSHIFT
let isShift = lshift || rshift
(f, hasFocus') = case (focus, hasFocus, inp) of
(HasFocus, _, _) -> (HasFocus, True)
(SetFocusTo n, _, _) | n == myid -> (NoFocus, True)
(_, _, Button pt _ True) -> (NoFocus, pt `inside` bounds ctx)
(_, True, SKey TAB _ True) -> if isShift then (SetFocusTo (myid1), False)
else (SetFocusTo (myid+1), False)
(_, _, _) -> (focus, hasFocus)
focus' = if hasFocus' then HasFocus else NoFocus
inp' = if hasFocus' then (case inp of
SKey TAB _ _ -> NoUIEvent
_ -> inp)
else (case inp of
Button _ _ True -> NoUIEvent
Key _ _ _ -> NoUIEvent
SKey _ _ _ -> NoUIEvent
_ -> inp)
redraw = hasFocus /= hasFocus'
(l, db, _, act, tids, (b, w')) <- expandUISF w a (ctx, (myid,focus'), t, inp')
return (l, db || redraw, (myid+1,f), act, tids, ((b, hasFocus'), compressUISF (h w')))
isInFocus :: UISF () Bool
isInFocus = getFocusData >>> arr ((== HasFocus) . snd)
bg, gray0, gray1, gray2, gray3, blue3 :: RGB
bg = rgb 0xec 0xe9 0xd8
gray0 = rgb 0xff 0xff 0xff
gray1 = rgb 0xf1 0xef 0xe2
gray2 = rgb 0xac 0xa8 0x99
gray3 = rgb 0x71 0x6f 0x64
blue3 = rgb 0x31 0x3c 0x79
box :: [(RGB,RGB)] -> Rect -> Graphic
box [] _ = nullGraphic
box ((t, b):cs) ((x, y), (w, h)) =
box cs ((x + 1, y + 1), (w 2, h 2))
// withColor' t (line (x, y) (x, y + h 1)
// line (x, y) (x + w 2, y))
// withColor' b (line (x + 1, y + h 1) (x + w 1, y + h 1)
// line (x + w 1, y) (x + w 1, y + h 1))
circle :: RGB -> Point -> Dimension -> Dimension -> Graphic
circle c (x, y) (w1, h1) (w2, h2) =
withColor' c $ arc (x + padding + w1, y + padding + h1)
(x + padding + w2, y + padding + h2) 0 360
block :: Rect -> Graphic
block ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)]
pushed, popped, marked :: [(RGB,RGB)]
pushed = [(gray2, gray0),(gray3, gray1)]
popped = [(gray1, gray3),(gray0, gray2)]
marked = [(gray2, gray0),(gray0, gray2)]
inside :: Point -> Rect -> Bool
inside (u, v) ((x, y), (w, h)) = u >= x && v >= y && u < x + w && v < y + h