;;;; cons-unique (aka hashcons)
;;;  Apparently invented by Ershov 
;;;    (see CACM 1, 8, August 1958, pp. 3--6)
;;;  Re-introduced by E.Goto in 1974.

(declare (usual-integrations))

;;; Given two arguments cons-unique
;;; returns a pair.  If exactly the same
;;; two arguments were previously
;;; combined with cons-unique it returns
;;; the same pair it returned the first
;;; time.

(define cons-unique
  ;; I don't want to cons if unnecessary.
  (let ((the-pair (cons #f #f)))  
    (define (hashcons x y)
      (set-car! the-pair x)
      (set-cdr! the-pair y)
      (let ((canonical-pair
	     (hash-table/get the-cons-table
			     the-pair
			     #f)))
	(if canonical-pair
	    (begin
	      (set-car! the-pair #f)
	      (set-cdr! the-pair #f)
	      canonical-pair)
	    (let ((new the-pair))
	      (hash-table/put! the-cons-table
			       new
			       new)
	      (set! the-pair (cons #f #f))
	      new))))
    hashcons))

;;; Given a list structure, to get a
;;; canonical copy equal to the given
;;; list structure.  Must canonicalize
;;; and share all substructure.
	    
(define (canonical-copy x)
  (if (pair? x)
      (let ((canonical-pair
	     (hash-table/get the-cons-table
			     x
			     #f)))
	;; Perhaps already canonical
	(or canonical-pair
	    (cons-unique
	     (canonical-copy (car x))
	     (canonical-copy (cdr x)))))
      x))

(define (list-unique . lst)
  (canonical-copy lst))

(define (append-unique l1 l2)
  (if (null? l1)
      l2
      (cons-unique (car l1)
		   (append-unique (cdr l1)
				  l2))))

(define (map-unique p lst)
  (if (pair? lst)
      (cons-unique (p (car lst))
		   (map-unique p (cdr lst)))
      lst))

;;; Support for the hashcons system.

(define (pair-eq? u v)
  (and (eq? (car u) (car v))
       (eq? (cdr u) (cdr v))))

(define the-cons-table
  ((weak-hash-table/constructor equal-hash-mod
				pair-eq?
				#t)))

#|
;;; For example...

(define foo
  '(define (canonical-copy x)
     (if (pair? x)
	 (let ((canonical-pair
		(hash-table/get the-cons-table x #f)))
	   (or canonical-pair
	       (let ((new
		      (cons (canonical-copy (car x))
			    (canonical-copy (cdr x)))))
		 (hash-table/put! the-cons-table new new)
		 new)))
	 x)))

(define bar
  '(define cons-unique
     ;; I don't want to cons if unnecessary.
     (let ((the-pair (cons #f #f)))  
       (define (hashcons x y)
	 (set-car! the-pair x)
	 (set-cdr! the-pair y)
	 (let ((canonical-pair
		(hash-table/get the-cons-table the-pair #f)))
	   (or canonical-pair
	       (let ((new the-pair))
		 (hash-table/put! the-cons-table new new)
		 (set! the-pair (cons #f #f))
		 new))))
       hashcons)))

(define cfoo
  (canonical-copy foo))
;Value: cfoo

(eq? cfoo (canonical-copy foo))
;Value: #t

(define cbar (canonical-copy bar))
;Value: cbar

(define baz (caddr (caddr (caddr (caddr (caddr cfoo))))))
;Value: baz

baz
;Value: (hash-table/put! the-cons-table new new)


(define mum (caddr (caddr (caddr (car (cddddr (caddr (caddr cbar))))))))
;Value: mum

;Value: mum
;Value: (hash-table/put! the-cons-table new new)

(eq? baz mum)
;Value: #t
|#