Fixed up and added in the struct hierarchy diagram from the Scribble paper

original commit: ac8a4f23e5df50d1e7cc579fd8cbcd6606b8dc6d

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

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

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