diff --git a/scheme/xlib/text.scm b/scheme/xlib/text.scm new file mode 100644 index 0000000..68117a1 --- /dev/null +++ b/scheme/xlib/text.scm @@ -0,0 +1,169 @@ +;; author -> Norbert Freudemann +;; creation date : 16/07/2001 +;; last change : 19/07/2001 + + +(define (1-byte? int) + (and (< 0 int) (> 255 int))) + +(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! + +(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? '1-byte) 1) + ((eq? '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, +; 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")))) + +(import-lambda-definition %text-width (Xfontstruct text format) + "Text_Width") + +; --- Each extents-...-functions returns an 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 (extends-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?) + (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) + "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!")))) + + +(import-lambda-definition %draw-image-text (Xdisplay Xdrawable Xgcontext + x y text format) + "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 (change-format! format))) + +(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext + x y text format) + "Draw_Poly_Text") + + + + +; --- 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) + (if (string? 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)))))) + (error "the parameter istn't a string" translate-string))) + + + + +