(module trace-display mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
"interfaces.ss"
"trace-control.ss"
"trace-grid.ss"
"trace-header.ss"
"trace-sidebar.ss"
"draw.ss"
"../model/view.ss"
)
(provide/contract
[trace-display% (class/c panel%)])
(define trace-display%
(class panel%
(super-new)
(inherit change-children)
(init-field view)
(override container-size place-children)
(public do-update set-filter get-view
scroll-trace/xy scroll-trace/object scroll-trace/action)
(define controls
(new trace-control% [parent this] [trace-display this]))
(define grid
(new trace-grid% [parent this] [trace-display this]))
(define header
(new trace-header% [parent this] [trace-display this]))
(define sidebar
(new trace-sidebar% [parent this] [trace-display this]))
(change-children (lambda any (list controls header sidebar grid)))
(define (set-filter pred)
(set! view (make-view (view-buffer view) pred))
(do-update))
(define (get-view)
view)
(define (do-update)
(view-update view)
(send controls on-update)
(send grid on-update)
(send header on-update)
(send sidebar on-update))
(define (scroll-trace/xy x y)
(send grid scroll-to/xy x y)
(send header scroll-to/xy x #f)
(send sidebar scroll-to/xy #f y))
(define (scroll-trace/object object)
(let*-values ([(index) (view-object-index view object)]
[(x y) (send grid get-client-size)]
[(editor-x) (* (+ index 1/2) OBJECT-WIDTH)]
[(dc-x) (/ x 2)])
(scroll-trace/xy (- editor-x dc-x) #f)))
(define (scroll-trace/action action)
(let*-values ([(index) (view-action-index view action)]
[(x y) (send grid get-client-size)]
[(editor-y) (* (+ index 1/2) ACTION-HEIGHT)]
[(dc-y) (/ y 2)])
(scroll-trace/xy #f (- editor-y dc-y))))
(define (container-size info)
(let* ([control-width (send controls min-width)]
[control-height (send controls min-height)]
[obj-width (send header min-width)]
[obj-height (send header min-height)]
[act-width (send sidebar min-width)]
[act-height (send sidebar min-height)]
[grid-width (send grid min-width)]
[grid-height (send grid min-height)])
(values (+ (max control-width act-width)
(max obj-width grid-width))
(+ (max control-height obj-height)
(max act-height grid-height)))))
(define (place-children info width height)
(let* ([control-height (send controls get-height)]
[control-width (send controls get-width)]
[obj-height (send header min-height)]
[act-width (send sidebar min-width)]
[header-height (max control-height obj-height)]
[sidebar-width (max control-width act-width)]
[grid-width (- width act-width)]
[grid-height (- height obj-height)])
(list (list 0 0 sidebar-width header-height)
(list sidebar-width (- header-height obj-height)
grid-width obj-height)
(list (- sidebar-width act-width) header-height
act-width grid-height)
(list sidebar-width header-height
grid-width grid-height))))
))
)