#lang racket
(require mrlib/image-core)
(require 2htdp/private/image-more)
; (require 2htdp/private/img-err)
(require scheme/gui)
(require lang/prim)

(provide real->int
         maybe-color?
         name->color
         )
(provide-higher-order-primitive map-image (f _))
(provide-higher-order-primitive map-masked-image (f _))
(provide-primitive get-pixel-color)
(provide-primitive pixel-visible?)
(provide-higher-order-primitive build-image (_ _ f))
(provide-higher-order-primitive build-masked-image (_ _ f))

(define (maybe-color? thing)
  (or (color? thing)
      (eqv? thing #f)))

; name->color : string -> maybe-color
(define (name->color name)
  (let [[result (send the-color-database find-color name)]]
    (if result
        (color%->color result)
        #f)))


; color->color% : does the obvious
(define (color->color% c)
  (if (string? c) 
      c
      (make-object color% 
        (color-red c)
        (color-green c)
        (color-blue c))))

; color%->color : does the obvious
(define (color%->color c)
  (make-color (send c red)
              (send c green)
              (send c blue)))

; natural? : anything -> boolean
(define (natural? it)
  (and (integer? it)
       (>= it 0)))

; build-image-internal : nat(width) nat(height) (nat nat -> color) bitmap% -> image
(define (build-image-internal width height f mask-bm)
  (unless (and (natural? width) (natural? height))
    (error 'build-image "Expected natural numbers as first two arguments"))
  (unless (procedure-arity-includes? f 2)
    (error 'build-image "Expected function with contract number number -> color as third argument"))
  (let* [[bm (make-object bitmap% width height)]
         [bmdc (make-object bitmap-dc% bm)]
         ]
    (for ((y (in-range height)))
      (for ((x (in-range width)))
        (send bmdc set-pixel x y (color->color% (f x y)))
        ))
    (send bmdc set-bitmap #f)
    (make-image
     (make-translate (quotient width 2) (quotient height 2)
                     (make-bitmap bm mask-bm 0 1 1 #f #f))
     (make-bb width height height)
     #f ; not normalized
     )
    ))

; build-image : natural(width) natural(height) (nat nat -> color) -> image
(define (build-image width height f)
  (unless (and (natural? width) (natural? height))
    (error 'build-image "Expected natural numbers as first two arguments"))
  (unless (procedure-arity-includes? f 2)
    (error 'build-image "Expected function with contract number number -> color as third argument"))
  (let* [[mask-bm (make-object bitmap% width height #t)] ; monochrome
         [mask-bmdc (make-object bitmap-dc% mask-bm)]
         [black (make-object color% 0 0 0)]]
    (send mask-bmdc set-background black)
    (send mask-bmdc clear)
;    (for ((y (in-range height)))
;      (for ((x (in-range width)))
;        (send mask-bmdc set-pixel x y black)))
    ; can we replace this with (send mask-bmdc clear)?
    (send mask-bmdc set-bitmap #f)
    (build-image-internal width height f mask-bm)
    )
  )

; build-masked-image : nat(width) nat(height) (nat nat -> maybe-color) -> image
(define (build-masked-image width height f)
  (unless (and (natural? width) (natural? height))
    (error 'build-masked-image "Expected natural numbers as first two arguments"))
  (unless (procedure-arity-includes? f 2)
    (error 'build-masked-image "Expected function with contract number number -> maybe-color as third argument"))
  (let* [[bm (make-object bitmap% width height)]
         [bmdc (make-object bitmap-dc% bm)]
         [mask-bm (make-object bitmap% width height #t)] ; monochrome
         [mask-bmdc (make-object bitmap-dc% mask-bm)]
         [visible (make-object color% 0 0 0)]
         [transparent (make-object color% 255 255 255)]]
    (for ((y (in-range height)))
      (for ((x (in-range width)))
        (let* [[mc (f x y)]
               [color (if mc (color->color% mc) transparent)]
               [mask (if mc visible transparent)]]
          (send bmdc set-pixel x y color)
          (send mask-bmdc set-pixel x y mask)
          )))
    (send bmdc set-bitmap #f)
    (send mask-bmdc set-bitmap #f)
    (make-image
     (make-translate (quotient width 2) (quotient height 2)
                     (make-bitmap bm mask-bm 0 1 1 #f #f))
     (make-bb width height height)
     #f ; not normalized
     )
    ))




(define (real->int num)
  (inexact->exact (round num)))


; get-px : x y bitmap-dc% -> color
(define (get-px x y bmdc)
  (let ((col (make-object color%)))
    (send bmdc get-pixel x y col)
    (color%->color col)))

; get-pixel-color : x y image -> color
; This will remember the last image on which it was called.
; Really terrible performance if you call it in alternation
; on two different images, but should be OK if you call it
; lots of times on the same image.
; Returns black if you ask about a position outside the picture.
(define get-pixel-color
  (let [[last-image #f]
        [last-bm #f]
        [last-bmdc #f]]
    (lambda (x y pic)
      (unless (eqv? pic last-image)
        (set! last-image pic)
        (set! last-bm (make-object bitmap% (image-width pic) (image-height pic)))
        (set! last-bmdc (make-object bitmap-dc% last-bm))
        (render-image pic last-bmdc 0 0))
      (if (and (<= 0 x (image-width pic))
               (<= 0 y (image-height pic)))
          (get-px x y last-bmdc)
          (make-color 0 0 0)))))

; pixel-visible? : nat(x) nat(y) image -> boolean
; similar
(define pixel-visible?
  (let [[last-image #f]
        [last-bm #f]
        [last-bmdc #f]]
    (lambda (x y pic)
      (unless (eqv? pic last-image)
        (set! last-image pic)
        (set! last-bm (get-mask pic))
        (set! last-bmdc (make-object bitmap-dc% last-bm)))
      (let [[mask-pix (get-px x y last-bmdc)]] ; assumes this doesn't crash if out of bounds
        (and (equal? mask-pix (make-color 0 0 0)) ; treat anything else as transparent
             (>= x 0)
             (>= y 0)
             (< x (image-width pic))
             (< y (image-height pic))
            )))))

; get-mask : image -> bitmap
; There MUST be a better way to do this!
; I draw the image into a green background, and again into a purple background.
; Anywhere that the results differ, I figure the rendering didn't touch so I'll
; make it transparent.
(define (get-mask pic)
  (let* ((w (image-width pic))
         (h (image-height pic))
         (bm1 (make-object bitmap% w h))
         (bm2 (make-object bitmap% w h))
         (mask-bm (make-object bitmap% w h #t))
         (dc1 (make-object bitmap-dc% bm1))
         (dc2 (make-object bitmap-dc% bm2))
         (mask-dc (make-object bitmap-dc% mask-bm))
         (white (make-object color% "white"))
         (black (make-object color% "black")))
    (render-image (rectangle w h "solid" "green") dc1 0 0)
    (render-image (rectangle w h "solid" "purple") dc2 0 0)
    (render-image pic dc1 0 0)
    (render-image pic dc2 0 0)
    (for ((x (in-range w)))
      (for ((y (in-range h)))
        (send mask-dc set-pixel x y
              (if (equal? (get-px x y dc1) (get-px x y dc2))
                  black
                  white))))
    (send mask-dc set-bitmap #f)
    mask-bm))

; map-image : (int int color -> color) image -> image
; Preserves the old image's mask
(define (map-image f pic)
  (unless (procedure-arity-includes? f 3)
    (error 'map-image "Expected function with contract number number color -> color as first argument"))
  (unless (image? pic)
    (error 'map-image "Expected image as second argument"))
  (let* [[width (image-width pic)]
         [height (image-height pic)]
         [bm (make-object bitmap% width height)]
         [bmdc (make-object bitmap-dc% bm)]
         [mask (get-mask pic)]
         ]
    (render-image pic bmdc 0 0) ; dx & dy?
    (build-image-internal (image-width pic) (image-height pic)
                        (lambda (x y)
                          (f x y (get-px x y bmdc)))
                        mask)))


; map-masked-image : (int int maybe-color -> maybe-color) image -> image
(define (map-masked-image f pic)
  (unless (procedure-arity-includes? f 3)
    (error 'map-masked-image "Expected function with contract number number maybe-color -> maybe-color as first argument"))
  (unless (image? pic)
    (error 'map-masked-image "Expected image as second argument"))
  (let* [[width (image-width pic)]
         [height (image-height pic)]
         [bm (make-object bitmap% width height)]
         [bmdc (make-object bitmap-dc% bm)]
         [mask (get-mask pic)]
         ]
    (render-image pic bmdc 0 0)
    (build-masked-image
     width height
     (lambda (x y)
       (f x y
          (if (pixel-visible? x y pic)
              (get-pixel-color x y pic)
              #f))))))