(module cache-image-snip mzscheme
  (require (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "string.ss")
	   (lib "contract.ss")
           (lib "list.ss"))
  
  (provide cache-image-snip%
           snip-class)
           
  ;; type argb = (make-argb (vectorof rational[between 0 & 255]) int)
  (define-struct argb (vector width))
  
  #|

    The true meaning of an image is a vector of rationals,
    between 0 & 255, representing color and alpha channel
    information. The vector's contents are analagous to
    the last argument to the get-argb-pixels method. That is,
    there are (* 4 w h) entries in the vector for an image
    of width w and height h, and the entries represent the
    alpha, red, green, & blue channels, resp.

    When drawn to the screen, the rationals are rounded to
    their nearest integer, but the true meaning is kept inside
    the image.

  note to self:
    mask of zero means this image dominates
    mask of 255 means this image contributes nothing

    black is 0
    white is 255

    a cleared out bitmap is full of 255s (white)

    an alpha of 1 means the pixel value is 0
    an alpha of 0 means the pixel value is 255
 |#
  
  (define cache-image-snip%
    (class snip%
      
      ;; dc-proc : (union #f ((is-a?/c dc<%>) int[dx] int[dy] -> void))
      ;; used for direct drawing
      (init-field dc-proc)
      (define/public (get-dc-proc) dc-proc)
      
      ;; argb-proc : ((vectorof rational[0 <= x <= 255]) int[dx] int[dy] -> void)
      ;; used for drawing into a bitmap
      (init-field argb-proc)
      (define/public (get-argb-proc) argb-proc)
      
      ;; the pinhole's coordinates
      (init-field px py)
      (define/public (get-pinhole) (values px py))

      (init-field (width #f)
                  (height #f))
      (define/public (get-size)
        (values width height))
      
      ;; argb : (union #f argb)
      (init-field [argb #f])

      
      ;; bitmap : (union #f (is-a?/c bitmap%))
      ;; the way that this image is be drawn, on its own
      (define bitmap #f)
      
      (define/override (copy)
        (new cache-image-snip% 
             (dc-proc dc-proc)
             (argb-proc argb-proc)
             (width width)
             (height height)
             (argb argb)
             (px px)
             (py py)))
      
      ;; get-bitmap : -> bitmap
      ;; returns a bitmap showing what the image would look like, 
      ;; if it were drawn
      (define/public (get-bitmap)
        (unless bitmap
          (set! bitmap (argb->bitmap (get-argb))))
        bitmap)
      
      ;; get-argb : -> argb
      (define/public (get-argb)
        (unless argb
          (set! argb (make-argb (make-vector (* 4 width height) 255) width))
          (argb-proc argb 0 0))
        argb)
      
      ;; get-argb/no-compute : -> (union #f argb)
      (define/public (get-argb/no-compute)
        argb)
      
      (define/override (get-extent dc x y w h descent space lspace rspace)
        (set-box/f! w width)
        (set-box/f! h height)
        (set-box/f! descent 0)
        (set-box/f! space 0)
        (set-box/f! lspace 0)
        (set-box/f! rspace 0))
      
      (define/override (draw dc x y left top right bottom dx dy draw-caret)
        (cond
          [argb (let ([bitmap (get-bitmap)])
                  (send dc draw-bitmap bitmap x y 'solid 
                        (send the-color-database find-color "black")
                        (send bitmap get-loaded-mask)))]
          [dc-proc (dc-proc dc x y)]
          [else (void)]))
      
      (define/override (write f)
        (let ([str (string->bytes/utf-8
                    (format "~s"
                            (list (argb-vector (get-argb))
                                  width
                                  px 
                                  py)))])
          (send f put str)))
      
      (define/override (get-num-scroll-steps) (inexact->exact (+ (floor (/ height 20)) 1)))
      (define/override (find-scroll-step y) (inexact->exact (floor (/ y 20))))
      (define/override (get-scroll-step-offset offset) (* offset 20))
      
      (super-new)
      (inherit set-snipclass)
      (set-snipclass snip-class)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; snip-class
  ;;
  
  (define cache-image-snip-class%
    (class snip-class%
      (define/override (read f)
        (let ([data (read-from-string (bytes->string/utf-8 (send f get-bytes))
                                      void
                                      (lambda (x) #f))])
          (if data
              (argb->cache-image-snip (make-argb (first data) (second data)) (third data) (fourth data))
              (make-null-cache-image-snip))))
      (super-new)))
  
  (define snip-class (new cache-image-snip-class%))
  (send snip-class set-version 1)
  (send snip-class set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib")))
  (send (get-the-snip-class-list) add snip-class)
  
  (define (make-null-cache-image-snip)
    (define size 10)
    (define (draw dc dx dy)
      (with-pen/brush
       dc
       "black" 'solid
       "black" 'transparent
       (send dc draw-ellipse dx dy size size)
       (send dc draw-line dx (+ dy size -1) (+ dx size -1) dy)))
    (define bm (build-bitmap (lambda (dc) (draw dc 0 0))
                             size
                             size))
    (new cache-image-snip%
         (width size)
         (height size)
         (draw-proc draw)
         (px (/ size 2))
         (py (/ size 2))
         (argb-proc 
          (lambda (argb dx dy)
            (overlay-bitmap argb size size dx dy bm bm)))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; misc. utilities
  ;;
  
  ;; takes a bitmap with a mask and flattens the colors and the mask
  ;; drawing them as they would appear on the screen.
  (define (flatten-bitmap bm)
    (let* ([w (send bm get-width)]
           [h (send bm get-height)]
           [new-bm (make-object bitmap% w h)]
           [bdc (make-object bitmap-dc% new-bm)])
      (send bdc draw-bitmap bm 0 0 'solid 
            (send the-color-database find-color "black")
            (send bm get-loaded-mask))
      (send bdc set-bitmap #f)
      new-bm))
  
  ;; build-bitmap : (dc -> void) number number -> bitmap
  (define (build-bitmap draw w h)
    (let* ([bm (make-object bitmap% w h)]
           [bdc (make-object bitmap-dc% bm)])
      (send bdc clear)
      (draw bdc)
      (send bdc set-bitmap #f)
      bm))

  (define-syntax (with-pen/brush stx)
    (syntax-case stx ()
      [(_ dc pen-color pen-style brush-color brush-style code ...)
       (syntax
        (let ([old-pen (send dc get-pen)]
              [old-brush (send dc get-brush)])
          (send dc set-pen (send the-pen-list find-or-create-pen pen-color 1 pen-style))
          (send dc set-brush (send the-brush-list find-or-create-brush brush-color brush-style))
          code ...
          (send dc set-pen old-pen)
          (send dc set-brush old-brush)))]))
  
  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; argb vector utilties
  ;;
  
  ;; argb->cache-image-snip : argb number number -> cache-image-snip
  (define (argb->cache-image-snip argb px py)
    (let* ([width (argb-width argb)]
           [argb-vector (argb-vector argb)]
           [height (quotient (vector-length argb-vector) (* 4 width))]
           [bitmap (argb->bitmap argb)]
           [mask (send bitmap get-loaded-mask)])
      (new cache-image-snip%
           (width width)
           (height height)
           (argb argb)
           (px px)
           (py py)
           (argb-proc 
            (lambda (argb dx dy)
              (overlay-bitmap argb dx dy bitmap mask)))
           (dc-proc (lambda (dc dx dy)
                      (send dc draw-bitmap bitmap dx dy 'solid 
                            (send the-color-database find-color "black")
                            mask))))))
  
  ;; argb-vector->bitmap : argb -> bitmap
  ;; flattens the argb vector into a bitmap
  (define (argb->bitmap argb)
    (let* ([argb-vector (argb-vector argb)]
           [w (argb-width argb)]
           [h (quotient (vector-length argb-vector) (* w 4))]
           [bm (make-object bitmap% w h)]
           [mask-bm (make-object bitmap% w h)]
           [bdc (new bitmap-dc% (bitmap bm))]
           [bytes (make-bytes (vector-length argb-vector) 255)]
           [mask-bytes (make-bytes (vector-length argb-vector) 255)])
      (let loop ([i (- (vector-length argb-vector) 1)])
        (cond
          [(zero? (modulo i 4))
           (let ([av (round (vector-ref argb-vector i))])
             (bytes-set! mask-bytes (+ i 1) av)
             (bytes-set! mask-bytes (+ i 2) av)
             (bytes-set! mask-bytes (+ i 3) av))]
          [else
           (bytes-set! bytes i (round (vector-ref argb-vector i)))])
        (unless (zero? i)
          (loop (- i 1))))
      (send bdc set-argb-pixels 0 0 w h bytes)
      (send bdc set-bitmap mask-bm)
      (send bdc set-argb-pixels 0 0 w h mask-bytes)
      (send bdc set-bitmap #f)
      (send bm set-loaded-mask mask-bm)
      bm))
  
  ;; overlay-bitmap : argb int int bitmap bitmap -> void
  ;; assumes that the mask bitmap only has greyscale in it
  ;; (ie, that looking at the red component of the mask is enough)
  (define (overlay-bitmap argb dx dy color mask)
    (let* ([argb-vector (argb-vector argb)]
           [argb-w (argb-width argb)]
           [w (send color get-width)]
           [h (send color get-height)]
           [color-bytes (make-bytes (* w h 4) 0)]
           [mask-bytes (make-bytes (* w h 4) 0)]
           [dc (make-object bitmap-dc%)])
      (send dc set-bitmap color)
      (send dc get-argb-pixels 0 0 w h color-bytes)
      (send dc set-bitmap #f) ;; in case mask and color are the same bitmap....
      (send dc set-bitmap mask)
      (send dc get-argb-pixels 0 0 w h mask-bytes)
      (send dc set-bitmap #f)
      (let yloop ([y 0]
                  [str-i 0])
        (unless (= y h)
          (let xloop ([x 0]
                      [str-i str-i])
            (if (= x w)
                (yloop (add1 y) str-i)
                (begin
                  (when (and (<= 0 (+ x dx))
                             (< (+ x dx) argb-w))
                    (let ([argb-i (* 4 (+ (+ dx x) (* (+ dy y) argb-w)))])
                      (when (and (<= 0 argb-i)
                                 (< argb-i (vector-length argb-vector)))
                        (let* ([m1 (vector-ref argb-vector argb-i)]
                               [m2 (bytes-ref mask-bytes (+ str-i 1))] ;; get red coordinate
                               [m3 (build-m3 m1 m2)]
			       [bang (lambda (i v) (vector-set! argb-vector i (floor v)))]
                               [do-b
                                (lambda (off)
                                  (bang (+ argb-i off)
					(build-b3 m1
						  (vector-ref argb-vector (+ argb-i off))
						  m2
						  (bytes-ref color-bytes (+ str-i off))
						  m3)))])
                          (bang argb-i m3)
                          (do-b 1)
                          (do-b 2)
                          (do-b 3)))))
                  (xloop (+ x 1) (+ str-i 4)))))))))
  
#|
From Matthew's computation in PR 6930:
> m3 is (m1+m2-m1*m2) and 
> b3 is (m1*b1*(1-m2) + m2*b2)/m3

but that's for values between 0 and 1 and we
need values between 0 and 255. Worse, the values
sense are reversed. That is,
1 above corresponds to 0 in pixel values and
0 above corresponds to 255.

;; the spec
(define (build-m3-0 big-m1 big-m2)
  (let ([m1 (- 1 (/ big-m1 255))]
        [m2 (- 1 (/ big-m2 255))])
    (let ([m3 (+ m1 m2 (- (* m1 m2)))])
      (* 255 (- 1 m3)))))

; = substitute in lets
(define (build-m3-1 m1 m2)
  (* 255 (- 1 (+ (- 1 (/ m1 255))
                 (- 1 (/ m2 255))
                 (- (* (- 1 (/ m1 255))
                       (- 1 (/ m2 255))))))))

;= multiply out last product
(define (build-m3-2 m1 m2)
  (* 255 (- 1 (+ (- 1 (/ m1 255))
                 (- 1 (/ m2 255))
                 (- (+ 1 
                       (- (/ m1 255))
                       (- (/ m2 255))
                       (* (- (/ m1 255)) (- (/ m2 255)))))))))

; = lift out the neagtives into topmost sum
(define (build-m3-3 m1 m2)
  (* 255 (- 1 (+ (- (/ m1 255))
                 1
                 (- (/ m2 255))
                 1
                 -1
                 (/ m1 255)
                 (/ m2 255)
                 (- (* (/ m1 255) (/ m2 255)))))))

; = push in topmost subtraction
(define (build-m3-4 m1 m2)
  (* 255 (+ 1
            (/ m1 255)
            -1
            (/ m2 255)
            -1
            1
            (- (/ m1 255))
            (- (/ m2 255))
            (* (/ m1 255) (/ m2 255)))))

; = simplify sum:

(define (build-m3-5 m1 m2)
  (* 255 (* (/ m1 255) (/ m2 255))))

; = distribute 255

(define (build-m3-6 m1 m2) (* m1 m2 1/255))

(define (test-m3 m1 m2)
  (values (build-m3-0 m1 m2)
          (build-m3-1 m1 m2)
          (build-m3-2 m1 m2)
          (build-m3-3 m1 m2)
          (build-m3-4 m1 m2)
          (build-m3-5 m1 m2)
          (build-m3-6 m1 m2)))

(test-m3 0 0)
(test-m3 255 255)
(test-m3 100 200)

for b3, we have:

(define (build-m3-6 m1 m2) (* m1 m2 1/255))

;; the spec
(define (build-b3-0 big-m1 big-b1 big-m2 big-b2 big-m3)
  (let ([m1 (- 1 (/ big-m1 255))]
        [b1 (- 1 (/ big-b1 255))]
        [m2 (- 1 (/ big-m2 255))]
        [b2 (- 1 (/ big-b2 255))]
        [m3 (- 1 (/ big-m3 255))])
    (let ([ans (/ (+ (* m1 b1 (- 1 m2)) (* m2 b2)) m3)])
      (* 255 (- 1 ans)))))

;; = substitute in for let.
(define (build-b3-1 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- 1 (/ m1 255)) (- 1 (/ b1 255)) (- 1 (- 1 (/ m2 255)))) 
                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
                 (- 1 (/ m3 255))))))

;; = simple substitution
(define (build-b3-2 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- 1 (/ m1 255)) (- 1 (/ b1 255)) (/ m2 255))
                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
                 (- 1 (/ m3 255))))))

;; = multiply out first part of first *
(define (build-b3-3 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (+ 1
                          (- (/ m1 255))
                          (- (/ b1 255))
                          (* (/ m1 255) (/ b1 255))) 
                       (/ m2 255))
                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
                 (- 1 (/ m3 255))))))

;; = distribute out newly created product 
(define (build-b3-4 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (/ m2 255)
                    (* (- (/ m1 255)) (/ m2 255))
                    (* (- (/ b1 255)) (/ m2 255))
                    (* (/ m1 255) (/ b1 255) (/ m2 255))
                    (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))
                 (- 1 (/ m3 255))))))

;; = multiply out product of sum
(define (build-b3-5 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (/ m2 255)
                    (* (- (/ m1 255)) (/ m2 255))
                    (* (- (/ b1 255)) (/ m2 255))
                    (* (/ m1 255) (/ b1 255) (/ m2 255))
                    (+ 1
                       (- (/ m2 255))
                       (- (/ b2 255))
                       (* (/ m2 255) (/ b2 255))))
                 (- 1 (/ m3 255))))))

;; = flatten out sum of sum & simplify
(define (build-b3-6 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- (/ m1 255)) (/ m2 255))
                    (* (- (/ b1 255)) (/ m2 255))
                    (* (/ m1 255) (/ b1 255) (/ m2 255))
                    1
                    (- (/ b2 255))
                    (* (/ m2 255) (/ b2 255)))
                 (- 1 (/ m3 255))))))

;; = rearrange denom
(define (build-b3-7 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- (/ m1 255)) (/ m2 255))
                    (* (- (/ b1 255)) (/ m2 255))
                    (* (/ m1 255) (/ b1 255) (/ m2 255))
                    1
                    (- (/ b2 255))
                    (* (/ m2 255) (/ b2 255)))
                 (/ (- 255 m3) 255)))))

;; = move 255 to numerator
(define (build-b3-8 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (* 255 (+ (* (- (/ m1 255)) (/ m2 255))
                           (* (- (/ b1 255)) (/ m2 255))
                           (* (/ m1 255) (/ b1 255) (/ m2 255))
                           1
                           (- (/ b2 255))
                           (* (/ m2 255) (/ b2 255))))
                 (- 255 m3)))))

;; cancel out 255s in numerator
(define (build-b3-9 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- m1) (/ m2 255))
                    (* (- b1) (/ m2 255))
                    (* m1 (/ b1 255) (/ m2 255))
                    255
                    (- b2)
                    (* m2 (/ b2 255)))
                 (- 255 m3)))))

;; rearrange numerator
(define (build-b3-10 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (/ (* (- m1) m2) 255)
                    (/ (* (- b1) m2) 255)
                    (/ (* m1 b1 (/ m2 255)) 255)
                    (/ (* 255 255) 255)
                    (/ (* 255 (- b2)) 255)
                    (/ (* m2 b2) 255))
                 (- 255 m3)))))

;; pull out 255 in num
(define (build-b3-11 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (/ (+ (* (- m1) m2)
                       (* (- b1) m2)
                       (* m1 b1 (/ m2 255))
                       (* 255 255)
                       (* 255 (- b2))
                       (* m2 b2))
                    255)
                 (- 255 m3)))))

;; push 255 into denom
(define (build-b3-12 m1 b1 m2 b2 m3)
  (* 255 (- 1 (/ (+ (* (- m1) m2)
                    (* (- b1) m2)
                    (* m1 b1 (/ m2 255))
                    (* 255 255)
                    (* 255 (- b2))
                    (* m2 b2))
                 (* 255 (- 255 m3))))))

;; turn 1 into (/ (* 255 (- 255 m3)) (* 255 (- 255 m3)))
;; and add into numerator
(define (build-b3-13 m1 b1 m2 b2 m3)
  (* 255 (/ (- (* 255 (- 255 m3))
               (+ (* (- m1) m2)
                  (* (- b1) m2)
                  (* m1 b1 (/ m2 255))
                  (* 255 255)
                  (* 255 (- b2))
                  (* m2 b2)))
            (* 255 (- 255 m3)))))

;; cancel out outer 255
(define (build-b3-14 m1 b1 m2 b2 m3)
  (/ (- (* 255 (- 255 m3))
        (+ (* (- m1) m2)
           (* (- b1) m2)
           (* m1 b1 (/ m2 255))
           (* 255 255)
           (* 255 (- b2))
           (* m2 b2)))
     (- 255 m3)))

;; push negative thru to make big sum in numerator
(define (build-b3-15 m1 b1 m2 b2 m3)
  (/ (+ (* 255 (- 255 m3))
        (* m1 m2)
        (* b1 m2)
        (- (* m1 b1 (/ m2 255)))
        (- (* 255 255))
        (* 255 b2)
        (- (* m2 b2)))
     (- 255 m3)))

;; distribute 255 in first num term
(define (build-b3-16 m1 b1 m2 b2 m3)
  (/ (+ (* 255 255)
        (- (* 255 m3))
        (* m1 m2)
        (* b1 m2)
        (- (* m1 b1 (/ m2 255)))
        (- (* 255 255))
        (* 255 b2)
        (- (* m2 b2)))
     (- 255 m3)))

;; simplify num
(define (build-b3-17 m1 b1 m2 b2 m3)
  (/ (+ (* m1 m2)
        (* b1 m2)
        (- (* m2 b2))
        (- (* m1 b1 m2 1/255))
        (* 255 b2)
        (- (* 255 m3)))
     (- 255 m3)))

;; simplify num, some more
(define (build-b3-18 m1 b1 m2 b2 m3)
  (/ (+ (* (+ m1 b1 (- b2)) m2) 
        (* m1 b1 m2 -1/255)
        (* 255 b2)
        (* -255 m3))
     (- 255 m3)))

(define (test-b3 m1 b1 m2 b2)
  (let ([m3 (build-m3-6 m1 m2)])
    (values (build-b3-0 m1 b1 m2 b2 m3)
            (build-b3-1 m1 b1 m2 b2 m3)
            (build-b3-2 m1 b1 m2 b2 m3)
            (build-b3-3 m1 b1 m2 b2 m3)
            (build-b3-4 m1 b1 m2 b2 m3)
            (build-b3-5 m1 b1 m2 b2 m3)
            (build-b3-6 m1 b1 m2 b2 m3)
            (build-b3-7 m1 b1 m2 b2 m3)
            (build-b3-8 m1 b1 m2 b2 m3)
            (build-b3-9 m1 b1 m2 b2 m3)
            (build-b3-10 m1 b1 m2 b2 m3)
            (build-b3-11 m1 b1 m2 b2 m3)
            (build-b3-12 m1 b1 m2 b2 m3)
            (build-b3-13 m1 b1 m2 b2 m3)
            (build-b3-14 m1 b1 m2 b2 m3)
            (build-b3-15 m1 b1 m2 b2 m3)
            (build-b3-16 m1 b1 m2 b2 m3)
            (build-b3-17 m1 b1 m2 b2 m3)
            (build-b3-18 m1 b1 m2 b2 m3)
            )))

(test-b3 255 100 0 250)
(test-b3 0 150 255 100)
(test-b3 100 200 75 150)


|#
  
  (define (build-m3 m1 m2) (* m1 m2 1/255))
  
  (define (build-b3 m1 b1 m2 b2 m3)
    (if (= m3 255)
        0
        (/ (+ (* (+ m1 b1 (- b2)) m2) 
              (* m1 b1 m2 -1/255)
              (* 255 b2)
              (* -255 m3))
           (- 255 m3))))

  (provide/contract
   [overlay-bitmap (argb? number? number? (is-a?/c bitmap%) (is-a?/c bitmap%) . -> . any)]
   [build-bitmap (((is-a?/c dc<%>) . -> . any) number? number? . -> . (is-a?/c bitmap%))]
   [flatten-bitmap ((is-a?/c bitmap%) . -> . (is-a?/c bitmap%))]

   [argb->cache-image-snip (argb? number? number? . -> . (is-a?/c cache-image-snip%))]
   [argb->bitmap (argb? . -> . (is-a?/c bitmap%))]
           
   [argb? (any/c . -> . boolean?)]
   [make-argb ((vectorof (integer-in 0 255)) integer? . -> . argb?)]
   [argb-vector (argb? . -> . (vectorof (integer-in 0 255)))]
   [argb-width (argb? . -> . integer?)]))