feat: add pratt parser

Author: ryukinix

lisp-inference.asd

@@ -14,12 +14,13 @@
   :components ((:file "package")
                (:file "operators")
                (:file "parser")
+               (:file "pratt")
                (:file "equivalences"
                 :depends-on ("parser" "operators"))
                (:file "inferences"
                 :depends-on ("parser" "operators"))
                (:file "truth-table"
-                :depends-on ("parser" "operators" "equivalences"))))
+                :depends-on ("pratt" "parser" "operators" "equivalences"))))
 
 (asdf:defsystem #:lisp-inference/web
   :description "An web interface for Lisp Inference Truth Table"

src/package.lisp

@@ -15,6 +15,7 @@
            #:simplification-first
            #:simplification-second
            #:syllogism-hypothetical
+           #:parse-logic ;; pratt
            #:absorption     ;; parser
            #:propositionp
            #:operationp

src/pratt.lisp

@@ -0,0 +1,76 @@
+(in-package :lisp-inference)
+
+(defparameter *binding-precedence*
+  '(
+    ("^" . 80) 
+    ("v" . 70)
+    ("[+]" . 60) 
+    ("=>" . 50)
+    ("<=>" . 40)))
+
+(defvar *tokens* nil)
+(defvar *pos* 0)
+
+
+(defun read-token (stream)
+  (cond
+    ((peek-char nil stream nil nil)
+     (let ((c (peek-char nil stream)))
+       (cond
+         ((find c "()") (list (string (read-char stream))))
+         ((char= c #\~) (list (string (read-char stream))))
+         ((member c '(#\Space #\Tab #\Newline)) (read-char stream) (read-token stream))
+         ((alpha-char-p c)
+          (let ((sym (read stream)))
+                      (list (string-downcase (string sym)))))
+         (t
+          (let ((token (with-output-to-string (out)
+                         (loop for ch = (peek-char nil stream nil nil)
+                               while (and ch (find ch "<=>[+]"))
+                               do (write-char (read-char stream) out)))))
+            (if (string= token "") (list (string (read-char stream))) (list token)))))))))
+
+(defun tokenize (input)
+  (with-input-from-string (in input)
+    (loop for token = (read-token in)
+          while token
+          append token)))
+
+(defun next-token () 
+  (nth *pos* *tokens*))
+
+(defun advance () 
+  (prog1 (next-token) (incf *pos*)))
+
+(defun match (tok)
+  (when (equal (next-token) tok) (advance) t))
+
+(defun get-binding (tok)
+  (or (cdr (assoc tok *binding-precedence* :test #'string=)) 0))
+
+(defun nud (token)
+  (cond
+    ((string= token "~") `(~ ,(parse-expression 90)))
+    ((string= token "(")
+     (prog1 (parse-expression) (match ")")))
+    (t (intern (string-upcase token)))))
+
+(defun led (token left)
+  (let ((right (parse-expression
+                (if (member token '("=>" "<=>") :test #'string=)
+                    (1- (get-binding token)) ;; Right-associative
+                    (get-binding token)))))
+    (list (intern (string-upcase token)) left right)))
+
+(defun parse-expression (&optional (rbp 0))
+  (let* ((token (advance))
+         (left (nud token)))
+    (loop while (and (next-token) (< rbp (get-binding (next-token))))
+          do (setf left (led (advance) left)))
+    left))
+
+;; entrypoint
+(defun parse-logic (input)
+  (setf *tokens* (tokenize input)
+        *pos* 0)
+  (parse-expression))

src/truth-table.lisp

@@ -203,6 +203,7 @@ a tautology."
   "A easy way to generate a truth table"
   `(print-truth-table (quote ,exp)))
 
+;; TODO: implement a pratt parser
 (defmacro truth-infix (exp)
   "A easy and infix way of EXP generate a truth table.
    Ex.: (truth-infix (p ^ q)) "
@@ -212,9 +213,9 @@ a tautology."
 (defun main ()
   (format t "Example of usage: (p ^ q)~%Operators: ~a ~%" *valid-operators*)
   (let ((*output-stream* *standard-output*))
-   (handler-case (loop do (princ-n "TRUTH-TABLE> ")
+    (handler-case (loop do (princ-n "TRUTH-TABLE> ")
                        do (force-output *output-stream*)
-                       do (print-truth-table (infix-to-prefix (read))))
+                       do (print-truth-table (parse-logic (read-line))))
      (end-of-file () )
      #+sbcl (sb-sys:interactive-interrupt () nil))
 

web/webapp.lisp

@@ -40,17 +40,10 @@
     :initform nil
     :accessor truth)))
 
-(defun parse-string (string)
-  "Translate string to a list expression"
-  (if (and (str:starts-with-p "(" string)
-           (str:ends-with-p ")" string))
-      (read-from-string string)
-      (read-from-string (str:concat "(" string ")"))))
-
 (defun truth-table (exp)
   (with-output-to-string (s)
     (let ((inference:*output-stream* s))
-      (inference:print-truth-table (inference:infix-to-prefix exp)))))
+      (inference:print-truth-table exp))))
 
 (defun create-table (exp)
   (make-instance 'table
@@ -61,13 +54,13 @@
 
 (defmethod update-table (table (exp list))
   (setf (prop table) (format nil "~a" exp))
-  (setf (truth table) (truth-table exp))
+  (setf (truth table) (truth-table exp)
   (update table))
 
 (defmethod update-table (table (exp string))
   (update-table
    table
-   (parse-string exp)))
+   (inference:parse-logic exp)))
 
 (defmethod render ((table table))
   (with-html