202 lines
6.2 KiB
Scheme
202 lines
6.2 KiB
Scheme
;; list-font-names returns the names of all available fonts that match
|
|
;; the pattern. pattern has to be a string. See XListFonts.
|
|
|
|
(define (list-font-names display pattern)
|
|
(vector->list (%list-font-names (display-Xdisplay display)
|
|
(if (symbol? pattern)
|
|
(symbol->string pattern)
|
|
pattern))))
|
|
|
|
(import-lambda-definition %list-font-names (Xdisplay pattern)
|
|
"scx_List_Font_Names")
|
|
|
|
;; list-fonts returns all fonts that match the pattern. pattern has to
|
|
;; be string. See XListFonts.
|
|
|
|
(define (list-fonts display pattern)
|
|
(let ((v (%list-fonts (display-Xdisplay display)
|
|
(if (symbol? pattern)
|
|
(symbol->string pattern)
|
|
pattern))))
|
|
(vector->list (vector-map! (lambda (name-Xfontstruct)
|
|
(make-font (car name-Xfontstruct)
|
|
#f
|
|
(cdr name-Xfontstruct)
|
|
display
|
|
#t))
|
|
v))))
|
|
|
|
(import-lambda-definition %list-fonts (Xdisplay pattern)
|
|
"scx_List_Fonts")
|
|
|
|
;; font-properties returns an alist that maps atoms to the
|
|
;; corresponding values. See XFontStruct.
|
|
|
|
(define (font-properties font)
|
|
(let ((v (%font-properties (font-Xfontstruct font))))
|
|
(vector->list (vector-map! (lambda (XAtom-Val)
|
|
(cons (make-atom (car XAtom-Val))
|
|
(cdr XAtom-Val)))
|
|
v))))
|
|
|
|
(import-lambda-definition %font-properties (Xfontstruct)
|
|
"scx_Font_Properties")
|
|
|
|
;; font-property returns the value of specified
|
|
;; property. property-name has to be string or a symbol specifying an
|
|
;; atom. See XGetFontProperty.
|
|
|
|
(define (font-property font property-name)
|
|
(let ((atom (intern-atom (font-display font)
|
|
property-name)))
|
|
(%font-property (font-Xfontstruct font)
|
|
(atom-Xatom atom))))
|
|
|
|
(import-lambda-definition %font-property (Xfontstruct Xatom)
|
|
"scx_Font_Property")
|
|
|
|
;; font-path returns the (implementation and file system dependand)
|
|
;; path to the font files. See XGetFontPath, and XSetFontPath.
|
|
|
|
(define (font-path display)
|
|
(vector->list (%font-path (display-Xdisplay display))))
|
|
|
|
(import-lambda-definition %font-path (Xdisplay)
|
|
"scx_Font_Path")
|
|
|
|
(define (set-font-path! display path)
|
|
(%set-font-path! (display-Xdisplay display)
|
|
(map (lambda (s)
|
|
(if (symbol? s)
|
|
(symbol->string s)
|
|
s))
|
|
(list->vector path))))
|
|
|
|
(import-lambda-definition %set-font-path! (Xdisplay path)
|
|
"scx_Set_Font_Path")
|
|
|
|
;; font-info returns a vector containing all information available for
|
|
;; the font. See XFontStruct.
|
|
|
|
(define (font-info font)
|
|
(let ((v (%font-info (font-Xfontstruct font))))
|
|
(vector-set! v 0 (integer->font-direction (vector-ref v 0)))
|
|
v))
|
|
|
|
(import-lambda-definition %font-info (Xfontstruct)
|
|
"scx_Font_Info")
|
|
|
|
(define (integer->font-direction i)
|
|
(case i
|
|
((0) 'left-to-right)
|
|
((1) 'right-to-left)
|
|
(else i)))
|
|
|
|
(define (font-info-getter num)
|
|
(lambda (font)
|
|
(vector-ref (font-info font)
|
|
num)))
|
|
|
|
(define font-direction (font-info-getter 0))
|
|
(define font-min-byte2 (font-info-getter 1))
|
|
(define font-max-byte2 (font-info-getter 2))
|
|
(define font-min-byte1 (font-info-getter 3))
|
|
(define font-max-byte1 (font-info-getter 4))
|
|
(define font-all-chars-exist? (font-info-getter 5))
|
|
(define font-default-char (font-info-getter 6))
|
|
(define font-ascent (font-info-getter 7))
|
|
(define font-descent (font-info-getter 8))
|
|
|
|
;; char-info returns a vector containing font-dependand character
|
|
;; information. See also min/max/char-* functions below. See XFontStruct.
|
|
|
|
(define (char-info font index)
|
|
(%char-info (font-Xfontstruct font)
|
|
(cond
|
|
((eq? index 'min) #f)
|
|
((eq? index 'max) #t)
|
|
(else (let ((i (if (char? index)
|
|
(char->integer index)
|
|
index)))
|
|
(calc-index font i))))))
|
|
|
|
(import-lambda-definition %char-info (Xfontstruct index)
|
|
"scx_Char_Info")
|
|
|
|
;; calc-index calculates the array-position in XFontStruct.per_char by giving
|
|
;; the character index which ranges between [font-min-byte2...font-max-byte2]
|
|
;; for one-byte fonts or for two-byte fonts the lower 8 bits must be between
|
|
;; [font-min-byte1...font-max-byte1] and the higher 8 bits must be between
|
|
;; [font-min-byte2...font-max-byte2]. An error is raised if the index does not
|
|
;; fit into these boundaries.
|
|
(define (calc-index font index)
|
|
(let ((min1 (font-min-byte1 font))
|
|
(max1 (font-max-byte1 font))
|
|
(min2 (font-min-byte2 font))
|
|
(max2 (font-max-byte2 font))
|
|
(check-bounds
|
|
(lambda (min max i s)
|
|
(if (or (< i min)
|
|
(> i max))
|
|
(error (string-append s
|
|
(number->string min)
|
|
" and "
|
|
(number->string max)
|
|
"; given")
|
|
index)))))
|
|
(if (and (= 0 min1) (= 0 max1))
|
|
;; two-byte font
|
|
(let ((b1 (bitwise-and index 255))
|
|
(b2 (bitwise-and (arithmetic-shift index -8) 255)))
|
|
(check-bounds min1 max1 b1
|
|
"expected an integer with lower 8 bits between ")
|
|
(check-bounds min2 max2 b2
|
|
"expected an integer with higher 8 bits between ")
|
|
(+ (* b1 (+ (- max2 min2) 1))
|
|
b2))
|
|
;; one-byte font
|
|
(begin
|
|
(check-bounds min2 max2 index
|
|
"expected an integer between ")
|
|
index))))
|
|
|
|
(define (char-info-getter num)
|
|
(lambda (font index)
|
|
(vector-ref (char-info font index)
|
|
num)))
|
|
|
|
(define char-rbearing (char-info-getter 0))
|
|
(define char-lbearing (char-info-getter 1))
|
|
(define char-width (char-info-getter 2))
|
|
(define char-ascent (char-info-getter 3))
|
|
(define char-descent (char-info-getter 4))
|
|
(define char-attributes (char-info-getter 5))
|
|
|
|
(define (max-char-info-getter num)
|
|
(lambda (font)
|
|
(vector-ref (char-info font 'max)
|
|
num)))
|
|
|
|
(define (max-char-info font)
|
|
(char-info font 'max))
|
|
(define max-char-rbearing (max-char-info-getter 0))
|
|
(define max-char-lbearing (max-char-info-getter 1))
|
|
(define max-char-width (max-char-info-getter 2))
|
|
(define max-char-ascent (max-char-info-getter 3))
|
|
(define max-char-descent (max-char-info-getter 4))
|
|
(define max-char-attributes (max-char-info-getter 5))
|
|
|
|
(define (min-char-info-getter num)
|
|
(lambda (font)
|
|
(vector-ref (char-info font 'min)
|
|
num)))
|
|
|
|
(define (min-char-info font)
|
|
(char-info font 'min))
|
|
(define min-char-rbearing (min-char-info-getter 0))
|
|
(define min-char-lbearing (min-char-info-getter 1))
|
|
(define min-char-width (min-char-info-getter 2))
|
|
(define min-char-ascent (min-char-info-getter 3))
|
|
(define min-char-descent (min-char-info-getter 4))
|
|
(define min-char-attributes (min-char-info-getter 5))
|