Threi

Threi is an esoteric programming language desgined by User:Infinitehexagon.
==Instructions==
Command	Name 	Description
< 	move pointer left 	change the cell pointer to the left.
> 	move pointer right	change the cell pointer to the right.
h 	Invert bit 	Flip the bit that the cell pointer is on.
x 	random bit 	Set the bit that the cell pointer is pointing to a value to a random bit.
& 	AND gate 	If the cell before it and the current cell both have a value of 1, replace the 3rd cell after the current cell with 1.
o 	Output 	Output the bit at the cell pointer.
e 	Clear 	set the bit at the cell pointer to 0.
{} 	While not 0 	jump back to the { while the current bit is not 0.
=Programs=
===Truth machine===
h --remove for 0
>h{&
 >o<<
}
===Hello world program===
This program prints the message “Hello, World!” to the standard output:
 o>ho>o>o>ho>o>o>o>
 o>ho>ho>o>o>ho>o>ho>
 o>ho>ho>o>ho>ho>o>o>
 o>ho>ho>o>ho>ho>o>o>
 o>ho>ho>o>ho>ho>ho>ho>
 o>o>ho>o>ho>ho>o>o>
 o>o>ho>o>o>o>o>o>
 o>ho>o>ho>o>ho>ho>ho>
 o>ho>ho>o>ho>ho>ho>ho>
 o>ho>ho>ho>o>o>ho>o>
 o>ho>ho>o>ho>ho>o>o>
 o>ho>ho>o>o>ho>o>o>
 o>o>ho>o>o>o>o>ho
==Computational class==
Language is Turing complete because instructions h<>{} correspond directly to Smallfuck *<>[], deviating merely from the latter's program termination aspect on leaving the memory boundaries.
==Implementation==
The following presents an implementation in Common Lisp:
 (deftype hash-table-of (&optional (key-type '*) (value-type '*))
 "Defines a hash table composed whose keys assume the KEY-TYPE and
 whose values adhere to the VALUE-TYPE."
 (let ((predicate (gensym)))
 (declare (type symbol predicate))
 (setf (symbol-function predicate)
 #'(lambda (candidate)
 (declare (type T candidate))
 (and
 (hash-table-p candidate)
 (loop
 for key being the hash-keys in (the hash-table candidate)
 using (hash-value value)
 always (and (typep key key-type) (typep value value-type))))))
 `(satisfies ,predicate)))
 
 (deftype list-of (&optional (element-type '*))
 "Defines a list composed of the zero or more elements of the ELEMENT-TYPE."
 (let ((predicate (gensym)))
 (declare (type symbol predicate))
 (setf (symbol-function predicate)
 #'(lambda (candidate)
 (declare (type T candidate))
 (loop for element of-type T in (the list candidate) always
 (typep element element-type))))
 `(satisfies ,predicate)))
 
 (deftype jump-table ()
 "Maps the forward jump positions to that of the back jumps, and vice versa."
 '(hash-table-of fixnum fixnum))
 
 (defun compute-jump-table (code)
 "Computes and returns the jump-table for the piece of Threi source CODE."
 (declare (type string code))
 (let ((jump-table (make-hash-table :test #'eql))
 (forward-jump-points NIL))
 (declare (type jump-table) (type (list-of fixnum) forward-jump-points))
 (loop
 for token of-type character across code
 and position of-type fixnum from 0 by 1
 if (char= token #\{) do
 (push position forward-jump-points)
 else if (char= token #\}) do
 (if forward-jump-points
 (let ((start-point (pop forward-jump-points))
 (end-point position))
 (declare (type fixnum start-point))
 (declare (type fixnum end-point))
 (setf (gethash start-point jump-table) end-point)
 (setf (gethash end-point jump-table) start-point))
 (error "Unmatched back jump point at position ~d." position))
 end
 finally
 (when forward-jump-points
 (error "Unmatched forward jump point~p at position~:p ~
 ~{~d~^, ~}."
 (length forward-jump-points)
 (nreverse forward-jump-points))))
 (the jump-table jump-table)))
 
 (defclass Memory ()
 ((cells
 :initform (make-array 0 :element-type 'bit :initial-element 0)
 :type simple-bit-vector
 :documentation "A tape of cells which grows along the positive axis.")
 (pointer
 :initform 0
 :type fixnum
 :documentation "The index (key) of the current cell among the CELLS."))
 (:documentation "Maintains a bit vector with a cell pointer."))
 
 (defun accommodate-space-for (memory index)
 "Ascertains the MEMORY's capacity to answer to the cell INDEX and
 returns no value."
 (declare (type Memory memory) (type fixnum index))
 (when (>= index (length (slot-value memory 'cells)))
 (setf (slot-value memory 'cells)
 (adjust-array (slot-value memory 'cells) (1+ index) :initial-element 0)))
 (values))
 
 (defun cell-at (memory index)
 "Returns the MEMORY cell value at the INDEX."
 (declare (type Memory memory) (type fixnum index))
 (accommodate-space-for memory index)
 (the bit (sbit (slot-value memory 'cells) index)))
 
 (defun (setf cell-at) (new-value memory index)
 "Sets the MEMORY cell value the INDEX to the NEW-VALUE and returns no value."
 (declare (type bit new-value) (type Memory memory) (type fixnum index))
 (accommodate-space-for memory index)
 (setf (sbit (slot-value memory 'cells) index) new-value)
 (values))
 
 (defun current-cell (memory)
 "Returns the value of the current MEMORY cell."
 (declare (type Memory memory))
 (the bit (cell-at memory (slot-value memory 'pointer))))
 
 (defun (setf current-cell) (new-value memory)
 "Stores the NEW-VALUE in the MEMORY's current cell and returns no value."
 (declare (type Memory memory) (type bit new-value))
 (setf (cell-at memory (slot-value memory 'pointer)) new-value)
 (values))
 
 (defun and-combine-cells (memory)
 "If the current and its preceding cell contain the value 1, stores the
 value 1 in the cell three positions right to the current cell, in any
 case returning no value."
 (declare (type Memory memory))
 (when (and (plusp (slot-value memory 'pointer))
 (= (cell-at memory (1- (slot-value memory 'pointer))) 1))
 (setf (cell-at memory (+ (slot-value memory 'pointer) 3)) 1))
 (values))
 
 (defun move-cell-pointer-left (memory)
 "Translates the MEMROY's cell pointer one step to the left, if no
 already on the first position, and returns no value."
 (declare (type Memory memory))
 (when (plusp (slot-value memory 'pointer))
 (decf (slot-value memory 'pointer)))
 (values))
 
 (defun move-cell-pointer-right (memory)
 "Translates the MEMORY's cell pointer on step to the right and returns
 no value."
 (declare (type Memory memory))
 (incf (slot-value memory 'pointer))
 (values))
 
 (defun interpret-Threi (code)
 "Interprets the piece of Threi source CODE and returns no value."
 (declare (type string code))
 (let ((jump-table (compute-jump-table code))
 (memory (make-instance 'Memory)))
 (declare (type jump-table jump-table))
 (declare (type Memory memory))
 (loop with ip of-type fixnum = 0 while (< ip (length code)) do
 (case (char code ip)
 (#\> (move-cell-pointer-right memory))
 (#\< (move-cell-pointer-left memory))
 (#\h (setf (current-cell memory) (- 1 (current-cell memory))))
 (#\x (setf (current-cell memory) (random 2)))
 (#\e (setf (current-cell memory) 0))
 (#\& (and-combine-cells memory))
 (#\o (format T "~d" (current-cell memory)))
 (#\{ (when (zerop (current-cell memory))
 (setf ip
 (or (gethash ip jump-table)
 (error "No back jump position associated with ~d." ip)))))
 (#\} (unless (zerop (current-cell memory))
 (setf ip
 (or (gethash ip jump-table)
 (error "No back jump position associated with ~d." ip)))))
 (otherwise NIL))
 (incf ip)))
 (values))
 
 ;; Initialize the random number generator.
 (setf *random-state* (make-random-state T))
Category:LanguagesCategory:2023Category:Cell-basedCategory:Output only
Category:Turing complete