Instantly share code, notes, and snippets.

# ploeh/Main.purs

Last active February 23, 2021 00:45
Show Gist options
• Save ploeh/d9d207906adf44713e302ba7d3654f11 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 purescript-drawing demo
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 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.

### 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": {
"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

### 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
``````