scx/scheme/xlib/font.scm

(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)
  "GContext_Font")

(define (list-font-names display pattern)
  (%list-font-names (display-Xdisplay)
		    (if (symbol? pattern)
			(symbol->string pattern)
			pattern)))

(import-lambda-definition %list-font-names (Xdisplay pattern)
  "List_Font_Names")

(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)
  "List_Fonts")

(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)
  "Font_Properties")

(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)
  "Font_Property")

(define (font-path display)
  (vector->list (%font-path (display-Xdisplay display))))

(import-lambda-definition %font-path (Xdisplay)
  "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)
  "Set_Font_Path")

;; ............

(define (font-info font)
  (%font-info (font-Xfontstruct font)))

(import-lambda-definition %font-info (Xfontstruct)
  "Font_Info")

(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))

;; ..................

(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)
  "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
				     (integer->string min)
				     " and "
				     (integer->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))