1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2;;; form.l -- screen forms handler 3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 5(declare 6 (specials t) 7 (macros t)) 8 9(eval-when (compile) 10 (load 'utilities) 11 (load 'constants) 12 (load 'zone) 13 (load 'look) 14 (load 'font) 15 (load 'text) 16 (load 'text-edit)) 17 18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19;;; generic fields 20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 22(defstruct 23 (field ; generic field 24 (:displace t) 25 (:list) 26 (:conc-name)) 27 (type 'generic-field) ; type = generic 28 (zone (make-zone)) ; bounding zone 29 (properties (list nil)) ; empty property list 30) 31 32(defvar field-properties ; list of expected field properties 33 '("field-properties" 34 fill-ground (solid pattern) ; should we draw when highlit? 35 fill-colour (x_colour x_pattern) ; what colour or pattern? 36 empty-ground (solid pattern) ; should we draw when unlit? 37 empty-colour (x_colour x_pattern) ; what colour or pattern? 38 border-colour (x_colour) ; should we draw border (and what colour?) 39 )) ; can use this as real plist for online documentation 40 41(defun draw-field (f) ; draw field from scratch 42 (apply (concat 'draw- (field-type f)) ; construct draw function name 43 (ncons f))) ; then call it 44 45(defun init-field (f) ; initialize a field 46 (apply (concat 'init- (field-type f)) ; construct init function name 47 (ncons f))) ; then call it 48 49(defun resize-field (f box) ; resize a field 50 (apply ; construct resize function name 51 (concat 'resize- (field-type f)) 52 (list f box))) ; then call it 53 54(defun toggle-field (f) ; toggle a field 55 (apply (concat 'toggle- (field-type f)) ; construct toggle fcn name 56 (ncons f))) ; then call it 57 58(defun check-field (f p) ; check if point is inside field excl.border 59 (cond ((point-in-box-interior p (zone-box (field-zone f))) 60 (apply ; if so, construct check function name 61 (concat 'check- (field-type f)) 62 (list f p))) ; then call it and return result 63 (t nil))) ; otherwise return nil 64 65(defun fill-field (f) ; fill the field interior, if defined 66 (let ((b (get (field-properties f) 'fill-ground)) ; check if has one 67 (c (get (field-properties f) 'fill-colour))) 68 (cond ((eq b 'solid) ; solid background 69 (cond (c (clear-zone-interior (field-zone f) c)) 70 (t (clear-zone-interior (field-zone f) W-CONTRAST)))) 71 ((eq b 'pattern) ; patterned background 72 (cond (c (pattern-zone-interior (field-zone f) c)) 73 (t (pattern-zone-interior (field-zone f) W-PATTERN-1)))) 74 ))) ; no background at all! 75 76(defun empty-field (f) ; empty the field interior, if defined 77 (let ((b (get (field-properties f) 'empty-ground)) ; check if has one 78 (c (get (field-properties f) 'empty-colour))) 79 (cond ((eq b 'solid) ; solid background 80 (cond (c (clear-zone-interior (field-zone f) c)) 81 (t (clear-zone-interior (field-zone f) W-BACKGROUND)))) 82 ((eq b 'pattern) ; patterned background 83 (cond (c (pattern-zone-interior (field-zone f) c)) 84 (t (pattern-zone-interior (field-zone f) W-PATTERN-1)))) 85 ))) ; no background at all! 86 87(defun draw-field-background (f) ; just what it says 88 (let ((b (get (field-properties f) 'empty-ground)) ; check if has one 89 (c (get (field-properties f) 'empty-colour))) 90 (cond ((eq b 'solid) ; solid background 91 (cond (c (clear-zone (field-zone f) c)) 92 (t (clear-zone (field-zone f) W-BACKGROUND)))) 93 ((eq b 'pattern) ; patterned background 94 (cond (c (pattern-zone (field-zone f) c)) 95 (t (pattern-zone (field-zone f) W-PATTERN-1)))) 96 ))) ; no background at all! 97 98(defun draw-field-border (f) ; draw outline, if any 99 (let ((c (get (field-properties f) 'border-colour))) 100 (cond (c (draw-zone-outline (field-zone f) c))) 101 )) 102 103;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104;;; aggregate fields 105;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 107(defstruct 108 (aggregate-field ; aggregate field = form 109 (:displace t) 110 (:list) 111 (:conc-name)) 112 (type 'aggregate-field) ; type 113 (zone (make-zone)) ; bounding zone 114 (properties (list nil)) ; empty property list 115 subfields ; list of subfields 116 selection ; which subfield was last hit 117) 118 119(defvar aggregate-field-properties 120 `("aggregate-field-properties" 121 = ,field-properties 122 )) ; can use this as real plist for online documentation 123 124(defun draw-aggregate-field (f) 125 (draw-field-background f) ; clear background, if any 126 (draw-field-border f) ; draw border, if any 127 (mapc 'draw-field (aggregate-field-subfields f)) ; draw subfields 128 (w-flush (window-w (zone-window (field-zone f)))) t) ; flush it out 129 130(defun init-aggregate-field (f) 131 (mapc 'init-field (aggregate-field-subfields f)) 132 (alter-aggregate-field f selection nil) t) 133 134(defun resize-aggregate-field (f box) 135 (alter-zone (field-zone f) box box)) 136 137(defun check-aggregate-field (f p) 138 (do ((subfields (aggregate-field-subfields f) ; go through subfields 139 (cdr subfields)) 140 (gotcha)) 141 ((or (null subfields) ; stop when no more 142 (setq gotcha (check-field (car subfields) p))) ; or when one is hit 143 (alter-aggregate-field f selection gotcha) ; remember which one 144 gotcha))) ; also return it 145 146;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147;;; remote fields 148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149;;; A remote field is a field which activates another field when hit. 150;;; Usually the remote field has some functional significance! 151 152(defstruct 153 (remote-field ; remote field 154 (:displace t) 155 (:list) 156 (:conc-name)) 157 (type 'remote-field) ; type = remote 158 (zone (make-zone)) ; bounding zone 159 (properties (list nil)) ; empty plist 160 (target) ; the actual target field 161 (point) ; x,y coords to pretend to use 162) 163 164(defvar remote-field-properties 165 `("remote-field-properties" 166 = ,field-properties 167 )) ; can use this as real plist for online documentation 168 169(defun draw-remote-field (f) 't) ; nothing to draw 170 171(defun init-remote-field (f) 't) ; nothing to initialize 172 173(defun resize-remote-field (f box) 174 (alter-zone (field-zone f) box box)) 175 176(defun check-remote-field (f p) 177 (check-field 178 (remote-field-target f) 179 (remote-field-point f))) ; return result of checking target 180 181;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182;;; button fields 183;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 185(defstruct 186 (button-field ; button field 187 (:displace t) 188 (:list) 189 (:conc-name)) 190 (type 'button-field) ; type = button 191 (zone (make-zone)) ; bounding zone 192 (properties 193 (list nil ; default properties 194 'fill-ground 'solid 195 'empty-ground 'solid 196 'border-colour W-CONTRAST 197 )) 198 (value nil) ; value 199) 200 201(defvar button-field-properties 202 `("button-field-properties" 203 = ,field-properties 204 )) ; can use this as real plist for online documentation 205 206(defun draw-button-field (f) 207 (draw-field-border f) 208 (cond ((button-field-value f) 209 (fill-field f)) 210 (t (empty-field f)))) 211 212(defun toggle-button-field (f) 213 (alter-button-field f value (not (button-field-value f))) 214 (clear-zone-interior (field-zone f) W-XOR)) 215 216(defun init-button-field (f) 217 (alter-button-field f value nil)) ; turn it off 218 219(defun resize-button-field (f box) 220 (alter-zone (field-zone f) box box)) 221 222(defun check-button-field (f p) 223 (toggle-button-field f) f) ; if we get here it's a hit -> return self 224 225;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 226;;; radio-button fields 227;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228;;; Named for the buttons on radios in which only one is "in" at a time. 229 230(defstruct 231 (radio-button-field ; radio-button field 232 (:displace t) 233 (:list) 234 (:conc-name)) 235 (type 'radio-button-field) ; type = radio-button 236 (zone (make-zone)) ; bounding zone 237 (properties (list nil)) ; empty plist 238 (subfields nil) ; individual buttons 239 (selection nil) ; which one last hit 240) 241 242(defvar radio-button-field-properties 243 `("radio-button-field-properties" 244 = ,aggregate-field-properties 245 )) ; can use this as real plist for online documentation 246 247(defun draw-radio-button-field (f) 248 (draw-aggregate-field f)) 249 250(defun init-radio-button-field (f) 251 (init-aggregate-field f)) 252 253(defun resize-radio-button-field (f box) 254 (alter-zone (field-zone f) box box)) 255 256(defun check-radio-button-field (f p) 257 (cond ((and (radio-button-field-selection f) ; if button previously sel'd 258 (button-field-value 259 (radio-button-field-selection f))) ; and it has a value 260 (toggle-field ; turn it off 261 (radio-button-field-selection f)))) 262 (check-aggregate-field f p) ; check individual buttons 263) ; this will turn back on if same one sel'd, and return it 264 265;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 266;;; text fields 267;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 269(defstruct 270 (text-field ; text field 271 (:displace t) 272 (:list) 273 (:conc-name)) 274 (type 'text-field) ; type = text 275 (zone (make-zone)) ; bounding zone 276 (properties 277 (list nil 278 'fill-ground 'solid 279 'empty-ground 'solid 280 'border-colour W-CONTRAST 281 'x-offset 5 ; offset from left 282 )) 283 (value nil) 284 (text '||) ; text of text 285) 286 287(defvar text-field-properties 288 `("text-field-properties" 289 x-offset (x_pixels) ; text offset from box ll, otherwise centred 290 y-offset (x_pixels) ; text offset from box ll, otherwise centred 291 + ,button-field-properties 292 )) ; can use this as real plist for online documentation 293 294(defun draw-text-field (f) 295 (draw-button-field f) 296 (w-flush (window-w (zone-window (field-zone f)))) ; guarantee text on top 297 (draw-text (text-field-text f))) 298 299(defun redraw-text-field (f) 300 (empty-field f) 301 (w-flush (window-w (zone-window (field-zone f)))) ; guarantee text on top 302 (draw-text (text-field-text f))) 303 304(defun init-text-field (f) ; position & position the text in the field 305 (let ((s (text-field-text f)) 306 (x-offset (get (field-properties f) 'x-offset)) ; x offset from ll 307 (y-offset (get (field-properties f) 'y-offset))); y offset from ll 308 (alter-text s 309 zone (make-zone ; ensure it has a zone 310 window (zone-window (field-zone f)) 311 box (box-interior (zone-box (field-zone f))))) 312 (format-text s) ; ensure text delta calculated 313 (cond ((null x-offset) ; x-offset specified? 314 (setq x-offset ; nope! centre it left-right 315 (/ (- (x (box-size (zone-box (field-zone f)))) 316 (x (text-delta s))) 317 2)))) 318 (cond ((null y-offset) ; y-offset specified? 319 (setq y-offset ; nope! centre it up-down 320 (/ (- (y (box-size (zone-box (field-zone f)))) 321 (font-x-height (look-font (text-look s)))) 322 2)))) 323 (alter-text s ; now position the text 324 offset (make-point x x-offset y y-offset)) 325 )) 326 327(defun resize-text-field (f box) ; position the text in the field 328 (alter-zone (field-zone f) box box) 329 (init-text-field f)) 330 331(defun check-text-field (f p) 332 (input-text-field f) f) ; if we get here it's a hit -> return self 333 334(defun input-text-field (f) 335 (alter-text (text-field-text f) 336 text '|| nn 0 kr 0 kl 0 delta (make-point x 0 y 0)) 337 (draw-text-field f) 338 (edit-text-field f (ll (zone-box (text-zone (text-field-text f)))))) 339 340(defun edit-text-field (f p) ; edit in middle of text field 341 (edit-text (text-field-text f) p) ; edit the text 342 (draw-field f)) ; redraw 343 344 345;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 346;;; prompt fields 347;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 348 349(defstruct 350 (prompt-field ; prompt field 351 (:displace t) 352 (:list) 353 (:conc-name)) 354 (type 'prompt-field) ; type = prompt 355 (zone (make-zone)) ; bounding zone 356 (properties 357 (list nil 'x-offset 0)) ; put it exactly where spec indicates. 358 (value nil) 359 (text '||) ; text of prompt 360) 361 362(defvar prompt-field-properties 363 `("prompt-field-properties" 364 = ,text-field-properties 365 )) ; can use this as real plist for online documentation 366 367(defun draw-prompt-field (f) 368 (draw-text-field f)) 369 370(defun init-prompt-field (f) 371 (init-text-field f)) 372 373(defun resize-prompt-field (f box) ; position the text in the field 374 (resize-text-field f box)) 375 376(defun check-prompt-field (f p) f) ; just return self 377 378;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 379;;; text-button fields 380;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 381;;; A text-button is a button tied to a text. 382;;; When the button is pressed, the text is input from the keyboard. 383;;; Zone could same as either the button (activation by button only) 384;;; or include both button & text (should then be adjacent) 385 386(defstruct 387 (text-button-field ; text-button field 388 (:displace t) 389 (:list) 390 (:conc-name)) 391 (type 'text-button-field) ; type = text-button 392 (zone (make-zone)) ; bounding zone 393 (properties (list nil)) ; empty plist 394 (button) ; button subfield 395 (text) ; text subfield 396) 397 398(defvar text-button-field-properties 399 `("text-button-field-properties" 400 = ,field-properties 401 )) ; can use this as real plist for online documentation 402 403(defun draw-text-button-field (f) 404 (draw-field (text-button-field-button f)) 405 (draw-text-field (text-button-field-text f))) 406 407(defun init-text-button-field (f) 408 (init-field (text-button-field-button f)) 409 (init-text-field (text-button-field-text f))) 410 411(defun resize-text-button-field (f box) 412 (alter-zone (field-zone f) box box)) 413 414(defun toggle-text-button-field (f) ; toggle only the button part 415 (cond ((button-field-value ; and only if non-nil 416 (text-button-field-button f)) 417 (toggle-button-field (text-button-field-button f))))) 418 419(defun check-text-button-field (f p) 420 (cond ((check-field (text-button-field-button f) p) 421 (input-text-field ; input from scratch 422 (text-button-field-text f))) ; get the data 423 (t (toggle-button-field ; must be pointing at text 424 (text-button-field-button f)) ; toggle only the button part 425 (edit-text-field 426 (text-button-field-text f) p)) ; edit the data 427 ) 428 (toggle-button-field ; toggle button back 429 (text-button-field-button f)) 430 (alter-button-field (text-button-field-button f) 431 value nil) ; keep aggregate from toggling again 432 f) ; return self 433 434;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 435;;; labelled button fields 436;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 437 438(defstruct 439 (labelled-button-field ; labelled button field 440 (:displace t) 441 (:list) 442 (:conc-name)) 443 (type 'labelled-button-field) ; type = labelled-button 444 (zone (make-zone)) ; bounding zone 445 (properties 446 (list nil 447 'fill-ground 'solid 448 'empty-ground 'solid 449 'border-colour W-CONTRAST 450 )) 451 (value nil) ; value 452 (text '||) ; label text 453) 454 455(defvar labelled-button-field-properties 456 `("labelled-button-field-properties" 457 = ,text-field-properties 458 )) ; can use this as real plist for online documentation 459 460(defun draw-labelled-button-field (f) 461 (draw-text-field f)) 462 463(defun init-labelled-button-field (f) 464 (init-text-field f)) 465 466(defun resize-labelled-button-field (f box) 467 (resize-text-field f box)) 468 469(defun check-labelled-button-field (f p) 470 (toggle-button-field f) f) ; if we get here it's a hit -> return self 471 472(defun toggle-labelled-button-field (f) 473 (toggle-button-field f)) 474 475;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 476;;; expanded-bitmap fields 477;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 478 479(defstruct 480 (expanded-bitmap-field ; expanded-bitmap field 481 (:displace t) 482 (:list) 483 (:conc-name)) 484 (type 'expanded-bitmap-field) ; type = expanded-bitmap 485 (zone (make-zone)) ; bounding zone 486 (properties (list nil)) ; empty plist 487 (subfields nil) ; individual bits 488 (selection nil) ; which one last hit 489 (nrows 1) 490 (ncols 1) 491) 492 493(defvar expanded-bitmap-field-properties 494 `("expanded-bitmap-field-properties" 495 = ,aggregate-field-properties 496 )) ; can use this as real plist for online documentation 497 498(defun draw-expanded-bitmap-field (f) 499 (draw-aggregate-field f)) 500 501(defun init-expanded-bitmap-field (f) 502 (let ((s (divide-points ; calculate x,y dimensions 503 (box-size (zone-box (field-zone f))) 504 (make-point 505 x (expanded-bitmap-field-ncols f) 506 y (expanded-bitmap-field-nrows f))))) 507 (do ((z (field-zone f)) 508 (r nil) 509 (x (x (ll (zone-box (field-zone f))))) 510 (y (y (ll (zone-box (field-zone f)))) 511 (+ y dy)) 512 (dx (x s)) 513 (dy (y s)) 514 (nc (expanded-bitmap-field-nrows f)) 515 (nr (expanded-bitmap-field-nrows f)) 516 (j 0 (1+ j))) 517 ((= j nr) (alter-aggregate-field f subfields (nreverse r)) 't) 518 (do ((x x (+ x dx)) 519 (p) 520 (i 0 (1+ i))) 521 ((= i nc)) ; create a row of buttons 522 (setq p (make-point x x y y)) 523 (setq r (xcons r (make-button-field zone (append z nil)))) 524 (alter-zone (field-zone (car r)) 525 box (make-box ll p ur (add-points p s))) 526 )))) 527 528(defun resize-expanded-bitmap-field (f box) 529 (alter-zone (field-zone f) box box) 530 (let ((s (divide-points ; calculate x,y dimensions 531 (box-size box) 532 (make-point 533 x (expanded-bitmap-field-ncols f) 534 y (expanded-bitmap-field-nrows f))))) 535 (do ((z (field-zone f)) 536 (r (expanded-bitmap-field-subfields f)) 537 (x (x (ll box))) 538 (y (y (ll box)) (+ y dy)) 539 (dx (x s)) 540 (dy (y s)) 541 (nc (expanded-bitmap-field-nrows f)) 542 (nr (expanded-bitmap-field-nrows f)) 543 (j 0 (1+ j))) 544 ((= j nr) t) 545 (do ((x x (+ x dx)) 546 (p) 547 (i 0 (1+ i))) 548 ((= i nc)) ; create a row of buttons 549 (setq p (make-point x x y y)) 550 (resize-button-field (car r) 551 (make-box ll p ur (add-points p s))) 552 (setq r (cdr r)) 553 )))) 554 555(defun check-expanded-bitmap-field (f p) 556 (check-aggregate-field f p)) ; if we get here it's a hit -> check subfields 557 558;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 559;;; utilities.l ; 560;;; ; 561;;; These macros and functions are thought to be generally useful. ; 562;;; ; 563;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 564;;; Macros ; 565;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 566 567(declare 568 (macros t) ; keep macros around after compiling 569 (localf pairify* pairifyq* split2* sublist*) 570 (special compiled-with-help)) 571 572(defmacro copy-all-but-last (ls) ; copy all but last member of list 573 `(let ((ls ,ls)) 574 (firstn (1- (length ls)) 575 ls))) 576 577(defmacro all-but-last (ls) ; destructive all-but-last 578 `(let ((ls ,ls)) 579 (cond ((cdr ls) 580 (rplacd (nthcdr (- (length ls) 2) ls) nil) 581 ls)))) 582 583(def hex (macro (arglist) ; hex to integer conversion 584 `(car (hex-to-int ',(cdr arglist))))) 585 586;;; define properties on symbols for use by help routines 587 588(defmacro def-usage (fun usage returns group) 589 (cond (compiled-with-help ; flag controls help generation 590 `(progn (putprop ,fun ,usage 'fcn-usage) 591 (putprop ,fun ,returns 'fcn-returns) 592 (putprop ,fun (nconc ,group (ncons ,fun)) 'fcn-group))))) 593(defvar compiled-with-help t) ; unless otherwise notified 594 595;;; (letenv 'l_bind_plist g_expr1 ... g_exprn) -- pair-list form of "let" 596;;; Lambda-binds pairs of "binding-objects" (see description of let,let*), 597;;; at RUN TIME, then evaluates g_expr1 to g_exprn, returning g_exprn. eg: 598;;; (apply 'letenv '(letenv '(a 1 b (+ c d)) 599;;; (e)(f g))) 600;-> (eval (cons 'let (cons (pairify '(a 1 b (+ c d))) 601;;; '((e) (f g))))) 602;-> (let ((a 1) (b (+ c d))) 603;;; (e) (f g)) 604(def letenv 605 (macro (x) 606 `(eval (cons 'let 607 (cons 608 (pairify ,(cadr x)) ; plist of binding objects 609 ',(cddr x)))))) ; exprs to be eval'ed 610 611(def letenvq ; letenv, quoted binding objects 612 (macro (x) 613 `(eval (cons 'let 614 (cons 615 (pairifyq ,(cadr x)) ; plist of binding objects 616 ',(cddr x)))))) ; exprs to be eval'ed 617 618(defmacro mergecar (L1 L2 cmpfn) ; merge, comparing by car's 619 `(merge ,L1 ,L2 '(lambda (e1 e2) ; (like sortcar) 620 (funcall ,cmpfn (car e1) (car e2))))) 621 622;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 623;;; Functions ; 624;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 625;;; (all-but-last l_items) -- copy all but last list element 626 627;(defun all-but-last (ls) 628; (cond ((cdr ls) (cons (car ls) (all-but-last (cdr ls)))))) 629 630;;; (alphap sx_char) 631(defun alphap (char) ; is char alphabetic? 632 (cond ((symbolp char) 633 (setq char (car (exploden char))))) 634 (and (fixp char) 635 (or (and (>& char #.(1- #/A)) 636 (<& char #.(1+ #/Z))) 637 (and (>& char #.(1- #/a)) 638 (<& char #.(1+ #/z)))))) 639 640;;; (alphanumericp sx_char) 641(defun alphanumericp (char) ; is char alphabetic or numeric? 642 (cond ((symbolp char) 643 (setq char (car (exploden char))))) 644 (and (fixp char) 645 (or (and (>& char #.(1- #/A)) 646 (<& char #.(1+ #/Z))) 647 (and (>& char #.(1- #/a)) 648 (<& char #.(1+ #/z))) 649 (and (>& char #.(1- #/0)) 650 (<& char #.(1+ #/9)))))) 651 652;;; (assqonc 'g_key 'g_val 'l_al) 653;;; like (cond ((assq key alist)) 654;;; (t (cadr (rplacd (last alist) 655;;; (ncons (cons key val)))))) 656(defun assqonc (key val al) ; tack (key.val) on end if not found 657 (do ((al al (cdr al))) 658 ((or (eq key (caar al)) 659 (and (null (cdr al)) 660 (rplacd al (setq al (ncons (cons key val)))))) 661 (car al)))) 662 663;;; (cartesian l_xset l_yset) 664(defun cartesian (xset yset) ; cartesian product of elements 665 (mapcan 666 '(lambda (x) 667 (mapcar 668 '(lambda (y) (cons x y)) 669 yset)) 670 xset)) 671 672(defun concat-pairs (sb-list) ; concat neighbouring symbol pairs 673 (do ((s1 (car sb-list) s2) 674 (s2 (cadr sb-list) (car sbs-left)) 675 (sbs-left (cddr sb-list) (cdr sbs-left)) 676 (result nil (cons (concat s1 s2) result))) 677 ((null s2) (nreverse result)))) 678;;; (detach l) 679;;; Detaches (and throws away) first element of list (converse of attach) 680;;; keeping the same initial list cell. 681(defun detach (l) 682 (cond (l (rplacd l (cddr (rplaca l (cadr l))))))) 683 684;;; (distribute x_Q x_N) 685;;; returns list of the form: (1 1 1 0 0 0 0 1 1) or (3 2 2 2 3) 686;;; i.e. a list of length <N> containing quantity <Q> evenly distributed 687;;; with the excess <Q mod N> surrounding a "core" of <Q div N>'s 688;;; Useful (?) for padding spaces in line adjustment. 689;(defun distribute (Q N) ; this one only does 1's and 0's 690; (cond ((signp le Q) (duplicate N 0)) 691; ((eq Q 1) (pad 0 N '(1))) 692; (t (cons 1 (nconc 693; (distribute (- Q 2) (- N 2)) 694; '(1)))))) 695 696(defun distribute (Q N) ; distribute quantity Q among N elements 697 (let ((tmp (Divide (abs Q) N))) 698 (setq tmp (distribute0 (cadr tmp) N (car tmp) (1+ (car tmp)))) 699 (cond ((signp ge Q) tmp) 700 (t (mapcar 'minus tmp))))) 701 702(defun distribute0 (Q N X X1) 703 (cond ((signp le Q) (duplicate N X)) 704 ((eq Q 1) (pad X N (ncons X1))) 705 (t (cons X1 (nconc 706 (distribute0 (- Q 2) (- N 2) X X1) 707 (ncons X1)))))) 708 709;;; (duplicate x_n g_object) 710;;; Returns list of n copies of object (nil if n <= 0) 711(defun duplicate (n object) 712 (do ((res nil (cons object res)) 713 (i n (1- i))) 714 ((signp le i) res))) 715 716(defun e0 (in out) ; simulate binary insertion procedure 717 (let ((lin (length in)) 718 (lout (length out))) 719 (cond ((> lin lout) 720 (e0 721 (nthcdr lout in) 722 (mapcan 'list out (firstn lout in)))) 723 (t (nconc (mapcan 'list (firstn lin out) in) 724 (nthcdr lin out)))))) 725 726(defun e (files) ; determine file permutation for emacs insert 727 (let ((i (e0 (cdr (iota (length files))) '(0))) 728 (f (append files nil))) 729 (mapc '(lambda (f-index f-name) 730 (rplaca (nthcdr f-index f) f-name)) 731 i files) 732 f)) 733 734;;; (firstn x_n l_listarg) 735(defun firstn (n l) ; copy first <n> elements of list 736 (do ((n n (1- n)) 737 (l l (cdr l)) 738 (r nil)) 739 ((not (plusp n)) (nreverse r)) ; <nil> if n=0 or -ve 740 (setq r (cons (car l) r)))) 741 742;;; (iota x_n) 743;;; APL index generator (0,1,2,...,<n>-1) 744(defun iota (n) 745 (do ((i (1- n) (1- i)) 746 (res nil)) 747 ((minusp i) res) 748 (setq res (cons i res)))) 749 750(defun hex-to-int (numlist) ; eg. (hex-to-int '(12b3 120 8b)) 751 (cond 752 (numlist ; terminate recursion on null numlist 753 (cons 754 (apply '+ 755 (maplist 756 '(lambda (digits) 757 (lsh 758 (get '(hex |0| 0 |1| 1 |2| 2 |3| 3 759 |4| 4 |5| 5 |6| 6 |7| 7 760 |8| 8 |9| 9 a 10 b 11 761 c 12 d 13 e 14 f 15) 762 (car digits)) 763 (lsh (1- (length digits)) 2))) 764 (explodec (car numlist)))) 765 (hex-to-int (cdr numlist)))))) 766 767;;; (lctouc g_expr) 768;;; Returns s-expression formed by translating lower-case alphabetic 769;;; characters in <expr> to their upper-case equivalents. 770;;; Operates by imploding the translated characters, in the case of a 771;;; symbol or string, or by recursively calling on members of a list. 772;;; Other object types are returned unchanged. 773(defun lctouc (expr) 774 (cond 775 ((dtpr expr) (mapcar 'uctolc expr)) 776 ((or (symbolp expr) (stringp expr)) 777 (implode 778 (mapcar 779 '(lambda (ch) 780 (cond ((alphap ch) ; and-out lower-case bit 781 (boole 1 #.(1- (1- #/a)) ch)) (t ch))) 782 (exploden expr)))) 783 (t expr))) 784 785;;; (log2 x_n) 786(defun log2 (n) ; log base 2 (truncated) 787 (do ((n (lsh n -1) (lsh n -1)) 788 (p 0 (1+ p))) 789 ((zerop n) p))) 790 791;;; (lowerp sx_char) 792(defun lowerp (char) ; is char lower-case alphabetic? 793 (cond ((symbolp char) 794 (setq char (car (exploden char))))) 795 (and (fixp char) 796 (or (and (> char #.(1- #/a)) 797 (< char #.(1+ #/z)))))) 798 799;;; (numericp sx_char) 800;;; returns t if char is numeric, otherwise nil 801(defun numericp (char) 802 (cond ((symbolp char)(setq char (car (exploden char))))) 803 (and (fixp char) 804 (and (> char #.(1- #/0)) 805 (< char #.(1+ #/9))))) 806 807;;; (pad g_item x_n l_list) 808;;; Returns <list> padded with copies of <item> to length <n> 809(defun pad (item n list) 810 (append list (duplicate (- n (length list)) item))) 811 812;;; (pairify l_items) ; make a-list from alternating elements 813(defun pairify (pl) 814 (pairify* nil pl)) 815(defun pairify* (rs pl) ; tail-recursive local fun 816 (cond (pl (pairify* (cons (list (car pl) (cadr pl)) rs) 817 (cddr pl))) 818 (t (nreverse rs)))) 819 820;;; (pairifyq l_items) ; make a-list from alternating elements 821(defun pairifyq (pl) ; with each second element quoted 822 (pairifyq* nil pl)) 823(defun pairifyq* (rs pl) ; tail-recursive local fun 824 (cond (pl (pairifyq* (cons (list (car pl) (kwote (cadr pl))) rs) 825 (cddr pl))) 826 (t (nreverse rs)))) 827 828;;; (penultimate l_items) ; cdr down to next-to-last list element 829(defun penultimate (ls) 830 (cond ((cddr ls) (penultimate (cdr ls))) 831 (t ls))) 832 833;;; (split2 l_L) 834;;; Splits list <L> into two (new) second-level lists 835(defun split2* (L tc1 tc2) 836 (cond ((null L) (list (nreverse tc1) (nreverse tc2))) 837 (t (split2* (cddr L) 838 (cons (car L) tc1) 839 (cons (cadr L) tc2))))) 840 841(defun split2 (L) 842 (split2* L nil nil)) 843 844;;; (sublist L IL) 845;;; Splits list <L> (destructively) into (length IL) sub-lists. 846;;; IL is a list of starting indices, base zero, should be unique positive 847;;; fixnums in ascending order, and shouldn't exceed the length of L. 848;;; Each resulting sublist <i> begins with (nthcdr (nth <i> IL) L) 849(defun sublist (L IL) 850 (sublist* 0 nil (cons nil L) IL)) 851(defun sublist* (I R L IL) ; tail-recursion function 852 (cond ((and L IL) 853 (cond 854 ((<& I (car IL)) 855 (sublist* (1+ I) R (cdr L) IL)) 856 (t (sublist* (1+ I) 857 (cons (cdr L) R) 858 (prog1 (cdr L) (rplacd L nil)) 859 (cdr IL))))) 860 (t (nreverse R)))) 861 862(defun try-fun (fun l-arg) ; try function on each arg until non-nil 863 (cond ((funcall fun (car l-arg))) 864 (l-arg (try-fun fun (cdr l-arg))))) 865 866;;; (uctolc g_expr) 867;;; Returns s-expression formed by translating upper-case alphabetic 868;;; characters in <expr> to their lower-case equivalents. 869;;; Operates by imploding the translated characters, in the case of a 870;;; symbol or string, or by recursively calling on members of a list. 871;;; Other object types are returned unchanged. 872(defun uctolc (expr) 873 (cond 874 ((dtpr expr) (mapcar 'uctolc expr)) 875 ((or (symbolp expr) (stringp expr)) 876 (implode 877 (mapcar 878 '(lambda (ch) 879 (cond ((alphap ch) ; or-in lower-case bit 880 (boole 7 #.(1- #/a) ch)) (t ch))) 881 (exploden expr)))) 882 (t expr))) 883 884;;; (unique a l) -- Scan <l> for an element <e> "equal" to <a>. 885;;; If found, return <e>. Otherwise nconc <a> onto <l>; return <a>. 886(defun unique (a l) ; ensure unique in list 887 (car 888 (do ((cdr_ul l (cdr ul)) 889 (ul l cdr_ul)) 890 ((null cdr_ul) (rplacd ul (ncons a))) 891 (cond ((equal a (car cdr_ul)) (return cdr_ul)))))) 892 893;;; (upperp sx_char) 894(defun upperp (char) ; is char upper-case alphabetic? 895 (cond ((symbolp char) 896 (setq char (car (exploden char))))) 897 (and (fixp char) 898 (or (and (> char #.(1- #/A)) 899 (< char #.(1+ #/Z)))))) 900;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 901;;; zone.l -- data structures and routines for concrete window zones 902;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 903;;; a "point" is a pair of integer x,y coordinates 904;;; a "box" is a pair of points defining lower left and upper right corners 905;;; a "position" is a point coupled with a window 906;;; a "zone" is a box coupled with a window 907;;; a "window" is a machine, integer window id and, for compatibility 908;;; with the toolbox, an integer toolbox window pointer 909;;; a "machine" is a name coupled with the j-process-id's of resident servers 910;;; The basic idea is to define a notion of a concrete position for a 911;;; display object, that can be incorporated into the object data structure. 912;;; Higher levels of software can use the objects without explicit reference 913;;; to server processes, windows and machines. 914;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 915 916(declare 917 (specials t) ; global vars not local to this file 918 (macros t)) ; compile macros as well 919 920(eval-when (compile) ; trust to higher level for eval & load 921 (load 'utilities) ; utility functions 922 (load 'constants) ; common constants for window toolbox 923; (load 'shape) ; arbitrarily shaped screen areas 924) 925 926(defstruct 927 (position ; a concrete display position 928 (:displace t) 929 (:list) 930 (:conc-name)) 931 (window (make-window)) ; concrete window 932 (point (make-point)) ; actual x, y coordinates 933) 934 935(defstruct 936 (zone ; a concrete display zone 937 (:displace t) 938 (:list) 939 (:conc-name)) 940 (window (make-window)) ; concrete window 941 (box (make-box)) ; bounding box of zone 942 (colour W-BACKGROUND) ; colour (for scrolling etc) 943 shape 944) 945 946(defstruct 947 (window ; concrete window 948 (:displace t) 949 (:list) 950 (:conc-name)) 951 (id 0) ; integer window id 952 (machine (make-machine)) ; machine (workstation) 953 (w 0) ; toolbox window structure pointer 954) 955 956(defstruct 957 (machine ; machine (workstation) 958 (:displace t) 959 (:list) 960 (:conc-name)) 961 (name 'unknown-machine) ; machine name 962 (servers nil) ; plist of server processes living there 963) 964 965;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 966;;; manipulation routines 967;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 968 969(defun add-points (p q) ; vector sum (x1+x2) (y1+y2) 970 (make-point 971 x (+ (x p) (x q)) 972 y (+ (y p) (y q)))) 973 974(defun subtract-points (p q) ; vector subtract (x1-x2) (y1-y2) 975 (make-point 976 x (- (x p) (x q)) 977 y (- (y p) (y q)))) 978 979(defun multiply-points (p q) ; vector multiply (x1*x2) (y1*y2) 980 (make-point 981 x (* (x p) (x q)) 982 y (* (y p) (y q)))) 983 984(defun divide-points (p q) ; vector division (x1-x2) (y1-y2) 985 (make-point 986 x (/ (x p) (x q)) 987 y (/ (y p) (y q)))) 988 989(defun move-point (p q) ; move point p to point q 990 (alter-point p 991 x (x q) 992 y (y q)) 993 t) ; return true 994 995(defun box-size (b) ; size of box = ur - ll 996 (subtract-points (ur b) (ll b))) 997 998(defun box-interior (b) ; return box just inside this box dimensions 999 (make-box 1000 ll (add-points (ll b) '(1 1)) 1001 ur (subtract-points (ur b) '(1 1)))) 1002 1003(defun move-box (b p) ; move box b to point p (lower-left) 1004 (let ((size (box-size b))) 1005 (alter-box b 1006 ll p 1007 ur (add-points p size)) 1008 t)) ; return true 1009 1010(defun point-in-box (p b) ; is point p in box b? (including boundary) 1011 (and (>= (x p) (x (ll b))) 1012 (<= (x p) (x (ur b))) 1013 (>= (y p) (y (ll b))) 1014 (<= (y p) (y (ur b))) 1015 )) 1016 1017(defun point-in-box-interior (p b) ; is point p in box b? (excluding boundary) 1018 (and (> (x p) (x (ll b))) 1019 (< (x p) (x (ur b))) 1020 (> (y p) (y (ll b))) 1021 (< (y p) (y (ur b))) 1022 )) 1023 1024(defun init-window (w) ; fill in "window" structure 1025 (let ; presuming window-w predefined 1026 ((m (j-machine-name (w-get-manager (window-w w))))) 1027 (alter-window w id (w-get-id (window-w w))) 1028 (cond ((not (window-machine w)) 1029 (alter-window w machine (make-machine name m))) 1030 (t (alter-machine (window-machine w) name m))) 1031 (init-machine (window-machine w)) ; also fill in machine structure 1032 t)) ; return true 1033 1034(defun init-machine (m) ; fill in "machine" structure 1035 (cond ; presuming machine-name predefined 1036 ((null (machine-servers m)) ; if no plist, make new one 1037 (alter-machine m servers (ncons 'servers:)))) 1038 (mapc '(lambda (pname) ; for each expected server name 1039 (let 1040 ((pid (j-search-machine-e jipc-error-code 1041 (machine-name m) 1042 pname))) ; try to find one on that machine 1043 (cond ((j-same-process pid J-NO-PROCESS) 1044 (putprop (machine-servers m) nil pname)) ; failed! use nil 1045 (t (putprop (machine-servers m) pid pname))))) ; success! 1046 EXPECTED-WORKSTATION-SERVERS) ; global list of process names 1047 t) ; return true 1048 1049(defvar EXPECTED-WORKSTATION-SERVERS ; global list of process names 1050 '(window_manager creator savemem 1051 text-composer)) ; usually want at least these 1052 1053(defun window-box (w) ; box fills entire window 1054 (let ((w-size (w-get-window-size (window-w w)))) 1055 (make-box 1056 ll (make-point x 0 y 0) 1057 ur (make-point x (car w-size) y (cadr w-size))) 1058 )) 1059 1060(defun clear-zone (z colour) ; clear zone (including boundaries) 1061 (let ((b (box-size (zone-box z)))) 1062 (w-clear-rectangle (window-w (zone-window z)) 1063 (x (ll (zone-box z))) (y (ll (zone-box z))) 1064 (1+ (x b)) (1+ (y b)) 1065 colour))) 1066 1067(defun clear-zone-interior (z colour) ; clear zone (excluding boundaries) 1068 (let ((b (box-size (zone-box z)))) 1069 (w-clear-rectangle (window-w (zone-window z)) 1070 (1+ (x (ll (zone-box z)))) (1+ (y (ll (zone-box z)))) 1071 (1- (x b)) (1- (y b)) 1072 colour))) 1073 1074(defun pattern-zone (z pattern) ; pattern zone (including boundaries) 1075 (let ((b (zone-box z))) 1076 (w-pattern-rectangle (window-w (zone-window z)) 1077 (x (ll b)) (y (ll b)) 1078 (1+ (x (ur b))) (1+ (y (ur b))) pattern) 1079 )) 1080 1081(defun pattern-zone-interior (z pattern) ; pattern zone (excluding boundaries) 1082 (let ((b (box-size (zone-box z)))) 1083 (w-pattern-rectangle (window-w (zone-window z)) 1084 (1+ (x (ll (zone-box z)))) (1+ (y (ll (zone-box z)))) 1085 (1- (x b)) (1- (y b)) pattern) 1086 )) 1087 1088(defun draw-zone-outline (z colour) ; draw zone boundaries 1089 (let* ((w (window-w (zone-window z))) 1090 (b (zone-box z)) 1091 (ll (ll b)) 1092 (ur (ur b))) 1093 (w-draw-vector w (x ll) (y ll) (x ll) (y ur) colour) 1094 (w-draw-vector w (x ll) (y ur) (x ur) (y ur) colour) 1095 (w-draw-vector w (x ur) (y ur) (x ur) (y ll) colour) 1096 (w-draw-vector w (x ur) (y ll) (x ll) (y ll) colour) 1097 )) 1098;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1099;;; font.l -- font manipulation 1100;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1101 1102(eval-when (compile) 1103 (load 'utilities) 1104 (load 'constants)) 1105 1106(defvar -installed-fonts nil) ; list of installed fonts 1107 1108(defstruct 1109 (font ; font structure 1110 (:displace t) 1111 (:list) 1112 (:conc-name)) 1113 (name 'standard) 1114 (size 8) 1115 (body 8) 1116 (cap-height 7) 1117 (x-height 5) 1118 (fixed-width 5) 1119 (first 0) 1120 (last 127) 1121 glyph ; the actual characters 1122) 1123 1124(defstruct 1125 (glyph ; glyph structure 1126 (:displace t) 1127 (:list) 1128 (:conc-name)) 1129 code 1130 width 1131 (bytes (byte-block 32)) ; the actual bitmap 1132) 1133 1134;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1135;;; font manipulation routines 1136;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1137 1138(defun read-font (family size path) 1139 (let ((p (infile path)) ; open file 1140 (x (new-vectori-long 2)) 1141 (f nil)) 1142 (setq f (make-font 1143 name family 1144 size (tyi p) 1145 body (tyi p) 1146 cap-height (tyi p) 1147 x-height (tyi p) 1148 fixed-width (tyi p) 1149 first (prog1 (tyi p) (tyi p)) 1150 last (prog1 (tyi p) (tyi p)))) 1151 (alter-font f glyph 1152 (do ((i (font-first f) (1+ i)) 1153 (r (ncons nil)) 1154 (g)) 1155 ((> i (font-last f)) (car r)) 1156 (setq g (make-glyph code i)) ; allocate char 1157 (do ((j 0 (1+ j))) ; read bitmap 1158 ((> j 31)) 1159 (vseti-byte (glyph-bytes g) j (tyi p))) 1160 (alter-glyph g width (tyi p)) ; read width 1161 (setq r (tconc r g)) 1162 )) 1163 (close p) ; close file 1164 1165 (rplacd ; install font 1166 (cond ((assoc (list (font-name f) (font-size f)) -installed-fonts)) 1167 (t (car (setq -installed-fonts 1168 (cons (ncons (list (font-name f) (font-size f))) 1169 -installed-fonts))))) 1170 f) 1171 f)) ; return font 1172 1173(def-usage 'read-font '(|'st_family| |'x_size| |'st_path|) 1174 'l_font-descriptor 1175 (setq fcn-group (ncons "Font Manipulation:"))) 1176 1177(defun install-font (f) 1178 (cdr 1179 (rplacd ; install font 1180 (cond ((assoc (list (font-name f) (font-size f)) -installed-fonts)) 1181 (t (car (setq -installed-fonts 1182 (cons (ncons (list (font-name f) (font-size f))) 1183 -installed-fonts))))) 1184 f))) 1185 1186(defun find-font (family size) ; always "finds" one even if dummy 1187 (cond ((cdr (assoc (list family size) -installed-fonts))) 1188 (t (install-font (make-font name family size size))))) 1189 1190(def-usage 'find-font 1191 '(|'st_family| |'x_size|) 1192 'l_font-descriptor 1193 fcn-group) 1194 1195(defun create-font (driver font) 1196 (j-send-se-list driver 1197 (list 'make-font 1198 (font-name font) 1199 (font-size font) 1200 (font-body font) 1201 (font-cap-height font) 1202 (font-x-height font) 1203 (font-fixed-width font) 1204 (font-first font) 1205 (font-last font)))) 1206 1207(defun download-glyph (driver font glyph) 1208 (j-put-items 1209 `((J-STRING set-glyph) 1210 (J-STRING ,(font-name font)) 1211 (J-INT ,(font-size font)) 1212 (J-INT ,(glyph-code glyph)) 1213 (J-INT ,(glyph-width glyph)) 1214 (J-BLOCK ,(glyph-bytes glyph)))) 1215 (j-send driver)) 1216 1217(defun download-font (driver font) 1218 (do ((g (font-glyph font)) 1219 (font-size (font-size font))) 1220 ((null g)) 1221 (j-put-items 1222 `((J-STRING set-glyph) 1223 (J-STRING ,(font-name font)) 1224 (J-INT ,font-size))) 1225 (do ((gg g (cdr gg))) 1226 ((or (null gg) (j-put-items 1227 `((J-INT ,(glyph-code (car gg))) 1228 (J-INT ,(glyph-width (car gg))) 1229 (J-BLOCK 1230 ,(glyph-bytes (car gg)) 1231 ,(+ font-size font-size))))) 1232 (setq g gg))) ; when buffer full, save remainder 1233 (j-send driver) 1234 (cond ((eq J-STRING (j-next-item-type)) 1235 (j-gets j-comm-string 128) ; skip past message string 1236 (cond ((eq J-INT (j-next-item-type))(patom (j-geti))(terpr))))) 1237 )) 1238 1239(def-usage 'download-font 1240 '(|'x_process-id| |'l_font-descriptor|) 1241 't 1242 fcn-group) 1243 1244(defun read-create-download-font (driver family size path) 1245 (let ((f (read-font family size path))) 1246 (create-font driver f) 1247 (download-font driver f) 1248 f)) 1249 1250(def-usage 'read-create-download-font 1251 '(|'x_process-id| |'st_family| |'x_size| |'st_path|) 1252 'l_font-descriptor 1253 fcn-group) 1254 1255(defun font-depth (f) 1256 (- (font-body f) (font-cap-height f))) 1257 1258(defun font-height (f) 1259 (font-cap-height f)) 1260 1261(defun get-font-list (sc) ; arg is string-composer or font-server pid 1262 (j-send-se sc 'get-font-list) 1263 (pairify (mapcar 1264 '(lambda (x) 1265 (cond ((stringp (cadr x)) (concat (cadr x))) 1266 (t (cadr x)))) 1267 (j-get-items)))) 1268 1269(defun get-all-font-info (sc) ; arg is string-composer or font-server pid 1270 (mapc '(lambda (f) 1271 (rplacd (apply 'find-font f) 1272 (cdr (progn 1273 (j-send-se-list sc (cons 'get-font-info f)) 1274 (mapcar 'cadr (j-get-items)))))) 1275 (get-font-list sc))) 1276;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1277;;; text.l -- fancy text strings 1278;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1279 1280(declare 1281 (specials t) 1282 (macros t)) 1283 1284(eval-when (compile) 1285 (load 'utilities) 1286 (load 'constants) 1287 (load 'zone) 1288 (load 'font) 1289 (load 'look)) 1290 1291(defstruct 1292 (text ; text structure 1293 (:displace t) 1294 (:list) 1295 (:conc-name)) 1296 (text '||) ; the text to draw 1297 (look (make-look)) ; what style to draw it in 1298 (kl 0) ; (starting) left kerning mask 1299 (zone (make-zone)) ; specific window, clipping box 1300 (offset (make-point)) ; offset of start point from zone ll 1301 (kr 0) ; (final) right kerning mask 1302 (delta (make-point)) ; change in (x,y) relative to start point 1303 (nn -1) ; char count 1304) 1305 1306;;; NOTE: clipping box of ((0 0) (-1 -1)) uses window boundaries 1307 1308(defun text-width (s) ; presumes non-rotated 1309 (x (text-delta s))) 1310 1311(defun text-box (s) ; presumes non-rotated 1312 (make-box 1313 ll (subtract-points 1314 (text-start-point s) 1315 (make-point x 0 y (font-depth (look-font (text-look s))))) 1316 ur (add-points 1317 (text-end-point s) 1318 (make-point x 0 y (font-height (look-font (text-look s))))))) 1319 1320(defun text-start-point (s) 1321 (add-points 1322 (ll (zone-box (text-zone s))) 1323 (text-offset s))) 1324 1325(defun text-end-point (s) 1326 (add-points 1327 (text-start-point s) 1328 (text-delta s))) 1329 1330(defun text-x (s) ; x coord of start of text object 1331 (+ (x (ll (zone-box (text-zone s)))) 1332 (x (text-offset s)))) 1333 1334(defun text-y (s) ; y coord of start of text object 1335 (+ (y (ll (zone-box (text-zone s)))) 1336 (y (text-offset s)))) 1337 1338(defun text-xx (s) ; x coord of end of text object 1339 (+ (x (ll (zone-box (text-zone s)))) 1340 (x (text-offset s)) 1341 (x (text-delta s)))) 1342 1343(defun text-yy (s) ; y coord of end of text object 1344 (+ (y (ll (zone-box (text-zone s)))) 1345 (y (text-offset s)) 1346 (y (text-delta s)))) 1347 1348(defun move-text (s p) ; move s to new x,y 1349 (alter-text s 1350 offset (subtract-points p (ll (zone-box (text-zone s)))))) 1351 1352(defun draw-text (s) ; quietly draw text, clipping to zone box 1353 (let (((x y) (text-start-point s)) 1354 (l (text-look s))) 1355 (j-put-items 1356 `((J-STRING compose) 1357 (J-INT ,(window-id (zone-window (text-zone s)))) 1358 (J-STRING ,(text-text s)) 1359 (J-STRING ,(font-name (look-font l))) 1360 (J-INT ,(font-size (look-font l))) 1361 (J-INT ,(boole 7 (look-mode l) QUIET)) 1362 (J-INT ,(look-colour l)) 1363 (J-INT ,(look-gap l)) 1364 (J-INT ,(look-ul l)) 1365 (J-INT ,(text-kl s)) 1366 (J-INT ,x) 1367 (J-INT ,y) 1368 (J-INT ,(x (cond 1369 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1370 (ur (zone-box (text-zone s)))) 1371 (t (ll (zone-box (text-zone s))))))) 1372 (J-INT ,(y (cond 1373 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1374 (ur (zone-box (text-zone s)))) 1375 (t (ll (zone-box (text-zone s))))))) 1376 (J-INT ,(text-nn s)) 1377 )) 1378 (j-send (get (machine-servers 1379 (window-machine 1380 (zone-window 1381 (text-zone s)))) 1382 'text-composer)) 1383 )) 1384 1385(defun undraw-text (s) ; quietly undraw text, clipping to zone box 1386 (let (((x y) (text-start-point s)) 1387 (l (text-look s))) 1388 (j-put-items 1389 `((J-STRING compose) 1390 (J-INT ,(window-id (zone-window (text-zone s)))) 1391 (J-STRING ,(text-text s)) 1392 (J-STRING ,(font-name (look-font l))) 1393 (J-INT ,(font-size (look-font l))) 1394 (J-INT ,(boole 7 OVERSTRIKE QUIET (look-mode l))) 1395 (J-INT ,(inverse-colour (look-colour l))) 1396 (J-INT ,(look-gap l)) 1397 (J-INT ,(look-ul l)) 1398 (J-INT ,(text-kl s)) 1399 (J-INT ,x) 1400 (J-INT ,y) 1401 (J-INT ,(x (cond 1402 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1403 (ur (zone-box (text-zone s)))) 1404 (t (ll (zone-box (text-zone s))))))) 1405 (J-INT ,(y (cond 1406 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1407 (ur (zone-box (text-zone s)))) 1408 (t (ll (zone-box (text-zone s))))))) 1409 (J-INT ,(text-nn s)) 1410 )) 1411 (j-send (get (machine-servers 1412 (window-machine 1413 (zone-window 1414 (text-zone s)))) 1415 'text-composer)) 1416 )) 1417 1418(defun format-text (s) ; format text without drawing or clipping 1419 (let ((memop (symbolp (text-text s))) ; can only memoize symbols 1420 (k) (p) (q) (l (text-look s))) 1421 (cond 1422 (memop ; are we memoizing? yes! 1423 (setq k (unique-look-id l)) ; key based on look 1424 (setq p (get (text-text s) k)) ; alist found on plist 1425 (setq q (assoc (text-kl s) p)))) ; entry based on kl 1426 (cond 1427 (q (alter-text s ; if info found 1428 kr (cadr q) ; record result 1429 delta (caddr q) ; then return 1430 nn (cadddr q))) 1431 (t ; otherwise compute data 1432 (j-put-items 1433 `((J-STRING compose) 1434 (J-INT 0) ; no window needed 1435 (J-STRING ,(text-text s)) 1436 (J-STRING ,(font-name (look-font l))) 1437 (J-INT ,(font-size (look-font l))) 1438 (J-INT ,(boole 7 NO-DRAW (look-mode l))) 1439 (J-INT ,(look-colour l)) 1440 (J-INT ,(look-gap l)) 1441 (J-INT ,(look-ul l)) 1442 (J-INT ,(text-kl s)) 1443 (J-INT 0) ; starting point 0 0 1444 (J-INT 0) 1445 (J-INT -1) ; no clipping 1446 (J-INT -1) 1447 (J-INT -1) 1448 )) 1449 (j-send (get (machine-servers 1450 (window-machine 1451 (zone-window 1452 (text-zone s)))) 1453 'text-composer)) 1454 (let ((kr (j-geti)) ; now record result 1455 (xx (j-geti)) 1456 (yy (j-geti)) 1457 (nn (j-geti))) 1458 (alter-text s 1459 kr kr 1460 delta (make-point x xx y yy) 1461 nn nn) 1462 (cond (memop ; memoize if req'd 1463 (cond (p (nconc p 1464 (ncons (list (text-kl s) kr 1465 (text-delta s) nn)))) 1466 (t (putprop (text-text s) 1467 (ncons (list (text-kl s) kr 1468 (text-delta s) nn)) 1469 k)))) 1470 )) 1471 )) 1472 't)) ; always return t 1473 1474(defun scan-text (s p) ; scan text s for point p, return (kr delta nn) 1475 (let (((x y) (text-start-point s)) ; inside: check text 1476 (l (text-look s))) 1477 (j-put-items 1478 `((J-STRING compose) 1479 (J-INT 0) 1480 (J-STRING ,(text-text s)) 1481 (J-STRING ,(font-name (look-font l))) 1482 (J-INT ,(font-size (look-font l))) 1483 (J-INT ,(boole 7 NO-DRAW (look-mode l))) 1484 (J-INT ,(look-colour l)) 1485 (J-INT ,(look-gap l)) 1486 (J-INT ,(look-ul l)) 1487 (J-INT ,(text-kl s)) 1488 (J-INT ,x) 1489 (J-INT ,y) 1490 (J-INT ,(x p)) 1491 (J-INT ,(y p)) 1492 (J-INT ,(text-nn s)) 1493 )) 1494 (j-send (get (machine-servers 1495 (window-machine 1496 (zone-window 1497 (text-zone s)))) 1498 'text-composer)) 1499 (let ((kr (j-geti)) ; now record result 1500 (xx (j-geti)) 1501 (yy (j-geti)) 1502 (nn (j-geti))) 1503 (list kr (make-point x (- xx x) y (- yy y)) nn)) 1504 )) 1505 1506(defun format-draw-text (s) ; draw it while formatting 1507 (let ((memop (symbolp (text-text s))) ; can only memoize symbols 1508 ((x y) (text-start-point s)) 1509 (k) (p) (q) (l (text-look s))) 1510 (cond 1511 (memop ; are we memoizing? yes! 1512 (setq k (unique-look-id l)) ; key based on look 1513 (setq p (get (text-text s) k)) ; alist found on plist 1514 (setq q (assoc (text-kl s) p)))) ; entry based on kl 1515 (cond 1516 (q (alter-text s ; if info found 1517 kr (cadr q) ; record result 1518 delta (caddr q) 1519 nn (cadddr q)) 1520 (draw-text s)) ; draw it & return 1521 (t ; otherwise compute data 1522 (j-put-items 1523 `((J-STRING compose) 1524 (J-INT ,(window-id (zone-window (text-zone s)))) 1525 (J-STRING ,(text-text s)) 1526 (J-STRING ,(font-name (look-font l ))) 1527 (J-INT ,(font-size (look-font l))) 1528 (J-INT ,(boole 4 (look-mode l) QUIET)) 1529 (J-INT ,(look-colour l)) 1530 (J-INT ,(look-gap l)) 1531 (J-INT ,(look-ul l)) 1532 (J-INT ,(text-kl s)) 1533 (J-INT ,x) 1534 (J-INT ,y) 1535 (J-INT ,(x (cond 1536 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1537 (ur (zone-box (text-zone s)))) 1538 (t (ll (zone-box (text-zone s))))))) 1539 (J-INT ,(y (cond 1540 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1541 (ur (zone-box (text-zone s)))) 1542 (t (ll (zone-box (text-zone s))))))) 1543 (J-INT -1) ; format to end of text 1544 )) 1545 (j-send (get (machine-servers 1546 (window-machine 1547 (zone-window 1548 (text-zone s)))) 1549 'text-composer)) 1550 (let ((kr (j-geti)) ; now alter result data 1551 (xx (j-geti)) 1552 (yy (j-geti)) 1553 (nn (j-geti))) 1554 (cond ((neq nn (length (exploden (text-text s)))) 1555 (format-text s)) ; actually clipped! reformat 1556 (t (alter-text s 1557 kr kr 1558 delta (make-point x (- xx x) y (- yy y)) 1559 nn nn) 1560 (cond 1561 (memop ; memoize if req'd 1562 (cond (p (nconc p 1563 (ncons (list (text-kl s) kr 1564 (text-delta s) nn)))) 1565 (t (putprop (text-text s) 1566 (ncons (list (text-kl s) kr 1567 (text-delta s) nn)) 1568 k)))) 1569 )) 1570 )) 1571 )) 1572 't)) ; always return t 1573 1574(defun backspace-text (s n) ; undraw last n characters, remove from text 1575 (cond ; this presumes s has valid delta,kr,nn 1576 ((plusp (text-nn s)) ; proceed only if length > 0 1577 (setq n (min n (text-nn s))) ; can't delete more than nn chars 1578 (let ((text (text-text s)) 1579 (l (text-look s))) 1580 (alter-text s ; keep all but last n chars 1581 text (substring text 1 (- (text-nn s) n)) 1582 nn (- (text-nn s) n)) 1583 (format-text s) ; reformat to find the new end 1584 (j-put-items 1585 `((J-STRING compose) ; now undraw last character 1586 (J-INT ,(window-id (zone-window (text-zone s)))) 1587 (J-STRING ,(substring text (- n))) ; undraw last n chars 1588 (J-STRING ,(font-name (look-font l))) 1589 (J-INT ,(font-size (look-font l))) 1590 (J-INT ,(boole 7 QUIET OVERSTRIKE (look-mode l))) 1591 (J-INT ,(inverse-colour (look-colour l))) 1592 (J-INT ,(look-gap l)) 1593 (J-INT ,(look-ul l)) 1594 (J-INT ,(text-kr s)) 1595 (J-INT ,(text-xx s)) 1596 (J-INT ,(text-yy s)) 1597 (J-INT ,(x (cond 1598 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1599 (ur (zone-box (text-zone s)))) 1600 (t (ll (zone-box (text-zone s))))))) 1601 (J-INT ,(y (cond 1602 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1603 (ur (zone-box (text-zone s)))) 1604 (t (ll (zone-box (text-zone s))))))) 1605 (J-INT ,n) 1606 )) 1607 (j-send (get (machine-servers 1608 (window-machine 1609 (zone-window 1610 (text-zone s)))) 1611 'text-composer)) 1612 't)) ; return t if able to do it; nil if nn <= 0 1613 )) 1614 1615(defun append-text (s c) ; draw new char(s) & add to end of text 1616 (cond ((fixp c) ; this presumes s has valid delta,kr,nn 1617 (setq c (ascii c)))) 1618 (j-put-items 1619 `((J-STRING compose) ; draw new last character(s) 1620 (J-INT ,(window-id (zone-window (text-zone s)))) 1621 (J-STRING ,c) 1622 (J-STRING ,(font-name (look-font (text-look s)))) 1623 (J-INT ,(font-size (look-font (text-look s)))) 1624 (J-INT ,(boole 4 (look-mode (text-look s)) QUIET)) ; be noisy! 1625 (J-INT ,(look-colour (text-look s))) 1626 (J-INT ,(look-gap (text-look s))) 1627 (J-INT ,(look-ul (text-look s))) 1628 (J-INT ,(text-kr s)) ; this presumes s has valid delta,kr,nn 1629 (J-INT ,(text-xx s)) 1630 (J-INT ,(text-yy s)) 1631 (J-INT ,(x (cond 1632 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1633 (ur (zone-box (text-zone s)))) 1634 (t (ll (zone-box (text-zone s))))))) 1635 (J-INT ,(y (cond 1636 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1637 (ur (zone-box (text-zone s)))) 1638 (t (ll (zone-box (text-zone s))))))) 1639 (J-INT -1) 1640 )) 1641 (j-send (get (machine-servers 1642 (window-machine 1643 (zone-window 1644 (text-zone s)))) 1645 'text-composer)) 1646 (let ((kr (j-geti)) 1647 (xx (j-geti)) 1648 (yy (j-geti)) 1649 (nn (j-geti))) 1650 (alter-text s 1651 text (concat (text-text s) c) 1652 kr kr 1653 delta (subtract-points 1654 (make-point x xx y yy) 1655 (text-start-point s)) 1656 nn (+ (text-nn s) nn))) 1657 't) 1658 1659(defun append-text-scroll (s c colour) ; draw and add new char(s) 1660 (let ((w (window-id ; while scrolling zone box b in specified colour 1661 (zone-window (text-zone s)))) 1662 (b (zone-box (text-zone s))) 1663 (l (text-look s))) 1664 (cond ((fixp c) 1665 (setq c (ascii c)))) ; this presumes s has valid delta,kr,nn 1666 (j-put-items 1667 `((J-STRING compose) ; format new last character 1668 (J-INT ,w) 1669 (J-STRING ,c) 1670 (J-STRING ,(font-name (look-font l))) 1671 (J-INT ,(font-size (look-font l))) 1672 (J-INT ,(boole 7 NO-DRAW (look-mode l))) 1673 (J-INT ,(look-colour l)) 1674 (J-INT ,(look-gap l)) 1675 (J-INT ,(look-ul l)) 1676 (J-INT ,(text-kr s)) ; this presumes s has valid delta,kr,nn 1677 (J-INT 0) 1678 (J-INT 0) 1679 (J-INT -1) 1680 (J-INT -1) 1681 (J-INT -1) 1682 )) 1683 (j-send (get (machine-servers 1684 (window-machine 1685 (zone-window 1686 (text-zone s)))) 1687 'text-composer)) 1688 (let ((kr (j-geti)) 1689 (xx (j-geti)) 1690 (yy (j-geti)) 1691 (nn (j-geti))) 1692 (apply 1693 'w-scroll-rectangle 1694 (nconc 1695 (ncons (window-w (zone-window (text-zone s)))) 1696 (let ((direction (boole 1 ROTATION 1697 (look-mode l)))) 1698 (cond 1699 ((= direction ROTATE-0) 1700 (list (text-xx s) 1701 (y (ll b)) 1702 (- (x (ur b)) (text-xx s) -1) 1703 (- (y (ur b)) (y (ll b)) -1) 1704 WM-RIGHT xx)) 1705 ((= direction ROTATE-90) 1706 (list (x (ll b)) 1707 (text-yy s) 1708 (- (x (ur b)) (x (ll b)) -1) 1709 (- (y (ur b)) (text-yy s) -1) 1710 WM-UP yy)) 1711 ((= direction ROTATE-180) 1712 (list (x (ll b)) 1713 (y (ll b)) 1714 (- (text-xx s) (x (ll b)) -1) 1715 (- (y (ur b)) (y (ll b)) -1) 1716 WM-LEFT (- xx))) 1717 ((= direction ROTATE-270) 1718 (list (x (ll b)) 1719 (y (ll b)) 1720 (- (x (ur b)) (x (ll b)) -1) 1721 (- (text-yy s) (y (ll b)) -1) 1722 WM-DOWN (- yy))) 1723 )) 1724 (ncons colour))) 1725 (w-flush (window-w (zone-window (text-zone s)))) 1726 (j-put-items 1727 `((J-STRING compose) ; draw new last character 1728 (J-INT ,w) 1729 (J-STRING ,c) 1730 (J-STRING ,(font-name (look-font l))) 1731 (J-INT ,(font-size (look-font l))) 1732 (J-INT ,(boole 7 (look-mode l) QUIET)) 1733 (J-INT ,(look-colour l)) 1734 (J-INT ,(look-gap l)) 1735 (J-INT ,(look-ul l)) 1736 (J-INT ,(text-kr s)) ; this presumes s has valid delta,kr,nn 1737 (J-INT ,(text-xx s)) 1738 (J-INT ,(text-yy s)) 1739 (J-INT ,(x (cond 1740 ((zerop (boole 1 ROTATE-180 (look-mode l))) 1741 (ur (zone-box (text-zone s)))) 1742 (t (ll (zone-box (text-zone s))))))) 1743 (J-INT ,(y (cond 1744 ((zerop (boole 1 ROTATE-90 (look-mode l))) 1745 (ur (zone-box (text-zone s)))) 1746 (t (ll (zone-box (text-zone s))))))) 1747 (J-INT -1) 1748 )) 1749 (j-send (get (machine-servers 1750 (window-machine 1751 (zone-window 1752 (text-zone s)))) 1753 'text-composer)) 1754 (alter-text s 1755 text (concat (text-text s) c) 1756 kr kr 1757 delta (add-points 1758 (make-point x xx y yy) 1759 (text-delta s)) 1760 nn (+ (text-nn s) nn)) 1761 )'t)) 1762 1763(defun format-text-list (sl) ; chain the text objects 1764 (do ((s (car sl) (car sl)) ; so that xx,yy,kr of one 1765 (sl (cdr sl) (cdr sl))) ; used as x,y,kl of next 1766 ((null sl) (format-text s) 't) 1767 (format-text s) 1768 (alter-text (car sl) 1769 kl (text-kr s)) 1770 (move-text (car sl) (text-end-point s)) 1771 )) 1772 1773(defun move-text-list (sl p) ; move whole list of text objects 1774 (do ((s (car sl) (car sl)) 1775 (sl (cdr sl) (cdr sl)) 1776 (p p (text-end-point s))) 1777 ((null s) 't) 1778 (move-text s p) 1779 )) 1780 1781(defun compress-text-list (sl) ; combine like-moded text objects 1782 (do ((s (car sl) (car sl)) ; to reduce communication 1783 (sl (cdr sl) (cdr sl)) 1784 (new-text nil) 1785 (new-end-point (text-start-point s)) 1786 (new-s (append (car sl) nil)) ; top-level copy 1787 (dx nil) 1788 (gap (look-gap (text-look (car sl)))) 1789 (result nil)) 1790 ((null s) (alter-text new-s 1791 text (apply 'concat (nreverse new-text)) 1792 nn -1) 1793 (nreverse (cons new-s result))) ; return new s-list 1794 (setq dx (- (x (text-start-point s)) 1795 (x new-end-point))) 1796 (cond ((and ; check most likely diffs first 1797 (or (eq dx 0) (>= dx (look-gap (text-look s)))) 1798 (= (y (text-start-point s)) (y new-end-point)) 1799 (eq (text-look s) 1800 (text-look new-s)) 1801 ) ; presume kerning doesn't matter! 1802 (cond ((plusp dx) ; horizontal movement 1803 (setq new-text 1804 (cons 1805 (implode 1806 (do ((dx (- dx gap 4) (- dx gap 4)) 1807 (result nil)) 1808 ((minusp dx) 1809 (do ((dx (+ dx 4 -1) (- dx gap 1))) 1810 ((minusp dx) 1811 (cond ((eq dx -1) 1812 (setq result 1813 (cons 1 result))))) 1814 ; 0-pixel space 1815 (setq result (cons 2 result))) 1816 ; 1-pixel space 1817 result) 1818 (setq result (cons 3 result)) 1819 ; 4-pixel space 1820 )) 1821 new-text)))) 1822 (setq new-text (cons (text-text s) new-text)) 1823 (setq new-end-point (text-end-point s)) 1824 ) 1825 (t (alter-text new-s 1826 text (apply 'concat (nreverse new-text)) 1827 nn -1 1828 delta (subtract-points new-end-point 1829 (text-start-point new-s))) 1830 (setq result (cons new-s result)) 1831 (setq new-s (append s nil) 1832 new-text (ncons (text-text s))) 1833 (setq 1834 new-end-point (text-start-point s) 1835 gap (look-gap (text-look s))) 1836 ) 1837 ))) 1838 1839(defun draw-text-list (sl) 1840 (mapc '(lambda (x) (draw-text x)) sl) 't) 1841 1842(defun undraw-text-list (sl) 1843 (mapc '(lambda (x) (undraw-text x)) sl) 't) 1844 1845(defun format-draw-text-list (slist) ; format all on same line 1846 (do ((s (car slist) (car sl)) 1847 (sl (cdr slist) (cdr sl))) 1848 ((null sl) (format-draw-text s)) ; format the last one 1849 (format-draw-text s) 1850 (move-text (car sl) ; chain xx,yy,kr to next one's x,y,kl 1851 (text-end-point s)) 1852 )) 1853;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1854;;; text-edit.l -- rudimentary line editor for fancy character texts 1855;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1856;;; 1857;;; These routines provide a simple line editor with control keys reminiscent 1858;;; of the default EMACS key bindings. 1859;;; 1860;;; The calling program presumably has obtained a "point" event, at 1861;;; position "p". The cursor will be placed on the nearest character, 1862;;; and then input is accepted from the keyboard, until such time as a 1863;;; <return> key is accepted, or a point event occurs outside the text 1864;;; zone boundary, or until a non-key, non-point event occurs. Another 1865;;; point event within the text zone causes the cursor to be re-positioned. 1866;;; 1867;;; Editing operations currently supported are: 1868;;; CTRL-A (ascii 1) ; control A = beginning of line 1869;;; CTRL-B (ascii 2) ; control B = backward-character 1870;;; CTRL-D (ascii 4) ; control D = delete next char 1871;;; CTRL-E (ascii 5) ; control E = end of line 1872;;; CTRL-F (ascii 6) ; control F = forward-character 1873;;; BACKSPACE (ascii 8) ; BACKSPACE = delete previous char 1874;;; CTRL-K (ascii 11) ; control K = kill to end of line 1875;;; CTRL-L (ascii 12) ; control L = redraw text 1876;;; RETURN (ascii 13) ; RETURN = "done" 1877;;; CTRL-T (ascii 20) ; control T = transpose previous 2 chars 1878;;; CTRL-Y (ascii 25) ; control Y = "yank" recently killed text 1879 1880(declare 1881 (specials t) 1882 (macros t)) 1883 1884(eval-when (compile) 1885 (load 'utilities) 1886 (load 'constants) 1887 (load 'zone) 1888 (load 'font) 1889 (load 'look) 1890 (load 'text)) 1891 1892 1893(eval-when (compile eval load) 1894 (defvar BACKSPACE (ascii 8)) ; backspace char = delete previous char 1895 (defvar RETURN (ascii 13)) ; carriage return = "done" 1896 (defvar CTRL-A (ascii 1)) ; control A = beginning of line 1897 (defvar CTRL-B (ascii 2)) ; control B = backward-character 1898 (defvar CTRL-D (ascii 4)) ; control D = delete next char 1899 (defvar CTRL-E (ascii 5)) ; control E = end of line 1900 (defvar CTRL-F (ascii 6)) ; control F = forward-character 1901 (defvar CTRL-K (ascii 11)) ; control K = kill to end of line 1902 (defvar CTRL-L (ascii 12)) ; control L = redraw text 1903 (defvar CTRL-T (ascii 20)) ; control T = transpose previous 2 chars 1904 (defvar CTRL-Y (ascii 25)) ; control Y = "yank" recently killed text 1905 (defvar TYPEAHEAD-THRESHOLD 5); can type at most 5 chars -> forced feedback 1906) 1907 1908(defun edit-text (s p) ; edit a text at point p 1909 (cond ; p outside zone => nil 1910 ((not (point-in-box p (zone-box (text-zone s)))) nil) 1911 (t ; p inside zone => edit text 1912 (let 1913 ((w (window-w (zone-window (text-zone s)))) 1914 (post (append s nil)) 1915 (kill-text "")) 1916 (split-texts s post p) ; split into left and right parts 1917 (draw-cursor-leading-text post) ; highlight first char 1918 (skip-stroke-release-events w) 1919 (do ((e (w-get-next-event w) ; get an event 1920 (w-get-next-event w)) ; then keep getting events 1921 (l) (c)) ; character list, character 1922 ((eq c '#.RETURN) ; stop when <return> is received 1923 (cond ((neq e WM-KEY) ; if not caused by key, put event back 1924 (w-put-back-event w))) 1925 (combine-texts s post) 1926 t) ; just return 't 1927 (cond ; main loop 1928 ((eq e WM-KEY) 1929 (setq c (concat (car (w-get-key w)))) ; get the character 1930 (cond 1931 ((eq c '#.BACKSPACE) ; backspace char 1932 (text-delete-previous-character s post)) 1933 ((eq c '#.CTRL-A) ; control A 1934 (text-beginning-of-line s post)) 1935 ((eq c '#.CTRL-B) ; control B 1936 (text-backward-character s post)) 1937 ((eq c '#.CTRL-D) ; control D 1938 (text-delete-next-character s post)) 1939 ((eq c '#.CTRL-E) ; control E 1940 (text-end-of-line s post)) 1941 ((eq c '#.CTRL-F) ; control F 1942 (text-forward-character s post)) 1943 ((eq c '#.CTRL-K) ; control K 1944 (text-kill-to-end-of-line s post)) 1945 ((eq c '#.CTRL-L) ; control L 1946 (text-redraw-display s post)) 1947 ((eq c '#.CTRL-T) ; control T 1948 (text-transpose-characters s post)) 1949 ((eq c '#.CTRL-Y) ; control Y 1950 (text-yank-from-killbuffer s post)) 1951 ((neq c '#.RETURN) ; not <return> 1952 (text-insert-character s post)) 1953 (t (w-put-back-event w)) ; it's a <return>; put it back 1954 )) ; so loop control can get it again 1955 ((eq e WM-POINT-DEPRESSED) 1956 (setq p (w-get-point w)) 1957 (cond ; check point in zone 1958 ((point-in-box p (zone-box (text-zone s))) 1959 (draw-cursor-leading-text post) ; un-highlight char 1960 (combine-texts s post) 1961 (split-texts s post p) 1962 (draw-cursor-leading-text post) ; highlight new char 1963 (skip-stroke-release-events w)) 1964 (t (w-put-back-event w) ; outside zone => return 1965 (setq c '#.RETURN)))) 1966 ((neq e WM-CANCEL) ; an event we can't handle 1967 (w-put-back-event w) ; so put it back, then return 1968 (setq c '#.RETURN)) 1969 ))) 1970 ))) 1971 1972(defun input-typeahead-keys (w n brk-fcn l) ; return keys typed ahead 1973 (cond ; brk-fcn tests text 1974 ((or (zerop n) ; already have max typeahead 1975 (not (w-any-events w))) (nreverse l)) ; or there aren't any events 1976 (t (let ((x (w-get-next-event w))) ; there's an event 1977 (cond 1978 ((neq x WM-KEY) 1979 (w-put-back-event w) (nreverse l)) ; but not a keystroke 1980 (t (setq x (car (w-get-key w))) ; it's a keystroke 1981 (cond 1982 ((funcall brk-fcn x) ; is it a break char? 1983 (w-put-back-event w) (nreverse l)) ; it's a special char 1984 (t (input-typeahead-keys ; it's a regular char 1985 w (1- n) brk-fcn (cons x l))) ; tail recur for rest 1986 ))))))) 1987 1988(defun split-texts (s post p) ; split text s at point p 1989 (let ; yielding texts s and post 1990 (((kr delta nn) (scan-text s p))) ; scan for char pos'n 1991 (alter-text post ; text incl & after char pt'ed 1992 text (cond ((substring (text-text s) (1+ nn))) ; if it exists! 1993 ("")) ; otherwise,nothing 1994 offset (add-points (text-offset s) delta) 1995 kl kr 1996 delta (subtract-points (text-delta s) delta) 1997 nn (- (text-nn s) nn)) 1998 (alter-text s kr kr delta delta nn nn ; truncate text 1999 text (cond ((substring (text-text s) 1 nn)) 2000 (""))) 2001 )) 2002 2003(defun skip-stroke-release-events (w) 2004 (do ((e (w-get-next-event w) 2005 (w-get-next-event w))) 2006 ((neq e WM-POINT-STROKE) ; get events until non-point-stroke 2007 (cond ((neq e WM-POINT-RELEASED) ; should be point-release 2008 (w-put-back-event w)))) ; if not, put it back 2009 )) 2010 2011(defun combine-texts (s post) ; recombine texts 2012 (alter-text s 2013 text (concat (text-text s) (text-text post)) 2014 nn (+ (text-nn s) (text-nn post)) 2015 delta (add-points (text-delta s) (text-delta post)) 2016 kr (text-kr post)) 2017 (format-text s)) 2018 2019(defun draw-cursor-leading-text (s) ; highlight first char of text 2020 (let ((c (append s nil))) 2021 (alter-text c ; get first char 2022 text (concat (cond ((substring (text-text c) 1 1)) ; if any 2023 (t 'a)))) ; otherwise use a typical character 2024 (format-text c) 2025 (w-clear-rectangle 2026 (window-w (zone-window (text-zone c))) 2027 (text-x c) 2028 (y (ll (zone-box (text-zone c)))) 2029 (min (x (text-delta c)) 2030 (- (x (ur (zone-box (text-zone c)))) 2031 (text-x c) -1)) 2032 (- (y (ur (zone-box (text-zone c)))) 2033 (y (ll (zone-box (text-zone c)))) -1) 2034 W-XOR) 2035 (w-flush (window-w (zone-window (text-zone c)))) 2036 t)) 2037 2038(defun text-delete-previous-character (s post) 2039 (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD 2040 '(lambda (x) ; break on first non-BS 2041 (not (equal x #.(get_pname BACKSPACE)))) 2042 (ncons '#.BACKSPACE)))) 2043 (alter-text s 2044 nn (max 0 (- (text-nn s) (length l)))) 2045 (alter-text s 2046 text (cond ((substring 2047 (text-text s) 2048 1 (text-nn s))) 2049 (""))) 2050 (format-text s) 2051 (w-scroll-rectangle 2052 (window-w (zone-window (text-zone s))) 2053 (text-xx s) 2054 (y (ll (zone-box (text-zone s)))) 2055 (- (x (ur (zone-box (text-zone s)))) 2056 (text-xx s) 1) 2057 (1+ (y (box-size (zone-box (text-zone s))))) 2058 WM-LEFT 2059 (- (x (text-start-point post)) 2060 (x (text-end-point s))) 2061 (zone-colour (text-zone s))) 2062 (w-flush 2063 (window-w (zone-window (text-zone s)))) 2064 (move-text post (text-end-point s)) 2065 (alter-text post kl (text-kr s)))) 2066 2067(defun text-beginning-of-line (s post) 2068 (draw-cursor-leading-text post) ; un-highlight first char 2069 (alter-text post 2070 text (concat (text-text s) (text-text post)) 2071 nn (+ (text-nn s) (text-nn post)) 2072 delta (add-points (text-delta s) (text-delta post)) 2073 kl 0 2074 offset (text-offset s)) 2075 (alter-text s text "" nn 0 delta '(0 0) kr 0) 2076 (draw-cursor-leading-text post)) ; highlight new first char 2077 2078(defun text-backward-character (s post) 2079 (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD 2080 '(lambda (x) ; break on first non-BS 2081 (not (equal x #.(get_pname CTRL-B)))) 2082 (ncons '#.CTRL-B)))) 2083 (draw-cursor-leading-text post) ; un-highlight first char 2084 (alter-text post 2085 text (get_pname (concat (substring (text-text s) (- (length l))) 2086 (text-text post))) 2087 nn (1+ (text-nn post))) 2088 (alter-text s 2089 text (substring (text-text s) 1 (- (text-nn s) (length l))) 2090 nn (- (text-nn s) (length l))) 2091 (format-text s) 2092 (alter-text post 2093 kl (text-kr s) 2094 offset (add-points (text-offset s) (text-delta s)) 2095 delta (subtract-points 2096 (text-end-point post) 2097 (text-end-point s))) 2098 (draw-cursor-leading-text post) ; highlight new first char 2099 )) 2100 2101(defun text-forward-character (s post) 2102 (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD 2103 '(lambda (x) ; break on first non-BS 2104 (not (equal x #.(get_pname CTRL-F)))) 2105 (ncons '#.CTRL-F)))) 2106 (draw-cursor-leading-text post) ; un-highlight first char 2107 (alter-text s 2108 text (get_pname (concat (text-text s) 2109 (substring (text-text post) 1 (length l)))) 2110 nn (+ (text-nn s) (length l))) 2111 (format-text s) 2112 (alter-text post 2113 text (substring (text-text post) (1+ (length l))) 2114 nn (- (text-nn post) (length l)) 2115 kl (text-kr s) 2116 offset (add-points (text-offset s) (text-delta s)) 2117 delta (subtract-points 2118 (text-end-point post) 2119 (text-end-point s))) 2120 (draw-cursor-leading-text post) ; highlight new first char 2121 )) 2122 2123(defun text-end-of-line (s post) 2124 (draw-cursor-leading-text post) ; un-highlight first char 2125 (alter-text s 2126 text (concat (text-text s) (text-text post)) 2127 nn (+ (text-nn s) (text-nn post)) 2128 delta (add-points (text-delta s) (text-delta post)) 2129 kr (text-kr post)) 2130 (alter-text post 2131 text "" 2132 nn 0 2133 offset (add-points (text-offset post) (text-delta post)) 2134 delta '(0 0) 2135 kl (text-kr s)) 2136 (draw-cursor-leading-text post)) ; highlight new first char 2137 2138(defun text-kill-to-end-of-line (s post) 2139 (w-clear-rectangle 2140 (window-w (zone-window (text-zone post))) 2141 (text-x post) 2142 (y (ll (zone-box (text-zone post)))) 2143 (- (x (ur (zone-box (text-zone post)))) (text-x post)) 2144 (1+ (y (box-size (zone-box (text-zone post))))) 2145 (zone-colour (text-zone post))) 2146 (setq kill-text (text-text post)) 2147 (alter-text post 2148 text "" 2149 nn 0 2150 delta '(0 0) 2151 kl (text-kr s)) 2152 (draw-cursor-leading-text post)) ; highlight new first char 2153 2154(defun text-yank-from-killbuffer (s post) 2155 (append-text-scroll s kill-text 2156 (zone-colour (text-zone s))) 2157 (move-text post (text-end-point s)) 2158 (alter-text post 2159 kl (text-kr s))) 2160 2161(defun text-transpose-characters (s post) 2162 (let ((tmp (append s nil))) 2163 (alter-text tmp 2164 nn (- (text-nn tmp) 2)) 2165 (let (((kr delta nn) (scan-text tmp '(-1 -1)))) ; find 2nd prev char 2166 (alter-text tmp 2167 text (substring (text-text tmp) -2) 2168 offset (add-points (text-offset tmp) delta) 2169 kl kr) 2170 (format-text tmp) 2171 (w-clear-rectangle 2172 (window-w (zone-window (text-zone tmp))) 2173 (text-x tmp) 2174 (y (ll (zone-box (text-zone tmp)))) 2175 (x (text-delta tmp)) 2176 (1+ (y (box-size (zone-box (text-zone tmp))))) 2177 (zone-colour (text-zone tmp))) 2178 (w-flush (window-w (zone-window (text-zone tmp)))) 2179 (alter-text tmp 2180 text (get_pname (concat 2181 (substring (text-text tmp) 2 1) 2182 (substring (text-text tmp) 1 1)))) 2183 (format-draw-text tmp) 2184 (alter-text s 2185 text (get_pname 2186 (concat 2187 (substring (text-text s) 1 (- (text-nn s) 2)) 2188 (text-text tmp))) 2189 kr (text-kr tmp)) 2190 ))) 2191 2192(defun text-delete-next-character (s post) 2193 (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD 2194 '(lambda (x) ; break on first non-BS 2195 (not (equal x #.(get_pname CTRL-D)))) 2196 (ncons '#.CTRL-D)))) 2197 (alter-text post 2198 nn (length l)) 2199 (let (((kl delta nn) ; scan for nn'th char position 2200 (scan-text post '(-1 -1)))) 2201 (w-scroll-rectangle 2202 (window-w (zone-window (text-zone post))) 2203 (text-x post) 2204 (y (ll (zone-box (text-zone post)))) 2205 (- (x (ur (zone-box (text-zone post)))) 2206 (text-x post) 1) 2207 (1+ (y (box-size (zone-box (text-zone post))))) 2208 WM-LEFT 2209 (x delta) 2210 (zone-colour (text-zone post))) 2211 (alter-text post 2212 nn (max 0 (- (length (exploden (text-text post))) 2213 (length l))) 2214 kl kl) 2215 (alter-text post 2216 text (cond ((substring 2217 (text-text post) 2218 (- (text-nn post)))) 2219 (""))) 2220 (format-text post) 2221 (draw-cursor-leading-text post) 2222 (w-flush (window-w (zone-window (text-zone post)))) 2223 ))) 2224 2225(defun text-insert-character (s post) 2226 (let ((l (input-typeahead-keys w TYPEAHEAD-THRESHOLD 2227 '(lambda (x) ; break on first BS or CR 2228 (memq (concat x) '#.(list BACKSPACE RETURN))) 2229 (ncons c)))) 2230 (append-text-scroll s (concatl l) 2231 (zone-colour (text-zone s))) 2232 (move-text post (text-end-point s)) 2233 (alter-text post 2234 kl (text-kr s)))) 2235 2236(defun text-redraw-display (s post) 2237 (clear-zone (text-zone s) (zone-colour (text-zone s))) 2238 (w-flush (window-w (zone-window (text-zone post)))) 2239 (format-draw-text s) 2240 (alter-text post 2241 kl (text-kr s) 2242 offset (add-points (text-offset s) (text-delta s))) 2243 (format-draw-text post) 2244 (draw-cursor-leading-text post)) 2245