swartz.clp

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

;;;=================================
;;;
;;;		<<<<  Stipulated Program Documentation  >>>>>>>
;;;
;;;	Programmer:   			John Swartz
;;;	Affiliation of Programmer:	Staff Programmer/Analyst 
;;;					 State of Texas
;;;						member IEEE and ACM
;;;
;;;	e-mail address:			[e-mail]
;;;	phone:				(512)  438-4510
;;;	fax:				(512)  438-3131
;;;	CLIPS version:			6.04
;;;	Purpose of program:		This program implements the Symbolic Integrals 
;;;	 				algorithm.   It represents a
;;;					rehosting of the work of 
;;;					James Slagle  in his 1961 MIT PhD
;;;					dissertation.
;;;					This program has no input file.
;;;					To execute, just (load) and (run)
;;;					it.
;;;
;;;	Disclaimer:			The implementer of this code makes no
;;;					guarantee as to bugs and defects.   Any
;;;					user shall not hold responsible
;;;					the implementer nor Joseph Giarratano nor
;;;					Gary Riley if the code does not work as
;;;					claimed.
;;;
;;;	Acknowledgement:  		This program was published in the
;;;					June 1997 issue of Dr. Dobbs Journal
;;;		
;;;===================================

;;;**********************************
;;;*
;;;*		Templates
;;;*
;;;**********************************

(deftemplate standard
    (slot argument
	(type SYMBOL)
	(default nothing))
    (multislot image
	(type SYMBOL)
	(default nothing)))

(deftemplate pythag
    (slot arg1
	(type LEXEME)
	(default nothing))
    (slot arg2
	(type SYMBOL)
	(default nothing))
    (slot arg3
	(type LEXEME)
	(default nothing)))

(deftemplate  heuristic
    (multislot domain
	(type SYMBOL)
	(default nothing))
    (multislot  range
	(type SYMBOL)
	(default nothing)))

(deftemplate transform
    (multislot arg1
   	(type LEXEME)
	(default ?DERIVE))
    (multislot arg2
   	(type LEXEME)
	(default ?DERIVE)))


(deftemplate goal-is-to
    (slot action
	(type SYMBOL)
	(allowed-symbols integrate transform heuristic)
	(default ?NONE))
    (multislot arguments
	(type LEXEME)
	(default ?NONE)))


;;;**********************************
;;;*
;;;*	utility functions
;;;*
;;;**********************************

(deffunction total (?addend  ?augend)
	(implode$ (create$ (+ (integer (nth$ 1 (explode$ ?addend))) 
		(integer (nth$ 1 (explode$ ?augend)))))))

(deffunction root (?val)
	(implode$ (create$ (integer (sqrt (integer (integer (nth$ 1 (explode$ ?val))))
				)))))

(deffunction along (?val ?arg)
	(printout t "   value is   "  ?val  crlf)
     	(if  (member$ uuu ?val)
	   then 
           (bind ?val (replace$ ?val (member$ uuu ?val) (member$ uuu ?val) arctan_v))
	    (along ?val ?arg))))

(deffunction jam (?old-val)
       (sym-cat (sub-string 1 (- (str-index "t"  ?old-val) 1) ?old-val) "xxx")))

;;;**********************************
;;;*
;;;*	integration  and transformation rules
;;;*
;;;**********************************

(defrule  integrate	""
    (goal-is-to  (action integrate)  (arguments ?alfa))
    (standard   (argument  ?alfa )  (image $?beta))
    =>
    (printout t   ?beta crlf))

(defrule integer	""
    (goal-is-to  (action integrate)  (arguments ?alfa))
    (test (stringp ?alfa))
    =>
;    (printout t "value of integrand is   "  ?alfa crlf)
    (printout t   ?alfa " v " ))

(defrule  special "this is the last standard integral form"
    (declare (salience  50))    
    ?goal <- (goal-is-to  (action integrate) 
		 (arguments RECIP MINUS $?fluff ?x&:(stringp ?x)))
    =>
    (assert (integral  ln DIVIDE { MINUS uuu 1 ! (root ?x) }{PLUS uuu 1 ! (root ?x) })))
    (printout t "value of integral is   "   crlf
	"ln  DIVIDE { MINUS uuu  1  !  " (root ?x) " }{PLUS uuu 1 !  " (root ?x) crlf))   

(defrule  plusform   ""
    ?goal <- (goal-is-to (action transform)  (arguments PLUS ?x  ?y))
    (not  (goal-is-to  (action integrate)  (arguments ?x)))
    =>
    (printout t "style of integral is  PLUS  ")
    (assert (goal-is-to  (action integrate)  (arguments ?x)))
    (assert (goal-is-to  (action integrate)  (arguments ?y)))
    (retract ?goal))

(defrule trigonometric "this rule inserts square-sec in the denominator"
    (declare (salience  100))
    ?goal <- (goal-is-to (action heuristic) 
		(arguments $?leader ?x&:(eq ?x square-sec )  $?remainder ))
    ?flag  <- (flag-set yes)
    =>
    (modify ?goal (arguments ?leader ?x ! ?x ?remainder ))
    (retract ?flag)
    (assert (tangent yes))
 (printout t "argument value is now:   " ?leader ?x ?x ?remainder  crlf)))
    
(defrule cancel ""
    (declare (salience  50))
    ?goal <- (goal-is-to (action heuristic) 
		(arguments $?leader ?x ?y&:(eq ?y !)  ?x $?remainder))
    =>
    (modify ?goal (arguments ?leader "1"  !  ?remainder )))

(defrule substitute ""
    ?goal <- (goal-is-to (action heuristic) 
    (arguments $?leader ?x&:(or (eq tan  ?x) (eq square-tan  ?x)) $?remainder))
    =>
    (modify ?goal (arguments ?leader (jam ?x) ?remainder))))
;;  need a control fact here to ensure executing this doesn't get out of hand !!!

(defrule resolve  "this rule removes middle term from quadratic denominator"
    (declare (salience  -50))
    ?goal <- (goal-is-to (action heuristic) 
	(arguments ?x&:(eq ?x DIVIDE) ?y&:(stringp ?y) ?$?middle ?z&:(stringp ?z)
		?$?smore ?xx ?yy&:(stringp ?yy) $?))
    =>
    (assert (goal-is-to (action integrate) (arguments RECIP MINUS square-uuu "1" ! "4")))
    (retract ?goal))

(defrule   heuristic  ""
    ?goal <- (goal-is-to (action heuristic)  
			(arguments $?leader ?x&:(symbolp ?x) $?remainder))
    (pythag  (arg1 ?flaff)  (arg2 ?bloof) (arg3 ?x))
;    (symbolp ?x)
    =>
    (printout t "made it to here  "  ?remainder  crlf)
    (modify  ?goal (arguments ?leader PLUS ?flaff  ?bloof ?remainder)))

(defrule   simplify  ""
    ?goal <-  (goal-is-to  (action heuristic) 
 	(arguments $?leader PLUS ? ?x&:(stringp ?x)  PLUS ?y&:(stringp ?y)  $?remainder))
;    (sum (term1  ?x)  (term2 ?y)  (term3 ?z))  
    =>
    (modify ?goal (arguments ?leader PLUS (total ?x ?y) ?remainder))
;    (printout t "type of variable ?z is:  "  (type ?z)  crlf)
    (printout t "execute simplify  value:  " ?leader PLUS (total ?x ?y) ?remainder  crlf))

(defrule mapback "this rule maps back any trigonometric substutions that were made"
    ?final <- (integral $?almost)
    (tangent yes)
    =>
    (printout t "value of integral is   "   crlf
			(along ?almost (create$ arctan v))  crlf
					))

(defrule spawn	""
    ?goal <- (goal-is-to  (action integrate)  (arguments ?x ?y $?alfa))
;    (test ( <  3 (length$ arguments)))
    (not  (goal-is-to	(action transform)  (arguments  $?alfa)))
    =>
    (printout t "  value of integrand is   "  crlf ?x "  " ?y crlf  "   " ?alfa  crlf)
    (assert   (goal-is-to  (action   transform)  (arguments ?x ?y ?alfa)))
    (assert   (goal-is-to  (action   heuristic)  (arguments  ?x ?y ?alfa)))
    (retract ?goal))

;;;*********************************
;;;*                               *
;;;*	Initial State Rule	   *
;;;*                               *
;;;*********************************
	
(defrule startup	""
    =>
    (assert (standard  (argument  integer)  (image  integer v)))
    (assert (standard  (argument  exp)  (image  exp v)))
    (assert (standard  (argument  powerc )  (image  divide {power c  v}  ln c)))
    (assert (standard  (argument  ln)  (image	times *v ln v*)))
    (assert (standard  (argument  logc )  
			(image  minus *times *v logc v* *divide *v ln c*)))
    (assert (standard  (argument cos)  (image   sin v)))
    (assert (standard  (argument sin)  (image   -cos v)))
    (assert (standard  (argument  tan)  (image ln sec v)))
    (assert (standard  (argument  ctn)  (image  ln sin v)))
    (assert (standard  (argument  sec)  (image  ln *plus *sec v tan v*)))
    (assert (standard  (argument  csc)  (image  ln *minus *csc v ctn v*)))
;;;************************************
;;;*
;;;*    pythagorian identies follow
;;;*
;;;************************************
    (assert (pythag (arg1 square-sin) (arg2 square-cos) (arg3 "1")))
    (assert (pythag (arg1 "1") (arg2 square-tan) (arg3 square-sec)))
    (assert (pythag (arg1 "1") (arg2 square-ctn) (arg3 square-csc)))
    (assert (DIVIDE))
    (assert (goal-is-to  (action  integrate)  
      (arguments  DIVIDE square-sec PLUS {"1" square-sec { TIMES { MINUS "3"} tan } )))
;    (assert (goal-is-to  (action  integrate)  (arguments  PLUS cos "5"))))
;    (assert (goal-is-to  (action  integrate)  (arguments   cos ))))
    (assert (flag-set yes))
    (printout t " memory used is:   "  (mem-used)  crlf))