Refactor to use ASDF
This commit is contained in:
272
typeset.lisp
Normal file
272
typeset.lisp
Normal file
@ -0,0 +1,272 @@
|
||||
;; 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))))
|
||||
Reference in New Issue
Block a user