2008-12-10

Drawing trees with Haskell and Cairo


I'd like to draw a tree, but how? Let's start by writing a simple draw loop:

module Main where
import Graphics.Rendering.Cairo
import Canvas

main = canvas draw 600 600

draw w h t = do
color white
rectangle 0 0 w h
fill
color black
drawTree w h t

Then, what is a tree? A tree is sort of a recursive forking function. A scanl towards the sun. Every year its branches grow in thickness, possibly forking.

Let's define a simple branch as a function of age and angle. A branch of age 0 has no forks. A branch of age N has 2 sub-branches of age N-1.

branch 0 angle = [map (rotateP angle) [(0,0), (0, -1)]]
branch n angle =
this ++ subBranches
where
this = branch 0 angle
[[_,(x,y)]] = this
subBranches = map (map (translateP x y)) (left ++ right)
left = branch (n-1) (angle-pi/8)
right = branch (n-1) (angle+pi/8)

To draw the branches, we need to write the drawTree procedure. Here's one that draws a tree of age 7 and rotates it in the middle of the screen:

drawTree w h t = do
translate (w/2) (h/2)
rotate t
mapM_ strokeLine tree
where tree = map (map (uscaleP 25)) $ branch 7 0

You can see the result on the right. Not the prettiest tree in the land. Let's make the branches get thicker with age.

To draw lines of different thickness, we need to add the thickness information to the line data structure. Previously it was a list of (x,y)-tuples, with width it becomes a (lineWidth, (x,y) list)-tuple. A couple combinators will help here:

strokeWidthLine = tupleDo lineWidth strokeLine
mapWidthLine f = fupleR (map f)

fupleR f (a,b) = (a, f b)

Then rewrite branch and drawTree to use width-carrying lines:

drawTree w h t = do
translate (w/2) h
mapM_ strokeWidthLine tree
where tree = map (mapWidthLine (uscaleP 25)) $ branch 8 0

branch 0 angle = []
branch n angle =
(thickness, points) : subBranches
where
points = map (rotateP angle) [(0,0), (0, -1)]
thickness = n
[_,(x,y)] = points
subBranches = map (mapWidthLine (translateP x y)) (left ++ right)
left = branch (n-1) (angle-pi/8)
right = branch (n-1) (angle+pi/8)


Now the tree grows from the bottom of the screen and looks a bit more aesthetically pleasing. Next we could make the branches rotate and grow with an upwards bias. Compute distance from up-vector and scale points and the angle accordingly. Something like this:

da = angularDistance 0 angle
scale = 3 * ((1-(abs da / pi)) ** 2)
points = map (rotateP (angle + da/3) . uscaleP scale) [(0,0), (0, -1)]

And then, hmm, random angles for the branches? That needs a bit of extra work. The random number generator is in the IO monad, whereas draw is in the Render monad, and branch is a pure function. So, extend main to get a pure list of random Doubles, then pass that to draw, which passes it to drawTree and branch.

main = do
gen <- getStdGen
let ns = randoms gen :: [Double]

canvas (draw ns) 600 600

draw ns w h t = do
color white
rectangle 0 0 w h
fill
color black
drawTree ns w h t

drawTree ns w h t = do
translate (w/2) (h+5)
mapM_ strokeWidthLine tree
where tree = map (mapWidthLine (uscaleP 25)) $ branch ns 8 (pi/2*sin t)

And make branch do something with it:

branch _ 0 _ = []
branch (r1:r2:rs) n angle =
[...snip...]
left = branch (takeOdd rs) (n-1) (angle - r1*pi/4)
right = branch (takeEven rs) (n-1) (angle + r2*pi/4)

takeOdd [] = []
takeOdd [x] = []
takeOdd (_:x:xs) = x : (takeOdd xs)

takeEven [] = []
takeEven [x] = [x]
takeEven (x:_:xs) = x : (takeEven xs)

The result of all this tomfoolery is a tree that looks a bit more natural than the geometric trees above.

The trees at the top of this post use random numbers for scaling the branches as well, so they're even more noisy.

Here's the source code: tree.hs and canvas.hs.
Compile by doing ghc --make tree.hs canvas.hs -o tree
Post a Comment

Blog Archive