diff --git a/beautiful-racket/br/demo/basic/aceyducey.bas b/beautiful-racket/br/demo/basic/aceyducey.bas new file mode 100644 index 0000000..e0ffee9 --- /dev/null +++ b/beautiful-racket/br/demo/basic/aceyducey.bas @@ -0,0 +1,101 @@ +#lang br/demo/basic +10 PRINT TAB(26);"ACEY DUCEY CARD GAME" +20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY" +21 PRINT +22 PRINT +30 PRINT"ACEY-DUCEY IS PLAYED IN THE FOLLOWING MANNER " +40 PRINT"THE DEALER (COMPUTER) DEALS TWO CARDS FACE UP" +50 PRINT"YOU HAVE AN OPTION TO BET OR NOT BET DEPENDING" +60 PRINT"ON WHETHER OR NOT YOU FEEL THE CARD WILL HAVE" +70 PRINT"A VALUE BETWEEN THE FIRST TWO." +80 PRINT"IF YOU DO NOT WANT TO BET, INPUT A 0" +100 N=100 +110 Q=100 +120 PRINT "YOU NOW HAVE";Q;"DOLLARS." +130 PRINT +140 GOTO 260 +210 Q=Q+M +220 GOTO 120 +240 Q=Q-M +250 GOTO 120 +260 PRINT"HERE ARE YOUR NEXT TWO CARDS: " +270 A=INT(14*RND(1))+2 +280 IF A<2 THEN 270 +290 IF A>14 THEN 270 +300 B=INT(14*RND(1))+2 +310 IF B<2 THEN 300 +320 IF B>14 THEN 300 +330 IF A>=B THEN 270 +350 IF A<11 THEN 400 +360 IF A=11 THEN 420 +370 IF A=12 THEN 440 +380 IF A=13 THEN 460 +390 IF A=14 THEN 480 +400 PRINT A +410 GOTO 500 +420 PRINT"JACK" +430 GOTO 500 +440 PRINT"QUEEN" +450 GOTO 500 +460 PRINT"KING" +470 GOTO 500 +480 PRINT"ACE" +500 IF B<11 THEN 550 +510 IF B=11 THEN 570 +520 IF B=12 THEN 590 +530 IF B=13 THEN 610 +540 IF B=14 THEN 630 +550 PRINT B +560 GOTO 650 +570 PRINT"JACK" +580 GOTO 650 +590 PRINT"QUEEN" +600 GOTO 650 +610 PRINT"KING" +620 GOTO 650 +630 PRINT"ACE" +640 PRINT +650 PRINT +660 INPUT"WHAT IS YOUR BET";M +670 IF M<>0 THEN 680 +675 PRINT"CHICKEN!!" +676 PRINT +677 GOTO 260 +680 IF M<=Q THEN 730 +690 PRINT"SORRY, MY FRIEND, BUT YOU BET TOO MUCH." +700 PRINT"YOU HAVE ONLY ";Q;" DOLLARS TO BET." +710 GOTO 650 +730 C=INT(14*RND(1))+2 +740 IF C<2 THEN 730 +750 IF C>14 THEN 730 +760 IF C<11 THEN 810 +770 IF C=11 THEN 830 +780 IF C=12 THEN 850 +790 IF C=13 THEN 870 +800 IF C=14 THEN 890 +810 PRINT C +820 GOTO 910 +830 PRINT"JACK" +840 GOTO 910 +850 PRINT"QUEEN" +860 GOTO 910 +870 PRINT"KING" +880 GOTO 910 +890 PRINT "ACE" +900 PRINT +910 IF C>A THEN 930 +920 GOTO 970 +930 IF C>=B THEN 970 +950 PRINT"YOU WIN!!!" +960 GOTO 210 +970 PRINT"SORRY, YOU LOSE" +980 IF MW/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 \ No newline at end of file diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 43110a4..54c166d 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -10,8 +10,8 @@ (define #'(basic-module-begin PARSE-TREE ...) #'(#%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 PARSE-TREE ...)) - PARSE-TREE ...))) + (println (quote PARSE-TREE ...)) + PARSE-TREE ...))) ; #%app and #%datum have to be present to make #%top work (define #'(basic-top . id) @@ -23,40 +23,66 @@ (define (run lines) (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines))) - (void (for/fold ([line-idx 0]) - ([i (in-naturals)] - #:break (= line-idx (vector-length program-lines))) - (match-define (cons line-number proc) - (vector-ref program-lines line-idx)) - (define maybe-jump-number (and proc (proc))) - (if (number? maybe-jump-number) - (let ([jump-number maybe-jump-number]) - (for/or ([idx (in-range (vector-length program-lines))]) - (and (= (car (vector-ref program-lines idx)) jump-number) - idx))) - (add1 line-idx))))) + (void (with-handlers ([exn:program-end? (λ (exn) (void))]) + (for/fold ([program-counter 0]) + ([i (in-naturals)] + #:break (= program-counter (vector-length program-lines))) + (match-define (cons line-number proc) + (vector-ref program-lines program-counter)) + (define maybe-jump-number (and proc (proc))) + (if (number? maybe-jump-number) + (let ([jump-number maybe-jump-number]) + (for/or ([idx (in-range (vector-length program-lines))]) + (and (= (car (vector-ref program-lines idx)) jump-number) + idx))) + (add1 program-counter)))))) (define #'(cr-line ARG ...) #'(begin ARG ...)) -(define #'(line NUMBER STATEMENT ...) - #'(cons NUMBER (λ _ STATEMENT ...))) +(define current-return-stack (make-parameter empty)) + +(define-cases #'line + [#'(_ NUMBER (STATEMENT "GOSUB" WHERE)) #'(cons NUMBER + (λ _ + (current-return-stack (cons NUMBER (current-return-stack))) + (GOTO WHERE)))] + [#'(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))]) -(define vars (make-hasheq)) (define-cases #'statement [#'(statement ID "=" EXPR) #'(set! ID EXPR)] [#'(statement PROC ARG ...) #'(PROC ARG ...)]) +(define-cases #'IF + [#'(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT) + #'(if (true? COND) + TRUE-RESULT + FALSE-RESULT)] + [#'(_ COND "THEN" TRUE-RESULT) + #'(when (true? COND) + TRUE-RESULT)]) + (define-cases #'value [#'(value "(" EXPR ")") #'EXPR] [#'(value ID "(" ARG ... ")") #'(ID ARG ...)] [#'(value ID-OR-DATUM) #'ID-OR-DATUM]) -(define-cases expr - [(_ lexpr op rexpr) (if (op lexpr rexpr) 1 0)] - [(_ expr) expr]) -(provide < > <= >=) +(define true? (compose1 not zero?)) + +(define-cases #'expr + [#'(_ LEXPR "AND" REXPR) + #'(if (and (true? LEXPR) (true? REXPR)) 1 0)] + [#'(_ LEXPR "OR" REXPR) + #'(if (or (true? LEXPR) (true? REXPR)) 1 0)] + [#'(_ EXPR) #'EXPR]) + +(define-cases #'comp-expr + [#'(_ lexpr "=" rexpr) #'(comp-expr lexpr equal? rexpr)] ; special case because = is overloaded + [#'(_ lexpr op rexpr) #'(if (op lexpr rexpr) 1 0)] + [#'(_ expr) #'expr]) +(define (<> lexpr rexpr) (not (equal? lexpr rexpr))) +(provide < > <= >= <>) (define-cases sum [(_ term op sum) (op term sum)] @@ -73,21 +99,46 @@ (define (PRINT args) (match args [(list) (displayln "")] - [(list print-list-item ... ";" pl) (begin (for-each display print-list-item) (PRINT pl))] - [(list print-list-item ... ";") (for-each display print-list-item)] + [(list print-list-item ... ";" pl) (begin (for-each display print-list-item) + (display " ") + (PRINT pl))] + [(list print-list-item ... ";") (begin + (for-each display print-list-item) + (display " "))] [(list print-list-item ...) (for-each displayln print-list-item)])) (define (TAB num) (make-string num #\space)) -(define (INT num) (inexact->exact (round num))) +(define #'(INT EXPR ...) #'(inexact->exact (round (expr EXPR ...)))) (define (SIN num) (sin num)) +(define (ABS num) (inexact->exact (abs num))) (define (RND num) (* (random) num)) -(define #'(INPUT PRINT-LIST ";" ID) - #'(begin - (PRINT (append PRINT-LIST (list ";"))) - (set! ID (read-line)))) +(define-cases #'INPUT + [#'(_ PRINT-LIST ";" ID) + #'(begin + (PRINT (append PRINT-LIST (list ";"))) + (INPUT ID))] + [#'(_ ID) #'(set! ID (let* ([str (read-line)] + [num (string->number str)]) + (if num num str)))]) (define (GOTO where) where) +(define (GOSUB where) + where) + +(define (RETURN) + (define where (car (current-return-stack))) + (current-return-stack (cdr (current-return-stack))) + where) + + +(struct exn:program-end exn:fail ()) +(define (END) + (raise + (exn:program-end + "program ended" + (current-continuation-marks)))) + (define (comment . args) void) diff --git a/beautiful-racket/br/demo/basic/gosub.bas b/beautiful-racket/br/demo/basic/gosub.bas new file mode 100644 index 0000000..ea6683f --- /dev/null +++ b/beautiful-racket/br/demo/basic/gosub.bas @@ -0,0 +1,5 @@ +#lang br/demo/basic +10 GOSUB 40 +11 END +20 PRINT "YAY" +25 RETURN \ No newline at end of file diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 9ef7a9e..3634c1d 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -6,24 +6,30 @@ program : [line [CR line]*] line: INTEGER statement+ statement : "END" -| "FOR" ID "=" expr "TO" expr ["STEP" expr] +| "FOR" ID "=" expr "TO" expr ["STEP" expr] +| "GOSUB" INTEGER | "GOTO" expr -| "IF" expr "THEN" (statement | expr) ; change: add expr -| "INPUT" print-list ";" ID +| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]; change: add expr +| "INPUT" [print-list ";"] ID | ["LET"] ID "=" expr ; change: make "LET" opt | "NEXT" ID+ | "PRINT" print-list +| "RETURN" | REM-COMMENT print-list : [expr [";" [print-list]]] -expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") expr] +expr : comp-expr [("AND" | "OR") expr] + +comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr] sum : product [("+" | "-") sum] product : value [("*" | "/") product] -value : ID ["(" expr* ")"] +value : "(" expr ")" +| ID +| PROC "(" expr* ")" | INTEGER | STRING | REAL diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt index b8edee3..41de900 100644 --- a/beautiful-racket/br/demo/basic/tokenizer.rkt +++ b/beautiful-racket/br/demo/basic/tokenizer.rkt @@ -12,9 +12,10 @@ [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n"))) (token 'REM-COMMENT (format-datum '(comment "~v") lexeme))] [(repetition 1 +inf.0 "\n") (token 'CR "cr")] - [(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO" - "INPUT" "LET" "NEXT" "GOSUB" "RETURN" + [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO" + "INPUT" "LET" "NEXT" "RETURN" "CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)] + [(union "THEN" "ELSE" "GOSUB") lexeme] ;; this only matches integers [(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))] @@ -27,6 +28,7 @@ [(union ";" "=" "(" ")") lexeme] [(union "+" "-" "*" "/" "<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol lexeme)] + [(union "RND" "INT" "TAB" "SIN" "ABS") (token 'PROC (string->symbol lexeme))] [(:seq (repetition 1 +inf.0 upper-case) (:? "$")) (token 'ID (string->symbol lexeme))] [upper-case (token 'UPPERCASE (string->symbol lexeme))] [whitespace (token 'WHITESPACE lexeme #:skip? #t)]