365 lines
15 KiB
Racket
365 lines
15 KiB
Racket
#lang racket/base
|
|
|
|
(require "class-diagrams.rkt"
|
|
texpict/mrpict
|
|
texpict/utils
|
|
racket/system
|
|
racket/class
|
|
racket/draw)
|
|
|
|
(define (mk-ps-diagram)
|
|
;; thicken up the lines for postscript
|
|
(linewidth .8 (mk-diagram)))
|
|
|
|
(provide mk-diagram)
|
|
|
|
(define (mk-diagram)
|
|
|
|
(define part-name (class-name "part"))
|
|
(define part-blocks-field (field-spec #f "blocks"))
|
|
(define part-subparts-field (field-spec #f "subparts"))
|
|
(define part-title-field (field-spec #f "title"))
|
|
(define part-box (class-box part-name (list part-title-field part-blocks-field part-subparts-field) #f))
|
|
|
|
(define block-name (class-name "block"))
|
|
(define block-box (class-box block-name #f #f))
|
|
|
|
(define para-name (class-name "paragraph"))
|
|
(define para-style (field-spec #f "style"))
|
|
(define para-content (field-spec #f "content"))
|
|
(define para-box (class-box para-name (list para-style para-content) #f))
|
|
|
|
(define compound-para-name (class-name "compound-\nparagraph"))
|
|
(define compound-para-style (field-spec #f "style"))
|
|
(define compound-para-blocks (field-spec #f "blocks"))
|
|
(define compound-para-box (class-box compound-para-name (list compound-para-style compound-para-blocks) #f))
|
|
|
|
(define table-name (class-name "table"))
|
|
(define table-style (field-spec #f "style"))
|
|
(define table-cells (field-spec #f "cells")) ;; blockss
|
|
(define table-box (class-box table-name (list table-style table-cells) #f))
|
|
|
|
(define itemization-name (class-name "itemization"))
|
|
(define itemization-style (field-spec #f "style"))
|
|
(define itemization-items (field-spec #f "items")) ;; blockss
|
|
(define itemization-box (class-box itemization-name (list itemization-style itemization-items) #f))
|
|
|
|
(define nested-flow-name (class-name "nested-\nflow"))
|
|
(define nested-flow-style (field-spec #f "style"))
|
|
(define nested-flow-blocks (field-spec #f "blocks"))
|
|
(define nested-flow-box (class-box nested-flow-name (list nested-flow-style nested-flow-blocks) #f))
|
|
|
|
(define delayed-block-name (class-name "delayed-block"))
|
|
(define delayed-block-block (field-spec #f "block"))
|
|
(define delayed-block-box (class-box delayed-block-name (list delayed-block-block) #f))
|
|
|
|
(define traverse-block-name (class-name "traverse-\nblock"))
|
|
(define traverse-block-block (field-spec #f "block"))
|
|
(define traverse-block-box (class-box traverse-block-name (list traverse-block-block) #f))
|
|
|
|
(define content-name (class-name "content"))
|
|
(define content-box (class-box content-name #f #f))
|
|
|
|
(define element-name (class-name "element"))
|
|
(define element-style (field-spec #f "style"))
|
|
(define element-box (class-box element-name (list element-style) #f))
|
|
|
|
(define string-name (class-name "string"))
|
|
(define string-box (class-box string-name #f #f))
|
|
|
|
(define symbol-name (class-name "symbol"))
|
|
(define symbol-box (class-box symbol-name #f #f))
|
|
|
|
(define pict-name (class-name "pict"))
|
|
(define pict-box (class-box pict-name #f #f))
|
|
|
|
(define list-name (class-name "list"))
|
|
(define list-box (class-box list-name #f #f))
|
|
|
|
(define target-element-name (class-name "target-\nelement"))
|
|
(define target-tag (field-spec #f "tag"))
|
|
(define target-content (field-spec #f "content"))
|
|
(define target-element-box (class-box target-element-name
|
|
(list target-tag target-content)
|
|
#f))
|
|
|
|
(define link-element-name (class-name "link-\nelement"))
|
|
(define link-tag (field-spec #f "tag"))
|
|
(define link-content (field-spec #f "content"))
|
|
(define link-element-box (class-box link-element-name
|
|
(list link-tag link-content)
|
|
#f))
|
|
|
|
(define delayed-element-name (class-name "delayed-\nelement"))
|
|
(define delayed-content (field-spec #f "content"))
|
|
(define delayed-element-box (class-box delayed-element-name (list delayed-content) #f))
|
|
|
|
(define render-element-name (class-name "render-\nelement"))
|
|
(define render-content (field-spec #f "content"))
|
|
(define render-element-box (class-box render-element-name (list render-content) #f))
|
|
|
|
(define traverse-element-name (class-name "traverse-\nelement"))
|
|
(define traverse-content (field-spec #f "content"))
|
|
(define traverse-element-box (class-box traverse-element-name (list traverse-content) #f))
|
|
|
|
(define collect-element-name (class-name "collect-\nelement"))
|
|
(define collect-content (field-spec #f "content"))
|
|
(define collect-element-box (class-box collect-element-name (list collect-content) #f))
|
|
|
|
(define index-element-name (class-name "index-\nelement"))
|
|
(define index-element-tag (field-spec #f "tag"))
|
|
(define index-element-keywords (field-spec #f "keywords"))
|
|
(define index-element-content (field-spec #f "content"))
|
|
(define index-element-box (class-box index-element-name
|
|
(list index-element-tag index-element-keywords index-element-content)
|
|
#f))
|
|
|
|
(define image-element-name (class-name "image-\nelement"))
|
|
(define image-element-box (class-box image-element-name (list) #f))
|
|
|
|
(define multi-arg-element-name (class-name "multi-arg-\nelement"))
|
|
(define multi-arg-element-tag (field-spec #f "tag"))
|
|
(define multi-arg-element-content (field-spec #f "content"))
|
|
(define multi-arg-element-box (class-box multi-arg-element-name (list multi-arg-element-tag multi-arg-element-content) #f))
|
|
|
|
(define part-relative-element-name (class-name "part-relative-\nelement"))
|
|
(define part-relative-element-resolve (field-spec #f "resolve"))
|
|
(define part-relative-element-box (class-box part-relative-element-name (list part-relative-element-resolve) #f))
|
|
|
|
(define block-hierarchy
|
|
(hierarchy
|
|
(vc-append block-box
|
|
(blank 0 50)
|
|
(ht-append 20
|
|
(ht-append 30
|
|
compound-para-box
|
|
para-box)
|
|
(vc-append (blank 0 30) itemization-box)
|
|
table-box)
|
|
(blank 0 25)
|
|
(ht-append nested-flow-box
|
|
(blank 120 0)
|
|
(vc-append (blank 0 30) delayed-block-box)
|
|
(blank 80 0)
|
|
traverse-block-box))
|
|
(list block-box)
|
|
(list compound-para-box
|
|
para-box
|
|
nested-flow-box
|
|
itemization-box
|
|
table-box
|
|
delayed-block-box
|
|
traverse-block-box)))
|
|
|
|
(define target-element-parent-link (blank))
|
|
(define render-element-parent-link (blank))
|
|
(define delayed-element-parent-link (blank))
|
|
(define part-relative-element-parent-link (blank))
|
|
(define traverse-element-parent-link (blank))
|
|
|
|
(define element-hierarchy
|
|
(hierarchy
|
|
(vc-append element-box
|
|
(blank 0 50)
|
|
(ht-append 20
|
|
(hc-append collect-element-box (blank 30 0))
|
|
(vc-append (blank 0 10) multi-arg-element-box)
|
|
(vc-append (blank 0 20) index-element-box)
|
|
(vc-append (blank 0 10) image-element-box)
|
|
link-element-box)
|
|
(blank 0 20)
|
|
(ht-append 10
|
|
(rt-superimpose target-element-box
|
|
(ht-append target-element-parent-link
|
|
(blank 8 0)))
|
|
(lt-superimpose render-element-box
|
|
(ht-append (blank 8 0)
|
|
render-element-parent-link))
|
|
(blank 250 0))
|
|
(ht-append 10
|
|
(blank 130 0)
|
|
(vc-append (blank 0 60)
|
|
(rt-superimpose delayed-element-box
|
|
(ht-append delayed-element-parent-link
|
|
(blank 15 0))))
|
|
(vc-append (blank 0 30)
|
|
(ct-superimpose part-relative-element-box
|
|
(ht-append (blank 20 0)
|
|
part-relative-element-parent-link)))
|
|
(ct-superimpose traverse-element-box
|
|
(ht-append traverse-element-parent-link
|
|
(blank 30 0)))))
|
|
(list element-box)
|
|
(list collect-element-box
|
|
index-element-box
|
|
image-element-box
|
|
target-element-parent-link
|
|
multi-arg-element-box
|
|
link-element-box
|
|
delayed-element-parent-link
|
|
traverse-element-parent-link
|
|
part-relative-element-parent-link
|
|
render-element-parent-link
|
|
link-element-box)))
|
|
|
|
(define content-hierarchy
|
|
(hierarchy
|
|
(vc-append content-box
|
|
(blank 0 50)
|
|
(ht-append (ht-append 20
|
|
string-box
|
|
symbol-box)
|
|
(inset element-hierarchy -130 0)
|
|
(ht-append 20
|
|
pict-box
|
|
list-box)))
|
|
(list content-box)
|
|
(list string-box
|
|
symbol-box
|
|
pict-box
|
|
element-box
|
|
list-box)))
|
|
|
|
(define raw
|
|
(vc-append part-box
|
|
(blank 0 20)
|
|
(vc-append block-hierarchy
|
|
(blank 0 20)
|
|
content-hierarchy)))
|
|
|
|
(define w/connections
|
|
(double
|
|
right-right-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
right-right-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
left-left-reference
|
|
(triple
|
|
right-right-reference
|
|
(triple
|
|
right-right-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
right-right-reference
|
|
(double
|
|
left-left-reference
|
|
(double
|
|
left-left-reference
|
|
raw
|
|
part-box part-title-field content-box content-name 21)
|
|
part-box part-blocks-field block-box block-name)
|
|
part-box part-subparts-field part-box part-name 2)
|
|
para-box para-content content-box content-name 2)
|
|
compound-para-box compound-para-blocks block-box block-name 3)
|
|
table-box table-cells block-box block-name 2)
|
|
itemization-box itemization-items block-box block-name 10)
|
|
nested-flow-box nested-flow-blocks block-box block-name 1)
|
|
target-element-box target-content content-box content-name 8)
|
|
link-element-box link-content content-box content-name)
|
|
multi-arg-element-box multi-arg-element-content content-box content-name 14)
|
|
index-element-box index-element-content content-box content-name 26)
|
|
collect-element-box collect-content content-box content-name 1)
|
|
list-box list-box content-box content-name))
|
|
|
|
(define w/delayed-connections
|
|
(dotted-right-right-reference
|
|
(dotted-right-right-reference
|
|
(dotted-right-right-reference
|
|
(dotted-right-right-reference
|
|
(dotted-right-right-reference
|
|
(dotted-right-right-reference
|
|
w/connections
|
|
render-element-box render-content content-box content-name 31)
|
|
traverse-block-box traverse-block-block block-box block-name 1)
|
|
delayed-block-box delayed-block-block block-box block-name 17)
|
|
traverse-element-box traverse-content content-box content-name 5)
|
|
delayed-element-box delayed-content content-box content-name 27)
|
|
part-relative-element-box part-relative-element-resolve content-box content-name 14))
|
|
|
|
;; one extra pixel on the right so we get the
|
|
;; line drawn to the outermost turning point
|
|
(inset (panorama w/delayed-connections) 0 0 1 0))
|
|
|
|
(define (double f p0 a b c d [count 1])
|
|
(let ([arrows1 (launder (f (ghost p0) a b c d count #:dot-delta 1))]
|
|
[arrows2 (launder (f (ghost p0) a b c d count #:dot-delta -1))])
|
|
(cc-superimpose p0
|
|
arrows1
|
|
arrows2)))
|
|
|
|
(define (triple f p0 a b c d [count 1])
|
|
(let ([arrows (launder (f (ghost p0) a b c d count))]
|
|
[up-arrows (launder (f (ghost p0) a b c d count #:dot-delta 2))]
|
|
[down-arrows (launder (f (ghost p0) a b c d count #:dot-delta -2))])
|
|
(cc-superimpose p0
|
|
arrows
|
|
up-arrows
|
|
down-arrows)))
|
|
|
|
(define (connect-circly-dots show-arrowhead? main dot1 . dots)
|
|
(let loop ([prev-dot dot1]
|
|
[dots dots]
|
|
[pict main])
|
|
(cond
|
|
[(null? dots) pict]
|
|
[else
|
|
(loop (car dots)
|
|
(cdr dots)
|
|
(connect-two-circly-dots pict prev-dot (car dots) (null? (cdr dots))))])))
|
|
|
|
;; this is a hack -- it will only work with right-right-reference
|
|
(define (connect-two-circly-dots pict dot1 dot2 arrowhead?)
|
|
(let ([base
|
|
(let*-values ([(sx sy) (cc-find pict dot1)]
|
|
[(raw-ex ey) (cc-find pict dot2)]
|
|
[(ex) (if arrowhead?
|
|
(+ raw-ex 2)
|
|
raw-ex)])
|
|
(cc-superimpose
|
|
(dc
|
|
(λ (dc dx dy)
|
|
(let ([pen (send dc get-pen)])
|
|
(send dc set-pen
|
|
(send pen get-color)
|
|
(if (is-a? dc post-script-dc%)
|
|
4
|
|
2)
|
|
'dot)
|
|
(send dc draw-line
|
|
(+ dx sx) (+ dy sy)
|
|
(+ dx ex) (+ dy ey))
|
|
(send dc set-pen pen)))
|
|
(pict-width pict)
|
|
(pict-height pict))
|
|
pict))])
|
|
(if arrowhead?
|
|
(pin-arrow-line field-arrowhead-size
|
|
base
|
|
dot1 (λ (ignored1 ignored2)
|
|
(let-values ([(x y) (cc-find pict dot2)])
|
|
(values (+ x 2) y)))
|
|
dot2 cc-find
|
|
#f #f #f #f)
|
|
base)))
|
|
|
|
(define (dotted-right-right-reference p0 a b c d [count 1])
|
|
(right-right-reference p0 a b c d count #:connect-dots connect-circly-dots))
|
|
|
|
(module+ slideshow
|
|
(require slideshow)
|
|
(define p (mk-diagram))
|
|
(slide (scale p
|
|
(min (/ client-w (pict-width p))
|
|
(/ client-h (pict-height p))))))
|