Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv3929/scheme/xlib
Modified Files:
color.scm colormap.scm
Log Message:
- removed direct calls to scx_Create_Color
- renamed save-color-cell to store-color
- added store-colors, copy-colormap-and-free,
respect. scx_Store_Colors, scx_Copy_Colormap
- renamed alloc-named-color to query/alloc-named-color
- added new alloc-named-color that can be used like alloc-color!
- changed my-floor definition (color.scm)
- added parse-color
- updated calls to make-pixel
Index: color.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/color.scm,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -r1.7 -r1.8
*** color.scm 2001/08/22 11:49:01 1.7
--- color.scm 2001/10/09 15:31:33 1.8
***************
*** 7,11 ****
(if (exact? v)
(floor v)
! (my-floor (inexact->exact v))))
(define (make-color r g b)
--- 7,11 ----
(if (exact? v)
(floor v)
! (floor (inexact->exact v))))
(define (make-color r g b)
Index: colormap.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap.scm,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -r1.8 -r1.9
*** colormap.scm 2001/09/20 14:41:01 1.8
--- colormap.scm 2001/10/09 15:31:33 1.9
***************
*** 9,13 ****
(display-Xdisplay (colormap-display colormap)))))
(if Xpixel
! (make-pixel Xpixel)
Xpixel)))
--- 9,13 ----
(display-Xdisplay (colormap-display colormap)))))
(if Xpixel
! (make-pixel Xpixel colormap #t)
Xpixel)))
***************
*** 15,24 ****
"scx_Alloc_Color")
! ;; alloc-named-color looks up the named color with respect to the screen that
! ;; is associated with the specified colormap. It returns both the exact
database
! ;; definition and the closest color supported by the screen (as a pair).
! ;; See XAllocNamedColor.
! (define (alloc-named-color colormap color-name)
(let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
(if (symbol? color-name)
--- 15,25 ----
"scx_Alloc_Color")
! ;; query/alloc-named-color looks up the named color with respect to
! ;; the screen that is associated with the specified colormap. It
! ;; returns the allocated pixel and both the exact database definition
! ;; and the closest color supported by the screen (as a list). See
! ;; XAllocNamedColor.
! (define (query/alloc-named-color colormap color-name)
(let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
(if (symbol? color-name)
***************
*** 28,32 ****
(colormap-display colormap)))))
(if Xres
! (list (make-pixel (car Xres))
(apply create-color (cadr Xres))
(apply create-color (caddr Xres)))
--- 29,33 ----
(colormap-display colormap)))))
(if Xres
! (list (make-pixel (car Xres) colormap #t)
(apply create-color (cadr Xres))
(apply create-color (caddr Xres)))
***************
*** 35,48 ****
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
"scx_Alloc_Named_Color")
-
-
- ; added by N. Freudemann
- ; swaped from utility.scm to this file.
! (define (parse-color colormap string)
! (%parse-color (display-Xdisplay (colormap-display colormap))
! (colormap-Xcolormap colormap)
! string))
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
--- 36,64 ----
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
"scx_Alloc_Named_Color")
! ;; alloc-named-color only allocates a named color and returns the
! ;; allocated pixel (as one might suppose). If the color does not
! ;; exists it returns #f.
+ (define (alloc-named-color colormap color-name)
+ (let ((c (parse-color colormap color-name)))
+ (if c
+ (alloc-color! colormap c)
+ #f)))
+
+ ;; parse-color looks up the string name of a color and returns the
+ ;; exact color value. See XParseColor. See lookup-color.
+
+ (define (parse-color colormap color-name)
+ (let ((res (%parse-color (display-Xdisplay (colormap-display colormap))
+ (colormap-Xcolormap colormap)
+ (if (symbol? color-name)
+ (symbol->string color-name)
+ color-name))))
+ (if res
+ (create-color (vector-ref res 0)
+ (vector-ref res 1)
+ (vector-ref res 2))
+ #f)))
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
***************
*** 79,83 ****
(if res
(cons (vector->list (car res))
! (map make-pixel
(vector->list (cdr res))))
res)))
--- 95,100 ----
(if res
(cons (vector->list (car res))
! (map (lambda (Xpixel)
! (make-pixel Xpixel colormap #t))
(vector->list (cdr res))))
res)))
***************
*** 87,91 ****
"scx_Alloc_Color_Cells")
! ;; The set-color-cell function uses XStoreColor(s) to set the content
;; of the color cell specified by pixel (a pixel is an index to a
;; colormap) to color. An optional parameter is a list of the symbols
--- 104,108 ----
"scx_Alloc_Color_Cells")
! ;; The store-color function uses XStoreColor(s) to set the content
;; of the color cell specified by pixel (a pixel is an index to a
;; colormap) to color. An optional parameter is a list of the symbols
***************
*** 94,98 ****
;; do-blue). See XStoreColors.
! (define (set-color-cell colormap pixel color . flags)
(%set-color-cell (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
--- 111,115 ----
;; do-blue). See XStoreColors.
! (define (store-color colormap pixel color . flags)
(%set-color-cell (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
***************
*** 104,106 ****
(import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
flags)
! "scx_Set_Color_Cell")
--- 121,164 ----
(import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
flags)
! "scx_Store_Color")
!
! ;; store-colors does the same as store-color, but for multiple
! ;; colorcells. The paramter cells must be a list of lists consisting
! ;; of 2 or 3 elements: a pixel, a color and an optional flags list
! ;; (see above).
!
! (define (store-colors colormap cells)
! (let ((cells (list->vector
! (map (lambda (p-c-f)
! (list->vector
! (list (pixel-Xpixel (car p-c-f))
! (color-Xcolor (cadr p-c-f))
! (if (null? (cddr p-c-f))
! '(do-red do-green do-blue)
! (caddr p-c-f)))))
! cells))))
! (%store-colors (display-Xdisplay (colormap-display colormap))
! (colormap-Xcolormap colormap)
! cells)))
!
! (import-lambda-definition %store-colors (Xdisplay Xcolormap cells)
! "scx_Store_Colors")
!
! ;; copy-colormap-and-free function creates a colormap of the same
! ;; visual type and for the same screen as the specified colormap and
! ;; returns the new colormap. It also moves all of the client's
! ;; existing allocation from the specified colormap to the new colormap
! ;; with their color values intact and their read-only or writable
! ;; characteristics intact and frees those entries in the specified
! ;; colormap. See XCopyColormapAndFree
!
! (define (copy-colormap-and-free colormap)
! (make-colormap (%copy-colormap-and-free
! (display-Xdisplay (colormap-display colormap))
! (colormap-Xcolormap colormap))
! (colormap-display colormap)
! #t))
!
! (import-lambda-definition %copy-colormap-and-free (Xdisplay Xcolormap)
! "scx_Copy_Colormap_And_Free")
!
|