;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for MEDIUM-RESOLUTION-COLOR version 3.4
;;; Reason:
;;;  Remove calls to RETURN-ARRAY in COLOR-ZOOM and COLOR-GUARD.
;;; Written 10-Apr-86 15:04:10 by dg (Dave Goodine) at site LMI Cambridge
;;; while running on Maurice Ravel from band 3
;;; with Don't-dump-a-band! Experimental System 110.188, Experimental Lambda-Diag 7.3, Experimental Local-File 68.5, Experimental FILE-Server 18.3, Experimental Unix-Interface 9.1, Experimental ZMail 65.13, Inconsistent (unreleased patches loaded) Object Lisp 3.2, Experimental Tape 6.37, Experimental Site Data Editor 3.3, Experimental Tiger 24.0, Experimental KERMIT 31.3, Experimental Window-Maker 1.0, Experimental Gateway 4.6, Experimental TCP-Kernel 39.6, Experimental TCP-User 62.7, Experimental TCP-Server 45.5, Experimental MEDIUM-RESOLUTION-COLOR 3.1, Experimental MICRO-COMPILATION-TOOLS 3.2, microcode 1408, SDU ROM 102, Alpha III Working.


; From modified file DJ: L.VIDEO-DEVICE.GREY; COLXOR.LISP#1 at 10-Apr-86 15:04:14
#8R HACKS#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "HACKS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; COLXOR  "

	
(defun color-guard (&optional (snooze 0) (y 0)
		    &aux (map-values (make-array '(400 3)
						 ':type 'art-8b)))
      (do ((i 0 (1+ i))
	   (r) (g) (b))
	  (( i 400))
	(multiple-value (r g b) (COLOR:read-color-map i))
	(aset r map-values i 0)
	(aset g map-values i 1)
	(aset b map-values i 2))
      (do ((dr 0 (- (random 1020) 400))
	   (dg -404 (- (random 1020) 400))
	   (db  404 (- (random 1020) 400)))
	  ((funcall terminal-io ':tyi-no-hang))
	(do ((r (aref map-values y 0) (+ r dr))
	     (g (aref map-values y 1) (+ g dg))
	     (b (aref map-values y 2) (+ b db)))
	    ((bit-test (logior r g b) 400))
	  (do ((i snooze (1- i))) ((< i 0)))
	  (do ((i 377 (1- i))
	       (or) (og) (ob)
	       (r r or)
	       (g g og)
	       (b b ob))
	      ((< i y))
	    (setq or (aref map-values i 0) og (aref map-values i 1) ob (aref map-values i 2))
	    (aset r map-values i 0)
	    (aset g map-values i 1)
	    (aset b map-values i 2)
	    (grey:write-color-map-immediate i r g b)))))

))

; From modified file DJ: L.VIDEO-DEVICE.GREY; COLXOR.LISP#1 at 10-Apr-86 15:04:16
#8R HACKS#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "HACKS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; COLXOR  "


(defun color-zoom (&optional (z 0) &aux (map-values (make-array '(400 3)
								':type 'art-8b)))
      (do ((i 0 (1+ i))
	   (r) (g) (b))
	  (( i 400))
	(multiple-value (r g b) (COLOR:read-color-map i))
	(aset r map-values i 0)
	(aset g map-values i 1)
	(aset b map-values i 2))
      (do ((j 1)
	   (dr 0 (- (random 2000) 740))
	   (dg -404 (- (random 2000) 740))
	   (db 404 (- (random 2000) 740)))
	  ((funcall terminal-io ':tyi-no-hang))
	(do ((r (aref map-values j 0) (+ r dr))
	     (g (aref map-values j 1) (+ g dg))
	     (b (aref map-values j 2) (+ b db)))
	    ((bit-test (logior r g b) 400))
	  (setq j (logand (1- j) 377))
	  (do ((i j (logand (1- i) 377))
	       (r r) (g g) (b b)
	       (rr)  (gg)  (bb)
	       (k 0 (1+ k)))
	      ((= k 400))
	    (do ((i 0 (1+ i)))((> i z)))	;snooze
	    (setq rr (aref map-values i 0)
		  gg (aref map-values i 1)
		  bb (aref map-values i 2))
	    (aset r map-values i 0)
	    (aset g map-values i 1)
	    (aset b map-values i 2)
	    (setq r (ash (+ r (* 760 rr) 405) -5)
		  g (ash (+ g (* 760 gg) 405) -5)
		  b (ash (+ b (* 760 bb) 405) -5)))
	  (COLOR:blt-color-map map-values))))

))