;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Change to mouse-confirm to allow NIL for WINDOW-MAX-WIDTH as advertised. ;;; 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. ;;; Written 01/17/90 14:00:37 by MARKY, ;;; while running on LIBRA from band LODB ;;; With SYSTEM 6.23, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.6, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.3, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.56, ;;; Experimental CLX 6.7, CLUE 6.45, X11M 6.16, Experimental BUG 11.17, MMON 6.2, ;;; Experimental SC 2.0, Experimental CLIO 12.0, Experimental CONFORMANCE-CHECKER 2.0, ;;; microcode 429, Band Name: REL6-mmon-11/15/89 ;;; SPR 10911. Allow NIL for WINDOW-MAX-WIDTH as advertised. #!C ; From file SYSMEN.LISP#> WINDOW; Hotel: #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; SYSMEN.#" (DEFUN MOUSE-CONFIRM (MESSAGE &OPTIONAL (WHAT-TO-DO "Click mouse, or press if YES. Move off window, or press if NO.") ; (MESSAGE-FONT FONTS:HL12b) ; (WHAT-TO-DO-FONT FONTS:HL12) (WINDOW-MAX-WIDTH 400.)) "Ask for confirmation from the user with a click on a window. MESSAGE text displayed at the top of the window. WHAT-TO-DO text displayed at the bottom of the window. MESSAGE-FONT font that MESSAGE is displayed in. WHAT-TO-DO-FONT font that WHAT-TO-DO is displayed in. WINDOW-MAX-WIDTH maximum number of pixels for the window width or NIL if it should be calculated from the messages." (USING-RESOURCE (window confirmation-window mouse-sheet) (setf message-font (send (tv:sheet-get-screen window) :parse-font-descriptor message-font) what-to-do-font (send (tv:sheet-get-screen window) :parse-font-descriptor what-to-do-font)) (SEND window :clear-input) (SEND window :set-font-map (LIST message-font what-to-do-font)) ;; If the caller does not specify width (OR ONE TOO SMALL) then calculate how wide the window should ;; be from the messages that are provided. (UNLESS (and window-max-width (< 30 window-max-width)) ;; may 01/17/90 (SETQ window-max-width (MAX (MULTIPLE-VALUE-BIND (ignore ignore max-mess-x) (SEND window :string-length message 0 nil nil message-font) max-mess-x) (MULTIPLE-VALUE-BIND (ignore ignore max-what-to-do-x) (SEND window :string-length what-to-do 0 nil nil what-to-do-font) max-what-to-do-x)))) (SETQ window-max-width (MIN window-max-width (- (sheet-inside-width (sheet-superior window)) (sheet-left-margin-size window) (sheet-right-margin-size window)))) ;; Break up the two strings to that they will fit into the window. ;; ***** This calculation assumes a fixed width font, which is not always the ***** ;; ***** case lets fix this sometime and then we can take out the ***** ;; ***** recalculation of window-max-width. dls ***** (SETQ MESSAGE (ADJUST-BY-INTERVAL (TRUNCATE window-max-width (FONT-CHAR-WIDTH message-font)) message) WHAT-TO-DO (ADJUST-BY-INTERVAL (TRUNCATE window-max-width (FONT-CHAR-WIDTH what-to-do-font)) what-to-do)) (SETQ window-max-width (MIN (MAX (MULTIPLE-VALUE-BIND (nil nil max-x) (SEND window :string-length message 0 nil nil message-font) max-x) (MULTIPLE-VALUE-BIND (nil nil max-x) (SEND window :string-length what-to-do 0 nil nil what-to-do-font) max-x)) (- (sheet-inside-width (sheet-superior window)) (sheet-left-margin-size window) (sheet-right-margin-size window)))) ;; The next calculation is somewhat complex. Overall, we are making the window ;; large enough to hold both strings. The first argument to :SET-INSIDE-SIZE is the ;; width of the window. This was calulated earlier. The second argument to ;; :SET-INSIDE-SIZE is the height of the window. To get this, we first calculate ;; the number of lines which are being displayed and add one for the blank line in ;; the middle and multiply this sum times the line height for the window. (SEND window :set-inside-size window-max-width (* (+ (COUNT-LINES message) (COUNT-LINES what-to-do) 1) (sheet-line-height window))) (SEND window :Set-cursorpos 0 0) (SEND window :clear-screen) (SEND window :expose-near '(:mouse) nil) (window-call (window :deactivate) (SEND window :set-current-font message-font) (SEND window :line-out message) (SEND window :line-out "") (SEND window :set-current-font what-to-do-font) (SEND window :string-out what-to-do) (LOOP FOR input = (read-any window) DO (COND ((AND (CONSP input) (EQ :mouse-button (FIRST input))) ; (return t)) ;; user clicked on window ((eql input nil) ;; confirmation window :after :handle mouse now stuffs NIL instead of end when user (return nil)) ;; moves mouse off window! ((or (EQL input #\End) (eql input #\space)) (return t )) ((or (EQL INPUT #\n) (eql input #\N)) (return nil))) )))) ))