;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB)Ï1; Ï*Patch-file:T -*-

;Ï1;;                     RESTRICTED RIGHTS LEGEND          Ï*
;Ï1;; Use, duplication, or disclosure by the Government is subject toÏ*
;Ï1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights inÏ*
;Ï1;; Technical Data and Computer Software clause at 52.227-7013.Ï*
;Ï1;;                   TEXAS INSTRUMENTS INCORPORATED.Ï*
;Ï1;;                            P.O. BOX 149149Ï*
;Ï1;;                         AUSTIN, TEXAS 78714-9149Ï*
;Ï1;;                             MS 2151Ï*
;Ï1;; Copyright (C) 1986,1987,1988, 1989 Texas Instruments Incorporated. All rights reserved.Ï*


;Ï1 TAC 07-25-89 - pulled these functions from WINDOW-SYSTEM-ADDITIONSÏ*

(DEFUN Ï4clean-up-choicesÏ* (margin-choices)
"Ï2Taken from the body of choose-variable-values.Ï*"
  (MAPCAR #'(lambda (x)
	      (LIST (IF (ATOM x) x (CAR x)) nil
		    'choose-variable-values-choice-box-handler
		    nil nil (IF (ATOM x) nil (CADR x))))
	  margin-choices))

(DEFUN Ï4just-call-windowÏ* (window-location superior near-mode margin-choices osw)
"Ï2Taken from the body of choose-variable-values.Ï*"
  (LET ((window (SYMBOL-VALUE window-location))
	(processed-message nil)
	(margin-choices (clean-up-choices margin-choices)))
       (LET ((current-window
	       (IF (SEND superior :operation-handled-p
			 :set-selection-substitute)
		   superior
		   (OR osw mouse-sheet)))
	     (old-substitute (SEND superior :selection-substitute)))
	 (UNWIND-PROTECT
	     (PROGN
	       (CLEAR-INPUT window)
	       (delaying-screen-management
		 (expose-window-near window near-mode)
		 (SEND window :select)  
		 (SEND current-window :send-if-handles
		       :set-selection-substitute window))
	       (DO () (nil)
		 ;Ï1; wait for something from the keyboard.Ï*
		 (LET ((kbd-intercepted-characters
			 choose-variable-values-intercepted-characters))
		   (PROCESS-WAIT "Ï3ChooseÏ*" #'LISTEN window)
		   (AND (SETQ processed-message
			      (choose-variable-values-process-message
				window (read-any window)))
			(RETURN)))))
	   (delaying-screen-management
	     (SEND window :deactivate)
	     (SEND current-window :send-if-handles
		   :set-selection-substitute old-substitute)
	     (AND osw (SEND osw :select nil))))
	 (IF (EQ processed-message 'exit)
	     (execute-margin-choice margin-choices
	       w::margin-choice-completion-string
	       #'IGNORE)
	     ;Ï1;elseÏ*
	     (IF (EQ processed-message 'abort)
		 (execute-margin-choice
		   margin-choices
		   w::margin-choice-abort-string
		   #'(lambda ()
		       (SIGNAL-CONDITION eh:*abort-object*))))))))

(DEFMACRO Ï4maybe-ephemeral-cvv-menuÏ*
	  (variables &key
	   (permanent t)
	   (FUNCTION nil)
	   (near-mode ''(:mouse))
	   (label "Ï3Choose Variable ValuesÏ*")
	   (width nil)
	   (extra-width 10.)
	   (height nil)
	   (margin-choices nil)
	   (superior nil)
	   (reverse-video-p nil)
	   (value-tab t)
	   (force-permanent nil)
	   (selected-io nil)
	   (foreground-color *default-menu-foreground*)
	   (background-color *default-menu-background*)
	   (label-color      *default-menu-label-foreground*)
	   (label-background *default-menu-label-background*))
"Ï2Just like choose-variable-values, only has a :Permanent arg.  If this is true
 then it organises things so that the cvv menu is only consed once.Ï*"
  (IF permanent
     `(LET ((window-location ',(PROG1 (GENSYM "Ï3CVV-WINDOW-Ï*" t) (GENSYM "Ï3GÏ*")))
	    (the-superior ,superior)
	    (near-mode ,near-mode)
	    (margin-choices ,margin-choices)
	    (old-allocate #'ALLOCATE-RESOURCE)
	    (old-deallocate #'DEALLOCATE-RESOURCE))
	   (IF (BOUNDP window-location)
	       (LET ((osw selected-window))
		    (just-call-window window-location the-superior near-mode
				      margin-choices osw))
	       (letf ((#'ALLOCATE-RESOURCE
		       #'(lambda (.name. &rest args)
			   (IF (EQUAL .name.
				   'tv:temporary-choose-variable-values-window)
			       (PROGN (SETF (SYMBOL-VALUE window-location)
					    (make-window
					      'temporary-choose-variable-values-window
					      :superior
					      (OR (FIRST args)
						  tv:default-screen)
					      :edges-from
					      (LIST
						(sheet-inside-left
						  default-screen)
						(sheet-inside-top
						  default-screen)
						(sheet-inside-right
						  default-screen)
						(sheet-inside-bottom
						  default-screen))
					      :foreground-color
					      *default-menu-foreground*
					      :background-color
					      *default-menu-background*))
				      (SYMBOL-VALUE window-location))
			       (APPLY old-allocate .name. args))))
		      (#'DEALLOCATE-RESOURCE
		       #'(lambda (.name. &rest args)
			   (IF (EQUAL .name.
				   'tv:temporary-choose-variable-values-window)
			       nil
			       (APPLY old-deallocate .name. args)))))
		     (choose-variable-values
		       ,variables
		       :function ,function
		       :label ,label
		       :width ,width
		       :superior the-superior
		       :near-mode ,near-mode
		       :margin-choices ,margin-choices
		       :extra-width ,extra-width
		       :height ,height
		       :reverse-video-p ,reverse-video-p
		       :value-tab ,value-tab
		       :force-permanent t;Ï1,force-permanentÏ*
		       :selected-io ,selected-io
		       :foreground-color ,foreground-color
		       :background-color ,background-color
		       :label-color ,label-color
		       :label-background ,label-background))))

     `(choose-variable-values
	,variables
	:function ,function
	:label ,label
	:width ,width
	:superior ,superior
	:near-mode ,near-mode
	:margin-choices ,margin-choices
	:extra-width ,extra-width
	:height ,height
	:reverse-video-p ,reverse-video-p
	:value-tab ,value-tab
	:force-permanent ,force-permanent
	:selected-io ,selected-io
	:foreground-color ,foreground-color
	:background-color ,background-color
	:label-color ,label-color
	:label-background ,label-background)))

(DEFUN Ï4process-variable-values-itemsÏ* (an-item)
"Ï2This function is called by the choose variable values macros.  It is passed
 an item that the user wants to go into the menu.  The item is one of two
 things.  Either it is a list which has the structure (expression .rest), where
 the expression denotes the initial value/location of the initial value for the
 menu and the rest has an optional string, a keyword and optional arguments. 
 These are defined in the windows manual for choose variable values menus.  The
 other option is for the item to be a string.  This causes a separator to be
 produced in the menu.  This function returns a list, which has six elements
 and can be of two forms.  If the item that this function is passed is not a
 list ie. it is a string then
 (:Throw-Away :Throw-Away :Throw-Away :Throw-Away item :Throw-Away) is
 returned.  This causes the calling macro to throw everything away except the
 string.  If the item is a list then the six items that are returned are as
 follows:-  The first and second are generated symbols.  These will be declared
 special in the macro that calls this function so that Choose-variable-values
 can change its value and so that a special variable holds onto the initial
 value so that the quit option can be Evaled correctly.  Why the code in this
 choice box has to be interpretted I do not know but it's ridiculous in my
 opinion.  The third and fourth are lists denoting Setfs to the generated
 symbols of the initial value passed on by the user.  This will be displayed
 as the initial value by the menu.  The fourth is used as a reinitialisation
 clause in the quit option.  The Fifth is a list that actually goes into the
 argument list of choose variable values.  It specifies the generated symbol as
 the destination for the value returned by the user.  The Sixth value is a
 list denoting a Setf, which reassigns the value returned by the menu to the
 initial expression provided by the user.  This is only used in the side effect
 causing cases such as Assign-Using-Menu.Ï*"
    (IF (CONSP an-item)
	(LET ((temporary-name-1 (GENSYM))
	      (temporary-name-2 (GENSYM)))
	     (LIST temporary-name-1
		   temporary-name-2
	           (LIST 'SETF temporary-name-2 (FIRST an-item))
	           (LIST 'SETF temporary-name-1 temporary-name-2)
	           (CONS 'LIST
			 (CONS (LIST 'QUOTE temporary-name-1)
			       (IF (STRINGP (SECOND an-item))
			           (CONS (SECOND an-item)
				         (REST (REST an-item)))			           
			           (REST an-item))))
	           (LIST 'SETF (FIRST an-item) temporary-name-1)))
	(LIST :throw-away :throw-away :throw-away
	      :throw-away an-item     :throw-away)))

(DEFUN Ï4defaultise-choose-variable-values-keywordsÏ* (keywords)
"Ï2Gives a useful set of defaults for the CVV keywords.Ï*"
  (LET ((selected-io-to-add (IF (MEMBER :selected-io keywords)
				nil
				#+ti '(:selected-io nil)
				#+symbolics nil))
	(superior-to-add (IF (MEMBER :superior keywords)
			     nil
			     #+ti '(:superior tv:main-screen)
			     #+symbolics nil)))
       (APPEND selected-io-to-add superior-to-add keywords)))

(DEFMACRO Ï4assign-using-menuÏ* (items &rest keywords)
"This is a macro that parcels up a call to Choose-Variable-Values so that the
 user does not have to worry about defining any Special symbols to hold the
 values used by the menu.  It takes a menu specification like
 tv:choose-variable-values ie. a list of items &rest option keywords.  Calling
 this construct has the side effect of assigning the chosen values back to the
 items that as the specifications for the initial values, ie. the heads of the
 items within the item list.  The item list should not be quoted. This is done
 by mapping the user's arguments into the following code :-
    (Assign-using-Menu ((Item-one \"Item One\" :Expression)
			'A separator'
			(Item-two \"Item Two\" :String))
		       :Label \"A Name\")

==>

   (Funcall #'(Lambda ()
		(Declare (Special #Genedsym1 #Genedsym1-2
				  #Genedsym2 #Genedsym2-2
			 )
		)
	        (Setf #Genedsym1-2 Item-one)
	        (Setf #Genedsym1 #Genedsym1-2)
	        (Setf #Genedsym2-2 Item-two)
	        (Setf #Genedsym2 #Genedsym2-2)
		(tv:maybe-ephemeral-cvv-menu
		    (List (List '#Genedsym1 \"Item One\" :Expression)
			  'A separator'
			  (List '#Genedsym2 \"Item Two\" :String))
		    :Margin-Choices
			'((\"Abort []\"
			   '(Progn (Setf #Genedsym1 #Genedsym1-2)
				   (Setf #Genedsym2 #Genedsym2-2)))
                          \"Do it []\")			
		    :Label \"A Name\")
	        (Setf Item-one #Genedsym1)
	        (Setf Item-two #Genedsym2)))"

  (LET ((processed-items (MAPCAR #'process-variable-values-items items)))
     `(FUNCALL ;Ï1; Call the automatically generated closure.Ï*
	#'(lambda() ;Ï1; Define a closure in which to put the special variablesÏ*
	 (DECLARE (SPECIAL ;Ï1; Construct a special declaration for theÏ*
			   ;Ï1; generated symbols.Ï*
		     ,@(REMOVE :throw-away ;Ï1; Throw away values for separatorsÏ*
				(MAPCAR #'(lambda (an-item) (FIRST an-item))
				        processed-items))
		     ,@(REMOVE :throw-away ;Ï1; Throw away values for separatorsÏ*
				(MAPCAR #'(lambda (an-item) (SECOND an-item))
				        processed-items))))
	 ;Ï1; Construct a set of initialisation SetfsÏ*
	 ,@(REMOVE :throw-away ;Ï1; Throw away values for separatorsÏ*
		  (MAPCAR #'(lambda (an-item) (THIRD  an-item)) processed-items))
	 ,@(REMOVE :throw-away ;Ï1; Throw away values for separatorsÏ*
		  (MAPCAR #'(lambda (an-item) (FOURTH an-item)) processed-items))
	 ;Ï1; Get the user to choose from the menu.Ï*
	 (CATCH :abort-menu
	   (maybe-ephemeral-cvv-menu
	    ,(CONS 'LIST
		   (MAPCAR #'(lambda (an-item) (FIFTH an-item)) processed-items))
	    :margin-choices
		(LIST (LIST "Ï3Abort [Ï*Ï3]Ï*"
			    '(PROGN ;Ï1; Reset the values of the #1 symbols.Ï*
				,@(REMOVE :throw-away
		  			(MAPCAR #'(lambda (an-item)
					                (FOURTH an-item))
					    	processed-items))
				   (THROW :abort-menu nil)))
		      "Ï3Do it [Ï*Ï3]Ï*")
	    ,@(defaultise-choose-variable-values-keywords keywords)))
	 ;Ï1; Construct a set of terminating SetfsÏ*
	 ,@(REMOVE :throw-away ;Ï1; Throw away values for separatorsÏ*
	  	  (MAPCAR #'(lambda (an-item) (SIXTH an-item)) processed-items))))))

(EXPORT 'assign-using-menu 'tv)