string iterator

1 files changed, 160 insertions, 0 deletions

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))