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

..

Browse Source 
original commit: 141d14c8cbae5f5cf7cb4e49e889514681acc359
This commit is contained in:
Robby Findler 2003-03-19 18:06:33 +00:00
parent e6e7e5a827
commit 8d7d79e2dd
3 changed files with 59 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/framework/private/comment-box.ss
View File

@ -6,6 +6,7 @@
(lib "unitsig.ss") (lib "unitsig.ss")
"sig.ss" "sig.ss"
"../decorated-editor-snip.ss" "../decorated-editor-snip.ss"
(lib "bitmap-constant.ss" "mrlib")
(lib "string-constant.ss" "string-constants")) (lib "string-constant.ss" "string-constants"))
(provide comment-box@) (provide comment-box@)
@ -28,11 +29,7 @@
(send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) (send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
(send (get-the-snip-class-list) add snipclass) (send (get-the-snip-class-list) add snipclass)
(define bm (let ([file (build-path (collection-path "icons") "semicolon.gif")]) (define bm (include-bitmap (lib "semicolon.gif" "icons")))
(and (file-exists? file)
(let ([bm (make-object bitmap% file)])
(and (send bm ok?)
bm)))))
(define (editor-keymap-mixin %) (define (editor-keymap-mixin %)
(class % (class %

120
collects/framework/private/icon.ss
View File

@ -1,6 +1,7 @@
(module icon mzscheme (module icon mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "bitmap-constant.ss" "mrlib")
"bday.ss" "bday.ss"
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred")) (lib "mred-sig.ss" "mred"))
@ -11,89 +12,62 @@
(unit/sig framework:icon^ (unit/sig framework:icon^
(import mred^) (import mred^)
(define icon-path (define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
(with-handlers ([not-break-exn? (define (get-anchor-bitmap) (force anchor-bitmap))
(lambda (x)
(case (system-type)
[(windows) "C:"] ;; just avoid quering the floppy drive
[else (car (filesystem-root-list))]))])
(collection-path "icons")))
(define (load-icon name type) (define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons"))))
(letrec ([p (build-path icon-path name)] (define-values (get-lock-bitmap) (force lock-bitmap))
[f (define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons"))))
(lambda () (define-values (get-unlock-bitmap) (force unlock-bitmap))
(let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap))
bitmap))])
(lambda ()
(f))))
(define (load-bitmap name type) (define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons"))))
(letrec ([p (build-path icon-path name)] (define (get-autowrap-bitmap) (force autowrap-bitmap))
[f (define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons"))))
(lambda () (define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
(let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap))
bitmap))])
(lambda ()
(f))))
(define-values (get-anchor-bitmap) (load-bitmap "anchor.gif" 'gif)) (define-syntax (make-get-cursor stx)
(define-values (get-lock-bitmap) (load-bitmap "lock.gif" 'gif)) (syntax-case stx ()
(define-values (get-unlock-bitmap) (load-bitmap "unlock.gif" 'gif)) [(_ name mask fallback)
(syntax
(define get-autowrap-bitmap (load-icon "return.xbm" 'xbm)) (let ([ans (delay
(define get-paren-highlight-bitmap (load-icon "paren.xbm" 'xbm)) (let* ([msk-b (include-bitmap (lib mask "icons"))]
[csr-b (include-bitmap (lib name "icons"))])
(define (make-get/mask filename type)
(let ([icon #f]
[p (build-path icon-path filename)])
(lambda ()
(or icon
(begin
(set! icon (make-object bitmap% p type))
icon)))))
(define (make-cursor name mask fallback)
(let* ([msk-b (make-object bitmap% (build-path icon-path mask))]
[csr-b (make-object bitmap% (build-path icon-path name))])
(if (and (send msk-b ok?) (if (and (send msk-b ok?)
(send csr-b ok?)) (send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)]) (let ([csr (make-object cursor% msk-b csr-b 7 7)])
(if (send csr ok?) (if (send csr ok?)
csr csr
(make-object cursor% fallback))) (make-object cursor% fallback)))
(make-object cursor% fallback)))) (make-object cursor% fallback))))])
(define up/down-cursor (make-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
(define (get-up/down-cursor) up/down-cursor)
(define left/right-cursor (make-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
(define (get-left/right-cursor) left/right-cursor)
(define gc-on-bitmap #f)
(define (fetch)
(unless gc-on-bitmap
(set! gc-on-bitmap
(if (mrf-bday?)
((load-icon "mrf.jpg" 'jpeg))
((load-icon "recycle.gif" 'gif))))))
(define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
(define get-gc-off-bitmap
(let ([bitmap #f])
(lambda () (lambda ()
(if bitmap (force ans))))]))
bitmap
(begin (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
(let ([bdc (make-object bitmap-dc%)] (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
[onb (get-gc-on-bitmap)])
(set! bitmap (make-object bitmap% (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-width)
(send onb get-height))) (send onb get-height))]
(send bdc set-bitmap bitmap) [bdc (make-object bitmap-dc% bitmap)])
(send bdc clear) (send bdc clear)
(send bdc set-bitmap #f) (send bdc set-bitmap #f)
bitmap))))))))) 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))))))

5
collects/mrlib/bitmap-constant.ss
View File

@ -5,7 +5,10 @@
(require-for-syntax (lib "path-spec.ss" "syntax")) (require-for-syntax (lib "path-spec.ss" "syntax"))
(provide bitmap-constant (provide bitmap-constant
bitmap-constant/relative-to) (rename bitmap-constant include-bitmap)
bitmap-constant/relative-to
(rename bitmap-constant/relative-to include-bitmap/relative-to))
(define-syntax (-bitmap-constant stx) (define-syntax (-bitmap-constant stx)
(syntax-case stx () (syntax-case stx ()