(define shooter
  (lambda ()
    (new (start startshooter)
	 (quit quitshooter))))

(define startshooter
  (lambda ()
    (spawn shootermon)))

(define quitshooter
  (lambda ()
    (when shooterpid
      (send shooterpid (quit)))))

(define shooterpid nil)

(define shootermon
  (let ((obituary
	 (lambda (pid reason)
	   (strcat "shooter process " (write pid)
		   " died: " (write reason))))
	(clear
	 (lambda ()
	   (box 'lgreen 0 0 480 400)
	   (draw))))
    (lambda ()
      (trapexits)
      (let loop ()
	   (set shooterpid (spawnlink runshooter))
	   (receive
	    ((exit pid snap reason)
	     (when (!= reason 'quitting)
	       (showsnapshot snap)
	       (log (obituary pid reason))
	       (log "restarting")
	       (loop)))))
      (set shooterpid nil)
      (clear))))

(define tilepid nil)
(define enemypid nil)
(define ctlpid nil)
(define playerpid nil)
(define movepid nil)

(define editingp nil)
(define collidingp nil)
(define firingp 0)
(define mapdepth 8)
(define mapsize '(1280 . 1280))

(define runshooter
  (lambda ()
    (set collidingp t)
    (set ctlpid (spawnlink ctlloop))
    (set playerpid (spawnlink playerloop))
    (set tilepid (spawnlink tileloop))
    (send tilepid (load (self) "map.lisp"))
    (receive
     ((response) nil))
    (set enemypid (spawnlink enemyloop))
    (set movepid (spawnlink moveloop))
    (spawnlink drawloop)
    (receive
     ((quit)
      (exit 'quitting)))))

(define keygrabpid nil)

(define keygrab
  (lambda ()
    (set keygrabpid
	 (spawn
	  (lambda ()
	    (doc 'post '(body listeners) 'keydown)
	    (let loop ()
		 (receive
		  ((keydown k)
		   (log (write k))))
		 (loop)))))))

(define abs
  (lambda (x)
    (if (< x 0) (- 0 x) x)))

(define min
  (lambda (a b)
    (if (< a b) a b)))

(define max
  (lambda (a b)
    (if (> a b) a b)))

(define bbox
  (lambda (ps)
    (let loop ((lbound (car ps))
	       (ubound (car ps))
	       (tail (cdr ps)))
	 (cond
	  ((nilp tail) (cons lbound ubound))
	  (t (loop (cons (min (car lbound)
			      (caar tail))
			 (min (cdr lbound)
			      (cdar tail)))
		   (cons (max (car ubound)
			      (caar tail))
			 (max (cdr ubound)
			      (cdar tail)))
		   (cdr tail)))))))

(define any
  (lambda (x pred)
    (cond
     ((nilp x) nil)
     ((pred (car x)) t)
     (t (any (cdr x) pred)))))

(define isectp
  (lambda (tree box)
    (any (tiletreeselect tree (car box) (cdr box))
	 (lambda (cell)
	   (_ cell blockedp)))))

(define raysquareisectp
  (lambda (p0 a lbound size range)
    (let ((kmin range))
      (let ((x (car lbound)))
	(when (< (car a) 0)
	  (set x (+ x size)))
	(let ((dx (- x (car p0))))
	  (when (> (* (car a) dx) 1e-5)
	    (let ((k (/ dx (car a))))
	      (when (< k kmin)
		(let ((y (+ (cdr p0) (* k (cdr a)))))
		  (when (and (>= y (cdr lbound))
			     (< y (+ (cdr lbound) size)))
		    (set kmin k))))))))
      (let ((y (cdr lbound)))
	(when (< (cdr a) 0)
	  (set y (+ y size)))
	(let ((dy (- y (cdr p0))))
	  (when (> (* (cdr a) dy) 1e-5)
	    (let ((k (/ dy (cdr a))))
	      (when (< k kmin)
		(let ((x (+ (car p0) (* k (car a)))))
		  (when (and (>= x (car lbound))
			     (< x (+ (car lbound) size)))
		    (set kmin k))))))))
      (if (< kmin range)
	  (cons kmin (c+ p0 (s* a kmin)))
	nil))))

(define laserhitp
  (lambda (p a d box)
    (let ((isect (raysquareisectp
		  p a (car box) 20 d)))
      (and isect (< (car isect) d)))))

(define occludedp
  (lambda (p a d tiles)
    (let loop ((tail tiles))
	 (cond
	  ((nilp tail) nil)
	  (t (let ((tile (car tail)))
	       (let ((isect (raysquareisectp
			     p a (_ tile location) 80 d)))
		 (if (and isect (< (car isect) d))
		     tile
		   (loop (cdr tail))))))))))

(define player
  (lambda (a)
    (let ((x1 (c* a '(20 . 0)))
	  (x2 (c* a '(-4 . 6)))
	  (x3 (c* a '(-4 . -6))))
      (list x1 x2 x3))))

(define drawplayer
  (lambda (a)
    (let ((p (map (lambda (x) (c+ x '(240 . 200)))
		  (player a))))
      (let ((x1 (first p))
	    (x2 (second p))
	    (x3 (third p)))
	(beginpath)
	(moveto (car x1) (cdr x1))
	(lineto (car x2) (cdr x2))
	(lineto (car x3) (cdr x3))
	(fill)))))

(define drawsight
  (lambda (p a tiles)
    (let ((k 300) (q nil) (isect nil))
      (dolist (tile tiles)
	(set isect (raysquareisectp p a (_ tile location) 80 k))
	(when (and isect (< (car isect) k))
	  (set k (car isect))
	  (set q (cdr isect))))
      (unless q
	(set q (c+ p (s* a 300))))
      (when (> firingp 0)
	(send enemypid (laser p a k)))
      (beginpath)
      (moveto 240 200)
      (lineto (+ 240 (- (car q) (car p)))
	      (+ 200 (- (cdr q) (cdr p))))
      (if (> firingp 0)
	  (begin (linewidth 3)
		 (stroke 'dred)
		 (linewidth 1)
		 (set firingp (- firingp 1)))
	(stroke 'lred)))))

(define drawloop
  (lambda ()
    (doc 'post '(pause listeners) 'click)
    (let loop ()
	 (receive
	  ((click id)
	   (cond
	    ((= id 'quit)
	     (exit 'quit))
	    ((= id 'pause)
	     (doc 'put '(pause value) "resume")
	     (receive
	      ((click id)
	       (doc 'put '(pause value) "pause")
	       (cond
		((= id 'pause) nil)
		((= id 'quit) (exit 'quit))))))))
	  ((after 30)
	   (box 'lgreen 0 0 480 400)
	   (send playerpid (get (self)))
	   (receive
	    ((response p a)
	     (send tilepid (get (self)))
	     (receive
	      ((response visibles)
	       (drawsight p a visibles)
	       (dolist (tile visibles)
		 (let ((ptile (_ tile location)))
		   (let ((x (+ 240 (- (car ptile) (car p))))
			 (y (+ 200 (- (cdr ptile) (cdr p)))))
		     (box 'dblue (- x 1) (- y 1) 82 82))))))
	     (send enemypid (get (self)))
	     (receive
	      ((response es)
	       (dolist (e es)
		 (let ((x (caar e)) (y (cdar e)))
		   (circle 'lred (+ 240 (- x (car p)))
			   (+ 200 (- y (cdr p))))))))
	     (drawplayer a)))
	   (draw)
	   (send tilepid (tick))
	   (send enemypid (tick))
	   (send movepid (tick))))
	 (loop))))

(define convexcomb
  (lambda (a x0 x1)
    (+ (* (- 1 a) x0) (* a x1))))

(define randpoint
  (lambda (lbound ubound)
    (let ((ax (rand))
	  (ay (rand)))
      (cons (convexcomb ax (car lbound) (car ubound))
	    (convexcomb ay (cdr lbound) (cdr ubound))))))

(define s*
  (lambda (x s)
    (cons (* (car x) s)
	  (* (cdr x) s))))

(define s/
  (lambda (x s)
    (s* x (/ 1 s))))

(define centeredbox
  (lambda (p s)
    (let ((q (cons s s)))
      (cons (c- p q)
	    (c+ p q)))))

(define enemyloop
  (lambda ()
    (let ((enemies nil))
      (let loop ((n 0))
	   (unless (>= n 20)
	     (let ((p (randpoint '(0 . 0) mapsize)))
	       (send tilepid (isectp (self) (centeredbox p 10)))
	       (receive
		((response blockedp)
		 (cond
		  (blockedp (loop n))
		  ((< (norm (c- p '(640 . 640))) 240) (loop n))
		  (t (push enemies (cons p nil))
		     (loop (+ n 1)))))))))
      (let loop ()
	   (receive
	    ((tick)
	     (when (nilp enemies)
	       (exit 'winner!))
	     (send tilepid (get (self)))
	     (receive
	      ((response visibles)
	       (send playerpid (get (self)))
	       (receive
		((response p a)
		 (let ((d nil) (v nil))
		   (dolist (e enemies)
		     (set v (c- p (car e)))
		     (set d (norm v))
		     (set v (s/ v d))
		     (when (< d 10)
		       (exit 'gameover))
		     (when (< d 200)
		       (let ((tile (occludedp (car e) v d
					      (if (cdr e)
						  (cons (cdr e)
							visibles)
						visibles))))
			 (if tile
			     (setcdr e tile)
			   (setcar e (c+ (car e) (s* v 8)))))))))))))
	    ((laser p a d)
	     (let ((survivors nil))
	       (dolist (e enemies)
		 (unless (laserhitp p a d (centeredbox (car e) 10))
		   (push survivors e)))
	       (set enemies survivors)))
	    ((get pid)
	     (send pid (response enemies))))
	   (loop)))))

(define playerloop
  (lambda ()
    (let ((p '(640 . 640))
	  (a '(1 . 0)))
      (let loop ()
	   (receive
	    ((put q b)
	     (set p q)
	     (set a b))
	    ((get pid)
	     (send pid (response p a))))
	   (loop)))))

(define canmove
  (lambda (p a dp)
    (let ((q (c+ p dp)))
      (let ((qq (map (lambda (x) (c+ q x))
		     (player a))))
	(send tilepid (isectp (self) (bbox qq)))
	(receive
	 ((response blockedp)
	  (not blockedp)))))))

(define moveloop
  (lambda ()
    (let ((p nil) (a nil) (ds nil))
      (let loop ()
	   (receive
	    ((tick)
	     (send playerpid (get (self)))
	     (receive
	      ((response pp aa)
	       (set p pp)
	       (set a aa)))
	     (send ctlpid (get (self)))
	     (receive
	      ((response ctls)
	       (set ds '(0 . 0))
	       (cond
		((member 'uping ctls)
		 (set ds '(8 . 0)))
		((member 'downing ctls)
		 (set ds '(-8 . 0))))
	       (cond
		((member 'lefting ctls)
		 (set a (c* a (euler 1 -0.1))))
		((member 'righting ctls)
		 (set a (c* a (euler 1 0.1)))))
	       (let ((dp (c* ds a)))
		 (if (canmove p a dp)
		     nil
		   (if (canmove p a (cons 0 (cdr dp)))
		       (setcar dp 0)
		     (if (canmove p a (cons (car dp) 0))
			 (setcdr dp 0)
		       (set dp '(0 . 0)))))
		 (set p (c+ p dp)))
	       (send playerpid (put p a))))))
	   (loop)))))

(define tileloop
  (lambda ()
    (doc 'post '(body listeners) 'keydown)
    (let ((tiles (tiletree mapdepth '(0 . 0) mapsize))
	  (visibles nil))
      (let loop ()
	   (receive
	    ((keydown k)
	     (cond
	      ((and editingp (= k 32))
	       (send playerpid (get (self)))
	       (receive
		((response p a)
		 (tiletreechange tiles p
				 (lambda (x)
				   (cons '(blockedp t) x))))))
	      ((= k 32)
	       (set firingp 2))))
	    ((isectp pid b)
	     (send pid (response (isectp tiles b))))
	    ((tick)
	     (send playerpid (get (self)))
	     (receive
	      ((response p a)
	       (let ((px (car p)) (py (cdr p)))
		 (let ((lb (cons (- px 240) (- py 200)))
		       (ub (cons (+ px 240) (+ py 200))))
		   (set visibles
			(tiletreequery tiles lb ub
				       (lambda (tile)
					 (_ tile blockedp)))))))))
	    ((get pid)
	     (send pid (response visibles)))
	    ((save name)
	     (spawn
	      (lambda ()
		(http 'put name (write tiles))
		(receive
		 ((response code) nil)))))
	    ((load pid name)
	     (spawn
	      (lambda ()
		(http 'get name)
		(receive
		 ((response code body)
		  (when (= code 200)
		    (set tiles (car (readall body))))
		  (send pid (response))))))))
	   (loop)))))

(define ctlloop
  (lambda ()
    (doc 'post '(body listeners) 'keydown)
    (doc 'post '(body listeners) 'keyup)
    (let ((lefting nil) (righting nil)
	  (uping nil) (downing nil))
      (let loop ()
	   (receive
	    ((keydown k)
	     (cond
	      ((= k 37) (set lefting t))
	      ((= k 39) (set righting t))
	      ((= k 38) (set uping t))
	      ((= k 40) (set downing t))))
	    ((keyup k)
	     (cond
	      ((= k 37) (set lefting nil))
	      ((= k 39) (set righting nil))
	      ((= k 38) (set uping nil))
	      ((= k 40) (set downing nil))))
	    ((get pid)
	     (let ((x nil))
	       (cond
		((and lefting righting) nil)
		(lefting (push x 'lefting))
		(righting (push x 'righting)))
	       (cond
		((and uping downing) nil)
		(uping (push x 'uping))
		(downing (push x 'downing)))
	       (send pid (response x)))))
	   (loop)))))
