lgtk-0.8: lgtkdemo/LGtk/Demos/Main.hs
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module LGtk.Demos.Main
( main
) where
import Numeric
import Data.Maybe (isJust)
import Control.Lens hiding ((#))
import Control.Monad
import Diagrams.Prelude hiding (vcat, hcat, interval, tri)
import LGtk
import LGtk.Demos.Tri
import LGtk.Demos.IntListEditor
import LGtk.Demos.TEditor
import LGtk.Demos.Maze
main :: IO ()
main = runWidget mainWidget
mainWidget = notebook
[ (,) "Simple" $ notebook
-- , (,) "Hello" $ label $ return "Hello World!"
[ (,) "Counters" $ notebook
[ (,) "Unbounded" $ do
c <- newEqRef (0 :: Int)
vcat
[ label $ liftM show $ readRef c
, hcat
[ smartButton (return "+1") c (+1)
, smartButton (return "-1") c (+(-1))
]
]
, (,) "1..3" $ do
c <- newEqRef (1 :: Int)
vcat
[ label $ liftM show $ readRef c
, hcat
[ smartButton (return "+1") c $ min 3 . (+1)
, smartButton (return "-1") c $ max 1 . (+(-1))
]
]
, (,) "a..b" $ do
ab <- newRef (1 :: Int, 3)
let (a, b) = interval ab
c <- counter 0 ab
vcat
[ label $ liftM show $ readRef c
, hcat
[ smartButton (return "+1") c (+1)
, smartButton (return "-1") c (+(-1))
]
, hcat [ label $ return "min", entryShow a ]
, hcat [ label $ return "max", entryShow b ]
]
]
{-
, (,) "Buttons" $ do
x <- newRef (0 :: Int)
let is = [0 :: Double, 0.5, 1]
colorlist = tail $ liftM3 sRGB is is is
f n = colorlist !! (n `mod` length colorlist)
button__ (return "Push") (return True) (liftM f $ readRef x) $ modRef x (+1)
, (,) "Tabs" $ notebook
[ (,) "TabSwitch" $ do
x <- newRef "a"
let w = vcat [ label $ readRef x, entry x ]
notebook
[ (,) "T1" w
, (,) "T2" w
]
]
-}
, (,) "Tri" tri
, (,) "T-Editor" $ notebook
[ (,) "Version 1" $ do
t <- newRef $ iterate (Node Leaf) Leaf !! 10
hcat
[ canvas 200 200 20 (const $ return ()) Nothing (readRef t) $
\x -> tPic 0 x # value () # lw 0.05 # translate (r2 (0,10))
, tEditor3 t
]
, (,) "Version 2" tEditor1
]
, (,) "Notebook" $ notebook
[ (,) "Version 2" $ do
buttons <- newRef ("",[])
let ctrl = entry $ lens fst (\(_,xs) x -> ("",x:xs)) `lensMap` buttons
h b = do
q <- extRef b listLens (False, ("", []))
cell (liftM fst $ readRef q) $ \bb -> case bb of
False -> empty
_ -> do
vcat $ reverse
[ h $ _2 . _2 `lensMap` q
, hcat
[ button (return "Del") $ return $ Just $ modRef b tail
, label $ readRef $ _2 . _1 `lensMap` q
]
]
vcat $ [ctrl, h $ _2 `lensMap` buttons]
, (,) "Version 1" $ do
buttons <- newRef ("",[])
let h i b = hcat
[ label $ return b
, button (return "Del") $ return $ Just $ modRef (_2 `lensMap` buttons) $ \l -> take i l ++ drop (i+1) l
]
set (a,xs) x
| a /= x = ("",x:xs)
| otherwise = (a,xs)
vcat
[ entry $ lens fst set `lensMap` buttons
, cell (liftM snd $ readRef buttons) $ vcat . zipWith h [0..]
]
]
]
, (,) "Canvas" $ notebook
[ (,) "NotReactive" $ notebook
[ (,) "Dynamic" $ do
r <- newRef (3 :: Double)
vcat
[ canvas 200 200 12 (const $ return ()) Nothing (readRef r) $
\x -> circle x # lw 0.05 # fc blue # value ()
, hcat
[ hscale 0.1 5 0.05 r
, label (liftM (("radius: " ++) . ($ "") . showFFloat (Just 2)) $ readRef r)
]
]
, (,) "Animation" $ do
fps <- newRef (50 :: Double)
speed <- newRef (1 :: Double)
phase <- newRef (0 :: Double)
t <- newRef 0
_ <- onChangeSimple (readRef phase) $ \x -> do
s <- readRef speed
f <- readRef fps
asyncWrite (round $ 1000000 / f) $ writeRef phase (x + 2 * pi * s / f)
vcat
[ canvas 200 200 10 (const $ return ()) Nothing (liftM2 (,) (readRef t) (readRef phase)) $
\(t,x) -> (case t of
0 -> circle (2 + 1.5*sin x)
1 -> circle 1 # translate (r2 (3,0)) # rotate ((-x) @@ rad)
2 -> rect 6 6 # rotate ((-x) @@ rad)
3 -> mconcat [circle (i'/10) # translate (r2 (i'/3, 0) # rotate ((i') @@ rad)) | i<-[1 :: Int ..10], let i' = fromIntegral i] # rotate ((-x) @@ rad)
4 -> mconcat [circle (i'/10) # translate (r2 (i'/3, 0) # rotate ((x/i') @@ rad)) | i<-[1 :: Int ..10], let i' = fromIntegral i]
) # lw 0.05 # fc blue # value ()
, combobox ["Pulse","Rotate","Rotate2","Spiral","Spiral2"] t
, hcat
[ hscale 0.1 5 0.1 speed
, label (liftM (("freq: " ++) . ($ "") . showFFloat (Just 2)) $ readRef speed)
]
, hcat
[ hscale 1 100 1 fps
, label (liftM (("fps: " ++) . ($ "") . showFFloat (Just 2)) $ readRef fps)
]
]
]
, (,) "Reactive" $ notebook
[ (,) "ColorChange" $ do
phase <- newRef (0 :: Double)
col <- newRef True
_ <- onChangeSimple (readRef phase) $ \x -> do
let s = 0.5 :: Double
let f = 50 :: Double
asyncWrite (round $ 1000000 / f) $ writeRef phase (x + 2 * pi * s / f)
let handler (Click (MousePos _ l), _) = when (not $ null l) $ modRef col not
handler _ = return ()
vcat
[ canvas 200 200 10 handler Nothing (liftM2 (,) (readRef col) (readRef phase)) $
\(c,x) -> circle 1 # translate (r2 (3,0)) # rotate ((-x) @@ rad) # lw 0.05 # fc (if c then blue else red) # value [()]
, label $ return "Click on the circle to change color."
]
, (,) "Enlarge" $ do
phase <- newRef (0 :: Double)
col <- newRef 1
_ <- onChangeSimple (readRef phase) $ \x -> do
let s = 0.5 :: Double
let f = 50 :: Double
asyncWrite (round $ 1000000 / f) $ do
writeRef phase (x + 2 * pi * s / f)
modRef col $ max 1 . (+(- 5/f))
let handler (Click (MousePos _ l), _) = when (not $ null l) $ modRef col (+1)
handler _ = return ()
vcat
[ canvas 200 200 10 handler Nothing (liftM2 (,) (readRef col) (readRef phase)) $
\(c,x) -> circle c # translate (r2 (3,0)) # rotate ((-x) @@ rad) # lw 0.05 # fc blue # value [()]
, label $ return "Click on the circle to temporarily enlarge it."
]
, (,) "Chooser" $ do
i <- newRef (0 :: Int, 0 :: Rational)
let i1 = _1 `lensMap` i
i2 = _2 `lensMap` i
_ <- onChangeSimple (readRef i) $ \(i,d) -> do
let dd = fromIntegral i - d
if dd == 0
then return ()
else do
let s = 2 :: Rational
let f = 25 :: Rational
asyncWrite (round $ 1000000 / f) $ do
writeRef i2 $ d + signum dd * min (abs dd) (s / f)
let keyh (SimpleKey Key'Left) = modRef i1 pred >> return True
keyh (SimpleKey Key'Right) = modRef i1 succ >> return True
keyh _ = return False
vcat
[ canvas 200 200 10 (const $ return ()) (Just keyh) (readRef i2) $
\d -> text "12345" # translate (r2 (realToFrac d, 0)) # scale 2 # value ()
, label $ liftM show $ readRef i1
]
]
, (,) "InCanvas" $ notebook
[ (,) "Widgets" $ inCanvasExample
, (,) "Recursive" $ inCanvas 800 600 30 mainWidget
]
]
, (,) "System" $ notebook
{-
, (,) "Accumulator" $ do
x <- newRef (0 :: Integer)
y <- onChangeAcc (readRef x) 0 (const 0) $ \x _ y -> Left $ return $ x+y
hcat
[ entryShow x
, label $ liftM show y
]
-}
[ (,) "Async" $ do
ready <- newRef True
delay <- newRef (1.0 :: Double)
_ <- onChange (readRef ready) $ \b -> return $ case b of
True -> return ()
False -> do
d <- readRef delay
asyncWrite (ceiling $ 1000000 * d) $ writeRef ready True
vcat
[ hcat [ entryShow delay, label $ return "sec" ]
, button_ (readRef delay >>= \d -> return $ "Start " ++ show d ++ " sec computation")
(readRef ready)
(writeRef ready False)
, label $ liftM (\b -> if b then "Ready." else "Computing...") $ readRef ready
]
, (,) "Timer" $ do
t <- newRef (0 :: Int)
_ <- onChange (readRef t) $ \ti -> return $ asyncWrite 1000000 $ writeRef t $ 1 + ti
vcat
[ label $ liftM show $ readRef t
]
, (,) "System" $ notebook
[ (,) "Args" $ getArgs >>= \args -> label $ return $ unlines args
, (,) "ProgName" $ getProgName >>= \args -> label $ return args
, (,) "Env" $ do
v <- newRef "HOME"
lv <- newRef ""
_ <- onChange (readRef v) $ \s -> return $
postponeModification . writeRef lv =<< liftM (maybe "Not in env." show) (lookupEnv s)
vcat
[ entry v
, label $ readRef lv
]
, (,) "Std I/O" $ let
put = do
x <- newRef Nothing
_ <- onChange (readRef x) $ return . maybe (return ()) putStrLn_
hcat
[ label $ return "putStrLn"
, entry $ iso (maybe "" id) Just `lensMap` x
]
get = do
ready <- newRef $ Just ""
_ <- onChange (liftM isJust $ readRef ready) $ \b ->
return $ when (not b) $ getLine_ $ writeRef ready . Just
hcat
[ button_ (return "getLine") (liftM isJust $ readRef ready) $ writeRef ready Nothing
, label $ liftM (maybe "<<<waiting for input>>>" id) $ readRef ready
]
in vcat [ put, put, put, get, get, get ]
]
]
, (,) "Complex" $ notebook
[ (,) "ListEditor" $ do
state <- fileRef "intListEditorState.txt"
list <- extRef (justLens "" `lensMap` state) showLens []
settings <- fileRef "intListEditorSettings.txt"
range <- extRef (justLens "" `lensMap` settings) showLens True
intListEditor (0 :: Integer, True) 15 list range
, (,) "Maze" $ mazeGame
]
{-
, (,) "Csaba" $ notebook
[ (,) "#1" $ do
name <- newRef "None"
buttons <- newRef []
let ctrl = hcat
[ label $ readRef name
, button (return "Add") $ return $ Just $ do
l <- readRef buttons
let n = "Button #" ++ (show . length $ l)
writeRef buttons $ n:l
]
f n = vcat $ map g n
g n = button (return n) (return . Just $ writeRef name n)
vcat $ [ctrl, cell (readRef buttons) f]
, (,) "#2" $ do
name <- newRef "None"
buttons <- newRef []
let ctrl = hcat
[ label $ readRef name
, button (return "Add") $ return $ Just $ do
l <- readRef buttons
let n = "Button #" ++ (show . length $ l)
writeRef buttons $ l ++ [n]
]
h b = do
q <- extRef b listLens (False, ("", []))
cell (liftM fst $ readRef q) $ \b -> case b of
False -> empty
_ -> do
na <- readRef $ _2 . _1 `lensMap` q
vcat $ reverse
[ h $ _2 . _2 `lensMap` q
, hcat [ button (return na) $ return $ Just $ writeRef name na, entry $ _2 . _1 `lensMap` q ]
]
vcat $ [ctrl, h buttons]
]
-}
]
tPic :: Int -> T -> Dia Any
tPic _ Leaf = circle 0.5 # fc blue
tPic i (Node a b) = tPic (i+1) a # translate (r2 (-w,-2))
<> tPic (i+1) b # translate (r2 (w,-1.8))
<> fromVertices [p2 (-w, -2), p2 (0,0), p2 (w,-1.8)]
where w = 3 * 0.7 ^ i
justLens :: a -> Lens' (Maybe a) a
justLens a = lens (maybe a id) (flip $ const . Just)
counter :: forall m a . (MonadRegister m, Ord a) => a -> Ref m (a, a) -> m (EqRefSimple (BaseRef m) a)
counter x ab = do
c <- extRef ab (fix . _2) (x, (x, x))
return $ fix . _1 `lensMap` toEqRef c
where
fix :: Lens' (a, (a,a)) (a, (a,a))
fix = lens id $ \_ (x, ab@(a, b)) -> (min b $ max a x, ab)
interval :: (RefClass r, Ord a) => RefSimple r (a, a) -> (RefSimple r a, RefSimple r a)
interval ab = (lens fst set1 `lensMap` ab, lens snd set2 `lensMap` ab) where
set1 (_, b) a = (min b a, b)
set2 (a, _) b = (a, max a b)
----------------------------------------------------------------------------
inCanvasExample = do
t <- newRef $ iterate (Node Leaf) Leaf !! 5
i <- newRef (0 :: Int)
j <- newRef 0
s <- newRef "x"
s' <- newRef "y"
let x = vcat
[ hcat
[ vcat
[ hcat
[ label $ readRef i >>= \i -> return $ show i ++ "hello"
, button_ (return "+1") (return True) $ modRef i (+1)
]
, hcat
[ entry s
, entry s
]
, hcat
[ entry s'
, entry s'
]
]
, combobox ["Hello","World","!"] j
]
, tEditor3 t
]
hcat [ inCanvas 200 300 15 $ vcat [x, inCanvas 100 100 15 x], x]