172 lines
4.8 KiB
Scheme
172 lines
4.8 KiB
Scheme
;; author -> Norbert Freudemann
|
|
;; creation date : 16/07/2001
|
|
;; last change : 19/07/2001
|
|
|
|
; --- Dimension-Predicates
|
|
|
|
(define (1-byte? int)
|
|
(and (< 0 int) (> 255 int)))
|
|
|
|
(define (2-byte? int)
|
|
(and (< 0 int) (> 65535 int)))
|
|
|
|
; --- verify-format checks wheather the text-vec elements are between correct
|
|
; dimensions.
|
|
|
|
(define (verify-format text format)
|
|
(let ((pred (if (eq? format '1-byte)
|
|
1-byte?
|
|
2-byte?)))
|
|
(let loop ((t text))
|
|
(cond
|
|
((null? t) #f)
|
|
((pred (car t)) (loop (cdr t)))
|
|
(else (error "text doesnt' match format" text format))))))
|
|
|
|
; --- Makes a number (1 or 2) from the format-symbols '1-byte or '2-byte
|
|
|
|
(define (get-format-id format)
|
|
(cond ((eq? format '1-byte) 0)
|
|
((eq? format '2-byte) 1)
|
|
(else (error "Unknown format specifier" format))))
|
|
|
|
; --- mixed-text->pure-text converts a list of integers, chars, symbols and
|
|
; strings into a long list of integers (= the characters)
|
|
|
|
(define (mixed-text->pure-text list)
|
|
(if (not (list? list))
|
|
(mixed-text->pure-text (cons list '()))
|
|
(let loop ((list list)
|
|
(rev-list '()))
|
|
(if (null? list)
|
|
(reverse rev-list)
|
|
(loop (cdr list)
|
|
(let loop2 ((e (car list)))
|
|
(cond
|
|
((integer? e) (cons e rev-list))
|
|
((char? e) (cons (char->ascii e) rev-list))
|
|
((symbol? e) (loop2 (symbol->string e)))
|
|
((string? e)
|
|
(append (reverse
|
|
(mixed-text->pure-text (string->list e)))
|
|
rev-list))
|
|
(else (error "wrong element in text list" list e)))))))))
|
|
|
|
; --- separate-fonts converts a list of mixed types (including fonts) like this:
|
|
; (13 "abc" font 'abc) -> ((13 "abc") font ('abc)) or
|
|
; "abc" -> ("abc")
|
|
|
|
(define (separate-fonts lst)
|
|
(cond
|
|
((null? lst) lst)
|
|
;; a single text-spec
|
|
((not (list? lst)) (list lst))
|
|
;; a font-spec
|
|
((or (font? (car lst))
|
|
(pair? (car lst)))
|
|
(cons (car lst) (separate-fonts (cdr lst))))
|
|
(else (let ((r (separate-fonts (cdr lst))))
|
|
(cond
|
|
;; first element is a font-spec:
|
|
((or (null? r) (font? (car r)) (pair? (car r)))
|
|
(cons (list (car lst)) r))
|
|
;; first element is a text-spec, so add this one
|
|
(else
|
|
(cons (cons (car lst) (car r))
|
|
(cdr r))))))))
|
|
|
|
; --- text->internal-text
|
|
|
|
(define (text->internal-text text format)
|
|
(let ((t (mixed-text->pure-text text)))
|
|
(verify-format t format)
|
|
(list->vector t)))
|
|
|
|
|
|
; --- text-width returns the widht of the given 1- or 2-byte char-string,
|
|
; represented by a vector of integers.
|
|
|
|
(define (text-width font text format)
|
|
(%text-width (font-Xfontstruct font)
|
|
(text->internal-text text format)
|
|
(get-format-id format)))
|
|
|
|
(import-lambda-definition %text-width (Xfontstruct text format)
|
|
"scx_Text_Width")
|
|
|
|
; --- Each extents-...-functions returns a number.
|
|
|
|
(define (extents-lbearing font text format)
|
|
(extents-intern font text format 0))
|
|
|
|
|
|
(define (extents-rbearing font text format)
|
|
(extents-intern font text format 1))
|
|
|
|
|
|
(define (extents-width font text format)
|
|
(extents-intern font text format 2))
|
|
|
|
|
|
(define (extents-ascent font text format)
|
|
(extents-intern font text format 3))
|
|
|
|
|
|
(define (extents-descent font text format)
|
|
(extents-intern font text format 4))
|
|
|
|
|
|
(define (extents-intern font text format which?)
|
|
(%extents (font-Xfontstruct font)
|
|
(text->internal-text text format)
|
|
(get-format-id format)
|
|
which?))
|
|
|
|
(import-lambda-definition %extents-text (Xfontstruct text format which)
|
|
"scx_Extents_Text")
|
|
|
|
; --- draw-image-text draws the text. text is a integer, character, string
|
|
; or symbol, or event a list of these types.
|
|
|
|
(define (draw-image-text drawable gcontext x y text format)
|
|
(%draw-image-text (display-Xdisplay (drawable-display drawable))
|
|
(drawable-Xobject drawable)
|
|
(gcontext-Xgcontext gcontext)
|
|
x y
|
|
(text->internal-text text format)
|
|
(eq? format '2-byte)))
|
|
|
|
|
|
(import-lambda-definition %draw-image-text (Xdisplay Xdrawable Xgcontext
|
|
x y text format)
|
|
"scx_Draw_Image_Text")
|
|
|
|
; --- text is a list of font-object and chars.
|
|
|
|
(define (draw-poly-text drawable gcontext x y text format)
|
|
(let ((text-spec
|
|
(map (lambda (text-or-font)
|
|
(cond
|
|
((font? text-or-font)
|
|
(cons (font-Xfont text-or-font)
|
|
0))
|
|
((and (pair? text-or-font)
|
|
(not (list? text-or-font)))
|
|
(cons (if (font? (car text-or-font))
|
|
(font-Xfont (car text-or-font))
|
|
'none)
|
|
(cdr text-or-font)))
|
|
(else (text->internal-text text-or-font
|
|
format))))
|
|
(separate-fonts text))))
|
|
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
|
|
(drawable-Xobject drawable)
|
|
(gcontext-Xgcontext gcontext)
|
|
x y
|
|
(list->vector text-spec)
|
|
(eq? format '2-byte))))
|
|
|
|
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
|
|
x y text twobyte)
|
|
"scx_Draw_Poly_Text")
|