Create a gist now

Instantly share code, notes, and snippets.

@ploeh /Main.purs
Last active Aug 6, 2017

What would you like to do?
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN">
<html>
<head>
<title>purescript-drawing demo</title>
</head>
<body>
<canvas id="canvas" width="800" height="800"></canvas>
<script src="index.js" type="text/javascript"></script>
</body>
</html>
module Main where
import Control.Monad.Eff (Eff)
import Data.Maybe (fromJust)
import Data.Tuple (Tuple(..))
import Graphics.Canvas (CANVAS, Context2D, closePath, getCanvasElementById,
getContext2D, lineTo, moveTo, setLineWidth, strokePath)
import Math (cos, pi, sin)
import Partial.Unsafe (unsafePartial)
import Prelude (Unit, bind, discard, negate, void, ($), (*), (+), (-), (/), (<=))
data Tree a = Leaf a | Node a (Tree a) (Tree a)
data Line = Line {
x :: Number,
y :: Number,
angle :: Number,
length :: Number,
width :: Number }
data FractalParameters = FractalParameters {
leftAngle :: Number,
rightAngle :: Number,
shrinkFactor :: Number }
endpoint :: forall r.
{ x :: Number
, y :: Number
, angle :: Number
, length :: Number
| r }
-> Tuple Number Number
endpoint line =
-- Flip the y value because Canvas coordinate system points down from upper
-- left corner
Tuple
(line.x + line.length * cos line.angle)
(-(-line.y + line.length * sin line.angle))
createBranches :: FractalParameters -> Line -> Tuple Line Line
createBranches (FractalParameters p) (Line line) =
Tuple left right
where
Tuple x y = endpoint line
left = Line {
x: x,
y: y,
angle: pi * (line.angle / pi + p.leftAngle),
length: (line.length * p.shrinkFactor),
width: (line.width * p.shrinkFactor) }
right = Line {
x: x,
y: y,
angle: pi * (line.angle / pi - p.rightAngle),
length: (line.length * p.shrinkFactor),
width: (line.width * p.shrinkFactor) }
-- Not tail-recursive
createTree :: Int -> FractalParameters -> Line -> Tree Line
createTree depth p line =
if depth <= 0
then Leaf line
else
let Tuple leftLine rightLine = createBranches p line
left = createTree (depth - 1) p leftLine
right = createTree (depth - 1) p rightLine
in Node line left right
drawLine :: Context2D -> Line -> Eff (canvas :: CANVAS) Unit
drawLine ctx (Line line) = do
let Tuple x' y' = endpoint line
void $ strokePath ctx $ do
void $ moveTo ctx line.x line.y
void $ setLineWidth line.width ctx
void $ lineTo ctx x' y'
closePath ctx
drawTree :: Context2D -> Tree Line -> Eff (canvas :: CANVAS) Unit
drawTree ctx (Leaf line) = drawLine ctx line
drawTree ctx (Node line left right) = do
drawLine ctx line
drawTree ctx left
drawTree ctx right
main :: Eff (canvas :: CANVAS) Unit
main = do
mcanvas <- getCanvasElementById "canvas"
let canvas = unsafePartial (fromJust mcanvas)
ctx <- getContext2D canvas
let trunk = Line
{ x: 300.0, y: 600.0, angle: (pi / 2.0), length: 100.0, width: 4.0 }
let p = FractalParameters
{ leftAngle: 0.1, rightAngle: 0.1, shrinkFactor: 0.8 }
let tree = createTree 10 p trunk
drawTree ctx tree

miclill commented Jun 6, 2017

Thanks for sharing.

Thanks, great article. Not sure if I'm wrong here, but a note to others trying this - I had to do a pulp init, move source files to /src and add these dependencies to bower.json with bower install -save. Also copied index.html to the output html folder.

Dependencies added:
"dependencies": {
"purescript-prelude": "^3.0.0",
"purescript-console": "^3.0.0",
"purescript-maybe": "^3.0.0",
"purescript-tuples": "^4.1.0",
"purescript-canvas": "^3.0.0",
"purescript-math": "^2.0.0",
"purescript-partial": "^1.2.0"
},

Nice article

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment