(cddr pl)))	(t (nreverse rs))));;; (penultimate l_items)	; cdr down to next-to-last list element(defun penultimate (ls)	  (cond ((cddr ls) (penultimate (cdr ls)))	(t ls)));;; (split2 l_L);;; Splits list <L> into two (new) second-level lists(defun split2* (L tc1 tc2)  (cond ((null L) (list (nreverse tc1) (nreverse tc2)))	(t (split2* (cddr L)	     (cons (car L) tc1)	     (cons (cadr L) tc2)))))(defun split2 (L)  (split2* L nil nil));;; (sublist L IL);;; Splits list <L> (destructively) into (length IL) sub-lists.;;; IL is a list of starting indices, base zero, should be unique positive;;; fixnums in ascending order, and shouldn't exceed the length of L.;;; Each resulting sublist <i> begins with (nthcdr (nth <i> IL) L)(defun sublist (L IL)  (sublist* 0 nil (cons nil L) IL))(defun sublist* (I R L IL)		; tail-recursion function  (cond ((and L IL)	 (cond	   ((<& I (car IL))	    (sublist* (1+ I) R (cdr L) IL))	   (t (sublist* (1+ I)			(cons (cdr L) R)			(prog1 (cdr L) (rplacd L nil))			(cdr IL)))))	(t (nreverse R))))(defun try-fun (fun l-arg)	; try function on each arg until non-nil  (cond ((funcall fun (car l-arg)))	(l-arg (try-fun fun (cdr l-arg)))));;; (uctolc g_expr);;; Returns s-expression formed by translating upper-case alphabetic;;; characters in <expr> to their lower-case equivalents.;;; Operates by imploding the translated characters, in the case of a;;; symbol or string, or by recursively calling on members of a list.;;; Other object types are returned unchanged.(defun uctolc (expr)    (cond	((dtpr expr) (mapcar 'uctolc expr))	((or (symbolp expr) (stringp expr))	 (implode	     (mapcar		 '(lambda (ch)		      (cond ((alphap ch)		; or-in lower-case bit			     (boole 7 #.(1- #/a) ch)) (t ch)))		 (exploden expr))))	(t expr)));;; (unique a l) -- Scan <l> for an element <e> "equal" to <a>.;;; If found, return <e>. Otherwise nconc <a> onto <l>; return <a>.(defun unique (a l)			; ensure unique in list  (car    (do ((cdr_ul l (cdr ul))	 (ul l cdr_ul))	((null cdr_ul) (rplacd ul (ncons a)))	(cond ((equal a (car cdr_ul)) (return cdr_ul))))));;; (upperp sx_char)(defun upperp (char)		; is char upper-case alphabetic?  (cond ((symbolp char)	 (setq char (car (exploden char)))))  (and (fixp char)       (or (and (> char #.(1- #/A))		(< char #.(1+ #/Z))))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; zone.l -- data structures and routines for concrete window zones;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; a "point" is a pair of integer x,y coordinates;;; a "box" is a pair of points defining lower left and upper right corners;;; a "position" is a point coupled with a window;;; a "zone" is a box coupled with a window;;; a "window" is a machine, integer window id and, for compatibility;;;	with the toolbox, an integer toolbox window pointer;;; a "machine" is a name coupled with the j-process-id's of resident servers;;; The basic idea is to define a notion of a concrete position for a;;; display object, that can be incorporated into the object data structure.;;; Higher levels of software can use the objects without explicit reference;;; to server processes, windows and machines.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(declare  (specials t)			; global vars not local to this file  (macros t))			; compile macros as well(eval-when (compile)		; trust  to higher level for eval & load  (load 'utilities)		; utility functions  (load 'constants)		; common constants for window toolbox;  (load 'shape)		; arbitrarily shaped screen areas)(defstruct  (position		; a concrete display position    (:displace t)    (:list)    (:conc-name))  (window (make-window))	; concrete window  (point (make-point))		; actual x, y coordinates)(defstruct  (zone			; a concrete display zone    (:displace t)    (:list)    (:conc-name))  (window (make-window))	; concrete window  (box (make-box))		; bounding box of zone  (colour W-BACKGROUND)		; colour (for scrolling etc)  shape)(defstruct  (window		; concrete window    (:displace t)    (:list)    (:conc-name))  (id 0)			; integer window id  (machine (make-machine))	; machine (workstation)  (w 0)				; toolbox window structure pointer)(defstruct  (machine		; machine (workstation)    (:displace t)    (:list)    (:conc-name))  (name	'unknown-machine)	; machine name  (servers nil)			; plist of server processes living there);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; manipulation routines;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(defun add-points (p q)		; vector sum (x1+x2) (y1+y2)  (make-point    x (+ (x p) (x q))    y (+ (y p) (y q))))(defun subtract-points (p q)	; vector subtract (x1-x2) (y1-y2)  (make-point    x (- (x p) (x q))    y (- (y p) (y q))))(defun multiply-points (p q)	; vector multiply (x1*x2) (y1*y2)  (make-point    x (* (x p) (x q))    y (* (y p) (y q))))(defun divide-points (p q)	; vector division (x1-x2) (y1-y2)  (make-point    x (/ (x p) (x q))    y (/ (y p) (y q))))(defun move-point (p q)		; move point p to point q  (alter-point p    x (x q)    y (y q))  t)					; return true(defun box-size (b)		; size of box = ur - ll  (subtract-points (ur b) (ll b)))(defun box-interior (b)		; return box just inside this box dimensions  (make-box    ll (add-points (ll b) '(1 1))    ur (subtract-points (ur b) '(1 1))))(defun move-box (b p)		; move box b to point p (lower-left)  (let ((size (box-size b)))       (alter-box b	 ll p	 ur (add-points p size))       t))				; return true(defun point-in-box (p b)	; is point p in box b? (including boundary)  (and (>= (x p) (x (ll b)))       (<= (x p) (x (ur b)))       (>= (y p) (y (ll b)))       (<= (y p) (y (ur b)))  ))(defun point-in-box-interior (p b) ; is point p in box b? (excluding boundary)  (and (> (x p) (x (ll b)))       (< (x p) (x (ur b)))       (> (y p) (y (ll b)))       (< (y p) (y (ur b)))  ))(defun init-window (w)		; fill in  "window" structure  (let				; presuming window-w predefined    ((m (j-machine-name (w-get-manager (window-w w)))))    (alter-window w id (w-get-id (window-w w)))    (cond ((not (window-machine w))	   (alter-window w machine (make-machine name m)))	  (t (alter-machine (window-machine w) name m)))    (init-machine (window-machine w))	; also fill in machine structure    t))				; return true(defun init-machine (m)		; fill in "machine" structure  (cond				; presuming machine-name predefined    ((null (machine-servers m))		; if no plist, make new one     (alter-machine m servers (ncons 'servers:))))  (mapc '(lambda (pname)		; for each expected server name	   (let	     ((pid (j-search-machine-e jipc-error-code		     (machine-name m)		     pname)))		; try to find one on that machine	     (cond ((j-same-process pid J-NO-PROCESS)		    (putprop (machine-servers m) nil pname)) ; failed! use nil		   (t (putprop (machine-servers m) pid pname))))) ; success!	EXPECTED-WORKSTATION-SERVERS)	; global list of process names  t)					; return true(defvar EXPECTED-WORKSTATION-SERVERS	; global list of process names  '(window_manager creator savemem     text-composer))			; usually want at least these(defun window-box (w)		; box fills entire window  (let ((w-size (w-get-window-size (window-w w))))       (make-box	 ll (make-point x 0 y 0)	 ur (make-point x (car w-size) y (cadr w-size)))  ))(defun clear-zone (z colour)	; clear zone (including boundaries)  (let ((b (box-size (zone-box z))))       (w-clear-rectangle (window-w (zone-window z))	 (x (ll (zone-box z))) (y (ll (zone-box z)))	 (1+ (x b)) (1+ (y b))	 colour)))(defun clear-zone-interior (z colour)	; clear zone (excluding boundaries)  (let ((b (box-size (zone-box z))))       (w-clear-rectangle (window-w (zone-window z))	 (1+ (x (ll (zone-box z)))) (1+ (y (ll (zone-box z))))	 (1- (x b)) (1- (y b))	 colour)))(defun pattern-zone (z pattern)	; pattern zone (including boundaries)  (let ((b (zone-box z)))       (w-pattern-rectangle (window-w (zone-window z))	 (x (ll b)) (y (ll b))	 (1+ (x (ur b))) (1+ (y (ur b))) pattern)  ))(defun pattern-zone-interior (z pattern) ; pattern zone (excluding boundaries)  (let ((b (box-size (zone-box z))))       (w-pattern-rectangle (window-w (zone-window z))	 (1+ (x (ll (zone-box z)))) (1+ (y (ll (zone-box z))))	 (1- (x b)) (1- (y b)) pattern)  ))(defun draw-zone-outline (z colour)	; draw zone boundaries  (let* ((w (window-w (zone-window z)))	 (b (zone-box z))	 (ll (ll b))	 (ur (ur b)))	(w-draw-vector w (x ll) (y ll) (x ll) (y ur) colour)	(w-draw-vector w (x ll) (y ur) (x ur) (y ur) colour)	(w-draw-vector w (x ur) (y ur) (x ur) (y ll) colour)	(w-draw-vector w (x ur) (y ll) (x ll) (y ll) colour)  ));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font.l -- font manipulation;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(eval-when (compile)  (load 'utilities)  (load 'constants))(defvar -installed-fonts nil)	; list of installed fonts(defstruct  (font			; font structure    (:displace t)    (:list)    (:conc-name))  (name 'standard)  (size 8)  (body 8)  (cap-height 7)  (x-height 5)  (fixed-width 5)  (first 0)  (last 127)  glyph			; the actual characters)(defstruct  (glyph			; glyph structure    (:displace t)    (:list)    (:conc-name))  code  width  (bytes (byte-block 32))	; the actual bitmap);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 				font manipulation routines;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(defun read-font (family size path)  (let ((p (infile path))		; open file	(x (new-vectori-long 2))	(f nil))       (setq f (make-font		 name family		 size (tyi p)		 body (tyi p)		 cap-height (tyi p)		 x-height (tyi p)		 fixed-width (tyi p)		 first (prog1 (tyi p) (tyi p))		 last (prog1 (tyi p) (tyi p))))       (alter-font f glyph	 (do ((i (font-first f) (1+ i))	      (r (ncons nil))	      (g))	   	     ((> i (font-last f)) (car r))	     (setq g (make-glyph code i))	; allocate char	     (do ((j 0 (1+ j)))			; read bitmap		 ((> j 31))		 (vseti-byte (glyph-bytes g) j (tyi p)))	     (alter-glyph g width (tyi p))	; read width	     (setq r (tconc r g))	 ))       (close p)			; close file       (rplacd				; install font	 (cond ((assoc (list (font-name f) (font-size f)) -installed-fonts))	       (t (car (setq -installed-fonts			     (cons (ncons (list (font-name f) (font-size f)))				   -installed-fonts)))))	 f)       f))				; return font(def-usage 'read-font '(|'st_family| |'x_size| |'st_path|)  'l_font-descriptor  (setq fcn-group (ncons "Font Manipulation:")))(defun install-font (f)  (cdr    (rplacd				; install font      (cond ((assoc (list (font-name f) (font-size f)) -installed-fonts))	    (t (car (setq -installed-fonts			  (cons (ncons (list (font-name f) (font-size f)))				-installed-fonts)))))      f)))(defun find-font (family size)	; always "finds" one even if dummy  (cond ((cdr (assoc (list family size) -installed-fonts)))	(t (install-font (make-font name family size size)))))(def-usage 'find-font  '(|'st_family| |'x_size|)  'l_font-descriptor  fcn-group)(defun create-font (driver font)  (j-send-se-list driver    (list 'make-font	  (font-name font)	  (font-size font)	  (font-body font)	  (font-cap-height font)	  (font-x-height font)	  (font-fixed-width font)	  (font-first font)	  (font-last font))))(defun download-glyph (driver font glyph)  (j-put-items    `((J-STRING set-glyph)       (J-STRING ,(font-name font))       (J-INT ,(font-size font))       (J-INT ,(glyph-code glyph))       (J-INT ,(glyph-width glyph))       (J-BLOCK ,(glyph-bytes glyph))))  (j-send driver))(defun download-font (driver font)  (do ((g (font-glyph font))       (font-size (font-size font)))      ((null g))      (j-put-items	`((J-STRING set-glyph)	  (J-STRING ,(font-name font))	  (J-INT ,font-size)))      (do ((gg g (cdr gg)))	  ((or (null gg) (j-put-items			   `((J-INT ,(glyph-code (car gg)))			     (J-INT ,(glyph-width (car gg)))			     (J-BLOCK			       ,(glyph-bytes (car gg))			       ,(+ font-size font-size)))))	   (setq g gg)))		; when buffer full, save remainder      (j-send driver)      (cond ((eq J-STRING (j-next-item-type))	     (j-gets j-comm-string 128)		; skip past message string	     (cond ((eq J-INT (j-next-item-type))(patom (j-geti))(terpr)))))