(module filter-frame mzscheme (require (lib "contract.ss") (lib "class.ss") (lib "mred.ss" "mred") "class-gui.ss" "interfaces.ss" "../model/require.ss" "../model/class-hierarchy.ss" "../model/view.ss" "../model/action-util.ss" "../model/pool.ss") (require-etc) (provide/contract [filter-frame% (class/c frame% updatee<%>)]) (define filter-frame% (class* frame% (updatee<%>) (super-new [label "Filter Traced Classes"]) (inherit show) (public on-update) (init buffer) (init-field trace-display) (define view (make-view buffer (constant #t))) (define count (view-count-objects view)) (define panel (new vertical-panel% [parent this])) (define gui (new class-gui% [hierarchy (make-class-forest)] [parent panel])) (define done-button (new button% [parent panel] [label "Done"] [callback (lambda (b e) (show #f) (let* ([class-pred (send gui get-predicate)] [obj-pred (lambda (obj) (and obj (class-pred (object-class obj))))]) (send trace-display set-filter (lambda (action) (or (obj-pred (action-source action)) (obj-pred (action-target action)))))))])) (define default-record (make-tree-record #t 'auto)) (define (on-update) (view-update view) (let* ([new-count (view-count-objects view)] [hierarchy (let iter ([index count] [hierarchy (send gui get-hierarchy)]) (if (< index new-count) (let* ([class% (object-class (view-get-object view index))]) (iter (+ index 1) (if (class-forest-exists? class% hierarchy) hierarchy (class-forest-insert class% hierarchy default-record)))) hierarchy))]) (send gui set-hierarchy hierarchy) (set! count new-count))))) )