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)
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
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), (wpadding*2, hpadding*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 :: UISF String ()
displayStr = setLayout layout $ displayField NoWrap
where layout = makeLayout (Stretchy $ padding * 2) (Fixed $ textHeight "" + padding * 2)
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 :: 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)
textboxE :: UITexty s => s -> UISF (SEvent s) String
textboxE = textbox
textbox' :: UITexty s => UISF s UIText
textbox' = setLayout layout $ textField' CharWrap
where layout = makeLayout (Stretchy $ padding * 2) (Fixed $ textHeight "" + padding * 2)
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
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), (wpadding*2, hpadding*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 (i1) s
in (t `appendUIText` dropUIText 1 d, max (i1) 0)
(SKey KeyDelete _ True) -> let (t,d) = splitUIText i s
in (t `appendUIText` dropUIText 1 d, i)
(SKey KeyLeft _ True) -> (s, max (i1) 0)
(SKey KeyRight _ True) -> (s, min (i+1) (uitextLen s))
(SKey KeyUp _ True) -> (s, if j <= 0 then 0 else
sum (map length $ take (j1) strings) +
(uitextLen $ fst $ textWithinPixels (textWidth $ takeUIText i' (texts!!j))
$ trimTailWS (texts!!(j1))))
(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 :: 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 :: UISF a a
spacer = mkBasicWidget (Layout 0 0 0 0 0 0 1) (const nullGraphic)
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
stickyButton :: UITexty s => s -> UISF () Bool
stickyButton l = constA Nothing >>> stickyButtonS l
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)]
checkbox :: UITexty s => s -> Bool -> UISF () Bool
checkbox l state = constA Nothing >>> checkboxS l state
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)
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 :: UITexty s => [s] -> Int -> UISF () Int
radio labels i = constA Nothing >>> radioS labels i
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 _ [] = 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 ((xC5, yC5), (11, 11)) 0 360)
// whenG down (withColor DarkBeige (circleFilled (xC, yC) 3))
// whenG inFocus (withColor MediumBeige (circleOutline (xC, yC) 7))
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
listbox' :: (Eq a, Show a) => UISF ([a], Int) Int
listbox' = focusable $ mkWidget ([], 1) layout process draw
where
layout = makeLayout (Stretchy 80) (Stretchy lineheight)
lineheight = textHeight ""
draw rect@((x,y'),(w,_h)) _ (lst, i) =
genTextGraphic (y'+2) i lst
// 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),(w4,lineheight)))
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 (i1) 0
SKey KeyHome _ True -> 0
SKey KeyEnd _ 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 a b = constA Nothing >>> hSliderS a b
vSlider a b = constA Nothing >>> vSliderS a b
hiSlider, viSlider :: Integral a => a -> (a, a) -> a -> UISF () a
hiSlider a b c = constA Nothing >>> hiSliderS a b c
viSlider a b c = constA Nothing >>> viSliderS a b c
hSliderS, vSliderS :: RealFrac a => (a, a) -> a -> UISF (SEvent a) a
hSliderS = slider True
vSliderS = slider False
hiSliderS, viSliderS :: Integral a => a -> (a, a) -> a -> UISF (SEvent a) a
hiSliderS = iSlider True
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'
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 :: 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)) _ (Just lst@(_:_)) = translateGraphic xy $ polyline $ mkPts lst
where mkPts l = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l)
xs n = let k = n1 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
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)
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 = n1
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), h16) s) // pg)
nullGraphic $ zip (xs $ length l) l
draw _ _ _ = nullGraphic
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 (ww')) * ws
yoff = max 0 $ round $ (fromIntegral (hh')) * 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 (0xoff,0yoff) 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'
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)