Zander671/truth-table
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make web server

Browse Source
This commit is contained in:
Alexander Rosenberg 2024-09-05 14:46:05 -07:00
parent 9e35fed164
commit c6cadc3123
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
11 changed files with 525 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
Makefile
View File

@ -1,20 +1,16 @@
LISP ?= sbcl
SBCL ?= sbcl
BASE_FILES=packages.lisp parse.lisp table.lisp typeset.lisp eval.lisp
BASE_FILES=base-packages.lisp parse.lisp table.lisp typeset.lisp eval.lisp \
arguments.lisp
CLI_FILES=cli.lisp
WEB_FILES=web.lisp
all: cli web
all: cli
cli: truth-table
truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES)
$(LISP) --load build.lisp --eval '(cli)'
web: truth-table-webserver
truth-table-webserver: build.lisp truth-table.asd $(BASE_FILES) $(WEB_FILES)
$(LISP) --load build.lisp --eval '(web)'
$(SBCL) --load build.lisp --eval '(cli)'
clean:
rm -f truth-table truth-table-webserver
rm -f truth-table
.PHONY: all cli clean

8
arguments.lisp
View File

@ -130,7 +130,8 @@ arguments will be placed in a list at the beginning of the alist."
finally (setf output-other (nconc (nreverse rest) output-other)))
(cons (nreverse output-other) output-opts)))
(defun print-usage (stream spec exec-name &optional general-args)
(defun print-usage (stream spec exec-name &key general-args
(print-astrisk t))
"Print the command line usage corresponding to SPEC to STREAM."
(format stream "usage: ~a [options]~@[ ~a~]~%~%" exec-name general-args)
(loop with longest-option
@ -149,8 +150,9 @@ arguments will be placed in a list at the beginning of the alist."
(format stream " ~v@<~@[-~c~]~@[, ~*~]~@[--~a~]~@[=<arg>~*~]~> ~a~%"
longest-option
short (or short long) long has-arg-p desc))
(format stream "~%The choice surrounded by '*' is the default. Arguments to long
options are also required for their short variant.~%"))
(format stream
"~%~@[The choice surrounded by '*' is the default. ~]Arguments to long~:[ ~;~%~]~
options are also required for their short variant.~%" print-astrisk print-astrisk))
(defun option-value (opt opts)
"Get the value of command line option OPT from OTPS, which is an alist as

15
packages.lisp → base-packages.lisp
View File

@ -41,6 +41,7 @@
#:latex-var-name-transform
#:typeset-proposition
#:convert-truth-table-to-latex
#:convert-truth-table-to-html
#:*table-border-ascii-alist*
#:*table-border-unicode-alist*
#:typeset-truth-table
@ -56,16 +57,6 @@
#:unknown-option-error
#:option-no-arg-error
#:no-input-error
#:parse-command-line
#:print-usage
#:option-value))
(defpackage #:truth-table/cli
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main))
(defpackage #:truth-table/web
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main))
#:option-value
#:parse-command-line))

15
build.lisp
View File

@ -1,15 +1,14 @@
;; This file should be run as follows:
;; sbcl --load build.lisp --eval '(<BUILD FUNCTION>)'
;; sbcl --load build.lisp --eval '(cli)'
;; where <BUILD FUNCTION> is either `cli' or `web'
#-sbcl (error "Only SBCL is supported right now")
(sb-ext:disable-debugger)
(require :asdf)
(defun cli ()
"Build the CLI application executable."
(sb-ext:disable-debugger)
(asdf:load-system :truth-table/cli)
(require :truth-table/cli)
(sb-ext:save-lisp-and-die
@ -17,13 +16,3 @@
:executable t
:save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/cli)))
(defun web ()
"Build the web server executable."
(asdf:load-system :truth-table/web)
(require :truth-table/web)
(sb-ext:save-lisp-and-die
"truth-table-webserver"
:executable t
:save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/web)))

12
cli.lisp
View File

@ -13,6 +13,11 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:truth-table/cli
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main))
(in-package :truth-table/cli)
(defun eval-and-typeset-propositions (prop-strs &key (format "unicode")
@ -43,7 +48,8 @@ functions involved in evaluating and typesetting."
(defparameter *command-line-spec*
'((#\h "help" help nil "print this message, then exit")
(#\f "format" format t "specify the output format (*unicode*, ascii, or latex)")
(#\f "format" format t
"specify the output format (*unicode*, ascii, latex, or html)")
(#\s "subexps" subexps nil "include sub-expressions in the output table")
(#\n "no-vars" no-vars nil "do not include variables in the output table")
(#\m "multi-char" multi-char nil "allow multi-character variable names")
@ -70,8 +76,8 @@ arguments."
(parse-command-line *command-line-spec* argv)
(cond
((option-value 'help opts)
(print-usage t *command-line-spec*
"truth-table" "<propositions...>")
(print-usage t *command-line-spec* "truth-table"
:general-args "<propositions...>")
(uiop:quit (if cmdline-error 1 0)))
((null prop-strs)
(cerror *cli-parse-continue-string* 'no-input-error))

44
parse.lisp
View File

@ -258,6 +258,16 @@ found variables."
(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)
(:multi-char-names multi-char-names)
(destructuring-bind (type value) (interpret-token token)
@ -277,23 +287,25 @@ found variables."
:position token-pos
:proposition str
:message "expected operator, found operand"))
(multiple-value-bind (new-oper new-opan pop-count)
(apply-lower-precedent (operator-precedence 'and)
operators operands str token-pos)
(setq operators new-oper
operands new-opan)
(dotimes (i pop-count)
(pop oper-poses)))
(push 'and operators)
(push token-pos oper-poses))
(push-operator 'and token-pos))
(unless (member value '(true false))
(pushnew value found-vars :test 'equal))
(push value operands)
(setq last-was-operand t))
;; open and close paren don't touch `last-was-operand'
((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'
((eq value 'close-paren)
(loop while (not (eq (car operators) 'open-paren))
when (null operators) do
@ -311,15 +323,7 @@ found variables."
(pop oper-poses))
;; operator
(t
(multiple-value-bind (new-oper new-opan pop-count)
(apply-lower-precedent (operator-precedence value)
operators operands str token-pos)
(setq operators new-oper
operands new-opan)
(dotimes (i pop-count)
(pop oper-poses)))
(push value operators)
(push token-pos oper-poses)
(push-operator value token-pos)
(setq last-was-operand nil)))))
(loop while operators
for oper-pos = (pop oper-poses)
@ -333,4 +337,4 @@ found variables."
(apply-one-operator operators operands
str oper-pos)))
;; return variables in the order we found them
(values (car operands) (nreverse found-vars))))
(values (car operands) (nreverse found-vars)))))

29
table.lisp
View File

@ -15,13 +15,18 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(in-package :truth-table/base)
(defun flatten-tree (tree)
"Flatten TREE into a single list."
(if (atom tree)
(list tree)
(apply 'append (mapcar 'flatten-tree tree))))
(defun discover-variables (prop)
"Return a list of all the variables in PROP, in left to right order."
(cond
((stringp prop)
(list prop))
((listp prop)
(mapcan 'discover-variables (cdr prop)))))
(let ((vars))
(dolist (item (flatten-tree prop) (nreverse vars))
(when (stringp item)
(pushnew item vars :test 'equal)))))
(defun permute-variables (vars)
"Return a list of alists, each with a different permutation of VARS."
@ -38,17 +43,21 @@
"Evaluate PROP with all possible combinations of truth values for its
variables. If supplied VARS should be a list of all the know variables in PORP,
if it is excluded, `discover-variables' will be used to generate it."
(if (null vars)
(list (list (cons prop (eval-proposition prop '()))))
(cond
((null prop)
(list (list (cons nil nil))))
((null vars)
(list (list (cons prop (eval-proposition prop '())))))
(t
(loop for perm in (permute-variables vars)
for (value sub-map) = (multiple-value-list
(eval-proposition prop perm))
collect
(append (when include-vars perm)
(when include-intermediate
(delete-if (lambda (item) (equal prop (car item)))
sub-map))
(list (cons prop value))))))
(reverse (delete-if (lambda (item) (equal prop (car item)))
sub-map)))
(list (cons prop value)))))))
(defun extract-truth-table-expressions (table)
"Extract each expression from TABLE and return them as a list.

5
truth-table-web-wrapper Executable file
View File

@ -0,0 +1,5 @@
#!/bin/sh
exec sbcl --noinform \
--eval '(asdf:load-system :truth-table/web)' \
--eval '(truth-table/web:toplevel)' "${@}"

12
truth-table.asd
View File

@ -9,7 +9,7 @@
:depends-on ()
:serial t
:components
((:file "packages")
((:file "base-packages")
(:file "parse")
(:file "eval")
(:file "table")
@ -19,7 +19,7 @@
:depends-on (#:uiop)
:serial t
:components
((:file "packages")
((:file "base-packages")
(:file "arguments")))
(defsystem #:truth-table/cli
@ -29,17 +29,15 @@
#:truth-table/args)
:serial t
:components
((:file "packages")
(:file "cli")))
((:file "cli")))
(defsystem #:truth-table/web
:depends-on (#:uiop
#:with-user-abort
#:reblocks
#:reblocks-ui
#:reblocks-lass
#:truth-table/base
#:truth-table/args)
:serial t
:components
((:file "packages")
(:file "web")))
((:file "web")))

62
typeset.lisp
View File

@ -71,6 +71,22 @@
(false . "\\bot"))
"Lookup table mapping operators to their LaTeX representation.")
(defparameter *operator-html-lookup-alist*
'((and . "&and;")
(nand . "&uarr;")
(or . "&or;")
(nor . "&darr;")
(xor . "&oplus;")
(not . "&not;")
(implies . "&rarr;")
(converse . "&larr;")
(iff . "&harr;")
(open-paren . "(")
(close-paren . ")")
(true . "&top;")
(false . "&perp;"))
"Lookup table mapping operators to their HTML representation.")
(defun latex-var-name-transform (name)
"Transform NAME so that it is escaped for use in LaTeX."
(format nil "{~{~A~}}" (loop for char across name
@ -83,6 +99,16 @@
else
collect char)))
(defun html-var-name-transform (name)
"Transform NAME so that it is escaped for use in HTML."
(format nil "~{~A~}" (loop for char across name
if (eq char #\<)
collect "&lt;"
else if (eq char #\>)
collect "&gt;"
else
collect char)))
(defun typeset-proposition (expr &optional
(lookup-table *operator-ascii-lookup-alist*)
var-name-transform
@ -93,6 +119,9 @@ be a table mapping operators to their textual representation. VAR-NAME-TRANSFORM
escape it for use in the target typesetting system. PARENT-PERC is for internal
use (it controls when parentheses are applied.)"
(cond
;; expr is empty
((null expr)
"")
;; expr is a variable name
((stringp expr)
(if var-name-transform
@ -154,6 +183,35 @@ between each row."
typeset-exprs
(extract-truth-table-values table))))
(defun format-html-properties-alist (props)
"Format PROPS, a list of conses, as a list of HTML properties."
(loop for (name . value) in props
when (eq value t)
collect (format nil "~A=\"\"" name)
else when value
collect (format nil "~A=~S" name (princ-to-string value))))
(defun convert-truth-table-to-html (table &key class id more-props)
"Convert TABLE, which should be a truth table as returned by
`create-truth-table' to HTML. CLASS and ID are their respective HTML
properties. MORE-PROPS is an alist mapping properties to values.
NOTE: though the overall order does not matter, the order must be the same
between each row."
(let ((typeset-exprs (mapcar (lambda (expr)
(typeset-proposition
expr *operator-html-lookup-alist*
'html-var-name-transform))
(extract-truth-table-expressions table))))
(format nil "~
<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~
<tr>~{<th>~A</th>~}</tr>~
~{<tr>~{<td>~:[&perp;~;&top;~]</td>~}</tr>~}~
</table>"
class id (format-html-properties-alist more-props)
typeset-exprs
(extract-truth-table-values table))))
(defparameter *table-border-ascii-alist*
'((vertical . #\|)
(horizontal . #\-)
@ -255,7 +313,7 @@ between each row."
(cdr (assoc 'bottom-right box-lookup-table))))))
(defparameter *known-formats*
'("unicode" "ascii" "latex")
'("unicode" "ascii" "latex" "html")
"The known formats that `typeset-table-to-format' can take.")
(defun typeset-table-to-format (table format)
@ -269,4 +327,6 @@ between each row."
*table-border-ascii-alist*))
((equal format "latex")
(convert-truth-table-to-latex table))
((equal format "html")
(convert-truth-table-to-html table))
(t (error 'table-format-error :format format))))

335
web.lisp
View File

@ -13,18 +13,341 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:truth-table/web
(:use #:common-lisp #:truth-table/base
#:truth-table/args)
(:export #:toplevel #:main)
(:import-from #:reblocks/app
#:defapp)
(:import-from #:reblocks/html
#:with-html)
(:import-from #:reblocks/widget
#:defwidget
#:update
#:render)
(:import-from #:reblocks-ui/form
#:with-html-form)
(:import-from #:reblocks/actions
#:make-js-action)
(:import-from #:reblocks/dependencies
#:get-dependencies))
(in-package :truth-table/web)
(defparameter *default-port* 8000)
(defparameter *default-address* "127.0.0.1")
(defwidget truth-table ()
((data :initform nil
:accessor truth-table-data)
(format :initform "html"
:accessor truth-table-format)
(output-visible :initform t
:accessor truth-table-output-visible))
(:documentation "Class to hold the generated table."))
(defmethod truth-table-toggle-output ((table truth-table))
"Toggle the visibility of the output box of TABLE."
(with-slots (output-visible) table
(setf output-visible (not output-visible))))
(defparameter *blank-hash-table* (make-hash-table)
"Blank hash table to pass to make-js-action because of what seems to be a
reblocks bug.")
(defmethod render ((table truth-table))
"Render TABLE."
(with-slots (data format output-visible) table
(let* ((html-text (convert-truth-table-to-html data))
(other-text
(when output-visible
(if (equal format "html")
html-text
(typeset-table-to-format data format)))))
(when data
(with-html
(:div :class "label" "Output:")
(:span :id "output-span"
;; there seems to be a bug in reblocks that means you have to pass
;; the second argument to `make-js-action'
(:button :onclick (make-js-action
(lambda (&key &allow-other-keys)
(truth-table-toggle-output table)
(update table))
:args *blank-hash-table*)
:id "output-expander-button"
(if output-visible
"⏷"
"⏵"))
(if (or (equal format "ascii")
(equal format "unicode"))
(:pre :id "output-area" :hidden (not output-visible)
other-text)
(:code :id "output-area" :hidden (not output-visible)
other-text)))
(:div :class "label" "HTML Preview:"))
(princ html-text reblocks/html:*stream*))))
nil)
(defmethod get-dependencies ((widget truth-table))
(append
(list
(reblocks-lass:make-dependency
'(.truth-table
(.label
:font-size "large"
:font-weight "bold"
:margin-top "5px"
:margin-bottom "5px")
(|#output-span|
:display "flex"
(button :margin-right "10px"))
(|#output-expander-button|
:margin-bottom "auto"
:font-size "xx-large"
:background "none"
:border "none"
:cursor "pointer")
(|#output-area|
:background "lightgrey"
:flex-grow "1"
:padding "5px"
:border-style "solid"
:border-color "black"
:border-width "1px"
:max-height "25vh"
:overflow-y "scroll")
(table
:margin "auto"
:border-collapse "collapse"
:border-spacing "0px"
((:or th td)
:padding "3px"
:text-align "center"
:border-style "solid"
:border-width "1px"
:border-color "black")))))
(call-next-method)))
(defwidget error-box ()
((message :initform nil
:accessor error-box-message))
(:documentation "Class to hold various error messages."))
(defmethod render ((box error-box))
"Render BOX."
(with-html
(with-slots (message) box
(when message
(:div
(:pre message))))))
(defmethod get-dependencies ((box error-box))
(append
(list
(reblocks-lass:make-dependency
`(.error-box
(div
:border-width "1px"
:border-style "solid"
:border-color "black"
(pre
:margin "0px"
:padding-top "5px"
:font-size "large"
:border-left-style "solid"
:border-left-color "red"
:border-left-width "10px"
:padding-left "5px")))))
(call-next-method)))
(defwidget page ()
((table :initform (make-instance 'truth-table)
:accessor page-table)
(error-box :initform (make-instance 'error-box)
:accessor page-error-box))
(:documentation "The root of the whole page"))
(defmethod handle-generate-request ((page page)
&key prop-str implicit-and multi-char-names
format include-vars subexps)
"Handler for requests to generate truth tables."
(with-slots (table error-box) page
(setf (truth-table-format table) format
(error-box-message error-box) nil)
(if (not (zerop (length prop-str)))
(handler-case
(multiple-value-bind (parsed-exp vars)
(parse-proposition-string
prop-str
:implicit-and implicit-and
:multi-char-names multi-char-names)
(setf (truth-table-data table) (create-truth-table parsed-exp
:vars vars
:include-vars include-vars
:include-intermediate subexps)))
((or proposition-parse-error proposition-eval-error) (e)
(setf (error-box-message error-box) (princ-to-string e))))
(setf (truth-table-data table) nil))
(update table)
(update error-box)))
(defmethod render ((page page))
"Render PAGE."
(with-html
(with-slots (table error-box) page
(:h1 "Truth Table Generator")
(with-html-form (:POST (lambda (&key prop-str implicit-and
multi-char-names format
include-vars subexps
&allow-other-keys)
(handle-generate-request
page :prop-str prop-str
:implicit-and implicit-and
:multi-char-names multi-char-names
:format format
:include-vars include-vars
:subexps subexps)))
(:div :id "main-controls-wrapper"
(:input :id "prop-input-field"
:type "text"
:name "prop-str"
:placeholder "Proposition string...")
(:input :id "submit-button"
:type "submit"
:value "Generate"))
(:div :id "extra-controls-wrapper"
(:input :type "checkbox"
:name "implicit-and"
:checked t)
(:label :for "implicit-and" "Implicit And")
(:input :type "checkbox"
:name "multi-char-names"
:style "margin-left: 10px;")
(:label :for "multi-char-names" "Multi-character Variables")
(:input :type "checkbox"
:name "include-vars"
:checked t
:style "margin-left: 10px;")
(:label :for "include-vars" "Include Variables")
(:input :type "checkbox"
:name "subexps"
:checked t
:style "margin-left: 10px;")
(:label :for "subexps" "Include Sub-expressions")
(:select :name "format" :style "margin-left: 10px;"
(:option :value "html" "HTML")
(:option :value "latex" "LaTeX")
(:option :value "ascii" "ASCII")
(:option :value "unicode" "Unicode"))))
(render error-box)
(render table)
(:div :id "info-text"
(:span
"This website is free software under the terms of the AGPL"
"license version 3. You can find a copy of the license ")
(:a :href "https://www.gnu.org/licenses/agpl-3.0.html"
"here")
(:span ". You can find the source of this website ")
(:a :href "https://git.zander.im/Zander671/truth-table"
"here")
(:span ".")))))
(defmethod get-dependencies ((page page))
(append
(list
(reblocks-lass:make-dependency
'(.page
:width "70%"
:margin "auto"
(h1 :text-align "center")
(form
:margin-bottom "5px"
(|#main-controls-wrapper|
:display flex
:margin-bottom "5px"
(|#prop-input-field|
:flex-grow "1"
:margin-right "5px"
:font-size "large")
(|#submit-button|
:font-size "large"))
(|#extra-controls-wrapper|
:display "flex"
:justify-content "center"
:align-items "center"))
(|#info-text|
:text-align "center"
:margin-top "10px"
:font-size "small"))))
(call-next-method)))
(defapp truth-table-app
:prefix "/")
(defmethod reblocks/page:init-page ((app truth-table-app) (url-path string)
expire-at)
"Main entry point for webpage."
(declare (ignorable app url-path expire-at))
(make-instance 'page))
(defparameter *command-line-spec*
`((#\h "help" help nil "print this message, then exit")
(#\d "debug" debug nil "enable debug output")
(#\p "port" port t
,(format nil "specify port to use (default: ~d)" *default-port*))
(#\a "address" address t
,(format nil "specify address to bind to (default: ~a)" *default-address*)))
"Spec for use in `parse-command-line.")
(defun determine-port (opts)
"Get port from the command line option array OPTS, or use a default if port
was not specified."
(let ((raw-value (option-value 'port opts)))
(if raw-value
(handler-case
(let ((value (parse-integer raw-value :junk-allowed nil)))
(if (< value 1)
(error 'parse-error)
value))
(parse-error ()
(cerror "Use *default-port*" 'command-line-error
:message (format nil "invalid port: ~a" raw-value))
*default-port*))
*default-port*)))
(defun main (argv)
"The main entry point to the program. ARGV is the list of command line
arguments."
(format t "Hello World~%"))
(let ((cmdline-error nil))
(handler-bind
((command-line-error
(lambda (c)
(format *error-output* "~a~%" c)
(setq cmdline-error t)
(continue))))
(destructuring-bind ((&rest norm-args) &rest opts)
(parse-command-line *command-line-spec* argv)
;; parse the options here so that continue still exits properly
(let ((port (determine-port opts))
(address (or (option-value 'address opts) *default-address*)))
(when norm-args
(cerror "Ignore the extra arguments." 'command-line-error
:message "extra non-option arguments"))
(when (option-value 'help opts)
(print-usage t *command-line-spec* "truth-table-webserver"
:print-astrisk nil)
(if cmdline-error
(uiop:quit 1)
(uiop:quit 0)))
(when cmdline-error
(uiop:quit 1))
(reblocks/server:start :apps '(truth-table-app)
:port port
:interface address
:debug (option-value 'debug opts)))))))
(defun toplevel ()
"Top-level function to be passed to `save-lisp-and-die'."
(handler-case
(with-user-abort:with-user-abort
#+sbcl (sb-ext:disable-debugger)
(main (uiop:command-line-arguments)))
(with-user-abort:user-abort ()
(format *error-output* "Keyboard interrupt~%")
(uiop:quit 1))))