;; 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")
    (latin-true . "T")
    (latin-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 . "⊥")
    (latin-true . "T")
    (latin-false . "F"))
  "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")
    (latin-true . "\\textrm{T}")
    (latin-false . "\\textrm{F}"))
  "Lookup table mapping operators to their LaTeX representation.")

(defparameter *operator-html-lookup-alist*
  '((and . "&and;")
    (nand . "&uarr;")
    (or . "&or;")
    (nor . "&darr;")
    (xor . "&oplus;")
    (not . "&not;")
    (implies . "&rarr;")
    (converse . "&larr;")
    (iff . "&harr;")
    (open-paren . "(")
    (close-paren . ")")
    (true . "&top;")
    (false . "&perp;")
    (latin-true . "T")
    (latin-false . "F"))
  "Lookup table mapping operators to their HTML 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 html-var-name-transform (name)
  "Transform NAME so that it is escaped for use in HTML."
  (format nil "~{~A~}" (loop for char across name
                             if (eq char #\<)
                               collect "&lt;"
                             else if (eq char #\>)
                                    collect "&gt;"
                             else
                               collect char)))

(defun typeset-proposition (expr &key
                                   (lookup-table *operator-ascii-lookup-alist*)
                                   var-name-transform
                                   (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
escape it for use in the target typesetting system. PARENT-PERC is for internal
use (it controls when parentheses are applied.)"
  (cond
    ;; expr is empty
    ((null expr)
     "")
    ;; expr is a variable name
    ((stringp expr)
     (if var-name-transform 
         (funcall var-name-transform expr)
         expr))
    ;; expr is true or false
    ((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
       (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 lookup-table
                                          :var-name-transform var-name-transform
                                          :latin-truths latin-truths
                                          :parent-prec 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 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 &key pretty-print latin-truths)
  "Convert TABLE, which should be a truth table as returned by
`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
                                       :latin-truths latin-truths))
                               (extract-truth-table-expressions 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."
  (loop for (name . value) in props
        when (eq value t)
          collect (format nil "~A=\"\"" name)
        else when value
               collect (format nil "~A=~S" name (princ-to-string value))))


(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."
  (with-output-to-string (str)
    (format str "<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~@[~%  ~*~]<tr>"
            class id (format-html-properties-alist more-props)
            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~]"
                                  "~:[&perp;~;&top;~]")
            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 . #\|)
    (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*)
                                    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
                                        :latin-truths latin-truths))
                                (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
                                                     (if latin-truths
                                                         'latin-true
                                                         'true)
                                                     (if latin-truths
                                                         'latin-false
                                                         '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" "html")
  "The known formats that `typeset-table-to-format' can take.")

(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*
                          latin-truths))
    ((equal format "ascii")
     (typeset-truth-table table *operator-ascii-lookup-alist*
                          *table-border-ascii-alist*
                          latin-truths))
    ((equal format "latex")
     (convert-truth-table-to-latex table
                                   :pretty-print pretty-print
                                   :latin-truths latin-truths))
    ((equal format "html")
     (convert-truth-table-to-html table
                                  :pretty-print pretty-print
                                  :latin-truths latin-truths))
    (t (error 'table-format-error :format format))))