Brain-accumulator
Jump to navigation
Jump to search
BF with only an accumulator and 3 instructions made on June 22 2025 by User:A()
Commands
| Instruction | Function |
|---|---|
| + | adds one to the accumulator |
| - | subtracts one from the accumulator |
| * | Does something based on the accumulator mod 8 |
| mod | Function |
|---|---|
| 0 | move left |
| 1 | move right |
| 2 | add 1 |
| 3 | subtract 1 |
| 4 | while not 0 loop |
| 5 | while not 0 loop end |
| 6 | output cell value as a ascii char |
| 7 | Input as a ascii code |
Programs
Cat
+++++++*---*++*+*--*
Truth-Machine
+++++++*-------++++++*------++++*----+++*---+++*---+*-++*--++++*----+*-+*-+++++*-----*++++*----++++++*------+++++*-----**+++++*
Interpreter
The following furnishes an interpreter for the Brain-accumulator programming language, as well as the supererogations molded into converters from brainfuck to Brain-accumulator, and vice versa:
(deftype destination ()
"Defines a sink for output operations, such as \"format\"."
'(or null (eql T) stream string))
;;; -------------------------------------------------------
(deftype octet ()
"Defines an unsigned byte value in the range [0, 255]."
'(unsigned-byte 8))
;;; -------------------------------------------------------
(defun decode-the-brainfuck-instruction (accumulator destination)
"Obtains the brainfuck instruction symbol affiliated with the
ACCUMULATOR state modulo eight (8), writes thilk to the DESTINATION,
and returns no value."
(declare (type (integer 0 7) accumulator))
(declare (type destination destination))
(format destination "~c"
(case (mod accumulator 8)
(0 #\>)
(1 #\<)
(2 #\+)
(3 #\-)
(4 #\[)
(5 #\])
(6 #\.)
(7 #\,)
(otherwise (error "Invalid accumulator state: ~d." accumulator))))
(values))
;;; ---------------------------------------------------
(defun translate-to-brainfuck (brain-accumulator-code
&optional (destination NIL))
"Translates the BRAIN-ACCUMULATOR-CODE into its brainfuck tantamount,
writes the resulting code to the DESTINATION, and returns for a
non-\"NIL\" DESTINATION the \"NIL\" value; otherwise responds with
a fresh string comprehending the result."
(declare (type string brain-accumulator-code))
(declare (type destination destination))
(the (or null string)
(if destination
(loop
with accumulator of-type (integer 0 7) = 0
for current-token
of-type character
across brain-accumulator-code
if (char= current-token #\+) do
(setf accumulator (mod (1+ accumulator) 8))
else if (char= current-token #\-) do
(setf accumulator (mod (1- accumulator) 8))
else if (char= current-token #\*) do
(decode-the-brainfuck-instruction accumulator destination)
end)
(with-output-to-string (brainfuck-code)
(declare (type string-stream brainfuck-code))
(translate-to-brainfuck
brain-accumulator-code
brainfuck-code)))))
;;; -------------------------------------------------------
(defun encode-the-brainfuck-instruction (brainfuck-symbol)
"Returns the Brain-accumulator accumulator state corresponding to the
BRAINFUCK-SYMBOL designating one of its octuple operations."
(declare (type standard-char brainfuck-symbol))
(the (integer 0 7)
(case brainfuck-symbol
(#\< 0)
(#\> 1)
(#\+ 2)
(#\- 3)
(#\[ 4)
(#\] 5)
(#\. 6)
(#\, 7)
(otherwise (error "No brainfuck instruction symbol \"~c\"."
brainfuck-symbol)))))
;;; -------------------------------------------------------
(defun translate-to-brain-accumulator (brainfuck-code
&optional (destination NIL))
"Translate the piece of BRAINFUCK-CODE into an equivalent
Brain-accumulator program, writes the same to the DESTINATION, and
returns for a non-\"NIL\" DESTINATION the \"NIL\", otherwise
produces a fresh string comprehending the output."
(declare (type string brainfuck-code))
(declare (type destination destination))
(the (or null string)
(if destination
(loop
with current-accumulator-state of-type (integer 0 7) = 0
for current-token of-type character across brainfuck-code
when (find current-token "<>+-[].," :test #'char=) do
(format destination "~v@{~c~:*~}" current-accumulator-state #\-)
(let ((new-accumulator-state
(encode-the-brainfuck-instruction current-token)))
(declare (type (integer 0 7) new-accumulator-state))
(format destination "~v@{~c~:*~}" new-accumulator-state #\+)
(format destination "*")
(setf current-accumulator-state new-accumulator-state)))
(with-output-to-string (brain-accumulator-code)
(declare (type string-stream brain-accumulator-code))
(translate-to-brain-accumulator
brainfuck-code brain-accumulator-code)))))
;;; -------------------------------------------------------
(defun connect-the-jump-points (brainfuck-code)
"Creates and returns a bidirectional mapping betwixt the matching
jump points in the piece of BRAINFUCK-CODE."
(declare (type string brainfuck-code))
(the hash-table
(let ((jump-table (make-hash-table :test #'eql))
(forward-jump-points NIL))
(declare (type hash-table jump-table))
(declare (type list forward-jump-points))
(loop
for current-token of-type character across brainfuck-code
and current-position of-type fixnum from 0 by 1
if (char= current-token #\[) do
(push current-position forward-jump-points)
else if (char= current-token #\]) do
(if forward-jump-points
(let ((start-point (pop forward-jump-points))
(end-point current-position))
(declare (type fixnum start-point end-point))
(psetf (gethash start-point jump-table) end-point
(gethash end-point jump-table) start-point))
(error "Unmatched \"]\" at position ~d." current-position))
end
finally
(if forward-jump-points
(error "Unmatched \"[\" token~p at position~:p ~{~d~^, ~}."
(length forward-jump-points) forward-jump-points)
(return jump-table))))))
;;; -------------------------------------------------------
(defun interpret-brainfuck (code)
"Interprets the piece of brainfuck source CODE and returns no value."
(let ((ip 0)
(jump-table (connect-the-jump-points code))
(memory (make-hash-table :test #'eql))
(cell-pointer 0))
(declare (type fixnum ip))
(declare (type hash-table jump-table))
(declare (type hash-table memory))
(declare (type integer cell-pointer))
(flet ((current-cell-value ()
"Returns the current cell's byte value."
(the octet (gethash cell-pointer memory 0)))
((setf current-cell-value) (new-value)
"Stores the NEW-VALUE in the current cell, contingently
preceded by its wrapping into the byte range [0, 255], and
returns no value."
(declare (type integer new-value))
(setf (gethash cell-pointer memory 0) (mod new-value 256))
(values)))
(loop while (< ip (length code)) do
(case (char code ip)
(#\< (decf cell-pointer))
(#\> (incf cell-pointer))
(#\+ (incf (current-cell-value)))
(#\- (decf (current-cell-value)))
(#\[ (when (zerop (current-cell-value))
(setf ip (gethash ip jump-table))))
(#\] (unless (zerop (current-cell-value))
(setf ip (gethash ip jump-table))))
(#\. (format T "~c" (code-char (current-cell-value))))
(#\, (format T "~&>> ")
(finish-output)
(setf (current-cell-value)
(char-code (or (read-char NIL NIL #\Null))))
(clear-input))
(otherwise NIL))
(incf ip))))
(values))
;;; -------------------------------------------------------
(defun interpret-Brain-accumulator (code)
"Interprets the piece of Brain-accumulator source CODE and returns no
value."
(declare (type string code))
(interpret-brainfuck
(translate-to-brainfuck code NIL))
(values))