scx/scheme/xlib/text.scm

;; author -> Norbert Freudemann
;; creation date : 16/07/2001
;; last change   : 19/07/2001

; --- Dimension-Predicates

(define (1-byte? int)
  (and (< 0 int) (> 255 int)))

(define (2-byte? int)
  (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 text 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-byte or 2-byte string,
;; represented by an integer, character, string or symbol, or event a
;; list of those types. the optional argument format is one of '1-byte
;; or '2-byte, which defaults to '1-byte. See XTextWidth.

(define (text-width font text . format)
  (let ((format (if (null? format) '1-byte (car 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-...-function returns a number.

(define (extents-intern id)
  (lambda (font text . format)
    (let ((format (if (null? format) '1-byte (car format))))
      (%extents (font-Xfontstruct font)
		(text->internal-text text format)
		(get-format-id format)
		id))))

(define extents-lbearing (extents-intern 0))
(define extents-rbearing (extents-intern 1))
(define extents-width (extents-intern 2))
(define extents-ascent (extents-intern 3))
(define extents-descent (extents-intern 4))

(import-lambda-definition %extents-text (Xfontstruct text format which)
  "scx_Extents_Text")			  
      
;; draw-image-text draws a text on the gcontext at the specified
;; position. text is an integer, character, string or symbol, or even
;; a list of these types. format is '1-byte or '2-byte. '1-byte is the
;; default value. See XDrawImageString.

(define (draw-image-text drawable gcontext x y text . format)
  (let ((format (if (null? format) '1-byte (car 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))))
		    

(import-lambda-definition %draw-image-text (Xdisplay Xdrawable Xgcontext
						     x y text format)
  "scx_Draw_Image_Text")

;; draw-poly-test is a more complex function for text drawing. text
;; has the following format:
;; <text> ::= <text-spec> | ( <text-spec>+ )
;; <text-spec> ::= <integer> | <char> | <string> | <symbol> | <font> 
;;                 | (null . <delta>) | (<font> . <delta>)
;; <delta> ::= <integer>
;; so for example a text argument of
;; (list font-1 "Hello" (cons font-2 5) "World")
;; should draw Hello in font-1 and World in font-2 with a
;; character-spacing of 5.
;; the optional format argument is one of '1-byte or '2-byte and
;; defaults to '1-byte.

(define (draw-poly-text drawable gcontext x y text . format)
  (let* ((format (if (null? format) '1-byte (car format)))
	 (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")