(module game mzscheme

  (require (lib "list.ss"))
  (require (lib "async-channel.ss"))
  (require "util.ss")
  (require "keyboard.ss")
  (require (prefix mouse- "mouse.ss"))
  (require (prefix image- "image.ss"))

  (require (lib "math.ss"))
  (require (lib "etc.ss"))

  (require (lib "class.ss"))

  (define (real->int i) (inexact->exact (round (+ i 0.5))))
  (provide real->int)

  ;; send a method to an object but if the method
  ;; doesn't exist return void
  (provide send**)
  (define-syntax (send** stx)
    (syntax-case stx ()
      ((_ obj method args ...)
       (with-syntax ((num-args (length (syntax->list (syntax (args ...))))))
         #`(begin
	     #;
	     (printf "~a has method ~a ~a = ~a\n" obj 'method num-args
		     (object-method-arity-includes? obj 'method num-args))
	     (if (object-method-arity-includes? obj 'method num-args)
	       (send obj method args ...)
	       (void)))))))

  (provide basic2)
  (define basic2
    (class* object% ()

	    (init-field (phase 0))
	    (init-field (x 0))
	    (init-field (y 0))

	    (define/public (can-collide obj) #t)

	    (define/public (shapes) (list))
       
	    (define/public (get-x) x)
	    (define/public (get-y) y)

	    (begin
	      (super-new))

	    ))

  ;; min-x : () x coordinate furthest to the left
  ;; max-x : () x coordinate furthest to the right
  ;; min-y : () y coordinate furthest to the top( decreasing )
  ;; max-y : () y coordinate furthest to the bottom( increasing )
  ;; collide : (x y shape shape-x shape-y) #t if this touches `shape', else #f
  ;; inside : (x y sx sy) #t if sx sy is inside this shape
  (provide shape^)
  (define shape^
    (interface () min-x max-x min-y max-y collide inside))

  (define shape%
    (class* object% ()
      (super-new)
      (init-field (center-x 0) (center-y 0))))

  (provide rectangle%)
  (define rectangle%
    (class* shape% (shape^)
      (super-new)

      (init-field (width 0) (height 0))

      (define/public (inside x y sx sy)
        (and (<= (- x width) sx)
	     (>= (+ x width) sx)
	     (<= (- y height) sy)
	     (>= (+ y height) sy)))

      (define/public (collide x y shape sx sy)
        (cond
	  ((is-a? shape point%) (inside x y sx sy))
	  ((is-a? shape rectangle%)
	   (let ((shape-w (get-field width shape))
		 (shape-h (get-field height shape)))
	     (or
	       ;; upper right
	       (inside x y (+ sx shape-w) (- sy shape-h))
	       ;; upper left
	       (inside x y (- sx shape-w) (- sy shape-h))
	       ;; lower right
	       (inside x y (+ sx shape-w) (+ sy shape-h))
	       ;; lower left
	       (inside x y (- sx shape-w) (+ sy shape-h)))))
	  (else
	    ;; check some points around the perimeter and the middle
	    (let ((check (lambda (mx my) (send shape inside sx sy mx my))))
	      (or
		;; check middle of him
		(inside x y sx sy)
		;; check middle of us
		(check x y)
		(check (+ x width) (- y height))
		(check (+ x width) y)
		(check (+ x width) (+ y height))
		(check (- x width) (- y height))
		(check (- x width) y)
		(check (- x width) (+ y height))
		(check x (+ y height))
		(check x (- y height)))))))

      (define/public (min-x) (- width))
      (define/public (max-x) (+ width))
      (define/public (min-y) (- height))
      (define/public (max-y) (+ height))

      ))

  (provide circle%)
  (define circle%
    (class* shape% (shape^)

       (super-new)

       (init-field (radius 0))

       (define (dist x1 y1 x2 y2)
	 (let ((x (- x1 x2))
	       (y (- y1 y2)))
	   (sqrt (+ (* x x) (* y y)))))

       (define/public (inside x y sx sy)
          (< (dist x y sx sy) radius))

       (define/public (collide x y shape sx sy)
          (cond
	    ((is-a? shape point%) (inside x y sx sy))
	    ;; let the rectangle handle collision detection
	    ((is-a? shape rectangle%) (send shape collide sx sy this x y))
	    ((is-a? shape circle%)
	     (< (dist x y sx sy)
		(+ radius (get-field radius shape))))
	    (else
	      ;; check a handful of points
	      (call/cc (lambda (n)
			 (for-each
			   (lambda (r)
			     (for-each
			       (lambda (ang)
				 (let-values
				   (((cx cy) (values
					       (+ x (* r (cos (/ (* pi ang) 180))))
					       (+ y (* r (sin (/ (* pi ang) 180)))))))
				   (when (send shape inside sx sy cx cy)
				      (n #t))))
			       (build-list 10 (lambda (q) (* q 36)))))
			   (build-list (real->int (/ radius 2)) (lambda (q) (* q 2))))
			 (n #f))))))

       (define/public (min-x) (- radius))
       (define/public (max-x) (+ radius))
       (define/public (min-y) (- radius))
       (define/public (max-y) (+ radius))

       ))

  (provide point%)
  (define point%
    (class* shape% (shape^)
       (super-new)

       (define/public (inside x y sx sy)
         (and (= x sx)
	      (= y sy)))


       (define/public (collide x y shape sx sy)
         (send shape inside sx sy x y))

       (define/public (min-x) 0)
       (define/public (max-x) 0)
       (define/public (min-y) 0)
       (define/public (max-y) 0)))

  (provide animation)
  (define animation
    (class* object% ()
      (super-new)

      (init-field (speed 0))

      (field (pics '())
	     (counter 0)
	     (current pics))

      (define/public (add-animation image)
        (if (null? pics)
	  (begin
	    (set! pics (list image))
	    (set! current pics))
	  (set! pics (append pics (list image)))))

      (define/public (draw buffer x y)
	(when (not (null? current))
	  (image-draw buffer (car current)
		      (- x (/ (image-width (car current)) 2))
		      (- y (/ (image-height (car current)) 2)))))

      (define/public (next-animation)
	(set! counter (add1 counter))
	(when (>= counter speed)
	  (set! counter 0)
	  (if (null? current)
	    (set! current pics)
	    (set! current (cdr current)))))

      ))

  (provide make-animation-from-files)
  (define (make-animation-from-files files speed)
    (let ((a (new animation (speed speed))))
      (for-each (lambda (f)
		  (send a add-animation (image-create-from-file f)))
		files)
      a))

  (define world2
    (class* basic2 ()

	    (field (objects '()))
	    (field (collider (new binary-space-partition%)))

	    (define/public (key keys)
               (for-each (lambda (o) (send** o key this keys))
			 objects))

	    (define/public (add obj)
              (set! objects (cons obj objects)))

	    #;
	    (define/public (start)
               (for-each (lambda (o) (send** o start this)) objects))

	    (define/public (tick)
              (for-each (lambda (o)
			  (send** o tick this)
			  (send collider add-object o))
			objects))

	    (define/public (draw buffer)
              (for-each (lambda (o) (send** o draw this buffer))
			(sort objects
			      (lambda (a b)
				(<= (get-field phase a)
				    (get-field phase b)))
			      )))

	    (define/public (remove obj)
              (set! objects (filter (lambda (x) (not (eqv? x obj))) objects))
	      (for-each (lambda (n) (send** n death this obj)) objects))

	    (define/public (remove-all)
              (set! objects '()))

	    (define/public (get-objects)
              objects)

	    (define/public (get-object pred)
              (let loop ((objs objects))
		(cond
		  ((null? objs) '())
		  ((pred (car objs)) (car objs))
		  (else (loop (cdr objs))))))

	    (define/public (reset-collisions)
              (send collider clear))

	    (define (collision x1 y1 shapes1 x2 y2 shapes2)
	      (call/cc (lambda (k)
			 (for-each
			   (lambda (s1)
			     (for-each
			       (lambda (s2)
				 (when (send s1 collide
					     (+ x1 (get-field center-x s1))
					     (+ y1 (get-field center-y s1))
					     s2
					     (+ x2 (get-field center-x s2))
					     (+ y2 (get-field center-y s2)))
				   (k #t)))
			       shapes2))
			   shapes1)
			 (k #f))))

	    (define/public (collide)
              ;; `pairs' keeps track of objects that touch each other
	      ;; it could be the case that two objects are in two seperate
	      ;; partitions and intersect with each other in both partitions
	      ;; this would result in the 'touch' message being recieved
	      ;; twice by each object. To remedy this each time two objects
	      ;; collide they are stored in a hash table and can only collide
	      ;; if the two objects dont appear in the hash table
              (let ((pairs (make-hash-table 'equal)))
		(send collider iterate
		      (lambda (a b)
			(if (and (send a can-collide b)
				 (send b can-collide a)
				 (not (hash-table-get pairs (cons a b) #f))
				 (not (hash-table-get pairs (cons b a) #f)))
			  (when (collision
				  (get-field x a)
				  (get-field y a)
				  (send** a shapes)
				  (get-field x b)
				  (get-field y b)
				  (send** b shapes))
			    (hash-table-put! pairs (cons a b) #t)
			    (hash-table-put! pairs (cons b a) #t)
			    (send** a touch this b)
			    (send** b touch this a)))))))

	    (begin
	      (super-new))

	    ))

  (define binary-space-partition%
    (class* object% ()
	    (super-new)
	    (public add-object iterate)

	    ;; partitions is a list of things where each thing is
	    ;; a cons cell of x,y coordinates and a list of elements
	    ;; (list (cons x y) obj1 obj2 obj3 ...)
	    (define partitions '())

	    (define partition-size 100)

	    (define/public (clear)
              (set! partitions '()))

	    ;; iterate through the partitions and call some function
	    ;; on each element
	    (define (iterate fun)
	      (for-each (lambda (partition)
			  (let loop ((objs (cdr partition)))
			    (when (not (null? objs))
			      (let loop2 ((objs2 (cdr objs)))
				(when (not (null? objs2))
				  (begin
				    (fun (car objs) (car objs2))
				    (loop2 (cdr objs2)))))
			      (loop (cdr objs)))))
			partitions))

	    ;; lazily make new partitions and/or return a partition
	    ;; for a given coordinate pair (x,y)
	    (define (get-partition x y)
	      (let loop ((ps partitions))
		(cond
		  ((null? ps) (let ((space (list (cons x y))))
				(set! partitions (cons space partitions))
				space))
		  ((let ((coords (caar ps)))
		     (and (= (car coords) x)
			  (= (cdr coords) y)))
		   (car ps))
		  (else (loop (cdr ps))))))

	    (define (add-object element)
	      ;; calculate maximum coordinates in each direction
	      ;; minimum x( left )
	      ;; maximum x( right )
	      ;; minimum y( top )
	      ;; maximum y( bottom )
	      (when (not (null? (send** element shapes)))
		(let-values (((left right top bottom)
			      (let loop ((shapes (send** element shapes))
					 (left 0)
					 (right 0)
					 (top 0)
					 (bottom 0))
				(if (null? shapes)
				  (values left right top bottom)
				  (let ((s (car shapes))
					(rest (cdr shapes)))
				    (loop rest
					  (min left (send s min-x))
					  (max right (send s max-x))
					  (min top (send s min-y))
					  (max bottom (send s max-y))))))))
			    (let* ((ex (real->int (get-field x element)))
				   (ey (real->int (get-field y element)))
				   (x1 (- ex left))
				   (y1 (- ey top))
				   (x2 (+ ex right))
				   (y2 (- ey top))
				   (x3 (- ex left))
				   (y3 (+ ey bottom))
				   (x4 (- ex right))
				   (y4 (+ ey bottom))
				   (pairs (list (cons (quotient x1 partition-size) 
						      (quotient y1 partition-size))
						(cons (quotient x2 partition-size) 
						      (quotient y2 partition-size))
						(cons (quotient x3 partition-size) 
						      (quotient y3 partition-size))
						(cons (quotient x4 partition-size) 
						      (quotient y4 partition-size)))))
			      ;; filter list into unique coordinate pairs
			      (let ((coordinates (foldl (lambda (x y)
							  (let loop ((ys y))
							    (cond
							      ((null? ys) (cons x y))
							      ((or (not (= (car x) (caar ys)))
								   (not (= (cdr x) (cdar ys))))
							       (loop (cdr ys)))
							      (else y))))
							'()
							pairs)))
				;; for each pair of coodinates add the element to the
				;; corresponding partition space
				(for-each (lambda (c)
					    (let ((p (get-partition (car c) (cdr c))))
					      (append! p (list element))))
					  coordinates))))))
	    ))

   (provide make-world)
   (define (make-world)
     (new world2))
         
  (provide add-object)
  (define (add-object world n)
    (send world add n))

  (provide (rename mouse-x get-mouse-x)
	   (rename this me)
	   Cosine Sine
	   (rename mouse-y get-mouse-y)
	   (rename mouse-left-click? left-clicking?)
	   (rename mouse-right-click? right-clicking?)
	   (rename mouse-get-mickeys get-mouse-movement))

  ;; a basic object is simply a list of fields and methods
  (provide define-object)
  (define-syntax (define-object stx)
    (syntax-case stx (define)
      ((_ name (inherit ...) (var ...)
	  remaining ...)
       ;; set all fields as #f to begin with
       (with-syntax (((inits ...) (map (lambda (n) (list n #f))
				      (syntax->list #'(var ...))))
		     ((rest ...) (map
				   (lambda (stx)
				     (syntax-case stx (define constant)
				       ((constant id value)
					#'(define id value))
				       ((define (method args ...) body ...)
					(syntax-case (syntax method) (shapes can-collide)
                                          (shapes #'(define/override (shapes args ...) body ...))
					  (can-collide #'(define/override (can-collide args ...) body ...))
					  (else #'(define/public (method args ...) body ...))))))
				   (syntax->list (syntax (remaining ...))))))
         #'(define name
	     (class* basic2 ()
	       (inherit-field inherit ...)
	       (init-field inits ...)
	       rest ...

	       ;; constructor
	       (begin
		 (super-new)
		 (send** this create))))))
      ))
  #;
  (define-syntax (define-object stx)
    (syntax-case stx (define)
      ((_ name (inherit ...) (var ...)
	  (define (method args ...) body ...) ...)
       ;; set all fields as #f to begin with
       (with-syntax (((inits ...) (map (lambda (n) (list n #f))
				      (syntax->list #'(var ...))))
		     ((defines ...) (map (lambda (n)
					   (syntax-case n (shapes can-collide)
                                             (((shapes args ...) body ...) #'(define/override (shapes args ...) body ...))
					     (((can-collide args ...) body ...) #'(define/override (can-collide args ...) body ...))
					     (else (datum->syntax-object #'n (append (list 'define/public) n) #'n))))
					 (syntax->list (syntax (((method args ...) body ...) ...))))))
         #'(define name
	     (class* basic2 ()
	       (inherit-field inherit ...)
	       (init-field inits ...)
	       defines ...

	       ;; constructor
	       (begin
		 (super-new)
		 (send** this create))))))
      ))

  (provide (rename send** say)
	   is-a?
	   (rename new make))
   
  (define (start-real world first done)
    (easy-init 640 480 16)
    (first world)
    (game-loop
      (lambda ()
	;; (printf "Current keys = ~a\n" (current-keys))
	(send world reset-collisions)
	(let ((keys (current-keys)))
	  (when (not (null? keys))
	    (send** world key keys)))
	(send** world tick)
	(send** world collide)
	(keypressed? 'ESC))
      (lambda (buffer)
	(send** world draw buffer))
      (fps 30))
    (done world)
    (easy-exit))

  (provide start)
  (define start
    (case-lambda
      ((world) (start world (lambda () (void))))
      ((world first) (start world first (lambda () (void))))
      ((world first last) (start-real world first last))))

)