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