From ed8baf5d795adb857e772b3705fe3ee3f89362b2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 19 Jun 2012 17:38:25 -0500 Subject: [PATCH] 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 --- .../scribblings/scribble/class-diagrams.rkt | 62 ++-- collects/scribblings/scribble/core.scrbl | 17 +- .../scribblings/scribble/struct-hierarchy.rkt | 289 ++++++++++-------- 3 files changed, 210 insertions(+), 158 deletions(-) diff --git a/collects/scribblings/scribble/class-diagrams.rkt b/collects/scribblings/scribble/class-diagrams.rkt index da55d2d0..4f3feaee 100644 --- 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 index 65ab2585..baefb3fa 100644 --- 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 index c802aa4a..b542a337 100644 --- 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 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-content (field-spec #f "content")) (define link-element-box (class-box link-element-name - (list link-tag link-content) + (list link-tag) #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 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))))))))