3

我正在努力做我的功课。我有以下收藏。

(defparameter *tuples* 
  '((has bird feathers)
  (color budgie yellow)
  (eats budgie seed)
  (color tweetie green)
  (isa tweetie budgie)
  (isa budgie bird)
    ))

我需要让它以通过以下测试的方式工作。

(inherit tuples 'tweetie 'heart-rate) => nil
(inherit tuples 'tweetie 'color)      => green
(inherit tuples 'tweetie 'eats)       => seeds
(inherit tuples 'tweetie 'has)        => feathers

如果我指定 tweetie 的值，我已经设法完成工作，例如：

(forevery (' ((isa ?b budgie)  (eats budgie ?x)) *tuples*) 
    (format t "~&~a" #?x)      #?x)

返回种子。

但

(forevery (' ((isa ?b budgie)  (eats tweetie ?x)) *tuples*) 
    (format t "~&~a" #?x)      #?x)

返回 nil，所以我怎样才能使它与指定的父值匹配所以当测试时(eats tweetie ?x) 应该返回种子并且(has tweetie ?x) 应该返回羽毛。

多谢你们。

4

1 回答 1

2 
(defparameter *tuples* 
  '((has bird feathers)
    (color budgie yellow)
    (eats budgie seed)
    (color tweetie green)
    (isa tweetie budgie)
    (isa budgie bird)))

(defvar *traits-table* (make-hash-table))

(defun put-trait (trait object subject)
  (let ((object-table
         (gethash object *traits-table* (make-hash-table))))
    (setf (gethash trait object-table) subject
          (gethash object *traits-table*) object-table)))

(defun populate-traits ()
  (loop for (trait object subject) in *tuples* do
       (put-trait trait object subject)))

(defun inherits-p (object trait)
  (let ((object-table (gethash object *traits-table*)))
    (and object-table
         (or (gethash trait object-table)
             (inherits-p (gethash 'isa object-table) trait)))))

(populate-traits)

(inherits-p 'tweetie 'heart-rate)       ; nil
(inherits-p 'tweetie 'color)            ; GREEN
(inherits-p 'tweetie 'eats)             ; SEED
(inherits-p 'tweetie 'has)              ; FEATHERS

这是一种简单的方法。但在实践中，您很可能会为此目的使用类，或者至少是结构，它们具有内置的“是一种”关系的功能，而且它相当健壮和复杂。

编辑：

以下是将输入结构转换为类列表的一些方法，以便以后能够使用内置的 OO 功能来评估继承、访问字段（插槽）等：

(defmacro define-tuples (&body body)
  (loop for (trait object subject) in body
     ;; will will build a directed graph (assuming there
     ;; is only one root), where the root of the grpah
     ;; is the object, which maps to `nil', for simplicity
     ;; we will also assume there is always only one descendant
     with inheritance = (make-hash-table)
     with traits = (make-hash-table)
     with next-class = nil
     for object-table = (gethash object traits (make-hash-table))
     do (if (eql trait 'isa)
            (setf (gethash subject inheritance) object)
            (setf (gethash trait object-table) subject
                  (gethash (gethash object inheritance) inheritance)
                  (or (gethash (gethash object inheritance) inheritance) object)
                  (gethash object traits) object-table))
     finally
       (return                          ; We need to make sure
                                        ; we don't extend classes
                                        ; which we didn't define yet
         (let ((classes
                (cons nil
                      (loop for i from 0 to (hash-table-count traits)
                         collect
                           (setf next-class
                                 (gethash next-class inheritance))))))
           (append '(progn)
                   (loop for super in classes
                      for clazz in (cdr classes)
                      while (not (null clazz))
                      collect           ; generate class definitions
                        `(defclass ,clazz ,(when super (list super))
                           ,(loop for slot being the hash-key of
                                 (gethash clazz traits)
                               for slot-init-form being the hash-value of
                                 (gethash clazz traits)
                               collect  ; generate slot descriptors
                                 `(,slot :initarg
                                         ,(intern (string-upcase
                                                   (symbol-name slot)) "KEYWORD")
                                         :initform ',slot-init-form
                                         :accessor
                                         ,(intern
                                           (concatenate
                                            'string
                                            (string-upcase
                                             (symbol-name slot)) "-OF")))))))))))


(define-tuples
  (has bird feathers)
  (color budgie yellow)
  (eats budgie seed)
  (color tweetie green)
  (isa tweetie budgie)
  (isa budgie bird))

(let ((tweetie-instance (make-instance 'tweetie)))
  (format t "~&Tweetie eats ~s" (eats-of tweetie-instance))
  (format t "~&Tweetie has ~s" (has-of tweetie-instance))
  (format t "~&Tweetie color ~s" (color-of tweetie-instance))
  (format t "~&Tweetie has heart-rate ~s"
          (slot-exists-p tweetie-instance 'heart-rate)))
;; Tweetie eats SEED
;; Tweetie has FEATHERS
;; Tweetie color GREEN
;; Tweetie has heart-rate NIL
于 2012-12-07T21:28:18.927 回答