;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: scenario.lsp
;;;;    System: FIRE qp-source
;;;;   Version: 1.0
;;;;    Author: Jin Yan
;;;;   Created: March 5, 2003 12:23:11
;;;;   Purpose: Defining GIZMO scenario
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Thursday, March 6, 2003 at 22:10:14 by Jin Yan
;;;; ---------------------------------------------------------------------------

(in-package :fire)

(defun get-scenario (scenario-term source &key (refresh nil))
  (create-scenario scenario-term source))
    
;; For debugging
(defun clear-scenario-cache (source) (setf (scenarios source) nil))

(defmethod create-scenario ((sc-spec list) (source qp-source))
  (let ((sc-form
         (gather-sc-facts (car sc-spec) (cdr sc-spec) source)))
    (gizmo::process-embedded-language-form (->data sc-form) gizmo::*gizmo-modeling-language-table*)
    (push gizmo::*scenario* (scenarios source))
    gizmo::*scenario*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
;;; gather-sc-facts carries out dynamic case construction.
;;; For each case function, define a method that handles it appropriately.

(defgeneric gather-sc-facts (type specs source)
  (:documentation "Returns list of facts from the KB that go into making the 
      case for the SPECS using filter-type TYPE"))

;;;(defmethod gather-sc-facts ((type (eql 'data::explicit-case-fn))
;;;                                  (specs list)
;;;                                  (source qp-source))
;;;  (gather-explicit-case-scenario (car specs) source))
;;;
;;;(defmethod gather-sc-facts ((type (eql 'data::explicitCaseFn))
;;;                                  (specs list)
;;;                                  (source qp-source))
;;;  (gather-explicit-case-scenario (car specs) source))
;;;
;;;(defun gather-explicit-case-scenario (case-name source)
;;;  ;; (explicit-case-fn <case name>)
;;;  ;; (explicitCaseFn <case name>)
;;;  (ask (make-case-fact case-name '?fact)
;;;       (reasoner source)
;;;       :any ;; context
;;;       :all ;; number
;;;       '?fact ;; just the facts, ma'm
;;;       :lookup))

;;; Some general dynamic case construction methods 

(defmethod gather-sc-facts ((type (eql 'data::minimal-case-fn))
                                  (specs list)
                                  (source qp-source))
  (gather-minimal-case-scenario (car specs) source))

(defmethod gather-sc-facts ((type (eql 'data::minimalCaseFn))
                                  (specs list)
                                  (source qp-source))
  (gather-minimal-case-scenario (car specs) source))

(defun gather-minimal-case-scenario (concept source)
  (let ((mentioning-facts (extract-sc-facts concept)))
    mentioning-facts))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extracting informations
;;; (DEFSCENARIO :INITIALLY :DOCUMENTATION :INDIVIDUALS :THROUGHOUT)

(defun extract-sc-facts (sc-name)
  (let ((fragments (cdadar (ask-it (->data `(evaluate ?sf (TheSetOf ?f (scenFragment ,sc-name ?f)))))))
        (individuals (cdadar (ask-it (->data `(evaluate ?if (TheSetOf ?i (scenIndividual ,sc-name ?i)))))))
        (throughouts (cdadar (ask-it (->data `(evaluate ?tf (TheSetOf ?t (scenThroughOut ,sc-name ?t)))))))
        (documentation (caddar (ask-it (->data `(comment ,sc-name ?c))))))
    (setf fragments (extract-fragment-relevant-facts fragments)
      individuals (extract-individual-relevant-facts individuals)
      throughouts (fire->gizmo throughouts))
    (setup-sc-facts sc-name fragments individuals throughouts documentation)))
      
(defun setup-sc-facts (sc-name fragments individuals throughouts documentation)
  (append (list 'data::defscenario sc-name)
          (when documentation
            (list ':documentation documentation))
          (when fragments 
            (list ':fragments fragments))
          (when individuals
            (list ':individuals individuals))
          (when throughouts
            (list ':throughout throughouts))))

(defun extract-fragment-relevant-facts (fragments &aux type bindings)
  (mapcar #'(lambda (fragment)
              (setf type (cddar (ask-it (->data `(scenFragmentType ,fragment ?t))))
                bindings (cdadar 
                          (ask-it (->data `(evaluate ?bf (TheSetOf ?b (scenFragmentBinding ,fragment ?b)))))))
              (setup-sc-fragment fragment type bindings))
    fragments))

(defun setup-sc-fragment (fragment type bindings)
  (setf bindings (fire->gizmo bindings))
  (append (list fragment) 
          (when type
            (list ':type (car type)))
          (when bindings
            (list ':bindings bindings))))

(defun extract-individual-relevant-facts (ind-terms &aux type)
  (mapcar #'(lambda (ind-term)
              (setf type (cddar (ask-it (->data `(scenIndividualType ,ind-term ?t)))))
              (setup-sc-ind-type ind-term type))
    ind-terms))
          
(defun setup-sc-ind-type (ind-term type)
  (list ind-term ':type (car type)))