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