Add pretty print and latin truth values support
This commit is contained in:
parent
c86b38db09
commit
edd4f53a68
GPG Key ID:
5FD0394ADBD72730
16
cli.lisp
16
cli.lisp
@ -24,7 +24,9 @@
|
||||
(implicit-and t)
|
||||
multi-char-names
|
||||
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
|
||||
proposition strings. For a description of the key parameters, see each of the
|
||||
functions involved in evaluating and typesetting."
|
||||
@ -44,7 +46,9 @@ functions involved in evaluating and typesetting."
|
||||
exps vars
|
||||
:include-intermediate include-intermediate
|
||||
: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*
|
||||
'((#\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")
|
||||
(#\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")
|
||||
(#\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:
|
||||
(short long symbol has-arg-p desc).")
|
||||
|
||||
@ -93,7 +99,9 @@ arguments."
|
||||
: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)))
|
||||
:include-intermediate (option-value 'subexps opts)
|
||||
:pretty-print (option-value 'pretty opts)
|
||||
:latin-truths (option-value 'latin opts)))
|
||||
(terpri))))))))
|
||||
|
||||
(defun toplevel ()
|
||||
|
||||
138
typeset.lisp
138
typeset.lisp
@ -36,7 +36,9 @@
|
||||
(open-paren . "(")
|
||||
(close-paren . ")")
|
||||
(true . "T")
|
||||
(false . "F"))
|
||||
(false . "F")
|
||||
(latin-true . "T")
|
||||
(latin-false . "F"))
|
||||
"Lookup table mapping operators to their ASCII representation.")
|
||||
|
||||
(defparameter *operator-unicode-lookup-alist*
|
||||
@ -52,7 +54,9 @@
|
||||
(open-paren . "(")
|
||||
(close-paren . ")")
|
||||
(true . "⊤")
|
||||
(false . "⊥"))
|
||||
(false . "⊥")
|
||||
(latin-true . "T")
|
||||
(latin-false . "F"))
|
||||
"Lookup table mapping operators to their Unicode representation.")
|
||||
|
||||
(defparameter *operator-latex-lookup-alist*
|
||||
@ -68,7 +72,9 @@
|
||||
(open-paren . "\\left(")
|
||||
(close-paren . "\\right)")
|
||||
(true . "\\top")
|
||||
(false . "\\bot"))
|
||||
(false . "\\bot")
|
||||
(latin-true . "\\textrm{T}")
|
||||
(latin-false . "\\textrm{F}"))
|
||||
"Lookup table mapping operators to their LaTeX representation.")
|
||||
|
||||
(defparameter *operator-html-lookup-alist*
|
||||
@ -84,7 +90,9 @@
|
||||
(open-paren . "(")
|
||||
(close-paren . ")")
|
||||
(true . "⊤")
|
||||
(false . "⊥"))
|
||||
(false . "⊥")
|
||||
(latin-true . "T")
|
||||
(latin-false . "F"))
|
||||
"Lookup table mapping operators to their HTML representation.")
|
||||
|
||||
(defun latex-var-name-transform (name)
|
||||
@ -112,7 +120,8 @@
|
||||
(defun typeset-proposition (expr &key
|
||||
(lookup-table *operator-ascii-lookup-alist*)
|
||||
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
|
||||
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
|
||||
@ -128,9 +137,14 @@ use (it controls when parentheses are applied.)"
|
||||
(funcall var-name-transform expr)
|
||||
expr))
|
||||
;; expr is true or false
|
||||
((or (eq expr 'true)
|
||||
(eq expr 'false))
|
||||
(cdr (assoc expr lookup-table)))
|
||||
((eq expr 'true)
|
||||
(if latin-truths
|
||||
(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
|
||||
(t
|
||||
(destructuring-bind (oper first-arg &rest args) expr
|
||||
@ -146,6 +160,7 @@ use (it controls when parentheses are applied.)"
|
||||
(typeset-proposition first-arg
|
||||
:lookup-table lookup-table
|
||||
:var-name-transform var-name-transform
|
||||
:latin-truths latin-truths
|
||||
:parent-prec our-prec)
|
||||
(cdr prefix-suffix))
|
||||
;; we have many arguments
|
||||
@ -155,39 +170,49 @@ use (it controls when parentheses are applied.)"
|
||||
(typeset-proposition arg
|
||||
:lookup-table lookup-table
|
||||
:var-name-transform var-name-transform
|
||||
:latin-truths latin-truths
|
||||
:parent-prec our-prec)
|
||||
into output
|
||||
finally
|
||||
(push (typeset-proposition first-arg
|
||||
:lookup-table lookup-table
|
||||
:var-name-transform var-name-transform
|
||||
:latin-truths latin-truths
|
||||
:parent-prec our-prec)
|
||||
output)
|
||||
(return (format nil "~A~{~A~^ ~}~A" (car 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
|
||||
`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
|
||||
between each row."
|
||||
(let ((typeset-exprs (mapcar (lambda (expr)
|
||||
(typeset-proposition
|
||||
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))))
|
||||
(format nil "~
|
||||
\\begin{tabular}{~{~*|c~}|}~
|
||||
\\hline~
|
||||
~{ $ ~A $~^ &~} \\\\ ~
|
||||
\\hline~
|
||||
~{~{ $ ~:[\\bot~;\\top~] $~^ &~} \\\\ ~}~
|
||||
\\hline~
|
||||
\\end{tabular}"
|
||||
typeset-exprs
|
||||
typeset-exprs
|
||||
(extract-truth-table-values table))))
|
||||
(with-output-to-string (str)
|
||||
(format str "~
|
||||
\\begin{tabular}{~{~*|c~}|}~@[~% ~*~]~
|
||||
\\hline~:[ ~;~% ~]~
|
||||
~{$ ~A $~^ & ~} \\\\~:[ ~;~% ~]~
|
||||
\\hline~:[ ~;~% ~]"
|
||||
typeset-exprs
|
||||
pretty-print pretty-print
|
||||
typeset-exprs
|
||||
pretty-print pretty-print)
|
||||
(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)
|
||||
"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))))
|
||||
|
||||
|
||||
(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
|
||||
`create-truth-table' to HTML. CLASS and ID are their respective HTML
|
||||
properties. MORE-PROPS is an alist mapping properties to values.
|
||||
NOTE: though the overall order does not matter, the order must be the same
|
||||
between each row."
|
||||
(let ((typeset-exprs (mapcar (lambda (expr)
|
||||
(typeset-proposition
|
||||
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>~:[⊥~;⊤~]</td>~}</tr>~}~
|
||||
</table>"
|
||||
(with-output-to-string (str)
|
||||
(format str "<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~@[~% ~*~]<tr>"
|
||||
class id (format-html-properties-alist more-props)
|
||||
typeset-exprs
|
||||
(extract-truth-table-values table))))
|
||||
pretty-print)
|
||||
(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~]"
|
||||
"~:[⊥~;⊤~]")
|
||||
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*
|
||||
'((vertical . #\|)
|
||||
@ -274,14 +311,16 @@ length of each column."
|
||||
(expr-lookup-table
|
||||
*operator-ascii-lookup-alist*)
|
||||
(box-lookup-table
|
||||
*table-border-ascii-alist*))
|
||||
*table-border-ascii-alist*)
|
||||
latin-truths)
|
||||
"Convert TABLE, which should be a truth table as returned by
|
||||
`create-truth-table' to text.
|
||||
NOTE: though the overall order does not matter, the order must be the same
|
||||
between each row."
|
||||
(let* ((typeset-exprs (mapcar (lambda (expr)
|
||||
(typeset-proposition
|
||||
expr :lookup-table expr-lookup-table))
|
||||
expr :lookup-table expr-lookup-table
|
||||
:latin-truths latin-truths))
|
||||
(extract-truth-table-expressions table)))
|
||||
(col-widths (mapcar (lambda (expr)
|
||||
(+ (length expr) 2))
|
||||
@ -307,8 +346,12 @@ between each row."
|
||||
;; convert t or nil to strings
|
||||
(mapcar (lambda (entry)
|
||||
(cdr (assoc (if entry
|
||||
'true
|
||||
'false)
|
||||
(if latin-truths
|
||||
'latin-true
|
||||
'true)
|
||||
(if latin-truths
|
||||
'latin-false
|
||||
'false))
|
||||
expr-lookup-table)))
|
||||
row)
|
||||
(cdr (assoc 'vertical box-lookup-table)))
|
||||
@ -323,17 +366,24 @@ between each row."
|
||||
'("unicode" "ascii" "latex" "html")
|
||||
"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."
|
||||
(cond
|
||||
((equal format "unicode")
|
||||
(typeset-truth-table table *operator-unicode-lookup-alist*
|
||||
*table-border-unicode-alist*))
|
||||
*table-border-unicode-alist*
|
||||
latin-truths))
|
||||
((equal format "ascii")
|
||||
(typeset-truth-table table *operator-ascii-lookup-alist*
|
||||
*table-border-ascii-alist*))
|
||||
*table-border-ascii-alist*
|
||||
latin-truths))
|
||||
((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")
|
||||
(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))))
|
||||
|
||||
42
web.lisp
42
web.lisp
@ -43,6 +43,10 @@
|
||||
: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."))
|
||||
@ -58,13 +62,17 @@ 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))
|
||||
(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)))))
|
||||
(typeset-table-to-format data format
|
||||
:pretty-print pretty-print
|
||||
:latin-truths latin-truths)))))
|
||||
(when data
|
||||
(with-html
|
||||
(:div :class "label" "Output:")
|
||||
@ -80,7 +88,8 @@ reblocks bug.")
|
||||
(if output-visible
|
||||
"⏷"
|
||||
"⏵"))
|
||||
(if (or (equal format "ascii")
|
||||
(if (or pretty-print
|
||||
(equal format "ascii")
|
||||
(equal format "unicode"))
|
||||
(:pre :id "output-area" :hidden (not output-visible)
|
||||
other-text)
|
||||
@ -171,7 +180,7 @@ reblocks bug.")
|
||||
|
||||
(defmethod handle-generate-request ((page page)
|
||||
&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."
|
||||
(with-slots (table error-box) page
|
||||
(setf (truth-table-format table) format
|
||||
@ -186,7 +195,9 @@ reblocks bug.")
|
||||
(setf (truth-table-data table) (create-truth-table parsed-exp
|
||||
:vars 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)
|
||||
(setf (error-box-message error-box) (princ-to-string e))))
|
||||
(setf (truth-table-data table) nil))
|
||||
@ -200,15 +211,18 @@ reblocks bug.")
|
||||
(:h1 "Truth Table Generator")
|
||||
(with-html-form (:POST (lambda (&key prop-str implicit-and
|
||||
multi-char-names format
|
||||
include-vars subexps
|
||||
include-vars subexps latin
|
||||
pretty
|
||||
&allow-other-keys)
|
||||
(handle-generate-request
|
||||
page :prop-str prop-str
|
||||
:implicit-and implicit-and
|
||||
:implicit-and implicit-and
|
||||
:multi-char-names multi-char-names
|
||||
:format format
|
||||
:include-vars include-vars
|
||||
:subexps subexps)))
|
||||
:subexps subexps
|
||||
:pretty pretty
|
||||
:latin latin)))
|
||||
(:div :id "main-controls-wrapper"
|
||||
(:input :id "prop-input-field"
|
||||
:type "text"
|
||||
@ -236,6 +250,16 @@ reblocks bug.")
|
||||
: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")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user