Move to new parser
This commit is contained in:
parent
0d9b68a75a
commit
0a73cf3295
31
eval.lisp
31
eval.lisp
@ -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
|
||||||
|
240
parse.lisp
240
parse.lisp
@ -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)))))
|
||||||
|
Loading…
Reference in New Issue
Block a user