77 lines
3.0 KiB
Scheme
77 lines
3.0 KiB
Scheme
(module icon mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
(lib "include-bitmap.ss" "mrlib")
|
|
"bday.ss"
|
|
"sig.ss"
|
|
(lib "mred-sig.ss" "mred"))
|
|
|
|
(provide icon@)
|
|
|
|
(define icon@
|
|
(unit/sig framework:icon^
|
|
(import mred^)
|
|
|
|
(define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
|
|
(define (get-eof-bitmap) (force eof-bitmap))
|
|
|
|
(define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
|
|
(define (get-anchor-bitmap) (force anchor-bitmap))
|
|
|
|
(define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons"))))
|
|
(define (get-lock-bitmap) (force lock-bitmap))
|
|
(define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons"))))
|
|
(define (get-unlock-bitmap) (force unlock-bitmap))
|
|
|
|
(define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons"))))
|
|
(define (get-autowrap-bitmap) (force autowrap-bitmap))
|
|
(define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons"))))
|
|
(define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
|
|
|
|
(define-syntax (make-get-cursor stx)
|
|
(syntax-case stx ()
|
|
[(_ name mask fallback)
|
|
(syntax
|
|
(let ([ans (delay
|
|
(let* ([msk-b (include-bitmap (lib mask "icons"))]
|
|
[csr-b (include-bitmap (lib name "icons"))])
|
|
(if (and (send msk-b ok?)
|
|
(send csr-b ok?))
|
|
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
|
|
(if (send csr ok?)
|
|
csr
|
|
(make-object cursor% fallback)))
|
|
(make-object cursor% fallback))))])
|
|
(λ ()
|
|
(force ans))))]))
|
|
|
|
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
|
|
(define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
|
|
|
|
(define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons"))))
|
|
(define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons"))))
|
|
|
|
(define (make-off-bitmap onb)
|
|
(let* ([bitmap (make-object bitmap%
|
|
(send onb get-width)
|
|
(send onb get-height))]
|
|
[bdc (make-object bitmap-dc% bitmap)])
|
|
(send bdc clear)
|
|
(send bdc set-bitmap #f)
|
|
bitmap))
|
|
|
|
(define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap))))
|
|
(define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap))))
|
|
|
|
(define (get-gc-on-bitmap)
|
|
(force
|
|
(if (mrf-bday?)
|
|
mrf-on-bitmap
|
|
gc-on-bitmap)))
|
|
|
|
(define (get-gc-off-bitmap)
|
|
(force
|
|
(if (mrf-bday?)
|
|
mrf-off-bitmap
|
|
gc-off-bitmap))))))
|