Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-03-26

Common LispでL-99 (P48 真偽値表 その3)

| 15:55 | Common LispでL-99 (P48 真偽値表 その3) - わだばLisperになる を含むブックマーク はてなブックマーク - Common LispでL-99 (P48 真偽値表 その3) - わだばLisperになる

P48もCommon Lispで挑戦していたときには中間記法での表現はスルーしていたので、再挑戦。

P47で引数を2つに決め打ちにしていましたが、元のPrologの解答を眺めると、どうやら、自分で作った演算子に自分で優先順位を設定させることが問題の本意のようです。(Prologでは設定する機能があるため)

このあたりは、L-99を眺めていてもちょっと分からないですね(;´Д`)

ということで、演算子の優先順位を設定できるようにして、かつ、任意の個数の変数を取れるように拡張しました。

優先順位は、not, (and, nand), (or, nor), (impl equ xor)の順のみたいです。

table/cは使われる変数を宣言して、各変数にtかnilのが束縛され、そのすべての組み合わせを繰り返す、という仕様しました。

あと一踏ん張りが足らない出来となりました…。

(table/c (a b c)
  A and/2 (B or/2 C) equ/2 A and/2 B or/2 A and/2 C)
;=> T, T, T => T
;   T, T, NIL => T
;   T, NIL, T => T
;   T, NIL, NIL => T
;   NIL, T, T => T
;   NIL, T, NIL => T
;   NIL, NIL, T => T
;   NIL, NIL, NIL => T

(defparameter *OPERATOR-PRECEDENCE-LIST*
  '(and/2 nand/2 or/2 nor/2 impl/2 equ/2 xor/2)
  "オペレータの優先順位リスト: 先頭になるほど優先順位が高い")

(defmacro TABLE/C ((&rest args) &body expr)
  (let ((g (gensym))
        (len (length args)))
    `(DOLIST (,g (make-truth-table ,len))
       (DESTRUCTURING-BIND ,args ,g
         (FORMAT T "~{~A~^, ~} => ~A~%" ,g 
                 ,(to-prefix/c expr *operator-precedence-list*))))))

(defun MAKE-TRUTH-TABLE (size &optional (true t) (false nil))
  (loop :for i :below (expt 2 size)
        :collect (mapcar (lambda (x) (if (char= #\1 x) true false))
                         (coerce (format nil "~V,'0,B" size i) 'list))))

(defun CONJUNCT-INFIX-EXPR (pred expr)
  (cond ((atom expr) expr)
        ((eq pred (cadr expr))
         (destructuring-bind (a pred b &rest rest) expr
           `((,(CONJUNCT-INFIX-EXPR pred a)
               ,pred
               ,(CONJUNCT-INFIX-EXPR pred b))
             ,@(CONJUNCT-INFIX-EXPR pred rest))))
        ((atom (car expr))
         (cons (car expr) (CONJUNCT-INFIX-EXPR pred (cdr expr))))
        ;; 不要な入れ子を防ぐ
        ((= 3 (length (car expr)))
         (cons (car expr)
               (CONJUNCT-INFIX-EXPR pred (cdr expr))))
        ('T (cons (CONJUNCT-INFIX-EXPR pred (car expr))
                  (CONJUNCT-INFIX-EXPR pred (cdr expr))))))

(defun SET-OPERATOR-PREDENCE (expr precedence)
  (reduce (lambda (res x) (conjunct-infix-expr x res))
          precedence 
          :initial-value expr))

;; P47で定義したCONJUNCT-NOT-EXPRが必要
(defun TO-PREFIX/C (expr precedence)
  (labels ((frob (expr)
             (cond ((atom expr) expr)
                   ((and (consp expr) (eq 'not (car expr))) 
                    (if (consp (cadr expr))
                        `(not ,(frob (cadr expr)))
                        expr))
                   ((atom (car expr))
                    (destructuring-bind (a pred b) expr
                      `(,pred ,a ,(frob b))))
                   ('T (destructuring-bind (a pred b) expr
                         `(,pred ,(frob a) ,(frob b)))))))
    ;; 謎のcar (要素が一つのリストが結果になるため)
    (frob (car (set-operator-predence (conjunct-not-expr expr) 
                                      precedence)))))

;(to-prefix/c '(A and/2 (B or/2 C) equ/2 A and/2 B or/2 A and/2 C) 
;             *operator-precedence-list*)
;=> (EQU/2 (AND/2 A (OR/2 B C)) (OR/2 (AND/2 A B) (AND/2 A C)))