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