;;;; Discrimination-net classifier
;;;   for binary trees represented as pairs.

(define (classify data node)
  (define (walk tree node continue)
    (and node
	 (if (pair? tree)
	     (walk (car tree)
	        (classi:left node)
		(lambda (node)
		  (and node
		       (walk (cdr tree)
		          (classi:right node)
			  continue))))
	   (classi:scan tree node continue))))
  (assert (classi:node? node))
  (walk data node
	(lambda (terminal)
	  (and terminal
	    (classi:classification terminal)))))

(define (add-classification! node ptree class)
  (define (walk tree node continue)
    (if (pair? tree)
	(walk (car tree)
	      (classi:left* node)
	      (lambda (node)
		(walk (cdr tree)
		      (classi:right* node)
		      continue)))
	(classi:assign node tree continue)))
  (assert (classi:node? node))
  (walk ptree node
	(lambda (node)
	  (classi:set-classification! node
				      class)))
  'done)

(define (classi:new-node)
  (make-classi:node '() #f #f #f))

(define (classi:left* node)
  (let ((left (classi:left node)))
    (or left
	(let ((left (classi:new-node)))
	  (classi:set-left! node left)
	  left))))

(define (classi:right* node)
  (let ((right (classi:right node)))
    (or right
	(let ((right (classi:new-node)))
	  (classi:set-right! node right)
	  right))))

(define (classi:scan thing node continue)
  (let lp ((table (classi:table node)))
    (and (pair? table)
	 (or (and ((caar table) thing)
		  (continue (cdar table)))
	     (lp (cdr table))))))

(define (classi:assign node predicate continue)
  (if (null? predicate) (set! predicate null?))
  (assert (procedure? predicate))
  (let ((entry
	 (assq predicate (classi:table node))))
    (if entry
	(continue (cdr entry))
	(let ((new-node (classi:new-node)))
	  (classi:set-table!
	   node
	   (cons (cons predicate new-node)
		 (classi:table node)))
	  (continue new-node)))))

(define-record-type classi:node
    (make-classi:node table
		      left
		      right
		      classification)
    classi:node?
  (table classi:table classi:set-table!)
  (left classi:left classi:set-left!)
  (right classi:right classi:set-right!)
  (classification classi:classification
		  classi:set-classification!))


#|
(define the-classifier (classi:new-node))
;Value: the-classifier

(add-classification! the-classifier
		     (cons number? symbol?)
		     'ns)
;Value: done

(add-classification! the-classifier
		     (cons symbol? symbol?)
		     'ss)
;Value: done

(add-classification! the-classifier
		     (cons number? number?)
		     'nn)
;Value: done

(add-classification! the-classifier
		     (cons symbol? number?)
		     'sn)
;Value: done

(classify '(foo bar) the-classifier)
;Value: #f

(classify '(foo . bar) the-classifier)
;Value: ss

(classify '(3 . bar) the-classifier)
;Value: ns

(classify '(bar . 3) the-classifier)
;Value: sn

(classify '(4 . 3) the-classifier)
;Value: nn

(add-classification! the-classifier
		     (list symbol? symbol?)
		     'sse)

(classify '(foo bar) the-classifier)
;Value: sse

(classify '(foo . bar) the-classifier)
;Value: ss

(add-classification! the-classifier
		     (list any? symbol? number?)
		     'asne)

(classify '(foo bar 3) the-classifier)
;Value: asne

(classify '(4 bar 3) the-classifier)
;Value: asne
|#