{{ message }}

Instantly share code, notes, and snippets.

# ploeh/Main.purs

Last active Feb 23, 2021
 purescript-drawing demo
 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 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 commented Jun 8, 2017

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