#lang scheme/gui

(require "class-diagrams.ss"
         (lib "mrpict.ss" "texpict")
         (lib "utils.ss" "texpict")
         scheme/system)

(define (mk-ps-diagram)
  ;; thicken up the lines for postscript
  (linewidth .8 (mk-diagram)))

(define (mk-diagram)
  
  (define part-name (class-name "part"))
  (define part-flow-field (field-spec #f "flow"))
  (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-flow-field part-subparts-field) #f))
  
  (define flow-name (class-name "flow"))
  (define flow-blocks (field-spec #f "blocks"))
  (define flow-box (class-box flow-name (list flow-blocks) #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-elements (field-spec #f "elements"))
  (define para-box (class-box para-name (list para-style para-elements) #f))
  
  (define table-name (class-name "table"))
  (define table-style (field-spec #f "style"))
  (define table-cells (field-spec #f "cells")) ;; flowss
  (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")) ;; flows
  (define itemization-box (class-box itemization-name (list itemization-style itemization-items) #f))
  
  (define blockquote-name (class-name "blockquote"))
  (define blockquote-style (field-spec #f "style"))
  (define blockquote-flow (field-spec #f "flow"))
  (define blockquote-box (class-box blockquote-name (list blockquote-style blockquote-flow) #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 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 target-element-name (class-name "target-element"))
  (define target-tag (field-spec #f "tag"))
  (define target-elements (field-spec #f "elements"))
  (define target-element-box (class-box target-element-name 
                                        (list target-tag target-elements)
                                        #f))
  
  (define link-element-name (class-name "link-element"))
  (define link-tag (field-spec #f "tag"))
  (define link-elements (field-spec #f "elements"))
  (define link-element-box (class-box link-element-name
                                      (list link-tag link-elements)
                                      #f))
  
  (define delayed-element-name (class-name "delayed-element"))
  (define delayed-elements (field-spec #f "elements"))
  (define delayed-element-box (class-box delayed-element-name (list delayed-elements) #f))
  
  (define collect-element-name (class-name "collect-element"))
  (define collect-elements (field-spec #f "elements"))
  (define collect-element-box (class-box collect-element-name (list collect-elements) #f))
  
  (define block-hierarchy
    (hierarchy
     (vc-append block-box
                (blank 0 50)
                (ht-append 20 para-box 
                           (vc-append (blank 0 30) itemization-box)
                           delayed-block-box)
                (blank 0 25)
                (ht-append blockquote-box 
                           (blank 45 0)
                           table-box
                           (blank 45 0)))
     (list block-box)
     (list para-box
           blockquote-box
           itemization-box
           table-box
           delayed-block-box)))
  
  (define element-hierarchy
    (hierarchy
     (vc-append element-box
                (blank 0 50)
                (ht-append 40 
                           collect-element-box
                           string-box
                           delayed-element-box)
                (blank 0 20)
                (ht-append 10
                           target-element-box
                           link-element-box))
     (list element-box)
     (list collect-element-box
           target-element-box
           string-box
           link-element-box
           delayed-element-box)))

  (define raw
    (vc-append part-box
               (blank 0 20)
               flow-box
               (blank 0 20)
               (vc-append block-hierarchy
                          (blank 0 40)
                          element-hierarchy)))
  
  (define w/connections
    (double
     left-left-reference
     (double
      right-right-reference
      (double
       left-left-reference
       (left-left-reference
        (double
         right-right-reference
         (triple
          right-right-reference
          (double
           left-left-reference
           (double
            right-right-reference 
            (double
             right-right-reference 
             (left-left-reference 
              (double
               left-left-reference 
               raw
               part-box part-title-field element-box element-name 18)
              part-box part-flow-field flow-box flow-name)
             part-box part-subparts-field part-box part-name 2)
            flow-box flow-blocks block-box block-name)
           para-box para-elements element-box element-name 2)
          table-box table-cells flow-box flow-name 11)
         itemization-box itemization-items flow-box flow-name 15)
        blockquote-box blockquote-flow flow-box flow-name 8)
       target-element-box target-elements element-box element-name 10)
      link-element-box link-elements element-box element-name 9)
     collect-element-box collect-elements element-box element-name 1))
  
  (define w/delayed-connections 
    (dotted-right-right-reference
     (dotted-right-right-reference
      w/connections
      delayed-block-box delayed-block-block block-box block-name)
     delayed-element-box delayed-elements element-box element-name))
  
  w/delayed-connections)

(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)
  (right-right-reference p0 a b c d #:connect-dots connect-circly-dots))
  
(define (save-ps mk-pict filename)
  (let ([ps-setup (make-object ps-setup%)])
    (send ps-setup copy-from (current-ps-setup))
    (send ps-setup set-file filename)
    (let ([ps-dc (parameterize ([current-ps-setup ps-setup])
                   (make-object post-script-dc% #f #f #f #t))])
      (send ps-dc start-doc "")
      (send ps-dc start-page)
      (parameterize ([dc-for-text-size ps-dc])
        (draw-pict (mk-pict) ps-dc 0 0))
      (send ps-dc end-page)
      (send ps-dc end-doc))))

(define (save-png mk-pict filename)
  (let* ([pict (parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
                 ;; don't know why the panorama is necessary here.
                 (panorama (mk-pict)))]
         [bm (make-object bitmap%
               ;; don't know why the +1 is necessary here.
               (+ (ceiling (inexact->exact (pict-width pict))) 1)
               (+ (ceiling (inexact->exact (pict-height pict))) 1))]
         [bdc (make-object bitmap-dc% bm)])
    (send bdc set-smoothing 'aligned)
    (send bdc clear)
    (draw-pict pict bdc 0 0)
    (send bdc set-bitmap #f)
    (send bm save-file filename 'png)
    (void)))

(save-png mk-diagram "struct-hierarchy.png")
(save-ps mk-ps-diagram "struct-hierarchy.ps")
(void (system "epstopdf struct-hierarchy.ps"))

(require (only-in slideshow slide)) (slide (mk-diagram))