(module class-gui mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "hierlist.ss" "hierlist")
(lib "list.ss")
"draw.ss"
"interfaces.ss"
"snip-gui.ss"
"../model/class-hierarchy.ss")
(provide/contract
[class-gui% (class/c panel%)])
(define class-gui%
(class vertical-panel%
(super-new)
(init ([hier hierarchy]))
(define hierarchy hier)
(define hierlist (new hierarchical-list% [parent this] [style '()]))
(send hierlist selectable #f)
(public get-hierarchy set-hierarchy)
(private on-update clear)
(define (get-hierarchy)
hierarchy)
(define (set-hierarchy hier)
(set! hierarchy hier)
(on-update))
(define (on-update)
(clear)
(add-forest hierarchy hierlist))
(define (clear)
(for-each (lambda (item) (send hierlist delete-item))
(send hierlist get-items)))
(on-update)))
(define (add-forest forest hierlist)
(for-each (lambda (tree) (add-tree tree hierlist))
(class-forest-trees forest)))
(define (add-tree tree hierlist)
(if (class-tree-singleton? tree)
(let* ([item (send hierlist new-item)])
(initialize-item item tree))
(let* ([item (send hierlist new-list)])
(initialize-item item tree)
(add-forest (class-tree-children tree) item))))
(define (initialize-item item tree)
(send (send item get-editor) insert
(make-object string-snip% (class-name (class-tree-parent tree)))))
(define (test)
(define class-one% (class object% (super-new)))
(define class-two% (class object% (super-new)))
(define class-one-one% (class class-one% (super-new)))
(define class-one-one-one% (class class-one-one% (super-new)))
(define class-two-one% (class class-two% (super-new)))
(define class-two-two% (class class-two% (super-new)))
(define forest (foldl class-forest-insert
(make-class-forest)
(list class-one% class-two%
class-one-one% class-one-one-one%
class-two-one% class-two-two%)))
(define frame (new frame% [label "Class GUI"]))
(define gui (new class-gui% [parent frame] [hierarchy forest]))
(send frame show #t))
(test)
)