shine (empty) → 0.1.0.0
raw patch · 10 files changed
+749/−0 lines, 10 filesdep +basedep +ghcjs-domdep +ghcjs-primsetup-changed
Dependencies added: base, ghcjs-dom, ghcjs-prim, keycode, mtl, shine, time, transformers
Files
- LICENSE +23/−0
- README.md +110/−0
- Setup.hs +2/−0
- shine.cabal +48/−0
- src/Graphics/Shine.hs +217/−0
- src/Graphics/Shine/Image.hs +50/−0
- src/Graphics/Shine/Input.hs +45/−0
- src/Graphics/Shine/Picture.hs +82/−0
- src/Graphics/Shine/Render.hs +119/−0
- tests/everything.hs +53/−0
+ LICENSE view
@@ -0,0 +1,23 @@+The MIT License (MIT)++Copyright (c) 2016 Francesco Gazzetta++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+
+ README.md view
@@ -0,0 +1,110 @@+# Shine - Declarative Graphics for the Web++Shine wraps javascript's drawing functions in a declarative API.++Heavily inspired by [gloss](http://gloss.ouroborus.net/).++## Compiling++You need [ghcjs](https://github.com/ghcjs/ghcjs)++## Usage++### `Picture`s++To represent your drawing you have to build a tree using the `Picture` datatype.++```haskell+pic :: Picture+pic = Rect 10 20 -- represents a 10x20 square+```++To compose multiple `Picture`s you can use `Over`, which accepts two `Picture`s+and overlaps them.++`Picture` is a monoid: `<>` is an alias for `Over` and `mempty` is the empty picture.++```haskell+-- draw some shapes on top of each other+pic :: Picture+pic = Rect 10 20+ <> Translate 30 30 (Circle 15)+ <> Colored (Color 255 0 0 0.2) (RectF 4 4)+ <> Text "Sans 12px" LeftAlign 200 "The quick brown fox jumps over the lazy dog."+```++Using `Foldable` you can do things like++```haskell+concentricCircles :: Picture+concentricCircles = foldMap Circle [1,10..100]+```++### Drawing `Picture`s++Before drawing anything you need to obtain a `CanvasRenderingContext2D`.+For this purpose, shine provides two utility functions: `fullScreenCanvas` and `fixedSizeCanvas`++```haskell+main :: IO ()+main = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 800 600+ -- do something with ctx+```++To render a `Picture` on a context you have three options:++#### `render`++You can draw it manually using `render` from `Graphics.Shine.Render`++```haskell+main :: IO ()+main = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 400 400+ draw ctx concentricCircles+```++#### `animate`++You can draw a `Picture` that depends on time. That is, a `Float -> Picture`.++```haskell+-- An expanding-and-contracting circle.+animation :: Float -> Picture+animation = Translate 200 200+ . Circle+ . (*100) . (+1) -- bigger positive oscillation+ . sin -- the circle's radius oscillates++main :: IO ()+main = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 400 400+ animate ctx 30 animation+```++#### `play`++Finally, you can draw a `Picture` that depends on time, inputs+(keyboard and mouse) and an internal state. This is especially useful for games,+hence the name.++```haskell+-- this code draws a black rectangle in the center of the canvas only when the+-- left mouse button is pressed+main :: IO ()+main = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 400 400+ Just doc <- webViewGetDomDocument webView+ play ctx doc 30 initialState draw handleInput step+ where+ -- our state represents the state of the left mouse button+ initialState = Up+ -- we draw a square only if the button is pressed+ draw Up = Empty+ draw Down = Translate 200 200 $ RectF 200 200+ -- when an event is fired we store the button state+ handleInput (MouseBtn BtnLeft buttonState _) = const buttonState+ handleInput _ = id -- catch-all for all other events+ step _ = id -- our state does not depend on time+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ shine.cabal view
@@ -0,0 +1,48 @@+name: shine+version: 0.1.0.0+cabal-version: >=1.8+build-type: Simple+license: MIT+license-file: LICENSE+copyright: (c) 2016 Francesco Gazzetta+author: Francesco Gazzetta+maintainer: Francesco Gazzetta <francygazz@gmail.com>+stability: experimental+homepage: https://github.com/fgaz/shine+bug-reports: https://github.com/fgaz/shine/issues+synopsis: Declarative graphics for the browser using GHCJS+description:+ Shine wraps javascript's drawing functions in a declarative API.+ Heavily inspired by Gloss.+ .+ Read the README for an overview of the library.+extra-source-files: README.md+category: Web, Graphics+data-dir: ""++source-repository head+ type: git+ location: https://github.com/fgaz/shine++library+ exposed-modules: Graphics.Shine,+ Graphics.Shine.Input,+ Graphics.Shine.Image,+ Graphics.Shine.Picture,+ Graphics.Shine.Render+ build-depends: base >=4.2 && <5,+ ghcjs-dom >=0.2 && <0.3,+ ghcjs-prim,+ keycode,+ time,+ mtl,+ transformers+ hs-source-dirs: src+ ghc-options: -O2 -Wall++ --TODO run this in an actual window+test-suite test-shine+ type: exitcode-stdio-1.0+ main-is: everything.hs+ hs-source-dirs: tests+ build-depends: base, ghcjs-dom, shine
+ src/Graphics/Shine.hs view
@@ -0,0 +1,217 @@+{-|+Module : Graphics.Shine+Description : Short description+Copyright : (c) Francesco Gazzetta, 2016+License : MIT+Maintainer : francygazz@gmail.com+Stability : experimental++The main module. Here are defined all the functions needed to get+an animation on the screen.++If you want to render a single 'Picture' only once,+use 'render' from 'Graphics.Shine.Render'+-}+module Graphics.Shine (+ -- * Getting a rendering context+ toContext,+ fullScreenCanvas,+ fixedSizeCanvas,+ -- * Drawing+ animate,+ animateIO,+ play,+ playIO+) where++import GHCJS.DOM (webViewGetDomDocument)+import GHCJS.DOM.Document (getBody, getElementById, mouseUp, mouseDown, mouseMove, wheel, keyDown, keyUp)+import GHCJS.DOM.EventM (on, mouseButton, mouseCtrlKey, mouseAltKey, mouseShiftKey, mouseMetaKey, mouseOffsetXY, uiKeyCode, event)+import GHCJS.DOM.EventTarget (IsEventTarget)+import GHCJS.DOM.WheelEvent (getDeltaX, getDeltaY)+import GHCJS.DOM.KeyboardEvent (KeyboardEvent, getCtrlKey, getShiftKey, getAltKey, getMetaKey)+import GHCJS.DOM.Element (setInnerHTML)+import GHCJS.DOM.HTMLCanvasElement (getContext)+import GHCJS.DOM.CanvasRenderingContext2D+import GHCJS.DOM.Types (Window, Element, MouseEvent, IsDocument)++import GHCJS.Prim (JSVal)+import Web.KeyCode (keyCodeLookup)+import Unsafe.Coerce (unsafeCoerce)+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newMVar, modifyMVar, modifyMVar_)+import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Reader (ReaderT)+import Data.Foldable (foldrM)+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import Data.Maybe (isJust, fromJust)++import Graphics.Shine.Input+import Graphics.Shine.Picture+import Graphics.Shine.Render++-- | Get a context from a canvas element.+toContext :: Element -- ^ this __must__ be a canvas+ -> IO CanvasRenderingContext2D+toContext c = do+ ctx <- getContext (unsafeCoerce c) "2d" :: IO JSVal+ return $ unsafeCoerce ctx --how do i get a 2dcontext properly? This works for now.++customAttributesCanvas :: Window -> String -> IO CanvasRenderingContext2D+customAttributesCanvas webView attrs = do+ Just doc <- webViewGetDomDocument webView+ Just body <- getBody doc+ setInnerHTML body $ Just canvasHtml+ Just c <- getElementById doc "canvas"+ toContext c+ where canvasHtml :: String+ canvasHtml = "<canvas id=\"canvas\" " ++ attrs ++ " </canvas> "++-- | Create a full screen canvas+fullScreenCanvas :: Window -> IO CanvasRenderingContext2D+fullScreenCanvas webView = customAttributesCanvas webView attributes+ where attributes :: String+ attributes = "style=\"border:1px \+ \solid #000000; \+ \top:0px;bottom:0px;left:0px;right:0px;\""++-- | Create a fixed size canvas given the dimensions+fixedSizeCanvas :: Window -> Int -> Int -> IO CanvasRenderingContext2D+fixedSizeCanvas webView x y = customAttributesCanvas webView $ attributes x y+ where attributes :: Int -> Int -> String+ attributes x' y' = "width=\""++ show x' ++ "\" \+ \height=\""++ show y' ++ "\" \+ \style=\"border:1px \+ \solid #000000;\""++-- | Draws a picture which depends only on the time+animate :: CanvasRenderingContext2D -- ^ the context to draw on+ -> Float -- ^ FPS+ -> (Float -> Picture) -- ^ Your drawing function+ -> IO ()+animate ctx fps f = animateIO ctx fps $ return . f++-- | Draws a picture which depends only on the time... and everything else,+-- since you can do I/O.+animateIO :: CanvasRenderingContext2D -- ^ the context to draw on+ -> Float -- ^ FPS+ -> (Float -> IO Picture) -- ^ Your drawing function+ -> IO ()+animateIO ctx fps f = do+ initialTime <- getCurrentTime+ let loop = do+ stamp <- getCurrentTime+ -- empty the canvas before drawing+ -- MAYBE we need a buffer canvas on which to draw before copying it+ -- on the main canvas to avoid blinking+ clearRect ctx (-10000) (-10000) 20000 20000 --FIXME+ setTransform ctx 1 0 0 1 0 0 -- reset transforms (and accumulated errors!).+ -- get the Picture and draw it+ let t = realToFrac $ diffUTCTime stamp initialTime+ pic <- f t+ render ctx pic+ -- delay to match the target fps+ now <- getCurrentTime+ let td = diffUTCTime now stamp+ when (realToFrac td <= 1 / fps) $+ threadDelay $ floor $ (*1000000) (1 / fps - realToFrac td)+ loop+ in+ loop++getModifiersMouse :: ReaderT MouseEvent IO Modifiers+getModifiersMouse = Modifiers+ <$> fmap toKeyState mouseCtrlKey+ <*> fmap toKeyState mouseAltKey+ <*> fmap toKeyState mouseShiftKey+ <*> fmap toKeyState mouseMetaKey++getModifiersKeyboard :: ReaderT KeyboardEvent IO Modifiers+getModifiersKeyboard = Modifiers+ <$> fmap toKeyState (event >>= getCtrlKey)+ <*> fmap toKeyState (event >>= getAltKey)+ <*> fmap toKeyState (event >>= getShiftKey)+ <*> fmap toKeyState (event >>= getMetaKey)++-- | Lets you manage the input.+play :: (IsEventTarget eventElement, IsDocument eventElement)+ => CanvasRenderingContext2D -- ^ the context to draw on+ -> eventElement+ -> Float -- ^ FPS+ -> state -- ^ Initial state+ -> (state -> Picture) -- ^ Drawing function+ -> (Input -> state -> state) -- ^ Input handling function+ -> (Float -> state -> state) -- ^ Stepping function+ -> IO ()+play ctx doc fps initialState draw handleInput step =+ playIO+ ctx+ doc+ fps+ initialState+ (return . draw)+ (\s i -> return $ handleInput s i)+ (\s t -> return $ step s t)++-- | Same thing with I/O+playIO :: (IsEventTarget eventElement, IsDocument eventElement)+ => CanvasRenderingContext2D -- ^ the context to draw on+ -> eventElement+ -> Float -- ^ FPS+ -> state -- ^ Initial state+ -> (state -> IO Picture) -- ^ Drawing function+ -> (Input -> state -> IO state) -- ^ Input handling function+ -> (Float -> state -> IO state) -- ^ Stepping function+ -> IO ()+playIO ctx doc fps initialState draw handleInput step = do+ inputM <- newMVar [] -- this will accumulate the inputs+ -- setting up event listeners for mouse and keyboard+ _ <- on doc mouseDown $ do+ btn <- fmap toMouseBtn mouseButton+ modifiers <- getModifiersMouse+ when (isJust btn) $+ liftIO $ modifyMVar_ inputM $ fmap return (MouseBtn (fromJust btn) Down modifiers :) -- :-) :D XD+ _ <- on doc mouseUp $ do+ btn <- fmap toMouseBtn mouseButton+ modifiers <- getModifiersMouse+ when (isJust btn) $+ liftIO $ modifyMVar_ inputM $ fmap return (MouseBtn (fromJust btn) Up modifiers :) -- :-) :D XD+ _ <- on doc mouseMove $ do+ coords <- mouseOffsetXY -- experimental!+ liftIO $ modifyMVar_ inputM $ fmap return (MouseMove coords :) -- :-) :D XD+ _ <- on doc wheel $ do+ delta <- (,) <$> (event >>= getDeltaX) <*> (event >>= getDeltaY)+ liftIO $ modifyMVar_ inputM $ fmap return (MouseWheel delta :) -- :-) :D XD+ _ <- on doc keyDown $ do+ key <- uiKeyCode+ modifiers <- getModifiersKeyboard+ liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup key) Down modifiers :) -- :-) :D XD+ _ <- on doc keyUp $ do+ key <- uiKeyCode+ modifiers <- getModifiersKeyboard+ liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup key) Up modifiers :) -- :-) :D XD+ initialTime <- getCurrentTime+ -- main loop+ let loop state previousTime = do+ -- retrieve inputs and empty inputM+ inputs <- modifyMVar inputM $ \xs -> return ([], xs)+ -- handle inputs+ state' <- foldrM handleInput state inputs+ -- state stepping+ beforeRendering <- getCurrentTime+ let td = diffUTCTime beforeRendering previousTime+ state'' <- step (realToFrac td) state'+ -- actual rendering begins+ clearRect ctx (-10000) (-10000) 20000 20000 --FIXME+ setTransform ctx 1 0 0 1 0 0 -- reset transforms (and accumulated errors!).+ pic <- draw state''+ render ctx pic+ afterRendering <- getCurrentTime --do we really need two timestamps?+ -- delay to match the target fps+ let renderingTime = diffUTCTime afterRendering beforeRendering+ when (realToFrac renderingTime <= 1 / fps) $+ threadDelay $ floor $ (*1000000) (1 / fps - realToFrac renderingTime)+ loop state'' beforeRendering+ in+ loop initialState initialTime
+ src/Graphics/Shine/Image.hs view
@@ -0,0 +1,50 @@+{-|+Module : Graphics.Shine.Image+Description : Short description+Copyright : (c) Francesco Gazzetta, 2016+License : MIT+Maintainer : francygazz@gmail.com+Stability : experimental++Handling of external image (.png, .svg and all browser-supported formats).+-}++{-# LANGUAGE ForeignFunctionInterface #-}++module Graphics.Shine.Image (+ makeImage,+ ImageSize (..),+ ImageData (..),+) where++import GHCJS.DOM.HTMLImageElement++-- | Just a wrapper around the 'HTMLImageElement' type. Needed for the Show instance.+newtype ImageData = ImageData { unImageData :: HTMLImageElement } deriving Eq++-- we need this to show Pictures+instance Show ImageData where+ show _ = "ImageData"++-- | How big (and how stretched/cropped) the Image is drawn+data ImageSize =+ -- | The orizinal size of the image+ Original+ -- | Scale the image to the given dimensions+ | Stretched Float Float+ -- | Clip the image from the given coordinates to the given width and height+ | Clipped Float Float Float Float+ -- | Clip (x,y,width,height) and scale (width, height) the image+ | ClippedStretched Float Float Float Float Float Float+ deriving (Eq, Show)++foreign import javascript unsafe "$r = new Image();"+ js_newImage :: IO HTMLImageElement+++-- | Makes an image element from an URL+makeImage :: FilePath -> IO ImageData+makeImage url = do+ img <- js_newImage+ setSrc img url+ return $ ImageData img
+ src/Graphics/Shine/Input.hs view
@@ -0,0 +1,45 @@+{-|+Module : Graphics.Shine.Input+Description : Short description+Copyright : (c) Francesco Gazzetta, 2016+License : MIT+Maintainer : francygazz@gmail.com+Stability : experimental++Datatypes representing inputs.+-}+module Graphics.Shine.Input where++import Web.KeyCode++-- | The state of a button on the keyboard+data KeyState = Down | Up deriving (Show, Eq)++-- | The four key modifiers+data Modifiers = Modifiers { ctrl :: KeyState+ , alt :: KeyState+ , shift :: KeyState+ , meta :: KeyState }+ deriving (Show, Eq)++-- | The three mouse buttons+data MouseBtn = BtnLeft | BtnRight | BtnMiddle deriving (Show, Eq)++-- | Datatype representing all possible inputs+data Input = Keyboard Key KeyState Modifiers+ | MouseBtn MouseBtn KeyState Modifiers+ | MouseWheel (Double, Double)+ | MouseMove (Int, Int)+ deriving (Show, Eq)++-- | Convert a js mouse button identifier to the corresponding datatype+toMouseBtn :: Word -> Maybe MouseBtn+toMouseBtn 0 = Just BtnLeft+toMouseBtn 1 = Just BtnMiddle+toMouseBtn 2 = Just BtnRight+toMouseBtn _ = Nothing++-- | Convert a bool (from js) to a keystate+toKeyState :: Bool -> KeyState+toKeyState True = Down+toKeyState False = Up
+ src/Graphics/Shine/Picture.hs view
@@ -0,0 +1,82 @@+{-|+Module : Graphics.Shine.Picture+Description : Short description+Copyright : (c) Francesco Gazzetta, 2016+License : MIT+Maintainer : francygazz@gmail.com+Stability : experimental++This module contains the 'Picture' datatype, used to represent the image to draw+on the canvas, and some functions to operate on it.+-}+module Graphics.Shine.Picture (+ Picture (..),+ Color (..),+ TextAlignment (..),+ Font,+ circle,+ path,+ (<>)+) where++import Data.Monoid ((<>))+import Graphics.Shine.Image++-- | Js-style font, ex. @"12px Sans"@+type Font = String++-- | How the text should be aligned+data TextAlignment = LeftAlign | CenterAlign | RightAlign deriving (Eq, Show)++-- | A color given r, g, b (all from 0 to 255) and alpha (from 0 to 1)+data Color = Color Int Int Int Float deriving (Eq, Show)++-- | A drawable element. All Pictures are centered.+data Picture =+ -- | The empty picture. Draws nothing.+ Empty+ -- | A rectangle from the dimensions+ | Rect Float Float+ -- | Same thing but filled+ | RectF Float Float+ -- | A line from the coordinates of two points+ | Line Float Float Float Float+ -- | A polygon from a list of vertices+ | Polygon [(Float, Float)]+ -- | An arc from the radius, start angle, end angle.+ -- If the last parameter is True, the direction is counterclockwise+ -- TODO replace with Clockwise | Counterclockwise or remove entirely+ | Arc Float Float Float Bool+ -- | A filled circle from the radius+ | CircleF Float+ -- | Draws some text. The float is the max width.+ | Text Font TextAlignment Float String+ -- | Draws an image+ | Image ImageSize ImageData+ -- | Draws the second `Picture` over the first+ | Over Picture Picture+ -- | Applies the `Color` to the picture.+ -- Innermost colors have the precedence, so you can set a "global+ -- color" and override it+ | Colored Color Picture+ -- | Rotates the Picture (in radians)+ | Rotate Float Picture+ -- | Moves the Picture by the given x and y distances+ | Translate Float Float Picture+ -- TODO stroke+ deriving (Eq, Show)++-- | A circle from the center coordinates and radius+circle :: Float -> Picture+circle r = Arc r 0 (2*3.14) False++-- | Shorthand to draw a series of lines+path :: [(Float,Float)] -> Picture+path xs = foldMap (\((x,y),(x',y')) -> Line x y x' y') $ zip xs $ tail xs++-- | 'Picture's are 'Monoid's. The identity is an 'Empty' (completely transparent)+-- picture and the composing function is the overlapping (the right picture is+-- drawn over the left one).+instance Monoid Picture where+ mempty = Empty+ mappend = Over
+ src/Graphics/Shine/Render.hs view
@@ -0,0 +1,119 @@+{-|+Module : Graphics.Shine.Render+Description : Short description+Copyright : (c) Francesco Gazzetta, 2016+License : MIT+Maintainer : francygazz@gmail.com+Stability : experimental++One-shot rendering, mostly used internally.+-}+module Graphics.Shine.Render (+ render+) where++import GHCJS.DOM.HTMLImageElement (getWidth, getHeight)+import GHCJS.DOM.CanvasRenderingContext2D+import GHCJS.DOM.Enums (CanvasWindingRule (CanvasWindingRuleNonzero))+import GHCJS.DOM.Types (CanvasStyle (..))++import GHCJS.Prim (toJSString)+import Data.List (intercalate)++import Graphics.Shine.Picture+import Graphics.Shine.Image+++-- | Renders a picture on a 2D context.+render :: CanvasRenderingContext2D -> Picture -> IO ()+render _ Empty = return ()+render ctx (Line x y x' y') = do+ moveTo ctx x y+ lineTo ctx x' y'+ stroke ctx+render ctx (Rect x y) = do+ rect ctx (-x/2) (-y/2) x y+ stroke ctx+render ctx (RectF x y) = fillRect ctx (-x/2) (-y/2) x y+render ctx (Polygon ((x,y):pts)) = do+ beginPath ctx+ moveTo ctx x y+ mapM_ (uncurry (lineTo ctx)) pts+ closePath ctx+ fill ctx CanvasWindingRuleNonzero+render ctx (Polygon []) = render ctx Empty+render ctx (Arc r a b direction) = do+ beginPath ctx+ arc ctx 0 0 r a b direction+ stroke ctx+render ctx (CircleF r) = do+ save ctx+ render ctx $ circle r+ clip ctx CanvasWindingRuleNonzero+ render ctx $ RectF (r*2) (r*2)+ restore ctx+render ctx (Text font align width txt) = do+ setFont ctx font+ setTextAlign ctx $ case align of LeftAlign -> "left"+ CenterAlign -> "center"+ RightAlign -> "rignt"+ fillText ctx txt 0 0 width+render ctx (Image size (ImageData img)) =+ case size of+ Original -> do+ x <- ((/(-2)) . realToFrac) <$> getWidth img+ y <- ((/(-2)) . realToFrac) <$> getHeight img+ drawImage ctx (Just img) x y+ (Stretched w h) -> do+ let (x, y) = (-w/2, -h/2)+ drawImageScaled ctx (Just img) x y w h+ (Clipped a b c d) -> do+ let (x, y) = (-c/2, -d/2)+ drawImagePart ctx (Just img) a b c d x y c d+ (ClippedStretched a b c d e f) -> do+ let (x, y) = (-e/2, -f/2)+ drawImagePart ctx (Just img) a b c d x y e f+render ctx (Over a b) = do+ render ctx a+ render ctx b+render ctx (Colored col (Over a b)) = render ctx $ Over (Colored col a)+ (Colored col b)+-- push all the Colors to the leaves to avoid things like+-- Color blue $ Translate _ _ $ Over (Color red pic) pic'q+-- in which pic' would be black instead of blue:+-- do+-- set color blue -- first Colored+-- translate+-- set color red -- second Colored+-- render pic+-- set color back to black -- second Colored+-- render pic' -- now this is black!+-- translate back+-- set color back to black -- first Colored+render ctx (Colored col (Rotate angle pic)) =+ render ctx $ Rotate angle $ Colored col pic+render ctx (Colored col (Translate x y pic)) =+ render ctx $ Translate x y $ Colored col pic+render ctx (Colored _ (Colored col pic)) =+ render ctx $ Colored col pic --the innermost color wins+render ctx (Colored (Color r g b a) pic) = do+ let colorString = "rgba("+ ++ intercalate "," [show r, show g, show b, show a]+ ++ ")"+ let color = toJSString colorString+ setFillStyle ctx $ Just $ CanvasStyle color+ setStrokeStyle ctx $ Just $ CanvasStyle color+ render ctx pic+ -- set the color back to black+ let black = toJSString "#000000"+ setFillStyle ctx $ Just $ CanvasStyle black+ setStrokeStyle ctx $ Just $ CanvasStyle black+render ctx (Rotate angle pic) = do+ rotate ctx angle+ render ctx pic+ --setTransform ctx 1 0 0 1 0 0 --not ok: prevents Rotate composition+ rotate ctx (-angle)+render ctx (Translate x y pic) = do+ translate ctx x y+ render ctx pic+ translate ctx (-x) (-y)
+ tests/everything.hs view
@@ -0,0 +1,53 @@+import Graphics.Shine+import Graphics.Shine.Input+import Graphics.Shine.Image+import Graphics.Shine.Picture++import GHCJS.DOM (webViewGetDomDocument, runWebGUI)++myPic :: ImageData -> Float -> Picture+myPic img x =+ Translate (75+x'/2) 15 (RectF (150+x') 30)+ <> Colored (Color 255 0 0 1.0) (Translate 15 (75+x'/2) $ Rect 30 (150+x'))+ <> Colored (Color 200 200 0 1.0) (Translate 660 30 $ RectF 120 60)+ <> Colored (Color 100 100 (floor x') 1.0) (Translate 600 340 $ RectF 120 240)+ <> Translate (150+x') 150 (circle 100)+ <> Translate 140 120 (circle (80+x'))+ <> Line 400 400 10 x'+ <> Colored (Color 255 0 0 1.0) (Translate 800 500 $ CircleF (x'/10))+ <> foldMap (Translate 300 300 . circle) [1,5..x']+ <> Translate 350 350 (Rotate (x'/200) $ RectF 150 30)+ <> Translate 100 500 (Image Original img)+ <> Colored (Color 0 0 255 1) -- blue pentagon+ (Translate 200 500+ (Polygon [ (-110,-80)+ , (50,-120)+ , (140,20)+ , (30,140)+ , (-120,80)+ ]))+ <> Translate 600 500 (Text "20px Sans" CenterAlign 300 "The quick brown fox jumps over the lazy dog")+ where x' = sin (x*3) *100 +100++myAnimation :: IO ()+myAnimation = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 800 600+ img <- makeImage "httpS://placehold.it/200x70/afa"+ animate ctx 30 $ myPic img++myGame :: IO ()+myGame = runWebGUI $ \ webView -> do+ ctx <- fixedSizeCanvas webView 800 600+ Just doc <- webViewGetDomDocument webView+ play ctx doc 30 initialState draw handleInput step+ where+ initialState = False+ draw False = Empty+ draw True = RectF 300 300+ handleInput (MouseBtn BtnLeft Down _) = const True+ handleInput (MouseBtn BtnLeft Up _) = const False+ handleInput _ = id+ step _ = id++main :: IO ()+main = myAnimation --or myGame