From edd4f53a6801b5a774b7da187f51357b661c1d80 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Tue, 10 Sep 2024 22:19:43 -0700 Subject: [PATCH] Add pretty print and latin truth values support --- cli.lisp | 16 ++++-- typeset.lisp | 138 +++++++++++++++++++++++++++++++++++---------------- web.lisp | 42 ++++++++++++---- 3 files changed, 139 insertions(+), 57 deletions(-) diff --git a/cli.lisp b/cli.lisp index f2523df..96b2808 100644 --- a/cli.lisp +++ b/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 () diff --git a/typeset.lisp b/typeset.lisp index a8e4b5f..743b42a 100644 --- a/typeset.lisp +++ b/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 "~ -~ - ~{~A~}~ - ~{~{~:[⊥~;⊤~]~}~}~ -" + (with-output-to-string (str) + (format str "~@[~% ~*~]" 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 "~@[~% ~*~]~a" + pretty-print + (typeset-proposition + expr :lookup-table *operator-html-lookup-alist* + :var-name-transform 'html-var-name-transform))) + (format str "~@[~% ~]" pretty-print) + (dolist (row (extract-truth-table-values table)) + (format str "~@[~% ~*~]~@[~% ~*~]" 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 "~?" truth-str (list value)) + when (and pretty-print (cdr now)) do + (format str "~% ")) + (format str "~@[~% ~*~]" pretty-print)) + (format str "~@[~%~]" 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)))) diff --git a/web.lisp b/web.lisp index 8dc8e03..b70cecf 100644 --- a/web.lisp +++ b/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")