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 doseq ((elt seq &optional index) &body body)
  17   (let* ((nseq (gensym "seq"))
  18          (i (or index (gensym "i")))
  19          (list-body (if index
  20                         `(let ((,i -1))
  21                            (dolist (,elt ,nseq)
  22                              (incf ,i)
  23                              ,@body))
  24                         `(dolist (,elt ,nseq)
  25                            ,@body))))
  26     `(let ((,nseq ,seq))
  27        (if (listp ,nseq)
  28            ,list-body
  29            (dotimes (,i (length ,nseq))
  30              (let ((,elt (aref ,nseq ,i)))
  31                ,@body))))))
  32
  33 (defun find (item seq &key key (test #'eql))
  34   (if key
  35       (doseq (x seq)
  36         (when (funcall test (funcall key x) item)
  37           (return x)))
  38       (doseq (x seq)
  39         (when (funcall test x item)
  40           (return x)))))
  41
  42 (defun find-if (predicate sequence &key (key #'identity))
  43   (do-sequence (x sequence)
  44     (when (funcall predicate (funcall key x))
  45       (return x))))
  46
  47 (defun some (function seq)
  48   (do-sequence (elt seq)
  49     (when (funcall function elt)
  50       (return-from some t))))
  51
  52 (defun every (function seq)
  53   (do-sequence (elt seq)
  54     (unless (funcall function elt)
  55       (return-from every nil)))
  56   t)
  57
  58 (defun position (elt sequence)
  59   (let ((pos 0))
  60     (do-sequence (x seq)
  61       (when (eq elt x)
  62         (return))
  63       (incf pos))
  64     pos))
  65
  66
  67 (defun remove (x seq)
  68   (cond
  69     ((null seq)
  70      nil)
  71     ((listp seq)
  72      (let* ((head (cons nil nil))
  73             (tail head))
  74        (doseq (elt seq)
  75          (unless (eql x elt)
  76            (let ((new (list elt)))
  77              (rplacd tail new)
  78              (setq tail new))))
  79        (cdr head)))
  80     (t
  81      (let (vector)
  82        (doseq (elt seq index)
  83          (if (eql x elt)
  84              ;; Copy the beginning of the vector only when we find an element
  85              ;; that does not match.
  86              (unless vector
  87                (setq vector (make-array 0))
  88                (dotimes (i index)
  89                  (vector-push-extend (aref seq i) vector)))
  90              (when vector
  91                (vector-push-extend elt vector))))
  92        (or vector seq)))))
  93
  94
  95 ;;; TODO: Support vectors
  96
  97 (defun remove-if (func list)
  98   (cond
  99     ((null list)
 100      nil)
 101     ((funcall func (car list))
 102      (remove-if func (cdr list)))
 103     (t
 104      ;;
 105      (cons (car list) (remove-if func (cdr list))))))
 106
 107 (defun remove-if-not (func list)
 108   (cond
 109     ((null list)
 110      nil)
 111     ((funcall func (car list))
 112      (cons (car list) (remove-if-not func (cdr list))))
 113     (t
 114      (remove-if-not func (cdr list)))))