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 (defun not-seq-error (thing)
  17   (error "`~S' is not of type SEQUENCE" thing))
  18
  19 (defmacro do-sequence ((elt seq &optional (index (gensym "i") index-p)) &body body)
  20   (let ((nseq (gensym "seq")))
  21     (unless (symbolp elt)
  22       (error "`~S' must be a symbol." elt))
  23     `(let ((,nseq ,seq))
  24        (if (listp ,nseq)
  25            ,(if index-p
  26                 `(let ((,index -1))
  27                    (dolist (,elt ,nseq)
  28                      (incf ,index)
  29                      ,@body))
  30                 `(dolist (,elt ,nseq)
  31                    ,@body))
  32            (dotimes (,index (length ,nseq))
  33              (let ((,elt (aref ,nseq ,index)))
  34                ,@body))))))
  35
  36 (defun find (item seq &key key (test #'eql))
  37   (if key
  38       (do-sequence (x seq)
  39         (when (funcall test (funcall key x) item)
  40           (return x)))
  41       (do-sequence (x seq)
  42         (when (funcall test x item)
  43           (return x)))))
  44
  45 (defun find-if (predicate sequence &key key)
  46   (if key
  47       (do-sequence (x sequence)
  48         (when (funcall predicate (funcall key x))
  49           (return x)))
  50       (do-sequence (x sequence)
  51         (when (funcall predicate x)
  52           (return x)))))
  53
  54 (defun position (elt sequence &key (test #'eql))
  55   (do-sequence (x seq index)
  56     (when (funcall test elt x)
  57       (return index))))
  58
  59 (defun remove (x seq)
  60   (cond
  61     ((null seq)
  62      nil)
  63     ((listp seq)
  64      (let* ((head (cons nil nil))
  65             (tail head))
  66        (do-sequence (elt seq)
  67          (unless (eql x elt)
  68            (let ((new (list elt)))
  69              (rplacd tail new)
  70              (setq tail new))))
  71        (cdr head)))
  72     (t
  73      (let (vector)
  74        (do-sequence (elt seq index)
  75          (if (eql x elt)
  76              ;; Copy the beginning of the vector only when we find an element
  77              ;; that does not match.
  78              (unless vector
  79                (setq vector (make-array 0))
  80                (dotimes (i index)
  81                  (vector-push-extend (aref seq i) vector)))
  82              (when vector
  83                (vector-push-extend elt vector))))
  84        (or vector seq)))))
  85
  86
  87 (defun some (function seq)
  88   (do-sequence (elt seq)
  89     (when (funcall function elt)
  90       (return-from some t))))
  91
  92 (defun every (function seq)
  93   (do-sequence (elt seq)
  94     (unless (funcall function elt)
  95       (return-from every nil)))
  96   t)
  97
  98 (defun remove-if (func seq)
  99   (cond
 100     ((listp  seq) (list-remove-if   func seq nil))
 101     ((arrayp seq) (vector-remove-if func seq nil))
 102     (t (not-seq-error seq))))
 103
 104 (defun remove-if-not (func seq)
 105   (cond
 106     ((listp  seq) (list-remove-if   func seq t))
 107     ((arrayp seq) (vector-remove-if func seq t))
 108     (t (not-seq-error seq))))
 109
 110 (defun list-remove-if (func list negate)
 111   (if (endp list)
 112     ()
 113     (let ((test (funcall func (car list))))
 114       (if (if negate (not test) test)
 115         (list-remove-if func (cdr list) negate)
 116         (cons (car list) (list-remove-if func (cdr list) negate))))))
 117
 118 (defun vector-remove-if (func vector negate)
 119   (let ((out-vector (make-array 0)))
 120     (do-sequence (element vector i)
 121       (let ((test (funcall func element)))
 122         (when (if negate test (not test))
 123           (vector-push-extend element out-vector))))
 124     out-vector))
 125
 126 (defun subseq (seq a &optional b)
 127   (cond
 128     ((listp seq)
 129      (if b
 130        (let ((diff (- b a)))
 131          (cond
 132            ((zerop  diff) ())
 133            ((minusp diff)
 134             (error "Start index must be smaller than end index"))
 135            (t
 136             (let* ((drop-a (nthcdr a seq))
 137                    (pointer drop-a))
 138               (dotimes (n (1- diff))
 139                 (setq pointer (cdr pointer))
 140                 (when (null pointer)
 141                   (error "Ending index larger than length of list")))
 142               (setf (cdr pointer) nil)
 143               drop-a))))
 144        (nthcdr a seq)))
 145     ((arrayp seq)
 146      (if b
 147        (slice seq a b)
 148        (slice seq a)))
 149     (t (not-seq-error seq))))