;;;-*- Mode:LISP; Package:USER; Fonts:(HL12 HL12I HL12BI); Base:10 -*-


(DEFUN P-DOCD-FUNCTIONS (PKG)
  (let ((package (pkg-find-package pkg)))
    (MAPATOMS #'(LAMBDA (X)
		  (IF (and (fboundp x) (DOCUMENTATION X))
		      (FORMAT STANDARD-OUTPUT
			      "~&~S~%~A~%~%~%"
			      (cons x (arglist x))
			      (DOCUMENTATION X))))
	      PKG NIL)))


(DEFUN 2P-DOCD-FUNCTIONS-FILE* (PKG FILE)
  (WITH-OPEN-FILE (STANDARD-OUTPUT FILE ':OUT) ;1 comment ?*
    (P-DOCD-FUNCTIONS PKG)))				;1 foo*



(defun 2chack-1* (&optional foo &aux alu)
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ()
	(nil)
      (color:color-draw-line 0 0 (random x-n) (random y-n) (random 256.)
			     alu))))


(defun 2chack-2* (&optional foo &aux alu)
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ((x0)(y0)(x1)(y1))
	(nil)
      (setq x0 (random x-n))
      (setq y0 (random y-n))
      (setq x1 (random x-n))
      (setq y1 (random y-n))
      (cond ((and (> x1 x0) (> y1 y0))
	     (color:rectangle x0 y0 (- x1 x0) (- y1 y0)
			      (random 256.)
			      alu))))))

(defun chack-3 (&optional foo &aux alu)
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ((x0)(y0)(x1)(y1))
	(nil)
      (setq x0 (random x-n))
      (setq y0 (random y-n))
      (setq x1 (+ x0 (random (- x-n x0))))
      (setq y1 (+ y0 (random (- y-n y0))))
      (cond ((and (> x1 x0) (> y1 y0))
	     (color:rectangle x0 y0 (- x1 x0) (- y1 y0)
			      (random 256.)
			      alu))))))


(defun chack-4 (&optional foo &aux alu)
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ((x0)(y0)(x1)(y1))
	(nil)
      (setq x0 (random x-n))
      (setq y0 (random y-n))
      (setq x1 (+ x0 (random (- x-n x0))))
      (setq y1 (+ y0 (random (- y-n y0))))
      (cond ((and (> x1 x0) (> y1 y0))
	     (color:rectangle x0 y0 (min (- x1 x0) 100.) (min (- y1 y0) 100.)
			      (random 256.)
			      alu))))))



;; (chack-5 ':random) is pretty nice. -gjc

(defun chack-5 (&optional foo &aux alu)
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ((x0)(y0)(x1)(y1))
	(nil)
      (setq x0 (random x-n))
      (setq y0 (random y-n))
      (setq x1 (+ x0 (random (- x-n x0))))
      (setq y1 (+ y0 (random (- y-n y0))))
      (cond ((and (> x1 x0) (> y1 y0))
	     (color:rectangle x0 y0
			      (min (- x1 x0) (random 100.))
			      (min (- y1 y0) (random 100.))
			      (random 256.)
			      (if (eq foo ':random)
				  (random 15.)
				alu)))))))

(defvar *cmap* (make-array (list (^ 2 8.) 3) ':type 'art-8b))

(defun random-color-map ()
  (do ((j 0 (1+ j))
        (m (^ 2 8.))
        (n (^ 2 8.)))
       ((= j n))
    (grey:write-color-map j (random m) (random m) (random m))))


(defun random-color-map-1 ()
  (do ((j 0 (1+ j))
        (m (^ 2 8.))
        (n (^ 2 8.)))
       ((= j n))
    (setf (aref *cmap* j 0) (random m)) ; R
    (setf (aref *cmap* j 1) (random m)) ; G
    (setf (aref *cmap* j 2) (random m)) ; B
    )
  (send color:color-screen ':blt-color-map *cmap*))

(defun random-color-map-2 ()
  (do ((j 0 (1+ j))
        (m (^ 2 8.))
        (n (^ 2 8.)))
       ((= j n))
    (grey:write-color-map-immediate j (random m) (random m) (random m))))


(defun chack-6 (&aux (mod 300) alu (foo :random))
  (setq alu (if foo 5 tv:alu-xor))
  (color:clear)
  (color:spectrum-color-map)
  (multiple-value-bind (x-n y-n)
      (send color:color-screen ':size)
    (do ((x0)(y0)(x1)(y1)(j 0 (1+ j)))
	(nil)
      (if (zerop (remainder j mod)) (random-color-map-1))
      (setq x0 (random x-n))
      (setq y0 (random y-n))
      (setq x1 (+ x0 (random (- x-n x0))))
      (setq y1 (+ y0 (random (- y-n y0))))
      (cond ((and (> x1 x0) (> y1 y0))
	     (color:rectangle x0 y0
			      (min (- x1 x0) (random 100.))
			      (min (- y1 y0) (random 100.))
			      (random 256.)
			      (if (eq foo ':random)
				  (random 15.)
				alu)))))))