94 lines
4.0 KiB
Common Lisp
94 lines
4.0 KiB
Common 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 discover-variables (prop)
|
||
|
|
"Return a list of all the variables in PROP, in left to right order."
|
||
|
|
(cond
|
||
|
|
((stringp prop)
|
||
|
|
(list prop))
|
||
|
|
((listp prop)
|
||
|
|
(mapcan 'discover-variables (cdr prop)))))
|
||
|
|
|
||
|
|
(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."
|
||
|
|
(if (null vars)
|
||
|
|
(list (list (cons prop (eval-proposition prop '()))))
|
||
|
|
(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
|
||
|
|
(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."
|
||
|
|
(loop for (expr . value) in (car table)
|
||
|
|
collect expr))
|
||
|
|
|
||
|
|
(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."
|
||
|
|
(loop for row in table
|
||
|
|
collect (mapcar 'cdr row)))
|
||
|
|
|
||
|
|
|
||
|
|
(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)))
|