tree-derivations

Tree Derivations

A tour of Haskell by way of drawing trees

Bob Grudem

github.com/bobgru/tree-derivations

Purpose

Give an introductory talk at Boston Haskell that:

Shows a Haskell style of problem solving
Uses standard containers and functions
Uses the diagrams package

Topic—Drawing Trees

We will develop from scratch aprogram to draw a stick figure...

Topic—Drawing Trees

...then taper the branches...

Topic—Drawing Trees

...then model the tree in 3D.

A Haskell Style of Development

Examine the problem details
Determine the input and output data types
Determine a sequence of intervening types
Choose functions for each transformation
Stitch them together

Problem Details

Given:

point p, vector v, fixed scalar R, fixed angle θ

Then:

q ＝ p displaced by v w l ＝ v scaled by R, rotated by θ w r ＝ v scaled by R, rotated by −θ

So: (p, v) ⟼ { (q, wl), (q, wr) }

Input and Output Types—Thoughts

Our input will be the initial values of (p, v).
Our output is a file in some image format.
To determine the input and output types, we must know something of the libraries we plan to use.

The Diagrams Package

Has types for 2D points and vectors: P2 and R2
Supports numerous output formats, including SVG
Has type Diagram SVG R2 for working with 2D diagrams that will be output in SVG format
Has functions for creating diagrams from points and vectors and for composing them from lists (e.g. fromOffsets, mconcat)

Input and Output Types—Decided

Our input type is (P2, R2)
Our output type is Diagram SVG R2, ultimately output as an SVG file

Intervening Type Sequence—Thoughts

We will probably need some sort of Tree type.
The containers package on Hackage
- contains Tree a, where a represents the type of the data in a node—(P2, R2).
- has a function for creating a tree (unfoldTree)
- has a function for altering the contents of a tree (fmap)
- has a function for converting a tree to a list (flatten)

Intervening Type Sequence—Suggestion

The following is one possible sequence of types, informed by knowledge of what the containers and diagrams packages offer:

TreeNode = (P2, R2) Tree TreeNode Tree (Diagram SVG R2) [Diagram SVG R2] Diagram SVG R2 SVG file

Functions

Now we choose a function to accomplish each type transformation. The origin and unitY functions return a distinguished P2 and R2, respectively.

(origin, unitY) :: TreeNode unfoldTree f :: TreeNode → Tree TreeNode where f :: TreeNode → (TreeNode, [TreeNode]) fmap f :: Tree TreeNode → Tree (Diagram SVG R2) where f :: TreeNode → Diagram SVG R2 flatten :: Tree (Diagram SVG R2) → [Diagram SVG R2] mconcat :: [Diagram SVG R2] → Diagram SVG R2 defaultMain :: IO () which writes an SVG file

Final Assembly

We have all the information needed to write the program, except for the two helper functions to unfoldTree and fmap.

TreeNode → Tree TreeNode

unfoldTree invokes the branches function recursively starting from seed to produce a tree. Note that this process never ends—buildTree produces an infinite tree!

buildTree        :: Tree TreeNode
buildTree        =  unfoldTree branches seed

seed             :: TreeNode
seed             =  (origin, unitY)

branches         :: TreeNode -> (TreeNode, [TreeNode])
branches (p, v)  =  ((p, v), [(q, br (1/7)), (q, br (-1/7))])
    where q    = p .+^ v
          br a = v # scale 0.6 # rotateBy a

TreeNode → Tree TreeNode—Finitely

branches decides based on segment length when to stop.

buildTree  :: Tree TreeNode
buildTree  = unfoldTree branches seed

seed       :: TreeNode
seed       = (origin, unitY)

branches   :: TreeNode -> (TreeNode, [TreeNode])
branches   (p, v)
    | magnitude v < 0.05  =  ((p, v), [])
    | otherwise           =  ((p, v), pvs)
    where pvs  = [(q, br (1/7)), (q, br (-1/7))]
          q    = p .+^ v
          br a = v # scale 0.6 # rotateBy a

Tree TreeNode → Tree (Diagram SVG R2)

fmap applies the drawBranch function to every node of a tree without mention of the latter—an example of point-free style.

drawBranch creates a diagram of a line segment between p and p + v— a piece of data, not an image.

renderTree        :: Tree TreeNode -> Tree (Diagram SVG R2)
renderTree        =  fmap drawBranch

drawBranch        :: TreeNode -> Diagram SVG R2
drawBranch (p, v) =  place (fromOffsets [v]) p

Tree (Diagram SVG R2) to SVG file

We extend renderTree to a composition pipeline invoking mconcat after flatten after fmap drawBranch.

main is the program entrypoint, which invokes defaultMain to create an SVG file from the result of renderTree buildTree.

main       :: IO ()
main       =  defaultMain $ renderTree buildTree

renderTree :: Tree TreeNode -> Diagram SVG R2
renderTree =  mconcat . flatten . fmap drawBranch

A sample command line to run the program to create the file tree.svg with a width of 400 pixels:

λ: dist/build/stick-figure-0/stick-figure-0 -w 400 -o tree.svg

Stick Figure—The Code

Assembling code from the previous slides, with a few changes—add import statements, apply pad to the final diagram, remove type declarations:

import Data.Tree(flatten, unfoldTree)
import Diagrams.Backend.SVG.CmdLine(defaultMain)
import Diagrams.Prelude

main       = defaultMain $ pad 1.1 $ renderTree buildTree
renderTree = mconcat . flatten . fmap drawBranch
buildTree  = unfoldTree branches seed
seed       = (origin, unitY)
drawBranch (p, v) = place (fromOffsets [v]) p
branches   (p, v)
    | magnitude v < 0.05  =  ((p, v), [])
    | otherwise           =  ((p, v), pvs)
    where pvs  = [(q, br (1/7)), (q, br (-1/7))]
          q    = p .+^ v
          br a = v # scale 0.6 # rotateBy a

src/StickFigure0.hs

Casual Analysis

Declarative—no loops, conditionals, or sequence
Concise—6 functions, 5 one-liners, 4 without arguments
Self-documenting—no comments necessary
Type inference worked—type declarations helped during development but were ultimately unnecessary
Function application in 3 ways: f x, f $ x, x # f
No explicit data structures other than lists and pairs
No explicit recursion—embedded in unfoldTree
All pure code besides defaultMain
Close brush with an infinite tree

Preparing for Tapered—Overview

Refactor the code (no change to behavior!)

Add module name and type declarations Extract constants into configuration data structure Extract calculation of branch tips into new function Add explicit width Add white space and reformat slightly

Preparing for Tapered

Add module name and type declarations

module Main where
import Data.Tree(Tree, flatten, unfoldTree)
import Diagrams.Backend.SVG.CmdLine(defaultMain)
import Diagrams.Backend.SVG(SVG)
import Diagrams.Prelude

type TreeNode = (P2, R2)
type Dgm = Diagram SVG R2

src/StickFigure3.hs

Preparing for Tapered

Define configuration data structure

data TreeConfig = TC {
    tcScale        :: Double,
    tcCutOff       :: Double,
    tcMinWidth     :: Double,
    tcInitialWidth :: Double,
    tcBranchScale  :: Double,
    tcBranchAngle  :: Double
} deriving (Show)

src/StickFigure3.hs

Preparing for Tapered

Extract constants into configuration data structure

tc :: TreeConfig
tc = TC {
    tcScale        = s,
    tcCutOff       = 0.05 * s,
    tcMinWidth     = 0.01 * s,
    tcInitialWidth = 0.01 * s,
    tcBranchScale  = 0.6,
    tcBranchAngle  = 1/7
}
    where s = 10000

src/StickFigure3.hs

Preparing for Tapered

Extract calculation of branch tips into new function

branches :: TreeNode -> (TreeNode, [TreeNode])
branches n@(_, v)
    | magnitude v < tcCutOff tc  =  (n, [])
    | otherwise                  =  (n, branchTips n)

branchTips :: TreeNode -> [TreeNode]
branchTips (p, v) = [(q, br a), (q, br (-a))]
    where q    = p .+^ v
          br a = v # scale (tcBranchScale tc) # rotateBy a
          a    = tcBranchAngle tc

src/StickFigure3.hs

Preparing for Tapered

Add explicit width

type TreeNode = (P2, R2, Double)

tcInitialWidth :: Double

tcInitialWidth = 0.01 * s

seed = (origin, unitY ^* tcScale tc, tcInitialWidth tc)
drawBranch (p, v, w) = place (fromOffsets [v]) p # lw w
	...
branches n@(_, v, _)
	...
branchTips (p, v, w) = [(q, br a, w), (q, br (-a), w)]
	...

src/StickFigure3.hs

Tapered Branches—The Code Increase the initial width and add taper If minimum width, draw line; otherwise, draw trapezoid. Apply the taper, enforcing a minimum width

Tapered Branches—The Code

Increase the initial width and add taper

tcWidthTaper   :: Double

tcInitialWidth = 0.1  * s
tcWidthTaper   = 0.7

src/Tapered0.hs

Tapered Branches—The Code

If minimum width, draw line; otherwise, draw trapezoid.

drawBranch n@(p, v, w) = place d p
    where d | w <= tcMinWidth tc  =  lineSegment v w
            | otherwise           =  trapezoid n
lineSegment v w     = fromOffsets [v] # lw w
trapezoid (p, v, w) = (closeLine . lineFromVertices) [ p, a, b, c, d ]
                    # strokeLoop # fc black # lw 0.01
    where p' = p .+^ v
          w' = taperWidth w
          n  = v # rotateBy (1/4) # normalized
          w2 = w  / 2 ; w2' = w' / 2
          a  = p  .-^ (w2  *^ n) ; b = p' .-^ (w2' *^ n)
          c  = p' .+^ (w2' *^ n) ; d = p  .+^ (w2  *^ n)

src/Tapered0.hs

Tapered Branches—The Code

Apply the taper, enforcing a minimum width

taperWidth :: Double -> Double
taperWidth w = max (w * tcWidthTaper tc) (tcMinWidth tc)

branchTips (p, v, w) = [(q, br a, w'), (q, br (-a), w')]
          ...
          w'   = taperWidth w

src/Tapered0.hs

Preparing for 3D—Overview

Refactor the code (no change to behavior!)

Import 3D libraries Change seed to unitZ from unitY—the tree is now in the X-Z plane Add functions to project point and branch node Apply rotation in 3D instead of 2D Update comments to reflect new types

Preparing for 3D

Import 3D libraries and change seed to unitZ

import Diagrams.ThreeD.Transform(aboutY)
import Diagrams.ThreeD.Types(unp3)
import Diagrams.ThreeD.Vector(unitZ)

seed = (origin, unitZ ^* tcScale tc, tcInitialWidth tc)

src/Tapered1.hs

Preparing for 3D

Add functions to project point and branch node

renderTree = mconcat . flatten . fmap drawBranch . fmap projectNode

--projectNode :: TreeNode3 -> TreeNode
projectNode (p, v, w) = (p', v', w)
    where q  = p .+^ v
          q' = projectPtXZ q
          p' = projectPtXZ p
          v' = q' .-. p'

--projectPtXZ :: P3 -> P2
projectPtXZ p = case unp3 p of (x, _, z) -> p2 (x, z)

src/Tapered1.hs

Preparing for 3D

Apply rotation in 3D instead of 2D

br a = v # scale (tcBranchScale tc) # t a
...
t a  = transform (aboutY (a @@ turn))

src/Tapered1.hs

Preparing for 3D

Update comments to reflect new types

--type TreeNode3 = (P3, R3, Double)
--renderTree :: Tree TreeNode3 -> Dgm
--buildTree  :: Tree TreeNode3
--seed       :: TreeNode3
--branches   :: TreeNode3 -> (TreeNode3, [TreeNode3])
--branchTips :: TreeNode3 -> [TreeNode3]

src/Tapered1.hs

Deep 3D—The Code Rewrite branchTips to create childnodes off the X-Z plane Add inject and mkTip functions Add pointAt'' function Import needed library functions Tune cut off length

Deep 3D—The Code

Rewrite branchTips

-- Build a regular polygon in the XY-plane and tilt it perpendicular
-- to the vector it branches from. Orient the polygon to make the
-- projection more interesting.
--branchTips :: TreeNode3 -> [TreeNode3]
branchTips n@(_, v, _) = polygon po
                       # map (.-. origin)
                       # map inject
                       # map (^+^ (unitZ ^* h))
                       # map (transform (pointAt'' unitZ unitZ v))
                       # map (^*  (magnitude v * tcBranchScale tc))
                       # map (mkTip n)
    where po = PolygonOpts (PolyRegular c s) (OrientTo v') origin
          c  = 3            -- number of sides
          s  = 0.782        -- length of side
          v' = r2 (1,3)     -- orientation vector
          h  = 0.623        -- "height" of tips above base

src/Deep3D.hs

Deep 3D—The Code

Add inject and mkTip functions

--inject :: R2 -> R3
inject v = case unr2 v of (x, y) -> r3 (x, y, 0)

--mkTip :: TreeNode3 -> R3 -> TreeNode3
mkTip (p, v, w) v' = (p .+^ v, v', taperWidth w)

src/Deep3D.hs

Deep 3D—The Code

Add pointAt'' function

-- Copied from http://projects.haskell.org/diagrams/haddock/src/
-- Diagrams-ThreeD-Transform.html#pointAt
-- and modified to change the calculation of tilt angle.
-- Also eliminating panning, which is done for us automatically
-- by virtue of the relative vector spaces of composed subdiagrams.
-- There is already a function called pointAt'.
--pointAt'' :: R3 -> R3 -> R3 -> T3
pointAt'' about initial final = tilt
    where
        tiltAngle = angleBetween initial final
        tiltDir   = direction $ cross3 about final :: Spherical
        tilt      = rotationAbout origin tiltDir tiltAngle

src/Deep3D.hs

Deep 3D—The Code

Import needed library functions and tune cut off

import Data.Cross(cross3)
...
import Diagrams.Prelude hiding (rotationAbout, direction, angleBetween)
import Diagrams.ThreeD.Transform(aboutY, pointAt', rotationAbout)
import Diagrams.ThreeD.Types(unp3, R3, r3, T3, Spherical)
import Diagrams.ThreeD.Vector(unitZ, direction, angleBetween)

tcCutOff       = 0.12 * s

src/Deep3D.hs

A Note on Type Inference

According to my hint (Tapered0.hs)

--branchTips :: TreeNode -> [TreeNode]

According to my hint (Deep3D.hs)

--branchTips :: TreeNode3 -> [TreeNode3]

A Note on Type Inference

According to GHCI (cabal repl tapered-0)

tree-derivations$ cabal repl tapered-0
...
Ok, modules loaded: Main.
λ: :t branchTips 
branchTips
  :: (vector-space-0.8.6:Data.AffineSpace.AffineSpace t,
      diagrams-core-1.1.0.3:Diagrams.Core.Transform.Transformable
        (vector-space-0.8.6:Data.AffineSpace.Diff t),
      diagrams-core-1.1.0.3:Diagrams.Core.V.V
        (vector-space-0.8.6:Data.AffineSpace.Diff t)
      ~ Diagrams.TwoD.Types.R2) =>
     (t, vector-space-0.8.6:Data.AffineSpace.Diff t, Double)
     -> [(t, vector-space-0.8.6:Data.AffineSpace.Diff t, Double)]

A Note on Type Inference

According to GHCI (cabal repl deep-3d)

tree-derivations$ cabal repl deep-3d
...
Ok, modules loaded: Main.
λ: :t branchTips 
branchTips
  :: (Data.AffineSpace.AffineSpace t,
      Data.AffineSpace.Diff t ~ Diagrams.ThreeD.Types.R3) =>
     (t, Diagrams.ThreeD.Types.R3, Double)
     -> [(t, Diagrams.ThreeD.Types.R3, Double)]

Resources

Tree-derivations http://github.com/bobgru/tree-derivations The Haskell Platform http://www.haskell.org/platform Diagrams http://projects.haskell.org/diagrams Standard containers http://hackage.haskell.org/package/containers-0.5.5.1 reveal.js http://lab.hakim.se/reveal-js Git http://git-scm.com

The End

github.com/bobgru/tree-derivations

Tree Derivations

bobgru

Tree Derivations

1 3 (function() { var po = document.createElement('script'); po.type = 'text/javascript'; po.async = true; po.src = 'https://apis.google.com/js/platform.js'; var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(po, s); })();