Skip to content

Instantly share code, notes, and snippets.

@apskii

apskii/Bounce

Last active August 29, 2015 14:13
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save apskii/6d2865179d57212600c2 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save apskii/6d2865179d57212600c2 to your computer and use it in GitHub Desktop.
Download ZIP
Bounce
Raw
Bounce
// run here: http://jsfiddle.net/6mt3ffpe/
module Bounce where
import DOM
import Graphics.Canvas
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Trans
import Control.Monad.RWS
import Control.Monad.RWS.Trans
import qualified Control.Monad.JQuery as JQ
import Data.Monoid
import Data.Maybe
foreign import undefined :: forall a. a
foreign import yoba """function yoba(msg) {
console.log(msg);
};""" :: forall a . String -> a
foreign import tick """function tick(delay) {
return function(func) { return function() { return window.setInterval(func, delay); }; };
};""" :: forall eff r . Number -> Eff eff Unit -> Eff (dom :: DOM | eff) Unit
foreign import eventProps """function eventProps(evt) {
return function () { return { x : evt.pageX, y : evt.pageY }; };
};""" :: forall eff . JQ.JQueryEvent -> Eff (dom :: DOM | eff) { x :: Number, y :: Number }
clamp :: Number -> Number -> Number -> Number
clamp lo hi x = Math.max lo (Math.min hi x)
type Config = #
ballColor :: String
ballRadius :: Number
canvasElemId :: String
sceneWidth :: Number
sceneHeight :: Number
tickInterval :: Number
type Ball = #
x :: Number
y :: Number
vx :: Number
vy :: Number
type Scene = #
context :: Context2D
ballref :: RefVal Ball
type Bounce = RWST Config Unit Scene
type RefCanvasEff eff = Eff (ref :: Ref, canvas :: Canvas | eff)
type RefDomEff eff = Eff (ref :: Ref, dom :: DOM | eff)
runBounce :: forall m a . (Monad m) => Config -> Scene -> Bounce m a -> m a
runBounce r s m = runRWST m r s >>= \x -> return x.result
withRS :: forall r w s m a . (Monad m, Monoid w) => (r -> s -> RWST r w s m a) -> RWST r w s m a
withRS mf = ask >>= \r -> get >>= \s -> mf r s
bindEvents :: forall eff . Config -> Scene -> RefDomEff eff Unit
bindEvents conf scene = do
body <- JQ.body
canvas <- JQ.find conf.canvasElemId body
JQ.on "click" (onCanvasClick scene) canvas
return unit
where
onCanvasClick scene evt _ = do
{ x = mouseX, y = mouseY } <- eventProps evt
ball <- readRef scene.ballref
writeRef scene.ballref $ ball #
vx = (mouseX - ball.x) * 1.5
vy = ball.y - mouseY
return unit
renderScene :: forall eff . Bounce (RefCanvasEff eff) Unit
renderScene = withRS \conf scene -> do
ball <- lift $ readRef scene.ballref
let ctx = scene.context
lift $ clearRect ctx #
x: 0
y: 0
w: conf.sceneWidth
h: conf.sceneHeight
lift $ setFillStyle conf.ballColor ctx
lift $ fillPath ctx $ arc ctx #
x : ball.x
y : ball.y
r : conf.ballRadius
start : 0
end : 2 * Math.pi
return unit
performPhysics :: forall eff . Bounce (Eff (ref :: Ref | eff)) Unit
performPhysics = withRS \conf scene -> do
ball <- lift $ readRef scene.ballref
let r = conf.ballRadius
vx = ball.vx
newX = clamp r (conf.sceneWidth - r) (ball.x + ball.vx * 0.1)
newY = clamp r (conf.sceneHeight - r) (ball.y - ball.vy * 0.1)
lift $ writeRef scene.ballref $ ball #
x = newX
y = newY
vx = if (newX == r || newX == conf.sceneWidth - r)
then 0 - ball.vx / 2
else if vx > 0 then vx - 2 else vx + 2
vy = if (newY == r || newY == conf.sceneHeight - r)
then 0 - ball.vy / 2
else ball.vy - 10
return unit
conf :: Config
conf = #
ballColor : "red"
ballRadius : 10
canvasElemId : "canvas"
sceneWidth : 200
sceneHeight : 200
tickInterval : 24
initScene :: forall eff . Config -> RefCanvasEff eff Scene
initScene conf = do
Just canvas <- getCanvasElementById conf.canvasElemId
context <- getContext2D canvas
ballref <- newRef #
x : conf.sceneWidth / 2
y : conf.sceneHeight / 2
vx : 0
vy : 0
return #
context : context
ballref : ballref
main = JQ.ready do
scene <- initScene conf
bindEvents conf scene
tick conf.tickInterval $
runBounce conf scene do
renderScene
performPhysics
return unit
Raw
bower.json
{
"name": "bounce",
"version": "0.0.0",
"license": "MIT",
"private": true,
"dependencies": {
"purescript-canvas": "0.2.0",
"purescript-transformers": "0.4.0",
"purescript-refs" : "0.1.2",
"purescript-math" : "0.1.0",
"purescript-jquery" : "0.3.0"
},
"ignore": [
"**/.*",
"node_modules",
"bower_components",
"test",
"tests"
]
}
Raw
Gruntfile.js
module.exports = function(grunt) {
"use strict";
grunt.initConfig({
srcFiles: [
"src/**/*.desugar.purs",
"bower_components/**/src/**/*.purs"
],
psc: {
options: {
main: "Bounce",
modules: ["Bounce"]
},
all: {
src: ["<%=srcFiles%>"],
dest: "dist/Main.js"
}
},
run: {
commands: {
exec: "find src/*.purs | cut -d '.' -f 1 | uniq "
+ "| xargs -If puresugar f.purs f.desugar.purs"
}
}
});
grunt.loadNpmTasks("grunt-purescript");
grunt.loadNpmTasks("grunt-run");
grunt.registerTask("default", ["run:commands", "psc:all"]);
};
Raw
index.html
<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8" />
<title></title>
<script src="http://code.jquery.com/jquery-1.11.2.min.js"></script>
<script src="dist/Main.js"></script>
<style type="text/css">
#canvas {
border: 1px solid black;
}
</style>
</head>
<body>
<canvas id="canvas" width="200px" height="200px"></canvas>
</body>
</html>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment