Xcf4••

Xcf4•• (pronounced /ɛks si ɛf foar dʌbl alt-sɛvn/), uses only the symbols ☺, ☻, and π.

Commands

This will have Xcf4•• on the left and BF on the right.

☺☺ +
☻☻ -
ππ .
π☺ <
π☻ >
☺π [
☻π ]
☺☻ ,
☻☺ [>+<-]

Examples

ASCII Cycle

☺☺☺πππ☺☺☻π

Cat

☺☻ππ

Truth-machine

The following program provides a truth-machine:

☺☻ππ☺π☻☻☻☻π☻☺☺☺ππ☻π☻☻ππ☺☺πππ☻ππ☺π☺☻π

Interpreters

Common Lisp

An implementation in Common Lisp follows. Please note that Unicode support constitutes a dependency on the Common Lisp implementation. The interpreter at hand has been developed and tested with Steel Bank Common Lisp (SBCL) version 1.1.4 as part of the Lisp Cabinet 0.3.5 bundle.

(defun parse-commands (code &aux (commands NIL))
  (declare (type string code) (type list commands))
  (loop with position of-type fixnum = 0 while (< position (length code)) do
    (let ((token (subseq code position (min (+ position 2) (length code)))))
      (declare (type string token))
      (cond ((string= token "☺☺") (push :increment    commands) (incf position 2))
            ((string= token "☻☻") (push :decrement    commands) (incf position 2))
            ((string= token "ππ") (push :output       commands) (incf position 2))
            ((string= token "π☺") (push :move-left    commands) (incf position 2))
            ((string= token "π☻") (push :move-right   commands) (incf position 2))
            ((string= token "☺π") (push :jump-forward commands) (incf position 2))
            ((string= token "☻π") (push :jump-back    commands) (incf position 2))
            ((string= token "☺☻") (push :input        commands) (incf position 2))
            ((string= token "☻☺") (push :transfer     commands) (incf position 2))
            (T                    (incf position 1)))))
  (the (vector keyword *) (coerce (nreverse commands) '(vector keyword *))))

(defun compute-jump-table (commands &aux (jump-table (make-hash-table :test #'eql))
                                         (jump-stack NIL))
  (declare (type (vector keyword *) commands)
           (type list jump-stack) (type hash-table jump-table))
  (the hash-table
    (loop for position of-type fixnum from 0 below (length commands)
      if (eq (aref commands position) :jump-forward) do
        (push position jump-stack)
      else if (eq (aref commands position) :jump-back) do
        (if jump-stack
          (let ((jump-start-position (pop jump-stack)))
            (declare (type fixnum jump-start-position))
            (setf (gethash jump-start-position jump-table) position
                  (gethash position            jump-table) jump-start-position))
          (error "Mismatch in back jump commands at position ~d." position))
      finally
        (when jump-stack
          (error "Mismatch in forward jump commands at positions ~a." jump-stack))
        (return jump-table))))

(defun interpret-Xcf4•• (code &aux (commands     (parse-commands code))
                                   (jump-table   (compute-jump-table commands))
                                   (ip           0)
                                   (memory       (make-hash-table :test #'eql))
                                   (cell-pointer 0))
  (declare (type string code)
           (type (vector keyword *) commands) (type hash-table jump-table memory)
           (type fixnum ip) (type integer cell-pointer))
    (flet ((current-cell ()
            (the (unsigned-byte 8) (gethash cell-pointer memory 0)))
           ((setf current-cell) (new-value)
            (declare (type integer new-value))
            (setf (gethash cell-pointer memory 0) (mod new-value 256))
            (values)))
      (loop while (< ip (length commands)) do
        (case (aref commands ip)
          (:increment    (incf (current-cell)))
          (:decrement    (decf (current-cell)))
          (:move-right   (incf cell-pointer))
          (:move-left    (decf cell-pointer))
          (:input        (format T "~&>> ")
                         (setf (current-cell) (char-code (read-char)))
                         (clear-input))
          (:output       (write-char (code-char (current-cell))))
          (:jump-forward (when (zerop (current-cell))
                           (setf ip (gethash ip jump-table))))
          (:jump-back    (unless (zerop (current-cell))
                           (setf ip (gethash ip jump-table))))
          (:transfer     (loop until (zerop (current-cell)) do
                           (incf cell-pointer)
                           (incf (current-cell))
                           (decf cell-pointer)
                           (decf (current-cell))))
          (otherwise (error "Invalid command: ~s." (aref commands ip))))
        (incf ip))))