Implement SUBSEQ for lists
[jscl.git] / 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))))