yampa-canvas 0.2 → 0.2.2
raw patch · 4 files changed
+212/−21 lines, 4 filesdep +yampa-canvasdep ~Yampadep ~basedep ~blank-canvasnew-uploader
Dependencies added: yampa-canvas
Dependency ranges changed: Yampa, base, blank-canvas, stm, time
Files
- CHANGELOG.md +5/−0
- example/BouncingBalls.hs +180/−0
- src/FRP/Yampa/Canvas.hs +1/−1
- yampa-canvas.cabal +26/−20
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## 0.2.2+* Allow building with `blank-canvas-0.6` and `Yampa-0.10`++## 0.2.1+* Allowed building with `base-4.8.0.0` and `time-1.5`
+ example/BouncingBalls.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++module BouncingBalls where++-- set browser to: http://localhost:3000/+import Graphics.Blank hiding (Event)+import FRP.Yampa+import FRP.Yampa.Vector2+import Data.Text(Text)++import FRP.Yampa.Canvas++---------------------------------------------------++main :: IO ()+main = blankCanvas 3000 animateBouncingBalls++-- | Display an animation of multiple falling balls.+animateBouncingBalls :: DeviceContext -> IO ()+animateBouncingBalls = reactimateSFinContext (\ _ -> return NoEvent) renderScene (bouncingBalls someBalls)++---------------------------------------------------++type Radius = Double++type Acceleration = Vector2 Double+type Velocity = Vector2 Double+type Position = Vector2 Double++type Colour = Text++---------------------------------------------------++data Ball = MkBall { pos :: Position,+ vel :: Velocity,+ radius :: Radius,+ colour :: Colour+ }++negateXVel :: Ball -> Ball+negateXVel b = b { vel = let (x,y) = vector2XY (vel b)+ in vector2 (negate x) y+ }++negateYVel :: Ball -> Ball+negateYVel b = b { vel = let (x,y) = vector2XY (vel b)+ in vector2 x (negate y)+ }++---------------------------------------------------++ball1 :: Ball+ball1 = MkBall { pos = vector2 0.1 0.5,+ vel = vector2 0.4 0.1,+ radius = 0.05,+ colour = "red"+ }++ball2 :: Ball+ball2 = MkBall { pos = vector2 0.3 0.7,+ vel = vector2 (-0.5) (-0.1),+ radius = 0.03,+ colour = "blue"+ }++ball3 :: Ball+ball3 = MkBall { pos = vector2 0.5 0.4,+ vel = vector2 0.2 1.3,+ radius = 0.04,+ colour = "green"+ }++ball4 :: Ball+ball4 = MkBall { pos = vector2 0.7 0.8,+ vel = vector2 (-0.1) (-0.2),+ radius = 0.06,+ colour = "yellow"+ }++ball5 :: Ball+ball5 = MkBall { pos = vector2 0.2 0.9,+ vel = vector2 1.8 0.85,+ radius = 0.02,+ colour = "orange"+ }++someBalls :: [Ball]+someBalls = [ball1,ball2,ball3,ball4,ball5]++gravity :: Acceleration+gravity = vector2 0 (-1)++---------------------------------------------------++-- | Construct a free-falling ball from an initial ball configuration.+fallingBall :: Ball -> SF x Ball+fallingBall b = constant gravity >>> accelerator (vel b) (pos b) >>> arr updateBall+ where+ updateBall :: (Position,Velocity) -> Ball+ updateBall (p,v) = b { pos = p, vel = v }++-- | Construct a ball that bounces in one dimension from an initial ball configuration.+bouncingBall1d :: forall x. Ball -> SF x Ball+bouncingBall1d b = switchWhen (fallingBall b) detectFloor f+ where+ detectFloor :: SF Ball (Event Ball)+ detectFloor = edgeWhen p+ where+ p :: Ball -> Bool+ p b1 = (vector2Y (pos b1) <= radius b1) || (vector2Y (pos b1) >= 1 - radius b1)++ f :: Ball -> SF x Ball+ f b2 = bouncingBall1d (negateYVel b2)++-- | Construct a ball that bounces in two dimensions.+bouncingBall2d :: forall x. Ball -> SF x Ball+bouncingBall2d b = switchWhen (bouncingBall1d b) detectWall f+ where+ detectWall :: SF Ball (Event Ball)+ detectWall = edgeWhen p+ where+ p :: Ball -> Bool+ p b1 = (vector2X (pos b1) <= radius b1) || (vector2X (pos b1) >= 1 - radius b1)++ f :: Ball -> SF x Ball+ f b2 = bouncingBall2d (negateXVel b2)++-- | Construct a list of bouncing balls from a list of initial ball configurations.+bouncingBalls :: [Ball] -> SF x [Ball]+bouncingBalls bs = parB (map bouncingBall2d bs)++-------------------------------------------------------------------++-- | Draw a circle.+circle :: Position -> Radius -> Colour -> Canvas ()+circle pos' r col = do beginPath ()+ arc (vector2X pos', vector2Y pos', r, 0, pi*2, False)+ closePath ()+ fillStyle col+ fill ()++-- | A Canvas action to render a single Ball.+renderBall :: Ball -> Canvas ()+renderBall b = circle (pos b) (radius b) (colour b)++-- | A Canvas action to render a list of Balls.+renderBalls :: [Ball] -> Canvas ()+renderBalls = mapM_ renderBall++-- | A Canvas action to render the entire scene.+renderScene :: [Ball] -> Canvas ()+renderScene bs = scaleScene >> renderBalls bs++-- | We scale such that (0,0) is the bottom-left of the canvas and (1,1) is the top-right.+scaleScene :: Canvas ()+scaleScene =+ do context <- myCanvasContext+ let w = width context+ h = height context+ translate (0,h)+ scale (w, negate h)++-------------------------------------------------------------------++-- Auxillary signal function combinators not provided by the Yampa library.++-- | Given an initial 'Velocity' and 'Position', produce a signal function that takes an acceleration and emits+-- the current 'Velocity' and 'Distance'.+accelerator :: Velocity -> Position -> SF Acceleration (Position,Velocity)+accelerator v0 d0 = imIntegral v0 >>> (imIntegral d0 &&& identity)++-- | A variant of 'FRP.Yampa.switch' where the event only depends on the output of the sub-ordinate signal function.+switchWhen :: SF a b -> SF b (Event e) -> (e -> SF a b) -> SF a b+switchWhen sf1 sfe = switch (sf1 >>> identity &&& sfe)++-- | A variant of 'FRP.Yampa.edge' which takes a predicate on an input signal, and tags the event with the value of the input signal.+edgeWhen :: (a -> Bool) -> SF a (Event a)+edgeWhen p = (p ^>> edge) &&& identity >>^ uncurry tag++-------------------------------------------------------------------
src/FRP/Yampa/Canvas.hs view
@@ -30,7 +30,7 @@ -- 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))+ (Blank.Event -> Canvas (Event a)) -> (b -> Canvas ()) -> SF (Event a) b -> DeviceContext -> IO ()
yampa-canvas.cabal view
@@ -1,43 +1,49 @@ name: yampa-canvas-version: 0.2-synopsis: blank-canvas frontend for yampa+version: 0.2.2+synopsis: blank-canvas frontend for Yampa+description: @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+copyright: Copyright (c) 2014 The University of Kansas category: Graphics build-type: Simple-extra-source-files: README.md+extra-source-files: CHANGELOG.md, README.md+tested-with: GHC == 7.8.4, GHC == 7.10.3 cabal-version: >=1.10 +source-repository head+ type: git+ location: https://github.com/ku-fpg/yampa-canvas+ 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.*+ build-depends: base >= 4.7 && < 4.9,+ blank-canvas >= 0.5 && < 0.7,+ stm == 2.4.*,+ time >= 1.4 && < 1.6,+ Yampa >= 0.9.6 && < 0.11 hs-source-dirs: src default-language: Haskell2010 flag example- Description: Please build the example- Default: False+ 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+ build-depends: base >= 4.7 && < 4.9,+ blank-canvas >= 0.5 && < 0.7,+ text >= 1.1 && < 1.3,+ Yampa >= 0.9.6 && < 0.11,+ yampa-canvas == 0.2.2+ main-is: DropBalls.hs+ other-modules: BouncingBalls+ hs-source-dirs: example default-language: Haskell2010- Ghc-Options: -Wall -threaded+ ghc-options: -Wall -threaded