(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" (prefix action: "../model/action.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 next-action ([j (bounds-min-action bounds)]) (when (<= j (bounds-max-action bounds)) (recur next-object ([i (bounds-min-object bounds)]) (when (<= i (bounds-max-object bounds)) (draw-object easel view bounds i j) (next-object (+ i 1)))) (draw-action easel view bounds j) (next-action (+ 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 i j) (let* ([object (view-get-object view i)] [action (view-get-action view j)] [origin (- (view-object-origin view object) 1)] [now (action:action-timestamp action)]) (cond [(< now origin) (void)] [(= now origin) (send easel paint-pict (mid-x-of i) (mid-y-of j) (pip-line 0 (/ ACTION-HEIGHT 2) 0))] [(> now origin) (send easel paint-pict (mid-x-of i) (top-of j) (pip-line 0 ACTION-HEIGHT 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)))) )