(in-package "KPML")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; For compatibility with ML-environment, all references to the list
;;; systems replaced by (list-systems). John:IPSI:Nov94
;;;
;;; Selection setting also added below, for which, selection by region added 
;;; in some cases...
;;;
;;; 3.1 Bremen, March 2000: cleared of clisp.
;;; 4.0 Bremen, June 2002: some more explicit user messages
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun SET-SELECTOR (system selector)
  "Sets the selector for system to selector.
    Possible selectors are select-manual, choice-master, select-last, select-once, select-random"
  (setf (fetch-system-selector-associations system) selector))

(defun SET-ALL-SELECTORS (selector)
  "Sets all selectors for all systems to selector.
   Possible selectors are  select-manual, choicemaster, select-last, select-once, select-random"
  (loop for x in (list-systems) do (set-selector x selector))
  t)

(defun REVERT-ALL-SELECTORS ()
  "Forces the selector for all systems to be nil, forcing the use of the default-selector"
  (clrhash system-selector-associations)
  t)


(defun SELECT-MANUAL (Options &optional (Preselection nil))
  ;; KPML4
  ;;   The information given back to the user was always absolutely
  ;;   minimal in Penman because it was always assumed that one
  ;;   was in any case following the generation step-by-step in
  ;;   other windows. Nowadays this is often not the case, so we
  ;;   we pack in more relevant information...
  ;;   
  ;;   Also cleared up a bit with more modern Lisp idioms.
  ;;
  (if preselection
      (Select-Preselected Options Preselection)
    (let ((Features (loop for s in Options collect (Second s)))
	  (info-message (generate-generation-context-message))
	  )
		       
      (if (Eql 1 (LENGTH Options))
	  (CDAR Options)
	(let ((user-choice (askwindow :choice info-message features )))
	  (cdr 
	   (loop for opt in options 
		 when (equal (second opt) user-choice)
		 return opt)))))))

  ;; 
  ;; Adds more information to the traversal requests for user
  ;; interaction...
  ;; (4.0)
  ;;
(defun GENERATE-GENERATION-CONTEXT-MESSAGE 
  (&optional (tail "Select a feature... "))
  (if message-sender 
      (format nil "  Generation is considering ~%     the constituent at the bottom of the ~%     path: ~{~%~20T~A~} ~2%  and is in or has just finished with ~%      the grammatical system ~A ~2% ~A" 
	      (cons
	       *structure-graph-top-node*
	       (cdr (reverse alias-function-stack)))
	       message-sender tail)
    tail))



(DEFUN Specify-Chooser (Sys)
  (PROG ((Chooser-Name  (intern (format nil "~aCHOOSER" sys))))
	(unless (askwindow :yes-or-no (format nil "Is the name '~a correct? " chooser-name))
	  (when (setq chooser-name (intern (symbol-name (askwindow :value "Enter name of chooser: "))))
	    (cond
	      ((gethash Chooser-Name choosers)
	       (printwindow :display-pane
			    (indent-and-fill
			      (format nil  "Associating existing Chooser ~a with the System ~a." Chooser-Name Sys )))
	       (Set-Chooser Sys Chooser-Name))
	      (T
	       (printwindow :display-pane
			    (indent-and-fill
			      (format nil "Associating previously nonexistent Chooser ~a with the system ~a. Be sure to define ~a." chooser-name sys chooser-name)))
	       
		 (Set-Chooser Sys Chooser-Name)
		 ))))
	(RETURN Chooser-Name)))

(defun set-chooser (system chooser)
  (unless (equal chooser
		 (fetch-system-chooser system))
    (setf (fetch-system-chooser system) chooser)))

(DEFUN Select-Last (Output-Expression Preselection)
  (cond
    (Preselection (Select-Preselected Output-Expression Preselection))
    (T (PROG ((Old-Feature (fetch-System-Old-Feature Message-Sender)))
	     (RETURN (cond
		       (Old-Feature 
			(CDR (loop for c in Output-Expression 
				   when (Eq (Second c) Old-Feature)
				   return c)))
		       (T (PROGN 
			   (warning 
			    T  "While using selector SELECT-LAST, no old feature to use!!" )
			   (Select-Manual Output-Expression Preselection)))))))))

(DEFUN Select-Once (Outputs Preselection)
  (cond
    (Preselection (Select-Preselected Outputs Preselection))
    (T (PROG ((Selection-Was (Select-Manual Outputs Preselection)))
	     (set-selector Message-Sender 'Select-Last)
	     (RETURN Selection-Was)))))

(DEFUN Select-Random (Majors Preselection)
  "this implementation does not use probabilities"
  (if preselection
      (select-preselected majors preselection)
      (random-choice-with-probability majors)))

(defun random-choice-with-probability (majors)
  (let ((sum 0.0)
	(threshold (random 1.0)))
    (dolist (x majors)
      (setq sum (+ sum (car x)))
      (when (>= sum threshold)
	(return-from random-choice-with-probability (cdr x))))))





;;;--------------------------------------------------------------------------------
;;; Now the functions for setting selector options, moved here (John:Nov94) from
;;; the not particularly logical sgdisplay.lisp.
;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Change mode of some object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Systems
(defun set-selector-mode-manual (&optional system)
  (if system
      (set-selector system 'select-manual)
      (set-all-selectors 'select-manual)))
(defun set-selector-mode-choosers (&optional system)
  (if system
      (set-selector system 'choice-master)
      (set-all-selectors  'choice-master)))
(defun set-selector-mode-last (&optional system)
  (if system
      (set-selector system 'select-last)
      (set-all-selectors  'select-last)))
(defun set-selector-mode-once (&optional system)
  (if system
      (set-selector system 'select-once)
      (set-all-selectors  'select-once)))
(defun set-selector-mode-random (&optional system)
  (if system
      (set-selector system 'select-random)
      (set-all-selectors  'select-random)))

(defun SET-REGION-SELECTION-MANUAL (region)
  (dolist (system (systems-of-region region))
	  (set-selector-mode-manual system)))

(defun SET-REGION-SELECTION-CHOOSERS (region)
  (dolist (system (systems-of-region region))
	  (set-selector-mode-choosers system)))




;;; John: IPSI: April 94; added following as a general indication
;;;             of what kind of use of the resources is in progress...
(defvar *GENERAL-INQUIRY-MODE* nil)

(DEFUN set-inquiry-mode-manual (&optional inquiries)
  (set-inquiry-mode inquiries 'manual))

(DEFUN set-inquiry-mode-deimplemented (&optional inquiries)
  (setf *general-inquiry-mode* 'deimplemented)
  (set-inquiry-mode inquiries 'deimplemented))

(DEFUN set-inquiry-mode-implemented (&optional inquiries)
  (setf *general-inquiry-mode* 'implemented)
  (set-inquiry-mode inquiries 'implemented))

(DEFUN set-inquiry-mode-random (&optional inquiries)
  (set-inquiry-mode inquiries 'random))

(DEFUN set-inquiry-mode-default (&optional inquiries)
  (set-inquiry-mode inquiries 'default))

(DEFUN set-inquiry-mode-unspecified (&optional inquiries)
  (set-inquiry-mode inquiries 'nil))

