HTPF
Jump to navigation
Jump to search
Hypertext Programming Fuck (also known as Hypertext Programming F*ck, HTPF) is a brainfuck equivalent that aims to use only characters commonly used in HTML. It's idea and goals are similar to HTPL.
Syntax
| Brainfuck | HTPF | Description |
|---|---|---|
>
|
>
|
Move the pointer to the right |
<
|
<
|
Move the pointer to the left |
+
|
=
|
Increment the memory cell at the pointer |
-
|
/
|
Decrement the memory cell at the pointer |
.
|
"
|
Output the character signified by the cell at the pointer |
,
|
#
|
Input a character and store it in the cell at the pointer |
[
|
&
|
Jump past the matching ] if the cell at the pointer is 0
|
]
|
;
|
Jump back to the matching [ if the cell at the pointer is nonzero
|
Examples
Hello, World!
This program prints the message “Hello, World!” to the standard output:
=&//>/&>>=>/////<<;<//<///;>/">>>=">>""===&">;<<<<"==="//////"<</">>>>="
Cat program
This presents a repeating cat program which terminates on a null character input.
#&"#;
Implementation
This implementation in Common Lisp employs a shift-reduce parser for its duties' fulfilment. The consequent nimiety in code size shall hopefully be vindicated by the didascalic element of supererogation commorant in its presentation.
(defmacro define-custom-type (type-name (candidate-variable &rest lambda-list) &body body)
"Defines a new derived type nevened by the TYPE-NAME, its parameters
comporting to the LAMBDA-LIST, its satisfaction probed by testing the
CANDIDATE-VARIABLE in the BODY's context, the desinent form of which,
if returning a non-NIL value, is deemed successful, otherwise failed."
(let ((predicate-name (gensym)))
(declare (type symbol predicate-name))
`(deftype ,type-name (,@lambda-list)
,(if (stringp (first body))
(pop body)
(format NIL "The derived type ~s." type-name))
(let ((,predicate-name (gensym)))
(declare (type symbol ,predicate-name))
(setf (symbol-function ,predicate-name)
#'(lambda (,candidate-variable)
(declare (type T ,candidate-variable) (ignorable ,candidate-variable))
,@body))
`(satisfies ,,predicate-name)))))
(define-custom-type list-of (candidate &optional (element-type '*))
"A list composed of zero or more elements of the ELEMENT-TYPE."
(and (listp candidate)
(loop for element of-type T in candidate
always (typep element element-type))))
(deftype symbol-list ()
"A list composed of zero or more symbols."
'(list-of symbol))
(deftype octet ()
"An unsigned byte compact of eight accolent bits."
'(unsigned-byte 8))
(define-custom-type memory (candidate)
"The program memory fashioned as a hash table-based sparse vector of octets."
(and (hash-table-p candidate)
(loop for key of-type T being the hash-keys in candidate
using (hash-value value)
always (and (integerp key) (typep value 'octet)))))
(defstruct (AST-Node
(:constructor make-ast-node (type &optional (argument NIL))))
"Models an abstract syntax tree (AST) node in a generic fashion."
(type (error "Missing type.") :type keyword :read-only T)
(argument NIL :type T :read-only T))
(defstruct (Expression
(:constructor make-expression (type value)))
"Encapsulates a token, AST node, or node list for its insertion into
the stack."
(type (error "Missing type.") :type keyword :read-only T)
(value (error "Missing value.") :type T :read-only T))
(defstruct (Production-Rule
(:constructor make-production-rule (pattern handle)))
"A production rule, composed of a pattern which defines the handle's
(right-hand side or RHS) structure, capacitating its recognition
during the reduce step, and the handle itself, as a variadic function
which produces for a list of expressions a new one, the antecedent,
or left-hand side (LHS)."
(pattern (error "Missing pattern.")
:type (list-of keyword) :read-only T)
(handle (error "Missing handle.")
:type (function (&rest Expression) Expression) :read-only T))
(defstruct (Input-Buffer
(:constructor make-input-buffer (source)))
"Produces the HTPF source code tokens as expressions."
(source (error "Missing source.") :type string :read-only T)
(position 0 :type fixnum :read-only NIL))
(defun skip-comment (input-buffer)
"Proceeding from the current position into the INPUT-BUFFER, skips
a contingent comment section."
(declare (type Input-Buffer input-buffer))
(symbol-macrolet ((source (the string (input-buffer-source input-buffer)))
(position (the fixnum (input-buffer-position input-buffer))))
(setf position
(or (position-if
#'(lambda (current-character)
(declare (type character current-character))
(find current-character "><=/\"#&;" :test #'char=))
source :start position)
(length source))))
(values))
(defun input-buffer-exhausted-p (input-buffer)
"Determines whether the INPUT-BUFFER has returned all of its tokens."
(declare (type Input-Buffer input-buffer))
(skip-comment input-buffer)
(the boolean
(not (null (>= (input-buffer-position input-buffer)
(length (input-buffer-source input-buffer)))))))
(defun get-next-token (input-buffer)
"Returns the next token from the INPUT-BUFFER, encapsulated in an ``Expression``."
(declare (type Input-Buffer input-buffer))
(skip-comment input-buffer)
(symbol-macrolet ((source (the string (input-buffer-source input-buffer)))
(position (the fixnum (input-buffer-position input-buffer))))
(the Expression
(handler-case
(prog1 (ecase (char source position)
(#\> (make-expression :move-right #\>))
(#\< (make-expression :move-left #\<))
(#\= (make-expression :increment #\=))
(#\/ (make-expression :decrement #\/))
(#\" (make-expression :output #\"))
(#\# (make-expression :input #\#))
(#\& (make-expression :jump-forward #\&))
(#\; (make-expression :jump-back #\;)))
(incf position)
(skip-comment input-buffer))
(error () (make-expression :eof NIL))))))
(defstruct (Parser
(:constructor initialize-parser (input-buffer)))
"Implements the shift-reduce parser."
(input-buffer (error "Missing input buffer.") :type Input-Buffer)
(stack NIL :type (list-of Expression))
(productions NIL :type (list-of Production-Rule)))
(defun parser-pop-n (parser number-of-elements)
"Pops the NUMBER-OF-ELEMENTS from the PARSER's stack and returns these
as a list."
(declare (type Parser parser) (type (integer 0 *) number-of-elements))
(the (list-of Expression)
(loop repeat number-of-elements collect (pop (parser-stack parser)))))
(defun parser-shift (parser)
"Queries the next token from the PARSER's input buffer and pushes it
unto its stack."
(declare (type Parser parser))
(push (get-next-token (parser-input-buffer parser))
(parser-stack parser))
(values))
(defun production-rule-matches-p (parser probed-production-rule)
"Determines whether the PROBED-PRODUCTION-RULE's pattern matches the
PARSER stack's top elements."
(declare (type Parser parser) (type Production-Rule probed-production-rule))
(the boolean
(not (null
(and (>= (length (parser-stack parser))
(length (production-rule-pattern probed-production-rule)))
(every #'eq (reverse (production-rule-pattern probed-production-rule))
(mapcar #'expression-type (parser-stack parser))))))))
(defun parser-reduce (parser)
"Repeatedly applies the reduce step by selecting production rules
registered at the PARSER and substituting its stack's top by the
matching ones' handle results."
(declare (type Parser parser))
(flet ((find-matching-production ()
(the (or null Production-Rule)
(find-if
#'(lambda (probed-rule)
(declare (type Production-Rule probed-rule))
(production-rule-matches-p parser probed-rule))
(parser-productions parser)))))
(loop
for matching-production
of-type (or null Production-Rule)
= (find-matching-production)
while matching-production do
(push (apply (production-rule-handle matching-production)
(nreverse
(parser-pop-n parser
(length (production-rule-pattern matching-production)))))
(parser-stack parser))))
(values))
(defun parser-accept-or-error (parser)
"Determines whether the PARSER can accept its stack's state, on
confirmation returning the root AST node, otherwise signals an error."
(declare (type Parser parser))
(symbol-macrolet ((stack (the (list-of Expression) (parser-stack parser))))
(the AST-Node
;; Determine whether the stack contains the start symbol only.
(if (and (= (length stack) 1)
(eq (expression-type (first stack)) :program))
(expression-value (first stack))
(error "Parsing error encountered. Stack state: ~s" stack)))))
(defun parse-program (parser)
"Parses the program in the PARSER's input buffer and returns the root
AST node."
(declare (type Parser parser))
(loop until (input-buffer-exhausted-p (parser-input-buffer parser))
do (parser-shift parser)
(parser-reduce parser)
finally
(parser-shift parser)
(parser-reduce parser))
(the AST-Node (parser-accept-or-error parser)))
(defun build-parameter-names (arity)
"Returns a list which tallies ARITY automatically generated function
parameter names following the forbisen \"${x}\", where {x}
constitutes an ascending enumeration commencing from one (1)."
(declare (type (integer 0 *) arity))
(the (list-of symbol)
(loop for parameter-no of-type (integer 1 *) from 1 to arity
collect (intern (format NIL "$~d" parameter-no)))))
(defmacro define-productions (parser &rest productions)
"Offers an amenity for the definition of PRODUCTIONS, which are
subsequently registered at the PARSER.
---
Each production rule in the PRODUCTIONS constitutes a two-element
list, the sinistral moeity of which specifies the rule pattern as
a list of keywords, while the dextral compartment contributes the handle
body forms, the same, being implicitly ensconced in a 'lambda' form,
may access the ordered arguments by fixed symbol names following the
pattern '${i}', where '{i}' constitutes the i-th 'Expression', with
i >= 1."
(let ((evaluated-parser (gensym)))
(declare (type symbol evaluated-parser))
`(let ((,evaluated-parser ,parser))
(declare (type Parser ,evaluated-parser))
(setf (parser-productions ,evaluated-parser)
(list
,@(loop
for production of-type list in productions
for pattern of-type list = (first production)
for handle-body of-type list = (rest production)
for handle-parameters of-type symbol-list = (build-parameter-names (length pattern))
collect
`(make-production-rule ',pattern
#'(lambda (,@handle-parameters)
,@(loop for param-name of-type symbol in handle-parameters
collect `(declare (type Expression ,param-name)
(ignorable ,param-name)))
,@handle-body))))))))
(defun make-parser (input-buffer)
"Returns a new ``Parser`` for the INPUT-BUFFER, endowed with the
correct production rules."
(declare (type Input-Buffer input-buffer))
(let ((parser (initialize-parser input-buffer)))
(declare (type Parser parser))
(define-productions parser
;; Instruction tokens produce representative AST nodes.
((:increment) (make-expression :node (make-ast-node :increment)))
((:decrement) (make-expression :node (make-ast-node :decrement)))
((:move-right) (make-expression :node (make-ast-node :move-right)))
((:move-left) (make-expression :node (make-ast-node :move-left)))
((:input) (make-expression :node (make-ast-node :input)))
((:output) (make-expression :node (make-ast-node :output)))
;; Two nodes coalesce into a node list.
((:node :node)
(make-expression :node-list
(list (expression-value $1) (expression-value $2))))
;; A node list integrates the subsequent node.
((:node-list :node)
(make-expression :node-list
(append (expression-value $1)
(list (expression-value $2)))))
;; An empty loop node.
((:jump-forward :jump-back)
(make-expression :node
(make-ast-node :loop NIL)))
;; A singleton loop node.
((:jump-forward :node :jump-back)
(make-expression :node
(make-ast-node :loop (list (expression-value $2)))))
;; A loop node composed of several statements.
((:jump-forward :node-list :jump-back)
(make-expression :node
(make-ast-node :loop (expression-value $2))))
;; A singleton program.
((:node :eof)
(make-expression :program
(make-ast-node :program (list (expression-value $1)))))
;; A program composed of several statements.
((:node-list :eof)
(make-expression :program
(make-ast-node :program (expression-value $1))))
;; An empty program.
((:eof)
(make-expression :program
(make-ast-node :program NIL))))
(the Parser parser)))
(defstruct (Interpreter
(:constructor make-interpreter (tree))
(:conc-name NIL))
"Evaluates an abstract syntax tree (AST) representation of an HTPF program."
(tree (error "Missing tree.") :type AST-Node :read-only T)
(memory (make-hash-table :test #'eql) :type memory :read-only T)
(cell-pointer 0 :type integer :read-only NIL))
(declaim (ftype (function (Interpreter AST-Node) (values)) visit-node))
(defun get-current-cell (interpreter)
"Returns the byte value stored in the INTERPRETER's current memory cell."
(declare (type Interpreter interpreter))
(the octet (gethash (cell-pointer interpreter) (memory interpreter) 0)))
(defun set-current-cell (interpreter new-value)
"Stores the NEW-VALUE in the INTERPRETER's current memory cell, upon
necessity wrapping its value around into the octet range [0, 255]."
(declare (type Interpreter interpreter))
(declare (type integer new-value))
(setf (gethash (cell-pointer interpreter) (memory interpreter) 0)
(mod new-value 256))
(values))
(defgeneric dispatch-node (interpreter node-type node)
(:documentation "Processes the AST NODE, dispatching on its NODE-TYPE, in
the INTERPRETER's context and returns no value.")
(:method ((interpreter Interpreter) (node-type (eql :move-right)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(incf (cell-pointer interpreter))
(values))
(:method ((interpreter Interpreter) (node-type (eql :move-left)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(decf (cell-pointer interpreter))
(values))
(:method ((interpreter Interpreter) (node-type (eql :increment)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(set-current-cell interpreter
(1+ (get-current-cell interpreter)))
(values))
(:method ((interpreter Interpreter) (node-type (eql :decrement)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(set-current-cell interpreter
(1- (get-current-cell interpreter)))
(values))
(:method ((interpreter Interpreter) (node-type (eql :input)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(format T "~&>> ")
(finish-output)
(set-current-cell interpreter (char-code (read-char)))
(clear-input)
(values))
(:method ((interpreter Interpreter) (node-type (eql :output)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type node))
(write-char (code-char (get-current-cell interpreter)))
(values))
(:method ((interpreter Interpreter) (node-type (eql :loop)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type))
(loop until (zerop (get-current-cell interpreter)) do
(loop for statement of-type AST-Node in (ast-node-argument node) do
(visit-node interpreter statement)))
(values))
(:method ((interpreter Interpreter) (node-type (eql :program)) (node AST-Node))
(declare (type Interpreter interpreter) (type keyword node-type) (type AST-Node node)
(ignore node-type))
(loop for statement of-type AST-Node in (ast-node-argument node) do
(visit-node interpreter statement))
(values)))
(defun visit-node (interpreter node)
"Processes the NODE in the INTERPRETER's context by dispatching on its
``dispatch-node`` method and returns no value."
(declare (type Interpreter interpreter) (type AST-Node node))
(dispatch-node interpreter (ast-node-type node) node)
(values))
(defun interpret-HTPF (code)
"Interprets the piece of HTPF source CODE and returns no value."
(declare (type string code))
(let ((interpreter
(make-interpreter
(parse-program
(make-parser
(make-input-buffer code))))))
(declare (type Interpreter interpreter))
(visit-node interpreter
(tree interpreter)))
(values))