fenfire-0.1: _darcs/pristine/Vobs.fhs
{-# OPTIONS_GHC -fallow-overlapping-instances #-}
module Vobs where
-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
--
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details.
--
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA 02111-1307 USA
import Utils
import Cairo
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Time
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Trans (liftIO, MonadIO)
import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
import qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))
import qualified Graphics.Rendering.Cairo.Matrix as Matrix
import Graphics.UI.Gtk.Cairo
import Data.List (intersect)
import Data.Map (Map, keys, fromList, toList, insert, empty)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (Monoid(mempty, mappend))
import Control.Monad (when)
import Control.Monad.State
import Control.Monad.Reader
type Scene k = Map k (Maybe (Matrix, Size))
data Vob k = Vob { defaultSize :: Size,
vobScene :: RenderContext k -> Scene k,
renderVob :: RenderContext k -> Render () }
type Cx k = MaybeT (Reader (RenderContext k))
runCx :: RenderContext k -> Cx k a -> Maybe a
runCx cx m = runReader (runMaybeT m) cx
data RenderContext k = RenderContext {
rcRect :: Rect, rcScene :: Scene k, rcFade :: Double,
rcFgColor :: Color, rcBgColor :: Color, rcFadeColor :: Color }
rcMatrix = fst . rcRect; rcSize = snd . rcRect
type View s k = s -> Vob k
type Handler e s = e -> HandlerAction s
type HandlerAction s = StateT s (StateT (Bool, Bool) IO) ()
instance Ord k => Monoid (Vob k) where
mempty = Vob (0,0) (const Map.empty) (const $ return ())
mappend (Vob (w1,h1) sc1 r1) (Vob (w2,h2) sc2 r2) = Vob (w,h) sc r where
(w,h) = (max w1 w2, max h1 h2)
sc cx = Map.union (sc1 cx) (sc2 cx)
r cx = r1 cx >> r2 cx
instance Functor (Cx k) where fmap = liftM
instance Applicative (Cx k) where
pure = return
(<*>) = ap
instance Ord k => Cairo (Cx k) (Vob k) where
cxAsk = asks rcRect
cxLocal rect m = do rect' <- rect; local (\cx -> cx { rcRect = rect' }) m
cxWrap f (Vob size sc ren) =
Vob size sc $ \cx -> maybeDo (runCx cx $ f $ ren cx) id
cxLocalR rect (Vob size sc ren) = Vob size
(\cx -> let msc = liftM sc (upd cx)
in Map.mapWithKey (\k _ -> msc >>= (Map.! k)) (sc cx))
(\cx -> maybe (return ()) ren (upd cx))
where upd cx = do rect' <- runCx cx rect
return $ cx { rcRect = rect' }
defaultWidth (Vob (w,_) _ _) = w
defaultHeight (Vob (_,h) _ _) = h
setInterp :: Bool -> HandlerAction s
setInterp interp = lift $ modify $ \(_,handled) -> (interp, handled)
unhandledEvent :: HandlerAction s
unhandledEvent = lift $ modify $ \(interp,_) -> (interp, False)
runHandler handleEvent state event = do
(((), state'), (interpolate', handled)) <-
runStateT (runStateT (handleEvent event) state) (False, True)
return (state',interpolate',handled)
(@@) :: Ord k => Cx k a -> k -> Cx k a -- pronounce as 'of'
(@@) x key = do cx <- ask
rect <- maybeReturn =<< Map.lookup key (rcScene cx)
local (\_ -> cx { rcRect = rect }) x
changeSize :: Ord k => Endo Size -> Endo (Vob k)
changeSize f vob = vob { defaultSize = f $ defaultSize vob }
changeContext :: Ord k => Endo (RenderContext k) -> Endo (Vob k)
changeContext f (Vob s sc r) = Vob s (sc . f) (r . f)
changeRect :: Ord k => Endo Rect -> Endo (Vob k)
changeRect f = changeContext (\cx -> cx { rcRect = f $ rcRect cx })
ownSize :: Ord k => Endo (Vob k)
ownSize vob = changeRect (\(m,_) -> (m, defaultSize vob)) vob
invisibleVob :: Ord k => Endo (Vob k)
invisibleVob = cxWrap (const mempty)
comb :: Size -> (RenderContext k -> Vob k) -> Vob k
comb size f =
Vob size (\cx -> vobScene (f cx) cx) (\cx -> renderVob (f cx) cx)
renderable :: Ord k => Size -> Render () -> Vob k
renderable size ren = Vob size (const Map.empty) $ \cx -> do
do C.save; C.transform (rcMatrix cx); ren; C.restore
keyVob :: Ord k => k -> Endo (Vob k)
keyVob key vob = vob {
vobScene = \cx -> Map.insert key (Just $ rcRect cx) (vobScene vob cx),
renderVob = \cx ->
maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->
renderVob vob $ cx { rcRect = rect } }
rectBox :: Ord k => Endo (Vob k)
rectBox vob = useBgColor (fill extents) & clip extents vob &
useFgColor (stroke extents)
pangoContext :: PangoContext
pangoContext = unsafePerformIO $ do
context <- cairoCreateContext Nothing
desc <- contextGetFontDescription context
fontDescriptionSetFamily desc "Sans"
fontDescriptionSetSize desc (fromInteger 10)
contextSetFontDescription context desc
return context
label :: Ord k => String -> Vob k
label s = unsafePerformIO $ do
layout <- layoutText pangoContext s
(PangoRectangle _ _ w1 h1, PangoRectangle _ _ w2 h2)
<- layoutGetExtents layout
let w = max w1 w2; h = max h1 h2
return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
multiline :: Ord k => Bool -> Int -> String -> Vob k
multiline useTextWidth widthInChars s = unsafePerformIO $ do
layout <- layoutText pangoContext s
layoutSetWrap layout WrapPartialWords
desc <- contextGetFontDescription pangoContext
lang <- languageFromString s
(FontMetrics {approximateCharWidth=cw, ascent=ascent', descent=descent'})
<- contextGetMetrics pangoContext desc lang
let w1 = fromIntegral widthInChars * cw
h1 = ascent' + descent'
layoutSetWidth layout (Just w1)
(PangoRectangle _ _ w2 h2, PangoRectangle _ _ w3 h3)
<- layoutGetExtents layout
let w = if useTextWidth then max w2 w3 else w1
h = maximum [h1, h2, h3]
return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
fadedColor :: Ord k => Endo (Cx k Color)
fadedColor c = liftM3 interpolate (asks rcFade) (asks rcFadeColor) c
setFgColor :: Ord k => Color -> Endo (Vob k)
setFgColor c = changeContext $ \cx -> cx { rcFgColor = c }
setBgColor :: Ord k => Color -> Endo (Vob k)
setBgColor c = changeContext $ \cx -> cx { rcBgColor = c }
useFgColor :: Ord k => Endo (Vob k)
useFgColor = withColor (fadedColor $ asks rcFgColor)
useBgColor :: Ord k => Endo (Vob k)
useBgColor = withColor (fadedColor $ asks rcBgColor)
useFadeColor :: Ord k => Endo (Vob k)
useFadeColor = withColor (asks rcFadeColor)
fade :: Ord k => Double -> Endo (Vob k)
fade a = changeContext $ \cx -> cx { rcFade = rcFade cx * a }
centerVob :: Ord k => Endo (Vob k)
centerVob vob = translate (pure (-w/2)) (pure (-h/2)) vob
where (w,h) = defaultSize vob
pad4 :: Ord k => Double -> Double -> Double -> Double -> Endo (Vob k)
pad4 x1 x2 y1 y2 vob =
changeSize (const (x1+w+x2, y1+h+y2)) $
changeRect (\(m,(w',h')) -> (f m, (w'-x1-x2, h'-y1-y2))) vob
where (w,h) = defaultSize vob; f = Matrix.translate x1 y1
pad2 :: Ord k => Double -> Double -> Endo (Vob k)
pad2 x y = pad4 x x y y
pad :: Ord k => Double -> Endo (Vob k)
pad pixels = pad2 pixels pixels
class Interpolate a where
interpolate :: Double -> Op a
instance Interpolate Double where
interpolate fract x y = (1-fract)*x + fract*y
instance Interpolate Color where
interpolate fract (Color r g b a) (Color r' g' b' a') =
Color (i r r') (i g g') (i b b') (i a a') where
i = interpolate fract
instance Interpolate Matrix where
interpolate fract (Matrix u v w x y z) (Matrix u' v' w' x' y' z') =
Matrix (i u u') (i v v') (i w w') (i x x') (i y y') (i z z') where
i = interpolate fract
interpolateScene :: Ord k => Double -> Op (Scene k)
interpolateScene fract sc1 sc2 =
fromList [(key, liftM2 f (sc1 Map.! key) (sc2 Map.! key))
| key <- interpKeys] where
interpKeys = intersect (keys sc1) (keys sc2)
f (m1,(w1,h1)) (m2,(w2,h2)) = (i m1 m2, (i w1 w2, i h1 h2))
i x y = interpolate fract x y
isInterpUseful :: Ord k => Scene k -> Scene k -> Bool
isInterpUseful sc1 sc2 =
not $ all same [(sc1 Map.! key, sc2 Map.! key) | key <- interpKeys]
where same (a,b) = all (\d -> abs d < 5) $ zipWith (-) (values a) (values b)
values (Just (Matrix a b c d e f, (w,h))) = [a,b,c,d,e,f,w,h]
values Nothing = error "shouldn't happen"
interpKeys = intersect (getKeys sc1) (getKeys sc2)
getKeys sc = [k | k <- keys sc, isJust (sc Map.! k)]
instance Show Modifier where
show Shift = "Shift"
show Control = "Control"
show Alt = "Alt"
show Apple = "Apple"
show Compose = "Compose"
timeDbg :: MonadIO m => String -> Endo (m ())
timeDbg s act | False = do out s; act; out s
| otherwise = act
where out t = liftIO $ do time <- System.Time.getClockTime
putStrLn $ s ++ " " ++ t ++ "\t" ++ show time
linearFract :: Double -> (Double, Bool)
linearFract x = if (x<1) then (x,True) else (1,False)
bounceFract :: Double -> (Double, Bool)
bounceFract x = (y,cont) where -- ported from AbstractUpdateManager.java
x' = x + x*x
y = 1 - cos (2 * pi * n * x') * exp (-x' * r)
cont = -(x + x*x)*r >= log 0.02
(n,r) = (0.4, 2)
type Anim a = Time -> (Scene a, Bool) -- bool is whether to re-render
interpAnim :: Ord a => Time -> TimeDiff -> Scene a -> Scene a -> Anim a
interpAnim startTime interpDuration sc1 sc2 time =
if continue then (interpolateScene fract sc1 sc2, True) else (sc2, False)
where (fract, continue) = bounceFract ((time-startTime) / interpDuration)
noAnim scene = const (scene, False)
vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a ->
Handler c a -> (a -> IO ()) -> Color -> TimeDiff ->
IO (DrawingArea, Bool -> IO (), c -> IO Bool)
vobCanvas stateRef view eventHandler actionHandler stateChanged
bgColor animTime = do
canvas <- drawingAreaNew
widgetSetCanFocus canvas True
animRef <- newIORef (mempty, Map.empty, noAnim Map.empty)
let getWH = do (cw, ch) <- drawingAreaGetSize canvas
return (fromIntegral cw, fromIntegral ch)
getVob = do state <- readIORef stateRef
return $ useFadeColor paint & view state
getRenderContext sc = do
size <- getWH; return $ RenderContext {
rcScene=sc, rcRect=(Matrix.identity, size), rcFade=1,
rcFgColor=black, rcBgColor=white, rcFadeColor=bgColor }
updateAnim interpolate' = mdo
(vob,scene,_) <- readIORef animRef
vob' <- getVob
rc' <- getRenderContext scene'
let scene' = vobScene vob' rc'
time <- scene' `seq` getTime
let anim' = if interpolate' && isInterpUseful scene scene'
then interpAnim time animTime scene scene'
else noAnim scene'
writeIORef animRef (vob', scene', anim')
widgetQueueDraw canvas
handle handler event = do
state <- readIORef stateRef
(state', interpolate', handled) <-
runHandler handler state event
when handled $ do writeIORef stateRef state'
stateChanged state'
updateAnim interpolate'
return handled
handleEvent = handle eventHandler
handleAction = handle actionHandler
onRealize canvas $ mdo vob <- getVob; rc <- getRenderContext scene
let scene = vobScene vob rc
writeIORef animRef (vob, scene, noAnim scene)
onConfigure canvas $ \_event -> do updateAnim False; return True
onKeyPress canvas $ \event -> do
let Key {eventModifier=mods,eventKeyName=key,eventKeyChar=char} = event
putStrLn $ show mods++" "++key++" ("++show char++")"
handleEvent event
onButtonPress canvas $ \(Button {}) -> do
widgetGrabFocus canvas
return True
onExpose canvas $ \(Expose {}) -> do
drawable <- drawingAreaGetDrawWindow canvas
(vob, _, anim) <- readIORef animRef; time <- getTime
let (scene, rerender) = anim time
rc <- getRenderContext scene
renderWithDrawable drawable $ timeDbg "redraw" $ renderVob vob rc
if rerender then widgetQueueDraw canvas else return ()
return True
return (canvas, updateAnim, handleAction)