179 lines
5.6 KiB
Scheme
179 lines
5.6 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-byte or 2-byte string,
|
|
;; represented by an integer, character, string or symbol, or event a
|
|
;; list of those types. the optional argument format is one of '1-byte
|
|
;; or '2-byte, which defaults to '1-byte. See XTextWidth.
|
|
|
|
(define (text-width font text . format)
|
|
(let ((format (if (null? format) '1-byte (car 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-...-function returns a number.
|
|
|
|
(define (extents-intern id)
|
|
(lambda (font text . format)
|
|
(display "-----------------\n")
|
|
(let ((format (if (null? format) '1-byte (car format))))
|
|
(%extents-text (font-Xfontstruct font)
|
|
(text->internal-text text format)
|
|
(get-format-id format)
|
|
id))))
|
|
|
|
(define extents-lbearing (extents-intern 0))
|
|
(define extents-rbearing (extents-intern 1))
|
|
(define extents-width (extents-intern 2))
|
|
(define extents-ascent (extents-intern 3))
|
|
(define extents-descent (extents-intern 4))
|
|
|
|
(import-lambda-definition %extents-text (Xfontstruct text format which)
|
|
"scx_Extents_Text")
|
|
|
|
;; draw-image-text draws a text on the gcontext at the specified
|
|
;; position. text is an integer, character, string or symbol, or even
|
|
;; a list of these types. format is '1-byte or '2-byte. '1-byte is the
|
|
;; default value. See XDrawImageString.
|
|
|
|
(define (draw-image-text drawable gcontext x y text . format)
|
|
(let ((format (if (null? format) '1-byte (car 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")
|
|
|
|
;; draw-poly-test is a more complex function for text drawing. text
|
|
;; has the following format:
|
|
;; <text> ::= <text-spec> | ( <text-spec>+ )
|
|
;; <text-spec> ::= <integer> | <char> | <string> | <symbol> | <font>
|
|
;; | (null . <delta>) | (<font> . <delta>)
|
|
;; <delta> ::= <integer>
|
|
;; so for example a text argument of
|
|
;; (list font-1 "Hello" (cons font-2 5) "World")
|
|
;; should draw Hello in font-1 and World in font-2 with a
|
|
;; character-spacing of 5.
|
|
;; the optional format argument is one of '1-byte or '2-byte and
|
|
;; defaults to '1-byte.
|
|
|
|
(define (draw-poly-text drawable gcontext x y text . format)
|
|
(let* ((format (if (null? format) '1-byte (car format)))
|
|
(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))
|
|
0)
|
|
(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")
|