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