Permalink
Fetching contributors…
Cannot retrieve contributors at this time
394 lines (343 sloc) 15.9 KB
#lang racket/base
(require "class-diagrams.rkt"
(only-in pict pin-arrow-line)
texpict/mrpict
(except-in texpict/utils pin-arrow-line)
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" #:spacing-word "subparts"))
(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 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 convertible-name (class-name "convertible"))
(define convertible-box (class-box convertible-name #f #f))
(define list-name (class-name "list"))
(define list-box (class-box list-name #f #f))
(define delayed-element-name (class-name "delayed-\nelement"))
(define delayed-element-content (field-spec #f "content"))
(define delayed-element-box (class-box delayed-element-name (list delayed-element-content) #f))
(define render-element-name (class-name "render-\nelement"))
(define render-element-content (field-spec #f "content"))
(define render-element-box (class-box render-element-name (list render-element-content) #f))
(define traverse-element-name (class-name "traverse-\nelement"))
(define traverse-element-content (field-spec #f "content"))
(define traverse-element-box (class-box traverse-element-name (list traverse-element-content) #f))
(define part-relative-element-name (class-name "part-\nrelative-\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 element-name (class-name "element"))
(define element-style (field-spec #f "style"))
(define element-content (field-spec #f "content"))
(define element-box (class-box element-name (list element-style element-content) #f))
(define link-element-name (class-name "link-\nelement"))
(define link-tag (field-spec #f "tag"))
(define link-element-box (class-box link-element-name
(list link-tag)
#f))
(define collect-element-name (class-name "collect-\nelement"))
(define collect-element-collect (field-spec #f "collect"))
(define collect-element-box (class-box collect-element-name (list collect-element-collect) #f))
(define index-element-name (class-name "index-\nelement" #:spacing-word "keywords"))
(define index-element-tag (field-spec #f "tag"))
(define index-element-keywords (field-spec #f "keywords"))
(define index-element-box (class-box index-element-name
(list index-element-tag index-element-keywords)
#f))
(define image-element-name (class-name "image-\nelement" #:spacing-word "suffixes"))
(define image-element-path (field-spec #f "path"))
(define image-element-suffixes (field-spec #f "suffixes"))
(define image-element-scale (field-spec #f "scale"))
(define image-element-box (class-box image-element-name
(list image-element-path
image-element-suffixes
image-element-scale)
#f))
(define multiarg-element-name (class-name "multiarg-\nelement"))
(define multiarg-element-tag (field-spec #f "tag"))
(define multiarg-element-box (class-box multiarg-element-name (list multiarg-element-tag) #f))
(define target-element-name (class-name "target-\nelement"))
(define target-tag (field-spec #f "tag"))
(define target-element-box (class-box target-element-name
(list target-tag)
#f))
(define redirect-target-element-name (class-name "redirect-target-\nelement"))
(define redirect-target-alt-path (field-spec #f "alt-path"))
(define redirect-target-alt-anchor (field-spec #f "alt-anchor"))
(define redirect-target-element-box (class-box redirect-target-element-name
(list redirect-target-alt-path redirect-target-alt-anchor)
#f))
(define toc-target-element-name (class-name "toc-target-\nelement"))
(define toc-target-element-box (class-box toc-target-element-name (list) #f))
(define page-target-element-name (class-name "page-target-\nelement"))
(define page-target-element-box (class-box page-target-element-name (list) #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-hierarchy
(hierarchy
(vc-append target-element-box
(blank 0 50)
(ht-append 20
toc-target-element-box
page-target-element-box
redirect-target-element-box))
(list target-element-box)
(list toc-target-element-box
page-target-element-box
redirect-target-element-box)))
(define element-hierarchy
(hierarchy
(vc-append element-box
(blank 0 50)
(inset (ht-append 20
collect-element-box
multiarg-element-box
(refocus target-element-hierarchy target-element-box)
link-element-box
image-element-box
index-element-box)
0 0 -400 0))
(list element-box)
(list collect-element-box
index-element-box
image-element-box
target-element-box
multiarg-element-box
link-element-box
)))
(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-parent-link (blank))
(define (drop-and-link box parent-link i)
(vc-append
(blank 0 (+ 40 (* i 20)))
(refocus (ct-superimpose box parent-link)
parent-link)))
(define content-hierarchy
(hierarchy
(vc-append content-box
(blank 0 50)
(ht-append 15
(drop-and-link (refocus element-hierarchy element-box)
element-parent-link
4)
convertible-box
(drop-and-link render-element-box
render-element-parent-link
4)
pict-box
(drop-and-link delayed-element-box
delayed-element-parent-link
3)
symbol-box
(drop-and-link part-relative-element-box
part-relative-element-parent-link
1)
string-box
(drop-and-link traverse-element-box
traverse-element-parent-link
0)
list-box))
(list content-box)
(list element-box
string-box
symbol-box
convertible-box
pict-box
traverse-element-parent-link
part-relative-element-parent-link
delayed-element-parent-link
render-element-parent-link
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
(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
(left-left-reference
raw
element-box element-content content-box content-name 1 #:dot-delta -1)
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)
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-element-content content-box content-name 30)
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-element-content content-box content-name 3)
delayed-element-box delayed-element-content content-box content-name 22)
part-relative-element-box part-relative-element-resolve content-box content-name 12))
;; 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
type-link-color ;(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
#:color type-link-color)
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 (inset (mk-diagram) 0 0 0 1))
(define c (blank client-w client-h))
(slide (lt-superimpose (t "top") (clip (refocus (ct-superimpose p c) c))))
(slide (lt-superimpose (t "bottom") (clip (refocus (cb-superimpose p c) c))))
(slide (lt-superimpose (t "all")
(ct-superimpose
c
(scale p
(min (/ client-w (pict-width p))
(/ client-h (pict-height p))))))))