(defun toggle-text-button-field (f)	; toggle only the button part  (cond ((button-field-value		; and only if non-nil	   (text-button-field-button f))	 (toggle-button-field (text-button-field-button f)))))(defun check-text-button-field (f p)  (cond ((check-field (text-button-field-button f) p)	 (input-text-field			; input from scratch	   (text-button-field-text f)))	; get the data	(t (toggle-button-field			; must be pointing at text	     (text-button-field-button f))	; toggle only the button part	   (edit-text-field	     (text-button-field-text f) p))	; edit the data  )  (toggle-button-field			; toggle button back    (text-button-field-button f))  (alter-button-field (text-button-field-button f)    value nil)			; keep aggregate from toggling again  f)					; return self;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;						labelled button fields;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(defstruct  (labelled-button-field ; labelled button field    (:displace t)    (:list)    (:conc-name))  (type 'labelled-button-field)	; type = labelled-button  (zone (make-zone))		; bounding zone  (properties    (list nil	  'fill-ground 'solid	  'empty-ground 'solid	  'border-colour W-CONTRAST    ))  (value nil)			; value  (text '||)			; label text)(defvar labelled-button-field-properties  `("labelled-button-field-properties"    = ,text-field-properties   ))	; can use this as real plist for online documentation(defun draw-labelled-button-field (f)  (draw-text-field f))(defun init-labelled-button-field (f)  (init-text-field f))(defun resize-labelled-button-field (f box)  (resize-text-field f box))(defun check-labelled-button-field (f p)  (toggle-button-field f) f)	; if we get here it's a hit -> return self(defun toggle-labelled-button-field (f)  (toggle-button-field f));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;						expanded-bitmap fields;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(defstruct  (expanded-bitmap-field	; expanded-bitmap field    (:displace t)    (:list)    (:conc-name))  (type 'expanded-bitmap-field)	; type = expanded-bitmap  (zone (make-zone))		; bounding zone  (properties (list nil))	; empty plist  (subfields nil)		; individual bits  (selection nil)		; which one last hit  (nrows 1)  (ncols 1))(defvar expanded-bitmap-field-properties  `("expanded-bitmap-field-properties"    = ,aggregate-field-properties   ))	; can use this as real plist for online documentation(defun draw-expanded-bitmap-field (f)  (draw-aggregate-field f))(defun init-expanded-bitmap-field (f)  (let ((s (divide-points			; calculate x,y dimensions	     (box-size (zone-box (field-zone f)))	     (make-point	       x (expanded-bitmap-field-ncols f)	       y (expanded-bitmap-field-nrows f)))))       (do ((z (field-zone f))	    (r nil)	    (x (x (ll (zone-box (field-zone f)))))	    (y (y (ll (zone-box (field-zone f))))	       (+ y dy))	    (dx (x s))	    (dy (y s))	    (nc (expanded-bitmap-field-nrows f))	    (nr (expanded-bitmap-field-nrows f))	    (j 0 (1+ j)))	   ((= j nr) (alter-aggregate-field f subfields (nreverse r)) 't)	   (do ((x x (+ x dx))		(p)		(i 0 (1+ i)))	       ((= i nc))			; create a row of buttons	       (setq p (make-point x x y y))	       (setq r (xcons r (make-button-field zone (append z nil))))	       (alter-zone (field-zone (car r))		 box (make-box ll p ur (add-points p s)))	   ))))(defun resize-expanded-bitmap-field (f box)  (alter-zone (field-zone f) box box)  (let ((s (divide-points			; calculate x,y dimensions	     (box-size box)	     (make-point	       x (expanded-bitmap-field-ncols f)	       y (expanded-bitmap-field-nrows f)))))       (do ((z (field-zone f))	    (r (expanded-bitmap-field-subfields f))	    (x (x (ll box)))	    (y (y (ll box)) (+ y dy))	    (dx (x s))	    (dy (y s))	    (nc (expanded-bitmap-field-nrows f))	    (nr (expanded-bitmap-field-nrows f))	    (j 0 (1+ j)))	   ((= j nr) t)	   (do ((x x (+ x dx))		(p)		(i 0 (1+ i)))	       ((= i nc))			; create a row of buttons	       (setq p (make-point x x y y))	       (resize-button-field (car r)		 (make-box ll p ur (add-points p s)))	       (setq r (cdr r))	   ))))(defun check-expanded-bitmap-field (f p)  (check-aggregate-field f p))	; if we get here it's a hit -> check subfields;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities.l								;;;;									;;;; These macros and functions are thought to be generally useful.	;;;;									;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;							Macros		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(declare  (macros t)		; keep macros around after compiling  (localf pairify* pairifyq* split2* sublist*)  (special compiled-with-help))(defmacro copy-all-but-last (ls)	; copy all but last member of list  `(let ((ls ,ls))	(firstn (1- (length ls))	  ls)))(defmacro all-but-last (ls)		; destructive all-but-last  `(let ((ls ,ls))	(cond ((cdr ls)	       (rplacd (nthcdr (- (length ls) 2) ls) nil)	       ls))))(def hex (macro (arglist)		; hex to integer conversion		`(car (hex-to-int ',(cdr arglist)))));;; define properties on symbols for use by help routines(defmacro def-usage (fun usage returns group)  (cond (compiled-with-help	; flag controls help generation	  `(progn (putprop ,fun ,usage 'fcn-usage)		  (putprop ,fun ,returns 'fcn-returns)		  (putprop ,fun (nconc ,group (ncons ,fun)) 'fcn-group)))))(defvar compiled-with-help t)	; unless otherwise notified;;; (letenv 'l_bind_plist g_expr1 ... g_exprn) -- pair-list form of "let";;; Lambda-binds pairs of "binding-objects" (see description of let,let*),;;; at RUN TIME, then evaluates g_expr1 to g_exprn, returning g_exprn. eg:;;; (apply 'letenv '(letenv '(a 1 b (+ c d));;;		      (e)(f g)));-> (eval (cons 'let (cons (pairify '(a 1 b (+ c d)));;;			   '((e) (f g)))));-> (let ((a 1) (b (+ c d)));;;	 (e) (f g))(def letenv  (macro (x)    `(eval (cons 'let	     (cons	       (pairify ,(cadr x))	; plist of binding objects	       ',(cddr x))))))		; exprs to be eval'ed(def letenvq			; letenv, quoted binding objects  (macro (x)    `(eval (cons 'let	     (cons	       (pairifyq ,(cadr x))	; plist of binding objects	       ',(cddr x))))))		; exprs to be eval'ed(defmacro mergecar (L1 L2 cmpfn)	; merge, comparing by car's  `(merge ,L1 ,L2 '(lambda (e1 e2)		; (like sortcar)		     (funcall ,cmpfn (car e1) (car e2)))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;							Functions	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (all-but-last l_items)	-- copy all but last list element;(defun all-but-last (ls);  (cond ((cdr ls) (cons (car ls) (all-but-last (cdr ls))))));;; (alphap sx_char)(defun alphap (char)			; is char alphabetic?  (cond ((symbolp char)	 (setq char (car (exploden char)))))  (and (fixp char)       (or (and (>& char #.(1- #/A))		(<& char #.(1+ #/Z)))	   (and (>& char #.(1- #/a))		(<& char #.(1+ #/z))))));;; (alphanumericp sx_char)(defun alphanumericp (char)		; is char alphabetic or numeric?  (cond ((symbolp char)	 (setq char (car (exploden char)))))  (and (fixp char)       (or (and (>& char #.(1- #/A))		(<& char #.(1+ #/Z)))	   (and (>& char #.(1- #/a))		(<& char #.(1+ #/z)))	   (and (>& char #.(1- #/0))		(<& char #.(1+ #/9))))));;; (assqonc 'g_key 'g_val 'l_al);;; like   (cond ((assq key alist));;;		 (t (cadr (rplacd (last alist);;;			    (ncons (cons key val))))))(defun assqonc (key val al)	; tack (key.val) on end if not found  (do ((al al (cdr al)))      ((or (eq key (caar al))	   (and (null (cdr al))		(rplacd al (setq al (ncons (cons key val))))))       (car al))));;; (cartesian l_xset l_yset)(defun cartesian (xset yset)		; cartesian product of elements  (mapcan    '(lambda (x)       (mapcar	 '(lambda (y) (cons x y))	 yset))    xset))(defun concat-pairs (sb-list)	; concat neighbouring symbol pairs  (do ((s1 (car sb-list) s2)       (s2 (cadr sb-list) (car sbs-left))       (sbs-left (cddr sb-list) (cdr sbs-left))       (result nil (cons (concat s1 s2) result)))      ((null s2) (nreverse result))));;; (detach l);;; Detaches (and throws away) first element of list (converse of attach);;; keeping the same initial list cell.(defun detach (l)  (cond (l (rplacd l (cddr (rplaca l (cadr l)))))));;; (distribute x_Q x_N);;; returns list of the form: (1 1 1 0 0 0 0 1 1) or (3 2 2 2 3);;; i.e. a list of length <N> containing quantity <Q> evenly distributed;;; with the excess <Q mod N> surrounding a "core" of <Q div N>'s;;; Useful (?) for padding spaces in line adjustment.;(defun distribute (Q N)	; this one only does 1's and 0's;  (cond ((signp le Q) (duplicate N 0));	((eq Q 1) (pad 0 N '(1)));	(t (cons 1 (nconc;		     (distribute (- Q 2) (- N 2));		     '(1))))))(defun distribute (Q N)		; distribute quantity Q among N elements  (let ((tmp (Divide (abs Q) N)))       (setq tmp (distribute0 (cadr tmp) N (car tmp) (1+ (car tmp))))       (cond ((signp ge Q) tmp)	     (t (mapcar 'minus tmp)))))(defun distribute0 (Q N X X1)  (cond ((signp le Q) (duplicate N X))	((eq Q 1) (pad X N (ncons X1)))	(t (cons X1 (nconc			  (distribute0 (- Q 2) (- N 2) X X1)			  (ncons X1))))));;; (duplicate x_n g_object);;; Returns list of n copies of object (nil if n <= 0)(defun duplicate (n object)  (do ((res nil (cons object res))       (i n (1- i)))      ((signp le i) res)))(defun e0 (in out)		; simulate binary insertion procedure  (let ((lin (length in))	(lout (length out)))       (cond ((> lin lout)	      (e0		(nthcdr lout in)		(mapcan 'list out (firstn lout in))))	     (t (nconc (mapcan 'list (firstn lin out) in)		       (nthcdr lin out))))))(defun e (files)		; determine file permutation for emacs insert  (let ((i (e0 (cdr (iota (length files))) '(0)))	(f (append files nil)))       (mapc '(lambda (f-index f-name)		(rplaca (nthcdr f-index f) f-name))	     i files)       f));;; (firstn x_n l_listarg)(defun firstn (n l)		;  copy first <n> elements of list  (do ((n n (1- n))       (l l (cdr l))       (r nil))      ((not (plusp n)) (nreverse r))		; <nil> if n=0 or -ve      (setq r (cons (car l) r))));;; (iota x_n);;; APL index generator (0,1,2,...,<n>-1)(defun iota (n)  (do ((i (1- n) (1- i))       (res nil))      ((minusp i) res)      (setq res (cons i res))))(defun hex-to-int (numlist)		; eg. (hex-to-int '(12b3 120 8b))  (cond    (numlist			; terminate recursion on null numlist      (cons	(apply '+	       (maplist		 '(lambda (digits)		    (lsh		      (get '(hex |0| 0 |1| 1 |2| 2 |3| 3				 |4| 4 |5| 5 |6| 6 |7| 7				 |8| 8 |9| 9  a 10  b 11				  c 12  d 13  e 14  f 15)			   (car digits))		      (lsh (1- (length digits)) 2)))		 (explodec (car numlist))))	(hex-to-int (cdr numlist))))))  ;;; (lctouc g_expr);;; Returns s-expression formed by translating lower-case alphabetic;;; characters in <expr> to their upper-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 lctouc (expr)    (cond	((dtpr expr) (mapcar 'uctolc expr))	((or (symbolp expr) (stringp expr))	 (implode	     (mapcar		 '(lambda (ch)		      (cond ((alphap ch)		; and-out lower-case bit			     (boole 1 #.(1- (1- #/a)) ch)) (t ch)))		 (exploden expr))))	(t expr)));;; (log2 x_n)(defun log2 (n)			; log base 2 (truncated)  (do ((n (lsh n -1) (lsh n -1))       (p 0 (1+ p)))      ((zerop n) p)));;; (lowerp sx_char)(defun lowerp (char)		; is char lower-case alphabetic?  (cond ((symbolp char)	 (setq char (car (exploden char)))))  (and (fixp char)       (or (and (> char #.(1- #/a))		(< char #.(1+ #/z))))));;; (numericp sx_char);;; returns t if char is numeric, otherwise nil(defun numericp (char)  (cond ((symbolp char)(setq char (car (exploden char)))))  (and (fixp char)       (and (> char #.(1- #/0))	    (< char #.(1+ #/9)))));;; (pad g_item x_n l_list);;; Returns <list> padded with copies of <item> to length <n>(defun pad (item n list)  (append list (duplicate (- n (length list)) item)));;; (pairify l_items)	; make a-list from alternating elements(defun pairify (pl)  (pairify* nil pl))(defun pairify* (rs pl)		; tail-recursive local fun  (cond (pl (pairify* (cons (list (car pl) (cadr pl)) rs)		       (cddr pl)))	(t (nreverse rs))));;; (pairifyq l_items)	; make a-list from alternating elements(defun pairifyq (pl)	; with each second element quoted  (pairifyq* nil pl))(defun pairifyq* (rs pl)		; tail-recursive local fun  (cond (pl (pairifyq* (cons (list (car pl) (kwote (cadr pl))) rs)