Import

rktfck.rkt

@@ -0,0 +1,12 @@
+#lang typed/racket
+
+(require "rktfck/interpreter.rkt")
+
+;; (interpret ",[-.]")
+
+(define program
+  "
+  ++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++.
+")
+
+(interpret program)

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

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 '() '()))

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)