;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: mktext.sc,v 1.3 90/04/01 13:50:57 johani Exp $

;;; make-textitem -- a new solution to the format of the textitems in requests
;;;                  #74 (PolyText8) and #75 (PolyText16).
;;; 
;;; Format of call: (make-textitem 'string8 0 "Allan" font <font> ...)
;;; If no number precedes a string zero is assumed as delta-value. If the first
;;; argument is either 'string8 or 'string16 it is taken as the type, otherwise
;;; 'string8 is assumed.
;;; Please note that these textitems are only necessary when dealing with
;;; PolyTexts, as ImageTexts use ordinary strings.
;;;
;;; Note1: Not converted to new assembler format in a sensible way. Still deals
;;;        with lists instead of strings.
;;; Note2: Should it not be possible to unify make-polytext and make-textitem
;;;        into one constructor? The current use is kind of stupid...
(define make-textitem
  (lambda l
    (let ((type #f) (list-of-items '()))
      (if (memq (car l) '(string8 string16))
	  (begin
	    (set! type (car l))
	    (set! l (cdr l)) )
	  (set! type 'string8) )
      (let loop ((l l))
	(cond ((null? l))		; Do nothing
	      ((string? (car l))	; Is arg a string?
	       (set! list-of-items
		     (append list-of-items
			     (list (if (eq? type 'string8)
				       (string-length (car l))
				       (/ (string-length (car l)) 2) )
				   0)
			     (map (lambda (x)
				    (bit-and 255 (char->integer x)) )
				  (string->list (car l)) )))
	       (loop (cdr l)) )
	      ((< (length l) 2)		; If not a string then we need 2 args
	       (error 'make-textitem "Number of parameters even.")) ; incl type
	      ((eq? (car l) 'font)
	       (let ((font-id ((cadr l) 'id)))
		 (set! list-of-items
		       (append list-of-items
			       '(255)
			       (let loop ((id font-id) (res '()) (nr 0))
				 (if (= nr 4)
				     res
				     (loop (inexact->exact (quotient id 256))
					   (cons (inexact->exact
						  (modulo id 256)) res)
					   (+ 1 nr))))
			       ))
;			       (if (= (byte-order) #x6c) ; LSB first
;				   (reverse font-id)
;				   font-id)))
		 (loop (cddr l)) ))
	      ((number? (car l))
	       (set! list-of-items
		     (append list-of-items
			     (list (if (eq? type 'string8)
				       (string-length (cadr l))
				       (/ (string-length (cadr l)) 2) )
				   (car l) )
			     (map (lambda (x)
				    (bit-and 255 (char->integer x)) )
				  (string->list (cadr l)) )))
	       (loop (cddr l)) )
	      (else (error 'make-textitem "Unknown argument: ~a" (car l))) ))

      (set! list-of-items (list-pad4 list-of-items))

      (define (me msg . args)		; What args could be useful?
	(cond ((eq? msg 'type) type)
	      ((eq? msg 'object-class) 'textitem)
	      ((eq? msg 'object-system) 'light-weight)
	      ((eq? msg 'supported-messages) '(type items length))
	      ((eq? msg 'me) (lambda () me))
	      ((eq? msg 'object-desc)
	       (let ((ml `((type   . ,type)
			   (items  . ,list-of-items)
			   (length . ,(/ (length list-of-items) 4)) )))
		 (list 'textitem
		       ml
		       'dont-care 
		       (cons (cons 'me (lambda () me)) ml)
		       'dont-care)))
	      ((eq? msg 'items) list-of-items)
	      ((eq? msg 'length) (/ (length list-of-items) 4))
	      (else (error 'make-textitem "Unknown message: ~a" msg)) ))
      me)))