string iterator

6 files changed, 418 insertions, 0 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..868a778
--- /dev/null
+++ b/README.md
@@ -0,0 +1,8 @@
+# Container Iterators
+
+Container iterators are a generic way to access elements in a linearly
+ordered collection, such as strings, vectors, and ordered sets.
+
+"Iterators" are in the style of C++: they can (potentially) go forward,
+backward, have start and end limits, etc. Not all operations are available
+for a concrete iterator.
diff --git a/generic-iterator.scm b/generic-iterator.scm
new file mode 100644
index 0000000..c38c346
--- /dev/null
+++ b/generic-iterator.scm
@@ -0,0 +1,134 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-record-type <iterator-implementation>
+  (make-iterator-implementation start end
+                                start? end?
+                                advance
+                                ref
+                                to-index from-index
+                                comparator)
+  iterator-implementation?
+  (start get-start)
+  (end get-end)
+  (start? get-start-predicate)
+  (end? get-end-predicate)
+  (advance get-advance)
+  (ref get-ref)
+  (to-index get-to-index-procedure)
+  (from-index get-from-index-procedure)
+  (comparator get-comparator))
+
+(define-record-type <iterator>
+  (make-iterator implementation data)
+  iterator?
+  (implementation get-implementation)
+  (data get-data))
+
+;;; Define a function that invokes a field of the iterator on the data
+;;; object inside the iterator and any other arguments supplied to the
+;;; function.
+(define-syntax define-invoke-field-of-iterator
+  (syntax-rules ()
+    ((define-invoker name field-accessor emsg args ...)
+     (define (name iterator args ...)
+       (let ((proc (field-accessor (get-implementation iterator))))
+         (if (not proc)
+             (error emsg iterator)
+             (proc (get-data iterator) args ...)))))))
+
+;;; Define a constructor (something that makes an iterator from something
+;;; that is not an iterator).
+;;; 
+;;; The constructor can take as arguments either
+;;; 
+;;; 1) The implementation and any data objects necessary to make the
+;;;    iterator, or
+;;; 2) The iterator and any objects necessary to make the iterator, where
+;;;    the data in the iterator is the first such object.
+;;; 
+;;; This is implemented as a macro to catch arity issues.
+(define-syntax define-constructor-for-iterator-or-implementation
+  (syntax-rules ()
+    ((_ name field emsg args ...)
+     (define name
+       (case-lambda
+         ((iterator args ...)
+          (name (get-implementation iterator)
+                (get-data iterator)
+                args ...))
+         ((implementation data args ...)
+          (let ((constructor (field implementation)))
+            (if (not constructor)
+                (error emsg implementation data args ...)
+                (constructor data args ...)))))))))
+
+(define-constructor-for-iterator-or-implementation iterator-at-start
+  get-start
+  "no start constructor")
+
+(define-constructor-for-iterator-or-implementation iterator-at-end
+  get-end
+  "no end")
+
+(define-invoke-field-of-iterator iterator-at-start?
+  get-start-predicate
+  "no start predicate")
+(define-invoke-field-of-iterator iterator-at-end?
+  get-end-predicate
+  "no end predicate")
+
+(define-invoke-field-of-iterator iterator-advance
+  get-advance
+  "no procedure to move iterator"
+  spaces)
+
+(define-invoke-field-of-iterator iterator-ref
+  get-ref
+  "no procedure to access value at iterator")
+
+(define-invoke-field-of-iterator iterator->index
+  get-to-index-procedure
+  "no procedure to convert iterator->index")
+
+(define-constructor-for-iterator-or-implementation index->iterator
+  get-from-index-procedure
+  "no procedure to convert index->iterator"
+  index)
+
+;;; Create a procedure that calls COMPARISON on all (ITER1 . ITER-REST).
+;;; COMPARATOR-TYPE? is a predicate against the comparator, and if the
+;;; comparator fails the predicate an error message with string EMSG
+;;; will thrown.
+(define (generate-comparison comparison comparator-type? emsg)
+  (lambda (iter1 . iter-rest)
+    (let ((comparator (get-comparator (get-implementation iter1))))
+      (if (not (comparator-type? comparator))
+          (apply error emsg iter1 iter-rest)
+          (apply comparison comparator
+                 (map get-data (cons iter1 iter-rest)))))))
+
+(define iterator=?
+  (generate-comparison =? comparator? "no comparator"))
+
+(define iterator<?
+  (generate-comparison <? comparator-ordered? "no ordered comparator"))
+(define iterator>?
+  (generate-comparison >? comparator-ordered? "no ordered comparator"))
+
+(define iterator<=?
+  (generate-comparison <=? comparator-ordered? "no ordered comparator"))
+(define iterator>=?
+  (generate-comparison >=? comparator-ordered? "no ordered comparator"))
diff --git a/mcgoron.iterator.base.sld b/mcgoron.iterator.base.sld
new file mode 100644
index 0000000..22fd3c4
--- /dev/null
+++ b/mcgoron.iterator.base.sld
@@ -0,0 +1,29 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (mcgoron iterator base)
+  (import (scheme base) (scheme write) (scheme case-lambda) (srfi 128))
+  (export make-iterator-implementation iterator-implementation?
+          make-iterator iterator?
+          get-implementation get-data
+          iterator-at-start iterator-at-end
+          iterator-at-start? iterator-at-end?
+          iterator-advance
+          iterator-ref
+          iterator->index
+          index->iterator
+          iterator=? iterator<? iterator>? iterator<=? iterator>=?)
+  (include "generic-iterator.scm"))
+
diff --git a/mcgoron.iterator.string.sld b/mcgoron.iterator.string.sld
new file mode 100644
index 0000000..a72b9d0
--- /dev/null
+++ b/mcgoron.iterator.string.sld
@@ -0,0 +1,24 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (mcgoron iterator string)
+  (import (scheme base) (mcgoron iterator base)
+          (scheme case-lambda)
+          (srfi 130) (srfi 128) (srfi 26))
+  (export string-iterator-implementation
+          string-iterator-start
+          string-iterator-end
+          string-index->iterator)
+  (include "string-iterator.scm"))
diff --git a/string-iterator.scm b/string-iterator.scm
new file mode 100644
index 0000000..8589bdf
--- /dev/null
+++ b/string-iterator.scm
@@ -0,0 +1,160 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-record-type <fat-cursor>
+  (make-fat-cursor str srfi-130-cursor)
+  fat-cursor?
+  (str get-str)
+  (srfi-130-cursor get-srfi-130-cursor))
+
+(define-syntax lambda-fat-cursor
+  (syntax-rules ()
+    ((lambda-fat-cursor (str cursor rest ...) body ...)
+     (lambda (fat-cursor rest ...)
+       (let ((str (get-str fat-cursor))
+             (cursor (get-srfi-130-cursor fat-cursor)))
+         body ...)))))
+
+(define (recursively-compare predicate?)
+  (letrec ((cmp
+            (case-lambda
+              ((_) #t)
+              ((fc1 fc2)
+               (and (eq? (get-str fc1) (get-str fc2))
+                    (predicate? (get-srfi-130-cursor fc1)
+                                (get-srfi-130-cursor fc2))))
+              ((fc1 fc2 . fc-rest)
+               (and (cmp fc1 fc2)
+                    (apply cmp fc2 fc-rest))))))
+    cmp))
+
+(define fat-cursor=? (recursively-compare string-cursor=?))
+(define fat-cursor<? (recursively-compare string-cursor<?))
+
+(define fat-cursor-comparator
+  (make-comparator
+   fat-cursor?
+   fat-cursor=?
+   fat-cursor<?
+   #f))
+
+(define (string-cursor-valid-movement? str cursor spaces)
+  (cond
+    ((not (integer? spaces)) (error "can only move by exact integer"
+                                    spaces))
+    ((negative? spaces)
+     (<= (- spaces)
+         (string-cursor-diff str (string-cursor-start str) cursor)))
+    ((positive? spaces)
+     (<= spaces
+         (string-cursor-diff str cursor (string-cursor-end str))))
+    (else #t)))
+
+(define string-iterator-implementation
+  (letrec* ((make-string-iterator
+             (lambda (str cursor)
+               (make-iterator impl
+                              (make-fat-cursor str cursor))))
+            (start
+             (lambda (object)
+               (cond
+                 ((string? object)
+                  (make-string-iterator object
+                                        (string-cursor-start object)))
+                 ((fat-cursor? object)
+                  (make-string-iterator (get-str object)
+                                        (string-cursor-start
+                                         (get-str object))))
+                 (else (error "invalid object for start" object)))))
+            (end
+             (lambda (object)
+               (cond
+                 ((string? object)
+                  (make-string-iterator object
+                                        (string-cursor-end object)))
+                 ((fat-cursor? object)
+                  (make-string-iterator (get-str object)
+                                        (string-cursor-end
+                                         (get-str object))))
+                 (else (error "invalid object for end" object)))))
+            (start?
+             (lambda-fat-cursor (str cursor)
+               (string-cursor=? cursor (string-cursor-start str))))
+            (end?
+             (lambda-fat-cursor (str cursor)
+               (string-cursor=? cursor (string-cursor-end str))))
+            (advance
+             (lambda-fat-cursor (str cursor spaces)
+               (cond
+                 ((not (string-cursor-valid-movement? str cursor spaces))
+                  #f)
+                 ((negative? spaces)
+                  (make-string-iterator str
+                                        (string-cursor-back str
+                                                            cursor
+                                                            (- spaces))))
+                 (else
+                  (make-string-iterator str
+                                        (string-cursor-forward str
+                                                               cursor
+                                                               spaces))))))
+            (ref
+             (lambda (fat-cursor)
+               (if (end? fat-cursor)
+                   (error "cannot ref one past the end of the sequence"
+                          fat-cursor)
+                   (string-ref/cursor (get-str fat-cursor)
+                                      (get-srfi-130-cursor fat-cursor)))))
+            (to-index
+             (lambda-fat-cursor (str cursor)
+               (string-cursor->index str cursor)))
+            (from-index%string
+             (lambda (str index)
+               (make-string-iterator str
+                                     (string-index->cursor str index))))
+            (from-index
+             (lambda (obj index)
+               (cond
+                 ((string? obj) (from-index%string obj index))
+                 ((fat-cursor? obj)
+                  (from-index%string (get-str obj) index))
+                 (else (error "invalid object for from-index" obj index)))))
+            (impl
+             (make-iterator-implementation
+              start end
+              start? end?
+              advance ref
+              to-index from-index
+              fat-cursor-comparator)))
+    impl))
+
+(define (constructor-for-iterator-or-string procedure)
+  (lambda (object . rest)
+    (cond
+      ((string? object) (apply procedure
+                               string-iterator-implementation
+                               object
+                               rest))
+      ((iterator? object) (apply procedure
+                                 object
+                                 rest))
+      (else (error "invalid object" object rest)))))
+
+(define string-iterator-start
+  (constructor-for-iterator-or-string iterator-at-start))
+(define string-iterator-end
+  (constructor-for-iterator-or-string iterator-at-end))
+(define string-index->iterator
+  (constructor-for-iterator-or-string index->iterator))
diff --git a/test-string-iterator.scm b/test-string-iterator.scm
new file mode 100644
index 0000000..10a0020
--- /dev/null
+++ b/test-string-iterator.scm
@@ -0,0 +1,63 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(cond-expand
+ (chicken (import r7rs))
+ (else))
+
+(load "mcgoron.iterator.base.sld")
+(load "mcgoron.iterator.string.sld")
+
+(import (srfi 64) (mcgoron iterator string)
+        (mcgoron iterator base))
+
+(let* ((str "")
+       (itr (string-iterator-start str)))
+  (test-begin "empty string")
+  (test-assert "iterator-at-start?" (iterator-at-start? itr))
+  (test-assert "iterator-at-end?" (iterator-at-end? itr))
+  (test-assert "iterator-advance 1" (not (iterator-advance itr 1)))
+  (test-assert "iterator-advance -1" (not (iterator-advance itr -1)))
+  (test-eqv "iterator->index" 0 (iterator->index itr))
+  (test-assert "iterator=?" (iterator=? itr (string-iterator-end str)))
+  (test-error "iterator-ref" #t (iterator-ref itr))
+  (test-end "empty string"))
+
+(let* ((str "a")
+       (itr (string-iterator-start str))
+       (itr-from-itr (string-iterator-start itr)))
+  (test-begin "single character string")
+  (test-assert "iterator-at-start?" (iterator-at-start? itr))
+  (test-assert "iterator-at-end?" (not (iterator-at-end? itr)))
+  (test-assert (iterator=? itr itr-from-itr))
+  (test-eqv "iterator-ref 0" #\a (iterator-ref itr))
+  (test-assert "iterator-advance start -1" (not (iterator-advance itr -1)))
+  (let ((next-itr (iterator-advance itr 1)))
+    (test-assert "iterator? advanced" (iterator? next-itr))
+    (test-assert "iterator-at-end? advanced" (iterator-at-end? next-itr))
+    (test-assert "iterator=? end advanced"
+                 (iterator=? next-itr (string-iterator-end str)))
+    (test-assert "iterator=? itr next-itr"
+                 (not (iterator=? itr next-itr)))
+    (test-assert "iterator<? itr next-itr"
+                 (iterator<? itr next-itr))
+    (test-assert "iterator=? itr previous"
+                 (iterator=? itr (iterator-advance next-itr -1)))
+    (test-eqv "iterator->index next-itr" 1
+              (iterator->index next-itr))
+    (test-error "iterator-ref next-itr"
+                #t (iterator-ref next-itr)))
+  (test-end "single character string"))
+