Merge pull request #15 from ryukinix/webapp

Add lisp-inference/web system

Author: ryukinix

lisp-inference.asd

@@ -21,6 +21,20 @@
                (:file "truth-table"
                 :depends-on ("parser" "operators" "equivalences"))))
 
+(asdf:defsystem #:lisp-inference/web
+  :description "An web interface for Lisp Inference Truth Table"
+  :author "Manoel Vilela <[email protected]>"
+  :license "BSD"
+  :version "0.2.0"
+  :serial t
+  :depends-on (:lisp-inference
+               :weblocks
+               :weblocks-ui
+               :find-port
+               :str)
+  :pathname "web"
+  :components ((:file "webapp")))
+
 (asdf:defsystem #:lisp-inference/test
   :description "Lisp Inference Test Suit"
   :author "Manoel Vilela <[email protected]>"

roswell/inference-server.ros

@@ -0,0 +1,49 @@
+#!/bin/sh
+#|-*- mode:lisp -*-|#
+#|
+exec ros -Q -- $0 "$@"
+|#
+
+#+quicklisp (defun ensure-dist-installed (dist nick)
+              (let ((d (ql-dist:find-dist nick)))
+                (when (not (and d (ql-dist:installedp d)))
+                 (ql-dist:install-dist dist
+                                       :prompt nil))))
+
+(progn ;;init forms
+  (ros:ensure-asdf)
+  #+quicklisp (progn
+                (ensure-dist-installed "http://dist.ultralisp.org" "ultralisp")
+                (ql:quickload '(lisp-inference/web)))
+
+  )
+
+(defpackage :ros.script.lisp-inference/web
+  (:use :cl))
+(in-package :ros.script.lisp-inference/web)
+
+(defparameter *port* lisp-inference/web:*port*)
+
+(defun main (&rest argv)
+  (declare (ignorable argv))
+  (when (car argv)
+    (setq *port* (parse-integer (car argv))))
+  (unwind-protect
+       (handler-case
+           (progn
+             (format t "[+] Starting Lisp Inference server...~%")
+             (lisp-inference/web:start *port*)
+             (format t "[+] http://127.0.0.1:~a~%" *port*)
+             (format t "[+] Press C-c to kill Lisp Inference server...~%")
+             (loop do (sleep 10)))
+         (#+sbcl sb-sys:interactive-interrupt
+          #+ccl  ccl:interrupt-signal-condition
+          #+clisp system::simple-interrupt-condition
+          #+ecl ext:interactive-interrupt
+          #+allegro excl:interrupt-signal
+          () (progn
+               (format *error-output* "Aborting.~&")
+               (lisp-inference/web:stop)
+               (uiop:quit))))
+    (lisp-inference/web:stop)))
+;;; vim: set ft=lisp lisp:

web/webapp.lisp

@@ -0,0 +1,90 @@
+(defpackage lisp-inference/web
+  (:use #:cl
+        #:weblocks-ui/form
+        #:weblocks/html)
+  (:import-from #:weblocks/widget
+                #:render
+                #:update
+                #:defwidget)
+  (:import-from #:weblocks/actions
+                #:make-js-action)
+  (:import-from #:weblocks/app
+                #:defapp)
+  (:export #:start
+           #:stop
+           #:*propostion*
+           #:*port*)
+  (:nicknames #:webapp))
+
+(in-package lisp-inference/web)
+
+(defvar *proposition* '(P => Q) "Default proposition")
+(defvar *port* (find-port:find-port))
+
+(defapp truth-table
+  :prefix "/"
+  :description "Lisp Inference Truth Table")
+
+(defwidget table ()
+  ((prop
+    :initarg :prop
+    :accessor prop)
+   (truth
+    :initarg :truth
+    :initform nil
+    :accessor truth)))
+
+(defun truth-table (exp)
+  (with-output-to-string (s)
+    (let ((inference:*output-stream* s))
+      (inference:print-truth-table (inference:infix-to-prefix exp)))))
+
+(defun create-table (exp)
+  (make-instance 'table
+                 :prop (format nil "~a" exp)
+                 :truth (truth-table exp)))
+
+(defun update-table (table exp)
+  (setf (prop table) (format nil "~a" exp))
+  (setf (truth table) (truth-table exp)))
+
+(defgeneric update-proposition (table exp))
+
+(defmethod update-proposition (table (exp list))
+  (update-table table exp)
+  (update table))
+
+(defmethod update-proposition (table (string string))
+  (update-proposition
+    table
+    (mapcar (lambda (x)
+              (intern (string-upcase x)))
+            (str:words (string-trim '(#\( #\)) string)))))
+
+(defmethod render ((table table))
+  (with-html
+    (:h1 "Lisp Inference Truth Table System")
+    (with-html-form (:POST (lambda (&key prop &allow-other-keys)
+                             (update-proposition table prop)))
+      (:input :type "text"
+              :name "prop"
+              :placeholder (prop table))
+      (:input :type "submit"
+              :value "Eval"))
+    (:pre (truth table))))
+
+(defmethod render ((string string))
+  (with-html
+    (:pre string)))
+
+(defmethod weblocks/session:init ((app truth-table))
+  (declare (ignorable app))
+  (create-table *proposition*))
+
+(defun start (&optional (port *port*))
+  (weblocks/debug:on)
+  (weblocks/server:stop)
+  (weblocks/server:start :port port))
+
+(defun stop ()
+  (weblocks/server:stop))