;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
;; License for more details.
;; 
;; You should have received a copy of the GNU Library General Public License 
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


;;;;    listlib.lsp
;;;;
;;;;                        list manipulating routines

; Rewritten 11 Feb 1993 by William Schelter and Gordon Novak to use iteration
; rather than recursion, as needed for large data sets.


(in-package 'lisp)

(export '(union nunion intersection nintersection
          set-difference nset-difference set-exclusive-or nset-exclusive-or
          subsetp))

(in-package 'system)

(eval-when (compile)
  (proclaim '(optimize (safety 0) (space 3)))
  )

;(defun union (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) list2)
;        ((apply #'member1 (car list1) list2 rest)
;         (apply #'union (cdr list1) list2 rest))
;        (t
;         (cons (car list1)
;               (apply #'union (cdr list1) list2 rest)))))
(defun union (list1 list2 &rest rest &aux first last)
  (do ((x list1 (cdr x)))
      ((null x) (if last (rplacd last list2)) (return (or first list2)))
    (or (consp x) (error "UNION not passed a list"))
    (if (not (apply #'member1 (car x) list2 rest))
	(if last (progn (rplacd last (cons (car x) nil))
			(setq last (cdr last)))
	         (progn (setq first (cons (car x) nil))
			(setq last first)))) ) )

;(defun nunion (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) list2)
;        ((apply #'member1 (car list1) list2 rest)
;         (apply #'nunion (cdr list1) list2 rest))
;        (t
;         (rplacd list1
;                 (apply #'nunion (cdr list1) list2 rest)))))
(defun nunion (list1 list2 &rest rest &aux first last)
  (do ((x list1 (cdr x)))
      ((null x) (if last (rplacd last list2)) (return (or first list2)))
    (or (consp x) (error "NUNION not passed a list"))
    (if (not (apply #'member1 (car x) list2 rest))
	(progn (if last (rplacd last x)
		        (setq first x))
	       (setq last x))) ) )

;(defun intersection (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) nil)
;        ((apply #'member1 (car list1) list2 rest)
;         (cons (car list1)
;               (apply #'intersection (cdr list1) list2 rest)))
;        (t (apply #'intersection (cdr list1) list2 rest))))

;; all functions in this file should be written as follows:
;; Besides being non recursive, it allows compilation on safety 0
(defun intersection (list1 list2 &rest rest &aux ans)
  (do ((x list1 (cdr x)))
      ((null x) (return ans))
    (or (consp x) (error "INTERSECTION not passed a list"))
    (if (apply #'member1 (car x) list2 rest)
        (setq ans (cons (car x) ans))))
  )

;(defun nintersection (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) nil)
;        ((apply #'member1 (car list1) list2 rest)
;         (rplacd list1
;                 (apply #'nintersection (cdr list1) list2 rest)))
;        (t (apply #'nintersection (cdr list1) list2 rest))))
(defun nintersection (list1 list2 &rest rest &aux first last)
  (do ((x list1 (cdr x)))
      ((null x) (if last (rplacd last nil)) (return first))
    (or (consp x) (error "NINTERSECTION not passed a list"))
    (if (apply #'member1 (car x) list2 rest)
	(progn (if last (rplacd last x)
		        (setq first x))
	       (setq last x))) ) )

;(defun set-difference (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) nil)
;        ((not (apply #'member1 (car list1) list2 rest))
;         (cons (car list1)
;               (apply #'set-difference (cdr list1) list2 rest)))
;        (t (apply #'set-difference (cdr list1) list2 rest))))
(defun set-difference (list1 list2 &rest rest &aux ans)
  (do ((x list1 (cdr x)))
      ((null x) (return ans))
    (or (consp x) (error "SET-DIFFERENCE not passed a list"))
    (if (not (apply #'member1 (car x) list2 rest))
        (setq ans (cons (car x) ans))))  )

;(defun nset-difference (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (cond ((null list1) nil)
;        ((not (apply #'member1 (car list1) list2 rest))
;         (rplacd list1
;                 (apply #'nset-difference (cdr list1) list2 rest)))
;        (t (apply #'nset-difference (cdr list1) list2 rest))))
(defun nset-difference (list1 list2 &rest rest &aux first last)
  (do ((x list1 (cdr x)))
      ((null x) (if last (rplacd last nil)) (return first))
    (or (consp x) (error "NSET-DIFFERENCE not passed a list"))
    (if (not (apply #'member1 (car x) list2 rest))
	(progn (if last (rplacd last x)
		        (setq first x))
	       (setq last x))) ) )

;(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (append (apply #'set-difference list1 list2 rest)
;          (apply #'set-difference list2 list1 rest)))
(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
  (declare (ignore test test-not key))
  (nconc (apply #'set-difference list1 list2 rest)
         (apply #'set-difference list2 list1 rest)))

;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
;  (declare (ignore test test-not key))
;  (nconc (apply #'set-difference list1 list2 rest)
;         (apply #'nset-difference list2 list1 rest)))
(defun nset-exclusive-or (list1 list2 &rest rest &aux first last fint lint)
  (do ((x list1 (cdr x)))
      ((null x) (if lint (rplacd lint nil))
                (if last
		    (progn (rplacd last
				   (apply #'nset-difference list2 fint rest))
			   (return first))
		    (return (apply #'nset-difference list2 fint rest))))
    (or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list"))
    (if (apply #'member1 (car x) list2 rest)
	(progn (if lint (rplacd lint x)
		        (setq fint x))
	       (setq lint x))
	(progn (if last (rplacd last x)
		        (setq first x))
	       (setq last x))) ) )

(defun subsetp (list1 list2 &rest rest &key test test-not key)
  (declare (ignore test test-not key))
  (do ((l list1 (cdr l)))
      ((null l) t)
    (or (consp l) (error "SUBSETP not passed a list"))
    (if (not (apply #'member1 (car l) list2 rest)) (return nil))))


