(module image mzscheme

  (require (lib "foreign.ss")) (unsafe!)
  (require (prefix a: "private/allegro.ss"))

  (define-struct image (bitmap width height))

  ;; All functions in this module that work on an image
  ;; have the first argument the image that is to be modified.
  ;; Any extra image parameters come after.

  ;; defines 'name' and 'name-screen'
  ;; name = (lambda image args ...)
  ;; name-screen = (name (screen) args ...)
  (define-syntax (define/screen stx)
    (syntax-case stx ()
      ((_ (name image args ...) bodys ...)
       (with-syntax ((name-screen 
		       (datum->syntax-object
			 #'name
			 (string->symbol
			   (format "~a-screen" 
				   (symbol->string 
				     (syntax-object->datum #'name))))
			 #'name)))
         #'(begin
	     (define (name image args ...) bodys ...)
	     (define (name-screen args ...)
	       (name (screen) args ...)))))
      ((_ name bodys ...)
       (with-syntax ((name-screen 
		       (datum->syntax-object
			 #'name
			 (string->symbol
			   (format "~a-screen" 
				   (symbol->string 
				     (syntax-object->datum #'name))))
			 #'name)))
         #'(begin
	     (define name bodys ...)
	     (define (name-screen . args)
	       (apply name (screen) args)))))))

  ;; im sure this can be combined with the above
  (define-syntax (define/screen* stx)
    (syntax-case stx ()
      ((_ (name image args ...) bodys ...)
       (with-syntax ((name-screen 
		       (datum->syntax-object
			 #'name
			 (string->symbol
			   (format "~a-screen" 
				   (symbol->string 
				     (syntax-object->datum #'name))))
			 #'name)))
         #'(begin
	     (provide name name-screen)
	     (define/screen (name image args ...) bodys ...))))
      ((_ name bodys ...)
       (with-syntax ((name-screen 
		       (datum->syntax-object
			 #'name
			 (string->symbol
			   (format "~a-screen" 
				   (symbol->string 
				     (syntax-object->datum #'name))))
			 #'name)))
         #'(begin
	     (provide name name-screen)
	     (define/screen name bodys ...))))))

  (provide (rename image-width width))
  #;
  (define (get-image-width image)
    (image-width image))

  (provide (rename image-height height))
  #;
  (define (get-image-height image)
    (image-height image))

  (provide (rename a:acquire-screen acquire-screen)
	   (rename a:release-screen release-screen))

  (provide create)
  (define (create width height)
    (create-from-bitmap (a:create-bitmap width height)))

  (provide color)
  (define (color r g b)
    (a:makecol r g b))

  (provide get-rgb)
  (define (get-rgb color)
    (values (a:getr color)
	    (a:getg color)
	    (a:getb color)))

  (provide create-from-file)
  (define (create-from-file filename)
    (if (string? filename)
      (create-from-bitmap (a:load-bitmap filename #f))
      (error (format "~a must be a filename" filename))))

  (define create-from-bitmap
    (case-lambda
      ((bitmap) (make-image bitmap (a:BITMAP-w bitmap) (a:BITMAP-h bitmap)))
      ((bitmap x y width height) 
       (make-image (a:create-sub-bitmap bitmap x y width height) 
		   width height))))

  (define/screen* (create-sub image x y width height)
    (create-from-bitmap (image-bitmap image) x y width height))

  (provide make-palette)
  (define (make-palette)
    ; (malloc _byte 680)
    (let ((m (malloc a:_RGB 256)))
      (cpointer-push-tag! m a:RGB-tag)
      m))

  (provide get-palette-color)
  (define (get-palette-color num)
    (ptr-ref (a:palette-color) _int num)
    #;
    (let ((rgb (ptr-ref a:palette-color a:_RGB num)))
      (color (a:RGB-r rgb)
	     (a:RGB-g rgb)
	     (a:RGB-b rgb))))

  (provide get-desktop-color)
  (define (get-desktop-color num)
    (let ((rgb (ptr-ref a:desktop-palette a:_RGB num)))
      (color (a:RGB-r rgb)
	     (a:RGB-g rgb)
	     (a:RGB-b rgb))))

  (provide make-v3d)
  (define (make-v3d x y z u v c)
    (a:make-v3d (+ x 0.0)
		(+ y 0.0)
		(+ z 0.0)
		(+ u 0.0)
		(+ v 0.0)
		c))

  (provide (rename a:v3d-x v3d-x)
	   (rename a:v3d-y v3d-y)
	   (rename a:v3d-z v3d-z)
	   (rename a:v3d-u v3d-u)
	   (rename a:v3d-v v3d-v)
	   (rename a:v3d-c v3d-c))

  (define/screen* (quad3d image1 type image2 v1 v2 v3 v4)
    (a:quad3d (image-bitmap image1)
	      type
	      (image-bitmap image2)
	      v1 v2 v3 v4))

  (provide rgb-map)
  (define rgb-map
    (case-lambda
      (() a:rgb-map)
      ((new) (a:set-rgb-map! new))))

  (define/screen* (mask-color image)
    (a:bitmap-mask-color (image-bitmap image)))

  (provide color-map)
  (define color-map
    (case-lambda
      (() a:color-map)
      ((new) (a:set-color-map! new))))

  (provide (rename a:create-rgb-table create-rgb-table))
  (provide (rename a:create-light-table create-light-table))

  ; (provide unwrite-line)
  (define/screen* (unwrite-line image)
    (a:bmp-unwrite-line (image-bitmap image)))

  (provide (rename read-line- read-line)
	   (rename read-line--screen read-line-screen))
  (define/screen (read-line- image y)
    (a:bmp-read-line (image-bitmap image) y))

  ;; (provide write-line)
  (define/screen* (write-line image y)
    (a:bmp-write-line (image-bitmap image) y))

  #|
  (provide image-read32)
  (define (image-read32 pointer)
    (bmp-read32 pointer))

  (provide image-write32)
  (define (image-write32 pointer c)
    (bmp-write32 pointer c)) 
  |#

  (provide get-palette)
  (define (get-palette p num)
    (let ((rgb (ptr-ref p a:_RGB num)))
      (color (a:RGB-r rgb)
	     (a:RGB-g rgb)
	     (a:RGB-b rgb))))

  (provide set-palette!)
  (define set-palette!
    (case-lambda
      ((palette)
       (a:set-palette palette))
      ((palette num r g b)
       (let ((rgb (ptr-ref palette a:_RGB num)))
	 (a:set-RGB-r! rgb r)
	 (a:set-RGB-g! rgb g)
	 (a:set-RGB-b! rgb b)))))

  #;
  (define (create-image-bitmap bitmap)
    (make-image bitmap (BITMAP-w bitmap) (BITMAP-h bitmap)))

  (provide destroy)
  (define (destroy image)
    (a:destroy-bitmap (image-bitmap image)))

  ; (provide line)
  (define/screen* (line image x1 y1 x2 y2 color)
    (a:line (image-bitmap image) x1 y1 x2 y2 color))

  ; (provide triangle)
  (define/screen* (triangle image x1 y1 x2 y2 x3 y3 color)
    (a:triangle (image-bitmap image) x1 y1 x2 y2 x3 y3 color))
  
  #|
  (provide image-triangle-fill)
  (define (image-triangle-fill image x1 y1 x2 y2 x3 y3 color)
    (triangle-fill (image-bitmap image) x1 y1 x2 y2 x3 y3 color))
  |#

  ; (provide circle)
  (define/screen* (circle image x1 y1 radius color)
    (a:circle (image-bitmap image) x1 y1 radius color))
  
  ; (provide circle-fill)
  (define/screen* (circle-fill image x1 y1 radius color)
    (a:circlefill (image-bitmap image) x1 y1 radius color))

  ; (provide rectangle)
  (define/screen* (rectangle image x1 y1 x2 y2 color)
    (a:rect (image-bitmap image) x1 y1 x2 y2 color))
  
  ; (provide rectangle-fill)
  (define/screen* (rectangle-fill image x1 y1 x2 y2 color)
    (a:rectfill (image-bitmap image) x1 y1 x2 y2 color))

  ; (provide putpixel putpixel-screen)
  (define/screen* (putpixel image x1 y1 color)
    (a:putpixel (image-bitmap image) x1 y1 color))

  ; (provide getpixel)
  (define/screen* (getpixel image x1 y1)
    (a:getpixel (image-bitmap image) x1 y1))
  
  (provide (rename print- print)
	   (rename print--screen print-screen))
  (define/screen (print- image x y color bgcolor message)
    (a:textout-ex (image-bitmap image)
		  (a:default-font)
		  message x y color bgcolor))

  ; (provide print-center)
  (define/screen* (print-center image x y color bgcolor message)
    (a:textout-centre-ex (image-bitmap image)
			 (a:default-font)
			 message x y color bgcolor))

  ; (provide clear)
  (define/screen* clear
    (case-lambda
      ((image)
       (clear image (color 0 0 0)))
      ((image color)
       (a:clear-to-color (image-bitmap image) color))))

  (provide trans-sprite)
  (define trans-sprite
    (case-lambda
      ((image1 image2)
       (trans-sprite image1 image2 0 0 0))
      ((image1 image2 x1 y1)
       (a:draw-trans-sprite 
	 (image-bitmap image1)
	 (image-bitmap image2)
	 x1 y1))))

  (provide lit-sprite)
  (define lit-sprite
    (case-lambda
      ((image1 image2)
       (lit-sprite image1 image2 0 0 0))
      ((image1 image2 x1 y1 a)
       (a:draw-lit-sprite 
	 (image-bitmap image1)
	 (image-bitmap image2)
	 x1 y1 a))))

  (define/screen* (draw image1 image2 x y)
    (a:draw-sprite (image-bitmap image1)
		   (image-bitmap image2)
		   x y))

  ; (provide copy)
  (define/screen* copy
    (case-lambda
      ((image1 image2)
       (copy image1 image2 0 0))
      ((image1 image2 x1 y1)
       #;(draw-sprite (image-bitmap image2) (image-bitmap image1) x1 y1)
       (a:blit (image-bitmap image2)
	       (image-bitmap image1)
	       x1 y1 0 0
	       (image-width image2)
	       (image-height image2)))))

  #;
  (define (image-copy image1 x1 y1 width height image2 x2 y2)
    (let ((width (if (= width -1) (image-width image1) width))
	  (height (if (= height -1) (image-height image1) height)))
      (blit (image-bitmap image1)
	    (image-bitmap image2)
	    x1 y1 x2 y2 width height)))

  (provide screen)
  (define (screen)
    (create-from-bitmap (a:screen)))

  (define/screen* (save image name)
    (a:save-bitmap name image #f))

  (provide copy-to-screen)
  (define copy-to-screen
    (case-lambda
      ((image) (copy image (screen)))
      ((image x1 y1)
       (copy image (screen) x1 y1))))

  (define-struct equad (quads parent min-x min-y width height full))

  (define (full? quad)
    (equad-full quad))

  (define (num-quads quad)
    (length (equad-quads quad)))

  (define (make-equad-from-image image min-size mask-pixel min-x min-y parent)
    (let ((width (image-width image))
	  (height (image-height image))
	  (bitmap (image-bitmap image)))
      (let ((quad (make-equad null parent min-x min-y 
			      width height #f)))
	(if (andmap (lambda (x) (> x min-size)) (list width height))
	  (let ((w (inexact->exact (round (/ width 2))))
		(h (inexact->exact (round (/ height 2)))))
	    (set-equad-quads! 
	      quad
	      (map (lambda (x-y)
		     (let ((x (car x-y))
			   (y (cadr x-y)))
		       (let ((sub (create-from-bitmap bitmap
						      x y w h)))
			 (make-equad-from-image sub min-size mask-pixel x y quad))))
		   (list (list 0 0)
			 (list w 0)
			 (list 0 h)
			 (list w h))))
	    (if (andmap full? (equad-quads quad))
	      (begin
		(set-equad-quads! quad null)
		(set-equad-full! quad #t))
	      (set-equad-quads! 
		quad 
		(let loop ((sofar null)
			   (child-quads (equad-quads quad)))
		  (cond
		    ((null? child-quads) sofar)
		    ((= (num-quads (car child-quads)) 1) 
		     (let ((newquad (car (equad-quads (car child-quads))))
			   (min-x (equad-min-x (car child-quads)))
			   (min-y (equad-min-y (car child-quads))))
		       (set-equad-min-x! (+ (equad-min-x newquad) min-x))
		       (set-equad-min-y! (+ (equad-min-y newquad) min-y))
		       (set-equad-parent! quad)
		       (loop (cons newquad sofar) (cdr child-quads))))
		    (else (loop (cons (car child-quads) sofar)
				(cdr child-quads))))))))
	  (let ((total (let xloop ((x 0)
				   (total 0))
			 (if (< x width)
			   (let yloop ((y 0)
				       (total total))
			     (if (< y height)
			       (yloop (add1 y) 
				      (if (not (= (getpixel bitmap x y) mask-pixel))
					(add1 total)
					total))
			       (xloop (add1 x) total)))
			   total))))
	    (set-equad-full! quad (> (/ (* total 100) (* width height)) 50))))
	quad)))

  (define (touch-box? ax1 ay1 ax2 ay2 bx1 by1 bx2 by2)
    (cond
      ((and (< ax1 bx1) (< ax1 bx2)
	    (< ax2 bx1) (< ax2 bx2))
       #f)
      ((and (> ax1 bx1) (> ax1 bx2)
	    (> ax2 bx1) (> ax2 bx2))
       #f)
      ((and (< ay1 by1) (< ay1 by2)
	    (< ay2 by1) (< ay2 by2))
       #f)
      ((and (> ay1 by1) (> ay1 by2)
	    (> ay2 by1) (> ay2 by2))
       #f)
      (else #t)))

  (define (collide-equad? quad mx my x1 y1 x2 y2)
    (let* ((rx1 (+ mx (equad-min-x quad)))
	   (ry1 (+ my (equad-min-y quad)))
	   (rx2 (+ rx1 (equad-width quad)))
	   (ry2 (+ ry1 (equad-height quad))))
      (cond
	((not (touch-box? rx1 ry1 rx2 ry2 x1 y1 x2 y2)) #f)
	((ormap (lambda (q) 
		  (collide-equad? q rx1 ry1 x1 y1 x2 y2))
		(equad-quads quad))
	 #t)
	(else (equad-full quad)))))

#|
      (if (not (touch-box? rx1 ry1 rx2 ry2 x1 y1 x2 y2))
	#f
	(if (ormap (lambda (q) (collide-equad? rx1 ry1 x1 y1 x2 y2))
		   (equad-quads quad))
	  #t
	  (equad-full equad))))
|#

  (define (display-equad image equad x y color)
    (let* ((mx1 (+ x (equad-min-x equad)))
	   (my1 (+ y (equad-min-y equad)))
	   (mx2 (+ mx1 (equad-width equad)))
	   (my2 (+ my1 (equad-height equad))))
      (for-each (lambda (e) (display-equad image e mx1 my1 color)) (equad-quads equad))
      (when (full? equad)
	(rectangle image mx1 my1 mx2 my2 color))))

  (define-struct ebox (head))

  (define MIN-SIZE 8)

  (provide make-ebox-from-image)
  (define make-ebox-from-image
    (case-lambda
      ((image) (make-ebox (make-equad-from-image image MIN-SIZE (a:Bitmap:mask-color) 0 0 #f)))
      ((image mask-pixel)
       (make-ebox (make-equad-from-image image MIN-SIZE mask-pixel 0 0 #f)))))

  (define (ebox-width ebox)
    (equad-width (ebox-head ebox)))

  (define (ebox-height ebox)
    (equad-height (ebox-head ebox)))

  (provide ebox-collide?)
  (define (ebox-collide? ebox1 mx my ebox2 ax ay)
    (if (not (collide-equad? (ebox-head ebox1) mx my
			     ax ay 
			     (+ (ebox-width ebox2) ax)
			     (+ (ebox-height ebox2) ay)))
      #f
      (let ((x1 (max mx ax))
	    (y1 (max my ay))
	    (x2 (min (+ (ebox-width ebox1) mx)
		     (+ (ebox-width ebox2) ax)))
	    (y2 (min (+ (ebox-height ebox1) my)
		     (+ (ebox-height ebox2) ay))))
	(and (collide-equad? (ebox-head ebox1) mx my
			     x1 y1 x2 y2)
	     (collide-equad? (ebox-head ebox2) mx my
			     x1 y1 x2 y2)))))

  (provide display-ebox)
  (define (display-ebox image ebox x y color)
    (display-equad image (ebox-head ebox) x y color))

)