struct-hierarchy.rkt (16271B)
1 #lang racket/base 2 3 (require "class-diagrams.rkt" 4 (only-in pict pin-arrow-line) 5 texpict/mrpict 6 (except-in texpict/utils pin-arrow-line) 7 racket/system 8 racket/class 9 racket/draw) 10 11 (define (mk-ps-diagram) 12 ;; thicken up the lines for postscript 13 (linewidth .8 (mk-diagram))) 14 15 (provide mk-diagram) 16 17 (define (mk-diagram) 18 19 (define part-name (class-name "part" #:spacing-word "subparts")) 20 (define part-blocks-field (field-spec #f "blocks")) 21 (define part-subparts-field (field-spec #f "subparts")) 22 (define part-title-field (field-spec #f "title")) 23 (define part-box (class-box part-name (list part-title-field part-blocks-field part-subparts-field) #f)) 24 25 (define block-name (class-name "block")) 26 (define block-box (class-box block-name #f #f)) 27 28 (define para-name (class-name "paragraph")) 29 (define para-style (field-spec #f "style")) 30 (define para-content (field-spec #f "content")) 31 (define para-box (class-box para-name (list para-style para-content) #f)) 32 33 (define compound-para-name (class-name "compound-\nparagraph")) 34 (define compound-para-style (field-spec #f "style")) 35 (define compound-para-blocks (field-spec #f "blocks")) 36 (define compound-para-box (class-box compound-para-name (list compound-para-style compound-para-blocks) #f)) 37 38 (define table-name (class-name "table")) 39 (define table-style (field-spec #f "style")) 40 (define table-cells (field-spec #f "cells")) ;; blockss 41 (define table-box (class-box table-name (list table-style table-cells) #f)) 42 43 (define itemization-name (class-name "itemization")) 44 (define itemization-style (field-spec #f "style")) 45 (define itemization-items (field-spec #f "items")) ;; blockss 46 (define itemization-box (class-box itemization-name (list itemization-style itemization-items) #f)) 47 48 (define nested-flow-name (class-name "nested-\nflow")) 49 (define nested-flow-style (field-spec #f "style")) 50 (define nested-flow-blocks (field-spec #f "blocks")) 51 (define nested-flow-box (class-box nested-flow-name (list nested-flow-style nested-flow-blocks) #f)) 52 53 (define delayed-block-name (class-name "delayed-block")) 54 (define delayed-block-block (field-spec #f "block")) 55 (define delayed-block-box (class-box delayed-block-name (list delayed-block-block) #f)) 56 57 (define traverse-block-name (class-name "traverse-\nblock")) 58 (define traverse-block-block (field-spec #f "block")) 59 (define traverse-block-box (class-box traverse-block-name (list traverse-block-block) #f)) 60 61 (define content-name (class-name "content")) 62 (define content-box (class-box content-name #f #f)) 63 64 (define string-name (class-name "string")) 65 (define string-box (class-box string-name #f #f)) 66 67 (define symbol-name (class-name "symbol")) 68 (define symbol-box (class-box symbol-name #f #f)) 69 70 (define pict-name (class-name "pict")) 71 (define pict-box (class-box pict-name #f #f)) 72 73 (define convertible-name (class-name "convertible")) 74 (define convertible-box (class-box convertible-name #f #f)) 75 76 (define list-name (class-name "list")) 77 (define list-box (class-box list-name #f #f)) 78 79 (define delayed-element-name (class-name "delayed-\nelement")) 80 (define delayed-element-content (field-spec #f "content")) 81 (define delayed-element-box (class-box delayed-element-name (list delayed-element-content) #f)) 82 83 (define render-element-name (class-name "render-\nelement")) 84 (define render-element-content (field-spec #f "content")) 85 (define render-element-box (class-box render-element-name (list render-element-content) #f)) 86 87 (define traverse-element-name (class-name "traverse-\nelement")) 88 (define traverse-element-content (field-spec #f "content")) 89 (define traverse-element-box (class-box traverse-element-name (list traverse-element-content) #f)) 90 91 (define part-relative-element-name (class-name "part-\nrelative-\nelement")) 92 (define part-relative-element-resolve (field-spec #f "resolve")) 93 (define part-relative-element-box (class-box part-relative-element-name (list part-relative-element-resolve) #f)) 94 95 (define element-name (class-name "element")) 96 (define element-style (field-spec #f "style")) 97 (define element-content (field-spec #f "content")) 98 (define element-box (class-box element-name (list element-style element-content) #f)) 99 100 (define link-element-name (class-name "link-\nelement")) 101 (define link-tag (field-spec #f "tag")) 102 (define link-element-box (class-box link-element-name 103 (list link-tag) 104 #f)) 105 106 (define collect-element-name (class-name "collect-\nelement")) 107 (define collect-element-collect (field-spec #f "collect")) 108 (define collect-element-box (class-box collect-element-name (list collect-element-collect) #f)) 109 110 (define index-element-name (class-name "index-\nelement" #:spacing-word "keywords")) 111 (define index-element-tag (field-spec #f "tag")) 112 (define index-element-keywords (field-spec #f "keywords")) 113 (define index-element-box (class-box index-element-name 114 (list index-element-tag index-element-keywords) 115 #f)) 116 117 (define image-element-name (class-name "image-\nelement" #:spacing-word "suffixes")) 118 (define image-element-path (field-spec #f "path")) 119 (define image-element-suffixes (field-spec #f "suffixes")) 120 (define image-element-scale (field-spec #f "scale")) 121 (define image-element-box (class-box image-element-name 122 (list image-element-path 123 image-element-suffixes 124 image-element-scale) 125 #f)) 126 127 (define multiarg-element-name (class-name "multiarg-\nelement")) 128 (define multiarg-element-tag (field-spec #f "tag")) 129 (define multiarg-element-box (class-box multiarg-element-name (list multiarg-element-tag) #f)) 130 131 (define target-element-name (class-name "target-\nelement")) 132 (define target-tag (field-spec #f "tag")) 133 (define target-element-box (class-box target-element-name 134 (list target-tag) 135 #f)) 136 137 (define redirect-target-element-name (class-name "redirect-target-\nelement")) 138 (define redirect-target-alt-path (field-spec #f "alt-path")) 139 (define redirect-target-alt-anchor (field-spec #f "alt-anchor")) 140 (define redirect-target-element-box (class-box redirect-target-element-name 141 (list redirect-target-alt-path redirect-target-alt-anchor) 142 #f)) 143 144 (define toc-target-element-name (class-name "toc-target-\nelement")) 145 (define toc-target-element-box (class-box toc-target-element-name (list) #f)) 146 147 (define page-target-element-name (class-name "page-target-\nelement")) 148 (define page-target-element-box (class-box page-target-element-name (list) #f)) 149 150 151 (define block-hierarchy 152 (hierarchy 153 (vc-append block-box 154 (blank 0 50) 155 (ht-append 20 156 (ht-append 30 157 compound-para-box 158 para-box) 159 (vc-append (blank 0 30) itemization-box) 160 table-box) 161 (blank 0 25) 162 (ht-append nested-flow-box 163 (blank 120 0) 164 (vc-append (blank 0 30) delayed-block-box) 165 (blank 80 0) 166 traverse-block-box)) 167 (list block-box) 168 (list compound-para-box 169 para-box 170 nested-flow-box 171 itemization-box 172 table-box 173 delayed-block-box 174 traverse-block-box))) 175 176 (define target-element-hierarchy 177 (hierarchy 178 (vc-append target-element-box 179 (blank 0 50) 180 (ht-append 20 181 toc-target-element-box 182 page-target-element-box 183 redirect-target-element-box)) 184 (list target-element-box) 185 (list toc-target-element-box 186 page-target-element-box 187 redirect-target-element-box))) 188 189 (define element-hierarchy 190 (hierarchy 191 (vc-append element-box 192 (blank 0 50) 193 (inset (ht-append 20 194 collect-element-box 195 multiarg-element-box 196 (refocus target-element-hierarchy target-element-box) 197 link-element-box 198 image-element-box 199 index-element-box) 200 0 0 -400 0)) 201 (list element-box) 202 (list collect-element-box 203 index-element-box 204 image-element-box 205 target-element-box 206 multiarg-element-box 207 link-element-box 208 ))) 209 210 (define render-element-parent-link (blank)) 211 (define delayed-element-parent-link (blank)) 212 (define part-relative-element-parent-link (blank)) 213 (define traverse-element-parent-link (blank)) 214 (define element-parent-link (blank)) 215 216 (define (drop-and-link box parent-link i) 217 (vc-append 218 (blank 0 (+ 40 (* i 20))) 219 (refocus (ct-superimpose box parent-link) 220 parent-link))) 221 222 (define content-hierarchy 223 (hierarchy 224 (vc-append content-box 225 (blank 0 50) 226 (ht-append 15 227 (drop-and-link (refocus element-hierarchy element-box) 228 element-parent-link 229 4) 230 convertible-box 231 (drop-and-link render-element-box 232 render-element-parent-link 233 4) 234 pict-box 235 (drop-and-link delayed-element-box 236 delayed-element-parent-link 237 3) 238 symbol-box 239 (drop-and-link part-relative-element-box 240 part-relative-element-parent-link 241 1) 242 string-box 243 (drop-and-link traverse-element-box 244 traverse-element-parent-link 245 0) 246 list-box)) 247 (list content-box) 248 (list element-box 249 string-box 250 symbol-box 251 convertible-box 252 pict-box 253 traverse-element-parent-link 254 part-relative-element-parent-link 255 delayed-element-parent-link 256 render-element-parent-link 257 list-box))) 258 259 (define raw 260 (vc-append part-box 261 (blank 0 20) 262 (vc-append block-hierarchy 263 (blank 0 20) 264 content-hierarchy))) 265 266 (define w/connections 267 (double 268 right-right-reference 269 (double 270 left-left-reference 271 (triple 272 right-right-reference 273 (triple 274 right-right-reference 275 (double 276 left-left-reference 277 (double 278 left-left-reference 279 (double 280 right-right-reference 281 (double 282 left-left-reference 283 (double 284 left-left-reference 285 (left-left-reference 286 raw 287 element-box element-content content-box content-name 1 #:dot-delta -1) 288 part-box part-title-field content-box content-name 21) 289 part-box part-blocks-field block-box block-name) 290 part-box part-subparts-field part-box part-name 2) 291 para-box para-content content-box content-name 2) 292 compound-para-box compound-para-blocks block-box block-name 3) 293 table-box table-cells block-box block-name 2) 294 itemization-box itemization-items block-box block-name 10) 295 nested-flow-box nested-flow-blocks block-box block-name 1) 296 list-box list-box content-box content-name)) 297 298 (define w/delayed-connections 299 (dotted-right-right-reference 300 (dotted-right-right-reference 301 (dotted-right-right-reference 302 (dotted-right-right-reference 303 (dotted-right-right-reference 304 (dotted-right-right-reference 305 w/connections 306 render-element-box render-element-content content-box content-name 30) 307 traverse-block-box traverse-block-block block-box block-name 1) 308 delayed-block-box delayed-block-block block-box block-name 17) 309 traverse-element-box traverse-element-content content-box content-name 3) 310 delayed-element-box delayed-element-content content-box content-name 22) 311 part-relative-element-box part-relative-element-resolve content-box content-name 12)) 312 313 ;; one extra pixel on the right so we get the 314 ;; line drawn to the outermost turning point 315 (inset (panorama w/delayed-connections) 0 0 1 0)) 316 317 (define (double f p0 a b c d [count 1]) 318 (let ([arrows1 (launder (f (ghost p0) a b c d count #:dot-delta 1))] 319 [arrows2 (launder (f (ghost p0) a b c d count #:dot-delta -1))]) 320 (cc-superimpose p0 321 arrows1 322 arrows2))) 323 324 (define (triple f p0 a b c d [count 1]) 325 (let ([arrows (launder (f (ghost p0) a b c d count))] 326 [up-arrows (launder (f (ghost p0) a b c d count #:dot-delta 2))] 327 [down-arrows (launder (f (ghost p0) a b c d count #:dot-delta -2))]) 328 (cc-superimpose p0 329 arrows 330 up-arrows 331 down-arrows))) 332 333 (define (connect-circly-dots show-arrowhead? main dot1 . dots) 334 (let loop ([prev-dot dot1] 335 [dots dots] 336 [pict main]) 337 (cond 338 [(null? dots) pict] 339 [else 340 (loop (car dots) 341 (cdr dots) 342 (connect-two-circly-dots pict prev-dot (car dots) (null? (cdr dots))))]))) 343 344 ;; this is a hack -- it will only work with right-right-reference 345 (define (connect-two-circly-dots pict dot1 dot2 arrowhead?) 346 (let ([base 347 (let*-values ([(sx sy) (cc-find pict dot1)] 348 [(raw-ex ey) (cc-find pict dot2)] 349 [(ex) (if arrowhead? 350 (+ raw-ex 2) 351 raw-ex)]) 352 (cc-superimpose 353 (dc 354 (λ (dc dx dy) 355 (let ([pen (send dc get-pen)]) 356 (send dc set-pen 357 type-link-color ;(send pen get-color) 358 (if (is-a? dc post-script-dc%) 359 4 360 2) 361 'dot) 362 (send dc draw-line 363 (+ dx sx) (+ dy sy) 364 (+ dx ex) (+ dy ey)) 365 (send dc set-pen pen))) 366 (pict-width pict) 367 (pict-height pict)) 368 pict))]) 369 (if arrowhead? 370 (pin-arrow-line field-arrowhead-size 371 base 372 dot1 (λ (ignored1 ignored2) 373 (let-values ([(x y) (cc-find pict dot2)]) 374 (values (+ x 2) y))) 375 dot2 cc-find 376 #:color type-link-color) 377 base))) 378 379 (define (dotted-right-right-reference p0 a b c d [count 1]) 380 (right-right-reference p0 a b c d count #:connect-dots connect-circly-dots)) 381 382 (module+ slideshow 383 (require slideshow) 384 (define p (inset (mk-diagram) 0 0 0 1)) 385 (define c (blank client-w client-h)) 386 (slide (lt-superimpose (t "top") (clip (refocus (ct-superimpose p c) c)))) 387 (slide (lt-superimpose (t "bottom") (clip (refocus (cb-superimpose p c) c)))) 388 (slide (lt-superimpose (t "all") 389 (ct-superimpose 390 c 391 (scale p 392 (min (/ client-w (pict-width p)) 393 (/ client-h (pict-height p))))))))