goof-loop/goof/iterators.scm

;; iterators.scm - iterators for goof-loop. 
;;
;; Copyright 2020 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 () 
  ((_ ((var) (init)) n . rest)
   (n () ((var init var)) () () () . rest))
  ((_ ((var) (init step)) n . rest)
   (n () ((var init step)) () () () . rest))
  ((_ ((var) (init step stop)) n . rest)
   (n () ((var init step)) (stop) () () . rest))))

(define-syntax in-list
  (syntax-rules (:gen)
    ((_ ((var) source) next . rest)
     (in-list ((var cursor) source) next . rest))
    ((_       ((var cursor) source) next . rest)
     (in-list ((var cursor succ) source) next . rest))
    ((_ ((var cursor succ) (source)) next . rest)
     (in-list ((var cursor succ) (source cdr)) next . rest))
    ((_ ((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
    ((_ lst)
     (gen-list lst))
    ((_ :gen (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 ()
    ((in-lists ((elts) lol) next . rest)
     (in-lists ((elts pairs) lol) next . rest))
    ((in-lists ((elts pairs) lol) next . rest)
     (in-lists ((elts pairs succ) lol) next . rest))
    ((in-lists ((elts pairs succ) (lol)) next . rest)
     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists ((elts pairs succ) (lol)) next . rest)
     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
    ((in-lists ((elts pairs succ) (lol step)) next . rest)
     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
    ((in-lists ((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 seq next . rest)
            (%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
       (define-syntax in-type-reverse
         (syntax-rules ()
           ((in-type-reverse seq next . rest)
            (%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
       ))))

(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 ((var) source) next . rest)
     (in-port ((var p) source) next . rest))
    ((in-port ((var p) ()) next . rest)
     (in-port ((var p) ((current-input-port))) next . rest))
    ((in-port ((var p) (port)) next . rest)
     (in-port ((var p) (port read-char)) next . rest))
    ((in-port ((var p) (port read-char)) next . rest)
     (in-port ((var p) (port read-char eof-object?)) next . rest))
    ((in-port ((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 ((var) source) next . rest)
     (in-file ((var p) source) next . rest))
    ((in-file ((var p) (file)) next . rest)
     (in-file ((var p) (file read-char)) next . rest))
    ((in-file ((var p) (file reader)) next . rest)
     (in-file ((var p) (file reader eof-object?)) next . rest))
    ((in-file ((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 ()
    ((_ ((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-syntax up-from
  (syntax-rules (to by)
    ((up-from (() . args) next . rest)
     (up-from ((var) . args) next . rest))
    ((up-from ((var) (start (to limit) (by step))) next . rest)
     (next ((s start) (l limit) (e step))
           ((var s (+ var e)))
           ((>= var l))
           () () . rest))
    ((up-from ((var) (start (to limit))) next . rest)
     (next ((s start) (l limit)) ((var s (+ var 1)))
           ((>= var l)) () () . rest))
    ((up-from ((var) (start (by step))) next . rest)
     (next ((s start) (e step))
           ((var s (+ var e))) () () () . rest))
    ((up-from ((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 ((var) (start limit step)) next . rest)
     (next ((s start) (l limit) (e step)) ((var s (+ var e))) ((>= var l)) () () . rest))
    ((up-from ((var) (start limit)) next . rest)
     (up-from ((var) (start limit 1)) next . rest))))

(define-syntax down-from
  (syntax-rules (to by)
    ((down-from (() . args) next . rest)
     (down-from ((var) . args) next . rest))
    ((down-from ((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 ((var) (start (to limit))) next . rest)
     (next ((s start) (l limit)) ((var (- s 1) (- var 1)))
           ((< var l)) () () . rest))
    ((down-from ((var) (start (by step))) next . rest)
     (next ((s start) (e step)) ((var (- s e) (- var e)))
           () () () . rest))
    ((down-from ((var) (start)) next . rest)
     (next ((s start)) ((var (- s 1) (- var 1)))
           () () () . rest))
    ((down-from ((var) (start limit step)) next . rest)
     (next ((s start) (l limit) (e step)) ((var (- s e) (- var e))) ((< var l)) () () . rest))
    ((down-from ((var) (start limit)) next . rest)
     (down-from ((var) (start limit 1)) next . rest))))


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


(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 defualt-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
           ((hash init))
           ((dummy (if #f #f) (if guard (setter hash key value) (if #f #f))))
           ()
           ()
           ((var hash))
           . 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))

    ;; I am truly sorry. Currently this relies on pushing a :break clause WITHOUT
    ;; the :when #t to ensure a subloop. It is the solution I would have used
    ;; otherwise as well, but I would have wished for it to be more elegant.
    ((_ :acc ((var index) (expr (:length len) (:fill f))) next
        o n l a v c r fi ff ul uw ((ub ...) . ub-rest) uf . rest)
     (next ((var (make-vector len f)))
           ((index 0 (begin (vector-set! var index expr) (+ index 1))))
           ()
           ()
           ((var var))
           o n l a v c r fi ff ul uw ((ub ... (= index len)) . ub-rest) uf
           . 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 ()
    ((_ ((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 ()
    ((_ ((binding) (source)) n . rest)
     (n ((gen (generator-indexed source)))
        ((i (gen) (gen)))
        ((eof-object? i))
        ((binding i))
        ()
        . rest))))