fldval50.clp

NASA 开发使用的一个专家系统

 (retract ?f)
 (printout t "error in asserting special characters" crlf))

(defrule clean-up-rule-1-action-facts
 (declare (salience -20)) ; Added by Gary Riley
 (not (begin action-functions))
 (end action-assert-retract)
 ?f <- (rule-1 $?)
=>
 (retract ?f))

(defrule error-clean-up-rule-1-action-facts
 (declare (salience -30))
 (not (begin action-functions))
 (end action-assert-retract)
 (rule-1 $?)
=>
 (printout t "error cleaning up rule 1 action facts" crlf))

(defrule clean-up-rule-2-action-facts
 (declare (salience -20)) ; Added by Gary Riley
 (end action-assert-retract)
 (not (begin action-functions))
 ?f <- (rule-2 $?)
=>
 (retract ?f))

(defrule error-clean-up-rule-2-action-facts
 (declare (salience -30))
 (end action-assert-retract)
 (rule-2 $?)
 (not (begin action-functions))
=>
 (printout t "error cleaning up rule 2 action facts" crlf))


(defrule clean-up-rule-3-action-facts
 (declare (salience -20)) ; Added by Gary Riley
 (not (begin action-functions))
 (end action-assert-retract)
 ?f <- (rule-3 $?)
=>
 (retract ?f))

(defrule error-clean-up-rule-3-action-facts
 (declare (salience -30))
 (not (begin action-functions))
 (end action-assert-retract)
 (rule-3 $?)
=>
 (printout t "error cleaning up rule 3 action facts" crlf))

(defrule clean-up-action-data-facts
 (declare (salience -20)) ; Added by Gary Riley
 (not (begin action-functions))
 (end action-assert-retract)
 ?f <- (data $?)
=>
 (retract ?f))

(defrule error-cleaning-up-action-data-facts
 (declare (salience -30))
 (not (begin action-functions))
 (end action-assert-retract)
 (data $?)
=>
 (printout t "error cleaning up action data facts" crlf))


(defrule begin-action-functions-test
 (declare (salience -40)) ; Added by Gary Riley
 (end action-assert-retract)
 =>
 (assert (begin action-functions)))
 
;;; 4.3 The CLIPS I/O System
;;;
;;; The open function allow a user to open a file form the RHS and attach a
;;; logical name to it.  A write only file is established at the beginning
;;; of this file for procedural messages.  In this section a read only file
;;; is employed to test readline function.  fprintout, read, format, open and 
;;; close are tested in the filetst program.  fprintout is used extensively
;;; throughout this file.


;;; ============================ I/O SYSTEM ==============================
;;; ================= READLINE OPEN CLOSE FORMAT fprintout ===============


(defrule openw-fprintout-close-openr-test-file-for-action-function-facts
 (declare (salience -10))
 (begin action-functions)
 ?f <- (end action-assert-retract)
=>
 (retract ?f)
 (open "text.tmp" build-text "w")
 (printout build-text "data Computer Sciences Corporation" crlf
                       "data 16511 Space Center Blvd" crlf
                       "data Houston, Tx 77058" crlf ; Changed by Gary Riley
                       "EOF" crlf)
 (close build-text)  
 (open "text.tmp" text "r")
 (assert (open text-file)))

(defrule read-line-from-test-file
 (declare (salience 3))
 (begin action-functions)
 (open text-file)
=>
 (bind ?text-string (+ 1 2))
 (while (neq ?text-string "EOF")
  (bind ?text-string (readline text))
  (assert-string (str-cat "(" ?text-string ")")))
 (close text)
 (assert (close text-file)))

(defrule bind-function
 (declare (salience 2))
 (begin action-functions)
 (length ?x)
=>
 (bind ?y (+ ?x 10))
 (assert (new-length ?y)))

(defrule halt-function
 (declare (salience 1))
 (begin action-functions)
 (new-length 13)
 (new-length 14)
=>
 (printout t "testing halt function" crlf)
 (printout t "enter the (run) commmand to continue" crlf crlf)
 (halt))

;;; 4.2 Multifield Functions


;;; ======================== MULTIFIELD FUNCTIONS ============================
;;; ====================== LENGHT MEMBER NTH SUBSET ============================


(defrule multi-field-field-manipulation-tests                 ;CR0008
 (declare (salience 4))
 (begin action-functions)
  ?f <- (multifield $?mult1)                                  ;CR0008
=>                                                            ;CR0008
 (retract ?f)                                                 ;CR0008
 (bind ?mult2 (delete$ ?mult1 2 2))                         ;CR0008
 (assert (multifield2 ?mult2))                               ;CR0008
 (bind ?mult3 (create$ ?mult2 "four" 5))      ;CR0008
 (assert (multifield3 ?mult3))                            ;CR0008
 (bind ?mult3.5 (create$ ?mult3 (create$ cww)  a (create$) b));CR0014
 (assert (multifield3 ?mult3.5))                                         ;CR0008 CR0014 
 (bind ?mult4 (str-explode "1 two"))             ;CR0008 DR0093
 (assert (multifield4 ?mult4))                                           ;CR0008 DR0093
 (bind ?string (str-implode ?mult4))                         ;CR0008
 (assert (multifield4 ?string))                                           ;CR0008
 (assert (multifield5 =(subseq$ ?mult3.5 3 33))))

(defrule length-nth-member-action-functions
 (declare (salience 5))
 (begin action-functions)
 (close text-file)
 (data $?x)
=>
 (assert (length =(length ?x)))
 (assert (second-element =(nth 2 ?x)))
 (assert (member-center =(member Center ?x)))
 (assert (multifield one two three)))

(defrule clean-up-action-functions
 (declare (salience -10))
 ?f <- (begin action-functions)
 ?f1 <- (open text-file)
 ?f2 <- (close text-file)
 ?f3 <- (EOF)
 ?f4 <- (length 3)
 ?f5 <- (length 4)
 ?f6 <- (new-length 13)
 ?f7 <- (new-length 14)
 ?f8 <- (second-element Sciences)
 ?f9 <- (second-element Space)
 ?f10 <- (second-element Tx)
 ?f11 <- (member-center FALSE) ; Changed by Gary Riley
 ?f12 <- (member-center 3)
 ?f13 <- (data Computer $?)
 ?f14 <- (data 16511 $?)
 ?f15 <- (data Houston, $?)
 ?f16 <- (multifield2 one three)                               ;CR0008
 ?f17 <- (multifield3 one three "four" 5)                      ;CR0008
 ?f18 <- (multifield3 one three "four" 5 cww a b)              ;CR0008 CR0014
 ?f19 <- (multifield4 1 two)                                   ;CR0008
 ?f20 <- (multifield4 "1 two")                                 ;CR0008
 ?f21 <- (multifield5 "four" 5 cww a b)
=>
 (retract ?f ?f1 ?f2 ?f3 ?f4 ?f5 ?f6 ?f7 ?f8 ?f9 ?f10 ?f11 ?f12 ?f13 ?f14 ?f15
          ?f16 ?f17 ?f18 ?f19 ?f20 ?f21)
 (printout t "open, close, readline, bind and assert-string tests successful" crlf
               "length, member nth and multifield tests successful" crlf)
 (assert (end action-functions)))

(defrule error-cleaning-up-action-functions
 (declare (salience -30))
 (begin action-functions)
=>
 (printout t "error in cleaning up action functions" crlf))

(defrule begin-additional-action-functions-test
 (declare (salience -40)) ; Added by Gary Riley
 (end action-functions)
 =>
 (assert (begin additional-action-functions)))
 
(defrule error-clean-up-action-functions-data
 (declare (salience -30))
 (end action-functions)
 (data $?x)
=>
 (printout t "error in cleaning up action function data" crlf))

;;; ======================== MULTIFIELD FUNCTIONS ============================
;;; ====================== LENGHT MEMBER NTH SUBSET ============================

(defrule subset-function-data
 (declare (salience -10))
 (begin additional-action-functions)
 ?f <- (end action-functions)
 (not (data $?))
=>
 (retract ?f)
 (assert (data-0 apple orange grape apple pear)
         (data-1 apple grape orange apple)
         (data-2 orange orange)))


(defrule subset-function-1
 (declare (salience 1))
 (begin additional-action-functions)
 (data-0 $?x $?y)
 (data-1 $?z)
=>
 (if (subset ?x ?z)
  then
   (assert (set ?x is-a-subset-of ?z))
  else
   (assert (set ?x is-not-a-subset-of ?z))))

(defrule subset-function-2
 (declare (salience 2))
 (begin additional-action-functions)
 (data-2 $?x $?y)
 (data-1 $?z)
=>
 (if (subset ?x ?z)
  then
   (assert (set ?x is-a-subset-of ?z))
  else
   (assert (set ?x is-not-a-subset-of ?z))))

;;; 4.4 Math Functions

;;; Math functions are tested in the mathtst file.

;;; 4.5 Additional Functions

;;; The system function is tested manually at the top level in the HP9000, VAX
;;; and PC versions.


;;; ======================== ADDITIONAL FUNCTIONS ============================
;;; ============= GENSYM SETGEN IF...THEN...ELSE WHILE STR_CAT ==============



(defrule str-cat-function-data
 (declare (salience 3))
 (begin additional-action-functions)
=>
 (assert (string "This is the first string"))
 (assert (string "This is the second string")))

(defrule str-cat-function
 (declare (salience 4))
 (begin additional-action-functions)
 (string ?x)
 (string ?y&~?x)
=>
 (bind ?string (str-cat ?x ?y))
 (assert (new-string ?string)))



(defrule str-cat-1
 (declare (salience 5))
 (begin additional-action-functions)
=>
 (bind ?string (str-cat "This is string " one))
 (assert (new-string ?string)))


(defrule str-cat-2
 (declare (salience 6))
 (begin additional-action-functions)
=>
 (bind ?string (str-cat "This is string " 1.0))
 (assert (new-string ?string)))


(defrule str-cat-3
 (declare (salience 71))
 (begin additional-action-functions)
=>
 (bind ?string (str-cat This one))
 (assert (new-string ?string)))


(defrule str-cat-4
 (declare (salience 8))
 (begin additional-action-functions)
=>
 (bind ?string (str-cat This  1.0))
 (assert (new-string ?string)))


(defrule str-cat-5
 (declare (salience 9))
 (begin additional-action-functions)
=>
 (bind ?string (str-cat 5.4e3  1.0))
 (assert (new-string ?string)))

(defrule sub-string
 (declare (salience 10))
 (begin additional-action-functions)
 (string ?x)
=>
 (assert (new-string =(sub-string 13 18 ?x))))

(defrule str-index
 (declare (salience 11))
 (begin additional-action-functions)
 (string ?x)
=>
 (assert (new-string =(str-index "second" ?x))))
 

(defrule gensym-with-setgen
 (declare (salience 13))
 (begin additional-action-functions)
=>
 (bind ?count 5)                                           ;CR0005
 (setgen 10)                                               ;CR0005
 (while (> ?count 0) do                                    ;CR0005
  (assert (data-id =(gensym)))                             ;CR0005
  (bind ?count (- ?count 1))))                             ;CR0005


(defrule gensym-without-setgen
 (declare (salience 12))  ; Added by Gary Riley
 (begin additional-action-functions)
=>
 (bind ?count 5)
 (while (> ?count 0)
  (assert (data-id =(gensym)))
  (bind ?count (- ?count 1))))

(defrule clean-up-additional-action-functions
 (declare (salience -10))
 ?f <- (begin additional-action-functions)
 ?f1 <- (set is-a-subset-of apple grape orange apple)
 ?f2 <- (set apple is-a-subset-of apple grape orange apple)
 ?f3 <- (set apple orange is-a-subset-of apple grape orange apple)
 ?f4 <- (set apple orange grape is-a-subset-of apple grape orange apple)
 ?f22 <- (set apple orange grape apple is-a-subset-of apple grape orange apple)
 ?f23 <- (set apple orange grape apple pear is-not-a-subset-of apple grape orange 
          apple)
 ?f24 <- (set orange is-a-subset-of apple grape orange apple)
 ?f25 <- (set orange orange is-a-subset-of apple grape orange apple)
 ?f5 <- (new-string "This is the second stringThis is the first string")
 ?f6 <- (new-string "This is the first stringThis is the second string")
 ?f7 <- (new-string "This is string one")
 ?f8 <- (new-string "This is string 1.0")   ; Changed by Gary Riley
 ?f9 <- (new-string "Thisone")
 ?f10 <- (new-string "This1.0")             ; Changed by Gary Riley
 ?f11 <- (new-string "5400.01.0")           ; Changed by Gary Riley
 ?f26 <- (new-string "first ")
 ?f27 <- (new-string "second")
 ?f28 <- (new-string FALSE)                 ; Changed by Gary Riley
 ?f29 <- (new-string 13) 
 ?f12 <- (data-id gen15)
 ?f13 <- (data-id gen16)
 ?f14 <- (data-id gen17)
 ?f15 <- (data-id gen18)
 ?f16 <- (data-id gen19)
 ?f17 <- (data-id gen10)
 ?f18 <- (data-id gen11)
 ?f19 <- (data-id gen12)
 ?f20 <- (data-id gen13)
 ?f21 <- (data-id gen14)
=>
 (retract ?f ?f1 ?f2 ?f3 ?f4 ?f5 ?f6 ?f7 ?f8 ?f9 ?f10 ?f11 ?f12 ?f13)
 (retract ?f14 ?f15 ?f16 ?f17 ?f18 ?f19 ?f20 ?f21 ?f22 ?f23 ?f24 ?f25)
 (retract ?f26 ?f27 ?f28 ?f29)
 (printout t "subset, str-cat, str-index, sub_string, setgen, gensym, " t 
              "if then else and while tests successful" crlf)
 (assert (end additional-action-functions)))

(defrule error-cleaning-up-additional-action-functions
 (declare (salience -30))
 (begin additional-action-functions)
=>
 (printout t "error in cleaning up additional action functions" crlf))

(defrule clean-up-additional-action-functions-data
 (declare (salience -20)) ; Added by Gary Riley
 (end additional-action-functions)
 ?f <- (data-0 $?x)
 ?f1 <- (data-1 $?y)
 ?f2 <- (data-2 $?z)
=>
 (retract ?f ?f1 ?f2))


(defrule clean-up-addition-action-functions-string
 (declare (salience -20)) ; Added by Gary Riley
 (end additional-action-functions)
 ?f <- (string $?x)
=>
 (retract ?f))

(defrule error-clean-up-additional-action-functions-data
 (declare (salience -30))
 (end additional-action-functions)
 (or (data-0 $?x)
     (data-1 $?x)
     (data-2 $?x)
     (string $?x))
=>
 (printout t "error in cleaning up additional action function data" crlf))