diff --git a/eval.lisp b/eval.lisp index 75022a7..13f1058 100644 --- a/eval.lisp +++ b/eval.lisp @@ -29,25 +29,10 @@ (:documentation "Condition representing an error that occurred during 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) "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 -evaluation (all arguments are evaluated no matter what)." +NOTE: This is NOT a macro, there is no short circuit evaluation (all arguments +are evaluated no matter what)." (loop with result = nil for arg in args do (setq result (not (eq result arg))) @@ -55,21 +40,21 @@ evaluation (all arguments are evaluated no matter what)." (defun logical-and (&rest args) "Logical and (all true). -NOTE: This is NOT a macro, so all arguments, so there is no short circuit -evaluation (all arguments are evaluated no matter what)." +NOTE: This is NOT a macro, there is no short circuit evaluation (all arguments +are evaluated no matter what)." (not (member nil args))) (defun logical-or (&rest args) "Logical or (one or more true). -NOTE: This is NOT a macro, so all arguments, so there is no short circuit -evaluation (all arguments are evaluated no matter what)." +NOTE: This is NOT a macro, so there is no short circuit evaluation (all +arguments are evaluated no matter what)." (not (not (member t args)))) (defun logical-implies (prop1 prop2) "Evaluate the logical implies operation on PROP1 and PROP2. That is \"if PROP1, then PROP2\". -NOTE: This is NOT a macro, so all arguments, so there is no short circuit -evaluation (all arguments are evaluated no matter what)." +NOTE: This is NOT a macro, so there is no short circuit evaluation (all +arguments are evaluated no matter what)." (if prop1 ;; only if first is true prop2 ;; eval second t)) ;; otherwise, just return true diff --git a/parse.lisp b/parse.lisp index 22cfe1c..5226c3b 100644 --- a/parse.lisp +++ b/parse.lisp @@ -76,9 +76,9 @@ proposition.")) '((open-paren "(") (close-paren ")") (and "/\\" "and" "&&" "&" "∧" ".") - (nand "nand" "↑" "⊼") + (nand "nand" "↑" "⊼" "~&" "~&&" "!&" "!&&") (or "\\/" "or" "||" "|" "∥" "+" "∨") - (nor "nor" "↓" "⊽") + (nor "nor" "↓" "⊽" "~|" "~||" "!|" "!||") (xor "xor" "⊕" "⊻" "↮" "≢" "^" "!=") (not "¬" "~" "!" "not") (implies "->" ">" "=>" "⇒" "⟹" "→" "⊃" "implies") @@ -97,6 +97,7 @@ proposition.")) (case oper (not 1) (and 2) + (implicit-and 2) (nand 2) (xor 3) (or 4) @@ -107,6 +108,27 @@ proposition.")) (open-paren most-positive-fixnum) (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) "Return a symbol representing OPER-STR, or the string itself if it represents a variable." @@ -206,135 +228,143 @@ nil)." (list 'operand operand-value) (list nil nil)))))) -(defun apply-one-operator (operator-stack operand-stack - &optional proposition position) - "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. +(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 '()) - (oper-poses '()) - (last-was-operand nil)) - (flet ((push-operator (value pos) - (multiple-value-bind (new-oper new-opan pop-count) - (apply-lower-precedent (operator-precedence value) - operators operands str pos) - (setq operators new-oper - operands new-opan) - (dotimes (i pop-count) - (pop oper-poses))) - (push value operators) - (push pos oper-poses))) - (dotokens (token token-pos str) + (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 (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) - (destructuring-bind (type value) (interpret-token token) + (destructuring-bind (type value) (interpret-token token-str) (cond - ;; unknown type + ;; unknown token ((not type) (error 'proposition-parse-error :position token-pos - :proposition str + :proposition prop-str :message "unknown token")) ;; operand ((eq type 'operand) - (when last-was-operand - ;; 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)) + (convert-implicit-and "operand" token-pos) (unless (member value '(true false)) (pushnew value found-vars :test 'equal)) (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) - (when last-was-operand - ;; an open parenthesis directly following an operator is also a - ;; signal of an implicit "and" - (unless implicit-and - (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' + (convert-implicit-and "open parenthesis" token-pos) + (push (cons value token-pos) operators) + (push 0 paren-operands)) + ;; close parenthesis ((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 (error 'proposition-parse-error :position token-pos - :proposition str + :proposition prop-str :message "no matching open parenthesis") - do - (setf (values operators operands) - (apply-one-operator operators operands - str token-pos)) - (pop oper-poses)) - ;; remove the open-paren - (pop operators) - (pop oper-poses)) + 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 - (push-operator value token-pos) - (setq last-was-operand nil))))) - (loop while operators - for oper-pos = (pop oper-poses) - when (eq (car operators) 'open-paren) do + (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 str - :position oper-pos) + :proposition prop-str + :position top-pos) do - (setf (values operators operands) - (apply-one-operator operators operands - str oper-pos))) + (apply-one-operator)) ;; return variables in the order we found them (values (car operands) (nreverse found-vars)))))