edit basic
This commit is contained in:
Matthew Butterick
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 ())
|
||||
(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)])])))))
|
||||
(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-macro (cr-line ARG ...) #'(begin ARG ...))
|
||||
(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))))
|
||||
|
||||
(define current-return-stack (make-parameter empty))
|
||||
|
||||
(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 ...))])
|
||||
([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
|
||||
#'(PROC-ID . ARGS))])
|
||||
|
||||
(define-macro basic:IF
|
||||
[(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
|
||||
#'(if (true? COND)
|
||||
TRUE-RESULT
|
||||
FALSE-RESULT)]
|
||||
[(_ COND "THEN" TRUE-RESULT)
|
||||
(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…
Reference in New Issue
Block a user