850 lines
29 KiB
Racket
850 lines
29 KiB
Racket
#lang racket/base
|
|
(require racket/draw
|
|
racket/snip
|
|
racket/class
|
|
racket/contract
|
|
racket/promise
|
|
(for-syntax racket/base)
|
|
mzlib/string)
|
|
|
|
(provide cache-image-snip%
|
|
cache-image-snip-class%
|
|
snip-class
|
|
|
|
coerce-to-cache-image-snip
|
|
snip-size
|
|
bitmaps->cache-image-snip)
|
|
|
|
;; type argb = (make-argb (vectorof rational[between 0 & 255]) int int)
|
|
(define-struct argb (vector width height))
|
|
|
|
#|
|
|
|
|
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 analogous 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 image-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)
|
|
(when (inexact? px)
|
|
(set! px (floor (inexact->exact px))))
|
|
(when (inexact? py)
|
|
(set! py (floor (inexact->exact 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 or false
|
|
;; returns a bitmap showing what the image would look like,
|
|
;; if it were drawn
|
|
(define/override (get-bitmap)
|
|
(cond
|
|
[(or (zero? width) (zero? height))
|
|
#f]
|
|
[else
|
|
(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 height))
|
|
(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)])
|
|
(when bitmap
|
|
(send dc draw-bitmap bitmap x y 'solid
|
|
(send the-color-database find-color "black")
|
|
(send bitmap get-loaded-mask))))]
|
|
[dc-proc
|
|
(let ([smoothing (send dc get-smoothing)])
|
|
(send dc set-smoothing 'aligned)
|
|
(dc-proc dc x y)
|
|
(send dc set-smoothing smoothing))]
|
|
[else (void)]))
|
|
|
|
(define/override (write f)
|
|
(let ([str (string->bytes/utf-8
|
|
(format "~s"
|
|
(list (argb-vector (get-argb))
|
|
width
|
|
height
|
|
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))
|
|
|
|
(define/override (equal-to? snip recur)
|
|
(if (snip . is-a? . cache-image-snip%)
|
|
;; Support extensions of cache-image-snip%:
|
|
(send snip other-equal-to? this recur)
|
|
;; Use ths object's extension:
|
|
(other-equal-to? snip recur)))
|
|
(define/override (other-equal-to? snip recur)
|
|
(image=? this snip))
|
|
|
|
(super-new)
|
|
(inherit set-snipclass)
|
|
(set-snipclass snip-class)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; snip-class
|
|
;;
|
|
|
|
(define cache-image-snip-class%
|
|
(class snip-class%
|
|
(define/override (read f)
|
|
(data->snip (read-from-string (send f get-bytes) (lambda () #f))))
|
|
(define/public (data->snip data)
|
|
(cond
|
|
[(not (list? data)) (make-null-cache-image-snip)]
|
|
[(= (length data) 4)
|
|
;; this is the case for old save files
|
|
;; if the width is zero, the height
|
|
;; will automatically also be zero
|
|
(let ([argb-vec (list-ref data 0)]
|
|
[width (list-ref data 1)]
|
|
[px (list-ref data 2)]
|
|
[py (list-ref data 3)])
|
|
(argb->cache-image-snip (make-argb argb-vec
|
|
width
|
|
(if (zero? width)
|
|
0
|
|
(/ (vector-length argb-vec) width 4)))
|
|
px
|
|
py))]
|
|
[(= (length data) 5)
|
|
;; this is the new saved data and it has the width and the height separately.
|
|
(let ([argb-vec (list-ref data 0)]
|
|
[width (list-ref data 1)]
|
|
[height (list-ref data 2)]
|
|
[px (list-ref data 3)]
|
|
[py (list-ref data 4)])
|
|
(argb->cache-image-snip (make-argb argb-vec width height) px py))]))
|
|
(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")))
|
|
|
|
;; ***** WARNING: illegal activities **** -- MF
|
|
(define the-drscheme-snip-class (get-the-snip-class-list))
|
|
(send the-drscheme-snip-class add snip-class)
|
|
(provide the-drscheme-snip-class)
|
|
;; ***** WARNING: illegal activities ****
|
|
|
|
(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)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; image equality
|
|
;;
|
|
|
|
(define size-dc (delay (make-object bitmap-dc% (make-object bitmap% 1 1))))
|
|
|
|
(define (snip-size a)
|
|
(cond
|
|
[(is-a? a cache-image-snip%)
|
|
(send a get-size)]
|
|
[else
|
|
(let* ([dc (force size-dc)]
|
|
[wb (box 0)]
|
|
[hb (box 0)])
|
|
(send a get-extent dc 0 0 wb hb #f #f #f #f)
|
|
(values (unbox wb)
|
|
(unbox hb)))]))
|
|
|
|
(define (image=? a-raw b-raw)
|
|
(let ([a (coerce-to-cache-image-snip a-raw)]
|
|
[b (coerce-to-cache-image-snip b-raw)])
|
|
(let-values ([(aw ah) (snip-size a)]
|
|
[(bw bh) (snip-size b)]
|
|
[(apx apy) (send a get-pinhole)]
|
|
[(bpx bpy) (send b get-pinhole)])
|
|
(and (= aw bw)
|
|
(= ah bh)
|
|
(= apx bpx)
|
|
(= apy bpy)
|
|
(same/alpha? (argb-vector (send a get-argb))
|
|
(argb-vector (send b get-argb)))))))
|
|
|
|
(define (same/alpha? v1 v2)
|
|
(let loop ([i (vector-length v1)])
|
|
(or (zero? i)
|
|
(let ([a1 (vector-ref v1 (- i 4))]
|
|
[a2 (vector-ref v2 (- i 4))])
|
|
(and (or (= a1 a2 255)
|
|
(and (= a1 a2)
|
|
(= (vector-ref v1 (- i 3)) (vector-ref v2 (- i 3)))
|
|
(= (vector-ref v1 (- i 2)) (vector-ref v2 (- i 2)))
|
|
(= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
|
|
(loop (- i 4)))))))
|
|
|
|
(define image-snip-cache (make-weak-hasheq))
|
|
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
|
|
(define (coerce-to-cache-image-snip snp)
|
|
(cond
|
|
[(is-a? snp cache-image-snip%) snp]
|
|
[(hash-ref image-snip-cache snp (λ () #f)) => values]
|
|
[(is-a? snp image-snip%)
|
|
(let* ([bmp (send snp get-bitmap)]
|
|
[cis
|
|
(if bmp
|
|
(let ([bmp-mask (or (send bmp get-loaded-mask)
|
|
(send snp get-bitmap-mask)
|
|
(bitmap->mask bmp))])
|
|
(bitmaps->cache-image-snip (copy-bitmap bmp)
|
|
(copy-bitmap bmp-mask)
|
|
(floor (/ (send bmp get-width) 2))
|
|
(floor (/ (send bmp get-height) 2))))
|
|
(let-values ([(w h) (snip-size snp)])
|
|
(let* ([bmp (make-object bitmap%
|
|
(inexact->exact (floor w))
|
|
(inexact->exact (floor h)))]
|
|
[bdc (make-object bitmap-dc% bmp)])
|
|
(send bdc clear)
|
|
(send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
|
|
(send bdc set-bitmap #f)
|
|
(bitmaps->cache-image-snip bmp
|
|
(bitmap->mask bmp)
|
|
(floor (/ w 2))
|
|
(floor (/ h 2))))))])
|
|
(hash-set! image-snip-cache snp cis)
|
|
cis)]
|
|
[else snp]))
|
|
|
|
;; copy-bitmap : bitmap -> bitmap
|
|
;; does not copy the mask.
|
|
(define (copy-bitmap bitmap)
|
|
(let* ([w (send bitmap get-width)]
|
|
[h (send bitmap get-height)]
|
|
[copy (make-object bitmap% w h)]
|
|
[a-dc (make-object bitmap-dc% copy)])
|
|
(send a-dc clear)
|
|
(send a-dc draw-bitmap bitmap 0 0)
|
|
(send a-dc set-bitmap #f)
|
|
copy))
|
|
|
|
;; bitmap->mask : bitmap -> bitmap
|
|
(define (bitmap->mask bitmap)
|
|
(let* ([w (send bitmap get-width)]
|
|
[h (send bitmap get-height)]
|
|
[s (make-bytes (* 4 w h))]
|
|
[new-bitmap (make-object bitmap% w h)]
|
|
[dc (make-object bitmap-dc% new-bitmap)])
|
|
(send dc clear)
|
|
(send dc draw-bitmap bitmap 0 0)
|
|
(send dc get-argb-pixels 0 0 w h s)
|
|
(let loop ([i (* 4 w h)])
|
|
(unless (zero? i)
|
|
(let ([r (- i 3)]
|
|
[g (- i 2)]
|
|
[b (- i 1)])
|
|
(unless (and (eq? 255 (bytes-ref s r))
|
|
(eq? 255 (bytes-ref s g))
|
|
(eq? 255 (bytes-ref s b)))
|
|
(bytes-set! s r 0)
|
|
(bytes-set! s g 0)
|
|
(bytes-set! s b 0))
|
|
(loop (- i 4)))))
|
|
(send dc set-argb-pixels 0 0 w h s)
|
|
(begin0
|
|
(send dc get-bitmap)
|
|
(send dc set-bitmap #f))))
|
|
|
|
(define (bitmaps->cache-image-snip color mask px py)
|
|
(let ([w (send color get-width)]
|
|
[h (send color get-height)])
|
|
(new cache-image-snip%
|
|
[width w]
|
|
[height h]
|
|
[dc-proc
|
|
(lambda (dc dx dy)
|
|
(send dc draw-bitmap color dx dy 'solid
|
|
(send the-color-database find-color "black")
|
|
mask))]
|
|
[argb-proc
|
|
(lambda (argb-vector dx dy)
|
|
(overlay-bitmap argb-vector dx dy color mask))]
|
|
[px px]
|
|
[py py])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; 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 clear)
|
|
(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)
|
|
; (send bdc set-smoothing 'aligned) ; causes image-inside? to fail in test suite.
|
|
(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)]
|
|
[height (argb-height argb)]
|
|
[argb-vector (argb-vector argb)]
|
|
[bitmap (argb->bitmap argb)]
|
|
[mask (and bitmap (send bitmap get-loaded-mask))])
|
|
(new cache-image-snip%
|
|
(width width)
|
|
(height height)
|
|
(argb argb)
|
|
(px px)
|
|
(py py)
|
|
(argb-proc (if (or (zero? width) (zero? height))
|
|
void
|
|
(lambda (argb dx dy) (overlay-bitmap argb dx dy bitmap mask))))
|
|
(dc-proc (if (or (zero? width) (zero? height))
|
|
void
|
|
(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 or false
|
|
;; flattens the argb vector into a bitmap
|
|
(define (argb->bitmap argb)
|
|
(let* ([argb-vector (argb-vector argb)]
|
|
[w (argb-width argb)]
|
|
[h (argb-height argb)])
|
|
(cond
|
|
[(or (zero? w) (zero? h)) #f]
|
|
[else
|
|
(let* ([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))))
|
|
|
|
(define bitmap-size/c (and/c integer? exact? (between/c 1 10000)))
|
|
|
|
(provide/contract
|
|
[overlay-bitmap (argb? exact-integer?
|
|
exact-integer?
|
|
(is-a?/c bitmap%)
|
|
(is-a?/c bitmap%)
|
|
. -> .
|
|
any)]
|
|
[build-bitmap (((is-a?/c dc<%>) . -> . any) bitmap-size/c bitmap-size/c . -> . (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? . -> . (or/c #f (is-a?/c bitmap%)))]
|
|
|
|
[argb? (any/c . -> . boolean?)]
|
|
[make-argb ((vectorof byte?) exact-nonnegative-integer? exact-nonnegative-integer? . -> . argb?)]
|
|
[argb-vector (argb? . -> . (vectorof byte?))]
|
|
[argb-width (argb? . -> . exact-nonnegative-integer?)]
|
|
[argb-height (argb? . -> . exact-nonnegative-integer?)])
|