yampa-canvas (empty) → 0.2
raw patch · 6 files changed
+221/−0 lines, 6 filesdep +Yampadep +basedep +blank-canvassetup-changed
Dependencies added: Yampa, base, blank-canvas, stm, text, time
Files
- LICENSE +26/−0
- README.md +4/−0
- Setup.hs +2/−0
- example/DropBalls.hs +72/−0
- src/FRP/Yampa/Canvas.hs +74/−0
- yampa-canvas.cabal +43/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014 The University of Kansas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+yampa-canvas+============++Blank Canvas backend for Yampa
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/DropBalls.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}++module Main where++-- set browser to: http://localhost:3000/+import Graphics.Blank hiding (Event)+import qualified Graphics.Blank as Blank+import FRP.Yampa+import FRP.Yampa.Vector2++import FRP.Yampa.Canvas+import BouncingBalls hiding (main,renderScene)++---------------------------------------------------++main :: IO ()+main = blankCanvas 3000 { events = ["click"] } $ animateDroppingBalls++-- | Display an animation of multiple falling balls.+animateDroppingBalls :: DeviceContext -> IO ()+animateDroppingBalls = reactimateSFinContext detectClick renderScene dropBalls++-- | A Canvas action to render the entire scene.+renderScene :: [Ball] -> Canvas ()+renderScene bs = renderInstructions >> scaleScene >> renderBalls bs++-- | A Canvas action to render the instruction text.+renderInstructions :: Canvas ()+renderInstructions =+ do font "20pt Comic Sans MS"+ fillText ("Click on the canvas to add a ball",50,50)++---------------------------------------------------++-- | Detect a mouse click in the canvas.+detectClick :: Blank.Event -> Canvas (Event Position)+detectClick ev = case ePageXY ev of+ Nothing -> return NoEvent+ Just (x,y) -> fmap Event (toXYCo (x,y))++-- | Convert a Blank Canvas co-ordinate into a Yampa Position.+toXYCo :: (Double,Double) -> Canvas Position+toXYCo (i,j) =+ do context <- myCanvasContext+ let w = width context+ h = height context+ return $ vector2 (i / w) (1 - j / h)++---------------------------------------------------++-- | Construct a bouncing ball model that allows responds to input events by adding new balls.+dropBalls :: SF (Event Position) [Ball]+dropBalls = ballGenerator >>> ballCollection []++-- | A collection of active balls into which new balls can be dropped.+ballCollection :: [SF (Event Ball) Ball] -> SF (Event Ball) [Ball]+ballCollection bs = notYet >>> pSwitchB bs (arr fst) (\ sfs b -> ballCollection (bouncingBall1d b : sfs))++-- | Convert events carrying co-ordinates into events carrying new balls.+ballGenerator :: SF (Event Position) (Event Ball)+ballGenerator = arr (fmap newBallAt)++-- | Create a new ball of the specified colour, at the specified co-ordinates.+newBallAt :: Position -> Ball+newBallAt p = MkBall+ { pos = p,+ vel = vector2 0 0,+ radius = 0.02,+ colour = "purple"+ }++-------------------------------------------------------------------
+ src/FRP/Yampa/Canvas.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}++module FRP.Yampa.Canvas (reactimateSFinContext) where++import FRP.Yampa++import Data.Time.Clock+import Data.IORef+import Control.Concurrent.STM++import Graphics.Blank hiding (Event)+import qualified Graphics.Blank as Blank++-------------------------------------------------------------------++-- | Redraw the entire canvas.+renderCanvas :: DeviceContext -> Canvas () -> IO ()+renderCanvas context drawAction = send context canvas+ where+ canvas :: Canvas ()+ canvas = do clearCanvas+ beginPath ()+ saveRestore drawAction++-------------------------------------------------------------------++type Clock = IORef UTCTime++-- | A specialisation of 'FRP.Yampa.reactimate' to Blank Canvas.+-- The arguments are: the Canvas action to get input, the Canvas action to emit output, the signal function to be run, and the device context to use.+reactimateSFinContext+ :: forall a b.+ (Blank.Event -> Canvas (Event a))+ -> (b -> Canvas ())+ -> SF (Event a) b+ -> DeviceContext -> IO ()+reactimateSFinContext interpEvent putCanvasOutput sf context =+ do clock <- newClock++ let getInput :: Bool -> IO (DTime,Maybe (Event a))+ getInput canBlock =+ do let opt_block m =+ if canBlock+ then m+ else m `orElse` return Nothing++ opt_e <- atomically $ opt_block $ fmap Just $ readTChan (eventQueue context)+ ev <- case opt_e of+ Nothing -> return NoEvent+ Just e -> send context (interpEvent e)++ t <- clockTick clock+ return (t, Just ev)++ putOutput :: Bool -> b -> IO Bool+ putOutput changed b = if changed+ then renderCanvas context (putCanvasOutput b) >> return False+ else return False++ reactimate (return NoEvent) getInput putOutput sf++-- | Start a new clock.+newClock :: IO Clock+newClock = getCurrentTime >>= newIORef++-- | Compute the time delta since the last clock tick.+clockTick :: Clock -> IO DTime+clockTick x =+ do t0 <- readIORef x+ t1 <- getCurrentTime+ writeIORef x t1+ return (realToFrac (diffUTCTime t1 t0))++-------------------------------------------------------------------
+ yampa-canvas.cabal view
@@ -0,0 +1,43 @@+name: yampa-canvas+version: 0.2+synopsis: blank-canvas frontend for yampa+license: BSD3+license-file: LICENSE+author: Neil Sculthorpe+maintainer: andygill@ku.edu+copyright: Copyright (c) 2014 The University of Kansas+category: Graphics+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: FRP.Yampa.Canvas+ other-extensions: ScopedTypeVariables+ build-depends: base >= 4.7 && < 4.8,+ time >= 1.4 && < 1.5,+ blank-canvas >= 0.5 && < 0.6,+ Yampa >= 0.9.6 && < 0.10,+ stm == 2.4.*+ hs-source-dirs: src+ default-language: Haskell2010++flag example+ Description: Please build the example+ Default: False++executable yampa-canvas-bouncing-balls+ if flag(example)+ buildable: True+ else+ buildable: False+ Build-Depends: base >= 4.7 && < 4.8,+ time >= 1.4 && < 1.5,+ blank-canvas >= 0.5 && < 0.6,+ Yampa >= 0.9.6 && < 0.10,+ stm == 2.4.*,+ text >= 1.1 && < 1.3+ Main-Is: DropBalls.hs+ Hs-Source-Dirs: example, src+ default-language: Haskell2010+ Ghc-Options: -Wall -threaded