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