goof-loop/goof/iterators.scm

;; iterators.scm - iterators for goof-loop. 
;;
;; Copyright 2020-2021 Linus Björnstam
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the author(s) may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; TODO iterators
;; in-stream

(define-syntax in
  (syntax-rules () 
    ((in :for ((var) (init)) n . rest)
     (n () ((var init var)) () () () . rest))
    ((in :for ((var) (init step)) n . rest)
     (n () ((var init step)) () () () . rest))
    ((in :for ((var) (init step stop)) n . rest)
     (n () ((var init step)) (stop) () () . rest))))

(define-syntax in-list
  (syntax-rules (:for)
    ((in-list :for ((var) source) next . rest)
     (in-list :for ((var cursor) source) next . rest))
    ((in-list :for ((var cursor) source) next . rest)
     (in-list :for ((var cursor succ) source) next . rest))
    ((in-list :for ((var cursor succ) (source)) next . rest)
     (in-list :for ((var cursor succ) (source cdr)) next . rest))
    ((in-list :for ((var cursor succ) (source step)) next . rest)
     (next
      ;; outer let bindings, bound outside the loop, unchanged during the loop
      ()
      ;; iterator, init, step
      ((cursor source succ))
      ;; tests to check whether the iterator is exhausted.
      ((not (pair? cursor)))
      ;; loop variables (called refs) and updates.
      ((var (car cursor))
       (succ (step cursor)))
      ;; final bindings: things bound in the final function.
      ()
      ;; the continuation.
      . rest))

    ;; Generator-clauses
    ((in-list lst)
     (gen-list lst))
    ((in-list (var) (expr step))
     (gen-list lst step))))

(define gen-list
  (case-lambda
    ((lst)
     (gen-list lst cdr))
    ((lst by)
     (lambda ()
       (if (null? lst)
           (eof-object)
           (let ((res (car lst)))
             (set! lst (by lst))
             res))))))


(define-syntax in-lists
  (syntax-rules (:for)
    ((in-lists :for ((elts) lol) next . rest)
     (in-lists :for ((elts pairs) lol) next . rest))
    ((in-lists :for ((elts pairs) lol) next . rest)
     (in-lists :for ((elts pairs succ) lol) next . rest))
    ((in-lists :for ((elts pairs succ) (lol)) next . rest)
     (in-lists :for ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists :for ((elts pairs succ) (lol)) next . rest)
     (in-lists :for ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists :for ((elts pairs succ) (lol step)) next . rest)
     (in-lists :for ((elts pairs succ) (lol step null?)) next . rest))
    ((in-lists :for ((elts pairs succ) (lol step done?)) next . rest)
     (next ()
           ((pairs lol succ))
           ((let lp ((ls pairs)) ; an in-lined ANY
              (and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
           ((elts (map car pairs))
            (succ (map step pairs)))
           ()
           . rest))
    ;; Generator clause
    ((in-lists lists ...)
     (gen-lists lists ...))))

    
;; TODO: make this not slow.
(define (gen-lists . lists)
  (lambda ()
    (if (any null? lists)
        (eof-object)
        (let ((cars (map car lists))
              (cdrs (map cdr lists)))
          (set! lists cdrs)
          (values cars)))))
          
  

(define-syntax define-in-indexed
  (syntax-rules ()
    ((define-in-indexed in-type in-type-reverse length ref)
     (begin
       (define-syntax in-type
         (syntax-rules ()
           ((in-type :for seq next . rest)
            (%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))
           ((in-type coll)
            (in-indexed-generator coll length ref))))
       (define-syntax in-type-reverse
         (syntax-rules ()
           ((in-type-reverse :for seq next . rest)
            (%in-idx <
                     (lambda (x i) (- i 1))
                     (lambda (x) (- (length x) 1))
                     (lambda (x) 0) ref tmp seq next . rest))
           ((in-type coll)
            (in-indexed-generator-reverse coll length ref))))))))

(define (in-indexed-generator coll len ref)
  (let ((index -1)
        (length (len coll)))
    (lambda ()
      (set! index (+ index 1))
      (if (>= index length)
          (eof-object)
          (ref coll index)))))

(define (in-indexed-generator-reverse coll len ref)
  (let ((index (len coll)))
    (lambda ()
      (set! index (- index 1))
      (if (< index 0)
          (eof-object)
          (ref coll index)))))

(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)

(define-in-indexed in-string in-string-reverse string-length string-ref)

;; helper for the above string and vector iterators
(define-syntax %in-idx
  (syntax-rules ()
    ;;   cmp inc start end ref
    ((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
     (%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
     (%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
     (%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
    ((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
     (next ((tmp seq) (end to))
           ((index from (+ tmp index)))
           ((ge index end))
           ((var (r tmp index)))
           ()
       . rest))))


(define-syntax in-port
  (syntax-rules ()
    ((in-port :for ((var) source) next . rest)
     (in-port :for ((var p) source) next . rest))
    ((in-port :for ((var p) ()) next . rest)
     (in-port :for ((var p) ((current-input-port))) next . rest))
    ((in-port :for ((var p) (port)) next . rest)
     (in-port :for ((var p) (port read-char)) next . rest))
    ((in-port :for ((var p) (port read-char)) next . rest)
     (in-port :for ((var p) (port read-char eof-object?)) next . rest))
    ((in-port :for ((var p) (port reader eof?)) next . rest)
     (next ((p port))
           ((var (reader p) (reader p)))
           ((eof? var))
           ()
           ()
           . rest))
    ;; generator clauses
    ((in-port port)
     (gen-port port read-char eof-object?))
    ((in-port port reader)
     (gen-port port reader eof-object?))
    ((in-port port reader eof?)
     (gen-port port reader eof?))))

(define (gen-port port read eof?)
  (lambda ()
    (let ((res (read port)))
      (if (eof? res)
          (eof-object)
          res))))

(define-syntax in-file
  (syntax-rules ()
    ((in-file :for ((var) source) next . rest)
     (in-file :for ((var p) source) next . rest))
    ((in-file :for ((var p) (file)) next . rest)
     (in-file :for ((var p) (file read-char)) next . rest))
    ((in-file :for ((var p) (file reader)) next . rest)
     (in-file :for ((var p) (file reader eof-object?)) next . rest))
    ((in-file :for ((var p) (file reader eof?)) next . rest)
     (next ((p (open-input-file file)) (r reader) (e? eof?))
           ((var (r p) (r p)))
           ((e? var))
           ()
           ((close-input-port p)) . rest))
    ;; generator clauses
    ((in-file path)
     (gen-file path read-char eof-object?))
    ((in-file path read)
     (gen-file path read eof-object?))
    ((in-file path read eof?)
     (gen-file path read eof?))))

(define (gen-file path read eof?)
  (let ((file (open-input-file path)))
    (lambda ()
      (let ((res (read file)))
        (cond ((eof? res)
               (close-port file)
               (eof-object))
              (else res))))))

(define-syntax in-generator
  (syntax-rules ()
    ((_ :for ((var) source) next . rest)
     (next ((gen source))
           ((var (gen) (gen)))
           ((eof-object? var))
           ()
           ()
           . rest))
    ;; yes, generator clause
    ((in-generator gen)
     (let ((g gen))
       (lambda ()
         (g))))))

(define (make-up-from-generator/bounded start limit step)
  (lambda ()
    (if (>= start limit)
        (eof-object)
        (let ((res start))
          (set! start (+ start step))
          res))))

(define (make-up-from-generator/unbounded start step)
  (lambda ()
    (let ((res start))
      (set! start (+ start step))
      res)))


(define-syntax up-from
  (syntax-rules (:to :by)
    ((up-from :for (() . args) next . rest)
     (up-from :for ((var) . args) next . rest))
    ((up-from :for ((var) (start (:to limit) (:by step))) next . rest)
     (next ((s start) (l limit) (e step))
           ((var s (+ var e)))
           ((>= var l))
           () () . rest))
    ((up-from :for ((var) (start (:to limit))) next . rest)
     (next ((s start) (l limit)) ((var s (+ var 1)))
           ((>= var l)) () () . rest))
    ((up-from :for ((var) (start (:by step))) next . rest)
     (next ((s start) (e step))
           ((var s (+ var e))) () () () . rest))
    ((up-from :for ((var) (start)) next . rest)
     (next ((s start)) ((var s (+ var 1)))
           () () () . rest))
    ;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
    ((up-from :for ((var) (start limit step)) next . rest)
     (next ((s start) (l limit) (e step)) ((var s (+ var e))) ((>= var l)) () () . rest))
    ((up-from :for ((var) (start limit)) next . rest)
     (up-from :for ((var) (start limit 1)) next . rest))
    ;; Generator clauses
    ((up-from start (:to limit) (:by step))
     (make-up-from-generator/bounded start limit step))
    ((up-from start (:to limit))
     (make-up-from-generator/bounded start limit 1))
    ((up-from start (:by step))
     (make-up-from-generator/unbounded start step))
    ((up-from start)
     (make-up-from-generator/unbounded start 1))
    ((up-from start limit step)
     (make-up-from-generator/bounded start limit step))
    ((up-from start limit) (make-up-from-generator/bounded start limit 1))))


(define (make-down-from-generator/bounded start end step)
  (lambda ()
    (if (< start end)
        (eof-object)
        (let ((res start))
          (set! start (- start step))
          res))))

(define (make-down-from-generator/unbounded start step)
  (lambda ()
    (let ((res start))
      (set! start (- start step))
      res)))

(define-syntax down-from
  (syntax-rules (:to :by)
    ((down-from :for (() . args) next . rest)
     (down-from :for ((var) . args) next . rest))
    ((down-from :for ((var) (start (:to limit) (:by step))) next . rest)
     (next ((s start) (l limit) (e step))
           ((var (- s e) (- var e)))
           ((< var l))
           () () . rest))
    ((down-from :for ((var) (start (:to limit))) next . rest)
     (next ((s start) (l limit)) ((var (- s 1) (- var 1)))
           ((< var l)) () () . rest))
    ((down-from :for ((var) (start (:by step))) next . rest)
     (next ((s start) (e step)) ((var (- s e) (- var e)))
           () () () . rest))
    ((down-from :for ((var) (start)) next . rest)
     (next ((s start)) ((var (- s 1) (- var 1)))
           () () () . rest))
    ((down-from :for ((var) (start limit step)) next . rest)
     (next ((s start) (l limit) (e step)) ((var (- s e) (- var e))) ((< var l)) () () . rest))
    ((down-from :for ((var) (start limit)) next . rest)
     (down-from :for ((var) (start limit 1)) next . rest))
    ;;generator clauses
    ((down-from start (:to limit) (:by step))
     (make-down-from-generator/bounded start limit step))
    ((down-from start (:to limit))
     (make-down-from-generator/bounded start limit 1))
    ((down-from start (:by step))
     (make-down-from-generator/unbounded start step))
    ((down-from start limit step)
     (make-down-from-generator/bounded start limit step))
    ((down-from start limit) (make-down-from-generator/bounded start limit 1))
    ((down-from start) (make-down-from-generator/unbounded start 1))))


(define-syntax in-hash
  (syntax-rules ()
    ((in-hash :for ((bindings) expr) n . rest)
     (n
      ()
      ((cursor (hash-map->list cons expr) (cdr cursor)))
      ((not (pair? cursor)))
      ((bindings (car cursor)))
      ()
      . rest))
    ((in-hash hash-expr)
     (in-list (hash-map->list cons hash-expr)))))


(define-syntax accumulating
  (syntax-rules (initial if :acc)
    ((accumulating :acc (kons final init) ((var) . x) next . rest)
     (accumulating :acc (kons final init) ((var cursor) . x) next . rest))
    ((accumulating :acc (kons final init) ((var cursor) ((initial i) . x)) n . rest)
     (accumulating :acc (kons final i) ((var cursor) x) n . rest))
    ((accumulating :acc (kons final init) ((var cursor) (expr (if check))) n . rest)
     (n ((tmp-kons kons))
        ((cursor init (if check (tmp-kons expr cursor) cursor)))
        ()
        ()
        ((var (final cursor)))
        . rest))
    ((accumulating :acc (kons final init) ((var cursor) (expr)) n . rest)
     (n ((tmp-kons kons))
        ((cursor init (tmp-kons expr cursor)))
        ()
        ()
        ((var (final cursor)))
        . rest))))

(define-syntax folding
  (syntax-rules (if :acc)
    ((_ :acc ((var) (init update (if guard))) n . rest)
     (n ()
        ((var init (if guard update var)))
        () ()
        ((var var))
        . rest))
    ((_ :acc ((var) (init update)) n . rest)
     (folding :acc ((var) (init update (if #t))) n . rest))
    ((_ :acc ((var) (init)) n . rest)
     (folding :acc ((var) (init var (if #t))) n . rest))))

(define-syntax listing
  (syntax-rules (:acc)
    ((listing :acc args next . rest)
     (accumulating :acc (cons reverse '()) args next . rest))))

(define-syntax listing-reverse
  (syntax-rules (:acc)
    ((listing-reverse :acc args next . rest)
     (accumulating :acc (cons (lambda (x) x) '()) args next . rest))))

(define (append-reverse rev tail)
  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))

(define-syntax appending
  (syntax-rules (:acc)
    ((appending :acc args next . rest)
     (accumulating :acc (append-reverse reverse '()) args next . rest))))

(define-syntax appending-reverse
  (syntax-rules (:acc)
    ((appending-reverse :acc args next . rest)
     (accumulating :acc (append-reverse (lambda (x) x) '()) args next . rest))))

(define-syntax summing
  (syntax-rules (:acc)
    ((summing :acc args next . rest)
     (accumulating :acc (+ (lambda (x) x) 0) args next . rest))))

(define-syntax multiplying
  (syntax-rules (:acc)
    ((multiplying :acc args next . rest)
     (accumulating :acc (* (lambda (x) x) 1) args next . rest))))

(define-syntax define-hashing
  (syntax-rules ()
    ((_ name default-make setter)
     (define-syntax name
       (syntax-rules (:acc if initial)
         ((_ :acc ((var) (key value)) n . rest)
          (name :acc ((var) (key value (if #t) (initial default-make))) n . rest))
         ;; either init or if
         ((_ :acc ((var) (key value (if guard))) n . rest)
          (name :acc ((var) (key value (if guard) (initial default-make))) n . rest))
         ((_ :acc ((var) (key value (initial init))) n . rest)
          (name :acc ((var) (key value (if #t) (initial init))) n . rest))
         ;; both init and if
         ((_ :acc ((var) (key value (initial init) (if guard))) n . rest)
          (name ((var) (key value (if guard) (initial init))) n . rest))
         ((_ :acc ((var) (key value (if guard) (initial init))) n . rest)
          (n
           ((var init))
           ((dummy (if #f #f) (if guard (setter var key value) (if #f #f))))
           ()
           ()
           ((var var))
           . rest)))))))

(define-hashing hashing (make-hash-table) hash-set!)
(define-hashing hashving (make-hash-table) hashv-set!)
(define-hashing hashqing (make-hash-table) hashq-set!)

(define (vector-grow v factor len)
  (define newlen (* len factor))
  (define new (make-vector newlen))
  (vector-copy! new 0 v 0 len)
  new)

(define (vector-set!? vec index value)
  (cond ((= index (vector-length vec))
         (let ((newvec (vector-grow vec 2 (vector-length vec))))
           (vector-set! newvec index value)
           newvec))
        (else
         (vector-set! vec index value)
         vec)))

(define (vector-shrink? vec index)
  (if (= index (vector-length vec))
      vec
      (vector-copy vec 0 index)))

(define-syntax vectoring
  (syntax-rules (:acc :length :fill)
    ((_ :acc ((var) expr) n . rest)
     (vectoring :acc ((var index) expr) n . rest))
    ((_ :acc ((var index) (expr)) n . rest)
     (n ()
        ((index 0 (+ index 1)) (var (make-vector 32) (vector-set!? var index expr)))
        ()
        ()
        ((var (vector-shrink? var index)))
        . rest))
    ((_ :acc ((var index) (expr (:length len))) n . rest)
     (vectoring  :acc ((var index) (expr (:length len) (:fill (if #f #f)))) n . rest))
    ((_ :acc ((var index) (expr (:length len) (:fill f))) next . rest)
     (next ((var (make-vector len f)))
           ((index 0 (begin (vector-set! var index expr) (+ index 1))))
           ((= index len))
           ()
           ((var var))
           . rest))))


;; this is an internal "accumulator". It is used for final tests
;; :final in goof differs from in racket. It is lexical, meaning it
;; is tested where it is placed in the clauses, and any subloop is
;; executed completely.
(define-syntax final
  (syntax-rules (:acc)
    ((_ :acc ((var) (test)) n . rest)
     (n ()
        ((final #f test))
        (final)
        ()
        ()
        . rest))))

;;; Here starts generator clauses.

(define (generator->list gen)
  (let ((res (gen)))
    (if (eof-object? res)
        '()
        (cons res (generator->list gen)))))

(define (generator-cycle gen)
  (let ((circle (apply circular-list (generator->list gen))))
    (lambda ()
      (let ((res (car circle)))
        (set! circle (cdr circle))
        res))))
        
(define-syntax in-cycle
  (syntax-rules ()
    ((_ :for ((id) (source)) n . rest)
     (n ((gen (generator-cycle source)))
        ()
        ()
        ((id (gen)))
        ()
        . rest))))


(define (generator-indexed gen)
  (let ((i 0))
    (lambda ()
      (let ((res (gen)) (index i))
        (if (eof-object? res)
            (values res res)
            (begin
              (set! i (+ i 1))
              (cons index res)))))))

(define-syntax in-indexed
  (syntax-rules (:for)
    ((_ :for ((binding) (source)) n . rest)
     (n ((gen (generator-indexed source)))
        ((i (gen) (gen)))
        ((eof-object? i))
        ((binding i))
        ()
        . rest))))

(define (stop-before-generator gen pred)
  (lambda ()
    (let ((v (gen)))
      (if (pred v)
          (eof-object)
          v))))

(define (stop-after-generator gen pred)
  (let ((done? #f))
    (lambda ()
      (if done?
          (eof-object)
          (let ((v (gen)))
            (when (pred v)
              (set! done? #t))
            v)))))


(define-syntax stop-before
  (syntax-rules (:for)
    ((_ :for ((binding) (source pred)) n . rest)
     (in-generator :for ((binding) (stop-before-generator source pred)) n . rest))
    ((_ expr pred)
     (stop-before-generator expr pred))))

(define-syntax stop-after
  (syntax-rules (:for)
    ((_ :for ((binding) (source pred)) n . rest)
     (in-generator :for ((binding) (stop-after-generator source pred)) n . rest))
    ((_ expr pred) (stop-after-generator expr pred))))