module Graphics.Web.Processing.Core.Interface (
screenWidth, screenHeight
, random
, noise
, Drawing
, Color (..)
, stroke, fill, background
, strokeWeight
, Proc_Point
, ellipse
, circle
, arc
, line
, point
, quad
, rect
, triangle
, bezier
, polygon
, drawtext
, size
, setFrameRate
, translate
, rotate
, scale
, resetMatrix
, getMousePoint
, Key (..)
, ArrowKey (..)
, KeyModifier (..)
, SpecialKey (..)
, matchKey
, ifM
, frameCount
, getFrameRate
, comment
, ProcMonad
) where
import Graphics.Web.Processing.Core.Primal
( Proc_Key (..)
, Proc_KeyCode (..)
, varFromText
, Proc_Float (..)
, noisef
, ProcType (..)
, ProcArg
)
import Graphics.Web.Processing.Core.Types
import Graphics.Web.Processing.Core.Monad
import Graphics.Web.Processing.Core.Var
import Control.Arrow (first)
import Data.Text (Text)
screenWidth :: Proc_Int
screenWidth = proc_read $ varFromText "screenWidth"
screenHeight :: Proc_Int
screenHeight = proc_read $ varFromText "screenHeight"
frameCount :: (ProcMonad m, Monad (m c)) => m c Proc_Int
frameCount = liftProc $ readVar $ varFromText "frameCount"
getFrameRate :: (ProcMonad m, Monad (m c)) => m c Proc_Int
getFrameRate = liftProc $ readVar $ varFromText "frameRate"
noise :: (ProcMonad m, Monad (m c)) => Proc_Point -> m c Proc_Float
noise (x,y) = return $ noisef x y
random :: ProcMonad m
=> Var Proc_Float
-> Proc_Float
-> Proc_Float
-> m c ()
random v a b = writeVar v $ Float_Random a b
class Drawing a where
instance Drawing Setup where
instance Drawing Draw where
instance Drawing MouseClicked where
instance Drawing MouseReleased where
data Color = Color {
redc :: Proc_Int
, bluec :: Proc_Int
, greenc :: Proc_Int
, alphac :: Proc_Int
}
colorArgs :: Color -> [ProcArg]
colorArgs (Color r g b a) = fmap proc_arg [r,g,b,a]
stroke :: (ProcMonad m, Drawing c) => Color -> m c ()
stroke = commandM "stroke" . colorArgs
fill :: (ProcMonad m, Drawing c) => Color -> m c ()
fill = commandM "fill" . colorArgs
background :: (ProcMonad m, Drawing c) => Color -> m c ()
background = commandM "background" . colorArgs
strokeWeight :: (ProcMonad m, Drawing c) => Proc_Int -> m c ()
strokeWeight n = commandM "strokeWeight" [proc_arg n]
type Proc_Point = (Proc_Float,Proc_Float)
ellipse :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Float
-> Proc_Float
-> m c ()
ellipse (x,y) w h = commandM "ellipse" $ fmap proc_arg [x,y,w,h]
circle :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Float
-> m c ()
circle p r = ellipse p (2*r) (2*r)
arc :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Float
-> Proc_Float
-> Proc_Float
-> Proc_Float
-> m c ()
arc (x,y) w h a0 a1 = commandM "arc" $ fmap proc_arg [x,y,w,h,a0,a1]
line :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Point
-> m c ()
line (x0,y0) (x1,y1) = commandM "line" $ fmap proc_arg [x0,y0,x1,y1]
point :: (ProcMonad m, Drawing c)
=> Proc_Point
-> m c ()
point (x,y) = commandM "point" $ fmap proc_arg [x,y]
quad :: (ProcMonad m, Drawing c)
=> Proc_Point -> Proc_Point -> Proc_Point -> Proc_Point
-> m c ()
quad (x0,y0) (x1,y1) (x2,y2) (x3,y3) =
commandM "quad" $ fmap proc_arg [x0,y0,x1,y1,x2,y2,x3,y3]
rect :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Float
-> Proc_Float
-> m c ()
rect (x,y) w h = commandM "rect" $ fmap proc_arg [x,y,w,h]
triangle :: (ProcMonad m, Drawing c)
=> Proc_Point -> Proc_Point -> Proc_Point
-> m c ()
triangle (x0,y0) (x1,y1) (x2,y2) =
commandM "triangle" $ fmap proc_arg [x0,y0,x1,y1,x2,y2]
bezier :: (ProcMonad m, Drawing c)
=> Proc_Point
-> Proc_Point
-> Proc_Point
-> Proc_Point
-> m c ()
bezier (x0,y0) (x1,y1) (x2,y2) (x3,y3) =
commandM "bezier" $ fmap proc_arg [x0,y0,x1,y1,x2,y2,x3,y3]
beginShape :: (ProcMonad m, Drawing c) => m c ()
beginShape = commandM "beginShape" []
endShape :: (ProcMonad m, Drawing c) => m c ()
endShape = commandM "endShape" []
vertex :: (ProcMonad m, Drawing c) => Proc_Point -> m c ()
vertex (x,y) = commandM "vertex" [proc_arg x,proc_arg y]
polygon :: (ProcMonad m, Monad (m c), Drawing c) => [Proc_Point] -> m c ()
polygon ps = beginShape >> mapM_ vertex ps >> endShape
drawtext :: (ProcMonad m, Drawing c)
=> Proc_Text
-> Proc_Point
-> Proc_Float
-> Proc_Float
-> m c ()
drawtext t (x,y) w h =
commandM "text" $ [ proc_arg t
, proc_arg x, proc_arg y
, proc_arg w, proc_arg h
]
rotate :: (ProcMonad m, Drawing c) => Proc_Float -> m c ()
rotate a = commandM "rotate" [ proc_arg a ]
scale :: (ProcMonad m, Drawing c)
=> Proc_Float
-> Proc_Float
-> m c ()
scale x y = commandM "scale" [ proc_arg x, proc_arg y ]
translate :: (ProcMonad m, Drawing c)
=> Proc_Float
-> Proc_Float
-> m c ()
translate x y = commandM "translate" [ proc_arg x, proc_arg y ]
resetMatrix :: (ProcMonad m, Drawing c)
=> m c ()
resetMatrix = commandM "resetMatrix" []
ifM :: ProcMonad m => Proc_Bool -> m c a -> m c b -> m c ()
ifM = iff
getMousePoint :: (ProcMonad m, Monad (m c)) => m c Proc_Point
getMousePoint = do
x <- liftProc $ readVar $ varFromText "mouseX"
y <- liftProc $ readVar $ varFromText "mouseY"
return (x,y)
data Key =
CharKey Char
| SpecialKey SpecialKey
| ArrowKey ArrowKey
| ModKey KeyModifier Key
data ArrowKey = UP | DOWN | LEFT | RIGHT
data KeyModifier = ALT | CONTROL | SHIFT
data SpecialKey =
BACKSPACE
| TAB
| ENTER
| RETURN
| ESC
keySplit :: Key -> ([Proc_KeyCode],Maybe (Either Proc_Key Proc_KeyCode))
keySplit (CharKey c) = ([],Just $ Left $ Key_Char c)
keySplit (SpecialKey BACKSPACE) = ([],Just $ Right $ KeyCode_BACKSPACE)
keySplit (SpecialKey TAB) = ([],Just $ Right $ KeyCode_TAB)
keySplit (SpecialKey ENTER) = ([],Just $ Right $ KeyCode_ENTER)
keySplit (SpecialKey RETURN) = ([],Just $ Right $ KeyCode_RETURN)
keySplit (SpecialKey ESC) = ([],Just $ Right $ KeyCode_ESC)
keySplit (ArrowKey UP) = ([KeyCode_UP], Nothing)
keySplit (ArrowKey DOWN) = ([KeyCode_DOWN], Nothing)
keySplit (ArrowKey LEFT) = ([KeyCode_LEFT], Nothing)
keySplit (ArrowKey RIGHT) = ([KeyCode_RIGHT], Nothing)
keySplit (ModKey m k) =
let modToKeyCode :: KeyModifier -> Proc_KeyCode
modToKeyCode ALT = KeyCode_ALT
modToKeyCode CONTROL = KeyCode_CONTROL
modToKeyCode SHIFT = KeyCode_SHIFT
in first (modToKeyCode m:) $ keySplit k
matchKey :: (ProcMonad m, Monad (m KeyPressed)) => Var Proc_Bool -> Key -> m KeyPressed ()
matchKey v k = do
let (codedKeys,uncodedKey) = keySplit k
if null codedKeys
then writeVar v true
else iff (Key_Var #== Key_CODED)
(writeVar v $ foldr1 (#&&) $ fmap (KeyCode_Var #==) codedKeys)
(writeVar v false)
b <- liftProc $ readVar v
case uncodedKey of
Nothing -> return ()
Just (Left pk) -> writeVar v $ Key_Var #== pk #&& b
Just (Right ck) -> writeVar v $ KeyCode_Var #== ck #&& b
size :: ProcMonad m => Proc_Int -> Proc_Int -> m c ()
size w h = commandM "size" [proc_arg w, proc_arg h]
setFrameRate :: ProcMonad m => Proc_Int -> m Setup ()
setFrameRate r = commandM "frameRate" [proc_arg r]
comment :: ProcMonad m => Text -> m c ()
comment = writeComment