(define pong
  (lambda ()
    (new (start startpong)
	 (quit quitpong))))

(define startpong
  (lambda ()
    (spawn pongmon)))

(define quitpong
  (lambda ()
    (when pongpid
      (send pongpid (quit)))))

(define pongpid nil)

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

(define pongballcolor 'lgreen)

(define runpong
  (lambda ()
    (let ((paddle1pid (spawnlink (paddleloop 37 39)))
	  (aipid (spawnlink ailoop))
	  (scorepid (spawnlink scoreloop)))
      (let ((ballpid (spawnlink (ballloop scorepid
					  paddle1pid
					  aipid))))
	(spawnlink (pongdrawloop scorepid ballpid
				 paddle1pid aipid))
	(receive
	 ((quit)
	  (exit 'quitting)))))))

(define scoreloop
  (lambda ()
    (let ((blue 0) (red 0))
      (let loop ()
	   (receive
	    ((blue)
	     (incr blue))
	    ((red)
	     (incr red))
	    ((get pid)
	     (send pid (response (write blue) (write red)))))
	   (loop)))))

(define ballloop
  (lambda (scorepid paddle1pid aipid)
    (lambda ()
      (let ((x 235) (y 200) (dx 8) (dy 20))
	(let loop ()
	     (receive
	      ((tick pid)
	       (set x (+ x dx))
	       (set y (+ y dy))
	       (send pid (response x y))
	       (when (= y 100)
		 (send paddle1pid (get (self)))
		 (receive
		  ((response px)
		   (cond
		    ((and (> x px) (< (- x px) 60))
		     (set dy (- 0 dy))
		     (set dx (+ dx (/ (- (- x px) 30) 10))))))))
	       (when (= y 300)
		 (send aipid (get (self)))
		 (receive
		  ((response px)
		   (cond
		    ((and (> x px) (< (- x px) 60))
		     (set dy (- 0 dy))
		     (set dx (+ dx (/ (- (- x px) 30) 10))))))))
	       (if (< dx 0)
		   (set dx (max dx -10))
		 (set dx (min dx 10)))
	       (cond
		((> y 400)
		 (set dy (- 0 dy))
		 (send scorepid (blue)))
		((< y 0)
		 (set dy (- 0 dy))
		 (send scorepid (red)))
		((> x 480) (set dx (- 0 dx)))
		((< x 0) (set dx (- 0 dx))))))
	     (loop))))))

(define paddleloop
  (lambda (lkey rkey)
    (lambda ()
      (let ((x 235) (dx 16)
	    (ctlpid (spawnlink (pongctlloop lkey rkey))))
	(let loop ()
	     (receive
	      ((tick pid)
	       (send ctlpid (get (self)))
	       (receive
		((response d)
		 (cond
		  ((= d 'lefting)
		   (set x (- x dx)))
		  ((= d 'righting)
		   (set x (+ x dx))))))
	       (send pid (response x)))
	      ((get pid)
	       (send pid (response x))))
	     (loop))))))

(define ailoop
  (lambda ()
    (let ((x 235) (dx 8))
      (let loop ()
	   (receive
	    ((tick pid ballx)
	     (cond
	      ((> (- ballx (+ x 30)) 10)
	       (set x (+ x dx)))
	      ((> (- (+ x 30) ballx) 10)
	       (set x (- x dx))))
	     (send pid (response x)))
	    ((get pid)
	     (send pid (response x))))
	   (loop)))))

(define pongdrawloop
  (lambda (scorepid ballpid paddle1pid aipid)
    (lambda ()
      (doc 'post '(pause listeners) 'click)
      (let ()
	(let loop ()
	     (receive
	      ((click id)
	       (cond
		((= id 'pause)
		 (doc 'put '(pause value) "resume")
		 (receive
		  ((click id)
		   (doc 'put '(pause value) "pause")
		   (cond
		    ((= id 'pause) nil)
		    ((= id 'quit) (exit 'quit))))))
		((= id 'quit)
		 (exit 'quit))))
	      ((after 40)
	       (box 'lblue 0 0 480 400)
	       (send paddle1pid (tick (self)))
	       (receive
		((response x)
		 (box 'dblue x 100 60 10)))
	       (send ballpid (tick (self)))
	       (receive
		((response x y)
		 (box pongballcolor x y 10 10)
		 (send aipid (tick (self) x))
		 (receive
		  ((response x)
		   (box 'dred x 300 60 10)))))
	       (send scorepid (get (self)))
	       (receive
		((response blue red)
		 (text 'dblue blue 130 200)
		 (text 'dred red 330 200)))))
	     (draw)
	     (loop))))))

(define pongctlloop
  (lambda (lkey rkey)
    (lambda ()
      (doc 'post '(body listeners) 'keydown)
      (doc 'post '(body listeners) 'keyup)
      (let ((lefting nil)
	    (righting nil))
	(let loop ()
	     (receive
	      ((keydown k)
	       (cond
		((= k lkey) (set lefting t))
		((= k rkey) (set righting t))))
	      ((keyup k)
	       (cond
		((= k lkey) (set lefting nil))
		((= k rkey) (set righting nil))))
	      ((get pid)
	       (cond
		((and lefting righting)
		 (send pid (response 'stopped)))
		(lefting
		 (send pid (response 'lefting)))
		(righting
		 (send pid (response 'righting)))
		(t (send pid (response 'stopped))))))
	     (loop))))))
