progl

Best algorithm for LZW ..C language

	(nn (j-geti)))
       (alter-text s
	 text (concat (text-text s) c)
	 kr kr
	 delta (subtract-points
		 (make-point x xx y yy)
		 (text-start-point s))
	 nn (+ (text-nn s) nn)))
  't)

(defun append-text-scroll (s c colour) ; draw and add new char(s)
  (let ((w (window-id	;  while scrolling zone box b in specified colour
	     (zone-window (text-zone s))))
	(b (zone-box (text-zone s)))
	(l (text-look s)))
       (cond ((fixp c)
	      (setq c (ascii c)))) ; this presumes s has valid delta,kr,nn
       (j-put-items
	 `((J-STRING compose)	; format new last character
	   (J-INT ,w)
	   (J-STRING ,c)
	   (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-kr s)) ; this presumes s has valid delta,kr,nn
	   (J-INT 0)
	   (J-INT 0)
	   (J-INT -1)
	   (J-INT -1)
	   (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))
	     (nn (j-geti)))
	    (apply
	      'w-scroll-rectangle
	      (nconc
		(ncons (window-w (zone-window (text-zone s))))
		(let ((direction (boole 1 ROTATION
					(look-mode l))))
		     (cond
		       ((= direction ROTATE-0)
			(list (text-xx s)
			      (y (ll b))
			      (- (x (ur b)) (text-xx s) -1)
			      (- (y (ur b)) (y (ll b)) -1)
			      WM-RIGHT xx))
		       ((= direction ROTATE-90)
			(list (x (ll b))
			      (text-yy s)
			      (- (x (ur b)) (x (ll b)) -1)
			      (- (y (ur b)) (text-yy s) -1)
			      WM-UP yy))
		       ((= direction ROTATE-180)
			(list (x (ll b))
			      (y (ll b))
			      (- (text-xx s) (x (ll b)) -1)
			      (- (y (ur b)) (y (ll b)) -1)
			      WM-LEFT (- xx)))
		       ((= direction ROTATE-270)
			(list (x (ll b))
			      (y (ll b))
			      (- (x (ur b)) (x (ll b)) -1)
			      (- (text-yy s) (y (ll b)) -1)
			      WM-DOWN (- yy)))
		     ))
		(ncons colour)))
	    (w-flush (window-w (zone-window (text-zone s))))
	    (j-put-items
	      `((J-STRING compose)	; draw new last character
		(J-INT ,w)
		(J-STRING ,c)
		(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-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))
	    (alter-text s
	      text (concat (text-text s) c)
	      kr kr
	      delta (add-points
		      (make-point x xx y yy)
		      (text-delta s))
	      nn (+ (text-nn s) nn))
       )'t))

(defun format-text-list (sl)			; chain the text objects
  (do ((s (car sl) (car sl))			; so that xx,yy,kr of one
       (sl (cdr sl) (cdr sl)))			; used as x,y,kl of next
      ((null sl) (format-text s) 't)
      (format-text s)
      (alter-text (car sl)
	kl (text-kr s))
      (move-text (car sl) (text-end-point s))
  ))

(defun move-text-list (sl p)	; move whole list of text objects
  (do ((s (car sl) (car sl))
       (sl (cdr sl) (cdr sl))
       (p p (text-end-point s)))
      ((null s) 't)
      (move-text s p)
  ))

(defun compress-text-list (sl)		; combine like-moded text objects
  (do ((s (car sl) (car sl))			; to reduce communication
       (sl (cdr sl) (cdr sl))
       (new-text nil)
       (new-end-point (text-start-point s))
       (new-s (append (car sl) nil))	; top-level copy
       (dx nil)
       (gap (look-gap (text-look (car sl))))
       (result nil))
      ((null s) (alter-text new-s
		   text (apply 'concat (nreverse new-text))
		   nn -1)
       (nreverse (cons new-s result)))		; return new s-list
      (setq dx (- (x (text-start-point s))
		  (x new-end-point)))
      (cond ((and			; check most likely diffs first
	       (or (eq dx 0) (>= dx (look-gap (text-look s))))
	       (= (y (text-start-point s)) (y new-end-point))
	       (eq (text-look s)
		   (text-look new-s))
	     )				; presume kerning doesn't matter!
	     (cond ((plusp dx)		; horizontal movement
		    (setq new-text
			  (cons
			    (implode
			      (do ((dx (- dx gap 4) (- dx gap 4))
				   (result nil))
				  ((minusp dx)
				   (do ((dx (+ dx 4 -1) (- dx gap 1)))
				       ((minusp dx)
					(cond ((eq dx -1)
					       (setq result
						     (cons 1 result)))))
							; 0-pixel space
				       (setq result (cons 2 result)))
							; 1-pixel space
				   result)
				  (setq result (cons 3 result))
							; 4-pixel space
			      ))
			    new-text))))
	     (setq new-text (cons (text-text s) new-text))
	     (setq new-end-point (text-end-point s))
	    )
	    (t (alter-text new-s
		 text (apply 'concat (nreverse new-text))
		 nn -1
		 delta (subtract-points new-end-point
			 (text-start-point new-s)))
	       (setq result (cons new-s result))
	       (setq new-s (append s nil)
		     new-text (ncons (text-text s)))
	       (setq
		 new-end-point (text-start-point s)
		 gap (look-gap (text-look s)))
	    )
      )))

(defun draw-text-list (sl)
  (mapc '(lambda (x) (draw-text x)) sl) 't)

(defun undraw-text-list (sl)
  (mapc '(lambda (x) (undraw-text x)) sl) 't)

(defun format-draw-text-list (slist) ; format all on same line
  (do ((s (car slist) (car sl))
       (sl (cdr slist) (cdr sl)))
      ((null sl) (format-draw-text s))	; format the last one
      (format-draw-text s)
      (move-text (car sl)	; chain xx,yy,kr to next one's x,y,kl
	(text-end-point s))
  ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; text-edit.l -- rudimentary line editor for fancy character texts
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; These routines provide a simple line editor with control keys reminiscent
;;; of the default EMACS key bindings.
;;;
;;; The calling program presumably has obtained a "point" event, at
;;; position "p".  The cursor will be placed on the nearest character,
;;; and then input is accepted from the keyboard, until such time as a
;;; <return> key is accepted, or a point event occurs outside the text
;;; zone boundary, or until a non-key, non-point event occurs.  Another
;;; point event within the text zone causes the cursor to be re-positioned.
;;;
;;; Editing operations currently supported are:
;;;	CTRL-A (ascii 1)	; control A = beginning of line
;;;	CTRL-B (ascii 2)	; control B = backward-character
;;;	CTRL-D (ascii 4)	; control D = delete next char
;;;	CTRL-E (ascii 5)	; control E = end of line
;;;	CTRL-F (ascii 6)	; control F = forward-character
;;;	BACKSPACE (ascii 8)	; BACKSPACE = delete previous char
;;;	CTRL-K (ascii 11)	; control K = kill to end of line
;;;	CTRL-L (ascii 12)	; control L = redraw text
;;;	RETURN (ascii 13)	; RETURN = "done"
;;;	CTRL-T (ascii 20)	; control T = transpose previous 2 chars
;;;	CTRL-Y (ascii 25)	; control Y = "yank" recently killed text

(declare
  (specials t)
  (macros t))

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


(eval-when (compile eval load)
  (defvar BACKSPACE (ascii 8))	; backspace char = delete previous char
  (defvar RETURN (ascii 13))	; carriage return = "done"
  (defvar CTRL-A (ascii 1))	; control A = beginning of line
  (defvar CTRL-B (ascii 2))	; control B = backward-character
  (defvar CTRL-D (ascii 4))	; control D = delete next char
  (defvar CTRL-E (ascii 5))	; control E = end of line
  (defvar CTRL-F (ascii 6))	; control F = forward-character
  (defvar CTRL-K (ascii 11))	; control K = kill to end of line
  (defvar CTRL-L (ascii 12))	; control L = redraw text
  (defvar CTRL-T (ascii 20))	; control T = transpose previous 2 chars
  (defvar CTRL-Y (ascii 25))	; control Y = "yank" recently killed text
  (defvar TYPEAHEAD-THRESHOLD 5); can type at most 5 chars -> forced feedback
)

(defun edit-text (s p)	; edit a text at point p
  (cond					; p outside zone => nil
    ((not (point-in-box p (zone-box (text-zone s)))) nil)
    (t					; p inside zone => edit text
      (let
	((w (window-w (zone-window (text-zone s))))
	 (post (append s nil))
	 (kill-text ""))
	(split-texts s post p)	; split into left and right parts
	(draw-cursor-leading-text post)	; highlight first char
	(skip-stroke-release-events w)
	(do ((e (w-get-next-event w)		; get an event
		(w-get-next-event w))		; then keep getting events
	     (l) (c))				; character list, character
	    ((eq c '#.RETURN)		; stop when <return> is received
	     (cond ((neq e WM-KEY)	; if not caused by key, put event back
		    (w-put-back-event w)))
	     (combine-texts s post)
	     t)			; just return 't
	    (cond			; main loop
	      ((eq e WM-KEY)
	       (setq c (concat (car (w-get-key w))))	; get the character
	       (cond
		 ((eq c '#.BACKSPACE)		; backspace char
		  (text-delete-previous-character s post))
		 ((eq c '#.CTRL-A)			; control A
		  (text-beginning-of-line s post))
		 ((eq c '#.CTRL-B)			; control B
		  (text-backward-character s post))
		 ((eq c '#.CTRL-D)			; control D
		  (text-delete-next-character s post))
		 ((eq c '#.CTRL-E)			; control E
		  (text-end-of-line s post))
		 ((eq c '#.CTRL-F)			; control F
		  (text-forward-character s post))
		 ((eq c '#.CTRL-K)			; control K
		  (text-kill-to-end-of-line s post))
		 ((eq c '#.CTRL-L)			; control L
		  (text-redraw-display s post))
		 ((eq c '#.CTRL-T)			; control T
		  (text-transpose-characters s post))
		 ((eq c '#.CTRL-Y)			; control Y
		  (text-yank-from-killbuffer s post))
		 ((neq c '#.RETURN)			; not <return>
		  (text-insert-character s post))
		 (t (w-put-back-event w))	; it's a <return>; put it back
	       ))			; so loop control can get it again
	      ((eq e WM-POINT-DEPRESSED)
	       (setq p (w-get-point w))
	       (cond				; check point in zone
		 ((point-in-box p (zone-box (text-zone s)))
		  (draw-cursor-leading-text post)	; un-highlight char
		  (combine-texts s post)
		  (split-texts s post p)
		  (draw-cursor-leading-text post)	; highlight new char
		  (skip-stroke-release-events w))
		 (t (w-put-back-event w)	; outside zone => return
		    (setq c '#.RETURN))))
	      ((neq e WM-CANCEL)		; an event we can't handle
	       (w-put-back-event w)		; so put it back, then return
	       (setq c '#.RETURN))
	    )))
    )))

(defun input-typeahead-keys (w n brk-fcn l)	; return keys typed ahead
   (cond					; brk-fcn tests text
     ((or (zerop n)				; already have max typeahead
	  (not (w-any-events w))) (nreverse l))	; or there aren't any events
     (t (let ((x (w-get-next-event w)))		; there's an event
	     (cond
	       ((neq x WM-KEY)
		(w-put-back-event w) (nreverse l))	; but not a keystroke
	       (t (setq x (car (w-get-key w)))		; it's a keystroke
		  (cond
		    ((funcall brk-fcn x)		; is it a break char?
		     (w-put-back-event w) (nreverse l))	; it's a special char
		    (t (input-typeahead-keys		; it's a regular char
			 w (1- n) brk-fcn (cons x l)))	; tail recur for rest
		  )))))))

(defun split-texts (s post p)		; split text s at point p
  (let					; yielding texts s and post
    (((kr delta nn) (scan-text s p)))	; scan for char pos'n
    (alter-text post			; text incl & after char pt'ed
      text (cond ((substring (text-text s) (1+ nn)))	; if it exists!
		 (""))			; otherwise,nothing
      offset (add-points (text-offset s) delta)
      kl kr
      delta (subtract-points (text-delta s) delta)
      nn (- (text-nn s) nn))
    (alter-text s kr kr delta delta nn nn	; truncate text
      text (cond ((substring (text-text s) 1 nn))
		 ("")))
  ))

(defun skip-stroke-release-events (w)
  (do ((e (w-get-next-event w)
	  (w-get-next-event w)))
      ((neq e WM-POINT-STROKE)		; get events until non-point-stroke
       (cond ((neq e WM-POINT-RELEASED)	; should be point-release
	      (w-put-back-event w))))	; if not, put it back
  ))

(defun combine-texts (s post)	; recombine texts
  (alter-text s
    text (concat (text-text s) (text-text post))
    nn (+ (text-nn s) (text-nn post))
    delta (add-points (text-delta s) (text-delta post))
    kr (text-kr post))
  (format-text s))

(defun draw-cursor-leading-text (s)	; highlight first char of text
  (let ((c (append s nil)))
       (alter-text c			; get first char
	 text (concat (cond ((substring (text-text c) 1 1))	; if any
			    (t 'a))))	; otherwise use a typical character
       (format-text c)
       (w-clear-rectangle
	 (window-w (zone-window (text-zone c)))
	 (text-x c)
	 (y (ll (zone-box (text-zone c))))
	 (min (x (text-delta c))
	      (- (x (ur (zone-box (text-zone c))))
		 (text-x c) -1))
	 (- (y (ur (zone-box (text-zone c))))
	    (y (ll (zone-box (text-zone c)))) -1)
	 W-XOR)
       (w-flush (window-w (zone-window (text-zone c))))
       t))

(defun text-delete-previous-character (s post)
  (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD
	     '(lambda (x)	; break on first non-BS
		(not (equal x #.(get_pname BACKSPACE))))
	     (ncons '#.BACKSPACE))))
       (alter-text s
	 nn (max 0 (- (text-nn s) (length l))))
       (alter-text s
	 text (cond ((substring
		       (text-text s)
		       1 (text-nn s)))
		    ("")))
       (format-text s)
       (w-scroll-rectangle
	 (window-w (zone-window (text-zone s)))
	 (text-xx s)
	 (y (ll (zone-box (text-zone s))))
	 (- (x (ur (zone-box (text-zone s))))
	    (text-xx s) 1)
	 (1+ (y (box-size (