1#lang racket/base
2(require "../main.rkt"
3         racket/match
4         "layout.rkt")
5
6(provide binary-tidier)
7
8#|
9
10Tidier Drawing of Trees
11Edward M. Reingold and John S. Tilford
12IEEE Transactions on Software Engineering,
13Vol 7, #2, March 1981
14
15|#
16
17(define (binary-tidier t #:x-spacing [given-x-spacing #f] #:y-spacing [given-y-spacing #f])
18  (cond
19    [t
20     (define-values (x-spacing y-spacing) (compute-spacing t given-x-spacing given-y-spacing))
21     (unless given-y-spacing (set! y-spacing (* y-spacing 1.5)))
22     (define minsep 2)
23     (define xc (tidier-x-coordinates t minsep))
24     (define x-max (let loop ([xc xc])
25                     (match xc
26                       [#f 0]
27                       [(x-node x left-xc right-xc)
28                        (max x (loop left-xc) (loop right-xc))])))
29     (define y-max (let loop ([xc xc])
30                     (match xc
31                       [#f 0]
32                       [(x-node x left-xc right-xc)
33                        (+ 1 (max (loop left-xc) (loop right-xc)))])))
34
35     (define main (blank (* x-spacing (+ x-max 1))
36                         (* y-spacing y-max)))
37     (let loop ([t t]
38                [xc xc]
39                [y 0])
40       (match* (t xc)
41         [(#f #f) (void)]
42         [((tree-layout pict (list left-t right-t))
43           (x-node x left-xc right-xc))
44          (define node-pict (launder pict))
45          (set! main (pin-over main
46                               (* x x-spacing)
47                               (* y y-spacing)
48                               node-pict))
49          (define (add-edge to color width style)
50            (define colored
51              (colorize (launder (pin-line (ghost main)
52                                           node-pict cc-find
53                                           to cc-find))
54                        color))
55            (define with-linewidth
56              (if (eq? width 'unspecified)
57                  colored
58                  (linewidth width colored)))
59            (define with-linestyle
60              (if (eq? style 'unspecified)
61                  with-linewidth
62                  (linestyle style with-linewidth)))
63            (set! main (cc-superimpose with-linestyle main)))
64          (match left-t
65            [#f (void)]
66            [(tree-edge left-t left-color left-width left-style)
67             (define left-pict (loop left-t left-xc (+ y 1)))
68             (add-edge left-pict left-color left-width left-style)])
69          (match right-t
70            [#f (void)]
71            [(tree-edge right-t right-color right-width right-style)
72             (define right-pict (loop right-t right-xc (+ y 1)))
73             (add-edge right-pict right-color right-width right-style)])
74          node-pict]))
75
76     main]
77    [else (blank)]))
78
79;; x-coordinate-tree : (or/c #f x-node?)
80
81;; x : exact-positive-integer?
82;; l : x-coordinate-tree?
83;; r : x-coordinate-tree?
84(struct x-node (x l r) #:transparent)
85
86(define (tidier-x-coordinates t minsep)
87  (cond
88    [(not t) #f]
89    [else
90     (define t-link
91       (let loop ([t t])
92         (match t
93           [(tree-layout pict (list left right))
94            (link (and left (loop (tree-edge-child left)))
95                  (and right (loop (tree-edge-child right)))
96                  #f #f #f #f)])))
97     (setup t-link 0 (extreme #f #f #f) (extreme #f #f #f) minsep)
98     (petrify t-link 0)
99
100     (define smallest
101       (let loop ([t-link t-link])
102         (match t-link
103           [#f #f]
104           [(link llink rlink xcoord _ _ _)
105            (min2/f xcoord (min2/f (loop llink) (loop rlink)))])))
106
107     (let loop ([t-link t-link])
108       (match t-link
109         [#f #f]
110         [(link llink rlink xcoord ycoord offset thread)
111          (x-node (- xcoord smallest) (loop llink) (loop rlink))]))]))
112
113(define (min2/f a b)
114  (cond
115    [(not a) b]
116    [(not b) a]
117    [else (min a b)]))
118
119(struct extreme (addr off lev) #:mutable)
120(struct link (llink rlink xcoord ycoord offset thread) #:mutable)
121
122(define (setup t level rmost lmost minsep)
123  (cond
124    [(not t)
125     (set-extreme-lev! lmost -1)
126     (set-extreme-lev! rmost -1)]
127    [else
128     (define lr (extreme #f #f #f))
129     (define ll (extreme #f #f #f))
130     (define rr (extreme #f #f #f))
131     (define rl (extreme #f #f #f))
132     (set-link-ycoord! t level)
133     (define l (link-llink t))
134     (define r (link-rlink t))
135     (setup l (+ level 1) lr ll minsep)
136     (setup r (+ level 1) rr rl minsep)
137     (cond
138       [(and (not l) (not r))
139        (set-extreme-addr! rmost t)
140        (set-extreme-addr! lmost t)
141        (set-extreme-lev! rmost level)
142        (set-extreme-lev! lmost level)
143        (set-extreme-off! rmost 0)
144        (set-extreme-off! lmost 0)
145        (set-link-offset! t 0)]
146       [else
147        (define cursep minsep)
148        (define rootsep minsep)
149        (define loffsum 0)
150        (define roffsum 0)
151
152        (let loop ()
153          (when (and l r)
154            (when (< cursep minsep)
155              (set! rootsep (+ rootsep (- minsep cursep)))
156              (set! cursep minsep))
157            (cond
158              [(link-rlink l)
159               (set! loffsum (+ loffsum (link-offset l)))
160               (set! cursep (- cursep (link-offset l)))
161               (set! l (link-rlink l))]
162              [else
163               (set! loffsum (- loffsum (link-offset l)))
164               (set! cursep (+ cursep (link-offset l)))
165               (set! l (link-llink l))])
166            (cond
167              [(link-llink r)
168               (set! roffsum (- roffsum (link-offset r)))
169               (set! cursep (- cursep (link-offset r)))
170               (set! r (link-llink r))]
171              [else
172               (set! roffsum (+ roffsum (link-offset r)))
173               (set! cursep (+ cursep (link-offset r)))
174               (set! r (link-rlink r))])
175            (loop)))
176
177        (set-link-offset! t (quotient (+ rootsep 1) 2))
178        (set! loffsum (- loffsum (link-offset t)))
179        (set! roffsum (+ roffsum (link-offset t)))
180
181        (cond
182          [(or (> (extreme-lev rl) (extreme-lev ll)) (not (link-llink t)))
183           (extreme-copy! lmost rl)
184           (set-extreme-off! lmost (+ (extreme-off lmost) (link-offset t)))]
185          [else
186           (extreme-copy! lmost ll)
187           (set-extreme-off! lmost (- (extreme-off lmost) (link-offset t)))])
188        (cond
189          [(or (> (extreme-lev lr) (extreme-lev rr)) (not (link-rlink t)))
190           (extreme-copy! rmost lr)
191           (set-extreme-off! rmost (- (extreme-off rmost) (link-offset t)))]
192          [else
193           (extreme-copy! rmost rr)
194           (set-extreme-off! rmost (+ (extreme-off rmost) (link-offset t)))])
195
196        (cond
197          [(and l (not (eq? l (link-llink t))))
198           (set-link-thread! (extreme-addr rr) #t)
199           (set-link-offset! (extreme-addr rr)
200                             (abs (- (+ (extreme-off rr) (link-offset t)) loffsum)))
201           (cond
202             [(<= (- loffsum (link-offset t)) (extreme-off rr))
203              (set-link-llink! (extreme-addr rr) l)]
204             [else
205              (set-link-rlink! (extreme-addr rr) l)])]
206          [(and r (not (eq? r (link-rlink t))))
207           (set-link-thread! (extreme-addr ll) #t)
208           (set-link-offset! (extreme-addr ll)
209                             (abs (- (- (extreme-off ll) (link-offset t)) roffsum)))
210           (cond
211             [(>= (+ roffsum (link-offset t)) (extreme-off ll))
212              (set-link-rlink! (extreme-addr ll) r)]
213             [else
214              (set-link-llink! (extreme-addr ll) r)])])])]))
215
216(define (extreme-copy! dest src)
217  (set-extreme-addr! dest (extreme-addr src))
218  (set-extreme-off! dest (extreme-off src))
219  (set-extreme-lev! dest (extreme-lev src)))
220
221(define (petrify t xpos)
222  (when t
223    (set-link-xcoord! t xpos)
224    (when (link-thread t)
225      (set-link-thread! t #f)
226      (set-link-rlink! t #f)
227      (set-link-llink! t #f))
228    (petrify (link-llink t) (- xpos (link-offset t)))
229    (petrify (link-rlink t) (+ xpos (link-offset t)))))
230
231(module+ test
232  (require rackunit)
233  (check-equal? (tidier-x-coordinates #f 2)
234                #f)
235  (check-equal? (tidier-x-coordinates (_tree-layout #f #f) 2)
236                (x-node 0 #f #f))
237  (check-equal? (tidier-x-coordinates (_tree-layout
238                                       (_tree-layout
239                                        #f #f)
240                                       (_tree-layout
241                                        #f #f))
242                                      2)
243                (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)))
244
245  (check-equal? (tidier-x-coordinates (_tree-layout
246                                       #f
247                                       (_tree-layout
248                                        (_tree-layout #f #f)
249                                        (_tree-layout #f #f)))
250                                      2)
251                (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))))
252  (check-equal? (tidier-x-coordinates (_tree-layout
253                                       (_tree-layout
254                                        (_tree-layout #f #f)
255                                        (_tree-layout #f #f))
256                                       #f)
257                                      2)
258                (x-node 2 (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f)) #f))
259
260
261  ;; this is building up an example from
262  ;; http://rp-www.cs.usyd.edu.au/~comp5048/Lect2-trees.pdf and from
263  ;; http://sydney.edu.au/engineering/it/~shhong/comp5048-lec2.pdf
264  ;; for the tidier algorithm
265  (define triangle
266    (_tree-layout
267     (_tree-layout #f #f)
268     (_tree-layout #f #f)))
269
270  (define left-subtree
271    (_tree-layout (_tree-layout #f triangle)
272                  #f))
273
274  (define right-subtree
275    (_tree-layout
276     triangle
277     (_tree-layout #f #f)))
278
279  (check-equal? (tidier-x-coordinates left-subtree 2)
280                (x-node 1 (x-node 0 #f (x-node 1 (x-node 0 #f #f) (x-node 2 #f #f))) #f))
281
282  (check-equal? (tidier-x-coordinates (_tree-layout left-subtree right-subtree) 2)
283                (x-node 3
284                        (x-node 1
285                                (x-node 0
286                                        #f
287                                        (x-node 1
288                                                (x-node 0 #f #f)
289                                                (x-node 2 #f #f)))
290                                #f)
291                        (x-node 5
292                                (x-node 4
293                                        (x-node 3 #f #f)
294                                        (x-node 5 #f #f))
295                                (x-node 6 #f #f))))
296
297
298  ;; this is a simplification of the tree in figure 2 from the tidier paper
299  (define (build-left t) (_tree-layout (_tree-layout #f #f) t))
300  (define (build-right t) (_tree-layout t (_tree-layout #f #f)))
301  (check-equal? (tidier-x-coordinates
302                 (_tree-layout
303                  #f
304                  (build-left
305                   (build-left
306                    (build-right
307                     (build-right
308                      triangle)))))
309                 2)
310                (x-node
311                 0
312                 #f
313                 (x-node
314                  1
315                  (x-node 0 #f #f)
316                  (x-node
317                   2
318                   (x-node 1 #f #f)
319                   (x-node
320                    3
321                    (x-node
322                     2
323                     (x-node
324                      1
325                      (x-node 0 #f #f)
326                      (x-node 2 #f #f))
327                     (x-node 3 #f #f))
328                    (x-node 4 #f #f))))))
329
330
331  (check-pred pict? (binary-tidier #f))
332  (check-pred pict? (binary-tidier (_tree-layout #f #f))))
333
334
335(module+ main
336  (define (full d)
337    (cond
338      [(zero? d) #f]
339      [else (define s (full (- d 1)))
340            (_tree-layout s s)]))
341  (define triangle (full 1))
342  (define (build-left t) (_tree-layout (_tree-layout #f #f) t))
343  (define (build-right t) (_tree-layout t (_tree-layout #f #f)))
344  (define (n-of n f t) (if (zero? n) t (n-of (- n 1) f (f t))))
345  ;; this is the example from the paper
346  (binary-tidier
347   (_tree-layout
348    (n-of 3 build-right (n-of 3 build-left triangle))
349    (n-of 3 build-left (n-of 3 build-right triangle))))
350  (binary-tidier (full 3)))
351