scx/scheme/xlib/font.scm

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