Merge pull request #31 from ryukinix/pratt-parser

feat: add pratt parser

Author: ryukinix

.github/workflows/deploy.yml

@@ -0,0 +1,15 @@
+
+name: Deploy
+
+on:
+  push:
+    branches:
+      - master
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+      - name: Run docker publish
+        run: make docker-publish

.github/workflows/main.yml

@@ -0,0 +1,12 @@
+
+name: CI
+
+on: [pull_request]
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+      - name: Run docker check
+        run: make docker-check

Makefile

@@ -1,7 +1,8 @@
 SBCL_CMD := sbcl --noinform --disable-debugger --load
 OBJECTS := lisp-inference
 DOCKER_IMG = lisp-inference
-PUBLIC_IMG = ryukinix/$(DOCKER_IMG)
+VERSION := latest
+PUBLIC_IMG = ryukinix/$(DOCKER_IMG):$(VERSION)
 
 all: $(OBJECTS)
 
@@ -20,14 +21,14 @@ server:
 docker-build:
 	docker build -t $(DOCKER_IMG) .
 
-docker-run:
+docker-run: docker-build
 	docker run --rm -it --network=host $(DOCKER_IMG)
 
-docker-check:
+docker-check: docker-build
 	docker run --rm -t --entrypoint=ros $(DOCKER_IMG) run -s lisp-inference/test -l run-test.lisp
 
-docker-publish:
+docker-publish: docker-build
 	docker tag $(DOCKER_IMG) $(PUBLIC_IMG)
 	docker push $(PUBLIC_IMG)
 
-.PHONY: check
+.PHONY: check docker-build

fix-quicklisp.lisp

@@ -1,3 +1,10 @@
 (eval-when (:load-toplevel :execute)
   (pushnew (truename (sb-unix:posix-getcwd/)) ql:*local-project-directories* )
-  (ql:register-local-projects))
+  (ql:register-local-projects)
+
+  ;; install ultralisp if necessary
+  (unless (member "ultralisp" (ql-dist:all-dists)
+                  :key 'ql-dist:name
+                  :test 'string=)
+    (ql-dist:install-dist "http://dist.ultralisp.org/"
+                          :prompt nil)))

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"
@@ -30,6 +31,7 @@
   :depends-on (:lisp-inference
                :weblocks
                :weblocks-ui
+               :clack-handler-hunchentoot
                :find-port
                :str)
   :pathname "web"

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,78 @@
+(in-package :lisp-inference)
+
+(defparameter *binding-precedence*
+  '(
+    ("^" . 80)
+    ("v" . 70)
+    ("[+]" . 60)
+    ("=>" . 50)
+    ("->" . 50)
+    ("<=>" . 40)
+    ("<->" . 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

@@ -22,8 +22,7 @@
 (defvar *proposition* "P => Q" "Default proposition")
 (defvar *port* (find-port:find-port))
 (defvar *notes*
-  '("My lexer doesn't work very well with parenthesis."
-    "Please, don't be evil. Use less than 10 variables."
+  '("Please, don't be evil. Use less than 10 variables."
     "Yes, [+] it's a XOR. Mathematically: p ⊕ q."
     "(=> ->) and (<=> <->) are aliases."))
 
@@ -40,35 +39,23 @@
     :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 (inference:parse-logic exp)))))
 
-(defun create-table (exp)
+(defun create-table (exp-string)
   (make-instance 'table
-                 :prop (format nil "~a" exp)
-                 :truth (truth-table exp)))
+                 :prop exp-string
+                 :truth (truth-table exp-string)))
 
 (defgeneric update-table (table exp))
 
-(defmethod update-table (table (exp list))
-  (setf (prop table) (format nil "~a" exp))
+(defmethod update-table (table (exp string))
+  (setf (prop table) exp)
   (setf (truth table) (truth-table exp))
   (update table))
 
-(defmethod update-table (table (exp string))
-  (update-table
-   table
-   (parse-string exp)))
-
 (defmethod render ((table table))
   (with-html
     (:h1 :align "center" "Lisp Inference Truth Table System")
@@ -100,7 +87,7 @@
 
 (defmethod weblocks/session:init ((app truth-table))
   (declare (ignorable app))
-  (create-table (parse-string *proposition*)))
+  (create-table *proposition*))
 
 (defun start (&optional (port *port*))
   (weblocks/debug:on)