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

add equal?/recur; implement equal? for image-snip% via properties

Browse Source 
svn: r12950

original commit: 1642a84e690899f7da27839648e315ebb03d7966
This commit is contained in:
Matthew Flatt 2008-12-29 22:36:53 +00:00
parent 63ff193e47
commit 83dd14f202
4 changed files with 312 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
collects/mred/private/kernel.ss
View File

@ -47,7 +47,7 @@
(let ([defined null])
(lambda (stx)
(syntax-case stx ()
[(_ name print-name super args id ...)
[(_ name print-name super (intf ...) args id ...)
(let ([nm (syntax-e (syntax name))]
[sn (syntax-e (syntax super))]
[ids (map syntax-e (syntax->list (syntax (id ...))))])
@ -78,11 +78,11 @@
(syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class
(lambda (class prop:object preparer dispatcher)
(lambda (class prop:object preparer dispatcher more-props)
(kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher))
c prop:object class preparer dispatcher more-props))
kernel:initialize-primitive-object
'print-name super 'args
'print-name super (list intf ...) 'args
'(old ...)
'(new ...)
(list
@ -110,8 +110,8 @@
(define-a-class name intf super args id ...)
(define intf (class->interface name))
(provide (protect intf))))])))
(define-class object% #f #f)
(define-class window% object% #f
(define-class object% #f () #f)
(define-class window% object% () #f
on-drop-file
pre-on-event
pre-on-char
@ -147,11 +147,11 @@
set-focus
gets-focus?
centre)
(define-class item% window% #f
(define-class item% window% () #f
set-label
get-label
command)
(define-class message% item% #f
(define-class message% item% () #f
get-font
set-label
on-drop-file
@ -160,7 +160,7 @@
on-size
on-set-focus
on-kill-focus)
(define-private-class editor% editor<%> object% #f
(define-private-class editor% editor<%> object% () #f
dc-location-to-editor-location
editor-location-to-dc-location
set-inactive-caret-threshold
@ -300,7 +300,7 @@
(define-function write-editor-version)
(define-function set-editor-print-margin)
(define-function get-editor-print-margin)
(define-class bitmap% object% #f
(define-class bitmap% object% () #f
get-argb-pixels
get-gl-config
set-gl-config
@ -313,7 +313,7 @@
get-width
get-height
get-depth)
(define-class button% item% #f
(define-class button% item% () #f
set-border
set-label
on-drop-file
@ -322,7 +322,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class choice% item% #f
(define-class choice% item% () #f
set-selection
get-selection
number
@ -335,7 +335,7 @@
on-set-focus
on-kill-focus)
(define-function set-combo-box-font)
(define-class check-box% item% #f
(define-class check-box% item% () #f
set-label
set-value
get-value
@ -345,7 +345,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class canvas% window% #f
(define-class canvas% window% () #f
on-drop-file
pre-on-event
pre-on-char
@ -373,7 +373,7 @@
on-char
on-event
on-paint)
(define-private-class dc% dc<%> object% #f
(define-private-class dc% dc<%> object% () #f
get-alpha
set-alpha
glyph-exists?
@ -427,7 +427,7 @@
clear)
(define-function draw-tab)
(define-function draw-tab-base)
(define-class bitmap-dc% dc% ()
(define-class bitmap-dc% dc% () ()
get-bitmap
set-bitmap
draw-bitmap-section-smooth
@ -435,13 +435,13 @@
get-argb-pixels
set-pixel
get-pixel)
(define-class post-script-dc% dc% ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
(define-class printer-dc% dc% ([parent #f]))
(define-private-class gl-context% gl-context<%> object% #f
(define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
(define-class printer-dc% dc% () ([parent #f]))
(define-private-class gl-context% gl-context<%> object% () #f
call-as-current
swap-buffers
ok?)
(define-class gl-config% object% #f
(define-class gl-config% object% () #f
get-double-buffered
set-double-buffered
get-stereo
@ -454,23 +454,23 @@
set-depth-size
get-multisample-size
set-multisample-size)
(define-class event% object% ([time-stamp 0])
(define-class event% object% () ([time-stamp 0])
get-time-stamp
set-time-stamp)
(define-class control-event% event% (event-type [time-stamp 0])
(define-class control-event% event% () (event-type [time-stamp 0])
get-event-type
set-event-type)
(define-class popup-event% control-event% #f
(define-class popup-event% control-event% () #f
get-menu-id
set-menu-id)
(define-class scroll-event% event% ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
(define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
get-event-type
set-event-type
get-direction
set-direction
get-position
set-position)
(define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f])
(define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f])
set-other-caps-key-code
get-other-caps-key-code
set-other-shift-altgr-key-code
@ -498,7 +498,7 @@
get-y
set-y)
(define-function key-symbol-to-integer)
(define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f])
(define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f])
moving?
leaving?
entering?
@ -528,7 +528,7 @@
set-x
get-y
set-y)
(define-class frame% window% #f
(define-class frame% window% () #f
on-drop-file
pre-on-event
pre-on-char
@ -556,7 +556,7 @@
set-icon
iconize
set-title)
(define-class gauge% item% #f
(define-class gauge% item% () #f
get-value
set-value
get-range
@ -567,7 +567,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class font% object% #f
(define-class font% object% () #f
screen-glyph-exists?
get-font-id
get-size-in-pixels
@ -578,32 +578,32 @@
get-style
get-face
get-family)
(define-class font-list% object% #f
(define-class font-list% object% () #f
find-or-create-font)
(define-class color% object% #f
(define-class color% object% () #f
blue
green
red
set
ok?
copy-from)
(define-private-class color-database% color-database<%> object% #f
(define-private-class color-database% color-database<%> object% () #f
find-color)
(define-class point% object% #f
(define-class point% object% () #f
get-x
set-x
get-y
set-y)
(define-class brush% object% #f
(define-class brush% object% () #f
set-style
get-style
set-stipple
get-stipple
set-color
get-color)
(define-class brush-list% object% #f
(define-class brush-list% object% () #f
find-or-create-brush)
(define-class pen% object% #f
(define-class pen% object% () #f
set-style
get-style
set-stipple
@ -616,11 +616,11 @@
get-cap
set-width
get-width)
(define-class pen-list% object% #f
(define-class pen-list% object% () #f
find-or-create-pen)
(define-class cursor% object% #f
(define-class cursor% object% () #f
ok?)
(define-class region% object% (dc)
(define-class region% object% () (dc)
in-region?
is-empty?
get-bounding-box
@ -635,7 +635,7 @@
set-rounded-rectangle
set-rectangle
get-dc)
(define-class dc-path% object% #f
(define-class dc-path% object% () #f
get-bounding-box
append
reverse
@ -653,7 +653,7 @@
open?
close
reset)
(define-private-class font-name-directory% font-name-directory<%> object% #f
(define-private-class font-name-directory% font-name-directory<%> object% () #f
find-family-default-font-id
find-or-create-font-id
get-family
@ -686,7 +686,7 @@
(define-function get-display-depth)
(define-function is-color-display?)
(define-function file-selector)
(define-class list-box% item% #f
(define-class list-box% item% () #f
get-label-font
set-string
set-first-visible-item
@ -710,7 +710,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class editor-canvas% canvas% #f
(define-class editor-canvas% canvas% () #f
on-char
on-event
on-paint
@ -741,7 +741,7 @@
set-editor
get-wheel-step
set-wheel-step)
(define-class editor-admin% object% #f
(define-class editor-admin% object% () #f
modified
refresh-delayed?
popup-menu
@ -753,9 +753,9 @@
get-max-view
get-view
get-dc)
(define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f
(define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% () #f
get-snip)
(define-class snip-admin% object% #f
(define-class snip-admin% object% () #f
modified
popup-menu
update-cursor
@ -769,7 +769,7 @@
get-view-size
get-dc
get-editor)
(define-class snip-class% object% #f
(define-class snip-class% object% () #f
reading-version
write-header
read-header
@ -778,13 +778,13 @@
set-classname
get-version
set-version)
(define-private-class snip-class-list% snip-class-list<%> object% #f
(define-private-class snip-class-list% snip-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class keymap% object% #f
(define-class keymap% object% () #f
remove-chained-keymap
chain-to-keymap
set-break-sequence-callback
@ -800,11 +800,11 @@
handle-key-event
set-double-click-interval
get-double-click-interval)
(define-class editor-wordbreak-map% object% #f
(define-class editor-wordbreak-map% object% () #f
get-map
set-map)
(define-function get-the-editor-wordbreak-map)
(define-class text% editor% #f
(define-class text% editor% () #f
call-clickback
remove-clickback
set-clickback
@ -958,7 +958,7 @@
on-event
copy-self-to
copy-self)
(define-class menu% object% #f
(define-class menu% object% () #f
select
get-font
set-width
@ -973,30 +973,30 @@
delete-by-position
delete
append)
(define-class menu-bar% object% #f
(define-class menu-bar% object% () #f
set-label-top
number
enable-top
delete
append)
(define-class menu-item% object% #f
(define-class menu-item% object% () #f
id)
(define-function id-to-menu-item)
(define-class editor-stream-in-base% object% #f
(define-class editor-stream-in-base% object% () #f
read
bad?
skip
seek
tell)
(define-class editor-stream-out-base% object% #f
(define-class editor-stream-out-base% object% () #f
write
bad?
seek
tell)
(define-class editor-stream-in-bytes-base% editor-stream-in-base% #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% #f
(define-class editor-stream-in-bytes-base% editor-stream-in-base% () #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% () #f
get-bytes)
(define-class editor-stream-in% object% #f
(define-class editor-stream-in% object% () #f
ok?
jump-to
tell
@ -1009,19 +1009,19 @@
get-unterminated-bytes
get-bytes
get)
(define-class editor-stream-out% object% #f
(define-class editor-stream-out% object% () #f
ok?
pretty-finish
jump-to
tell
put-fixed
put)
(define-class timer% object% ()
(define-class timer% object% () ()
stop
start
notify
interval)
(define-private-class clipboard% clipboard<%> object% #f
(define-private-class clipboard% clipboard<%> object% () #f
get-clipboard-bitmap
set-clipboard-bitmap
get-clipboard-data
@ -1030,12 +1030,12 @@
set-clipboard-client)
(define-function get-the-x-selection)
(define-function get-the-clipboard)
(define-class clipboard-client% object% ()
(define-class clipboard-client% object% () ()
get-types
add-type
get-data
on-replaced)
(define-class ps-setup% object% ()
(define-class ps-setup% object% () ()
copy-from
set-margin
set-editor-margin
@ -1061,7 +1061,7 @@
get-command)
(define-function show-print-setup)
(define-function can-show-print-setup?)
(define-class pasteboard% editor% #f
(define-class pasteboard% editor% () #f
set-scroll-step
get-scroll-step
set-selection-visible
@ -1177,7 +1177,7 @@
paste
copy
cut)
(define-class panel% window% #f
(define-class panel% window% () #f
get-label-position
set-label-position
on-char
@ -1191,7 +1191,7 @@
on-kill-focus
set-item-cursor
get-item-cursor)
(define-class dialog% window% #f
(define-class dialog% window% () #f
system-menu
set-title
on-drop-file
@ -1203,7 +1203,7 @@
enforce-size
on-close
on-activate)
(define-class radio-box% item% #f
(define-class radio-box% item% () #f
button-focus
enable
set-selection
@ -1215,7 +1215,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class slider% item% #f
(define-class slider% item% () #f
set-value
get-value
on-drop-file
@ -1224,7 +1224,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class snip% object% #f
(define-class snip% object% () #f
previous
next
set-unmodified
@ -1262,7 +1262,7 @@
get-style
get-snipclass
set-snipclass)
(define-class string-snip% snip% #f
(define-class string-snip% snip% () #f
read
insert
set-unmodified
@ -1289,7 +1289,7 @@
draw
partial-offset
get-extent)
(define-class tab-snip% string-snip% #f
(define-class tab-snip% string-snip% () #f
set-unmodified
get-scroll-step-offset
find-scroll-step
@ -1314,7 +1314,11 @@
draw
partial-offset
get-extent)
(define-class image-snip% snip% #f
(define-class image-snip% snip% (equal<%>) #f
equal-secondary-hash-code-of
equal-hash-code-of
other-equal-to?
equal-to?
set-offset
get-bitmap-mask
get-bitmap
@ -1346,7 +1350,7 @@
draw
partial-offset
get-extent)
(define-class editor-snip% snip% #f
(define-class editor-snip% snip% () #f
get-inset
set-inset
get-margin
@ -1393,23 +1397,23 @@
get-extent
set-editor
get-editor)
(define-class editor-data-class% object% #f
(define-class editor-data-class% object% () #f
read
get-classname
set-classname)
(define-private-class editor-data-class-list% editor-data-class-list<%> object% #f
(define-private-class editor-data-class-list% editor-data-class-list<%> object% () #f
nth
number
add
find-position
find)
(define-class editor-data% object% #f
(define-class editor-data% object% () #f
set-next
write
get-dataclass
set-dataclass
get-next)
(define-private-class mult-color% mult-color<%> object% #f
(define-private-class mult-color% mult-color<%> object% () #f
set
get
get-r
@ -1418,7 +1422,7 @@
set-g
get-b
set-b)
(define-private-class add-color% add-color<%> object% #f
(define-private-class add-color% add-color<%> object% () #f
set
get
get-r
@ -1427,7 +1431,7 @@
set-g
get-b
set-b)
(define-class style-delta% object% #f
(define-class style-delta% object% () #f
copy
collapse
equal?
@ -1475,7 +1479,7 @@
set-alignment-on
get-alignment-off
set-alignment-off)
(define-private-class style% style<%> object% #f
(define-private-class style% style<%> object% () #f
switch-to
set-shift-style
get-shift-style
@ -1502,7 +1506,7 @@
get-face
get-family
get-name)
(define-class style-list% object% #f
(define-class style-list% object% () #f
forget-notification
notify-on-change
style-to-index
@ -1516,7 +1520,7 @@
number
basic-style)
(define-function get-the-style-list)
(define-class tab-group% item% #f
(define-class tab-group% item% () #f
button-focus
set
set-label
@ -1532,7 +1536,7 @@
on-size
on-set-focus
on-kill-focus)
(define-class group-box% item% #f
(define-class group-box% item% () #f
on-drop-file
pre-on-event
pre-on-char

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

@ -7,7 +7,11 @@
(provide cache-image-snip%
cache-image-snip-class%
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))
@ -38,9 +42,9 @@
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%
(class image-snip%
;; dc-proc : (union #f ((is-a?/c dc<%>) int[dx] int[dy] -> void))
;; used for direct drawing
@ -85,7 +89,7 @@
;; get-bitmap : -> bitmap or false
;; returns a bitmap showing what the image would look like,
;; if it were drawn
(define/public (get-bitmap)
(define/override (get-bitmap)
(cond
[(or (zero? width) (zero? height))
#f]
@ -141,6 +145,15 @@
(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)
@ -215,6 +228,138 @@
(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-hash-table 'weak))
;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
(define (coerce-to-cache-image-snip snp)
(cond
[(hash-table-get 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 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-table-put! 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

31
collects/mrlib/scribblings/cache-image-snip.scrbl
View File

@ -16,7 +16,22 @@ bitmap, but with alpha values. It has a maker, two selectors, and a
predicate.
@defclass[cache-image-snip% snip% ()]{
@defclass[cache-image-snip% image-snip% ()]{
The @scheme[cache-image-snip%] class is a subclass of
@scheme[image-snip%] simply so that its instances can be compared with
@scheme[image-snip%] using @scheme[equal?]. All @scheme[image-snip%]
functionality is overridden or ignored.
@defmethod[#:mode overrride
(equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Calls the @method[cache-image-snip% other-equal-to?] method of
@scheme[snip] if it is also a @scheme[cache-image-snip%] instance,
otherwise calls the @method[cache-image-snip% other-equal-to?] of
@this-obj[].}
@defmethod[(get-argb)
@ -44,7 +59,8 @@ predicate.
}
@defmethod[(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{
@defmethod[#:mode override
(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{
Builds (if not yet built) a bitmap corresponding to
this snip and returns it.
@ -75,7 +91,15 @@ predicate.
Returns the width and height for the image.
}}
}
@defmethod[#:mode override
(other-equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Refines the comparison of @xmethod[image-snip% other-equal-to?] to
exactly match alpha channels.}}
@; ----------------------------------------
@ -83,6 +107,7 @@ predicate.
This snipclass is used for saved cache image snips.}
@defproc[(make-argb [vectorof (integer-in 0 255)]
[width exact-nonnegative-integer?]
[height exact-nonnegative-integer?])

48
collects/scribblings/gui/image-snip-class.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@(require "common.ss")
@defclass/title[image-snip% snip% ()]{
@defclass/title[image-snip% snip% (equal<%>)]{
An @scheme[image-snip%] is a snip that can display bitmap images
(usually loaded from a file). When the image file cannot be found, a
@ -24,6 +24,38 @@ Creates an image snip, loading the image @scheme[filename] if
}
@defmethod[(equal-hash-code [hash-code (any/c . -> . exact-integer?)])
exact-integer?]{
Returns an integer that can be used as a @scheme[equal?]-based hash
code for @this-obj[] (using the same notion of @scheme[equal?] as
@method[image-snip% other-equal-to?]).
See also @scheme[equal<%>].}
@defmethod[(equal-secondary-hash-code [hash-code (any/c . -> . exact-integer?)])
exact-integer?]{
Returns an integer that can be used as a @scheme[equal?]-based
secondary hash code for @this-obj[] (using the same notion of
@scheme[equal?] as @method[image-snip% other-equal-to?]).
See also @scheme[equal<%>].}
@defmethod[(equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Calls the @method[image-snip% other-equal-to?] method of @scheme[snip]
(to simulate multi-method dispatch) in case @scheme[snip] provides a
more specific equivalence comparison.
See also @scheme[equal<%>].}
@defmethod[(get-bitmap)
(or/c (is-a?/c bitmap%) false/c)]{
@ -105,6 +137,20 @@ If @scheme[inline?] is not @scheme[#f], the image data will be saved
}
@defmethod[(other-equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)])
boolean?]{
Returns @scheme[#t] if @this-obj[] and @scheme[snip] both have bitmaps
and the bitmaps are the same dimensions. If either has a mask bitmap
with the same dimensions as the main bitmap, then the masks must be
the same (or if only one mask is present, it must correspond to a
solid mask).
The given @scheme[equal?] function (for recursive comparisons) is not
used.}
@defmethod[#:mode override
(resize [w (and/c real? (not/c negative?))]
[h (and/c real? (not/c negative?))])