changed the text-representation from vectors to lists, added delta
statements, changed the internal processing and abstractions.
This commit is contained in:
frese
parent
875610bc46
commit
5e0439da94
|
|
@ -2,6 +2,7 @@
|
|||
;; creation date : 16/07/2001
|
||||
;; last change : 19/07/2001
|
||||
|
||||
; --- Dimension-Predicates
|
||||
|
||||
(define (1-byte? int)
|
||||
(and (< 0 int) (> 255 int)))
|
||||
|
|
@ -9,50 +10,91 @@
|
|||
(define (2-byte? int)
|
||||
(and (< 0 int) (> 65535 int)))
|
||||
|
||||
; --- format is a number: 1 or 2. Make sure to call "change-format" before
|
||||
; useing this function!
|
||||
; --- verify-format checks wheather the text-vec elements are between correct
|
||||
; dimensions.
|
||||
|
||||
(define (vec-format? text-vec format)
|
||||
(let ((len (vector-length text-vec))
|
||||
(pred (cond ((and (number? format) (= 1 format))
|
||||
1-byte?)
|
||||
((and (number? format) (= 2 format))
|
||||
2-byte?)
|
||||
(else (error "Wrong format-type" vec-format?)))))
|
||||
(let loop ((i 0))
|
||||
(if (= i len)
|
||||
#t
|
||||
(if (pred (vector-ref text-vec i))
|
||||
(loop (+ i 1))
|
||||
#f)))))
|
||||
(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 (change-format format)
|
||||
(cond ((symbol? format)
|
||||
(cond ((eq? format '1-byte) 1)
|
||||
((eq? format '2-byte) 2)
|
||||
(else (error "Wrong format-type" change-format))))
|
||||
((number? format)
|
||||
(if (or (= 1 format) (= 2 format))
|
||||
format
|
||||
(error "Wrong format-type" change-format)))
|
||||
(else "Wrong format-type" change-format)))
|
||||
|
||||
(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 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)
|
||||
(let ((int-format (change-format format)))
|
||||
(if (vec-format? text format)
|
||||
(%text-width (font-Xfontstruct font) text int-format)
|
||||
(error "Wrong format for text"))))
|
||||
|
||||
(%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 an number.
|
||||
; --- Each extents-...-functions returns a number.
|
||||
|
||||
(define (extents-lbearing font text format)
|
||||
(extents-intern font text format 0))
|
||||
|
|
@ -75,96 +117,55 @@
|
|||
|
||||
|
||||
(define (extents-intern font text format which?)
|
||||
(let ((int-format (change-format format)))
|
||||
(if (vec-format? text int-format)
|
||||
(%extents (font-Xfontstruct font)
|
||||
text int-format which?)
|
||||
(error "Wrong format for text!"))))
|
||||
(%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 get's a mixed vector (text) with integer and
|
||||
; font-type inside.
|
||||
; --- 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)
|
||||
(let ((int-format (change-format format)))
|
||||
(if (vec-format? text int-format)
|
||||
(%draw-image-text (display-Xdisplay (drawable-display drawable))
|
||||
(drawable-Xobject drawable)
|
||||
(gcontext-Xgcontext gcontext)
|
||||
x y text int-format)
|
||||
(error "Wrong format for text!"))))
|
||||
(%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 Vector of font-object and chars.
|
||||
; --- text is a list of font-object and chars.
|
||||
|
||||
(define (draw-poly-text drawable gcontext x y text format)
|
||||
(let ((vec-text (transform-text text))
|
||||
(int-format (change-format format)))
|
||||
(if (check-format vec-text int-format)
|
||||
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
|
||||
(drawable-Xobject drawable) (gcontext-Xgcontext gcontext)
|
||||
x y vec-text int-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 format)
|
||||
x y text twobyte)
|
||||
"scx_Draw_Poly_Text")
|
||||
|
||||
(define (check-format (trans-text int-format))
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(for-each (lambda (obj)
|
||||
(if (and (vector? obj)
|
||||
(not (vec-format? obj int-format)))
|
||||
(return #f)))
|
||||
(vector->list trans-text))
|
||||
#t)))
|
||||
|
||||
|
||||
; --- Extracts the Xfont from the scheme48-font-record and makes vectors
|
||||
; from formerly integer vector entries...
|
||||
; [13 24 35 font 3 5 34] -> [[13 24 35] Xfont [3 5 34]]
|
||||
|
||||
(define (transform-text text)
|
||||
(let ((len (vector-length text)))
|
||||
(let loop ((i 0)
|
||||
(res '())
|
||||
(tmp '()))
|
||||
(if (= i len)
|
||||
(if (not (null? tmp))
|
||||
(list->vector (append res (list (list->vector tmp))))
|
||||
(list->vector res))
|
||||
(let ((item (vector-ref text i)))
|
||||
(if (font? item)
|
||||
(if (not (null? tmp))
|
||||
(loop (+ i 1)
|
||||
(append res (list (list->vector tmp))
|
||||
(list (font-Xfont item)))
|
||||
'())
|
||||
(loop (+ i 1)
|
||||
(append res (list font-Xfont item))
|
||||
'()))
|
||||
(loop (+ i 1)
|
||||
res
|
||||
(append tmp (list item)))))))))
|
||||
|
||||
|
||||
|
||||
; --- Translates a string to it's representation (as a vector of int)
|
||||
; for the other text proedures like text-width, ... .
|
||||
; The format is '1-byte.
|
||||
|
||||
(define (translate-text string)
|
||||
(let* ((len (string-length string))
|
||||
(res-vec (make-vector len)))
|
||||
(let loop ((i 0))
|
||||
(if (= i len)
|
||||
res-vec
|
||||
(begin
|
||||
(vector-set! res-vec i (char->integer (string-ref string i)))
|
||||
(loop (+ i 1)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue