In DJ: ILLUSTRATE; ARROWS.LISP#27 47* (let ((h (fixr (* w #+Symbolics (tan outside-angle) 48* #+(OR TI LMI) (// (sin outside-angle) (cos outside-angle)))))) 49> (let ((w/2 (// w 2)) 50> (w-h (- w h))) 51> (selectq rotation 52> (0 (values h w 0 0 w h w w)) 100* (signal 'sys:abort #+(OR TI LMI) nil)) 101> ((eq temp #\end) (return (setq button 0))) 102> ((eq temp #\c-end) (return (setq button 2))) 103> ((and (listp temp) 104> (eq (car temp) :mouse-button) In DJ: ILLUSTRATE; BFD-IMPRESS.LISP#1 In DJ: ILLUSTRATE; BITMAP-HARDCOPY.LISP#1 193* #+Symbolics (declare (sys:array-register x-array*)) 194* #+Symbolics (declare (sys:array-register y-array*)) 195> (loop for index from 1 below (array-active-length x-array) 196> for x1 first (aref x-array* 0) then x2 197> for y1 first (aref y-array* 0) then y2 198> for x2 = (aref x-array* index) In DJ: ILLUSTRATE; BUFFER-ICONS.LISP#34 163* #+Symbolics 164> (setf (aref new-icon-array x y) 1) 165* #+(OR TI LMI) 166> (setf (ar-2-reverse new-icon-array x y) 1))) 167> 168> (defmethod (buffer-icon :graph-line) (x1 y1 x2 y2 &optional ignore ignore) 169> (press->icon x1 y1) 180* #+Symbolics (declare (sys:array-register x-array*)) 181* #+Symbolics (declare (sys:array-register y-array*)) 182> (let ((first-x (aref x-array* 0)) 183> (first-y (aref y-array* 0))) 184> (press->icon first-x first-y) 185> (loop for index from 1 below (array-active-length x-array) 198* #+Symbolics (declare (sys:array-register x-segments*)) 199* #+Symbolics (declare (sys:array-register y-segments*)) 200> (loop for index from 0 below (array-active-length x-segments) by 2 201> for x1 = (aref x-segments* index) 202> and y1 = (aref y-segments* index) 203> and x2 = (aref x-segments* (1+ index)) 302* (signal 'sys:abort #+(OR TI LMI) nil)) 303> (:else 304> (return (send frame :untyi input)))))) 305> 306> ;;; Display-buffer-info displays only the name and pathname of all the buffers in the 433* (when changes? (send window #+Symbolics :clear-rest-of-line #+(OR TI LMI) :clear-eol)) 434> (send window :item 'illustrate-buffer self "~A" 435> (format nil " ~:[ ~;*~] ~A~30T~:[Undefined~*~;~A~]~VT" 436> modified? buffer-name buffer-pathname buffer-pathname 437> right-edge)))) 448* (when changes? (send window #+Symbolics :clear-rest-of-line #+(OR TI LMI) :clear-eol)) 449> (send window :item 'illustrate-buffer self "~A" buffer-name) 450> (newline-without-clear window) 451> (tab-to-position 13 window) 452> (format window "Pathname:~24T") 456* (when changes? (send window #+Symbolics :clear-rest-of-line #+(OR TI LMI) :clear-eol)) 457> (send window :item 'buffer-pathname self 458> "~:[Undefined~*~;~A~]" buffer-pathname buffer-pathname) 459> (newline-without-clear window) 460> (tab-to-position 13 window) 462* (when changes? (send window #+Symbolics :clear-rest-of-line #+(OR TI LMI) :clear-eol)) 463> (send window :item 'buffer-modify self "~:[NO~;YES~]" modified?) 464> (send self :expose-icon xpos ypos window)) 465> (send window :primitive-item 'illustrate-buffer self 466> xpos ypos (+ xpos buffer-icon-width 1) In DJ: ILLUSTRATE; BUFFERS.LISP#44 140* #+Symbolics 141> (defmethod (ill-frame :kill-buffer) (&optional buffer &aux new-buffer really-killed?) 142> (or buffer (setq buffer (send self :ask-for-buffer-name 143> "Buffer to kill (RETURN to kill current buffer):" 144> (send current-buffer :name)))) 160* #+(OR TI LMI) 161> (defmethod (ill-frame :kill-buffer) (&optional buffer &aux new-buffer really-killed?) 162> (or buffer (setq buffer (send self :ask-for-buffer-name 163> "Buffer to kill:" (send current-buffer :name)))) 164> (if (null buffer) () 209* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Done."))) 210> (mode-line-delayed-clear)) 211> 212> (defvar *select-buffer-comtab* 213* (zwei:set-comtab #+Symbolics "Select Buffer" #+(OR TI LMI) 'select-buffer 214> '(#\c-cr com-create-new-buffer-from-minibuffer))) 215> 216> (zwei:set-comtab-indirection *select-buffer-comtab* zwei:*completing-reader-comtab*) 217> 246* #+Symbolics 247> (defun read-buffer-name (prompt default &optional impossible-is-ok-p) 248> (let ((zwei:*read-buffer-kludge* t) 249> (zwei:*completing-delims* '(#\sp #\-)) 250> (zwei:*completing-reader-comtab* *select-buffer-comtab*) 281* #+(OR TI LMI) 282> (defun read-buffer-name (prompt default &optional impossible-is-ok-p) 283> (let ((zwei:*read-buffer-kludge* t) 284> (zwei:*mini-buffer-default-string* nil) 285> (zwei:*completing-delims* '(#\sp #/- #/. #/\ #// #/#)) 324* #+Symbolics 325> (defmethod (ill-frame :ask-for-buffer-name) (prompt default) 326> (let-globally ((accept-mouse-input? nil)) 327> (send interaction-pane :edit-in-mini-buffer #'ask-for-buffer-name prompt default))) 328> 330* #+(OR TI LMI) 331> (defmethod (ill-frame :ask-for-buffer-name) (prompt default) 332> (send self :read-buffer-name prompt default t)) 333> 334* #+Symbolics 335> (defun ask-for-buffer-name (prompt default) 336> (let ((zwei:*read-buffer-kludge* t) 337> (zwei:*completing-delims* '(#\sp #\-)) 338> (zwei:*completing-reader-comtab* *select-buffer-comtab*) In DJ: ILLUSTRATE; CFM.LISP#12 24* #+Symbolics ill-mode-line-window 25* #+Symbolics editor-for-illustrate-mini-buffer 26> font-menu 27> ill-text-mode-menu 28> ill-shape-menu 29> ill-dash-pattern-menu In DJ: ILLUSTRATE; COMMANDS.LISP#57 378* (define-ill-command-synonym #+Symbolics #\refresh #+(OR TI LMI) #\clear-screen :redraw-all-objects) 379> 380> (define-ill-command :return-to-normal-mag-scale () 381> "Redraw all objects in the current illustration in the normal ~ 382> scale, i.e. turn off magnification." 383* #+Symbolics #\c-Refresh #+(OR TI LMI) #\c-clear-screen (refresh magnification) 384> (setq mag-x-off 0 mag-y-off 0 mag-scale 1 385> mag-width horizontal-boundary mag-height vertical-boundary) 386> (send self :compute-scale-factors) 387> (send dash-pattern-menu :refresh) 575* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Done.~%") 576> (mode-line-redisplay)) 577> 578> (define-ill-command write-hp-file () 579> "Writes a representation of the current illustration to an HP file." 587* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%") 588> (mode-line-redisplay))) 589> 590> (defmethod (ill-frame :write-hp-file-to-file) (pathname) 591> (multiple-value-bind (ux uy lx ly) 620* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%") 621> (mode-line-redisplay))) 622> 623> (define-ill-command-synonym #\m-W write-press-file) 624> (define-ill-command-synonym (#\mouse-m :write-press-file) write-press-file) 651* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Done.~%") 652> (mode-line-redisplay)) 653> 654> ;;; Writes a press file of the objects in the current buffer to the file specified 655> ;;; by pathname. 693* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%")) 694> (send self :typein-line "Done.~%") 695> (mode-line-redisplay)) 696> 697> ;;; Shows the size of the current illustration in units of the current grid spacing. 728* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%") 729> (mode-line-redisplay)) 730> 731> (define-ill-command-synonym #\c-W :write-ill-file) 732> (define-ill-command-synonym (#\mouse-m :write-ill-file) :write-ill-file) 795* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Done.~%") 796> (mode-line-redisplay) 797> (send current-buffer :refresh-icon)) 798> 799> (define-ill-command-synonym #\m-R :read-ill-file-into-current-buffer) 884* '((:left #+Symbolics #\< #+Symbolics #\, #+TI #\left-arrow #+LMI #\hand-left) 885* (:right #+Symbolics #\> #+Symbolics #\. #+TI #\right-arrow #+LMI #\hand-right) 886* (:up #+Symbolics #\triangle #+TI #\up-arrow #+LMI #\hand-up) 887* (:down #+Symbolics #\space #+TI #\down-arrow #+LMI #\hand-down))) 888> 889> ;;; Incrementally moves the mouse by increment (usually 1 pixel). The direction 890> ;;; of movement depends on which key is used (see above variable). 891> (defun incrementally-move-mouse (command &aux char (increment 1)) 971* #+LMI ;; A GJC SPECIAL FOR DAWNA 972> (define-ill-command :print-screen () 973> "Hardcopy the bit array in the active graphics area" 974> "Print Screen" () 975> (USER:HARDCOPY-SCREEN (send self :get-pane 'graphics-pane))) 977* #+LMI ;; A GJC SPECIAL FOR DAWNA 978> (define-ill-command :save-screen () 979> "Save the screen image to a file of IMPRESS code" 980> "Save Screen" () 981> (USER:HARDCOPY-SCREEN (SEND SELF :GET-PANE 'GRAPHICS-PANE) T)) In DJ: ILLUSTRATE; COPY-ILL.LISP#4 In DJ: ILLUSTRATE; DEFINITIONS.LISP#101 11* #+TI 12> (eval-when (eval compile load) 13> (turn-zetalisp-on)) 14> 15> ;;; Add an element to the end of a list. 123* (death-from-deexposure #+Symbolics (signal 'sys:abort) 124* #+(or TI LMI) (signal 'sys:abort nil))))) 125> 126> (fs:define-canonical-type :ill "ILL" 127> ((:tenex :tops-20) "ILL") 128> (:its "ILL") 179* (defvar *menu-font* #+Symbolics fonts:jess13 180* #+(or TI LMI) fonts:cptfont) 181> 182> 183> (defvar initial-pattern-list '((635. 500.) 184> (0. 500.) 290* #+Symbolics 291> (defconstant pi 3.1415926535) 292> (defconstant pi//2 (// pi 2)) 293> (defconstant 2pi (* 2.0 pi)) 294> 298* (set-syntax-#-macro-char #/" #'(lambda (ignore stream) 299> (send stream :untyi #/") 300> (format nil (read stream))))) 301> 302> (defvar *typeout-window-alist* 451* #+Symbolics :decimal-number #+(OR TI LMI) :number "Circle Density") 452> 453> (define-user-option (circular-arc-density ill-options) 50. 454* #+Symbolics :decimal-number #+(OR TI LMI) :number "Circular Arc Density") 455> 456> (define-user-option (spline-density ill-options) 10. 457* #+Symbolics :decimal-number #+(OR TI LMI) :number "Spline Density") 458> 459> (define-user-option (default-press-type ill-options) "PRESS" 460> :string "Default Press Type") 461> 575* #+Symbolics 576> (defmacro array-dimension (array n) 577> `(array-dimension-n (1+ ,n) ,array)) 578> 579* #+(OR TI LMI) 580> (defmacro tv:%draw-line-internal (x1 y1 x2 y2 alu draw-end-point array) 581> `(sys:%draw-line ,x1 ,y1 ,x2 ,y2 ,alu ,draw-end-point ,array)) 582> 583* #+(OR TI LMI) 584> #8R TV: 585> (defun-method clip-and-offset-line graphics-mixin (from-x from-y to-x to-y) 586> (setq from-x (+ from-x (sheet-inside-left)) ; Add offsets 587> from-y (+ from-y (sheet-inside-top)) 630* #+Symbolics 631> (defmacro div2 (fixnum) 632> `(ldb #.(byte 31. 1) ,fixnum)) 633> 634* #+(OR TI LMI) 635> (defmacro div2 (fixnum) 636> `(ldb #.(byte 23. 1) ,fixnum)) 637> 638* #+(OR TI LMI) 639> (defmethod (tv:window :clear-window) () (send self :clear-screen)) 640> 641> ;;; IEEE floating point compatibility. 642> ;;; The two formats we care about are 4-8 bit bytes, and IEEE single (32-bit) 648* #+3600 649> (defun quadbyte->float (b1 b2 b3 b4) 650> (si:%flonum (%logdpb b1 (byte 8 24) 651> (%logdpb b2 (byte 8 16) 652> (%logdpb b3 (byte 8 8) b4))))) 654* #+3600 655> (defun float->quadbyte (float) 656> (let ((fixval (si:%fixnum float))) 657> (values (%logldb (byte 8 24) fixval) 658> (%logldb (byte 8 16) fixval) 662* #+(or Explorer LMI) 663> ;; this is in fact not processor specific, but instead a general 664> ;; hack on the numeric properties. Could be coded using SI:%FLOATING-POINT-. 665> (defun quadbyte->float (b1 b2 b3 b4) 666> (if (and (zerop b1) (zerop b2) (zerop b3) (zerop b4)) 0.0 682* #+(or Explorer LMI) 683> (defun float->quadbyte (float) 684> (if (zerop float) (values 0 0 0 0) 685> (let* ((sign (if (minusp float) 1 0)) 686> (number (abs float)) In DJ: ILLUSTRATE; DIGIPAD.LISP#7 In DJ: ILLUSTRATE; FRAME.LISP#211 53* tv:(stream-mixin process-mixin notification-mixin #+LMI select-mixin 54> bordered-constraint-frame-with-shared-io-buffer) 55> (:default-init-plist :save-bits :delayed) 56> (:gettable-instance-variables 57> grid-is-on? grid-spacing-string graphics-pane accept-mouse-input? command-state graphs 70* (setq tv:process #+(OR SYMBOLICS TI) '(ill-top-level) 71* #+LMI '(ILL-TOP-LEVEL :REGULAR-PDL-SIZE 16000 72> :SPECIAL-PDL-SIZE 2000)) 73* #+Symbolics 74> (setq tv:selected-pane 'graphics-pane) 75> (setq tv:panes `((interaction-pane ill-interaction-pane) 76> (graphics-pane ill-graphics-pane) 77> (brush-type-pane ill-brush-type-pane) 198* #+Symbolics 199> (setq zwei:*mode-line-window* interaction-pane 200> zwei:*interval* (zwei:window-interval 201> (send interaction-pane :mini-buffer-window))) 202> (setq grid-x-array (tv:make-sheet-bit-array 211* (send interaction-pane :set-font-map 'fonts:(cptfont cptfontb #-LMI cptfonti)) 212> (send interaction-pane :set-background-typeout-window typeout-window) 213> (send interaction-pane :set-background-typeout-stream typeout-window) 214> (send typeout-window :set-io-buffer tv:io-buffer) 215> (send typeout-window :set-item-type-alist *typeout-window-alist*) 286* #+Symbolics 287> (setq tv:*mouse-modifying-keystates* '(:control :meta :super :hyper))) 288> 289> ;;; This sets the global variable *illustrate-frame* to be the ill-frame and 290> ;;; selects the graphics pane, after the ill-frame has been selected. 300* #+Symbolics 301> (and (variable-boundp tv:process) tv:process (typep tv:process 'si:process) 302> (send tv:process :interrupt #'signal 'death-from-deexposure)) 303> (setq tv:mouse-double-click-time 200000. 304> tv:*mouse-incrementing-keystates* '(:shift)) 305* #+Symbolics 306> (setq tv:*mouse-modifying-keystates* '(:control :meta :super :hyper))) 307> 308> ;;; The name that goes in the system menu. 309> (defmethod (ill-frame :name-for-selection) () "Interactive Illustrator") 319* #+Symbolics #\circle 320* #+(OR TI LMI) #\*) 321> 'ill-frame "Interactive Illustrator" '(ill t))) 322> '(:once)) 323> 324> ;;; Perform a "local-beep" on a window by flashing the contents of the window. 360* #+Symbolics 361> (defflavor ill-mode-line-window 362> ((background-typeout-window nil) 363> background-typeout-stream) 364> (zwei:zmacs-mode-line-window) 371* #+Symbolics 372> (defflavor ill-interaction-pane 373> (mini-buffer-editor) 374> (ill-mode-line-window) 375> (:default-init-plist :number-of-mini-buffer-lines 3 :height 60.)) 377* #+Symbolics 378> (defmethod (ill-interaction-pane :after :init) (ignore) 379> (setq mini-buffer-editor (make-editor-for-illustrate-mini-buffer self))) 380> 381* #+Symbolics 382> (defmethod (ill-interaction-pane :edit-in-mini-buffer) 383> (function &rest args &aux (zwei:*current-command-loop* self)) 384> (lexpr-funcall mini-buffer-editor :edit-in-mini-buffer function args)) 385> 386* #+(OR TI LMI) 387> (defflavor ill-interaction-pane 388> ((zwei:background-typeout-window nil) 389> zwei:background-typeout-stream) 390> (tv:borders-mixin zwei:mode-line-superior-mixin zwei:mode-line-window-mixin 400* #+(OR TI LMI) 401> (defmethod (ill-interaction-pane :after :init) (ignore) 402> (setq tv:deexposed-typeout-action ':expose) 403> (let ((blinker-list (send zwei:mini-buffer-window :blinker-list))) 404> (loop for blinker in blinker-list 409* #+(OR TI LMI) 410> (defmethod (ill-interaction-pane :typeout-window) () 411> (send tv:superior :typeout-window)) 412> 413* #+(OR TI LMI) 414> (defmethod (ill-interaction-pane :top-of-editor-hierarchy) () self) 415> 416* #+(OR TI LMI) 417> (defmethod (ill-interaction-pane :editor-windows) () 418> (if (or (eq zwei:*window* zwei:mini-buffer-window) 419> (tv:sheet-exposed-p zwei:mini-buffer-window)) 420> (list zwei:mini-buffer-window) 425* #+(OR TI LMI) 426> (defmethod (ill-interaction-pane :clear-window) () 427> (send self :clear-screen)) 428> 429> ;;; 434* #+Symbolics 435> (defflavor editor-for-illustrate-mini-buffer 436> (zwei:*global-mode-line-window* 437> zwei:*last-file-name-typed* 438> ;; Things that edit-in-mini-buffer expects to have been set by :edit method 441* (:included-flavors #+Symbolics zwei:top-level-editor) 442> (:special-instance-variables zwei:*global-mode-line-window*) 443> (:initable-instance-variables zwei:*global-mode-line-window*)) 444> 445* #+Symbolics 446> (defun make-editor-for-illustrate-mini-buffer (*global-mode-line-window*) 447> (zwei:make-command-loop zwei:*standard-comtab* 448> (send *global-mode-line-window* ':mini-buffer-window) 449> 'editor-for-illustrate-mini-buffer 452* #+Symbolics 453> (defmethod (editor-for-illustrate-mini-buffer :after :init) (ignore) 454> (send zwei:*global-mode-line-window* ':set-io-buffer tv:io-buffer) 455> (push (send zwei:*global-mode-line-window* ':mini-buffer-window) zwei:*window-list*) 456> (setf (tv:sheet-deexposed-typeout-action zwei:*global-mode-line-window*) :permit)) 458* #+Symbolics 459> (defmethod (editor-for-illustrate-mini-buffer :terminal-streams) () 460> (values (send zwei:*global-mode-line-window* ':background-typeout-stream) 461> zwei:*global-mode-line-window* 462> si:syn-terminal-io zwei:syn-typein-window-io)) 464* #+Symbolics 465> (defmethod (editor-for-illustrate-mini-buffer :edit-in-mini-buffer) 466> (function &rest args &aux (zwei:*current-command-loop* self) old-selected-window) 467> (zwei:let*-instance-variables ((zwei:*typeout-window* si:syn-terminal-io)) 468> (unwind-protect 479* #+(OR TI LMI) 480> (defmethod (ill-interaction-pane :around :edit-in-mini-buffer) 481> (cont mt all-args &rest ignore) 482> mt 483> (lexpr-funcall (zwei:window-editor-closure zwei:mini-buffer-window) cont all-args)) 485* #+(OR TI LMI) 486> (defmethod (ill-interaction-pane :edit-in-mini-buffer) 487> (function &rest args 488> &aux old-selected-window 489> (standard-input self) 544* #+(OR Symbolics LMI) #'zwei:typein-line #+TI #'typein-line ctl-string args)) 545> 546* #+TI 547> (defun typein-line (string &rest args) 548> (lexpr-funcall #'format query-io string args)) 549> 550* #+Symbolics 551> (defmethod (ill-frame :typein-line-more) (ctl-string &rest args) 552> (lexpr-funcall interaction-pane :edit-in-mini-buffer 553> #'zwei:typein-line-more ctl-string args)) 554> 591* (multiple-value-bind (inside-width #+(OR TI LMI) inside-height) (send self :inside-size) 592> (let ((x-position horizontal-spacing) 593> (y-position vertical-spacing) 594> (final-x-position (+ horizontal-spacing 595> (* (+ horizontal-spacing *font-width*) number-of-columns)))) 600* #+Symbolics 601> (send self :string-out-explicit (string character) 602> x-position y-position inside-width fonts:ill-font tv:alu-ior) 603* #+(OR TI LMI) 604> (send self :string-out-explicit (string character) 605> x-position y-position inside-width inside-height fonts:ill-font tv:alu-ior) 606> (setq x-position (+ x-position horizontal-spacing *font-width*)))) 607> (send self :highlight-selected-item) 869* #+Symbolics 870> TV: 871> (defun choose-variable-values-with-locatives 872> (variables &rest options &aux op val (label "Choose Variable Values") function 873> margin-choices (near-mode '(:mouse)) sup osw 931* #+(OR TI LMI) 932> ;;; Modified to read keyboard input 933> ;;; Modified to accept variable sub-lists (to indicate more than one item per line) 934> ;;; Modified to do :EDIT processing 935> ;;; Modified to to :SIDE-EFFECT processing 1017* #-LMI (SEND window ':set-value-tab value-tab) #+LMI value-tab 1018> (SEND WINDOW ':SETUP VARIABLES LABEL FUNCTION MARGIN-CHOICES (OR WIDTH T) EXTRA-WIDTH) 1019> (WHEN height 1020> (SEND window ':set-size (SEND window ':width) height)) 1021> (SEND WINDOW ':SET-REVERSE-VIDEO-P REVERSE-VIDEO-P) 1192* #+Symbolics 1193> (multiple-value-bind (final-x final-y) 1194> (send window :draw-string (format nil "`~A'" string) 1195> x y (1+ x) y nil *menu-font*) 1196> (send window :set-cursorpos final-x (- final-y 10.))) 1197* #+(OR TI LMI) 1198> (multiple-value-bind (final-x final-y ignore) 1199> (send window :string-out-explicit (format nil "`~A'" string) 1200> x (- y (font-char-height *menu-font*)) 1201> (tv:sheet-inside-right window) nil *menu-font* tv:alu-ior) 1284* #+Symbolics (delete font lru-list) 1285* #+(OR TI LMI) (del #'equalp font lru-list))) 1286> (set lru-list-var lru-list)) 1287> 1288> (defmethod (font-menu :select-new-font) (font) 1289> (let ((lookup (member font lru-list))) 1297* (setq lru-list (cons font #+Symbolics (delete lru lru-list) 1298* #+(OR TI LMI) (del #'equalp lru lru-list))) 1299> (set lru-list-var lru-list) 1300> (send self :set-item-list (cons font 1301* #+Symbolics (delete lru old-item-list) 1302* #+(OR TI LMI) (del #'equalp lru old-item-list)))) 1303> (send self :set-highlighted-items nil) 1304> (send self :add-highlighted-item font)))) 1305> (send self :refresh)) 1306> 1447* #+Symbolics 1448> (multiple-value-bind (final-x final-y) 1449> (send window :draw-string (string-append #/` string #/') 1450> x y (1+ x) y nil *menu-font*) 1451> (send window :set-cursorpos final-x (- final-y 10.))) 1452* #+(OR TI LMI) 1453> (multiple-value-bind (final-x final-y ignore) 1454> (send window :string-out-explicit (format nil "`~A'" string) 1455> x (- y (font-char-height *menu-font*)) 1456> (tv:sheet-inside-right window) nil *menu-font* tv:alu-ior) 1625* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "~A~%" string)) 1626> (mode-line-delayed-clear)) 1627> 1628> ;;; Returns a formatted pattern list of pattern. 1629> (defmethod (ill-frame :get-formatted-pattern-list) (pattern) 1694* #+Symbolics :char-aluf #+Symbolics tv:alu-seta)) 1695> 1696> ;;; Updates the mouse position and causes it to be displayed in the 1697> ;;; ill-mouse-position-pane as a centered string. 1698> (defmethod (ill-frame :background-process-loop) (&aux mouse-position-x mouse-position-y) 1717* #+Symbolics 1718> (send interaction-pane :set-char-aluf tv:alu-seta) 1719* #+(OR TI LMI) 1720> (send interaction-pane :clear-window) 1721> (send interaction-pane :set-cursorpos 0 1 :character) 1722> (send interaction-pane :display-centered-string 1723> (lexpr-funcall #'format nil shape-dimensions-ctl-string shape-args)) 1744* #+(OR TI LMI) 1745> (send mouse-position-pane :clear-window) 1746> (send mouse-position-pane :display-x-y-centered-string 1747> (format nil "~2,,6,32$, ~2,,6,32$" x y)) 1748> ;; Make the mouse come back immediately instead of deferring. In DJ: ILLUSTRATE; GRAPH.LISP#25 In DJ: ILLUSTRATE; GRAPHICS.LISP#70 46* #+(OR TI LMI) (declare (ignore total-height)) 47* #+Symbolics 48> (multiple-value-bind (screen-width screen-height) (send tv:main-screen :size) 49> (cond ((and (= screen-width 1041.) (= screen-height 784.)) 50> (fix (* 9.0 (// (float total-height) 11.)))) 51> ((and (= screen-width 1111.) (= screen-height 736.)) 55* #+(OR TI LMI) 510.) 56> 57> ;;; Initialize the save-array and the xor-array. 58> (defmethod (ill-graphics-pane :after :init) (&rest ignore) 59> (multiple-value-bind (width height) (send tv:main-screen :size) 67* #+Symbolics (signal 'death-from-deexposure)) 68> 69> (defmethod (ill-graphics-pane :before :clear-window) () 70> (flush-typeout-window tv:typeout-window)) 71> 405* #+TI (swapf a-width a-height) 406> (cond (( from-x a-width) (setq from-x (\ from-x a-width))) 407> ((< from-x 0) 408> (when (minusp (setq from-x (\ from-x a-width))) 409> (incf from-x a-width)))) 428* #+(OR Symbolics LMI) 429> (bitblt-clipped alu width height array 0 0 screen-array x0 y0) 430* #+TI 431> (bitblt-clipped-1 alu width height array 0 0 screen-array x0 y0 432> (tv:sheet-inside-left window) (tv:sheet-inside-top window) 433> (tv:sheet-inside-right window) (tv:sheet-inside-bottom window))))))) 434> (:square 582* #+(OR Symbolics LMI) 583> (bitblt-clipped alu circle-width circle-height circle-array 0 0 window-array 584> x-corner y-corner) 585* #+(OR Symbolics LMI) 586> (bitblt-clipped alu circle-width circle-height circle-array 0 0 window-array 587> (+ x-corner width -1) y-corner) 588* #+TI 589> (let ((right (tv:sheet-inside-right window)) 590> (bottom (tv:sheet-inside-bottom window))) 591> (bitblt-clipped-1 alu circle-width circle-height circle-array 0 0 window-array 592> x-corner y-corner left top right bottom) 624* #+(OR Symbolics LMI) 625> (bitblt-clipped alu circle-width circle-height circle-array 0 0 window-array 626> x-corner y-corner) 627* #+(OR Symbolics LMI) 628> (bitblt-clipped alu circle-width circle-height circle-array 0 0 window-array 629> x-corner (+ y-corner height -1)) 630* #+TI 631> (let ((right (tv:sheet-inside-right window)) 632> (bottom (tv:sheet-inside-bottom window))) 633> (bitblt-clipped-1 alu circle-width circle-height circle-array 0 0 window-array 634> x-corner y-corner left top right bottom) 730* #+Symbolics (declare (sys:array-register x-array*)) 731* #+Symbolics (declare (sys:array-register y-array*)) 732> (let (first-x first-y) 733> (with-press->screen-cached (tv:superior) 734> (press->screen-cached (first-x first-y) (aref x-array* 0) (aref y-array* 0)) 735> (loop for index from 1 below (array-active-length x-array) 748* #+Symbolics (declare (sys:array-register x-segments*)) 749* #+Symbolics (declare (sys:array-register y-segments*)) 750> (with-press->screen-cached (tv:superior) 751> (loop for index from 0 below (array-active-length x-segments) by 2 752> for x1 = (aref x-segments* index) 753> and y1 = (aref y-segments* index) 773* (setq width (min width (max 0 (- (array-dimension array #+(OR Symbolics LMI) 0 #+TI 1) x-bitpos)))) 774* (setq height (min height (max 0 (- (array-dimension array #+(OR Symbolics LMI) 1 #+TI 0) y-bitpos)))) 775> (and (> width 0) (> height 0) 776> (tv:%draw-rectangle width height x-bitpos y-bitpos alu-function array))) 777> 778> (defmethod (ill-graphics-pane :draw-text-selection-box) (ux uy lx ly) 890* #+Symbolics (declare (sys:array-register font-set)) 891> (loop for char being the array-elements of string 892> for image = (aref font-set char) do 893> (when image 894> (let ((x-array (hp-char-image-x-array image)) 896* #+Symbolics (declare (sys:array-register x-array)) 897* #+Symbolics (declare (sys:array-register y-array)) 898> (setq size (array-active-length x-array)) 899> (using-resource (temp-x-array* coordinate-array size) 900> (using-resource (temp-y-array* coordinate-array size) 901> (let ((temp-x-array temp-x-array*) 903* #+Symbolics (declare (sys:array-register temp-x-array)) 904* #+Symbolics (declare (sys:array-register temp-y-array)) 905> (loop for index from 0 below size 906> for x1 = (aref x-array index) 907> for y1 = (aref y-array index) 908> for x1* = x1 954* #+Symbolics (declare (sys:array-register font-set)) 955> (loop for char being the array-elements of string 956> for image = (aref font-set char) do 957> (when image 958> (let ((x-array (hp-char-image-x-array image)) 960* #+Symbolics (declare (sys:array-register x-array)) 961* #+Symbolics (declare (sys:array-register y-array)) 962> (setq size (array-active-length x-array)) 963> (using-resource (temp-x-array* coordinate-array size) 964> (using-resource (temp-y-array* coordinate-array size) 965> (let ((temp-x-array temp-x-array*) 967* #+Symbolics (declare (sys:array-register temp-x-array)) 968* #+Symbolics (declare (sys:array-register temp-y-array)) 969> (loop for index from 0 below size 970> for x1 = (aref x-array index) 971> for y1 = (aref y-array index) 972> for x1* = x1 In DJ: ILLUSTRATE; GRID.LISP#19 42* #+Symbolics (setf (aref grid-x-array x1 0) 1) 43* #+(OR TI LMI) (setf (ar-2-reverse grid-x-array x1 0) 1)))) 44> (loop with x1 and y1 45> for x = 0 46> for y from (- initial-y grid-spacing) to (+ final-y grid-spacing) by grid-spacing 47> do 52* #+Symbolics (setf (aref grid-x-array x1 0) 1) 53* #+(OR TI LMI) (setf (ar-2-reverse grid-x-array x1 0) 1)) 54> (unless (or (< y1 1) (>= y1 gp-height)) 55> (array-push-extend grid-y-array y1))))))) 56> 57> ;;; If the grid is on this method turns it off, otherwise it turns it on. 150* #+Symbolics (signal 'sys:abort) 151* #+(OR TI LMI) (signal 'sys:abort nil)) 152> ((:nounit :nonumber) 153> (send self :display-error "You must specify a number followed by a unit of measure.")) 154> (:badnumber 155> (send self :display-error "Illegal number.")) In DJ: ILLUSTRATE; HARDCOPY.LISP#19 In DJ: ILLUSTRATE; HELP.LISP#13 55* #+(OR TI LMI) 56> (send terminal-io :clear-eol) 57> (format t "~2T[Also via: ") 58> (send frame :draw-keystroke-representation (first item) 59> terminal-io))))))) 104* (send terminal-io :set-font-map '(fonts:cptfont #-LMI fonts:cptfonti fonts:cptfontb)) 105> (send terminal-io :set-current-font 0) 106> (format t "This is Illustrate Version ~3,,1D. Bugs to BUG-ILLUSTRATE@OZ~%" *version*) 107> (loop doing 108> (format t "~%Type a key to document (Return for all keys),~@ In DJ: ILLUSTRATE; HP-FILES.LISP#13 In DJ: ILLUSTRATE; HP-FONT-WIDTHS.LISP#10 In DJ: ILLUSTRATE; HP-FONTS.LISP#20 295* #+Symbolics(signal 'sys:abort) 296* #+(OR TI LMI)(signal 'sys:abort nil)))))) 297> (send graphics-pane :show-hp-text-border-box 298> final-x final-y total-width char-height rotation slant) 299> (multiple-value-bind (dx dy) 300> (tv:sheet-calculate-offsets graphics-pane tv:mouse-sheet) 354* #+Symbolics (declare (sys:array-register font-set)) 355> (loop for char being the array-elements of string 356> for image = (aref font-set char) do 357> (when image 358> (let ((x-array (hp-char-image-x-array image)) 360* #+Symbolics (declare (sys:array-register x-array)) 361* #+Symbolics (declare (sys:array-register y-array)) 362> (setq size (array-active-length x-array)) 363> (using-resource (temp-x-array* coordinate-array size) 364> (using-resource (temp-y-array* coordinate-array size) 365> (let ((temp-x-array temp-x-array*) 367* #+Symbolics (declare (sys:array-register temp-x-array)) 368* #+Symbolics (declare (sys:array-register temp-y-array)) 369> (loop for index from 0 below size 370> for x1 = (aref x-array index) 371> for y1 = (aref y-array index) 372> for x1* = x1 In DJ: ILLUSTRATE; HP-OUTPUT.LISP#8 In DJ: ILLUSTRATE; ILL-FILES.LISP#24 In DJ: ILLUSTRATE; ILLUSTRATE.LISP#62 15* #+TI 16> (defpackage PRESS (:use global) 17> (:size 200.)) 18> 19* #+LMI 20> (when (> (si:get-system-version) 102) 21> (sstatus feature lmi-beta-test)) 22> 23> (defsystem illustrate 27* #+LMI (:patchable "ill:patch;") 28* #+LMI-BETA-TEST (:default-binary-file-type "NFASL") 29> 30> 31> (:package Illustrate) 32> 35* #+(OR TI LMI) 36> (:module load-fonts ("load-font-widths") :package PRESS) 37* (:module press-fonts (#+(OR TI LMI) load-fonts "press-fonts")) 38> (:module frame ("frame")) 39> (:module random ("scale" "grid")) 40> (:module ill-files ("ill-files")) 41> (:module hardcopy ("hardcopy")) In DJ: ILLUSTRATE; IMPRESS.LISP#2 208* (LOOP FOR INDEX FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH STRING) 1) DO 209> (BYTE-TO-IMFILE (AREF STRING INDEX)))) 210> 211> ;We set the perameters of the HV system for this picture. The origin is set at 212> ;the upper-left hand corner. The axes are set to 90 degrees apart rotating 241* (LOOP FOR INDEX FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH X-COORDS) 1) DO 242> (SETQ VERTICES 243> (APPEND (MULTIPLE-VALUE-LIST 244> (SEND XFORM :XFORM 245> (AREF X-COORDS INDEX) 372* (LOOP FOR INDEX FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH SEGMENTS-X) 2) DO 373> (SETQ DASH-LIST 374> (DRAW-DASHED-SEGMENT 375> (AREF SEGMENTS-X INDEX) (AREF SEGMENTS-Y INDEX) 376> (AREF SEGMENTS-X (+ INDEX 1)) (AREF SEGMENTS-Y (+ INDEX 1)) 564* (LOOP FOR CHAR FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH FONT-STRING) 1) DO 565> (COND 566> ((MEMBER (AREF FONT-STRING CHAR) '(48 49 50 51 52 53 54 55 56 57)) 567> (SETQ SUBSTRING 568* (REMOVE-CHAR SUBSTRING (- CHAR (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH SIZE)))) 569> (SETQ SIZE (STRING-APPEND SIZE (AREF FONT-STRING CHAR)))))) 570> (LET ((CHECK (ASSOC SUBSTRING FONT-TEMPLATE-ASSOC-LIST))) 571> (COND ((NULL CHECK) NIL) 572> (T 602* (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH STRING) 603> )) 604> (LEFTOVER-STRING-WIDTH (ROUND TOTAL-WIDTH )) 605> (UNKNOWN-WIDTH 0)) 606> (cond ((NULL FONT-WIDTHS-ARRAY) 739* (LOOP FOR INDEX FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH STRING) 1) DO 740> (COND ((MEMBER (AREF STRING INDEX) LOADED-GLYPHS) 741> (SETQ TOTAL (+ TOTAL 1))))) 742* (COND ((< (QUOTIENT (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH STRING) TOTAL) 2) 743> (SETQ LOADED-GLYPHS NIL)))) 744> (COND 745> ((NULL (CDR (ASSOC IMP-FONT FONT-FAMILY-ASSOC-LIST))) 746> (SETQ FONT-FAMILY-ASSOC-LIST 883* (LOOP FOR COPIES-CHAR FROM 0 TO (- (#+LMI LENGTH #+SYMBOLICS ARRAY-LENGTH STRING-NUMBER) 1) DO 884> (ASET (+ 48 (AREF STRING-NUMBER COPIES-CHAR)) 885> STRING-NUMBER 886> COPIES-CHAR)) 887> (SETQ NUMBER (STRING-APPEND "copies " STRING-NUMBER)) 908* #+Symbolics 909> (NET:DEFINE-PROTOCOL :IGP (:HARDCOPY :BYTE-STREAM) 910> (:DESIRABILITY 1.0) 911> (:INVOKE-WITH-STREAM-AND-CLOSE (STREAM) 912> (ILL:HARDCOPY-IMPRESS STREAM (SEND *IMPRESS-STREAM* :COPIES)))) 914* #+Symbolics 915> (CHAOS:ADD-CONTACT-NAME-FOR-PROTOCOL :IGP "IGP") 916> 917> In DJ: ILLUSTRATE; LOAD-FONT-WIDTHS.LISP#4 In DJ: ILLUSTRATE; OBJECTS.LISP#97 1296* #+Symbolics (declare (sys:array-register temporary-x-array*)) 1297* #+Symbolics (declare (sys:array-register temporary-y-array*)) 1298* #+Symbolics (declare (sys:array-register segments-x*)) 1299* #+Symbolics (declare (sys:array-register segments-y*)) 1300> (loop for index from 0 below size 1301> for x = (aref segments-x* index) 1302> for y = (aref segments-y* index) do 1303> (aset (xform-cached-x x y) temporary-x-array* index) In DJ: ILLUSTRATE; POSTSCRIPT-FILES.LISP#17 239* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%") 240> (mode-line-redisplay))) 241> 242> (defmethod (ill-frame :write-postscript-file-to-file) (pathname copies) 243> (multiple-value-bind (ux uy lx ly) In DJ: ILLUSTRATE; PRESS-FILES.LISP#40 In DJ: ILLUSTRATE; PRESS-FONTS.LISP#33 In DJ: ILLUSTRATE; QMS-FILES.LISP#1 In DJ: ILLUSTRATE; QMS-FONT-WIDTHS.LISP#2 In DJ: ILLUSTRATE; READ-PRESS-FILES.LISP#17 In DJ: ILLUSTRATE; SCALE.LISP#6 In DJ: ILLUSTRATE; SHAPES.LISP#36 23* (signal 'sys:abort #+(OR TI LMI) nil)) 24> ((eq temp #\end) (return (setq button 0))) 25> ((eq temp #\c-end) (return (setq button 2))) 26> ((and (listp temp) 27> (eq (car temp) :mouse-button) 172* (signal 'sys:abort #+(OR TI LMI) nil)) 173> ((eq temp #\end) (return (setq button 0))) 174> ((eq temp #\c-end) (return (setq button 2))) 175> ((and (listp temp) 176> (eq (car temp) :mouse-button) 325* (signal 'sys:abort #+(OR TI LMI) nil)) 326> ((eq temp #\end) (return (setq button 0))) 327> ((eq temp #\c-end) (return (setq button 2))) 328* ((eq temp #+Symbolics #\complete #+(OR TI LMI) #\return) 329> (return-from :next-point (values))) 330> ((and last-x 331> (listp temp) 332> (eq (car temp) :mouse-button) 452* (signal 'sys:abort #+(OR TI LMI) nil)) 453> ((eq temp #\end) (return (setq button 0))) 454> ((eq temp #\c-end) (return (setq button 2))) 455* ((eq temp #+Symbolics #\complete #+(OR TI LMI) #\return) 456> (return-from :next-point (values))) 457> ((and last-x 458> (listp temp) 459> (eq (car temp) :mouse-button) 578* (signal 'sys:abort #+(OR TI LMI) nil)) 579> ((eq temp #\end) (return (setq button 0))) 580> ((eq temp #\c-end) (return (setq button 2))) 581> ((and (listp temp) 582> (eq (car temp) :mouse-button) 644* (signal 'sys:abort #+(OR TI LMI) nil)) 645> ((eq temp #\end) (return (setq button 0))) 646> ((eq temp #\c-end) (return (setq button 2))) 647> ((and (listp temp) 648> (eq (car temp) :mouse-button) In DJ: ILLUSTRATE; SHP-FILES.LISP#5 283* (send self #+Symbolics :typein-line-more #+(OR TI LMI) :typein-line "Written.~%") 284> (mode-line-redisplay)))) 285> 286> (defmethod (ill-frame :write-shp-file-to-file) (pathname scale) 287> (multiple-value-bind (ux uy lx ly) In DJ: ILLUSTRATE; TOPLEVEL.LISP#158 41* (if (or (eq char #+Symbolics #\suspend #+(OR TI LMI) #\break) 42> (eq char #\abort)) 43> char 44> (tv:kbd-default-output-function arg char))) 45> 47* (if (eq char #+Symbolics #\suspend #+(OR TI LMI) #\break) nil 48> (tv:kbd-default-output-function arg char))) 49> 50> (defmethod (ill-frame :redisplay-mode-line) () 51> (when (eq *mode-line-redisplay-level* :full) 147* #+Symbolics 148> (define-ill-command :extended-command () 149> "Enter an extended command." 150> #\m-X (extended command) 151> (let-globally ((accept-mouse-input? nil)) 161* #+(OR TI LMI) 162> (define-ill-command :extended-command () 163> "Enter an extended command." 164> #\m-X (extended command) 165> (send interaction-pane :refresh) 258* #+Symbolics #\suspend #+(OR TI LMI) #\break (break suspend) 259> (let ((io-buffer (frame-lookup tv:io-buffer))) 260> (let ((terminal-io (frame-lookup typeout-window))) 261> (flush-typeout-window terminal-io) 262> (send terminal-io :expose-for-typeout) 992* #+Symbolics (signal 'sys:abort) 993* #+(OR TI LMI) (signal 'sys:abort nil)))))) 994> (send graphics-pane :show-horizontal-text-border-box 995> final-x final-y width height baseline) 996> (multiple-value-bind (dx dy) 997> (tv:sheet-calculate-offsets graphics-pane tv:mouse-sheet) 1082* #+Symbolics (signal 'sys:abort) 1083* #+(OR TI LMI) (signal 'sys:abort nil)))))) 1084> (send graphics-pane :show-vertical-text-border-box 1085> final-x final-y width height char-height) 1086> (multiple-value-bind (dx dy) 1087> (tv:sheet-calculate-offsets graphics-pane tv:mouse-sheet) In DJ: ILLUSTRATE; TRANSFORMATIONS.LISP#25 275* (signal 'sys:abort #+(OR TI LMI) nil)) 276> (:else 277> (incrementally-move-mouse input))))))) 278> (prog1 (send self :execute tv:chosen-item) 279> (setq tv:chosen-item nil))) 405* (signal 'sys:abort #+(OR TI LMI) nil)) 406> (otherwise 407> (send self selection)))))) 408> 409> ;;; Compute and return the top-level transformation that maps the selected objects 463* (signal 'sys:abort #+(OR TI LMI) nil)) 464> ((eq key #\end) 465> (return (setq buttons 1))) 466> ((eq key #\c-end) 467> (return (setq buttons 4))) In DJ: ILLUSTRATE; TRANSFORMS.LISP#19