207 lines
6.8 KiB
Scheme
207 lines
6.8 KiB
Scheme
(module helper mzscheme
|
|
(require (lib "contract.ss")
|
|
"reduction-semantics.ss")
|
|
|
|
(define counter 0)
|
|
(define (generate-string)
|
|
(set! counter (add1 counter))
|
|
(format "s~a" counter))
|
|
|
|
(define (unique-names? l)
|
|
(let ([ht (make-hash-table)])
|
|
(andmap (lambda (n)
|
|
(if (hash-table-get ht n (lambda () #f))
|
|
#f
|
|
(begin
|
|
(hash-table-put! ht n #t)
|
|
#t)))
|
|
l)))
|
|
|
|
(define (all-of P ?)
|
|
;; Traverse P as an sexp, and look for class-name uses:
|
|
(let ([l (let loop ([sexp P])
|
|
(cond
|
|
[(? sexp) (list sexp)]
|
|
[(pair? sexp) (append (loop (car sexp)) (loop (cdr sexp)))]
|
|
[else null]))]
|
|
[ht (make-hash-table)])
|
|
;; Filter duplicates by hashing:
|
|
(for-each (lambda (i) (hash-table-put! ht i #t)) l)
|
|
(hash-table-map ht (lambda (k v) k))))
|
|
|
|
(define-syntaxes (lang-match-lambda*
|
|
lang-match-lambda-memoized*
|
|
lang-match-lambda
|
|
lang-match-lambda-memoized)
|
|
(let ([generic
|
|
(lambda (lam)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (id ...) main-id grammar [pattern result] ...)
|
|
(with-syntax ([red (generate-temporaries #'(pattern ...))]
|
|
[lam lam]
|
|
[ids #'(id ...)])
|
|
(syntax/loc
|
|
stx
|
|
(let ([lang grammar]
|
|
[escape (make-parameter void)])
|
|
(let ([reds (list (reduction grammar pattern ((escape) (lambda ids result)))
|
|
...)])
|
|
(lam (id ...)
|
|
((let/ec esc
|
|
(parameterize ([escape esc])
|
|
(reduce reds main-id)
|
|
(error 'lang-match-lambda "no pattern matched input: ~e" main-id)))
|
|
id ...))))))])))]
|
|
[single
|
|
(lambda (multi)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (id) grammar [pattern result] ...)
|
|
(with-syntax ([multi multi])
|
|
#'(multi (id) id grammar [pattern result] ...))])))])
|
|
(values
|
|
(generic #'lambda)
|
|
(generic #'lambda-memoized)
|
|
(single #'lang-match-lambda*)
|
|
(single #'lang-match-lambda-memoized*))))
|
|
|
|
(define (transitive-closure orig)
|
|
;; Copy initial mapping:
|
|
(let ([map (map (lambda (p) (list (car p) (cdr p))) orig)])
|
|
;; Extend the map list until nothing changes
|
|
(let loop ()
|
|
(let ([changed? #f])
|
|
(for-each (lambda (pair)
|
|
(let ([mapping (cdr pair)])
|
|
(for-each (lambda (item)
|
|
(let ([trans (ormap (lambda (transitive)
|
|
(and (not (memq transitive mapping))
|
|
transitive))
|
|
(cdr (assq item map)))])
|
|
(when trans
|
|
(append! pair (list trans))
|
|
(set! changed? #t))))
|
|
mapping)))
|
|
map)
|
|
(when changed? (loop))))
|
|
;; Done
|
|
map))
|
|
|
|
(define-syntax (lambda-memoized stx)
|
|
(syntax-case stx ()
|
|
[(_ () body1 body ...)
|
|
(syntax/loc stx (lambda () body1 body ...))]
|
|
[(_ (arg) body1 body ...)
|
|
(syntax/loc
|
|
stx
|
|
(let ([ht (make-hash-table 'weak)])
|
|
(lambda (arg)
|
|
(hash-table-get
|
|
ht
|
|
arg
|
|
(lambda ()
|
|
(let ([v (begin body1 body ...)])
|
|
(hash-table-put! ht arg v)
|
|
v))))))]
|
|
[(_ (arg1 arg ...) body1 body ...)
|
|
(syntax/loc
|
|
stx
|
|
(let ([memo (lambda-memoized (arg1) (lambda-memoized (arg ...) body1 body ...))])
|
|
(lambda (arg1 arg ...)
|
|
((memo arg1) arg ...))))]))
|
|
|
|
(define-syntax define-memoized
|
|
(syntax-rules ()
|
|
[(_ (f . args) body1 body ...)
|
|
(define f (lambda-memoized args body1 body ...))]))
|
|
|
|
|
|
;; function-reduce*
|
|
(define (function-reduce* reds expr done? max-steps)
|
|
(cons
|
|
expr
|
|
(if (or (zero? max-steps) (done? expr))
|
|
null
|
|
(let ([l (reduce reds expr)])
|
|
(cond
|
|
[(null? l) null]
|
|
[(= 1 (length l))
|
|
(function-reduce* reds (car l) done? (sub1 max-steps))]
|
|
[else
|
|
(error 'function-reduce*
|
|
"found ~a possible steps from ~e"
|
|
(length l)
|
|
expr)])))))
|
|
|
|
(define-struct multi-result (choices))
|
|
|
|
;; ----------------------------------------
|
|
;; Path exploration:
|
|
|
|
(define-syntax (explore-results stx)
|
|
(syntax-case stx ()
|
|
[(_ (id) result-expr body-expr bes ...)
|
|
#'(let ([try (lambda (id) body-expr bes ...)])
|
|
(let ([r result-expr])
|
|
(do-explore r try)))]))
|
|
|
|
(define-syntax (explore-parallel-results stx)
|
|
(syntax-case stx ()
|
|
[(_ (list-id) result-list-expr body-expr bes ...)
|
|
#'(let ([try (lambda (list-id) body-expr bes ...)])
|
|
(let loop ([rs result-list-expr][es null])
|
|
(if (null? rs)
|
|
(try (reverse es))
|
|
(do-explore
|
|
(car rs)
|
|
(lambda (e)
|
|
(loop (cdr rs) (cons e es)))))))]))
|
|
|
|
(define (do-explore r try)
|
|
(cond
|
|
[(multi-result? r)
|
|
(let loop ([l (multi-result-choices r)])
|
|
(if (null? l)
|
|
#f
|
|
(let ([a ((car l))])
|
|
(if (multi-result? a)
|
|
(loop (append (multi-result-choices a)
|
|
(cdr l)))
|
|
(let ([v (try a)])
|
|
(if (not v)
|
|
(loop (cdr l))
|
|
(make-multi-result
|
|
(append (if (multi-result? v)
|
|
(multi-result-choices v)
|
|
(list (lambda () v)))
|
|
(list (lambda () (loop (cdr l))))))))))))]
|
|
[else (try r)]))
|
|
|
|
(define (many-results l)
|
|
(make-multi-result (map (lambda (v) (lambda () v)) l)))
|
|
|
|
(define (first-result result)
|
|
(let/ec k
|
|
(explore-results (x) result
|
|
(k x))))
|
|
|
|
(provide
|
|
define-memoized
|
|
lambda-memoized
|
|
lang-match-lambda
|
|
lang-match-lambda-memoized
|
|
lang-match-lambda*
|
|
lang-match-lambda-memoized*
|
|
explore-results
|
|
explore-parallel-results)
|
|
(provide/contract
|
|
(function-reduce* ((listof red?) any/c (any/c . -> . boolean?) number?
|
|
. -> . (listof any/c)))
|
|
(unique-names? ((listof symbol?) . -> . boolean?))
|
|
(generate-string (-> string?))
|
|
(all-of (any/c (any/c . -> . any) . -> . (listof any/c)))
|
|
(transitive-closure ((listof pair?) . -> . (listof (listof any/c))))
|
|
(many-results ((listof (lambda (x) (not (multi-result? x)))) . -> . any))
|
|
(first-result (any/c . -> . any))))
|