changed the text-representation from vectors to lists, added delta

statements, changed the internal processing and abstractions.
This commit is contained in:
frese 2001-08-21 15:01:38 +00:00
parent 875610bc46
commit 5e0439da94
1 changed files with 109 additions and 108 deletions

View File

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