feat: add pratt parser

.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)