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

(define (canonicalize data node)
  (define (walk tree node)
    (if (pair? tree)
	(walk (cdr tree)
	      (canon:right 
	       (walk (car tree)
		     (canon:left node))))
	(canon:lookup tree node)))
  (assert (canon:node? node))
  (canon:data (walk data node) data))

;;; Nodes have lazy selectors.

(define (canon:new-node)
  (make-canon:node #f #f #f #f))

(define (canon:table node)
  (let ((table (canon:node-table node)))
    (or table
	(let ((table (make-canon:node-table)))
	  (set-canon:node-table! node table)
	  table))))

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

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

(define (canon:data node data)
  (let ((thing (canon:node-data node)))
    (or thing
	(begin (set-canon:node-data! node data)
	       data))))

;;; Discrimination-network tables.

(define (canon:lookup thing node)	
  (let ((v
	 (canon:node-table/get
	  (canon:table node) thing #f)))
    (or v
	(let ((v (canon:new-node)))
	  (canon:node-table/put!
	   (canon:table node) thing v)
	  v))))

(define (make-canon:node-table)
  (make-1d-table))

(define (canon:node-table/get table key default)
  (1d-table/get table key default))

(define (canon:node-table/put! table key value)
  (1d-table/put! table key value))

;;; Discrimination-network nodes.

(define-record-type canon:node
    (make-canon:node table left right data)
    canon:node?
  (table canon:node-table set-canon:node-table!)
  (left canon:node-left set-canon:node-left!)
  (right canon:node-right set-canon:node-right!)
  (data canon:node-data set-canon:node-data!))


#|
;;; A simple example

(define the-net (canon:new-node))

(define foo (canonicalize '(a . b) the-net))
;Value: foo

(eq? foo (canonicalize '(a . b) the-net))
;Value: #t

(eq? foo (canonicalize '(a . c) the-net))
;Value: #f

(eq? foo (canonicalize '(a . b) the-net))
;Value: #t

|#

#|
;;; Alternate version with continuations.

(define (canonicalize data node)
  (define (walk tree node continue)
    (if (pair? tree)
	(walk (car tree)
	      (canon:left node)
	      (lambda (node)
		(walk (cdr tree)
		      (canon:right node)
		      continue)))
	(continue (canon:lookup tree node))))
  (assert (canon:node? node))
  (walk data node
	(lambda (terminal-node)
	  (canon:data terminal-node data))))
|#