;;; -*- Mode:LISP; Package:GREY; Base:8 -*-

;; Copyright LISP Machine, Inc. 1984
;;    See filename "Copyright" for
;; licensing and release information.


;;;;WINDOW SYSTEM CODE

(DEFVAR GREY-SCREEN)

(DEFFLAVOR GREY-SCREEN (LAYOUT (COLOR-MAP-CONTROL-WINDOW nil))
	   (grey-screen-download-mixin TV:STANDARD-SCREEN)
  (:INITABLE-INSTANCE-VARIABLES LAYOUT)
  (:GETTABLE-INSTANCE-VARIABLES LAYOUT COLOR-MAP-CONTROL-WINDOW)
  (:SETTABLE-INSTANCE-VARIABLES COLOR-MAP-CONTROL-WINDOW))

(DEFFLAVOR GREY-SCREEN-PLANE () (grey-screen-download-mixin  TV:STANDARD-SCREEN))

(DEFFLAVOR GREY-SCREEN-DOWNLOAD-MIXIN () ()
  (:DOCUMENTATION "Makes sure the board is downloaded before anybody tries to :EXPOSE it,
which would reference it as memory."))

;; next time we build from scratch change this to an :around method.

(DEFWRAPPER (GREY-SCREEN-DOWNLOAD-MIXIN :EXPOSE) (IGNORE . BODY)
  "Don't actually expose the color screen if there is no color monitor.  This
function is a TOTAL KLUDGE."
  `(COND ((GREY-EXISTS-AND-IF-SO-DOWNLOADED-P SELF)
	  ;; always write this since it is cheap and fixes the bug of
	  ;; a board actually allocated and downloaded, but our virtual memory not set up
	  ;; because we have cold booted the machine. someday we will handle these issues
	  ;; in the device-allocation code itself.
	  (WRITE-METER 'SI:%LOWEST-DIRECT-VIRTUAL-ADDRESS
		       VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS)
	  . ,BODY)))

(DEFVAR GREY-SCREEN0)
(DEFVAR GREY-SCREEN1)
(DEFVAR GREY-SCREEN2)
(DEFVAR GREY-SCREEN3)
(DEFVAR GREY-SCREEN4)
(DEFVAR GREY-SCREEN5)
(DEFVAR GREY-SCREEN6)
(DEFVAR GREY-SCREEN7)

(DEFVAR GREY-SCREEN-ARRAY)

(DEFVAR GREY-SCREEN-ARRAY0)
(DEFVAR GREY-SCREEN-ARRAY1)
(DEFVAR GREY-SCREEN-ARRAY2)
(DEFVAR GREY-SCREEN-ARRAY3)
(DEFVAR GREY-SCREEN-ARRAY4)
(DEFVAR GREY-SCREEN-ARRAY5)
(DEFVAR GREY-SCREEN-ARRAY6)
(DEFVAR GREY-SCREEN-ARRAY7)

;these kind of screens are pretty useless for the time being.
(DEFUN MAKE-GREY-SCREEN (&OPTIONAL
			 (LAYOUT ':PORTRAIT)
			 (NAME "GREY")
			 (XBUS-ADR VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS-AS-FIXNUM)
			 (CONTROL-ADR nil))  ;377530
  (loop for s in tv:all-the-screens
	if (string-equal name (funcall s ':name))
	do (progn (format t
 "~%There is already a screen with name ~S. Do you want to create another?" name)
		    (if (null (y-or-n-p)) (return s)))
	finally
	  (return 
	    (LET ((HEIGHT (SELECTQ LAYOUT
			    (:PORTRAIT 454.)
			    (:SQUARE 512.)
			    (OTHERWISE (FERROR NIL "UNKNOWN LAYOUT"))))
		  (WIDTH (SELECTQ LAYOUT
			   (:PORTRAIT 576.)
			   (:SQUARE 512.))))
	      (TV:DEFINE-SCREEN 'GREY-SCREEN NAME
				':BITS-PER-PIXEL 8
				':BUFFER XBUS-ADR
				':HEIGHT HEIGHT ':WIDTH WIDTH
				':CONTROL-ADDRESS CONTROL-ADR
				':LAYOUT LAYOUT
				':PROPERTY-LIST
				`(:VIDEO :COLOR
				  :CONTROLLER :LMGREY
				  :HARDWARE-COLOR-MAP
				    ,(MAKE-pixel-ARRAY 400 3 ':type ART-8B)))))))

(DEFUN GET-GREY-SCREEN-ARRAY (&OPTIONAL (L ':PORTRAIT))
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY) GREY-SCREEN-ARRAY)
	(T (SETQ GREY-SCREEN-ARRAY (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN) GREY-SCREEN)
					   (T (SETQ GREY-SCREEN (MAKE-GREY-SCREEN L)))))))))

(DEFUN KILL-SCREENS ()
  "CALL THIS IF YOU WANT TO REMAKE THE GREY SCREEN"
  (COND ((BOUNDP 'GREY-SCREEN)
     ;	 (FUNCALL GREY-SCREEN ':KILL)  		;****BOMBS TRYING TO SEND MSG TO SUPERIOR
						;FIX THIS
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY)

  (COND ((BOUNDP 'GREY-SCREEN0)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN0 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN0)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY0)

  (COND ((BOUNDP 'GREY-SCREEN1)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN1 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN1)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY1)

  (COND ((BOUNDP 'GREY-SCREEN2)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN2 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN2)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY2)

  (COND ((BOUNDP 'GREY-SCREEN3)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN3 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN3)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY3)

  (COND ((BOUNDP 'GREY-SCREEN4)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN4 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN4)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY4)

  (COND ((BOUNDP 'GREY-SCREEN5)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN5 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN5)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY5)

  (COND ((BOUNDP 'GREY-SCREEN6)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN6 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN6)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY6)

  (COND ((BOUNDP 'GREY-SCREEN7)
	 (SETQ TV:ALL-THE-SCREENS (DELQ GREY-SCREEN7 TV:ALL-THE-SCREENS))
	 (MAKUNBOUND 'GREY-SCREEN7)))
  (MAKUNBOUND 'GREY-SCREEN-ARRAY7))

(DEFUN MAKE-PLANE-SCREEN (
        PLANE &OPTIONAL (NAME (STRING-APPEND "grey-plane" (FORMAT NIL "~D" PLANE)))
	(XBUS-ADR (+ VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS-AS-FIXNUM 200000 (* PLANE 20000))))
  (TV:DEFINE-SCREEN 'GREY-SCREEN-PLANE NAME
    ':BUFFER XBUS-ADR
    ':CONTROL-ADDRESS nil  ;377530
    ':PROPERTY-LIST '(:VIDEO :COLOR-PLANE
			     :CONTROLLER :LMGREY)
    ':HEIGHT 454.
    ':WIDTH 576.))

(DEFUN GET-GREY-SCREEN-ARRAY0 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY0) GREY-SCREEN-ARRAY0)
	(T (SETQ GREY-SCREEN-ARRAY0 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN0) GREY-SCREEN0)
					   (T (SETQ GREY-SCREEN0 (MAKE-PLANE-SCREEN 0)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY1 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY1) GREY-SCREEN-ARRAY1)
	(T (SETQ GREY-SCREEN-ARRAY1 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN1) GREY-SCREEN1)
					   (T (SETQ GREY-SCREEN1 (MAKE-PLANE-SCREEN 1)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY2 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY2) GREY-SCREEN-ARRAY2)
	(T (SETQ GREY-SCREEN-ARRAY2 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN2) GREY-SCREEN2)
					   (T (SETQ GREY-SCREEN2 (MAKE-PLANE-SCREEN 2)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY3 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY3) GREY-SCREEN-ARRAY3)
	(T (SETQ GREY-SCREEN-ARRAY3 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN3) GREY-SCREEN3)
					   (T (SETQ GREY-SCREEN3 (MAKE-PLANE-SCREEN 3)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY4 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY4) GREY-SCREEN-ARRAY4)
	(T (SETQ GREY-SCREEN-ARRAY4 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN4) GREY-SCREEN4)
					   (T (SETQ GREY-SCREEN4 (MAKE-PLANE-SCREEN 4)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY5 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY5) GREY-SCREEN-ARRAY5)
	(T (SETQ GREY-SCREEN-ARRAY5 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN5) GREY-SCREEN5)
					   (T (SETQ GREY-SCREEN5 (MAKE-PLANE-SCREEN 5)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY6 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY6) GREY-SCREEN-ARRAY6)
	(T (SETQ GREY-SCREEN-ARRAY6 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN6) GREY-SCREEN6)
					   (T (SETQ GREY-SCREEN6 (MAKE-PLANE-SCREEN 6)))))))))

(DEFUN GET-GREY-SCREEN-ARRAY7 ()
  (COND ((BOUNDP 'GREY-SCREEN-ARRAY7) GREY-SCREEN-ARRAY7)
	(T (SETQ GREY-SCREEN-ARRAY7 (TV:SHEET-SCREEN-ARRAY
				     (COND ((BOUNDP 'GREY-SCREEN7) GREY-SCREEN7)
					   (T (SETQ GREY-SCREEN7 (MAKE-PLANE-SCREEN 7)))))))))

(DEFUN SCREEN-INITIALIZE NIL
 (COND ((NOT (BOUNDP 'GREY-SCREEN))
       (select si:processor-type-code
	 (si:cadr-type-code (USE-DIRECT))
	 (si:lambda-type-code (use-lam-direct)))	;So following MAKE-GREY-SCREEN will work
	(ADD-INITIALIZATION "Grey Make Screen" '(SETQ GREY-SCREEN (MAKE-GREY-SCREEN))
			    '(ONCE))) ))

;Grey font hackery (convert a font to be usable on the grey screen in old-style pixel mode)
(DEFUN MAKE-GREY-FONT (BW-FONT &OPTIONAL (BIT-LIST '(1 1 1 1 1 1 1 1)) (FONT-NAME-SUFFIX ""))
  (COND ((FIXP BIT-LIST)
	 (DO ((I 0 (1+ I))
	      (X BIT-LIST)
	      (L NIL))
	     ((>= I 8)
	      (SETQ BIT-LIST (NREVERSE L)))
	   (PUSH (LDB 0001 X) L)
	   (SETQ X (LSH X -1))))
	((OR ( (LENGTH BIT-LIST) 8)
	     (DOLIST (B BIT-LIST) (OR (NUMBERP B) (RETURN T))))
	 (FERROR NIL "Illegal format for bit list ~S" BIT-LIST)))
  (LET ((FIT) (MAXW 1) (SIZE 0) (RASTER-WIDTH) (WORDS-PER-CHAR) (RASTERS-PER-WORD)
	(GREY-FONT) (NEW-FIT)
	(FONT-NAME (INTERN (STRING-APPEND "GREY-" (FONT-NAME BW-FONT) FONT-NAME-SUFFIX)
			   'FONTS)))
    (IF (SETQ FIT (FONT-INDEXING-TABLE BW-FONT))
	(DOTIMES (CHAR 200)
	  (SETQ MAXW (MAX MAXW (- (AREF FIT (1+ CHAR)) (AREF FIT CHAR))))))
    (SETQ MAXW (* (FONT-RASTER-WIDTH BW-FONT) MAXW 8))
    (COND ((> MAXW 32.)
;Will need a font indexing table, make raster width 32., and
;figure out the size of the array
	   (SETQ RASTERS-PER-WORD 1
		 WORDS-PER-CHAR (FONT-RASTER-HEIGHT BW-FONT)
		 RASTER-WIDTH 32.)
	   (COND ((NULL FIT)
;Old font has no indexing table, so every character is same size
		  (SETQ SIZE (* (// (+ MAXW 31.) 32.) WORDS-PER-CHAR 200)))
		 (T
;Otherwise, loop through and figure out size on a per character basis
		  (DOTIMES (CHAR 200)
		    (SETQ SIZE (+ SIZE (* 8 WORDS-PER-CHAR
					  (- (AREF FIT (1+ CHAR)) (AREF FIT CHAR)))))))))
	  ((NULL FIT)
;Won't need an indexing table, and didn't have one
	   (SETQ RASTER-WIDTH MAXW)
	   (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH))
	   (SETQ WORDS-PER-CHAR (// (+ (FONT-RASTER-HEIGHT BW-FONT) (1- RASTERS-PER-WORD))
				    RASTERS-PER-WORD))
	   (SETQ SIZE (* WORDS-PER-CHAR 200)))
	  (T (FERROR NIL "We don't need an indexing table, but black-and-white font did?")))
    (SETQ GREY-FONT
	  (MAKE-ARRAY (* SIZE 32.)
		      ':TYPE 'ART-1B
		      ':LEADER-LENGTH TV:FONT-LEADER-SIZE
		      ':NAMED-STRUCTURE-SYMBOL 'FONT))
    (SETF (ARRAY-LEADER GREY-FONT 0) 0)			;Fill pointer
    (SETF (FONT-NAME GREY-FONT) FONT-NAME)
    (SET FONT-NAME GREY-FONT)
;Copy parameters which are the same
    (SETF (FONT-CHAR-HEIGHT GREY-FONT) (FONT-CHAR-HEIGHT BW-FONT))
    (SETF (FONT-CHAR-WIDTH GREY-FONT) (FONT-CHAR-WIDTH BW-FONT)) ;Software width is the same
    (SETF (FONT-RASTER-HEIGHT GREY-FONT) (FONT-RASTER-HEIGHT BW-FONT))
    (SETF (FONT-RASTER-WIDTH GREY-FONT) RASTER-WIDTH)
    (SETF (FONT-RASTERS-PER-WORD GREY-FONT) RASTERS-PER-WORD)
    (SETF (FONT-WORDS-PER-CHAR GREY-FONT) WORDS-PER-CHAR)
    (SETF (FONT-BASELINE GREY-FONT) (FONT-BASELINE BW-FONT))
    (SETF (FONT-CHAR-WIDTH-TABLE GREY-FONT) (FONT-CHAR-WIDTH-TABLE BW-FONT))
    (SETF (FONT-LEFT-KERN-TABLE GREY-FONT) (FONT-LEFT-KERN-TABLE BW-FONT))
    (SETF (FONT-BLINKER-WIDTH GREY-FONT) (FONT-BLINKER-WIDTH BW-FONT))
    (SETF (FONT-BLINKER-HEIGHT GREY-FONT) (FONT-BLINKER-HEIGHT BW-FONT))

;Setup new font indexing table if necessary
    (IF (> MAXW 32.)
	(SETF (FONT-INDEXING-TABLE GREY-FONT) (SETQ NEW-FIT (MAKE-ARRAY 201))))
    (COND ((NULL NEW-FIT)
;This is pretty easy -- loop over each char and duplicate bits
	   (LET ((RAS-PER-W (FONT-RASTERS-PER-WORD BW-FONT))
		 (RW (FONT-RASTER-WIDTH BW-FONT)))
	     (DOTIMES (CHAR 200)
	       (LET ((BW-BASE (* CHAR (FONT-WORDS-PER-CHAR BW-FONT) 32.))
		     (CBASE (* CHAR WORDS-PER-CHAR 32.))
		     (CPIX))
;Generator loop, calls sink on every bit
		 (DOTIMES (RAS (FONT-RASTER-HEIGHT BW-FONT))
		   (SETQ CPIX 0)
		   (DOTIMES (PIX RW)
;Here once for each pixel of bw font
		     (LET ((PIXEL (AREF BW-FONT
					(+ BW-BASE			;Offset
					   (* 32. (// RAS RAS-PER-W))	;Number of words in
					   (* RW (\ RAS RAS-PER-W))	;Num rasters in word
					   PIX))))			;Pixel within raster
		       (DOLIST (B BIT-LIST)
;Now store pixel eight times
			 (ASET (* PIXEL B) GREY-FONT
			       (+ CBASE
				  (* 32. (// RAS RASTERS-PER-WORD))
				  (* RASTER-WIDTH (\ RAS RASTERS-PER-WORD))
				  CPIX))
			 (SETQ CPIX (1+ CPIX))))))))))
	  (T
;We will have an indexing table
	   (LET ((RAS-PER-W (FONT-RASTERS-PER-WORD BW-FONT))
		 (RW (FONT-RASTER-WIDTH BW-FONT))
		 (GREY-IDX -1))
	     (DOTIMES (CHAR 200)
	       (ASET (1+ GREY-IDX) NEW-FIT CHAR)
	       (LET* ((BW-IDX (IF FIT
				  (AREF FIT CHAR)
				  CHAR))
		      (BW-NWIDE (IF FIT (- (AREF FIT (1+ CHAR)) BW-IDX) 1))
		      (BW-BASE)
		      (CBASE)
		      (IDX)
		      (CPIX))
		   (DOTIMES (RAS (FONT-RASTER-HEIGHT BW-FONT))
		     (SETQ IDX GREY-IDX
			   CPIX RASTER-WIDTH)
		     (DOTIMES (CHAR-WITHIN-CHAR BW-NWIDE)
		       (SETQ BW-BASE (* (FONT-WORDS-PER-CHAR BW-FONT)
					(+ BW-IDX CHAR-WITHIN-CHAR)
					32.))
		       (DOTIMES (PIX RW)
;Here once for each pixel of bw font
			 (LET ((PIXEL (AREF BW-FONT
					    (+ BW-BASE			  ;Offset
					       (* 32. (// RAS RAS-PER-W)) ;Number of words in
					       (* RW (\ RAS RAS-PER-W))	  ;Num rasters in word
					       PIX))))			  ;Pixel within raster
			   (DOLIST (B BIT-LIST)
;Now store pixel eight times
			     (SETQ CPIX (1+ CPIX))
			     (IF ( CPIX RASTER-WIDTH)
				 (SETQ IDX (1+ IDX)
				       CPIX 0
				       CBASE (* IDX WORDS-PER-CHAR 32.)))
			     (ASET (* PIXEL B) GREY-FONT
				   (+ CBASE
				      (* 32. (// RAS RASTERS-PER-WORD))
				      (* RASTER-WIDTH (\ RAS RASTERS-PER-WORD))
				      CPIX)))))))
		   (SETQ GREY-IDX IDX)))
	     (ASET (1+ GREY-IDX) NEW-FIT 200))))
    (PUTPROP FONT-NAME T 'GREY-FONT)
    (PUTPROP FONT-NAME (FONT-NAME BW-FONT) 'FONTS:CPT-FONT)
    (PUTPROP (FONT-NAME BW-FONT) FONT-NAME 'FONTS:GREY-FONT)
    GREY-FONT))

(DEFMETHOD (GREY-SCREEN :PARSE-FONT-DESCRIPTOR) (FD)
  (SETQ FD (TV:SCREEN-PARSE-FONT-DESCRIPTOR FD 'FONTS:GREY-FONT))
  (OR (GET (FONT-NAME FD) 'GREY-FONT)
      (SETQ FD (MAKE-GREY-FONT FD)))
  FD)


(DEFMETHOD (GREY-SCREEN :PARSE-FONT-SPECIFIER) (FD)
  (SETQ FD (TV:SCREEN-PARSE-FONT-DESCRIPTOR FD 'FONTS:GREY-FONT))
  (OR (GET (FONT-NAME FD) 'GREY-FONT)
      (SETQ FD (MAKE-GREY-FONT FD)))
  FD)

(DEFMETHOD (GREY-SCREEN :BLT-COLOR-MAP) (ARRAY)
  (LET ((HARDWARE-COLOR-MAP (GET
			      (LOCF (TV:SCREEN-PROPERTY-LIST SELF))
			      ':HARDWARE-COLOR-MAP))
	)
    (DOTIMES (I (ARRAY-DIMENSION HARDWARE-COLOR-MAP 0))
      (WRITE-COLOR-MAP
	I
	(FIX (ar-2-reverse ARRAY I 0))
	(FIX (ar-2-reverse ARRAY I 1))
	(FIX (ar-2-reverse ARRAY I 2))
	NIL
	SELF)
;        (AS-2-reverse (- 377 (FIX (AR-2-reverse ARRAY I 0))) HARDWARE-COLOR-MAP I 0)
;        (AS-2-reverse (- 377 (FIX (AR-2-reverse ARRAY I 1))) HARDWARE-COLOR-MAP I 1)
;        (AS-2-reverse (- 377 (FIX (AR-2-reverse ARRAY I 2))) HARDWARE-COLOR-MAP I 2)
      )
;      (LMGREY-BLT-COLOR-MAP-TO-HARDWARE HARDWARE-COLOR-MAP)
    ))

(defmethod (grey-screen :device-attached?) ()
  (grey-exists-and-if-so-downloaded-p))

(defmethod (grey-screen :WRITE-COLOR-MAP) (LOC R G B &OPTIONAL (SYNCHRONIZE NIL))
  (write-color-map loc r g b synchronize self))

(defmethod (grey-screen :read-color-map) (loc)
  (READ-COLOR-MAP LOC self))

(DEFUN LMGREY-BLT-COLOR-MAP-TO-HARDWARE (MAP)
  (DOTIMES (I (ARRAY-DIMENSION MAP 0))
    (WRITE-COLOR-MAP-IMMEDIATE I (AR-2-reverse MAP I 0)
			       (Ar-2-reverse MAP I 1) (AR-2-reverse MAP I 2))))

(DEFUN PRINT-MAP (MAP)
  (DOTIMES (I (ARRAY-DIMENSION MAP 0))
    (FORMAT T "~%~S,~S,~S"
	    (AR-2-reverse MAP I 0) (AR-2-reverse MAP I 1) (AR-2-reverse MAP I 2))))

(DEFUN REINITIALIZE-SCREEN ()
  (select si:processor-type-code
    (si:cadr-type-code (USE-DIRECT))
    (si:lambda-type-code (use-lam-direct)))
  (INIT)
  (START)
  (KILL-SCREENS)
  (SCREEN-INITIALIZE)
  (SETQ GREY-ARRAY (GET-GREY-SCREEN-ARRAY))
  (SETQ GREY-ARRAY0 (GET-GREY-SCREEN-ARRAY0))
  (SETQ GREY-ARRAY1 (GET-GREY-SCREEN-ARRAY1))
  (SETQ GREY-ARRAY2 (GET-GREY-SCREEN-ARRAY2))
  (SETQ GREY-ARRAY3 (GET-GREY-SCREEN-ARRAY3))
  (SETQ GREY-ARRAY4 (GET-GREY-SCREEN-ARRAY4))
  (SETQ GREY-ARRAY5 (GET-GREY-SCREEN-ARRAY5))
  (SETQ GREY-ARRAY6 (GET-GREY-SCREEN-ARRAY6))
  (SETQ GREY-ARRAY7 (GET-GREY-SCREEN-ARRAY7))
  (STRAIGHT-MAP))


(COMPILE-FLAVOR-METHODS GREY-SCREEN GREY-SCREEN-PLANE)

(DEFUN CREATE-USEFUL-GREY-FONTS ()
  (DOLIST (A-FONT-NAME 'FONTS:(HL12I MEDFNT MOUSE SEARCH CPTFONT 5X5))
    ;; list determined by calling (FIND-GREY-FONTS-CREATED)
    ;; after making and running windows (make-instance x ':superior grey-screen)
    ;; for x = tv:lisp-listener and zwei:zmacs-frame and putting the mouse and
    ;; a system menu on the grey screen.
    (OR (GET A-FONT-NAME 'FONTS:GREY-FONT)
	(MAKE-GREY-FONT (SYMEVAL A-FONT-NAME)))))

(IF (EQ SI:PROCESSOR-TYPE-CODE SI:LAMBDA-TYPE-CODE)
    (CREATE-USEFUL-GREY-FONTS))

(DEFVAR FIND-GREY-FONTS-CREATED NIL)

(DEFUN FIND-GREY-FONTS-CREATED ()
  (SETQ FIND-GREY-FONTS-CREATED NIL)
  (MAPATOMS #'(LAMBDA (X)
		(IF (GET X 'FONTS:GREY-FONT)
		    (PUSH X FIND-GREY-FONTS-CREATED)))
	    "FONTS")
  FIND-GREY-FONTS-CREATED)