src/sequence.lisp

   1 ;;; sequence.lisp
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (defmacro do-sequence ((elt seq &optional (index (gensym "i") index-p)) &body body)
  17   (let ((nseq (gensym "seq")))
  18     (unless (symbolp elt)
  19       (error "`~S' must be a symbol." elt))
  20     `(let ((,nseq ,seq))
  21        (if (listp ,nseq)
  22            ,(if index-p
  23                 `(let ((,index -1))
  24                    (dolist (,elt ,nseq)
  25                      (incf ,index)
  26                      ,@body))
  27                 `(dolist (,elt ,nseq)
  28                    ,@body))
  29            (dotimes (,index (length ,nseq))
  30              (let ((,elt (aref ,nseq ,index)))
  31                ,@body))))))
  32
  33 (defun find (item seq &key key (test #'eql))
  34   (if key
  35       (do-sequence (x seq)
  36         (when (funcall test (funcall key x) item)
  37           (return x)))
  38       (do-sequence (x seq)
  39         (when (funcall test x item)
  40           (return x)))))
  41
  42 (defun find-if (predicate sequence &key key)
  43   (if key
  44       (do-sequence (x sequence)
  45         (when (funcall predicate (funcall key x))
  46           (return x)))
  47       (do-sequence (x sequence)
  48         (when (funcall predicate x)
  49           (return x)))))
  50
  51 (defun position (elt sequence &key (test #'eql))
  52   (do-sequence (x seq index)
  53     (when (funcall test elt x)
  54       (return index))))
  55
  56 (defun remove (x seq)
  57   (cond
  58     ((null seq)
  59      nil)
  60     ((listp seq)
  61      (let* ((head (cons nil nil))
  62             (tail head))
  63        (do-sequence (elt seq)
  64          (unless (eql x elt)
  65            (let ((new (list elt)))
  66              (rplacd tail new)
  67              (setq tail new))))
  68        (cdr head)))
  69     (t
  70      (let (vector)
  71        (do-sequence (elt seq index)
  72          (if (eql x elt)
  73              ;; Copy the beginning of the vector only when we find an element
  74              ;; that does not match.
  75              (unless vector
  76                (setq vector (make-array 0))
  77                (dotimes (i index)
  78                  (vector-push-extend (aref seq i) vector)))
  79              (when vector
  80                (vector-push-extend elt vector))))
  81        (or vector seq)))))
  82
  83
  84 (defun some (function seq)
  85   (do-sequence (elt seq)
  86     (when (funcall function elt)
  87       (return-from some t))))
  88
  89 (defun every (function seq)
  90   (do-sequence (elt seq)
  91     (unless (funcall function elt)
  92       (return-from every nil)))
  93   t)
  94
  95 (defun remove-if (func seq)
  96   (cond
  97     ((listp  seq) (list-remove-if   func seq nil))
  98     ((arrayp seq) (vector-remove-if func seq nil))
  99     (t (error "`~S' is not of type SEQUENCE" seq))))
 100
 101 (defun remove-if-not (func seq)
 102   (cond
 103     ((listp  seq) (list-remove-if   func seq t))
 104     ((arrayp seq) (vector-remove-if func seq t))
 105     (t (error "`~S' is not of type SEQUENCE" seq))))
 106
 107 (defun list-remove-if (func list negate)
 108   (if (endp list)
 109     ()
 110     (let ((test (funcall func (car list))))
 111       (if (if negate (not test) test)
 112         (list-remove-if func (cdr list) negate)
 113         (cons (car list) (list-remove-if func (cdr list) negate))))))
 114
 115 (defun vector-remove-if (func vector negate)
 116   (let ((out-vector (make-array 0)))
 117     (do-sequence (element vector i)
 118       (let ((test (funcall func element)))
 119         (when (if negate test (not test))
 120           (vector-push-extend element out-vector))))
 121     out-vector))
 122
 123 ;;; TODO: Support both List and vectors in the following functions
 124
 125 (defun subseq (seq a &optional b)
 126   (if b
 127       (slice seq a b)
 128       (slice seq a)))