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

hierlist inlines arrow bitmaps

Browse Source 
svn: r231
This commit is contained in:
Matthew Flatt 2005-06-22 21:30:30 +00:00
parent d17ee2ab7c
commit bc203f55b8
3 changed files with 21 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/hierlist/hierlist-unit.ss
View File

@ -4,11 +4,17 @@
(lib "class.ss")
(lib "class100.ss")
(lib "mred-sig.ss" "mred")
(lib "include-bitmap.ss" "mrlib")
"hierlist-sig.ss")
(require (lib "list.ss")
(lib "etc.ss"))
(define turn-up (include-bitmap "../icons/turn-up.png" 'png))
(define turn-down (include-bitmap "../icons/turn-down.png" 'png))
(define turn-up-click (include-bitmap "../icons/turn-up-click.png" 'png))
(define turn-down-click (include-bitmap "../icons/turn-down-click.png" 'png))
(provide hierlist@)
(define hierlist@
(unit/sig hierlist^
@ -27,17 +33,7 @@
(define arrow-cursor (make-object cursor% 'arrow))
(define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap)
(with-handlers ([exn:fail? (lambda (x)
(values
(make-object bitmap% 10 10)
(make-object bitmap% 10 10)
(make-object bitmap% 10 10)
(make-object bitmap% 10 10)))])
(values
(make-object bitmap% (build-path (collection-path "icons") "turn-up.png"))
(make-object bitmap% (build-path (collection-path "icons") "turn-down.png"))
(make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png"))
(make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))))
(values turn-up turn-down turn-up-click turn-down-click))
;; Hack for implementing auto-wrapping items:
(define arrow-size 0)

10
collects/mrlib/doc.txt
View File

@ -130,13 +130,15 @@ program. The advantage of "inlining" the bitmap is that a stand-alone
executable can be created that contains the bitmap and does not refer
to the original image file.
> (include-bitmap file-spec) SYNTAX
> (include-bitmap file-spec) SYNTAX
> (include-bitmap file-spec type-expr) SYNTAX
The `file-spec' is the same as for MzLib's `include': a path string, a
`build-path' form, or a `lib' form.
`build-path' form, or a `lib' form. The `type-expr' should produce
'unknown, 'unknown/mask, etc., and the default is 'unknown/mask.
> (include-bitmap/relative-to source file-spec) SYNTAX
> (include-bitmap/relative-to source file-spec) SYNTAX
> (include-bitmap/relative-to source file-spec type-expr) SYNTAX
Analogous to `include-at/relative-to', though only a source is needed
(no context).

14
collects/mrlib/include-bitmap.ss
View File

@ -10,7 +10,7 @@
(define-syntax (-include-bitmap stx)
(syntax-case stx ()
[(_ orig-stx source path-spec)
[(_ orig-stx source path-spec type)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx #'build-path)]
[content
(with-handlers ([exn:fail?
@ -28,22 +28,24 @@
(with-syntax ([content content]
[c-file (path->bytes c-file)])
(syntax/loc stx
(get-or-load-bitmap content c-file))))]))
(get-or-load-bitmap content c-file type))))]))
(define-syntax (include-bitmap/relative-to stx)
(syntax-case stx ()
[(_ source path-spec) #`(-include-bitmap #,stx source path-spec)]))
[(_ source path-spec) #`(-include-bitmap #,stx source path-spec 'unknown/mask)]
[(_ source path-spec type) #`(-include-bitmap #,stx source path-spec type)]))
(define-syntax (include-bitmap stx)
(syntax-case stx ()
[(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec)]))
[(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec 'unknown/mask)]
[(_ path-spec type) #`(-include-bitmap #,stx #,stx path-spec type)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run-time support
(define cached (make-hash-table 'equal))
(define (get-or-load-bitmap content orig)
(define (get-or-load-bitmap content orig type)
(hash-table-get cached content
(lambda ()
(let ([bm (let ([fn (make-temporary-file)])
@ -53,7 +55,7 @@
(with-output-to-file fn
(lambda () (display content))
'truncate)
(make-object bitmap% fn 'unknown/mask))
(make-object bitmap% fn type))
(lambda ()
(delete-file fn))))])
(unless (send bm ok?)