370 lines
13 KiB
Scheme
370 lines
13 KiB
Scheme
;;;
|
|
;;; EXTRA GENERATORS (NOT IN SRFI-42)
|
|
;;;
|
|
|
|
(module extra-generators mzscheme
|
|
(provide :let-values
|
|
:repeat
|
|
:iterate
|
|
:combinations
|
|
:vector-combinations
|
|
:do-until
|
|
:pairs
|
|
:list-by
|
|
:alist
|
|
:hash-table
|
|
:hash-table-keys
|
|
:hash-table-values)
|
|
(require "ec-core.scm")
|
|
(require-for-syntax "ec-core.scm")
|
|
|
|
;;; :let-values
|
|
|
|
(define-generator (:let-values form-stx)
|
|
(syntax-case form-stx (index)
|
|
[(_ (var ...) (index i) expression)
|
|
#'(:do (let-values ([(var ...) expression] [(i) 0])) () #t (let ()) #f ())]
|
|
[(_ (var ...) expression)
|
|
#'(:do (let-values ([(var ...) expression])) () #t (let ()) #f ())]
|
|
[_
|
|
(raise-syntax-error
|
|
':let-values
|
|
"expected (:let-values (<var> ...) (index i) <expr> where the index is optional, got: "
|
|
form-stx)]))
|
|
|
|
;;; :repeat Fixed number of iterations
|
|
|
|
; (list-ec (:repeat 5) 1) => '(1 1 1 1 1)
|
|
|
|
(define-generator (:repeat form-stx)
|
|
(syntax-case form-stx (index)
|
|
[(_ (index i) expr)
|
|
#'(:range i expr)]
|
|
[(_ expr)
|
|
#'(:range i expr)]
|
|
[_
|
|
(raise-syntax-error
|
|
':repeat
|
|
"expected (:repeat <expr>) ot (:repeat (index i) <expr>), got: "
|
|
form-stx)]))
|
|
|
|
;;; Iteration :iterate
|
|
|
|
; An iterative process can be seen as a triple
|
|
; of an initial state, a transition function next-state
|
|
; from state to state, and a predicate end-state? that
|
|
; determines whether and terminal state has been reached.
|
|
|
|
; (list-ec (:iterate e 0 (lambda (x) (+ x 2)) (lambda (x) (>= x 10)))
|
|
; e) ; => (0 2 4 6 8)
|
|
|
|
(define-generator (:iterate stx)
|
|
(syntax-case stx (index)
|
|
[(:iterate state initial-state next-state end-state?)
|
|
(begin
|
|
(unless (identifier? #'state)
|
|
(raise-syntax-error
|
|
':iterate "expected variable (for the state), got: " #'state))
|
|
#'(:do (let ((initial initial-state) (end? end-state?) (next next-state)))
|
|
((state initial))
|
|
(not (end? state))
|
|
(let ())
|
|
#t
|
|
((next state))))]
|
|
[(:iterate state (index i) initial-state next-state end-state?)
|
|
(add-index stx #'(:iterate state initial-state next-state end-state?) #'i)]
|
|
[_
|
|
(raise-syntax-error
|
|
':iterate
|
|
"expected (:iterate <state-var> <initial-state> <next-state> <end-state?>), got: "
|
|
stx)]))
|
|
|
|
|
|
;;;; Combinations
|
|
;; The problem of generating all k combinations of the n numbers
|
|
;; 0,1,...,n-1 provides a nice example of the advanced :do-generator.
|
|
;; The list of 3,5-combinations are
|
|
;
|
|
;; (#3(0 1 2) #3(0 1 3) #3(0 1 4) #3(0 2 3) #3(0 2 4) #3(0 3 4)
|
|
;; #3(1 2 3) #3(1 2 4) #3(1 3 4)
|
|
;; #3(2 3 4))
|
|
;
|
|
;; The first combination is #(0 1 2) and the last combination is #3(2 3 4).
|
|
;; Given helper funcions first-combination, last-combination?, and
|
|
;; next-combination we can use the advanced :do-generator as follows.
|
|
;
|
|
(define-syntax vr (syntax-rules () [(_ v i) (vector-ref v i)]))
|
|
(define-syntax vs! (syntax-rules () [(_ v i x) (vector-set! v i x)]))
|
|
(define-syntax incrementable? (syntax-rules () [(_ v i k n) (< (vr v i) (+ n (- k) i))]))
|
|
(define-syntax last-combination? (syntax-rules () [(_ 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 (vector-copy v)
|
|
(vector-of-length-ec (vector-length v)
|
|
(:vector x v)
|
|
x))
|
|
|
|
(define (next-combination k n v)
|
|
(last-ec #f ; default, when there is no next combination
|
|
(:let v (vector-copy v))
|
|
; find the last incrementable index
|
|
(:let i (last-ec #f (:until (: i (- k 1) -1 -1)
|
|
(incrementable? v i k n))
|
|
i))
|
|
(if i)
|
|
; increment index i and fix indices to the right of i
|
|
(:parallel (: j i k)
|
|
(: vj (+ (vr v i) 1) n))
|
|
(begin (vs! v j vj))
|
|
; if all indices is fixed we have a new combination
|
|
(if (= j (- k 1)))
|
|
; return the new combination
|
|
v))
|
|
|
|
;;;; Combinations :combinations, :vector-combinations
|
|
;
|
|
;; In the section on the advanced :do-generator we showed that
|
|
;; how to use :do to generate all k,n-combinations of the
|
|
;; indices 0,1,...,n-1.
|
|
;
|
|
;; We can use this to define a the :combinations generator
|
|
;; that generates all k combinations of elements from a
|
|
;; given list l.
|
|
|
|
(define (indices->list indices elements)
|
|
; (indices->list '#(0 1 4) '#(a b c d e)) => (a b e)
|
|
(list-ec (:vector i indices)
|
|
(vector-ref elements i)))
|
|
|
|
(define-generator (:combinations stx)
|
|
(syntax-case stx (index)
|
|
((:combinations lc (index i) k l)
|
|
#'(:parallel (:integers i) (:combinations lc k l)))
|
|
((:combinations lc k l)
|
|
#'(:do (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))))))
|
|
|
|
; The vector version is similar.
|
|
|
|
(define (indices->vector k indices elements)
|
|
(vector-of-length-ec k
|
|
(:vector i indices)
|
|
(vector-ref elements i)))
|
|
|
|
(define-generator (:vector-combinations stx)
|
|
(syntax-case stx (index)
|
|
((:vector-combinations vc (index i) k v)
|
|
#'(:parallel (:integers i) (:vector-combinations vc k v)))
|
|
((:vector-combinations vc k v)
|
|
#'(:do (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))))))
|
|
|
|
;;; An alternative to :do, the :do-until
|
|
|
|
; The simple :do is a "do-while" loop. As we saw previously
|
|
; this we had to use the advanced :do-generator in order
|
|
; to write :list in terms of :do, due to the last element
|
|
; missing. Compare:
|
|
|
|
; (list-ec (:do-until ((x 0)) (> x 5) ((+ x 1))) x)
|
|
; => '(0 1 2 3 4 5 6)
|
|
|
|
; (list-ec (:do ((x 0)) (<= x 5) ((+ x 1))) x)
|
|
; => '(0 1 2 3 4 5)
|
|
|
|
; If only the the termination test were done *after* and
|
|
; not before the loop payload ... This leads to the
|
|
; idea of an :do-until.
|
|
|
|
(define-generator (:do-until stx)
|
|
(syntax-case stx ()
|
|
[(:do-until lb* ne1? ls*)
|
|
#'(:do (let ()) lb* #t (let ()) (not ne1?) ls*)]
|
|
[_
|
|
(raise-syntax-error
|
|
':do-until
|
|
"expected (:do-until <loop-bindings> <not-end?> <loop-steppers>), got: "
|
|
stx)]))
|
|
|
|
;;;
|
|
;;; Pairs of a list
|
|
;;;
|
|
|
|
; The normal :list generator allows one to work with the elements
|
|
; of a list. In order to work with the pairs of the list, we
|
|
; define :pairs that generate the pairs of the list.
|
|
|
|
; (list-ec (:pairs p '(1 2 3)) p) ; => '(1 2 3) (2 3) (3))
|
|
|
|
(define-generator (:pairs stx)
|
|
(syntax-case stx (index)
|
|
[(:pairs p (index i) l)
|
|
(add-index stx #'(:pairs p l) #'i)]
|
|
[(:pairs p l)
|
|
(begin
|
|
(unless (identifier? #'p)
|
|
(raise-syntax-error
|
|
':pairs "expected identifier to bind, got: " #'p))
|
|
#'(:iterate p l cdr null?))]
|
|
[_
|
|
(raise-syntax-error
|
|
':pairs
|
|
"expected (:pairs <var> (index <var>) <expr>), got: "
|
|
stx)]))
|
|
|
|
(define-generator (:pairs-by stx)
|
|
(syntax-case stx (index)
|
|
((:pairs-by p (index i) l) #'(:pairs-by p (index i) l cdr))
|
|
((:pairs-by p (index i) l next) #'(:pairs-by p (index i) l next null?))
|
|
((:pairs-by p (index i) l next end?) (add-index stx #'(:iterate p l next end?) #'i))
|
|
|
|
((:pairs-by p l) #'(:pairs-by p l cdr))
|
|
((:pairs-by p l next) #'(:pairs-by p l next null?))
|
|
((:pairs-by p l next end?) #'(:iterate p l next end?))
|
|
(_
|
|
(raise-syntax-error
|
|
':pairs-by
|
|
(string-append
|
|
"expected (:pairs-by <var> (index var) <list-expr> <next-expr> <end-expr>), where "
|
|
"the index is optional, and the defaults for <next-expr> and <end-expr> are cdr and null?. Got: ")
|
|
stx))))
|
|
|
|
;;;
|
|
;;; A more flexible :list, the :list-by
|
|
;;;
|
|
|
|
(define-generator (:list-by stx)
|
|
(syntax-case stx (index)
|
|
((:list-by x (index i) l)
|
|
#'(:list-by x (index i) l cdr))
|
|
((:list-by x (index i) l next)
|
|
#'(:list-by x (index i) l next null?))
|
|
((:list-by x (index i) l next end?)
|
|
(add-index stx #'(:do (let ()) ((t l)) (not (end? t))
|
|
(let ((x (car t)))) #t ((next t)))
|
|
#'i))
|
|
((:list-by x l)
|
|
#'(:list-by x l cdr))
|
|
((:list-by x l next)
|
|
#'(:list-by x l next null?))
|
|
((:list-by x l next end?)
|
|
#'(:do (let ()) ((t l)) (not (end? t)) (let ((x (car t)))) #t ((next t))))
|
|
(_
|
|
(raise-syntax-error
|
|
':list-by
|
|
(string-append
|
|
"expected (:list-by x (index <id>) <list-expr> <next-expr> <end-expr>), where "
|
|
"the (index <id>), <next-exp>, and <end-expr> are optional, got: ")
|
|
stx))))
|
|
|
|
(define-generator (:alist stx)
|
|
(syntax-case stx (index)
|
|
[(:alist vars (index i) al-expr)
|
|
(add-index stx #'(:alist vars al-expr) #'i)]
|
|
[(:alist (key val) al-expr)
|
|
#'(:do (let ([al al-expr]))
|
|
((al al))
|
|
(not (null? al))
|
|
(let-values ([(key val) (values (caar al) (cdar al))]))
|
|
#t
|
|
((cdr al)))]))
|
|
|
|
|
|
(define-generator (:hash-table stx)
|
|
(syntax-case stx (index)
|
|
[(:hash-table vars (index i) ht-expr)
|
|
(add-index stx #'(:hash-table vars ht-expr) #'i)]
|
|
[(:hash-table (key-var val-var) ht-expr)
|
|
#'(:alist (key-var val-var) (hash-table-map ht-expr cons))]
|
|
[(:hash-table var ht-expr)
|
|
#'(:list var (hash-table-map ht-expr cons))]
|
|
[_
|
|
(raise-syntax-error
|
|
':hash-table
|
|
"expected (:hash-table (<key-var> <val-var>) <ht-expr>) or (:hash-table <var> <ht-expr>) "
|
|
stx)]))
|
|
|
|
(define-generator (:hash-table-keys stx)
|
|
(syntax-case stx (index)
|
|
[(_ var (index i) ht-expr)
|
|
(add-index stx #'(:hash-table-keys vars ht-expr) #'i)]
|
|
[(_ var ht-expr)
|
|
#'(:list var (hash-table-map ht-expr (lambda (k v) k)))]
|
|
[_
|
|
(raise-syntax-error
|
|
':hash-table-keys
|
|
"expected (:hash-table-keys <var> (index <var>) <ht-expr>) where the index is optional "
|
|
stx)]))
|
|
|
|
(define-generator (:hash-table-values stx)
|
|
(syntax-case stx (index)
|
|
[(_ var (index i) ht-expr)
|
|
(add-index stx #'(:hash-table-keys vars ht-expr) #'i)]
|
|
[(_ var ht-expr)
|
|
#'(:list var (hash-table-map ht-expr (lambda (k v) v)))]
|
|
[_
|
|
(raise-syntax-error
|
|
':hash-table-values
|
|
"expected (:hash-table-values <var> (index <var>) <ht-expr>) where the index is optional "
|
|
stx)]))
|
|
|
|
#;(require-for-syntax (lib "private/match/gen-match.ss")
|
|
(lib "private/match/convert-pat.ss"))
|
|
|
|
#;(define-generator (:plt-match stx)
|
|
(syntax-case stx ()
|
|
[(_ pat expr)
|
|
(identifier? #'pat)
|
|
#'(:let pat expr)]
|
|
[(_ pat expr)
|
|
(let* ((**match-bound-vars** '())
|
|
(compiled-match
|
|
(gen-match #'the-expr
|
|
#'((pat never-used))
|
|
stx
|
|
(lambda (sf bv)
|
|
(set! **match-bound-vars** bv)
|
|
#`(begin
|
|
#,@(map (lambda (x)
|
|
#`(set! #,(car x) #,(cdr x)))
|
|
(reverse bv)))))))
|
|
#`(:do (let ((the-expr expr)
|
|
(match-found? #t)
|
|
#,@(map (lambda (x) #`(#,(car x) #f))
|
|
(reverse **match-bound-vars**)))
|
|
(with-handlers ([exn:fail? (lambda (exn) (set! match-found? #f))])
|
|
#,compiled-match))
|
|
() match-found? (let ()) #f ()))]
|
|
[_
|
|
(raise-syntax-error
|
|
':plt-match
|
|
"expected (:plt-match <pattern> <expr>)"
|
|
stx)]))
|
|
|
|
#;(define-generator (:match stx)
|
|
(syntax-case stx ()
|
|
[(_ pat expr)
|
|
(identifier? #'pat)
|
|
#'(:let path expr)]
|
|
[(_ pat expr)
|
|
(with-syntax ([new-pat (convert-pat #'pat)])
|
|
#'(:plt-match new-pat expr))]
|
|
[_
|
|
(raise-syntax-error
|
|
'match
|
|
"expected (:match <pattern> <expr>)"
|
|
stx)]))
|
|
) |