Start on a tree layout library
This commit is contained in:
Robby Findler
parent
6856e5253f
commit
c919579e06
|
|
@ -891,6 +891,10 @@ pict with the same shape and location.}
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@include-section["tree-layout.scrbl"]
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section{Miscellaneous}
|
||||
|
||||
@defproc[(hyperlinkize [pict pict?])
|
||||
|
|
|
|||
177
pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl
Normal file
177
pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl
Normal file
|
|
@ -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))]
|
||||
}
|
||||
|
|
@ -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\"")
|
||||
|
||||
|
|
|
|||
122
pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt
Normal file
122
pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt
Normal file
|
|
@ -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)))
|
||||
|
||||
80
pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt
Normal file
80
pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt
Normal file
|
|
@ -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))]))
|
||||
113
pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt
Normal file
113
pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt
Normal file
|
|
@ -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))
|
||||
358
pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt
Normal file
358
pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt
Normal file
|
|
@ -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)))
|
||||
46
pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt
Normal file
46
pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt
Normal file
|
|
@ -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?)]))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user