529 lines
19 KiB
Common Lisp
529 lines
19 KiB
Common Lisp
;; web.lisp -- Website to allow users to make truth tables
|
|
;; Copyright (C) 2024 Alexander Rosenberg
|
|
;;
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; 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")
|
|
(defparameter *default-prefix* "/")
|
|
|
|
(defwidget help-overlay ()
|
|
()
|
|
(:documentation "Simple class to handle holding the help overlay."))
|
|
|
|
(defmethod render ((overlay help-overlay))
|
|
(with-html
|
|
(:div :id "help-table-wrapper"
|
|
(:div :id "help-header-wrapper"
|
|
(:span :id "help-header" "Help")
|
|
(:span :id "help-close-button"
|
|
:onclick "document.querySelector(\".help-overlay\").style.display = \"none\""
|
|
"Close"))
|
|
(:table ;:style "margin-bottom: 10px;"
|
|
(:tr (:th "Operator") (:th "Syntax"))
|
|
(loop for ((sym (name . nics) desc (examples)) . rest-desc)
|
|
= *operator-descriptions* then rest-desc
|
|
for ((_sym . syntax) . rest-st)
|
|
= *operator-symbol-table* then rest-st
|
|
while sym
|
|
do
|
|
(:tr
|
|
(:td name)
|
|
(:td (format nil "~{~a~^, ~}" (sort (copy-list syntax)
|
|
'string<)))))
|
|
(:tr (:th "Operand") (:th "Syntax"))
|
|
(loop for (sym . syntax) in *operand-symbol-table* do
|
|
(:tr
|
|
(:td (string-downcase (symbol-name sym)))
|
|
(:td (format nil "~{~a~^, ~}" (sort (copy-list syntax)
|
|
'string<))))))
|
|
(:p "You can input multiple propositions by separating them with"
|
|
"commas (,):"
|
|
(:br)
|
|
(:code "ab,cd"))
|
|
(:p "Two operands next to each other is treated as an 'implicit and'"
|
|
"(unless this feature is disabled):"
|
|
(:br)
|
|
(:code (:raw "abc|d = a ∧ b ∧ c ∨ d"))))))
|
|
|
|
(defmethod get-dependencies ((overlay help-overlay))
|
|
(append
|
|
(list
|
|
(reblocks-lass:make-dependency
|
|
'(.help-overlay
|
|
:display "none"
|
|
:position "fixed"
|
|
:top "0px"
|
|
:left "0px"
|
|
:width "100%"
|
|
:height "100%"
|
|
:z-index "100" ;; be above EVERYTHING
|
|
(|#help-table-wrapper|
|
|
:background "#ffffff"
|
|
:border-width "2px"
|
|
:border-style "solid"
|
|
:border-color "black"
|
|
:padding "10px"
|
|
:width "fit-content"
|
|
:height "fit-content"
|
|
:position "fixed"
|
|
:top "40%"
|
|
:left "50%"
|
|
:transform translate "-50%" "-50%"
|
|
(|#help-header-wrapper|
|
|
:margin-bottom "3px"
|
|
:position "relative"
|
|
(|#help-header|
|
|
:font-size "x-large"
|
|
:font-weight "bold"
|
|
:display "block"
|
|
:text-align "center")
|
|
(|#help-close-button|
|
|
:user-select "none"
|
|
:text-decoration-line "underline"
|
|
:cursor "pointer"
|
|
:position "absolute"
|
|
:top "0"
|
|
:right "0"))
|
|
(table
|
|
:border-collapse "collapse"
|
|
:border-spacing "0px"
|
|
:margin "auto"
|
|
((:or th td)
|
|
:padding "3px"
|
|
:padding-left "10px"
|
|
:padding-right "10px"
|
|
:text-align "left"
|
|
:border-style "solid"
|
|
:border-width "1px"
|
|
:border-color "black"))
|
|
(code
|
|
:padding-left "1em")))))
|
|
(call-next-method)))
|
|
|
|
(defwidget truth-table ()
|
|
((data :initform nil
|
|
:accessor truth-table-data)
|
|
(format :initform "html"
|
|
:accessor truth-table-format)
|
|
(pretty-print :initform t
|
|
:accessor truth-table-pretty-print)
|
|
(latin-truths :initform nil
|
|
:accessor truth-table-latin-truths)
|
|
(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 pretty-print latin-truths output-visible) table
|
|
(let* ((html-text (convert-truth-table-to-html data
|
|
:pretty-print pretty-print
|
|
:latin-truths latin-truths))
|
|
(other-text
|
|
(when output-visible
|
|
(if (equal format "html")
|
|
html-text
|
|
(typeset-table-to-format data format
|
|
:pretty-print pretty-print
|
|
:latin-truths latin-truths)))))
|
|
(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 pretty-print
|
|
(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)
|
|
(help-overlay :initform (make-instance 'help-overlay)
|
|
:accessor page-help-overlay))
|
|
(:documentation "The root of the whole page"))
|
|
|
|
(defun parse-and-eval-propositions (input-str &key implicit-and
|
|
multi-char-names
|
|
include-vars
|
|
include-intermediate)
|
|
"Parse and then eval all of comma separated props in INPUT-STR."
|
|
(let ((prop-start 0))
|
|
(handler-case
|
|
(loop
|
|
for prop-str in (uiop:split-string input-str :separator '(#\,))
|
|
for (parsed-exp vars) = (multiple-value-list
|
|
(parse-proposition-string
|
|
prop-str
|
|
:implicit-and implicit-and
|
|
:multi-char-names multi-char-names))
|
|
when parsed-exp
|
|
append vars into all-vars
|
|
and
|
|
collect parsed-exp into parsed-exps
|
|
and
|
|
do (incf prop-start (1+ (length prop-str)))
|
|
finally
|
|
(return (create-combined-truth-table
|
|
parsed-exps
|
|
(remove-duplicates all-vars :test 'equal
|
|
:from-end t)
|
|
:include-intermediate include-intermediate
|
|
:include-vars include-vars)))
|
|
(proposition-parse-error (e)
|
|
;; adjust the position and proposition string
|
|
(error 'proposition-parse-error
|
|
:message (parse-error-message e)
|
|
:proposition input-str
|
|
:position (+ (parse-error-position e)
|
|
prop-start))))))
|
|
|
|
(defun blank-prop-string-p (str)
|
|
"Return t if STR would produce a blank proposition table."
|
|
(not (find-if-not (lambda (c)
|
|
(or (eq c #\,)
|
|
(whitespace-p c)))
|
|
str)))
|
|
|
|
(defmethod handle-generate-request ((page page)
|
|
&key prop-str implicit-and multi-char-names
|
|
format include-vars subexps latin pretty)
|
|
"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 (blank-prop-string-p prop-str))
|
|
(handler-case
|
|
(setf (truth-table-data table)
|
|
(parse-and-eval-propositions
|
|
prop-str
|
|
:implicit-and implicit-and
|
|
:multi-char-names multi-char-names
|
|
:include-vars include-vars
|
|
:include-intermediate subexps)
|
|
(truth-table-latin-truths table) latin
|
|
(truth-table-pretty-print table) pretty)
|
|
((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
|
|
(:doctype)
|
|
(:html
|
|
(:head
|
|
(:title "Truth Table Generator"))
|
|
(:body
|
|
(with-slots (table error-box help-overlay) page
|
|
(render help-overlay)
|
|
(:h1 "Truth Table Generator")
|
|
(with-html-form (:POST (lambda (&key prop-str implicit-and
|
|
multi-char-names format
|
|
include-vars subexps latin
|
|
pretty
|
|
&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
|
|
:pretty pretty
|
|
:latin latin)))
|
|
(: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")
|
|
(:button :id "help-button"
|
|
:onclick
|
|
"document.querySelector(\".help-overlay\").style.display = \"initial\""
|
|
"Help"))
|
|
(: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")
|
|
(:input :type "checkbox"
|
|
:name "pretty"
|
|
:checked t
|
|
:style "margin-left: 10px;")
|
|
(:label :for "pretty" "Pretty Print")
|
|
(:input :type "checkbox"
|
|
:name "latin"
|
|
:checked nil
|
|
:style "margin-left: 10px;")
|
|
(:label :for "latin" "Latin Truth Values")
|
|
(: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")
|
|
((:or |#submit-button| |#help-button|)
|
|
:font-size "large")
|
|
(|#help-button|
|
|
:margin-left "5px"))
|
|
(|#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 *default-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."
|
|
(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)
|
|
:disable-welcome-app t))))))
|
|
|
|
(defun toplevel ()
|
|
"Top-level function to be passed to `save-lisp-and-die'."
|
|
#+sbcl (sb-ext:disable-debugger)
|
|
(main (uiop:command-line-arguments)))
|