232 lines
8.7 KiB
Scheme
232 lines
8.7 KiB
Scheme
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
|
|
|
|
;; GC is a pointer to a C structure
|
|
;; GContext is the protocol ID
|
|
|
|
;; *** GC type *******************************************************
|
|
|
|
(define-record-type gc :gc
|
|
(make-gc cpointer)
|
|
gc?
|
|
(cpointer gc-cpointer))
|
|
|
|
(define-exported-binding "scx-gc" :gc)
|
|
|
|
;; *** GC values and types *******************************************
|
|
|
|
(define-enumerated-type gc-function :gc-function
|
|
gc-function? gc-functions gc-function-name gc-function-index
|
|
(clear and and-reverse copy and-inverted no-op xor or nor equiv
|
|
invert or-reverse copy-inverted or-inverted nand set))
|
|
|
|
(define-exported-binding "scx-gc-function" :gc-function)
|
|
(define-exported-binding "scx-gc-functions" gc-functions)
|
|
|
|
(define-enumerated-type line-style :line-style
|
|
line-style? line-styles line-style-name line-style-index
|
|
(solid on-off-dash double-dash))
|
|
|
|
(define-exported-binding "scx-line-style" :line-style)
|
|
(define-exported-binding "scx-line-styles" line-styles)
|
|
|
|
(define-enumerated-type cap-style :cap-style
|
|
cap-style? cap-styles cap-style-name cap-style-index
|
|
(not-last butt round projecting))
|
|
|
|
(define-exported-binding "scx-cap-style" :cap-style)
|
|
(define-exported-binding "scx-cap-styles" cap-styles)
|
|
|
|
(define-enumerated-type join-style :join-style
|
|
join-style? join-styles join-style-name join-style-index
|
|
(miter round bevel))
|
|
|
|
(define-exported-binding "scx-join-style" :join-style)
|
|
(define-exported-binding "scx-join-styles" join-styles)
|
|
|
|
(define-enumerated-type fill-style :fill-style
|
|
fill-style? fill-styles fill-style-name fill-style-index
|
|
(solid tiled stippled opaque-stippled))
|
|
|
|
(define-exported-binding "scx-fill-style" :fill-style)
|
|
(define-exported-binding "scx-fill-styles" fill-styles)
|
|
|
|
(define-enumerated-type fill-rule :fill-rule
|
|
fill-rule? fill-rules fill-rule-name fill-rule-index
|
|
(even-odd winding))
|
|
|
|
(define-exported-binding "scx-fill-rule" :fill-rule)
|
|
(define-exported-binding "scx-fill-rules" fill-rules)
|
|
|
|
(define-enumerated-type subwindow-mode :subwindow-mode
|
|
subwindow-mode? subwindow-modes subwindow-mode-name subwindow-mode-index
|
|
(clip-by-children include-inferiors))
|
|
|
|
(define-exported-binding "scx-subwindow-mode" :subwindow-mode)
|
|
(define-exported-binding "scx-subwindow-modes" subwindow-modes)
|
|
|
|
(define-enumerated-type arc-mode :arc-mode
|
|
arc-mode? arc-modes arc-mode-name arc-mode-index
|
|
(chord pie-slice))
|
|
|
|
(define-exported-binding "scx-arc-mode" :arc-mode)
|
|
(define-exported-binding "scx-arc-modes" arc-modes)
|
|
|
|
(define-enumerated-type gc-value :gc-value
|
|
gc-value?
|
|
gc-values
|
|
gc-value-name
|
|
gc-value-index
|
|
(function plane-mask foreground background line-width line-style cap-style
|
|
join-style fill-style fill-rule tile stipple ts-x-origin ts-y-origin
|
|
font subwindow-mode graphics-exposures clip-x-origin clip-y-origin
|
|
clip-mask dash-offset dashes arc-mode))
|
|
|
|
(define all-gc-values (vector->list gc-values))
|
|
|
|
(define-exported-binding "scx-gc-value" :gc-value)
|
|
(define-exported-binding "scx-gc-values" gc-values)
|
|
|
|
(define-syntax make-gc-value-alist
|
|
(syntax-rules
|
|
()
|
|
((make-gc-value-alist (attr arg) rest ...)
|
|
(cons (cons (gc-value attr) arg)
|
|
(make-gc-value-alist rest ...)))
|
|
((make-gc-value-alist)
|
|
'())))
|
|
|
|
(define-enum-set-type gc-value-set :gc-value-set
|
|
gc-value-set? make-gc-value-set
|
|
gc-value gc-value? gc-values gc-value-index)
|
|
|
|
(define-exported-binding "scx-gc-value-set" :gc-value-set)
|
|
|
|
;; *** create or free graphics contexts ******************************
|
|
|
|
(import-lambda-definition create-gc (display drawable gc-value-alist)
|
|
"scx_Create_Gc")
|
|
|
|
(import-lambda-definition copy-gc! (display srck dest mask)
|
|
"scx_Copy_Gc")
|
|
|
|
(define (copy-gc display drawable src)
|
|
(let ((gc (create-gc display drawable '())))
|
|
(copy-gc! display src all-gc-values gc)
|
|
gc))
|
|
|
|
(import-lambda-definition change-gc (display gc values)
|
|
"scx_Change_Gc")
|
|
|
|
(define (make-gc-setter name)
|
|
(lambda (display gc value)
|
|
(change-gc display gc (list (cons name value)))))
|
|
|
|
(define set-gc-function! (make-gc-setter (gc-value function)))
|
|
(define set-gc-plane-mask! (make-gc-setter (gc-value plane-mask)))
|
|
(define set-gc-foreground! (make-gc-setter (gc-value foreground)))
|
|
(define set-gc-background! (make-gc-setter (gc-value background)))
|
|
(define set-gc-line-width! (make-gc-setter (gc-value line-width)))
|
|
(define set-gc-line-style! (make-gc-setter (gc-value line-style)))
|
|
(define set-gc-cap-style! (make-gc-setter (gc-value cap-style)))
|
|
(define set-gc-join-style! (make-gc-setter (gc-value join-style)))
|
|
(define set-gc-fill-style! (make-gc-setter (gc-value fill-style)))
|
|
(define set-gc-fill-rule! (make-gc-setter (gc-value fill-rule)))
|
|
(define set-gc-arc-mode! (make-gc-setter (gc-value arc-mode)))
|
|
(define set-gc-tile! (make-gc-setter (gc-value tile)))
|
|
(define set-gc-stipple! (make-gc-setter (gc-value stipple)))
|
|
(define set-gc-ts-x-origin! (make-gc-setter (gc-value ts-x-origin)))
|
|
(define set-gc-ts-y-origin! (make-gc-setter (gc-value ts-y-origin)))
|
|
(define set-gc-font! (make-gc-setter (gc-value font)))
|
|
(define set-gc-subwindow-mode! (make-gc-setter (gc-value subwindow-mode)))
|
|
(define set-gc-graphics-exposures!
|
|
(make-gc-setter (gc-value graphics-exposures)))
|
|
(define set-gc-clip-x-origin! (make-gc-setter (gc-value clip-x-origin)))
|
|
(define set-gc-clip-y-origin! (make-gc-setter (gc-value clip-y-origin)))
|
|
(define set-gc-clip-mask! (make-gc-setter (gc-value clip-mask)))
|
|
(define set-gc-dash-offset! (make-gc-setter (gc-value dash-offset)))
|
|
(define set-gc-dashes! (make-gc-setter (gc-value dashes)))
|
|
|
|
(import-lambda-definition get-gc-values (display gc values)
|
|
"scx_Get_Gc_Values")
|
|
|
|
(define (make-gc-getter name)
|
|
(lambda (display gc)
|
|
(let ((values (get-gc-values display gc (list name))))
|
|
(and values (cdr (assq name values))))))
|
|
|
|
(define gc-gc-function (make-gc-getter (gc-value function)))
|
|
(define gc-plane-mask (make-gc-getter (gc-value plane-mask)))
|
|
(define gc-foreground (make-gc-getter (gc-value foreground)))
|
|
(define gc-background (make-gc-getter (gc-value background)))
|
|
(define gc-line-width (make-gc-getter (gc-value line-width)))
|
|
(define gc-line-style (make-gc-getter (gc-value line-style)))
|
|
(define gc-cap-style (make-gc-getter (gc-value cap-style)))
|
|
(define gc-join-style (make-gc-getter (gc-value join-style)))
|
|
(define gc-fill-style (make-gc-getter (gc-value fill-style)))
|
|
(define gc-fill-rule (make-gc-getter (gc-value fill-rule)))
|
|
(define gc-arc-mode (make-gc-getter (gc-value arc-mode)))
|
|
(define gc-tile (make-gc-getter (gc-value tile)))
|
|
(define gc-stipple (make-gc-getter (gc-value stipple)))
|
|
(define gc-ts-x-origin (make-gc-getter (gc-value ts-x-origin)))
|
|
(define gc-ts-y-origin (make-gc-getter (gc-value ts-y-origin)))
|
|
(define gc-font (make-gc-getter (gc-value font)))
|
|
(define gc-subwindow-mode (make-gc-getter (gc-value subwindow-mode)))
|
|
(define gc-graphics-exposures (make-gc-getter (gc-value graphics-exposures)))
|
|
(define gc-clip-x-origin (make-gc-getter (gc-value clip-x-origin)))
|
|
(define gc-clip-y-origin (make-gc-getter (gc-value clip-y-origin)))
|
|
(define gc-clip-mask (make-gc-getter (gc-value clip-mask)))
|
|
(define gc-dash-offset (make-gc-getter (gc-value dash-offset)))
|
|
(define gc-dashes (make-gc-getter (gc-value dashes)))
|
|
|
|
(import-lambda-definition free-gc (display gc)
|
|
"scx_Free_Gc")
|
|
|
|
(import-lambda-definition gcontext-from-gc (gc)
|
|
"scx_GContext_From_Gc")
|
|
|
|
;; *** GC convenience routines ***************************************
|
|
|
|
(define (set-line-attributes! display gc line-width line-style cap-style
|
|
join-style)
|
|
(change-gc display gc
|
|
(make-gc-value-alist (line-width line-width)
|
|
(line-style line-style)
|
|
(cap-style cap-style)
|
|
(join-style join-style))))
|
|
|
|
(import-lambda-definition set-dashes! (display gc dashoffset dashlist)
|
|
"scx_Set_Dashes")
|
|
|
|
(define (set-clip-origin display gc x-origin y-origin)
|
|
(change-gc display gc
|
|
(make-gc-value-alist (clip-x-origin x-origin)
|
|
(clip-y-origin y-origin))))
|
|
|
|
(define-enumerated-type rectangle-ordering :rectangle-ordering
|
|
rectangle-ordering? rectangle-orderings
|
|
rectangle-ordering-name rectangle-ordering-index
|
|
(unsorted y-sorted xy-sorted xy-banded))
|
|
|
|
(define-exported-binding "scx-rectangle-ordering" :rectangle-ordering)
|
|
(define-exported-binding "scx-rectangle-orderings" rectangle-orderings)
|
|
|
|
;; rectangles has to be list of (x y width height) lists.
|
|
(import-lambda-definition set-clip-rectangles!
|
|
(display gc x-origin y-origin rectangles ordering)
|
|
"scx_Set_Clip_Rectangles")
|
|
|
|
;; *** determine efficient sizes *************************************
|
|
|
|
;; returns a pair (width . height)
|
|
(import-lambda-definition %query-best-size (screen class width height)
|
|
"scx_Query_Best_Size")
|
|
|
|
(define (query-best-cursor screen width height)
|
|
(%query-best-size screen 0 width height))
|
|
|
|
(define (query-best-tile screen width height)
|
|
(%query-best-size screen 1 width height))
|
|
|
|
(define (query-best-stipple screen width height)
|
|
(%query-best-size screen 2 width height))
|