(module class-hierarchy mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "etc.ss")
(prefix srfi1: (lib "1.ss" "srfi")))
(define-struct class-forest (trees))
(define-struct class-tree (parent assoc children))
(provide/contract
[class-forest? (any/c . -> . boolean?)]
[rename new-class-forest make-class-forest (-> class-forest?)]
[class-forest-insert ([class? class-forest?] [any/c] . opt-> . class-forest?)]
[class-forest-exists? (class? class-forest? . -> . boolean?)]
[class-forest-lookup (class? class-forest? . -> . any/c)]
[class-forest-trees (class-forest? . -> . (listof class-tree?))]
[class-forest-empty? (class-forest? . -> . boolean?)]
[class-tree? (any/c . -> . boolean?)]
[rename new-class-tree make-class-tree
([class?] [any/c] . opt-> . class-tree?)]
[class-tree-insert ([class? class-tree?] [any/c] . opt-> . class-tree?)]
[class-tree-exists? (class? class-tree? . -> . boolean?)]
[class-tree-assoc (class-tree? . -> . any/c)]
[class-tree-lookup (class? class-tree? . -> . any/c)]
[class-tree-parent (class-tree? . -> . class?)]
[class-tree-children (class-tree? . -> . class-forest?)]
[class-tree-singleton? (class-tree? . -> . boolean?)])
(define (class-forest-empty? forest)
(null? (class-forest-trees forest)))
(define (class-tree-singleton? tree)
(class-forest-empty? (class-tree-children tree)))
(define (class-forest-exists? class% forest)
(ormap (lambda (tree) (class-tree-exists? class% tree))
(class-forest-trees forest)))
(define (class-tree-exists? class% tree)
(let* ([parent% (class-tree-parent tree)]
[children (class-tree-children tree)])
(and (subclass? class% parent%)
(or (subclass? parent% class%)
(class-forest-exists? class% children)))))
(define class-forest-lookup
(opt-lambda (class% forest [default #f])
default))
(define (class-tree-lookup class% tree)
#f)
(define (new-class-forest)
(make-class-forest null))
(define new-class-tree
(opt-lambda (parent [assoc #f])
(make-class-tree parent assoc (new-class-forest))))
(define class-tree-insert
(opt-lambda (class% tree [assoc #f])
(let* ([parent% (class-tree-parent tree)])
(unless (subclass? class% parent%)
(error 'class-tree-insert "~s is not a subclass of ~s"
class% parent%))
(if (subclass? parent% class%)
(make-class-tree
class%
assoc
(class-tree-children tree))
(make-class-tree
parent%
(class-tree-assoc tree)
(class-forest-insert class% (class-tree-children tree) assoc))))))
(define class-forest-insert
(opt-lambda (class% forest [assoc #f])
(let* ([trees (class-forest-trees forest)])
(make-class-forest
(or (insert-into-existing-tree class% assoc trees)
(insert-new-tree class% assoc trees))))))
(define (insert-into-existing-tree class% assoc trees)
(recur search ([done null]
[todo trees])
(if (null? todo)
#f
(let* ([tree (car todo)]
[rest (cdr todo)])
(if (subclass? class% (class-tree-parent tree))
(srfi1:append-reverse
done (cons (class-tree-insert class% tree assoc) rest))
(search (cons tree done) rest))))))
(define (insert-new-tree class% assoc trees)
(let*-values ([(children peers)
(srfi1:partition
(lambda (tree)
(subclass? (class-tree-parent tree) class%))
trees)])
(append peers
(list (make-class-tree class% assoc
(make-class-forest children))))))
)