X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fsequence.lisp;h=7f86a85127d71162fe0af2ed7d42b67197ac8f5a;hb=d4ade72f9e7c97217ffafb7f9ca37f12161148af;hp=e5e7aca90e2bf1a7aed459432de500a4154f5b39;hpb=c2493e3427215081351e8ab6a0e90aebe946c86d;p=jscl.git diff --git a/src/sequence.lisp b/src/sequence.lisp index e5e7aca..7f86a85 100644 --- a/src/sequence.lisp +++ b/src/sequence.lisp @@ -13,74 +13,91 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . -(defmacro doseq ((elt seq &optional index) &body body) - (let* ((nseq (gensym "seq")) - (i (or index (gensym "i"))) - (list-body (if index - `(let ((,i -1)) - (dolist (,elt ,nseq) - (incf ,i) - ,@body)) - `(dolist (,elt ,nseq) - ,@body)))) +(defun not-seq-error (thing) + (error "`~S' is not of type SEQUENCE" thing)) + +(defmacro do-sequence ((elt seq &optional (index (gensym "i") index-p)) &body body) + (let ((nseq (gensym "seq"))) + (unless (symbolp elt) + (error "`~S' must be a symbol." elt)) `(let ((,nseq ,seq)) (if (listp ,nseq) - ,list-body - (dotimes (,i (length ,nseq)) - (let ((,elt (aref ,nseq ,i))) + ,(if index-p + `(let ((,index -1)) + (dolist (,elt ,nseq) + (incf ,index) + ,@body)) + `(dolist (,elt ,nseq) + ,@body)) + (dotimes (,index (length ,nseq)) + (let ((,elt (aref ,nseq ,index))) ,@body)))))) -(defun find (item seq &key key (test #'eql)) +(defun find (item seq &key key (test #'eql testp) (test-not #'eql test-not-p)) + (do-sequence (x seq) + (when (satisfies-test-p item x :key key :test test :testp testp + :test-not test-not :test-not-p test-not-p) + (return x)))) + +(defun find-if (predicate sequence &key key) (if key - (doseq (x seq) - (when (funcall test (funcall key x) item) + (do-sequence (x sequence) + (when (funcall predicate (funcall key x)) (return x))) - (doseq (x seq) - (when (funcall test x item) + (do-sequence (x sequence) + (when (funcall predicate x) (return x))))) -(defun find-if (predicate sequence &key (key #'identity)) - (do-sequence (x sequence) - (when (funcall predicate (funcall key x)) - (return x)))) +(defun position (elt sequence + &key key (test #'eql testp) + (test-not #'eql test-not-p) + (start 0) end) + ;; TODO: Implement START and END efficiently for all the sequence + ;; functions. + (let ((end (or end (length sequence)))) + (do-sequence (x sequence index) + (when (and (<= start index) + (< index end) + (satisfies-test-p elt x + :key key :test test :testp testp + :test-not test-not :test-not-p test-not-p)) + (return index))))) -(defun some (function seq) - (do-sequence (elt seq) - (when (funcall function elt) - (return-from some t)))) +;; TODO: need to support &key from-end +(defun position-if (predicate sequence + &key key (start 0) end) + ;; TODO: Implement START and END efficiently for all the sequence + ;; functions. + (let ((end (or end (length sequence)))) + (do-sequence (x sequence index) + (when (and (<= start index) + (< index end) + (funcall predicate (if key (funcall key x) x))) + (return index))))) -(defun every (function seq) - (do-sequence (elt seq) - (unless (funcall function elt) - (return-from every nil))) - t) +(defun position-if-not (predicate sequence + &key key (start 0) end) + (position-if (complement predicate) sequence :key key :start start :end end)) -(defun position (elt sequence) - (let ((pos 0)) - (do-sequence (x seq) - (when (eq elt x) - (return)) - (incf pos)) - pos)) - - -(defun remove (x seq) +(defun remove (x seq &key key (test #'eql testp) (test-not #'eql test-not-p)) (cond ((null seq) nil) ((listp seq) (let* ((head (cons nil nil)) (tail head)) - (doseq (elt seq) - (unless (eql x elt) + (do-sequence (elt seq) + (unless (satisfies-test-p x elt :key key :test test :testp testp + :test-not test-not :test-not-p test-not-p) (let ((new (list elt))) (rplacd tail new) (setq tail new)))) (cdr head))) (t (let (vector) - (doseq (elt seq index) - (if (eql x elt) + (do-sequence (elt seq index) + (if (satisfies-test-p x elt :key key :test test :testp testp + :test-not test-not :test-not-p test-not-p) ;; Copy the beginning of the vector only when we find an element ;; that does not match. (unless vector @@ -92,23 +109,70 @@ (or vector seq))))) -;;; TODO: Support vectors +(defun some (function seq) + (do-sequence (elt seq) + (when (funcall function elt) + (return-from some t)))) + +(defun every (function seq) + (do-sequence (elt seq) + (unless (funcall function elt) + (return-from every nil))) + t) + +(defun remove-if (func seq) + (cond + ((listp seq) (list-remove-if func seq nil)) + ((arrayp seq) (vector-remove-if func seq nil)) + (t (not-seq-error seq)))) -(defun remove-if (func list) +(defun remove-if-not (func seq) (cond - ((null list) - nil) - ((funcall func (car list)) - (remove-if func (cdr list))) - (t - ;; - (cons (car list) (remove-if func (cdr list)))))) + ((listp seq) (list-remove-if func seq t)) + ((arrayp seq) (vector-remove-if func seq t)) + (t (not-seq-error seq)))) + +(defun list-remove-if (func list negate) + (if (endp list) + () + (let ((test (funcall func (car list)))) + (if (if negate (not test) test) + (list-remove-if func (cdr list) negate) + (cons (car list) (list-remove-if func (cdr list) negate)))))) -(defun remove-if-not (func list) +(defun vector-remove-if (func vector negate) + (let ((out-vector (make-array 0))) + (do-sequence (element vector i) + (let ((test (funcall func element))) + (when (if negate test (not test)) + (vector-push-extend element out-vector)))) + out-vector)) + +(defun subseq (seq a &optional b) (cond - ((null list) - nil) - ((funcall func (car list)) - (cons (car list) (remove-if-not func (cdr list)))) - (t - (remove-if-not func (cdr list))))) + ((listp seq) + (if b + (let ((diff (- b a))) + (cond + ((zerop diff) ()) + ((minusp diff) + (error "Start index must be smaller than end index")) + (t + (let* ((drop-a (copy-list (nthcdr a seq))) + (pointer drop-a)) + (dotimes (_ (1- diff)) + (setq pointer (cdr pointer)) + (when (null pointer) + (error "Ending index larger than length of list"))) + (rplacd pointer ()) + drop-a)))) + (copy-list (nthcdr a seq)))) + ((vectorp seq) + (let* ((b (or b (length seq))) + (size (- b a)) + (new (make-array size :element-type (array-element-type seq)))) + (do ((i 0 (1+ i)) + (j a (1+ j))) + ((= j b) new) + (aset new i (aref seq j))))) + (t (not-seq-error seq))))