(module extra-generators mzscheme
(provide :combinations
:do-until
:iterate
:let-values
:list-by
:match
:pairs
:pairs-by
:plt-match
:repeat
:vector-combinations)
(require "comprehensions.ss"
(only (lib "43.ss" "srfi") vector-copy))
(define-syntax :let-values
(syntax-rules (index)
((:let-values cc var (index i) expression)
(:do cc (let-values ((var expression) (i 0))) () #t (let ()) #f ()))
((:let-values cc var expression)
(:do cc (let-values ((var expression))) () #t (let ()) #f ()) )))
(define-syntax :match
(syntax-rules (index)
((:match cc pat (index i) expression)
(:do cc (let-match ((pat expression) (i 0))) () #t (let ()) #f ()))
((:match cc pat expression)
(:do cc (let-match ((pat expression))) () #t (let ()) #f ()) )))
(define-syntax :plt-match
(syntax-rules (index)
((:plt-match cc pat (index i) expression)
(:do cc (let-plt-match ((pat expression) (i 0))) () #t (let ()) #f ()))
((:plt-match cc pat expression)
(:do cc (let-plt-match ((pat expression))) () #t (let ()) #f ()) )))
(define (vr v i) (vector-ref v i))
(define (vs! v i x) (vector-set! v i x))
(define (incrementable? v i k n) (< (vr v i) (+ n (- k) i)))
(define (last-combination? k n v) (= (vr v 0) (- n k)))
(define (first-combination k n)
(if (<= 1 k n)
(vector-ec (: i 0 k) i)
#f))
(define (next-combination k n v)
(last-ec #f (:let v (vector-copy v))
(:let i (last-ec #f (:until (: i (- k 1) -1 -1)
(incrementable? v i k n))
i))
(if i)
(:parallel (: j i k)
(: vj (+ (vr v i) 1) n))
(begin (vs! v j vj))
(if (= j (- k 1)))
v))
(define-syntax :repeat
(syntax-rules (index)
((:repeat cc expr)
(:range cc i expr))
((:repeat cc expr (index i))
(:range cc i (index j) expr))))
(define-syntax :iterate
(syntax-rules (index)
[(:iterate cc state initial-state next-state end-state?)
(:do cc
((state initial-state))
(not (end-state? state))
((next-state state)))]
[(:iterate cc state (index i) initial-state next-state end-state?)
(:parallel cc (:integers i)
(:iterate state initial-state next-state end-state?))]))
(define-syntax :pairs
(syntax-rules (index)
((:pairs cc p l)
(:iterate cc p l cdr null?))
((:pairs cc p (index i) l)
(:iterate cc p (index i) l cdr null?))))
(define-syntax :pairs-by
(syntax-rules (index)
((:pairs-by cc p (index i) l) (:pairs-by cc p (index i) l cdr))
((:pairs-by cc p (index i) l next) (:pairs-by cc p (index i) l next null?))
((:pairs-by cc p (index i) l next end?) (:iterate cc p (index i) l next end?))
((:pairs-by cc p l) (:pairs-by cc p l cdr))
((:pairs-by cc p l next) (:pairs-by cc p l next null?))
((:pairs-by cc p l next end?) (:iterate cc p l next end?))))
(define (indices->list indices elements)
(list-ec (:vector i indices)
(vector-ref elements i)))
(define-syntax :combinations
(syntax-rules (index)
((:combinations cc lc (index i) k l)
(:parallel cc (:integers i) (:combinations lc k l)))
((:combinations cc lc k l)
(:do cc
(let ((n (length l))
(v (list->vector l))))
((c (first-combination k n)))
c
(let ((lc (indices->list c v))))
(not (last-combination? k n c))
((next-combination k n c))))))
(define (indices->vector k indices elements)
(vector-of-length-ec k
(:vector i indices)
(vector-ref elements i)))
(define-syntax :vector-combinations
(syntax-rules (index)
((:vector-combinations cc vc (index i) k v)
(:parallel cc (:integers i) (:vector-combinations vc k v)))
((:vector-combinations cc vc k v)
(:do cc
(let ((n (vector-length v))))
((c (first-combination k n)))
c
(let ((vc (indices->vector k c v))))
(not (last-combination? k n c))
((next-combination k n c))))))
(define-syntax :do-until
(syntax-rules ()
((:do-until cc lb* ne1? ls*)
(:do cc (let ()) lb* #t (let ()) (not ne1?) ls*))))
(define-syntax :list-by
(syntax-rules (index)
((:list-by cc x (index i) l) (:list-by cc x (index i) l cdr))
((:list-by cc x (index i) l next) (:list-by cc x (index i) l next null?))
((:list-by cc x (index i) l next end?) (:parallel cc
(:integers i)
(:do (let ()) ((t l)) (not (end? t))
(let ((x (car t)))) #t ((next t)))))
((:list-by cc x l) (:list-by cc x l cdr))
((:list-by cc x l next) (:list-by cc x l next null?))
((:list-by cc x l next end?) (:do cc (let ()) ((t l)) (not (end? t)) (let ((x (car t)))) #t ((next t))))))
)