Appendix ;;; Food & Wine Pairing Knowledge Base for Joshua;;; for use with Rule-Based Systems Exercises;;; 6.871 Spring 2005 ;;; Code pertaining to setup of system;;; Code mostly reused from pset 2 (in-package :ju) ; (ask [wine-to-drink john ?x] #'print-answer-with-certainty) (defun print-answer-with-certainty (backward-support &optional (stream*standard-output*))(check-type backward-support cons "backward-support from a query")(let ((predication (ask-database-predication backward-support)))(check-type predication predication "a predication from a query") (terpri stream) (ji::truth-value-case (predication-truth-value predication) (*true* (prin1 predication stream)) (*false* (write-string "[not " stream) (ji::print-without-truth-value predication stream) (write-string "]" stream))) (format stream " ~d" (certainty-factor predication)))) (defgeneric possesive-suffix (predication)) (defgeneric first-prompt (predication)) (defgeneric second-prompt (predication)) (defgeneric third-prompt (predication)) (defgeneric possible-values (predication)) (defgeneric get-an-answer (predication &optional stream)) (defgeneric appropriate-ptype (predication)) (defgeneric accept-prompt (predication)) (defgeneric question-prefix (predication)) (defgeneric remaining-object-string (predication)) ;;; The base mixin (define-predicate-model question-if-unknown-model () () ) (clim:define-gesture-name :my-rule :keyboard (:r :control :shift)) (clim:define-gesture-name :my-help :keyboard (:h :control :shift)) (clim:define-gesture-name :my-why :keyboard (:w :control :shift)) (defparameter *mycin-help-string* " ctrl-? - to show the valid answers to this question meta-r - to show the current rule meta-y - to see why this question is asked meta-h - to see this list" ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; explaining why we're asking what we're asking;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun print-why (trigger rule &optional (stream *standard-output*))(format stream "~%We are trying to determine ")(if (predicationp trigger)(progn (format stream "~a " (question-prefix trigger)) (say triggerstream))(princ trigger stream))(if (null rule)(format stream "~%This is a top level query")(let* ((debug-info (ji::rule-debug-info rule))(sub-goals (let ((ji::*known-lvs* nil))(eval (ji::rule-debug-info-context debug-info)))))(format stream "~%This is being asked for by the rule ~a in orderto determine:~%" rule)(format stream "~a " (question-prefix ji::*goal*)) (sayji::*goal* stream)(typecase sub-goals(ji::and-internal(let ((remaining-preds (rest (predication-statement sub-goals))) (good-answers nil)(remaining-stuff nil)(first-remaining-object-string nil))(labels ((do-good-preds ()(when remaining-preds(let ((first (pop remaining-preds)))(cond((not (predicationp first))(push (copy-object-if-necessary first)good-answers) (do-good-preds))(t(let ((found-it nil))(ask first#'(lambda (just)(push (ask-database-predicationjust) good-answers) (setq found-it t)(do-good-preds)):do-backward-rules nil :do-questions nil)(unless found-it(with-statement-destructured (whovalue) first (declare (ignore who))(with-unification(unify trigger first)(setq first-remaining-object-string(remaining-object-string first))(unify value first-remaining-object-string) (setq remaining-stuff(loop for pred in remaining-preds if (predicationp pred)collect (with-statement-destructured (who value) pred (declare(ignore who)) (unify value(if (joshua:unbound-logic-variable-p value) (remaining-object-string pred) (joshua:joshua-logic-variable-value value))) (copy-object-if-necessary pred)) else collect (copy-object-if-necessary pred)))))))))))))(do-good-preds))(loop for pred in (nreverse good-answers)for first-time = t then nil if first-time do (format stream "~%It has already been determinedwhether: ") else do (format stream "~%and whether: ")do (say pred stream))(format stream "~%It remains to determine ~a ~a ~a"(question-prefix trigger) first-remaining-object-string (remaining-stuff-suffix trigger))(loop for pred in remaining-stuffdo (format stream "~%and ~a ~a ~a" (question-prefixpred) (remaining-object-string pred) (remaining-stuff-suffix pred)))))(otherwise ))))) (defmethod remaining-stuff-suffix ((pred predication)) "is") (defmethod remaining-stuff-suffix ((expression cons)) "") (defmethod predication-value-description ((pred predication)) (remaining-object-string pred)) ;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PROTOCOL HACKING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod say ((expression cons) &optional (stream *standard-output*))(princ expression stream)) (defmethod remaining-object-string ((expression cons)) (format nil "~a"expression)) (defmethod question-prefix ((expression cons)) "whether")(defmethod get-an-answer ((predication question-if-unknown-model)&optional (stream *standard-output*))"Print the prompt for this parameter (or make one up) and read thereply."(fresh-line)(flet ((mycin-help (stream action string-so-far)(declare (ignore string-so-far)) (when (member action '(:help :my-help :my-rule :my-why)) (fresh-line stream)(case action(:my-why(print-why predication ji::*running-rule* stream))(:my-rule(format stream "You are running the rule ~a"ji::*running-rule*))(:my-help(format stream *mycin-help-string*)))(fresh-line stream)(write-string "You are being asked to enter " stream)(clim:describe-presentation-type (appropriate-ptypepredication) stream)(write-char #\. stream))))(let ((clim:*help-gestures* (list* :my-help :my-why :my-ruleclim:*help-gestures*)))(clim:with-accept-help ((:top-level-help #'mycin-help))(clim:accept (appropriate-ptype predication):stream stream :prompt (accept-prompt predication)))))) (defun rules-concluding-predicate (pred)(let ((answers nil))(map-over-backward-rule-triggers `[,pred ? ?]#'(lambda (trigger) (pushnew(ji::backward-trigger-rule trigger) answers)))answers)) (defun predicates-rule-relies-on (rule)(let ((answers nil))(labels ((do-one-level (stuff)(let ((connective (when (predication-maker-p stuff)(predication-maker-predicate stuff))))(case connective((and or)(with-predication-maker-destructured (&rest more-stuff) stuff (loop for thing in more-stuffdo (do-one-level thing))))((nil))(otherwise(pushnew connective answers))))))(do-one-level (ji::rule-debug-info-context (ji::rule-debug-inforule))))answers)) (defun graph-rule-tree (predicates &key (orientation :vertical) (size:small) (stream *standard-output*))(terpri