- completed get-gcontext-values and change/get-window-attributes to
pack/unpack all values correctly. - added copy-gcontext! and copy-gcontext - added comments.
This commit is contained in:
frese
parent
9478e09049
commit
fefeb73ccf
|
|
@ -106,6 +106,16 @@ s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) {
|
|||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto,
|
||||
s48_value attrs) {
|
||||
unsigned long mask = 0;
|
||||
mask = S48_SYMBOL_P(attrs) ? Symbol_To_Bit(attrs, Gcontext_Values_Syms) :
|
||||
Symbols_To_Bits(attrs, Gcontext_Values_Syms);
|
||||
XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xfrom),
|
||||
mask, SCX_EXTRACT_GCONTEXT(Xto));
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
s48_value scx_Free_Gc(s48_value Xgcontext, s48_value Xdisplay) {
|
||||
XFreeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext));
|
||||
return S48_UNSPECIFIC;
|
||||
|
|
@ -241,6 +251,7 @@ void scx_init_gcontext(void) {
|
|||
S48_EXPORT_FUNCTION(scx_Create_Gc);
|
||||
S48_EXPORT_FUNCTION(scx_Free_Gc);
|
||||
S48_EXPORT_FUNCTION(scx_Copy_Gc);
|
||||
S48_EXPORT_FUNCTION(scx_Copy_Gc_To_Gc);
|
||||
S48_EXPORT_FUNCTION(scx_Get_Gc_Values);
|
||||
S48_EXPORT_FUNCTION(scx_Change_Gc);
|
||||
S48_EXPORT_FUNCTION(scx_Set_Gcontext_Dashlist);
|
||||
|
|
|
|||
|
|
@ -1,4 +1,8 @@
|
|||
;; ...
|
||||
;; create-gcontext returns a newly create graphic context for the
|
||||
;; specified drawable (a window or a pixmap). Optional arguments are
|
||||
;; all attributes that can be set by the set-gcontext-xyz! functions
|
||||
;; below. They can be specified by name: 'function 'xor. Or the last
|
||||
;; argument can be an alist of such mappings. See XCreateGC.
|
||||
|
||||
(define (create-gcontext drawable . args)
|
||||
(let ((alist (named-args->alist args)))
|
||||
|
|
@ -20,7 +24,8 @@
|
|||
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist)
|
||||
"scx_Create_Gc")
|
||||
|
||||
;; ...
|
||||
;; copy-gcontext returns a newly create duplicate of the given
|
||||
;; gcontext, and assigns it to the specified drawable. See XCopyGC.
|
||||
|
||||
(define (copy-gcontext gcontext drawable)
|
||||
(let* ((new-gcontext (create-gcontext 'drawable drawable))
|
||||
|
|
@ -33,23 +38,53 @@
|
|||
(import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
|
||||
"scx_Copy_Gc")
|
||||
|
||||
;; ...
|
||||
;; copy-gcontext! copies the specified attributes from gc-from to
|
||||
;; gc-to. The attributes have to be a list of the names in the
|
||||
;; set-gcontext-*! functions. If that argument is not specified, then
|
||||
;; all atributes are copied. See XCopyGC.
|
||||
|
||||
(define (copy-gcontext! gc-from gc-to . attributes)
|
||||
(let ((attributes (if (null? attributes)
|
||||
'all
|
||||
(car attributes))))
|
||||
(%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
|
||||
(gcontext-Xgcontext gc-from)
|
||||
(gcontext-Xgcontext gc-to)
|
||||
attributes)))
|
||||
|
||||
(import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs)
|
||||
"scx_Copy_Gc_To_Gc")
|
||||
|
||||
;; get-gontext-values returns an alist of all attributes for the
|
||||
;; specified graphic context. See the gcontext-xyz functions
|
||||
;; below. See XGetGCValues.
|
||||
|
||||
(define (get-gcontext-values gcontext)
|
||||
(let ((Xgcontext (gcontext-Xgcontext gcontext))
|
||||
(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
|
||||
(let* ((Xgcontext (gcontext-Xgcontext gcontext))
|
||||
(display (gcontext-display gcontext))
|
||||
(Xdisplay (display-Xdisplay display)))
|
||||
(let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
|
||||
(if (not vals)
|
||||
(error "cannot get gcontext values." gcontext)
|
||||
(let*
|
||||
((mod-vals (begin
|
||||
(vector-set! vals 1 ;; plane-mask
|
||||
(make-pixel (vector-ref vals 1)))
|
||||
(vector-set! vals 2 ;; foreground
|
||||
(make-pixel (vector-ref vals 2)))
|
||||
(vector-set! vals 3 ;; background
|
||||
(make-pixel (vector-ref vals 3)))
|
||||
;; TODO: tile, stipple, font ...??
|
||||
((pack (lambda (i fun)
|
||||
(vector-set! vals i (fun (vector-ref vals i)))))
|
||||
(make-pixmap* (lambda (Xpixmap)
|
||||
(make-pixmap Xpixmap display #f)))
|
||||
(make-font* (lambda (Xfont)
|
||||
; this might not work properly, see Xlib Programming
|
||||
; Manual chapter 5.12
|
||||
(make-font #f Xfont #f display #t)))
|
||||
(make-pixel* (lambda (Xpixel)
|
||||
(make-pixel Xpixel #f #f)))
|
||||
(mod-vals (begin
|
||||
(pack 1 make-pixel*) ;; plane-mask
|
||||
(pack 2 make-pixel*) ;; foreground
|
||||
(pack 3 make-pixel*) ;; background
|
||||
(pack 11 make-pixmap*) ;; tile
|
||||
(pack 12 make-pixmap*) ;; stipple
|
||||
(pack 15 make-font*) ;; font
|
||||
(pack 20 make-pixmap*) ;; clip-mask
|
||||
vals))
|
||||
(alist
|
||||
(map cons
|
||||
|
|
@ -64,8 +99,6 @@
|
|||
(import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
|
||||
"scx_Get_Gc_Values")
|
||||
|
||||
;;...
|
||||
|
||||
(define (make-gcontext-getter name)
|
||||
(lambda (gcontext)
|
||||
(cdr (assq name (get-gcontext-values gcontext)))))
|
||||
|
|
@ -94,7 +127,21 @@
|
|||
(define gcontext-dash-offset (make-gcontext-getter 'dash-offset))
|
||||
(define gcontext-dashes (make-gcontext-getter 'dashes))
|
||||
|
||||
;; ...
|
||||
;; Alternative definition of gcontext-font. See XGcontextFromGC
|
||||
;
|
||||
;(define (gcontext-font gcontext)
|
||||
; (let* ((display (gcontext-display gcontext))
|
||||
; (Xfontstruct (%gcontext-font
|
||||
; (display-Xdisplay display)
|
||||
; (gcontext-Xgcontext gcontext))))
|
||||
; (make-font #f #f Xfontstruct display #f)))
|
||||
;
|
||||
;(import-lambda-definition %gcontext-font (Xdisplay Xgcontext)
|
||||
; "scx_GContext_Font") ; defined in font.c
|
||||
|
||||
;; change-gcontext sets some attributes of the specified graphic
|
||||
;; context. The format of the arguments is like for
|
||||
;; create-gcontext. See XChangeGC.
|
||||
|
||||
(define (change-gcontext gcontext . attrs)
|
||||
(let* ((alist (named-args->alist attrs))
|
||||
|
|
@ -157,7 +204,12 @@
|
|||
(import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
|
||||
"scx_Set_Gcontext_Dashlist")
|
||||
|
||||
;; ...
|
||||
;; set-gcontext-clip-rectangles changes the clip-mask in the specified
|
||||
;; graphic context to the list of rectangles and sets the clip
|
||||
;; origin. Each rectangle has to be a list (x y height width). The
|
||||
;; coordinates of the rectangles are interpreted relative to the clip
|
||||
;; origin specified by x and y. ordering can be one of 'unsorted,
|
||||
;; 'y-sorted, 'xy-sorted or 'xy-banded. See XSetClipRectangles.
|
||||
|
||||
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
|
||||
(%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext)
|
||||
|
|
@ -170,7 +222,12 @@
|
|||
y v ord)
|
||||
"scx_Set_Gcontext_Clip_Rectangles")
|
||||
|
||||
;; ...
|
||||
;; query-best-size/-cursor/-tile/-stipple function returns the best or
|
||||
;; closest size to the specified size. For 'cursor, this is the
|
||||
;; largest size that can be fully displayed on the screen specified by
|
||||
;; which_screen. For 'tile, this is the size that can be tiled
|
||||
;; fastest. For 'stipple, this is the size that can be stippled
|
||||
;; fastest. See XQueryBestSize.
|
||||
|
||||
(define (query-best-size display width height shape)
|
||||
(%query-best-size (display-Xdisplay display)
|
||||
|
|
@ -187,6 +244,3 @@
|
|||
|
||||
(define (query-best-stipple display width height)
|
||||
(query-best-size display width height 'stipple))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
((pixel? obj) (pixel-Xpixel obj))
|
||||
((pixmap? obj) (pixmap-Xpixmap obj))
|
||||
((colormap? obj) (colormap-Xcolormap obj))
|
||||
;; cursor...??
|
||||
((cursor? obj) (cursor-Xcursor obj))
|
||||
(else obj)))
|
||||
(map cdr change-win-attr-list))))
|
||||
(display (window-display parent))
|
||||
|
|
@ -101,7 +101,8 @@
|
|||
(let*
|
||||
((comp (lambda (i f) (vector-set! v i (f (vector-ref v i)))))
|
||||
(mod-v (begin
|
||||
(comp 13 make-pixel) ;; backing-pixel
|
||||
(comp 13 (lambda (Xpixel) ;; backing-pixel
|
||||
(make-pixel Xpixel #f #f)))
|
||||
(comp 7 (lambda (Xwin) ;; root
|
||||
(make-window Xwin (window-display window)
|
||||
#f)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue