329 lines
11 KiB
Scheme
329 lines
11 KiB
Scheme
;; 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-list
|
|
(syntax-rules ()
|
|
((_ ((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))))
|
|
|
|
|
|
|
|
|
|
(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))
|
|
))
|
|
|
|
;;> \macro{(for ch (in-port [input-port [reader [eof?]]]))}
|
|
|
|
(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) (r reader) (e? eof?))
|
|
()
|
|
((var (r p) (r p)))
|
|
((e? var))
|
|
()
|
|
()
|
|
. rest))))
|
|
|
|
;;> \macro{(for ch (in-file [input-port [reader [eof?]]]))}
|
|
|
|
(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))
|
|
()
|
|
((dummy (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))))
|
|
|
|
;;> \macro{(for x (up-from [start] [(to limit)] [(by step)]))}
|
|
|
|
(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))
|
|
))
|
|
|
|
;;> \macro{(for x (down-from [start] [(to limit)] [(by step)]))}
|
|
|
|
(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))
|
|
))
|
|
|
|
(define-syntax accumulating
|
|
(syntax-rules (initial if)
|
|
((accumulating (kons final init) ((var) . x) next . rest)
|
|
(accumulating (kons final init) ((var cursor) . x) next . rest))
|
|
((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
|
|
(accumulating (kons final i) ((var cursor) x) n . rest))
|
|
((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
|
|
(n ((tmp-kons kons))
|
|
((cursor '() (if check (tmp-kons expr cursor) cursor)))
|
|
()
|
|
()
|
|
()
|
|
((var (final cursor)))
|
|
. rest))
|
|
((accumulating (kons final init) ((var cursor) (expr)) n . rest)
|
|
(n ((tmp-kons kons))
|
|
((cursor '() (tmp-kons expr cursor)))
|
|
()
|
|
()
|
|
()
|
|
((var (final cursor)))
|
|
. rest))))
|
|
|
|
;;> \macro{(for x [pair] (listing expr))}
|
|
|
|
(define-syntax listing
|
|
(syntax-rules ()
|
|
((listing args next . rest)
|
|
(accumulating (cons reverse '()) args next . rest))))
|
|
|
|
;;> \macro{(for x [pair] (listing-reverse expr))}
|
|
|
|
(define-syntax listing-reverse
|
|
(syntax-rules ()
|
|
((listing-reverse args next . rest)
|
|
(accumulating (cons (lambda (x) x) '()) args next . rest))))
|
|
|
|
(define (append-reverse rev tail)
|
|
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
|
|
|
;;> \macro{(for x [pair] (appending expr))}
|
|
|
|
(define-syntax appending
|
|
(syntax-rules ()
|
|
((appending args next . rest)
|
|
(accumulating (append-reverse reverse '()) args next . rest))))
|
|
|
|
;;> \macro{(for x [pair] (appending-reverse expr))}
|
|
|
|
(define-syntax appending-reverse
|
|
(syntax-rules ()
|
|
((appending-reverse args next . rest)
|
|
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
|
|
|
|
;;> \macro{(for x (summing expr))}
|
|
|
|
(define-syntax summing
|
|
(syntax-rules ()
|
|
((summing args next . rest)
|
|
(accumulating (+ (lambda (x) x) 0) args next . rest))))
|
|
|
|
;;> \macro{(for x (multiplying expr))}
|
|
|
|
(define-syntax multiplying
|
|
(syntax-rules ()
|
|
((multiplying args next . rest)
|
|
(accumulating (* (lambda (x) x) 1) args next . rest))))
|