Rackety (mostly letrec-values => define and minimizing dependencies)

This commit is contained in:
Robby Findler 2011-10-31 09:08:31 -05:00
parent 64dfdb3c7f
commit 0ce6c75591
5 changed files with 232 additions and 238 deletions

View File

@ -1,10 +1,11 @@
#lang scheme/gui #lang racket/base
(require racket/contract
racket/class
racket/gui/base
racket/system)
(provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)] (provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)]
[find-dot (-> (or/c path? false/c))]) [find-dot (-> (or/c path? false/c))])
(require scheme/system)
(provide dot-label neato-label neato-hier-label neato-ipsep-label) (provide dot-label neato-label neato-hier-label neato-ipsep-label)
(define dot-label "dot") (define dot-label "dot")
(define neato-label "neato") (define neato-label "neato")

View File

@ -1,4 +1,5 @@
#lang scheme #lang racket/base
(require racket/contract)
(define re:gen-d #rx".*[^0-9]([0-9]+)$") (define re:gen-d #rx".*[^0-9]([0-9]+)$")
(define (variable-not-in sexp var) (define (variable-not-in sexp var)
@ -31,7 +32,7 @@
(let loop ([sorted (sort nums <)] (let loop ([sorted (sort nums <)]
[i 1]) [i 1])
(cond (cond
[(empty? sorted) i] [(null? sorted) i]
[else [else
(let ([fst (car sorted)]) (let ([fst (car sorted)])
(cond (cond

View File

@ -1,6 +1,7 @@
#lang racket #lang racket/base
(require (for-template racket/base racket/contract)) (require racket/match
(for-template racket/base racket/contract))
(define (parse-kw-args formals actuals source form-name) (define (parse-kw-args formals actuals source form-name)
(let loop ([current (for/hash ([arg formals]) (values (car arg) #f))] (let loop ([current (for/hash ([arg formals]) (values (car arg) #f))]

View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require "matcher.rkt" (require "matcher.rkt"
"reduction-semantics.rkt" "reduction-semantics.rkt"
@ -6,18 +6,17 @@
"term.rkt" "term.rkt"
"error.rkt" "error.rkt"
"struct.rkt" "struct.rkt"
(for-syntax scheme/base (for-syntax racket/base
"rewrite-side-conditions.rkt" "rewrite-side-conditions.rkt"
"term-fn.rkt" "term-fn.rkt"
"reduction-semantics.rkt" "reduction-semantics.rkt"
"keyword-macros.rkt") "keyword-macros.rkt")
scheme/dict racket/dict
scheme/contract racket/contract
scheme/promise racket/promise
scheme/unit racket/unit
scheme/match racket/match
scheme/pretty racket/pretty
scheme/function
mrlib/tex-table) mrlib/tex-table)
(define redex-pseudo-random-generator (define redex-pseudo-random-generator
@ -174,43 +173,41 @@
(import) (export decisions^)) (import) (export decisions^))
(define (gen-nt lang name cross? retries size attempt filler) (define (gen-nt lang name cross? retries size attempt filler)
(let*-values (define productions
([(productions) (hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name))
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)] (define-values (term _)
[(term _) (let ([gen (pick-from-list
(let ([gen (pick-from-list (if (zero? size)
(if (zero? size) (min-prods name productions
(min-prods name productions ((if cross? base-cases-cross base-cases-non-cross)
((if cross? base-cases-cross base-cases-non-cross) (rg-lang-base-cases lang)))
(rg-lang-base-cases lang))) ((next-non-terminal-decision) productions)))])
((next-non-terminal-decision) productions)))]) (gen retries (max 0 (sub1 size)) attempt empty-env filler)))
(gen retries (max 0 (sub1 size)) attempt empty-env filler))]) term)
term))
(define (generate/pred name gen pred init-sz init-att retries) (define (generate/pred name gen pred init-sz init-att retries)
(let ([pre-threshold-incr (define pre-threshold-incr
(ceiling (ceiling
(/ (- retry-threshold init-att) (/ (- retry-threshold init-att)
(* proportion-before-threshold (add1 retries))))] (* proportion-before-threshold (add1 retries)))))
[incr-size? (define (incr-size? remain)
(λ (remain) (zero?
(zero? (modulo (sub1 remain)
(modulo (sub1 remain) (ceiling (* proportion-at-size retries)))))
(ceiling (* proportion-at-size retries)))))]) (let retry ([remaining (add1 retries)]
(let retry ([remaining (add1 retries)] [size init-sz]
[size init-sz] [attempt init-att])
[attempt init-att]) (if (zero? remaining)
(if (zero? remaining) (raise-gen-fail what (format "pattern ~a" name) retries)
(raise-gen-fail what (format "pattern ~a" name) retries) (let-values ([(term env) (gen size attempt)])
(let-values ([(term env) (gen size attempt)]) (if (pred term env)
(if (pred term env) (values term env)
(values term env) (retry (sub1 remaining)
(retry (sub1 remaining) (if (incr-size? remaining) (add1 size) size)
(if (incr-size? remaining) (add1 size) size) (+ attempt
(+ attempt (if (>= attempt retry-threshold)
(if (>= attempt retry-threshold) post-threshold-incr
post-threshold-incr pre-threshold-incr))))))))
pre-threshold-incr)))))))))
(define (generate/prior name env gen) (define (generate/prior name env gen)
(let* ([none (gensym)] (let* ([none (gensym)]
@ -232,33 +229,32 @@
(foldl (λ (var env) (foldl (λ (var env)
(hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs)))
env vars)) env vars))
(let-values (define-values (seq envs)
([(seq envs) (let recur ([envs (split-environment env)])
(let recur ([envs (split-environment env)]) (if (null? envs)
(if (null? envs) (values null null)
(values null null) (let*-values
(let*-values ([(hd env) (gen (car envs))]
([(hd env) (gen (car envs))] [(tl envs) (recur (cdr envs))])
[(tl envs) (recur (cdr envs))]) (values (cons hd tl) (cons env envs))))))
(values (cons hd tl) (cons env envs)))))]) (values seq (merge-environments envs)))
(values seq (merge-environments envs))))
(define ((generator/attempts g) r s a e f) (define ((generator/attempts g) r s a e f)
(values (g a) e)) (values (g a) e))
(define (mismatches-satisfied? env) (define (mismatches-satisfied? env)
(let ([groups (make-hasheq)]) (define groups (make-hasheq))
(define (get-group group) (define (get-group group)
(hash-ref groups group (hash-ref groups group
(λ () (λ ()
(let ([vals (make-hash)]) (let ([vals (make-hash)])
(hash-set! groups group vals) (hash-set! groups group vals)
vals)))) vals))))
(for/and ([(name val) env]) (for/and ([(name val) env])
(or (not (mismatch? name)) (or (not (mismatch? name))
(let ([prior (get-group (mismatch-group name))]) (let ([prior (get-group (mismatch-group name))])
(and (not (hash-ref prior val #f)) (and (not (hash-ref prior val #f))
(hash-set! prior val #t))))))) (hash-set! prior val #t))))))
(define empty-env #hash()) (define empty-env #hash())
@ -269,167 +265,162 @@
(cons (make-bind (binder-name key) val) bindings) (cons (make-bind (binder-name key) val) bindings)
bindings)))) bindings))))
(let*-values ([(langp lits lang-bases) (prepare-lang lang)] (define-values (langp lits lang-bases) (prepare-lang lang))
[(sexpp _ sexp-bases) (prepare-lang sexp)] (define-values (sexpp _ sexp-bases) (prepare-lang sexp))
[(lit-syms) (compiled-lang-literals lang)]) (define lit-syms (compiled-lang-literals lang))
(letrec-values
([(compile) (define (compile pat any?)
(λ (pat any?) (let* ([nt? (is-nt? (if any? sexpp langp))]
(let* ([nt? (is-nt? (if any? sexpp langp))] [mismatches? #f]
[mismatches? #f] [generator
[generator ; retries size attempt env filler -> (values terms env)
; retries size attempt env filler -> (values terms env) ;
; ; Patterns like (in-hole C_1 p) require constructing both an unfilled context
; Patterns like (in-hole C_1 p) require constructing both an unfilled context ; (exposed via the C_1 binding) and a filled context (exposed as the result).
; (exposed via the C_1 binding) and a filled context (exposed as the result). ; A generator constructs both by constructing the context, using either
; A generator constructs both by constructing the context, using either ; `the-hole' or `the-not-hole' as appropriate, then filling it using `plug'.
; `the-hole' or `the-not-hole' as appropriate, then filling it using `plug'. ; Before returning its result, a generator replaces occurrences of `the-not-hole'
; Before returning its result, a generator replaces occurrences of `the-not-hole' ; with `the-hole' to avoid exposing the distinction to the user, but
; with `the-hole' to avoid exposing the distinction to the user, but ; `the-not-hole' remains in bindings supplied to side-condition predicates, to
; `the-not-hole' remains in bindings supplied to side-condition predicates, to ; match the behavior of the matcher.
; match the behavior of the matcher. ;
; ; Repeated traversals via `plug' are not asymptotically worse than simultaneously
; Repeated traversals via `plug' are not asymptotically worse than simultaneously ; constructing the filled and unfilled pattern, due to languages like this one,
; constructing the filled and unfilled pattern, due to languages like this one, ; which names contexts in a way that prevents any sharing.
; which names contexts in a way that prevents any sharing. ; (define-language L
; (define-language L ; (W hole
; (W hole ; ; extra parens to avoid matcher loop
; ; extra parens to avoid matcher loop ; (in-hole (W_1) (+ natural hole))))
; (in-hole (W_1) (+ natural hole)))) (let recur ([pat pat])
(let recur ([pat pat]) (match pat
(match pat [`number (generator/attempts (λ (a) ((next-number-decision) a)))]
[`number (generator/attempts (λ (a) ((next-number-decision) a)))] [`natural (generator/attempts (λ (a) ((next-natural-decision) a)))]
[`natural (generator/attempts (λ (a) ((next-natural-decision) a)))] [`integer (generator/attempts (λ (a) ((next-integer-decision) a)))]
[`integer (generator/attempts (λ (a) ((next-integer-decision) a)))] [`real (generator/attempts (λ (a) ((next-real-decision) a)))]
[`real (generator/attempts (λ (a) ((next-real-decision) a)))] [`(variable-except ,vars ...)
[`(variable-except ,vars ...) (let ([g (recur 'variable)])
(let ([g (recur 'variable)]) (λ (r s a e f)
(λ (r s a e f) (generate/pred pat
(generate/pred pat (λ (s a) (g r s a e f))
(λ (s a) (g r s a e f)) (λ (var _) (not (memq var vars)))
(λ (var _) (not (memq var vars))) s a r)))]
s a r)))] [`variable (generator/attempts (λ (a) ((next-variable-decision) lits a)))]
[`variable (generator/attempts (λ (a) ((next-variable-decision) lits a)))] [`variable-not-otherwise-mentioned
[`variable-not-otherwise-mentioned (let ([g (recur 'variable)])
(let ([g (recur 'variable)]) (λ (r s a e f)
(λ (r s a e f) (generate/pred pat
(generate/pred pat (λ (s a) (g r s a e f))
(λ (s a) (g r s a e f)) (λ (var _) (not (memq var lit-syms)))
(λ (var _) (not (memq var lit-syms))) s a r)))]
s a r)))] [`(variable-prefix ,prefix)
[`(variable-prefix ,prefix) (define (symbol-append prefix suffix)
(define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let ([g (recur 'variable)])
(let ([g (recur 'variable)]) (λ (r s a e f)
(λ (r s a e f) (let-values ([(t e) (g r s a e f)])
(let-values ([(t e) (g r s a e f)]) (values (symbol-append prefix t) e))))]
(values (symbol-append prefix t) e))))] [`string (generator/attempts (λ (a) ((next-string-decision) lits a)))]
[`string (generator/attempts (λ (a) ((next-string-decision) lits a)))] [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) (let ([g (recur pat)])
(let ([g (recur pat)]) (λ (r s a e f)
(λ (r s a e f) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) (λ (s a) (g r s a e f))
(λ (s a) (g r s a e f)) (λ (_ env) (condition (bindings env)))
(λ (_ env) (condition (bindings env))) s a r)))]
s a r)))] [`(name ,(? symbol? id) ,p)
[`(name ,(? symbol? id) ,p) (let ([g (recur p)])
(let ([g (recur p)]) (λ (r s a e f)
(λ (r s a e f) (let-values ([(t env) (g r s a e f)])
(let-values ([(t env) (g r s a e f)]) (values t (hash-set env (make-binder id) t)))))]
(values t (hash-set env (make-binder id) t)))))] [`hole (λ (r s a e f) (values f e))]
[`hole (λ (r s a e f) (values f e))] [`(in-hole ,context ,filler)
[`(in-hole ,context ,filler) (let ([c-context (recur context)]
(let ([c-context (recur context)] [c-filler (recur filler)])
[c-filler (recur filler)]) (λ (r s a e f)
(λ (r s a e f) (let*-values ([(filler env) (c-filler r s a e f)]
(let*-values ([(filler env) (c-filler r s a e f)] [(context env) (c-context r s a env the-hole)])
[(context env) (c-context r s a env the-hole)]) (values (plug context filler) env))))]
(values (plug context filler) env))))] [`(hide-hole ,pattern)
[`(hide-hole ,pattern) (let ([g (recur pattern)])
(let ([g (recur pattern)]) (λ (r s a e f)
(λ (r s a e f) (g r s a e the-not-hole)))]
(g r s a e the-not-hole)))] [`any
[`any (λ (r s a e f)
(λ (r s a e f) (let*-values ([(lang nt) ((next-any-decision) langc sexpc)]
(let*-values ([(lang nt) ((next-any-decision) langc sexpc)] [(term) (gen-nt lang nt #f r s a the-not-hole)])
[(term) (gen-nt lang nt #f r s a the-not-hole)]) (values term e)))]
(values term e)))] [(or (? symbol? (? nt? p)) `(cross ,(? symbol? p)))
[(or (? symbol? (? nt? p)) `(cross ,(? symbol? p))) (let ([cross? (not (symbol? pat))])
(let ([cross? (not (symbol? pat))]) (λ (r s a e f)
(λ (r s a e f) (values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))]
(values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))] [(? binder?)
[(? binder?) (let ([g (recur (binder-pattern pat))])
(let ([g (recur (binder-pattern pat))]) (λ (r s a e f)
(λ (r s a e f) (generate/prior pat e (λ () (g r s a e f)))))]
(generate/prior pat e (λ () (g r s a e f)))))] [(? mismatch?)
[(? mismatch?) (let ([g (recur (mismatch-pattern pat))])
(let ([g (recur (mismatch-pattern pat))]) (set! mismatches? #t)
(set! mismatches? #t) (λ (r s a e f)
(λ (r s a e f) (let-values ([(t e) (g r s a e f)])
(let-values ([(t e) (g r s a e f)]) (values t (hash-set e pat t)))))]
(values t (hash-set e pat t)))))] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?))
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (λ (r s a e f) (values pat e))]
(λ (r s a e f) (values pat e))] [(list-rest (struct ellipsis (name sub-pat class vars)) rest)
[(list-rest (struct ellipsis (name sub-pat class vars)) rest) (let ([elemg (recur sub-pat)]
(let ([elemg (recur sub-pat)] [tailg (recur rest)])
[tailg (recur rest)]) (when (mismatch? name)
(when (mismatch? name) (set! mismatches? #t))
(set! mismatches? #t)) (λ (r s a e f)
(λ (r s a e f) (let*-values ([(len)
(let*-values ([(len) (let ([prior (hash-ref e class #f)])
(let ([prior (hash-ref e class #f)]) (if prior
(if prior prior
prior (if (zero? s) 0 ((next-sequence-decision) s))))]
(if (zero? s) 0 ((next-sequence-decision) s))))] [(seq env)
[(seq env) (generate-sequence (λ (e) (elemg r s a e f)) e vars len)]
(generate-sequence (λ (e) (elemg r s a e f)) e vars len)] [(tail env)
[(tail env) (let ([e (hash-set (hash-set env class len) name len)])
(let ([e (hash-set (hash-set env class len) name len)]) (tailg r s a e f))])
(tailg r s a e f))]) (values (append seq tail) env))))]
(values (append seq tail) env))))] [(list-rest hdp tlp)
[(list-rest hdp tlp) (let ([hdg (recur hdp)]
(let ([hdg (recur hdp)] [tlg (recur tlp)])
[tlg (recur tlp)]) (λ (r s a e f)
(λ (r s a e f) (let*-values
(let*-values ([(hd env) (hdg r s a e f)]
([(hd env) (hdg r s a e f)] [(tl env) (tlg r s a env f)])
[(tl env) (tlg r s a env f)]) (values (cons hd tl) env))))]
(values (cons hd tl) env))))] [else
[else (error what "unknown pattern ~s\n" pat)]))])
(error what "unknown pattern ~s\n" pat)]))]) (if mismatches?
(if mismatches? (λ (r s a e f)
(λ (r s a e f) (let ([g (λ (s a) (generator r s a e f))]
(let ([g (λ (s a) (generator r s a e f))] [p? (λ (_ e) (mismatches-satisfied? e))])
[p? (λ (_ e) (mismatches-satisfied? e))]) (generate/pred (unparse-pattern pat) g p? s a r)))
(generate/pred (unparse-pattern pat) g p? s a r))) generator)))
generator)))] (define (compile-non-terminals nts any?)
[(compile-non-terminals) (make-immutable-hash
(λ (nts any?) (map (λ (nt) (cons (nt-name nt)
(make-immutable-hash (map (λ (p) (compile (rhs-pattern p) any?))
(map (λ (nt) (cons (nt-name nt) (nt-rhs nt))))
(map (λ (p) (compile (rhs-pattern p) any?)) nts)))
(nt-rhs nt)))) (define (compile-language lang bases any?)
nts)))] (make-rg-lang
[(compile-language) (compile-non-terminals (compiled-lang-lang lang) any?)
(λ (lang bases any?) (delay (compile-non-terminals (compiled-lang-cclang lang) any?))
(make-rg-lang bases))
(compile-non-terminals (compiled-lang-lang lang) any?) (define langc (compile-language langp lang-bases #f))
(delay (compile-non-terminals (compiled-lang-cclang lang) any?)) (define sexpc (compile-language sexpp sexp-bases #t))
bases))] (define (compile-pattern pat) (compile pat #f))
[(langc sexpc compile-pattern) (λ (pat)
(values (define g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level))))
(compile-language langp lang-bases #f) (λ (size attempt retries)
(compile-language sexpp sexp-bases #t) (define-values (t e) (g retries size attempt empty-env the-hole))
(λ (pat) (compile pat #f)))]) (values (let replace-the-not-hole ([t t])
(λ (pat) (cond [(eq? t the-not-hole) the-hole]
(let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))]) [(list? t) (map replace-the-not-hole t)]
(λ (size attempt retries) [else t]))
(let-values ([(t e) (g retries size attempt empty-env the-hole)]) (bindings e)))))
(values (let replace-the-not-hole ([t t])
(cond [(eq? t the-not-hole) the-hole]
[(list? t) (map replace-the-not-hole t)]
[else t]))
(bindings e)))))))))
(define-struct base-cases (delayed-cross non-cross)) (define-struct base-cases (delayed-cross non-cross))
(define (base-cases-cross x) (force (base-cases-delayed-cross x))) (define (base-cases-cross x) (force (base-cases-delayed-cross x)))
@ -997,7 +988,7 @@
(reduction-relation-make-procs r))) (reduction-relation-make-procs r)))
(define (metafunction-srcs m) (define (metafunction-srcs m)
(map (compose (curry format "clause at ~a") metafunc-case-src-loc) (map (λ (x) (format "clause at ~a" (metafunc-case-src-loc x)))
(metafunc-proc-cases m))) (metafunc-proc-cases m)))
(define-syntax (check-reduction-relation stx) (define-syntax (check-reduction-relation stx)

View File

@ -1,6 +1,6 @@
#lang racket #lang racket/base
(require "matcher.rkt") (require racket/list "matcher.rkt")
;; don't provide reduction-relation directly, so that we can use that for the macro's name. ;; don't provide reduction-relation directly, so that we can use that for the macro's name.
(provide reduction-relation-lang (provide reduction-relation-lang