Move to new parser

This commit is contained in:
Alexander Rosenberg 2024-09-06 14:20:13 -07:00
parent 0d9b68a75a
commit 0a73cf3295
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
2 changed files with 143 additions and 128 deletions

View File

@ -29,25 +29,10 @@
(:documentation "Condition representing an error that occurred during (:documentation "Condition representing an error that occurred during
evaluation for a proposition.")) evaluation for a proposition."))
(defun operator-argument-count (oper)
"Return the minimum number of arguments that OPER takes as the first value,
and the maximum number (or nil for infinity) as a second value."
(case oper
(and (values 2 nil))
(or (values 2 nil))
(xor (values 2 nil))
(not (values 1 1))
(implies (values 2 2))
(converse (values 2 2))
(iff (values 2 2))
(nand (values 2 nil))
(nor (values 2 2))
(t (error "unknown operator: ~S" oper))))
(defun logical-xor (&rest args) (defun logical-xor (&rest args)
"Logical xor (not equal) each argument in turn with its following argument. "Logical xor (not equal) each argument in turn with its following argument.
NOTE: This is NOT a macro, so all arguments, so there is no short circuit NOTE: This is NOT a macro, there is no short circuit evaluation (all arguments
evaluation (all arguments are evaluated no matter what)." are evaluated no matter what)."
(loop with result = nil (loop with result = nil
for arg in args do for arg in args do
(setq result (not (eq result arg))) (setq result (not (eq result arg)))
@ -55,21 +40,21 @@ evaluation (all arguments are evaluated no matter what)."
(defun logical-and (&rest args) (defun logical-and (&rest args)
"Logical and (all true). "Logical and (all true).
NOTE: This is NOT a macro, so all arguments, so there is no short circuit NOTE: This is NOT a macro, there is no short circuit evaluation (all arguments
evaluation (all arguments are evaluated no matter what)." are evaluated no matter what)."
(not (member nil args))) (not (member nil args)))
(defun logical-or (&rest args) (defun logical-or (&rest args)
"Logical or (one or more true). "Logical or (one or more true).
NOTE: This is NOT a macro, so all arguments, so there is no short circuit NOTE: This is NOT a macro, so there is no short circuit evaluation (all
evaluation (all arguments are evaluated no matter what)." arguments are evaluated no matter what)."
(not (not (member t args)))) (not (not (member t args))))
(defun logical-implies (prop1 prop2) (defun logical-implies (prop1 prop2)
"Evaluate the logical implies operation on PROP1 and PROP2. That is \"if "Evaluate the logical implies operation on PROP1 and PROP2. That is \"if
PROP1, then PROP2\". PROP1, then PROP2\".
NOTE: This is NOT a macro, so all arguments, so there is no short circuit NOTE: This is NOT a macro, so there is no short circuit evaluation (all
evaluation (all arguments are evaluated no matter what)." arguments are evaluated no matter what)."
(if prop1 ;; only if first is true (if prop1 ;; only if first is true
prop2 ;; eval second prop2 ;; eval second
t)) ;; otherwise, just return true t)) ;; otherwise, just return true

View File

@ -76,9 +76,9 @@ proposition."))
'((open-paren "(") '((open-paren "(")
(close-paren ")") (close-paren ")")
(and "/\\" "and" "&&" "&" "∧" ".") (and "/\\" "and" "&&" "&" "∧" ".")
(nand "nand" "↑" "⊼") (nand "nand" "↑" "⊼" "~&" "~&&" "!&" "!&&")
(or "\\/" "or" "||" "|" "∥" "+" "") (or "\\/" "or" "||" "|" "∥" "+" "")
(nor "nor" "↓" "⊽") (nor "nor" "↓" "⊽" "~|" "~||" "!|" "!||")
(xor "xor" "⊕" "⊻" "↮" "≢" "^" "!=") (xor "xor" "⊕" "⊻" "↮" "≢" "^" "!=")
(not "¬" "~" "!" "not") (not "¬" "~" "!" "not")
(implies "->" ">" "=>" "⇒" "⟹" "→" "⊃" "implies") (implies "->" ">" "=>" "⇒" "⟹" "→" "⊃" "implies")
@ -97,6 +97,7 @@ proposition."))
(case oper (case oper
(not 1) (not 1)
(and 2) (and 2)
(implicit-and 2)
(nand 2) (nand 2)
(xor 3) (xor 3)
(or 4) (or 4)
@ -107,6 +108,27 @@ proposition."))
(open-paren most-positive-fixnum) (open-paren most-positive-fixnum)
(t nil))) (t nil)))
(defun operator-argument-count (oper)
"Return the minimum number of arguments that OPER takes as the first value,
and the maximum number (or nil for infinity) as a second value."
(case oper
(and (values 2 nil))
(or (values 2 nil))
(xor (values 2 nil))
(not (values 1 1))
(implies (values 2 2))
(converse (values 2 2))
(iff (values 2 2))
(nand (values 2 nil))
(nor (values 2 2))
(open-paren (values 0 0))
(t (error "unknown operator: ~S" oper))))
(defun unary-p (oper)
"Return whether OPER is a unary operator or not."
(when oper
(= 1 (operator-argument-count oper))))
(defun interpret-operand (oper-str) (defun interpret-operand (oper-str)
"Return a symbol representing OPER-STR, or the string itself if it represents "Return a symbol representing OPER-STR, or the string itself if it represents
a variable." a variable."
@ -206,135 +228,143 @@ nil)."
(list 'operand operand-value) (list 'operand operand-value)
(list nil nil)))))) (list nil nil))))))
(defun apply-one-operator (operator-stack operand-stack (defun parse-proposition-string (prop-str &key (implicit-and t) multi-char-names)
&optional proposition position) "Parse PROP-STR, which is a proposition string.
"Apply the next operator from OPERATOR-STACK to its operands from
OPERAND-STACK, return the new state of both stacks as values."
(let* ((operator (pop operator-stack)))
(when (not operator)
(error 'proposition-parse-error :message "no more operators"
:position position :proposition proposition))
(let ((oper-args (operator-argument-count operator))
(cur-operands (list (pop operand-stack))))
(when (not (car cur-operands))
(error 'proposition-parse-error
:position position
:proposition proposition
:message (format nil
"operator ~A expects ~D arguments, found none"
operator oper-args)))
(when (= oper-args 2)
(push (pop operand-stack) cur-operands)
(when (not (car cur-operands))
(error 'proposition-parse-error
:position position
:proposition proposition
:message (format nil "operator ~A expects ~D arguments, found 1"
operator oper-args))))
(push (cons operator cur-operands) operand-stack)))
(values operator-stack operand-stack))
(defun apply-lower-precedent (prec operators operands
&optional proposition position)
"Apply all operators with lower precedent than PREC. Return the values of the
new operators and operands stack, as well as the number of operators removed."
(loop with pop-count = 0
while (<= (or (operator-precedence (car operators))
most-positive-fixnum)
prec)
do
(setf (values operators operands)
(apply-one-operator operators operands
proposition position)
pop-count (1+ pop-count))
finally (return (values operators operands pop-count))))
(defun parse-proposition-string (str &key (implicit-and t) multi-char-names)
"Parse STR, which is a proposition string.
The return value is the values set of the parsed string, and the list of all The return value is the values set of the parsed string, and the list of all
found variables." found variables."
(let ((found-vars '()) (let ((found-vars '())
(operators '()) (operators '())
(operands '()) (operands '())
(oper-poses '()) (paren-operands (list 0)))
(last-was-operand nil)) (labels ((peek-operator ()
(flet ((push-operator (value pos) (destructuring-bind (&optional value . pos) (car operators)
(multiple-value-bind (new-oper new-opan pop-count) (values value pos)))
(apply-lower-precedent (operator-precedence value) (pop-operator ()
operators operands str pos) (destructuring-bind (&optional value . pos) (pop operators)
(setq operators new-oper (values value pos)))
operands new-opan) (convert-implicit-and (this-name pos)
(dotimes (i pop-count) (multiple-value-bind (value top-pos) (peek-operator)
(pop oper-poses))) (when (eq value 'implicit-and)
(push value operators) (unless implicit-and
(push pos oper-poses))) (cerror "Insert implicit AND operator"
(dotokens (token token-pos str) '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 (operator-argument-count oper))
(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) (:multi-char-names multi-char-names)
(destructuring-bind (type value) (interpret-token token) (destructuring-bind (type value) (interpret-token token-str)
(cond (cond
;; unknown type ;; unknown token
((not type) ((not type)
(error 'proposition-parse-error (error 'proposition-parse-error
:position token-pos :position token-pos
:proposition str :proposition prop-str
:message "unknown token")) :message "unknown token"))
;; operand ;; operand
((eq type 'operand) ((eq type 'operand)
(when last-was-operand (convert-implicit-and "operand" token-pos)
;; two operands next to each other often means "and" implicitly
(unless implicit-and
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "expected operator, found operand"))
(push-operator 'and token-pos))
(unless (member value '(true false)) (unless (member value '(true false))
(pushnew value found-vars :test 'equal)) (pushnew value found-vars :test 'equal))
(push value operands) (push value operands)
(setq last-was-operand t)) (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) ((eq value 'open-paren)
(when last-was-operand (convert-implicit-and "open parenthesis" token-pos)
;; an open parenthesis directly following an operator is also a (push (cons value token-pos) operators)
;; signal of an implicit "and" (push 0 paren-operands))
(unless implicit-and ;; close parenthesis
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "expected operator, found open parenthesis"))
(push-operator 'and token-pos)
(setq last-was-operand nil))
(push value operators)
(push token-pos oper-poses))
;; close paren doesn't touch `last-was-operand'
((eq value 'close-paren) ((eq value 'close-paren)
(loop while (not (eq (car operators) 'open-paren)) (when (eq (peek-operator) 'implicit-and)
(pop-operator))
(loop while (not (eq (peek-operator) 'open-paren))
when (null operators) do when (null operators) do
(error 'proposition-parse-error (error 'proposition-parse-error
:position token-pos :position token-pos
:proposition str :proposition prop-str
:message "no matching open parenthesis") :message "no matching open parenthesis")
do do (apply-one-operator))
(setf (values operators operands) (when (zerop (pop paren-operands))
(apply-one-operator operators operands (error 'proposition-parse-error
str token-pos)) ;; open paren position
(pop oper-poses)) :position (cdr (pop operators))
;; remove the open-paren :proposition prop-str
(pop operators) :message "empty parenthesis"))
(pop oper-poses)) ;; remove open paren
(pop-operator)
(apply-all-unary)
(convert-implicit-and "close parenthesis" token-pos)
(push-operator 'implicit-and token-pos))
;; operator ;; operator
(t (t
(push-operator value token-pos) (if (eq (peek-operator) 'implicit-and)
(setq last-was-operand nil))))) (if (unary-p value)
(loop while operators (convert-implicit-and "unary operator" token-pos)
for oper-pos = (pop oper-poses) (pop-operator))
when (eq (car operators) 'open-paren) do (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 (error 'proposition-parse-error
:message "no matching closing parenthesis" :message "no matching closing parenthesis"
:proposition str :proposition prop-str
:position oper-pos) :position top-pos)
do do
(setf (values operators operands) (apply-one-operator))
(apply-one-operator operators operands
str oper-pos)))
;; return variables in the order we found them ;; return variables in the order we found them
(values (car operands) (nreverse found-vars))))) (values (car operands) (nreverse found-vars)))))