Added positions-of-subsequence to array.lisp; added array-test.lisp.

Pascal J. Bourguignon [2018-08-01 03:31]
Added positions-of-subsequence to array.lisp; added  array-test.lisp.
Filename
common-lisp/cesarum/array-test.lisp
common-lisp/cesarum/array.lisp
common-lisp/cesarum/com.informatimago.common-lisp.cesarum.test.asd
diff --git a/common-lisp/cesarum/array-test.lisp b/common-lisp/cesarum/array-test.lisp
new file mode 100644
index 0000000..4b89e91
--- /dev/null
+++ b/common-lisp/cesarum/array-test.lisp
@@ -0,0 +1,100 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               array-test.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Tests for the array functions.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2018-07-27 <PJB> Created
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2018 - 2018
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* (copy-readtable nil)))
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY.TEST"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY")
+  (:export "TEST/ALL"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY.TEST")
+
+(define-test test/positions-of-subsequence ()
+  (assert-true (handler-case
+                   (positions-of-subsequence "" "abc hello abc world abc how do abc you do abc")
+                 (:no-error (&rest results)
+                   (declare (ignore results))
+                   nil)
+                 (error (error)
+                   (declare (ignore error))
+                   t)))
+
+  (assert-true (equal (positions-of-subsequence "xyz" "abc hello abc world abc how do abc you do abc")
+                      '()))
+  (assert-true (equal (positions-of-subsequence "abc" "abc")
+                      '((0 . 3))))
+  (assert-true (equal (positions-of-subsequence "abc" "abcabcabc")
+                      '((0 . 3) (3 . 6) (6 . 9))))
+  (assert-true (equal (positions-of-subsequence "aaa" "aaaaaaaaaa")
+                      '((0 . 3) (3 . 6) (6 . 9))))
+  (assert-true (equal (positions-of-subsequence "abc" "abc hello abc world abc how do abc you do abc")
+                      '((0 . 3) (10 . 13) (20 . 23) (31 . 34) (42 . 45))))
+
+  (assert-true (equal (positions-of-subsequence "xyz" "abc hello abc world abc how do abc you do abc"
+                                                :from-end t)
+                      '()))
+  (assert-true (equal (positions-of-subsequence "abc" "abc"
+                                                :from-end t)
+                      '((0 . 3))))
+  (assert-true (equal (positions-of-subsequence "abc" "abcabcabc"
+                                                :from-end t)
+                      '((0 . 3) (3 . 6) (6 . 9))))
+  (assert-true (equal (positions-of-subsequence "aaa" "aaaaaaaaaa"
+                                                :from-end t)
+                      '((1 . 4) (4 . 7) (7 . 10))))
+  (assert-true (equal (positions-of-subsequence "abc" "abc hello abc world abc how do abc you do abc"
+                                                :from-end t)
+                      '((0 . 3) (10 . 13) (20 . 23) (31 . 34) (42 . 45))))
+
+  (assert-true (equal (positions-of-subsequence #((1 ?) (2 ?) (3 ?))
+                                                #((1 a) (2 b) (3 c)
+                                                  (1 d) (2 e)
+                                                  (1 f) (2 g) (3 h)
+                                                  (2 i) (3 j))
+                                                :key (function car)
+                                                :test (function =))
+                      '((0 . 3) (5 . 8))))
+  (assert-true (equal (positions-of-subsequence #((1 ?) (2 ?) (3 ?))
+                                                #((1 a) (2 b) (3 c)
+                                                  (1 d) (2 e)
+                                                  (1 f) (2 g) (3 h)
+                                                  (2 i) (3 j))
+                                                :key (function car)
+                                                :test (function /=))
+                      '((1 . 4) (4 . 7)))))
+
+(define-test test/all ()
+  (test/positions-of-subsequence))
+
+;;;; THE END ;;;;
diff --git a/common-lisp/cesarum/array.lisp b/common-lisp/cesarum/array.lisp
index f34bbb5..14f38e3 100644
--- a/common-lisp/cesarum/array.lisp
+++ b/common-lisp/cesarum/array.lisp
@@ -63,7 +63,7 @@
                                  "PRINT-NOT-READABLE-OBJECT")
   (:export
    "POSITIONS" ; should go to a sequence package...
-
+   "POSITIONS-OF-SUBSEQUENCE"
    "VECTOR-EMPTYP" "VECTOR-FIRST" "VECTOR-LAST" "VECTOR-REST"
    "VECTOR-BUTLAST" "VECTOR-DELETE"
    "NUDGE-DISPLACED-VECTOR" "DISPLACED-VECTOR"
@@ -79,7 +79,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2005 - 2012
+    Copyright Pascal J. Bourguignon 2005 - 2018

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -98,8 +98,6 @@ License:
 "))
 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY")

-
-
 (defun positions (item vector &key (from-end nil) (test 'eql) (test-not nil) (start 0) (end nil) (count nil) (key 'identity))
   "
 RETURN:     A list of indices of the occurences of ITEM in the VECTOR.
@@ -132,7 +130,56 @@ EXAMPLE:    (positions 'a #(a door a window a big hole and a bucket) :start 1)
           :while (and p (or (null count) (<= 0 (decf count))))
           :collect p))))

+(defun positions-of-subsequence (subsequence vector &key (from-end nil) (test 'eql) (test-not nil) (start1 0) (end1 nil) (start2 0) (end2 nil) (count nil) (key 'identity))
+  "
+
+RETURN:     A list of cons cells containing the start and end of the
+            occurences of (subseq SUBSEQUENCE START1 END1) in the
+            VECTOR between START2 and END2.

+            The occurences are defined by the SUBSEQUENCE, START1,
+            START2, TEST, TEST-NOT, KEY, START2, END2, as in SEARCH,
+            and the FROM-END and COUNT parameters as in DELETE.
+
+"
+  (let* ((end1 (or end1 (length subsequence)))
+         (len1 (- end1 start1))
+         (args (list :key key
+                     (if test-not :test-not :test)
+                     (if test-not  test-not  test))))
+    (if (zerop len1)
+        (if count
+            (if from-end
+                (loop :repeat count
+                      :with result := '()
+                      :for i :from end2 :downto start2
+                      :do (push (cons i i) result)
+                      :finally (return result))
+                (loop :repeat count
+                      :for i :from start2 :to end2
+                      :collect (cons i i)))
+            (loop :for i :from start2 :to end2
+                  :collect (cons i i)))
+        (if from-end
+            (loop
+              :with result = '()
+              :for cur-end = end2 :then p
+              :for p = (apply (function search) subsequence vector
+                              :start1 start1 :end1 end1
+                              :start2 start2 :end2 cur-end
+                              :from-end t
+                              args)
+              :while (and p (or (null count) (<= 0 (decf count))))
+              :do (push (cons p (+ p len1)) result)
+              :finally (return result))
+            (loop
+              :for cur-start = start2 :then (+ p len1)
+              :for p = (apply (function search) subsequence vector
+                              :start1 start1    :end1 end1
+                              :start2 cur-start :end2 end2
+                              args)
+              :while (and p (or (null count) (<= 0 (decf count))))
+              :collect (cons p (+ p len1)))))))

 (defun vector-emptyp (vector)
   "
diff --git a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.test.asd b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.test.asd
index 0251be2..3149a81 100644
--- a/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.test.asd
+++ b/common-lisp/cesarum/com.informatimago.common-lisp.cesarum.test.asd
@@ -57,6 +57,7 @@
   #+asdf-unicode :encoding #+asdf-unicode :utf-8
   :depends-on ("com.informatimago.common-lisp.cesarum")
   :components ((:file "a-star-test"         :depends-on ())
+               (:file "array-test"          :depends-on ())
                (:file "cache-test"          :depends-on ())
                (:file "date-test"           :depends-on ())
                (:file "dictionary-test"     :depends-on ())
@@ -73,6 +74,7 @@
   #+asdf3 :perform #+asdf3 (asdf:test-op
                             (operation system)
                             (dolist (p '("COM.INFORMATIMAGO.COMMON-LISP.CESARUM.A-STAR.TEST"
+                                         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY.TEST"
                                          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CACHE.TEST"
                                          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.DATE.TEST"
                                          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.DICTIONARY.TEST"
ViewGit