truth-table/web.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)))