;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:ZL -*-


(defun identity (item)
  item)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TREE-EQUAL

(defun TREE-EQUAL (tree1 tree2 &optional &key (test #'eql) test-not)
  (if test-not
      (tree-equal-1 tree1 tree2 test-not t)
    (tree-equal-1 tree1 tree2 test nil)))

(defun tree-equal-1 (tree1 tree2 test invertp)
  (cond ((and (atom tree1) (atom tree2))
	 (if invertp
	     (not (funcall test tree1 tree2))
	   (funcall test tree1 tree2)))
	((and (consp tree1) (consp tree2))
	 (and (tree-equal-1 (car tree1) (car tree2) test invertp)
	      (tree-equal-1 (cdr tree1) (cdr tree2) test invertp)))
	(t nil)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SUBST, SUBST-IF, SUBST-IF-NOT

(defun SUBST (new old tree &optional &key (test #'eql) test-not (key #'identity))
  (if test-not
      (subst-if-1 new #'(lambda (thing)
			  (funcall test-not old thing))
		  t tree key)
    (subst-if-1 new #'(lambda (thing)
			(funcall test old thing))
		nil tree key)))

(defun SUBST-IF (new test tree &optional &key (key #'identity))
  (subst-if-1 new test nil tree key))

(defun SUBST-IF-NOT (new test tree &optional &key (key #'identity))
  (subst-if-1 new test t tree key))

(defun subst-if-1 (new test invertp tree key)
  (cond ((funcall test (funcall key tree))
	 new)
	((atom tree) tree)
	(t (let* ((car (car tree))
		  (cdr (cdr tree))
		  (new-car (subst-if-1 new test invertp car key))
		  (new-cdr (subst-if-1 new test invertp cdr key)))
	     (if (and (eq car new-car)
		      (eq cdr new-cdr))
		 tree
	       (cons new-car new-cdr))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NSUBST, NSUBST-IF NSUBST-IF-NOT

(defun NSUBST (new old tree &optional &key (test #'eql) test-not (key #'identity))
  (if test-not
      (nsubst-if-1 new #'(lambda (thing)
			   (funcall test-not old thing))
		   t tree key)
    (nsubst-if-1 new #'(lambda (thing)
			 (funcall test-not old thing))
		 nil tree key)))

(defun NSUBST-IF (new test tree &optional &key (key #'identity))
  (nsubst-if-1 new test nil tree key))

(defun NSUBST-IF-NOT (new test tree &optional &key (key #'identity))
  (nsubst-if-1 new test t tree key))

(defun nsubst-if-1 (new test invertp tree key)
  (cond ((funcall test (funcall key tree))
	 new)
	((atom tree) tree)
	(t (let* ((car (car tree))
		  (cdr (cdr tree))
		  (new-car (nsubst-if-1 new test invertp car key))
		  (new-cdr (nsubst-if-1 new test invertp cdr key)))
	     (unless (eq car new-car)
	       (rplaca tree new-car))
	     (unless (eq cdr new-cdr)
	       (rplacd tree new-cdr))
	     tree))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SUBLIS, NSUBLIS

(defun SUBLIS (a-list tree &key (test #'eql) test-not (key #'identity))
  (if test-not
      (sublis-1 a-list tree test-not t key)
    (sublis-1 a-list tree test nil key)))

(defun sublis-1 (a-list tree test invertp key)
  (let ((pair (assoc tree a-list (if invertp :test-not :test) test :key key)))
    (cond (pair (cdr pair))
	  ((atom tree) tree)
	  (t (let* ((car (car tree))
		    (cdr (cdr tree))
		    (new-car (sublis-1 a-list car test invertp key))
		    (new-cdr (sublis-1 a-list cdr test invertp key)))
	       (if (and (eq car new-car)
			(eq cdr new-cdr))
		   tree
		 (cons new-car new-cdr)) )) )))

(defun NSUBLIS (a-list tree &key (test #'eql) test-not (key #'identity))
  (if test-not
      (nsublis-1 a-list tree test-not t key)
    (nsublis-1 a-list tree test nil key)))

(defun nsublis-1 (a-list tree test invertp key)
  (let ((pair (assoc tree a-list (if invertp :test-not :test) test :key key)))
    (cond (pair (cdr pair))
	  ((atom tree) tree)
	  (t (let* ((car (car tree))
		    (cdr (cdr tree))
		    (new-car (nsublis-1 a-list car test invertp key))
		    (new-cdr (nsublis-1 a-list cdr test invertp key)))
	       (unless (eq car new-car)
		 (rplaca tree new-car))
	       (unless (eq cdr new-cdr)
		 (rplacd tree new-cdr))
	       tree)) )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MEMBER, MEMBER-IF, MEMBER-IF-NOT

(defun MEMBER (item list &key (test #'eql) test-not key)
  (if test-not
      (do ((sublist list (cdr sublist)))
	  ((null sublist) nil)
	(unless (funcall test-not item (if key
					   (funcall key (car sublist))
					 (car sublist)))
	  (return sublist)))
    (do ((sublist list (cdr sublist)))
	((null sublist) nil)
      (when (funcall test item (if key
				   (funcall key (car sublist))
				 (car sublist)))
	(return sublist)))))

(defun MEMBER-EQL (item list)
  (do ((sublist list (cdr sublist)))
      ((null sublist) nil)
    (when (eql item (car sublist))
      (return sublist))))

(defun MEMBER-EQ (item list)
  (do ((sublist list (cdr sublist)))
	((null sublist) nil)
      (when (eq item (car sublist))
	(return sublist))))

(defun MEMBER-EQUAL (item list)
  (do ((sublist list (cdr sublist)))
      ((null sublist) nil)
    (when (equal item (car sublist))
      (return sublist))))


(def-rewrite-patterns MEMBER (item list)
  (()  `(MEMBER-EQL ,item ,list))
  ((&key (test #'eq)) `(MEMBER-EQ ,item ,list))
  ((&key (test #'equal)) `(MEMBER-EQUAL ,item ,list)))

(defun MEMBER-IF (predicate list &key (key #'identity))
  (do ((sublist list (cdr sublist)))
      ((null sublist) nil)
    (when (funcall predicate (funcall key (car sublist)))
      (return sublist))))

(defun MEMBER-IF-NOT (predicate list &key (key #'identity))
  (do ((sublist list (cdr sublist)))
      ((null sublist) nil)
    (unless (funcall predicate (funcall key (car sublist)))
      (return sublist))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ASSOC, ASSOC-IF, ASSOC-IF-NOT

(defun ASSOC (item a-list &key (test #'eql) test-not key)
  (if test-not
      (dolist (association a-list nil)
	(unless (funcall test item (if key
				       (funcall key (car association))
				     (car association)))
	  (return association)))
    (dolist (association a-list nil)
      (when (funcall test item (if key
				   (funcall key (car association))
				 (car association)))
	(return association)))))

(defun ASSOC-EQL (item a-list)
  (dolist (ass a-list nil)
    (when (eql ass item)
	(return ass))))

(defun ASSOC-EQ (item a-list)
  (dolist (ass a-list nil)
    (when (eq ass item)
	(return ass))))

(defun ASSOC-IF (predicate a-list)
  (dolist (association a-list nil)
    (when (funcall predicate (car association))
      (return association))))

(defun ASSOC-IF-NOT (predicate a-list)
  (dolist (association a-list nil)
    (unless (funcall predicate (car association))
      (return association))))


(def-rewrite-patterns assoc (item a-list)
  (()                 `(ASSOC-EQL ,item ,a-list))
  ((&key (test #'eq)) `(ASSOC-EQ ,item ,a-list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RASSOC, RASSOC-IF, RASSOC-IF-NOT

(defun RASSOC (item a-list &optional &key (test #'eql) test-not (key #'identity))
  (if test-not
      (dolist (association a-list nil)
	(unless (funcall test item (funcall key (cdr association)))
	  (return association)))
    (dolist (association a-list nil)
      (when (funcall test item (funcall key (cdr association)))
	(return association)))))

(defun RASSOC-IF (predicate a-list)
  (dolist (association a-list nil)
    (when (funcall predicate (cdr association))
      (return association))))

(defun RASSOC-IF-NOT (predicate a-list)
  (dolist (association a-list nil)
    (unless (funcall predicate (cdr association))
      (return association))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ADJOIN

(defun ADJOIN (item list &optional &key (test #'eql) test-not (key #'identity))
  (if (if test-not
	  (member (funcall key item) list :test-not test-not :key key)
	(member (funcall key item) list :test test :key key))
      list
    (cons item list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PUSHNEW

(defmacro PUSHNEW (item place &rest testandkey)
  `(setf ,place (adjoin ,item ,place . ,testandkey)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; UNION

(defun UNION (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (let ((result list2))
    (dolist (l list1)
      (setq result (adjoin l result)))
    result))

;;; Fudge this one.  CLtL says this "MAY destroy the argument lists" is doesn't say it must.
(defun NUNION (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (union list1 list2 :test test :test-not test-not :key key))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SET-INTERSECTION

(defun SET-INTERSECTION (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (let ((result nil))
    (if test-not
	(dolist (l list1)
	  (when (member l list2 :test-not test-not :key key)
	    (push l result)))
      (dolist (l list1)
	  (when (member l list2 :test test :key key)
	    (push l result))))
    result))

(defun NSET-INTERSECTION (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (set-intersection list1 list2 :test test :test-not test-not :key key))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SUBSETP

(defun SUBSETP (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (if test-not
      (dolist (l list1 t)
	(when (member l list2 :test-not test-not :key key)
	  (return nil)))
    (dolist (l list1 t)
      (unless (member l list2 :test test :key key)
	return nil))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SET-DIFFERENCE

(defun SET-DIFFERENCE (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (let ((result nil))
    (if test-not
	(dolist (l list1)
	  (unless (member l list2 :test-not test-not :key key)
	    (push l result)))
      (dolist (l list1)
	  (unless (member l list2 :test test :key key)
	    (push l result))))
    result))

(defun NSET-DIFFERENCE (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (set-exclusive-or list1 list2 :test test :test-not test-not :key key))
      

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SET-EXCLUSIVE-OR
      
(defun SET-EXCLUSIVE-OR (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (let ((result nil))
    (if test-not
	(progn 
	  (dolist (l list1)
	    (unless (member l list2 :test-not test-not :key key)
	      (push l result)))
	  (dolist (l list2)
	    (unless (member l list1 :test-not test-not :key key)
	      (push l result))))
      (progn 
	(dolist (l list1)
	  (unless (member l list2 :test test :key key)
	    (push l result)))
	(dolist (l list2)
	  (unless (member l list1 :test test :key key)
	    (push l result)))))
    result))

(defun NSET-EXCLUSIVE-OR (list1 list2 &optional &key (test #'eql) test-not (key #'identity))
  (set-exclusive-or list1 list2 :test test :test-not test-not :key key))