From f90c0af1b0c1c9fdbb864ee5767b41c8e3dfccfa Mon Sep 17 00:00:00 2001
From: Izaak Walton <iwalton@hrl.com>
Date: Wed, 21 Aug 2024 22:15:00 -0700
Subject: [PATCH] Adding faster brainfold implementations

---
 .../src/fast-brainfold.lisp                   | 285 ++++++++++++++++++
 .../src/faster-brainfold.lisp                 | 161 ++++++++++
 2 files changed, 446 insertions(+)
 create mode 100644 examples/small-coalton-programs/src/fast-brainfold.lisp
 create mode 100644 examples/small-coalton-programs/src/faster-brainfold.lisp

diff --git a/examples/small-coalton-programs/src/fast-brainfold.lisp b/examples/small-coalton-programs/src/fast-brainfold.lisp
new file mode 100644
index 000000000..f9f83a41e
--- /dev/null
+++ b/examples/small-coalton-programs/src/fast-brainfold.lisp
@@ -0,0 +1,285 @@
+;;;;
+;;;; A Brainfold/Brainf*** interpreter implemented in Coalton
+;;;;
+;;;; This interpreter handles all standard bf commands:
+;;;; ( > < + - . , [ ] ).
+;;;;
+;;;;
+;;;; Run Brainfold programs with (run-program "+++++[-]+++")
+;;;;
+;;;; or
+;;;;
+;;;; (run-file "/path/to/your/file.bf")
+;;;;
+;;;; try (coalton (hello-world)) in the REPL!
+;;;;
+
+(cl:defpackage #:brainfold
+  (:use
+   #:coalton
+   #:coalton-prelude)
+  (:local-nicknames
+   (#:vec #:coalton-library/vector)
+   (#:iter #:coalton-library/iterator)
+   (#:cell #:coalton-library/cell)
+   (#:char #:coalton-library/char)
+   (#:str #:coalton-library/string)
+   (#:list #:coalton-library/list)
+   (#:arith #:coalton-library/math)
+   (#:state #:coalton-library/monad/state)
+   (#:file #:coalton-library/file))
+  (:export
+   #:eval
+   #:run-program
+   #:run-file
+
+   ;; Examples
+   #:hello-world
+   #:gnarly-hello-world
+   #:squares))
+
+(in-package #:brainfold)
+
+(named-readtables:in-readtable coalton:coalton)
+
+(cl:declaim (cl:optimize (cl:speed 3)))
+;;;
+;;; State/Env
+;;;
+
+(coalton-toplevel
+
+  (define-struct BF-State
+    (memory       "The brainfold memory array."        (Vector Integer))
+    (pointer      "A pointer to the current register." (Cell UFix)))
+
+  ;;
+  ;; Generating a Brainfold memory vector
+  ;;
+
+  (declare bf-vector-size UFix)
+  (define bf-vector-size 1000)
+
+  ;;
+  ;; Generating a default BF-State:
+  ;;
+
+  (define-instance (Default BF-State)
+    (define (default)
+      (BF-State (vec:with-initial-element bf-vector-size 0)
+                (cell:new 0))))
+
+  ;;
+  ;; Accessing the current value
+  ;;
+
+  (declare value-at-pointer (BF-State -> Integer))
+  (define (value-at-pointer bfs)
+    "Returns the value at the current pointer."
+    (vec:index-unsafe (cell:read (.pointer bfs))
+		      (.memory bfs))))
+
+;;;
+;;; Commands (Functions called by Brainfold Cmds)
+;;;
+
+(coalton-toplevel
+
+  ;;
+  ;; Navigating through bf-cells (> <)
+  ;;
+
+  (declare move-right (BF-State -> Unit))
+  (define (move-right state)
+    "Moves the pointer one bf-cell to the right."
+    (cell:increment! (.pointer state))
+    Unit)
+
+  (declare move-left (BF-State -> Unit))
+  (define (move-left state)
+    "Moves the pointer one bf-cell to the left."
+    (cell:decrement! (.pointer state))
+    Unit)
+
+  ;;
+  ;; Changing bf-cell values (+ -)
+  ;;
+
+  (declare incr (BF-State -> Unit))
+  (define (incr state)
+    "Increments the value for the current bf-cell."
+    (vec:set! (cell:read (.pointer state))
+                     (1+ (value-at-pointer state))
+                     (.memory state))
+    Unit)
+
+  (declare decr (BF-State -> Unit))
+  (define (decr state)
+    "Decrements the value for the current bf-cell."
+    (vec:set! (cell:read (.pointer state))
+                     (1- (value-at-pointer state))
+                     (.memory state))
+    Unit)
+
+  ;;
+  ;; Printing Cells (.)
+  ;;
+
+  (declare display (BF-State -> Unit))
+  (define (display state)
+    "Prints the value at the pointer to the print buffer."
+    (let val = (value-at-pointer state))
+    (lisp Unit (val)
+      (cl:format cl:*standard-output* "~a" (cl:code-char val))
+      Unit))
+
+  ;;
+  ;; Taking Input (,)
+  ;;
+  ;; Currently takes individual characters one at a time as prompted
+
+  (define (prompt-char)
+    "A prompt for obtaining one character as input."
+    (Lisp Char ()
+      (cl:format cl:*query-io* "Input a character: ")
+      (cl:finish-output cl:*query-io*)
+      (cl:read-char cl:*query-io*)))
+
+  (declare take-input (BF-State -> Unit))
+  (define (take-input state)
+    "Takes and stores a character as an ascii code at the pointer."
+    (vec:set! (cell:read (.pointer state))
+                     (into (char:char-code (prompt-char)))
+                     (.memory state))))
+
+;;;
+;;; Parsing/Lexing
+;;;
+
+(coalton-toplevel
+
+  (define-type Cmd
+    BFRight
+    BFLeft
+    BFPlus
+    BFMinus
+    BFPrint
+    BFInput
+    (BFLoop (Vector Cmd)))
+
+  (declare parse (String -> (Vector Cmd)))
+  (define (parse input-string)
+    "Parses a Brainfold instruction string, returns a Vector of Brainfold Commands."
+    (let cmds = (vec:new))
+    (let vecs = (vec:new))
+    ;(let counter = (cell:new 0))
+    (let ((parser (fn (input-string v)
+     ;;               (traceobject "cmd#" (cell:read counter))
+      ;;              (cell:increment! counter!)
+                    (let ((head-tail (str:split 1 input-string)))
+                      (match (fst head-tail)
+                        ("" cmds)
+                        (">"
+                         (vec:push! BFRight v)
+                         (parser (snd head-tail) v))
+                        ("<"
+                         (vec:push! BFLeft v)
+                         (parser (snd head-tail) v))
+                        ("+"
+                         (vec:push! BFPlus v)
+                         (parser (snd head-tail) v))
+                        ("-"
+                         (vec:push! BFMinus v)
+                         (parser (snd head-tail) v))
+                        ("."
+                         (vec:push! BFPrint v)
+                         (parser (snd head-tail) v))
+                        (","
+                         (vec:push! BFInput v)
+                         (parser (snd head-tail) v))
+                        ("["
+                         (vec:push! v vecs)
+                         (parser (snd head-tail) (vec:new)))
+                        ("]"
+                         (vec:push! (BFLoop v) (unwrap (vec:last vecs)))
+                         (parser (snd head-tail) (unwrap (vec:pop! vecs))))
+                        (_ (parser (snd head-tail) v)))))))
+      (parser input-string cmds))))
+
+;;;
+;;; Evaluation
+;;;
+
+(coalton-toplevel
+
+  (declare exec (BF-State -> Cmd -> Unit))
+  (define (exec state cmd)
+    "Executes a given bf command."
+    ;;(traceobject "pos, current-val" (Tuple (cell:read (.pointer state)) (value-at-pointer state)))
+    (match cmd
+      ((BFRight) (move-right state))
+      ((BFLeft) (move-left state))
+      ((BFPlus) (incr state))
+      ((BFMinus) (decr state))
+      ((BFPRint) (display state))
+      ((BFInput) (take-input state))
+      ((BFLoop v) (exec-loop state v))))
+
+
+  (declare exec-cmds (BF-State -> (Vector Cmd) -> Unit))
+  (define (exec-cmds state cmds)
+    "Executes a list of bf-commands."
+    (for cmd in cmds
+      (exec state cmd)))
+
+  (declare exec-loop (BF-State -> (Vector Cmd) -> Unit))
+  (define (exec-loop state cmds)
+    "Executes a list of commands until the value at the pointer is 0."
+    (match (value-at-pointer state)
+      (0 Unit)
+      (_ (exec-cmds state cmds)
+         (exec-loop state cmds))))
+
+  (declare eval (String -> Unit))
+  (define (eval input-string)
+    "Parses and evaluates a string of brainfold input."
+    (exec-cmds (default) (into (parse input-string)))))
+
+
+;;;
+;;; Top Level
+;;;
+
+(coalton-toplevel
+
+  (declare run-program (String -> Unit))
+  (define (run-program bf-string)
+    "Evaluates and executes a bf-command string on a fresh state."
+    (eval bf-string))
+
+  (define (run-file filepath)
+    "Loads and executes the brainfold file at the given filepath."
+    ;;(run-program (unwrap (file:read-file-to-string filepath)))
+    (eval (unwrap (file:read-file-to-string filepath)))))
+
+
+;;;
+;;; Sample test programs
+;;;
+
+(coalton-toplevel
+
+  ;; from https://esolangs.org/wiki/Brainfuck
+
+  (define (hello-world)
+    (run-program
+     "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+."))
+
+  (define (gnarly-hello-world)
+    (run-program
+     ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+."))
+
+  ;; from https://github.com/saulpw/brainfuck/tree/master/tests
+
+  (define (squares)
+    (run-program "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]")))
diff --git a/examples/small-coalton-programs/src/faster-brainfold.lisp b/examples/small-coalton-programs/src/faster-brainfold.lisp
new file mode 100644
index 000000000..8fe1c2454
--- /dev/null
+++ b/examples/small-coalton-programs/src/faster-brainfold.lisp
@@ -0,0 +1,161 @@
+;;;;
+;;;; A Brainfold/Brainf*** interpreter implemented in Coalton
+;;;;
+;;;; This interpreter handles all standard bf commands:
+;;;; ( > < + - . , [ ] ).
+;;;;
+;;;;
+;;;; Run Brainfold programs with (run-program "+++++[-]+++")
+;;;;
+;;;; or
+;;;;
+;;;; (run-file "/path/to/your/file.bf")
+;;;;
+;;;; try (coalton (hello-world)) in the REPL!
+;;;;
+
+(cl:require :sb-sprof)
+
+(cl:setf coalton-impl/settings:*coalton-heuristic-inlining* cl:t)
+
+(cl:defpackage #:brainfold
+  (:use
+   #:coalton
+   #:coalton-prelude)
+  (:local-nicknames
+   (#:vec #:coalton-library/vector)
+   (#:iter #:coalton-library/iterator)
+   (#:cell #:coalton-library/cell)
+   (#:char #:coalton-library/char)
+   (#:str #:coalton-library/string)
+   (#:list #:coalton-library/list)
+   (#:arith #:coalton-library/math)
+   (#:state #:coalton-library/monad/state)
+   (#:file #:coalton-library/file))
+  (:export
+   #:eval
+   #:run-program
+   #:run-file
+
+   ;; Examples
+   #:hello-world
+   #:gnarly-hello-world
+   #:squares))
+
+(in-package #:brainfold)
+
+(named-readtables:in-readtable coalton:coalton)
+
+(coalton-toplevel
+
+  (declare current-cell ((Vector Integer) -> UFix -> Integer))
+  (define (current-cell tape pos)
+    "Returns the value at the current cell."
+    (vec:index-unsafe pos tape))
+
+  (declare incr ((Vector Integer) -> UFix -> UFix))
+  (define (incr tape pos)
+    (vec:set! pos (1+ (current-cell tape pos)) tape)
+    pos)
+
+  (declare decr ((Vector Integer) -> UFix -> UFix))
+  (define (decr tape pos)
+    (vec:set! pos (1- (current-cell tape pos)) tape)
+    pos)
+
+  (declare display ((Vector Integer) -> UFix -> UFix))
+  (define (display tape pos)
+    "Prints the value at the pointer to the print buffer."
+    (let val = (current-cell tape pos))
+    (lisp Unit (val)
+      (cl:format cl:*standard-output* "~a" (cl:code-char val))
+      Unit)
+    pos)
+
+  (declare run (String -> UFix))
+  (define (run input-string)
+    "Parses and runs a Brainfold instruction string, returns the length of the input string."
+    (let tape = (vec:with-initial-element 30000 0))
+    (let stack = (vec:new))
+    (let ((next-end (fn (i)
+                      (if (== (unwrap (str:ref input-string i))
+                              #\])
+                          i
+                          (next-end (1+ i)))))
+          (parse-and-run (fn (i pos)
+                           (unwrap-or-else
+                            (fn (x)
+                              (traceobject "cmd - val" (Tuple x (current-cell tape pos)))
+                              (match x
+                                (#\>
+                                 (parse-and-run (1+ i) (1+ pos)))
+                                (#\<
+                                 (parse-and-run (1+ i) (1- pos)))
+                                (#\+
+                                 (parse-and-run (1+ i) (incr tape pos)))
+                                (#\-
+                                 (parse-and-run (1+ i) (decr tape pos)))
+                                (#\.
+                                 (parse-and-run (1+ i) (display tape pos)))
+                                (#\[
+
+                                 (cond ((zero? (current-cell tape pos))
+                                        (trace "skipped")
+                                        (parse-and-run (1+ (next-end i)) pos))
+                                       (True
+                                        (vec:push! i stack)
+                                        (traceobject "stacked " stack)
+                                        (parse-and-run (1+ i) pos))))
+                                (#\]
+                                 (let popped = (vec:pop-unsafe! stack))
+                                 (traceobject "popped" stack;;(Tuple (current-cell tape pos) stack)
+                                              )
+                                 (cond ((zero? (current-cell tape pos))
+                                        (trace "continued")
+                                        (parse-and-run (1+ i) pos))
+                                       (True
+                                        (parse-and-run popped pos ;;(vec:pop-unsafe! stack) pos
+                                                       ))))
+                                (_ (parse-and-run (1+ i) pos))))
+                            (fn ()
+                              i)
+                            (str:ref input-string i)))))
+      (parse-and-run 0 0)))
+
+  ;; make another run that has cells for pos and idx
+  (declare run-file (String -> UFix))
+  (define (run-file filename)
+    (run (unwrap (file:read-file-to-string filename)))))
+
+;;;
+;;; Sample test programs
+;;;
+
+(coalton-toplevel
+
+  ;; from https://esolangs.org/wiki/Brainfuck
+  (define (hello-world)
+    (run
+     "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+."))
+
+  (define (gnarly-hello-world)
+    (run
+     ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+."))
+
+  ;; from https://github.com/saulpw/brainfuck/tree/master/tests
+
+  (define (squares)
+    (run "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]")))
+
+(cl:defun profile-bench ()
+  (sb-sprof:with-profiling (:max-samples 100000
+                            :sample-interval 0.001
+                            :report :flat
+                            :loop cl:nil)
+    (coalton (run-file "bench.b"))))
+#+ig
+(cl:defun profile-hello-world ()
+  (sb-sprof:with-profiling (:max-samples 1000
+                            :report :flat
+                            :loop cl:nil)
+    (coalton (brainfold:hello-world))))