rerefactoring

pull/2/head
Matthew Butterick 9 years ago
parent fc826f9269
commit d9e8be7544

@ -297,10 +297,12 @@
(define-syntax (br:define-macro stx) (define-syntax (br:define-macro stx)
(syntax-case stx (syntax) (syntax-case stx (syntax)
[(_ id #'other-id) ; (define-macro id #'other-id)
#'(br:define #'id #'other-id)]
[(_ (id . patargs) . body) [(_ (id . patargs) . body)
#'(br:define (syntax (id . patargs)) . body)] #'(br:define #'(id . patargs) . body)]
[(_ id [pat . patbody] ...) [(_ id [pat . patbody] ...)
#'(br:define-cases (syntax id) [pat . patbody] ...)])) #'(br:define-cases #'id [pat . patbody] ...)]))
(define-syntax (br:define-macro-cases stx) (define-syntax (br:define-macro-cases stx)
(syntax-case stx (syntax) (syntax-case stx (syntax)
@ -314,4 +316,6 @@
(br:define-macro-cases add-again [(_ X) #'(+ X X)]) (br:define-macro-cases add-again [(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10) (check-equal? (add-again 5) 10)
(br:define-macro add-3rd [(_ X) #'(+ X X)]) (br:define-macro add-3rd [(_ X) #'(+ X X)])
(check-equal? (add-3rd 5) 10)) (check-equal? (add-3rd 5) 10)
(br:define-macro add-4th #'add-3rd)
(check-equal? (add-4th 5) 10))

@ -132,4 +132,5 @@
. body)) . body))
(define-syntax with-shared-id (make-rename-transformer #'introduce-id)) (define-syntax with-shared-id (make-rename-transformer #'introduce-id))
(define-syntax mark-as-shared-id (make-rename-transformer #'introduce-id))

@ -69,11 +69,8 @@
(current-return-stack (cons NUMBER (current-return-stack))) (current-return-stack (cons NUMBER (current-return-stack)))
(basic:GOTO WHERE)] (basic:GOTO WHERE)]
[else (current-return-stack (cdr (current-return-stack)))]))))] [else (current-return-stack (cdr (current-return-stack)))]))))]
[(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))]) [(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))])
(define-macro statement-list
[(_ STATEMENT) #'(begin STATEMENT)]
[(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)])
(define-macro statement (define-macro statement
[(statement ID "=" EXPR) #'(set! ID EXPR)] [(statement ID "=" EXPR) #'(set! ID EXPR)]

@ -1,11 +1,8 @@
#lang brag #lang brag
;; recursive rules destucture easily in the expander program : line*
program : [CR]* [line [CR line]*] [CR]*
line: NUMBER statement-list line: NUMBER statement [":" statement]*
statement-list : statement [":" statement-list]
statement : "END" statement : "END"
| "GOSUB" NUMBER | "GOSUB" NUMBER

@ -15,9 +15,8 @@
(define get-token (define get-token
(lexer (lexer
[(eof) eof] [(eof) eof]
[(union #\tab #\space [(union #\tab #\space #\newline
(seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)] (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
[(seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")]
[(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO" [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
"INPUT" "LET" "NEXT" "RETURN" "INPUT" "LET" "NEXT" "RETURN"
"CLEAR" "LIST" "RUN" "END" "CLEAR" "LIST" "RUN" "END"

@ -49,7 +49,7 @@
(define-macro (output-file-expr OUTPUT-FILE-STRING) (define-macro (output-file-expr OUTPUT-FILE-STRING)
(with-shared-id (mark-as-shared-id
(output-file output-filename) (output-file output-filename)
#'(begin #'(begin
(define output-filename OUTPUT-FILE-STRING) (define output-filename OUTPUT-FILE-STRING)
@ -60,14 +60,14 @@
(define-macro (compare-to-expr COMPARE-FILE-STRING) (define-macro (compare-to-expr COMPARE-FILE-STRING)
(with-shared-id (mark-as-shared-id
(compare-files) (compare-files)
#'(define (compare-files) #'(define (compare-files)
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING))))) (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...) (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
(with-shared-id (mark-as-shared-id
(eval-result eval-chip output) (eval-result eval-chip output)
(with-pattern (with-pattern
([(COL-ID ...) (suffix-id #'(COL-NAME ...))] ([(COL-ID ...) (suffix-id #'(COL-NAME ...))]

@ -21,7 +21,7 @@
;; ============================================================ ;; ============================================================
;; Overall module: ;; Overall module:
(define #'(module-begin _lines ...) (define-macro (module-begin _lines ...)
#'(#%module-begin #'(#%module-begin
_lines ... _lines ...
@ -35,46 +35,44 @@
;; Process parse trees from the reader: ;; Process parse trees from the reader:
(provide txtadv-program) (provide txtadv-program)
(define #'txtadv-program #'module-begin) (define-macro txtadv-program #'module-begin)
(provide verb-section) (provide verb-section)
(define #'(verb-section (define-macro-cases verb-section
((_name0 . _transitive0?) [(_ ((NAME0 . TRANSITIVE0?) (NAME . _) ... DESC) ...)
(_name . _transitive?) ... _desc) ...) (mark-as-shared-id
(inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) (in-verbs)
#'(define-verbs in-verbs #'(define-verbs in-verbs
[_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...))) [(NAME0 . TRANSITIVE0?) (= NAME ...) DESC] ...))])
(provide everywhere-section) (provide everywhere-section)
(define #'(everywhere-section [_id _desc] ...) (define-macro (everywhere-section [ID DESC] ...)
#'(define-everywhere everywhere-actions #'(define-everywhere everywhere-actions
([_id _desc] ...))) ([ID DESC] ...)))
(provide things-section) (provide things-section)
(define #'(things-section (_thingname (_actionname _actiondesc) ...) ...) (define-macro (things-section (THINGNAME (ACTIONNAME ACTIONDESC) ...) ...)
#'(begin (define-thing _thingname [_actionname _actiondesc] ...) ...)) #'(begin (define-thing THINGNAME [ACTIONNAME ACTIONDESC] ...) ...))
(provide places-section) (provide places-section)
(define #'(places-section (_place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) ...) (define-macro (places-section (PLACE-ID PLACE-DESC [PLACE-ITEM ...] [ACTIONNAME ACTIONDESC] ...) ...)
#'(begin (define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)) ...)) #'(begin (define-place PLACE-ID PLACE-DESC [PLACE-ITEM ...] ([ACTIONNAME ACTIONDESC] ...)) ...))
;; todo: consolidate the game-starters. ;; todo: consolidate the game-starters.
;; `start-game-at` works with s-exp language, ;; `start-game-at` works with s-exp language,
;; `start-section` works with text lang. ;; `start-section` works with text lang.
(provide start-game-at) (provide start-game-at)
(define #'(start-game-at _where) (define-macro (start-game-at WHERE)
(inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) #'(init-game WHERE
#'(init-game _where in-verbs
in-verbs everywhere-actions))
everywhere-actions)))
(provide start-section) (provide start-section)
(define #'(start-section _where) (define-macro (start-section WHERE)
(inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) #'(init-game WHERE
#'(init-game _where in-verbs
in-verbs everywhere-actions))
everywhere-actions)))
;; ============================================================ ;; ============================================================
;; Model: ;; Model:
@ -108,42 +106,42 @@
;; ============================================================ ;; ============================================================
;; Macros for constructing and registering elements: ;; Macros for constructing and registering elements:
(define #'(define-verbs _all-id [_id _spec ...] ...) (define-macro (define-verbs ALL-ID [(ID . MAYBE-UNDERSCORE) SPEC ...] ...)
#'(begin #'(begin
(define-one-verb _id _spec ...) ... (define-one-verb (ID . MAYBE-UNDERSCORE) SPEC ...) ...
(record-element! '_id _id) ... (record-element! 'ID ID) ...
(define _all-id (list _id ...)))) (define ALL-ID (list ID ...))))
;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards ;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards
(define-cases #'define-one-verb (define-macro (define-one-verb (ID . MAYBE-UNDERSCORE) . REST)
[#'(_ _id (= _alias ...) _desc) (with-pattern
#'(define _id (verb (list '_id '_alias ...) _desc #f))] ([TRANSITIVE? (equal? '("_") (syntax->datum #'MAYBE-UNDERSCORE))]
[#'(_ _id _ (= _alias ...) _desc) [VERB-ARGS (syntax-case #'REST ()
#'(define _id (verb (list '_id '_alias ...) _desc #t))] [((= ALIAS ...) DESC)
[#'(_ _id) #'((list 'ID 'ALIAS ...) DESC TRANSITIVE?)]
#'(define _id (verb (list '_id) (symbol->string '_id) #f))] [else
[#'(_ _id _) #'((list 'ID) (symbol->string 'ID) TRANSITIVE?)])])
#'(define _id (verb (list '_id) (symbol->string '_id) #t))]) #'(define ID (verb . VERB-ARGS))))
(define #'(define-thing _id [_vrb _expr] ...) (define-macro (define-thing ID [VERB-ARG EXPR] ...)
#'(begin #'(begin
(define _id (define ID
(thing '_id #f (list (cons _vrb (λ () _expr)) ...))) (thing 'ID #f (list (cons VERB-ARG (λ () EXPR)) ...)))
(record-element! '_id _id))) (record-element! 'ID ID)))
(define #'(define-place _id _desc (_thng ...) ([_vrb _expr] ...)) (define-macro (define-place ID DESC (THING-ARG ...) ([VERB-ARG EXPR] ...))
#'(begin #'(begin
(define _id (place _desc (define ID (place DESC
(list _thng ...) (list THING-ARG ...)
(list (cons _vrb (λ () _expr)) ...))) (list (cons VERB-ARG (λ () EXPR)) ...)))
(record-element! '_id _id))) (record-element! 'ID ID)))
(define #'(define-everywhere _id ([_vrb _expr] ...)) (define-macro (define-everywhere ID ([VERB-ARG EXPR] ...))
#'(define _id (list (cons _vrb (λ () _expr)) ...))) #'(define ID (list (cons VERB-ARG (λ () EXPR)) ...)))
;; ============================================================ ;; ============================================================
;; Game state ;; Game state

@ -2,15 +2,6 @@
txtadv-program : verb-section everywhere-section things-section places-section start-section txtadv-program : verb-section everywhere-section things-section places-section start-section
;; hide on right side: remove element
;; useful for: getting rid of literals
;; splice on right side: lift element
;; useful for: selective splicing
;; hide on left side: remove name, leave container
;; useful for: grouping args, avoiding "alternation" pattern
;; splice on left side: lift everywhere
;; useful for: flattening recursive structures
verb-section : /"===VERBS===" verb-item+ verb-section : /"===VERBS===" verb-item+
/verb-item : verb-list s-exp /verb-item : verb-list s-exp
@ -19,7 +10,7 @@ verb-section : /"===VERBS===" verb-item+
/verb : ID ["_"] /verb : ID ["_"]
everywhere-section : /"===EVERYWHERE===" id-desc+ everywhere-section : /"===EVERYWHERE===" id-desc*
things-section : /"===THINGS===" thing-item+ things-section : /"===THINGS===" thing-item+

Loading…
Cancel
Save