truth-table/table.lisp

;; table.lisp -- Generate tables from parsed propositions
;; 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)

(defun flatten-tree (tree)
  "Flatten TREE into a single list."
  (if (atom tree)
      (list tree)
      (apply 'append (mapcar 'flatten-tree tree))))

(defun discover-variables (prop)
  "Return a list of all the variables in PROP, in left to right order."
  (let ((vars))
    (dolist (item (flatten-tree prop) (nreverse vars))
      (when (stringp item)
        (pushnew item vars :test 'equal)))))

(defun permute-variables (vars)
  "Return a list of alists, each with a different permutation of VARS."
  (loop for var in vars
        for perms = (list (list (cons (car vars) t))
                          (list (cons (car vars) nil)))
          then (loop for entry in perms
                     collect (cons (cons var t) entry)
                     collect (cons (cons var nil) entry))
        finally (return (mapcar 'reverse perms))))

(defun create-truth-table (prop &key (vars (discover-variables prop))
                                  (include-intermediate t) (include-vars t))
  "Evaluate PROP with all possible combinations of truth values for its
variables. If supplied VARS should be a list of all the know variables in PORP,
if it is excluded, `discover-variables' will be used to generate it."
  (cond
    ((null prop)
     (list (list (cons nil nil))))
    ((null vars)
     (list (list (cons prop (eval-proposition prop '())))))
    (t
     (loop for perm in (permute-variables vars)
           for (value sub-map) = (multiple-value-list
                                  (eval-proposition prop perm))
           collect
           (append (when include-vars perm)
                   (when include-intermediate
                     (reverse (delete-if (lambda (item) (equal prop (car item)))
                                         sub-map)))
                   (list (cons prop value)))))))

(defun extract-truth-table-expressions (table)
  "Extract each expression from TABLE and return them as a list.
NOTE: this just gets each expression from the first row, assuming each row has
the same expressions."
  (mapcar 'car (car table)))

(defun extract-truth-table-values (table)
  "Return a new table, where each row consists of just the value of the
expression that was originally in that spot in TABLE."
  (mapcar (lambda (row)
            (mapcar 'cdr row))
          table))


(defun combine-tables (table1 table2)
  "Join TABLE1 and TABLE2. Both tables must have the same number of rows.
TABLE1 is modified during this process."
  (loop for row1 in table1
        for row2 in table2
        do
           (setf (cdr (last row1)) row2))
  (mapcar 'keep-unique-expressions table1))

(defun create-combined-truth-table (props vars &key (include-intermediate nil)
                                                 (include-vars t))
  "Create a large truth table from all the propositions in PROPS. The other
arguments are as they are in `create-truth-table'."
  (loop with output-table = (create-truth-table
                             (car props)
                             :vars vars
                             :include-intermediate include-intermediate
                             :include-vars include-vars)
        for prop in (cdr props)
        for first-iter = t then nil do
          (setq output-table
                (combine-tables output-table
                                (create-truth-table
                                 prop :vars vars
                                 :include-intermediate include-intermediate
                                 :include-vars nil)))
        finally (return output-table)))