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

;; 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. TK"
  `(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-screen-plane0)
(DEFVAR grey-screen-plane1)
(DEFVAR grey-screen-plane2)
(DEFVAR grey-screen-plane3)
(DEFVAR grey-screen-plane4)
(DEFVAR grey-screen-plane5)
(DEFVAR grey-screen-plane6)
(DEFVAR grey-screen-plane7)

(DEFVAR grey-screen-array)

(DEFVAR grey-screen-plane-array0)
(DEFVAR grey-screen-plane-array1)
(DEFVAR grey-screen-plane-array2)
(DEFVAR grey-screen-plane-array3)
(DEFVAR grey-screen-plane-array4)
(DEFVAR grey-screen-plane-array5)
(DEFVAR grey-screen-plane-array6)
(DEFVAR grey-screen-plane-array7)

;these kind of screens are pretty useless for the time being.
(DEFUN make-grey-screen (&optional
			 (layout ':portrait)	; portrait 454x576 or square 512x512
			 (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)  		;tk
						
	 (setq tv:all-the-screens (delq grey-screen tv:all-the-screens))
	 (makunbound 'grey-screen)))
  (makunbound 'grey-screen-array)

  (cond ((boundp 'grey-screen-plane0)
	 (setq tv:all-the-screens (delq grey-screen-plane0 tv:all-the-screens))
	 (makunbound 'grey-screen-plane0)))
  (makunbound 'grey-screen-plane-array0)

  (cond ((boundp 'grey-screen-plane1)
	 (setq tv:all-the-screens (delq grey-screen-plane1 tv:all-the-screens))
	 (makunbound 'grey-screen-plane1)))
  (makunbound 'grey-screen-plane-array1)

  (cond ((boundp 'grey-screen-plane2)
	 (setq tv:all-the-screens (delq grey-screen-plane2 tv:all-the-screens))
	 (makunbound 'grey-screen-plane2)))
  (makunbound 'grey-screen-plane-array2)

  (cond ((boundp 'grey-screen-plane3)
	 (setq tv:all-the-screens (delq grey-screen-plane3 tv:all-the-screens))
	 (makunbound 'grey-screen-plane3)))
  (makunbound 'grey-screen-plane-array3)

  (cond ((boundp 'grey-screen-plane4)
	 (setq tv:all-the-screens (delq grey-screen-plane4 tv:all-the-screens))
	 (makunbound 'grey-screen-plane4)))
  (makunbound 'grey-screen-plane-array4)

  (cond ((boundp 'grey-screen-plane5)
	 (setq tv:all-the-screens (delq grey-screen-plane5 tv:all-the-screens))
	 (makunbound 'grey-screen-plane5)))
  (makunbound 'grey-screen-plane-array5)

  (cond ((boundp 'grey-screen-plane6)
	 (setq tv:all-the-screens (delq grey-screen-plane6 tv:all-the-screens))
	 (makunbound 'grey-screen-plane6)))
  (makunbound 'grey-screen-plane-array6)

  (cond ((boundp 'grey-screen-plane7)
	 (setq tv:all-the-screens (delq grey-screen-plane7 tv:all-the-screens))
	 (makunbound 'grey-screen-plane7)))
  (makunbound 'grey-screen-plane-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-plane-array0 ()
  (cond ((boundp 'grey-screen-plane-array0) grey-screen-plane-array0)
	(t (setq grey-screen-plane-array0 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane0) grey-screen-plane0)
					   (t (setq grey-screen-plane0 (make-plane-screen 0)))))))))

(DEFUN get-grey-screen-plane-array1 ()
  (cond ((boundp 'grey-screen-plane-array1) grey-screen-plane-array1)
	(t (setq grey-screen-plane-array1 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane1) grey-screen-plane1)
					   (t (setq grey-screen-plane1 (make-plane-screen 1)))))))))

(DEFUN get-grey-screen-plane-array2 ()
  (cond ((boundp 'grey-screen-plane-array2) grey-screen-plane-array2)
	(t (setq grey-screen-plane-array2 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane2) grey-screen-plane2)
					   (t (setq grey-screen-plane2 (make-plane-screen 2)))))))))

(DEFUN get-grey-screen-plane-array3 ()
  (cond ((boundp 'grey-screen-plane-array3) grey-screen-plane-array3)
	(t (setq grey-screen-plane-array3 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane3) grey-screen-plane3)
					   (t (setq grey-screen-plane3 (make-plane-screen 3)))))))))

(DEFUN get-grey-screen-plane-array4 ()
  (cond ((boundp 'grey-screen-plane-array4) grey-screen-plane-array4)
	(t (setq grey-screen-plane-array4 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane4) grey-screen-plane4)
					   (t (setq grey-screen-plane4 (make-plane-screen 4)))))))))

(DEFUN get-grey-screen-plane-array5 ()
  (cond ((boundp 'grey-screen-plane-array5) grey-screen-plane-array5)
	(t (setq grey-screen-plane-array5 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane5) grey-screen-plane5)
					   (t (setq grey-screen-plane5 (make-plane-screen 5)))))))))

(DEFUN get-grey-screen-plane-array6 ()
  (cond ((boundp 'grey-screen-plane-array6) grey-screen-plane-array6)
	(t (setq grey-screen-plane-array6 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane6) grey-screen-plane6)
					   (t (setq grey-screen-plane6 (make-plane-screen 6)))))))))

(DEFUN get-grey-screen-plane-array7 ()
  (cond ((boundp 'grey-screen-plane-array7) grey-screen-plane-array7)
	(t (setq grey-screen-plane-array7 (tv:sheet-screen-array
				     (cond ((boundp 'grey-screen-plane7) grey-screen-plane7)
					   (t (setq grey-screen-plane7 (make-plane-screen 7)))))))))

(DEFUN screen-initialize nil
  (cond ((not (boundp 'grey-screen))
	 (select-processor 
	   (:cadr (use-direct))
	   ((:lambda :explorer) (use-lam-direct)))
	 (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))

(DEFMETHOD (grey-screen :write-color-map-immediate) (loc r g b)
  (write-color-map-immediate loc r g b))

(DEFUN lmgrey-blt-color-map-to-hardware (map)
  "This function does not update the property :hardware-color-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-processor
    (:cadr (use-direct))
    ((:lambda :explorer) (use-lam-direct)))
  (init)
  (start)
  (kill-screens)
  (screen-initialize)
  (setq grey-screen-array (get-grey-screen-array))
  (setq grey-screen-plane-array0 (get-grey-screen-plane-array0))
  (setq grey-screen-plane-array1 (get-grey-screen-plane-array1))
  (setq grey-screen-plane-array2 (get-grey-screen-plane-array2))
  (setq grey-screen-plane-array3 (get-grey-screen-plane-array3))
  (setq grey-screen-plane-array4 (get-grey-screen-plane-array4))
  (setq grey-screen-plane-array5 (get-grey-screen-plane-array5))
  (setq grey-screen-plane-array6 (get-grey-screen-plane-array6))
  (setq grey-screen-plane-array7 (get-grey-screen-plane-array7))
  (straight-map))


(COMPILE-FLAVOR-METHODS grey-screen grey-screen-plane)

(DEFUN create-useful-grey-fonts ()
  (format t "Creating various special 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)))))

(select-processor
  (:cadr)
  ((:lambda :explorer)
   (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)


;;;

(DEFMETHOD (GREY-SCREEN :MOUSEBUTTON-GRAB-FRAME) (&OPTIONAL (CHAN 0) (MASK 0) (SCAN-MODE NIL) (EXT-SYNC NIL))
  (IF (NOT SCAN-MODE)					;test SCAN-MODE flag
      (COND ((NOT EXT-SYNC)
	     (WRITE-MODE (DPB CHAN 1402 44000201))	;Enter FG MODE
	     (PROCESS-SLEEP 3)
	     (LOOP WHILE (NOT (ZEROP (TV:MOUSE-BUTTONS))))
	     (WRITE-MODE (DPB CHAN 1402 44000241)))	;Back to TV MODE
	    (T
	     (WRITE-MODE (DPB MASK 3010
			      (DPB CHAN 1402 44001202)));Enter FG MODE, externally sync'ed
	     (PROCESS-SLEEP 3)
	     (LOOP WHILE (NOT (ZEROP (TV:MOUSE-BUTTONS))))
	     (WAIT-FOR-VSYNC)
	     (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			      (DPB CHAN 1402 44001242)));and still masked.
	     (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	     (WRITE-MODE (DPB CHAN 1402 44001242))))	;clear mask field.
    
    (COND ((NOT EXT-SYNC)				;SCAN-MODE flag is set
	   (WRITE-MODE (DPB CHAN 1402 44100201))	;Enter FG MODE
	   (PROCESS-SLEEP 3)
	   (LOOP WHILE (NOT (ZEROP (TV:MOUSE-BUTTONS))))
	   (WRITE-MODE (DPB CHAN 1402 44100241)))	;Back to TV MODE
	  (T
	   (WRITE-MODE (DPB MASK 3010
			    (DPB CHAN 1402 44101202)))	;Enter FG MODE, externally sync'ed
	   (PROCESS-SLEEP 3)
	   (LOOP WHILE (NOT (ZEROP (TV:MOUSE-BUTTONS))))
	   (WAIT-FOR-VSYNC)
	   (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			    (DPB CHAN 1402 44101242)))	;and still masked.
	   (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	   (WRITE-MODE (DPB CHAN 1402 44101242))))))	;clear mask field.

(DEFMETHOD (GREY-SCREEN :GRAB-FRAME-NOW) (&OPTIONAL (CHAN 0) (MASK 0) (SCAN-MODE NIL) (EXT-SYNC NIL))
  (IF (NOT SCAN-MODE)					;test SCAN-MODE flag
      (COND ((NOT EXT-SYNC)
	     (WRITE-MODE (DPB CHAN 1402 44000201))	;Enter FG MODE
	     (PROCESS-SLEEP 3)
	     (WRITE-MODE (DPB CHAN 1402 44000241)))	;Back to TV MODE
	    (T
	     (WRITE-MODE (DPB MASK 3010
			      (DPB CHAN 1402 44001202)));Enter FG MODE, externally sync'ed
	     (PROCESS-SLEEP 3)
	     (WAIT-FOR-VSYNC)
	     (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			      (DPB CHAN 1402 44001242)));and still masked.
	     (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	     (WRITE-MODE (DPB CHAN 1402 44001242))))	;clear mask field.
    
    (COND ((NOT EXT-SYNC)				;SCAN-MODE flag is set
	   (WRITE-MODE (DPB CHAN 1402 44100201))	;Enter FG MODE
	   (PROCESS-SLEEP 3)
	   (WRITE-MODE (DPB CHAN 1402 44100241)))	;Back to TV MODE
	  (T
	   (WRITE-MODE (DPB MASK 3010
			    (DPB CHAN 1402 44101202)))	;Enter FG MODE, externally sync'ed
	   (PROCESS-SLEEP 3)
	   (WAIT-FOR-VSYNC)
	   (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			    (DPB CHAN 1402 44101242)))	;and still masked.
	   (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	   (WRITE-MODE (DPB CHAN 1402 44101242))))))	;clear mask field.

(DEFMETHOD (GREY-SCREEN :LOAD-COLORMAP-FALSE-COLOR-ODD) ()
  (DOTIMES (I 256.)
    (IF (ZEROP (LOGAND I 1))
	(WRITE-COLOR-MAP I I I I NIL SELF)
        (COND ((LESSP I 128.)
	       (WRITE-COLOR-MAP I (+ 128.  I) (* I 2) (MAX (- I 64.) 0) NIL SELF))
	      ((LESSP I 192.)
	       (WRITE-COLOR-MAP I (- 384. I) 255. (- I 64.) NIL SELF))
	      (T
	       (WRITE-COLOR-MAP I (- 384. I) 255. (- I 64.) NIL SELF))))))

(DEFVAR *FILING-ARRAY* NIL "FOR LOADING AND SAVING IMAGES; THEY SHOULD ALWAYS BE `FASD'ED AS THIS SYMBOL")

(DEFMETHOD (GREY-SCREEN :LOAD) (FILE)
  (LET (*FILING-ARRAY*)
    (LOAD FILE)
    *FILING-ARRAY*))

(DEFMETHOD (GREY-SCREEN :SAVE) (ARRAY FILE)
  (LET ((*FILING-ARRAY* ARRAY))
    (COMPILER:FASD-SYMBOL-VALUE FILE '*FILING-ARRAY*)))

(defmethod (grey-screen :blt) (from to)
  (blt from to))

(defmethod (grey-screen :grab-frame) ()
  (grab-frame))