;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(CPTFONT HL12B HL12BI HL12BI HL12B) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(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) 1988, Texas Instruments Incorporated. All rights reserved.

;1;; This file contains code to implement blinking colors on the TI Explorer color monitor...*

;1;; New methods for SHEET...*
(DEFMETHOD 4(sheet :set-on-screen-p)*
	   (new-on-screen-p)
  (AND new-on-screen-p
       ;1; Color map of last exposed inferior will override this one's,*
       ;1;  so don't bother to install it if we have exposed inferiors...*
       (NULL exposed-inferiors)
       (install-color-map self))
  (DOLIST (window exposed-inferiors)
    (SEND window :set-on-screen-p new-on-screen-p)))

(DEFMETHOD 4(sheet :before :deexpose)*
	   (&rest ignore)
  (WHEN (on-screen self)
    (SEND self :set-on-screen-p nil)))

;1;; This is modified system code...*
(DEFMETHOD 4(sheet :after :expose)*
	   (&rest ignore)
  ;1; CJJ 12/6/88.  Call a method which calls INSTALL-COLOR-MAP,*
  ;1;  instead of calling it directly.  This ensures that INSTALL-COLOR-MAP*
  ;1;  is also called when a window's superior is exposed...*
  (WHEN (on-screen self)
    (SEND self :set-on-screen-p t)))

(DEFFLAVOR 4blinking-colors-mixin*
	   ((blinking-color-map nil)
	    (blink-rate 1.))
	   ()
  (:documentation
    "3Mixin for color windows.  Windows containing this flavor have a BLINKING-COLOR-MAP which, when the window is
exposed or selected, is alternated with the window's standard color map every BLINK-RATE 60ths of a second.*")
  (:settable-instance-variables blink-rate)
  (:gettable-instance-variables blinking-color-map)
  (:inittable-instance-variables blinking-color-map)
  :abstract-flavor
  (:required-instance-variables inferiors)
  (:required-flavors w:essential-window))

(DEFMETHOD 4(blinking-colors-mixin :set-blinking-color-map)*
	   (new-blinking-color-map &optional inherit)
  (WHEN inherit
    (LOOP FOR inferior IN inferiors
	  FOR inferior-blinking-color-map = (SEND inferior :send-if-handles :blinking-color-map)
	  UNLESS (AND inferior-blinking-color-map
		      (NEQ inferior-blinking-color-map blinking-color-map))
	  DOING (SEND inferior :send-if-handles :set-blinking-color-map new-blinking-color-map t)))
  (SETF blinking-color-map new-blinking-color-map))

(DEFFLAVOR 4color-priority-mixin*
	   ((color-priority -1))
	   ()
  (:documentation
    "3Mixin for color windows.  Windows containing this flavor have a COLOR-PRIORITY which, when the window is
exposed, gives it priority over lower priority windows for having its COLOR-MAP installed.*")
  :gettable-instance-variables
  :inittable-instance-variables
  :abstract-flavor
  (:required-flavors w:essential-window))

(DEFVAR 4*color-priority-stacks* *(MAKE-ARRAY 4 :initial-element nil)
  "2Array of lists of exposed windows whose color-maps have been installed.
Windows on list at index X in array have color-priority X.
Windows which do not have a color-priority or which have a color-priority less than 0
are not stored in a list in the array.
Each list is sorted by most-to-least recent exposure/selection of windows.*")

(DEFMETHOD 4(color-priority-mixin :after :init)*
	   (&rest ignore)
  (IF (FIXNUMP color-priority)
      (SETF color-priority (MIN color-priority (1- (LENGTH *color-priority-stacks*))))
      ;1; ELSE...*
      (SETF color-priority -1.)))

(DEFMETHOD 4(color-priority-mixin :set-color-priority)*
	   (new-priority)
1   *;1; remove SELF from stack at previous priority level...*
  (UNLESS (MINUSP color-priority)
    (SETF (AREF *color-priority-stacks* color-priority)
	  (DELETE self (AREF *color-priority-stacks* color-priority) :test #'EQ)))
  (IF (FIXNUMP new-priority)
      (SETF color-priority (MIN new-priority (1- (LENGTH *color-priority-stacks*))))
      ;1; ELSE...*
      (SETF color-priority -1.)))

(DEFMETHOD 4(color-priority-mixin :after :set-on-screen-p)* (new-on-screen-p)
  (UNLESS (OR new-on-screen-p
	      (MINUSP color-priority))
    (SETF (AREF *color-priority-stacks* color-priority)
	  (DELETE self (AREF *color-priority-stacks* color-priority) :test 'EQ))))

(DEFVAR 4*blinking-window* *nil
  "2A fully visible window which contains the BLINKING-COLORS-MIXIN flavor.
Set to a window instance by INSTALL-COLOR-MAP and set to NIL by BLINK-COLORS.
BLINK-COLORS runs on the sys:CLOCK-FUNCTION-LIST as long as this variable is non-NIL.*")

(DEFVAR 4*time-to-next-blink* *0
  "2Time in 60ths of a second until BLINK-COLORS will swap the current color LUT buffer.*")

(DEFUN 4blink-colors*
       (time-since-last-blink)
  "2Swaps the current color LUT buffer to effect blinking colors.
Runs in the scheduler process on the sys:CLOCK-FUNCTION-LIST.*"
  ;1; Make sure blinking window is still fully visible...*
  (AND *blinking-window*
       (NOT (on-screen *blinking-window*))
       (SETF *blinking-window* nil))
  (IF *blinking-window*
      ;1; See if it's time to blink yet...*
      (WHEN (MINUSP (DECF *time-to-next-blink* time-since-last-blink))
	;1; Blink now and reset timer.*
	(SETF *time-to-next-blink* (SEND *blinking-window* :blink-rate))
	;1; Swap in the swapped-out color LUT buffer.*
	;1; w:TRANSFER-COLOR-LUT-BUFFER updates *CURRENT-COLOR-LUT-BUFFER*...*
	(w:transfer-color-lut-buffer (LOGXOR *current-color-lut-buffer* 1)))
      ;1; ELSE...*
      ;1; The blinking window isn't fully visible anymore, so go away until needed...*
      (SETF sys:clock-function-list (DELETE 'blink-colors sys:clock-function-list :test #'EQ))))

;1;; This is modified system code...*
(DEFUN 4install-color-map* (window)
  (WHEN (AND sib-is-csib (download-color-map-p window))
    ;1; modification one of four starts here...*
    (LET ((priority (OR (SEND window :send-if-handles :color-priority) -1)))
      ;1; Move WINDOW to top of its priority stack...*
      (UNLESS (OR (MINUSP priority)
		  (EQ window (CAR (AREF *color-priority-stacks* priority))))
	(SETF (AREF *color-priority-stacks* priority)
	      (DELETE window (AREF *color-priority-stacks* priority) :test #'EQ))
	(WHEN (on-screen window)
	  (PUSH window (AREF *color-priority-stacks* priority))))
      ;1; Substitute a higher priority window, if there is one...*
      (SETF window
	    (LOOP FOR index FROM (1- (LENGTH *color-priority-stacks*)) DOWNTO (1+ priority)
		  WHEN (CAR (AREF *color-priority-stacks* index))
		  RETURN IT
		  FINALLY (RETURN window))))
    ;1; modification one of four ends here.*
    (LET ((map (sheet-color-map window))
	  ;1; modification two of four starts here...*
	  (current-color-lut-buffer (current-color-lut-buffer))
	  (blink-map (SEND window :send-if-handles :blinking-color-map))
	  ;1; modification two of four ends here.*
	  )
      (WHEN (AND map (on-screen window))	;1 only load if window is really on the screen and the map is non-nil*
	;1; Following line is modification three of four...*
	;1; Following line is modified to use local value of current-color-lut-buffer instead of global value.*
	;1; This ensures that BLINK-MAP will be downloaded to the other LUT buffer in case*
	;1; BLINK-COLORS swaps the current LUT buffer before the BLINK-MAP gets downloaded...*
        (download-color-lut-buffer map current-color-lut-buffer)
	;1; modification four of four begins here...*
	(IF blink-map
	    (PROGN
	      ;1; Put BLINK-MAP in the other LUT buffer...*
	      (w:download-color-lut-buffer blink-map (LOGXOR current-color-lut-buffer 1))
	      ;1; Make this window THE blinking window...*
	      (SETF *blinking-window* window)
	      ;1; Force an immediate blink, in case this window blinks faster than previous blinking window...*
	      (SETF *time-to-next-blink* 0)
	      ;1; Start the blinker function, if it's not already started...*
	      (PUSHNEW 'blink-colors sys:clock-function-list :test #'EQ))
	    ;1; ELSE...*
	    ;1; Blinking may have just been turned off for this window, so let the blinker function know...*
	    (SETF *blinking-window* nil))
	;1; modification four of four ends here.*
	;1; LOGAND'ing prevents overridding the screens' plane-mask.*
	(SEND window :write-plane-mask (LOGAND (sheet-plane-mask (get-screen window)) (sheet-plane-mask window)))
        (SEND (AREF *blocks* kludge-block) :set-foreground-color-register (color-map-saturate map))
        (SEND (AREF *blocks* kludge-block) :set-background-color-register (color-map-clamp map))))))