Hi Mark,
This looks like a very interesting and useful utility you've put together here.
I could certainly use this output to do some introspection of my own rulebase.
Problem is, I haven't looked at lisp code for over a decade, and can barely follow it.
Three things might get me started, though:
1) How do I envoke this? (process-jess-clp-file ?)
Can it be run with multiple .clp files (if not, I could just merge them).
2) Have you tried running this under emacs (the only lisp environment I have at my
disposal)
3) Any other pointers welcome!
Thanks,
Jack
Mark Nahabedian wrote:
> My knowledgebase is not yet making the conclusions I'm hoping for. In
> hopes of determining what additional facts or inference rules I need,
> I hacked together a CommonLisp program that reads my '.clp' files and
> produces an html file which shows how the rules and fact templates
> relate to one another.
>
> I expect that there's probably already similar tools that would
> provide the same information (or more) working directly from the Java
> Rete instance but I don't know what they are.
>
> Here's my hack, in case anyone's interested. It was develooped using
> LispWorks but I expect it should work in any CommonLisp.
>
> ;;; -*- Mode:Lisp -*-
>
> (defun index-clp-file (file)
> (let ((jess-info (process-jess-clp-file file)))
> (html-write jess-info
> (make-pathname :type "html" :defaults file))))
>
> (defclass jess-info ()
> ((fact-names :initform nil)
> (rule-names :initform nil)
> (facts-to-rules
> ;; ALIST of (FACT RULE-IT-TRIGGERS)
> :initform nil)
> (rules-to-facts
> ;; ALIST of (RULE FACT-IT-ASSERTS)
> :initform nil)))
>
> (defmethod note-rule-requires-fact ((ji jess-info)
> rule-name fact-name)
> (with-slots (fact-names rule-names facts-to-rules) ji
> (pushnew fact-name fact-names)
> (pushnew rule-name rule-names)
> (pushnew (list fact-name rule-name)
> facts-to-rules
> :test 'equal)))
>
> (defmethod note-rule-asserts-fact ((ji jess-info) rule-name fact-name)
> (with-slots (fact-names rule-names rules-to-facts) ji
> (pushnew fact-name fact-names)
> (pushnew rule-name rule-names)
> (pushnew (list rule-name fact-name)
> rules-to-facts
> :test 'equal)))
>
> (defvar *html-indent* 0)
> (defparameter +html-indent-step+ 2)
>
> (defmacro with-tag ((stream tag &rest attributes) &body body)
> (let ((tag-var '#:tag)
> (stream-var '#:stream))
> `(let ((,tag-var ,tag)
> (,stream-var ,stream))
> (format ,stream-var "~&~vT<~a~{ ~a='~a'~}>"
> (* *html-indent* +html-indent-step+)
> ,tag-var
> (list ,@attributes))
> (let ((*html-indent* (1+ *html-indent*)))
> ,@body)
> (format , stream-var "~&~vT</~a>"
> (* *html-indent* +html-indent-step+)
> ,tag-var))))
>
> (defmethod html-write ((jess-info jess-info) to)
> (html-write jess-info (pathname to)))
>
> (defmethod html-write ((jess-info jess-info) (to pathname))
> (with-open-file (stream to
> :direction :output
> :if-exists :supersede)
> (format *trace-output* "~&Outputting to ~a" (pathname stream))
> (html-write jess-info stream)))
>
> (defmethod html-write ((jess-info jess-info) (stream stream))
> (with-tag (stream "html")
> (with-tag (stream "body")
> (labels ((make-a-name (what thing)
> (ecase what
> (:fact (format nil "fact-~a" thing))
> (:rule (format nil "rule-~a" thing))))
> (do-em (list match-key match-value relationship other-key other-type)
> (dolist (item list)
> (when (eq match-value (funcall match-key item))
> (let ((other (funcall other-key item)))
> (with-tag (stream "li")
> (format stream "~a " relationship)
> (with-tag (stream
> "a" "href"
> (string-append "#"
> (make-a-name other-type
> other)))
> (format stream "~a" other))))))))
> (with-slots (fact-names rule-names facts-to-rules rules-to-facts) jess-info
> (setq fact-names (sort fact-names 'string-lessp :key 'symbol-name))
> (setq rule-names (sort rule-names 'string-lessp :key 'symbol-name))
> (with-tag (stream "dl")
> (with-tag (stream "h2")
> (write-string "Facts" stream))
> (dolist (fact fact-names)
> (with-tag (stream "dt")
> (with-tag (stream "a" "name" (make-a-name :fact fact))
> (format stream "fact ")
> (with-tag (stream "b")
> (format stream "~a" fact))))
> (with-tag (stream "dd")
> (do-em facts-to-rules 'first fact "triggers" 'second :rule)
> (do-em rules-to-facts 'second fact "asserted by" 'first :rule)))
> (with-tag (stream "h2")
> (write-string "Rules" stream))
> (dolist (rule rule-names)
> (with-tag (stream "dt")
> (with-tag (stream "a" "name" (make-a-name :rule rule))
> (format stream "rule ")
> (with-tag (stream "b")
> (format stream "~a" rule))))
> (with-tag (stream "dd")
> (do-em facts-to-rules 'second rule "triggered by" 'first :fact)
> (do-em rules-to-facts 'first rule "asserts" 'second :fact)))))))))
>
> (defun process-jess-clp-file (pathname
> &optional
> (jess-info (make-instance 'jess-info)))
> (with-open-file (stream pathname
> :direction :input)
> (format t "~&Processing ~a" (pathname stream))
> (handler-case
> (loop
> (let ((form (read stream)))
> (process-jess-top-level-form jess-info form)))
> (end-of-file () )))
> jess-info)
>
> (defmethod process-jess-top-level-form ((jess-info jess-info)
> (form list))
> (process-jess-top-level-expression jess-info (car form) (cdr form)))
>
> (defmethod process-jess-top-level-expression ((jess-info jess-info)
> (op symbol) args)
> )
>
> (defmethod process-jess-top-level-expression ((jess-info jess-info)
> (op (eql 'batch)) args)
> (process-jess-clp-file (car args) jess-info))
>
> (defmethod process-jess-top-level-expression ((jess-info jess-info)
> (op (eql 'deffacts)) args)
> )
>
> (defmethod process-jess-top-level-expression ((jess-info jess-info)
> (op (eql 'do-backward-chaining))
> args)
> (format t "~&Backward chaining: ~a" (car args)))
>
> (defmethod process-jess-top-level-expression ((jess-info jess-info)
> (op (eql 'defrule)) args)
> (let ((rule-name nil)
> (consequent-p :if))
> (dolist (f args)
> (multiple-value-setq (consequent-p rule-name)
> (process-jess-rule-clause jess-info f consequent-p rule-name)))))
>
> (defgeneric process-jess-rule-clause (jess-info clause consequent-p rule-name)
> (declare (values new-consequent-p rule-name)))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause (eql '<-))
> (consequent-p (eql :if))
> (rule-name symbol))
> ;; no-op
> (values consequent-p rule-name))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause (eql '=>))
> (consequent-p (eql :if))
> (rule-name symbol))
> ;; enter consequent mode
> (values :then rule-name))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause string)
> (consequent-p (eql :if))
> rule-name)
> ;; ignore rule doc string
> (values consequent-p rule-name))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause symbol)
> (consequent-p (eql :if))
> (rule-name null))
> ;; got rule name
> (values consequent-p clause))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause symbol)
> consequent-p
> (rule-name symbol))
> ;; no-op
> (values consequent-p rule-name))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause list)
> (consequent-p (eql :if))
> (rule-name symbol))
> (unless (eq (car clause) 'test)
> (note-rule-requires-fact jess-info rule-name (car clause)))
> (values consequent-p rule-name))
>
> (defmethod process-jess-rule-clause ((jess-info jess-info)
> (clause list)
> (consequent-p (eql :then))
> (rule-name symbol))
> (when (eq (car clause) 'assert)
> (dolist (asserted (cdr clause))
> (note-rule-asserts-fact jess-info rule-name (car asserted))))
> (values consequent-p rule-name))
>
> --------------------------------------------------------------------
> To unsubscribe, send the words 'unsubscribe jess-users [EMAIL PROTECTED]'
> in the BODY of a message to [EMAIL PROTECTED], NOT to the list
> (use your own address!) List problems? Notify [EMAIL PROTECTED]
> --------------------------------------------------------------------
--------------------------------------------------------------------
To unsubscribe, send the words 'unsubscribe jess-users [EMAIL PROTECTED]'
in the BODY of a message to [EMAIL PROTECTED], NOT to the list
(use your own address!) List problems? Notify [EMAIL PROTECTED]
--------------------------------------------------------------------
