module Graphics.Web.Processing.Simple (
module Graphics.Web.Processing.Core.Types
, Color (..)
, Proc_Point
, Path
, Figure (..)
, module Data.Monoid
, displayFigure
, animateFigure
, interactiveFigure
, Key (..)
, ArrowKey (..)
, KeyModifier (..)
, SpecialKey (..)
, module Graphics.Web.Processing.Mid.CustomVar
) where
import Data.Monoid
import Data.String
import Graphics.Web.Processing.Core.Types
import Graphics.Web.Processing.Mid
import Graphics.Web.Processing.Mid.CustomVar
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
type Path = [Proc_Point]
data Figure =
Line Path
| Polygon Path
| Ellipse Proc_Point Proc_Float Proc_Float
| Circle Proc_Point Proc_Float
| Arc Proc_Point Proc_Float Proc_Float
Proc_Float Proc_Float
| Rectangle Proc_Point Proc_Float Proc_Float
| Bezier Proc_Point Proc_Point Proc_Point Proc_Point
| Text Proc_Point Proc_Text
| LineColor Color Figure
| FillColor Color Figure
| Translate Proc_Point Figure
| Rotate Proc_Float Figure
| Scale Proc_Float Proc_Float Figure
| Figures [Figure]
instance Monoid Figure where
mempty = Figures []
mappend (Figures []) x = x
mappend x (Figures []) = x
mappend (Figures xs) (Figures ys) = Figures $ xs ++ ys
mappend (Figures xs) x = Figures $ xs ++ [x]
mappend x (Figures xs) = Figures $ x : xs
mappend x y = Figures [x,y]
pairList :: [a] -> [(a,a)]
pairList (x:y:zs) = (x,y) : pairList (y:zs)
pairList _ = []
adjustPoint :: Proc_Point -> Proc_Point
adjustPoint (x,y) = (x,y)
type SimpleEventM c = StateT Settings (EventM c)
data Settings = Settings {
currentLineColor :: Color
, currentFillColor :: Color
}
defaultSettings :: Settings
defaultSettings = Settings {
currentLineColor = Color 0 0 0 255
, currentFillColor = Color 255 255 255 255
}
setLineColor :: Color -> SimpleEventM c ()
setLineColor c = modify $ \s -> s { currentLineColor = c }
getLineColor :: SimpleEventM c Color
getLineColor = currentLineColor <$> get
setFillColor :: Color -> SimpleEventM c ()
setFillColor c = modify $ \s -> s { currentFillColor = c }
getFillColor :: SimpleEventM c Color
getFillColor = currentFillColor <$> get
figureSEvent :: Drawing c => Figure -> SimpleEventM c ()
figureSEvent (Line ps) = lift $ mapM_ (uncurry line) $ pairList $ fmap adjustPoint ps
figureSEvent (Polygon ps) = lift $ polygon $ fmap adjustPoint ps
figureSEvent (Ellipse p w h) = lift $ ellipse (adjustPoint p) w h
figureSEvent (Circle p r) = lift $ circle (adjustPoint p) r
figureSEvent (Arc p w h start end) = lift $ arc (adjustPoint p) w h start end
figureSEvent (Rectangle p w h) = lift $ rect (adjustPoint p) w h
figureSEvent (Bezier start p1 p2 end) =
lift $ bezier (adjustPoint start)
(adjustPoint p1)
(adjustPoint p2)
(adjustPoint end)
figureSEvent (Text p t) = lift $ drawtext t (adjustPoint p) 0 0
figureSEvent (LineColor c f) = do
c0 <- getLineColor
setLineColor c
lift $ stroke c
figureSEvent f
setLineColor c0
lift $ stroke c0
figureSEvent (FillColor c f) = do
c0 <- getFillColor
setFillColor c
lift $ fill c
figureSEvent f
setFillColor c0
lift $ fill c0
figureSEvent (Translate (x,y) f) = lift (translate x (y)) >> figureSEvent f >> lift (translate (x) y)
figureSEvent (Rotate a f) = lift (rotate a) >> figureSEvent f >> lift (rotate (a))
figureSEvent (Scale x y f) = lift (scale x y) >> figureSEvent f >> lift (scale (recip x) (recip y))
figureSEvent (Figures fs) = mapM_ figureSEvent fs
figureEvent :: Drawing c => Figure -> EventM c ()
figureEvent f = do
stroke $ currentLineColor defaultSettings
fill $ currentFillColor defaultSettings
evalStateT (figureSEvent f) defaultSettings
displayFigure ::
Maybe Int
-> Maybe Int
-> Color
-> Figure
-> ProcScript
displayFigure w h bgc f = execScriptM $ on Draw $ do
size (maybe screenWidth fromInt w) (maybe screenHeight fromInt h)
background bgc
translate (intToFloat screenWidth/2) (intToFloat screenHeight/2)
figureEvent f
animateFigure ::
Maybe Int
-> Maybe Int
-> Int
-> Color
-> (Proc_Int -> Figure)
-> ProcScript
animateFigure mw mh fr bgc f = execScriptM $ do
on Setup $ do
setFrameRate $ fromInt fr
on Draw $ do
let w = maybe screenWidth fromInt mw
h = maybe screenHeight fromInt mh
size w h
background bgc
translate (intToFloat w/2) (intToFloat h/2)
frameCount >>= figureEvent . f
interactiveFigure :: CustomValue w
=> Maybe Int
-> Maybe Int
-> Int
-> w
-> (w -> Figure)
-> (w -> Color)
-> (Proc_Int -> w -> w)
-> (Proc_Point -> w -> w)
-> [(Key,w -> w)]
-> ProcScript
interactiveFigure mw mh framerate s0 _print bg step onclick keyevents = execScriptM $ do
let w = maybe screenWidth fromInt mw
h = maybe screenHeight fromInt mh
v <- newVarC s0
keyv <- newVar false
on Setup $ do
setFrameRate $ fromInt framerate
on Draw $ do
size w h
translate (intToFloat w/2) (intToFloat h/2)
comment "Read state"
s <- readVarC v
comment "Background color"
background $ bg s
comment "Draw state"
figureEvent $ _print s
comment $ "Update state"
n <- frameCount
writeVarC v $ step n s
on MouseClicked $ do
comment "Read state"
s <- readVarC v
comment "Mouse event"
p <- getMousePoint
writeVarC v $ onclick p s
when (not $ null keyevents) $ on KeyPressed $ mapM_ (keyEvent v keyv) $ zip keyevents [1..]
keyEvent :: CustomValue w
=> CustomVar w -> Var Proc_Bool -> ((Key,w -> w),Int) -> EventM KeyPressed ()
keyEvent v keyv ((k,f),n) = do
comment $ "Key event " <> fromString (show n)
matchKey keyv k
b <- readVar keyv
ifM b (readVarC v >>= writeVarC v . f)
(return ())