;;; -*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*-

(defflavor wormy-flavor ()
	   (tv:label-mixin tv:kbd-mouse-buttons-mixin tv:select-mixin
	    tv:graphics-mixin tv:borders-mixin tv:stream-mixin
	    tv:minimum-window))

(defvar *worm-step-length* 10.)
(defvar *decision-node-radius* 3)

(defvar *worm-pond* nil)
(defvar *blinker* nil)

(defvar *pond-dimensions*)
(defvar *x-delta-array* (make-array 9. :element-type '(signed-byte 16.)))
(defvar *y-delta-array* (make-array 9. :element-type '(signed-byte 16.)))
(defvar *direction-to-go* (make-array 256. :element-type '(mod 16.)))

(defconst pi//4 (// pi 4))
(defconst pi//8 (// pi 8.))
(defconst  0.0000001)

(defvar *diagonal-trails*)
(defvar *straight-trails*)
(defvar *move-list*)
(defvar *x-pos*)
(defvar *y-pos*)

(defun worm-trails ()
  (unwind-protect
      (progn
	(if (null *worm-pond*) (initialize-pond))
	(send *worm-pond* ':expose)
	(send *worm-pond* ':select)
	(do ((play-it-again t
			    (let ((*query-io* *worm-pond*))
			      (y-or-n-p "Again? "))))
	    ((null play-it-again))
	  (send *worm-pond* :clear-window)
	  (let ((returnage (wander-around)))
	    (send *worm-pond* ':set-cursorpos 0 0 ':character)
	    (format *worm-pond*
		    "Died of ~A~&Length: ~A~&Moves were ~A~%"
		    (first returnage) (second returnage)
		    (nreverse (cddr returnage))))))
    (send *worm-pond* :deselect)))

(defun wander-around ()
  (let ((*x-pos* (truncate (car *pond-dimensions*) 2))	;start in the center of the screen
	(*y-pos* (truncate (cadr *pond-dimensions*) 2))
	(*move-list* nil)
	(*straight-trails* 0)
	(*diagonal-trails* 0))
    (fill *direction-to-go* 0)	;you don't know what to do!
    (do ((forced-move 1 (1+ forced-move))
	 (forced-nodes '(254. 253. 251. 247. 239. 223. 191. 127.) (cdr forced-nodes)))
	((null forced-nodes))
      (aset forced-move *direction-to-go* (car forced-nodes)))
    (hacks:with-real-time
      (do ((node (calculate-node) (calculate-node)))
	  ((or (not (plusp *x-pos*))		;run until you hit a wall
	       (not (plusp *y-pos*))
	       ( *x-pos* (car *pond-dimensions*))
	       ( *y-pos* (cadr *pond-dimensions*)))
	   (punt 'brain-damage))
	(if (= node 255.) (return (punt 'starvation))
	    (move (if (zerop (aref *direction-to-go* node)) (ask-where-to-go node)
		      (aref *direction-to-go* node))))))))

(defun move (direction)
  (let ((new-x (+ *x-pos* (* (aref *x-delta-array* direction) *worm-step-length*)))
	(new-y (+ *y-pos* (* (aref *y-delta-array* direction) *worm-step-length*))))
    (send *worm-pond* ':draw-line
	     *x-pos* *y-pos*
	     new-x new-y tv:alu-ior)
    (if (evenp direction)
	(setq *diagonal-trails* (1+ *diagonal-trails*))
      (setq *straight-trails* (1+ *straight-trails*)))
    (setq *x-pos* new-x				;update global position of worm.
	  *y-pos* new-y)))
 
(defun calculate-node ()
  (do ((node-value 0)
       (direction 1 (1+ direction))
       (pixel-value 1 (lsh pixel-value 1)))
      ((= direction 9.) node-value)
    (if (not (zerop (send *worm-pond* ':point
			     (+ *x-pos* (aref *x-delta-array* direction))
			     (+ *y-pos* (aref *y-delta-array* direction)))))
	(setq node-value (+ node-value pixel-value)))))

(defun ask-where-to-go (node &aux (offset (* *worm-trails-blinker-halfsize*
					     *worm-trails-blinker-factor*)))
  (send *worm-pond* ':draw-circle *x-pos* *y-pos* *decision-node-radius*)
  (sys:%beep 500. 100000.)
  (setq tv:mouse-x *x-pos*
	tv:mouse-y *y-pos*)
  (send *blinker* ':set-cursorpos (- *x-pos* offset) (- *y-pos* offset))
  (send *blinker* ':set-visibility ':on)
  (tv:with-mouse-usurped
    (setq tv:who-line-mouse-grabbed-documentation
	  "  Move mouse around to see possible worm moves -- Click any to select one.")
    (do ((over-line nil)
	 (old-direction 0)
	 (new-direction 0)
	 (delta-mouse (multiple-value-list (tv:mouse-input))
		      (multiple-value-list (tv:mouse-input)))
	 (mouse-x *x-pos* (fifth delta-mouse))
	 (mouse-y *y-pos* (sixth delta-mouse)))
	((and (not (zerop tv:mouse-last-buttons))
	      (de-click)
	      (not over-line))
	 (send *blinker* ':set-visibility ':off)
	 (learn-to-go-from node new-direction)
	 new-direction)
      (send *blinker* ':set-cursorpos (- mouse-x offset) (- mouse-y offset))
      (setq new-direction (calculate-direction mouse-x mouse-y))
      (cond (( old-direction new-direction)
	     (if (not over-line)
		 (ghost-line old-direction))
	     (cond ((zerop (send *worm-pond* ':point
				    (+ *x-pos* (aref *x-delta-array* new-direction))
				    (+ *y-pos* (aref *y-delta-array* new-direction))))
		    (ghost-line new-direction)
		    (setq over-line nil))
		   (t
		    (sys:%beep 250. 10000.)
		    (setq over-line t)))
	     (setq old-direction new-direction))))))

(defun de-click ()
  (do ((delta-mouse (multiple-value-list (tv:mouse-input))
		    (multiple-value-list (tv:mouse-input))))
      ((zerop tv:mouse-last-buttons)
       t)))

(defun ghost-line (direction)
  (send *worm-pond* ':draw-line
	   *x-pos* *y-pos*
	   (+ *x-pos* (* (aref *x-delta-array* direction) *worm-step-length*))
	   (+ *y-pos* (* (aref *y-delta-array* direction) *worm-step-length*))
	   tv:alu-xor nil)
  T)

(defun calculate-direction (x y)
  (do ((angle (atan (- *y-pos* y)
		    (+ (- x *x-pos*) )))
       (border-angle pi//8 (+ border-angle pi//4))
       (direction 1)
       (doop 2 (1+ doop)))
      ((= doop 10.)
       (if (= direction 9.) 1
	 direction))
    (if (> angle border-angle)
	(setq direction doop))))

(defun learn-to-go-from (node direction)
  (setq *move-list* (cons direction *move-list*))
  (do ((rotated-nodes nil (cons temp-node rotated-nodes))
       (temp-node node (* temp-node 2))
       (temp-direction direction (1+ temp-direction)))
      ((mem #'= temp-node rotated-nodes))
    (if (> temp-node 255.)
	(setq temp-node (- temp-node 255.)))
    (if (> temp-direction 8.)
	(setq temp-direction (- temp-direction 8.)))
    (aset temp-direction *direction-to-go* temp-node)))

(defun punt (reason)
  (sys:%beep 2000. 100000.)
;  (setq tv:who-line-mouse-grabbed-documentation
;	"  hit any character when done gawking at screen")
  (send *worm-pond* :tyi)
  (cons reason (cons (+ *straight-trails*
;I think this number is more what the user wants to know - RMS.
			*diagonal-trails*)
;			(* *diagonal-trails* (sqrt 2.0)))
			       *move-list*)))

(defdemo "Worm-Trails" "Teach this ignorant worm to be efficient and live." (worm-trails))

(compile-flavor-methods wormy-flavor)

(defconst *worm-trails-blinker-factor* 2)
(defconst *worm-trails-blinker-halfsize* 6)

(defun initialize-pond ()
  (setq *worm-pond* (make-instance 'wormy-flavor
				   :borders 5
				   :label nil
				   :activate-p t
				   :expose-p nil
				   :blinker-p nil)
	*blinker* (make-instance 'tv:magnifying-blinker
				 :sheet *worm-pond*
				 :height (* 2 *worm-trails-blinker-halfsize*
					    *worm-trails-blinker-factor*)
				 :width (* 2 *worm-trails-blinker-halfsize*
					   *worm-trails-blinker-factor*)
				 :x-offset (* *worm-trails-blinker-halfsize*
					      *worm-trails-blinker-factor*)
				 :y-offset (* *worm-trails-blinker-halfsize*
					      *worm-trails-blinker-factor*)
				 :magnification *worm-trails-blinker-factor*
				 :half-period 10.
				 :visibility :off)
	*pond-dimensions* (multiple-value-list (send *worm-pond* :size)))
  (fillarray *x-delta-array* '(0 1 1 0 -1 -1 -1 0 1))
  (fillarray *y-delta-array* '(0 0 -1 -1 -1 0 1 1 1)))