From c77b67ea80647af2210eeb914bdc7e6f6011f9ef Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 17 Jun 2012 07:39:31 -0500 Subject: [PATCH] Fixed up and added in the struct hierarchy diagram from the Scribble paper original commit: ac8a4f23e5df50d1e7cc579fd8cbcd6606b8dc6d --- .../scribblings/scribble/class-diagrams.rkt | 496 ++++++++++++++++++ collects/scribblings/scribble/core.scrbl | 26 +- .../scribblings/scribble/struct-hierarchy.rkt | 364 +++++++++++++ 3 files changed, 885 insertions(+), 1 deletion(-) create mode 100644 collects/scribblings/scribble/class-diagrams.rkt create mode 100644 collects/scribblings/scribble/struct-hierarchy.rkt diff --git a/collects/scribblings/scribble/class-diagrams.rkt b/collects/scribblings/scribble/class-diagrams.rkt new file mode 100644 index 00000000..da55d2d0 --- /dev/null +++ b/collects/scribblings/scribble/class-diagrams.rkt @@ -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?]) diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index c8047202..65ab2585 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -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 diff --git a/collects/scribblings/scribble/struct-hierarchy.rkt b/collects/scribblings/scribble/struct-hierarchy.rkt new file mode 100644 index 00000000..c802aa4a --- /dev/null +++ b/collects/scribblings/scribble/struct-hierarchy.rkt @@ -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))))))