First Implementation of Text Metrics

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