;;; -*- Mode:Common-Lisp; Package:TV; Base:10 -*-
;;;
;;; spirograph
;;;
;;; This displays a two-dimensional spirograph-like image.
;;;
;;; jsp 14-November-88
;;;
;;; (c) John S. Pezaris 1989.  All rights reserved.


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

(defconstant 2pi (* 2 pi))


(defstruct sprocket
  (diameter 0)
  (phase 0)
  (calc-x-pos '())
  (calc-y-pos '())
  (x-pos 0)
  (y-pos 0))


(defun g-cos (g)
  (* (sprocket-diameter g)
     (cos (sprocket-phase g))))

(defun g-sin (g)
  (* (sprocket-diameter g)
     (sin (sprocket-phase g))))


(defun g-cos2 (g)
  (* (sprocket-diameter g)
     (* 0.5 (+ (cos (sprocket-phase g))
	       (cos (* 2 (sprocket-phase g)))))))

(defun g-sin2 (g)
  (* (sprocket-diameter g)
     (* 0.5 (+ (sin (sprocket-phase g))
	       (sin (* 2 (sprocket-phase g)))))))



(defun g-cos-cos (g)
  (* (sprocket-diameter g)
     (cos (* pi (cos (sprocket-phase g))))))

(defun g-sin-sin (g)
  (* (sprocket-diameter g)
     (sin (* pi (sin (sprocket-phase g))))))



(defun sign (x) (if (< x 0) -1 1))

(defun g-sqrtx (g)
  (let ((z (cos (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (sqrt (abs z)))))

(defun g-sqrty (g)
  (let ((z (sin (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (sqrt (abs z)))))


(defun cube (x) (* x x x))
(defun x^4 (x) (* x x x x))
(defun x^5 (x) (* x x x x x))

(defun g-x3 (g)
  (* (sprocket-diameter g)
     (cube (cos (sprocket-phase g)))))

(defun g-y3 (g)
  (* (sprocket-diameter g)
     (cube (sin (sprocket-phase g)))))



(defun g-x5 (g)
  (let ((z (cos (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (x^5 z))))

(defun g-y5 (g)
  (let ((z (sin (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (x^5 z))))


(defun g-x4 (g)
  (let ((z (cos (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (x^4 z))))

(defun g-y4 (g)
  (let ((z (sin (sprocket-phase g))))
    (* (sprocket-diameter g)
       (sign z)
       (x^4 z))))



(defvar function-list '((g-cos-cos g-sin-sin)))

(defvar function-list '((g-cos     g-sin)
			(g-cos2    g-sin2)
 			(g-x3      g-y3)
			))

(defvar function-list '((g-cos     g-sin)
			(g-cos2    g-sin2)
			(g-sqrtx   g-sqrty)
			(g-cos-cos g-sin-sin)
 			(g-x3      g-y3)
 			(g-x4      g-y4)
 			(g-x5      g-y5)
			))

(defun list-unique (l)
  (cond ((null l) '())
	((eq (car l) (cadr l))
	 (list-unique (cdr l)))
	(t (cons (car l)
		 (list-unique (cdr l))))))

(defun perterbate (l)
  (cond ((null l) '())
	(t (let ((x (nth (random (length l)) l)))
	     (cons x (perterbate (remove x l)))))))



(defun new-sprocket (s size functions homogeneous? symmetric?)
  (setf (sprocket-diameter s) size)
  (let ((f1 (nth (random (length function-list)) functions))
	(f2 (nth (random (length function-list)) functions)))
    (if homogeneous?
	(if symmetric?
	    (progn
	      (setf (sprocket-calc-x-pos s) (cadr f1))
	      (setf (sprocket-calc-y-pos s) (car f1)))
	    (if (zerop (random 2))
		(progn
		  (setf (sprocket-calc-x-pos s) (cadr f1))
		  (setf (sprocket-calc-y-pos s) (car f1)))
		(progn
		  (setf (sprocket-calc-x-pos s) (car f1))
		  (setf (sprocket-calc-y-pos s) (cadr f1)))))
	(if symmetric?
	    (progn
	      (setf (sprocket-calc-x-pos s) (cadr f1))
	      (setf (sprocket-calc-y-pos s) (car  f2)))
	    (progn
	      (setf (sprocket-calc-x-pos s) (if (zerop (random 2))
						(car  f1)
						(cadr f1)))
	      (setf (sprocket-calc-y-pos s) (if (zerop (random 2))
						(car  f2)
						(cadr f2)))))
	)
    )
  s
  )




(defun spirograph (&optional (stream *terminal-io*))
  (let ((real-xlim) (real-ylim)
	(xlim/2) (ylim/2)
	(sprocket-list (loop repeat 10 collecting (make-sprocket)))
	)

    (multiple-value-setq (real-xlim real-ylim)
      (send stream :inside-size))

    (setq xlim/2 (/ real-xlim 2))
    (setq ylim/2 (/ real-ylim 2))


  (loop while t do
	(send stream :clear-screen)
	(let ((halt-flag '())
	      (temp-flag '())
	      (temp-iter 0)
	      (homogeneous? 't)
	      (symmetric?   (zerop (random 2)))
	      )
	  
	  (let* ((number-of-sprockets (+ 2 (random 2)))
		 (freq 0.05)
		 (old-x '())
		 (old-y '())
		 (size-limit (min xlim/2 ylim/2))
		 (size-quantum (floor (/ size-limit (* 4 number-of-sprockets))))
		 (size-list '()))
	    
	    (loop while (or (< (length size-list) number-of-sprockets)
			    (< size-limit
			       (loop for size in size-list summing size)))
		  do
		  (setq size-list (list-unique (sort (loop repeat number-of-sprockets
							   collecting (* size-quantum (+ 1 (random 8))))
						     #'<))))
	    
	    (setq size-list (perterbate size-list))
	    (setq sprocket-list
		  (loop for size in size-list collecting
			(new-sprocket (make-sprocket) size function-list homogeneous? symmetric?)))
	    
	    (setq old-x (floor (- xlim/2
				  (loop for gear in sprocket-list do
					(setf (sprocket-x-pos gear) (funcall (sprocket-calc-x-pos gear) gear))
					summing (sprocket-x-pos gear)))))

	    (setq old-y (floor (- ylim/2
				  (loop for gear in sprocket-list do
					(setf (sprocket-y-pos gear) (funcall (sprocket-calc-y-pos gear) gear))
					summing (sprocket-y-pos gear)))))
	    

	    (loop for iterations from 0
		  until halt-flag
		  do
		  (let ((old-diameter 0)
			(parity 1))
		    (loop for gear in sprocket-list do
			  (setf (sprocket-phase gear)
				(mod (+ (sprocket-phase gear)
					(* freq (if (zerop old-diameter)
						    1
						    (/ old-diameter
						       (sprocket-diameter gear)))
					   parity))
				     2pi))
			  (setq parity (* -1 parity))
			  (setq old-diameter (sprocket-diameter gear))
			  (setf (sprocket-x-pos gear) (funcall (sprocket-calc-x-pos gear) gear))
			  (setf (sprocket-y-pos gear) (funcall (sprocket-calc-y-pos gear) gear))
			  ))
		  
		  (let ((x (floor (- xlim/2
				     (loop for gear in sprocket-list summing (sprocket-x-pos gear)))))
			(y (floor (- ylim/2
				     (loop for gear in sprocket-list summing (sprocket-y-pos gear))))))
		    (tv:prepare-sheet (stream)
		      (sys:%draw-line
			old-x old-y x y
			tv:alu-seta t stream))
		    (setq old-x x)
		    (setq old-y y)
		    )
		  
		  (setq halt-flag (and temp-flag
				       (> iterations (+ temp-iter 5))))
		  (when (and (> iterations 10)
			     (loop for gear in sprocket-list always (near-0.1? gear)))
		    (setq temp-flag t)
		    (setq temp-iter iterations))
		  
		  )
	    )
	  )
	(sleep 2)			   ; wait for the user to view the creation!
	))

)

(defun near-0.1? (g)
  (let* ((phase (sprocket-phase g))
	 (diam  (sprocket-diameter g)))
    (< (* diam (min phase (- 2pi phase)))
       5)))