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

(defsubst 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.

(defsubst kill-work (work)
  (setf (works-dead work) t)
  (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 empiracly chosen to provide a pleasing display on a full screen window.  It returns the new
;;; work.

(defsubst 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.

(defsubst 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*))

  (send stream :clear-screen)
  (if (null *fireworks-projectiles*) (setq *fireworks-projectiles* (loop repeat 40 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)
			  ;; We're simulating a primary work.
			  (progn
			    (incf (works-fuse p) -1)		; shorten the fuse

			    ;; Erase old image, and draw new one
			    (tv:prepare-sheet (stream)
			      (sys:%draw-rectangle old-size old-size old-x old-y tv:alu-setz stream)
			      (sys:%draw-rectangle size     size     x-pos y-pos tv:alu-seta stream))
				  
			    ;; If expired, then kill projectile.
			    (when (<= (works-fuse p) 0)
			      (tv:prepare-sheet (stream)	; Erase new image
				(sys:%draw-rectangle size size x-pos y-pos tv:alu-setz stream))
			      (kill-work p)			; Kill work
			      ;; Fragmentation after explosion.
			      (loop repeat (+ 7 (random 10)) do (new-sub-work p))))

			  ;; We're simulating a sub-work.
			  (progn
			    ;; If expired, then kill projectile.
			    (when (<= size 0)
			      (kill-work p)
			      (setq size 0))

			    ;; Erase old image and draw new one.
			    (w:with-clipping-rectangle (0 0 real-xlim real-ylim)
			      (tv:prepare-sheet (stream)
				(sys:%draw-rectangle old-size old-size old-x old-y tv:alu-setz stream)
				(sys:%draw-rectangle size     size     x-pos y-pos tv:alu-seta stream)))

			    ))

		      )
		    
		    ;; Else clause for dead works.
		    (loop repeat 40)
		    
		    )
		)
	  )
    )
  )