;;; -*- 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)
  (pushnew 'fireworks *screen-saver-hacks-list*))


(defstruct works
  (x-pos 0)
  (y-pos 0)
  (x-vel 0)
  (y-vel 0)
  (decay 0)
  (size  0)
  (fuse  0)
  (dead  t)
  )


;;; *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*))


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

(defun kill-work (work)
  (setf (works-dead work) t)
  (push work *free-works*)
  )


;;; unkill-work

(defun unkill-work (work)
  (setf (works-dead work) '())
  (pop *free-works*)
  )


;;; number-of-unused-works
;;;
;;; A simple interface.

(defun number-of-unused-works ()
  (length *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 empiracly chosen to provide a pleasing display on a full
;;; screen window.  It returns the new work.

(defun new-work (xlim ylim g)
  (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
		      (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-dead  w) '())
		      )
	    )
      (setf (works-y-vel w) (+ -13000 (random 4000)))
      (setf (works-fuse  w) (floor (/ (* (+ (random 500) 600) (abs (/ (works-y-vel w) g))) 1000)))
      )
    w)
  )


;;; new-sub-work
;;;
;;; 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.

(defun new-sub-work (old-work)
  (let ((out (find-unused-work)))
    (when out 
      (setf (works-x-pos out) (works-x-pos old-work))
      (setf (works-y-pos out) (works-y-pos old-work))
      (setf (works-x-vel out) (+ -2500 (random 5000) (works-x-vel old-work)))
      (setf (works-y-vel out) (+ -2500 (random 5000) (works-y-vel old-work)))
      (setf (works-decay out) (- -60 (random 50)))
      (setf (works-size  out) 6000)
      (setf (works-fuse  out) '())
      (setf (works-dead  out) '()))
    out))



;;; 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*) (reset? '()))
  (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 (or reset? (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))	; possibly create a new work.
	    
	    (loop for p in *fireworks-projectiles* do
		  (if (null (works-dead 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) (incf (works-fuse p) -1))
			
			;; 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))
			  (if (>= (number-of-unused-works) 3)	; are there enough for a minimal explosion?
			      (case processor-type
				(0 (loop repeat (+ 7  (random 10)) do (new-sub-work p)))
				(1 (loop repeat (+ 10 (random 20)) do (new-sub-work p))))
			      (progn
				(unkill-work p)			; restore it
				(setf (works-fuse p) 10))))
			)
		      
		      ;; Else clause (dummy)
		      (loop repeat 40)
		      
		      )
		  )
	    )
      )
    ))