goof-loop/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
;; in-naturals
;; in-hash with variations

;; TODO: accumulators
;; vectoring
;; hashing
;; hashqing
;; hashving

(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
      ()
      ;; accumulators. These are the same as the bindings below, but values are
      ;; kept through subloops.
      ()
      ;; 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))))

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

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

(define-syntax in-generator
  (syntax-rules ()
    ((_ ((var) (source)) next . rest)
     (next ((gen source))
           ()
           ((var (gen) (gen)))
           ((eof-object? var))
           ()
           ()
           . rest))))

(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 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 :acc ((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 :acc ((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 ((var) (init update (if #t))) n . rest))
    ((_ :acc ((var) (init)) n . rest)
     (folding ((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))))


;;; 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))
              (values index res)))))))

;; Somewhat of a hack :)
(define-syntax in-indexed
  (syntax-rules ()
    ((_ ((i val) (source)) n . rest)
     (n ((gen (generator-indexed source)))
        ()
        ((i 0 i))
        ((eof-object? i))
        ((i val (gen)))
        ()
        . rest))))