gui/draw.ss
(module draw mzscheme

  (require (lib "contract.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred")
           (lib "mrpict.ss" "texpict")
           (lib "utils.ss" "texpict")
           (lib "plt-match.ss")
           (lib "etc.ss")
           (lib "list.ss")
           "../model/view.ss"
           "../model/pool.ss"
           (prefix action: "../model/action.ss")
           "../model/action-util.ss"
           "snip-mixins.ss"
           "easel.ss"
           "interfaces.ss")

  (provide/contract
   [draw-view ((object/c easel<%>) view? . -> . void?)]
   [draw-header ((object/c easel<%>) view? . -> . void?)]
   [draw-sidebar ((object/c easel<%>) view? . -> . void?)]
   [view-height (view? . -> . (>=/c 0))]
   [view-width (view? . -> . (>=/c 0))]
   [class-name (class? . -> . string?)]
   [SCROLLBAR-WIDTH natural-number/c]
   [HEADER-HEIGHT natural-number/c]
   [SIDEBAR-WIDTH natural-number/c]
   [ACTION-HEIGHT natural-number/c]
   [OBJECT-WIDTH natural-number/c]
   [ARROW-HEIGHT natural-number/c]
   [ARROW-WIDTH natural-number/c]
   [DEFAULT-TEXT-SIZE natural-number/c]
   )

  (define-struct bounds
    (min-x max-x min-y max-y min-object max-object min-action max-action))

  (define (bound-x x bounds)
    (max (bounds-min-x bounds)
         (min (bounds-max-x bounds)
              x)))

  (define (bound-y y bounds)
    (max (bounds-min-y bounds)
         (min (bounds-max-y bounds)
              y)))

  (define (draw-header easel view)
    (let* ([bounds (get-bounds easel view)])
      (recur loop ([i (bounds-min-object bounds)])
        (when (<= i (bounds-max-object bounds))
          (draw-header-object easel view bounds i)
          (loop (+ i 1))))))

  (define (draw-sidebar easel view)
    (let* ([bounds (get-bounds easel view)])
      (recur loop ([j (bounds-min-action bounds)])
        (when (<= j (bounds-max-action bounds))
          (draw-sidebar-action easel view bounds j)
          (loop (+ j 1))))))

  (define (draw-header-object easel view bounds index)
    (let* ([object (view-get-object view index)]
           [object-title (symbol->string (handle-tag object))]
           [class-title (class-name (object-class object))]
           [pict (vc-append (standard-text object-title)
                            (standard-text class-title))])
      (center-pict pict easel
                   (* index OBJECT-WIDTH) 0 OBJECT-WIDTH HEADER-HEIGHT)))

  (define (draw-sidebar-action easel view bounds index)
    (let* ([action (view-get-action view index)]
           [source-title (opt-object-title (action-source action))]
           [target-title (opt-object-title (action-target action))]
           [action-title (short-action-label action)]
           [pict1 (standard-text source-title)]
           [pict2 (vc-append (standard-text action-title)
                             (pin-over (blank ARROW-WIDTH ARROW-HEIGHT)
                                       0 (/ ARROW-HEIGHT 2)
                                       (pip-arrow-line ARROW-WIDTH 0
                                                       (/ ARROWHEAD-SIZE 2))))]
           [pict3 (standard-text target-title)])
      (center-pict pict1 easel
                   (* SIDEBAR-WIDTH 0/3) (* index ACTION-HEIGHT)
                   (/ SIDEBAR-WIDTH 3) ACTION-HEIGHT)
      (center-pict pict2 easel
                   (* SIDEBAR-WIDTH 1/3) (* index ACTION-HEIGHT)
                   (/ SIDEBAR-WIDTH 3) ACTION-HEIGHT)
      (center-pict pict3 easel
                   (* SIDEBAR-WIDTH 2/3) (* index ACTION-HEIGHT)
                   (/ SIDEBAR-WIDTH 3) ACTION-HEIGHT)))

  (define (opt-object-title object)
    (if object
        (symbol->string (handle-tag object))
        "N/A"))

  (define (draw-view easel view)
    (let* ([bounds (get-bounds easel view)])
      (recur loop ([i (bounds-min-object bounds)])
        (when (<= i (bounds-max-object bounds))
          (draw-object easel view bounds i)
          (loop (+ i 1))))
      (recur loop ([j (bounds-min-action bounds)])
        (when (<= j (bounds-max-action bounds))
          (draw-action easel view bounds j)
          (loop (+ j 1))))))

  (define (get-bounds easel view)
    (let*-values ([(bbox-min-x bbox-min-y bbox-max-x bbox-max-y)
                   (send easel get-bbox)])
      (let* ([bbox-min-object
              (inexact->exact (floor (/ bbox-min-x OBJECT-WIDTH)))]
             [bbox-min-action
              (inexact->exact (floor (/ bbox-min-y ACTION-HEIGHT)))]
             [bbox-max-object
              (inexact->exact (ceiling (/ bbox-max-x OBJECT-WIDTH)))]
             [bbox-max-action
              (inexact->exact (ceiling (/ bbox-max-y ACTION-HEIGHT)))]
             [objects (view-count-objects view)]
             [actions (view-count-actions view)]
             [view-min-object 0]
             [view-min-action 0]
             [view-max-object (- objects 1)]
             [view-max-action (- actions 1)]
             [view-min-x 0]
             [view-min-y 0]
             [view-max-x (* objects OBJECT-WIDTH)]
             [view-max-y (* actions ACTION-HEIGHT)])
        (make-bounds (max bbox-min-x view-min-x)
                     (min bbox-max-x view-max-x)
                     (max bbox-min-y view-min-y)
                     (min bbox-max-y view-max-y)
                     (max bbox-min-object view-min-object)
                     (min bbox-max-object view-max-object)
                     (max bbox-min-action view-min-action)
                     (min bbox-max-action view-max-action)))))

  (define (draw-object easel view bounds index)
    (let* ([object (view-get-object view index)]
           [start (- (view-object-origin view object) 1)]
           [finish (view-count-actions view)])
      (when (<= start (bounds-max-action bounds))
        (let* ([x (mid-x-of index)]
               [y1 (bound-y (mid-y-of start) bounds)]
               [y2 (bound-y (top-of finish) bounds)])
          (send easel paint-pict x y1 (pip-line 0 (- y2 y1) 0))))))

  (define (draw-action easel view bounds index)
    (draw-action-arrow easel view bounds index)
    (draw-action-control easel view bounds index)
    (draw-action-label easel view bounds index))

  (define (draw-action-label easel view bounds index)
    (let* ([action (view-get-action view index)]
           [source (action-source action)]
           [target (action-target action)]
           [source-index (obj-index view source)]
           [target-index (obj-index view target)]
           [source-index (or source-index (- target-index 1/2))]
           [target-index (or target-index (- source-index 1/2))]
           [start-index (min source-index target-index)]
           [finish-index (max source-index target-index)])
      (when (and (<= start-index (bounds-max-object bounds))
                 (>= finish-index (bounds-min-object bounds)))
        (let* ([label (action-label action)]
               [pict (standard-text label)]
               [x (+ (bound-x (mid-x-of start-index) bounds)
                     LABEL-HORIZONTAL-GAP)]
               [y (- (mid-y-of index) (pict-height pict) LABEL-VERTICAL-GAP)])
          (send easel paint-pict x y pict)))))

  (define short-action-label
    (match-lambda
      [(? action:new?) "new"]
      [(? action:call?) "call"]
      [(? action:return?) "return"]
      [(? action:get?) "get"]
      [(? action:set?) "set"]
      [(? action:inspect?) "inspect"]))

  (define action-label
    (match-lambda
      [(struct action:new (t o i object fields))
       (format "new ~a(~a)"
               (class-name (object-class object))
               (comma-separated (map field->string fields)))]
      [(struct action:call (t o i receiver method arguments))
       (format "call ~a.~a(~a)"
               (handle->string receiver)
               method
               (comma-separated (map handle->string arguments)))]
      [(struct action:return (t o i returned-values))
       (format "return ~a"
               (comma-separated (map handle->string returned-values)))]
      [(struct action:get (t o i receiver field))
       (format "get ~a.~a"
               (handle->string receiver)
               field)]
      [(struct action:set (t o i receiver field value))
       (format "set ~a.~a = ~a"
               (handle->string receiver)
               field
               (handle->string value))]
      [(struct action:inspect (t o i receiver))
       (format "inspect ~a"
               (handle->string receiver))]))

  (define class-pattern (regexp "^class:"))

  (define (class-name class%)
    (let* ([name (object-name class%)])
      (if name
          (regexp-replace class-pattern (format "~a" name) "")
          "<unknown>")))

  (define (field->string field)
    (format "~a=~a" (first field) (handle->string (second field))))

  (define (comma-separated strings)
    (if (null? strings) ""
        (recur loop ([strings strings])
          (match strings
            [(list str) str]
            [(cons str rest) (format "~a,~a" str (loop rest))]))))

  (define (draw-action-control easel view bounds index)
    (let* ([action (view-get-action view index)]
           [from (obj-index
                  view
                  (action:stack-frame-control
                   (action:action-control-in action)))]
           [to (obj-index
                view
                (action:stack-frame-control
                 (action:action-control-out action)))])
      (draw-action-control-in easel bounds index from)
      (draw-action-control-transfer easel bounds index from to)
      (draw-action-control-out easel bounds index to)))

  (define (draw-action-control-in easel bounds action object)
    (when (and object (<= (bounds-min-object bounds)
                          object
                          (bounds-max-object bounds)))
      (let* ([x (mid-x-of object)]
             [y1 (top-of action)]
             [y2 (mid-y-of action)])
        (draw-control easel x y1 0 (- y2 y1)))))

  (define (draw-action-control-transfer easel bounds action from to)
    (when (and from to)
      (let*-values ([(left right)
                     (if (< from to) (values from to) (values to from))])
        (when (and (<= left (bounds-max-object bounds))
                   (>= right (bounds-min-object bounds)))
          (let* ([x1 (bound-x (mid-x-of left) bounds)]
                 [x2 (bound-x (mid-x-of right) bounds)]
                 [y (mid-y-of action)])
            (draw-control easel x1 y (- x2 x1) 0))))))

  (define (draw-action-control-out easel bounds action object)
    (when (and object (<= (bounds-min-object bounds)
                          object
                          (bounds-max-object bounds)))
      (let* ([x (mid-x-of object)]
             [y1 (mid-y-of action)]
             [y2 (bottom-of action)])
        (draw-control easel x y1 0 (- y2 y1)))))

  (define (draw-control easel x y w h)
    (let* ([offset (/ CONTROL-THICKNESS 2)])
      (send easel paint-pict
            (- x offset) (- y offset)
            (filled-rectangle (+ w CONTROL-THICKNESS)
                              (+ h CONTROL-THICKNESS)))))
  
  (define (draw-action-arrow easel view bounds index)
    (let* ([action (view-get-action view index)]
           [source (obj-index view (action-source action))]
           [target (obj-index view (action-target action))])
      (cond
       [(and (not source) (not target))
        (error 'draw-action-arrow "action involves no objects")]
       [(not source)
        (draw-action-arrow-incoming easel bounds index target)]
       [(not target)
        (draw-action-arrow-outgoing easel bounds index source)]
       [(= source target)
        (draw-action-arrow-self easel bounds index source)]
       [else
        (draw-action-arrow-normal easel bounds index source target)])))

  (define (draw-action-arrow-incoming easel bounds action object)
    (when (<= (bounds-min-object bounds) object (bounds-max-object bounds))
      (let* ([x (mid-x-of object)]
             [y (mid-y-of action)]
             [length (/ OBJECT-WIDTH 4)])
        (draw-squiggle easel (- x length) y)
        (send easel paint-pict
              (- x length) y
              (pip-arrow-line length 0 ARROWHEAD-SIZE)))))

  (define (draw-action-arrow-outgoing easel bounds action object)
    (when (<= (bounds-min-object bounds) object (bounds-max-object bounds))
      (let* ([x (mid-x-of object)]
             [y (mid-y-of action)]
             [length (/ OBJECT-WIDTH 4)])
        (draw-squiggle easel (- x length) y)
        (send easel paint-pict x y
              (pip-arrow-line (- length) 0 ARROWHEAD-SIZE)))))

  (define (draw-action-arrow-self easel bounds action object)
    (when (<= (bounds-min-object bounds) object (bounds-max-object bounds))
      (let* ([x (mid-x-of object)]
             [y (mid-y-of action)])
        (send easel paint-pict (+ x 1) y
              (pip-arrow-line -1 0 ARROWHEAD-SIZE)))))

  (define (draw-action-arrow-normal easel bounds action source target)
    (when (and (<= (min source target) (bounds-max-object bounds))
               (>= (max source target) (bounds-min-object bounds)))
      (let* ([x1 (bound-x (mid-x-of source) bounds)]
             [x2 (bound-x (mid-x-of target) bounds)]
             [y (mid-y-of action)])
        (send easel paint-pict x1 y
              (pip-arrow-line (- x2 x1) 0 ARROWHEAD-SIZE)))))

  (define (draw-squiggle easel x y)
    (let* ([half (/ SQUIGGLE-SIZE 2)]
           [quarter (/ half 2)])
      (send easel paint-pict
            (+ x (- quarter)) (+ y (- half))
            (pip-line half SQUIGGLE-SIZE 0))
      (send easel paint-pict
            (+ x (- half)) (+ y (- half))
            (pip-line half SQUIGGLE-SIZE 0))))

  (define (standard-text string)
    (text string 'default DEFAULT-TEXT-SIZE))

  (define (left-of object) (* object OBJECT-WIDTH))
  (define (right-of object) (* (+ object 1) OBJECT-WIDTH))
  (define (mid-x-of object) (* (+ object 1/2) OBJECT-WIDTH))

  (define (top-of action) (* action ACTION-HEIGHT))
  (define (bottom-of action) (* (+ action 1) ACTION-HEIGHT))
  (define (mid-y-of action) (* (+ action 1/2) ACTION-HEIGHT))

  (define (view-width view) (* (view-count-objects view) OBJECT-WIDTH))
  (define (view-height view) (* (view-count-actions view) ACTION-HEIGHT))

  (define SCROLLBAR-WIDTH 19)
  (define DEFAULT-TEXT-SIZE 10)
  
  (define SIDEBAR-WIDTH 120)
  (define HEADER-HEIGHT 50)
  (define ARROW-HEIGHT 8)
  (define ARROW-WIDTH 20)

  (define OBJECT-WIDTH 80)
  (define ACTION-HEIGHT 30)
  (define LABEL-VERTICAL-GAP 6)
  (define LABEL-HORIZONTAL-GAP 6)
  (define ARROWHEAD-SIZE 8)
  (define SQUIGGLE-SIZE 12)
  (define CONTROL-THICKNESS 4)

  (define (center-pict pict easel x y w h)
    (send easel paint-pict
          (+ x (- (/ w 2) (/ (pict-width pict) 2)))
          (+ y (- (/ h 2) (/ (pict-height pict) 2)))
          pict))

  (define (obj-index view object) (and object (view-object-index view object)))

  (define (curry f . args) (lambda rest (apply f (append args rest))))

  )