Skip to content

Instantly share code, notes, and snippets.

@ploeh

ploeh/Main.purs

Last active Mar 24, 2020
Embed
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

This comment has been minimized.

Copy link

@miclill miclill commented Jun 6, 2017

Thanks for sharing.

@hakonrossebo

This comment has been minimized.

Copy link

@hakonrossebo hakonrossebo commented Jun 7, 2017

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"
},

@nsdevaraj

This comment has been minimized.

Copy link

@nsdevaraj nsdevaraj commented Jun 8, 2017

Nice article

@patroza

This comment has been minimized.

Copy link

@patroza patroza commented Mar 24, 2020

Updated version for latest with Spago. used with npm/parcel:
https://github.com/purescript/spago#get-started-from-scratch-with-parcel-frontend-projects

module Main where

import Effect (Effect)
import Data.Maybe (fromJust)
import Data.Tuple (Tuple(..))
import Graphics.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 -> Effect 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 ctx line.width
    void $ lineTo ctx x' y'
    closePath ctx

drawTree :: Context2D -> Tree Line -> Effect 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 :: Effect 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.