;;; File: switches.lisp
;;; Author: Peter Clark
;;; Date: 4/19/01
;;; Purpose: Toy system for finding coherent interpretations of input
;;; Requires: km.lisp, switches.lisp
;;; For a trace of the execution, see Working Note 24 at
;;;	http://www.cs.utexas.edu/users/pclark/working_notes/
#|
USAGE:
USER(1): (doit)
|#

(setq *print-right-margin* 140)

(defun doit ()
  (format t "Enter sentence: ")
  (let* ( (sentence (read-line)) 			; "he pushed the switch"
;	  (sentence (progn
;		      (format t "\"he pushed the switch\"~%")
;		      "he pushed the switch"))
	  (words (string-to-words sentence))		; ("he" "pushed" "the" "switch")
	  (word-concepts-list 				; (("pushed" (Pushing)) ("switch" (Changing Switch-Device)))
	   (remove nil
		   (mapcar #'(lambda (word)
			       (let ( (concepts
				       (km `#$(allof (the all-subclasses of Thing)
						     where ((the words of It) includes ,WORD)) :fail-mode 'fail)) )
				 (cond (concepts (list word concepts)))))
			   words)))
	  (interpretations (interpretations word-concepts-list)) 
	  (_dummy (km-format t "interpretations = ~%~{  ~a~%~}" interpretations))
	  (all-prototypes (remove-if-not #'prototype-rootp (km '#$(the all-instances of Thing))))
	  (ranked-matches						 ; list of rank-prototype-matches
	   (mapcan #'(lambda (prototype)
		       (mapcar #'(lambda (interpretation)
				   (ranked-match prototype interpretation))
			       interpretations))
		   all-prototypes)) )
    (declare (ignore _dummy))
    (km-format t "Scenarios fitting the data:~%")
    (mapc #'ranked-match-write ranked-matches)
    (let* ( (best-ranked-match (first (sort ranked-matches #'> :key #'first))) 
	    (best-prototype (second best-ranked-match)) 
	    (best-word-interpretations (third best-ranked-match)) )
      (km-format t "Best ranked-match:~%")
      (ranked-match-write best-ranked-match)
      (km-format t "Therefore:~%")
      (mapc #'(lambda (word+class+protopart)
		(let ( (word (first word+class+protopart))
		       (class (second word+class+protopart))
		       (protopart (third word+class+protopart)) )
		  (cond ((neq protopart '?)
			 (km-format t "        ~a -> ~a~%" word class)))))
	    best-word-interpretations)
      (km-format t "Additional inferences:~%")
      (mapcar #'(lambda (protopart)
		  (let ( (protopart-classes (delistify (immediate-classes protopart))) )
		    (mapcar #'(lambda (slotvals)
				(let* ( (slot (slot-in slotvals))
					(vals (vals-in slotvals)) )
				  (cond ((not (built-in-slot slot))
					 (let ( (class-sets (mapcar #'delistify (mapcar #'immediate-classes vals))) )
					   (km-format t "   ~a ~a ~a~%" protopart-classes slot class-sets))))))
			    (get-slotsvals protopart 'own-properties))))
	      (km `#$(the protoparts of ,BEST-PROTOTYPE)))
      t)))

;;; ----------------------------------------				

(defun ranked-match-write (rank+prototype+matches)
  (let ( (rank (first rank+prototype+matches))
	 (prototype (second rank+prototype+matches))
	 (matches (third rank+prototype+matches)) )
    (km-format t "        ~a (score ~a)~%           [for interpretation ~a]~%"
	       (delistify (km `#$(the classes of ,PROTOTYPE))) rank matches)))


(defun interpretations (word-concepts-list)
  (cond 
   ((null word-concepts-list) '(()))
   (t (let* ( (word-concepts (first word-concepts-list))
	      (word (first word-concepts))
	      (concepts (second word-concepts)) 
	      (rest-interpretations (interpretations (rest word-concepts-list))) )
	(mapcan #'(lambda (concept)
		    (mapcar #'(lambda (rest-interpretation)
				(cons (list word concept) rest-interpretation))
			    rest-interpretations))
		concepts)))))

(defun ranked-match (prototype interpretation)
  (let* ( (protoparts (km `#$(the protoparts of ,PROTOTYPE))) 
	  (matches (match interpretation protoparts))
	  (rank (length (remove '? (mapcar #'third matches)))) )
    (list rank prototype matches)))
			      

(defun match (interpretation protoparts)
  (cond 
   ((null interpretation) nil)
   (t (let* ( (word+concept (first interpretation))
	      (word (first word+concept))
	      (concept (second word+concept)) 
	      (match (or (find-if #'(lambda (protopart)
				      (isa protopart concept))
				  protoparts)
			 '?)) 
	      (specialized-concept (cond ((eq match '?) concept)
					 (t (delistify (immediate-classes match))))) )
	(cons (list word specialized-concept match) 
	      (match (rest interpretation) (remove match protoparts)))))))