Boolean expression parser (truth table generation)

Question

I'm contacting you because I currently have the need to parse (what could be transcripted as) boolean expression in order to say which members have to be 1 or not.

To be clear with the topic here's an example. I have this equation:

equ = ((((SIPROT:1 INTERACT (((((((ACTIVE_drawing OR ACTIVE_hd) OR ACTIVE_dm) OR PDIFF_drawing) OR NDIFF_drawing) NOT polyact_sign_mkr) NOT ((COPY (NWELL_drawing OR NWELL_hd)) AND (((((ACTIVE_drawing OR ACTIVE_hd) OR ACTIVE_dm) OR PDIFF_drawing) OR NDIFF_drawing) NOT polyact_sign_mkr))) NOT ((COPY (PPLUS_drawing OR PPLUS_hd)) OR (COPY ((NPLUS_drawing OR NPLUS_dm) OR NPLUS_hd))))) INSIDE RHDMY_drawing) INTERACT ((((COPY ((NPLUS_drawing OR NPLUS_dm) OR NPLUS_hd)) AND (((((ACTIVE_drawing OR ACTIVE_hd) OR ACTIVE_dm) OR PDIFF_drawing) OR NDIFF_drawing) NOT polyact_sign_mkr)) INTERACT (N(((((ACTIVE_drawing OR ACTIVE_hd) OR ACTIVE_dm) OR PDIFF_drawing) OR NDIFF_drawing) NOT polyact_sign_mkr) INTERACT ((COPY (PPLUS_drawing OR PPLUS_hd)) AND (((((ACTIVE_drawing OR ACTIVE_hd) OR ACTIVE_dm) OR PDIFF_drawing) OR NDIFF_drawing) NOT polyact_sign_mkr)))) NOT NLDEMOS_FINAL)) OUTSIDE (COPY GO2_25_drawing))

This is describing the equation of a shape, involving the drawing of several others, drawn in different "colors".

So the inputs of my equation are the "colors", like ACTIVE_drawing for example. My goal is to say, having this equation, what colors are mandatory, forbidden, or optional, to have equ=1. That's why I'm talking about a truth table.

The equation is not really boolean, but can be processed to be. INTERACT can be replaced by AND, COPY can be removed and maybe other operations might be needed.

So my question is not on the way to replace my equation in order to have a "real boolean" one, but on the algorithm to implement in order to correctly parse the boolean expression to have the corresponding truth table.

Do you guys have some hints about it? I'm working in Perl to generate the equation, so I'd like to keep it, but if you know another tool that could take my input to process it, why not.

Use a CPAN module to parse, like Parse::RecDescent . You cannot parse a language that allows unbounded nesting with regular expressions alone. This requires a tokenizer and a stack to keep track of the levels. — shawnhcorey, Apr 30 '15 at 12:52
P::RD is quite slow. I hear good things about Marpa. Never used it myself, though. — ikegami, Apr 30 '15 at 13:38
What is `((X AND B) NOT C)`; is there an implied `AND` there? As in `((X AND B) AND NOT C)`? — Kaz, Dec 15 '15 at 20:56
This 'equation' describes geometrical operations. X,B and C are shapes. You create a new shape by combining B and X and another one by substracting C from this last one. Not sure if I'm clear. You can have a look at mentor graphics SVRF language if you're interested. Bye — Sylvain Trx, Dec 16 '15 at 21:42
See my SO answer on how to build a parser: http://stackoverflow.com/questions/2245962/is-there-an-alternative-for-flex-bison-that-is-usable-on-8-bit-embedded-systems/2336769#2336769 It also includes a way to evaluate expressions. — Ira Baxter, Dec 20 '15 at 02:33

Kaz · Answer 1 · 2023-06-09T00:35:30.497

Solution in TXR Lisp, version 128.

Interactive run:

$txr -i truth.tl 
1> (parse-infix '(a and b or c and d))
(or (and a b)
  (and c d))
2> (pretty-truth-table '(a))
    a   | a
--------+--
    F   | F
    T   | T
nil
3> (pretty-truth-table '(not a))
    a   | not a
--------+------
    F   |   T
    T   |   F
nil
4> (pretty-truth-table '(a and t))
    a   | a and t
--------+--------
    F   |    F   
    T   |    T   
nil
5> (pretty-truth-table '(a and nil))
    a   | a and nil
--------+----------
    F   |     F    
    T   |     F    
nil
6> (pretty-truth-table '(a and b))
    a     b   | a and b
--------------+--------
    F     F   |    F   
    F     T   |    F   
    T     F   |    F   
    T     T   |    T   
nil
7> (pretty-truth-table '(a -> b))
    a     b   | a -> b
--------------+-------
    F     F   |   T   
    F     T   |   T   
    T     F   |   F   
    T     T   |   T   
nil
8> (pretty-truth-table '(a or b))
    a     b   | a or b
--------------+-------
    F     F   |   F   
    F     T   |   T   
    T     F   |   T   
    T     T   |   T   
nil
9> (pretty-truth-table '(a and b or c and d))
    a     b     c     d   | a and b or c and d
--------------------------+-------------------
    F     F     F     F   |         F         
    F     F     F     T   |         F         
    F     F     T     F   |         F         
    F     F     T     T   |         T         
    F     T     F     F   |         F         
    F     T     F     T   |         F         
    F     T     T     F   |         F         
    F     T     T     T   |         T         
    T     F     F     F   |         F         
    T     F     F     T   |         F         
    T     F     T     F   |         F         
    T     F     T     T   |         T         
    T     T     F     F   |         T         
    T     T     F     T   |         T         
    T     T     T     F   |         T         
    T     T     T     T   |         T         
nil

Code in truth.tl:

;; auto-incrementing precedence level
(defvarl prec-level 0)

;; symbol to operator definition hash
(defvarl ops (hash))

;; operator definition structure
(defstruct operator nil
  sym                           ;; operator symbol
  (assoc :left)                 ;; associativity: default left
  (arity 2)                     ;; # of arguments: 1 or 2; default 2.
  (prec 0)                      ;; precedence: if zero, automatically assign.

  (:postinit (self)             ;; post-construction hook
    (set [ops self.sym] self)   ;; register operator in hash
    (if (zerop self.prec)       ;; assign precedence if necessary
      (set self.prec (inc prec-level)))))

;; define operators
(new operator sym '->)
(new operator sym 'or)
(new operator sym 'and)
(new operator sym 'not assoc :right arity 1)

;; conditional function
(defun -> (a b)
  (or (not a) b))

;; parse infix to prefix
;; https://en.wikipedia.org/wiki/Shunting-yard_algorithm
(defun parse-infix (expr)
  (let (nodestack opstack)
    (flet ((add-node (oper)
              (caseql oper.arity
                (1 (push (list oper.sym
                               (pop nodestack)) nodestack))
                (2 (let ((y (pop nodestack))
                         (x (pop nodestack)))
                     (push (list oper.sym x y) nodestack))))))
      (each ((tok expr))
        (condlet
          (((o1 [ops tok]))
           (whilet ((o2 (first opstack))
                    (yes (when o2 (caseq o2.assoc
                                    (:left  (>= o2.prec o1.prec))
                                    (:right (>  o2.prec o1.prec))))))
             (pop opstack)
             (add-node o2))
           (push o1 opstack))
          (((c (consp tok)))
           (push (parse-infix tok) nodestack))
          (t (push tok nodestack))))
      (whilet ((o2 (first opstack)))
        (pop opstack)
        (add-node o2)))
    (first nodestack)))

;; extract leaf terms from expression
(defun terms-of (prefix)
  (if (atom prefix)
    (list prefix)
    [mappend terms-of (rest prefix)]))

;; generate truth table materials
(defun truth-table (prefix)
  (let* ((vars (uniq [keep-if 'bindable (terms-of prefix)]))
         (truths (rperm '(nil t) (length vars)))
         (fun (eval ^(lambda (,*vars) ,prefix)))
         (expr-truths [mapcar (apf fun) truths]))
    (list vars truths expr-truths)))

;; overridable column width
(defvar *col-width* 5)

;; parse infix, generate truth table and format nicely
(defun pretty-truth-table (infix-expr : (stream *stdout*))
  (tree-bind (vars truths expr-truths) (truth-table (parse-infix infix-expr))
    (let ((cols (length vars))
          (cw *col-width*)
          (infix-expr-str `@{infix-expr}`))
      ;; header
      (each ((v vars))
        (put-string `@{v (- cw)} ` stream))
      (put-string "  | " stream)
      (put-line infix-expr-str stream)
      (each ((v vars))
        (put-string `------` stream))
      (put-line `--+-@{(repeat "-" (length infix-expr-str)) ""}` stream)
      (each ((vr truths)
             (et expr-truths))
        (each ((vt vr))
          (put-string `@{(if vt "T" "F") (- cw)} ` stream))
        (put-string "  | " stream)
        (format stream "~^*a\n" (length infix-expr-str) (if et "T" "F"))))))

Hello @kaz and thank you for your comment. Thanks to your message, I will have a trainee who will work on this topic and we'll use your code to begin. Sorry I did not reply earlier, but I had nothing new to discuss until now. Kind regards, Sylvain — Sylvain Trx, Apr 03 '17 at 08:34
@SylvainTrx Hi Sylvain. I just noticed your comment from 6 years ago. Hope 2023 finds you well. (I see you've not been here in over five years.) — Kaz, Jun 08 '23 at 20:36

score 0 · Answer 2 · answered Mar 04 '19 at 20:52

I know this question is old, but you can try https://logic.lerax.me. The source is available as open source and if you use quicklisp+ultralisp you can do it by:

(ql-dist:install-dist "http://dist.ultralisp.org" :replace t :prompt nil)
(ql:quickload :lisp-inference)
(inference:truth-infix ((p ^ q) => r))

; +------------------------------------------------+
; |  P  |  Q  |  R  |  (P ^ Q)  |  ((P ^ Q) => R)  |
; +------------------------------------------------+
; |  T  |  T  |  T  |     T     |        T         |
; |  T  |  T  |  F  |     T     |        F         |
; |  T  |  F  |  T  |     F     |        T         |
; |  T  |  F  |  F  |     F     |        T         |
; |  F  |  T  |  T  |     F     |        T         |
; |  F  |  T  |  F  |     F     |        T         |
; |  F  |  F  |  T  |     F     |        T         |
; |  F  |  F  |  F  |     F     |        T         |
; +------------------------------------------------+

Disclaimer: I'm the author of Lisp Inference System.

Boolean expression parser (truth table generation)

2 Answers2