#! /bin/sh
#|
exec mzscheme -qr "$0" ${1+"$@"}
|#

;; pong!
;; use up/numpad 8 and down/numpad 2 to control
;; computer and ball progressively get faster

;; jon rafkind
;; 12/25/2006

(require (planet "game.ss" ("kazzmir" "allegro.plt")))
(require (prefix image- (planet "image.ss" ("kazzmir" "allegro.plt"))))
(require (lib "etc.ss"))

(define player-score 0)
(define computer-score 0)

(define (player-win) (set! player-score (add1 player-score)))
(define (computer-win) (set! computer-score (add1 computer-score)))

(define-object human (x y) (size)
  (define (create)
    (set! size 20)
    (set! x 10)
    (set! y 320))

  (constant width 4)

  (define (x1)
    (- x width))
  
  (define (x2)
    (+ x width))

  (define (y1)
    (- y size))
  
  (define (y2)
    (+ y size))

  (constant speed 5)

  (define (shapes)
    (let loop ((cs '())
	       (y (- (+ size width))))
      (if (<= y (+ width size))
	(loop (cons (make Circle (radius width) (center-y y))
		    cs)
	      (+ y width))
	cs)))

  (define (key world keys)
    (for-each (lambda (k)
		(case k
		  ((F12) (image-save-screen "screenshot.png"))
		  ((PAD-2 DOWN) (set! y (+ speed y)))
		  ((PAD-8 UP) (set! y (- y speed)))))
	      keys)
    (set! y (max y (* size 1)))
    (set! y (min y (- 480 (* size 1)))))

  (define (draw world buffer)
    (image-rectangle-fill buffer (x1) (y1) (x2) (y2) (image-color 255 255 255))
    (let ((mx (round* (/ (+ (x1) (x2)) 2)))
	  (radius width)
	  (color (image-color 255 255 255)))
      (image-circle-fill buffer mx (y1) radius color)
      (image-circle-fill buffer mx (y2) radius color))
    )
  )

(define-object ball (x y) (speed angle radius)

  (define (create)
    (set! speed 3)
    (set! radius 5)
    (set! angle 45)
    (set! x 320)
    (set! y 240))

  (define (shapes)
    (list (make Circle (radius radius))))

  (define (quadrant-1? a)
    (and (<= a 90) (>= a 0)))

  (define (quadrant-2? a)
    (and (>= a 90) (<= a 180)))

  (define (quadrant-3? a)
    (and (<= a 270) (>= a 180)))

  (define (quadrant-4? a)
    (and (>= a 270) (<= a 360)))

  (define (bounce-x a)
    (cond
      ((quadrant-1? a) (- 180 a))
      ((quadrant-2? a) (- 180 a))
      ((quadrant-3? a) (- 360 (- a 180)))
      ((quadrant-4? a) (+ 180 (- 360 a)))
      (else (bounce-x (- a 360)))))

  (define (bounce-y a)
    (cond
      ((quadrant-1? a) (- 360 a))
      ((quadrant-2? a) (+ 180 (- 180 a)))
      ((quadrant-3? a) (- 180 (- a 180)))
      ((quadrant-4? a) (- 360 a))
      (else (bounce-y (- a 360)))))

  (define (touch world obj)
    (set! angle (bounce-x angle)))

  (define (tick world)
    (let ((dx (* speed (Cosine angle)))
	  (dy (* speed (Sine angle))))
      (set! speed (+ speed 0.002))
      (set! x (+ x dx))
      (set! y (+ y dy)))
    (when (or (< x 0) (> x 640))
      (cond
	((> x 640) (player-win))
	((< x 0) (computer-win)))
      (let ((computer (say world get-object (lambda (o) (is-a? o computer)))))
	(say computer reset))
      (set! x 320)
      (set! y 240)
      (set! speed (/ speed 2)))
    (when (or (< y 0) (> y 480))
      (set! angle (bounce-y angle))))

  (define (draw world buffer)
    (image-circle-fill buffer (round* x) (round* y) radius (image-color 255 255 255)))
  )

(define-object computer (x y) (size radius speed)

  (define (create)
    (set! x (- 640 10))
    (set! speed 3)
    (set! size 20)
    (set! y 240))

  (constant width 4)

  (define (x1)
    (round* (- x width)))
  
  (define (x2)
    (round* (+ x width)))

  (define (y1)
    (round* (- y size)))
  
  (define (y2)
    (round* (+ y size)))

  (define (shapes)
    (let loop ((cs '())
	       (y (- (+ size width))))
      (if (<= y (+ width size))
	(loop (cons (make Circle (radius width) (center-y y))
		    cs)
	      (+ y width))
	cs)))

  (define (reset)
    (set! speed (/ speed 2)))

  (define (get-speed y*)
    (min (abs (- y y*)) speed))

  (define (tick world)
    (set! speed (+ 0.001 speed))
    (let ((ball (say world get-object (lambda (o) (is-a? o ball)))))
      (let* ((ball-y (say ball get-y))
	     (speed (get-speed ball-y)))
	(cond
	  ((< y ball-y) (set! y (min (- 480 (+ size width)) (+ speed y))))
	  ((> y ball-y) (set! y (max (+ size width) (- y speed))))))))

  (define (draw world buffer)
    (image-rectangle-fill buffer (x1) (y1) (x2) (y2) (image-color 255 255 255))
    (let ((mx (round* (/ (+ (x1) (x2)) 2)))
	  (radius width)
	  (color (image-color 250 250 250)))
      (image-circle-fill buffer mx (y1) radius color)
      (image-circle-fill buffer mx (y2) radius color)))
  )

(define-object background (phase) (meld)

  (define (create)
    (set! meld 0)
    (set! phase -1))

  #;
  (define (draw world buffer)
    (define (boxes start end size step)
      (define (x1 n) (+ step (modulo n 640)))
      (define (x2 n) (+ step size (modulo n 640)))
      (define (y1 n) (round* (/ n 5)))
      (define (y2 n) (round* (+ step size (/ n 5))))
      (define (color n) (let ((c (+ 15 (modulo n 150))))
			  (image-color c c c)))
      (let loop ((n start))
	(when (< n end)
	  (image-rectangle-fill/translucent
	    buffer
	    0 0 0 128
	    (x1 n) (y1 n) (x2 n) (y2 n)
	    (color n))
	  (loop (+ n (* size 2))))))
      (boxes 30 800 200 -20)
      (boxes 90 9200 100 100) 
      (boxes 300 8000 30 12)
      (boxes 300 8000 150 30)
      (boxes -20 15000 55 4)
      )

  (define (tick world)
    (void)
    #;(set! meld (add1 meld)))

  (define (draw world buffer)
    (define (fy y) (* y 48))
    (define (fx x) (* x 64))
    (define (c x y) (+ 40 (modulo (+ meld x y) 50)))
    (for-each (lambda (y)
		(for-each (lambda (x)
			    (let* ((n (c x y))
				   (color (image-color n n n)))
			    (image-rectangle-fill buffer
						  (fx x) (fy y)
						  (fx (add1 x)) (fy (add1 y))
						  color)))
			  (build-list 10 (lambda (x) x))))
	      (build-list 10 (lambda (x) x)))
    (image-rectangle-fill buffer (- 320 1) 0 (+ 320 1) 480 (image-color 255 255 255))
    (image-print buffer 10 10 (image-color 255 255 255) -1 (format "Player ~a Computer ~a" player-score computer-score))
    )
  )

(define world (make-world))
(start world (lambda (w)
	       (add-object w (make background))
	       (add-object w (make computer))
	       (add-object w (make ball))
	       (add-object w (make human))))