progl

Best algorithm for LZW ..C language

  ))

(def-usage 'download-font
  '(|'x_process-id| |'l_font-descriptor|)
  't
  fcn-group)

(defun read-create-download-font (driver family size path)
  (let ((f (read-font family size path)))
       (create-font driver f)
       (download-font driver f)
       f))

(def-usage 'read-create-download-font
  '(|'x_process-id| |'st_family| |'x_size| |'st_path|)
  'l_font-descriptor
  fcn-group)

(defun font-depth (f)
  (- (font-body f) (font-cap-height f)))

(defun font-height (f)
  (font-cap-height f))

(defun get-font-list (sc) ; arg is string-composer or font-server pid
  (j-send-se sc 'get-font-list)
  (pairify (mapcar
	     '(lambda (x)
		(cond ((stringp (cadr x)) (concat (cadr x)))
		      (t (cadr x))))
	     (j-get-items))))

(defun get-all-font-info (sc) ; arg is string-composer or font-server pid
  (mapc '(lambda (f)
	   (rplacd (apply 'find-font f)
	     (cdr (progn
		    (j-send-se-list sc (cons 'get-font-info f))
		    (mapcar 'cadr (j-get-items))))))
	(get-font-list sc)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; text.l -- fancy text strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare
  (specials t)
  (macros t))

(eval-when (compile)
  (load 'utilities)
  (load 'constants)
  (load 'zone)
  (load 'font)
  (load 'look))

(defstruct
  (text		; text structure
    (:displace t)
    (:list)
    (:conc-name))
  (text '||)			; the text to draw
  (look (make-look))		; what style to draw it in
  (kl 0)			; (starting) left kerning mask
  (zone (make-zone))		; specific window, clipping box
  (offset (make-point))		; offset of start point from zone ll
  (kr 0)			; (final) right kerning mask
  (delta (make-point))		; change in (x,y) relative to start point
  (nn -1)			; char count
)

;;; NOTE: clipping box of ((0 0) (-1 -1)) uses window boundaries

(defun text-width (s)		; presumes non-rotated
  (x (text-delta s)))

(defun text-box (s)		; presumes non-rotated
  (make-box
    ll (subtract-points
	 (text-start-point s)
	 (make-point x 0 y (font-depth (look-font (text-look s)))))
    ur (add-points
	 (text-end-point s)
	 (make-point x 0 y (font-height (look-font (text-look s)))))))

(defun text-start-point (s)
  (add-points
    (ll (zone-box (text-zone s)))
    (text-offset s)))

(defun text-end-point (s)
  (add-points
    (text-start-point s)
    (text-delta s)))

(defun text-x (s)	; x coord of start of text object
  (+ (x (ll (zone-box (text-zone s))))
     (x (text-offset s))))

(defun text-y (s)	; y coord of start of text object
  (+ (y (ll (zone-box (text-zone s))))
     (y (text-offset s))))

(defun text-xx (s)	; x coord of end of text object
  (+ (x (ll (zone-box (text-zone s))))
     (x (text-offset s))
     (x (text-delta s))))

(defun text-yy (s)	; y coord of end of text object
  (+ (y (ll (zone-box (text-zone s))))
     (y (text-offset s))
     (y (text-delta s))))

(defun move-text (s p)	; move s to new x,y
  (alter-text s
    offset (subtract-points p (ll (zone-box (text-zone s))))))

(defun draw-text (s)		; quietly draw text, clipping to zone box
  (let (((x y) (text-start-point s))
	(l (text-look s)))
       (j-put-items
	 `((J-STRING compose)
	   (J-INT ,(window-id (zone-window (text-zone s))))
	   (J-STRING ,(text-text s))
	   (J-STRING ,(font-name (look-font l)))
	   (J-INT ,(font-size (look-font l)))
	   (J-INT ,(boole 7 (look-mode l) QUIET))
	   (J-INT ,(look-colour l))
	   (J-INT ,(look-gap l))
	   (J-INT ,(look-ul l))
	   (J-INT ,(text-kl s))
	   (J-INT ,x)
	   (J-INT ,y)
	   (J-INT ,(x (cond
			((zerop (boole 1 ROTATE-180 (look-mode l)))
			 (ur (zone-box (text-zone s))))
			(t (ll (zone-box (text-zone s)))))))
	   (J-INT ,(y (cond
			((zerop (boole 1 ROTATE-90 (look-mode l)))
			 (ur (zone-box (text-zone s))))
			(t (ll (zone-box (text-zone s)))))))
	   (J-INT ,(text-nn s))
	  ))
       (j-send (get (machine-servers
		      (window-machine
			(zone-window
			  (text-zone s))))
		    'text-composer))
  ))

(defun undraw-text (s)	; quietly undraw text, clipping to zone box
  (let (((x y) (text-start-point s))
	(l (text-look s)))
       (j-put-items
	 `((J-STRING compose)
	   (J-INT ,(window-id (zone-window (text-zone s))))
	   (J-STRING ,(text-text s))
	   (J-STRING ,(font-name (look-font l)))
	   (J-INT ,(font-size (look-font l)))
	   (J-INT ,(boole 7 OVERSTRIKE QUIET (look-mode l)))
	   (J-INT ,(inverse-colour (look-colour l)))
	   (J-INT ,(look-gap l))
	   (J-INT ,(look-ul l))
	   (J-INT ,(text-kl s))
	   (J-INT ,x)
	   (J-INT ,y)
	   (J-INT ,(x (cond
			((zerop (boole 1 ROTATE-180 (look-mode l)))
			 (ur (zone-box (text-zone s))))
			(t (ll (zone-box (text-zone s)))))))
	   (J-INT ,(y (cond
			((zerop (boole 1 ROTATE-90 (look-mode l)))
			 (ur (zone-box (text-zone s))))
			(t (ll (zone-box (text-zone s)))))))
	   (J-INT ,(text-nn s))
	  ))
       (j-send (get (machine-servers
		      (window-machine
			(zone-window
			  (text-zone s))))
		    'text-composer))
  ))

(defun format-text (s)	; format text without drawing or clipping
  (let ((memop (symbolp (text-text s)))	; can only memoize symbols
	(k) (p) (q) (l (text-look s)))
       (cond
	 (memop					; are we memoizing? yes!
	   (setq k (unique-look-id l))	; key based on look
	   (setq p (get (text-text s) k))		; alist found on plist
	   (setq q (assoc (text-kl s) p))))		; entry based on kl
       (cond
	 (q (alter-text s			; if info found
	      kr (cadr q)			; record result
	      delta (caddr q)			; then return
	      nn (cadddr q)))
	 (t					; otherwise compute data
	   (j-put-items
	     `((J-STRING compose)
	       (J-INT 0)			; no window needed
	       (J-STRING ,(text-text s))
	       (J-STRING ,(font-name (look-font l)))
	       (J-INT ,(font-size (look-font l)))
	       (J-INT ,(boole 7 NO-DRAW (look-mode l)))
	       (J-INT ,(look-colour l))
	       (J-INT ,(look-gap l))
	       (J-INT ,(look-ul l))
	       (J-INT ,(text-kl s))
	       (J-INT 0)			; starting point 0 0
	       (J-INT 0)
	       (J-INT -1)			; no clipping
	       (J-INT -1)
	       (J-INT -1)
	      ))
	   (j-send (get (machine-servers
			  (window-machine
			    (zone-window
			      (text-zone s))))
			'text-composer))
	   (let ((kr (j-geti))			; now record result
		 (xx (j-geti))
		 (yy (j-geti))
		 (nn (j-geti)))
		(alter-text s
		  kr kr
		  delta (make-point x xx y yy)
		  nn nn)
		(cond (memop				; memoize if req'd
			(cond (p (nconc p
				   (ncons (list (text-kl s) kr
						(text-delta s) nn))))
			      (t (putprop (text-text s)
				   (ncons (list (text-kl s) kr
						(text-delta s) nn))
				   k))))
		))
	 ))
       't))					; always return t

(defun scan-text (s p) ; scan text s for point p, return (kr delta nn)
  (let (((x y) (text-start-point s))		; inside: check text
	(l (text-look s)))
       (j-put-items
	 `((J-STRING compose)
	   (J-INT 0)
	   (J-STRING ,(text-text s))
	   (J-STRING ,(font-name (look-font l)))
	   (J-INT ,(font-size (look-font l)))
	   (J-INT ,(boole 7 NO-DRAW (look-mode l)))
	   (J-INT ,(look-colour l))
	   (J-INT ,(look-gap l))
	   (J-INT ,(look-ul l))
	   (J-INT ,(text-kl s))
	   (J-INT ,x)
	   (J-INT ,y)
	   (J-INT ,(x p))
	   (J-INT ,(y p))
	   (J-INT ,(text-nn s))
	  ))
       (j-send (get (machine-servers
		      (window-machine
			(zone-window
			  (text-zone s))))
		    'text-composer))
       (let ((kr (j-geti))			; now record result
	     (xx (j-geti))
	     (yy (j-geti))
	     (nn (j-geti)))
	    (list kr (make-point x (- xx x) y (- yy y)) nn))
  ))

(defun format-draw-text (s)		; draw it while formatting
  (let ((memop (symbolp (text-text s)))	; can only memoize symbols
	((x y) (text-start-point s))
	(k) (p) (q) (l (text-look s)))
       (cond
	 (memop					; are we memoizing? yes!
	   (setq k (unique-look-id l))	; key based on look
	   (setq p (get (text-text s) k))		; alist found on plist
	   (setq q (assoc (text-kl s) p))))		; entry based on kl
       (cond
	 (q (alter-text s			; if info found
	      kr (cadr q)			; record result
	      delta (caddr q)
	      nn (cadddr q))
	    (draw-text s))			; draw it & return
	 (t					; otherwise compute data
	   (j-put-items
	     `((J-STRING compose)
	       (J-INT ,(window-id (zone-window (text-zone s))))
	       (J-STRING ,(text-text s))
	       (J-STRING ,(font-name (look-font l )))
	       (J-INT ,(font-size (look-font l)))
	       (J-INT ,(boole 4 (look-mode l) QUIET))
	       (J-INT ,(look-colour l))
	       (J-INT ,(look-gap l))
	       (J-INT ,(look-ul l))
	       (J-INT ,(text-kl s))
	       (J-INT ,x)
	       (J-INT ,y)
	       (J-INT ,(x (cond
			    ((zerop (boole 1 ROTATE-180 (look-mode l)))
			     (ur (zone-box (text-zone s))))
			    (t (ll (zone-box (text-zone s)))))))
	       (J-INT ,(y (cond
			    ((zerop (boole 1 ROTATE-90 (look-mode l)))
			     (ur (zone-box (text-zone s))))
			    (t (ll (zone-box (text-zone s)))))))
	       (J-INT -1)			; format to end of text
	      ))
	   (j-send (get (machine-servers
			  (window-machine
			    (zone-window
			      (text-zone s))))
			'text-composer))
	   (let ((kr (j-geti))			; now alter result data
		 (xx (j-geti))
		 (yy (j-geti))
		 (nn (j-geti)))
		(cond ((neq nn (length (exploden (text-text s))))
		       (format-text s))	; actually clipped! reformat
		      (t (alter-text s
			   kr kr
			   delta (make-point x (- xx x) y (- yy y))
			   nn nn)
			 (cond
			   (memop		; memoize if req'd
			     (cond (p (nconc p
					(ncons (list (text-kl s) kr
						     (text-delta s) nn))))
				   (t (putprop (text-text s)
					(ncons (list (text-kl s) kr
						     (text-delta s) nn))
					k))))
			 ))
		))
	 ))
       't))					; always return t

(defun backspace-text (s n)	; undraw last n characters, remove from text
  (cond				; this presumes s has valid delta,kr,nn
    ((plusp (text-nn s))	; proceed only if length > 0
     (setq n (min n (text-nn s)))	; can't delete more than nn chars
     (let ((text (text-text s))
	   (l (text-look s)))
	  (alter-text s		; keep all but last n chars
	    text (substring text 1 (- (text-nn s) n))
	    nn (- (text-nn s) n))
	  (format-text s)		; reformat to find the new end
	  (j-put-items
	    `((J-STRING compose)	; now undraw last character
	      (J-INT ,(window-id (zone-window (text-zone s))))
	      (J-STRING ,(substring text (- n))) ; undraw last n chars
	      (J-STRING ,(font-name (look-font l)))
	      (J-INT ,(font-size (look-font l)))
	      (J-INT ,(boole 7 QUIET OVERSTRIKE (look-mode l)))
	      (J-INT ,(inverse-colour (look-colour l)))
	      (J-INT ,(look-gap l))
	      (J-INT ,(look-ul l))
	      (J-INT ,(text-kr s))
	      (J-INT ,(text-xx s))
	      (J-INT ,(text-yy s))
	      (J-INT ,(x (cond
			   ((zerop (boole 1 ROTATE-180 (look-mode l)))
			    (ur (zone-box (text-zone s))))
			   (t (ll (zone-box (text-zone s)))))))
	      (J-INT ,(y (cond
			   ((zerop (boole 1 ROTATE-90 (look-mode l)))
			    (ur (zone-box (text-zone s))))
			   (t (ll (zone-box (text-zone s)))))))
	      (J-INT ,n)
	     ))
	  (j-send (get (machine-servers
			 (window-machine
			   (zone-window
			     (text-zone s))))
		       'text-composer))
	  't))			; return t if able to do it; nil if nn <= 0
  ))

(defun append-text (s c)	; draw new char(s) & add to end of text
  (cond ((fixp c)		; this presumes s has valid delta,kr,nn
	 (setq c (ascii c))))
  (j-put-items
    `((J-STRING compose)	; draw new last character(s)
      (J-INT ,(window-id (zone-window (text-zone s))))
      (J-STRING ,c)
      (J-STRING ,(font-name (look-font (text-look s))))
      (J-INT ,(font-size (look-font (text-look s))))
      (J-INT ,(boole 4 (look-mode (text-look s)) QUIET))	; be noisy!
      (J-INT ,(look-colour (text-look s)))
      (J-INT ,(look-gap (text-look s)))
      (J-INT ,(look-ul (text-look s)))
      (J-INT ,(text-kr s))	; this presumes s has valid delta,kr,nn
      (J-INT ,(text-xx s))
      (J-INT ,(text-yy s))
	       (J-INT ,(x (cond
			    ((zerop (boole 1 ROTATE-180 (look-mode l)))
			     (ur (zone-box (text-zone s))))
			    (t (ll (zone-box (text-zone s)))))))
	       (J-INT ,(y (cond
			    ((zerop (boole 1 ROTATE-90 (look-mode l)))
			     (ur (zone-box (text-zone s))))
			    (t (ll (zone-box (text-zone s)))))))
      (J-INT -1)
     ))
  (j-send (get (machine-servers
		 (window-machine
		   (zone-window
		     (text-zone s))))
	       'text-composer))
  (let ((kr (j-geti))
	(xx (j-geti))
	(yy (j-geti))