From cface5b7f9c8d83ff8605977d1903bf492b0e9f3 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 2 May 2016 16:18:29 -0400 Subject: [PATCH] start new parser for txtadv --- beautiful-racket/br/demo/txtadv.rkt | 4 +- beautiful-racket/br/demo/txtadv/expander.rkt | 37 +++- beautiful-racket/br/demo/txtadv/footest.rkt | 1 + beautiful-racket/br/demo/txtadv/main.rkt | 5 - beautiful-racket/br/demo/txtadv/parser.rkt | 15 ++ beautiful-racket/br/demo/txtadv/reader.rkt | 164 +----------------- beautiful-racket/br/demo/txtadv/reader0.rkt | 160 +++++++++++++++++ beautiful-racket/br/demo/txtadv/tokenizer.rkt | 23 +++ beautiful-racket/br/demo/txtadv/world.rkt | 8 +- .../br/demo/txtadv/world0-test.rkt | 41 +++++ beautiful-racket/br/demo/txtadv/world0.rkt | 162 +++++++++++++++++ 11 files changed, 452 insertions(+), 168 deletions(-) create mode 100644 beautiful-racket/br/demo/txtadv/footest.rkt delete mode 100644 beautiful-racket/br/demo/txtadv/main.rkt create mode 100644 beautiful-racket/br/demo/txtadv/parser.rkt create mode 100644 beautiful-racket/br/demo/txtadv/reader0.rkt create mode 100644 beautiful-racket/br/demo/txtadv/tokenizer.rkt create mode 100644 beautiful-racket/br/demo/txtadv/world0-test.rkt create mode 100644 beautiful-racket/br/demo/txtadv/world0.rkt diff --git a/beautiful-racket/br/demo/txtadv.rkt b/beautiful-racket/br/demo/txtadv.rkt index 45f5dd3..1793843 100644 --- a/beautiful-racket/br/demo/txtadv.rkt +++ b/beautiful-racket/br/demo/txtadv.rkt @@ -1,5 +1,5 @@ #lang br (module reader br - (require "txtadv/reader.rkt") - (provide (all-from-out "txtadv/reader.rkt"))) + (require "txtadv/reader0.rkt") + (provide (all-from-out "txtadv/reader0.rkt"))) diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index 1498624..e900424 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/beautiful-racket/br/demo/txtadv/expander.rkt @@ -1,4 +1,5 @@ #lang br +(require (for-syntax racket/string)) (provide define-verbs define-thing @@ -20,7 +21,41 @@ ;; ============================================================ ;; Overall module: -(define #'(module-begin (define-verbs _all-verbs _cmd ...) +(define #'(module-begin _arg ...) + #'(#%module-begin + '_arg ...)) + +(provide txtadv-program) +(define-inverting #'(txtadv-program _verb-section ...) + #'(_verb-section ...)) + +(provide verb-section) +(define-inverting #'(verb-section _heading _verb-entry ...) + #'(define-verbs all-verbs + _verb-entry ...)) + +(provide verb-entry) +(define-inverting #'(verb-entry (_name0 _transitive0?) (_name _transitive?) ... _desc) + #`[_name0 #,@(if #'transitive0? #'(_) #'()) (= _name ...) _desc]) + +(provide verb-name) +(define-cases #'verb-name + ;; cases with literals go first, so they're not caught by wildcards + [#'(_ "," _id) #'(_id #f)] + [#'(_ "," _id _underscore) #'(_id #t)] + [#'(_ _id) #'(_id #f)] + [#'(_ _id _underscore) #'(_id #t)]) + +(provide s-exp) +(define #'(s-exp _sx) + #'_sx) + +(provide desc) +(define #'(desc _d) + #'_d) + + +#;(define #'(module-begin (define-verbs _all-verbs _cmd ...) (define-everywhere _everywhere-actions _act ...) _decl ... _id) diff --git a/beautiful-racket/br/demo/txtadv/footest.rkt b/beautiful-racket/br/demo/txtadv/footest.rkt new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/footest.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/beautiful-racket/br/demo/txtadv/main.rkt b/beautiful-racket/br/demo/txtadv/main.rkt deleted file mode 100644 index 71f1a98..0000000 --- a/beautiful-racket/br/demo/txtadv/main.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang br - -(module+ reader - (require "reader.rkt") - (provide (all-from-out "reader.rkt"))) diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt new file mode 100644 index 0000000..85163c6 --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/parser.rkt @@ -0,0 +1,15 @@ +#lang ragg + +txtadv-program : [verb-section] + +verb-section : verb-heading verb-entry+ + +verb-heading : "===VERBS===" + +verb-entry : verb-name+ desc + +verb-name : [","] ID ["_"] + +desc : s-exp + +s-exp : ID | STRING | "(" s-exp* ")" \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/reader.rkt b/beautiful-racket/br/demo/txtadv/reader.rkt index aac2996..b9ea3f2 100644 --- a/beautiful-racket/br/demo/txtadv/reader.rkt +++ b/beautiful-racket/br/demo/txtadv/reader.rkt @@ -1,160 +1,6 @@ -#lang racket -(require syntax/readerr) +#lang br -(provide (rename-out [txtadv-read-syntax read-syntax]) - ;; added at the end to link syntax to colorer: - get-info) - -(define (txtadv-read-syntax src in) - (expect-section src in "VERBS") - (define verbs (in-section src in read-verb)) - (expect-section src in "EVERYWHERE") - (define actions (in-section src in read-action)) - (expect-section src in "THINGS") - (define things (in-section src in read-thing)) - (expect-section src in "PLACES") - (define places (in-section src in read-place)) - (datum->syntax - #f - `(module world br/demo/txtadv/expander - (define-verbs all-verbs - ,@verbs) - (define-everywhere everywhere-actions - ,actions) - ,@things - ,@places - ,(if (null? places) - (complain src in "no places defined") - (cadar places))))) - -(define (complain src in msg) - (define-values (line col pos) (port-next-location in)) - (raise-read-error msg src line col pos 1)) - -(define (skip-whitespace in) - (regexp-try-match #px"^\\s+" in)) - -(define (expect-section src in name) - (skip-whitespace in) - (unless (regexp-match-peek (pregexp (format "^===~a===\\s" name)) - in) - (complain src in (format "expected a ===~a=== section" name))) - (read-line in) - (read-line in)) - -(define (in-section src in reader) - (skip-whitespace in) - (if (or (regexp-match-peek #rx"^===" in) - (eof-object? (peek-byte in))) - null - (cons (reader src in) - (in-section src in reader)))) - -(define (in-defn src in reader) - (skip-whitespace in) - (if (or (regexp-match-peek #rx"^(===|---)" in) - (eof-object? (peek-byte in))) - null - (cons (reader src in) - (in-defn src in reader)))) - -(define (read-name src in) - (if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in) - (read-syntax src in) - (complain src in "expected a name"))) - -(define (read-name-sequence src in transitive) - (let loop ([names null] [transitive transitive]) - (define s (read-name src in)) - (define is-trans? - (cond - [(regexp-match-peek #rx"^ _" in) - (if (or (eq? transitive 'unknown) - (eq? transitive #t)) - (begin - (read-char in) - (read-char in) - #t) - (begin - (read-char in) - (complain src in "unexpected underscore")))] - [else - (if (eq? transitive #t) - (complain src in "inconsistent transitivity") - #f)])) - (if (regexp-match-peek #rx"^, " in) - (begin - (read-char in) - (read-char in) - (loop (cons s names) is-trans?)) - (values (reverse (cons s names)) is-trans?)))) - -(define (read-verb src in) - (skip-whitespace in) - (define-values (names is-transitive?) - (read-name-sequence src in 'unknown)) - (skip-whitespace in) - (define desc - (if (regexp-match-peek #rx"^\"" in) - (read-syntax src in) - (symbol->string (syntax-e (car names))))) - `[,(car names) - ,@(if is-transitive? '(_) '()) - (= ,@(cdr names)) - ,desc]) - -(define (read-action src in) - (skip-whitespace in) - (define name (read-name src in)) - (define expr (read-syntax src in)) - `[,name ,expr]) - -(define (read-defn-name src in what) - (skip-whitespace in) - (unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s" - in) - (complain src in (format "expected a ~a definition of the form ---name---" what))) - (read-string 3 in) - (define-values (line col pos) (port-next-location in)) - (define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in)))) - (datum->syntax #f - (string->symbol name-str) - (vector src line col pos (string-length name-str)) - orig-props)) -(define orig-props (read-syntax 'src (open-input-string "orig"))) - -(define (read-thing src in) - (define name (read-defn-name src in "thing")) - (define actions (in-defn src in read-action)) - `(define-thing ,name - ,@actions)) - -(define (read-place src in) - (define name (read-defn-name src in "place")) - (skip-whitespace in) - (define desc (if (regexp-match-peek #rx"^\"" in) - (read-syntax src in) - (complain src in "expected description string"))) - (skip-whitespace in) - (unless (regexp-match-peek #rx"^[[]" in) - (complain src in "expected a square bracket to start a list of things for a place")) - (read-char in) - (define-values (things _) - (if (regexp-match-peek #rx"^[]]" in) - (values null #f) - (read-name-sequence src in #f))) - (unless (regexp-match-peek #rx"^[]]" in) - (complain src in "expected a square bracket to end a list of things for a place")) - (read-char in) - (define actions (in-defn src in read-action)) - `(define-place ,name ,desc ,things ,actions)) - -;; DrRacket asks `get-info' for a 'color-lexer module: -(require racket/runtime-path) -(define-runtime-path color-lexer-path "color.rkt") -(define (get-info in mod line col pos) - (lambda (key default) - (case key - [(color-lexer) - (dynamic-require color-lexer-path 'color-lexer)] - [else default]))) +(require br/reader-utils "parser.rkt" "tokenizer.rkt") + (define-read-and-read-syntax (source-path input-port) + #`(module txtadv-mod br/demo/txtadv/expander + #,(parse source-path (tokenize input-port)))) diff --git a/beautiful-racket/br/demo/txtadv/reader0.rkt b/beautiful-racket/br/demo/txtadv/reader0.rkt new file mode 100644 index 0000000..aac2996 --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/reader0.rkt @@ -0,0 +1,160 @@ +#lang racket +(require syntax/readerr) + +(provide (rename-out [txtadv-read-syntax read-syntax]) + ;; added at the end to link syntax to colorer: + get-info) + +(define (txtadv-read-syntax src in) + (expect-section src in "VERBS") + (define verbs (in-section src in read-verb)) + (expect-section src in "EVERYWHERE") + (define actions (in-section src in read-action)) + (expect-section src in "THINGS") + (define things (in-section src in read-thing)) + (expect-section src in "PLACES") + (define places (in-section src in read-place)) + (datum->syntax + #f + `(module world br/demo/txtadv/expander + (define-verbs all-verbs + ,@verbs) + (define-everywhere everywhere-actions + ,actions) + ,@things + ,@places + ,(if (null? places) + (complain src in "no places defined") + (cadar places))))) + +(define (complain src in msg) + (define-values (line col pos) (port-next-location in)) + (raise-read-error msg src line col pos 1)) + +(define (skip-whitespace in) + (regexp-try-match #px"^\\s+" in)) + +(define (expect-section src in name) + (skip-whitespace in) + (unless (regexp-match-peek (pregexp (format "^===~a===\\s" name)) + in) + (complain src in (format "expected a ===~a=== section" name))) + (read-line in) + (read-line in)) + +(define (in-section src in reader) + (skip-whitespace in) + (if (or (regexp-match-peek #rx"^===" in) + (eof-object? (peek-byte in))) + null + (cons (reader src in) + (in-section src in reader)))) + +(define (in-defn src in reader) + (skip-whitespace in) + (if (or (regexp-match-peek #rx"^(===|---)" in) + (eof-object? (peek-byte in))) + null + (cons (reader src in) + (in-defn src in reader)))) + +(define (read-name src in) + (if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in) + (read-syntax src in) + (complain src in "expected a name"))) + +(define (read-name-sequence src in transitive) + (let loop ([names null] [transitive transitive]) + (define s (read-name src in)) + (define is-trans? + (cond + [(regexp-match-peek #rx"^ _" in) + (if (or (eq? transitive 'unknown) + (eq? transitive #t)) + (begin + (read-char in) + (read-char in) + #t) + (begin + (read-char in) + (complain src in "unexpected underscore")))] + [else + (if (eq? transitive #t) + (complain src in "inconsistent transitivity") + #f)])) + (if (regexp-match-peek #rx"^, " in) + (begin + (read-char in) + (read-char in) + (loop (cons s names) is-trans?)) + (values (reverse (cons s names)) is-trans?)))) + +(define (read-verb src in) + (skip-whitespace in) + (define-values (names is-transitive?) + (read-name-sequence src in 'unknown)) + (skip-whitespace in) + (define desc + (if (regexp-match-peek #rx"^\"" in) + (read-syntax src in) + (symbol->string (syntax-e (car names))))) + `[,(car names) + ,@(if is-transitive? '(_) '()) + (= ,@(cdr names)) + ,desc]) + +(define (read-action src in) + (skip-whitespace in) + (define name (read-name src in)) + (define expr (read-syntax src in)) + `[,name ,expr]) + +(define (read-defn-name src in what) + (skip-whitespace in) + (unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s" + in) + (complain src in (format "expected a ~a definition of the form ---name---" what))) + (read-string 3 in) + (define-values (line col pos) (port-next-location in)) + (define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in)))) + (datum->syntax #f + (string->symbol name-str) + (vector src line col pos (string-length name-str)) + orig-props)) +(define orig-props (read-syntax 'src (open-input-string "orig"))) + +(define (read-thing src in) + (define name (read-defn-name src in "thing")) + (define actions (in-defn src in read-action)) + `(define-thing ,name + ,@actions)) + +(define (read-place src in) + (define name (read-defn-name src in "place")) + (skip-whitespace in) + (define desc (if (regexp-match-peek #rx"^\"" in) + (read-syntax src in) + (complain src in "expected description string"))) + (skip-whitespace in) + (unless (regexp-match-peek #rx"^[[]" in) + (complain src in "expected a square bracket to start a list of things for a place")) + (read-char in) + (define-values (things _) + (if (regexp-match-peek #rx"^[]]" in) + (values null #f) + (read-name-sequence src in #f))) + (unless (regexp-match-peek #rx"^[]]" in) + (complain src in "expected a square bracket to end a list of things for a place")) + (read-char in) + (define actions (in-defn src in read-action)) + `(define-place ,name ,desc ,things ,actions)) + +;; DrRacket asks `get-info' for a 'color-lexer module: +(require racket/runtime-path) +(define-runtime-path color-lexer-path "color.rkt") +(define (get-info in mod line col pos) + (lambda (key default) + (case key + [(color-lexer) + (dynamic-require color-lexer-path 'color-lexer)] + [else default]))) diff --git a/beautiful-racket/br/demo/txtadv/tokenizer.rkt b/beautiful-racket/br/demo/txtadv/tokenizer.rkt new file mode 100644 index 0000000..e51ff4a --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/tokenizer.rkt @@ -0,0 +1,23 @@ +#lang br +(require parser-tools/lex parser-tools/lex-sre + ragg/support + racket/string) + +(provide tokenize) +(define (tokenize input-port) + (define (next-token) + (define get-token + (lexer + [(eof) eof] + [(union + (seq "/*" (complement (seq any-string "*/" any-string)) "*/") + (seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) + (token 'COMMENT lexeme #:skip? #t)] + [(union #\tab #\space #\newline) (get-token input-port)] + [(repetition 1 +inf.0 (union upper-case (char-set "="))) lexeme] + [(seq "\"" (complement (seq any-string "\"" any-string)) "\"") (token 'STRING lexeme)] + [(char-set ",_") lexeme] + [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) + (token 'ID (string->symbol lexeme))])) + (get-token input-port)) + next-token) diff --git a/beautiful-racket/br/demo/txtadv/world.rkt b/beautiful-racket/br/demo/txtadv/world.rkt index 2f7d9a6..5dd325d 100644 --- a/beautiful-racket/br/demo/txtadv/world.rkt +++ b/beautiful-racket/br/demo/txtadv/world.rkt @@ -1,4 +1,5 @@ -#lang br/demo/txtadv +#lang reader "reader.rkt" + ===VERBS=== @@ -8,6 +9,8 @@ north, n south, s "go south" + + east, e "go east" @@ -49,6 +52,7 @@ look, show inventory "check inventory" +/* ===EVERYWHERE=== @@ -160,3 +164,5 @@ west out house-front + +*/ \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/world0-test.rkt b/beautiful-racket/br/demo/txtadv/world0-test.rkt new file mode 100644 index 0000000..18a9583 --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/world0-test.rkt @@ -0,0 +1,41 @@ +#lang at-exp racket +(require rackunit) +(require "world0.rkt") + +(check-equal? (with-output-to-string (λ _ (do-place))) + "You're standing in a meadow. There is a house to the north.\n") + +(define-syntax-rule (check-cmd? cmd result) + (check-equal? (with-output-to-string (λ _ (do-verb cmd))) result)) + +(check-cmd? + "s" + "You're in a desert. There is nothing for miles around.\nThere is a cactus here.\nThere is a key here.\n") + +(check-cmd? + "get cactus" + "Ouch!\n") + +(check-cmd? + "get key" + "You now have the key.\n") + +(check-cmd? + "n" + "You're standing in a meadow. There is a house to the north.\n") + +(check-cmd? + "n" + "You are standing in front of a house.\nThere is a door here.\n") + +(check-cmd? + "open door" + "The door is now unlocked and open.\n") + +(check-cmd? + "enter" + "You're in the house.\nThere is a trophy here.\n") + +(check-cmd? + "get trophy" + "You win!\n") \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/world0.rkt b/beautiful-racket/br/demo/txtadv/world0.rkt new file mode 100644 index 0000000..2f7d9a6 --- /dev/null +++ b/beautiful-racket/br/demo/txtadv/world0.rkt @@ -0,0 +1,162 @@ +#lang br/demo/txtadv + +===VERBS=== + +north, n + "go north" + +south, s + "go south" + +east, e + "go east" + +west, w + "go west" + +up + "go up" + +down + "go down" + +in, enter + "enter" + +out, leave + "leave" + +get _, grab _, take _ + "take" + +put _, drop _, leave _ + "drop" + +open _, unlock _ + "open" + +close _, lock _ + "close" + +knock _ + +quit, exit + "quit" + +look, show + "look" + +inventory + "check inventory" + + +===EVERYWHERE=== + +quit + (begin + (printf "Bye!\n") + (exit)) + +look + (show-current-place) + +inventory + (show-inventory) + + + +===THINGS=== + +---cactus--- +get + "Ouch!" + +---door--- +open + (if (have-thing? key) + (begin + (set-thing-state! door 'open) + "The door is now unlocked and open.") + "The door is locked.") + +close + (begin + (set-thing-state! door #f) + "The door is now closed.") + +knock + "No one is home." + +---key--- + +get + (if (have-thing? key) + "You already have the key." + (begin + (take-thing! key) + "You now have the key.")) + +put + (if (have-thing? key) + (begin + (drop-thing! key) + "You have dropped the key.") + "You don't have the key.") + +---trophy--- + +get + (begin + (take-thing! trophy) + "You win!") + + +===PLACES=== + +---meadow--- +"You're standing in a meadow. There is a house to the north." +[] + +north + house-front + +south + desert + + +---house-front--- +"You are standing in front of a house." +[door] + +in + (if (eq? (thing-state door) 'open) + room + "The door is not open.") + +south + meadow + + +---desert--- +"You're in a desert. There is nothing for miles around." +[cactus, key] + +north + meadow + +south + desert + +east + desert + +west + desert + + +---room--- +"You're in the house." +[trophy] + +out + house-front