#lang racket
; Spring 2010: started trying to get this to work.
; Late June 2010: Got build-image and map-image working.
; Added name->color and get-pixel-color.
; Added build-masked-image and map-masked-image.
; July 6, 2010: added change-to-color
; July 28, 2010: added map3-image and build3-image.  Is change-to-color really useful?
(require mrlib/image-core)
(require 2htdp/private/image-more)
; (require 2htdp/private/img-err)
(require scheme/gui)
(require lang/prim)

(provide-primitives real->int
                    maybe-color?
                    name->color
                    get-pixel-color
                    pixel-visible?
                    ; change-to-color
                    )
(provide-higher-order-primitive map-image (f _))
(provide-higher-order-primitive map3-image (rfunc gfunc bfunc _))
(provide-higher-order-primitive map-masked-image (f _))
(provide-higher-order-primitive build-image (_ _ f))
(provide-higher-order-primitive build3-image (_ _ rfunc gfunc bfunc))
(provide-higher-order-primitive build-masked-image (_ _ f))

(define MONOCHROME #f)

;(provide foo)
;
;(define foo "hello")
(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)))

; lookup-if-nec : string-or-color -> maybe-color
(define (lookup-if-nec c)
  (if (color? c)
      c
      (name->color c)))

;; change-to-color : (or/c string? color?) -> (nat-num nat-num [color] -> color)
;; Given a color or the string name of a color, creates a constant-valued function
;; suitable for use in map-image or build-image.
;(define (change-to-color new-color)
;  (let [[real-color
;         (or (lookup-if-nec new-color)
;             (error 'change-to-color "Expected color or color name as argument"))]]
;    (lambda (x y [color #f])
;      real-color)))

; 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)))

; color=? : does the obvious
(define (color=? c1 c2)
  (let [[rc1 (lookup-if-nec c1)]
        [rc2 (lookup-if-nec c2)]]
    (unless (and (color? rc1) (color? rc2))
      (error 'color=? "Expected two colors or color names as arguments"))
    (and (= (color-red rc1) (color-red rc2))
         (= (color-green rc1) (color-green rc2))
         (= (color-blue rc1) (color-blue rc2)))))

; 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 (and (procedure? f) (procedure-arity-includes? f 2))
    (error 'build-image "Expected function with contract number number -> color as third argument"))
  (if (or (zero? width) (zero? height))       ; bitmap% doesn't like zero-sized images
    (rectangle width height "solid" "white")
    (let* [[mask-bm (make-object bitmap% width height MONOCHROME)] ; 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)
      )
    )
  )
 
; build3-image: nat(width) nat(height) (nat nat -> nat) (nat nat -> nat) (nat nat -> nat) -> image
(define (build3-image width height rfunc gfunc bfunc)
  (unless (and (natural? width) (natural? height))
    (error 'build3-image "Expected natural numbers as first two arguments"))
  (unless (and (procedure? rfunc) (procedure-arity-includes? rfunc 2))
    (error 'build3-image "Expected function with contract number number -> number as third argument"))
  (unless (and (procedure? gfunc) (procedure-arity-includes? gfunc 2))
    (error 'build3-image "Expected function with contract number number -> number as fourth argument"))
  (unless (and (procedure? bfunc) (procedure-arity-includes? bfunc 2))
    (error 'build3-image "Expected function with contract number number -> number as fifth argument"))
  (build-image width height
               (lambda (x y) (make-color (rfunc x y) (gfunc x y) (bfunc x y)))))

; 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 (and (procedure? f) (procedure-arity-includes? f 2))
    (error 'build-masked-image "Expected function with contract number number -> maybe-color as third argument"))
  (if (or (zero? width) (zero? height))       ; bitmap% doesn't like zero-sized images
    (rectangle width height "solid" "white")
    (let* [[bm (make-object bitmap% width height)]
           [bmdc (make-object bitmap-dc% bm)]
           [mask-bm (make-object bitmap% width height MONOCHROME)] ; 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))
            )))))

; color-diff : color color -> color
(define (color-diff c1 c2)
  (make-color (- (color-red c1) (color-red c2))
              (- (color-green c1) (color-green c2))
              (- (color-blue c1) (color-blue c2))))

; to-grey : color -> color
(define (to-grey c)
  (local [(define avg (quotient (+ (color-red c) (color-green c) (color-blue c)) 3))]
    (make-color avg avg avg)))

; get-mask : image -> bitmap
; There MUST be a better way to do this!
; I draw the image into a white background, and again into a black background.
; Anywhere that the results differ, I figure the rendering didn't touch so I'll
; make it transparent.
; Robby points out that this misses dithered edges: sometimes the mask
; value should be a shade of gray, neither black nor white.
(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 MONOCHROME))
         (dc1 (make-object bitmap-dc% bm1))
         (dc2 (make-object bitmap-dc% bm2))
         (mask-dc (make-object bitmap-dc% mask-bm)))
    (render-image (rectangle w h "solid" "white") dc1 0 0)
    (render-image (rectangle w h "solid" "black") 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
              (color->color% (to-grey (color-diff (get-px x y dc1)
                                                  (get-px x y dc2))))
              )))
    (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 (and (procedure? f) (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)))

; The version for use before students have seen structs:
; map3-image :
; (int(x) int(y) int(r) int(g) int(b) -> int(r))
; (int(x) int(y) int(r) int(g) int(b) -> int(g))
; (int(x) int(y) int(r) int(g) int(b) -> int(b))
; image -> image
(define (map3-image rfunc gfunc bfunc pic)
  (unless (and (procedure? rfunc) (procedure-arity-includes? rfunc 5))
    (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument"))
  (unless (and (procedure? gfunc) (procedure-arity-includes? gfunc 5))
    (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument"))
  (unless (and (procedure? bfunc) (procedure-arity-includes? bfunc 5))
    (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument"))
   (map-image
      (lambda (x y c)
          (make-color (rfunc x y (color-red c) (color-green c) (color-blue c))
                      (gfunc x y (color-red c) (color-green c) (color-blue c))
                      (bfunc x y (color-red c) (color-green c) (color-blue c))))
      pic))

; map-masked-image : (int int maybe-color -> maybe-color) image -> image
(define (map-masked-image f pic)
  (unless (and (procedure? f) (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))))))