Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv21193
Modified Files:
text.scm
Log Message:
changed the text-representation from vectors to lists, added delta
statements, changed the internal processing and abstractions.
Index: text.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/text.scm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** text.scm 2001/07/31 14:54:53 1.3
--- text.scm 2001/08/21 15:01:38 1.4
***************
*** 3,6 ****
--- 3,7 ----
;; last change : 19/07/2001
+ ; --- Dimension-Predicates
(define (1-byte? int)
***************
*** 10,43 ****
(and (< 0 int) (> 65535 int)))
! ; --- format is a number: 1 or 2. Make sure to call "change-format" before
! ; useing this function!
! (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)))))
; --- 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)))
!
; --- text-width returns the widht of the given 1- or 2-byte char-string,
--- 11,86 ----
(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 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,
***************
*** 45,57 ****
(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"))))
!
(import-lambda-definition %text-width (Xfontstruct text format)
"scx_Text_Width")
! ; --- Each extents-...-functions returns an number.
(define (extents-lbearing font text format)
--- 88,99 ----
(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)
***************
*** 76,99 ****
(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!"))))
(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.
(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!"))))
--- 118,139 ----
(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)))
***************
*** 102,170 ****
"scx_Draw_Image_Text")
! ; --- text is a Vector 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))))
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
! x y text format)
"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)))))))
--- 142,171 ----
"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")
|