lgtk-0.8: src/LGtk/Render.hs
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecursiveDo #-}
module LGtk.Render
( inCanvas
) where
import Control.Applicative hiding (empty)
import Control.Monad
import Control.Monad.State
import Control.Lens hiding ((#), beside)
import Data.List
import Data.Typeable
import Data.Maybe
import Diagrams.Prelude
--import Diagrams.BoundingBox
--import Graphics.SVGFonts
import Data.Colour.SRGB
import Unsafe.Coerce
import Data.LensRef
import LGtk.Key
import LGtk.Widgets
----------------------
pairs xs = zip xs (tail xs)
-------------------------------------- Maybe type with another semigroup structure
data Maybe' a = Just' a | Nothing'
instance Semigroup (Maybe' a) where
_ <> Just' a = Just' a
a <> Nothing' = a
instance Monoid (Maybe' a) where
mempty = Nothing'
mappend = (<>)
instance Monad Maybe' where
return = pure
Just' x >>= f = f x
_ >>= _ = Nothing'
instance Applicative Maybe' where
pure = Just'
Just' f <*> Just' x = Just' $ f x
_ <*> _ = Nothing'
instance Functor Maybe' where
fmap _ Nothing' = Nothing'
fmap f (Just' x) = Just' $ f x
-------------------------------------- better clipBy
data X a = X a | Cancel | Z
instance Monoid (X a) where
mempty = Z
mappend = (<>)
instance Semigroup (X a) where
x <> Z = x
Z <> x = x
_ <> Cancel = Cancel
Cancel <> _ = Cancel
clipBy' p d = fmap unX (fmap X d # clipBy p # withEnvelope p <> fmap flipp (stroke p # lw 0 # value Cancel))
where
flipp Cancel = Z
flipp Z = Cancel
unX (X a) = a
unX _ = mempty
--------------------------------------------------------- Identifiers
newtype Id = Id [Int]
deriving (Eq, Ord, Show, Typeable)
type WithId = StateT Id
firstId :: Id
firstId = Id []
newId :: Monad m => WithId m Id
newId = do
x@(Id (i:is)) <- get
put $ Id $ i+1:is
return x
newIds :: Monad m => Id -> WithId m a -> m a
newIds (Id i) = flip evalStateT $ Id (0:i)
instance IsName Id where
---------------------------------------------------------
-- how to handle keyboard events
type KeyHandler m = ModifiedKey -> m Bool
-- focus enter action; keyboard event handler; focus leave action; id of the keyboard-focused widget
type KeyFocusHandler m = (m (), KeyHandler m, m (), Id)
type CapturedEventHandler a m = (MouseEvent a, Dia a) -> m Bool
-- for each mouse event:
-- - what to do
-- - the new keyboard focus handler
-- - the id of the mouse-focused widget
type EventHandler a m = (MouseEvent a, Dia a) -> Maybe' (m (), Maybe (CapturedEventHandler a m), Maybe (KeyFocusHandler m), Id)
-- compiled widget
data CWidget m
= forall a x . (Eq x, Monoid a, Semigroup a)
=> CWidget (RefReader m (([KeyFocusHandler m], [[KeyFocusHandler m]]), x)) (a -> EventHandler () m) (x -> [Id] -> Id -> Dia a)
------------------
value_ :: Monad m => m () -> KeyFocusHandler m -> Id -> Dia Any -> Dia (EventHandler () m)
value_ a c i = value $ valueFun a c i
valueFun a c i = f where
f (Click _, _di) = Just' (a, Nothing, Just c, i)
f (MoveTo _, _di) = Just' (return (), Nothing, Nothing, i)
f _ = mempty
-----------------
[] !!! _ = Nothing
_ !!! n | n < 0 = Nothing
(x:_) !!! 0 = Just x
(_:xs) !!! n = xs !!! (n-1 :: Int)
[x] !!!! _ = x
(x:_) !!!! n | n <= 0 = x
(_:xs) !!!! n = xs !!!! (n-1 :: Int)
inCanvas :: forall m . (MonadRegister m, MonadFix m) => Int -> Int -> Double -> Widget m -> Widget m
inCanvas width height scale w = mdo
let i = firstId
foc <- newRef df
rememberfoc <- newRef df
-- captured event handler
capt <- newRef Nothing
-- mouse-focused widget id
hi <- newRef [i]
let df = (return (), dkh, return (), i)
calcPos i jss = listToMaybe [(a,b) | (a,js) <- zip [0..] jss, (b, j) <- zip [0..] js, i == j]
changeFoc f = do
(_, _, _, j) <- readRef foc
(_, xss_) <- liftRefReader bb
let xss = filter (not . null) xss_
if null xss
then return False
else do
let mp = calcPos j $ map (map (\(_,_,_,i)->i)) xss
((a,_), (a',b')) = maybe ((0,0), (0,0)) (\x -> (x, f x)) mp
if a == a'
then maybe (return False) ((>> return True) . h2) $ (xss !! a') !!! b'
else maybe (return False) ((>> return True) . h2) $ fmap (!!!! b') (xss !!! a')
dkh (SimpleKey Key'Up) = changeFoc $ \(a,b) -> (a-1,b)
dkh (SimpleKey Key'Down) = changeFoc $ \(a,b) -> (a+1,b)
dkh (SimpleKey Key'Left) = changeFoc $ \(a,b) -> (a,b-1)
dkh (SimpleKey Key'Right) = changeFoc $ \(a,b) -> (a,b+1)
dkh (SimpleKey Key'Tab) = moveFoc True
dkh (ControlKey Key'Tab) = moveFoc False
dkh _ = return False
h2 m@(a,_,_,i) = do
i' <- readRef $ _4 `lensMap` foc
when (i /= i') $ do
join $ readRef $ _3 `lensMap` foc
a
writeRef foc m
moveFoc f = do
(_, _, _, j) <- readRef foc
(xs, _) <- liftRefReader bb
h2 $ maybe (head xs) snd $ find (\((_,_,_,x),_) -> x == j) $ pairs $ (if f then id else reverse) (xs ++ xs)
return $ if f then j /= last xs ^. _4 else j /= head xs ^. _4
-- compiled widget
bhr <- newIds firstId $ tr (fromIntegral width / scale) dkh w
let bb = case bhr of
CWidget b _ _ -> liftM fst b
case bhr of
CWidget b hr render -> do
let handle_ Nothing' = writeRef hi [i] -- return ()
handle_ (Just' (a, cap, bb, i)) = do
a
maybe (return ()) (writeRef capt . Just) cap
maybe (return ()) h2 bb
writeRef hi [i]
return ()
hr_ (Just' x) = hr x
hr_ Nothing' = valueFun (return ()) df i
handle f x = do
m <- readRef capt
case m of
Nothing -> handle_ $ hr_ f x
Just f -> do
b <- f x
when (not b) $ writeRef capt Nothing
handleEvent (Release (MousePos p f), di) = handle f (Release $ MousePos p (), di # clearValue # value ())
handleEvent (Click (MousePos p f), di) = handle f (Click $ MousePos p (), di # clearValue # value ())
handleEvent (MoveTo (MousePos p f), di) = handle f (MoveTo $ MousePos p (), di # clearValue # value ())
handleEvent (GetFocus, _di) = readRef rememberfoc >>= h2
handleEvent (LostFocus, _di) = readRef foc >>= writeRef rememberfoc >> h2 df
handleEvent _ = return ()
handleKeys key = do
(_,f,_,_) <- readRef foc
f key
return $ Canvas width height scale handleEvent (Just handleKeys) (liftM3 (,,) (readRef hi) (readRef $ _4 `lensMap` foc) $ liftM snd b) $
\(is, is', x) ->
fmap Just' (render x is is' # alignT # alignL # translate (r2 (-scale/2,scale/2* fromIntegral height / fromIntegral width)))
<> fmap (const Nothing') (rect scale (scale / fromIntegral width * fromIntegral height) # value ())
focWidth = 0.1
text__ :: Double -> Double -> String -> ((Double :& Double), Dia Any)
{-
text_ s = (coords $ boxExtents (boundingBox t) + r2 (0.2, 0.2) , t) where
t = textSVG s 1.8 # stroke # fc black
-}
text__ ma mi s = ((max mi (min ma $ fromIntegral (length s) * 2/3) :& 1), text s)
defcolor = sRGB 0.95 0.95 0.95
tr :: forall m . MonadRegister m
=> Double
-> KeyHandler (Modifier m)
-> Widget m
-> WithId m (CWidget (Modifier m))
tr sca dkh w = do
w' <- lift w
case w' of
Label r -> do
let render bv _ _ = ((rect x y # lw 0 <> te) # clipped (rect x y)) # value mempty
where ((x :& y), te) = text__ 25 5 bv
return $ CWidget (liftM ((,) ([], [])) r) id render
Button r sens col a -> do
i <- newId
let ff (CharKey ' ') = a () >> return True
ff (CharKey '\n') = a () >> return True
ff k = dkh k
kh = (return (), ff, return (), i)
col' = maybe (return black) id col
render (bv, se, color) is is' =
(te # fc (if se then color else gray)
<> roundedRect x y 0.3 # fc (if i `elem` is && se then yellow else defcolor)
# (if is' == i && se then lc yellow . lw focWidth else lc black . lw 0.02)
)
# (if se then value_ (a ()) kh i else value mempty)
# clipBy' (rect (x+0.1) (y+0.1)) # freeze # frame 0.1
where ((x :& y), te) = text__ 15 3 bv
return $ CWidget (liftM3 (\r se c -> (([kh | se], [[kh] | se]), (r,se,c))) r sens col') id render
Entry isOk (rs, rr) -> do
i <- newId
-- s <- readRef rs
j <- lift $ newRef (False, ("", ""))
let f (CharKey c) (a,b) = Just (c:a,b)
f (SimpleKey Key'Backspace) (_:a,b) = Just (a,b)
f (SimpleKey Key'Delete) (a,_:b) = Just (a,b)
f (SimpleKey Key'Left) (c:a,b) = Just (a,c:b)
f (SimpleKey Key'Right) (a,c:b) = Just (c:a,b)
f _ _ = Nothing
commit = do
(_, ab) <- readRef j
let s = value' ab
old <- liftRefReader rs
when (s /= old && isOk s) $ do
rr s
new <- liftRefReader rs
update new
update s = writeRef (_2 `lensMap` j) (reverse s, "")
ff (CharKey '\n') = commit >> return True
ff key = do
x <- readRef (_2 `lensMap` j)
case f key x of
Just x -> writeRef (_2 `lensMap` j) x >> return True
_ -> dkh key
value' (a,b) = reverse a ++ b
text' (False,ab) = value' ab
text' (True,(a,b)) = reverse a ++ "|" ++ b
isOk' (_,ab) = isOk $ value' ab
kh = (fin, ff, fout, i)
where
fin = writeRef (_1 `lensMap` j) True
fout = do
commit
writeRef (_1 `lensMap` j) False
render (orig,bv) is is' =
( te # clipped (rect x y) # value mempty
<> rect x y # (if isOk' bv then (if i `elem` is then fc yellow else (if orig /= value' (snd bv) then fc defcolor else id)) else fc red)
# (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)
# value_ (return ()) kh i
) # freeze # frame 0.1
where ((x :& y), te) = text__ 7 5 $ text' bv
_ <- lift $ onChangeSimple rs $ postponeModification . update
return $ CWidget (liftM ((,) ([kh],[[kh]])) (liftM2 (,) rs (readRef j))) id render
Checkbox (bs, br) -> do
i <- newId
let ff (CharKey ' ') = liftRefReader bs >>= br . not >> return True
ff k = dkh k
kh = (return (), ff, return (), i)
render bv is is' =
(
(if bv then fromVertices [p2 (-0.3, 0), p2 (-0.1,-0.3), p2 (0.3,0.3)]
# lineCap LineCapRound else mempty) # value mempty # lw 0.15
<> rect 1 1 # value_ (br (not bv)) kh i
# fc (if i `elem` is then yellow else sRGB 0.95 0.95 0.95)
# (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)
) # freeze # frame 0.1
return $ CWidget (liftM ((,) ([kh],[[kh]])) bs) id render
Cell r f -> do
i <- newId
r' <- lift $ onChange r $ \x -> do
h <- f (newIds i . tr sca dkh) x
return $ do
hv <- h
return $ case hv of
CWidget rr hr render -> do
(es, rrv) <- rr
return $ (es, UnsafeEqWrap (x, rrv) $ fmap (fmap (fmap hr)) $ render rrv)
return $ CWidget (join r') id $ \(UnsafeEqWrap _ d) is is' -> d is is'
List layout ws -> liftM (foldr conc2 nil) $ mapM (tr sca dkh) ws
where
nil :: MonadRefCreator n => CWidget n
nil = CWidget (return (([],[]),())) id mempty
conc2 (CWidget b hr r) (CWidget b' hr' r')
= CWidget (liftM2 (\((a,a'),b)((c,c'),d)->((a++c,comb layout a' c'),(b,d))) b b') id (\(x,y) -> liftM2 (liftM2 ff) (fmap (fmap (fmap hr)) $ r x) (fmap (fmap (fmap hr')) $ r' y))
comb Vertical = (++)
comb Horizontal = fx
fx (a:as) (b:bs) = (a++b): fx as bs
fx as bs = as ++ bs
ff = case layout of
Horizontal -> \a b -> a # alignT ||| b # alignT
Vertical -> \a b -> a # alignL === b # alignL
Canvas w h d r keyh s f -> do
i <- newId
let ff key = do
b <- fromMaybe (\_ -> return False) keyh key
if b then return True else dkh key
tr di p = case lookupName i di of
Just subd -> p # translate (p2 (0,0) .-. q) # scale (1/((fromIntegral w / d) / sca))
where q = location subd
-- decomp (x :& y) = (x,y)
gg (Just' ls) (Click (MousePos p _), di) = Just' (r (Click $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Just kh, i)
gg (Just' ls) (Release (MousePos p _), di) = Just' (r (Release $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Nothing, i)
gg (Just' ls) (MoveTo (MousePos p _), di) = Just' (r (MoveTo $ MousePos (tr di p) ls, di # clearValue # value ls) >> return (), Nothing, Nothing, i)
gg _ _ = mempty
wi = fromIntegral w / sca
hi = fromIntegral h / sca
kh = (r (GetFocus, undefined) >> return (), ff, r (LostFocus, undefined) >> return (), i)
render bv _is is' = (fmap gg (fmap Just' (f bv # freeze) # scale ((fromIntegral w / d) / sca)
# clipBy' (rect wi hi))
<> rect wi hi # named i # value mempty # lw 0.02 # lc (if is' == i then yellow else black)
) # freeze # frame 0.1
return $ CWidget (liftM ((,) ([kh | isJust keyh],[[kh] | isJust keyh])) s) id render
Combobox xs (bs, br) -> do
let n = length xs
iss <- replicateM n newId
ii <- newId
let -- ff ind _ _ (Just ' ') = br ind
br' ind = br (ind `mod` n)
br'' f = liftRefReader bs >>= br' . f >> return True
ff (CharKey '\n') = br'' (+1)
ff (CharKey ' ') = br'' (+1)
ff (SimpleKey Key'Backspace) = br'' (+(-1))
ff k = dkh k
kh = (return (), ff, return (), ii)
x = maximum [x | txt <- xs, let (x :& _) = fst $ text__ 15 3 txt ]
render bv is is' = vcat (zipWith3 g [0..] iss xs) # freeze # frame 0.1
where
g ind i txt = (
(if bv == ind then fromVertices [p2 (-0.3, 0), p2 (-0.1,-0.3), p2 (0.3,0.3)]
# lineCap LineCapRound else mempty) # value mempty # translate (r2 (x / 2,0)) # lw 0.15
<> te # clipped (rect x y) # value mempty
<> rect x y # (if i `elem` is then fc yellow else id)
# (if is' == ii then lc yellow . lw focWidth else lc black . lw 0.02)
# value_ (br ind) kh i
) # frame 0.02
where ((_ :& y), te) = text__ 15 3 txt
return $ CWidget (liftM ((,) ([kh],[[kh]])) bs) id render
Notebook' br xs -> do
let (names, wis) = unzip xs
n = length names
iss <- replicateM n newId
ii <- newId
ir <- lift $ newRef (0 :: Int)
let br' :: Int -> Modifier m ()
br' ind = br ind' >> writeRef ir ind' where ind' = ind `mod` n
br'' f = readRef ir >>= br' . f >> return True
ff (SimpleKey Key'Left) = br'' (+(-1))
ff (SimpleKey Key'Right) = br'' (+ 1)
ff (AltKey (Key'Char c)) | Just i <- ind c = br'' (const i)
ff k = dkh k
ind c | 0 <= i && i < n = Just i
| otherwise = Nothing
where i = fromEnum c - fromEnum '1'
wisv <- mapM (tr sca dkh) wis
wr <- lift $ onChangeSimple (readRef ir) $ \x -> return $ case wisv !! x of
CWidget rr hr render -> do
(es, rrv) <- rr
return $ (es, UnsafeEqWrap (x, rrv) $ fmap (fmap (fmap hr)) $ render rrv)
let kh = (return (), ff, return (), ii)
render (bv, UnsafeEqWrap _ d) is is' =
vcat
[ strutY 0.1
, alignL $ line 0.2
||| hcat (intersperse (line 0.1) $ zipWith3 g [0..] iss names)
||| line 100
, strutY 0.2
, alignL $ d is is'
] # freeze
where
line dx = fromOffsets [r2 (dx,0)] # strokeLine # translate (r2 (0,-0.5)) # value mempty # lcw
lcw = if is' == ii then lc yellow . lw focWidth else lc black . lw 0.02
g ind i txt =
te # clipped (rect x y) # value mempty
# fc black
<> bez # value mempty
# lcw
<> (if bv == ind then mempty else line x # translate (r2 (-x/2, 0))) # lcw
<> bez' # closeLine # strokeLoop # translate (r2 (-x/2,-y/2)) # lw 0
# (if bv == ind then value mempty else value_ (br' ind) kh i)
# (if bv /= ind then fc (if i `elem` is then yellow else defcolor) else id)
where ((x_ :& y), te) = text__ 10 3 txt
x = x_ + 2
bez = fromSegments [ bezier3 (r2 (0.7,0)) (r2 (0.3,1)) (r2 (1,1))
, straight (r2 (x - 2, 0))
, bezier3 (r2 (0.7,0)) (r2 (0.3,-1)) (r2 (1,-1))
] # translate (r2 (-x/2,-y/2))
bez' = fromSegments [ bezier3 (r2 (0.7,0)) (r2 (0.3,1)) (r2 (1,1))
, straight (r2 (x - 2, 0))
, bezier3 (r2 (0.7,0)) (r2 (0.3,-1)) (r2 (1,-1))
]
return $ CWidget (liftM2 (\iv ((ls,ls'),vv) -> ((kh:ls,[kh]:ls'), (iv, vv))) (readRef ir) (join wr)) id render
Scale mi ma step (sr,rr) -> do
i <- newId
mv <- lift $ newRef Nothing
let ff (SimpleKey Key'Right) = modR $ min ma . (+step)
ff (SimpleKey Key'Left) = modR $ max mi . (+(-step))
ff k = dkh k
kh = (return (), ff, return (), i)
modR f = do
v <- liftRefReader sr
rr $ f v
return True
adj x = do
m <- readRef mv
case m of
Just (x_, v) -> rr $ min ma $ max mi $ v + (ma - mi) * (x - x_) / 10
Nothing -> return ()
f (Click (MousePos p _), _) = Just' (liftRefReader sr >>= \v -> writeRef mv $ Just (getx p, v), Just f', Just kh, i)
f (MoveTo _, _) = Just' (return (), Nothing, Nothing, i)
f _ = mempty
f' (Release (MousePos p _), _) = adj (getx p) >> writeRef mv Nothing >> return False
f' (MoveTo (MousePos p _), _) = adj (getx p) >> return True
f' _ = return True
getx p = case coords p of (x :& _) -> x
render r is is' =
( circle 0.38 # value f
# fc (if i `elem` is then yellow else sRGB 0.95 0.95 0.95)
# lw 0.02 -- (if is' == i then lc yellow . lw focWidth else lc black . lw 0.02)
# translate (r2 (10 * ((r - mi) / (ma - mi)) - 5, 0))
<> ( fromVertices [p2 (-5, 0), p2 (5,0)] # lineCap LineCapRound # lw 0.05
<> roundedRect 11 1 0.5 # lw 0 # fc (if is' == i then yellow else sRGB 0.95 0.95 0.95)
) # value mempty
) # freeze # frame 0.1
return $ CWidget (liftM ((,) ([kh],[[kh]])) sr) id render
--------------------
data UnsafeEqWrap b = forall a . Eq a => UnsafeEqWrap a b
instance Eq (UnsafeEqWrap b) where
UnsafeEqWrap a _ == UnsafeEqWrap b _ = a == unsafeCoerce b