Add syntax help menu and cli option
This commit is contained in:
parent
627c62772b
commit
6f8135238b
@ -7,6 +7,11 @@
|
||||
#:delim-p
|
||||
#:symbol-char-p
|
||||
#:proposition-parse-error
|
||||
#:parse-error-position
|
||||
#:parse-error-proposition
|
||||
#:parse-error-message
|
||||
#:*operator-symbol-table*
|
||||
#:*operator-descriptions*
|
||||
#:operator-symbol
|
||||
#:operator-precedence
|
||||
#:interpret-operand
|
||||
@ -45,6 +50,7 @@
|
||||
#:convert-truth-table-to-html
|
||||
#:*table-border-ascii-alist*
|
||||
#:*table-border-unicode-alist*
|
||||
#:with-draw-table
|
||||
#:typeset-truth-table
|
||||
#:*known-formats*
|
||||
#:typeset-table-to-format))
|
||||
|
98
cli.lisp
98
cli.lisp
@ -50,8 +50,80 @@ functions involved in evaluating and typesetting."
|
||||
:pretty-print pretty-print
|
||||
:latin-truths latin-truths)))))
|
||||
|
||||
(defun word-wrap-string (string &optional (cols 80))
|
||||
(with-output-to-string (str)
|
||||
(loop with word = ()
|
||||
with word-len = 0
|
||||
with cur-col = 0
|
||||
for char across string
|
||||
when (whitespace-p char) do
|
||||
(if (>= (+ cur-col word-len 1) cols)
|
||||
(progn
|
||||
(terpri str)
|
||||
(setq cur-col 0))
|
||||
(unless (zerop cur-col)
|
||||
(format str " ")
|
||||
(incf cur-col)))
|
||||
(format str "~{~c~}" (nreverse word))
|
||||
(setq word nil
|
||||
cur-col (+ cur-col word-len)
|
||||
word-len 0)
|
||||
else do
|
||||
(push char word)
|
||||
(incf word-len)
|
||||
finally
|
||||
(if (>= (+ cur-col word-len 1) cols)
|
||||
(terpri str)
|
||||
(format str " "))
|
||||
(format str "~{~c~}" (nreverse word)))))
|
||||
|
||||
(defun ascii-string-p (str)
|
||||
"Return true if STR is only ASCII characters."
|
||||
(loop for char across str
|
||||
unless (<= (char-code char) 127)
|
||||
do (return-from ascii-string-p))
|
||||
t)
|
||||
|
||||
(defun print-syntax-help (ascii-only)
|
||||
"Print the syntax help message."
|
||||
(loop
|
||||
for ((sym (name . nicks) desc examples) . rest-desc)
|
||||
= *operator-descriptions* then rest-desc
|
||||
for ((_sym . syntax) . rest-st) = *operator-symbol-table* then rest-st
|
||||
for syntax-str = (format nil "~{~a~^, ~}"
|
||||
(sort (copy-list
|
||||
(if ascii-only
|
||||
(remove-if-not 'ascii-string-p
|
||||
syntax)
|
||||
syntax))
|
||||
'string<))
|
||||
while sym
|
||||
maximize (length name) into name-col-len
|
||||
maximize (length syntax-str) into syntax-col-len
|
||||
collect syntax-str into syntax-entries
|
||||
finally
|
||||
(let ((col-widths (list name-col-len syntax-col-len))
|
||||
(box-lookup-table (if ascii-only
|
||||
*table-border-ascii-alist*
|
||||
*table-border-unicode-alist*)))
|
||||
(with-draw-table (t col-widths box-lookup-table
|
||||
:padding 1 :align :left)
|
||||
(:row (list "Operator" "Syntax"))
|
||||
(:seperator)
|
||||
(loop for (sym (name . nicks) desct) in *operator-descriptions*
|
||||
for syntax-str in syntax-entries do
|
||||
(:row (list name syntax-str))))))
|
||||
(format t "~%~%~a~%Example:~% abc|d = ~a~%"
|
||||
(word-wrap-string "Two operands next to each other is treated as an
|
||||
'implicit and' (unless this feature is disabled).")
|
||||
(typeset-proposition '(or (and "a" "b" "c") "d")
|
||||
:lookup-table (if ascii-only
|
||||
*operator-ascii-lookup-alist*
|
||||
*operator-unicode-lookup-alist*))))
|
||||
|
||||
(defparameter *command-line-spec*
|
||||
'((#\h "help" help nil "print this message, then exit")
|
||||
(nil "syntax-help" syntax-help nil "print a syntax help message, then exit")
|
||||
(#\f "format" format t
|
||||
"specify the output format (*unicode*, ascii, latex, or html)")
|
||||
(#\s "subexps" subexps nil "include sub-expressions in the output table")
|
||||
@ -85,6 +157,20 @@ arguments."
|
||||
(print-usage t *command-line-spec* "truth-table"
|
||||
:general-args "<propositions...>")
|
||||
(uiop:quit (if cmdline-error 1 0)))
|
||||
((and (not cmdline-error) ;; if option parsing failed, error out
|
||||
(option-value 'syntax-help opts))
|
||||
(let ((format (option-value 'format opts)))
|
||||
(cond
|
||||
((or (not format)
|
||||
(equal format "unicode"))
|
||||
(print-syntax-help nil))
|
||||
((equal format "ascii")
|
||||
(print-syntax-help t))
|
||||
(t
|
||||
(cerror "Exit without printing anything" 'command-line-error
|
||||
:message (format nil "The syntax help table is only ~
|
||||
available in ASCII or Unicode.")))))
|
||||
(uiop:quit))
|
||||
((null prop-strs)
|
||||
(cerror *cli-parse-continue-string* 'no-input-error))
|
||||
(cmdline-error
|
||||
@ -96,12 +182,12 @@ arguments."
|
||||
(setq format "unicode"))
|
||||
(princ (eval-and-typeset-propositions
|
||||
prop-strs :format format
|
||||
:implicit-and (not (option-value 'no-implicit opts))
|
||||
:multi-char-names (option-value 'multi-char opts)
|
||||
:include-vars (not (option-value 'no-vars opts))
|
||||
:include-intermediate (option-value 'subexps opts)
|
||||
:pretty-print (option-value 'pretty opts)
|
||||
:latin-truths (option-value 'latin opts)))
|
||||
:implicit-and (not (option-value 'no-implicit opts))
|
||||
:multi-char-names (option-value 'multi-char opts)
|
||||
:include-vars (not (option-value 'no-vars opts))
|
||||
:include-intermediate (option-value 'subexps opts)
|
||||
:pretty-print (option-value 'pretty opts)
|
||||
:latin-truths (option-value 'latin opts)))
|
||||
(terpri))))))))
|
||||
|
||||
(defun toplevel ()
|
||||
|
71
parse.lisp
71
parse.lisp
@ -86,6 +86,77 @@ proposition."))
|
||||
(iff "<->" "<>" "<=>" "⇔" "↔" "≡" "iff" "=" "==" "xnor" "⊙"))
|
||||
"Alist table of operator symbols and their possible string representations.")
|
||||
|
||||
(defparameter *operator-descriptions* ;; noindent 30
|
||||
`((open-paren ("open parenthesis")
|
||||
,(format nil "Used in combination with a close parenthesis to denote ~
|
||||
some terms to be evaluated before the surrounding terms.")
|
||||
(((and (or true true) false) . false)
|
||||
((or true (and true false)) . true)))
|
||||
(close-paren ("close parenthesis")
|
||||
"Used to close a group started with an open parenthesis."
|
||||
()) ;; no examples for closed paren
|
||||
(and ("and" "conjunction")
|
||||
,(format nil "Evaluate to true only if the expressions to the left and ~
|
||||
right evaluate to true.")
|
||||
(((and true true) . true)
|
||||
((and true false) . false)))
|
||||
(nand ("nand" "non-conjunction")
|
||||
,(format nil "Evaluate to true unless the expressions to the left and ~
|
||||
right are both true. This is the negation of the 'and' operator.")
|
||||
(((nand true true) . false)
|
||||
((nand true false) . true)
|
||||
((nand false false) . true)))
|
||||
(or ("or" "disjunction")
|
||||
,(format nil "Evaluate to true if the expression to the left is true, the ~
|
||||
expression to the right is true, or both the left and right expressions are ~
|
||||
true.")
|
||||
(((or true true) . true)
|
||||
((or true false) . true)
|
||||
((or false false) . false)))
|
||||
(nor ("nor" "non-disjunction")
|
||||
,(format nil "Evaluate to true if the expressions to the left and right ~
|
||||
are both false. This is the negation of the 'or' operator.")
|
||||
(((nor true true) . false)
|
||||
((nor true false) . false)
|
||||
((nor false false) . true)))
|
||||
(xor ("exclusive or" "exclusive disjunction") ;; noindent 30
|
||||
,(format nil "Evaluate to true if the expression to the left is true or ~
|
||||
if the expression to the right is true, but not if both of them are true.")
|
||||
(((xor true true) . false)
|
||||
((xor true false) . true)))
|
||||
(not ("not" "negation")
|
||||
,(format nil "Evaluate to false if the expression to the left evaluates ~
|
||||
to true, and evaluate to true if the expression to the left evaluates to ~
|
||||
false. This is a unary operator (it only applies to the expression following ~
|
||||
it).")
|
||||
(((not true) . false)
|
||||
((not false) . true)))
|
||||
(implies ("implies" "conditional")
|
||||
,(format nil "Evaluate to false if the expression to the left evaluates ~
|
||||
to true and the expressions to the right evaluates to false. Otherwise, ~
|
||||
evaluate to true.")
|
||||
(((implies true true) . true)
|
||||
((implies true false) . false)
|
||||
((implies false true) . true)
|
||||
((implies false false) . true)))
|
||||
(converse ("converse")
|
||||
,(format nil "Evaluate to false if the expression to the right evaluates ~
|
||||
to true and the expression to the left evaluates to false. Otherwise, evaluate ~
|
||||
to true. This is the 'implies' operator with its arguments flipped.")
|
||||
(((implies true true) . true)
|
||||
((implies true false) . true)
|
||||
((implies false true) . false)
|
||||
((implies false false) . true)))
|
||||
(iff ("biconditional" "equivalent")
|
||||
,(format nil "Evaluate to true if the expressions to the left and rigt ~
|
||||
evaluate to the same value. That is, they are both true or both false.")
|
||||
(((iff true true) . true)
|
||||
((iff true false) . false)
|
||||
((iff false false) . true))))
|
||||
"Alist table of operator symbols and their descriptions. The format of this
|
||||
list is SYMBOL NAMES DESCRIPTION (&rest (EXAMPLE LEFT . EXAMPLE RIGHT)). These
|
||||
are useful for use in things like syntax explanation messages.")
|
||||
|
||||
(defun operator-symbol (oper-str)
|
||||
"Return the symbol for OPER-STR, or nil if it is not a know operator."
|
||||
(loop for (oper-sym . strs) in *operator-symbol-table*
|
||||
|
122
typeset.lisp
122
typeset.lisp
@ -318,7 +318,8 @@ between each row."
|
||||
(bottom-right . #\┘))
|
||||
"Characters used to draw Unicode table borders.")
|
||||
|
||||
(defun typeset-table-break (stream lengths horiz start column end)
|
||||
(defun typeset-table-break (stream lengths horiz start column end
|
||||
&key (left-pad-len 0) (right-pad-len 0))
|
||||
"Typeset the first row, the last row, or a break to STREAM. The proper box
|
||||
character will be placed at each intersection. LENGTHS is a list of column
|
||||
lengths. HORIZ, START, COLUMN, and END are the box characters to use when
|
||||
@ -328,20 +329,78 @@ drawing."
|
||||
while length
|
||||
do
|
||||
(format stream "~a"
|
||||
(make-string length :initial-element horiz))
|
||||
(make-string (+ left-pad-len length right-pad-len)
|
||||
:initial-element horiz))
|
||||
when rest do
|
||||
(format stream "~c" column))
|
||||
(format stream "~c" end))
|
||||
|
||||
(defun typeset-table-row (stream lengths row vert)
|
||||
(defun typeset-table-row (stream lengths row vert
|
||||
&key (align :center) (left-pad-str "")
|
||||
(right-pad-str ""))
|
||||
"Typeset ROW to STREAM. VERT is the vertical separator. LENGTHS should be the
|
||||
length of each column."
|
||||
(loop for col in row
|
||||
(loop with format = (case align
|
||||
(:right
|
||||
"~c~a~v:<~a~>~a")
|
||||
(:left
|
||||
"~c~a~v@<~a~>~a")
|
||||
(t ;; :center
|
||||
"~c~a~v:@<~a~>~a"))
|
||||
for col in row
|
||||
for length in lengths
|
||||
do
|
||||
(format stream "~c~v:@<~a~>" vert length col))
|
||||
(format stream format
|
||||
vert left-pad-str length col right-pad-str))
|
||||
(format stream "~c" vert))
|
||||
|
||||
(defmacro with-draw-table ((stream col-widths lookup-table
|
||||
&key (padding 0) (align :center))
|
||||
&body body)
|
||||
"Execute BODY with the function \=:seperator and \=:row bound. STREAM is the
|
||||
stream to write the table to. COL-WIDTHS is a list of column
|
||||
widths. LOOKUP-TABLE is the table to use to lookup characters for the table
|
||||
border. PADDING is the number to spaces to both append and prepend to each table
|
||||
cell. ALIGN is one of \=:right, \=:center, or \=:left."
|
||||
(let ((pad-str-var (gensym)))
|
||||
`(let ((,pad-str-var (make-string ,padding :initial-element #\space)))
|
||||
(truth-table/base::typeset-table-break
|
||||
,stream ,col-widths
|
||||
(cdr (assoc 'horizontal ,lookup-table))
|
||||
(cdr (assoc 'top-left ,lookup-table))
|
||||
(cdr (assoc 'down ,lookup-table))
|
||||
(cdr (assoc 'top-right ,lookup-table))
|
||||
:right-pad-len ,padding
|
||||
:left-pad-len ,padding)
|
||||
(format ,stream "~%")
|
||||
(flet ((:seperator ()
|
||||
(truth-table/base::typeset-table-break
|
||||
,stream ,col-widths
|
||||
(cdr (assoc 'horizontal ,lookup-table))
|
||||
(cdr (assoc 'right ,lookup-table))
|
||||
(cdr (assoc 'cross ,lookup-table))
|
||||
(cdr (assoc 'left ,lookup-table))
|
||||
:right-pad-len ,padding
|
||||
:left-pad-len ,padding)
|
||||
(format ,stream "~%"))
|
||||
(:row (row)
|
||||
(truth-table/base::typeset-table-row
|
||||
,stream ,col-widths row
|
||||
(cdr (assoc 'vertical ,lookup-table))
|
||||
:align ,align
|
||||
:left-pad-str ,pad-str-var
|
||||
:right-pad-str ,pad-str-var)
|
||||
(format ,stream "~%")))
|
||||
,@body)
|
||||
(truth-table/base::typeset-table-break
|
||||
,stream ,col-widths
|
||||
(cdr (assoc 'horizontal ,lookup-table))
|
||||
(cdr (assoc 'bottom-left ,lookup-table))
|
||||
(cdr (assoc 'up ,lookup-table))
|
||||
(cdr (assoc 'bottom-right ,lookup-table))
|
||||
:right-pad-len ,padding
|
||||
:left-pad-len ,padding))))
|
||||
|
||||
(defun typeset-truth-table (table &optional
|
||||
(expr-lookup-table
|
||||
*operator-ascii-lookup-alist*)
|
||||
@ -355,47 +414,28 @@ between each row."
|
||||
(let* ((typeset-exprs (mapcar (lambda (expr)
|
||||
(typeset-proposition
|
||||
expr :lookup-table expr-lookup-table
|
||||
:latin-truths latin-truths))
|
||||
:latin-truths latin-truths))
|
||||
(extract-truth-table-expressions table)))
|
||||
(col-widths (mapcar (lambda (expr)
|
||||
(+ (length expr) 2))
|
||||
typeset-exprs)))
|
||||
(with-output-to-string (str)
|
||||
(typeset-table-break str col-widths
|
||||
(cdr (assoc 'horizontal box-lookup-table))
|
||||
(cdr (assoc 'top-left box-lookup-table))
|
||||
(cdr (assoc 'down box-lookup-table))
|
||||
(cdr (assoc 'top-right box-lookup-table)))
|
||||
(terpri str)
|
||||
(typeset-table-row str col-widths typeset-exprs
|
||||
(cdr (assoc 'vertical box-lookup-table)))
|
||||
(terpri str)
|
||||
(typeset-table-break str col-widths
|
||||
(cdr (assoc 'horizontal box-lookup-table))
|
||||
(cdr (assoc 'right box-lookup-table))
|
||||
(cdr (assoc 'cross box-lookup-table))
|
||||
(cdr (assoc 'left box-lookup-table)))
|
||||
(terpri str)
|
||||
(dolist (row (extract-truth-table-values table))
|
||||
(typeset-table-row str col-widths
|
||||
;; convert t or nil to strings
|
||||
(mapcar (lambda (entry)
|
||||
(cdr (assoc (if entry
|
||||
(if latin-truths
|
||||
'latin-true
|
||||
'true)
|
||||
(if latin-truths
|
||||
'latin-false
|
||||
'false))
|
||||
expr-lookup-table)))
|
||||
row)
|
||||
(cdr (assoc 'vertical box-lookup-table)))
|
||||
(terpri str))
|
||||
(typeset-table-break str col-widths
|
||||
(cdr (assoc 'horizontal box-lookup-table))
|
||||
(cdr (assoc 'bottom-left box-lookup-table))
|
||||
(cdr (assoc 'up box-lookup-table))
|
||||
(cdr (assoc 'bottom-right box-lookup-table))))))
|
||||
(with-draw-table (str col-widths box-lookup-table)
|
||||
(:row typeset-exprs)
|
||||
(:seperator)
|
||||
(dolist (row (extract-truth-table-values table))
|
||||
(:row (mapcar
|
||||
(lambda (entry)
|
||||
(cdr (assoc
|
||||
(if entry
|
||||
(if latin-truths
|
||||
'latin-true
|
||||
'true)
|
||||
(if latin-truths
|
||||
'latin-false
|
||||
'false))
|
||||
expr-lookup-table)))
|
||||
row)))))))
|
||||
|
||||
(defparameter *known-formats*
|
||||
'("unicode" "ascii" "latex" "html")
|
||||
|
350
web.lisp
350
web.lisp
@ -38,6 +38,94 @@
|
||||
(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
|
||||
(: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<))))))
|
||||
(: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)
|
||||
@ -77,24 +165,24 @@ reblocks bug.")
|
||||
(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)))
|
||||
;; 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)
|
||||
@ -175,9 +263,53 @@ reblocks bug.")
|
||||
((table :initform (make-instance 'truth-table)
|
||||
:accessor page-table)
|
||||
(error-box :initform (make-instance 'error-box)
|
||||
:accessor page-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)
|
||||
@ -185,19 +317,17 @@ reblocks bug.")
|
||||
(with-slots (table error-box) page
|
||||
(setf (truth-table-format table) format
|
||||
(error-box-message error-box) nil)
|
||||
(if (not (zerop (length prop-str)))
|
||||
(if (not (blank-prop-string-p 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)
|
||||
(truth-table-latin-truths table) latin
|
||||
(truth-table-pretty-print table) pretty))
|
||||
(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))
|
||||
@ -207,76 +337,86 @@ reblocks bug.")
|
||||
(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 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"))
|
||||
(: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 ".")))))
|
||||
(: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
|
||||
@ -290,13 +430,15 @@ reblocks bug.")
|
||||
:margin-bottom "5px"
|
||||
(|#main-controls-wrapper|
|
||||
:display flex
|
||||
:margin-bottom "5px"
|
||||
:margin-bottom "5px"
|
||||
(|#prop-input-field|
|
||||
:flex-grow "1"
|
||||
:margin-right "5px"
|
||||
:font-size "large")
|
||||
(|#submit-button|
|
||||
:font-size "large"))
|
||||
((:or |#submit-button| |#help-button|)
|
||||
:font-size "large")
|
||||
(|#help-button|
|
||||
:margin-left "5px"))
|
||||
(|#extra-controls-wrapper|
|
||||
:display "flex"
|
||||
:justify-content "center"
|
||||
|
Loading…
Reference in New Issue
Block a user