我正在和您联系，因为我目前需要解析（可以转录为）布尔表达式，以便说明哪些成员必须是1。
要明确这个主题，这是一个例子。我有这个等式：
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))
这是描述形状的等式，包括以不同“颜色”绘制的其他几个图形。
因此，我的等式的输入是“颜色”，例如ACTIVE_drawing。我的目标是，使用这个等式，equ=1强制，禁止或可选的颜色是什么。这就是为什么我在谈论真相表。
该等式不是真正的布尔值，但可以被处理为。 INTERACT可以替换为AND，可以删除COPY，也可能需要其他操作。
所以我的问题不在于替换我的等式以获得“真正的布尔”值，而是在算法上实现以便正确解析布尔表达式以获得相应的真值表。
你们有一些关于它的提示吗？我正在使用Perl来生成等式，所以我想保留它，但是如果你知道另一个可以接受我的输入来处理它的工具，为什么不呢。
答案 0 :(得分：0)
TXR Lisp版本128中的解决方案。
互动运行：
$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
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
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"))))))
答案 1 :(得分：0)
我知道这个问题很旧，但是您可以尝试https://logic.lerax.me。该资源可以作为开放源代码使用，如果您使用quicklisp + ultralisp，则可以通过以下方式实现：
(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 |
; +------------------------------------------------+
免责声明：我是Lisp推理系统的作者。