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
  96 ;;; TODO: Support both List and vectors in the following functions
  97
  98 (defun remove-if (func list)
  99   (cond
 100     ((null list)
 101      nil)
 102     ((funcall func (car list))
 103      (remove-if func (cdr list)))
 104     (t
 105      ;;
 106      (cons (car list) (remove-if func (cdr list))))))
 107
 108 (defun remove-if-not (func list)
 109   (cond
 110     ((null list)
 111      nil)
 112     ((funcall func (car list))
 113      (cons (car list) (remove-if-not func (cdr list))))
 114     (t
 115      (remove-if-not func (cdr list)))))
 116
 117 (defun subseq (seq a &optional b)
 118   (if b
 119       (slice seq a b)
 120       (slice seq a)))
 121