93 lines
2.6 KiB
Scheme
93 lines
2.6 KiB
Scheme
|
; Access to the xpm library
|
||
|
|
|
||
|
|
(define-enumerated-type xpm-attribute :xpm-attribute
|
||
|
|
xpm-attribute?
|
||
|
|
xpm-attributes
|
||
|
|
xpm-attribute-name
|
||
|
|
xpm-attribute-index
|
||
|
|
(visual colormap depth color-symbols return-pixels exact-colors
|
||
|
|
;closeness rgb-closeness
|
||
|
|
return-alloc-pixels alloc-close-colors
|
||
|
|
bitmap-format
|
||
|
|
))
|
||
|
|
|
||
|
|
(define (name->string obj)
|
||
|
|
(if (symbol? obj)
|
||
|
|
(symbol->string obj)
|
||
|
|
obj))
|
||
|
|
|
||
|
|
(define xpm-attribute-alist->vector
|
||
|
|
(make-enum-alist->vector
|
||
|
|
xpm-attributes xpm-attribute-index
|
||
|
|
(lambda (i)
|
||
|
|
(case i
|
||
|
|
((0) visual-Xvisual)
|
||
|
|
((1) colormap-Xcolormap)
|
||
|
|
((2) (lambda (x) x))
|
||
|
|
((3) (lambda (color-symbols)
|
||
|
|
(list->vector
|
||
|
|
(map (lambda (mapping)
|
||
|
|
(list->vector
|
||
|
|
(list (name->string (car mapping))
|
||
|
|
(name->string (cadr mapping))
|
||
|
|
(pixel-Xpixel (caddr mapping)))))
|
||
|
|
color-symbols))))
|
||
|
|
((4 6) (lambda (x) x))
|
||
|
|
((5 7) (lambda (x)
|
||
|
|
(if x 1 0)))
|
||
|
|
((8) (lambda (bitmap-format)
|
||
|
|
(case bitmap-format
|
||
|
|
((z-pixmap) 0)
|
||
|
|
((xy-bitmap) 1)
|
||
|
|
(else (error "illegal bitmap format" bitmap-format)))))
|
||
|
|
))))
|
||
|
|
|
||
|
|
(define (make-result display vec)
|
||
|
|
(vector-set! vec 0 (make-pixmap (vector-ref vec 0)
|
||
|
|
display #t))
|
||
|
|
(vector-set! vec 3 (make-pixmap (vector-ref vec 3)
|
||
|
|
display #t))
|
||
|
|
(vector->list vec))
|
||
|
|
|
||
|
|
(define (create-pixmap-from-data drawable data xpm-attribute-alist)
|
||
|
|
(let ((r (%create-pixmap-from-data
|
||
|
|
(display-Xdisplay (drawable-display drawable))
|
||
|
|
(drawable-Xobject drawable)
|
||
|
|
data
|
||
|
|
(xpm-attribute-alist->vector xpm-attribute-alist))))
|
||
|
|
(case r
|
||
|
|
((0) (error "Not enough memory!"))
|
||
|
|
((1) (error "Invalid XPM-File data." data))
|
||
|
|
(else
|
||
|
|
(make-result (drawable-display drawable) r)))))
|
||
|
|
|
||
|
|
;-> (pixmap (width . height) (x-hot . y-hot) shape-mask)
|
||
|
|
|
||
|
|
(import-lambda-definition %create-pixmap-from-data
|
||
|
|
(Xdisplay Xdrawable data attribute-vector)
|
||
|
|
"scx_Create_Pixmap_From_Data")
|
||
|
|
|
||
|
|
;(define (create-data-from-pixmap ...))
|
||
|
|
|
||
|
|
(define (read-file-to-pixmap drawable filename xpm-attribute-alist)
|
||
|
|
(let ((r (%read-file-to-pixmap
|
||
|
|
(display-Xdisplay (drawable-display drawable))
|
||
|
|
(drawable-Xobject drawable)
|
||
|
|
filename
|
||
|
|
(xpm-attribute-alist->vector xpm-attribute-alist))))
|
||
|
|
(case r
|
||
|
|
((0) (error "Not enough memory!"))
|
||
|
|
((1) (error "Invalid XPM-File data." filename))
|
||
|
|
((2) (error "Open failed." filename))
|
||
|
|
(else (make-result (drawable-display drawable) r)))))
|
||
|
|
|
||
|
|
;-> (pixmap (width . height) (x-hot . y-hot) shape-mask)
|
||
|
|
|
||
|
|
|
||
|
|
(import-lambda-definition %read-file-to-pixmap
|
||
|
|
(Xdisplay Xdrawable filename attribute-vector)
|
||
|
|
"scx_Read_File_To_Pixmap")
|
||
|
|
|
||
|
|
|
||
|
|
;(define (write-file-from-pixmap ...))
|