brainappend

brainappend is a brainfuck derivative by User:Joaozin003, partly inspired by Vague where the braces ([ and ]) append their contents to the source code (including themselves). This makes looping much more difficult.

Instructions

Instruction	Command
+, -, <, >, , and .	Same as brainfuck
]	If the value of the current memory cell is not 0, then append the source code enclosed by this and the matching [, including the braces themselves, e.g. [>] appends [>] when ] gets ran
[	If the value of the current memory cell is 0, then jump to the matching ].

Examples

Cat program (NUL-terminated)

,[.,]

Gets a character, then appends [.,] to the source code if it is not NUL.

Truth-machine

The following program implements a truth-machine:

,.>+++++++++++++++++++++++++++++++++++++++++++++++++
<------------------------------------------------[>.<]

See also

• Brainfuck
• Vague

Implementation

An implementation in Common Lisp shall be produced below:

(deftype hash-table-of (&optional (key-type T) (value-type T))
  "Defines a hash table composed of entries whose key match the KEY-TYPE
   and whose values assume 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 of-type T 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 octet ()
  "Defines an unsigned byte as an integer in the range [0, 255]."
  '(unsigned-byte 8))

(deftype memory ()
  "Defines the program memory as a hash table-based vector of unsigned bytes."
  '(hash-table-of integer octet))

(defun make-memory ()
  "Returns a new memory instance."
  (the memory (make-hash-table :test #'eql)))

(defun cell-value-at (memory index)
  "Returns the value stored in the MEMORY cell at the INDEX."
  (declare (type memory  memory) (type integer index))
  (the octet (gethash index memory 0)))

(defun (setf cell-value-at) (new-value memory index)
  "Stores the NEW-VALUE in the MEMORY cell at the INDEX and returns no value."
  (declare (type memory  memory) (type integer index))
  (setf (gethash index memory 0) (mod new-value 256))
  (values))

(defun find-left-bracket (code start)
  "Commencing with the START index into the CODE, returns the position
   of the matching \"[\" token, or signals an error of an unspecified type
   upon its disrespondency."
  (declare (type string code) (type fixnum start))
  (the fixnum
    (loop
      with nesting-level of-type fixnum    =    0
      for position       of-type fixnum    from start downto  0
      for token          of-type character =    (char code position)
      if (and (char= token #\[) (zerop nesting-level)) do
        (return position)
      else if (and (char= token #\[) (/= nesting-level 0)) do
        (decf nesting-level)
      else if (char= token #\]) do
        (incf nesting-level)
      end
      finally
        (error "No matching left bracket (\"[\") found."))))

(defun find-right-bracket (code start)
  "Commencing with the START index into the CODE, returns the position
   of the matching \"]\" token, or signals an error of an unspecified type
   upon its disrespondency."
  (declare (type string code) (type fixnum start))
  (the fixnum
    (loop
      with nesting-level of-type fixnum    =    0
      for position       of-type fixnum    from start below (fill-pointer code)
      for token          of-type character =    (char code position)
      if (char= token #\[) do
        (incf nesting-level)
      else if (and (char= token #\]) (zerop nesting-level)) do
        (return position)
      else if (and (char= token #\]) (/= nesting-level 0)) do
        (decf nesting-level)
      end
      finally (error "No matching right bracket (\"]\") found."))))

(defun interpret-brainappend (initial-code)
  "Interprets the brainappend INITIAL-CODE and returns no value."
  (declare (type string initial-code))
  (let ((code         (make-array (length initial-code)
                        :element-type     'character
                        :initial-contents initial-code
                        :adjustable       T
                        :fill-pointer     T))
        (ip           0)
        (memory       (make-memory))
        (cell-pointer 0))
    (declare (type string code) (type fixnum ip)
             (type memory  memory) (type integer cell-pointer))
    (loop while (< ip (fill-pointer code)) do
      (case (char code ip)
        (#\+ (incf (cell-value-at memory cell-pointer)))
        (#\- (decf (cell-value-at memory cell-pointer)))
        (#\> (incf cell-pointer))
        (#\< (decf cell-pointer))
        (#\, (format T "~&>> ")
             (finish-output)
             (let ((input (read-char NIL NIL #\Null)))
               (declare (type character input))
               (setf (cell-value-at memory cell-pointer)
                 (if (char= input #\Newline)
                   0
                   (char-code input))))
             (clear-input))
        (#\. (write-char
               (code-char
                (cell-value-at memory cell-pointer))))
        (#\[ (when (zerop (cell-value-at memory cell-pointer))
               (setf ip (find-right-bracket code (1+ ip)))))
        (#\] (unless (zerop (cell-value-at memory cell-pointer))
               (let ((start-point (find-left-bracket code (1- ip))))
                 (declare (type fixnum start-point))
                 (format code "~a" (subseq code start-point (1+ ip))))))
        (otherwise NIL))
      (incf ip)))
  (values))