;;; -*- Mode:Common-Lisp; Package:TV; Base:10 -*-
;;;
;;; fireworks
;;;
;;; A whimsical screen saver loosely based upon Pyro, a program available for Apple MacIntosh computers.
;;;
;;; jsp 27-April-88



;;; To install fireworks onto the list of possible screen-savers, we evaluate the next line:
;(eval-when (load)
;  (push 'fireworks *screen-saver-hacks-list*))


(defstruct works
  (x-pos  0)		; The work's present x-position (in pixels time 1024)
  (y-pos  0)		; ditto for y-position
  (x-vel  0)		; and x-velocity (in pixels/iteration)
  (y-vel  0)		; ditto
  (decay  0)		; the decay-rate for the work size
  (subs   0)		; the number of sub-works reserved
  (size   0)		; the current drawing size of the work
  (fuse   0)		; countdown for explosion
  (status 0)		; 0 => dead, -1 => reserved, 1 => live
  )


;;; *fireworks-projectiles* and *free-works*
;;;
;;; These two lists contain the objects (works) for the system.  *fireworks-projectiles* contains all of the
;;; works being simulated.  *free-works* contains a subset of *fireworks-projectiles*, specifically all works
;;; which are currently idle (not being simulated or displayed).

(defvar *fireworks-projectiles* '())

(defvar *free-works* '())


;;; find-unused-work
;;;
;;; This returns an idle work, if any are available, by popping one off of the *free-works* list.

(defun find-unused-work ()
  (pop *free-works*))


;;; find-reserved-work
;;;
;;; This returns a reserved work.  Anytime this is called, there should be an appropriate number availble.

(defun find-reserved-work ()
  (loop for w in *fireworks-projectiles* do
	(if (minusp (works-status w))
	    (return w))))



;;; number-of-unused-works
;;;
;;; This returns the length of the free list.

(defun number-of-unused-works ()
  (length *free-works*))



;;; kill-work
;;;
;;; This kills a work by setting the works-status field, and pushes it onto the free list.

(defun kill-work (work)
  (setf (works-status work) 0)
  (push work *free-works*)
  )


;;; new-work
;;;
;;; This attempts to create a new projectile for simulation.  If one is available, it sets the initial parameters
;;; which have been empiricly chosen to provide a pleasing display on a full screen window.  It returns the new
;;; work.

(defun new-work (xlim ylim g processor-type)
  ;; First step, make sure that there are enough available works on the free list.  If not, then do nothing.
  (let ((works-necessary (1+ (case processor-type
			       (0 (+ 7  (random 10)))
			       (1 (+ 10 (random 20)))))))

    (format t "  ~d(~d)" works-necessary (number-of-unused-works))

    ;; When there are enough free works, go at it!
    (when (>= (number-of-unused-works) works-necessary)
      
      (format t "!")

      (let ((w (find-unused-work)))
	(when w
	  (loop for x-pos = (random xlim)
		as x-vel = (- 30000 (random 60000))
		as xxx   = (+ x-pos (* x-vel 200))
		until (and (< 0 xxx) (< xxx xlim))
		finally (progn
			  ;; Set the parameters of the new work
			  (setf (works-x-pos  w) x-pos)
			  (setf (works-y-pos  w) ylim)
			  (setf (works-x-vel  w) x-vel)
			  (setf (works-size   w) 8000)
			  (setf (works-decay  w) 0)
			  (setf (works-status w) 1)
			  (setf (works-subs   w) (1- works-necessary))
			  ;; And reserve the appropriate sub-works
			  (loop repeat works-necessary do
				(let ((w (find-unused-work)))
				  (when w
				    (setf (works-status w) -1)))))	; reserve the subworks
		)
	  (setf (works-y-vel w) (+ -13000 (random 4000)))
	  (setf (works-fuse  w) (floor (/ (* (+ (random 500) 600) (abs (/ (works-y-vel w) g))) 1000)))
	  ))
    )))


;;; new-sub-works
;;;
;;; This performs much the same function as new-work, except the initial parameters are linked to the original
;;; projectile, and were chosen to provide a nice splash pattern.  Also, it looks for reserved works, rather than
;;; free works.

(defun new-sub-works (old-work)
  (loop repeat (works-subs old-work) do
	(let ((w (find-reserved-work)))
	  (when w 
	    (setf (works-x-pos  w) (works-x-pos old-work))
	    (setf (works-y-pos  w) (works-y-pos old-work))
	    (setf (works-x-vel  w) (+ -2500 (random 5000) (works-x-vel old-work)))
	    (setf (works-y-vel  w) (+ -2500 (random 5000) (works-y-vel old-work)))
	    (setf (works-decay  w) (- -60 (random 50)))
	    (setf (works-size   w) 6000)
	    (setf (works-fuse   w) '())
	    (setf (works-status w) 1))
	  )))
  


;;; fireworks
;;;
;;; This is the main simulation function.  It cycles indefinitely through the active works list *fireworks-projectiles*
;;; simulating each in turn.  If a work is primary (launched from the ground), then it has a non-null FUSE field which
;;; is decremented at each simulation step, and once it crosses zero, the work explodes into a collection of sub-works.
;;; This creates a pleasing splash which mimics a real fireworks display.  Figues are computed with integers (fixnums or
;;; bignums) with a false scaling factor of 1000.  This is because computing with integers combined with the necessary
;;; scaling is much faster than computing with floating-points and converting into integers.  The actual scaling factor
;;; is 1024, which makes normalization simple.  Works are drawn as squares (much faster than arbitrary glyphs), and
;;; sub-works (explosion fragments) die out by incrementing their SIZE field by their DECAY field at each simulation
;;; step.  If a work either explodes or dies out, simulation ceases for that work, and its data structure becomes available
;;; for another work.
;;;
;;; There is a balance between the spawning rate for new works, the fragmentation number, and the number of work structures
;;; available in *fireworks-projectiles* for simulation.  If these numbers are not in proper balance, the display appears
;;; empty, slow, etc.

(defun fireworks (&optional (stream *terminal-io*))
  (let* ((processor-name (si:get-processor-name))
	 (processor-type (cond ((equal processor-name "Explorer I")  0)
			       ((equal processor-name "Explorer II") 1))))
    (send stream :clear-screen)
    (if (null *fireworks-projectiles*)
	(case processor-type
	  (0 (setq *fireworks-projectiles* (loop repeat  40 collecting (make-works))))
	  (1 (setq *fireworks-projectiles* (loop repeat 100 collecting (make-works))))))
    (setq *free-works* '())
    (loop for p in *fireworks-projectiles* do (kill-work p))
    
    (let ((g 100) (xlim) (ylim) (real-xlim) (real-ylim))
      
      (multiple-value-setq (real-xlim real-ylim)
	(send stream :inside-size))
      (setq xlim (* real-xlim 1000))
      (setq ylim (* real-ylim 1000))
      
      (loop do
	    
	    (if (= 0 (random 30)) (new-work xlim ylim g processor-type))	; possibly create a new work.
	    
	    (loop for p in *fireworks-projectiles* do
		  (if (plusp (works-status p))
		      (let ((old-x    (lsh (works-x-pos p) -10))
			    (old-y    (lsh (works-y-pos p) -10))
			    (old-size (lsh (works-size  p) -10))
			    (size     (lsh (incf (works-size  p) (works-decay p)) -10))
			    (x-pos    (lsh (incf (works-x-pos p) (works-x-vel p)) -10))
			    (y-pos    (lsh (incf (works-y-pos p) (works-y-vel p)) -10))
			    )
			
			(incf (works-y-vel p) (lsh (works-size p) -6))	; the effects of gravity
			(if (works-fuse p) (decf (works-fuse p)))
			
			;; And draw it
			(tv:prepare-sheet (stream)
			  ;; Erase old image
			  (sys:%draw-rectangle
			    old-size old-size
			    old-x old-y
			    tv:alu-setz stream)
			  
			  ;; If alive, then display new image.
			  (if (and (or (and (works-fuse p) (< 0 (works-fuse p)))
				       (and (null (works-fuse p)) (< 0 (works-size p))))
				   (< x-pos real-xlim)
				   (< 0 x-pos)
				   (< y-pos real-ylim)
				   (< 0 y-pos))
			      
			      (sys:%draw-rectangle
				size size
				x-pos y-pos
				tv:alu-seta stream)
			      
			      ;; If expired, then kill projectile.
			      (kill-work p)))
			
			;; Fragmentation after explosion.
			(when (and (works-fuse p)
				   (<= (works-fuse p) 0))
			  (new-sub-works p))

			)
		      
		      ;; Else clause (dummy)
		      (loop repeat 40)
		      
		      )
		  )
	    )
      )
    ))