(provide 'ucons1)

;; (c) 1990, 1991, Richard J. Fateman

(in-package :mma)
;; alternative to ucons1 file
;; for non-Allegro CL.  This is a much inferior version in
;; efficiency of the unique-ification, and any CL could do
;; better. But maybe not the same way.

;;Simplest way to make the substitution would be to rename this
;; file ucons1.lisp.



(defvar *uniq-table* (make-hash-table :test #'eq))
(defvar *uniq-atom-table* (make-hash-table :test #'equal))

(defun uniq (x)
  "Return a canonical representation that is EQUAL to x,
  such that (equal x y) => (eq (uniq x) (uniq y))"
  (typecase x
    ((or fixnum symbol) x)
    (atom (or (gethash x *uniq-atom-table*)
              (setf (gethash x *uniq-atom-table*) x)))
    (cons (ucons (uniq (car x))   ; this could check in 
                                  ; *uniq-table* first...
                 (uniq (cdr x))))))

(defun ucons (x y)
  "Unique cons: (eq (ucons x y) (ucons x y)) is always true."
;; Look up the car, x, in the hash-table *uniq-table*.
;; If there a table there, then we have already hashed an
;; item with this car in the table.
;; If it is missing, create a hash-table for the purpose of
;; storing the new (cons x y) in the next step.

  (let ((car-table (or (gethash x *uniq-table*)
	               (setf (gethash x *uniq-table*)
                             (make-hash-table :test #'eq :size 10)))))

;;  At this point, car-table is a hash-table that either has
;;  (cons x y) in it, hashed under the key y, or we create 
;;  such an item and store it.

    (or (gethash y car-table)
        (setf (gethash y car-table) (cons x y)))))



(defun umapcar(f x)(cond((null x)nil)
			(t (ucons (funcall f (car x))(umapcar f (cdr x))))))

(defmacro ulist(&rest l)(cond ((null l)nil)
			      (t `(ucons ,(car l) (ulist ,@(cdr l))))))

(defun uappend(r s)(cond ((null r)s)
			 (t (ucons (car r)(uappend (cdr r) s)))))