CLISP Program to determine the truth table is inconsistent, valid or invalid

Question

I just have a small problem on the loop catching the condition on the generated truth table.. so you input a logical expression then it turns it into a truth table where it also interprets if it is valid or invalid or inconsistent. So far this is part of the program that interprets it, but it only catches invalid or valid... can you please guide me thru this? Thanks

*edit// So this is how the program runs:

*******Welcome!********

Type (LogicStart) to begin or (exit) to quit anytime.

;; Loaded file MyLogic.lisp

T [2]> (LogicStart) Enter Logical Expression or Formula: "(p^(~p))"

p (~p) (p^(~p))
T NIL NIL

NIL T NIL

The formula is Invalid

So the input is only a logical expression, then the output is a truth table for that expression.... and can also interpret it, But my code only has two intepretations: invalid or valid(tautology), since the example above should be inconsistent/unsatisfiable(since all interpretations of the formula/expression is false)

end edit

(defun interpret() ; interpret if valid or not or inconsistent
(setq lastcolumn (- (column) 1))
(setq lastcolumnROW 1)
(loop   
    (unless (aref (aref tbl lastcolumn) lastcolumnROW) (progn (princ "The formula is Invalid")(return)))

    (setq lastcolumnROW (+ lastcolumnROW 1))
    (when (= lastcolumnROW (+ 1 (row))) (progn (princ "The formula is a Tautology ") (return)))
)
)

edit two:///

This is LogicStart Function:

(defun LogicStart()  
;Function to run program

(princ "Enter Logical Expression or Formula: " )
(setq input (read))
;Get input

(format t "-----------------------------------------------~C" #\linefeed)

;Create two dimension array(table)
(setq tbl (make-array (column)))
(setq index 0)
(loop 
    (setf (aref tbl index) (make-array  (+ (row) 1)))   
    (setq index (+ 1 index))
    (when (= index (column))(return))
)

(setAtoms)
(setFirstValue)
(tblReplaceValue)
(watchTable)
(format t "-----------------------------------------------~C" #\linefeed)
(interpret)
)

setAtoms Function:

(defun setAtoms()
;Get ALL possible formula

(setq indexOFTBL (make-array (column)))

(setq openP (make-array (- (column) (length Latoms))))
; Get index of open Parenthesis

(setq cOpenP 0) 
(setq closeP (make-array (- (column) (length Latoms))))
;Get index of close Parenthesis

(setq cCloseP 0) 
(setq index 0)
(loop
    (when (char-equal (char input index) #\() 
        (progn
            (setf (aref openP cOpenP) index)
            (setq cOpenP (+ 1 cOpenP))
        )
    )
    (when (char-equal (char input index) #\)) 
        (progn
            (setf (aref closeP cCloseP) index)
            (setq cCloseP (+ 1 cCloseP))
        )
    )
    (setq index (+ 1 index))
    (when (= index (length input)) (return))
)
;(print openP)

;(print closeP)
(setq index 0)
(loop
    (if (< index (length Latoms))
        (progn
            (setf (aref (aref tbl index) 0) (char Latoms index))
            (setf (aref indexOFTBL index) index)
        )
        (progn
            (setq OpIndex cOpenP)
            (loop
                (setq OpIndex (- OpIndex 1))
                (setq CpIndex 0)
                (loop
                    (if (or (> (aref openP OpIndex) (aref closeP CpIndex)) (= -1 (aref closeP CpIndex)))
                        (progn 
                            (setq CpIndex (+ CpIndex 1))
                        )
                        (progn
                            (setf (aref (aref tbl index) 0) (subseq input (aref openP OpIndex) (+ 1 (aref closeP CpIndex))))
                            (setf (aref closeP CpIndex) -1)
                            (return)
                        )
                    )
                    (when (= CpIndex (length closeP))(return))
                )
                (setq index (+ index 1))
                (when (= OpIndex 0) (return))
            )
            (return)
        )
    )
    (setq index (+ index 1))
    (when (= index (column)) (return))
)
)

watchTable and column function

(defun watchTable()
; View table

(setq ro 0)
(loop
    (setq co 0)
    (loop
        (princ(aref (aref tbl co) ro))(format t "~C" #\tab)
        (setq co (+ 1 co))
        (when (= co (column))(return))
    )
    (format t "~C" #\linefeed)
    (setq ro (+ 1 ro))
    (when (= ro (+ (row) 1))(return))
)
)


(defun column()
; Get the number of columns
(+ (atoms) (symbols))
)

//edit 3 So for (OR A (NOT A)), the table lacks "not A" in @jkiiski's code

A   |   NOT A  |  (OR A (NOT A))
----+----------+--------
NIL |    T     |   T  
T   |   NIL    |   T  
This expression is a Tautology.

Another example for reference: While P implies Q, this code accepts implies as: >

 ; Logical Connectives:
 ; ~ negation
 ; - biconditional
 ; > conditional
 ; ^ and
 ; v or

; Example Input:
;   "(~((a^b)>c))"
;   "(p>q)"

p   q      p>q
T   T       T 
T   NIL    NIL 
NIL T       T
NIL NIL     T

Another example:
Enter an expression: "((p>q)^r)"
T <- True 
NIL <- False
--------------------------------------------
p   q   r   (p>q)   ((p>q)^r)   
T   T   T    T         T    
T   T   NIL  T        NIL   
T   NIL T    NIL      NIL   
T   NIL NIL  NIL      NIL   
NIL T   T    T         T    
NIL T   NIL  T        NIL   
NIL NIL T    T         T    
NIL NIL NIL  T        NIL   
--------------------------------------------

So it in (p>q)^r it shows p, q, r, (p>q) and finally (p>q)^r on the truth table..

edit four//

(defun generate-value-combinations (variables)
(let ((combinations (list)))
(labels ((generate (variables &optional (acc (list)))
           (if (endp variables)
               (push (reverse acc) combinations)
               (loop for value in '(t nil)
                     for var-cell = (cons (car variables) value)
                     do (generate (cdr variables) (cons var-cell acc))))))
  (generate variables)
  combinations)))

to this one?
(defun generate-value-combinations (variables)
(let ((combinations (list)))
(labels ((generate (variables &optional (acc (list)))
           (if (endp variables)
               (push (reverse acc) combinations)
               (loop for value in '(t nil)
                     for var-cell = (cons (car variables) value)
                     do (generate (cdr variables) (cons var-cell acc))))))
  (generate variables) nreverse combinations)))

Answer 1

Coredump already gave an answer, and I used his/her solution as a part of this (with minor modification), but since your code is not very lispy I figured I'd show another solution for learning purposes. This is rather quickly written so feel free to point out all the stupid mistakes...

In this code I'm assuming you want the logical expression to be given using the usual Lisp syntax (like (and a (or b c))).

Let's start with a function to extract all the variables used in the expression. I'll assume that everything that isn't a logical operator (AND, OR, > or NOT) is a variable. This takes a list as an argument, and uses a recursive function (EXTRACT) to walk over it, collecting all atoms that aren't operators into a list (VARIABLES). The list is finally reverse and returned.

(defun extract-variables (input)
  (let ((variables (list)))
    (labels ((extract (input)
               (if (atom input)
                   (unless (member input '(and or not > -))
                     ;; PUSHNEW only pushes variables that haven't
                     ;; already been added to the list.
                     (pushnew input variables))
                   ;; If INPUT is a list, use MAPC to apply EXTRACT
                   ;; to all its elements.
                   (mapc #'extract input))))
      (extract input)
      (nreverse variables))))

Things you should notice in this are:

1. Local variables should be defined using LET rather than SETQ.
2. Local functions are defined using LABELS.

You can test the function:

CL-USER> (extract-variables '(and a (or b c (not a))))
(A B C)

Next, let's write a function to generate all the possible value combinations for these variables. For simplicity, we'll use a list of association lists to hold the variables. An association list is a list that consists of key-value pairs. For example:

((A . T) (B . T))

You can use ASSOC to find elements in an association list. It will return the whole pair, so you usually need to use CDR to get just the value:

CL-USER> (cdr (assoc 'b '((a . nil) (b . t))))
T

So we want the list of value combinations for the expression (AND A B) to look something like this:

(((A . T) (B . T))
 ((A . T) (B . NIL) ; (B . NIL) would usually be printed (B)
 ((A . NIL) (B . T))
 ((A . NIL) (B . NIL)))

So, here's a function to achive this:

(defun generate-value-combinations (variables)
  (let ((combinations (list)))
    (labels ((generate (variables &optional (acc (list)))
               (if (endp variables)
                   (push (reverse acc) combinations)
                   (loop for value in '(nil t)
                         for var-cell = (cons (car variables) value)
                         do (generate (cdr variables) (cons var-cell acc))))))
      (generate variables)
      combinations)))

I used the same recursive pattern as in the previous function. The inner function accumulates the variable values into the optional argument ACC and when the end of the variable-list is reached, the accumulated association list is pushe to COMBINATIONS. The alist is reversed to maintain the same order the variables are given in. We can test it now:

CL-USER> (generate-value-combinations '(a b))
(((A) (B)) ((A) (B . T)) ((A . T) (B)) ((A . T) (B . T)))

Next we'll need a function to evaluate an expression using the variable values in one of those alists. We can do this easily with a recursive evaluator:

(defun evaluate (input variables)
  (labels (;; GET-VALUE is just a simple helper to get the value of 
           ;; a variable from the association list.
           (get-value (variable)
             (cdr (assoc variable variables)))
           (evaluator (input)
             (typecase input
               ;; For atoms we just return its value from the alist.
               (atom (get-value input))
               ;; Lists consist of an operator and arguments for it.
               ;; We only recognize three operators: AND, OR and NOT.
               (list (destructuring-bind (operator &rest args) input
                       (ecase operator
                         (and (loop for arg in args always (evaluator arg)))
                         (or (loop for arg in args thereis (evaluator arg)))
                         (> (not (and (evaluator (first args))
                                      (not (evaluator (second args))))))
                         (- (equal (evaluator (first args))
                                   (evaluator (second args))))
                         (not (not (evaluator (first args))))))))))
    (evaluator input)))

Again, let's test it:

CL-USER> (evaluate '(and a (or b c)) '((a . t) (b . nil) (c . t)))
T
CL-USER> (evaluate '(and a (or b c)) '((a . t) (b . nil) (c . nil)))
NIL

With these functions we could create a truth table like this:

CL-USER> (let ((input '(and a (or b c))))
           (mapcar (lambda (row)
                     (append (mapcar #'cdr row)
                             (list (evaluate input row))))
                   (generate-value-combinations (extract-variables input))))
((NIL NIL NIL NIL) (NIL NIL T NIL) (NIL T NIL NIL) (NIL T T NIL)
 (T NIL NIL NIL) (T NIL T T) (T T NIL T) (T T T T))

In each of the sublists the first three values are the values of the variables (since we have three values in our test-input). The last value is the value of the expression evaluated with those variable values.

Now let's write the function to check if the expression is satisfiable/etc. This is pretty much the same as in Coredumps answer. The main difference is that in this version the truth table is stored as a list, rather than as an array.

(defun interpret (truth-table)
  (loop for (value) in (mapcar #'last truth-table)
        for valid = value then (and valid value)
        for satisfiable = value then (or satisfiable value)
        finally (return (cond (valid :valid)
                              (satisfiable :satisfiable)
                              (t :unsatisfiable)))))

And finally let's connect everything:

(defun logic-start ()
  (format *query-io* "~&Enter A Logical Expression: ")
  (finish-output *query-io*)
  (let* ((input (read *query-io*))
         (variables (extract-variables input))
         (value-combinations (generate-value-combinations variables))
         ;; Gather all sub-expressions.
         (columns (labels ((collect-sub-expressions (expression)
                             (append (when (and (listp expression)
                                                (not (and (eql (first expression)
                                                               'not)
                                                          (atom (second expression)))))
                                       (loop for arg in (rest expression)
                                             append (collect-sub-expressions arg)))
                                     (list expression))))
                    (remove-duplicates (collect-sub-expressions input)
                                       :from-end t)))
         ;; Widths of the columns in the table.
         (column-widths (loop for column in columns
                              collect (max 3 (length (princ-to-string column)))))
         (truth-table (mapcar (lambda (variables)
                                (loop for col in columns
                                      for width in column-widths
                                      collect width
                                      ;; This is a bit wasteful, since
                                      ;; it evaluates every sub-expression
                                      ;; separately, as well as evaluating
                                      ;; the full expression.
                                      collect (evaluate col variables)))
                              value-combinations)))
    (format t "~&~{ ~{~v<~a~;~>~}~^ |~}~%~{-~v,,,'-<-~>-~^+~}~%"
            (mapcar #'list column-widths columns) column-widths)
    (format t "~&~{~{ ~v<~a~;~> ~^|~}~%~}" truth-table)
    (format t "~&This expression is ~a.~%"
            (case (interpret truth-table)
              (:valid "a Tautology")
              (:satisfiable "Satisfiable")
              (:unsatisfiable "Unsatisfiable")))))

And test it out:

CL-USER> (logic-start)
Enter A Logical Expression: (and a (not a))

 A   | (NOT A) | (AND A (NOT A))
-----+---------+-----------------
 NIL | T       | NIL             
 T   | NIL     | NIL             
This expression is Unsatisfiable.

NIL
CL-USER> (logic-start)
Enter A Logical Expression: (or a (not a))

 A   | (NOT A) | (OR A (NOT A))
-----+---------+----------------
 NIL | T       | T              
 T   | NIL     | T              
This expression is a Tautology.

NIL
CL-USER> (logic-start)
Enter A Logical Expression: (and a (or b c) (not d))

 A   | B   | C   | (OR B C) | (NOT D) | (AND A (OR B C) (NOT D))
-----+-----+-----+----------+---------+--------------------------
 NIL | NIL | NIL | NIL      | T       | NIL                      
 NIL | NIL | NIL | NIL      | NIL     | NIL                      
 NIL | NIL | T   | T        | T       | NIL                      
 NIL | NIL | T   | T        | NIL     | NIL                      
 NIL | T   | NIL | T        | T       | NIL                      
 NIL | T   | NIL | T        | NIL     | NIL                      
 NIL | T   | T   | T        | T       | NIL                      
 NIL | T   | T   | T        | NIL     | NIL                      
 T   | NIL | NIL | NIL      | T       | NIL                      
 T   | NIL | NIL | NIL      | NIL     | NIL                      
 T   | NIL | T   | T        | T       | T                        
 T   | NIL | T   | T        | NIL     | NIL                      
 T   | T   | NIL | T        | T       | T                        
 T   | T   | NIL | T        | NIL     | NIL                      
 T   | T   | T   | T        | T       | T                        
 T   | T   | T   | T        | NIL     | NIL                      
This expression is Satisfiable.

Parsing input

The easiest way to handle input like (a and b > q) would be to parse it into the regular Lisp syntax. Here's a quickly written parser to do that:

(defun find-and-split (item list)
  (let ((position (position item list :from-end t)))
    (when position
      (list (subseq list 0 position)
            item
            (subseq list (1+ position))))))

(defparameter *operator-precedence* '(- > or and))

(defun parse-input (input)
  (typecase input
    (atom input)
    (list (cond
            ((> (length input) 2)
             (dolist (op *operator-precedence* input)
               (let ((split (find-and-split op input)))
                 (when split
                   (destructuring-bind (left operator right) split
                     (return-from parse-input
                       (list operator
                             (parse-input left)
                             (parse-input right))))))))
            ((= (length input) 2) (mapcar #'parse-input input))
            (t (parse-input (first input)))))))

Testing:

CL-USER> (parse-input '(a and b > q))
(> (AND A B) Q)
CL-USER> (parse-input '((not q) or p and x))
(OR (NOT Q) (AND P X))
CL-USER> (parse-input '(q > p or y))
(> Q (OR P Y))

To add this to the program, just change the (READ *QUERY-IO*) in LOGIC-START to (PARSE-INPUT (READ *QUERY-IO*)).

Avoiding problems with - and > being read as a part of a variable name

Instead of reading the input directly with READ, you can use READ-LINE to read it as a string, then insert spaces around any - and >, and only then use READ-FROM-STRING to turn it into a list.

(defun insert-spaces (input-str)
  (with-output-to-string (str)
    (loop for char across input-str
          ;; Add a space before - or >
          when (or (char= char #\-)
                   (char= char #\>)) do (write-char #\space str)
          ;; Write the character itself.
          do (write-char char str)
             ;; Add a space after - or >
          when (or (char= char #\-)
                   (char= char #\>)) do (write-char #\space str))))

Testing:

CL-USER> (insert-spaces "((p and q)-r)")
"((p and q) - r)"

Then change the (PARSE-INPUT (READ *QUERY-IO*)) to (parse-input (read-from-string (insert-spaces (read-line *query-io*))))

Answer 2

You are using idioms from C in Common Lisp, with too many SETQ expressions mutating global variables: (i) SETQ with unbound identifiers has undefined behavior; (ii) global variables make your code non-reentrant and non thread-safe. Also, the way you create your two-dimensional array looks like how it is done in C. MAKE-ARRAY accepts a list for multiple dimensions:

 (make-array (list row column) :initial-element nil)

But let's keep your version for now. You have to iterate over the last column. Since you store columns in an array, you can retrieve the last column as follows:

(aref table (1- (length table)))

Then you can interpret the last column by iterating over each of its elements:

(defun interpret (table)
  (let ((last-column 
         (aref table (1- (length table)))))
    (loop
       for value across last-column
       for valid = value then (and valid value)
       for satisfiable = value then (or satisfiable value) 
       finally
         (return
           (cond
             (valid       :valid)
             (satisfiable :satisfiable)
             (t           :unsatisfiable))))))

So here I just iterate over all values while computing two predicates:

• valid is true when all values are true;
• satisfiable is true as soon as one value is true.

In the above function, I do not print anything but prefer to return symbols to represent the different cases. If you need to print something, you can then do it in another function.