-
Notifications
You must be signed in to change notification settings - Fork 2
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #27 from ericlesaquiles/sequences
Added sequence tests
- Loading branch information
Showing
15 changed files
with
1,413 additions
and
1,104 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,28 @@ | ||
| (in-package "LISP") | ||
|
|
||
| (defun characterp (ch) | ||
| "Returns T if ch is a character, false otherwise." | ||
| (if (or (floatp ch) (derivedp ch object) (< ch 0)) | ||
| nil | ||
| t)) | ||
|
|
||
| (defun char-int (ch) (assert (characterp ch)) ch) | ||
| (defun char-not-equal (x y) | ||
| (assert (and (characterp x) (characterp y))) | ||
| (not (equal x y))) | ||
|
|
||
| (setf (symbol-function 'char<) #'< | ||
| (symbol-function 'char=) #'= | ||
| (symbol-function 'char>) #'> | ||
| (symbol-function 'char/=) #'/= | ||
| (symbol-function 'char<=) #'<= | ||
| (symbol-function 'char>=) #'>= | ||
| (symbol-function 'char-code) #'char-int | ||
| (symbol-function 'char-equal) #'equal | ||
| (symbol-function 'char-lessp) #'< | ||
| (symbol-function 'char-greaterp) #'> | ||
| (symbol-function 'char-not-lessp) #'>=) | ||
|
|
||
| (export '(characterp char-int char-code char-equal char-not-equal | ||
| char-lessp char-greaterp char-not-lessp | ||
| char< char= char> char/= char<= char>=)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,80 @@ | ||
| (in-package "LISP") | ||
|
|
||
|
|
||
| (defmacro complement (fn) | ||
| `(function (lambda (&rest args) (not (apply ,fn args))))) | ||
|
|
||
| ;;; EQUALP -- public. | ||
| ;; | ||
| (defun equalp (x y) | ||
| "Just like EQUAL, but more liberal in several respects. | ||
| Numbers may be of different types, as long as the values are identical | ||
| after coercion. Characters may differ in alphabetic case. Vectors and | ||
| arrays must have identical dimensions and EQUALP elements, but may differ | ||
| in their type restriction." | ||
| (cond ((eq x y) t) | ||
| ;;((characterp x) (and (characterp y) (char-equal x y))) <- characters are numbers | ||
| ((numberp x) (and (numberp y) (= x y))) | ||
| ((consp x) | ||
| (and (consp y) | ||
| (equalp (car x) (car y)) | ||
| (equalp (cdr x) (cdr y)))) | ||
| ((pathnamep x) | ||
| ;; (and (pathnamep y) (pathname= x y))) | ||
| (error "pathname is not yet supported here. Sorry.")) | ||
| ((hash-table-p x) | ||
| (error "hash table is not yet supported here. Sorry.")) | ||
| ;; (and (hash-table-p y) | ||
| ;; (eql (hash-table-count x) (hash-table-count y)) | ||
| ;; (eql (hash-table-test x) (hash-table-test y)) | ||
| ;; (with-hash-table-iterator (next x) | ||
| ;; (loop | ||
| ;; (multiple-value-bind (more x-key x-value) | ||
| ;; (next) | ||
| ;; (cond (more | ||
| ;; (multiple-value-bind (y-value foundp) | ||
| ;; (gethash x-key y) | ||
| ;; (unless (and foundp (equalp x-value y-value)) | ||
| ;; (return-from equalp nil)))) | ||
| ;; (t | ||
| ;; (return-from equalp t)))))))) | ||
| ;; ((%instancep x) | ||
| ;; (let* ((layout-x (%instance-layout x)) | ||
| ;; (len (layout-length layout-x))) | ||
| ;; (and (%instancep y) | ||
| ;; (eq layout-x (%instance-layout y)) | ||
| ;; (structure-class-p (layout-class layout-x)) | ||
| ;; (do ((i 1 (1+ i))) | ||
| ;; ((= i len) t) | ||
| ;; (declare (fixnum i)) | ||
| ;; (let ((x-el (%instance-ref x i)) | ||
| ;; (y-el (%instance-ref y i))) | ||
| ;; (unless (or (eq x-el y-el) | ||
| ;; (equalp x-el y-el)) | ||
| ;; (return-from equalp nil))))))) | ||
| ((vectorp x) | ||
| (let ((length (length x))) | ||
| (and (vectorp y) | ||
| (= length (length y)) | ||
| (dotimes (i length t) | ||
| (let ((x-el (aref x i)) | ||
| (y-el (aref y i))) | ||
| (if (not (or (eq x-el y-el) | ||
| (equalp x-el y-el))) | ||
| (return-from equalp nil))))))) | ||
| ((arrayp x) | ||
| (and (arrayp y) | ||
| (= (array-rank x) (array-rank y)) | ||
| (dotimes (axis (array-rank x) t) | ||
| (unless (= (array-dimension x axis) | ||
| (array-dimension y axis)) | ||
| (return-from equalp nil))) | ||
| (dotimes (index (array-total-size x) t) | ||
| (let ((x-el (row-major-aref x index)) | ||
| (y-el (row-major-aref y index))) | ||
| (unless (or (eq x-el y-el) | ||
| (equalp x-el y-el)) | ||
| (return-from equalp nil)))))) | ||
| (t nil))) | ||
|
|
||
| (export '(complement equalp)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,152 @@ | ||
| ;; Shadows a few substitute functions | ||
| ;; - substitute should accept a from-end keyword | ||
| ;; - count = nil should default to count = 10^6 (due to hacky reasons) | ||
|
|
||
| (in-package :lisp) | ||
|
|
||
|
|
||
| ;; TODO: implement from-end in sequence.c | ||
| (defmacro defsubstitute (name fn arg-lst | ||
| newitem olditem seq test testnot key iftest ifnottest start end count) | ||
| `(defun ,name ,arg-lst | ||
| (let ((count (or (and count (< count 0) 0) count 1000000)) | ||
| len) | ||
| (unless end (setq len (length seq) end len)) | ||
| (if from-end | ||
| (let ((len (or len (length seq)))) | ||
| (reverse (,fn ,newitem ,olditem (reverse ,seq) ,test ,testnot ,key ,iftest ,ifnottest (- len ,end) (- len ,start) ,count))) | ||
| (,fn ,newitem ,olditem ,seq ,test ,testnot ,key ,iftest ,ifnottest ,start ,end ,count))))) | ||
|
|
||
| (defsubstitute substitute system::raw-substitute | ||
| (newitem olditem seq | ||
| &key (start 0) (end nil) | ||
| (test #'eq) (test-not nil) | ||
| (count 1000000) | ||
| (key #'identity) | ||
| (from-end nil)) | ||
| newitem olditem seq test test-not key nil nil start end count) | ||
|
|
||
| (defsubstitute substitute-if system::raw-substitute | ||
| (newitem pred seq | ||
| &key (start 0) (end nil) | ||
| (count 1000000) | ||
| (key #'identity) | ||
| (from-end nil)) | ||
| newitem nil seq nil nil key pred nil start end count) | ||
|
|
||
| (defsubstitute substitute-if-not system::raw-substitute | ||
| (newitem pred seq | ||
| &key (start 0) (end nil) | ||
| (count 1000000) | ||
| (key #'identity) | ||
| (from-end nil)) | ||
| newitem nil seq nil nil key nil pred start end count) | ||
|
|
||
| (defsubstitute nsubstitute system::raw-nsubstitute | ||
| (newitem olditem seq | ||
| &key (start 0) (end nil) | ||
| (test #'eq) (test-not nil) | ||
| (count 1000000) | ||
| (key #'identity) | ||
| (from-end nil)) | ||
| newitem olditem seq test test-not key nil nil start end count) | ||
|
|
||
| (defsubstitute nsubstitute-if system::raw-nsubstitute | ||
| (newitem pred seq | ||
| &key (start 0) (end nil) | ||
| (key #'identity) | ||
| (count 1000000) | ||
| (from-end nil)) | ||
| newitem nil seq nil nil key pred nil start end count) | ||
|
|
||
| (defsubstitute nsubstitute-if-not system::raw-nsubstitute | ||
| (newitem pred seq | ||
| &key (start 0) (end nil) | ||
| (count 1000000) | ||
| (key #'identity) | ||
| (from-end nil)) | ||
| newitem nil seq nil nil key nil pred start end count) | ||
|
|
||
| ;; ;; Shadows replace function | ||
| ;; ;; - replace should default nil to entire string | ||
|
|
||
| (defun replace (dest src &key (start1 0) (end1 nil) | ||
| (start2 0) (end2 nil)) | ||
| (let ((end1 (or end1 (length dest))) | ||
| (end2 (or end2 (length src)))) | ||
| (let ((result dest) (count (min (- end1 start1) (- end2 start2)))) | ||
| (cond ((listp dest) | ||
| (setq dest (nthcdr start1 dest)) | ||
| (cond ((listp src) | ||
| (setq src (nthcdr start2 src)) | ||
| (dotimes (c count) | ||
| (setq (dest . car) (pop src)) | ||
| (pop dest))) | ||
| (t | ||
| (dotimes (c count) | ||
| (setq (dest . car) (aref src start2)) | ||
| (inc start2) (pop dest))))) | ||
| ((listp src) ; list --> vector | ||
| (setq src (nthcdr start2 src)) | ||
| (dotimes (c count) | ||
| (aset dest start1 (pop src)) | ||
| (inc start1))) | ||
| (t (system::vector-replace dest src start1 end1 start2 end2))) | ||
| result))) | ||
|
|
||
|
|
||
| ;; Add mismatch function | ||
|
|
||
| (defmacro mismatch-core (from-end) | ||
| `(when (if test-not | ||
| (funcall test-not | ||
| (funcall key (elt seq1 index1)) | ||
| (funcall key (elt seq2 index2))) | ||
| (not (funcall test | ||
| (funcall key (elt seq1 index1)) | ||
| (funcall key (elt seq2 index2))))) | ||
| (return-from mismatch ,(if from-end | ||
| '(1+ index1) | ||
| 'index1)))) | ||
|
|
||
| (defun mismatch (seq1 seq2 &key (from-end nil) | ||
| (test #'eql) | ||
| (test-not nil) | ||
| (start1 0) | ||
| (start2 0) | ||
| (end1 nil) | ||
| (end2 nil) | ||
| (key #'identity)) | ||
| "The specified subsequences of Sequence1 and Sequence2 are compared | ||
| element-wise. If they are of equal length and match in every element, the | ||
| result is NIL. Otherwise, the result is a non-negative integer, the index | ||
| within Sequence1 of the leftmost position at which they fail to match; or, | ||
| if one is shorter than and a matching prefix of the other, the index within | ||
| Sequence1 beyond the last position tested is returned. If a non-Nil | ||
| :From-End keyword argument is given, then one plus the index of the | ||
| rightmost position in which the sequences differ is returned." | ||
| (let ((end1 (or end1 (length seq1))) | ||
| (end2 (or end2 (length seq2)))) | ||
| (if (or (zerop end1) (zerop end2)) (return-from mismatch 0)) | ||
| (if from-end | ||
| (loop | ||
| for index1 from (- end1 1) downto start1 | ||
| for index2 from (- end2 1) downto start2 | ||
| do | ||
| (mismatch-core t)) | ||
| (loop | ||
| for index1 from start1 below end1 | ||
| for index2 from start2 below end2 | ||
| do | ||
| (mismatch-core nil))) | ||
| (cond | ||
| ((> (- end1 start1) (- end2 start2)) end2) | ||
| ((< (- end1 start1) (- end2 start2)) end1) | ||
| (t nil)))) | ||
|
|
||
| ;; ;; Auxiliary function to shadow peek-char | ||
| ;; (defun OOpeek-char (&optional (stream *standard-input*) | ||
| ;; (eof-errorp t) eof-value recursive-p) | ||
| ;; (peek-char stream eof-errorp eof-value recursive-p)) | ||
|
|
||
| (export '(mismatch)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.