#lang racket/base
(require racket/list 
         racket/class 
         racket/draw
         slideshow/pict
         data/interval-map
         "visualizer-data.rkt" 
         "graph-drawing.rkt" 
         "drawing-helpers.rkt"
         "display.rkt" 
         "constants.rkt")

(provide timeline-pict 
         timeline-pict-for-trace-data 
         timeline-overlay 
         seg-in-vregion 
         calc-segments 
         calc-ticks
         calc-row-mid-y 
         find-seg-for-coords 
         segment-edge
         segs-equal-or-later
         creation-tree-pict
         draw-creategraph-pict 
         zoom-level->factor
         graph-overlay-pict
         (struct-out segment) 
         (struct-out frame-info) 
         (struct-out timeline-tick) 
         find-node-for-coords
         find-fid-for-coords
         first-seg-for-fid)

;Represents a dot or square on the timeline
(struct segment (event
                 x 
                 y 
                 width 
                 height 
                 color 
                 p 
                 prev-future-seg
                 next-future-seg 
                 prev-proc-seg
                 next-proc-seg  
                 prev-targ-future-seg
                 next-targ-future-seg) #:transparent #:mutable)


;General information about the timeline image
(struct frame-info (adjusted-width 
                    adjusted-height
                    row-height 
                    modifier 
                    timeline-ticks
                    process-line-coords) #:transparent)

;Represents a vertical line depicting a specific time in the execution history
(struct timeline-tick (x 
                       abs-time
                       rel-time 
                       show-label?) #:transparent) 

;;viewable-region-from-frame : frame-info -> viewable-region
(define (viewable-region-from-frame finfo) 
  (viewable-region 0 
                   0 
                   (frame-info-adjusted-width finfo) 
                   (frame-info-adjusted-height finfo)))

;;seg-in-vregion : viewable-region segment -> bool
(define (seg-in-vregion vregion)
  (λ (seg) 
    (in-viewable-region vregion 
                        (segment-x seg) 
                        (segment-y seg) 
                        (segment-width seg) 
                        (segment-height seg))))

;;calc-seg-x : event process-timeline trace uint float -> uint
(define (calc-seg-x evt tr modifier) 
  (floor (* (relative-time tr (event-start-time evt)) 
            modifier)))

;;calc-seg-width : float event -> uint
(define (calc-seg-width modifier evt)
  (case (event-type evt) 
    [(start-work start-0-work) (max MIN-SEG-WIDTH (* modifier (- (event-end-time evt) 
                                                                 (event-start-time evt))))] 
    [else MIN-SEG-WIDTH]))

;Finds the segment for given x and y mouse coordinates
;;find-seg-for-coords : uint uint interval-map -> segment
(define (find-seg-for-coords x y index) 
  (let ([xmap (interval-map-ref index y #f)]) 
    (if xmap 
        (interval-map-ref xmap x #f) 
        #f)))

;;find-fid-for-coords : uint uint (listof drawable-node) -> drawable-node
(define (find-node-for-coords x y nodes) 
  (define node-l (filter (λ (n)
                               (define n-x (drawable-node-x n))
                               (define n-y (drawable-node-y n))
                               (define n-w (drawable-node-width n))
                               (and (n-x . < . x)
                                    (n-y . < . y)
                                    (x . < . (+ n-x n-w))
                                    (y . < . (+ n-y n-w))))
                          (remove-duplicates (flatten nodes))))
  (cond 
    [(empty? node-l) 
     #f] 
    [(= 1 (length node-l)) 
     (car node-l)] 
    [else 
     (error 'find-node-for-coords "Multiple nodes found for coords: ~s ~s, ~s" x y node-l)]))

;;find-fid-for-coords : x y ??(listof (listof nodes)) by depth?? viewable-region -> fid
(define (find-fid-for-coords x y nodes vregion)
  (define n (find-node-for-coords x y nodes)) 
  (if n 
      (event-user-data (node-data (drawable-node-node n))) 
      #f))

;;first-seg-for-fid : future-id (listof segments) -> segment
(define (first-seg-for-fid fid segs)
  (first
   (sort
    (filter (λ (s) (define seg-fid (event-future-id (segment-event s)))
              (and seg-fid fid (= fid seg-fid))) segs)
    < #:key (λ (s) (event-start-time (segment-event s))))))

;;calc-adjusted-width : uint trace -> uint
(define (calc-adjusted-width w tr) 
  (define baseModifier (/ w (- (trace-end-time tr) (trace-start-time tr)))) 
  (define max-x-extent (for*/fold ([x 0]) ([tl (in-list (trace-proc-timelines tr))] 
                                           [evt (in-list (process-timeline-events tl))]) 
                         (max (+ (calc-seg-x evt tr baseModifier) 
                                 (calc-seg-width baseModifier evt))  
                              x))) 
  (- (- w (- max-x-extent w)) MIN-SEG-WIDTH))

;;calc-row-mid-y : uint uint -> uint
(define (calc-row-mid-y proc-index row-height) 
  (floor (- (+ (* proc-index 
                  row-height) 
               (/ row-height 2)) 
            2)))

;Gets the center of a circle with (xleft, ytop) as the top-left coordinate.
;;calc-center : uint uint uint -> (values uint uint)
(define (calc-center xleft ytop diameter) 
  (let ([rad (floor (/ diameter 2))]) 
    (values (+ xleft rad) 
            (+ ytop rad))))

;;segs-equal-or-after : float (listof segment) -> (listof segment)
(define (segs-equal-or-later real-time segs)
  (let loop ([sgs segs]) 
    (cond 
      [(null? sgs) '()] 
      [(>= (event-start-time (segment-event (car sgs))) real-time) sgs] 
      [else (loop (cdr sgs))])))  

;;segment-edge : segment -> uint
(define (segment-edge seg) 
  (define evt (segment-event seg)) 
  (if (event-has-duration? evt) 
      (segment-x seg)
      (+ (segment-x seg) (segment-width seg))))

(define (find-most-recent-and-next segs time)
  (let loop ([ss segs])
    (cond
      [(empty? (cddr ss))
       (values (first ss) (second ss) ss)]
      [(> (event-start-time (segment-event (second ss))) time)
       (values (first ss) (second ss) ss)]
      [else
       (loop (cdr ss))])))

;;timeline-tick-label-pict : real -> pict
(define (timeline-tick-label-pict rel-time) 
  (text-block-pict (format "~a ms" (real->decimal-string rel-time)) 
                   #:backcolor (timeline-tick-label-backcolor) 
                   #:forecolor (timeline-tick-label-forecolor) 
                   #:padding 3))

;;calc-ticks : (listof segment) float trace -> (listof timeline-tick)
(define (calc-ticks segs timeToPixMod tr)
  (define LABEL-PAD 3)
  (define trace-start (inexact->exact (trace-start-time tr)))
  (define segs-len (length segs)) 
  (define-values (lt lx tks _ __) 
    (for/fold ([last-time trace-start] 
               [last-x 0]
               [ticks '()]
               [last-label-x-extent 0]
               [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) 
                                                         trace-start) 
                                                      DEFAULT-TIME-INTERVAL)))]) 
      #;(define tick-time (+ last-time DEFAULT-TIME-INTERVAL)) 
      (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL))
      (define tick-time (+ trace-start tick-rel-time))
      (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod)))
      (define-values (most-recent-seg next-seg r-segs)
        (find-most-recent-and-next remain-segs tick-time))
      (define most-recent-evt (segment-event most-recent-seg))
      (define most-recent-time (inexact->exact (event-start-time most-recent-evt)))
      (define next-evt (segment-event next-seg))
      (define next-evt-time (inexact->exact (event-start-time next-evt)))
      (define most-recent-edge (segment-edge most-recent-seg)) 
      (define next-edge (segment-x next-seg))
      (define tick-x 
        (cond 
          [(= most-recent-time tick-time) (segment-x most-recent-seg)] 
          [(= (segment-x next-seg) (add1 (+ (segment-x most-recent-seg) (segment-width most-recent-seg)))) 
           (+ (segment-x most-recent-seg) (segment-width most-recent-seg))] 
          [else 
           (define start-x (max most-recent-edge last-x))
           (define start-time (max most-recent-time last-time))
           (define size-mod (/ (- next-edge start-x) (- next-evt-time start-time)))
           (define x-offset (ceiling (* (- tick-time start-time) size-mod)))
           (round (+ start-x x-offset))]))
      (define show-tick? ((- tick-x last-x) . >= . TIMELINE-MIN-TICK-PADDING))
      (define show-label? 
        (if (not show-tick?) 
            #f 
            (>= tick-x (+ last-label-x-extent LABEL-PAD))))
      (define new-label-x-extent 
        (if show-label? 
            (+ tick-x (pict-width (timeline-tick-label-pict tick-rel-time)))
            last-label-x-extent))
      (if show-tick? 
          (values tick-time 
                  tick-x 
                  (cons (timeline-tick tick-x tick-time tick-rel-time show-label?) ticks) 
                  new-label-x-extent 
                  r-segs) 
          (values tick-time 
                  last-x 
                  ticks 
                  new-label-x-extent 
                  r-segs))))
  tks)

;;calc-process-timespan-lines : trace (listof segment) -> (listof (uint . uint))
(define (calc-process-timespan-lines trace segs) 
  (for/list ([tl (in-list (trace-proc-timelines trace))]) 
    (let ([segs (filter (λ (s) (= (process-timeline-proc-id tl) 
                                  (event-proc-id (segment-event s)))) 
                        segs)]) 
      (cons (segment-x (car segs)) 
            (segment-x (last segs))))))

;;get-first-future-seg : seg -> seg
(define (get-first-future-seg seg) 
  (let loop ([cur seg]) 
    (if (segment-prev-future-seg cur) 
        (loop (segment-prev-future-seg cur)) 
        cur)))

;;get-first-future-seg-in-region : viewable-region segment -> segment
(define (get-first-future-seg-in-region vregion seg)
  (define prev-seg (get-seg-previous-to-vregion vregion seg))
    (if ((seg-in-vregion vregion) prev-seg)
        prev-seg
        (segment-next-future-seg prev-seg)))

;; get-seg-previous-to-vregion : viewable-region segment -> segment
(define (get-seg-previous-to-vregion vregion seg)
  (define first-seg
    (let loop ([cur seg])
      (define prev (segment-prev-future-seg cur))
      (if (not prev)
          cur
          (loop prev))))
  (let loop ([cur first-seg])
    (define next (segment-next-future-seg cur))
    (if (or (not next)
            (> (segment-x next) (viewable-region-x vregion)))
        cur
        (loop next))))

  
;;adjust-work-segs! : (listof segment) -> void
(define (adjust-work-segs! segs) 
  (for ([seg (in-list segs)]) 
    (case (event-type (segment-event seg)) 
      [(start-work start-0-work) 
       (set-segment-width! seg (max MIN-SEG-WIDTH 
                                    (- (segment-x (segment-next-proc-seg seg)) (segment-x seg))))] 
      [else 
       void])))

;;connect-segments! : (listof segment) -> void
(define (connect-segments! segs) 
  (for ([s (in-list segs)]) 
    (let ([evt (segment-event s)])
      (set-segment-prev-proc-seg! s (if (event-prev-proc-event evt) 
                                        (event-segment (event-prev-proc-event evt)) 
                                        #f)) 
      (set-segment-next-proc-seg! s (if (event-next-proc-event evt) 
                                        (event-segment (event-next-proc-event evt))
                                        #f)) 
      (set-segment-prev-future-seg! s (if (event-prev-future-event evt) 
                                          (event-segment (event-prev-future-event evt)) 
                                          #f))
      (set-segment-next-future-seg! s (if (event-next-future-event evt) 
                                          (event-segment (event-next-future-event evt)) 
                                          #f)) 
      (set-segment-prev-targ-future-seg! s (if (event-prev-targ-future-event evt) 
                                               (event-segment (event-prev-targ-future-event evt)) 
                                               #f)) 
      (set-segment-next-targ-future-seg! s (if (event-next-targ-future-event evt) 
                                               (event-segment (event-next-targ-future-event evt)) 
                                               #f)))))

;;build-seg-layout : flonum (listof event) trace -> (values (listof segment) uint uint)
(define (build-seg-layout timeToPixModifier events tr)
  (define last-right-edges (build-vector (length (trace-proc-timelines tr)) (λ (n) 0)))
  (define-values (sgs d x-extent)
    (for/fold ([segs '()]
               [delta 0]
               [largest-x 0]) ([evt (in-list events)])
      (define last-right-edge (vector-ref last-right-edges (event-proc-index evt)))
      (define wanted-offset (+ delta (* DEFAULT-TIMELINE-WIDTH
                                        (inexact->exact 
                                         (/ (- (event-start-time evt) (trace-start-time tr))
                                            (- (trace-end-time tr) (trace-start-time tr)))))))
      (define-values (offset new-delta) 
        (if (last-right-edge . <= . wanted-offset) 
            (values wanted-offset delta)
            (values last-right-edge (+ delta (- last-right-edge wanted-offset)))))
      (define radius (/ MIN-SEG-WIDTH 2))
      (define segw MIN-SEG-WIDTH)
      (define seg (segment evt 
                           (round offset) 
                           (- (calc-row-mid-y (event-proc-index evt) TIMELINE-ROW-HEIGHT) radius)
                           segw
                           MIN-SEG-WIDTH 
                           (get-event-color (event-type evt)) 
                           #f 
                           #f 
                           #f 
                           #f 
                           #f 
                           #f 
                           #f)) 
      (set-event-segment! evt seg)
      (vector-set! last-right-edges (event-proc-index evt) (+ offset segw))
      (values (cons seg segs)
              new-delta
              (max largest-x last-right-edge))))
  (values sgs x-extent))

;;calc-segments : trace uint uint -> (values frame-info (listof segment))
(define (calc-segments tr) 
  (define evts (trace-all-events tr))
  (define timeToPixModifier (/ DEFAULT-TIMELINE-WIDTH (- (trace-end-time tr) (trace-start-time tr))))
  (define-values (segments x) 
    (build-seg-layout timeToPixModifier evts tr))
  (define ordered-segs (reverse segments))
  (connect-segments! ordered-segs)
  (adjust-work-segs! ordered-segs)
  (define ticks (calc-ticks ordered-segs timeToPixModifier tr))
  (values (frame-info (+ MIN-SEG-WIDTH (round x)) 
                      (* TIMELINE-ROW-HEIGHT (length (trace-proc-timelines tr)))
                      TIMELINE-ROW-HEIGHT 
                      timeToPixModifier 
                      ticks
                      (calc-process-timespan-lines tr ordered-segs)) 
          ordered-segs))

;;pict-for-segment : segment -> pict
(define (pict-for-segment seg) 
  (unless (segment-p seg)
    (set-segment-p! seg (if (event-has-duration? (segment-event seg)) 
                            (rect-pict (segment-color seg)
                                       (timeline-event-strokecolor) 
                                       (segment-width seg) 
                                       MIN-SEG-WIDTH 
                                       #:stroke-width .5) 
                            (circle-pict (segment-color seg) 
                                         (timeline-event-strokecolor) 
                                         MIN-SEG-WIDTH  
                                         #:stroke-width .5)))) 
  (segment-p seg))

;;draw-ruler-on : pict viewable-region frameinfo -> pict
(define (draw-ruler-on base vregion frameinfo)
  (for/fold ([pct base]) ([tick (in-list (filter (λ (t) (in-viewable-region-horiz vregion (timeline-tick-x t))) 
                                                 (frame-info-timeline-ticks frameinfo)))])
    (define cur-x (timeline-tick-x tick))
    (define pinnedline 
      (pin-over pct 
                (- cur-x (viewable-region-x vregion)) 
                0 
                (linestyle 'dot 
                           (colorize (vline 1 
                                            (frame-info-adjusted-height frameinfo)) 
                                     (timeline-tick-color)))))
    (if (timeline-tick-show-label? tick)
        (pin-over pinnedline 
                  (- cur-x (viewable-region-x vregion)) 
                  3 
                  (timeline-tick-label-pict (timeline-tick-rel-time tick)))
        pinnedline)))

;;draw-row-lines-on : pict viewable-region trace frameinfo -> pict
(define (draw-row-lines-on base vregion tr finfo opacity) 
  (pin-over base 
            0 
            0
            (for/fold ([pct base]) ([tl (in-list (trace-proc-timelines tr))] 
                                    [i (in-naturals)])
              (let* ([line-coords (list-ref (frame-info-process-line-coords finfo) 
                                           (process-timeline-proc-index tl))]
                     [line-start (car line-coords)] 
                     [line-end (cdr line-coords)]
                     [vregion-start (viewable-region-x vregion)] 
                     [vregion-end (viewable-region-x-extent vregion)]
                     [start-x (cond 
                                [(< line-start vregion-start) 0] 
                                [(between line-start vregion-start vregion-end) 
                                 (- line-start vregion-start)] 
                                [else vregion-end])]
                     [end-x (cond 
                              [(< line-end vregion-start) 0] 
                              [(between line-end vregion-start vregion-end) 
                               (- line-end vregion-start)] 
                              [else vregion-end])]
                     [proc-name (if (zero? i) 
                                    "Thread 0 (Runtime Thread)" 
                                    (format "Thread ~a" (process-timeline-proc-id tl)))]
                     [proc-title (text-block-pict proc-name 
                                                  #:backcolor (header-backcolor) 
                                                  #:forecolor (header-forecolor) 
                                                  #:padding HEADER-PADDING
                                                  #:opacity opacity 
                                                  #:width (viewable-region-width vregion))]) 
                (draw-stack-onto pct 
                                 (at 0 
                                     (- (* (add1 i) (frame-info-row-height finfo)) (viewable-region-y vregion)) 
                                     (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) 
                                 (at 0  
                                     (+ (+ (- (* i (frame-info-row-height finfo)) (viewable-region-y vregion)) 
                                           (- (frame-info-row-height finfo) (pict-height proc-title))) 
                                        1) 
                                     proc-title) 
                                 (at start-x 
                                     (- (calc-row-mid-y (process-timeline-proc-index tl) (frame-info-row-height finfo))
                                        (viewable-region-y vregion))
                                     (colorize (hline (- end-x start-x) 1) 
                                               (timeline-event-baseline-color))))))))

;Magnifies a segment's pict (dot or square) to make 
;it stand out when hovered over with the mouse pointer.
;;make-stand-out-pict : segment -> pict
(define (make-stand-out-pict seg) 
  (case (event-type (segment-event seg)) 
    [(start-work start-0-work) (scale (pict-for-segment seg) 1 2)] 
    [else (scale (pict-for-segment seg) 2)]))

;;frame-bg : viewable-region frame-info trace -> pict
(define (frame-bg vregion finfo tr)
  (draw-frame-bg-onto (colorize (filled-rectangle (viewable-region-width vregion) 
                                                  (frame-info-adjusted-height finfo)) 
                                (timeline-frame-bg-color))
                      vregion                                
                      finfo 
                      tr 
                      TIMELINE-HEADER-OPACITY))

;;draw-frame-bg-onto : pict viewable-region frameinfo trace -> pict
(define (draw-frame-bg-onto base vregion finfo tr opacity) 
  (let ([with-ruler (draw-ruler-on base vregion finfo)])
    (draw-row-lines-on with-ruler vregion tr finfo opacity)))

;;draw-connection : viewable-region segment segment pict string [uint bool symbol] -> pict
(define (draw-connection vregion 
                         start 
                         end 
                         base-pct 
                         color 
                         #:width [width 1] 
                         #:with-arrow [with-arrow #f] 
                         #:style [style 'solid]) 
  (let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion)) 
                                          (- (segment-y start) (viewable-region-y vregion)) 
                                          MIN-SEG-WIDTH)] 
                [(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion)) 
                                            (- (segment-y end) (viewable-region-y vregion)) 
                                            MIN-SEG-WIDTH)] 
                [(dx dy) (values (- nextx midx) (- nexty midy))]) 
    (if (and (zero? dy) 
             (or (not (eq? (segment-next-proc-seg start) end)) 
                 (< dx CONNECTION-LINE-HAT-THRESHOLD))) 
        (let* ([dxa (/ dx 2)]  
               [dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)] 
               [breakx (+ midx dxa)] 
               [breaky (+ midy dya)])
          (draw-line-onto (draw-line-onto base-pct 
                                          midx 
                                          midy 
                                          breakx 
                                          breaky 
                                          color 
                                          #:width width
                                          #:style style) 
                          breakx 
                          breaky 
                          nextx 
                          nexty 
                          color 
                          #:width width 
                          #:with-arrow with-arrow 
                          #:style style))
        (draw-line-onto base-pct 
                        midx 
                        midy 
                        nextx 
                        nexty 
                        color 
                        #:width width 
                        #:with-arrow with-arrow 
                        #:style style))))

;;timeline-pict : (listof indexed-future-event) [viewable-region] [integer] -> pict
(define (timeline-pict logs 
                       #:x [x #f]
                       #:y [y #f]
                       #:width [width #f] 
                       #:height [height #f]
                       #:selected-event-index [selected-event-index #f]) 
  (define tr (build-trace logs))
  (define-values (finfo segments) (calc-segments tr))
  (define vregion (if x 
                      (viewable-region x y width height) 
                      (viewable-region 0 0 (frame-info-adjusted-width finfo) (frame-info-adjusted-height finfo))))
  (timeline-pict-for-trace-data vregion 
                                tr 
                                finfo 
                                segments 
                                #:selected-event-index selected-event-index))

;;timeline-pict : (or viewable-region #f) trace frame-info (listof segment) -> pict
(define (timeline-pict-for-trace-data vregion 
                                      tr 
                                      finfo 
                                      segments 
                                      #:selected-event-index [selected-event-index #f]) 
  (define vr (if (not vregion) 
                 (viewable-region 0 
                                  0 
                                  (frame-info-adjusted-width finfo) 
                                  (frame-info-adjusted-height finfo)) 
                 vregion))
  (define tp (for/fold ([pct (frame-bg vr finfo tr)]) 
               ([seg (in-list (filter (seg-in-vregion vr) segments))])                 
               (pin-over pct
                         (- (segment-x seg) (viewable-region-x vr)) 
                         (- (segment-y seg) (viewable-region-y vr)) 
                         (pict-for-segment seg))))  
  (cond 
    [selected-event-index 
     (define overlay (timeline-overlay vregion
                                              #f 
                                              (list-ref segments selected-event-index) 
                                              finfo 
                                              tr)) 
     (pin-over tp 
               0 
               0 
               overlay)] 
    [else tp]))

;;draw-arrows : pict viewable-region segment -> pict
(define (draw-arrows base-pct vregion seg) 
  (let ([fst (get-seg-previous-to-vregion vregion seg)])
    (let loop ([pct base-pct] 
               [cur-seg fst])
        (if (not cur-seg)
            pct 
            (let ([next (segment-next-future-seg cur-seg)])
              (let* ([next-targ (segment-next-targ-future-seg cur-seg)] 
                     [prev-targ (segment-prev-targ-future-seg cur-seg)]              
                     [ftl-arrows (if (not next) 
                                     pct 
                                     (draw-connection vregion 
                                                      cur-seg 
                                                      next 
                                                      pct 
                                                      (event-connection-line-color) 
                                                      #:width 2))] 
                     [prev-targ-arr (if (not prev-targ) 
                                        ftl-arrows 
                                        (draw-connection vregion 
                                                         prev-targ 
                                                         cur-seg 
                                                         ftl-arrows 
                                                         (event-target-future-line-color) 
                                                         #:with-arrow #t 
                                                         #:style 'dot))] 
                     [next-targ-arr (if (not next-targ) 
                                        prev-targ-arr 
                                        (draw-connection vregion 
                                                         cur-seg 
                                                         next-targ 
                                                         prev-targ-arr 
                                                         (event-target-future-line-color) 
                                                         #:with-arrow #t 
                                                         #:style 'dot))])
                (if (and next 
                         ((seg-in-vregion vregion) next))
                    (loop next-targ-arr next)
                    next-targ-arr)))))))

;Draws the pict that is layered on top of the exec. timeline canvas 
;to highlight a specific future's event sequence
;;timeline-overlay : uint uint (or segment #f) (or segment #f) frame-info trace -> pict
(define (timeline-overlay vregion tacked hovered finfo tr)
  (define-values (width height) (values (viewable-region-width vregion) 
                                        (viewable-region-height vregion)))
  (define base (blank (viewable-region-width vregion) 
                      (viewable-region-height vregion))) 
  (define-values (seg-with-arrows showing-tacked) 
    (if tacked (values tacked #t) (values hovered #f)))
  (if seg-with-arrows 
      (let* ([bg base] 
             [aseg-rel-x (- (segment-x seg-with-arrows) (viewable-region-x vregion))] 
             [aseg-rel-y (- (segment-y seg-with-arrows) (viewable-region-y vregion))]
             [line (pin-over bg
                             (- (+ aseg-rel-x 
                                   (/ (segment-width seg-with-arrows) 2)) 
                                2)
                             0
                             (colorize (vline 1 height) (hover-tickline-color)))]
             [bigger (make-stand-out-pict seg-with-arrows)]
             [width-dif (/ (- (pict-width bigger) (segment-width seg-with-arrows)) 2)]
             [height-dif (/ (- (pict-height bigger) (segment-height seg-with-arrows)) 2)]
             [magnified (pin-over line 
                                  (- aseg-rel-x width-dif)
                                  (- aseg-rel-y height-dif) 
                                  bigger)] 
             [hover-magnified (if (and showing-tacked 
                                       hovered 
                                       (not (eq? hovered tacked)))
                                  (let* ([hmag (make-stand-out-pict hovered)] 
                                         [hwidth-dif (/ (- (pict-width hmag)
                                                           (pict-width (pict-for-segment hovered)))
                                                        2)] 
                                         [hheight-dif (/ (- (pict-height hmag)
                                                            (pict-height (pict-for-segment hovered)))
                                                         2)])
                                    (pin-over magnified 
                                              (- (- (segment-x hovered) (viewable-region-x vregion)) hwidth-dif) 
                                              (- (- (segment-y hovered) (viewable-region-y vregion)) hheight-dif)
                                              hmag)) 
                                  magnified)] 
             [arrows (draw-arrows hover-magnified vregion seg-with-arrows)])
        arrows)
      base))

;Draw a line from one node on the creation graph to another
;;line-from : drawable-node drawable-node pict viewable-region -> pict
(define (line-from start end pct minx miny) 
  (define par-center (drawable-node-center start))
  (define child-center (drawable-node-center end))
  (draw-line-onto pct 
                  (- (point-x par-center) minx)
                  (- (point-y par-center) miny)
                  (- (point-x child-center) minx)  
                  (- (point-y child-center) miny) 
                  (create-graph-edge-color) 
                  #:width 1
                  #:style 'dot))

;Draws a circle for a node on the creation graph
;;node-pict : drawable-node -> pict
(define (node-pict dnode) 
  (let* ([ndata (node-data (drawable-node-node dnode))]
         [ntext (if (equal? ndata 'runtime-thread) 
                    "RTT" 
                    (format "~a" (event-user-data ndata)))]) 
    (cc-superimpose (circle-pict (create-graph-node-backcolor) 
                                 (create-graph-node-strokecolor) 
                                 (drawable-node-width dnode)) 
                    (colorize (text ntext) (create-graph-node-forecolor)))))

;;creation-tree-pict : (listof indexed-future-event) [enni] [enni] [enni] [enni] [enni] [enni] [enni] -> pict
(define (creation-tree-pict events 
                             #:x [x #f] 
                             #:y [y #f] 
                             #:width [width #f] 
                             #:height [height #f]
                             #:node-width [node-width #f] 
                             #:padding [padding #f] 
                             #:zoom [zoom CREATE-GRAPH-MIN-ZOOM]) 
  (define tr (build-trace events)) 
  (define node-diam (if node-width 
                        node-width 
                        CREATE-GRAPH-NODE-DIAMETER)) 
  (define graph-padding (if padding 
                            padding 
                            CREATE-GRAPH-PADDING))
  (define layout (draw-tree (trace-creation-tree tr) 
                            #:node-width node-diam 
                            #:padding graph-padding 
                            #:zoom zoom)) 
  (define vregion (if x 
                      (viewable-region x y width height) 
                      #f))
  (draw-creategraph-pict vregion layout))
  

;;draw-creategraph-pict : (or/c viewable-region #f) tree-layout -> pict
;; if vregion is #f, return a pict that includes the entire tree
(define (draw-creategraph-pict vregion layout) 
  (define rt-root (first (graph-layout-nodes layout)))
  (define width (inexact->exact (floor (graph-layout-width layout))))
  (define height (inexact->exact (floor (graph-layout-height layout))))
  (define base (if vregion 
                   (blank (viewable-region-width vregion) (viewable-region-height vregion))
                   (blank)))
  (define minx (if vregion (viewable-region-x vregion) 0))
  (define miny (if vregion (viewable-region-y vregion) 0))
  (define viewable-nodes (if vregion
                             (filter (λ (n) (in-viewable-region vregion 
                                                                (drawable-node-x n) 
                                                                (drawable-node-y n) 
                                                                (drawable-node-width n) 
                                                                (drawable-node-width n))) 
                                     (graph-layout-nodes layout))
                             (graph-layout-nodes layout)))
  (define with-arrows
    (let ([arrow-pct (for/fold ([pct base]) ([node (in-list (graph-layout-nodes layout))])
                       (for/fold ([p pct]) ([child (in-list (drawable-node-children node))]) 
                         (line-from node child p minx miny)))])
      (for/fold ([pct arrow-pct]) ([node (in-list viewable-nodes)]) 
        (pin-over pct 
                  (- (drawable-node-x node) minx) 
                  (- (drawable-node-y node) miny) 
                  (node-pict node)))))
  (if vregion
      with-arrows
      (panorama with-arrows)))

(define (zoom-level->factor zoom-level)
   (+ 1.0 (* (- zoom-level CREATE-GRAPH-DEFAULT-ZOOM) 
                       CREATE-GRAPH-ZOOM-FACTOR)))

;;graph-overlay-pict : drawable-node trace graph-layout -> pict
(define (graph-overlay-pict hover-node tr layout vregion scale-factor) 
  (when hover-node 
    (unless (equal? (node-data (drawable-node-node hover-node)) 'runtime-thread)
      (define fid (event-user-data (node-data (drawable-node-node hover-node))))
      (define ri (hash-ref (trace-future-rtcalls tr) fid (λ () #f)))
      (when ri
        (define block-ops (sort (hash-keys (rtcall-info-block-hash ri)) 
                                > 
                                #:key (λ (p) 
                                        (hash-ref (rtcall-info-block-hash ri) p))))
        (define sync-ops (sort (hash-keys (rtcall-info-sync-hash ri))
                               > 
                               #:key (λ (op) 
                                       (hash-ref (rtcall-info-sync-hash ri) op))))
        (define-values (node-origin-x node-origin-y) 
          (values (* (- (drawable-node-x hover-node) (viewable-region-x vregion)) scale-factor) 
                  (* (- (drawable-node-y hover-node) (viewable-region-y vregion)) scale-factor)))
        (define-values (center-x center-y) 
          (values (+ node-origin-x (/ (* (drawable-node-width hover-node) scale-factor) 2)) 
                  (+ node-origin-y (/ (* (drawable-node-width hover-node) scale-factor) 2))))
        (define x (+ center-x CREATE-GRAPH-NODE-DIAMETER))
        (define-values (pct yacc) 
          (for/fold ([p (pin-over (blank (viewable-region-width vregion) (viewable-region-height vregion)) 
                                  node-origin-x 
                                  node-origin-y 
                                  (scale (node-pict hover-node) scale-factor))] 
                     [yacc node-origin-y])
            ([rtcall (in-list (append (map (λ (op) (cons 'block op)) block-ops) 
                                      (map (λ (op) (cons 'sync op)) sync-ops)))]) 
            (define evt-type (car rtcall)) 
            (define prim (cdr rtcall))
            (define the-hash (if (equal? evt-type 'block) (rtcall-info-block-hash ri) (rtcall-info-sync-hash ri)))
            (define txtp (text-pict (format "~a (~a)" 
                                            (symbol->string prim) 
                                            (hash-ref the-hash prim)) 
                                    #:color (get-event-forecolor evt-type))) 
            (define txtbg (rect-pict (get-event-color evt-type)
                                     (create-graph-edge-color) 
                                     (+ (pict-width txtp) (* TOOLTIP-MARGIN 2)) 
                                     (+ (pict-height txtp) (* TOOLTIP-MARGIN 2)) 
                                     #:stroke-width .5))
            (values 
             (pin-over (draw-line-onto p 
                                       center-x
                                       center-y
                                       x 
                                       yacc 
                                       (create-graph-edge-color))
                       x 
                       yacc 
                       (pin-over txtbg 
                                 TOOLTIP-MARGIN 
                                 TOOLTIP-MARGIN 
                                 txtp)) 
             (+ yacc (pict-height txtbg) CREATE-GRAPH-PADDING))))
        pct))))