Move to new parser

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

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,149 @@ 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)
+                 (format t "Apply: ~a~%" oper)
+                 (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))))
+        (format t "Oper: ~a~%Opan: ~a~%~%" (reverse operators)
+                (reverse operands)))
+      (format t "End main loop ~%~%")
+      ;; 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)
+               (format t "Oper: ~a~%Opan: ~a~%~%" (reverse operators)
+                       (reverse operands)))
       ;; return variables in the order we found them
       (values (car operands) (nreverse found-vars)))))