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))))
Category:Brainfuck derivativesCategory:LanguagesCategory:Implemented