Fixed up and added in the struct hierarchy diagram from the Scribble paper
original commit: ac8a4f23e5df50d1e7cc579fd8cbcd6606b8dc6d
This commit is contained in:
Robby Findler
parent
4fc0b01398
commit
c77b67ea80
496
collects/scribblings/scribble/class-diagrams.rkt
Normal file
496
collects/scribblings/scribble/class-diagrams.rkt
Normal file
|
|
@ -0,0 +1,496 @@
|
|||
#lang racket/base
|
||||
(require (prefix-in etc: mzlib/etc)
|
||||
texpict/mrpict
|
||||
texpict/utils
|
||||
racket/class
|
||||
racket/runtime-path
|
||||
racket/draw
|
||||
racket/contract
|
||||
(only-in racket/list last))
|
||||
|
||||
(define the-font-size 12)
|
||||
(define prim-font-family 'swiss)
|
||||
;; Was 'modern, but we want font smoothing even for small text:
|
||||
(define font-family (make-object font% the-font-size 'modern 'normal 'normal #f 'smoothed))
|
||||
|
||||
(define prim-types '("int" "String" "float" "double" "boolean"))
|
||||
|
||||
;; how far a dot is to the right of a class
|
||||
(define dot-edge-spacing 10)
|
||||
|
||||
(define field-arrowhead-size 10)
|
||||
|
||||
#|
|
||||
(define font-family "Palatino")
|
||||
(define-runtime-path afm "afm")
|
||||
(current-ps-afm-file-paths (cons afm (current-ps-afm-file-paths)))
|
||||
|
||||
(let ([id (send the-font-name-directory find-or-create-font-id font-family 'default)])
|
||||
(send the-font-name-directory set-post-script-name
|
||||
id 'normal 'normal "Palatino-Roman")
|
||||
(send the-font-name-directory set-post-script-name
|
||||
id 'bold 'normal "Palatino-Bold")
|
||||
(send the-font-name-directory set-post-script-name
|
||||
id 'normal 'italic "Palatino-Italic"))
|
||||
|#
|
||||
|
||||
(define (user-type-font x) (text x font-family the-font-size))
|
||||
(define (prim-type-font x) (text x prim-font-family the-font-size))
|
||||
(define (var-font x) (text x `(bold . ,font-family) the-font-size))
|
||||
(define (field-name-font x) (text x font-family the-font-size))
|
||||
(define (comment-font x) (text x font-family the-font-size))
|
||||
(define (normal-font x) (text x font-family the-font-size))
|
||||
(define (java-this) (text "this" `(bold . ,font-family) the-font-size))
|
||||
|
||||
;; field-spec : string string -> pict
|
||||
(define (field-spec type fd #:default [default #f] [comment #f])
|
||||
(let ([code-line
|
||||
(hbl-append (if type
|
||||
(hbl-append (type-spec type)
|
||||
(normal-font " "))
|
||||
(blank))
|
||||
(field-name-font fd)
|
||||
(if default
|
||||
(hbl-append (normal-font " = ")
|
||||
(normal-font default))
|
||||
(blank))
|
||||
#;
|
||||
(normal-font ";"))])
|
||||
(if comment
|
||||
(hbl-append code-line
|
||||
(normal-font " ")
|
||||
(comment-font (format "[in ~a]" comment)))
|
||||
code-line)))
|
||||
|
||||
(define (method-spec range name #:body [body #f] . args)
|
||||
(unless (even? (length args))
|
||||
(error 'method-spec "expected a list of types and argument names, but found ~a arguments"
|
||||
(length args)))
|
||||
(let ([first-line
|
||||
(hbl-append
|
||||
(type-spec range)
|
||||
(normal-font " ")
|
||||
(var-font name)
|
||||
(cond
|
||||
[(null? args)
|
||||
(normal-font "()")]
|
||||
[else
|
||||
(hbl-append
|
||||
(normal-font "(")
|
||||
(let loop ([args args])
|
||||
(let* ([type (car args)]
|
||||
[param (cadr args)]
|
||||
[single-arg
|
||||
(if param
|
||||
(hbl-append (type-spec type)
|
||||
(normal-font " ")
|
||||
(var-font param))
|
||||
(type-spec type))])
|
||||
|
||||
(cond
|
||||
[(null? (cddr args))
|
||||
(hbl-append single-arg (normal-font ")"))]
|
||||
[else
|
||||
(hbl-append single-arg
|
||||
(normal-font ", ")
|
||||
(loop (cddr args)))]))))])
|
||||
(if body
|
||||
(hbl-append (normal-font " {"))
|
||||
(blank)))])
|
||||
(if body
|
||||
(vl-append first-line
|
||||
(hbl-append (blank 8 0) body (normal-font "}")))
|
||||
first-line)))
|
||||
|
||||
(define (type-spec str)
|
||||
(cond
|
||||
[(member str prim-types) (prim-type-font str)]
|
||||
[else (user-type-font str)]))
|
||||
|
||||
;; class-name : string -> pict
|
||||
(define (class-name txt)
|
||||
(apply vl-append (map var-font (regexp-split #rx"\n" txt))))
|
||||
|
||||
;; class-box : pict (or/c #f (listof pict)) (or/c #f (listof pict)) -> pict
|
||||
(define (class-box name fields methods)
|
||||
(let* ([spacing 4]
|
||||
[mk-blank (λ () (blank 0 spacing))])
|
||||
(cond
|
||||
[(and methods fields)
|
||||
(let* ([top-spacer (mk-blank)]
|
||||
[bottom-spacer (mk-blank)]
|
||||
[main (vl-append name
|
||||
top-spacer
|
||||
(if (null? fields)
|
||||
(blank 0 4)
|
||||
(apply vl-append fields))
|
||||
bottom-spacer
|
||||
(if (null? methods)
|
||||
(blank 0 4)
|
||||
(apply vl-append methods)))])
|
||||
(add-hline
|
||||
(add-hline (frame (inset main spacing))
|
||||
top-spacer)
|
||||
bottom-spacer))]
|
||||
[fields
|
||||
(let* ([top-spacer (mk-blank)]
|
||||
[main (vl-append name
|
||||
top-spacer
|
||||
(if (null? fields)
|
||||
(blank)
|
||||
(apply vl-append fields)))])
|
||||
(add-hline (frame (inset main spacing))
|
||||
top-spacer))]
|
||||
[methods (class-box name methods fields)]
|
||||
[else (frame (inset name spacing))])))
|
||||
|
||||
(define (add-hline main sub)
|
||||
(let-values ([(x y) (cc-find main sub)])
|
||||
(pin-line main
|
||||
sub (λ (p1 p2) (values 0 y))
|
||||
sub (λ (p1 p2) (values (pict-width main) y)))))
|
||||
|
||||
;; hierarchy : pict (cons pict (listof pict)) (cons pict (listof pict)) -> pict
|
||||
(define (hierarchy main supers subs)
|
||||
(let ([supers-bottoms (apply max (map (λ (x) (let-values ([(x y) (cb-find main x)]) y)) supers))]
|
||||
[subs-tops (apply min (map (λ (x) (let-values ([(x y) (ct-find main x)]) y)) subs))]
|
||||
[sorted-subs (sort subs (λ (x y) (< (left-edge-x main x) (left-edge-x main y))))])
|
||||
(unless (< supers-bottoms subs-tops)
|
||||
(error 'hierarchy "expected supers to be on top of subs, supers bottom is at ~a, and subs tops is at ~a"
|
||||
supers-bottoms
|
||||
subs-tops))
|
||||
(let* ([main-line-y (/ (+ supers-bottoms subs-tops) 2)]
|
||||
[main-line-start-x (center-x main (car sorted-subs))]
|
||||
[main-line-end-x (center-x main (last sorted-subs))]
|
||||
[w/main-line
|
||||
(pin-line main
|
||||
main (λ (_1 _2) (values main-line-start-x main-line-y))
|
||||
main (λ (_1 _2) (values main-line-end-x main-line-y)))]
|
||||
[super-lines
|
||||
(map (λ (super)
|
||||
(let-values ([(x y) (cb-find main super)])
|
||||
(pin-over
|
||||
(pin-line (ghost main)
|
||||
super cb-find
|
||||
main (λ (_1 _2) (values x main-line-y)))
|
||||
(- x (/ (pict-width triangle) 2))
|
||||
(- (/ (+ y main-line-y) 2)
|
||||
(/ (pict-height triangle) 2))
|
||||
triangle)))
|
||||
supers)]
|
||||
[sub-lines
|
||||
(map (λ (sub)
|
||||
(let-values ([(x y) (ct-find main sub)])
|
||||
(pin-line (ghost main)
|
||||
sub ct-find
|
||||
main (λ (_1 _2) (values x main-line-y)))))
|
||||
subs)])
|
||||
(apply cc-superimpose
|
||||
w/main-line
|
||||
(append sub-lines
|
||||
super-lines)))))
|
||||
|
||||
(define triangle-width 12)
|
||||
(define triangle-height 12)
|
||||
(define triangle
|
||||
(let ([points (list (make-object point% (/ triangle-width 2) 0)
|
||||
(make-object point% 0 triangle-height)
|
||||
(make-object point% triangle-width triangle-height))])
|
||||
(dc (λ (dc dx dy)
|
||||
(let ([brush (send dc get-brush)])
|
||||
(send dc set-brush (send brush get-color) 'solid)
|
||||
(send dc draw-polygon points dx dy)
|
||||
(send dc set-brush brush)))
|
||||
triangle-width
|
||||
triangle-height)))
|
||||
|
||||
(define (center-x main pict)
|
||||
(let-values ([(x y) (cc-find main pict)])
|
||||
x))
|
||||
|
||||
(define (left-edge-x main pict)
|
||||
(let-values ([(x y) (lc-find main pict)])
|
||||
x))
|
||||
|
||||
|
||||
(define (add-dot-right main class field) (add-dot-left-right/offset main class field 0 rc-find))
|
||||
(define add-dot-right/space
|
||||
(λ (main class field [count 1])
|
||||
(add-dot-right/offset main class field (* count dot-edge-spacing))))
|
||||
(define (add-dot-right/offset main class field offset)
|
||||
(add-dot-left-right/offset main class field offset rc-find))
|
||||
|
||||
(define (add-dot-left main class field) (add-dot-left-right/offset main class field 0 lc-find))
|
||||
(define add-dot-left/space
|
||||
(λ (main class field [count 1])
|
||||
(add-dot-left/offset main class field (* count (- dot-edge-spacing)))))
|
||||
(define (add-dot-left/offset main class field offset)
|
||||
(add-dot-left-right/offset main class field offset lc-find))
|
||||
|
||||
(define (add-dot-left-right/offset main class field offset finder)
|
||||
(let-values ([(_1 y) (cc-find main field)]
|
||||
[(x-edge _2) (finder main class)])
|
||||
(add-dot main (+ x-edge offset) y)))
|
||||
|
||||
(define add-dot-junction
|
||||
(case-lambda
|
||||
[(main x-pict y-pict) (add-dot-junction main x-pict cc-find y-pict cc-find)]
|
||||
[(main x-pict x-find y-pict y-find)
|
||||
(let-values ([(x _1) (x-find main x-pict)]
|
||||
[(_2 y) (y-find main y-pict)])
|
||||
(add-dot main x y))]))
|
||||
|
||||
(define (add-dot-offset pict dot dx dy)
|
||||
(let-values ([(x y) (cc-find pict dot)])
|
||||
(add-dot pict (+ x dx) (+ y dy))))
|
||||
|
||||
(define dot-δx (make-parameter 0))
|
||||
(define dot-δy (make-parameter 0))
|
||||
|
||||
(define (add-dot pict dx dy)
|
||||
(let ([dot (blank)])
|
||||
(values (pin-over pict
|
||||
(+ dx (dot-δx))
|
||||
(+ dy (dot-δy))
|
||||
dot)
|
||||
dot)))
|
||||
|
||||
(define (connect-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-dots pict prev-dot (car dots) (null? (cdr dots)) show-arrowhead?))])))
|
||||
|
||||
(define (connect-two-dots pict dot1 dot2 arrowhead? show-arrowhead?)
|
||||
(if arrowhead?
|
||||
(pin-arrow-line field-arrowhead-size pict
|
||||
dot1 cc-find
|
||||
dot2 cc-find
|
||||
#f #f #f #f
|
||||
#:hide-arrowhead? (not show-arrowhead?))
|
||||
(pin-line pict
|
||||
dot1 cc-find
|
||||
dot2 cc-find)))
|
||||
|
||||
(define (hierarchy/layout tops bottoms
|
||||
#:every-other-space [every-other-space 0]
|
||||
#:top-space [top-space 40]
|
||||
#:bottom-space [bottom-space 40]
|
||||
#:vertical-space [vertical-space 60])
|
||||
(hierarchy
|
||||
(vc-append (apply ht-append top-space tops)
|
||||
(blank 0 vertical-space)
|
||||
(apply ht-append bottom-space
|
||||
(let loop ([bottoms bottoms]
|
||||
[every-other? #f])
|
||||
(cond
|
||||
[(null? bottoms) '()]
|
||||
[else
|
||||
(cons (if every-other?
|
||||
(vc-append (blank 0 every-other-space)
|
||||
(car bottoms))
|
||||
(car bottoms))
|
||||
(loop (cdr bottoms)
|
||||
(not every-other?)))]))))
|
||||
tops
|
||||
bottoms))
|
||||
|
||||
(define (add-dot-delta f dx dy)
|
||||
(parameterize ([dot-δx dx]
|
||||
[dot-δy dy])
|
||||
(f)))
|
||||
|
||||
|
||||
(define (right-right-reference main0 start-class start-field finish-class finish-name
|
||||
[count 1]
|
||||
#:connect-dots [connect-dots connect-dots]
|
||||
#:dot-delta [dot-delta 0])
|
||||
(let ([going-down? (let-values ([(_1 start-y) (find-cc main0 start-field)]
|
||||
[(_2 finish-y) (find-cc main0 finish-name)])
|
||||
(< start-y finish-y))])
|
||||
(define-values (main1 dot1) (add-dot-delta (λ () (add-dot-right main0 start-class start-field))
|
||||
0
|
||||
(if going-down?
|
||||
dot-delta
|
||||
(- dot-delta))))
|
||||
(define-values (main2 dot2) (add-dot-delta (λ () (add-dot-right/space main1 start-class start-field count))
|
||||
dot-delta
|
||||
(if going-down?
|
||||
dot-delta
|
||||
(- dot-delta))))
|
||||
(define-values (main3 dot3) (add-dot-delta (λ () (add-dot-right main2 finish-class finish-name))
|
||||
0
|
||||
(if going-down?
|
||||
(- dot-delta)
|
||||
dot-delta)))
|
||||
(define-values (main4 dot4) (add-dot-delta (λ () (add-dot-junction main3 dot2 dot3))
|
||||
0
|
||||
0))
|
||||
|
||||
;; these last two dots are just there for the delta-less arrowhead
|
||||
(define-values (main5 dot5) (add-dot-right main4 finish-class finish-name))
|
||||
(define-values (main6 dot6) (add-dot-delta (λ () (add-dot-right main5 finish-class finish-name))
|
||||
1 ;; just enough to get the arrowhead going the right direction; not enough to see the line
|
||||
0))
|
||||
|
||||
(connect-dots
|
||||
#t
|
||||
(connect-dots #f main6 dot1 dot2 dot4 dot3)
|
||||
dot6
|
||||
dot5)))
|
||||
|
||||
(define left-left-reference
|
||||
(λ (main0 start-class start-field finish-class finish-name [count 1]
|
||||
#:connect-dots [connect-dots connect-dots]
|
||||
#:dot-delta [dot-delta 0])
|
||||
(let ([going-down? (let-values ([(_1 start-y) (find-cc main0 start-field)]
|
||||
[(_2 finish-y) (find-cc main0 finish-name)])
|
||||
(< start-y finish-y))])
|
||||
(define-values (main1 dot1) (add-dot-delta (λ () (add-dot-left main0 start-class start-field))
|
||||
0
|
||||
(if going-down?
|
||||
dot-delta
|
||||
(- dot-delta))))
|
||||
(define-values (main2 dot2) (add-dot-delta (λ () (add-dot-left/space main1 start-class start-field count))
|
||||
(- dot-delta)
|
||||
(if going-down?
|
||||
dot-delta
|
||||
(- dot-delta))))
|
||||
(define-values (main3 dot3) (add-dot-delta (λ () (add-dot-left main2 finish-class finish-name))
|
||||
0
|
||||
(if going-down?
|
||||
(- dot-delta)
|
||||
dot-delta)))
|
||||
(define-values (main4 dot4) (add-dot-delta (λ () (add-dot-junction main3 dot2 dot3))
|
||||
0
|
||||
0))
|
||||
(define-values (main5 dot5) (add-dot-left main4 finish-class finish-name))
|
||||
(define-values (main6 dot6) (add-dot-delta (λ () (add-dot-left main5 finish-class finish-name))
|
||||
-1 ;; just enough to get the arrowhead going the right direction; not enough to see the line
|
||||
0))
|
||||
|
||||
(connect-dots
|
||||
#t
|
||||
(connect-dots #f main6 dot1 dot2 dot4 dot3)
|
||||
dot6
|
||||
dot5))))
|
||||
|
||||
(define left-top-reference
|
||||
(λ (main0 start-class start-field finish-class [count 1] #:connect-dots [connect-dots connect-dots])
|
||||
(define-values (main1 dot1) (add-dot-left main0 start-class start-field))
|
||||
(define-values (main2 dot2) (add-dot-left/space main1 start-class start-field count))
|
||||
(define-values (main3 dot3) (add-dot-junction main2 dot2 cc-find finish-class ct-find))
|
||||
(connect-dots #t main3 dot1 dot2 dot3)))
|
||||
|
||||
(define right-left-reference
|
||||
(λ (main0 start-class start-field finish-class finish-name
|
||||
[offset
|
||||
(find-middle main0 start-class rc-find finish-class lc-find)]
|
||||
#:connect-dots [connect-dots connect-dots])
|
||||
(define-values (main1 dot1) (add-dot-right main0 start-class start-field))
|
||||
(define-values (main2 dot2) (add-dot-right/offset main1 start-class start-field offset))
|
||||
(define-values (main3 dot3) (add-dot-left main2 finish-class finish-name))
|
||||
(define-values (main4 dot4) (add-dot-junction main3 dot2 dot3))
|
||||
(connect-dots #t main4 dot1 dot2 dot4 dot3)))
|
||||
|
||||
(define left-right-reference
|
||||
(λ (main0 start-class start-field finish-class finish-name
|
||||
[offset
|
||||
(- (find-middle main0 start-class lc-find finish-class rc-find))]
|
||||
#:connect-dots [connect-dots connect-dots])
|
||||
(define-values (main1 dot1) (add-dot-left main0 start-class start-field))
|
||||
(define-values (main2 dot2) (add-dot-left/offset main1 start-class start-field offset))
|
||||
(define-values (main3 dot3) (add-dot-right main2 finish-class finish-name))
|
||||
(define-values (main4 dot4) (add-dot-junction main3 dot2 dot3))
|
||||
(connect-dots #t main4 dot1 dot2 dot4 dot3)))
|
||||
|
||||
(define (find-middle main p1 find1 p2 find2)
|
||||
(let-values ([(x1 y1) (find1 main p1)]
|
||||
[(x2 y2) (find2 main p2)])
|
||||
(- (/ (+ x1 x2) 2) (min x1 x2))))
|
||||
|
||||
(define right-top-reference
|
||||
(λ (main0 start-class start-field finish-class [count 1] #:connect-dots [connect-dots connect-dots])
|
||||
(define-values (main1 dot1) (add-dot-right main0 start-class start-field))
|
||||
(define-values (main2 dot2) (add-dot-right/space main1 start-class start-field count))
|
||||
(define-values (main3 dot3) (add-dot-junction main2 dot2 cc-find finish-class ct-find))
|
||||
(connect-dots #t main3 dot1 dot2 dot3)))
|
||||
|
||||
(define connect-dots-contract (->* (boolean? pict? pict?) () #:rest (listof pict?) (values pict?)))
|
||||
|
||||
(provide/contract
|
||||
[field-spec (->* ((or/c #f string?) string?) (string? #:default string?) pict?)]
|
||||
[class-name (-> string? pict?)]
|
||||
[class-box (-> pict? (or/c false/c (listof pict?)) (or/c false/c (listof pict?)) pict?)]
|
||||
[hierarchy/layout
|
||||
(->* ((cons/c pict? (listof pict?)) (cons/c pict? (listof pict?)))
|
||||
(#:top-space
|
||||
integer?
|
||||
#:bottom-space integer?
|
||||
#:vertical-space integer?
|
||||
#:every-other-space integer?)
|
||||
pict?)]
|
||||
[user-type-font (-> string? pict?)]
|
||||
[prim-type-font (-> string? pict?)]
|
||||
[var-font (-> string? pict?)]
|
||||
[normal-font (-> string? pict?)]
|
||||
[comment-font (-> string? pict?)]
|
||||
|
||||
[hierarchy (-> pict?
|
||||
(cons/c pict? (listof pict?))
|
||||
(cons/c pict? (listof pict?))
|
||||
pict?)]
|
||||
[right-right-reference (->* (pict? pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract
|
||||
#:dot-delta number?)
|
||||
pict?)]
|
||||
[left-left-reference (->* (pict? pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract
|
||||
#:dot-delta number?)
|
||||
pict?)]
|
||||
[right-left-reference (->* (pict? pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract)
|
||||
pict?)]
|
||||
[left-right-reference (->* (pict? pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract)
|
||||
pict?)]
|
||||
[left-top-reference (->* (pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract)
|
||||
pict?)]
|
||||
[right-top-reference (->* (pict? pict? pict? pict?)
|
||||
(number?
|
||||
#:connect-dots connect-dots-contract)
|
||||
pict?)]
|
||||
|
||||
[dot-edge-spacing number?]
|
||||
[connect-dots connect-dots-contract]
|
||||
[add-dot-right (-> pict? pict? pict? (values pict? pict?))]
|
||||
[add-dot-right/space (-> pict? pict? pict? (values pict? pict?))]
|
||||
[add-dot-left (-> pict? pict? pict? (values pict? pict?))]
|
||||
[add-dot-left/space (-> pict? pict? pict? (values pict? pict?))]
|
||||
[add-dot-junction
|
||||
(case->
|
||||
(-> pict? pict? pict? (values pict? pict?))
|
||||
(-> pict?
|
||||
pict? (-> pict? pict? (values number? number?))
|
||||
pict? (-> pict? pict? (values number? number?))
|
||||
(values pict? pict?)))]
|
||||
[add-dot-offset (-> pict? pict? number? number? (values pict? pict?))]
|
||||
[add-dot (-> pict? number? number? (values pict? pict?))]
|
||||
[method-spec
|
||||
(->* (string? string?)
|
||||
(#:body (or/c false/c pict?))
|
||||
#:rest (listof (or/c false/c string?))
|
||||
pict?)]
|
||||
[java-this (-> pict?)]
|
||||
[field-arrowhead-size number?])
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual "utils.rkt"
|
||||
"struct-hierarchy.rkt"
|
||||
(for-label scribble/manual-struct
|
||||
file/convertible
|
||||
setup/main-collects
|
||||
|
|
@ -48,9 +49,32 @@ None of the passes mutate the document representation. Instead, the
|
|||
@tech{resolve pass} are effectively specialized version of
|
||||
@tech{traverse pass} that work across separately built documents.
|
||||
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section[#:tag "parts"]{Parts}
|
||||
@section[#:tag "parts"]{Parts, Flows, Blocks, and Paragraphs}
|
||||
|
||||
This diagram shows the large-scale structure of the
|
||||
type hierarchy for Scribble documents. A box represents
|
||||
a struct; for example @racket[part] is a struct. The substruct relationship
|
||||
is shown vertically with lines connected by a triangle;
|
||||
for example, a @racket[compound-paragraph] is a @racket[block].
|
||||
The types of values on fields are shown via lines in the diagram.
|
||||
Doubled lines represent lists and tripled lines represent lists
|
||||
of lists; for example, the @racket[blocks] field of
|
||||
@racket[compound-paragraph] is a list of @racket[blocks].
|
||||
Dotted lists represent functions that compute elements of
|
||||
a given field; for example, the @racket[block] field of
|
||||
a @racket[traverse-block] struct is a function that
|
||||
computes a @racket[block].
|
||||
|
||||
The diagram is not completely
|
||||
accurate; a few fields are omitted and sometimes the types
|
||||
are simplified (e.g., a @racket[table] may have @racket['cont]
|
||||
in place of a block).
|
||||
A prose description with more detail follows the diagram.
|
||||
|
||||
@(mk-diagram)
|
||||
|
||||
A @deftech{part} is an instance of @racket[part]; among other things,
|
||||
it has a title @techlink{content}, an initial @techlink{flow}, and a
|
||||
|
|
|
|||
364
collects/scribblings/scribble/struct-hierarchy.rkt
Normal file
364
collects/scribblings/scribble/struct-hierarchy.rkt
Normal file
|
|
@ -0,0 +1,364 @@
|
|||
#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))))))
|
||||
Loading…
Reference in New Issue
Block a user