edit basic

pull/2/head
Matthew Butterick 9 years ago
parent aed79823ea
commit 0ad719ce4a

@ -1,29 +1,30 @@
#lang br/demo/basic
3 PRINT TAB(33);"CHEMIST"
6 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
8 PRINT:PRINT:PRINT
10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE"
20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID."
30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE"
40 PRINT "AND SOON EXPLODES. GIVEN THE AMOUNT OF ACID, YOU MUST"
50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION. IF YOU MISS"
60 PRINT "YOU FACE THE CONSEQUENCES."
100 A=INT(RND(1)*50)
3 print TAB(33);"Chemist"
6 print TAB(15);"Creative Computing | Morristown, New Jersey"
8 print:print:print
10 print "The fictitious chemical kryptocyanic acid can only be"
20 print "diluted by the ratio of 7 parts water to 3 parts acid."
30 print "if any other ratio is attempted, the acid becomes unstable"
40 print "and soon explodes. Given the amount of acid, you must"
50 print "decide who much water to add for dilution. If you miss,"
60 print "you face the consequences."
100 A=INT(RND(50))
110 W=7*A/3
120 PRINT A;"LITERS OF KRYPTOCYANIC ACID. HOW MUCH WATER";
130 INPUT R
115 if A=1 then P="liter" else P="liters"
120 print A; " "; P ; " of kryptocyanic acid. How much water?";
130 input R
140 D=ABS(W-R)
150 IF D>W/20 THEN 200
160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!"
170 PRINT
180 GOTO 100
200 PRINT " SIZZLE! YOU HAVE JUST BEEN DESALINATED INTO A BLOB"
210 PRINT " OF QUIVERING PROTOPLASM!"
150 if D>W/20 then 200
160 print "Good job! You may breathe now, but don't inhale the fumes!"
170 print
180 goto 100
200 print "Sizzle! You have just been desalinated into a blob"
210 print "of quivering protoplasm!"
220 T=T+1
230 IF T=9 THEN 260
240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE."
250 GOTO 100
260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR"
270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY."
280 END
230 if T=3 then 260
240 print "However, you may try again with another life."
250 goto 100
260 print "Your 3 lives are used, but you will be long remembered for"
270 print "your contributions to the field of comic-book chemistry."
280 end

@ -3,18 +3,18 @@
(rename-out [basic-module-begin #%module-begin])
(rename-out [basic-top #%top])
(all-defined-out))
(require br/stxparam (for-syntax br/datum))
(require br/stxparam)
; BASIC implementation details
; http://www.atariarchives.org/basicgames/showpage.php?page=i12
(define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
(define-macro (basic-module-begin SRC-EXPR ...)
(define-macro (basic-module-begin . PROGRAM-LINES)
#'(#%module-begin
(inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
(println (quote SRC-EXPR ...))
SRC-EXPR ...)))
(println (quote . PROGRAM-LINES))
. PROGRAM-LINES)))
; #%app and #%datum have to be present to make #%top work
(define-macro (basic-top . ID)
@ -22,71 +22,71 @@
(displayln (format "got unbound identifier: ~a" 'ID))
(procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
(define-macro (program LINE ...) #'(run (list LINE ...)))
(define-macro (basic-program LINE ...) #'(run (list LINE ...)))
(struct exn:line-not-found exn:fail ())
(struct exn:program-end exn:fail ())
(define (raise-line-not-found-error ln)
(raise
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks))))
(struct exn:program-end exn:fail ())
(define (raise-program-end-error)
(raise (exn:program-end "" (current-continuation-marks))))
(define (run lines)
(define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
(define (line-number->index ln)
(define (run line-list)
(define lines (list->vector line-list))
(define (find-index ln)
(or
(for/or ([idx (in-range (vector-length program-lines))])
(and (= (car (vector-ref program-lines idx)) ln)
(for/or ([idx (in-range (vector-length lines))])
(and (= ($line-number (vector-ref lines idx)) ln)
idx))
(raise
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks)))))
(with-handlers ([exn:program-end? (λ(exn) (void))])
(void
(raise-line-not-found-error ln)))
(void
(with-handlers ([exn:program-end? void])
(for/fold ([program-counter 0])
([i (in-naturals)])
(cond
[(= program-counter (vector-length program-lines)) (basic:END)]
[else
(define line-function (cdr (vector-ref program-lines program-counter)))
(define maybe-next-line (and line-function (line-function)))
(cond
[(number? maybe-next-line) (line-number->index maybe-next-line)]
[else (add1 program-counter)])])))))
(define-macro (cr-line ARG ...) #'(begin ARG ...))
(define current-return-stack (make-parameter empty))
(if (= program-counter (vector-length lines))
(basic:end)
(let* ([line-thunk ($line-thunk (vector-ref lines program-counter))]
[maybe-line-number (line-thunk)])
(if (number? maybe-line-number)
(find-index maybe-line-number)
(add1 program-counter))))))))
(define return-stack empty)
(define (do-gosub number where)
(if (or (empty? return-stack)
(not (= number (car return-stack))))
(begin
(set! return-stack (cons number return-stack))
(basic:goto where))
(set! return-stack (cdr return-stack))))
(struct $line (number thunk) #:transparent)
(define-macro line
[(_ NUMBER (statement-list (statement "GOSUB" WHERE)))
#'(cons NUMBER
(λ _
(let ([return-stack (current-return-stack)])
(cond
[(or (empty? return-stack)
(not (= NUMBER (car return-stack))))
(current-return-stack (cons NUMBER (current-return-stack)))
(basic:GOTO WHERE)]
[else (current-return-stack (cdr (current-return-stack)))]))))]
[(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))])
[(_ NUMBER (statement "gosub" WHERE))
#'($line NUMBER (λ () (do-gosub NUMBER WHERE)))]
[(_ NUMBER . STATEMENTS)
#'($line NUMBER (λ () . STATEMENTS))])
(define-macro statement
[(statement ID "=" EXPR) #'(set! ID EXPR)]
[(statement PROC-STRING ARG ...)
[(statement PROC-NAME . ARGS)
(with-pattern
([PROC-ID (prefix-id "basic:" #'PROC-STRING)])
#'(PROC-ID ARG ...))])
(define-macro basic:IF
[(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
#'(if (true? COND)
TRUE-RESULT
FALSE-RESULT)]
[(_ COND "THEN" TRUE-RESULT)
([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
#'(PROC-ID . ARGS))])
(define-macro basic:if
[(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
#'(if (true? COND-EXPR)
TRUE-EXPR
FALSE-EXPR)]
[(_ COND TRUE-EXPR)
#'(when (true? COND)
TRUE-RESULT)])
TRUE-EXPR)])
(define true? (compose1 not zero?))
(define (cond->int cond) (if cond 1 0))
@ -94,35 +94,38 @@
(define (basic:or . args) (cond->int (ormap true? args)))
(define-macro expr
[(_ COMP-EXPR) #'COMP-EXPR]
[(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR) #'COMP-EXPR])
[(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
(define-macro comp-expr
[(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded
[(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))])
#'(cond->int (OP LEXPR REXPR)))]
[(_ ARG) #'ARG])
[(_ SUM) #'SUM]
[(_ SUM "=" COMP-EXPR)
#'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
[(_ SUM OP-STR COMP-EXPR)
(with-pattern
([OP (replace-context #'here (prefix-id #'OP-STR))])
#'(cond->int (OP SUM COMP-EXPR)))])
(define <> (compose1 not equal?))
(define-macro sum
[(_ TERM "+" SUM) #'(+ TERM SUM)]
[(_ TERM "-" SUM) #'(- TERM SUM)]
[(_ TERM) #'TERM])
[(_ SUM) #'SUM]
[(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
[(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
(define-macro product
[(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)]
[(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)]
[(_ VALUE) #'VALUE])
[(_ VALUE) #'VALUE]
[(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
[(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
(define print-list list)
(define (basic:PRINT args)
(define (basic:print [args #f])
(match args
[(list) (displayln "")]
[#f (displayln "")]
[(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
(basic:PRINT pl))]
(basic:print pl))]
[(list print-list-item ... ";") (for-each display print-list-item)]
[(list print-list-item ...) (for-each displayln print-list-item)]))
@ -132,21 +135,17 @@
(define (ABS num) (inexact->exact (abs num)))
(define (RND num) (* (random) num))
(define-macro basic:INPUT
[(_ PRINT-LIST ";" _ID)
(define-macro basic:input
[(_ PRINT-LIST _ID)
#'(begin
(basic:PRINT (append PRINT-LIST (list ";")))
(basic:INPUT _ID))]
(basic:print (append PRINT-LIST (list ";")))
(basic:input _ID))]
[(_ ID) #'(set! ID (let* ([str (read-line)]
[num (string->number str)])
(or num str)))])
(define (basic:GOTO where) where)
(define (basic:goto where) where)
(define (basic:RETURN) (car (current-return-stack)))
(define (basic:return) (car return-stack))
(define (basic:END)
(raise
(exn:program-end
""
(current-continuation-marks))))
(define (basic:end) (raise-program-end-error))

@ -1,29 +1,30 @@
#lang brag
program : line*
basic-program : line*
line: NUMBER statement [":" statement]*
line: NUMBER statement [/":" statement]*
statement : "END"
| "GOSUB" NUMBER
| "GOTO" expr
| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]
| "INPUT" [print-list ";"] ID
| ID "=" expr ; change: make "LET" opt
| "PRINT" print-list
| "RETURN"
statement : "end"
| "gosub" expr
| "goto" expr
| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
| "input" [print-list /";"] ID
| ID "=" expr
| "print" [print-list]
| "return"
print-list : [expr [";" [print-list]]]
print-list : expr [";" [print-list]]
expr : comp-expr [("AND" | "OR") expr]
comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
sum : product [("+" | "-") sum]
sum : [sum ("+" | "-")] product
product : value [("*" | "/") product]
product : [product ("*" | "/")] value
@value : ID | id-expr
@value : ID
| id-expr
| /"(" expr /")"
| STRING
| NUMBER

@ -13,16 +13,17 @@
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer
(lexer-src-pos
[(eof) eof]
[(union #\tab #\space #\newline
(seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
[(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
"INPUT" "LET" "NEXT" "RETURN"
"CLEAR" "LIST" "RUN" "END"
"THEN" "ELSE" "GOSUB" "AND" "OR"
[(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if"
"GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
"RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
"END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
"AND" "and" "OR" "or"
";" "=" "(" ")" "+" "-" "*" "/"
"<=" ">=" "<>" "<" ">" "=" ":") lexeme]
"<=" ">=" "<>" "<" ">" "=" ":") (string-downcase lexeme)]
[(union ",") (get-token input-port)]
[number (token 'NUMBER (string->number lexeme))]
[(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]

@ -3,7 +3,7 @@
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer
(lexer-src-pos
[(char-set "><-.,+[]") lexeme]
[(char-complement (char-set "><-.,+[]"))
(token 'OTHER #:skip? #t)]

@ -7,7 +7,7 @@
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer
(lexer-src-pos
[(eof) eof]
[(union
(seq "/*" (complement (seq any-string "*/" any-string)) "*/")

@ -7,7 +7,7 @@
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer
(lexer-src-pos
[(eof) eof]
[(union
(seq "/*" (complement (seq any-string "*/" any-string)) "*/")

Loading…
Cancel
Save