-*-Mode:LISP;Package:Color-*-
(special direction-vector increment-vector)
(setq direction-vector (make-array nil 'art-q '(16. 3)))
(setq increment-vector '(1 1 1))

(defun vary-color-map ()
      (do ((red)
	   (green)
	   (blue)
	   (color-list))
	  ((kbd-tyi-no-hang))
	(do i 0 (1+ i) (= i 16.)
	    (multiple-value (red green blue)
	      (read-color-map i))
	    (setq color-list (list red green blue))
	    (setq color-list (mapcar '(lambda (index value)
					      (increment-color i index value))
				     '(0 1 2) color-list))
	    (write-color-map i (car color-list) (cadr color-list) (caddr color-list)))))

(defun increment-color (color index value)
      (cond ((aref direction-vector color index)
	     (cond ((> (+ value (nth index increment-vector)) 377)
		    (aset nil direction-vector color index)
		    value)
		   (t (+ value (nth index increment-vector)))))
	    (t (cond ( (< (- value (nth index increment-vector)) 0)
		      (aset t direction-vector color index)
		      value)
		     (t (- value (nth index increment-vector)))))))

(defun vary-gray ()
      (do ()
	  ((kbd-tyi-no-hang))
	(do ((i 0 (1+ i)))
	    ((= i 200))
	  (gray-color-map i))))

(special saved-color)

(defun exchange-color (i &aux red green blue)
      (multiple-value (red green blue) (read-color-map i))
      (write-color-map i (car saved-color) (cadr saved-color) (caddr saved-color))
      (setq saved-color (list red green blue)))

(defun cycle-once (&aux red green blue (tv-adr (screen-control-address tv-color-screen)))
      (prog nil a (cond ((greaterp (logand 40 (%xbus-read tv-adr)) 0)
			 (return nil)))(go a))
      (multiple-value (red green blue) (read-color-map 0))
      (setq saved-color (list red green blue))
      (do i 15. (1- i) (= i 0)
	  (exchange-color i))
      (write-color-map 0 (car saved-color) (cadr saved-color) (caddr saved-color)))

(defun cycle-colors (&optional (n 0))
      (do () ((kbd-tyi-no-hang))
	(cycle-once)
	(process-sleep n)))

(defun shaded-color-map (&optional (r 1) (g 1) (b 1) (base 0))
       (do ((i 0 (1+ i))
            (level))
           ((= i 20))
           (setq level (\ (+ base (* 20 i)) 400))
           (write-color-map i (* level r) (* level g) (* level b))))