360 lines
15 KiB
Common Lisp
360 lines
15 KiB
Common Lisp
;; parse.lisp -- Proposition string parsing subroutines
|
||
;; Copyright (C) 2024 Alexander Rosenberg
|
||
;;
|
||
;; This program is free software: you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
(in-package :truth-table/base)
|
||
|
||
(defun whitespace-p (char)
|
||
"Return nil unless CHAR is whitespace."
|
||
(member char '(#\newline #\space) :test 'eq))
|
||
|
||
(defun paren-p (char)
|
||
"Return nil unless CHAR is a parenthesis."
|
||
(member char '(#\( #\))))
|
||
|
||
(defun delim-p (char)
|
||
"Return nil unless CHAR is either whitespace or a parenthesis."
|
||
(or (whitespace-p char) (paren-p char)))
|
||
|
||
(defun symbol-char-p (char)
|
||
"Return nil until CHAR is a valid character for use in proposition variable
|
||
names."
|
||
(or (alpha-char-p char) (eq char #\_) (digit-char-p char)))
|
||
|
||
(defun replace-in-string (str chars new-char)
|
||
"Replace all instances of any of CHARS in STR with NEW-CHAR."
|
||
(coerce (loop with lchars = (if (atom chars)
|
||
(list chars)
|
||
chars)
|
||
for char across str
|
||
when (member char lchars)
|
||
collect new-char
|
||
else
|
||
collect char)
|
||
'string))
|
||
|
||
(define-condition proposition-parse-error (error)
|
||
((position :initarg :position
|
||
:accessor parse-error-position
|
||
:initform nil)
|
||
(proposition :initarg :proposition
|
||
:accessor parse-error-proposition
|
||
:initform nil)
|
||
(message :initarg :message
|
||
:accessor parse-error-message
|
||
:initform nil))
|
||
(:report (lambda (con stream)
|
||
(with-slots (position proposition message) con
|
||
(format stream
|
||
"parse error~@[ at column ~d~]~@[: ~a~]~
|
||
~@[:~% ~a~@[~% ~a^~]~]"
|
||
(when position
|
||
(1+ position))
|
||
message
|
||
(when proposition
|
||
(replace-in-string proposition
|
||
'(#\newline #\return)
|
||
#\space))
|
||
(when position
|
||
(make-string position
|
||
:initial-element #\space))))))
|
||
(:documentation "Condition representing an error during parsing of a
|
||
proposition."))
|
||
|
||
(defparameter *operator-symbol-table*
|
||
'((open-paren "(")
|
||
(close-paren ")")
|
||
(and "/\\" "and" "&&" "&" "∧" ".")
|
||
(nand "nand" "↑" "⊼" "~&" "~&&" "!&" "!&&")
|
||
(or "\\/" "or" "||" "|" "∥" "+" "∨")
|
||
(nor "nor" "↓" "⊽" "~|" "~||" "!|" "!||")
|
||
(xor "xor" "⊕" "⊻" "↮" "≢" "^" "!=")
|
||
(not "¬" "~" "!" "not")
|
||
(implies "->" ">" "=>" "⇒" "⟹" "→" "⊃" "implies")
|
||
(converse "<-" "<" "<=" "←" "⇐" "⟸" "⊂" "converse")
|
||
(iff "<->" "<>" "<=>" "⇔" "↔" "≡" "iff" "=" "==" "xnor" "⊙"))
|
||
"Alist table of operator symbols and their possible string representations.")
|
||
|
||
(defun operator-symbol (oper-str)
|
||
"Return the symbol for OPER-STR, or nil if it is not a know operator."
|
||
(loop for (oper-sym . strs) in *operator-symbol-table*
|
||
when (member oper-str strs :test 'equalp)
|
||
do (return oper-sym)))
|
||
|
||
(defun operator-precedence (oper)
|
||
"Return the precedence for OPER."
|
||
(case oper
|
||
(not 1)
|
||
(and 2)
|
||
(implicit-and 2)
|
||
(nand 2)
|
||
(xor 3)
|
||
(or 4)
|
||
(nor 4)
|
||
(implies 5)
|
||
(converse 5)
|
||
(iff 6)
|
||
(open-paren most-positive-fixnum)
|
||
(t nil)))
|
||
|
||
(defun unary-p (oper)
|
||
"Return whether OPER is a unary operator or not."
|
||
(eq oper 'not))
|
||
|
||
(defun interpret-operand (oper-str)
|
||
"Return a symbol representing OPER-STR, or the string itself if it represents
|
||
a variable."
|
||
(cond
|
||
((member oper-str '("t" "true" "⊤" "1") :test 'equalp)
|
||
'true)
|
||
((member oper-str '("f" "false" "⊥" "0") :test 'equalp)
|
||
'false)
|
||
(t
|
||
(loop for char across oper-str
|
||
unless (symbol-char-p char)
|
||
do (return nil)
|
||
finally (return oper-str)))))
|
||
|
||
(defun string-first-char-safe (str)
|
||
"Return the first character of STR, or nil if it is empty."
|
||
(unless (zerop (length str))
|
||
(elt str 0)))
|
||
|
||
(defun next-symbol-token (str &key multi-char-names)
|
||
"Return the next token from STR that is not a paren. If MULTI-CHAR-NAMES is
|
||
non-nil, allow names to be more than one character long."
|
||
(loop with mode = (if (symbol-char-p (elt str 0))
|
||
'alpha
|
||
'sym)
|
||
for char across str
|
||
for chari from 0
|
||
while (or (and (eq mode 'alpha) (symbol-char-p char))
|
||
(and (eq mode 'sym) (not (symbol-char-p char))
|
||
(not (delim-p char))))
|
||
collect char into token
|
||
finally
|
||
(let ((str (coerce token 'string)))
|
||
(return
|
||
(string
|
||
(cond
|
||
;; single character unary operand
|
||
((let ((val (operator-symbol (string (first token)))))
|
||
(and (symbolp val) (unary-p val)))
|
||
(first token))
|
||
;; multi-char variable, constant (true or false), or operator
|
||
((or multi-char-names
|
||
(operator-symbol str)
|
||
(symbolp (interpret-operand str)))
|
||
str)
|
||
;; single letter variable (multi-char-names is off)
|
||
(t (first token))))))))
|
||
|
||
(defun next-token (str &key multi-char-names)
|
||
"Return a list of the next token in STR and how much whitespace it had."
|
||
(let ((whitespace-chars 0))
|
||
(loop for char across str
|
||
while (whitespace-p char) do
|
||
(setq whitespace-chars (1+ whitespace-chars)))
|
||
(setq str (subseq str whitespace-chars))
|
||
(let ((next-char (string-first-char-safe str)))
|
||
(cond
|
||
((not next-char)
|
||
(list nil whitespace-chars))
|
||
((paren-p next-char)
|
||
(list (string next-char) whitespace-chars))
|
||
(t
|
||
(let ((token (next-symbol-token str :multi-char-names multi-char-names)))
|
||
(list token whitespace-chars)))))))
|
||
|
||
(defmacro dotokens ((var pos-var str &optional (retval nil retvalp))
|
||
(&key multi-char-names &allow-other-keys)
|
||
&body body)
|
||
"Execute BODY once with VAR bound to each token in STR. Optionally, return
|
||
RETVAL. The position of each token will be stored in POS-VAR. If
|
||
MULTI-CHAR-NAMES is enabled, allow multiple characters in variable names."
|
||
(let ((stream-var (gensym))
|
||
(token-start-var (gensym))
|
||
(token-var (gensym))
|
||
(read-chars-var (gensym))
|
||
(whitespace-var (gensym)))
|
||
`(loop for ,stream-var = ,str then (subseq ,str ,read-chars-var)
|
||
for (,token-var ,whitespace-var)
|
||
= (next-token ,stream-var :multi-char-names ,multi-char-names)
|
||
for ,token-start-var = ,whitespace-var
|
||
then (+ ,read-chars-var ,whitespace-var)
|
||
for ,read-chars-var = (+ ,whitespace-var (length ,token-var))
|
||
then (+ ,read-chars-var ,whitespace-var (length ,token-var))
|
||
while ,token-var do
|
||
(let ((,var ,token-var)
|
||
(,pos-var ,token-start-var))
|
||
(declare (ignorable ,pos-var))
|
||
,@body)
|
||
finally
|
||
(return ,(when retvalp
|
||
retval)))))
|
||
|
||
(defun interpret-token (token)
|
||
"Return a list of the form (type value), where type is one of: `operator' or
|
||
`operand', and value is the tokens value, as returned by `operator-symbol' or
|
||
`interpret-operand'. If the token is of an unknown type, return a list of (nil
|
||
nil)."
|
||
(let ((operator-value (operator-symbol token)))
|
||
(if operator-value
|
||
(list 'operator operator-value)
|
||
(let ((operand-value (interpret-operand token)))
|
||
(if operand-value
|
||
(list 'operand operand-value)
|
||
(list nil nil))))))
|
||
|
||
(defun parse-proposition-string (prop-str &key (implicit-and t) multi-char-names)
|
||
"Parse PROP-STR, which is a proposition string.
|
||
The return value is the values set of the parsed string, and the list of all
|
||
found variables."
|
||
(let ((found-vars '())
|
||
(operators '())
|
||
(operands '())
|
||
(paren-operands (list 0)))
|
||
(labels ((peek-operator ()
|
||
(destructuring-bind (&optional value . pos) (car operators)
|
||
(values value pos)))
|
||
(pop-operator ()
|
||
(destructuring-bind (&optional value . pos) (pop operators)
|
||
(values value pos)))
|
||
(convert-implicit-and (this-name pos)
|
||
(multiple-value-bind (value top-pos) (peek-operator)
|
||
(when (eq value 'implicit-and)
|
||
(unless implicit-and
|
||
(cerror "Insert implicit AND operator"
|
||
'proposition-parse-error
|
||
:position pos
|
||
:proposition prop-str
|
||
:message
|
||
(format nil "expected binary operator, found ~a"
|
||
this-name)))
|
||
(pop-operator)
|
||
(push (cons 'and top-pos) operators))))
|
||
(apply-one-operator ()
|
||
(multiple-value-bind (oper pos) (pop-operator)
|
||
(when (not oper)
|
||
(error 'proposition-parse-error :message "no more operators"
|
||
:position pos
|
||
:proposition prop-str))
|
||
(let ((oper-args (if (unary-p oper) 1 2))
|
||
(cur-operands (list (pop operands))))
|
||
(when (not (car cur-operands))
|
||
(error 'proposition-parse-error
|
||
:position pos
|
||
:proposition prop-str
|
||
:message
|
||
(format nil "~A expects ~D arguments, found none"
|
||
oper oper-args)))
|
||
(when (= oper-args 2)
|
||
(push (pop operands) cur-operands)
|
||
(when (not (car cur-operands))
|
||
(error 'proposition-parse-error
|
||
:position pos
|
||
:proposition prop-str
|
||
:message
|
||
(format nil "~A expects ~D arguments, found 1"
|
||
oper oper-args))))
|
||
(push (cons oper cur-operands) operands))))
|
||
(apply-lower-precedent (prec)
|
||
(loop for top-oper = (peek-operator)
|
||
while (and top-oper
|
||
(<= (or (operator-precedence top-oper)
|
||
most-positive-fixnum)
|
||
prec)
|
||
(not (unary-p top-oper)))
|
||
do (apply-one-operator)))
|
||
(apply-all-unary ()
|
||
(loop while (unary-p (peek-operator))
|
||
do
|
||
(apply-one-operator)))
|
||
(push-operator (oper token-pos)
|
||
(apply-lower-precedent (operator-precedence oper))
|
||
(push (cons oper token-pos) operators)))
|
||
(dotokens (token-str token-pos prop-str)
|
||
(:multi-char-names multi-char-names)
|
||
(destructuring-bind (type value) (interpret-token token-str)
|
||
(cond
|
||
;; unknown token
|
||
((not type)
|
||
(error 'proposition-parse-error
|
||
:position token-pos
|
||
:proposition prop-str
|
||
:message "unknown token"))
|
||
;; operand
|
||
((eq type 'operand)
|
||
(convert-implicit-and "operand" token-pos)
|
||
(unless (member value '(true false))
|
||
(pushnew value found-vars :test 'equal))
|
||
(push value operands)
|
||
(incf (car paren-operands))
|
||
(apply-all-unary)
|
||
(convert-implicit-and "operand" token-pos)
|
||
(push-operator 'implicit-and token-pos))
|
||
;; open parenthesis
|
||
((eq value 'open-paren)
|
||
(convert-implicit-and "open parenthesis" token-pos)
|
||
(push (cons value token-pos) operators)
|
||
(push 0 paren-operands))
|
||
;; close parenthesis
|
||
((eq value 'close-paren)
|
||
(when (eq (peek-operator) 'implicit-and)
|
||
(pop-operator))
|
||
(loop while (not (eq (peek-operator) 'open-paren))
|
||
when (null operators) do
|
||
(error 'proposition-parse-error
|
||
:position token-pos
|
||
:proposition prop-str
|
||
:message "no matching open parenthesis")
|
||
do (apply-one-operator))
|
||
(when (zerop (pop paren-operands))
|
||
(error 'proposition-parse-error
|
||
;; open paren position
|
||
:position (cdr (pop operators))
|
||
:proposition prop-str
|
||
:message "empty parenthesis"))
|
||
;; remove open paren
|
||
(pop-operator)
|
||
(apply-all-unary)
|
||
(convert-implicit-and "close parenthesis" token-pos)
|
||
(push-operator 'implicit-and token-pos))
|
||
;; operator
|
||
(t
|
||
(if (eq (peek-operator) 'implicit-and)
|
||
(if (unary-p value)
|
||
(convert-implicit-and "unary operator" token-pos)
|
||
(pop-operator))
|
||
(unless (unary-p value)
|
||
(error 'proposition-parse-error
|
||
:position token-pos
|
||
:proposition prop-str
|
||
:message "expected operand, found operator")))
|
||
(push-operator value token-pos)))))
|
||
;; remove implicit-and
|
||
(when (eq 'implicit-and (peek-operator))
|
||
(pop-operator))
|
||
(loop for (top-oper . top-pos) = (car operators)
|
||
while top-oper
|
||
when (eq top-oper 'open-paren) do
|
||
(error 'proposition-parse-error
|
||
:message "no matching closing parenthesis"
|
||
:proposition prop-str
|
||
:position top-pos)
|
||
do
|
||
(apply-one-operator))
|
||
;; return variables in the order we found them
|
||
(values (car operands) (nreverse found-vars)))))
|