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))))))