X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fsequence.lisp;h=be36e994fedeef7904f48a9c61b48c6b91dcb71f;hb=fc17cd58e6bd60aa129bb879e3cf7452a944384b;hp=93e3fdd3871f0ae4d9cc02382d842e79c370d1e8;hpb=d204a3907769bfafd55fe8ca1b927a0b61812a56;p=jscl.git diff --git a/src/sequence.lisp b/src/sequence.lisp index 93e3fdd..be36e99 100644 --- a/src/sequence.lisp +++ b/src/sequence.lisp @@ -13,6 +13,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . +(/debug "loading sequence.lisp!") + +(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) @@ -30,14 +35,11 @@ (let ((,elt (aref ,nseq ,index))) ,@body)))))) -(defun find (item seq &key key (test #'eql)) - (if key - (do-sequence (x seq) - (when (funcall test (funcall key x) item) - (return x))) - (do-sequence (x seq) - (when (funcall test x item) - (return x))))) +(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 @@ -48,12 +50,38 @@ (when (funcall predicate x) (return x))))) -(defun position (elt sequence &key (test #'eql)) - (do-sequence (x seq index) - (when (funcall test elt x) - (return index)))) +(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 remove (x seq) +;; 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 position-if-not (predicate sequence + &key key (start 0) end) + (position-if (complement predicate) sequence :key key :start start :end end)) + +(defun remove (x seq &key key (test #'eql testp) (test-not #'eql test-not-p)) (cond ((null seq) nil) @@ -61,7 +89,8 @@ (let* ((head (cons nil nil)) (tail head)) (do-sequence (elt seq) - (unless (eql x elt) + (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)))) @@ -69,7 +98,8 @@ (t (let (vector) (do-sequence (elt seq index) - (if (eql x elt) + (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,30 +122,88 @@ (return-from every nil))) t) - -;;; TODO: Support both List and vectors in the following functions - -(defun remove-if (func list) +(defun remove-if (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 nil)) + ((arrayp seq) (vector-remove-if func seq nil)) + (t (not-seq-error seq)))) -(defun remove-if-not (func list) +(defun remove-if-not (func seq) (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) (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 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) - (if b - (slice seq a b) - (slice seq a))) + (cond + ((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)))) + +(defun copy-seq (sequence) + (subseq sequence 0)) + + +;;; Reduce (based on SBCL's version) +(defun reduce (function sequence &key key from-end (start 0) end (initial-value nil ivp)) + (let ((key (or key #'identity)) + (end (or end (length sequence)))) + (if (= end start) + (if ivp initial-value (funcall function)) + (macrolet ((reduce-list (function sequence key start end initial-value ivp from-end) + `(let ((sequence + ,(if from-end + `(reverse (nthcdr ,start ,sequence)) + `(nthcdr ,start ,sequence)))) + (do ((count (if ,ivp ,start (1+ ,start)) + (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value (funcall ,key (car sequence))) + ,(if from-end + `(funcall ,function (funcall ,key (car sequence)) value) + `(funcall ,function value (funcall ,key (car sequence)))))) + ((>= count ,end) value))))) + (if from-end + (reduce-list function sequence key start end initial-value ivp t) + (reduce-list function sequence key start end initial-value ivp nil))))))