suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 89c7f99a2af274f05b30b2e8db7e9dd6b8ec6007
This commit is contained in:
Robby Findler 2004-07-22 15:24:30 +00:00
parent 6bf3380de4
commit d3b93bb3e8
2 changed files with 96 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
collects/mrlib/cache-image-snip.ss
View File

@ -6,8 +6,9 @@
(provide argb-vector->bitmap
overlay-bitmap
build-bitmap
flatten-bitmap
cache-image-snip%
snipclass)
snip-class)
#|
@ -76,15 +77,17 @@
;; if it were drawn
(define/public (get-bitmap)
(unless bitmap
(set! bitmap (argb-vector->bitmap (get-argb-vector)
(ceiling (inexact->exact width))
(ceiling (inexact->exact height)))))
(set! bitmap (flatten-bitmap
(argb-vector->bitmap
(get-argb-vector)
(ceiling (inexact->exact width))
(ceiling (inexact->exact height))))))
bitmap)
;; get-argb-vector : -> argb-vector
(define/public (get-argb-vector)
(unless argb-vector
(set! argb-vector (make-string (* 4 width height) #\000))
(set! argb-vector (make-vector (* 4 width height) 255))
(argb-proc argb-vector 0 0))
argb-vector)
@ -100,25 +103,34 @@
(cond
[argb-vector
(let ([bitmap (get-bitmap)])
(send dc draw-bitmap bitmap x y))]
(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)
(printf "calling write\n")
(let ([str (format "~s"
(list width
height
(get-argb-vector)))])
(send f write str)))
(send f put str)))
(super-new)
(inherit set-snipclass)
(set-snipclass snipclass)))
(set-snipclass snip-class)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; snip-class
;;
(define cache-image-snip-class%
(class snip-class%
(define/override (read f)
(printf "called read\n")
(let ([data (read-from-string (send f get-string)
void
(lambda (x) #f))])
@ -133,6 +145,12 @@
(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")))
(printf "installing snipclass\n")
(send (get-the-snip-class-list) add snip-class)
(define (make-null-cache-image-snip)
(define size 10)
(define (draw dc dx dy)
@ -141,7 +159,7 @@
"black" 'solid
"black" 'transparent
(send dc draw-ellipse dx dy size size)
(send dc draw-line dx dy (+ dx size -1) (+ dy size -1))))
(send dc draw-line dx (+ dy size -1) (+ dx size -1) dy)))
(define bm (build-bitmap (lambda (dc) (draw dc 0 0))
size
size))
@ -152,7 +170,52 @@
(argb-proc
(lambda (argb-vector dx dy)
(overlay-bitmap argb-vector 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))
(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-vector->bitmap : argb-vector int int -> bitmap
;; flattens the argb vector into a bitmap
(define (argb-vector->bitmap argb-vector w h)
@ -520,6 +583,7 @@ for b3, we have:
|#
(define (build-m3 m1 m2) (* m1 m2 1/255))
(define (build-b3 m1 b1 m2 b2 m3)
@ -529,62 +593,4 @@ for b3, we have:
(* m1 b1 m2 -1/255)
(* 255 b2)
(* -255 m3))
(- 255 m3))))
(define snipclass (new cache-image-snip-class%))
(send snipclass set-version 1)
(send snipclass set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib")))
(send (get-the-snip-class-list) add snipclass)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; misc. utilities
;;
(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)))
;; --
;; bitmaps->cache-image-snip : bitmap bitmap -> cache-image-snip
(define (bitmaps->cache-image-snip bmp bmp-mask)
(new cache-image-snip%
[dc-proc (lambda (dc dx dy)
(send dc draw-bitmap
bmp
dx
dy
'solid
(send the-color-database find-color "black")
bmp-mask))]
[argb-proc (lambda (dc dx dy)
(send dc draw-bitmap
bmp
dx
dy
'solid
(send the-color-database find-color "black")
bmp-mask))]
[width (send bmp get-width)]
[height (send bmp get-height)]))
)
(- 255 m3)))))

35
collects/tests/mzscheme/cache-image-snip-test.ss
View File

@ -153,19 +153,6 @@
(get-one (send main-bm get-loaded-mask)))
(get-one main-bm))))
;; 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))
(test '("\377\377\377\377" "\377\377\377\377") argb-vector->bitmap->string #(255 255 255 255) 1 1)
(test '("\377\377\377\377" "\377\0\0\0") argb-vector->bitmap->string #(255 0 0 0) 1 1)
(test '("\377\1\1\1" "\377\100\100\100") argb-vector->bitmap->string #(1 64 64 64) 1 1)
@ -241,6 +228,28 @@
;; but it isn't, due to rounding error (final is actually wrong!)
;; the stuff below just makes sure that each entry is within 3
;; the expression below shows the truncated bitmap,
;; the true bitmap (after rounding) and the difference, as a bitmap
#;
(let* ([argb-bitmap (flatten-bitmap (argb-vector->bitmap argb-str w h))]
[argb-str (cadr (bitmap->string argb-bitmap))]
[bitmap-str (cadr (bitmap->string final))]
[new-bitmap-str (make-string (string-length argb-str) #\000)]
[new-bitmap (make-object bitmap% w h)]
[dc (make-object bitmap-dc% new-bitmap)])
(let loop ([i 0])
(when (< i (string-length argb-str))
(unless (equal? (string-ref argb-str i)
(string-ref bitmap-str i))
(string-set! new-bitmap-str i #\377))
(loop (+ i 1))))
(send dc set-argb-pixels 0 0 w h new-bitmap-str)
(send dc set-bitmap #f)
(show-bitmap argb-bitmap #f "argb")
(show-bitmap final #f "final")
(show-bitmap new-bitmap #f "difference"))
(let* ([argb-bitmap (flatten-bitmap (argb-vector->bitmap argb-str w h))]
[argb-ents (map char->integer (string->list (cadr (bitmap->string argb-bitmap))))]
[bitmap-ents (map char->integer (string->list (cadr (bitmap->string final))))])