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 に答える