;;;; 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)))