;;; -*- Mode:Common-Lisp; Package:TV; Base:10 -*-
;;;
;;; swarm
;;;
;;; This displays a swarm of objects.
;;;
;;; jsp 28-May-89
;;;
;;; (c) John S. Pezaris 1989.  All rights reserved.


;;; Same font as used by ATTRACTION, for now.

(unless (boundp 'fonts:bugs)
  (load "pz:fonts;bugs" :verbose nil))

(defvar *bugs-font* fonts:bugs)

;(pushnew 'swarm *screen-saver-hacks-list*)

(defstruct (bug (:print-function print-bug))
  (num   0)
  (x-pos 0)
  (y-pos 0)
  (x-vel 0)
  (y-vel 0)
  (glyph  0)
  (neighbors '())
  )


(defun print-bug (b ignore ignore)
  (format t "<Bug ~d (~s, ~s) [~s, ~s] #s"
	  (bug-num b)
	  (bug-x-pos b) (bug-y-pos b)
	  (bug-x-vel b) (bug-y-vel b))
  (loop for bb in (bug-neighbors b) do (format t " ~d" (bug-num bb)))
  (format t ">")
  )



;;; step-bug
;;;
;;; The increment of the simulation.  Update the positions, and then peruse the dependency links to
;;; compute the new velocities.

(defun step-bug (b)

  ;; increment position
  (incf (bug-x-pos b) (bug-x-vel b))
  (incf (bug-y-pos b) (bug-y-vel b))

  ;; calculate new velocities
  (setf (bug-x-vel b)
	(+ -1.0 (random 2.0)
	   (/ (+ (bug-x-vel b)
		 (loop for bb in (bug-neighbors b) summing (bug-x-vel bb)))
	      (1+ (length (bug-neighbors b))))))

  (setf (bug-y-vel b)
	(+ -1.0 (random 2.0)
	   (/ (+ (bug-y-vel b)
		 (loop for bb in (bug-neighbors b) summing (bug-y-vel bb)))
	      (1+ (length (bug-neighbors b))))))

  (if (>= (abs (bug-x-vel b)) 10) (setf (bug-x-vel b) (* 0.9 (bug-x-vel b))))
  (if (>= (abs (bug-y-vel b)) 10) (setf (bug-y-vel b) (* 0.9 (bug-y-vel b))))

  (compute-bug-glyph b)

  )


(defun try ()
  (let ((stream *terminal-io*)
	(b (make-bug)))
    (setf (bug-x-pos b) 100)
    (setf (bug-y-pos b) 100)
    (setf (bug-x-vel b) 0.0)
    (setf (bug-y-vel b) 0.0)
    (loop while t do
	  (let ((x (tyi)))
	    ;; Erase old image
	    (tv:prepare-sheet (stream)
	      (sys:%draw-character *bugs-font* (bug-glyph b) 9
				   (x-pix b) (y-pix b)
				   tv:alu-setz stream))
	    (case x
	      (11 (incf (bug-y-vel b) 1.0))
	      (1  (decf (bug-y-vel b) 1.0))
	      (25 (incf (bug-x-vel b) 1.0))
	      (24 (decf (bug-x-vel b) 1.0))))

	  (if (zerop (bug-x-vel b))
	      (if (plusp (bug-y-vel b))
		  (format t "+")
		  (format t "-"))
	      (format t "~3d" (/ (bug-y-vel b) (bug-x-vel b))))

	  (compute-bug-glyph b)
	  ;; Draw new image
	  (tv:prepare-sheet (stream)
	    (sys:%draw-character *bugs-font* (bug-glyph b) 9		; draw new bug
				 (x-pix b) (y-pix b)
				 tv:alu-seta stream))
	  )))





(defun compute-bug-glyph (b)
  (setf (bug-glyph b)
	(if (zerop (bug-x-vel b))
	    (if (plusp (bug-y-vel b))
		14
		0)
	    (let ((slope (/ (bug-y-vel b) (bug-x-vel b))))
	      (if (or (plusp slope) (zerop slope))
		  (if (plusp (bug-y-vel b))
		      
		      ;; x and y positive
		      (cond ((and (<= 0.00 slope) (<= slope 0.11)) 15)
			    ((and (<= 0.11 slope) (<= slope 0.33)) 27)
			    ((and (<= 0.33 slope) (<= slope 0.55)) 26)
			    ((and (<= 0.55 slope) (<= slope 1.08)) 25)
			    ((and (<= 1.08 slope) (<= slope 1.87)) 24)
			    ((and (<= 1.87 slope) (<= slope 3.37)) 23)
			    ((and (<= 3.37 slope) (<= slope 6.00)) 22)
			    (t 21))
		      
		      ;; x and y negative
		      (cond ((and (<= 0.00 slope) (<= slope 0.11))  0)
			    ((and (<= 0.11 slope) (<= slope 0.33)) 13)
			    ((and (<= 0.33 slope) (<= slope 0.55)) 12)
			    ((and (<= 0.55 slope) (<= slope 1.08)) 11)
			    ((and (<= 1.08 slope) (<= slope 1.87)) 10)
			    ((and (<= 1.87 slope) (<= slope 3.37))  9)
			    ((and (<= 3.37 slope) (<= slope 6.00))  8)
			    (t 7))
		      
		      )
		  
		  (progn
		    (setq slope (abs slope))
		    (if (plusp (bug-y-vel b))
			
			;; x neg, y pos
			(cond ((and (<= 0.00 slope) (<= slope 0.11))  0)
			      ((and (<= 0.11 slope) (<= slope 0.33)) 15)
			      ((and (<= 0.33 slope) (<= slope 0.55)) 16)
			      ((and (<= 0.55 slope) (<= slope 1.08)) 17)
			      ((and (<= 1.08 slope) (<= slope 1.87)) 18)
			      ((and (<= 1.87 slope) (<= slope 3.37)) 19)
			      ((and (<= 3.37 slope) (<= slope 6.00)) 20)
			      (t 21))
			
			;; x pos, y neg
			(cond ((and (<= 0.00 slope) (<= slope 0.11)) 14)
			      ((and (<= 0.11 slope) (<= slope 0.33))  1)
			      ((and (<= 0.33 slope) (<= slope 0.55))  2)
			      ((and (<= 0.55 slope) (<= slope 1.08))  3)
			      ((and (<= 1.08 slope) (<= slope 1.87))  4)
			      ((and (<= 1.87 slope) (<= slope 3.37))  5)
			      ((and (<= 3.37 slope) (<= slope 6.00))  6)
			      (t 7))
			
			)))))
	
	))




(defvar *x-lim* 0)
(defvar *y-lim* 0)

(defun x-pix (b)
  (min *x-lim* (max 0 (floor (bug-x-pos b)))))

(defun y-pix (b)
  (min *y-lim* (max 0 (floor (bug-y-pos b)))))


(defun draw-bug (b stream)
  
  ;; Erase old image
  (tv:prepare-sheet (stream)
    (sys:%draw-character *bugs-font* (bug-glyph b) 9		; erase
			 (x-pix b) (y-pix b)
			 tv:alu-setz stream))
  ;; Increment bug
  (step-bug b)
  (check-bug b)
  
  ;; Draw new image
  (tv:prepare-sheet (stream)
    (sys:%draw-character *bugs-font* (bug-glyph b) 9		; draw new bug
			 (x-pix b) (y-pix b)
			 tv:alu-seta stream))
  )


(defun check-bug (b &optional (max-x *x-lim*) (max-y *y-lim*))
  (when (>= (bug-x-pos b) max-x)
    (setf (bug-x-pos b) max-x)
    (setf (bug-x-vel b) (* -1 (bug-x-vel b))))
  (when (>= (bug-y-pos b) max-y)
    (setf (bug-y-pos b) max-y)
    (setf (bug-y-vel b) (* -1 (bug-y-vel b))))
  (when (>= 0 (bug-x-pos b))
    (setf (bug-x-pos b) 0)
    (setf (bug-x-vel b) (* -1 (bug-x-vel b))))
  (when (>= 0 (bug-y-pos b))
    (setf (bug-y-pos b) 0)
    (setf (bug-y-vel b) (* -1 (bug-y-vel b))))
  )


(defun create-bug (x y)
  (make-bug :x-pos (+ -100.0 x (random 200.0))
	    :y-pos (+ -100.0 y (random 200.0))
	    :x-vel (/ (+ -4.0 (random 10.0)) 10.0)
	    :y-vel (/ (+ -4.0 (random 10.0)) 10.0)
	    ))


(defvar *bug-list* '())



;;; hack-bug
;;;
;;; This is used to insure that there is some dynamism in the swarm by making random alterations in the
;;; neighbor-dependency lists.

(defun hack-bug (b n-bugs)
  (when (zerop (random 100))
    (if (zerop (random 2))
	(pop (bug-neighbors b)))
    (if (zerop (random 2))
	(push (nth (random n-bugs) *bug-list*) (bug-neighbors b)))))


;;; swarm
;;;
;;; This is the top-level function.

(defun swarm (&optional (stream *terminal-io*) &key (n-bugs 20) (reset? t))
  
  (send stream :clear-screen)
  (multiple-value-bind (xlim ylim)
      (send stream :inside-size)
    
    (decf xlim 10)
    (decf ylim 10)

    (setq *x-lim* xlim)						; set the global values
    (setq *y-lim* ylim)
    
    
    ;; Initialize list of bugs?
    (if (or reset? (null *bug-list*))
	(let ((x-pos (random *x-lim*))
	      (y-pos (random *y-lim*)))
	  (setq *bug-list* (loop repeat n-bugs collecting (create-bug x-pos y-pos)))
	  (loop for i from 0
		and b in *bug-list* do
		(setf (bug-num b) i))))
    
    ;; Set neighbor relations
    (loop for b in *bug-list* do
	  (setf (bug-neighbors b)
		(loop repeat (+ 2 (random 1)) collecting (nth (random n-bugs) *bug-list*))))
    
    
    (loop while t do
	  (loop for b in *bug-list* do
		(draw-bug b stream)
		(hack-bug b n-bugs)
		))
    
    )
  )