From 94b6f7089981b752a0b32df55090af1894a85d62 Mon Sep 17 00:00:00 2001 From: Adam Ruzicka Date: Wed, 16 Mar 2022 19:14:51 +0100 Subject: [PATCH] Import --- rktfck.rkt | 12 +++++ rktfck/interpreter.rkt | 117 +++++++++++++++++++++++++++++++++++++++++ rktfck/parser.rkt | 67 +++++++++++++++++++++++ rktfck/types.rkt | 35 ++++++++++++ 4 files changed, 231 insertions(+) create mode 100755 rktfck.rkt create mode 100755 rktfck/interpreter.rkt create mode 100755 rktfck/parser.rkt create mode 100755 rktfck/types.rkt diff --git a/rktfck.rkt b/rktfck.rkt new file mode 100755 index 0000000..3327420 --- /dev/null +++ b/rktfck.rkt @@ -0,0 +1,12 @@ +#lang typed/racket + +(require "rktfck/interpreter.rkt") + +;; (interpret ",[-.]") + +(define program + " + ++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++. +") + +(interpret program) diff --git a/rktfck/interpreter.rkt b/rktfck/interpreter.rkt new file mode 100755 index 0000000..c1538c5 --- /dev/null +++ b/rktfck/interpreter.rkt @@ -0,0 +1,117 @@ +#lang typed/racket + +(require "types.rkt" + "parser.rkt") + +(require threading) + +(provide Interpreter + make-interpreter + interpreter-run + interpret) + +(define-type Interpreter interpreter) + +(struct interpreter + ([left : Tape] + [current : Cell] + [right : Tape] + [program : Program]) + #:transparent) + +(: make-interpreter (-> Program Interpreter)) +(define (make-interpreter program) + (interpreter '() 0 '() program)) + +(: cell-inc (-> Cell Cell)) +(define (cell-inc x) + (cast (if (= x 255) + 0 + (+ x 1)) + Cell)) + +(: cell-dec (-> Cell Cell)) +(define (cell-dec x) + (cast (if (zero? x) + 255 + (- x 1)) + Cell)) + +(: cell-input (-> Cell Cell)) +(define (cell-input _) + (let ([b (read-byte)]) + (if (eof-object? b) + 0 + b))) + +(: interpreter-step (-> Interpreter Interpreter)) +(define (interpreter-step i) + (define instruction (car (interpreter-program i))) + (define next-state (struct-copy interpreter i + [program (cdr (interpreter-program i))])) + + (match instruction + ['increment (modify-current next-state cell-inc)] + ['decrement (modify-current next-state cell-dec)] + ['input (modify-current next-state cell-input)] + ['output (output next-state)] + ['pointer-increment (pointer-increment next-state)] + ['pointer-decrement (pointer-decrement next-state)] + [(list _ ...) (interpreter-loop next-state instruction)])) + +(: interpreter-loop (-> Interpreter Loop Interpreter)) +(define (interpreter-loop i ins) + (if (zero? (interpreter-current i)) + i + (struct-copy interpreter i + [program (append ins (list ins) (interpreter-program i))]))) + +(: pointer-increment (-> Interpreter Interpreter)) +(define (pointer-increment i) + (match i + [(interpreter left current right program) + (interpreter (cons current left) + (if (null? right) 0 (car right)) + (if (null? right) '() (cdr right)) + program)])) + +(: pointer-decrement (-> Interpreter Interpreter)) +(define (pointer-decrement i) + (~> i + interpreter-flip + pointer-increment + interpreter-flip)) + +(: interpreter-flip (-> Interpreter Interpreter)) +(define (interpreter-flip i) + (match i + [(interpreter left current right program) + (interpreter right current left program)])) + +(: output (-> Interpreter Interpreter)) +(define (output i) + (begin + (display (integer->char (interpreter-current i))) + i)) + +(: modify-current (-> Interpreter (-> Cell Cell) Interpreter)) +(define (modify-current i f) + (struct-copy interpreter i + [current (f (interpreter-current i))])) + +(: interpreter-done? (-> Interpreter Boolean)) +(define (interpreter-done? i) + (null? (interpreter-program i))) + +(: interpreter-run (-> Interpreter Interpreter)) +(define (interpreter-run i) + (if (interpreter-done? i) + i + (interpreter-run (interpreter-step i)))) + +(: interpret (-> String Interpreter)) +(define (interpret source) + (~> source + string->program + make-interpreter + interpreter-run)) diff --git a/rktfck/parser.rkt b/rktfck/parser.rkt new file mode 100755 index 0000000..d4c622b --- /dev/null +++ b/rktfck/parser.rkt @@ -0,0 +1,67 @@ +#lang typed/racket + +(provide string->program) + +(require "types.rkt") +(require threading) + +(: string->program (-> String Program)) +(define (string->program src) + (~> src + string->list + tokenize + parse)) + +(: tokenize (-> (Listof Char) (Listof Token))) +(define (tokenize chars) + + (: parse-char (-> Char (U Token Null))) + (define (parse-char c) + (case c + [(#\>) 'pointer-increment] + [(#\<) 'pointer-decrement] + [(#\+) 'increment] + [(#\-) 'decrement] + [(#\.) 'output] + [(#\,) 'input] + [(#\[) 'loop-start] + [(#\]) 'loop-end] + [else '()])) + (cast (filter (lambda (x) (not (null? x))) + (map parse-char chars)) (Listof Token))) + +(: parse (-> (Listof Token) Program)) +(define (parse tokens) + (: safe-parse (-> (Listof Token) Program (Listof Loop) Program)) + (define (safe-parse tokens acc loop-stack) + (if (null? tokens) + (reverse acc) + (inner-parse tokens acc loop-stack))) + + (: inner-parse (-> (Listof Token) Program (Listof Loop) Program)) + (define (inner-parse tokens acc loop-stack) + (define next (car tokens)) + + (: continue (-> Program (Listof Loop) Program)) + (define (continue acc loop-stack) + (safe-parse (cdr tokens) acc loop-stack)) + + (define (new-loop) + (continue acc (cons '() loop-stack))) + + (define (end-loop) + (continue (cons (reverse (car loop-stack)) acc) + (cdr loop-stack))) + + (define (add-next) + (if (null? loop-stack) + (continue (cons (cast next Instruction) acc) loop-stack) + (continue acc (cons (cons (cast next Instruction) (car loop-stack)) + (cdr loop-stack))))) + + (case next + ['loop-start (new-loop)] + ['loop-end (end-loop)] + [else (add-next)])) + + (safe-parse tokens '() '())) diff --git a/rktfck/types.rkt b/rktfck/types.rkt new file mode 100755 index 0000000..d70cf6c --- /dev/null +++ b/rktfck/types.rkt @@ -0,0 +1,35 @@ +#lang typed/racket + +(provide Cell + Tape + Instruction + Token + Program + Loop) + +(define-type Cell (U Zero Positive-Byte)) + +(define-type Tape (Listof Cell)) + +(define-type Instruction + (U 'pointer-increment + 'pointer-decrement + 'increment + 'decrement + 'output + 'input + Loop)) + +(define-type Token + (U 'pointer-increment + 'pointer-decrement + 'increment + 'decrement + 'output + 'input + 'loop-start + 'loop-end)) + +(define-type Program (Listof Instruction)) + +(define-type Loop Program)