first implementation.
This commit is contained in:
frese
parent
9a815a9864
commit
736a828fbe
|
|
@ -0,0 +1,77 @@
|
|||
(define-record-type font :font
|
||||
(really-make-font name Xfont Xfontstruct display)
|
||||
font?
|
||||
(name font-name font-set-name!)
|
||||
(Xfont font-Xfont font-set-Xfont!)
|
||||
(Xfontstruct font-Xfontstruct font-set-Xfontstruct!)
|
||||
(display font-display font-set-display!))
|
||||
|
||||
;; creates a font object. name can be #f. if Xfont is #f then it is obtained
|
||||
;; from the Xfontstruct.
|
||||
|
||||
(define (make-font name Xfont Xfontstruct display)
|
||||
(let ((maybe-font (font-list-find Xfontstruct)))
|
||||
(if maybe-font
|
||||
maybe-font
|
||||
(let* ((Xfont (if Xfont Xfont
|
||||
(%Get_Xfont Xfontstruct)))
|
||||
(font (really-make-font name Xfont Xfontstruct display)))
|
||||
(add-finalizer! font unload-font)
|
||||
(font-list-set! Xfontstruct font)
|
||||
font))))
|
||||
|
||||
;; load-font loads a font by its name. See XLoadQueryFont.
|
||||
|
||||
(define (load-font display font-name)
|
||||
(let ((Xfontstruct (%load-font (display-Xdisplay display)
|
||||
(if (symbol? font-name)
|
||||
(symbol->string font-name)
|
||||
font-name))))
|
||||
(make-font font-name #f Xfontstruct display)))
|
||||
|
||||
(import-lambda-definition %load-font (Xdisplay font_name)
|
||||
"Load_Font")
|
||||
|
||||
;; for compatibility with Elk:
|
||||
|
||||
(define open-font load-font)
|
||||
|
||||
;; unload-font unloads a font. This is also automatically called on
|
||||
;; garbage collection. See XUnloadFont.
|
||||
|
||||
(define (unload-font font)
|
||||
(let ((Xfontstruct (font-Xfontstruct font))
|
||||
(Xdisplay (display-Xdisplay (font-display font))))
|
||||
(if (integer? Xfontstruct)
|
||||
(%free-font Xdisplay Xfontstruct))
|
||||
(font-set-Xfontstruct! font 'already-freed)
|
||||
(font-set-Xfont! font 'already-freed)
|
||||
(font-list-delete! Xfont)))
|
||||
|
||||
;; for compatibility with Elk:
|
||||
(define close-font unload-font)
|
||||
|
||||
;; %free-font frees the Xfontstruct and also deletes the association between
|
||||
;; the Xfont (the resource id) and the specified font. See XFreeFont.
|
||||
;; Elk uses only XUnloadFont, but then the XFontStruct is not freed ??
|
||||
|
||||
(import-lambda-definition %free-font (Xdisplay Xfontstruct)
|
||||
"Free_Font")
|
||||
|
||||
;; All font records need to be saved in a weak-list, to have only one record
|
||||
;; for the same font in the heap.
|
||||
|
||||
(define *weak-font-list* (make-integer-table))
|
||||
|
||||
(define (font-list-find Xfont)
|
||||
(let ((r (table-ref *weak-font-list* Xfont)))
|
||||
(if r
|
||||
(weak-pointer-ref r)
|
||||
r)))
|
||||
|
||||
(define (font-list-set! Xfont font)
|
||||
(let ((p (make-weak-pointer font)))
|
||||
(table-set! *weak-font-list* Xfont p)))
|
||||
|
||||
(define (font-list-delete! Xfont)
|
||||
(table-set! *weak-font-list* Xfont #f))
|
||||
|
|
@ -0,0 +1,185 @@
|
|||
(define (gcontext-font gcontext)
|
||||
(let* ((display (gcontext-display gcontext))
|
||||
(Xfontstruct (%gcontext-font
|
||||
(display-Xdisplay display)
|
||||
(gcontext-Xgcontext gcontext))))
|
||||
(make-font #f #f Xfontstruct display)))
|
||||
|
||||
(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))
|
||||
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))
|
||||
Loading…
Reference in New Issue