commit ed8baf5d795adb857e772b3705fe3ee3f89362b2
parent 87197b53ca00859a4b49928bf268bbb3762fc9b1
Author: Robby Findler <robby@racket-lang.org>
Date: Tue, 19 Jun 2012 17:38:25 -0500
a bunch of fixes to the diagram:
- added some color (mostly to try to disambiguate the lines)
- several of the things named '*-element' actually belong under content, not element.
- element has 'content', not the substructs.
- convertible?s are content's.
- the 'content' field in an element is not a list, but simply a content.
- there are a bunch of things under target-element.
- image-element was missing fields
- collect-element was missing the collect field
original commit: 411aeb99b845823aa5f9bcaebe6b686ad478ab75
Diffstat:
3 files changed, 210 insertions(+), 158 deletions(-)
diff --git a/collects/scribblings/scribble/class-diagrams.rkt b/collects/scribblings/scribble/class-diagrams.rkt
@@ -1,7 +1,8 @@
#lang racket/base
(require (prefix-in etc: mzlib/etc)
texpict/mrpict
- texpict/utils
+ (only-in slideshow/pict pin-line pin-arrow-line)
+ (except-in texpict/utils pin-line pin-arrow-line)
racket/class
racket/runtime-path
racket/draw
@@ -20,6 +21,9 @@
(define field-arrowhead-size 10)
+(define hierarchy-color "navy")
+(define type-link-color "firebrick")
+
#|
(define font-family "Palatino")
(define-runtime-path afm "afm")
@@ -108,13 +112,21 @@
[else (user-type-font str)]))
;; class-name : string -> pict
-(define (class-name txt)
- (apply vl-append (map var-font (regexp-split #rx"\n" txt))))
+(define (class-name txt #:spacing-word [spacing-word txt])
+ (define p (colorize (lt-superimpose (ghost (var-font spacing-word))
+ (apply vl-append (map var-font (regexp-split #rx"\n" txt))))
+ "white"))
+ (refocus (cc-superimpose (colorize (filled-rectangle (+ class-box-margin class-box-margin (pict-width p))
+ (+ class-box-margin class-box-margin (pict-height p)))
+ "black")
+ p)
+ p))
+
+(define class-box-margin 4)
;; 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))])
+ (let* ([mk-blank (λ () (blank 0 (+ class-box-margin class-box-margin)))])
(cond
[(and methods fields)
(let* ([top-spacer (mk-blank)]
@@ -129,7 +141,7 @@
(blank 0 4)
(apply vl-append methods)))])
(add-hline
- (add-hline (frame (inset main spacing))
+ (add-hline (frame (inset main class-box-margin))
top-spacer)
bottom-spacer))]
[fields
@@ -139,10 +151,10 @@
(if (null? fields)
(blank)
(apply vl-append fields)))])
- (add-hline (frame (inset main spacing))
+ (add-hline (frame (inset main class-box-margin))
top-spacer))]
[methods (class-box name methods fields)]
- [else (frame (inset name spacing))])))
+ [else (frame (inset name class-box-margin))])))
(define (add-hline main sub)
(let-values ([(x y) (cc-find main sub)])
@@ -159,13 +171,14 @@
(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)]
+ (let* ([main-line-y (max (- subs-tops 20) (/ (+ 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)))]
+ main (λ (_1 _2) (values main-line-end-x main-line-y))
+ #:color hierarchy-color)]
[super-lines
(map (λ (super)
(let-values ([(x y) (cb-find main super)])
@@ -183,7 +196,8 @@
(let-values ([(x y) (ct-find main sub)])
(pin-line (ghost main)
sub ct-find
- main (λ (_1 _2) (values x main-line-y)))))
+ main (λ (_1 _2) (values x main-line-y))
+ #:color hierarchy-color)))
subs)])
(apply cc-superimpose
w/main-line
@@ -196,13 +210,15 @@
(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)))
+ (colorize
+ (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)
+ hierarchy-color)))
(define (center-x main pict)
(let-values ([(x y) (cc-find main pict)])
@@ -271,11 +287,12 @@
(pin-arrow-line field-arrowhead-size pict
dot1 cc-find
dot2 cc-find
- #f #f #f #f
- #:hide-arrowhead? (not show-arrowhead?))
+ #:hide-arrowhead? (not show-arrowhead?)
+ #:color type-link-color)
(pin-line pict
dot1 cc-find
- dot2 cc-find)))
+ dot2 cc-find
+ #:color type-link-color)))
(define (hierarchy/layout tops bottoms
#:every-other-space [every-other-space 0]
@@ -423,9 +440,10 @@
(define connect-dots-contract (->* (boolean? pict? pict?) () #:rest (listof pict?) (values pict?)))
+(provide type-link-color)
(provide/contract
[field-spec (->* ((or/c #f string?) string?) (string? #:default string?) pict?)]
- [class-name (-> string? pict?)]
+ [class-name (->* (string?) (#:spacing-word 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?)))
diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl
@@ -56,10 +56,14 @@ None of the passes mutate the document representation. Instead, the
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;
+a struct or a built-in Racket type; for example @racket[part] is a struct.
+The bottom portion of a box shows the fields; for example
+@racket[part] has three fields, @racket[title], @racket[blocks],
+and @racket[subparts].
+The substruct relationship
+is shown vertically with navy blue 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.
+The types of values on fields are shown via dark red 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].
@@ -69,9 +73,10 @@ 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).
+accurate: a @racket[table] may have @racket['cont]
+in place of a block in its @racket[cells] field, and
+the types of fields are only shown if they are other structs
+in the diagram.
A prose description with more detail follows the diagram.
@(mk-diagram)
diff --git a/collects/scribblings/scribble/struct-hierarchy.rkt b/collects/scribblings/scribble/struct-hierarchy.rkt
@@ -1,8 +1,9 @@
#lang racket/base
(require "class-diagrams.rkt"
+ (only-in slideshow/pict pin-arrow-line)
texpict/mrpict
- texpict/utils
+ (except-in texpict/utils pin-arrow-line)
racket/system
racket/class
racket/draw)
@@ -15,7 +16,7 @@
(define (mk-diagram)
- (define part-name (class-name "part"))
+ (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"))
@@ -60,10 +61,6 @@
(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))
@@ -73,58 +70,83 @@
(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 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 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-content (field-spec #f "content"))
- (define render-element-box (class-box render-element-name (list render-content) #f))
+ (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-content (field-spec #f "content"))
- (define traverse-element-box (class-box traverse-element-name (list traverse-content) #f))
+ (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-content (field-spec #f "content"))
- (define collect-element-box (class-box collect-element-name (list collect-content) #f))
+ (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"))
+ (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-content (field-spec #f "content"))
(define index-element-box (class-box index-element-name
- (list index-element-tag index-element-keywords index-element-content)
+ (list index-element-tag index-element-keywords)
#f))
- (define image-element-name (class-name "image-\nelement"))
- (define image-element-box (class-box image-element-name (list) #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 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 multi-arg-element-box (class-box multi-arg-element-name (list multi-arg-element-tag) #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 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
@@ -151,73 +173,87 @@
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 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)
- (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)))))
+ (inset (ht-append 20
+ collect-element-box
+ multi-arg-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-parent-link
+ target-element-box
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 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 (ht-append 20
- string-box
- symbol-box)
- (inset element-hierarchy -130 0)
- (ht-append 20
- pict-box
- list-box)))
+ (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 string-box
+ (list element-box
+ string-box
symbol-box
+ convertible-box
pict-box
- element-box
+ traverse-element-parent-link
+ part-relative-element-parent-link
+ delayed-element-parent-link
+ render-element-parent-link
list-box)))
(define raw
@@ -232,44 +268,31 @@
right-right-reference
(double
left-left-reference
- (double
- left-left-reference
- (double
- left-left-reference
+ (triple
+ right-right-reference
+ (triple
+ right-right-reference
(double
- right-right-reference
+ left-left-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)
+ 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
@@ -280,12 +303,12 @@
(dotted-right-right-reference
(dotted-right-right-reference
w/connections
- render-element-box render-content content-box content-name 31)
+ 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-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))
+ 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
@@ -331,7 +354,7 @@
(λ (dc dx dy)
(let ([pen (send dc get-pen)])
(send dc set-pen
- (send pen get-color)
+ type-link-color ;(send pen get-color)
(if (is-a? dc post-script-dc%)
4
2)
@@ -350,7 +373,7 @@
(let-values ([(x y) (cc-find pict dot2)])
(values (+ x 2) y)))
dot2 cc-find
- #f #f #f #f)
+ #:color type-link-color)
base)))
(define (dotted-right-right-reference p0 a b c d [count 1])
@@ -358,7 +381,13 @@
(module+ slideshow
(require slideshow)
- (define p (mk-diagram))
- (slide (scale p
- (min (/ client-w (pict-width p))
- (/ client-h (pict-height p))))))
+ (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))))))))
