fldval50.clp

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

(defrule constraining-functions-not-vertical
 (declare (salience 4)) ; Added by Gary Riley
 (begin constraining-functions) ; Added by Gary Riley
 (point ?p1 ?x1 ?)
 (point ?p2&~?p1 ?x2&:(neq ?x1 ?x2) ?)
=>
 (assert (rule-3 ?p1 ?p2 not-vertical))
 (printout t "constraining-functions-not-vertical should fire")
 (printout t " ten times" crlf))

;;; 3.5 Test to Constrain Variables
;;;
;;; Any external function may be embedded within a test operation. All defined
;;; functions, user or CLIPS functions use the prefix notation.


;;; ======================= CONSTRAINING FUNCTIONS ===========================
;;; ============================ TEST FUNCTION ===============================


(defrule slope-of-line-negative-test-function
 (declare (salience 3)) ; Added by Gary Riley
 (begin constraining-functions) ; Added by Gary Riley
 (point ?p1 ?x1 ?y1)
 (point ?p2 ?x2 ?y2)
 (test (and ( neq 0 ( - ?x2 ?x1))
  (or ( neq ?x1 ?x2)( neq ?y1 ?y2))
  ( > 0 ( / ( - ?y2 ?y1) ( - ?x2 ?x1)))))
=>
 (assert (rule-4 ?p1 ?p2 "+" slope))
 (printout t "slope-of-line-negative-test-function should")
 (printout t " fire four times" crlf))

(defrule slope-of-line-positive-test-function
 (declare (salience 2)) ; Added by Gary Riley
 (begin constraining-functions) ; Added by Gary Riley
 (point ?p1 ?x1 ?y1)
 (point ?p2 ?x2 ?y2)
 (test (and ( neq 0 ( - ?x2 ?x1))
  (or ( neq ?x1 ?x2)( neq ?y1 ?y2))
  ( < 0 ( / ( - ?y2 ?y1) ( - ?x2 ?x1)))))
=>
 (assert (rule-5 ?p1 ?p2 "-" slope))
 (printout t "slope-of-line-positive-test-function")
 (printout t " fire four times" crlf))

(defrule fact-address-test-function                                  ;CR0023
 (declare (salience 1)) ; Added by Gary Riley
 (begin constraining-functions) ; Added by Gary Riley
  ?f1 <- (point ~B $?)                                               ;CR0023
  ?f2 <- (point ~C $?)                                               ;CR0023
  (test (neq ?f1 ?f2))                                               ;CR0023
=>                                                                   ;CR0023
  (printout t "fact-address-test-function should fire seven times" crlf));CR0023

(defrule constraining-functions-clean-up
 (declare (salience -10)) ; Added by Gary Riley
 ?f <- (begin constraining-functions)
 ?f1 <- (rule-1 D A 4 0)
 ?f2 <- (rule-1 D C 4 -6)
 ?f3 <- (rule-1 B C 4 -6)
 ?f4 <- (rule-1 B A 4 0)
 ?f5 <- (rule-2 D B vertical)
 ?f6 <- (rule-2 B D vertical)
 ?f7 <- (rule-3 D A not-vertical)
 ?f8 <- (rule-3 A D not-vertical)
 ?f9 <- (rule-3 B A not-vertical)
 ?f10 <- (rule-3 D C not-vertical)
 ?f11 <- (rule-3 C D not-vertical)
 ?f12 <- (rule-3 C A not-vertical)
 ?f13 <- (rule-3 A C not-vertical)
 ?f14 <- (rule-3 C B not-vertical)
 ?f15 <- (rule-3 B C not-vertical)
 ?f16 <- (rule-3 A B not-vertical)
 ?f17 <- (rule-5 B C "-" slope)
 ?f18 <- (rule-5 C B "-" slope)
 ?f19 <- (rule-5 B A "-" slope)
 ?f20 <- (rule-5 A B "-" slope)
 ?f21 <- (rule-4 A D "+" slope)
 ?f22 <- (rule-4 D A "+" slope)
 ?f23 <- (rule-4 C D "+" slope)
 ?f24 <- (rule-4 D C "+" slope)
=>
 (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)
 (assert (end constraining-functions)))


(defrule error-constraining-functions-clean-up
 (declare (salience -30)) ; Added by Gary Riley 
 (begin constraining-functions)
=>
 (printout t "error in constraining functions" crlf))

(defrule point-facts-clean-up
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-functions)
 ?f <- (point $?)
=>
 (retract ?f))

(defrule error-clean-up-rules-for-constraining-functions
 (declare (salience -30)) ; Added by Gary Riley
 (end constraining-functions)
 (or (rule-1 $?)
  (rule-2 $?)
  (rule-3 $?)
  (rule-4 $?))
=>
 (printout t "error in constraining functions values" crlf))

(defrule begin-constraining-patterns-test
 (declare (salience -40)) ; Added by Gary Riley
 (end constraining-functions)
 =>
 (assert (begin constraining-patterns)))

 
;;; 3.6 Constraining Patterns

;;; Logcial pattern blocks allow patterns to be combined using inclusive OR,
;;; explicit AND, and negation NOT.  Single, multiple and nested inclusive ORs
;;; are tested.  OR with nested ANDs is also tested in this section.


;;; ====================== CONSTRAINING PATTERNS ============================
;;; =========================== OR AND NOT ==================================

(defrule facts-for-constraining-patterns
 (declare (salience -10))
 (begin constraining-patterns)
 ?f <- (end constraining-functions)
=>
 (retract ?f)
 (assert (letter a))
 (assert (letter b))
 (assert (letter c))
 (assert (letter d))
 (assert (letter e))
 (assert (block a))
 (assert (block b))
 (assert (block c))
 (assert (pattern A))
 (assert (pattern B))
 (assert (part A))
 (assert (part B)))

(defrule or-not-nested-constraining-patterns
 (declare (salience 4)) ; Added by Gary Riley
 (begin constraining-patterns)
 (or (letter a)
  (letter b)
  (letter c))
=>
 (assert (successful "or not nested constraining patterns"))
 (printout t "or-not-nested-constraining-patterns should fire three")
 (printout t " times" crlf))

(defrule multiple-ors-constraining-patterns
 (declare (salience 3)) ; Added by Gary Riley
 (begin constraining-patterns)
 (or (letter a)
  (letter b))
 (or (block a)
  (block b))
=>
 (assert (successful "multiple ors constraining patterns"))
 (printout t "multiple-ors-constraining-patterns should fire four")
 (printout t " times" crlf))

(defrule nested-ors-constraining-patterns
 (declare (salience 2)) ; Added by Gary Riley
 (begin constraining-patterns)
 (or
   (or (letter a)
   (letter b))
  (or (block a)
   (block b)))
=>
 (assert (successful "nested ors constraining patterns"))
 (printout t "nested-ors-constraining-patterns should fire")
 (printout t " four times" crlf))

(defrule nested-ands-or-not-constraining-patterns
 (declare (salience 1)) ; Added by Gary Riley
 (begin constraining-patterns)
 (or (and (letter ?x)
   (block ?x))
  (and (pattern ?x)
   (part ?x)))
 (letter ?y)
 (not (block ?y))
=>
 (assert (rule-1 ?x ?x only-letter ?y))
 (printout t "nested-ands-or-not-constraining-patterns should fire")
 (printout t " ten times" crlf))

(defrule constraining-patterns-clean-up
 (declare (salience -10))
 ?f <- (begin constraining-patterns)
 ?f1 <- (successful "multiple ors constraining patterns")
 ?f2 <- (successful "nested ors constraining patterns")
 ?f3 <- (successful "or not nested constraining patterns")
 (rule-1 B B only-letter d)
 (rule-1 B B only-letter e)
 (rule-1 A A only-letter d)
 (rule-1 A A only-letter e)
 (rule-1 c c only-letter d)
 (rule-1 c c only-letter e)
 (rule-1 b b only-letter d)
 (rule-1 b b only-letter e)
 (rule-1 a a only-letter d)
 (rule-1 a a only-letter e)
=>
 (retract ?f ?f1 ?f2 ?f3)
 (assert (end constraining-patterns)))


(defrule error-constraining-patterns
 (declare (salience -30))
 (begin constraining-patterns)
=>
 (printout t "error in constraining patterns" crlf))

(defrule clean-up-letter-facts
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-patterns)
 ?f <- (letter ?)
=>
 (retract ?f))

(defrule clean-up-block-facts
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-patterns)
 ?f <- (block ?)
=>
 (retract ?f))

(defrule clean-up-pattern-facts
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-patterns)
 ?f <- (pattern ?)
=>
 (retract ?f))

(defrule clean-up-part-facts
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-patterns)
 ?f <- (part ?)
=>
 (retract ?f))

(defrule clean-up-rule-1-facts-two
 (declare (salience -20)) ; Added by Gary Riley
 (end constraining-patterns)
 ?f <- (rule-1 $?)
=>
 (retract ?f))

(defrule error-clean-up-constraining-patterns-facts
 (declare (salience -30)) ; Added by Gary Riley
 (end constraining-patterns)
 (or (letter ?)
  (block ?)
  (pattern ?)
  (part ?)
  (rule-1 $?))
=>
 (printout t "error in cleaning up constraining patterns facts" crlf))


(defrule begin-rule-properties-test
 (declare (salience -40)) ; Added by Gary Riley
 (end constraining-patterns)
 =>
 (assert (begin rule-properties)))
 
;;; 3.7 Pattern bindings

;;; A variable can be bound to an entire fact.  Pattern bindings are tested in
;;; all clean up rules with different patterns containing a variable number of
;;; fields and constraints.

;;; 3.8 Declaring rule properties

;;; Properties or characteristics of a rule may be defined in the declare
;;; construct.  All declare statements must appear before the first pattern on
;;; the LHS.

;;; 3.8.1 Assigning rule priority

;;; A salience statement allows the assignment of a priority to a rule.  In
;;; this file salience, in conjunction with control facts, is employed to phase
;;; from one testing sequence to another.  Additionally, sets of clean up rules
;;; are controlled with salience.  Therefore only maximum and minimum salience
;;; values are tested in this section.


;;; ========================== RULE PROPERTIES =================================
;;; ========================== DECLARE SALIENCE ================================


(defrule salience-max-value
 (declare (salience 10000))
 (initial-fact)
=>
 (printout t crlf "TESTING CLIPS - BASIC PROGRAMMING GUIDE" crlf))

(defrule salience-positive
 (declare (salience 100))
 (initial-fact)
=>
 (printout t "common capabilities such as:" crlf
              "assert, retract, salience, fprintout" crlf
              "are exercised all through the test" crlf))

(defrule salience-min-value
 (declare (salience -10000))
 ?f <- (initial-fact)
=>
 (retract ?f)
 (printout t "list of facts that were not cleaned up, error if any" crlf)
 (facts)
 (printout t "file text.tmp may be deleted" crlf
              "CLIPS TESTING COMPLETED" crlf crlf))

;;; 4.0 Actions

;;; 4.1 Basic actions


;;; ========================= ACTIONS FUNCTIONS ==============================
;;; ===================== ASSERTS RETRACT STR_ASSERT =========================
;;; ======================== BIND HALT OPEN CLOSE ============================

;;; 4.1.1 Creating new facts

;;; The assert action permits a fact to be added to the fact-list.  Facts
;;; containing bound single and multiple field variables, in addition to literal
;;; values, are asserted during the testing beginning in section 3.3.  Only
;;; assert actions containing function calls will be tested in this section.


(defrule assert-facts-for-actions
 (declare (salience -10))
 ?f1 <- (begin rule-properties)
 ?f2 <- (end constraining-patterns)
=>
 (retract ?f1 ?f2)
 (assert (begin action-assert-retract))
 (assert (data numbers 2.75e3 -53.7 6.25e2))
 (assert (data string "Computer Sciences Corporation"))
 (assert (charles specialchar!@#$%^*_+{}:>`-=\[]'./))
 (assert (charles "specialchar~!@#$%^&*()_+|{}:\"<>?`-=\\[];',./"))
 (assert (chuck delimeter ab<cd"a"x
y)))

(defrule assert-facts-using-external-functions-1                 ;DR0023
 (declare (salience 1))
 (begin action-assert-retract)                                   ;DR0023
 (data numbers ?num-1 ?num-2 ?num-3)                             ;DR0023
=>                                                               ;DR0023
 (assert (rule-1 numbers =(/ ?num-1 ?num-3) =(* ?num-1 ?num-2)   ;DR0023
    =(max ?num-1 ?num-2 ?num-3))))                               ;DR0023

(defrule assert-facts-using-external-functions-2
 (declare (salience 3))
 (begin action-assert-retract)
=>
 (printout t "Enter the number 7: " crlf)
 (assert (rule-2 number =(read))))

;;; 4.1.2 Removing Facts From The Fact-list

;;; The retract actions allow you to remove facts from the fact-list.  All
;;; clean up rules retract one or more facts which have been bound to a fact-
;;; variable on the LHS.  Only the retraction of a fact by fact-number is tested
;;; in this section.

(defrule retract-fact-by-fact-number
 (declare (salience 2))
 (begin action-assert-retract)
=>
 (retract 31 44))
;;; f-31  (end field-values)
;;; f-44  (end wildcards)

;;; 4.1.3 Asserting A String

;;; The assert-string takes a single string and breaks it into separate fields
;;; prior to asserting the fact.  String-assert in tested in asserting
;;; with literal string arguments and then with a variable argument in
;;; combination with the readline function.

(defrule assert-string-of-facts
 (declare (salience 4))
 (begin action-assert-retract)
=>
 (assert-string "(rule-3 Steve Mueller)")
 (assert-string "(rule-3 numbers 7 3.5 -4.5e4)")
 (assert-string "(rule-3 string\"Ann\"\"Baker\")")
 (assert-string "(rule-3 delimiters a<b c d e f)")) ; Changed by Gary Riley

(defrule clean-up-assert-retract
 (declare (salience -10)) ; Added by Gary Riley
 ?f <- (begin action-assert-retract)
 (not (end field-values))
 (not (end wildcards))
 (rule-1 numbers 4.4 -147675.0 2.75e3) ; Changed by Gary Riley
 (rule-2 number 7)
 (rule-3 Steve Mueller)
 (rule-3 numbers 7 3.5 -4.5e4)
 (rule-3 string "Ann" "Baker")
 (rule-3 delimiters a <b c d e f)        ;CR0001 Change by Gary Riley
 ?f1 <- (charles specialchar!@#$%^*_+{}:>`-=\[]'./)
 ?f2 <- (charles "specialchar~!@#$%^&*()_+|{}:\"<>?`-=\\[];',./")
 ?f3 <- (chuck delimeter ab <cd "a" x y)
=>
 (retract ?f ?f1 ?f2 ?f3)
 (printout t "retract by fact number test successful" crlf
  "assert using external functions and assert-string tests successful" crlf)
 (assert (end action-assert-retract)))

(defrule error-assert-retract
 (declare (salience -30))
 (begin action-assert-retract)
=>
 (printout t "error in action assert retract values" crlf))

(defrule error-asserting-delimeters
 (declare (salience -30))
 (end action-assert-retract)
 ?f <- (chuck delimeter $?x)
=>
 (retract ?f)
 (printout t "error in asserting delimeter test" crlf))

(defrule error-asserting-specialchars
 (declare (salience -30))
 (end action-assert-retract)
 ?f <- (charles $?x)
=>