Skip to content

Instantly share code, notes, and snippets.

@ploeh

ploeh/Main.purs

Last active February 23, 2021 00:45
Show Gist options
  • Star 5 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save ploeh/d9d207906adf44713e302ba7d3654f11 to your computer and use it in GitHub Desktop.
Save ploeh/d9d207906adf44713e302ba7d3654f11 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
index.html
<!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>
Raw
Main.purs
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
@nsdevaraj
Copy link

Nice article

@patroza
Copy link

patroza commented Mar 24, 2020 •
edited

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