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")
(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 &and; b &and; c &or; 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-web-wrapper"
                         :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)))