;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Changes to BASIC-CHOOSE-VARIABLE-VALUES :print-item and
;;; :who-line-documentation-string to handle mouse doc on 
;;; continuation lines properly.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for TV version 6.3
;;; Written 05/16/89 12:31:33 by marky,
;;; while running on LIBRA from band LODA
;;; With SYSTEM 6.1, VIRTUAL-MEMORY 6.0, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.0, TV 6.2, DATALINK 6.0, CHAOSNET 6.0, GC 6.0, MEMORY-AUX 6.0, NVRAM 6.0,
;;;  SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0,
;;;  DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.0, SERIAL 6.0, PRINTER 6.0, MAC-PRINTER-TYPES 6.0, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.0, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.0, CLEH 6.0, IP 3.45,
;;;  Experimental BUG 11.4, Experimental CLX 6.0, Experimental CLUE 21.0, Experimental X11M 4.0,
;;;   microcode 428, Band Name: Rel 6.0 + SLE 5/15

;;; SPR 9676
#!C
; From file CHOICE.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; CHOICE.#"

;;; Had to modify this since MULTIPLE continuation lines were broke (term-Q menu)
;;; in that the mouse doc was not being displayed. The item had (list nil 'more-choices ...)
;;; in it when the code assumed it had (list <var> nil 'more-choices ...). This did
;;; not work on rel3 either. The reason is that ITEM has been set to the (cdr item)
;;; when STR is set - do not confuse ITEM with the contents of the array ITEMS - which
;;; DO have 'more-choices as the 3rd element, if there are any.

;; may 05/16/89 Fixed several bugs with continuation lines
(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :PRINT-ITEM) ;; MODIFIED 4/21/86 - KDB
           (ITEM LINE-NO ITEM-NO
		 &OPTIONAL (EXTRA-WIDTH 0) (TABLE-P NIL)
		 &AUX VAR STR FONTNO CHOICES PF RF K&A GPVF GVVF PVAL CVAL
		 (VSP (SEND SELF :VSP))
		 CONSTRAINT
		 (COMPLETE-ITEM ITEM))
  "Print a single item for choose-variable-values."
  (DECLARE (SPECIAL ITEM-VALUE-FOR-SET))
  LINE-NO ITEM-NO				;ignored
  (when cvv-debug
    (send si:cold-load-stream :line-out "Entering :print-item"))
  (IF (AND (CONSP ITEM) (CONSP (CAR ITEM)))
      (DO ((SUB-ITEM ITEM (CDR SUB-ITEM)))
	  ((NULL SUB-ITEM))
        ;; Call again to handle recursive definitions.
	(SEND SELF :PRINT-ITEM (FIRST SUB-ITEM) LINE-NO ITEM-NO EXTRA-WIDTH T))
      ;;ELSE
      ;; Parse ITEM into label string, font to print that in, variable, and keyword-&-arguments
      (PROGN
	(COND ((STRINGP ITEM)
               (SETQ STR ITEM
                     FONTNO 0))
              ((SYMBOLP ITEM)
               (SETQ VAR ITEM
                     STR (SYMBOL-NAME VAR)
                     FONTNO 1))
              (T
               (SETQ VAR (CAR ITEM)
                     STR (IF (OR (STRINGP (CADR ITEM)) (NUMBERP (CADR ITEM)) (NULL (CADR ITEM)))
			     ;; may 05/16/89 NOTE: the (null (cadr item) above will allow the next
			     ;; line to cdr the item so that 'MORE-CHOICES is the second not third item !
                             (CAR (SETQ ITEM (CDR ITEM))) 
                             (IF (SYMBOLP VAR)
                                 (SYMBOL-NAME VAR)
                                 NIL))
                     FONTNO 1
                     K&A (CDR ITEM))))
        ;; If any label string, print it and a colon.
	(COND (TABLE-P
               (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO))
               (SHEET-STRING-OUT SELF "  "))
              ((EQ (CAR K&A) 'MORE-CHOICES)
               ;; This is a continuation.  Print out some
               ;; space before these choices.
               (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO))
               (SHEET-STRING-OUT SELF "     "))
              (STR
               (MULTIPLE-VALUE-BIND (START-X START-Y)
                   (SEND SELF :READ-CURSORPOS)
                 (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO))
                 (SHEET-STRING-OUT SELF STR)
                 (IF VAR (SHEET-STRING-OUT SELF ": "))
		 (MULTIPLE-VALUE-BIND (NEW-X NEW-Y)
		     (SEND SELF :READ-CURSORPOS)
		   (WHEN (AND (FIXNUMP VALUE-TAB)
			      (< NEW-X (+ START-X VALUE-TAB)))
		     (MULTIPLE-VALUE-BIND (LEFT-MARGIN )
			 (SEND SELF :MARGINS)
		       (WHEN (AND VAR (< (1- (FONT-CHAR-WIDTH CURRENT-FONT))
                                         (- (+ START-X VALUE-TAB) NEW-X)))
			 ;;; ASH line-height... centers leader lines.
			 (SEND SELF :BITBLT (sheet-char-aluf self)(- (+ START-X VALUE-TAB) NEW-X) 2
			       12%-GRAY 0 0 (- NEW-X LEFT-MARGIN) (+ NEW-Y (ASH (- LINE-HEIGHT VSP 1) -1)))))
		     (SEND SELF :SET-CURSORPOS (+ START-X VALUE-TAB) START-Y))))))
	;; If any variable, get its value and decide how to print it.
	(WHEN VAR
	  ;; change ITEM-VALUE-FOR-SET to a binding instead of setq
	  ;; in choose-variable-values-choice :redisplay is called
	  ;; after an error to display an item that is not the
	  ;; current item; needless to say we don't want ITEM-VALUE-FOR-SET
	  ;; changed.  PMH7/26/87
	  (let ((ITEM-VALUE-FOR-SET (COND ((SYMBOLP VAR)
					   (SYMEVAL-IN-STACK-GROUP VAR STACK-GROUP))
					  (T (CAR VAR)))))
	    (MULTIPLE-VALUE-SETQ (PF RF CHOICES GPVF GVVF NIL NIL NIL NIL CONSTRAINT)
	      (SEND SELF :DECODE-VARIABLE-TYPE (OR K&A '(:SEXP))))
	    (COND ((NOT CHOICES)
		   (LET ((LABEL-WIDTH
			   (IF TABLE-P
			       (SEND SELF :STRING-LENGTH STR 0 NIL NIL (AREF FONT-MAP 0))
			       EXTRA-WIDTH)))
		     (SHEET-SET-FONT SELF (AREF FONT-MAP 2))
		     (SEND SELF :ITEM1
			   (CONS ITEM-VALUE-FOR-SET COMPLETE-ITEM) :VARIABLE-CHOICE
			   'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF
			   ITEM-VALUE-FOR-SET LABEL-WIDTH))
		   ;;testing for constraints was removed from here since errors
		   ;;couldn't be handled properly  PMH 7/25/87
		   )
		  (T
		   (when cvv-debug
		     (send si:cold-load-stream :line-out
			   (format nil "in :print-item, pf=~a, rf=~a, choices=~a"
				   pf rf choices)))
		   (LET (LAST-X
                         (CHOICES-LEFT CHOICES)
                         ;; We are changing the font inside of the DO loop, so we
                         ;; need to save it here.
                         (OLD-SHEET-FONT (SHEET-CURRENT-FONT SELF)))
                     ;; Print out the variable's value.
                     (CATCH 'LINE-OVERFLOW
                       (LOOP FOR CHOICE IN CHOICES-LEFT
                             DO (PROGN 
                                  (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE)
                                        CVAL (IF GVVF (FUNCALL GVVF CHOICE) CHOICE))
                                  (SHEET-SET-FONT
                                    SELF (AREF FONT-MAP (IF (EQUAL CVAL ITEM-VALUE-FOR-SET) 4 3)))
                                  (SETQ LAST-X CURSOR-X)
                                  (SEND SELF :ITEM1 (CONS CHOICE COMPLETE-ITEM) :VARIABLE-CHOICE
                                        'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF PVAL)
                                  (SEND SELF :TYO #\SPACE)
                                  ;; Pop one off after we have successfully processed a choice.
                                  (POP CHOICES-LEFT))
                             ))
                     ;; Restore the font to its original value.
                     (SHEET-SET-FONT SELF OLD-SHEET-FONT)
                     ;; If this is a continuation line and not even one choice fits,
                     ;; leave that gigantic choice name on this line.
                     (WHEN (AND (EQ CHOICES-LEFT CHOICES) (EQ (second ITEM) 'MORE-CHOICES)) ;; may 05/16/89 
                       (SETQ LAST-X CURSOR-X)
                       (POP CHOICES-LEFT))
                     ;; If choices don't fit on line, push some into following line.
                     (WHEN CHOICES-LEFT
                       (SHEET-SET-CURSORPOS SELF (- LAST-X LEFT-MARGIN-SIZE)
                                            (- CURSOR-Y TOP-MARGIN-SIZE))
                       (SHEET-CLEAR-EOL SELF)
                       (LET* ((NO-ITEMS (ARRAY-LEADER ITEMS 0))
                              (NEXT-ITEM
                                (IF (> NO-ITEMS (1+ ITEM-NO))
                                    (AREF ITEMS (1+ ITEM-NO)))))
                         ;; See if we ALREADY made a continuation item for this one.
                         (UNLESS (AND (CONSP NEXT-ITEM)
                                      (EQ (THIRD NEXT-ITEM) 'MORE-CHOICES)) 
                           ;; If not, make one, and put into it
                           ;; all the choices we could not fit on this line.
                           (VECTOR-PUSH-EXTEND NIL ITEMS)
                           (DO ((I 1 (1+ I))
                                (LIM (- NO-ITEMS ITEM-NO)))
                               ((= I LIM))
                             ;; Bubble items up <- I think this is really DOWN     ;; may 05/16/89 
                             (SETF (AREF ITEMS (1+ (- NO-ITEMS I))) (AREF ITEMS (- NO-ITEMS I))))
                           (SETF (AREF ITEMS (1+ ITEM-NO))
                                 (LIST VAR () 'MORE-CHOICES
                                       (IF (EQ (second ITEM) 'MORE-CHOICES) ;; may 05/16/89 was third
                                           (third ITEM) 		    ;; may 05/16/89 was second
					   ITEM)
                                       CHOICES-LEFT PF GPVF GVVF)))))
                     (WHEN EXTRA-WIDTH
                       (DOTIMES (I EXTRA-WIDTH) (SEND SELF :TYO #\SPACE))))))))))
  (when cvv-debug
    (send si:cold-load-stream :line-out "Leaving :print-item"))
  )

;; This was changed incorrectly in patch 4.116 - it is NOT part of a margin region
;; choice box descriptor ( as I thought before ).  This makes a continuation line item
;; return the value chosen (correct) instead of the entire item in a list (incorrect)

(DEFUN (:PROPERTY MORE-CHOICES CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (KWD-AND-ARGS)
  (VALUES (FOURTH KWD-AND-ARGS) NIL (THIRD KWD-AND-ARGS)
          (FIFTH KWD-AND-ARGS) (SIXTH KWD-AND-ARGS)))

;; Added who-line doc functionality on continuation lines - it
;; apparently never worked before.

(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :WHO-LINE-DOCUMENTATION-STRING) ()
  (MULTIPLE-VALUE-BIND (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
      (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET)
    (LET ((X (- MOUSE-X WINDOW-X-OFFSET))
	  (Y (- MOUSE-Y WINDOW-Y-OFFSET)))
      (MULTIPLE-VALUE-BIND (VALUE TYPE) (SEND SELF :MOUSE-SENSITIVE-ITEM X Y)
	(IF TYPE
	    (LET ((ITEM (AREF ITEMS (+ TOP-ITEM (TRUNCATE (- Y (SHEET-INSIDE-TOP))
                                                          LINE-HEIGHT)))))
		  ;; If we have a table, get the column of the table that
		  ;; the value part identifies and make that the item here.
	      (IF (AND (CONSP ITEM) (CONSP (CAR ITEM)))
		  (SETQ ITEM (ASSOC (SECOND VALUE) ITEM :TEST #'EQUAL)))
	      (IF (ATOM ITEM) '(:MOUSE-L-1 "input a new value from the keyboard"
                                :MOUSE-R-1 "edit this value")
		  ;;ELSE
		  (PROGN
		    (SETQ ITEM (CDR ITEM))
		    (AND (OR (STRINGP (CAR ITEM)) (NULL (CAR ITEM)))
                         (SETQ ITEM (CDR ITEM)))
		    ;; may 05/16/89 extract doc string from 'MORE-CHOICES
		    ;; This functionality seems to never have been implemented before.
		    (and (eq (car item) 'more-choices)
			 (setq item (cdadr item)))
		    ;; may 05/16/89 end patch
		    (MULTIPLE-VALUE-BIND (IGNORE RF IGNORE IGNORE IGNORE DOC)
                        (SEND SELF :DECODE-VARIABLE-TYPE (OR ITEM '(:SEXP)))
		      (COND ((STRINGP DOC) DOC)
                            ((CONSP   DOC) DOC)
                            ((AND     DOC (FUNCALL DOC VALUE)))
                            ((NULL RF) '(:MOUSE-L-1 "change to this value"
                                         :MOUSE-R-1 "edit this value"))
                            (T '(:MOUSE-L-1 "input a new value from the keyboard"
                                 :MOUSE-R-1 "edit this value")))))))
	    ;;ELSE
	    (PROGN
	      (MULTIPLE-VALUE-SETQ (VALUE TYPE) (MOUSE-SENSITIVE-ITEM X Y))
	      (IF (AND VALUE (SYMBOLP (SECOND VALUE)))
                  (DOCUMENTATION (SECOND VALUE))
                  ;;ELSE
		  DEFAULT-WHO-LINE-DOCUMENTATION)))))))
))