フレーム型知識表現のＬｉｓｐによる実装例


(defun fget (frame slot facet)
　　　(cdr (assoc facet (cdr (assoc slot (cdr (get frame 'frame)))))))

(putprop 'Henry
　　　　　　'(Henry (a-kind-of (value man))
　　　　　　　　　　　(height (value 1.78))
　　　　　　　　　　　(weight (value 75))
　　　　　　　　　　　(hobies (value jogging skiing))
　　　　　　　　　　　(licence (if-needed ask answer))
　　　　　　　　　　　(occupation (value teaching research)))
　　　　　　'frame)

(defun extend (key a-list)
　　　(cond ((assoc key (cdr a-list)))
　　　　　　　(t
　　　　　　　　(cadr (rplacd (last a-list) (list (list key)))))))

(defun follow-path (path a-list)
　　　(cond ((null path) a-list)
　　　　　　　(t
　　　　　　　　(follow-path (cdr path) (extend (car path) a-list)))))

(defun fget-frame (frame)
　　　(cond ((get frame 'frame))
　　　　　　　(t
　　　　　　　　(setf (get frame 'frame) (list frame)))))

(defun fput (frame slot facet value)
　　　(let ((value-list (follow-path (list slot facet) (fget-frame frame))))
　　　　(cond ((member value value-list :test #'equal) nil)
　　　　　　　　　(t
　　　　　　　　　　(rplacd (last value-list) (list value)) value))))

(defun fremove (frame slot facet value)
　　　(let ((value-list (follow-path (list slot facet) (fget-frame frame))))
　　　　(cond ((member value value-list :test #'equal)
　　　　　　　　　(delete value value-list :test #'equal)
　　　　　　　　　t)
　　　　　　　　　(t nil))))

(defun fcheck (frame slot facet value)
　　　(cond ((member value (fget frame slot facet) :test #'equal) t)
　　　　　　　(t nil)))

(defun fclamp (frame1 frame2 slot)
　　　(rplacd (fget-frame frame1)
　　　　　　　　(list (follow-path (list slot) (fget-frame frame2))))
　　　slot)

(defun fget-v-d (frame slot)
　　　(cond ((fget frame slot 'value))
　　　　　　　((fget frame slot 'default))))

(defun fget-v-d-p (frame slot)
　　　(cond ((fget frame slot 'value))
　　　　　　　((fget frame slot 'default))
　　　　　　　(t
　　　　　　　　(mapcan
　　　　　　　　　　　#'(lambda (demon) (fucall demon frame slot))
　　　　　　　　　　(fget frame slot 'if-needed)))))

(defun ask (frame slot)
　　　(print `(Please supply a value for the
　　　　　　　,slot slot in the
　　　　　　　,frame frame))
　　　　　　　(terpri)
　　　　　　　(let ((response (read)))
　　　　　　　　　(cond (response (list response))
　　　　　　　　　　　　　(t nil))))

(defun answer (&rest l)
　　　(print '(It has been abswered)))

(setf *print-length* 200)

(setf *print-level* 6)

(defun caluculate-weight (frame slot)
　　(let ((heigh (fget-v-d frame 'height)))
　　　　(cond (height (list (fput frame
　　　　　　　　　　　　　　　　　　　'weight
　　　　　　　　　　　　　　　　　　　'value
　　　　　　　　　　　　　　　　　　　(* 33 (car height))))))))

(putprop 'man
　　　　　　'(man (a-kind-of (value human))
　　　　　　　　　　(hobbies (if-removed report report) (value music reading))
　　　　　　　　　　(height (if-added caluculate-weight)))
　　　　　　'frame)

(putprop 'human
　　　　　　'(human (a-kind-of (value being))
　　　　　　　　　　　　(place (value earth)))
　　　　　　'frame)

(defun report (&rest l)
　　　(print '(The data has been removed)))

;;;
;;; (fget-classes 'Henry)===>(Henry man human being)
;;;
(defun fget-classes (start)
　　　(reverse (fget-classes1 (list start) nil)))

(defun fget-classes1 (queue classes)
　　　(cond ((null queue) classes)
　　　　　　　(t
　　　　　　　　(fget-classes1
　　　　　　　　;;;
　　　　　　　　(append (fget (car queue) 'a-kind-of 'value)
　　　　　　　　　　　　　　(cdr queue))
　　　　　　　　;;;
　　　　　　　　(cond ((member (car queue) classes)
　　　　　　　　　　　　　classes)
　　　　　　　　　　　　(t
　　　　　　　　　　　　　(cons (car queue) classes)))))))

;;;
;;; I-inheritannce
;;;
(defun fget-i (frame slot)
　　(fget-i1 (fget-classes frame) slot))

(defun fget-i1 (frames slot)
　　(cond ((null frames) nil)
　　　　　　((fget (car frames) slot 'value))
　　　　　　(t
　　　　　　　(fget-i1 (cdr frames) slot))))

;;;
;;; Z-inheritannce
;;;
(defun fget-z (frame slot)
　　(fget-z1 slot (fget-calasses frame)))

(defun fget-z1 (slot classes)
　　(cond ((null classes) nil)
　　　　　　((fget-v-d-p (car classes) slot))
　　　　　　(t
　　　　　　　(fget-z1 slot (cdr classes)))))

;;;
;;; N-inheritance
;;;
(defun fget-n (frame slot)
　　　(let ((classes (fget-classes frame)))
　　　　(cond ((fget-n1 slot classes 'value))
　　　　　　　　((fget-n1 slot classes 'default))
　　　　　　　　((fget-n2 slot classes 'if-needed))
　　　　　　　　(t nil))))

(defun fget-n1 (slot classes key)
　　　(cond ((null classes) nil)
　　　　　　　((fget (car classes) slot key))
　　　　　　　(t
　　　　　　　　(fget-n1 slot (cdr classes) key))))

(defun fget-n2 (slot classes key)
　　　(cond ((null classes) nil)
　　　　　　　((mapcan #'(lambda (demon) (funcall demon (car classase) slot))
　　　　　　　　　　(fget (car classes) slot ley)))
　　　　　　　(t
　　　　　　　　(fget-n2 slot (cdr classes) key))))

;;;
;;;
;;;
(defun fput-p (frame slot facet value)
　　　(cond ((fput frame slot facet value)
　　　　　　　　(mapcar #'(lambda (e)
　　　　　　　　　　(mapcar #'(lambda (demon) (funcall demon frame slot))
　　　　　　　　　　　　(fget e slot 'if-added)))
　　　　　　　　　　(fget-classes frame))
　　　　　　　　value)))

;;;
;;;
;;;
(defun remove-p (frame slot facet value)
　　　(cond ((fremove frame slot facet value)
　　　　　　　　(mapcar #'(lambda (e)
　　　　　　　　　　　(mapcar #'(lambda (demon) (funcall demon frame slot))
　　　　　　　　　　　　　(fget e slot 'if-removed)))
　　　　　　　　　　　(fget-classes frame))
　　　　　　　　value)))

;;;
;;;
;;;
(defun copy-frame (name1 name2)
　　(let ((lst (list name2 (second (fget-frame name1)))))
　　　　(putprop name2 lst 'frame)))