truth-table/web.lisp

354 lines
13 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")
(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."
(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'."
#+sbcl (sb-ext:disable-debugger)
(main (uiop:command-line-arguments)))