Added files for the tm package

README.md

 # csci71-lib
 
-Racket library for CSCI 71
\ No newline at end of file
+This is a Racket library for CSCI 71, which aims to implement simulators for different computing models (specifically: finite automata, regular expressions, context-free grammars, and Turing machines).
+
+## Installation
+
+```
+raco pkg install "https://gitlab.discs.ateneo.edu/brian/csci71-lib.git?path=tm"
+```
+
+## Update (untested)
+
+```
+raco pkg update --update-deps csci71-tm
+```
+
+## Documentation
+
+Partial documentation for `tm` package here: http://penoy.admu.edu.ph/~guadalupe154884/classes/csci71/doc/tm/

info.rkt

+#lang info
+
+(collection 'multi)

tm/LICENSE-MIT

+tm 
+
+MIT License
+
+Copyright (c) 2023 brian
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

tm/colorer.rkt

+#lang br
+
+(require "lexer.rkt"
+         brag/support)
+
+(provide tm-colorer)
+
+(define (tm-colorer port)
+  (define (handle-lexer-error exn)
+    (define exn-srclocs (exn:fail:read-srclocs exn))
+    (srcloc-token (token 'ERROR) (car exn-srclocs)))
+  (define srcloc-tok
+    (with-handlers ([exn:fail:read? handle-lexer-error])
+      (tm-lexer port)))
+  (match srcloc-tok
+    [(? eof-object?) (values srcloc-tok 'eof #f #f #f)]
+    [else
+     (match-define
+       (srcloc-token
+        (token-struct type val _ _ _ _ _)
+        (srcloc _ _ _ posn span)) srcloc-tok)
+     (define start posn)
+     (define end (+ start span))
+     (match-define (list cat paren)
+       (match type
+         ['COMMENT  '(comment #f)]
+         ['ERROR    '(error #f)]
+         ['SYM      '(constant #f)]
+         ['LABEL    '(symbol #f)]
+         [else
+          (match val
+            ["If" '(keyword #f)]
+            ["Not" '(keyword #f)]
+            ["Write" '(keyword #f)]
+            ["Move" '(keyword #f)]
+            ["Goto" '(keyword #f)]
+            ["Return" '(keyword #f)]
+            ["True"  '(constant #f)]
+            ["False" '(constant #f)]
+            ["Left"  '(constant #f)]
+            ["Right" '(constant #f)]
+            ["Blank" '(constant #f)]
+            [else '(no-color #f)])]))
+     (values val cat paren start end)]))
\ No newline at end of file

tm/expander.rkt

+#lang br/quicklang
+
+(require (except-in tm/tmachine run)
+         (only-in tm/gui simulate)
+         racket/set)
+
+(provide (rename-out [tm-module-begin #%module-begin])
+         (all-from-out tm/tmachine)
+         tm-sym tm-if-so tm-if-not
+         tm-mov tm-ret tm-stmt)
+
+(define-macro-cases tm-sym
+  [(tm-sym "Blank") #'BLANK]
+  [(tm-sym CHAR)    #'CHAR])
+
+(define-macro-cases tm-ret
+  [(tm-ret "True")  #'(tm-return #t)]
+  [(tm-ret "False") #'(tm-return #f)])
+
+(define-macro-cases tm-mov
+  [(tm-mov "Left")  #'(tm-move 'left)]
+  [(tm-mov "Right") #'(tm-move 'right)])
+
+(define-macro (tm-if-so SYM CMD)
+  #'(tm-if SYM CMD #f))
+(define-macro (tm-if-not SYM CMD)
+  #'(tm-if SYM CMD #t))
+
+(struct tm-line (number cmd) #:transparent)
+
+(define-macro (tm-stmt CMD)
+  (with-syntax ([ln (syntax-line caller-stx)])
+    (syntax/loc caller-stx
+      (tm-line ln CMD))))
+
+(define (make-tm-config raw-prgm)
+  (begin
+    (define program-list 
+       (map tm-line-cmd raw-prgm))
+    (define raw-label-table
+      (for/hasheqv ([ln raw-prgm]
+                    #:when (tm-label? (tm-line-cmd ln)))
+        (values (tm-label-name (tm-line-cmd ln))
+                (tm-line-number ln))))
+
+    ; hash tables with raw line numbers from source
+     #|(define raw-line-table
+       (for/hasheqv ([ln raw-prgm])
+         (values (tm-line-number ln)
+                 (tm-line-cmd ln))))|#
+    
+    ; Find all labels and write them down, throwing an error if they
+    ; already exist in the set.
+    (define labels-set (make-hash))
+    (for ([line (in-list raw-prgm)]
+          #:when (tm-label? (tm-line-cmd line)))
+      (let ([name (tm-label-name (tm-line-cmd line))])
+        (if (hash-has-key? labels-set name)
+          (error (format "Label name ~v already defined in line ~a" name (hash-ref labels-set name)))
+          (hash-set! labels-set name (tm-line-number line)))))
+
+    ; Build the label table
+    (define label-table
+       (for/hash ([ln (range (length program-list))]
+                     #:when (tm-label? (list-ref program-list ln)))
+         (values (tm-label-name (list-ref program-list ln))
+                 ln)))
+    (define start-line-no
+      (hash-ref label-table "Start"
+                (λ ()
+                  (error "This program is missing a \"Start\" label"))))
+    (define raw-end-line-no
+      (tm-line-number (last raw-prgm)))
+    (define end-line-no
+      (length program-list))
+
+    ; Find all used labels and make sure they exist
+    (for ([line (in-list raw-prgm)]
+          #:when (or (tm-goto? (tm-line-cmd line))
+                     (and (tm-if? (tm-line-cmd line))
+                      (tm-goto? (tm-if-cmd (tm-line-cmd line))))))
+      (let* ([cmd (tm-line-cmd line)]
+             [dest (cond
+                     [(tm-goto? cmd)
+                      (tm-goto-dest cmd)]
+                     [(tm-if? cmd)
+                      (tm-goto-dest (tm-if-cmd cmd))])])
+        (when (not (hash-has-key? labels-set dest))
+          (error (format "Goto statement (in line ~a) references undefined label ~v"
+                         (tm-line-number line) dest)))))
+
+    ; Return the interpreter object
+    (tm-config
+        ; initial tape config
+        (initial-tape-for "")
+        ; initial state
+        'running
+        ; program listing
+        (list->vector program-list)
+        ; starting line number
+        start-line-no
+        ; last line number
+        end-line-no
+        ; initial step count
+        0
+        ; label table
+        label-table)))  
+
+(define-macro (tm-module-begin (tm-program STMTS ...))
+  #'(#%module-begin
+     (provide this-tm)
+     (define raw-prgm (list STMTS ...))
+     (define this-tm
+       (make-tm-config raw-prgm))
+     (display "Input string: ")
+     (define input (read-line))
+     (set-input! this-tm input)
+     (simulate this-tm)))
+

tm/gui.rkt

+#lang racket
+
+(require 2htdp/image
+         2htdp/universe
+         (except-in tm/tmachine run)
+         (only-in pict show-pict))
+
+(provide run-simulation
+         simulate)
+
+(define (tape-cell i sym [head? #f])
+  (above/align
+   "middle"
+   (text/font (number->string i)
+               12 "gray"
+               #f "modern" "normal" "normal" #f)
+   (overlay
+    (text/font (if (eq? sym BLANK) "" (string sym))
+               30 "black"
+               #f "modern" "normal" "normal" #f)
+    (square 40 "outline" "black")
+    (square 40 "solid" (make-color 239 239 239)))
+   (if head? tape-head no-tape-head)))
+
+(define tape-head
+  (triangle 20 "solid" (make-color 122 166 218)))
+(define no-tape-head
+  (triangle 20 "solid" "transparent"))
+
+(define (render-tape tm)
+  (let ([tape (tm-config-tape tm)])
+    (apply beside
+           (for/list ([i (in-range (sub1 TAPE-WIDTH))])
+             (let ([tape-idx (+ (tape-leftmost-pos tape) i)])
+               (tape-cell tape-idx (tape-at tm tape-idx)
+                          (= tape-idx (tape-pos tape))))))))
+
+; render single line from program listing
+(define (program-line linestr [in-focus? #f])
+  (overlay/align "left" "middle"
+   (text/font linestr
+              18 "black"
+              #f ;"JuliaMono"
+              "modern" "normal" "normal" #f)
+   (rectangle (* TAPE-WIDTH 40) 30 "solid"
+              (if in-focus?
+                  (make-color 240 198 116)
+                  "white"))))
+
+; display 10 lines at a time
+(define PRGM-HEIGHT 10)
+(define PRGM-MARGIN 2)
+(define topmost-line 0)
+
+(define (render-program-list tm from to)
+  (apply above/align
+       (append (list "left")
+       (for/list ([i (in-range from to)])
+         (program-line
+          (if (or (< i 0) (>= i (tm-config-last-line-no tm)))
+              ""
+              ;(string-append (~r i #:min-width 4) " "
+              (stmt->string
+               (vector-ref (tm-config-program tm) i)));)
+          (= i (tm-config-line-no tm)))))))
+
+(define (render-status tm)
+  (overlay/align "left" "middle"
+   (text/font
+    (match (tm-config-state tm)
+      ['accept  (format "Accepted after ~a steps" (tm-config-steps tm))]
+      ['reject  (format "Rejected after ~a steps" (tm-config-steps tm))]
+      ['running  (format "Running: ~a steps" (tm-config-steps tm))])
+              16 "black"
+              #f "swiss" "normal" "normal" #f)
+   (rectangle (* TAPE-WIDTH 40)
+              25 "solid" "white")))
+
+(define (render-frame tm)
+  ; print out current line from program
+  (let ([tape (tm-config-tape tm)])
+    (when (>= (tm-config-line-no tm)
+              (- (+ topmost-line PRGM-HEIGHT) PRGM-MARGIN))
+      (set! topmost-line (+ (- (tm-config-line-no tm) PRGM-HEIGHT) (+ PRGM-MARGIN 1))))
+      
+    (when (< (tm-config-line-no tm)
+             (+ topmost-line PRGM-MARGIN))
+      (set! topmost-line (- (tm-config-line-no tm) PRGM-MARGIN)))
+      
+    (when (< topmost-line 0)
+      (set! topmost-line 0))
+      
+    ; if bottom-line = topmost-line + HEIGHT == last-line-np
+    (when (and (> (tm-config-line-no tm) PRGM-HEIGHT)
+               (>= (+ topmost-line PRGM-HEIGHT) (tm-config-last-line-no tm)))
+      (set! topmost-line (- (tm-config-last-line-no tm) PRGM-HEIGHT)))
+
+    (define curr-listing
+      (render-program-list tm
+                           topmost-line
+                           (+ topmost-line PRGM-HEIGHT)))
+    
+    (when (>= (tape-pos tape)
+              (- (+ (tape-leftmost-pos tape) TAPE-WIDTH) TAPE-MARGIN))
+      (set-tape-leftmost-pos! tape (add1 (tape-leftmost-pos tape))))
+    (when (< (tape-pos tape)
+             (+ (tape-leftmost-pos tape) TAPE-MARGIN))
+      (set-tape-leftmost-pos! tape (sub1 (tape-leftmost-pos tape))))
+
+    (above curr-listing
+           (render-tape tm)
+           (render-status tm))))
+
+(define tape-anim-frames (list))
+(define (run! tm)
+  ; generate first frame
+  (set! tape-anim-frames
+        (append tape-anim-frames
+                (list (render-frame tm))))
+
+  (define (run!/loop tm)
+    (begin
+      (step! tm)
+      (when (and (eq? (tm-config-state tm) 'running)
+                 (> (tm-config-steps tm) MAX-STEPS))
+        (error (format "TM still running after ~a steps; double-check for possible infinite loop"
+                       MAX-STEPS)))
+      ; generate next frame
+      (set! tape-anim-frames
+            (append tape-anim-frames
+                    (list (render-frame tm))))
+      (when (eq? (tm-config-state tm) 'running)
+        (run!/loop tm))))
+  (run!/loop tm))
+
+(define ANIMATION-DELAY ; in seconds
+  (list 750 ;0.75
+        500 ;0.5
+        250 ;0.25
+        125 ;0.125
+        50  ;0.05
+        25  ;0.025
+        10  ;0.01
+        5   ;0.005
+        ))
+
+(struct tm-gui ([steps #:mutable]
+                [running? #:mutable]
+                [rate #:mutable]
+                [ticks #:mutable]))
+
+(define (simulate tm)
+  (begin
+    (set! tape-anim-frames (list))
+    (set! topmost-line 0)
+    (define (update-step steps ticks rate)
+      ;(printf "st:~a tk:~a dl:~a\n" steps ticks (list-ref ANIMATION-DELAY rate))
+      (if (= (remainder ticks (list-ref ANIMATION-DELAY rate)) 0)
+          (add1 steps)
+          steps))
+    (run! tm)
+    (thread
+     (λ ()
+       (big-bang
+         (tm-gui 0 #f 0 0)
+         (name "TM Debugger")
+         (on-tick
+          (λ (state)
+            (if (tm-gui-running? state)
+                        (if (< (tm-gui-steps state) (tm-config-steps tm))
+                            (tm-gui (update-step (tm-gui-steps state)
+                                                 (tm-gui-ticks state)
+                                                 (tm-gui-rate state))
+                                    #t
+                                    (tm-gui-rate state)
+                                    (add1 (tm-gui-ticks state)))
+                            (tm-gui (tm-gui-steps state)
+                                    #f
+                                    (tm-gui-rate state)
+                                    (add1 (tm-gui-ticks state)))
+                            )
+                        (tm-gui (tm-gui-steps state)
+                                #f
+                                (tm-gui-rate state)
+                                (add1 (tm-gui-ticks state)))))
+          0.001)
+         (to-draw (λ (state)
+                    (list-ref tape-anim-frames (tm-gui-steps state))))
+
+         ; key handler
+         (on-key
+          (λ (state a-key)
+            (cond
+              ; play/pause simulation
+              [(key=? a-key " ")
+               (tm-gui (tm-gui-steps state)
+                       (not (tm-gui-running? state))
+                       (tm-gui-rate state)
+                       (tm-gui-ticks state))]
+              ; step forward
+              [(key=? a-key "right")
+               (tm-gui (min (tm-config-steps tm) (add1 (tm-gui-steps state)))
+                       #f
+                       (tm-gui-rate state)
+                       (tm-gui-ticks state))]
+              ; step backward
+              [(key=? a-key "left")
+               (tm-gui (max 0 (sub1 (tm-gui-steps state)))
+                       #f
+                       (tm-gui-rate state)
+                       (tm-gui-ticks state))]
+              ; rewind
+              [(key=? a-key "r")
+               (tm-gui 0
+                       #f
+                       (tm-gui-rate state)
+                       (tm-gui-ticks state))]
+              ; fast forward
+              [(key=? a-key "f")
+               (tm-gui (tm-config-steps tm)
+                       #f
+                       (tm-gui-rate state)
+                       (tm-gui-ticks state))]
+              ; faster
+              [(key=? a-key "up")
+               (tm-gui (tm-gui-steps state)
+                       (tm-gui-running? state)
+                       (min (sub1 (length ANIMATION-DELAY))
+                            (add1 (tm-gui-rate state)))
+                       (tm-gui-ticks state))]
+              ; slower
+              [(key=? a-key "down")
+               (tm-gui (tm-gui-steps state)
+                       (tm-gui-running? state)
+                       (max 0
+                            (sub1 (tm-gui-rate state)))
+                       (tm-gui-ticks state))]
+              [else state]
+                  )))
+         )))))

tm/info.rkt

+#lang info
+(define collection "tm")
+(define deps '("beautiful-racket-lib"
+               "brag-lib"
+               "htdp-lib"
+               "pict-lib"
+               "base"))
+(define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
+(define scribblings '(("scribblings/tm.scrbl" ())))
+(define pkg-desc "Turing machine simulator/debugger for CSCI 71")
+(define version "0.1")
+(define pkg-authors '(brian))
+(define license '(MIT))

tm/lexer.rkt

+#lang racket
+
+(require brag/support)
+
+(provide tm-lexer
+         make-tokenizer)
+
+(define-lex-abbrevs
+  (lower-letter (:/ #\a #\z))
+  (upper-letter (:/ #\A #\Z))
+  (letter (:or lower-letter upper-letter))
+  (digit (:/ #\0 #\9))
+  (underscore #\_)
+  (colon #\:)
+  (squote #\')
+  (dquote #\")
+  (keywords (:or "Write" "Move" "If" "Not" "Goto"
+                 "Return" "True" "False" "Left" "Right" "Blank"))
+  )
+
+(define tm-lexer
+  (lexer-srcloc
+   [#\newline (token 'NEWLINE)]
+   [whitespace
+    (token lexeme #:skip? #t)]
+   [colon
+    (token 'COLON lexeme)]
+   [keywords
+    (token lexeme lexeme)]
+   [(from/to squote squote)
+    (token 'SYM (string-ref
+                 (trim-ends "'" lexeme "'") 0))]
+   [(:: (:or letter underscore)
+        (:* (:or letter underscore digit)))
+    (token 'LABEL lexeme)]
+   ; comments
+   [(from/stop-before ";;" "\n")
+    (token 'COMMENT lexeme #:skip? #t)]
+   ))
+
+(define (make-tokenizer input-port [path #f])
+  (lexer-file-path path)
+  (define (next-token) (tm-lexer input-port))
+  next-token)
+
+(define (scan str)
+  (apply-port-proc tm-lexer str))
\ No newline at end of file

tm/main.rkt

+#lang br/quicklang
+
+(require "parser.rkt" "tokenizer.rkt")
+
+(module+ reader
+  (provide read-syntax get-info))
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module tm-mod tm/expander
+       #,parse-tree
+       )))
+
+(define (get-info port src-mod src-line src-col src-pos)
+  (define (handle-query key default)
+    (case key
+      [(color-lexer)
+       (dynamic-require 'tm/colorer 'tm-colorer)]
+      [(drracket:opt-out-toolbar-buttons)
+       '(drracket:syncheck debug-tool macro-stepper)]
+      ; for some reason this don't work hmmmmmm
+      [(drracket:default-extension)
+       "tm"]
+      [else default]))
+  handle-query)

tm/parser.rkt

+#lang brag
+
+tm-program: [tm-stmt] (/NEWLINE [tm-stmt])*
+tm-stmt: tm-label | tm-write | tm-mov
+        | tm-if | tm-goto | tm-ret
+
+tm-label: LABEL /COLON
+tm-write: /"Write" tm-sym
+tm-mov: /"Move" "Left" | /"Move" "Right"
+
+@tm-if: tm-if-so | tm-if-not
+tm-if-so: /"If" tm-sym if-consequent
+tm-if-not: /"If" /"Not" tm-sym if-consequent
+@if-consequent: tm-write | tm-mov | tm-goto | tm-ret
+
+tm-goto: /"Goto" LABEL
+tm-ret: /"Return" "True" | /"Return" "False"
+
+tm-sym: SYM | "Blank"

tm/tmachine.rkt

+#lang racket
+
+(provide (all-defined-out))
+
+; TM instruction set
+(struct tm-label (name) #:transparent)
+(struct tm-write (sym) #:transparent)
+(struct tm-move (direction) #:transparent)
+(struct tm-if (sym cmd negated?) #:transparent)
+(struct tm-goto (dest) #:transparent)
+(struct tm-return (result) #:transparent)
+
+(struct tm-config ([tape  #:mutable]
+                   [state #:mutable]     ; initially 'running
+                   [program #:mutable]
+                   [line-no #:mutable]   ; starting line number
+                   [last-line-no #:mutable] ; last line number
+                   [steps #:mutable]
+                   labels)) 
+
+; blank symbol
+(define BLANK '□)
+
+;; tape structure
+
+(struct tape
+  ([before #:mutable]
+   [after #:mutable]
+   ; current position of tape head
+   [pos #:mutable]
+   ; minimum character position to display on the tape
+   [leftmost-pos #:mutable]
+   ))
+
+; Margin on each side of the tape that the tape head can't leave. If the tape
+; head's displayed position were to move outside of this range, instead we scroll
+; the tape over.
+(define TAPE-MARGIN 3)
+(define TAPE-WIDTH 18)
+
+(define (tape-head tape)
+  (car (tape-after tape)))
+
+(define (replace-tape-head! tape new)
+  (set-tape-after! tape
+   (cons new (cdr (tape-after tape)))))
+
+(define (read-tape tm)
+  (tape-head (tm-config-tape tm)))
+
+(define (write-tape! tm sym)
+  (replace-tape-head! (tm-config-tape tm) sym))
+
+;; TO-DO: fix comestic bug where the new blank cell gets "added"
+(define (move-head-left! tm)
+  (let ([tape (tm-config-tape tm)])
+    (begin
+      ; if nothing before, add a new cell
+      (when (empty? (tape-before tape))
+        (set-tape-before! tape (cons BLANK '()))
+        ;(set-tape-leftmost-pos! tape (add1 (tape-leftmost-pos tape)))
+        )
+      (define new-head (car (tape-before tape)))
+      (set-tape-before! tape (cdr (tape-before tape)))
+      (set-tape-after! tape (cons new-head (tape-after tape)))
+      (set-tape-pos! tape (sub1 (tape-pos tape))))))
+
+(define (move-head-right! tm)
+  (let ([tape (tm-config-tape tm)])
+    (begin
+      (define curr-head (tape-head tape))
+      (when (empty? (cdr (tape-after tape)))
+        (set-tape-after! tape (cons curr-head (cons BLANK '()))))
+      (set-tape-after! tape (cdr (tape-after tape)))
+      (set-tape-before! tape (cons curr-head (tape-before tape)))
+      (set-tape-pos! tape (add1 (tape-pos tape))))))
+
+
+; if index is "out of range", just return a blank
+(define (symbol-or-blank lst idx)
+  (if (<= (length lst) idx)
+      BLANK
+      (list-ref lst idx)))
+(define (tape-at tm index)
+  (let ([tape (tm-config-tape tm)]
+        [head-pos (tape-pos (tm-config-tape tm))])
+    (if (< index head-pos)
+        (symbol-or-blank (tape-before tape) (- head-pos (+ index 1)))
+        (symbol-or-blank (tape-after tape)  (- index head-pos)))))
+
+; TO-DO: truncate tape if it only contains mostly blanks
+(define (tape-list->string tl)
+  (if (empty? tl) ""
+      (string-append*
+       (format "~a" (car tl))
+       (append* (map (λ (s) (list " " (format "~a" s))) (cdr tl))))))
+  
+(define (print-tape tm)
+  (let ([tape (tm-config-tape tm)])
+    (printf "~a[~a]~a\n"
+            (tape-list->string (reverse (tape-before tape)))
+            (tape-head tape)
+            (tape-list->string (cdr (tape-after tape))))))
+
+(define (tape-contents tm)
+  (let ([tape (tm-config-tape tm)])
+    (format "~a~a~a"
+            (tape-list->string (reverse (tape-before tape)))
+            (tape-head tape)
+            (tape-list->string (cdr (tape-after tape))))))
+
+;; program-related stuff
+
+(define (jump-to! tm label-str)
+  (set-tm-config-line-no! (label->line-no label-str)))
+  
+(define (label->line-no tm label)
+  (hash-ref (tm-config-labels tm)
+            label
+            (λ () (error 'execute-statement! "Label ~v is undefined" label))))
+
+(define (execute-statement! tm stmt)
+  (match stmt
+    [(tm-write sym)  (write-tape! tm sym)]
+    [(tm-move dir)   (match dir
+                       ['left  (move-head-left! tm)]
+                       ['right (move-head-right! tm)]
+                       [_      (error "Invalid direction")])]
+    [(tm-goto destination)   (set-tm-config-line-no! tm
+                                                     (label->line-no tm destination))]
+    [(tm-return result)  (set-tm-config-state! tm (if result 'accept 'reject))]
+    [(tm-if sym cmd negated?)     (if (xor (eq? sym (read-tape tm)) negated?)
+                                      (execute-statement! tm cmd)
+                                      #f)]
+    [(tm-label _)   (go-to-next-line! tm)]
+    [_    (error 'execute-statement! "Invalid instruction '~a'" (car stmt))]
+    ))
+
+(define (stmt->string stmt)
+  (match stmt
+    [(tm-label name) (string-append name ":")]
+    [(tm-write sym)  (string-append "  Write " (if (eq? sym BLANK)
+                                                 "Blank"
+                                                 (string #\' sym #\')))]
+    [(tm-move dir)   (string-append "  Move "  (match dir
+                                               ['left  "Left"]
+                                               ['right "Right"]
+                                               [_   "<unknown direction>"]))]
+    [(tm-return result) (string-append "  Return " (if result "True" "False"))]
+    [(tm-goto destination)     (string-append "  Goto " destination)]
+    [(tm-if sym cmd negated?)  (string-append "  If "
+                                              (if negated? "Not " "")
+                                              (if (eq? sym BLANK)
+                                                  "Blank"
+                                                  (string #\' sym #\'))
+                                              (stmt->string cmd))]
+    [_ "<illegal operation>"]))
+
+(define (go-to-next-line! tm)
+  (set-tm-config-line-no! tm (+ (tm-config-line-no tm) 1)))
+
+(define (step! tm)
+  (when (eq? (tm-config-state tm) 'running)
+      (begin
+        (set-tm-config-steps! tm (+ 1 (tm-config-steps tm)))
+        (define line-before (tm-config-line-no tm))
+        (define stmt (vector-ref (tm-config-program tm) (tm-config-line-no tm)))
+        (execute-statement! tm stmt)
+        (when (not (eq? (tm-config-state tm) 'running)) (void))
+        
+        (when (= line-before (tm-config-line-no tm))
+            (go-to-next-line! tm))
+        (when (and (>= (tm-config-line-no tm) (tm-config-last-line-no tm))
+                   (eq? (tm-config-state tm) 'running))
+               (set-tm-config-state! tm 'reject)))))
+
+(define MAX-STEPS 100000) ; 100k steps should be enough
+;(define MAX-STEPS 10000000)
+(define (run tm)
+  (begin
+    (when (and (eq? (tm-config-state tm) 'running)
+             (> (tm-config-steps tm) MAX-STEPS))
+      (error (format "TM still running after ~a steps; double-check for possible infinite loop"
+                     MAX-STEPS)))
+    (printf "~a\n\t" (stmt->string (vector-ref (tm-config-program tm)
+                            (tm-config-line-no tm))))
+    (step! tm)
+    (print-tape tm)
+    ;(printf "tape position: ~a" (tape-pos (tm-config-tape tm)))
+    (if (not (eq? (tm-config-state tm) 'running))
+        (tm-config-state tm)
+        (run tm))
+  ))
+
+(define (initial-tape-for str)
+  (tape '()
+        (append (string->list str) (list BLANK))
+        0
+        (- TAPE-MARGIN)))
+
+(define (set-input! tm input)
+  (set-tm-config-tape! tm (initial-tape-for input)))
+

tm/tokenizer.rkt

+#lang br
+
+(require "lexer.rkt" brag/support)
+
+(define (make-tokenizer ip [path #f])
+  (port-count-lines! ip)
+  (lexer-file-path path)
+  (define (next-token) (tm-lexer ip))
+  next-token)
+
+(provide make-tokenizer)
\ No newline at end of file