;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(CPTFONT); Patch-file:T -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; V-ATTRACTION
;;;

;;; V-ATTRACTION
;;; A number of attractive/repulsive balls.  Needs to have a special font loaded.
;;; Also by pz@hx.lcs.mit.edu.
;;; Copyright (C) 1988, 1989 by John S. Pezaris.  All rights reserved.
;;;
;;; Changed to Van Der Walls force.

(unless (boundp 'fonts:balls-16)
  (load "rts-23:fonts;balls-16" :verbose nil))

(unless (boundp 'orb-list)        (defvar orb-list nil))
(unless (boundp 'orb-list-length) (defvar orb-list-length nil))
(unless (boundp 'orb-font)        (defvar orb-font fonts:cptfont))

(pushnew 'v-attraction *screen-saver-hacks-list*)

(defun v-attraction (&optional (stream *terminal-io*) (length 5) (times nil)
		     (max-size 16))
  "Van Der Walls Attraction"

  (macrolet
    ((x-acc (orb) `(first  ,orb))
     (y-acc (orb) `(second ,orb))
     (x-vel (orb) `(third  ,orb))
     (y-vel (orb) `(fourth ,orb))
     (x-pos (orb) `(fifth  ,orb))
     (y-pos (orb) `(sixth  ,orb))
     (mass  (orb) `(seventh ,orb))
     (size  (orb) `(eighth  ,orb))
     (x-pix (orb xlim) `(min ,xlim (max 0 (floor (+ (/ ,xlim 2.) (* 2 (x-pos ,orb)))))))
     (y-pix (orb ylim) `(min ,ylim (max 0 (floor (+ (/ ,ylim 2.) (* 2 (y-pos ,orb)))))))
     (increment (place value)
		"increment a value"
		(declare (arglist place value &key test test-not key))
		(let ((pl (gensym))
		      (val (gensym)))
		  (si:sublis-eval-once `((,val . ,value))
				       (si:sublis-eval-once `((,pl . ,place))
							    `(values (setf ,place (+ ,pl ,val))))))))

  
  (multiple-value-bind (xlim ylim)
      (send stream :inside-size)
    
    (let* ((xlim/2 (/ xlim 4))
	   (ylim/2 (/ ylim 4))
	   (-xlim/2 (* -1.0 xlim/2))
	   (-ylim/2 (* -1.0 ylim/2)))
      
      (let* ((diameter (- (min xlim/2 ylim/2) 50))
	     (o-list (progn
		       (if (not (and orb-list (= length orb-list-length)))
			   (progn
			     (setq orb-list-length length
				   orb-list (make-list orb-list-length))
			     (dotimes (n length)
			       (setf (nth n orb-list) (list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0)))))
		       (dotimes (n length)
			 (let ((new-size (min 16 (+ 8 (random (- max-size 9)))))
			       (orb (nth n orb-list)))
			   (setf (x-acc orb) 0.0)
			   (setf (y-acc orb) 0.0)
			   (setf (x-vel orb) (/ (- 3.0 (random 6.0)) 4.0))
			   (setf (y-vel orb) (/ (- 3.0 (random 6.0)) 4.0))
			   (setf (x-pos orb) (* diameter (cos (* n (/ (* 2.0 pi) length)))))
			   (setf (y-pos orb) (* diameter (sin (* n (/ (* 2.0 pi) length)))))
			   (setf (mass orb) (* 1.0 new-size new-size 5.0))
			   (setf (size orb) new-size)
			   ))
		       orb-list)))
	
	(send stream :clear-screen)
	
	(loop until (if times (= (setf times (1- times)) 0) NIL) do
	      (loop for orb in o-list do
		    ;; calculate attraction of this orb to the other orbs, this will set the x-acc and y-acc.
		    (let ((new-x-acc 0.0) (new-y-acc 0.0))
		      (loop for other-orb in o-list do
			    (if (not (eq orb other-orb))	; don't do it to yourself !!!
				(let* ((x-dist (- (x-pos other-orb) (x-pos orb)))
				       (y-dist (- (y-pos other-orb) (y-pos orb)))
				       (dist^2 (+ (* x-dist x-dist)
						  (* y-dist y-dist)))
				       (dist (sqrt dist^2))
				       (new-acc 0.0)
				       (new-acc/dist 0.0))
				  (if (> dist 0.1)
				      (progn
					(setq new-acc (- (/ (mass other-orb) (+ 1 dist^2))
							 (* (/ (mass other-orb) (max 0.001 (* dist^2 dist^2)))
							    10)))
					(setq new-acc/dist (/ new-acc dist))
					(increment new-x-acc (* new-acc/dist x-dist))
					(increment new-y-acc (* new-acc/dist y-dist))
					)
				      (progn
					(increment new-x-acc (- 3.0 (random 6.0)))
					(increment new-y-acc (- 3.0 (random 6.0)))
					)
				      )
				  ))
			    )
		      (setf (x-acc orb) new-x-acc)
		      (setf (y-acc orb) new-y-acc)
		      ))
	      
	      (loop for orb in o-list do
		    (let* ((old-x-pix (x-pix orb xlim))
			   (old-y-pix (y-pix orb ylim))
			   (new-x-pix 0)
			   (new-y-pix 0)
			   (orb-size (size orb)))
		      
		      ;; set the new velocities
		      (increment (x-vel orb) (x-acc orb))
		      (increment (y-vel orb) (y-acc orb))
		      
		      ;; make sure that if things get too fast, they slow down!
		      (if (< 3.0 (abs (x-vel orb)))
			  (progn
			    (setf (x-vel orb) (* (x-vel orb) 0.9))
			    (setf (x-acc orb) 0.0)))
		      
		      (if (< 3.0 (abs (y-vel orb)))
			  (progn
			    (setf (y-vel orb) (* (y-vel orb) 0.9))
			    (setf (y-acc orb) 0.0)))
		      
		      ;; set the new positions
		      (increment (x-pos orb) (x-vel orb))
		      (increment (y-pos orb) (y-vel orb))
		      
		      ;; check for maximum position in x direction
		      (if (<= (- xlim/2 max-size 4) (x-pos orb))
			  (progn
			    (setf (x-pos orb) (- xlim/2 max-size 5))
			    (setf (x-vel orb) (* -1.0 (max 0.1 (abs (x-vel orb))))))
			  (if (>= (+ -xlim/2 1) (x-pos orb))
			      (progn
				(setf (x-pos orb) (+ -xlim/2 2))
				(setf (x-vel orb) (* 1.0 (max 0.1 (abs (x-vel orb))))))))
		      
		      ;; check for maximum position in y direction
		      (if (<= (- ylim/2 max-size 4) (y-pos orb))
			  (progn
			    (setf (y-pos orb) (- ylim/2 max-size 5))
			    (setf (y-vel orb) (* -1.0 (max 0.1 (abs (y-vel orb))))))
			  (if (>= (+ -ylim/2 1) (y-pos orb))
			      (progn
				(setf (y-pos orb) (+ -ylim/2 2))
				(setf (y-vel orb) (* 1.0 (max 0.1 (abs (y-vel orb))))))))
		      
		      ;; calculate the new pixel position
		      (setq new-x-pix (x-pix orb xlim))
		      (setq new-y-pix (y-pix orb ylim))
		      
		      (tv:prepare-sheet (stream)
			(sys:%draw-character orb-font orb-size (+ 4 orb-size)	; erase
					     old-x-pix old-y-pix
					     tv:alu-xor stream)
			(sys:%draw-character orb-font orb-size (+ 4 orb-size)	; draw new orb
					     new-x-pix new-y-pix
					     tv:alu-xor stream)
			)
		      
		      )
		    )
	      ))
      )
    )
  )
  )