(in-package "KPML-I")

;;; File: user-response-frame.lisp
;;; This nasty stuff isolated here...
;;; KPML 3.0. Broken out of misc-extra-frames.lisp
;;;    an ACL5.0 PC compatible version also folded in.
;;; ----------------------------------------------------------------------
;;; A specialized option frame... The following is a rather hacky
;;; (I think) way around the problem that the accepting-values previously
;;; used causes all mouse-sensitivity in other windows to be lost
;;; until the selection is made. This is precisely what we do not
;;; want in many cases. Just have to make sure here that the
;;; command-tables for the desired commands are in the command table
;;; specification here, otherwise they are not accessible.
;;; ----------------------------------------------------------------------

(defvar *yes-no-frame* nil)
(defvar *yes-no-response* nil)

;;; ----------------------------------------------------------------------
;;; The frame def...
;;;
;;; 0.9.16 improvement of the yes-no-question kpml dialog box...
;;; ----------------------------------------------------------------------

(clim:define-application-frame 
 USER-RESPONSE-FRAME ()
 ((question :initform nil))
 (:menu-bar NIL)
 (:top-level (clim:default-frame-top-level))
 (:command-table 
  (user-response-commands
   :inherit-from (kpml-resource-inspector kpml-resource-development)))
  (:panes 
   (question :application
	     :display-function 'user-question-display)
   (dialog :command-menu))
  (:layouts
   (first (clim:vertically () 
	    (:fill question) 
	    (#-lispworks 50 #+lispworks 1/4 dialog)))))

;;; ----------------------------------------------------------------------
;;; Since more context now given for the query, make the
;;; display method properly print the text it has...
;;; 0.9.16
;;; ----------------------------------------------------------------------

(defmethod USER-QUESTION-DISPLAY ((frame user-response-frame) stream)
  (clim:window-clear stream)
  (when (slot-value frame 'question)
    (kpml-i-terpri stream)
    (clim:filling-output 
	(stream :fill-width 
		(clim:bounding-rectangle-width (clim:window-viewport stream)))
      (format stream "~%~{~A~}" (slot-value frame 'question)))))

;;; ----------------------------------------------------------------------
;;; The startups...
;;; a.  the first is for Lispworks and ACL5.0-Unix and previous ACLs where
;;;     the frame def and the process can be spread out as they fall...
;;; b.  the second is for ACL5.0-PC with its special solutions for MS
;;;     threads...
;;; ----------------------------------------------------------------------

#-ms-osthreads
(defun STARTUP-USER-RESPONSE-FRAME (&optional (question nil))
  #+allegro   (tpl:setq-default *yes-no-response* nil)
  #+acl3.0    (setf *yes-no-response* nil)
  #+lispworks (setf *yes-no-response* nil)
  (setf *yes-no-frame*
	(clim:make-application-frame
	 'user-response-frame
	 :pretty-name "User Decision: yes or no?"
	 :left 100 :top 20
	 :width 450 :height (if (and
				 (consp question)
				 (string= (first question) ""))
				100 250)))
  (setf (slot-value *yes-no-frame* 'question) 
        (if (consp question) question (list question)))
  (process-run-function "KPML YES-NO DIALOG" #'clim:run-frame-top-level 
			   *yes-no-frame*)

  ;; 0.9.25 added acl4.3 compatibility...
  ;; 1.1 added minimal ACL-PC3.0.2 compatibility...
  ;; 2.0 have to consider harlequin too... 
  ;;     (need to get to outermost stackframe?)
  ;;     note that without the sleep, no other processes get a lookin
  ;;     under Lispworks...
  ;; 2.1 ranged conditions added...
  #-acl3.0(loop 
	      until #+(and :excl :allegro)
		    (:version-case 
		     (":ALLEGRO-V")
		     ((- "4.3")
		      (mp::global-symbol-value *yes-no-response*))
		     (t 
		      (sys::global-symbol-value *yes-no-response*)))
		    #+(or lispworks acl3.0) 
		    *yes-no-response*
              do #+lispworks (sleep 2) #-lispworks (progn nil))
  *yes-no-response*)

#+ms-osthreads
(defun STARTUP-USER-RESPONSE-FRAME (&optional (question nil))
  (tpl:setq-default *yes-no-response* nil)
  (setf *yes-no-frame*
	(clim:make-application-frame
	    'user-response-frame
	  :pretty-name "User Decision: yes or no?"
	  :left 100 :top 20
	  :width 450 :height (if (and
				  (consp question)
				  (string= (first question) ""))
				 100 250)))
  (setf (slot-value *yes-no-frame* 'question) 
        (if (consp question) question (list question)))
  (process-run-function "KPML YES-NO DIALOG" #'clim:run-frame-top-level 
                        *yes-no-frame*)
  (loop until (sys::global-symbol-value *yes-no-response*))
  *yes-no-response*)

;;; ----------------------------------------------------------------------
;;; The commands for activating the various answers...
;;; ----------------------------------------------------------------------

(define-user-response-frame-command
    (com-ABORT-GENERATION-UR :name "Abort Generation" :menu T)
    ()
    #+allegro   (tpl:setq-default *yes-no-response* :abort)
    #+acl3.0    (setf *yes-no-response* :abort)
    #+lispworks (setf *yes-no-response* :abort)
    (clim:frame-exit clim:*application-frame*))

(define-user-response-frame-command
  (com-YES :menu T)
  ()
  #+allegro  (tpl:setq-default *yes-no-response* :yes)
  #+acl3.0   (setf *yes-no-response* :yes)
  #+lispworks(setf *yes-no-response* :yes)
  (clim:frame-exit clim:*application-frame*))

(define-user-response-frame-command
  (com-NO :menu T)
  ()
  #+allegro(tpl:setq-default *yes-no-response* :no)
  #+acl3.0(setf *yes-no-response* :no)
  #+lispworks(setf *yes-no-response* :no)
  (clim:frame-exit clim:*application-frame*))

(define-user-response-frame-command
  (com-MODES :menu T)
  ()
  (run-modes))

(define-user-response-frame-command
  (com-RESET-MODES :menu T)
  ()
  (kpml::reset-tracing-levels))

