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

;; wildly unfinished, but this game plays like raptor: call of the shadows
;; or tyrian or whatever game you are used to

;; jon rafkind
;; 0.1 - 12/25/2006

(require (planet "game.ss" ("kazzmir" "allegro.plt")))
(require (prefix image- (planet "image.ss" ("kazzmir" "allegro.plt"))))
(require (planet "util.ss" ("kazzmir" "allegro.plt")))
(require (planet "sound.ss" ("kazzmir" "allegro.plt")))
(require (planet "jclass.ss" ("kazzmir" "java-class.plt")))
(require (only (lib "1.ss" "srfi") last-pair))
(require (lib "errortrace.ss" "errortrace"))

;; (require (lib "class.ss"))

(define-syntax (make/initialize stx)
  (syntax-case stx ()
    ((_ class arg ...)
     #'(let ((e (make class)))
	 (say e initialize arg ...)
	 e))))

(define-object star (x y) (brightness)

   (define (create)
     (set! x (random 640))
     (set! y (random 480))
     (let ((c (+ 128 (* 2 (random 32)))))
       (set! brightness (image-color c c c))))

   (define (can-collide obj) #f)

   (define (tick world)
     (set! y (add1 y))
     (when (> y 480)
       (set! y 0)))

   (define (draw world buffer)
     (image-circle-fill buffer x y 1 brightness))
   )

(define human-bullet
  (jclass
    extends Basic
    (constructor (x* y* dx* dy* damage*)
      (set! shape (list (make Point)))
      (set! x x*)
      (set! y y*)
      (set! dx dx*)
      (set! damage damage*)
      (set! dy dy*))

    (inherit-field x y)
    (public-fields dx dy shape damage)
  
    (override-method (shapes) shape)

    (override-method (touch world obj)
      (say world remove me))

    (override-method (tick world)
      (set! x (+ x dx))
      (set! y (+ y dy))
      (when (< y 0)
	(say world remove me)))

    (override-method (can-collide obj)
      (is-a? obj enemy))
    ))

(define plasma-bullet
  (jclass
    extends human-bullet
    (constructor (x* y*)
      (super-constructor x* y* 0 0 0.3)
      (set! health 2)
      (set! shape (cons (make Rectangle (width 2) (height 480))
			(let loop ((points '())
				   (y -240))
			  (if (< y 240)
			    (loop (cons (make Point (center-y y))
					points)
				  (add1 y))
			    points)))))

    (private-field health)
    (inherit-field shape x y)
    (constant size 2)
    
    (override-method (touch world obj)
      (void))

    (override-method (tick world)
      (set! health (sub1 health))
      (when (<= health 0)
	(say world remove me)))

    (override-method (draw world buffer)
      (image-rectangle-fill/translucent buffer 0 0 0 128
					(- x 2) (- y 240)
					(+ x 2) (+ y 240)
					(image-color 0 0 200)))
    ))

(define machine-bullet
  (jclass
    extends human-bullet
    (constructor (x* y* dx* dy*)
      (super-constructor x* y* dx* dy* 1))

    (inherit-field x y)

    (override-method (draw world buffer)
      (image-putpixel buffer x y (image-color 255 255 255)))
  ))

(define-object explosion (x y) (health dx dy size)

  (define (create)
    (set! health 10))

  (define (can-collide obj) #f)

  (define (initialize size* x* y* dx* dy*)
    (set! x x*)
    (set! y y*)
    (set! size size*)
    (set! dx dx*)
    (set! dy dy*))

  (define (draw world buffer)
    (image-circle-fill buffer
		       (round* x) (round* y)
		       size
		       (image-color (- 255 (* health 10))
				    0 0)))

  (define (tick world)
    (set! health (sub1 health))
    (set! x (+ x dx))
    (set! y (+ y dy))
    (when (< health 0)
      (say world remove me)))
  )

(define-object enemy-bullet (x y) (dx dy)

   (define (initialize x* y* dx* dy*)
     (set! x x*)
     (set! y y*)
     (set! dx dx*)
     (set! dy dy*))

   (define (tick world)
     (set! x (+ x dx))
     (set! y (+ y dy))
     (when (or (< x 0)
	       (> x 640)
	       (< y 0)
	       (> y 480))
       (say world remove me)))

   (define (shapes)
     (list (make Point)))

   (define (draw world buffer)
     (image-circle-fill buffer (round* x) (round* y) 2 (image-color 0 128 128)))
   )

(define enemy
  (jclass extends Basic
    (constructor (x* y* dx* dy* health*)
      (set! x x*)
      (set! y y*)
      (set! dx dx*)
      (set! dy dy*)
      (set! health health*))

    (override-method (can-collide obj)
      (or (is-a? obj human-bullet)
	  (is-a? obj human)))

    (override-method (touch world obj)
      (set! health (- health (get-field damage obj))))

    (override-method (tick world)
      (set! y (+ y dy))
      (set! x (+ x dx))
      (when (> y 480)
	(say world remove me)))

    (inherit-field x y)
    (public-fields dx dy health)
    ))

;; make a color gradient from color1 -> color2 -> color1
(define (connected-gradient color1 color2 num)
  (let ((a (blend-palette color1 color2 num))
	(b (blend-palette color2 color1 num)))
    (set-cdr! (last-pair a) b)
    (set-cdr! (last-pair b) a)
    a))

(define powerup%
  (jclass extends Basic
     (constructor (x* y* type*)
       (set! x x*)
       (set! y y*)
       (let-values (((start end) (color-type type*)))
	 (set! gradient (connected-gradient start end 15)))
       (set! type type*))

     (private-fields type gradient)
     (inherit-field x y)
     (constant size 5)

     (define (color-type type)
       (case type
	 ((red) (values (image-color 100 0 0)
			(image-color 255 0 0)))
	 ((green) (values (image-color 0 100 0)
			  (image-color 0 255 0)))
	 ((blue) (values (image-color 0 0 100)
			 (image-color 0 0 255)))))

     (override-method (can-collide obj)
       (is-a? obj human))

     (override-method (shapes)
       (list (make Circle (radius size))))

     (override-method (touch world obj)
       (say obj powerup type)
       (say world remove me))

     (override-method (draw world buffer)
       (image-circle-fill buffer x y 4 (car gradient))
		    #;
       (image-circle-fill buffer x y 4 (image-color 255 255 255)))

     (override-method (tick world)
       (set! gradient (cdr gradient))
       (set! y (+ y 2))
       (when (> y 480)
	 (say world remove me)))

     ))

(define small-enemy
  (jclass extends enemy
    (constructor (x* y*)
      (super-constructor x* y* 0 2 5)
      (set! shape (make Circle (radius size))))

    (constant size 8)

    (private-fields shape)
    (inherit-field x y dx dy health)

    (override-method (shapes)
      (list shape))

    (define (angle-to-human world)
      (let ((h (say world get-object (lambda (n) (is-a? n human)))))
	(if (not (null? h))
	  (calculate-normal-angle x y (say h get-x) (say h get-y))
	  #f)))

    (define (shoot-at-player world speed)
      (let ((ang (angle-to-human world)))
	(when ang
	  (add-object world (make/initialize enemy-bullet
					     x y
					     (* speed (Cosine ang))
					     (* speed (Sine ang)))))))

    (override-method (tick world)
      (constant speed 4)
      (super tick world)
      (when (= 0 (random 100))
	(shoot-at-player world speed)))

    (define (explode world explosions)
      (define (random-movement)
	(/ (- (random 20) 10)
	   (add1 (random 10))))
      (repeat
	(lambda ()
	  (add-object world
		      (make/initialize explosion
				       (add1 (random 5))
				       x y
				       (+ dx (random-movement))
				       (+ dy (random-movement)))))
	explosions))

    (public-method (died world)
      (when (= 0 (random 20))
	(add-object world (new powerup% x y 'red))))

    (override-method (touch world obj)
      (super touch world obj)
      (explode world 1)
      (when (< health 0)
	(explode world 8)
	(say me died world)
	(say world remove me)))

    (override-method (draw world buffer)
      (image-circle-fill buffer x y size (image-color 0 0 255)))
))

(define big-enemy
  (jclass extends enemy
    (constructor (x* y*)
      (super-constructor x* y* 0 0.5 15))
    
    (constant size 16)

    (private-field shape (make Circle (radius size)))
    (inherit-field x y dx dy health)

    (override-method (shapes)
      (list shape))

    (override-method (touch world obj)
      (define (random-movement)
	(/ (- (random 20) 10)
	   (add1 (random 10))))
      (super touch world obj)
      (add-object world (make/initialize explosion
					 (add1 (random 5))
					 x y
					 (+ dx (random-movement))
					 (+ dy (random-movement))))
      (when (< health 0)
	(repeat
	  (lambda ()
	    (add-object world
			(make/initialize explosion
					 (add1 (random 5))
					 x y
					 (+ dx (random-movement))
					 (+ dy (random-movement)))))
	  8)
	(say world remove me)))

    (override-method (draw world buffer)
      (image-circle-fill buffer (round* x) (round* y) size (image-color 0 255 0)))
    ))

(define-generator enemy-generator
	   (every (+ 10 (random 20))
		  (lambda (world)
		    (add-object world (new small-enemy (random 640) -5))))
	   (every (+ 40 (random 40))
		  (lambda (world)
		    (add-object world (new big-enemy (random 640) -5)))))

(define gun^ (jinterface make-bullet))

(define-syntax define-gun
  (syntax-rules (make wait)
    ((_ name (wait : wait-time) (make (world x y) expr ...))
     (begin
       (define name
	 (jclass
	   implements (gun^)
	   (constructor () (void))
	   (private-field hold wait-time)

	   (public-method (make-bullet world x y)
	     (if (<= hold 0)
	       (begin
		 expr ...
		 (set! hold wait-time))
	       (set! hold (sub1 hold))))
	   ))))))

(define-gun single-machine-gun%
	    (wait : 2)
	    (make (world x y)
	      (add-object world (new machine-bullet x y 0 -8))))

(define-gun double-machine-gun%
	    (wait : 3)
	    (make (world x y)
	      (add-object world (new machine-bullet (- x 3) y 0 -8))
	      (add-object world (new machine-bullet (+ x 3) y 0 -8))))

(define-gun single-machine-fast-gun%
	    (wait : 0)
	    (make (world x y)
	      (add-object world (new machine-bullet x y 0 -8))))

(define-gun double-machine-fast-gun%
	    (wait : 0)
	    (make (world x y)
	      (add-object world (new machine-bullet (- x 3) y 0 -8))
	      (add-object world (new machine-bullet (+ x 3) y 0 -8))))

(define-gun triple-machine-gun%
	    (wait : 1)
	    (make (world x y)
	      (add-object world (new machine-bullet (- x 5) y 0 -8))
	      (add-object world (new machine-bullet x (- y 2) 0 -8))
	      (add-object world (new machine-bullet (+ x 5) y 0 -8))))

(define-gun plasma-gun%
	    (wait : 10)
	    (make (world x y)
	      (add-object world (new plasma-bullet x (- y 240)))))

(define (make-gun type power)
  (define (make-red-gun)
    (case power
      ((0) (new single-machine-gun%))
      ((1) (new double-machine-gun%))
      ((2) (new single-machine-fast-gun%))
      ((3) (new double-machine-fast-gun%))
      ((4) (new triple-machine-gun%))
      (else (make-gun 'red 4))))
  (define (make-green-gun)
    (case power
      ((0) (new plasma-gun%))))
  (case type
    ((red) (make-red-gun))
    ((green) (make-green-gun))))

(define-object human (x y phase) (gun power)

  (define (create)
    (set! power 0)
    (set! phase 1)
    (set! gun (make-gun 'red power)))

  (define (set-x! x*)
    (set! x x*))

  (define (set-y! y*)
    (set! y y*))

  (define (damage) 3)

  (define (powerup type)
    (set! power (add1 power))
    (set! gun (make-gun type power)))

  (define (can-collide obj)
    (not (or (is-a? obj human)
	     (is-a? obj human-bullet))))

  (define (draw world buffer)
    (image-triangle buffer
		    (- x 5) (+ y 5)
		    (+ x 5) (+ y 5)
		    x (- y 5)
		    (image-color 200 100 0)))

  (define (find-level world)
    (say world get-object (lambda (x) (is-a? x level))))

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

  (define (died world)
    (say world remove me)
    (let ((time-left 20))
      (add-object world
		  (new (jclass extends Basic
			 (constructor () (void))
			 (override-method (tick world)
			   (set! time-left (sub1 time-left))
			   (when (<= time-left 0)
			     (let ((l (find-level world)))
			       (say l make-level world)))))))))

  (define (touch world object)
    (when (not (is-a? object powerup%))
      (died world)))

  (constant speed 4)

  (define (key world keys)
    (for-each (lambda (key)
		(case key
		  ((F12) (image-save-screen "screenshot.png"))
		  ((UP PAD-8) (set! y (- y speed)))
		  ((DOWN PAD-2) (set! y (+ y speed)))
		  ((LEFT PAD-4) (set! x (- x speed)))
		  ((RIGHT PAD-6) (set! x (+ x speed)))
		  ((SPACE ENTER_PAD)
		   (say gun make-bullet world x y)))
		(when (< x 0)
		  (set! x 0))
		(when (> x 640)
		  (set! x 640))
		(when (< y 0)
		  (set! y 0))
		(when (> y 470)
		  (set! y 470))
		)
	      keys))
  )

(define level
  (jclass extends Basic
    (constructor (world num*)
      (set! guy (make human))
      (set! level-num num*)
      (set! display-level (show-level 0))
      (make-level world))

    (private-field guy)
    (private-field level-num)
    (private-field display-level)

    (define (show-level num)
      (let ((white (image-color 255 255 255)))
	(lambda (buffer)
	  (when (> num 0)
	    (image-print-translucent buffer 320 240 white
				     128 (format "Level ~a" level-num))
	    (set! num (sub1 num))))))

    (override-method (draw world buffer)
      (display-level buffer))

    (override-method (can-collide obj) #f)

    (public-method (make-level world)
      (define (add-stars num)
	(repeat (lambda () (add-object world (make star))) num))

      (set! display-level (show-level 100))

      (say world remove-all)
      (add-stars 100)
      (say guy set-x! 320)
      (say guy set-y! 470)
      (add-object world me)
      (add-object world (make enemy-generator))
      (add-object world guy))
    ))

#;
(define-object level () (guy time)

   (define (create)
     (set! time 0)
     (set! guy (make human)))

   (define (tick world)
     (when (= time 0)
       (make-level world)
       (set! time 10000))
     (set! time (sub1 time)))

   (define (make-level world)
     (say world remove-all)
     (repeat (lambda ()
	       (add-object world (make star)))
	     100)
     (say guy set-x! 320)
     (say guy set-y! 470)
     (add-object world me)
     (add-object world (make enemy-generator))
     (add-object world guy)))

(define (repeat thunk times)
  (let loop ((n times))
    (when (> n 0)
      (thunk)
      (loop (sub1 n)))))

(define world (make-world))

(start world (lambda (world) (add-object world (new level world 1))))