(in-package :LED-cube)

;; And now the time of the naive mathematic is come.

(defstruct (point (:constructor new-point (x y z)))
  (x 0.0)
  (y 0.0)
  (z 0.0))

(defun add-points (&rest points)
  (if (null (cdr points))
      (car points)
      (apply #'add-points (new-point (+ (point-x (cadr points)) (point-x (car points)))
				     (+ (point-y (cadr points)) (point-y (car points)))
				     (+ (point-z (cadr points)) (point-z (car points))))
	     (cddr points))))

(defun multiply-point (multiplier point)
  (new-point (* multiplier (point-x point))
	     (* multiplier (point-y point))
	     (* multiplier (point-z point))))

(defstruct (line (:constructor new-line (a b)))
  (a (new-point 0 0 0) :type point)
  (b (new-point 0 0 1) :type point))     

(defun new-line-short (a-x a-y a-z  b-x b-y b-z)
  (new-line (new-point a-x a-y a-z)
	    (new-point b-x b-y b-z)))

(defun square (x)
  (expt x 2))

(defun Pythagoras (a b)
  (sqrt (+ (square a)
	   (square b))))

(defun distance-between-points (a b)
  (Pythagoras
   (- (point-z a)
      (point-z b))
   (Pythagoras (- (point-x a)
		  (point-x b))
	       (- (point-y a)
		  (point-y b)))))

(defun distance-between-point-and-line (point line)
  ;; perhaps you want to have a look at my sketches? :)
  (let ((a (distance-between-points (line-b line) point))
	(b (distance-between-points (line-a line) point))
	(c (distance-between-points (line-a line) (line-b line))))
    (sqrt (- (square b)
	     (square (/ (+ (square b)
			   (- (square a))
			   (square c))
			(* 2 c)))))))
;; alternatively:
;;     (sqrt (/ (- (* 2 (+ (* (square c)
;; 			   (square b))
;; 			(* (square a)
;; 			   (square b))
;; 			(* (square a)
;; 			   (square c))))
;; 		(expt a 4)
;; 		(expt b 4)
;; 		(expt c 4))
;; 	     (* 4 (square c))))))

(defun interpolate-line (line &key (units 0.16) (cube (current-cube)))
  (assert (not (equalp (line-a line) (line-b line)))
	  ((line-a line) (line-b line))
	  "To define a line a and b have to specify different points.~% Right now a is ~d and b is ~d.~%"
	  (line-a line) (line-b line))
  (do-cube-times (x y z cube)
    (let ((brightness (- 5
			 (round (realpart
				    (/ (distance-between-point-and-line (new-point x y z) line)
				       units))))))
;;      (format t "~s ~s ~s: ~s~%" x y z brightness)
      (when (and (>= brightness 0)
		 (> brightness (- (char-code (aref (current-cube) x y z)) (char-code #\0))))
	(setf (aref cube x y z) (code-char (+ (char-code #\0) brightness)))))))  



(defun regular-polygon (n &key (centre (new-point 2 2 0)) (offset 0) (radius 2))
  (let ((angle (/ (* 2 pi) n))
	coords)
    (dotimes (i n coords)
      (let ((current-angle (* (+ i offset) angle)))
	(pushnew (new-point (+ (* (cos current-angle) radius) (point-x centre))
			    (+ (* (sin current-angle) radius) (point-y centre))
			    (point-z centre))
	       coords)))))

(defun nth-mod (n list)
  (nth (mod n (length list)) list))

(defun rotating-line (&key (top-n 16) (bottom-n 24))
  (let* ((radius 3)
	 (top (regular-polygon top-n :offset 0 :radius radius))
	 (bottom (regular-polygon bottom-n :centre (new-point 2 2 4) :offset (/ bottom-n 2) :radius radius)))
    (delete-animation)
    (with-disabled-save-undo
	(dotimes (i (max top-n bottom-n))
	  (unless (= i 0)
	    (insert-cube-copy :cube-to-copy (make-cube)))
	  (interpolate-line (new-line (nth-mod i top)
				      (nth-mod i bottom)))))))

(defun rotating-line (&key (top-n 16) (bottom-n 24))
  (let* ((radius 3)
	 (way (give-n-points 8 (new-point 1 1 0) (new-point 3 3 1))))
    (setf way (append way (reverse way)))
    (delete-animation)
    (with-disabled-save-undo
	(dotimes (i (max top-n bottom-n))
	  (let* ((point (nth-mod i way))
		 (x (point-x point))
		 (y (point-y point))
		 (z (point-z point))
		 (top (regular-polygon top-n :centre (new-point x y z) :offset 0 :radius radius))
		 (bottom (regular-polygon bottom-n :centre (new-point x y (+ 4 z)) :offset (/ bottom-n 2) :radius radius)))
	    (unless (= i 0)
	      (insert-cube-copy :cube-to-copy (make-cube)))
	    (interpolate-line (new-line (nth (mod i top-n) top)
					(nth (mod i bottom-n) bottom))))))))



(defun give-n-points (n point-a point-b &key (dump-first nil))
  (assert (> n 1)
	  (n)
	  "You have to take a and b themselves into account when specifying the value of n.~% Therefore n has to be greater than 1, but it is right now: ~d.~%"
	  n)
  (let ((vector (add-points point-b (multiply-point -1 point-a)))
	points)
    (dotimes (i n (nreverse points))
      (pushnew (add-points point-a (multiply-point (/ i (1- n)) vector))
	       points))))



(defun moving-line ()
  (delete-animation)
  (with-disabled-save-undo
      (let ((on-first t))
	(dolist (line (mapcar (lambda (x) (apply #'new-line-short x))
			      '((0 0 0 0 0 4) (0 0 0 0 1 4))))
	  (if on-first
	      (setf on-first nil)
	      (insert-cube-copy :cube-to-copy (make-cube)))
	  (interpolate-line line)))
    (goto-cube :first)))

(defun moving-line ()
  (delete-animation)
  (with-disabled-save-undo
      (let ((on-first t)
	    old-a
	    old-b)
	(dolist (line (mapcar (lambda (x)
				(if (typep (car x) 'list)
				    (let ((a (car x))
					  (b (cadr x)))
				      (when a
					(setf old-a a))
				      (when b
					(setf old-b b)))
				    (setf old-a (subseq x 0 3)
					  old-b (subseq x 3 6)))
				(apply #'new-line-short (append old-a old-b)))
			      '((0 0 0 0 0 4) (nil (0 1 4)) (nil (0 2 4)) (nil (0 3 4)) (nil (0 4 4))
				((0 0 1) nil) ((0 0 2) nil) ((0 0 3) nil) ((0 0 4) nil)
				(nil (1 4 3)) (nil (2 4 2)) (nil (3 4 1)) (nil (4 4 0))
				((0 0 3) nil) ((0 0 2) nil) ((0 0 1) nil) ((0 0 0) nil)
				(1 0 0  3 4 0) (2 0 0  2 4 0) (3 0 0  1 4 0) (4 0 0  0 4 0)
				)))
	  (if on-first
	      (setf on-first nil)
	      (insert-cube-copy :cube-to-copy (make-cube)))
	  (interpolate-line line)))
    (goto-cube :first)))

(defmacro moving-line-creator (line-def)
  `(defun moving-line ()
     (delete-animation)
     (with-disabled-save-undo
	 (let ((on-first t))
	   (dolist (spec ,line-def)
	     (let ((a (car spec))
		(b (cdr spec)))
	       (dotimes (i (max (length a) (length b)))
		 (if on-first
		     (setf on-first nil)
		     (insert-cube-copy :cube-to-copy (make-cube)))
	    (interpolate-line (new-line (nth (mod i (length a)) a)
					(nth (mod i (length b)) b)))))))
       (goto-cube :first))))

(moving-line-creator
 `(((,(new-point 0 0 0)) . ,(give-n-points 5 (new-point 0 0 4) (new-point 0 4 4)))
   (,(give-n-points 4 (new-point 0 0 1) (new-point 0 0 4)) . (,(new-point 0 4 4)))
   ((,(new-point 0 0 4)) . ,(give-n-points 4 (new-point 1 4 3) (new-point 4 4 0)))
   (,(give-n-points 4 (new-point 0 0 3) (new-point 4 0 0)) . (,(new-point 4 4 0)))
   (,(give-n-points 4 (new-point 1 0 0) (new-point 4 0 0)) .
     ,(give-n-points 4 (new-point 3 4 0) (new-point 0 4 0)))
   (,(give-n-points 5 (new-point 4 0 0) (new-point 2 0 2)) .
     ,(give-n-points 5 (new-point 0 4 0) (new-point 2 4 2)))
   (,(give-n-points 5 (new-point 2 0 2) (new-point 0 0 4)) .
     ,(give-n-points 5 (new-point 2 4 2) (new-point 4 4 4)))
   ((,(new-point 0 0 4)) . ,(give-n-points 9 (new-point 4 4 4) (new-point 0 0 0)))
   ))

(moving-line-creator
 (list (cons (list (new-point 0 0 0))
	     (give-n-points 5 (new-point 0 0 4) (new-point 0 4 4)))
       (cons (give-n-points 4 (new-point 0 0 1) (new-point 0 0 4))
	     (list (new-point 0 4 4)))
       (cons (list (new-point 0 0 4))
	     (give-n-points 4 (new-point 1 4 3) (new-point 4 4 0)))
       (cons (give-n-points 4 (new-point 0 0 3) (new-point 4 0 0))
	     (list (new-point 4 4 0)))
       (cons (give-n-points 4 (new-point 1 0 0) (new-point 4 0 0))
	     (give-n-points 4 (new-point 3 4 0) (new-point 0 4 0)))
       (cons (give-n-points 5 (new-point 4 0 0) (new-point 2 0 2))
	     (give-n-points 5 (new-point 0 4 0) (new-point 2 4 2)))
       (cons (give-n-points 5 (new-point 2 0 2) (new-point 0 0 4))
	     (give-n-points 5 (new-point 2 4 2) (new-point 4 4 4)))
       (cons (list (new-point 0 0 4))
	     (give-n-points 9 (new-point 4 4 4) (new-point 0 0 0)))))

(moving-line-creator
 (list (cons (list (new-point 0 0 0))
	     (give-n-points 5 (new-point 0 0 4) (new-point 0 4 4)))
       (cons (cdr (give-n-points 5 (new-point 0 0 0) (new-point 0 0 4)))
			   (list (new-point 0 4 4)))
       (cons (list (new-point 0 0 4))
	     (cdr (give-n-points 5 (new-point 0 4 4) (new-point 4 4 0))))
       (cons (cdr (give-n-points 5 (new-point 0 0 4) (new-point 0 0 0)))
	     (list (new-point 4 4 0)))
       (cons (cdr (give-n-points 5 (new-point 0 0 0) (new-point 4 0 0)))
	     (cdr (give-n-points 5 (new-point 4 4 0) (new-point 0 4 0))))
       
;;        (cons (cdr (give-n-points 5 (new-point 4 0 0) (new-point 2 0 2)))
;; 	     (cdr (give-n-points 5 (new-point 0 4 0) (new-point 2 4 2))))
;;        (cons (cdr (give-n-points 5 (new-point 2 0 2) (new-point 0 0 4)))
;; 	     (cdr (give-n-points 5 (new-point 2 4 2) (new-point 4 4 4))))
       (cons (cdr (give-n-points 9 (new-point 4 0 0) (new-point 0 0 4)))
	     (cdr (give-n-points 9 (new-point 0 4 0) (new-point 4 4 4))))
       
       (cons (list (new-point 0 0 4))
	     (butlast (cdr (give-n-points 9 (new-point 4 4 4) (new-point 0 0 0)))))))

(moving-line-creator
 (list (cons (list (new-point 0 0 0))
	     (give-n-points 5 (new-point 0 0 4) (new-point 0 4 4)))
       (cons (cdr (give-n-points 5 (new-point 0 0 0) (new-point 0 0 4)))
	     (list (new-point 0 4 4)))
       (cons (list (new-point 0 0 4))
	     (cdr (give-n-points 5 (new-point 0 4 4) (new-point 4 4 0))))
       (cons (cdr (give-n-points 5 (new-point 0 0 4) (new-point 0 0 0)))
	     (list (new-point 4 4 0)))
       (cons (cdr (give-n-points 5 (new-point 0 0 0) (new-point 4 0 0)))
	     (cdr (give-n-points 5 (new-point 4 4 0) (new-point 0 4 0))))
       
       (cons (cdr (give-n-points 9 (new-point 4 0 0) (new-point 0 2 2)))
	     (cdr (give-n-points 9 (new-point 0 4 0) (new-point 4 2 2))))
       (cons (cdr (give-n-points 9 (new-point 0 2 2) (new-point 4 0 4)))
	     (cdr (give-n-points 9 (new-point 4 2 2) (new-point 0 4 4))))
       
       (cons (cdr (give-n-points 5 (new-point 4 0 4) (new-point 4 4 4)))
	     (cdr (give-n-points 5 (new-point 0 4 4) (new-point 0 0 0))))
       (let ((radius (Pythagoras 2 2)))
	 (cons (subseq (regular-polygon 16 :centre (new-point 2 2 0) :radius radius :offset 11) 1 8)
	       (subseq (regular-polygon 16 :centre (new-point 2 2 4) :radius radius :offset 3) 1 8)))
       ;; ending points (0 0 4) and (4 4 0)
       (cons (list (new-point 0 0 4))
	     (let ((radius (Pythagoras 2 2)))
	       (nreverse (subseq (regular-polygon 16 :centre (new-point 2 2 0) :radius radius :offset 11) 1 8))))
;;             (butlast (give-n-points 9 (new-point 4 4 0) (new-point 0 0 0))))
       
;;        (cons (butlast (cdr (give-n-points 9 (new-point 4 0 4) (new-point 0 0 4))))
;; 	     (butlast (cdr (give-n-points 9 (new-point 0 4 4) (new-point 0 0 0)))))
       ))
 
(moving-line-creator
 (list (cons ;;(list (new-point 2 2 0))
	(append (give-n-points 25 (new-point 0 2 0) (new-point 4 2 0))
		(give-n-points 25 (new-point 4 2 0) (new-point 0 2 0)))
	(regular-polygon 50 :centre (new-point 2 2 4) :radius 3))))

(moving-line-creator 
 (let (list)
   (dotimes (i 6 list)
     (pushnew 
      (cons (regular-polygon 30 :centre (new-point 2 2 (- 2 i)) :radius 3 :offset 15)
	    (regular-polygon 30 :centre (new-point 2 2 (- 6 i)) :radius 3))
      list))))

(moving-line-creator 
 (let (list)
   (dolist (point (append (give-n-points 5 (new-point 2 0 0) (new-point 0 2 0))
			  (cdr (give-n-points 5 (new-point 0 2 0) (new-point 2 4 0)))
			  (cdr (give-n-points 5 (new-point 2 4 0) (new-point 4 2 0)))
			  (butlast (cdr (give-n-points 5 (new-point 4 2 0) (new-point 2 0 0)))))
	    list)
     (pushnew 
      (cons (regular-polygon 20 :centre point :radius 3 :offset 10)
	    (regular-polygon 20 :centre (add-points point (new-point 0 0 4)) :radius 3))
      list))))