suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update func expander

Browse Source
This commit is contained in:
Matthew Butterick 2016-08-30 12:28:22 -07:00
parent 90ec2a1244
commit e2df4fee70
1 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
beautiful-racket/br/demo/bf/bf-expander.rkt
View File

@ -5,22 +5,24 @@
PARSE-TREE)) PARSE-TREE))
(provide (rename-out [bf-module-begin #%module-begin])) (provide (rename-out [bf-module-begin #%module-begin]))
(define-macro (bf-program OP-OR-LOOP-ARG ...) (define (fold-funcs apl bf-funcs)
#'(void (fold-args (list (make-vector 30000 0) 0)
OP-OR-LOOP-ARG ...)))
(provide bf-program)
(define (fold-args apl . bf-args)
(for/fold ([current-apl apl]) (for/fold ([current-apl apl])
([bf-arg (in-list bf-args)]) ([bf-func (in-list bf-funcs)])
(apply bf-arg current-apl))) (apply bf-func current-apl)))
(define-macro (bf-program OP-OR-LOOP-ARG ...)
#'(begin
(define first-apl (list (make-vector 30000 0) 0))
(void (fold-funcs first-apl (list OP-OR-LOOP-ARG ...)))))
(provide bf-program)
(define-macro (loop "[" OP-OR-LOOP-ARG ... "]") (define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
#'(lambda (arr ptr) #'(lambda (arr ptr)
(for/fold ([current-apl (list arr ptr)]) (for/fold ([current-apl (list arr ptr)])
([i (in-naturals)] ([i (in-naturals)]
#:break (zero? (apply current-byte apl))) #:break (zero? (apply current-byte
(fold-args current-apl OP-OR-LOOP-ARG ...)))) current-apl)))
(fold-funcs current-apl (list OP-OR-LOOP-ARG ...)))))
(provide loop) (provide loop)
(define-macro-cases op (define-macro-cases op