;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(CPTFONT); Patch-file:T -*-
;;;
;;;
;;; TWINKLE
;;;
;;; This shows a screen of 1000 twinkling stars.
;;;
;;; 28 September 1987 pz.  The structure follows along the lines of QIX.
;;; Revised 22 November 1989, pz.  Structure cleaner.
;;;
;;; Copyright (C) 1988, 1989 by John S. Pezaris.  All rights reserved.


(pushnew 'twinkle *screen-saver-hacks-list*)


(defvar *star-vector* '())

(defstruct star
  (x-pos 0 :type fixnum)
  (y-pos 0 :type fixnum)
  (size  0 :type fixnum)
  )

(defconstant exp1  (exp 1))
(defconstant exp2  (exp 2))
(defconstant exp3  (exp 3))
(defconstant exp4  (exp 4))
(defconstant exp5  (exp 5))
(defconstant exp6  (exp 6))
(defconstant exp7  (exp 7))
(defconstant exp8  (exp 8))
(defconstant exp9  (exp 9))
(defconstant exp10 (exp 10))
(defconstant exp11 (exp 11))
(defconstant exp12 (exp 12))
(defconstant exp13 (exp 13))
(defconstant exp14 (exp 14))
(defconstant exp15 (exp 15))

(defmacro new-star (s xlim ylim max-size)
  `(progn
     (setf (star-x-pos ,s) (random (- ,xlim ,max-size)))
     (setf (star-y-pos ,s) (random (- ,ylim ,max-size)))
     (setf (star-size  ,s) (- max-size
			      (let ((m (+ 1 (random exp-max-size))))
				(cond ((> m exp15) 15) ((> m exp14) 14)
				      ((> m exp13) 13) ((> m exp12) 12)
				      ((> m exp11) 11) ((> m exp10) 10)
				      ((> m  exp9)  9) ((> m  exp8)  8)
				      ((> m  exp7)  7) ((> m  exp6)  6)
				      ((> m  exp5)  5) ((> m  exp4)  4)
				      ((> m  exp3)  3) ((> m  exp2)  2)
				      ((> m  exp1)  1) (t 1)))))
     ))


(defun twinkle (&optional (stream *terminal-io*) (reset? '()) (n 1000) (max-size 15))
  "Non-consing TWINKLE.  Revised to use vectors!"
  
  (let ((exp-max-size (floor (exp max-size)))
	(xlim 0)
	(ylim 0))
    
    (send stream :clear-screen)
    (multiple-value-setq (xlim ylim)
      (send stream :inside-size))
    
    (when (or reset?
	      (null *star-vector*)
	      (/= n (length *star-vector*)))
      (setq *star-vector*
	    (apply #'vector (loop repeat n collecting (make-star))))
      (map '() #'(lambda (s) (new-star s xlim ylim max-size)) *star-vector*)
      )
    
    (loop do
	  (map '()
	       #'(lambda (s)
		   ;; Erase current placement
		   (tv:prepare-sheet (stream)
		     (sys:%draw-rectangle
		       (star-size s) (star-size s)
		       (star-x s) (star-y s)
		       tv:alu-setz stream))
		   
		   ;; Create a new position
		   (new-star s xlim ylim max-size)
		   
		   ;; And draw it
		   (tv:prepare-sheet (stream)
		     (sys:%draw-rectangle
		       (star-size s) (star-size s)
		       (star-x s) (star-y s)
		       tv:alu-seta stream))
		   )
	       *star-vector*)))
  )