Zander671/truth-table
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add pretty print and latin truth values support

Browse Source
This commit is contained in:
Alexander Rosenberg 2024-09-10 22:19:43 -07:00
parent c86b38db09
commit edd4f53a68
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
3 changed files with 139 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
cli.lisp
View File

@ -24,7 +24,9 @@
(implicit-and t) (implicit-and t)
multi-char-names multi-char-names
include-intermediate include-intermediate
(include-vars t)) (include-vars t)
pretty-print
latin-truths)
"Evaluate and then typeset PROP-STRS as a table, which is a list of "Evaluate and then typeset PROP-STRS as a table, which is a list of
proposition strings. For a description of the key parameters, see each of the proposition strings. For a description of the key parameters, see each of the
functions involved in evaluating and typesetting." functions involved in evaluating and typesetting."
@ -44,7 +46,9 @@ functions involved in evaluating and typesetting."
exps vars exps vars
:include-intermediate include-intermediate :include-intermediate include-intermediate
:include-vars include-vars))) :include-vars include-vars)))
(return (typeset-table-to-format table format))))) (return (typeset-table-to-format table format
:pretty-print pretty-print
:latin-truths latin-truths)))))
(defparameter *command-line-spec* (defparameter *command-line-spec*
'((#\h "help" help nil "print this message, then exit") '((#\h "help" help nil "print this message, then exit")
@ -53,7 +57,9 @@ functions involved in evaluating and typesetting."
(#\s "subexps" subexps nil "include sub-expressions in the output table") (#\s "subexps" subexps nil "include sub-expressions in the output table")
(#\n "no-vars" no-vars nil "do not include variables in the output table") (#\n "no-vars" no-vars nil "do not include variables in the output table")
(#\m "multi-char" multi-char nil "allow multi-character variable names") (#\m "multi-char" multi-char nil "allow multi-character variable names")
(#\i "no-implicit" no-implicit nil "do not use implicit 'and' operations")) (#\i "no-implicit" no-implicit nil "do not use implicit 'and' operations")
(#\p "pretty" pretty nil "pretty print latex, html, etc. output")
(#\l "latin" latin nil "use the Latin T and F characters for truth values"))
"Specification for `parse-command-line'. This is of the format: "Specification for `parse-command-line'. This is of the format:
(short long symbol has-arg-p desc).") (short long symbol has-arg-p desc).")
@ -93,7 +99,9 @@ arguments."
:implicit-and (not (option-value 'no-implicit opts)) :implicit-and (not (option-value 'no-implicit opts))
:multi-char-names (option-value 'multi-char opts) :multi-char-names (option-value 'multi-char opts)
:include-vars (not (option-value 'no-vars opts)) :include-vars (not (option-value 'no-vars opts))
:include-intermediate (option-value 'subexps opts))) :include-intermediate (option-value 'subexps opts)
:pretty-print (option-value 'pretty opts)
:latin-truths (option-value 'latin opts)))
(terpri)))))))) (terpri))))))))
(defun toplevel () (defun toplevel ()

138
typeset.lisp
View File

@ -36,7 +36,9 @@
(open-paren . "(") (open-paren . "(")
(close-paren . ")") (close-paren . ")")
(true . "T") (true . "T")
(false . "F")) (false . "F")
(latin-true . "T")
(latin-false . "F"))
"Lookup table mapping operators to their ASCII representation.") "Lookup table mapping operators to their ASCII representation.")
(defparameter *operator-unicode-lookup-alist* (defparameter *operator-unicode-lookup-alist*
@ -52,7 +54,9 @@
(open-paren . "(") (open-paren . "(")
(close-paren . ")") (close-paren . ")")
(true . "⊤") (true . "⊤")
(false . "⊥")) (false . "⊥")
(latin-true . "T")
(latin-false . "F"))
"Lookup table mapping operators to their Unicode representation.") "Lookup table mapping operators to their Unicode representation.")
(defparameter *operator-latex-lookup-alist* (defparameter *operator-latex-lookup-alist*
@ -68,7 +72,9 @@
(open-paren . "\\left(") (open-paren . "\\left(")
(close-paren . "\\right)") (close-paren . "\\right)")
(true . "\\top") (true . "\\top")
(false . "\\bot")) (false . "\\bot")
(latin-true . "\\textrm{T}")
(latin-false . "\\textrm{F}"))
"Lookup table mapping operators to their LaTeX representation.") "Lookup table mapping operators to their LaTeX representation.")
(defparameter *operator-html-lookup-alist* (defparameter *operator-html-lookup-alist*
@ -84,7 +90,9 @@
(open-paren . "(") (open-paren . "(")
(close-paren . ")") (close-paren . ")")
(true . "⊤") (true . "⊤")
(false . "⊥")) (false . "⊥")
(latin-true . "T")
(latin-false . "F"))
"Lookup table mapping operators to their HTML representation.") "Lookup table mapping operators to their HTML representation.")
(defun latex-var-name-transform (name) (defun latex-var-name-transform (name)
@ -112,7 +120,8 @@
(defun typeset-proposition (expr &key (defun typeset-proposition (expr &key
(lookup-table *operator-ascii-lookup-alist*) (lookup-table *operator-ascii-lookup-alist*)
var-name-transform var-name-transform
(parent-prec most-positive-fixnum)) (parent-prec most-positive-fixnum)
latin-truths)
"Typeset the propositional expression EXPR to plain text. LOOKUP-TABLE should "Typeset the propositional expression EXPR to plain text. LOOKUP-TABLE should
be a table mapping operators to their textual representation. VAR-NAME-TRANSFORM be a table mapping operators to their textual representation. VAR-NAME-TRANSFORM
(if non-nil) should take a single string argument which is a variable name and (if non-nil) should take a single string argument which is a variable name and
@ -128,9 +137,14 @@ use (it controls when parentheses are applied.)"
(funcall var-name-transform expr) (funcall var-name-transform expr)
expr)) expr))
;; expr is true or false ;; expr is true or false
((or (eq expr 'true) ((eq expr 'true)
(eq expr 'false)) (if latin-truths
(cdr (assoc expr lookup-table))) (cdr (assoc 'latin-true lookup-table))
(cdr (assoc 'true lookup-table))))
((eq expr 'false)
(if latin-truths
(cdr (assoc 'latin-false lookup-table))
(cdr (assoc 'false lookup-table))))
;; expr is a compound expression ;; expr is a compound expression
(t (t
(destructuring-bind (oper first-arg &rest args) expr (destructuring-bind (oper first-arg &rest args) expr
@ -146,6 +160,7 @@ use (it controls when parentheses are applied.)"
(typeset-proposition first-arg (typeset-proposition first-arg
:lookup-table lookup-table :lookup-table lookup-table
:var-name-transform var-name-transform :var-name-transform var-name-transform
:latin-truths latin-truths
:parent-prec our-prec) :parent-prec our-prec)
(cdr prefix-suffix)) (cdr prefix-suffix))
;; we have many arguments ;; we have many arguments
@ -155,39 +170,49 @@ use (it controls when parentheses are applied.)"
(typeset-proposition arg (typeset-proposition arg
:lookup-table lookup-table :lookup-table lookup-table
:var-name-transform var-name-transform :var-name-transform var-name-transform
:latin-truths latin-truths
:parent-prec our-prec) :parent-prec our-prec)
into output into output
finally finally
(push (typeset-proposition first-arg (push (typeset-proposition first-arg
:lookup-table lookup-table :lookup-table lookup-table
:var-name-transform var-name-transform :var-name-transform var-name-transform
:latin-truths latin-truths
:parent-prec our-prec) :parent-prec our-prec)
output) output)
(return (format nil "~A~{~A~^ ~}~A" (car prefix-suffix) (return (format nil "~A~{~A~^ ~}~A" (car prefix-suffix)
output (cdr prefix-suffix)))))))))) output (cdr prefix-suffix))))))))))
(defun convert-truth-table-to-latex (table) (defun convert-truth-table-to-latex (table &key pretty-print latin-truths)
"Convert TABLE, which should be a truth table as returned by "Convert TABLE, which should be a truth table as returned by
`create-truth-table' to latex. `create-truth-table' to latex. If PRETTY-PRINT, add newlines to make the
generated code easier to read.
NOTE: though the overall order does not matter, the order must be the same NOTE: though the overall order does not matter, the order must be the same
between each row." between each row."
(let ((typeset-exprs (mapcar (lambda (expr) (let ((typeset-exprs (mapcar (lambda (expr)
(typeset-proposition (typeset-proposition
expr :lookup-table *operator-latex-lookup-alist* expr :lookup-table *operator-latex-lookup-alist*
:var-name-transform 'latex-var-name-transform)) :var-name-transform 'latex-var-name-transform
:latin-truths latin-truths))
(extract-truth-table-expressions table)))) (extract-truth-table-expressions table))))
(format nil "~ (with-output-to-string (str)
\\begin{tabular}{~{~*|c~}|}~ (format str "~
\\hline~ \\begin{tabular}{~{~*|c~}|}~@[~% ~*~]~
~{ $ ~A $~^ &~} \\\\ ~ \\hline~:[ ~;~% ~]~
\\hline~ ~{$ ~A $~^ & ~} \\\\~:[ ~;~% ~]~
~{~{ $ ~:[\\bot~;\\top~] $~^ &~} \\\\ ~}~ \\hline~:[ ~;~% ~]"
\\hline~ typeset-exprs
\\end{tabular}" pretty-print pretty-print
typeset-exprs typeset-exprs
typeset-exprs pretty-print pretty-print)
(extract-truth-table-values table)))) (let ((format-str
(if latin-truths
"~{$ ~:[\\textrm{F}~;\\textrm{T}~] $~^ & ~} \\\\~:[ ~;~% ~]"
"~{$ ~:[\\bot~;\\top~] $~^ & ~} \\\\~:[ ~;~% ~]")))
(dolist (row (extract-truth-table-values table))
(format str format-str row pretty-print)))
(format str "\\hline~@[~%~]\\end{tabular}" pretty-print))))
(defun format-html-properties-alist (props) (defun format-html-properties-alist (props)
"Format PROPS, a list of conses, as a list of HTML properties." "Format PROPS, a list of conses, as a list of HTML properties."
@ -198,25 +223,37 @@ between each row."
collect (format nil "~A=~S" name (princ-to-string value)))) collect (format nil "~A=~S" name (princ-to-string value))))
(defun convert-truth-table-to-html (table &key class id more-props) (defun convert-truth-table-to-html (table &key class id more-props
pretty-print latin-truths)
"Convert TABLE, which should be a truth table as returned by "Convert TABLE, which should be a truth table as returned by
`create-truth-table' to HTML. CLASS and ID are their respective HTML `create-truth-table' to HTML. CLASS and ID are their respective HTML
properties. MORE-PROPS is an alist mapping properties to values. properties. MORE-PROPS is an alist mapping properties to values.
NOTE: though the overall order does not matter, the order must be the same NOTE: though the overall order does not matter, the order must be the same
between each row." between each row."
(let ((typeset-exprs (mapcar (lambda (expr) (with-output-to-string (str)
(typeset-proposition (format str "<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~@[~% ~*~]<tr>"
expr :lookup-table *operator-html-lookup-alist*
:var-name-transform 'html-var-name-transform))
(extract-truth-table-expressions table))))
(format nil "~
<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~
<tr>~{<th>~A</th>~}</tr>~
~{<tr>~{<td>~:[&perp;~;&top;~]</td>~}</tr>~}~
</table>"
class id (format-html-properties-alist more-props) class id (format-html-properties-alist more-props)
typeset-exprs pretty-print)
(extract-truth-table-values table)))) (dolist (expr (extract-truth-table-expressions table))
(format str "~@[~% ~*~]<th>~a</th>"
pretty-print
(typeset-proposition
expr :lookup-table *operator-html-lookup-alist*
:var-name-transform 'html-var-name-transform)))
(format str "~@[~% ~]</tr>" pretty-print)
(dolist (row (extract-truth-table-values table))
(format str "~@[~% ~*~]<tr>~@[~% ~*~]" pretty-print pretty-print)
(loop with truth-str = (if latin-truths
"~:[F~;T~]"
"~:[&perp;~;&top;~]")
for now = row then (cdr now)
for value = (car now)
while now do
(format str "<td>~?</td>" truth-str (list value))
when (and pretty-print (cdr now)) do
(format str "~% "))
(format str "~@[~% ~*~]</tr>" pretty-print))
(format str "~@[~%~]</table>" pretty-print)))
(defparameter *table-border-ascii-alist* (defparameter *table-border-ascii-alist*
'((vertical . #\|) '((vertical . #\|)
@ -274,14 +311,16 @@ length of each column."
(expr-lookup-table (expr-lookup-table
*operator-ascii-lookup-alist*) *operator-ascii-lookup-alist*)
(box-lookup-table (box-lookup-table
*table-border-ascii-alist*)) *table-border-ascii-alist*)
latin-truths)
"Convert TABLE, which should be a truth table as returned by "Convert TABLE, which should be a truth table as returned by
`create-truth-table' to text. `create-truth-table' to text.
NOTE: though the overall order does not matter, the order must be the same NOTE: though the overall order does not matter, the order must be the same
between each row." between each row."
(let* ((typeset-exprs (mapcar (lambda (expr) (let* ((typeset-exprs (mapcar (lambda (expr)
(typeset-proposition (typeset-proposition
expr :lookup-table expr-lookup-table)) expr :lookup-table expr-lookup-table
:latin-truths latin-truths))
(extract-truth-table-expressions table))) (extract-truth-table-expressions table)))
(col-widths (mapcar (lambda (expr) (col-widths (mapcar (lambda (expr)
(+ (length expr) 2)) (+ (length expr) 2))
@ -307,8 +346,12 @@ between each row."
;; convert t or nil to strings ;; convert t or nil to strings
(mapcar (lambda (entry) (mapcar (lambda (entry)
(cdr (assoc (if entry (cdr (assoc (if entry
'true (if latin-truths
'false) 'latin-true
'true)
(if latin-truths
'latin-false
'false))
expr-lookup-table))) expr-lookup-table)))
row) row)
(cdr (assoc 'vertical box-lookup-table))) (cdr (assoc 'vertical box-lookup-table)))
@ -323,17 +366,24 @@ between each row."
'("unicode" "ascii" "latex" "html") '("unicode" "ascii" "latex" "html")
"The known formats that `typeset-table-to-format' can take.") "The known formats that `typeset-table-to-format' can take.")
(defun typeset-table-to-format (table format) (defun typeset-table-to-format (table format
&key pretty-print latin-truths)
"Typeset TABLE into FORMAT, or error if FORMAT is not a know format." "Typeset TABLE into FORMAT, or error if FORMAT is not a know format."
(cond (cond
((equal format "unicode") ((equal format "unicode")
(typeset-truth-table table *operator-unicode-lookup-alist* (typeset-truth-table table *operator-unicode-lookup-alist*
*table-border-unicode-alist*)) *table-border-unicode-alist*
latin-truths))
((equal format "ascii") ((equal format "ascii")
(typeset-truth-table table *operator-ascii-lookup-alist* (typeset-truth-table table *operator-ascii-lookup-alist*
*table-border-ascii-alist*)) *table-border-ascii-alist*
latin-truths))
((equal format "latex") ((equal format "latex")
(convert-truth-table-to-latex table)) (convert-truth-table-to-latex table
:pretty-print pretty-print
:latin-truths latin-truths))
((equal format "html") ((equal format "html")
(convert-truth-table-to-html table)) (convert-truth-table-to-html table
:pretty-print pretty-print
:latin-truths latin-truths))
(t (error 'table-format-error :format format)))) (t (error 'table-format-error :format format))))

42
web.lisp
View File

@ -43,6 +43,10 @@
:accessor truth-table-data) :accessor truth-table-data)
(format :initform "html" (format :initform "html"
:accessor truth-table-format) :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 (output-visible :initform t
:accessor truth-table-output-visible)) :accessor truth-table-output-visible))
(:documentation "Class to hold the generated table.")) (:documentation "Class to hold the generated table."))
@ -58,13 +62,17 @@ reblocks bug.")
(defmethod render ((table truth-table)) (defmethod render ((table truth-table))
"Render TABLE." "Render TABLE."
(with-slots (data format output-visible) table (with-slots (data format pretty-print latin-truths output-visible) table
(let* ((html-text (convert-truth-table-to-html data)) (let* ((html-text (convert-truth-table-to-html data
:pretty-print pretty-print
:latin-truths latin-truths))
(other-text (other-text
(when output-visible (when output-visible
(if (equal format "html") (if (equal format "html")
html-text html-text
(typeset-table-to-format data format))))) (typeset-table-to-format data format
:pretty-print pretty-print
:latin-truths latin-truths)))))
(when data (when data
(with-html (with-html
(:div :class "label" "Output:") (:div :class "label" "Output:")
@ -80,7 +88,8 @@ reblocks bug.")
(if output-visible (if output-visible
"⏷" "⏷"
"⏵")) "⏵"))
(if (or (equal format "ascii") (if (or pretty-print
(equal format "ascii")
(equal format "unicode")) (equal format "unicode"))
(:pre :id "output-area" :hidden (not output-visible) (:pre :id "output-area" :hidden (not output-visible)
other-text) other-text)
@ -171,7 +180,7 @@ reblocks bug.")
(defmethod handle-generate-request ((page page) (defmethod handle-generate-request ((page page)
&key prop-str implicit-and multi-char-names &key prop-str implicit-and multi-char-names
format include-vars subexps) format include-vars subexps latin pretty)
"Handler for requests to generate truth tables." "Handler for requests to generate truth tables."
(with-slots (table error-box) page (with-slots (table error-box) page
(setf (truth-table-format table) format (setf (truth-table-format table) format
@ -186,7 +195,9 @@ reblocks bug.")
(setf (truth-table-data table) (create-truth-table parsed-exp (setf (truth-table-data table) (create-truth-table parsed-exp
:vars vars :vars vars
:include-vars include-vars :include-vars include-vars
:include-intermediate subexps))) :include-intermediate subexps)
(truth-table-latin-truths table) latin
(truth-table-pretty-print table) pretty))
((or proposition-parse-error proposition-eval-error) (e) ((or proposition-parse-error proposition-eval-error) (e)
(setf (error-box-message error-box) (princ-to-string e)))) (setf (error-box-message error-box) (princ-to-string e))))
(setf (truth-table-data table) nil)) (setf (truth-table-data table) nil))
@ -200,15 +211,18 @@ reblocks bug.")
(:h1 "Truth Table Generator") (:h1 "Truth Table Generator")
(with-html-form (:POST (lambda (&key prop-str implicit-and (with-html-form (:POST (lambda (&key prop-str implicit-and
multi-char-names format multi-char-names format
include-vars subexps include-vars subexps latin
pretty
&allow-other-keys) &allow-other-keys)
(handle-generate-request (handle-generate-request
page :prop-str prop-str page :prop-str prop-str
:implicit-and implicit-and :implicit-and implicit-and
:multi-char-names multi-char-names :multi-char-names multi-char-names
:format format :format format
:include-vars include-vars :include-vars include-vars
:subexps subexps))) :subexps subexps
:pretty pretty
:latin latin)))
(:div :id "main-controls-wrapper" (:div :id "main-controls-wrapper"
(:input :id "prop-input-field" (:input :id "prop-input-field"
:type "text" :type "text"
@ -236,6 +250,16 @@ reblocks bug.")
:checked t :checked t
:style "margin-left: 10px;") :style "margin-left: 10px;")
(:label :for "subexps" "Include Sub-expressions") (: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;" (:select :name "format" :style "margin-left: 10px;"
(:option :value "html" "HTML") (:option :value "html" "HTML")
(:option :value "latex" "LaTeX") (:option :value "latex" "LaTeX")