mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

start new parser for txtadv

Browse Source
dev-elider-3
Matthew Butterick 8 years ago
parent 6de2df5ceb
commit cface5b7f9
11 changed files with 452 additions and 168 deletions
Show Stats Download Patch File Download Diff File

4
beautiful-racket/br/demo/txtadv.rkt
Unescape Escape View File

@ -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")))

37
beautiful-racket/br/demo/txtadv/expander.rkt
Unescape Escape View File

@ -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)

1
beautiful-racket/br/demo/txtadv/footest.rkt
Unescape Escape View File

@ -0,0 +1 @@
#lang racket

5
beautiful-racket/br/demo/txtadv/main.rkt
Unescape Escape View File

@ -1,5 +0,0 @@
#lang br
(module+ reader
(require "reader.rkt")
(provide (all-from-out "reader.rkt")))

15
beautiful-racket/br/demo/txtadv/parser.rkt
Unescape Escape View File

@ -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* ")"

164
beautiful-racket/br/demo/txtadv/reader.rkt
Unescape Escape View File

@ -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))))

160
beautiful-racket/br/demo/txtadv/reader0.rkt
Unescape Escape View File

@ -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])))

23
beautiful-racket/br/demo/txtadv/tokenizer.rkt
Unescape Escape View File

@ -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)

8
beautiful-racket/br/demo/txtadv/world.rkt
Unescape Escape View File

@ -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
*/

41
beautiful-racket/br/demo/txtadv/world0-test.rkt
Unescape Escape View File

@ -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")

162
beautiful-racket/br/demo/txtadv/world0.rkt
Unescape Escape View File

@ -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
Write Preview
Loading…
Cancel
Save