;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;;  Copyright (c) 1995, Giuseppe Attardi.
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;;    This program 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 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.
;;;;                        list manipulating routines

(in-package "SYSTEM")


(defmacro apply-key (key element)
  `(if ,key
       (funcall ,key ,element)
     ,element))

(defun tailp (object list)
  (if (null list)
      (null object)
    (do ((list list (cdr list)))
        ((atom (cdr list)) (or (eql object list) (eql object (cdr list))))
      (if (eql object list)
          (return t)))))

;;; Definition from CLHS 14.2.30 (LDIFF, TAILP)
(defun ldiff (list object)
  (unless (listp list)
    (error 'simple-type-error
           :format-control "Not a proper list or a dotted list.; ~s."
           :format-arguments (list list)
           :datum list
           :expected-type 'list))
  (do ((list list (cdr list))
       (r '() (cons (car list) r)))
      ((atom list)
       (if (eql list object) (nreverse r) (nreconc r list)))
    (when (eql object list)
      (return (nreverse r)))))

;   "Substitute data of ALIST for subtrees matching keys of ALIST."
(defun sublis (alist tree &key key (test #'eql) test-not)
  (when test-not
    (setq test (complement test-not)))
  (labels ((sub (subtree)
                (let ((assoc (assoc (apply-key key subtree) alist :test test)))
                  (cond
                   (assoc (cdr assoc))
                   ((atom subtree) subtree)
                   (t (let ((car (sub (car subtree)))
                            (cdr (sub (cdr subtree))))
                        (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
                            subtree
                          (cons car cdr))))))))
    (sub tree)))
;   "Substitute data of ALIST for subtrees matching keys of ALIST destructively."
(defun nsublis (alist tree &key key (test #'eql) test-not)
  (when test-not
    (setq test (complement test-not)))
  (labels ((sub (subtree)
                (let ((assoc (assoc (apply-key key subtree) alist :test test)))
                  (cond
                   (assoc (cdr assoc))
                   ((atom subtree) subtree)
                   (t
                    (rplaca subtree (sub (car subtree)))
                    (rplacd subtree (sub (cdr subtree)))
                    subtree)))))
    (sub tree)))

(defun union (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, the union of elements in LIST1 and in LIST2."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (first) (last))
      ((null x)
       (when last (rplacd last list2))
       (or first list2))
    (unless (member1 (car x) list2 test test-not key)
      (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 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive UNION.  Both LIST1 and LIST2 may be destroyed."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (first) (last))
      ((null x)
       (when last (rplacd last list2))
       (or first list2))
    (unless (member1 (car x) list2 test test-not key)
      (if last
	  (rplacd last x)
	  (setq first x))
      (setq last x))))

(defun intersection (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns a list consisting of those objects that are elements of both LIST1 and
LIST2."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (ans))
      ((null x)
       (nreverse ans)) ; optional nreverse: not required by CLtL
    (when (member1 (car x) list2 test test-not key)
        (push (car x) ans))))

(defun nintersection (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive INTERSECTION.  Only LIST1 may be destroyed."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (first) (last))
      ((null x)
       (when last (rplacd last nil))
       first)
    (when (member1 (car x) list2 test test-not key)
      (if last
	  (rplacd last x)
	  (setq first x))
      (setq last x))))

(defun set-difference (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, those elements of LIST1 that are not elements of LIST2."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (ans))
      ((null x) (nreverse ans))
    (unless (member1 (car x) list2 test test-not key)
      (push (car x) ans))))

(defun nset-difference (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive SET-DIFFERENCE.  Only LIST1 may be destroyed."
  (declare (optimize safety))
  (do ((x list1 (cdr x))
       (first) (last))
      ((null x)
       (when last (rplacd last nil))
       first)
    (unless (member1 (car x) list2 test test-not key)
      (if last
	  (rplacd last x)
	  (setq first x))
      (setq last x))))

(defun swap-args (f)
  (and f #'(lambda (x y) (funcall f y x))))

(defun set-exclusive-or (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns, as a list, those elements of LIST1 that are not elements of LIST2 and
those elements of LIST2 that are not elements of LIST1."
  (nconc (set-difference list1 list2 :test test :test-not test-not :key key)
         (set-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))

(defun nset-exclusive-or (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Destructive SET-EXCLUSIVE-OR.  Both LIST1 and LIST2 may be destroyed."
  (nconc (set-difference list1 list2 :test test :test-not test-not :key key)
	 (nset-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key)))

(defun subsetp (list1 list2 &key test test-not key)
  "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not)
Returns T if every element of LIST1 is also an element of LIST2.  Returns NIL
otherwise."
  (do ((l list1 (cdr l)))
      ((null l) t)
    (unless (member1 (car l) list2 test test-not key)
      (return nil))))

(defun rassoc-if (test alist &key key)
  "Returns the first pair in ALIST whose cdr satisfies TEST. Returns NIL if no
such pair exists."
  (declare (optimize safety))
  (rassoc test alist :test #'funcall :key key))
(defun rassoc-if-not (test alist &key key)
  "Returns the first pair in ALIST whose cdr does not satisfy TEST.  Returns NIL
if no such pair exists."
  (declare (optimize safety))
  (rassoc test alist :test-not #'funcall :key key))

(defun assoc-if (test alist &key key)
  "Returns the first pair in ALIST whose car satisfies TEST.  Returns NIL if no
such pair exists."
  (declare (optimize safety))
  (assoc test alist :test #'funcall :key key))
(defun assoc-if-not (test alist &key key)
  "Returns the first pair in ALIST whose car does not satisfy TEST.  Returns NIL
if no such pair exists."
  (declare (optimize safety))
  (assoc test alist :test-not #'funcall :key key))

(defun member-if (test list &key key)
  "Searches LIST for an element that satisfies TEST.  If found, returns the
sublist of LIST that begins with the element.  If not found, returns NIL."
  (declare (optimize safety))
  (member test list :test #'funcall :key key))
(defun member-if-not (test list &key key)
  "Searches LIST for an element that does not satisfy TEST.  If found, returns
the sublist of LIST that begins with the element.  If not found, returns NIL."
  (declare (optimize safety))
  (member test list :test-not #'funcall :key key))

(defun subst (new old tree &key key (test #'eql) test-not)
  "Substitute NEW for subtrees matching OLD."
  (when test-not
    (setq test (complement test-not)))
  (labels ((sub (subtree)
		(cond
		 ((funcall test old (apply-key key subtree)) new)
		 ((atom subtree) subtree)
		 (t (let ((car (sub (car subtree)))
			  (cdr (sub (cdr subtree))))
		      (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
			  subtree
			(cons car cdr)))))))
    (sub tree)))

(defun subst-if (new test tree &key key)
  "Substitutes NEW for subtrees of TREE that satisfy TEST and returns the result.
The original TREE is not destroyed."
  (declare (optimize safety))
  (subst new test tree :test #'funcall :key key))
(defun subst-if-not (new test tree &key key)
  "Substitutes NEW for subtrees of TREE that do not satisfy TEST and returns the
result.  The original TREE is not destroyed."
  (declare (optimize safety))
  (subst new test tree :test-not #'funcall :key key))

(defun nsubst-if (new test tree &key key)
  "Destructive SUBST-IF. TREE may be modified."
  (declare (optimize safety))
  (nsubst new test tree :test #'funcall :key key))
(defun nsubst-if-not (new test tree &key key)
  "Destructive SUBST-IF-NOT. TREE may be modified."
  (declare (optimize safety))
  (nsubst new test tree :test-not #'funcall :key key))

;;;
;;; Copyright 1994-2009 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; kpoeck slightly modified (set-car, set-cdr -> rplaca, rplacd) to working with clasp
;;; Borrowed with permission

(defun nsubst (new old tree &key key
                   (test #'eql testp) (test-not nil notp))
  "Substitute NEW for subtrees matching OLD."
  (if (and testp notp)
    (error 'core:simple-program-error
       :FORMAT-CONTROL "Cannot pass both test and test-not to nsubst"
       :format-arguments nil) 
  (nsubst-aux new old tree (or key #'identity) test test-not)))

(defun nsubst-aux (new old subtree key test test-not)
  (flet ((satisfies-the-test (item elt)
           (let* ((val (if key (funcall key elt) elt)))
             (if test-not
               (not (funcall test-not item val))
               (funcall test item val)))))
    (declare (inline satisfies-the-test))
    (cond ((satisfies-the-test old subtree) new)
          ((atom subtree) subtree)
          (t (do* ((last nil subtree)
                   (subtree subtree (cdr subtree)))
                  ((atom subtree)
                   (if (satisfies-the-test old subtree)
                     (rplacd last new)))
               (if (satisfies-the-test old subtree)
                 (return (rplacd last new))
                 (rplaca subtree 
                          (nsubst-aux new old (car subtree)
                                      key test test-not))))
             subtree))))



