diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl
index 52b29e9c39..6992ca3861 100644
--- a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl
+++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl
@@ -891,6 +891,10 @@ pict with the same shape and location.}
 
 @; ----------------------------------------
 
+@include-section["tree-layout.scrbl"]
+
+@; ----------------------------------------
+
 @section{Miscellaneous}
 
 @defproc[(hyperlinkize [pict pict?])
diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl
new file mode 100644
index 0000000000..1d32239e31
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl
@@ -0,0 +1,177 @@
+#lang scribble/doc
+
+@(require (for-label pict racket pict/tree-layout)
+          pict/private/layout
+          scribble/manual
+          scribble/eval)
+
+@(define tree-layout-eval (make-base-eval))
+@(tree-layout-eval '(require pict/tree-layout pict))
+
+@title{Tree Layout}
+
+These functions specify tree layouts and functions
+that render them as @racket[pict]s.
+
+@declare-exporting[pict/tree-layout]
+
+@defproc[(tree-layout [#:pict node-pict (or/c #f pict?) #f]
+                      [child (or/c tree-layout? tree-edge? #f)] ...)
+         tree-layout?]{
+  Specifies an interior node of a tree for use with one of the renderers below.
+  
+  If the children are @racket[tree-layout?]s, then they have edges
+  created by passing the corresponding @racket[tree-layout?]s directly
+  to @racket[tree-edge]. Children that are @racket[#f] correspond to
+  leaf nodes that are not drawn.
+  
+  The default @racket[node-pict] (used when it is @racket[#f]) is
+  @default-node-pict
+}
+
+@defproc[(tree-edge [node tree-layout?]
+                    [#:edge-color edge-color
+                                  (or/c string? 
+                                        (is-a?/c color%)
+                                        (list/c byte? byte? byte?))
+                                  "gray"])
+         tree-edge?]{
+  This function specifies an edge from some parent to the given @racket[node].
+  It it intended to be used with @racket[tree-layout].
+}
+
+@defproc[(tree-layout? [v any/c]) boolean?]{
+  Recognizes a tree layout. It returns @racket[#t]
+  when given @racket[#f] or the result of @racket[tree-layout].
+}
+
+@defproc[(binary-tree-layout? [v any/c]) boolean?]{
+  Recognizes a @racket[tree-layout?] that represents
+  a binary tree. That is, each interior node
+  has either two children or is @racket[#f]. Note
+  that a node with zero children does not count as a
+  leaf for the purposes of @racket[binary-tree-layout?].
+  
+  @examples[#:eval 
+            tree-layout-eval
+            (binary-tree-layout? (tree-layout #f #f))
+            (binary-tree-layout? #f)
+            (binary-tree-layout? (tree-layout (tree-layout) (tree-layout)))]
+}
+
+@defproc[(tree-edge? [v any/c]) boolean?]{
+  Recognizes an @racket[tree-edge].
+}
+
+
+@defproc[(naive-layered [tree-layout tree-layout?]
+                        [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f]
+                        [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f])
+         pict?]{
+  Uses a naive layered algorithm to build the tree.
+  It recursively constructs subtrees and then horizontally
+  combines them, aligning them at the tops. Then it places
+  the root node centered over the children nodes.
+  
+  @examples[#:eval 
+            tree-layout-eval
+            (define (complete d)
+              (cond
+                [(zero? d) #f]
+                [else (define s (complete (- d 1)))
+                      (tree-layout s s)]))
+            
+            (naive-layered (complete 4))
+            
+            (naive-layered (tree-layout
+                            (tree-layout)
+                            (tree-layout)
+                            (tree-layout
+                             (tree-layout)
+                             (tree-layout)
+                             (tree-layout
+                              (tree-layout)
+                              (tree-layout)))))
+            (define right-subtree-with-left-chain
+              (tree-layout
+               (tree-layout
+                (tree-layout #f #f)
+                (tree-layout
+                 (tree-layout #f #f)
+                 #f))
+               (tree-layout
+                (tree-layout
+                 (tree-layout
+                  (tree-layout #f #f)
+                  #f)
+                 #f)
+                #f)))
+            (naive-layered right-subtree-with-left-chain)]
+}
+                
+@defproc[(binary-tidier [tree-layout binary-tree-layout?]
+                        [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f]
+                        [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f])
+         pict?]{
+  Uses the layout algorithm from
+  @italic{Tidier Drawing of Trees} by Edward M. Reingold and John S. Tilford
+  (IEEE Transactions on Software Engineering, Volume 7, Number 2, March 1981)
+  to lay out @racket[tree-layout].
+  
+  The layout algorithm guarantees a number of properties, namely:
+  @itemlist[@item{nodes at the same level of tree appear at 
+                  the same vertical distance from the top of the pict}
+             @item{parents are centered over their children, which are 
+                   placed from left to right,}
+             @item{isomorphic subtrees are drawn the same way, no matter
+                   where they appear in the complete tree, and}
+             @item{a tree and its mirror image produce picts that are
+                   mirror images of each other (which also holds for subtrees
+                   of the complete tree).}]
+  Within those constraints, the algorithm tries to make as narrow a drawing
+  as it can, even to the point that one subtree of a given node might cross
+  under the other one.
+
+  The @racket[x-spacing] and @racket[y-spacing] are the amount of space that each
+  row and each column takes up, measured in pixels. If @racket[x-spacing] is @racket[#f],
+  it is the width of the widest node @racket[pict?] in the tree. 
+  If @racket[y-spacing] is @racket[#f],
+  it is @racket[1.5] times the width of the widest node @racket[pict?] in the tree. 
+  
+  @examples[#:eval 
+            tree-layout-eval
+            
+            (binary-tidier (complete 4))
+
+            
+            (define (dl t) (tree-layout (tree-layout #f #f) t))
+            (define (dr t) (tree-layout t (tree-layout #f #f)))
+            (binary-tidier
+             (tree-layout
+              (dr (dr (dr (dl (dl (dl (complete 2)))))))
+              (dl (dl (dl (dr (dr (dr (complete 2)))))))))
+            
+            
+            (binary-tidier right-subtree-with-left-chain)]
+
+
+}
+
+@defproc[(hv-alternating [tree-layout binary-tree-layout?]
+                         [#:x-spacing x-spacing (or/c (and/c real? positive?) #f) #f]
+                         [#:y-spacing y-spacing (or/c (and/c real? positive?) #f) #f])
+         pict?]{
+                
+  Uses the ``CT'' binary tree layout algorithm from 
+  @italic{A note on optimal area algorithms for upward drawing of binary trees}
+  by P. Crescenzi, G. Di Battista, and A. Piperno 
+  (Computational Geometry, Theory and Applications, 1992) to lay out @racket[tree-layout].
+  
+  It adds horizontal and vertical space between layers based on @racket[x-spacing] and
+  @racket[y-spacing]. If either is @racket[#f], @racket[1.5] times the size of the biggest
+  node is used.
+                
+  @examples[#:eval 
+            tree-layout-eval
+            (hv-alternating (complete 8))]
+}
diff --git a/pkgs/pict-pkgs/pict-lib/info.rkt b/pkgs/pict-pkgs/pict-lib/info.rkt
index 4e4bcaa75b..29ba051c03 100644
--- a/pkgs/pict-pkgs/pict-lib/info.rkt
+++ b/pkgs/pict-pkgs/pict-lib/info.rkt
@@ -6,6 +6,7 @@
                "base"
                "compatibility-lib"
                "draw-lib" "snip-lib"))
+(define build-deps '("rackunit-lib"))
 
 (define pkg-desc "implementation (no documentation) part of \"pict\"")
 
diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt
new file mode 100644
index 0000000000..046aab95a5
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt
@@ -0,0 +1,122 @@
+#lang racket/base
+(require "../main.rkt"
+         "layout.rkt"
+         racket/match)
+
+#|
+
+A note on optimal area algorithms for upward drawing of binary trees
+P. Crescenzi, G. Di Battista, and A. Piperno
+Computational Geometry, Theory and Applications 2 (1992)
+
+|#
+(provide hv-alternating)
+(define (hv-alternating t #:x-spacing [given-x-spacing #f] #:y-spacing [given-y-spacing #f])
+  (define-values (x-size y-size) (compute-spacing t #f #f))
+  (define x-spacing (or given-x-spacing (* x-size 1.5)))
+  (define y-spacing (or given-y-spacing (* y-size 1.5)))
+  (inset
+   (let loop ([t t]
+              [l #t])
+     (match t
+       [#f (blank)]
+       [(tree-layout pict (list left right))
+        (define-values (left-t left-color) 
+          (match left
+            [#f (values #f #f)]
+            [(tree-edge child color) (values child color)]))
+        (define-values (right-t right-color) 
+          (match right
+            [#f (values #f #f)]
+            [(tree-edge child color) (values child color)]))
+        (cond
+          [(and (not left-t) (not right-t)) 
+           (dot-ize pict)]
+          [(not left-t) 
+           (empty-left (dot-ize pict) x-spacing right-color (loop right-t (not l)))]
+          [(not right-t)
+           (empty-right (dot-ize pict) y-spacing left-color (loop left-t (not l)))]
+          [else
+           (define left-p (loop left-t (not l)))
+           (define right-p (loop right-t (not l)))
+           (define main
+             ((if l left-right top-bottom)
+              x-spacing y-spacing
+              left-p right-p))
+           (pin-over
+            (add-lines main left-color right-color left-p right-p)
+            (- (/ (pict-width pict) 2))
+            (- (/ (pict-height pict) 2))
+            pict)])]))
+   (/ x-size 2)
+   (/ y-size 2)))
+
+(define (dot-ize p)
+  (define b (blank))
+  (refocus (cc-superimpose b p) b))
+
+(define (left-right hgap vgap left right)
+  (ht-append
+   hgap
+   (vl-append (blank 0 vgap) left)
+   right))
+
+(define (top-bottom hgap vgap left right)
+  (vl-append 
+   vgap
+   (ht-append (blank hgap 0) left)
+   right))
+
+(define (empty-left pict hgap color sub-tree-p)
+  (add-a-line (ht-append hgap pict sub-tree-p)
+              color 
+              sub-tree-p))
+  
+(define (empty-right pict vgap color sub-tree-p)
+  (add-a-line (vl-append vgap pict sub-tree-p)
+              color
+              sub-tree-p))
+
+(define (add-lines main left-color right-color t1 t2)
+  (add-a-line (add-a-line main left-color t1)
+              right-color t2))
+  
+(define (add-a-line main color sub)
+  (cc-superimpose
+   (launder
+    (colorize
+     (pin-line (ghost main)
+               main lt-find 
+               sub lt-find)
+     color))
+   main))
+
+(module+ test
+  (require rackunit)
+  
+  (check-pred pict? 
+              (hv-alternating 
+               (let* ([p1 (_tree-layout #f #f)]
+                      [p2 (_tree-layout p1 p1)]
+                      [p3 (_tree-layout p2 p2)]
+                      [p4 (_tree-layout p3 p3)])
+                 (_tree-layout p4 p4))))
+  (check-pred 
+   pict?
+   (hv-alternating (_tree-layout (_tree-layout #f #f) #f)))
+  (check-pred
+   pict?
+   (hv-alternating (_tree-layout #f (_tree-layout #f (_tree-layout #f #f)))))
+  (check-pred pict? (hv-alternating #f)))
+
+(module+ main
+  (define (complete n)
+    (cond
+      [(= n 0) #f]
+      [else
+       (define t (complete (- n 1)))
+       (_tree-layout t t)]))
+  
+  ;; an example from the paper
+  (hv-alternating (complete 4)))
+
diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt
new file mode 100644
index 0000000000..2c4c241396
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt
@@ -0,0 +1,80 @@
+#lang racket/base
+(require "../main.rkt" racket/match)
+
+(provide (struct-out tree-layout)
+         (struct-out tree-edge)
+         binary-tree-layout?
+         _tree-layout?
+         _tree-layout
+         _tree-edge
+         default-node-pict
+         compute-spacing)
+
+;; values of this struct leak outside, so it cannot be transparent
+(struct tree-layout (pict children))
+(struct tree-edge (child edge-color))
+
+(define _tree-layout
+  (let ([constructor tree-layout])
+    (define (tree-layout #:pict [node-pict #f]
+                         . children)
+      (constructor (or node-pict default-node-pict)
+                   (for/list ([child (in-list children)])
+                     (cond
+                       [(tree-edge? child) child]
+                       [(not child) child]
+                       [else (_tree-edge child)]))))
+    tree-layout))
+
+(define _tree-layout?
+  (let ([predicate tree-layout?])
+    (define (tree-layout? v)
+      (or (not v) (predicate v)))
+    tree-layout?))
+
+(define default-node-pict
+  (cc-superimpose
+   (disk 12)
+   (colorize (disk 8) "white")))
+
+(define _tree-edge
+  (let ([constructor tree-edge])
+    (define (tree-edge child #:edge-color [edge-color "gray"])
+      (constructor child edge-color))
+    tree-edge))
+
+(define (binary-tree-layout? t)
+  (match t
+    [#f #t]
+    [(tree-layout pict (list left right))
+     (and (binary-tree-edge? left)
+          (binary-tree-edge? right))]
+    [else #f]))
+
+(define (binary-tree-edge? e)
+  (match e
+    [(tree-edge t _) (binary-tree-layout? t)]
+    [#f #t]))
+
+(define (compute-spacing t given-x-spacing given-y-spacing)
+  (cond
+    [(and given-x-spacing given-y-spacing)
+     (values given-x-spacing given-y-spacing)]
+    [else
+     (define x-spacing 0)
+     (define y-spacing 0)
+     
+     (let loop ([t t])
+       (match t
+         [#f (void)]
+         [(tree-layout pict (list children ...))
+          (set! x-spacing (max (pict-width pict) x-spacing))
+          (set! y-spacing (max (pict-height pict) y-spacing))
+          (for ([edge (in-list children)])
+            (match edge
+              [#f (void)]
+              [(tree-edge child edge-color)
+               (loop child)]))]))
+     
+     (values (or given-x-spacing x-spacing)
+             (or given-y-spacing y-spacing))]))
diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt
new file mode 100644
index 0000000000..fb3e0129aa
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt
@@ -0,0 +1,113 @@
+#lang racket/base
+(require racket/match
+         "../main.rkt"
+         "layout.rkt")
+(provide naive-layered)
+(define (naive-layered t #:x-spacing [given-x-spacing #f] #:y-spacing [given-y-spacing #f])
+  (define-values (x-space y-space) (compute-spacing t given-x-spacing given-y-spacing))
+
+  (define root+tree-pair
+    (let loop ([t t])
+      (match t
+        [#f (cons #f (blank))]
+        [(tree-layout pict children)
+         (cond
+           [(andmap not children)
+            (define this-root (ghost (launder pict)))
+            (cons this-root (cc-superimpose this-root pict))]
+           [else
+            (define children-pairs
+              (for/list ([child (in-list children)])
+                (match child
+                  [#f (cons #f (blank))]
+                  [(tree-edge child color) 
+                   (loop child)])))
+            (define this-root (launder (ghost pict)))
+            (define children-roots (map car children-pairs))
+            (define children-trees (map cdr children-pairs))
+            (let loop ([main (place-parent-over-children
+                              (cc-superimpose this-root pict)
+                              children-roots
+                              (vc-append
+                               y-space
+                               (ghost (launder pict))
+                               (apply ht-append x-space children-trees)))]
+                       [children-roots children-roots]
+                       [tree-edges children])
+              (cond
+                [(null? children-roots) (cons this-root main)]
+                [else 
+                 (define child-root (car children-roots))
+                 (define this-tree-edge (car tree-edges))
+                 (match this-tree-edge
+                   [#f (loop main (cdr children-roots) (cdr tree-edges))]
+                   [(tree-edge child edge-color)
+                    (define w/line
+                      (colorize
+                       (launder
+                        (pin-line (ghost main)
+                                  this-root cc-find
+                                  child-root cc-find))
+                       edge-color))
+                    (loop (cc-superimpose w/line main)
+                          (cdr children-roots)
+                          (cdr tree-edges))])]))])])))
+  
+  (cdr root+tree-pair))
+
+(define (place-parent-over-children parent-root children-roots main)
+  (define x-min (pict-width main))
+  (define x-max 0)
+  (for ([child-root (in-list children-roots)])
+    (when child-root
+      (define-values (c-min _1) (lc-find main child-root))
+      (define-values (c-max _2) (rc-find main child-root))
+      (set! x-min (min c-min x-min))
+      (set! x-max (max c-max x-max))))
+  (pin-over main
+            (- (/ (+ x-min x-max) 2) (/ (pict-width parent-root) 2))
+            0
+            parent-root))
+                             
+
+(module+ test 
+  (require rackunit)
+  (check-pred pict? (naive-layered #f))
+  (check-pred pict? (naive-layered (_tree-layout)))
+  (check-pred pict? (naive-layered (_tree-layout
+                                    (_tree-layout)
+                                    (_tree-layout))))
+  (check-pred pict? (naive-layered (_tree-layout
+                                    (_tree-layout)
+                                    (_tree-layout)
+                                    (_tree-layout
+                                     (_tree-layout)
+                                     (_tree-layout)
+                                     (_tree-layout
+                                      (_tree-layout)
+                                      (_tree-layout)))))))
+
+(module+ main
+  (define (complete n)
+    (cond
+      [(= n 0) #f]
+      [else
+       (define t (complete (- n 1)))
+       (apply _tree-layout (build-list n (λ (_) t)))]))
+  
+  (naive-layered (complete 4))
+  (define right-subtree-with-long-left-chain
+    (_tree-layout
+     (_tree-layout
+      (_tree-layout #f #f)
+      (_tree-layout
+       (_tree-layout #f #f)
+       #f))
+     (_tree-layout
+      (_tree-layout
+       (_tree-layout
+        (_tree-layout #f #f)
+        #f)
+       #f)
+      #f)))
+  (naive-layered right-subtree-with-long-left-chain))
diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt
new file mode 100644
index 0000000000..04f2cac643
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt
@@ -0,0 +1,358 @@
+#lang racket/base
+(require "../main.rkt"
+         racket/match
+         "layout.rkt")
+
+(provide binary-tidier)
+
+#|
+
+Tidier Drawing of Trees
+Edward M. Reingold and John S. Tilford
+IEEE Transactions on Software Engineering, 
+Vol 7, #2, March 1981
+
+|#
+
+(define (binary-tidier t #:x-spacing [given-x-spacing #f] #:y-spacing [given-y-spacing #f])
+  (cond
+    [t
+     (define-values (x-spacing y-spacing) (compute-spacing t given-x-spacing given-y-spacing))
+     (unless given-y-spacing (set! y-spacing (* y-spacing 1.5)))
+     (define minsep 2)
+     (define xc (tidier-x-coordinates t minsep))
+     (define x-max (let loop ([xc xc])
+                     (match xc
+                       [#f 0]
+                       [(x-node x left-xc right-xc)
+                        (max x (loop left-xc) (loop right-xc))])))
+     (define y-max (let loop ([xc xc])
+                     (match xc 
+                       [#f 0]
+                       [(x-node x left-xc right-xc)
+                        (+ 1 (max (loop left-xc) (loop right-xc)))])))
+     
+     (define main (blank (* x-spacing (+ x-max 1))
+                         (* y-spacing y-max)))
+     (let loop ([t t]
+                [xc xc]
+                [y 0])
+       (match* (t xc)
+         [(#f #f) (void)]
+         [((tree-layout pict (list left-t right-t))
+           (x-node x left-xc right-xc))
+          (define node-pict (launder pict))
+          (set! main (pin-over main 
+                               (* x x-spacing)
+                               (* y y-spacing)
+                               node-pict))
+          (define (add-edge to color)
+            (set! main (cc-superimpose
+                        (colorize (launder (pin-line (ghost main)
+                                                     node-pict cc-find
+                                                     to cc-find))
+                                  color)
+                        main)))
+          (match left-t
+            [#f (void)]
+            [(tree-edge left-t left-color)
+             (define left-pict (loop left-t left-xc (+ y 1)))
+             (add-edge left-pict left-color)])
+          (match right-t
+            [#f (void)]
+            [(tree-edge right-t right-color)
+             (define right-pict (loop right-t right-xc (+ y 1)))
+             (add-edge right-pict right-color)])
+          node-pict]))
+     
+     main]
+    [else (blank)]))
+
+;; x-coordinate-tree : (or/c #f x-node?)
+
+;; x : exact-positive-integer?
+;; l : x-coordinate-tree?
+;; r : x-coordinate-tree?
+(struct x-node (x l r) #:transparent)
+
+(define (tidier-x-coordinates t minsep)
+  (define t-link
+    (let loop ([t t])
+      (match t
+        [(tree-layout pict (list left right))
+         (link (and left (loop (tree-edge-child left)))
+               (and right (loop (tree-edge-child right)))
+               #f #f #f #f)])))
+  (setup t-link 0 (extreme #f #f #f) (extreme #f #f #f) minsep)
+  (petrify t-link 0)
+  
+  (define smallest
+    (let loop ([t-link t-link])
+      (match t-link
+        [#f #f]
+        [(link llink rlink xcoord _ _ _)
+         (min2/f xcoord (min2/f (loop llink) (loop rlink)))])))
+  
+  (let loop ([t-link t-link])
+    (match t-link
+      [#f #f]
+      [(link llink rlink xcoord ycoord offset thread)
+       (x-node (- xcoord smallest) (loop llink) (loop rlink))])))
+
+(define (min2/f a b) 
+  (cond
+    [(not a) b]
+    [(not b) a]
+    [else (min a b)]))
+
+(struct extreme (addr off lev) #:mutable)
+(struct link (llink rlink xcoord ycoord offset thread) #:mutable)
+
+(define (setup t level rmost lmost minsep)
+  (cond
+    [(not t) 
+     (set-extreme-lev! lmost -1)
+     (set-extreme-lev! rmost -1)]
+    [else
+     (define lr (extreme #f #f #f))
+     (define ll (extreme #f #f #f))
+     (define rr (extreme #f #f #f))
+     (define rl (extreme #f #f #f))
+     (set-link-ycoord! t level)
+     (define l (link-llink t))
+     (define r (link-rlink t))
+     (setup l (+ level 1) lr ll minsep)
+     (setup r (+ level 1) rr rl minsep)
+     (cond 
+       [(and (not l) (not r))
+        (set-extreme-addr! rmost t)
+        (set-extreme-addr! lmost t)
+        (set-extreme-lev! rmost level)
+        (set-extreme-lev! lmost level)
+        (set-extreme-off! rmost 0)
+        (set-extreme-off! lmost 0)
+        (set-link-offset! t 0)]
+       [else
+        (define cursep minsep)
+        (define rootsep minsep)
+        (define loffsum 0)
+        (define roffsum 0)
+        
+        (let loop ()
+          (when (and l r)
+            (when (< cursep minsep)
+              (set! rootsep (+ rootsep (- minsep cursep)))
+              (set! cursep minsep))
+            (cond
+              [(link-rlink l)
+               (set! loffsum (+ loffsum (link-offset l)))
+               (set! cursep (- cursep (link-offset l)))
+               (set! l (link-rlink l))]
+              [else 
+               (set! loffsum (- loffsum (link-offset l)))
+               (set! cursep (+ cursep (link-offset l)))
+               (set! l (link-llink l))])
+            (cond
+              [(link-llink r)
+               (set! roffsum (- roffsum (link-offset r)))
+               (set! cursep (- cursep (link-offset r)))
+               (set! r (link-llink r))]
+              [else
+               (set! roffsum (+ roffsum (link-offset r)))
+               (set! cursep (+ cursep (link-offset r)))
+               (set! r (link-rlink r))])
+            (loop)))
+        
+        (set-link-offset! t (quotient (+ rootsep 1) 2))
+        (set! loffsum (- loffsum (link-offset t)))
+        (set! roffsum (+ roffsum (link-offset t)))
+        
+        (cond
+          [(or (> (extreme-lev rl) (extreme-lev ll)) (not (link-llink t)))
+           (extreme-copy! lmost rl)
+           (set-extreme-off! lmost (+ (extreme-off lmost) (link-offset t)))]
+          [else
+           (extreme-copy! lmost ll)
+           (set-extreme-off! lmost (- (extreme-off lmost) (link-offset t)))])
+        (cond
+          [(or (> (extreme-lev lr) (extreme-lev rr)) (not (link-rlink t)))
+           (extreme-copy! rmost lr)
+           (set-extreme-off! rmost (- (extreme-off rmost) (link-offset t)))]
+          [else
+           (extreme-copy! rmost rr)
+           (set-extreme-off! rmost (+ (extreme-off rmost) (link-offset t)))])
+        
+        (cond
+          [(and l (not (eq? l (link-llink t))))
+           (set-link-thread! (extreme-addr rr) #t)
+           (set-link-offset! (extreme-addr rr) 
+                             (abs (- (+ (extreme-off rr) (link-offset t)) loffsum)))
+           (cond
+             [(<= (- loffsum (link-offset t)) (extreme-off rr))
+              (set-link-llink! (extreme-addr rr) l)]
+             [else
+              (set-link-rlink! (extreme-addr rr) l)])]
+          [(and r (not (eq? r (link-rlink t))))
+           (set-link-thread! (extreme-addr ll) #t)
+           (set-link-offset! (extreme-addr ll) 
+                             (abs (- (- (extreme-off ll) (link-offset t)) roffsum)))
+           (cond
+             [(>= (+ roffsum (link-offset t)) (extreme-off ll))
+              (set-link-rlink! (extreme-addr ll) r)]
+             [else 
+              (set-link-llink! (extreme-addr ll) r)])])])]))
+
+(define (extreme-copy! dest src)
+  (set-extreme-addr! dest (extreme-addr src))
+  (set-extreme-off! dest (extreme-off src))
+  (set-extreme-lev! dest (extreme-lev src)))
+
+(define (petrify t xpos)
+  (when t
+    (set-link-xcoord! t xpos)
+    (when (link-thread t)
+      (set-link-thread! t #f)
+      (set-link-rlink! t #f)
+      (set-link-llink! t #f))
+    (petrify (link-llink t) (- xpos (link-offset t)))
+    (petrify (link-rlink t) (+ xpos (link-offset t)))))  
+
+(module+ test
+  (require rackunit)
+  (check-equal? (tidier-x-coordinates (_tree-layout) 2)
+                #f)
+  (check-equal? (tidier-x-coordinates (_tree-layout (_tree-layout) (_tree-layout)) 2)
+                (x-node 0 #f #f))
+  (check-equal? (tidier-x-coordinates (_tree-layout
+                                       (_tree-layout
+                                        (_tree-layout)
+                                        (_tree-layout))
+                                       (_tree-layout
+                                        (_tree-layout)
+                                        (_tree-layout)))
+                                      2)
+                (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)))
+  
+  (check-equal? (tidier-x-coordinates (_tree-layout
+                                       (_tree-layout)
+                                       (_tree-layout 
+                                        (_tree-layout
+                                         (_tree-layout)
+                                         (_tree-layout))
+                                        (_tree-layout
+                                         (_tree-layout)
+                                         (_tree-layout))))
+                                      2)
+                (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))))
+  (check-equal? (tidier-x-coordinates (_tree-layout
+                                       (_tree-layout 
+                                        (_tree-layout
+                                         (_tree-layout)
+                                         (_tree-layout))
+                                        (_tree-layout
+                                         (_tree-layout)
+                                         (_tree-layout)))
+                                       (_tree-layout))
+                                      2)
+                (x-node 2 (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)) #f))
+  
+  
+  ;; this is building up an example from 
+  ;; http://rp-www.cs.usyd.edu.au/~comp5048/Lect2-trees.pdf and from
+  ;; http://sydney.edu.au/engineering/it/~shhong/comp5048-lec2.pdf
+  ;; for the tidier algorithm
+  (define triangle
+    (_tree-layout 
+     (_tree-layout
+      (_tree-layout)
+      (_tree-layout))
+     (_tree-layout
+      (_tree-layout)
+      (_tree-layout))))
+  
+  (define left-subtree
+    (_tree-layout
+     (_tree-layout
+      (_tree-layout)
+      triangle)
+     (_tree-layout)))
+
+  (define right-subtree
+    (_tree-layout 
+     triangle
+     (_tree-layout
+      (_tree-layout)
+      (_tree-layout))))
+  
+  (check-equal? (tidier-x-coordinates left-subtree 2)
+                (x-node 1 (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))) #f))
+  
+  (check-equal? (tidier-x-coordinates (_tree-layout left-subtree right-subtree) 2)
+                (x-node 3
+                        (x-node 1
+                                (x-node 0 
+                                        #f
+                                        (x-node 1
+                                                (x-node 0 #f #f)
+                                                (x-node 2 #f #f)))
+                                #f)
+                        (x-node 5
+                                (x-node 4
+                                        (x-node 3 #f #f)
+                                        (x-node 5 #f #f))
+                                (x-node 6 #f #f))))
+  
+  
+  ;; this is a simplification of the tree in figure 2 from the tidier paper
+  (define (build-left t) (_tree-layout (_tree-layout (_tree-layout) (_tree-layout)) t))
+  (define (build-right t) (_tree-layout t (_tree-layout (_tree-layout) (_tree-layout))))
+  (check-equal? (tidier-x-coordinates
+                 (_tree-layout
+                  (_tree-layout)
+                  (build-left
+                   (build-left
+                    (build-right
+                     (build-right
+                      triangle)))))
+                 2)
+                (x-node
+                 0
+                 #f 
+                 (x-node
+                  1 
+                  (x-node 0 #f #f)
+                  (x-node
+                   2 
+                   (x-node 1 #f #f) 
+                   (x-node
+                    3
+                    (x-node
+                     2 
+                     (x-node
+                      1 
+                      (x-node 0 #f #f) 
+                      (x-node 2 #f #f))
+                     (x-node 3 #f #f))
+                    (x-node 4 #f #f))))))
+  
+  
+  (check-pred pict? (binary-tidier #f))
+  (check-pred pict? (binary-tidier (_tree-layout #f #f))))
+
+
+(module+ main
+  (define (full d)
+    (cond
+      [(zero? d) #f]
+      [else (define s (full (- d 1)))
+            (_tree-layout s s)]))
+  (define triangle (full 1))
+  (define (build-left t) (_tree-layout (_tree-layout #f #f) t))
+  (define (build-right t) (_tree-layout t (_tree-layout #f #f)))
+  (define (n-of n f t) (if (zero? n) t (n-of (- n 1) f (f t))))
+  ;; this is the example from the paper
+  (binary-tidier
+   (_tree-layout
+    (n-of 3 build-right (n-of 3 build-left triangle))
+    (n-of 3 build-left (n-of 3 build-right triangle)))) 
+  (binary-tidier (full 3)))
diff --git a/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt b/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt
new file mode 100644
index 0000000000..5ad625e4b9
--- /dev/null
+++ b/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt
@@ -0,0 +1,46 @@
+#lang racket/base
+(require racket/contract
+         racket/class
+         racket/draw
+         "main.rkt"
+         "private/tidier.rkt"
+         "private/layout.rkt"
+         "private/hv.rkt"
+         "private/naive-layered.rkt")
+
+(provide
+ (contract-out
+  [rename _tree-layout
+          tree-layout
+          (->* () 
+               (#:pict pict?) 
+               #:rest (listof (or/c tree-edge? tree-layout? #f))
+               tree-layout?)]
+  [rename _tree-edge
+          tree-edge
+          (->* (tree-layout?) 
+               (#:edge-color (or/c string? 
+                                   (is-a?/c color%)
+                                   (list/c byte? byte? byte?)))
+               tree-edge?)]
+          
+
+  [tree-edge? (-> any/c boolean?)]
+  [rename _tree-layout? tree-layout? (-> any/c boolean?)]
+  [binary-tree-layout? (-> any/c boolean?)]
+  [binary-tidier (->* (binary-tree-layout?)
+                      (#:x-spacing 
+                       (or/c (and/c real? positive?) #f)
+                       #:y-spacing (or/c (and/c real? positive?) #f))
+                      pict?)]
+  [hv-alternating (->* (binary-tree-layout?)
+                       (#:x-spacing 
+                        (or/c (and/c real? positive?) #f)
+                        #:y-spacing (or/c (and/c real? positive?) #f))
+                       pict?)]
+  [naive-layered (->* (tree-layout?)
+                      (#:x-spacing 
+                       (or/c (and/c real? positive?) #f)
+                       #:y-spacing (or/c (and/c real? positive?) #f))
+                      pict?)]))
+