Add pretty print and latin truth values support
This commit is contained in:
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))))
|
||||
|
||||
Reference in New Issue
Block a user