;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(MEDFNT HL12B HL12BI); Base:10 -*-

;;;                           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
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved.

;;;
;;; VISIDOC Help windows
;;;
;;; Change History started 10/22/87
;;; 1/20/88    slm  Clean up the test in CONFIGURE-WINDOW-PANE-WITH-MENUS

(DEFFLAVOR Zmacs-fake-out-mixin ((interval nil))
           ()
  :abstract-flavor
  (:required-flavors w:menu)
  (:required-instance-variables main-window))

(DEFMETHOD (Zmacs-fake-out-mixin :ready-for-redisplay-p) (&rest ignore) nil)

(DEFMETHOD (Zmacs-fake-out-mixin :redisplay) (&rest ignore) nil)

(DEFFLAVOR Doc-Viewer-Command-Menu (main-window)
           (Zmacs-fake-out-mixin
            w:menu)
  (:default-init-plist
    :label '(:centered :string "VISIDOC COMMANDS" :font fonts:hl12b)
    :item-list '(("" :no-select ignore)
		 ("Find documentation" :buttons ((nil :kbd (:execute com-doc-viewer-2))
						 (nil :kbd (:execute com-doc-viewer-apropos))
						 (nil :kbd (:execute com-doc-viewer-2)))
		  :documentation "Click left to find documentation on a name,
Click middle to find documentation from an apropos-like style")
                 ("List of Manuals" :kbd (:execute com-list-of-manuals)
                  :documentation "Choose from a list of available online manuals.
Get the table of contents if a buffer for this manual does not already exist.")
                 ("Table of Contents" :kbd (:execute com-table-of-contents)
                  :documentation "Retrieve the table of contents for the current manual")
                 ("Show Buffer Hierarchy" :kbd #\h ;1;;;;*(:execute com-show-buffer-hierarchy)
                  :documentation "View a selectable list of the sections within this buffer")
                 ("Show Page Number" :kbd (:execute com-show-page)
                  :documentation "Display (in the Mini-Buffer) the page for the topic where the cursor is")
                 ;;("" :no-select ignore)
                 ("View Next Topic" :kbd (:execute com-find-next)
                  :documentation "View the next topic defined in this section")
                 ("View Previous Topic" :kbd (:execute com-find-previous)
                  :documentation "View the previous topic defined in this section")
                 ("View Surrounding Topic" :kbd (:execute com-find-superior)
                  :documentation "View the topic that this reference is defined within")
                 ("" :no-select ignore)
                 ("Help" :kbd #\help ;1;;;;;*(:execute com-doc-viewer-documentation)
                  :documentation "View the Help supplied with the document viewer")
                 ("Exit" :kbd #\end
                  :documentation "Exit the document viewer, returning to previous buffer")
                 )
    :fill-p nil
    :scrolling-p nil
    :geometry '(1 12 180 160 nil nil)
    :border-margin-width 5
    :permanent t
    :width 250
    :height 300)
  :settable-instance-variables)

(DEFFLAVOR Doc-Viewer-History-Menu (main-window)
           (Zmacs-fake-out-mixin
            W:menu)
  (:default-init-plist
    :label '(:centered :string "Request History:" :font fonts:hl12b)
    :dynamic t
    :item-list-pointer '*doc-viewer-request-history*
    :permanent t
    :fill-p nil
    :geometry '(1 nil 180 nil nil nil)
    :columns 1
    :border-margin-width 5
    :width 250
    :height 300
    :scroll-bar-side :right
    ;;:scroll-bar-on-off :on
    )
  :settable-instance-variables)

(DEFMETHOD (DOC-VIEWER-COMMAND-MENU :after :mouse-buttons) (&rest ignore)
  (IF W:CHOSEN-ITEM
;      (PROGN
;	(IF (STRING-EQUAL (FIRST w:chosen-item) "Exit")
;	    (SEND main-window :remprop   :Leave-Menus-Up)
;	    (SEND main-window :putprop t :Leave-Menus-Up))
	(SEND self :execute (PROG1 w:chosen-item (SETQ w:chosen-item nil)));)
      (BEEP)))

(DEFMETHOD (DOC-VIEWER-HISTORY-MENU :after :mouse-buttons) (blip &rest ignore)
  (IF (EQUAL #\mouse-m-2 (w:mouse-character-button-encode blip))
    (PROCESS-RUN-FUNCTION "delete menu item" #'delete-history-item? w:current-item self)
    (SEND SELF :EXECUTE (PROG1 W:CHOSEN-ITEM (SETQ W:CHOSEN-ITEM NIL)))
    ))

(DEFUN delete-history-item? (menu-item history-menu)
  (WHEN (w:mouse-confirm
	  (FORMAT nil "Remove <<~a>> from the Request History?" (CAR menu-item)))
    (SETQ *doc-viewer-request-history*
	  (remove menu-item *doc-viewer-request-history* :test #'equal)) 
    (SEND history-menu :update-item-list)))

(DEFUN find-or-make-history-menu (zmacs-frame)
  "Return the history menu instance associated with ZMACS-FRAME.
If it does not exist, create it."
  (DOLIST (inf (SEND zmacs-frame :inferiors))
    (WHEN (TYPEP inf 'doc-viewer-history-menu)
      (RETURN-FROM find-or-make-history-menu inf)))
  (MAKE-INSTANCE 'doc-viewer-history-menu))

(DEFUN find-or-make-command-menu (zmacs-frame)
  "Return the command menu instance associated with ZMACS-FRAME.
If it does not exist, create it."
  (DOLIST (inf (SEND zmacs-frame :inferiors))
    (WHEN (TYPEP inf 'doc-viewer-command-menu)
      (RETURN-FROM find-or-make-command-menu inf)))
  (MAKE-INSTANCE 'doc-viewer-command-menu))

(DEFUN Configure-Window-Pane-with-Menus (zmacs-window)
  (LET* ((zw (window-sheet zmacs-window))
         (frame (window-frame zmacs-window))
         (cm (find-or-make-command-menu frame))
         (hm (find-or-make-history-menu frame))
         right-width ;;(right-width (SEND cm :width))
         (FEW (frame-exposed-windows)))
    
    (SEND hm :update-item-list)
    (SETQ cm (window-sheet cm)
	  hm (window-sheet hm)
	  right-width (SEND cm :width))
    (UNLESS (AND (EQ frame (SEND cm :superior)) (SEND cm :exposed-p))
      (SEND cm :set-io-buffer (SEND frame :io-buffer))
      (SEND hm :set-io-buffer (SEND frame :io-buffer))
      (SEND cm :set-main-window zmacs-window)
      (SEND hm :set-main-window zmacs-window)
      (SEND cm :set-superior frame)
      (SEND hm :set-superior frame)
      (WHEN (>= (SEND frame :width) (+ right-width *minimum-pixel-width-for-text*))  ;;clean up this test!
	(MULTIPLE-VALUE-BIND (left top right bottom)
	    (SEND frame :inside-edges-without-mode-line-window)
	  ;1; Test for multiple exposed windows, such as two-windows mode*
	  (WHEN (>= (LENGTH FEW) 2)
	    (MULTIPLE-VALUE-SETQ (left top right bottom)
	      (SEND zw :edges)))
	  (w:preserve-substitute-status (SEND zw :superior)
	    (w:delaying-screen-management
	      (SEND zw :deexpose)
	      (SEND zw :set-edges left top (- right right-width) bottom)
	      (SEND cm :set-edges (- right right-width) top right (+ top (SEND cm :height)))
	      (SEND hm :set-edges (- right right-width) (+ top (SEND cm :height)) right bottom)
	      (SEND zw :expose nil :clean)
	      (SEND cm :expose)
	      (SEND hm :expose))))))
    (SEND zw :set-label nil)))

(DEFUN Configure-Window-Pane-WITHOUT-Menus (zmacs-window) ;; command-menu history-menu)
  (LET* ((zw (window-sheet zmacs-window))
         (frame (window-frame zmacs-window))
	 (sup (send zmacs-window :superior))
         (few (frame-exposed-windows)))
    (SEND (find-or-make-command-menu frame) :deexpose)
    (SEND (find-or-make-history-menu frame) :deexpose)
    (MULTIPLE-VALUE-BIND (left top right bottom)
        (SEND frame :inside-edges-without-mode-line-window)
      ;1; Test for multiple exposed windows, such as two-windows mode.*
      ;1; When true, need new top and bottom edges.*
      (WHEN (>= (LENGTH few) 2)
        (MULTIPLE-VALUE-SETQ (nil top nil bottom)
          (SEND zw :edges)))
      (w:preserve-substitute-status sup
        (w:delaying-screen-management
          (SEND zw :deexpose)
          (SEND zw :set-edges left top right bottom)
          (SEND zw :expose nil :clean))))
    (SEND zw :set-label nil)))

;;; These Zmacs functions need to be patched in order to make Two-Windows mode
;;; to work correctly for the document viewer.

;(LET ((inhibit-fdefine-warnings t))

;  ;1; Most of these are from the SCREEN file.*
;  ;1;All in the SCREEN file are in zmacs patch 3.23*  slm 10/87
;  (DEFMETHOD (ZWEI-FRAME :EDITOR-WINDOW) ()
;    (DO ((L W:INFERIORS (CDR L)))
;        ((NULL L) (FERROR NIL "No inferiors"))
;      (OR (NOT (TYPEP (CAR L) 'zmacs-window-pane)) ;1Added for VISIDOC*
;          (EQ (CAR L) MODE-LINE-WINDOW)
;          (RETURN (SEND (CAR L) :ZWEI-WINDOW))))) 


;  (DEFMETHOD (ZMACS-FRAME :TWO-EDITOR-WINDOWS) ()
;    (DO ((L W:INFERIORS (CDR L))
;         (WINDOW)
;         (TOP-WINDOW)
;         (BOTTOM-WINDOW))
;        ((NULL L) (VALUES TOP-WINDOW (SEND SELF :CREATE-WINDOW 'ZMACS-WINDOW-PANE
;                                           :INTERVAL (OR (PREVIOUS-BUFFER)
;                                                         'ZMACS-BUFFER))))
;      (COND ((NOT (TYPEP (car L) 'zmacs-window-pane)))     ;Added for VISIDOC
;            ((EQ (SETQ WINDOW (CAR L)) MODE-LINE-WINDOW))
;            ((NULL TOP-WINDOW)
;             (SETQ TOP-WINDOW WINDOW))
;            (T
;             (SETQ BOTTOM-WINDOW WINDOW)
;             (AND (W:SHEET-EXPOSED-P BOTTOM-WINDOW)
;                  (< (W:SHEET-Y-OFFSET BOTTOM-WINDOW)
;                     (W:SHEET-Y-OFFSET TOP-WINDOW))
;                  (PSETQ TOP-WINDOW BOTTOM-WINDOW BOTTOM-WINDOW TOP-WINDOW))
;             (RETURN (VALUES TOP-WINDOW BOTTOM-WINDOW)))))) 
  
;  (DEFMETHOD (ZMACS-FRAME :N-EDITOR-WINDOWS) (N &AUX LIST)
;    (DO ((L W:INFERIORS (CDR L))
;         (I 0 (1+ I)))
;        ((OR (NULL L) (>= I N)))
;      (OR (NOT (TYPEP (car L) 'zmacs-window-pane)) ;Added for VISIDOC
;          (EQ (CAR L) MODE-LINE-WINDOW)
;          (PUSH (SEND (CAR L) :ZWEI-WINDOW) LIST)))
;    (DOTIMES (I (- N (LENGTH LIST)))
;      (PUSH (SEND SELF :CREATE-WINDOW 'ZMACS-WINDOW-PANE) LIST))
;    LIST) 
  
;  (DEFMETHOD (ZWEI-FRAME :EDITOR-WINDOWS) ()
;    (APPEND (SORT (REMOVE-IF-NOT #'(lambda (w) (TYPEP w 'zmacs-window-pane))
;                                 (THE LIST W:EXPOSED-INFERIORS))
;                  #'(LAMBDA (W1 W2) (< (W:SHEET-Y-OFFSET W1) (W:SHEET-Y-OFFSET W2))))
;            (REMOVE-IF-NOT #'(LAMBDA (W) (TYPEP W 'DISPLAYER))
;                           (IF (EQ MODE-LINE-WINDOW (SEND *WINDOW* :SUPERIOR))
;                               (LIST *WINDOW*)
;                               (SEND MODE-LINE-WINDOW :EXPOSED-INFERIORS)))))

;  (DEFMETHOD (ZWEI-FRAME :SELECTABLE-WINDOWS) ()
;    (LET ((SELECTABLE-WINDOWS NIL))
;      (DOLIST (I W:EXPOSED-INFERIORS)
;        (OR (NOT (TYPEP I 'ZMACS-WINDOW-PANE))     ;1Added for VISIDOC*
;            (EQ I MODE-LINE-WINDOW)
;            (LET ((STRING (SEND I :NAME-FOR-SELECTION)))
;              (AND STRING
;                   (PUSH (LIST STRING SELF) SELECTABLE-WINDOWS)))))
;      (NREVERSE SELECTABLE-WINDOWS)))

;;1;THIS IS ALREADY IN MAIL-READER PATCH 3.14*
;;1; This from file sys:mail-reader;buffer.lisp Change made for selection to also deselect previous buffer. *
;  (defmethod (message-sequence :SELECT) (&optional ignore)
  
;  (let ((new-interval self)
;	(old-buffer (window-interval *window*))
;	old-config config buffer)
;    ;; Just behave normally if entered recursively -- this can happen during make-window-current
;    (unless (eq *mail-buffer-selection-mode* :in-progress)
;      ;; Changed this from a WHEN to an IF, and put in the ELSE part to (send old-buffer :deselect)
;      ;; in order to remain consistent with the way Zmacs handles selecting a buffer.
;      (IF (mail-reader-buffer-p old-buffer)
;	(setq old-config (current-mail-window-configuration))
;        (SEND old-buffer :deselect))
;      (cond ((memeq *mail-buffer-selection-mode* '(:summary :message :both))
;	     ;; Selection being forced by a mail command -- obey
;	     (setq config *mail-buffer-selection-mode*)
;	     (setq buffer self))
;	    ((eq old-buffer self)
;	     ;; Window containing this buffer is just being reselected
;	     (setq config :message)
;	     (setq buffer self))
;	    (t
;	     ;; Mail file buffer being selected by random ZMACS command -- observe stickyness
;	     (setq config (cond ((eq old-config :both)
;				 :both)
;				(*sticky-mail-window-configuration-p*
;				 (or (get (mail-file-buffer-of self) :prev-mail-window-configuration)
;				     (default-mail-window-configuration)))
;				(t
;				 (default-mail-window-configuration))))
;	     (setq buffer (cond ((or (not (mail-file-buffer-p self))
;				     (not *sticky-mail-buffer-selection-p*))
;				 self)
;				(t
;				 (or (get self :prev-selected-message-sequence)
;				     self))))
;	     (when (get buffer :killed)
;	       (setq buffer self))))
;      (when *sticky-mail-window-configuration-p*
;	(setf (get (mail-file-buffer-of self) :prev-mail-window-configuration) config))
;      (when *sticky-mail-buffer-selection-p*
;	(setf (get (mail-file-buffer-of self) :prev-selected-message-sequence) buffer))
      
;      (let ((*mail-buffer-selection-mode* :in-progress)
;	    (windows (frame-exposed-windows)))
;	(when (and (cdr windows)
;		   (not *preserve-windows-during-select*)
;		   (not (eq config :both)))
;	  (make-window-full-screen *window*))
;	(case config
;	  (:both
;	   (multiple-value-bind (top bottom)
;	       (two-mail-reader-windows-p buffer)
;	     (unless (and top bottom)
;	       (multiple-value-setq (top bottom)
;		 (two-windows-by-fraction *mail-summary-window-fraction*)))
;	     (make-window-current top)
;	     (send bottom :set-interval-internal buffer)
;	     (setq new-interval (mail-summary-of buffer t))))
;	  (:message
;	   (setq new-interval buffer))
;	  (otherwise
;	   (setq new-interval (mail-summary-of buffer t))))
;	(update-buffer-history old-buffer (mail-file-buffer-of buffer))))
    
;    ;; Save away the major and minor modes, and turn them off.
;    (when *interval*
;      (setf (buffer-saved-mode-list *interval*) *mode-list*)
;      (setf (buffer-saved-major-mode *interval*) *major-mode*)
;      (setf (buffer-saved-local-variables *interval*)
;	    (mapcar #'(lambda (v)
;			(cons v (if (memeq v *local-bound-variables*)
;				    (sys:%p-contents-as-locative (value-cell-location v))
;				  (list (symbol-value v)))))
;		    *local-variables*))
;      (un-set-modes))
;    (when (neq (window-interval *window*) new-interval)
;      (send *window* :set-interval-internal new-interval))
;    (setq *interval* new-interval)
;    ;; Recompute which package READs should be done in.
;    (update-buffer-names *interval*)
;    (compute-buffer-package *interval*)
;    ;; Restore the old major and minor modes.
;    (set-modes (buffer-saved-mode-list *interval*)
;	       (buffer-saved-major-mode *interval*)
;	       (buffer-saved-local-variables *interval*))
;    (unless (eq *mail-buffer-selection-mode* :in-progress)
;      (setq *mail-buffer* (message-sequence-of new-interval))
;      (setq *msg* (current-message *mail-buffer* nil))
;      (must-redisplay-mail-buffer *mail-buffer* dis-text dis-text))
;    NIL))
;  );1;end of inhibit-fdefine-warnings scope