273 lines
10 KiB
Common Lisp
273 lines
10 KiB
Common Lisp
;; typeset.lisp -- Typeset proposition 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/>.
|
||
(in-package :truth-table/base)
|
||
|
||
(define-condition table-format-error (error)
|
||
((format :initarg :format
|
||
:accessor table-format-error-format))
|
||
(:report
|
||
(lambda (con stream)
|
||
(format stream "unknown table format: ~a"
|
||
(table-format-error-format con)))))
|
||
|
||
(defparameter *operator-ascii-lookup-alist*
|
||
'((and . "&")
|
||
(nand . "nand")
|
||
(or . "|")
|
||
(nor . "nor")
|
||
(xor . "^")
|
||
(not . "~")
|
||
(implies . "->")
|
||
(converse . "<-")
|
||
(iff . "<->")
|
||
(open-paren . "(")
|
||
(close-paren . ")")
|
||
(true . "T")
|
||
(false . "F"))
|
||
"Lookup table mapping operators to their ASCII representation.")
|
||
|
||
(defparameter *operator-unicode-lookup-alist*
|
||
'((and . "∧")
|
||
(nand . "⊼")
|
||
(or . "∨")
|
||
(nor . "⊽")
|
||
(xor . "⊕")
|
||
(not . "¬")
|
||
(implies . "→")
|
||
(converse . "←")
|
||
(iff . "↔")
|
||
(open-paren . "(")
|
||
(close-paren . ")")
|
||
(true . "⊤")
|
||
(false . "⊥"))
|
||
"Lookup table mapping operators to their Unicode representation.")
|
||
|
||
(defparameter *operator-latex-lookup-alist*
|
||
'((and . "\\land")
|
||
(nand . "\\uparrow")
|
||
(or . "\\lor")
|
||
(nor . "\\downarrow")
|
||
(xor . "\\oplus")
|
||
(not . "\\lnot ")
|
||
(implies . "\\to")
|
||
(converse . "\\gets")
|
||
(iff . "\\leftrightarrow")
|
||
(open-paren . "\\left(")
|
||
(close-paren . "\\right)")
|
||
(true . "\\top")
|
||
(false . "\\bot"))
|
||
"Lookup table mapping operators to their LaTeX representation.")
|
||
|
||
(defun latex-var-name-transform (name)
|
||
"Transform NAME so that it is escaped for use in LaTeX."
|
||
(format nil "{~{~A~}}" (loop for char across name
|
||
if (eq char #\\)
|
||
collect "\\backslash "
|
||
else if (eq char #\_)
|
||
collect "\\_"
|
||
else if (eq char #\$)
|
||
collect "\\$"
|
||
else
|
||
collect char)))
|
||
|
||
(defun typeset-proposition (expr &optional
|
||
(lookup-table *operator-ascii-lookup-alist*)
|
||
var-name-transform
|
||
(parent-prec most-positive-fixnum))
|
||
"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
|
||
escape it for use in the target typesetting system. PARENT-PERC is for internal
|
||
use (it controls when parentheses are applied.)"
|
||
(cond
|
||
;; expr is a variable name
|
||
((stringp expr)
|
||
(if var-name-transform
|
||
(funcall var-name-transform expr)
|
||
expr))
|
||
;; expr is true or false
|
||
((or (eq expr 'true)
|
||
(eq expr 'false))
|
||
(cdr (assoc expr lookup-table)))
|
||
;; expr is a compound expression
|
||
(t
|
||
(destructuring-bind (oper first-arg &rest args) expr
|
||
(let* ((our-prec (operator-precedence oper))
|
||
(oper-ascii (cdr (assoc oper lookup-table)))
|
||
(prefix-suffix (if (< parent-prec our-prec)
|
||
(cons (cdr (assoc 'open-paren lookup-table))
|
||
(cdr (assoc 'close-paren lookup-table)))
|
||
'("" . ""))))
|
||
(if (null args)
|
||
;; we have one argument
|
||
(format nil "~A~A~A~A" (car prefix-suffix) oper-ascii
|
||
(typeset-proposition first-arg lookup-table
|
||
var-name-transform our-prec)
|
||
(cdr prefix-suffix))
|
||
;; we have many arguments
|
||
(loop for arg in args
|
||
collect oper-ascii into output
|
||
collect
|
||
(typeset-proposition arg lookup-table
|
||
var-name-transform our-prec)
|
||
into output
|
||
finally
|
||
(push (typeset-proposition first-arg lookup-table
|
||
var-name-transform our-prec)
|
||
output)
|
||
(return (format nil "~A~{~A~^ ~}~A" (car prefix-suffix)
|
||
output (cdr prefix-suffix))))))))))
|
||
|
||
|
||
(defun convert-truth-table-to-latex (table)
|
||
"Convert TABLE, which should be a truth table as returned by
|
||
`create-truth-table' to latex.
|
||
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 *operator-latex-lookup-alist*
|
||
'latex-var-name-transform))
|
||
(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))))
|
||
|
||
(defparameter *table-border-ascii-alist*
|
||
'((vertical . #\|)
|
||
(horizontal . #\-)
|
||
(right . #\|)
|
||
(left . #\|)
|
||
(up . #\-)
|
||
(down . #\-)
|
||
(cross . #\+)
|
||
(top-left . #\+)
|
||
(top-right . #\+)
|
||
(bottom-left . #\+)
|
||
(bottom-right . #\+))
|
||
"Characters used to draw ASCII table borders.")
|
||
|
||
(defparameter *table-border-unicode-alist*
|
||
'((vertical . #\│)
|
||
(horizontal . #\─)
|
||
(right . #\├)
|
||
(left . #\┤)
|
||
(up . #\┴)
|
||
(down . #\┬)
|
||
(cross . #\┼)
|
||
(top-left . #\┌)
|
||
(top-right . #\┐)
|
||
(bottom-left . #\└)
|
||
(bottom-right . #\┘))
|
||
"Characters used to draw Unicode table borders.")
|
||
|
||
(defun typeset-table-break (stream lengths horiz start column end)
|
||
"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
|
||
drawing."
|
||
(format stream "~c" start)
|
||
(loop for (length . rest) = lengths then rest
|
||
while length
|
||
do
|
||
(format stream "~a"
|
||
(make-string length :initial-element horiz))
|
||
when rest do
|
||
(format stream "~c" column))
|
||
(format stream "~c" end))
|
||
|
||
(defun typeset-table-row (stream lengths row vert)
|
||
"Typeset ROW to STREAM. VERT is the vertical separator. LENGTHS should be the
|
||
length of each column."
|
||
(loop for col in row
|
||
for length in lengths
|
||
do
|
||
(format stream "~c~v:@<~a~>" vert length col))
|
||
(format stream "~c" vert))
|
||
|
||
(defun typeset-truth-table (table &optional
|
||
(expr-lookup-table
|
||
*operator-ascii-lookup-alist*)
|
||
(box-lookup-table
|
||
*table-border-ascii-alist*))
|
||
"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 expr-lookup-table))
|
||
(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
|
||
'true
|
||
'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))))))
|
||
|
||
(defparameter *known-formats*
|
||
'("unicode" "ascii" "latex")
|
||
"The known formats that `typeset-table-to-format' can take.")
|
||
|
||
(defun typeset-table-to-format (table format)
|
||
"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*))
|
||
((equal format "ascii")
|
||
(typeset-truth-table table *operator-ascii-lookup-alist*
|
||
*table-border-ascii-alist*))
|
||
((equal format "latex")
|
||
(convert-truth-table-to-latex table))
|
||
(t (error 'table-format-error :format format))))
|