1

我正在与您联系，因为我目前需要解析（可以转录为）布尔表达式，以便说明哪些成员必须为 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 来生成方程，所以我想保留它，但如果你知道另一个工具可以接受我的输入来处理它，为什么不呢。

4

2 回答 2

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"))))))
于 2015-12-20T02:02:58.280 回答
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 推理系统的作者。

于 2019-03-04T20:52:40.147 回答