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

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

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

Common Lispで作成したものを移植。

大したことはしていないのに、なんだか長〜くなりました。

(table/c (A B C)
  A *and (B *or C) *equ A *and B *or A *and C)
;=> nil, nil, nil => t
;   nil, nil, t => t
;   nil, t, nil => t
;   nil, t, t => t
;   t, nil, nil => t
;   t, nil, t => t
;   t, t, nil => t
;   t, t, t => t

(set *operator-precedence-list* '(*and *nand *or *nor *impl *equ *xor))

(mac table/c (args . expr)
  (let argl (len args)
    `(each ,args (make-truth-table ,argl)
       (prall (list ,@args))
       (pr " => " ,(to-prefix/c expr *operator-precedence-list*) "\n"))))

(def nth-truth (size num (o true t) (o false nil))
  ((afn (cnt acc)
     (if (is 0 cnt)
         rev.acc
         (let cnt (- cnt 1)
           (self cnt
                 (cons (if (odd:trunc (/ num (expt 2 cnt))) true false) 
                       acc)))))
   size () ))

(def make-truth-table (size (o true t) (o false nil))
  ((afn (cnt acc)
     (if (is cnt (expt 2 size))
         rev.acc
         (self (+ cnt 1) 
               (cons (nth-truth size cnt true false)
                     acc))))
   0 () ))

;; 前回定義のconjunct-not-exprが必要
(def to-prefix/c (expr precedence)
  ((afn (expr)
     (if atom.expr expr
         ;; 
         (and acons.expr (is 'no car.expr))
         (if (acons cadr.expr)
             `(no ,(self cadr.expr))
             expr)
         ;; 
         (atom car.expr)
         (let (a pred b) expr
           `(,pred ,a ,self.b))
         ;; 
         'else 
         (let (a pred b) expr
           `(,pred ,self.a ,self.b))))
   (car:set-operator-predence conjunct-not-expr.expr precedence)))

(def conjunct-infix-expr (pred expr)
  (if atom.expr expr
      ;; 
      (is pred cadr.expr)
      (let (a pred b . 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))
      ;; 
      (is 3 (len car.expr))
      (cons car.expr (conjunct-infix-expr pred cdr.expr))
      ;; 
      'else
      (cons (conjunct-infix-expr pred car.expr)
            (conjunct-infix-expr pred cdr.expr))))

(def set-operator-predence (expr precedence)
  ((afn (lst res)
     (if no.lst
         res
         (self cdr.lst (conjunct-infix-expr car.lst res))))
   precedence expr))
;    

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)))

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20080326