wxcore-0.10.4: samples/wx/TimeFlowsEx.hs
{--------------------------------------------------------------------------------
Copyright (c) 2003 Daan Leijen.
"Time flows like a river" -- an old Fran demo :-)
Demonstrates the use of an idle event handler to implement a resource
aware gui that still does heavy animation.
This is an extended version of the "TimeFlows" demo that adds menus
and dialogs to customize the appearance of the text, font, and delay.
--------------------------------------------------------------------------------}
module Main where
import System.CPUTime
import Graphics.UI.WXCore hiding (Time)-- (getTextExtent)
import Graphics.UI.WX
{-------------------------------------------------------------------------
Types
-------------------------------------------------------------------------}
-- Time is in seconds, represented as a double.
type Time = Double
-- The (mouse) history consists of time/position pairs (and is never null)
type History = [(Time,Point)]
{-------------------------------------------------------------------------
The gui
-------------------------------------------------------------------------}
main
= start timeFlows
timeFlows
= do -- mouse history as list of time/position pairs: is never null!
vmouseHistory <- varCreate [(0,pt 0 0)]
-- the total time delay of the last word (in seconds)
vtimeSpan <- varCreate 1.0
-- the text
vflowText <- varCreate "time flows like a river"
-- the font
vflowFont <- varCreate (fontSwiss{ _fontSize = 16 })
-- show mouse track?
vflowLine <- varCreate True
-- create a frame and panel to draw in.
f <- frame [ text := "Time flows"]
p <- panel f []
-- create menus & status fields
mfile <- menuPane [text := "&File"]
mquit <- menuQuit mfile [help := "Exit the demo", on command := close f]
medit <- menuPane [text := "&Edit"]
mshowline<- menuItem medit [text := "&Show mouse track\tCtrl+S", checkable := True, checked := True]
mfont <- menuItem medit [text := "&Font...\tCtrl+F", help := "Set the font"]
moptions <- menuItem medit [text := "&Options...\tCtrl+O", help := "Edit demo options"]
mhelp <- menuHelp []
mabout <- menuAbout mhelp [help := "Information about this demo."]
flowText <- varGet vflowText
status <- statusField [text := flowText]
-- set layout (before the menubar!)
set f [ layout := fill $ widget p
, clientSize := sz 300 300 --initial size
]
-- set menu and status bar
set f [ menuBar := [mfile,medit,mhelp]
, statusBar := [status]
, on (menu mabout) := infoDialog f "About Time flows.." "This is an idle event application."
, on (menu mshowline) := do showit <- get mshowline checked
varSet vflowLine showit
, on (menu moptions) := showOptionDialog f vtimeSpan vflowText status
, on (menu mfont) := showFontDialog f vflowFont
, on (charKey '+') := do varUpdate vtimeSpan (\n -> min 10 (n+1)); return ()
, on (charKey '-') := do varUpdate vtimeSpan (\n -> max 1 (n-1)); return ()
]
-- set event handlers
set p [ on paint := onPaint vmouseHistory vtimeSpan vflowLine vflowText vflowFont
, on idle := onIdle vmouseHistory vtimeSpan p
, on drag := onDrag vmouseHistory
]
return ()
{-------------------------------------------------------------------------
Dialogs
-------------------------------------------------------------------------}
showFontDialog frame vflowFont
= do flowFont <- varGet vflowFont
mbfont <- fontDialog frame flowFont
case mbfont of
Nothing -> return ()
Just font -> varSet vflowFont font
showOptionDialog frame vtimeSpan vflowText status
= do flowText <- varGet vflowText
timeSpan <- varGet vtimeSpan
-- create dialog
d <- dialog frame [text := "Options", resizeable := True]
p <- panel d []
entry <- textEntry p [text := flowText]
delay <- spinCtrl p 1 10 [selection := round timeSpan]
ok <- button p [text := "Ok"]
can <- button p [text := "Cancel"]
-- layout
set d [defaultButton := ok
,layout := container p $ margin 10 $
column 10 [ boxed "" $ grid 5 5 [[label "text:", hfill $ widget entry]
,[label "delay:", floatRight $ widget delay]
]
, floatBottomRight $ row 5 [widget ok, widget can]
]
]
-- show modal
ret <- showModal d $ \stop ->
do set ok [on command := do flowText <- get entry text
timeSpan <- get delay selection
stop (Just (flowText,fromIntegral timeSpan))]
set can [on command := stop Nothing]
-- set results
case ret of
Nothing -> return ()
Just (flowText,timeSpan)
-> do varSet vflowText flowText
set status [text := flowText]
varSet vtimeSpan timeSpan
{-------------------------------------------------------------------------
Event handlers
-------------------------------------------------------------------------}
-- repaint handler
onPaint vmouseHistory vtimeSpan vflowLine vflowText vflowFont dc viewArea
= do time <- getTime
history <- varGet vmouseHistory
timeSpan <- varGet vtimeSpan
flowFont <- varGet vflowFont
flowText <- varGet vflowText
flowLine <- varGet vflowLine
-- draw trace line
when (flowLine) (polyline dc (map snd history) [penColor := lightgrey])
-- draw the words
set dc [font := flowFont ]
mapM_ drawWord (wordPositions history timeSpan time flowText)
where
drawWord (pos,word)
= do -- center word
sz <- getTextExtent dc word
let newX = pointX pos - (sizeW sz `div` 2)
newY = pointY pos - (sizeH sz `div` 2)
-- and draw it.
drawText dc word (pt newX newY) []
-- idle event handler
onIdle :: Var History -> Var Time -> Window a -> IO Bool
onIdle vmouseHistory vtimeSpan win
= do history <- varGet vmouseHistory
if (null (tail history))
then do -- don't call idle again until some other event happens
return False
else do time <- getTime
timeSpan <- varGet vtimeSpan
repaint win
-- prune the history
varSet vmouseHistory (prune (time - timeSpan) history)
return True
where
-- prune the history: only remember time/position pairs up to a certain time span.
prune time (h:hs)
= h:takeWhile (after time) hs
after time (t,p)
= time <= t
-- mouse drag handler
onDrag vmouseHistory mousePos
= do time <- getTime
-- prepend a new time/position pair
varUpdate vmouseHistory ((time,mousePos):)
return ()
{-------------------------------------------------------------------------
Helper functions
-------------------------------------------------------------------------}
-- Tuple each word in a string with its historic position, given a mouse
-- history, a time span, and current time.
wordPositions :: History -> Time -> Time -> String -> [(Point,String)]
wordPositions history timeSpan time
= wordPositionsAt history . wordTimes timeSpan time . words
-- Translate time/word pairs to position/word pairs given the mouse position history.
wordPositionsAt :: History -> [(Time,String)] -> [(Point,String)]
wordPositionsAt history timedWords
= [(posAtTime t history, word) | (t,word) <- timedWords]
-- | Return the mouse position at a certain time.
posAtTime :: Time -> History -> Point
posAtTime time [(t,pos)] = pos
posAtTime time ((t,pos):xs) | t <= time = pos
| otherwise = posAtTime time xs
-- | Evenly assign times to the words in a string, given a timeSpan and current time.
wordTimes :: Time -> Time -> [String] -> [(Time,String)]
wordTimes timeSpan time words
= let n = length words
delta = timeSpan / (fromIntegral n)
in zip (iterate (\t -> t-delta) time) words
-- Get the current Time
getTime :: IO Time
getTime
= do picoSecs <- getCPUTime
let time = (fromIntegral picoSecs) / 1.0e12
return time