scx/scheme/xlib/text.scm

;; 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? 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,
;     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)
  "scx_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 (extents-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)
  "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!"))))
		    

(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.

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