drtest10.bat

一套美国国家宇航局人工智能中心NASA的专家系统工具源代码

(clear)                   ; DR0793
(load bug793.clp)
(BEeditInit streamout)
(BECPMIn bug793.ins)
(clear)                   ; DR0795

(defrule rule-1
  (blah $?y)
  =>
  (progn$ (?x ?y) (printout t ?x)))
(ppdefrule rule-1)
(clear)                   ; DR0798
(reset)
(assert (a))
(assert (b))
(defrule t1 (b) (a) =>)
(defrule t2 (a) (or (b) (b)) =>)
(agenda)
(clear)                   ; DR0801
(setgen 1)
(unwatch all)
(watch instances)
(watch activations)
(watch rules)

(defclass A (is-a USER)
  (role concrete)
  (pattern-match reactive)
  (slot match (default yes) (create-accessor read-write))
  (slot container (create-accessor read-write)))
  
(defmessage-handler A delete before ()
  (if (instance-existp ?self:container) then
     (unmake-instance ?self:container)))
     
(defrule A-rule
  (logical ?obj <- (object (is-a A) (match yes)))
=>
  (send ?obj put-container 
      (make-instance of A (match no)
                          (container (make-instance of INITIAL-OBJECT))))
  (send ?obj put-match no))
(make-instance a of A)
(run)
(unwatch all)
(clear)                   ; DR0802

(defclass A (is-a USER)
  (role concrete)
  (slot foo (default bar)))
  
(defmessage-handler A delete after ()
  (printout t ?self:foo crlf))
(unmake-instance (make-instance of A))
(clear)                   ; DR0803

(defclass A
   (is-a USER)
  (role concrete)
  (pattern-match reactive)
  (multislot data
    (create-accessor read-write)))
    
(defrule rule1
  (object (is-a A) (data 0 ?x))
  (object (is-a A) (data 1 ?x))
  =>
  (printout t ?x crlf))

(definstances objects
  (a of A (data 0 0))
  (b of A (data 1 0))
  (c of A (data 1 1)))
(reset)
(agenda)
(clear)                   ; DR0804

(deffunction imfi (?cv)
   (bind ?position 3)
   (while TRUE do
     (bind ?nv (+ (nth$ ?position ?cv) 1))
     (if (<= ?nv 9)
        then 
        (return (replace$ ?cv ?position ?position ?nv)))
     (bind ?cv (replace$ ?cv ?position ?position 1))
     (bind ?position (- ?position 1))
     (if (< ?position 1) then (return FALSE))))
 
(deffunction optimize ()
   (bind ?current-settings (create$ 1 1 1))
   (while (neq ?current-settings FALSE)
      (bind ?current-settings (imfi ?current-settings))))
(reset)
(optimize)
(clear)                   ; DR0805
(setgen 1)

(defclass A
   (is-a USER)
   (role concrete)
   (pattern-match reactive)
   (multislot data
      (create-accessor read-write)))

(defrule rule1
   (object (is-a A) (data ? red ?x&green))
   (object (is-a A) (data ? red ?x))
   =>)
(make-instance of A (data orange red green))
(matches rule1)
(clear)                   ; DR0806
(setgen 1)

(defclass A (is-a INITIAL-OBJECT)
   (multislot foo))

(defclass B (is-a A)
   (slot foo))

(defrule AB
   (object (is-a A) (foo ?val))
   =>
   (printout t ?val crlf))
(make-instance of B)
(run)
(clear)                   ; DR0807
(insert$ (rest$ (create$ abc def)) 2 ghi)
(clear)                   ; DR0808
(assert (m))
(assert (a))
(defrule r1 (m) (not (a)) =>)
(defrule r2 (m) (not (a)) (not (b)) =>)
(agenda)
(clear)                   ; DR0809
(deffunction pins () (ppinstance))
(defmessage-handler USER pins () (pins))
(defclass A (is-a USER) (role concrete))
(make-instance a of A)
(send [a] pins)
(clear)                   ; DR0810
(deffunction MAIN::foo
   (?garbage)
   (setgen 1)
   (loop-for-count ?garbage
      (make-instance of INITIAL-OBJECT))
   (delayed-do-for-all-instances ((?ins INITIAL-OBJECT))
      TRUE
      (progn
         (unmake-instance *)
         (return (gensym*)))))
(foo 100)
(foo 500)
(clear)                   ; DR0813

(defclass A (is-a INITIAL-OBJECT)
   (multislot foo (create-accessor read-write)))

(defrule A
   (fact ?v)
   (not (object (is-a A) (foo $? ?v $?)))
=>)
(assert (fact a))
(make-instance a of A (foo a b c))
(make-instance b of A (foo a b c))

(object-pattern-match-delay
   (modify-instance a (foo q))
   (modify-instance b (foo q)))
(clear)                   ; DR0815

(defclass grammy (is-a USER)
    (role concrete)
    (pattern-match reactive)
    (multislot  text
    (create-accessor write)
    (type SYMBOL)))

(defmessage-handler grammy print before ()
    (printout t crlf)
    (printout t "******  starting to print   ****"  ?self crlf))

(defmessage-handler grammy print after ()
    (printout t "******  starting to print   ****"  ?self crlf)
    (printout t crlf))

(deffunction resize (?xlist)
   (if (= (length$ ?xlist)  0)
     then
     (printout t "got to here !!! "  crlf)
     (return)
     else
     (make-instance (gensym) of grammy
         (text (subseq$ ?xlist 1 9))))
     (resize (subseq$ ?xlist 10 (length$ ?xlist))))

(deffunction ask ()
   (do-for-all-instances ((?tag grammy)) (instancep ?tag)
      (send ?tag print)))

(defrule commence  "make it happen"
   =>
   (resize (create$ a b c d e f g h i j k l m n)))
(reset)
(run)
(clear)                   ; DR0816

(defclass A
	  (is-a USER)
	  (role concrete)
	  (slot str
	    (create-accessor read-write)
	    (type STRING))
	  (slot length
	    (create-accessor read-write)
	    (type INTEGER)))

(defmessage-handler A put-str after (?value)
   (bind ?self:length 3))
(make-instance a of A (str 4))
(send [a] get-length)
(clear)                   ; DR0817

(deftemplate status 
   (slot search-depth)
   (slot parent))

(defrule move-alone 
  ?node <- (status)
  =>
  (duplicate ?node (search-depth =(+ 1 3))
                   (parent ?node)))
(ppdefrule move-alone) 
 
(deftemplate dbdata
  (multislot values))
 
(defrule bug1
  =>
  (assert (dbdata (values (create$ 1 2)))))
(ppdefrule bug1)
 
(defrule bug2
  =>
  (assert (dbdata (values (create$ 1 2) (create$ 3 4)))))
(ppdefrule bug2)    
 
(deftemplate foo 
   (field x) 
   (multifield y))
 
(deffacts d5 (foo (y a)))
(ppdeffacts d5)
(deffacts d6 (foo (y a b)) (b) (foo (x 3)) (d))
(ppdeffacts d6)
(clear)                   ; DR0818
(defmodule A (export ?ALL))
(defgeneric A::foo)
(defmethod A::foo ((?arg NUMBER)))
(defmodule B (import A ?ALL))
(defclass B (is-a USER))
(defmethod B::foo ((?arg B)))
(clear)