1;;; artist.el --- draw ascii graphics with your mouse 2 3;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Tomas Abrahamsson <tab@lysator.liu.se> 7;; Maintainer: Tomas Abrahamsson <tab@lysator.liu.se> 8;; Keywords: mouse 9;; Version: 1.2.6 10;; Release-date: 6-Aug-2004 11;; Location: http://www.lysator.liu.se/~tab/artist/ 12 13;; This file is part of GNU Emacs. 14 15;; GNU Emacs is free software; you can redistribute it and/or modify 16;; it under the terms of the GNU General Public License as published by 17;; the Free Software Foundation; either version 2, or (at your option) 18;; any later version. 19 20;; GNU Emacs is distributed in the hope that it will be useful, 21;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23;; GNU General Public License for more details. 24 25;; You should have received a copy of the GNU General Public License 26;; along with GNU Emacs; see the file COPYING. If not, write to the 27;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 28;; Boston, MA 02110-1301, USA. 29 30;;; Commentary: 31 32;; What is artist? 33;; --------------- 34;; 35;; Artist is an Emacs lisp package that allows you to draw lines, 36;; rectangles and ellipses by using your mouse and/or keyboard. The 37;; shapes are made up with the ascii characters |, -, / and \. 38;; 39;; Features are: 40;; 41;; * Intersecting: When a `|' intersects with a `-', a `+' is 42;; drawn, like this: | \ / 43;; --+-- X 44;; | / \ 45;; 46;; * Rubber-banding: When drawing lines you can interactively see the 47;; result while holding the mouse button down and moving the mouse. If 48;; your machine is not fast enough (a 386 is a bit to slow, but a 49;; pentium is well enough), you can turn this feature off. You will 50;; then see 1's and 2's which mark the 1st and 2nd endpoint of the line 51;; you are drawing. 52;; 53;; * Drawing operations: The following drawing operations are implemented: 54;; 55;; lines straight-lines 56;; rectangles squares 57;; poly-lines straight poly-lines 58;; ellipses circles 59;; text (see-thru) text (overwrite) 60;; spray-can setting size for spraying 61;; vaporize line vaporize lines 62;; erase characters erase rectangles 63;; 64;; Straight lines are lines that go horizontally, vertically or 65;; diagonally. Plain lines go in any direction. The operations in 66;; the right column are accessed by holding down the shift key while 67;; drawing. 68;; 69;; It is possible to vaporize (erase) entire lines and connected lines 70;; (rectangles for example) as long as the lines being vaporized are 71;; straight and connected at their endpoints. Vaporizing is inspired 72;; by the drawrect package by Jari Aalto <jari.aalto@poboxes.com>. 73;; 74;; * Flood-filling: You can fill any area with a certain character by 75;; flood-filling. 76;; 77;; * Cut copy and paste: You can cut, copy and paste rectangular 78;; regions. Artist also interfaces with the rect package (this can be 79;; turned off if it causes you any trouble) so anything you cut in 80;; artist can be yanked with C-x r y and vice versa. 81;; 82;; * Drawing with keys: Everything you can do with the mouse, you can 83;; also do without the mouse. 84;; 85;; * Arrows: After having drawn a (straight) line or a (straight) 86;; poly-line, you can set arrows on the line-ends by typing < or >. 87;; 88;; * Aspect-ratio: You can set the variable artist-aspect-ratio to 89;; reflect the height-width ratio for the font you are using. Squares 90;; and circles are then drawn square/round. Note, that once your 91;; ascii-file is shown with font with a different height-width ratio, 92;; the squares won't be square and the circles won't be round. 93;; 94;; * Picture mode compatibility: Artist is picture mode compatible (this 95;; can be turned off). 96;; 97;; See the documentation for the function artist-mode for a detailed 98;; description on how to use artist. 99;; 100;; 101;; What about adding my own drawing modes? 102;; --------------------------------------- 103;; 104;; See the short guide at the end of this file. 105;; If you add a new drawing mode, send it to me, and I would gladly 106;; include in the next release! 107 108 109;;; Installation: 110 111;; To use artist, put this in your .emacs: 112;; 113;; (autoload 'artist-mode "artist" "Enter artist-mode" t) 114 115 116;;; Requirements: 117 118;; Artist requires Emacs 19.28 or higher. 119;; 120;; Artist requires the `rect' package (which comes with Emacs) to be 121;; loadable, unless the variable `artist-interface-with-rect' is set 122;; to nil. 123;; 124;; Artist also requires the Picture mode (which also comes with Emacs) 125;; to be loadable, unless the variable `artist-picture-compatibility' 126;; is set to nil. 127 128;;; Known bugs: 129 130;; The shifted operations are not available when drawing with the mouse 131;; in Emacs 19.29 and 19.30. 132;; 133;; It is not possible to change between shifted and unshifted operation 134;; while drawing with the mouse. (See the comment in the function 135;; artist-shift-has-changed for further details.) 136 137 138;;; ChangeLog: 139 140;; 1.2.6 6-Aug-2004 141;; New: Coerced with the artist.el that's in Emacs-21.3. 142;; (minor editorial changes) 143;; 144;; 1.2.5 4-Aug-2004 145;; New: Added tool selection via the mouse-wheel 146;; Function provided by Andreas Leue <al@sphenon.de> 147;; 148;; 1.2.4 25-Oct-2001 149;; Bugfix: Some operations (the edit menu) got hidden 150;; Bugfix: The first arrow for poly-lines was always pointing 151;; to the right 152;; Changed: Updated with changes made for Emacs 21.1 153;; 154;; 1.2.3 20-Nov-2000 155;; Bugfix: Autoload cookie corrected 156;; 157;; 1.2.2 19-Nov-2000 158;; Changed: More documentation fixes. 159;; Bugfix: The arrow characters (`artist-arrows'), which 160;; got wrong in 1.1, are now corrected. 161;; 162;; 1.2.1 15-Nov-2000 163;; New: Documentation fixes. 164;; Bugfix: Sets next-line-add-newlines to t while in artist-mode. 165;; Drawing with keys was confusing without this fix, if 166;; next-line-add-newlines was set to nil. 167;; Thanks to Tatsuo Furukawa <tatsuo@kobe.hp.com> for this. 168;; 169;; 1.2 22-Oct-2000 170;; New: Updated to work with Emacs 21 171;; 172;; 1.1 15-Aug-2000 173;; Bugfix: Cursor follows mouse pointer more closely. 174;; New: Works with Emacs 20.x 175;; New: Variables are customizable 176;; 177;; 1.1-beta1 21-Apr-1998 178;; New: Spray-can (Utterly useless, I believe, but it was fun 179;; to implement :-) after an idea by Karl-Johan Karlsson 180;; <kj@lysator.liu.se>. 181;; New: Freehand drawing (with pen). 182;; New: Vaporizing lines. 183;; New: Text-rendering using figlet. 184;; New: Picture mode compatibility. 185;; Changed: All Artist keys now uses the prefix C-c C-a not to conflict 186;; with Picture mode. 187;; Bugfix: No longer leaves traces of lines when rubberbanding 188;; if the buffer auto-scrolls. 189;; Bugfix: Infinite loop sometimes when rubberbanding was turned 190;; off. 191;; 192;; 1.0 01-Mar-1998 193;; First official release. 194 195;;; Code: 196 197;; Variables 198 199(defconst artist-version "1.2.6") 200(defconst artist-maintainer-address "tab@lysator.liu.se") 201 202(defvar x-pointer-crosshair) 203 204(eval-and-compile 205 (condition-case () 206 (require 'custom) 207 (error nil)) 208 (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) 209 nil ;; We've got what we needed 210 ;; We have the old custom-library, hack around it! 211 (defmacro defgroup (&rest args) 212 nil) 213 (defmacro defface (var values doc &rest args) 214 `(make-face ,var)) 215 (defmacro defcustom (var value doc &rest args) 216 `(defvar ,var ,value ,doc)))) 217 218;; User options 219;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv 220 221(defgroup artist nil 222 "Customization of the Artist mode." 223 :group 'mouse) 224 225(defgroup artist-text nil 226 "Customization of the text rendering." 227 :group 'artist) 228 229(defcustom artist-rubber-banding t 230 "Interactively do rubber-banding when non-nil." 231 :group 'artist 232 :type 'boolean) 233 234(defcustom artist-first-char ?1 235 "Character to set at first point when not rubber-banding." 236 :group 'artist 237 :type 'character) 238 239(defcustom artist-second-char ?2 240 "Character to set at second point when not rubber-banding." 241 :group 'artist 242 :type 'character) 243 244(defcustom artist-interface-with-rect t 245 "Whether to interface with the rect package or not. 246 247Interfacing to the rect package means that the Copy and Paste operations 248will use the rectangle buffer when accessing the copied area. This means 249that you can insert a rectangle which is copied using the artist package 250and vice versa. 251 252If this causes any problem for you (for example, if the implementation of 253the rectangle package changes), you can set this variable to nil, and the 254artist package will use its own copy buffer." 255 :group 'artist 256 :type 'boolean) 257 258(defvar artist-arrows [ ?> nil ?v ?L ?< nil ?^ nil ] 259 ;; This is a defvar, not a defcustom, since the custom 260 ;; package shows vectors of characters as a vector of integers, 261 ;; which is confusing 262 "A vector of characters to use as arrows. 263 264The vector is 8 elements long and contains a character for each 265direction, or nil if there is no suitable character to use for arrow 266in that direction. 267 268The directions are as follows: 269 270 5 6 7 271 \\ | / 272 4 - * - 0 273 / | \\ 274 3 2 1") 275 276(defcustom artist-aspect-ratio 1 277 "Defines the character height-to-width aspect ratio. 278This is used when drawing squares and circles. If the height of the" 279 :group 'artist 280 :type 'number) 281 282(defcustom artist-trim-line-endings t 283 "Whether or not to remove white-space at end of lines. 284 285If non-nil, line-endings are trimmed (that is, extraneous white-space 286at the end of the line is removed) when the shape is drawn." 287 :group 'artist 288 :type 'boolean) 289 290 291(defcustom artist-flood-fill-right-border 'window-width 292 "Right edge definition, used when flood-filling. 293 294When flood-filling, if the area is not closed off to the right, then 295flood-filling will fill no more to the right than specified by this 296variable. This limit is called the fill-border." 297 :group 'artist 298 :type '(choice (const :tag "limited to window" window-width) 299 (const :tag "limited to value of `fill-column'" fill-column))) 300 301(defcustom artist-flood-fill-show-incrementally t 302 "Whether or not to incrementally update display when flood-filling. 303 304If non-nil, incrementally update display when flood-filling. 305If set to non-nil, this currently implies discarding any input events 306during the flood-fill." 307 :group 'artist 308 :type 'boolean) 309 310 311(defcustom artist-ellipse-right-char ?\) 312 "Character to use at the rightmost position when drawing narrow ellipses. 313 314In this figure, it is the right parenthesis (the ``)'' character): 315 ----- 316 ( ) 317 -----" 318 :group 'artist 319 :type 'character) 320 321 322(defcustom artist-ellipse-left-char ?\( 323 "Character to use at the leftmost position when drawing narrow ellipses. 324 325In this figure, it is the left parenthesis (the ``('' character): 326 ----- 327 ( ) 328 -----" 329 :group 'artist 330 :type 'character) 331 332(defcustom artist-picture-compatibility t 333 "Whether or not picture mode compatibility is on." 334 :group 'artist 335 :type 'boolean) 336 337 338 339 340(defcustom artist-vaporize-fuzziness 1 341 "How to vaporize lines that are cut off. 342 343Accept this many characters cutting off a line and still treat 344it as one line. 345Example: 346 If `artist-vaporize-fuzziness' is 2, then those will be recognized as 347 lines from A to B (provided you start vaporizing them at the ``*''): 348 / 349 A----*------/-----------B 350 \\/ 351 A----*----/\\------------B 352 / \\ 353 354 but this one won't, since it is cut off by more than 2 characters: 355 \\/ / 356 A----*----/\\/----------B 357 / /\\ 358 (in fact, only the left part (between the A and the leftmost ``/'' 359 crossing the line) will be vaporized)" 360 :group 'artist 361 :type 'integer) 362 363 364(defvar artist-pointer-shape (if (eq window-system 'x) x-pointer-crosshair nil) 365 "*If in X Windows, use this pointer shape while drawing with the mouse.") 366 367 368(defcustom artist-text-renderer-function 'artist-figlet 369 "Function for doing text rendering." 370 :group 'artist-text 371 :type 'symbol) 372(defvaralias 'artist-text-renderer 'artist-text-renderer-function) 373 374 375(defcustom artist-figlet-program "figlet" 376 "Program to run for `figlet'." 377 :group 'artist-text 378 :type 'string) 379 380 381(defcustom artist-figlet-default-font "standard" 382 "Default font for `figlet'." 383 :group 'artist-text 384 :type 'string) 385 386 387(defcustom artist-figlet-list-fonts-command 388 ;; list files ending with *.flf in any directory printed by the 389 ;; ``figlet -I2'' command. I think this will not produce more than 390 ;; one directory, but it never hurts to be on the safe side... 391 "for dir in `figlet -I2`; do cd $dir; ls *.flf; done" 392 "Command to run to get list of available fonts." 393 :group 'artist-text 394 :type 'string) 395 396 397(defcustom artist-spray-interval 0.2 398 "Number of seconds between repeated spraying." 399 :group 'artist 400 :type 'number) 401 402 403(defcustom artist-spray-radius 4 404 "Size of the area for spraying." 405 :group 'artist 406 :type 'integer) 407 408 409(defvar artist-spray-chars '(?\s ?. ?- ?+ ?m ?% ?* ?#) 410 ;; This is a defvar, not a defcustom, since the custom 411 ;; package shows lists of characters as a lists of integers, 412 ;; which is confusing 413 "*Characters (``color'') to use when spraying. 414They should be ordered 415from the ``lightest'' to the ``heaviest'' since spraying replaces a 416light character with the next heavier one.") 417 418 419(defvar artist-spray-new-char ?. 420 "*Initial character to use when spraying. 421This character is used if spraying upon a character that is 422not in `artist-spray-chars'. The character defined by this variable 423should be in `artist-spray-chars', or spraying will behave 424strangely.") 425 426 427;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 428;; End of user options 429 430 431;; Internal variables 432;; 433(defvar artist-mode nil 434 "Non-nil to enable `artist-mode' and nil to disable.") 435(make-variable-buffer-local 'artist-mode) 436 437(defvar artist-mode-name " Artist" 438 "Name of artist mode beginning with a space (appears in the mode-line).") 439 440(defvar artist-curr-go 'pen-char 441 "Current selected graphics operation.") 442(make-variable-buffer-local 'artist-curr-go) 443 444(defvar artist-line-char-set nil 445 "Boolean to tell whether user has set some char to use when drawing lines.") 446(make-variable-buffer-local 'artist-line-char-set) 447 448(defvar artist-line-char nil 449 "Char to use when drawing lines.") 450(make-variable-buffer-local 'artist-line-char) 451 452(defvar artist-fill-char-set nil 453 "Boolean to tell whether user has set some char to use when filling.") 454(make-variable-buffer-local 'artist-fill-char-set) 455 456(defvar artist-fill-char nil 457 "Char to use when filling.") 458(make-variable-buffer-local 'artist-fill-char) 459 460(defvar artist-erase-char ?\s 461 "Char to use when erasing.") 462(make-variable-buffer-local 'artist-erase-char) 463 464(defvar artist-default-fill-char ?. 465 "Char to use when a fill-char is required but none is set.") 466(make-variable-buffer-local 'artist-default-fill-char) 467 468; This variable is not buffer local 469(defvar artist-copy-buffer nil 470 "Copy buffer.") 471 472(defvar artist-draw-region-min-y 0 473 "Line-number for top-most visited line for draw operation.") 474(make-variable-buffer-local 'artist-draw-region-min-y) 475 476(defvar artist-draw-region-max-y 0 477 "Line-number for bottom-most visited line for draw operation.") 478(make-variable-buffer-local 'artist-draw-region-max-y) 479 480(defvar artist-borderless-shapes nil 481 "When non-nil, draw shapes without border. 482The fill char is used instead, if it is set.") 483(make-variable-buffer-local 'artist-borderless-shapes) 484 485(defvar artist-prev-next-op-alist nil 486 "Assoc list for looking up next and/or previous draw operation. 487The structure is as follows: (OP . (PREV-OP . NEXT-OP)) 488where the elements are as follows: 489* OP is an atom: the KEY-SYMBOL in the `artist-mt' structure 490* PREV-OP and NEXT-OP are strings: the KEYWORD in the `artist-mt' structure 491 492This variable is initialized by the artist-make-prev-next-op-alist function.") 493 494(eval-when-compile 495 ;; Make rect available at compile-time 496 (require 'rect) ; for interfacing with rect 497 (require 'reporter) ; the bug-reporting tool 498 (require 'picture)) ; picture mode compatibility 499 500(if artist-interface-with-rect 501 (require 'rect)) 502 503(require 'reporter) 504 505(if artist-picture-compatibility 506 (require 'picture)) 507 508;; Variables that are made local in artist-mode-init 509(defvar artist-key-is-drawing nil) 510(defvar artist-key-endpoint1 nil) 511(defvar artist-key-poly-point-list nil) 512(defvar artist-key-shape nil) 513(defvar artist-key-draw-how nil) 514(defvar artist-popup-menu-table nil) 515(defvar artist-key-compl-table nil) 516(defvar artist-rb-save-data nil) 517(defvar artist-arrow-point-1 nil) 518(defvar artist-arrow-point-2 nil) 519 520(defvar artist-mode-map 521 (let ((map (make-sparse-keymap))) 522 (setq artist-mode-map (make-sparse-keymap)) 523 (define-key map [down-mouse-1] 'artist-down-mouse-1) 524 (define-key map [S-down-mouse-1] 'artist-down-mouse-1) 525 (define-key map [down-mouse-2] 'artist-mouse-choose-operation) 526 (define-key map [S-down-mouse-2] 'artist-mouse-choose-operation) 527 (define-key map [down-mouse-3] 'artist-down-mouse-3) 528 (define-key map [S-down-mouse-3] 'artist-down-mouse-3) 529 (define-key map [C-mouse-4] 'artist-select-prev-op-in-list) 530 (define-key map [C-mouse-5] 'artist-select-next-op-in-list) 531 (define-key map "\r" 'artist-key-set-point) ; return 532 (define-key map [up] 'artist-previous-line) 533 (define-key map "\C-p" 'artist-previous-line) 534 (define-key map [down] 'artist-next-line) 535 (define-key map "\C-n" 'artist-next-line) 536 (define-key map [left] 'artist-backward-char) 537 (define-key map "\C-b" 'artist-backward-char) 538 (define-key map [right] 'artist-forward-char) 539 (define-key map "\C-f" 'artist-forward-char) 540 (define-key map "<" 'artist-toggle-first-arrow) 541 (define-key map ">" 'artist-toggle-second-arrow) 542 (define-key map "\C-c\C-a\C-e" 'artist-select-erase-char) 543 (define-key map "\C-c\C-a\C-f" 'artist-select-fill-char) 544 (define-key map "\C-c\C-a\C-l" 'artist-select-line-char) 545 (define-key map "\C-c\C-a\C-o" 'artist-select-operation) 546 (define-key map "\C-c\C-a\C-r" 'artist-toggle-rubber-banding) 547 (define-key map "\C-c\C-a\C-t" 'artist-toggle-trim-line-endings) 548 (define-key map "\C-c\C-a\C-s" 'artist-toggle-borderless-shapes) 549 (define-key map "\C-c\C-c" 'artist-mode-off) 550 (define-key map "\C-c\C-al" 'artist-select-op-line) 551 (define-key map "\C-c\C-aL" 'artist-select-op-straight-line) 552 (define-key map "\C-c\C-ar" 'artist-select-op-rectangle) 553 (define-key map "\C-c\C-aR" 'artist-select-op-square) 554 (define-key map "\C-c\C-as" 'artist-select-op-square) 555 (define-key map "\C-c\C-ap" 'artist-select-op-poly-line) 556 (define-key map "\C-c\C-aP" 'artist-select-op-straight-poly-line) 557 (define-key map "\C-c\C-ae" 'artist-select-op-ellipse) 558 (define-key map "\C-c\C-ac" 'artist-select-op-circle) 559 (define-key map "\C-c\C-at" 'artist-select-op-text-see-thru) 560 (define-key map "\C-c\C-aT" 'artist-select-op-text-overwrite) 561 (define-key map "\C-c\C-aS" 'artist-select-op-spray-can) 562 (define-key map "\C-c\C-az" 'artist-select-op-spray-set-size) 563 (define-key map "\C-c\C-a\C-d" 'artist-select-op-erase-char) 564 (define-key map "\C-c\C-aE" 'artist-select-op-erase-rectangle) 565 (define-key map "\C-c\C-av" 'artist-select-op-vaporize-line) 566 (define-key map "\C-c\C-aV" 'artist-select-op-vaporize-lines) 567 (define-key map "\C-c\C-a\C-k" 'artist-select-op-cut-rectangle) 568 (define-key map "\C-c\C-a\M-w" 'artist-select-op-copy-rectangle) 569 (define-key map "\C-c\C-a\C-y" 'artist-select-op-paste) 570 (define-key map "\C-c\C-af" 'artist-select-op-flood-fill) 571 (define-key map "\C-c\C-a\C-b" 'artist-submit-bug-report) 572 map) 573 "Keymap for `artist-minor-mode'.") 574 575(defvar artist-replacement-table (make-vector 256 0) 576 "Replacement table for `artist-replace-char'.") 577 578 579;;; 580;;; The table of graphic operations 581;;; 582(defvar artist-mt 583 ;; Implementation note: Maybe this should be done using a structure 584 ;; in the cl package? 585 ;; 586 '( 587 (menu 588 ("Drawing" 589 ((function-call 590 ( "Undo" do-undo undo)) 591 592 (separator ) 593 (graphics-operation 594 ("Pen" (("Pen" pen-char "pen-c" 595 artist-no-arrows nil 596 nil nil nil 597 artist-do-continously 598 artist-pen 599 (nil)) 600 ("Pen Line" pen-line "pen-l" 601 artist-arrows artist-pen-set-arrow-points 602 artist-pen-reset-last-xy nil nil 603 artist-do-continously 604 artist-pen-line 605 (nil))))) 606 607 (graphics-operation 608 ("Line" (("line" line "line" 609 artist-arrows artist-set-arrow-points-for-2points 610 nil nil nil 611 2 612 artist-draw-line 613 (artist-undraw-line 614 artist-nil nil)) 615 ("straight line" s-line "sline" 616 artist-arrows artist-set-arrow-points-for-2points 617 nil nil nil 618 2 619 artist-draw-sline 620 (artist-undraw-sline 621 artist-nil nil))))) 622 623 (graphics-operation 624 ("Rectangle" (("rectangle" rect "rect" 625 artist-no-arrows nil 626 nil nil nil 627 2 628 artist-draw-rect 629 (artist-undraw-rect 630 artist-t-if-fill-char-set artist-fill-rect)) 631 ("square" square "square" 632 artist-no-arrows nil 633 nil nil nil 634 2 635 artist-draw-square 636 (artist-undraw-square 637 artist-t-if-fill-char-set artist-fill-square))))) 638 639 (graphics-operation 640 ("Poly-line" (("poly-line" polyline "poly" 641 artist-arrows artist-set-arrow-points-for-poly 642 nil nil nil 643 artist-do-poly 644 artist-draw-line 645 (artist-undraw-line 646 artist-nil nil)) 647 ("straight poly-line" spolyline "s-poly" 648 artist-arrows artist-set-arrow-points-for-poly 649 nil nil nil 650 artist-do-poly 651 artist-draw-sline 652 (artist-undraw-sline 653 artist-nil nil))))) 654 655 (graphics-operation 656 ("Ellipse" (("ellipse" ellipse "ellipse" 657 artist-no-arrows nil 658 nil nil nil 659 2 660 artist-draw-ellipse 661 (artist-undraw-ellipse 662 artist-t-if-fill-char-set artist-fill-ellipse)) 663 ("circle" circle "circle" 664 artist-no-arrows nil 665 nil nil nil 666 2 667 artist-draw-circle 668 (artist-undraw-circle 669 artist-t-if-fill-char-set artist-fill-circle))))) 670 671 (graphics-operation 672 ("Text" (("text see-thru" text-thru "text-thru" 673 artist-no-arrows nil 674 nil nil nil 675 1 676 artist-text-see-thru 677 nil) 678 ("text overwrite" text-ovwrt "text-ovwrt" 679 artist-no-arrows nil 680 nil nil nil 681 1 682 artist-text-overwrite 683 nil)))) 684 685 (graphics-operation 686 ("Spray-can" (("spray-can" spray-can "spray-can" 687 artist-no-arrows nil 688 nil nil nil 689 artist-do-continously 690 artist-spray 691 (artist-spray-get-interval)) 692 ("spray set size" spray-get-size "spray-size" 693 artist-no-arrows nil 694 nil artist-spray-clear-circle artist-spray-set-radius 695 2 696 artist-draw-circle 697 (artist-undraw-circle 698 artist-nil nil))))) 699 700 (graphics-operation 701 ("Erase" (("erase char" erase-char "erase-c" 702 artist-no-arrows nil 703 nil nil nil 704 artist-do-continously 705 artist-erase-char 706 (nil)) 707 ("erase rectangle" erase-rect "erase-r" 708 artist-no-arrows nil 709 nil nil nil 710 2 711 artist-draw-rect 712 (artist-undraw-rect 713 artist-t artist-erase-rect))))) 714 715 (graphics-operation 716 ("Vaporize" (("vaporize line" vaporize-line "vaporize-1" 717 artist-no-arrows nil 718 nil nil nil 719 1 720 artist-vaporize-line 721 nil) 722 ("vaporize lines" vaporize-lines "vaporize-n" 723 artist-no-arrows nil 724 nil nil nil 725 1 726 artist-vaporize-lines 727 nil))))))) 728 729 (menu 730 ("Edit" 731 ((graphics-operation 732 ("Cut" (("cut rectangle" cut-r "cut-r" 733 artist-no-arrows nil 734 nil nil nil 735 2 736 artist-draw-rect 737 (artist-undraw-rect 738 artist-t artist-cut-rect) 739 ("cut square" cut-s "cut-s" 740 artist-no-arrows nil 741 nil nil nil 742 2 743 artist-draw-square 744 (artist-undraw-square 745 artist-t artist-cut-square)))))) 746 747 (graphics-operation 748 ("Copy" (("copy rectangle" copy-r "copy-r" 749 artist-no-arrows nil 750 nil nil nil 751 2 752 artist-draw-rect 753 (artist-undraw-rect 754 artist-t artist-copy-rect) 755 ("copy square" copy-s "copy-s" 756 artist-no-arrows nil 757 nil nil nil 758 2 759 artist-draw-square 760 (artist-undraw-square 761 artist-t artist-copy-square)))))) 762 763 (graphics-operation 764 ("Paste" (("paste" paste "paste" 765 artist-no-arrows nil 766 nil nil nil 767 1 768 artist-paste 769 nil) 770 ("paste" paste "paste" 771 artist-no-arrows nil 772 nil nil nil 773 1 774 artist-paste 775 nil)))) 776 777 (graphics-operation 778 ("Flood-fill" (("flood-fill" flood-fill "flood" 779 artist-no-arrows nil 780 nil nil nil 781 1 782 artist-flood-fill 783 nil) 784 ("flood-fill" flood-fill "flood" 785 artist-no-arrows nil 786 nil nil nil 787 1 788 artist-flood-fill 789 nil))))))) 790 791 (menu 792 ("Settings" 793 ((function-call 794 ("Set Fill" set-fill artist-select-fill-char)) 795 796 (function-call 797 ("Set Line" set-line artist-select-line-char)) 798 799 (function-call 800 ("Set Erase" set-erase artist-select-erase-char)) 801 802 (function-call 803 ("Rubber-banding" rubber-band artist-toggle-rubber-banding)) 804 805 (function-call 806 ("Trimming" trimming artist-toggle-trim-line-endings)) 807 808 (function-call 809 ("Borders" borders artist-toggle-borderless-shapes)) 810 811 (function-call 812 ("Spray-chars" spray-chars artist-select-spray-chars))))) 813 814 ) ;; end of list 815 816 "Master Table for `artist-mode'. 817This table is primarily a table over the different graphics operations 818available in artist mode, but it also holds layout information for the 819popup menu. 820 821The master table is a list of table elements. The elements of this table 822have the layout 823 824 (TAG INFO-PART) 825 826There are three kinds of TAG: 827 828 `menu' -- a sub-menu 829 `separator' -- produce a separator in the popup menu 830 `function-call' -- call a function 831 `graphics-operation' -- a graphics operation 832 833The layout of the INFO-PART for `menu' is 834 835 (TITLE ((TAG-1 INFO-PART-1) (TAG-2 INFO-PART-2) ...)) 836 837TITLE is the title of the submenu; this is followed by a list of 838menu items, each on the general form (TAG INFO-PART). 839 840 841The layout of the INFO-PART for `separator' is empty and not used. 842 843 844This is the layout of the INFO-PART for `function-call': 845 846 (KEYWORD SYMBOL FN) 847 848KEYWORD is a string naming the operation, and appears in the popup menu. 849SYMBOL is the symbol for the operations. 850FN is the function performing the operation. This function 851 is called with no arguments. Its return value is ignored. 852 853 854The layout of the INFO-PART for `graphics-operation' is 855 856 (TITLE (UNSHIFTED SHIFTED)) 857 858TITLE is the title that appears in the popup menu. UNSHIFTED 859and SHIFTED specify for unshifted and shifted operation. Both 860have the form 861 862 (KEYWORD KEY-SYMBOL MODE-LINE ARROW-PRED ARROW-SET-FN 863 INIT-FN PREP-FILL-FN EXIT-FN DRAW-HOW DRAW-FN EXTRA-DRAW-INFO) 864 865KEYWORD is a string specifying the name of the shape to draw. 866 This is used when selecting drawing operation. 867KEY-SYMBOL is the key which is used when looking up members 868 through the functions `artist-go-get-MEMBER-from-symbol' 869 and `artist-fc-get-MEMBER-from-symbol'. 870MODE-LINE is a string that appears in the mode-line when drawing 871 the shape. 872ARROW-PRED is a function that is called to find out if the shape 873 can have arrows. The function is called with no arguments and 874 must return nil or t. 875ARROW-SET-FN is a function that is called to set arrow end-points. 876 Arguments and return values for this funcion are described below. 877INIT-FN is, if non-nil, a function that is called when the first 878 point of the shape is set. Arguments and return values for 879 this funcion are described below. 880PREP-FILL-FN is, if non-nil, a function that is called after 881 the last point is set, but before the filling is done. 882 Arguments and return values for this funcion are described below. 883EXIT-FN is, if non-nil, a function that is called after filling 884 is done. Arguments and return values for this funcion are 885 described below. 886DRAW-HOW defines the kind of shape. The kinds of shapes are: 887 `artist-do-continously' -- Do drawing operation continously, 888 as long as the mouse button is held down. 889 `artist-do-poly' -- Do drawing operation many times. 890 1 -- Do drawing operation only once. 891 2 -- The drawing operation requires two points. 892DRAW-FN is the function to call for drawing. Arguments and 893 return values for this funcion are described below. 894EXTRA-DRAW-INFO the layout of this depends on the value of DRAW-HOW: 895 If DRAW-HOW is `artist-do-continously': 896 897 (INTERVAL-FN) 898 899 INTERVAL-FN is, if non-nil, a function to call for getting 900 an interval between repeated calls to the DRAW-FN. 901 This function is called with no arguments and must 902 return a number, the interval in seconds. 903 If nil, calls to DRAW-FN are done only when the mouse 904 or cursor is moved. 905 906 If DRAW-HOW is either `artist-do-poly' or 2: 907 908 (UNDRAW-FN FILL-PRED FILL-FN) 909 910 UNDRAW-FN is a function to call for undrawing the shape. 911 Arguments and return values for this funcion are 912 described below. 913 FILL-PRED is a function that is called to find out if the shape 914 can have arrows. The function must take no arguments and 915 return nil or t. 916 FILL-FN is a function to call for filling the shape. 917 Arguments and return values for this funcion are 918 described below. 919 920 If DRAW-HOW is 1: 921 922 () 923 924Note! All symbols and keywords (both in the `funcion-call' INFO-PART 925 as well as in the `graphics-operation' INFO-PART) must be unique. 926 927The following table describe function arguments and return value 928for different functions and DRAW-HOWs. 929 930If DRAW-HOW is either `artist-do-continously' or 1: 931 932 INIT-FN X Y ==> ignored 933 PREP-FILL-FN X Y ==> ignored 934 EXIT-FN X Y ==> ignored 935 ARROW-SET-FN X Y ==> ignored 936 DRAW-FN X Y ==> ignored 937 938If DRAW-HOW is 2: 939 940 INIT-FN X1 Y1 ==> ignored 941 PREP-FILL-FN X1 Y1 X2 Y2 ==> ignored 942 EXIT-FN X1 Y1 X2 Y2 ==> ignored 943 ARROW-SET-FN X1 Y1 X2 Y2 ==> ignored 944 DRAW-FN X1 Y1 X2 Y2 ==> (ENDPOINT-1 ENDPOINT-2 SHAPE) 945 UNDRAW-FN (ENDPOINT-1 ENDPOINT-2 SHAPE) ==> ignored 946 FILL-FN (ENDPOINT-1 ENDPOINT-2 SHAPE) X1 Y1 X2 Y2 ==> ignored 947 948 ENDPOINT-1 and ENDPOINT-2 are endpoints which are created with 949 `artist-make-endpoint' 950 SHAPE is an opaque structure, created by the DRAW-FN and intented 951 to be used only by the UNDRAW-FN. 952 953If DRAW-HOW is `artist-do-poly': 954 955 INIT-FN X1 Y1 956 PREP-FILL-FN POINT-LIST 957 ARROW-SET-FN POINT-LIST 958 EXIT-FN POINT-LIST 959 DRAW-FN X-LAST Y-LAST X-NEW Y-NEW ==> (ENDPOINT-1 ENDPOINT-2 SHAPE) 960 UNDRAW-FN (ENDPOINT-1 ENDPOINT-2 SHAPE) 961 FILL-FN POINT-LIST 962 963 ENDPOINT-1 and ENDPOINT-2 are endpoints which are created with 964 `artist-make-endpoint'. 965 SHAPE is an opaque structure, created by the DRAW-FN and intented 966 to be used only by the UNDRAW-FN. 967 POINT-LIST is a list of vectors [X Y].") 968 969 970;; 971;; Accessors for the master table 972;; 973 974(defun artist-mt-get-tag (element) 975 "Retrieve the tag component from the master table ELEMENT." 976 (elt element 0)) 977 978(defun artist-mt-get-info-part (element) 979 "Retrieve the info part component from the master table ELEMENT." 980 (elt element 1)) 981 982;; For the 'graphics-operation info-parts 983;; 984(defsubst artist-go-get-desc (info-part) 985 "Retrieve the description component from a graphics operation INFO-PART." 986 (elt info-part 0)) 987 988(defsubst artist-go-get-unshifted (info-part) 989 "Retrieve the unshifted info from a graphics operation INFO-PART." 990 (elt (elt info-part 1) 0)) 991 992(defsubst artist-go-get-shifted (info-part) 993 "Retrieve the shifted info from a graphics operation INFO-PART." 994 (elt (elt info-part 1) 1)) 995 996(defsubst artist-go-get-keyword (info-variant-part) 997 "Retrieve the keyword component from an INFO-VARIANT-PART. 998An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 999 (elt info-variant-part 0)) 1000 1001(defsubst artist-go-get-symbol (info-variant-part) 1002 "Retrieve the symbol component from an INFO-VARIANT-PART. 1003An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1004 (elt info-variant-part 1)) 1005 1006(defsubst artist-go-get-mode-line (info-variant-part) 1007 "Retrieve the mode line component from an INFO-VARIANT-PART. 1008An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1009 (elt info-variant-part 2)) 1010 1011(defsubst artist-go-get-arrow-pred (info-variant-part) 1012 "Retrieve the arrow predicate component from an INFO-VARIANT-PART. 1013An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1014 (elt info-variant-part 3)) 1015 1016(defsubst artist-go-get-arrow-set-fn (info-variant-part) 1017 "Retrieve the arrow set component from an INFO-VARIANT-PART. 1018An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1019 (elt info-variant-part 4)) 1020 1021(defsubst artist-go-get-init-fn (info-variant-part) 1022 "Retrieve the init function component from an INFO-VARIANT-PART. 1023An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1024 (elt info-variant-part 5)) 1025 1026(defsubst artist-go-get-prep-fill-fn (info-variant-part) 1027 "Retrieve the fill preparation function component from an INFO-VARIANT-PART. 1028An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1029 (elt info-variant-part 6)) 1030 1031(defsubst artist-go-get-exit-fn (info-variant-part) 1032 "Retrieve the exit component from an INFO-VARIANT-PART. 1033An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1034 (elt info-variant-part 7)) 1035 1036(defsubst artist-go-get-draw-how (info-variant-part) 1037 "Retrieve the draw how component from an INFO-VARIANT-PART. 1038An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1039 (elt info-variant-part 8)) 1040 1041(defsubst artist-go-get-draw-fn (info-variant-part) 1042 "Retrieve the draw function component from an INFO-VARIANT-PART. 1043An INFO-VARIANT-PART is the shifted or unshifted info from a info-part." 1044 (elt info-variant-part 9)) 1045 1046(defsubst artist-go-get-undraw-fn (info-variant-part) 1047 "Retrieve the undraw function component from an INFO-VARIANT-PART. 1048An INFO-VARIANT-PART is the shifted or unshifted info from a info-part. 1049This interval function component is available only if the `draw-how' 1050component is other than `artist-do-continously' or 1." 1051 (elt (elt info-variant-part 10) 0)) 1052 1053(defsubst artist-go-get-interval-fn (info-variant-part) 1054 "Retrieve the interval function component from an INFO-VARIANT-PART. 1055An INFO-VARIANT-PART is the shifted or unshifted info from a info-part. 1056This interval function component is available only if the `draw-how' 1057component is `artist-do-continously'." 1058 (elt (elt info-variant-part 10) 0)) 1059 1060(defsubst artist-go-get-fill-pred (info-variant-part) 1061 "Retrieve the fill predicate component from an INFO-VARIANT-PART. 1062An INFO-VARIANT-PART is the shifted or unshifted info from a info-part. 1063This interval function component is available only if the `draw-how' 1064component is other than `artist-do-continously' or 1." 1065 (elt (elt info-variant-part 10) 1)) 1066 1067(defsubst artist-go-get-fill-fn (info-variant-part) 1068 "Retrieve the fill function component from an INFO-VARIANT-PART. 1069An INFO-VARIANT-PART is the shifted or unshifted info from a info-part. 1070This interval function component is available only if the `draw-how' 1071component is other than `artist-do-continously' or 1." 1072 (elt (elt info-variant-part 10) 2)) 1073 1074;; For the 'function-call info-parts 1075;; 1076(defsubst artist-fc-get-keyword (info-part) 1077 "Retrieve the keyword component from a graphics operation INFO-PART." 1078 (elt info-part 0)) 1079 1080(defsubst artist-fc-get-symbol (info-part) 1081 "Retrieve the symbol component from a graphics operation INFO-PART." 1082 (elt info-part 1)) 1083 1084(defsubst artist-fc-get-fn (info-part) 1085 "Retrieve the function component from a graphics operation INFO-PART." 1086 (elt info-part 2)) 1087 1088;; For the 'menu info-parts 1089;; 1090(defsubst artist-mn-get-title (info-part) 1091 "Retrieve the title component from a graphics operation INFO-PART." 1092 (elt info-part 0)) 1093 1094(defsubst artist-mn-get-items (info-part) 1095 "Retrieve the items component from a graphics operation INFO-PART." 1096 (elt info-part 1)) 1097 1098;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1099;; mouse wheel cyclic operation selection 1100 1101(defun artist-get-last-non-nil-op (op-list &optional last-non-nil) 1102 "Find the last non-nil draw operation in OP-LIST. 1103Optional LAST-NON-NIL will be returned if OP-LIST is nil." 1104 (if op-list 1105 (artist-get-last-non-nil-op (cdr op-list) 1106 (or (car (car op-list)) last-non-nil)) 1107 last-non-nil)) 1108 1109(defun artist-get-first-non-nil-op (op-list) 1110 "Find the first non-nil draw operation in OP-LIST." 1111 (or (car (car op-list)) (artist-get-first-non-nil-op (cdr op-list)))) 1112 1113(defun artist-is-in-op-list-p (op op-list) 1114 "Check whether OP is in OP-LIST." 1115 (and op-list 1116 (or (and (car (car op-list)) (string= op (car (car op-list)))) 1117 (artist-is-in-op-list-p op (cdr op-list))))) 1118 1119(defun artist-make-prev-next-op-alist (op-list 1120 &optional 1121 last-non-nil-arg first-non-nil-arg 1122 prev-entry prev-op-arg) 1123 "Build an assoc-list of OP-LIST. 1124The arguments LAST-NON-NIL-ARG, FIRST-NON-NIL-ARG, PREV-ENTRY and 1125PREV-OP-ARG are used when invoked recursively during the build-up." 1126 (let* ((last-non-nil (or last-non-nil-arg 1127 (artist-get-last-non-nil-op 1128 artist-key-compl-table))) 1129 (first-non-nil (or first-non-nil-arg 1130 (artist-get-first-non-nil-op 1131 artist-key-compl-table))) 1132 (prev-op (or prev-op-arg last-non-nil)) 1133 (op (car (car op-list))) 1134 (opsym (artist-mt-get-symbol-from-keyword op)) 1135 (entry (cons opsym (cons prev-op nil)))) 1136 (if (or (and op-list (not op)) 1137 (artist-is-in-op-list-p op (cdr op-list))) 1138 (artist-make-prev-next-op-alist (cdr op-list) 1139 last-non-nil first-non-nil 1140 prev-entry prev-op) 1141 (if prev-entry (setcdr (cdr prev-entry) op)) 1142 (if op-list 1143 (cons entry (artist-make-prev-next-op-alist 1144 (cdr op-list) 1145 last-non-nil first-non-nil 1146 entry op)) 1147 (progn (setcdr (cdr prev-entry) first-non-nil) nil))))) 1148 1149(defun artist-select-next-op-in-list () 1150 "Cyclically select next drawing mode operation." 1151 (interactive) 1152 (let ((next-op (cdr (cdr (assoc artist-curr-go artist-prev-next-op-alist))))) 1153 (artist-select-operation next-op) 1154 (message next-op))) 1155 1156(defun artist-select-prev-op-in-list () 1157 "Cyclically select previous drawing mode operation." 1158 (interactive) 1159 (let ((prev-op (car (cdr (assoc artist-curr-go artist-prev-next-op-alist))))) 1160 (artist-select-operation prev-op) 1161 (message prev-op))) 1162 1163;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1164 1165;;; --------------------------------- 1166;;; The artist-mode 1167;;; --------------------------------- 1168 1169;;;###autoload 1170(defun artist-mode (&optional state) 1171 "Toggle artist mode. With arg, turn artist mode on if arg is positive. 1172Artist lets you draw lines, squares, rectangles and poly-lines, ellipses 1173and circles with your mouse and/or keyboard. 1174 1175How to quit artist mode 1176 1177 Type \\[artist-mode-off] to quit artist-mode. 1178 1179 1180How to submit a bug report 1181 1182 Type \\[artist-submit-bug-report] to submit a bug report. 1183 1184 1185Drawing with the mouse: 1186 1187 mouse-2 1188 shift mouse-2 Pops up a menu where you can select what to draw with 1189 mouse-1, and where you can do some settings (described 1190 below). 1191 1192 mouse-1 1193 shift mouse-1 Draws lines, rectangles or poly-lines, erases, cuts, copies 1194 or pastes: 1195 1196 Operation Not shifted Shifted 1197 -------------------------------------------------------------- 1198 Pen fill-char at point line from last point 1199 to new point 1200 -------------------------------------------------------------- 1201 Line Line in any direction Straight line 1202 -------------------------------------------------------------- 1203 Rectangle Rectangle Square 1204 -------------------------------------------------------------- 1205 Poly-line Poly-line in any dir Straight poly-lines 1206 -------------------------------------------------------------- 1207 Ellipses Ellipses Circles 1208 -------------------------------------------------------------- 1209 Text Text (see thru) Text (overwrite) 1210 -------------------------------------------------------------- 1211 Spray-can Spray-can Set size for spray 1212 -------------------------------------------------------------- 1213 Erase Erase character Erase rectangle 1214 -------------------------------------------------------------- 1215 Vaporize Erase single line Erase connected 1216 lines 1217 -------------------------------------------------------------- 1218 Cut Cut rectangle Cut square 1219 -------------------------------------------------------------- 1220 Copy Copy rectangle Copy square 1221 -------------------------------------------------------------- 1222 Paste Paste Paste 1223 -------------------------------------------------------------- 1224 Flood-fill Flood-fill Flood-fill 1225 -------------------------------------------------------------- 1226 1227 * Straight lines can only go horizontally, vertically 1228 or diagonally. 1229 1230 * Poly-lines are drawn while holding mouse-1 down. When you 1231 release the button, the point is set. If you want a segment 1232 to be straight, hold down shift before pressing the 1233 mouse-1 button. Click mouse-2 or mouse-3 to stop drawing 1234 poly-lines. 1235 1236 * See thru for text means that text already in the buffer 1237 will be visible through blanks in the text rendered, while 1238 overwrite means the opposite. 1239 1240 * Vaporizing connected lines only vaporizes lines whose 1241 _endpoints_ are connected. See also the variable 1242 `artist-vaporize-fuzziness'. 1243 1244 * Cut copies, then clears the rectangle/square. 1245 1246 * When drawing lines or poly-lines, you can set arrows. 1247 See below under ``Arrows'' for more info. 1248 1249 * The mode line shows the currently selected drawing operation. 1250 In addition, if it has an asterisk (*) at the end, you 1251 are currently drawing something. 1252 1253 * Be patient when flood-filling -- large areas take quite 1254 some time to fill. 1255 1256 1257 mouse-3 Erases character under pointer 1258 shift mouse-3 Erases rectangle 1259 1260 1261Settings 1262 1263 Set fill Sets the character used when filling rectangles/squares 1264 1265 Set line Sets the character used when drawing lines 1266 1267 Erase char Sets the character used when erasing 1268 1269 Rubber-banding Toggles rubber-banding 1270 1271 Trimming Toggles trimming of line-endings (that is: when the shape 1272 is drawn, extraneous white-space at end of lines is removed) 1273 1274 Borders Toggles the drawing of line borders around filled shapes. 1275 1276 1277Drawing with keys 1278 1279 \\[artist-key-set-point] Does one of the following: 1280 For lines/rectangles/squares: sets the first/second endpoint 1281 For poly-lines: sets a point (use C-u \\[artist-key-set-point] to set last point) 1282 When erase characters: toggles erasing 1283 When cutting/copying: Sets first/last endpoint of rect/square 1284 When pasting: Pastes 1285 1286 \\[artist-select-operation] Selects what to draw 1287 1288 Move around with \\[artist-next-line], \\[artist-previous-line], \\[artist-forward-char] and \\[artist-backward-char]. 1289 1290 \\[artist-select-fill-char] Sets the charater to use when filling 1291 \\[artist-select-line-char] Sets the charater to use when drawing 1292 \\[artist-select-erase-char] Sets the charater to use when erasing 1293 \\[artist-toggle-rubber-banding] Toggles rubber-banding 1294 \\[artist-toggle-trim-line-endings] Toggles trimming of line-endings 1295 \\[artist-toggle-borderless-shapes] Toggles borders on drawn shapes 1296 1297 1298Arrows 1299 1300 \\[artist-toggle-first-arrow] Sets/unsets an arrow at the beginning 1301 of the line/poly-line 1302 1303 \\[artist-toggle-second-arrow] Sets/unsets an arrow at the end 1304 of the line/poly-line 1305 1306 1307Selecting operation 1308 1309 There are some keys for quickly selecting drawing operations: 1310 1311 \\[artist-select-op-line] Selects drawing lines 1312 \\[artist-select-op-straight-line] Selects drawing straight lines 1313 \\[artist-select-op-rectangle] Selects drawing rectangles 1314 \\[artist-select-op-square] Selects drawing squares 1315 \\[artist-select-op-poly-line] Selects drawing poly-lines 1316 \\[artist-select-op-straight-poly-line] Selects drawing straight poly-lines 1317 \\[artist-select-op-ellipse] Selects drawing ellipses 1318 \\[artist-select-op-circle] Selects drawing circles 1319 \\[artist-select-op-text-see-thru] Selects rendering text (see thru) 1320 \\[artist-select-op-text-overwrite] Selects rendering text (overwrite) 1321 \\[artist-select-op-spray-can] Spray with spray-can 1322 \\[artist-select-op-spray-set-size] Set size for the spray-can 1323 \\[artist-select-op-erase-char] Selects erasing characters 1324 \\[artist-select-op-erase-rectangle] Selects erasing rectangles 1325 \\[artist-select-op-vaporize-line] Selects vaporizing single lines 1326 \\[artist-select-op-vaporize-lines] Selects vaporizing connected lines 1327 \\[artist-select-op-cut-rectangle] Selects cutting rectangles 1328 \\[artist-select-op-copy-rectangle] Selects copying rectangles 1329 \\[artist-select-op-paste] Selects pasting 1330 \\[artist-select-op-flood-fill] Selects flood-filling 1331 1332 1333Variables 1334 1335 This is a brief overview of the different varaibles. For more info, 1336 see the documentation for the variables (type \\[describe-variable] <variable> RET). 1337 1338 artist-rubber-banding Interactively do rubber-banding or not 1339 artist-first-char What to set at first/second point... 1340 artist-second-char ...when not rubber-banding 1341 artist-interface-with-rect If cut/copy/paste should interface with rect 1342 artist-arrows The arrows to use when drawing arrows 1343 artist-aspect-ratio Character height-to-width for squares 1344 artist-trim-line-endings Trimming of line endings 1345 artist-flood-fill-right-border Right border when flood-filling 1346 artist-flood-fill-show-incrementally Update display while filling 1347 artist-pointer-shape Pointer shape to use while drawing 1348 artist-ellipse-left-char Character to use for narrow ellipses 1349 artist-ellipse-right-char Character to use for narrow ellipses 1350 artist-borderless-shapes If shapes should have borders 1351 artist-picture-compatibility Whether or not to be picture mode compatible 1352 artist-vaporize-fuzziness Tolerance when recognizing lines 1353 artist-spray-interval Seconds between repeated sprayings 1354 artist-spray-radius Size of the spray-area 1355 artist-spray-chars The spray-``color'' 1356 artist-spray-new-chars Initial spray-``color'' 1357 1358Hooks 1359 1360 When entering artist-mode, the hook `artist-mode-init-hook' is called. 1361 When quitting artist-mode, the hook `artist-mode-exit-hook' is called. 1362 1363 1364Keymap summary 1365 1366\\{artist-mode-map}" 1367 (interactive) 1368 (if (setq artist-mode 1369 (if (null state) (not artist-mode) 1370 (> (prefix-numeric-value state) 0))) 1371 (artist-mode-init) 1372 (artist-mode-exit))) 1373 1374;; insert our minor mode string 1375(or (assq 'artist-mode minor-mode-alist) 1376 (setq minor-mode-alist 1377 (cons '(artist-mode artist-mode-name) 1378 minor-mode-alist))) 1379 1380;; insert our minor mode keymap 1381(or (assq 'artist-mode minor-mode-map-alist) 1382 (setq minor-mode-map-alist 1383 (cons (cons 'artist-mode artist-mode-map) 1384 minor-mode-map-alist))) 1385 1386 1387;; Init and exit 1388(defun artist-mode-init () 1389 "Init Artist mode. This will call the hook `artist-mode-init-hook'." 1390 (let ((i 0)) 1391 (while (< i 256) 1392 (aset artist-replacement-table i i) 1393 (setq i (1+ i)))) 1394 (aset artist-replacement-table ?\n ?\s) 1395 (aset artist-replacement-table ?\t ?\s) 1396 (aset artist-replacement-table 0 ?\s) 1397 (make-local-variable 'artist-key-is-drawing) 1398 (make-local-variable 'artist-key-endpoint1) 1399 (make-local-variable 'artist-key-poly-point-list) 1400 (make-local-variable 'artist-key-shape) 1401 (make-local-variable 'artist-key-draw-how) 1402 (make-local-variable 'artist-popup-menu-table) 1403 (make-local-variable 'artist-key-compl-table) 1404 (make-local-variable 'artist-prev-next-op-alist) 1405 (make-local-variable 'artist-rb-save-data) 1406 (make-local-variable 'artist-arrow-point-1) 1407 (make-local-variable 'artist-arrow-point-2) 1408 (setq artist-key-is-drawing nil) 1409 (setq artist-key-endpoint1 nil) 1410 (setq artist-key-poly-point-list nil) 1411 (setq artist-key-shape nil) 1412 (setq artist-popup-menu-table (artist-compute-popup-menu-table artist-mt)) 1413 (setq artist-key-compl-table (artist-compute-key-compl-table artist-mt)) 1414 (setq artist-prev-next-op-alist 1415 (artist-make-prev-next-op-alist artist-key-compl-table)) 1416 (setq artist-rb-save-data (make-vector 7 0)) 1417 (setq artist-arrow-point-1 nil) 1418 (setq artist-arrow-point-2 nil) 1419 (make-local-variable 'next-line-add-newlines) 1420 (setq next-line-add-newlines t) 1421 (setq artist-key-draw-how 1422 (artist-go-get-draw-how-from-symbol artist-curr-go)) 1423 (if (and artist-picture-compatibility (not (eq major-mode 'picture-mode))) 1424 (progn 1425 (picture-mode) 1426 (message ""))) 1427 (run-hooks 'artist-mode-init-hook) 1428 (artist-mode-line-show-curr-operation artist-key-is-drawing)) 1429 1430(defun artist-mode-exit () 1431 "Exit Artist mode. This will call the hook `artist-mode-exit-hook'." 1432 (if (and artist-picture-compatibility (eq major-mode 'picture-mode)) 1433 (picture-mode-exit)) 1434 (kill-local-variable 'next-line-add-newlines) 1435 (run-hooks 'artist-mode-exit-hook)) 1436 1437(defun artist-mode-off () 1438 "Turn Artist mode off." 1439 (interactive) 1440 (artist-mode -1) 1441 (force-mode-line-update)) 1442 1443;; 1444;; General routines 1445;; 1446 1447(defun artist-update-display () 1448 "Repaint the display." 1449 (sit-for 0)) 1450 1451(defun artist-mode-line-show-curr-operation (is-drawing) 1452 "Show current operation in mode-line. If IS-DRAWING, show that." 1453 (let ((mtext (concat artist-mode-name "/" 1454 (artist-go-get-mode-line-from-symbol artist-curr-go) 1455 (if is-drawing "/*" "")))) 1456 (setcdr (assq 'artist-mode minor-mode-alist) (list mtext))) 1457 (force-mode-line-update)) 1458 1459 1460(defun artist-t-if-fill-char-set () 1461 "Return the value of the variable `artist-fill-char-set'." 1462 artist-fill-char-set) 1463 1464(defun artist-t () 1465 "Always return t." 1466 t) 1467 1468(defun artist-nil () 1469 "Always return nil." 1470 nil) 1471 1472(defun artist-arrows () 1473 "Say yes to arrows!" 1474 t) 1475 1476(defun artist-no-arrows () 1477 "Say no to arrows!" 1478 nil) 1479 1480;; 1481;; Auxiliary init-routines 1482;; 1483 1484; 1485; Computing the table for the x-popup-menu from the master table 1486; 1487 1488(defun artist-compute-popup-menu-table (menu-table) 1489 "Create a menu from from MENU-TABLE data. 1490The returned value is suitable for the `x-popup-menu' function." 1491 (cons "Artist menu" 1492 (artist-compute-popup-menu-table-sub menu-table))) 1493 1494(defun artist-compute-popup-menu-table-sub (menu-table) 1495 "Compute operation table suitable for `x-popup-menu' from MENU-TABLE." 1496 (mapcar 1497 (lambda (element) 1498 (let ((element-tag (artist-mt-get-tag element))) 1499 (cond ((eq element-tag 'graphics-operation) 1500 (let* ((info-part (artist-mt-get-info-part element)) 1501 (descr (artist-go-get-desc info-part)) 1502 (unshifted (artist-go-get-unshifted info-part)) 1503 (symbol (artist-go-get-symbol unshifted))) 1504 (list descr symbol))) 1505 1506 ((eq element-tag 'function-call) 1507 (let* ((info-part (artist-mt-get-info-part element)) 1508 (keyword (artist-fc-get-keyword info-part)) 1509 (symbol (artist-fc-get-symbol info-part))) 1510 (list keyword symbol))) 1511 1512 ((eq element-tag 'separator) 1513 '("" "")) 1514 1515 ((eq element-tag 'menu) 1516 (let* ((info-part (artist-mt-get-info-part element)) 1517 (title (artist-mn-get-title info-part)) 1518 (items (artist-mn-get-items info-part))) 1519 (cons title (artist-compute-popup-menu-table-sub items)))) 1520 1521 (t 1522 (error "Internal error: unknown element-tag: \"%s\"" 1523 element-tag))))) 1524 menu-table)) 1525 1526; 1527; Computing the completion table from the master table 1528; 1529 1530(defun artist-compute-key-compl-table (menu-table) 1531 "Compute completion table from MENU-TABLE, suitable for `completing-read'." 1532 (apply 1533 'nconc 1534 (remq nil 1535 (mapcar 1536 (lambda (element) 1537 (let ((element-tag (artist-mt-get-tag element))) 1538 (cond ((eq element-tag 'graphics-operation) 1539 (let* ((info-part (artist-mt-get-info-part element)) 1540 (unshifted (artist-go-get-unshifted info-part)) 1541 (shifted (artist-go-get-shifted info-part)) 1542 (unshifted-kwd (artist-go-get-keyword unshifted)) 1543 (shifted-kwd (artist-go-get-keyword shifted))) 1544 (list (list unshifted-kwd) (list shifted-kwd)))) 1545 ((eq element-tag 'menu) 1546 (let* ((info-part (artist-mt-get-info-part element)) 1547 (items (artist-mn-get-items info-part))) 1548 (artist-compute-key-compl-table items))) 1549 (t 1550 nil)))) 1551 menu-table)))) 1552 1553 1554; 1555; Retrieving a symbol (graphics operation or function-call) from a keyword 1556; 1557 1558(defun artist-mt-get-symbol-from-keyword (kwd) 1559 "Search master table for keyword KWD and return its symbol." 1560 (artist-mt-get-symbol-from-keyword-sub artist-mt kwd)) 1561 1562(defun artist-mt-get-symbol-from-keyword-sub (table kwd) 1563 "Search TABLE for keyword KWD and return its symbol." 1564 (catch 'found 1565 (mapcar 1566 (lambda (element) 1567 (let ((element-tag (artist-mt-get-tag element))) 1568 (cond ((eq element-tag 'graphics-operation) 1569 (let* ((info-part (artist-mt-get-info-part element)) 1570 (unshifted (artist-go-get-unshifted info-part)) 1571 (shifted (artist-go-get-shifted info-part)) 1572 (unshifted-kwd (artist-go-get-keyword unshifted)) 1573 (shifted-kwd (artist-go-get-keyword shifted)) 1574 (unshifted-sym (artist-go-get-symbol unshifted)) 1575 (shifted-sym (artist-go-get-symbol shifted))) 1576 (if (string-equal kwd unshifted-kwd) 1577 (throw 'found unshifted-sym)) 1578 (if (string-equal kwd shifted-kwd) 1579 (throw 'found shifted-sym)))) 1580 1581 ((eq element-tag 'function-call) 1582 (let* ((info-part (artist-mt-get-info-part element)) 1583 (keyword (artist-fc-get-keyword info-part)) 1584 (symbol (artist-fc-get-symbol info-part))) 1585 (if (string-equal kwd keyword) 1586 (throw 'found symbol)))) 1587 ((eq element-tag 'menu) 1588 (let* ((info-part (artist-mt-get-info-part element)) 1589 (items (artist-mn-get-items info-part)) 1590 (answer (artist-mt-get-symbol-from-keyword-sub 1591 items kwd))) 1592 (if answer (throw 'found answer)))) 1593 (t 1594 nil)))) 1595 table) 1596 nil)) 1597 1598 1599; 1600; Retrieving info from a graphics operation symbol 1601; 1602 1603(defun artist-go-retrieve-from-symbol (symbol retrieve-fn) 1604 "Search the master table for a graphics operation SYMBOL. 1605Calls RETRIEVE-FN to retrieve information from that symbol's 1606info-variant-part." 1607 (artist-go-retrieve-from-symbol-sub artist-mt symbol retrieve-fn)) 1608 1609(defun artist-go-retrieve-from-symbol-sub (table symbol retrieve-fn) 1610 "Search the TABLE for a graphics operation SYMBOL. 1611Calls RETRIEVE-FN to retrieve information from that symbol's 1612info-variant-part." 1613 (catch 'found 1614 (mapcar 1615 (lambda (element) 1616 (let ((element-tag (artist-mt-get-tag element))) 1617 (cond ((eq element-tag 'graphics-operation) 1618 (let* ((info-part (artist-mt-get-info-part element)) 1619 (unshifted (artist-go-get-unshifted info-part)) 1620 (shifted (artist-go-get-shifted info-part)) 1621 (unshifted-sym (artist-go-get-symbol unshifted)) 1622 (shifted-sym (artist-go-get-symbol shifted)) 1623 (variant-part (cond 1624 ((eq unshifted-sym symbol) unshifted) 1625 ((eq shifted-sym symbol) shifted) 1626 (t nil)))) 1627 (if variant-part ; if found do: 1628 (throw 'found (funcall retrieve-fn variant-part))))) 1629 1630 ((eq element-tag 'menu) 1631 (let* ((info-part (artist-mt-get-info-part element)) 1632 (items (artist-mn-get-items info-part)) 1633 (answer (artist-go-retrieve-from-symbol-sub 1634 items symbol retrieve-fn))) 1635 (if answer (throw 'found answer))))))) 1636 1637 table) 1638 nil)) 1639 1640(defun artist-go-get-keyword-from-symbol (symbol) 1641 "Search the master table, get keyword from a graphics operation SYMBOL." 1642 (artist-go-retrieve-from-symbol symbol 'artist-go-get-keyword)) 1643 1644(defun artist-go-get-mode-line-from-symbol (symbol) 1645 "Search the master table, get mode-line from a graphics operation SYMBOL." 1646 (artist-go-retrieve-from-symbol symbol 'artist-go-get-mode-line)) 1647 1648(defun artist-go-get-arrow-pred-from-symbol (symbol) 1649 "Search the master table, get arrow-pred from a graphics operation SYMBOL." 1650 (artist-go-retrieve-from-symbol symbol 'artist-go-get-arrow-pred)) 1651 1652(defun artist-go-get-arrow-set-fn-from-symbol (symbol) 1653 "Search the master table, get arrow-set-fn from a graphics operation SYMBOL." 1654 (artist-go-retrieve-from-symbol symbol 'artist-go-get-arrow-set-fn)) 1655 1656(defun artist-go-get-init-fn-from-symbol (symbol) 1657 "Search the master table, get init-fn from a graphics operation SYMBOL." 1658 (artist-go-retrieve-from-symbol symbol 'artist-go-get-init-fn)) 1659 1660(defun artist-go-get-prep-fill-fn-from-symbol (symbol) 1661 "Search the master table, get prep-fill-fn from a graphics operation SYMBOL." 1662 (artist-go-retrieve-from-symbol symbol 'artist-go-get-prep-fill-fn)) 1663 1664(defun artist-go-get-exit-fn-from-symbol (symbol) 1665 "Search the master table, get exit-fn from a graphics operation SYMBOL." 1666 (artist-go-retrieve-from-symbol symbol 'artist-go-get-exit-fn)) 1667 1668(defun artist-go-get-draw-fn-from-symbol (symbol) 1669 "Search the master table, get draw-fn from a graphics operation SYMBOL." 1670 (artist-go-retrieve-from-symbol symbol 'artist-go-get-draw-fn)) 1671 1672(defun artist-go-get-draw-how-from-symbol (symbol) 1673 "Search the master table, get draw-how from a graphics operation SYMBOL." 1674 (artist-go-retrieve-from-symbol symbol 'artist-go-get-draw-how)) 1675 1676(defun artist-go-get-undraw-fn-from-symbol (symbol) 1677 "Search the master table, get undraw-fn from a graphics operation SYMBOL." 1678 (artist-go-retrieve-from-symbol symbol 'artist-go-get-undraw-fn)) 1679 1680(defun artist-go-get-interval-fn-from-symbol (symbol) 1681 "Search the master table, get interval-fn from a graphics operation SYMBOL." 1682 (artist-go-retrieve-from-symbol symbol 'artist-go-get-interval-fn)) 1683 1684(defun artist-go-get-fill-pred-from-symbol (symbol) 1685 "Search the master table, get fill-pred from a graphics operation SYMBOL." 1686 (artist-go-retrieve-from-symbol symbol 'artist-go-get-fill-pred)) 1687 1688(defun artist-go-get-fill-fn-from-symbol (symbol) 1689 "Search the master table, get fill-fn from a graphics operation SYMBOL." 1690 (artist-go-retrieve-from-symbol symbol 'artist-go-get-fill-fn)) 1691 1692(defun artist-go-get-symbol-shift (symbol is-shifted) 1693 "Search for (shifted or unshifted) graphics operation SYMBOL. 1694If IS-SHIFTED is non-nil, return the shifted symbol, 1695otherwise the shifted symbol." 1696 (artist-go-get-symbol-shift-sub artist-mt symbol is-shifted)) 1697 1698(defun artist-go-get-symbol-shift-sub (table symbol is-shifted) 1699 "Search TABLE for (shifted or unshifted) graphics SYMBOL. 1700If IS-SHIFTED is non-nil, return the shifted symbol, 1701otherwise the shifted symbol." 1702 (catch 'found 1703 (mapcar 1704 (lambda (element) 1705 (let ((element-tag (artist-mt-get-tag element))) 1706 (cond ((eq element-tag 'graphics-operation) 1707 (let* ((info-part (artist-mt-get-info-part element)) 1708 (unshift-variant (artist-go-get-unshifted info-part)) 1709 (shift-variant (artist-go-get-shifted info-part)) 1710 (unshift-sym (artist-go-get-symbol unshift-variant)) 1711 (shift-sym (artist-go-get-symbol shift-variant))) 1712 (if (or (eq symbol unshift-sym) (eq symbol shift-sym)) 1713 (throw 'found (if is-shifted shift-sym unshift-sym))))) 1714 1715 ((eq element-tag 'menu) 1716 (let* ((info-part (artist-mt-get-info-part element)) 1717 (items (artist-mn-get-items info-part)) 1718 (answer (artist-go-get-symbol-shift-sub 1719 items symbol is-shifted))) 1720 (if answer (throw 'found answer))))))) 1721 1722 table) 1723 nil)) 1724 1725; 1726; Retrieving info from a function-call symbol 1727; 1728 1729(defun artist-fc-retrieve-from-symbol (symbol retrieve-fn) 1730 "Search the master table for a function call SYMBOL. 1731Calls RETRIEVE-FN to retrieve information from that symbol's 1732info-variant-part." 1733 (artist-fc-retrieve-from-symbol-sub artist-mt symbol retrieve-fn)) 1734 1735(defun artist-fc-retrieve-from-symbol-sub (table symbol retrieve-fn) 1736 "Search TABLE for a function-call SYMBOL. 1737Calls RETRIEVE-FN to retrieve information from that symbol's 1738info-variant-part." 1739 (catch 'found 1740 (mapcar 1741 (lambda (element) 1742 (let ((element-tag (artist-mt-get-tag element))) 1743 (cond ((eq element-tag 'function-call) 1744 (let* ((info-part (artist-mt-get-info-part element)) 1745 (fc-symbol (artist-fc-get-symbol info-part))) 1746 (if (eq fc-symbol symbol) 1747 (throw 'found (funcall retrieve-fn info-part))))) 1748 1749 ((eq element-tag 'menu) 1750 (let* ((info-part (artist-mt-get-info-part element)) 1751 (items (artist-mn-get-items info-part)) 1752 (answer (artist-fc-retrieve-from-symbol-sub 1753 items symbol retrieve-fn))) 1754 (if answer (throw 'found answer))))))) 1755 1756 table) 1757 nil)) 1758 1759(defun artist-fc-get-fn-from-symbol (symbol) 1760 "Search the master table to get function from a function call SYMBOL." 1761 (artist-fc-retrieve-from-symbol symbol 'artist-fc-get-fn)) 1762 1763 1764;; 1765;; Utilities 1766;; 1767 1768;; Macro that won't funcall the function if it is nil. 1769;; 1770(defmacro artist-funcall (fn &rest args) 1771 "Call function FN with ARGS iff FN is not nil." 1772 (list 'if fn (cons 'funcall (cons fn args)))) 1773 1774(defun artist-uniq (l) 1775 "Remove consecutive duplicates in list L. Comparison is done with `equal'." 1776 (cond ((null l) nil) 1777 ((null (cdr l)) l) ; only one element in list 1778 ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal 1779 (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different 1780 1781(defun artist-string-split (str r) 1782 "Split string STR at occurrences of regexp R, returning a list of strings." 1783 (let ((res nil) 1784 (start 0) 1785 (match-pos 0)) 1786 (while (setq match-pos (string-match r str start)) 1787 (setq res (cons (copy-sequence (substring str start match-pos)) res)) 1788 (setq start (match-end 0))) 1789 (if (null res) 1790 (list str) 1791 (if (< (match-end 0) (- (length str) 1)) 1792 (setq res (cons (substring str (match-end 0) (length str)) res))) 1793 (reverse res)))) 1794 1795(defun artist-string-to-file (str file-name) 1796 "Write string STR to file FILE-NAME." 1797 (write-region str 'end-is-ignored file-name nil 'no-message)) 1798 1799(defun artist-file-to-string (file-name) 1800 "Read from file FILE-NAME into a string." 1801 (save-excursion 1802 (let ((tmp-buffer (get-buffer-create (concat "*artist-" file-name "*")))) 1803 (set-buffer tmp-buffer) 1804 (goto-char (point-min)) 1805 (insert-file-contents file-name nil nil nil t) 1806 (let ((str (copy-sequence (buffer-substring (point-min) 1807 (point-max))))) 1808 (kill-buffer tmp-buffer) 1809 str)))) 1810 1811(defun artist-clear-buffer (buf) 1812 "Clear contents of buffer BUF." 1813 (save-excursion 1814 (set-buffer buf) 1815 (goto-char (point-min)) 1816 (delete-char (- (point-max) (point-min)) nil))) 1817 1818 1819(defun artist-system (program stdin &optional program-args) 1820 "Run PROGRAM synchronously with the contents of string STDIN to stdin. 1821Optional args PROGRAM-ARGS are arguments to PROGRAM. 1822Return a list (RETURN-CODE STDOUT STDERR)." 1823 (save-excursion 1824 (let* ((tmp-stdin-file-name (if stdin 1825 (make-temp-file 1826 (concat (file-name-as-directory 1827 (or (getenv "TMPDIR") "/tmp")) 1828 "artist-stdin.")) 1829 nil)) 1830 (tmp-stdout-buffer (get-buffer-create 1831 (concat "*artist-" program "*"))) 1832 (tmp-stderr-file-name (make-temp-file 1833 (concat (file-name-as-directory 1834 (or (getenv "TMPDIR") "/tmp")) 1835 "artist-stdout."))) 1836 (binary-process-input nil) ; for msdos 1837 (binary-process-output nil)) 1838 1839 ;; Prepare stdin 1840 (if stdin (artist-string-to-file stdin tmp-stdin-file-name)) 1841 1842 ;; Clear the buffer 1843 (artist-clear-buffer tmp-stdout-buffer) 1844 1845 ;; Start the program 1846 (unwind-protect 1847 (let ((res (if program-args 1848 (apply 'call-process 1849 program 1850 tmp-stdin-file-name 1851 (list tmp-stdout-buffer 1852 tmp-stderr-file-name) 1853 nil 1854 (if (stringp program-args) 1855 (list program-args) 1856 program-args)) 1857 (apply 'call-process 1858 program 1859 tmp-stdin-file-name 1860 (list tmp-stdout-buffer 1861 tmp-stderr-file-name) 1862 nil)))) 1863 1864 ;; the return value 1865 (list res 1866 (save-excursion 1867 (set-buffer tmp-stdout-buffer) 1868 (copy-sequence (buffer-substring (point-min) 1869 (point-max)))) 1870 (artist-file-to-string tmp-stderr-file-name))) 1871 1872 ;; Unwind: remove temporary files and buffers 1873 (if (and stdin (file-exists-p tmp-stdin-file-name)) 1874 (delete-file tmp-stdin-file-name)) 1875 (if (file-exists-p tmp-stderr-file-name) 1876 (delete-file tmp-stderr-file-name)) 1877 (if (memq tmp-stdout-buffer (buffer-list)) 1878 (kill-buffer tmp-stdout-buffer)))))) 1879 1880;; Routines that deal with the buffer 1881;; 1882;; artist-current-line get line number (top of buffer is 0) 1883;; 1884;; artist-move-to-xy move to (x,y) (0,0) is beg-of-buffer 1885;; 1886;; artist-get-char-at-xy get char in at (x,y) 1887;; 1888;; artist-replace-char overwrite (replace) char at point 1889;; artist-replace-chars overwrite (replace) chars at point 1890;; 1891 1892(defsubst artist-current-column () 1893 "Return point's current column." 1894 (current-column)) 1895 1896(defsubst artist-current-line () 1897 "Return point's current line, buffer-relative. Top of buffer is 0." 1898 (+ (count-lines 1 (point)) 1899 (if (= (current-column) 0) 1 0) 1900 -1)) 1901 1902(defsubst artist-move-to-xy (x y) 1903 "Move to column X, at row Y from the top of buffer. Top line is 0." 1904 ;; 1905 ;; Q: Why do we do forward-line twice? 1906 ;; A: The documentation for forward-line says 1907 ;; 1908 ;; "... Returns the count of lines left to move. ... With 1909 ;; positive N, a non-empty line at the end counts as one 1910 ;; line successfully moved (for the return value)." 1911 ;; 1912 ;; This means that if we are trying to move forward past the end 1913 ;; of the buffer, and that last line happened to be longer than 1914 ;; the current column, then we end up at the end of that last 1915 ;; line, and forward-line returns one less than we actually 1916 ;; wanted to move. 1917 ;; 1918 ;; Example: In the figure below, the `X' is the very last 1919 ;; character in the buffer ("a non-empty line at the 1920 ;; end"). Suppose point is at at P. Then (forward-line 1) 1921 ;; returns 0 and puts point after the `X'. 1922 ;; 1923 ;; --------top of buffer-------- 1924 ;; 1925 ;; P X 1926 ;; -------bottom of buffer------ 1927 ;; 1928 ;; But, if we are at the end of buffer when trying to move 1929 ;; forward, then forward-line will return the (for us) correct 1930 ;; value, which is good, because we will come to the end of the 1931 ;; buffer by the first forward-line. The second forward-line 1932 ;; will then get us where we really wanted to go. 1933 ;; 1934 ;; If we are not moving past the end of the buffer, then the 1935 ;; second forward-line will return 0. 1936 ;; 1937 ;; Q: What happens if we are moving upwards? 1938 ;; A: That will work good. insert-char won't insert a negative 1939 ;; number of chars, and forward-line will fail silently if we are 1940 ;; moving past the beginning of the buffer. 1941 ;; 1942 (forward-line (- y (artist-current-line))) 1943 (insert-char ?\n (forward-line (- y (artist-current-line)))) 1944 (move-to-column (max x 0) t) 1945 (let ((curr-y (artist-current-line))) 1946 (setq artist-draw-region-min-y (min curr-y artist-draw-region-min-y)) 1947 (setq artist-draw-region-max-y (max curr-y artist-draw-region-max-y)))) 1948 1949(defsubst artist-get-char-at-xy (x y) 1950 "Return the character found at column X, row Y. 1951Also updates the variables `artist-draw-min-y' and `artist-draw-max-y'." 1952 (artist-move-to-xy x y) 1953 (let ((curr-y (artist-current-line))) 1954 (setq artist-draw-region-min-y (min curr-y artist-draw-region-min-y)) 1955 (setq artist-draw-region-max-y (max curr-y artist-draw-region-max-y))) 1956 (following-char)) 1957 1958 1959(defun artist-get-char-at-xy-conv (x y) 1960 "Retrieve the character at X, Y, converting tabs and new-lines to spaces." 1961 (save-excursion 1962 (aref artist-replacement-table (artist-get-char-at-xy x y)))) 1963 1964 1965(defun artist-replace-char (new-char) 1966 "Replace the character at point with NEW-CHAR." 1967 ;; Check that the variable exists first. The doc says it was added in 19.23. 1968 (if (and (and (boundp 'emacs-major-version) (= emacs-major-version 20)) 1969 (and (boundp 'emacs-minor-version) (<= emacs-minor-version 3))) 1970 ;; This is a bug workaround for Emacs 20, versions up to 20.3: 1971 ;; The self-insert-command doesn't care about the overwrite-mode, 1972 ;; so the insertion is done in the same way as in picture mode. 1973 ;; This seems to be a little bit slower. 1974 (progn 1975 (artist-move-to-xy (1+ (artist-current-column)) 1976 (artist-current-line)) 1977 (delete-char -1) 1978 (insert (aref artist-replacement-table new-char))) 1979 ;; In emacs-19, the self-insert-command works better and faster 1980 (let ((overwrite-mode 'overwrite-mode-textual) 1981 (fill-column 32765) ; Large :-) 1982 (blink-matching-paren nil)) 1983 (setq last-command-event (aref artist-replacement-table new-char)) 1984 (self-insert-command 1)))) 1985 1986(defun artist-replace-chars (new-char count) 1987 "Replace characters at point with NEW-CHAR. COUNT chars are replaced." 1988 ;; Check that the variable exists first. The doc says it was added in 19.23. 1989 (if (and (and (boundp 'emacs-major-version) (= emacs-major-version 20)) 1990 (and (boundp 'emacs-minor-version) (<= emacs-minor-version 3))) 1991 ;; This is a bug workaround for Emacs 20, versions up to 20.3: 1992 ;; The self-insert-command doesn't care about the overwrite-mode, 1993 ;; so the insertion is done in the same way as in picture mode. 1994 ;; This seems to be a little bit slower. 1995 (let* ((replaced-c (aref artist-replacement-table new-char)) 1996 (replaced-s (make-string count replaced-c))) 1997 (artist-move-to-xy (+ (artist-current-column) count) 1998 (artist-current-line)) 1999 (delete-char (- count)) 2000 (insert replaced-s)) 2001 ;; In emacs-19, the self-insert-command works better 2002 (let ((overwrite-mode 'overwrite-mode-textual) 2003 (fill-column 32765) ; Large :-) 2004 (blink-matching-paren nil)) 2005 (setq last-command-event (aref artist-replacement-table new-char)) 2006 (self-insert-command count)))) 2007 2008(defsubst artist-replace-string (string &optional see-thru) 2009 "Replace contents at point with STRING. 2010With optional argument SEE-THRU, set to non-nil, text in the buffer 2011``shines thru'' blanks in the STRING." 2012 (let ((char-list (append string nil)) ; convert the string to a list 2013 (overwrite-mode 'overwrite-mode-textual) 2014 (fill-column 32765) ; Large :-) 2015 (blink-matching-paren nil)) 2016 (while char-list 2017 (let ((c (car char-list))) 2018 (if (and see-thru (= (aref artist-replacement-table c) ?\s)) 2019 (artist-move-to-xy (1+ (artist-current-column)) 2020 (artist-current-line)) 2021 (artist-replace-char c))) 2022 (setq char-list (cdr char-list))))) 2023 2024;; 2025;; Routines for setting and unsetting points 2026;; Used when not rubber-banding 2027;; 2028(defun artist-no-rb-unset-point1 () 2029 "Unsets point 1 when not rubber-banding." 2030 (let ((x-now (artist-current-column)) 2031 (y-now (artist-current-line)) 2032 (x (aref artist-rb-save-data 0)) 2033 (y (aref artist-rb-save-data 1))) 2034 (artist-move-to-xy x y) 2035 (artist-replace-char (aref artist-rb-save-data 2)) 2036 (artist-move-to-xy x-now y-now))) 2037 2038(defun artist-no-rb-set-point1 (x y) 2039 "Set point 1 at X, Y when not rubber-banding." 2040 (let ((x-now (artist-current-column)) 2041 (y-now (artist-current-line))) 2042 (aset artist-rb-save-data 0 x) 2043 (aset artist-rb-save-data 1 y) 2044 (aset artist-rb-save-data 2 (artist-get-char-at-xy x y)) 2045 (artist-move-to-xy x y) 2046 (artist-replace-char artist-first-char) 2047 (artist-move-to-xy x-now y-now) 2048 (aset artist-rb-save-data 6 0))) 2049 2050(defun artist-no-rb-unset-point2 () 2051 "This function unsets point 2 when not rubber-banding." 2052 (if (= (aref artist-rb-save-data 6) 1) 2053 (let ((x-now (artist-current-column)) 2054 (y-now (artist-current-line)) 2055 (x (aref artist-rb-save-data 3)) 2056 (y (aref artist-rb-save-data 4))) 2057 (artist-move-to-xy x y) 2058 (artist-replace-char (aref artist-rb-save-data 5)) 2059 (artist-move-to-xy x-now y-now)))) 2060 2061(defun artist-no-rb-set-point2 (x y) 2062 "Set point 2 at X, Y when not rubber-banding." 2063 (let ((x-now (artist-current-column)) 2064 (y-now (artist-current-line))) 2065 (aset artist-rb-save-data 3 x) 2066 (aset artist-rb-save-data 4 y) 2067 (aset artist-rb-save-data 5 (artist-get-char-at-xy x y)) 2068 (artist-move-to-xy x y) 2069 (artist-replace-char artist-second-char) 2070 (artist-move-to-xy x-now y-now) 2071 (aset artist-rb-save-data 6 1))) 2072 2073(defun artist-no-rb-unset-points () 2074 "This function unsets point 1 and 2 when not rubber-banding." 2075 (artist-no-rb-unset-point1) 2076 (artist-no-rb-unset-point2)) 2077 2078 2079;; artist-intersection-char 2080;; 2081;; Note: If changing this, see the notes for artist-unintersection-char 2082;; and artist-vaporize-lines 2083;; 2084(defun artist-intersection-char (new-c old-c) 2085 "Calculates intersection character when drawing a NEW-C on top of an OLD-C. 2086Return character according to this scheme: 2087 2088 OLD-C NEW-C return 2089 - | + 2090 | - + 2091 + | + 2092 + - + 2093 \\ / X 2094 / \\ X 2095 X / X 2096 X \\ X 2097 other combinations NEW-C" 2098 2099 (cond ((and (= old-c ?- ) (= new-c ?| )) ?+ ) 2100 ((and (= old-c ?| ) (= new-c ?- )) ?+ ) 2101 ((and (= old-c ?+ ) (= new-c ?- )) ?+ ) 2102 ((and (= old-c ?+ ) (= new-c ?| )) ?+ ) 2103 ((and (= old-c ?\\ ) (= new-c ?/ )) ?X ) 2104 ((and (= old-c ?/ ) (= new-c ?\\ )) ?X ) 2105 ((and (= old-c ?X ) (= new-c ?/ )) ?X ) 2106 ((and (= old-c ?X ) (= new-c ?\\ )) ?X ) 2107 (t new-c))) 2108 2109;; artist-unintersection-char 2110;; 2111;; Note: If changing this, see the note for artist-vaporize-lines 2112;; 2113(defun artist-unintersection-char (line-c buffer-c) 2114 "Restore character to before intersection when removing LINE-C from BUFFER-C. 2115Return character according to this scheme: 2116 2117 LINE-C BUFFER-C return 2118 - + | 2119 | + - 2120 \\ X / 2121 / X \\ 2122 other combinations `artist-erase-char'." 2123 2124 (cond ((and (= line-c ?- ) (= buffer-c ?+ )) ?| ) 2125 ((and (= line-c ?| ) (= buffer-c ?+ )) ?- ) 2126 ((and (= line-c ?\\ ) (= buffer-c ?X )) ?/ ) 2127 ((and (= line-c ?/ ) (= buffer-c ?X )) ?\\ ) 2128 ((= line-c buffer-c) artist-erase-char) 2129 (t buffer-c))) 2130 2131 2132;; Computing the line-char to use 2133;; for use with borderless shapes 2134;; 2135(defsubst artist-compute-line-char () 2136 "Compute which character to use for lines, if any. 2137Return value is either nil for the default characters that make up lines, or 2138a character chosen depending on the variables `artist-borderless-shapes', 2139`artist-fill-char-set', `artist-fill-char' and 2140`artist-line-char-set' and `artist-line-char'." 2141 (if (and artist-borderless-shapes artist-fill-char-set) 2142 artist-fill-char 2143 (if artist-line-char-set 2144 artist-line-char 2145 nil))) 2146 2147 2148;; Things for drawing horizontal, vertical and diagonal (straight) lines. 2149;; 2150;; A line here is a vector: 2151;; [ start-x start-y length direction saved-char-1 saved-char-2 ... ] 2152;; directions start with 0 at the x-axis and counts anti clockwise. 2153;; 2154(defvar artist-direction-info 2155 ;; x y char 2156 [ [ 1 0 ?- ] ; direction 0 2157 [ 1 1 ?\\ ] ; direction 1 2158 [ 0 1 ?| ] ; direction 2 2159 [ -1 1 ?/ ] ; direction 3 2160 [ -1 0 ?- ] ; direction 4 2161 [ -1 -1 ?\\ ] ; direction 5 2162 [ 0 -1 ?| ] ; direction 6 2163 [ 1 -1 ?/ ] ] ; direction 7 2164 "Table used for stepping x and y coordinates in a specific direction. 2165This table is also used for determining which char to use for that direction.") 2166 2167(defsubst artist-direction-step-x (direction) 2168 "Return the x-step for DIRECTION from the `artist-direction-info' table." 2169 (aref (aref artist-direction-info direction) 0)) 2170 2171(defsubst artist-direction-step-y (direction) 2172 "Return the y-step for DIRECTION from the `artist-direction-info' table." 2173 (aref (aref artist-direction-info direction) 1)) 2174 2175(defun artist-direction-char (direction) 2176 "Return the character for DIRECTION from the `artist-direction-info' table." 2177 (aref (aref artist-direction-info direction) 2)) 2178 2179;; artist-find-direction 2180;; 2181;; 2182;; 2183(defun artist-find-direction (x1 y1 x2 y2) 2184 "Find the direction from point X1,Y1 to X2,Y2. 2185Returns a DIRECTION, a number 0--7, coded as follows: 2186 2187 5 6 7 2188 \\ | / 2189 4 - * - 0 2190 / | \\ 2191 3 2 1" 2192 (let ((delta-x (- x2 x1)) 2193 (delta-y (- y2 y1))) 2194 (cond ((>= delta-x (* 2 (abs delta-y))) 0) 2195 ((>= delta-y (* 2 (abs delta-x))) 2) 2196 ((>= (- delta-x) (* 2 (abs delta-y))) 4) 2197 ((>= (- delta-y) (* 2 (abs delta-x))) 6) 2198 ((and (>= delta-x 0) (>= delta-y 0)) 1) 2199 ((and (<= delta-x 0) (>= delta-y 0)) 3) 2200 ((and (<= delta-x 0) (<= delta-y 0)) 5) 2201 ((and (>= delta-x 0) (<= delta-y 0)) 7)))) 2202 2203(defun artist-straight-calculate-length (direction x1 y1 x2 y2) 2204 "Calculate length for a straight line in DIRECTION from X1,Y1 to X2,Y2." 2205 (cond ((or (= direction 7) 2206 (= direction 0) 2207 (= direction 1)) (1+ (- x2 x1))) 2208 ((or (= direction 3) 2209 (= direction 4) 2210 (= direction 5)) (1+ (- x1 x2))) 2211 (t (1+ (abs (- y2 y1)))))) 2212 2213(defun artist-sline (x1 y1 x2 y2) 2214 "Create a straight line from X1,Y1 to X2,Y2." 2215 (let* ((direction (artist-find-direction x1 y1 x2 y2)) 2216 (length (artist-straight-calculate-length direction x1 y1 x2 y2)) 2217 (line (make-vector (+ length 4) x1))) 2218 ;; not needed: 2219 ;; (aset line 0 x1) 2220 ;; because we set all elements to x1 2221 (aset line 1 y1) 2222 (aset line 2 length) 2223 (aset line 3 direction) 2224 line)) 2225 2226(defun artist-save-chars-under-sline (line) 2227 "Save characters under a LINE." 2228 (let ((x (aref line 0)) 2229 (y (aref line 1)) 2230 (length (+ (aref line 2) 4)) 2231 (direction (aref line 3)) 2232 (i 4)) 2233 (while (< i length) 2234 (aset line i (artist-get-char-at-xy x y)) 2235 (setq x (+ x (artist-direction-step-x direction))) 2236 (setq y (+ y (artist-direction-step-y direction))) 2237 (setq i (1+ i)))) 2238 line) 2239 2240 2241 2242;; Things for drawing lines in all directions. 2243;; The line drawing engine is the eight-point alrogithm. 2244;; 2245;; A line is here a list of (x y saved-char new-char)s. 2246;; 2247(defvar artist-octant-info 2248 ;; Initial Step in Step in 2249 ;; coeffs x and y x and y 2250 ;; for if q >= 0 if g < 0 2251 ;; dfdx,dfdy 2252 [ [ 2 1 1 0 1 1 ] ; 1st octant 2253 [ 1 2 1 1 0 1 ] ; 2nd octant 2254 [ -1 2 0 1 -1 1 ] ; 3rd octant 2255 [ -2 1 -1 1 -1 0 ] ; 4th octant 2256 [ -2 -1 -1 0 -1 -1 ] ; 5th octant 2257 [ -1 -2 -1 -1 0 -1 ] ; 6th octant 2258 [ 1 -2 0 -1 1 -1 ] ; 7th octant 2259 [ 2 -1 1 -1 1 0 ] ] ; 8th octant 2260 "Table used by line drawing algorithm (eight point).") 2261 2262;; Primitives for the artist-octant-info. 2263;; Decrease octant by 1 since elt counts from 0 and octant counts from 1. 2264;; 2265(defsubst artist-get-dfdx-init-coeff (octant) 2266 "Retrieve dfdx component for OCTANT." 2267 (aref (aref artist-octant-info (- octant 1)) 0)) 2268 2269(defsubst artist-get-dfdy-init-coeff (octant) 2270 "Retrieve dfdy component for OCTANT." 2271 (aref (aref artist-octant-info (- octant 1)) 1)) 2272 2273(defsubst artist-get-x-step-q>=0 (octant) 2274 "Retrieve x-step component for OCTANT when q >= 0." 2275 (aref (aref artist-octant-info (- octant 1)) 2)) 2276 2277(defsubst artist-get-y-step-q>=0 (octant) 2278 "Retrieve y-step component for OCTANT when q >= 0." 2279 (aref (aref artist-octant-info (- octant 1)) 3)) 2280 2281(defsubst artist-get-x-step-q<0 (octant) 2282 "Retrieve x-step component for OCTANT for q < 0." 2283 (aref (aref artist-octant-info (- octant 1)) 4)) 2284 2285(defsubst artist-get-y-step-q<0 (octant) 2286 "Retrieve y-step component for OCTANT for q < 0." 2287 (aref (aref artist-octant-info (- octant 1)) 5)) 2288 2289 2290;; Find octant from x1 y1 x2 y2 coordinates. 2291;; 2292(defun artist-find-octant (x1 y1 x2 y2) 2293 "Find octant for a line from X1,Y1 to X2,Y2. 2294Octant are numbered 1--8, anti-clockwise as: 2295 2296 \\3|2/ 2297 4\\|/1 2298 ---+--- 2299 5/|\\8 2300 /6|7\\" 2301 2302 (if (<= x1 x2) ; quadrant 1 or 4 2303 (if (<= y1 y2) ; quadrant 1, octant 1 or 2 2304 (if (>= (- x2 x1) (- y2 y1)) 2305 1 2306 2) 2307 (if (>= (- x2 x1) (- (- y2 y1))) ; quadrant 4, octant 7 or 8 2308 8 2309 7)) 2310 (if (<= y1 y2) ; quadrant 2 or 3 2311 (if (>= (- (- x2 x1)) (- y2 y1)) ; quadrant 2, octant 3 or 4 2312 4 2313 3) 2314 (if (>= (- (- x2 x1)) (- (- y2 y1))) ; quadrant 3, octant 5 or 6 2315 5 2316 6)))) 2317 2318;; Some inline funtions for creating, setting and reading 2319;; members of a coordinate 2320;; 2321(defsubst artist-new-coord (x y &optional new-char) 2322 "Create a new coordinate at X,Y for use in a line. 2323Optional argument NEW-CHAR can be used for setting the new-char component 2324in the coord." 2325 (let ((coord (make-vector 4 x))) 2326 (aset coord 1 y) 2327 (aset coord 3 new-char) 2328 coord)) 2329 2330(defsubst artist-coord-get-x (coord) 2331 "Retrieve the x component of a COORD." 2332 (aref coord 0)) 2333 2334(defsubst artist-coord-get-y (coord) 2335 "Retrieve the y component of a COORD." 2336 (aref coord 1)) 2337 2338(defsubst artist-coord-set-x (coord new-x) 2339 "Set the x component of a COORD to NEW-X." 2340 (aset coord 0 new-x) 2341 coord) 2342 2343(defsubst artist-coord-set-y (coord new-y) 2344 "Set the y component of a COORD to NEW-Y." 2345 (aset coord 1 new-y) 2346 coord) 2347 2348(defsubst artist-coord-get-saved-char (coord) 2349 "Retrieve the saved char component of a COORD." 2350 (aref coord 2)) 2351 2352(defsubst artist-coord-get-new-char (coord) 2353 "Retrieve the new char component of a COORD." 2354 (aref coord 3)) 2355 2356(defsubst artist-coord-add-saved-char (coord saved-char) 2357 "Set the saved char component of a COORD to SAVED-CHAR." 2358 (aset coord 2 saved-char) 2359 coord) 2360 2361(defsubst artist-coord-add-new-char (coord new-char) 2362 "Set the new char component of a COORD to NEW-CHAR." 2363 (aset coord 3 new-char) 2364 coord) 2365 2366(defsubst artist-coord-set-new-char (coord new-char) 2367 "Set the new char component of a COORD to NEW-CHAR." 2368 (aset coord 3 new-char) 2369 coord) 2370 2371 2372;; Pretend we are plotting a pixel. Instead we just list it 2373;; 2374(defmacro artist-put-pixel (point-list x y) 2375 "In POINT-LIST, store a ``pixel'' at coord X,Y." 2376 (list 'setq point-list 2377 (list 'append point-list (list 'list (list 'artist-new-coord x y))))) 2378 2379;; Calculate list of points using eight point algorithm 2380;; return a list of coords 2381;; 2382(defun artist-eight-point (x1 y1 x2 y2) 2383 "Run the eight-point algorithm to get a list of coords from X1,Y1 to X2,Y2." 2384 (let* ((point-list nil) 2385 (octant (artist-find-octant x1 y1 x2 y2)) 2386 (dfdx-coeff (artist-get-dfdx-init-coeff octant)) 2387 (dfdy-coeff (artist-get-dfdy-init-coeff octant)) 2388 (x-step-q>=0 (artist-get-x-step-q>=0 octant)) 2389 (y-step-q>=0 (artist-get-y-step-q>=0 octant)) 2390 (x-step-q<0 (artist-get-x-step-q<0 octant)) 2391 (y-step-q<0 (artist-get-y-step-q<0 octant)) 2392 (dfdx (- (- y2 y1))) 2393 (dfdy (- x2 x1)) 2394 (x x1) 2395 (y y1) 2396 (f 0) 2397 (q (+ (* 2 f) 2398 (* dfdx-coeff dfdx) 2399 (* dfdy-coeff dfdy)))) 2400 (artist-put-pixel point-list x y) 2401 (while (or (not (eq x x2)) (not (eq y y2))) 2402 (if (>= q 0) 2403 (progn 2404 (setq x (+ x x-step-q>=0)) 2405 (setq y (+ y y-step-q>=0)) 2406 (setq f (+ f (* x-step-q>=0 dfdx) (* y-step-q>=0 dfdy)))) 2407 (progn 2408 (setq x (+ x x-step-q<0)) 2409 (setq y (+ y y-step-q<0)) 2410 (setq f (+ f (* x-step-q<0 dfdx) (* y-step-q<0 dfdy))))) 2411 (setq q (+ (* 2 f) (* dfdx-coeff dfdx) (* dfdy-coeff dfdy))) 2412 (artist-put-pixel point-list x y)) 2413 point-list)) 2414 2415;; artist-save-chars-under-point-list 2416;; Remebers the chars that were there before we did draw the line. 2417;; Returns point-list. 2418;; 2419(defun artist-save-chars-under-point-list (point-list) 2420 "Save characters originally under POINT-LIST." 2421 (mapcar 2422 (lambda (coord) 2423 (artist-coord-add-saved-char 2424 coord 2425 (artist-get-char-at-xy (artist-coord-get-x coord) 2426 (artist-coord-get-y coord)))) 2427 point-list)) 2428 2429;; artist-calculate-new-char, artist-calculate-new-chars 2430;; Calculates which char to insert depending on direction of point-list. 2431;; 2432;; Depending on new-coord's position relative to last-coord one of the 2433;; following chars are returned: \ | / - o, as indicated by this: 2434;; 2435;; \ | / 2436;; - o - 2437;; / | \ 2438;; 2439;; artist-calculate-new-char works on one coordinate, returns char. 2440;; artist-calculate-new-chars works on a point-list, returns point-list. 2441;; 2442(defun artist-calculate-new-char (last-coord new-coord) 2443 "Return a line-char to use when moving from LAST-COORD to NEW-COORD." 2444 (let ((last-x (artist-coord-get-x last-coord)) 2445 (last-y (artist-coord-get-y last-coord)) 2446 (new-x (artist-coord-get-x new-coord)) 2447 (new-y (artist-coord-get-y new-coord))) 2448 (cond ((> new-x last-x) (cond ((< new-y last-y) ?/ ) 2449 ((> new-y last-y) ?\\ ) 2450 (t ?- ))) 2451 ((< new-x last-x) (cond ((< new-y last-y) ?\\ ) 2452 ((> new-y last-y) ?/ ) 2453 (t ?- ))) 2454 ((eq new-y last-y) ?o) 2455 (t ?| )))) 2456 2457(defun artist-calculate-new-chars (point-list) 2458 "Return a list of coords with line-chars calculated. Input: POINT-LIST." 2459 (if (null (cdr point-list)) 2460 (list (artist-coord-add-new-char (car point-list) ?o )) 2461 (let ((last-coord (car point-list))) 2462 (cons (artist-coord-add-new-char 2463 (car point-list) 2464 (artist-calculate-new-char (car (cdr point-list)) 2465 (car point-list))) 2466 (mapcar 2467 (lambda (this-coord) 2468 (prog1 2469 (artist-coord-add-new-char 2470 this-coord 2471 (artist-calculate-new-char last-coord this-coord)) 2472 (setq last-coord this-coord))) 2473 (cdr point-list)))))) 2474 2475;; artist-modify-new-chars 2476;; Replaces some characters with some other characters. 2477;; 2478;; artist-modify-new-chars works on a point-list, returns point-list. 2479;; 2480(defun artist-modify-new-chars (point-list) 2481 "Replace intersecting characters in POINT-LIST. 2482This function returns a point-list." 2483 (mapcar 2484 (lambda (coord) 2485 (let* ((new-c (artist-coord-get-new-char coord)) 2486 (saved-c (artist-coord-get-saved-char coord)) 2487 (modified-c (artist-intersection-char new-c saved-c))) 2488 (artist-coord-set-new-char coord modified-c))) 2489 point-list)) 2490 2491 2492;; 2493;; functions for accessing endoints and elements in object requiring 2494;; 2 endpoints 2495;; 2496 2497(defun artist-make-endpoint (x y) 2498 "Create an endpoint at X, Y." 2499 (let ((new-endpoint (make-vector 2 x))) 2500 (aset new-endpoint 1 y) 2501 new-endpoint)) 2502 2503(defun artist-endpoint-get-x (endpoint) 2504 "Retrieve the x component of an ENDPOINT." 2505 (aref endpoint 0)) 2506 2507(defun artist-endpoint-get-y (endpoint) 2508 "Retrieve the y component of an ENDPOINT." 2509 (aref endpoint 1)) 2510 2511(defun artist-make-2point-object (endpoint1 endpoint2 shapeinfo) 2512 "Create a 2-point object of ENDPOINT1, ENDPOINT2 and SHAPEINFO." 2513 (list endpoint1 endpoint2 shapeinfo)) 2514 2515(defun artist-2point-get-endpoint1 (obj) 2516 "Retrieve the first endpoint of a 2-point object OBJ." 2517 (elt obj 0)) 2518 2519(defun artist-2point-get-endpoint2 (obj) 2520 "Retrieve the second endpoint of a 2-point object OBJ." 2521 (elt obj 1)) 2522 2523(defun artist-2point-get-shapeinfo (obj) 2524 "Retrieve the shapeinfo component of a 2-point object OBJ." 2525 (elt obj 2)) 2526 2527 2528;; 2529;; Drawing and undrawing lines (any direction) 2530;; 2531 2532(defun artist-draw-line (x1 y1 x2 y2) 2533 "Draws a line from X1, Y1 to X2, Y2. 2534 2535Output is a line, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO). 2536 2537END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 2538SHAPE-INFO is a list of vectors [X Y SAVED-CHAR NEW-CHAR]." 2539 (let ((endpoint1 (artist-make-endpoint x1 y1)) 2540 (endpoint2 (artist-make-endpoint x2 y2))) 2541 (artist-make-2point-object 2542 endpoint1 2543 endpoint2 2544 (mapcar 2545 (lambda (coord) 2546 (artist-move-to-xy (artist-coord-get-x coord) 2547 (artist-coord-get-y coord)) 2548 (if artist-line-char-set 2549 (artist-replace-char artist-line-char) 2550 (artist-replace-char (artist-coord-get-new-char coord))) 2551 coord) 2552 (artist-modify-new-chars 2553 (artist-calculate-new-chars 2554 (artist-save-chars-under-point-list 2555 (artist-eight-point x1 y1 x2 y2)))))))) 2556 2557(defun artist-undraw-line (line) 2558 "Undraws LINE." 2559 (mapcar 2560 (lambda (coord) 2561 (artist-move-to-xy (artist-coord-get-x coord) 2562 (artist-coord-get-y coord)) 2563 (artist-replace-char (artist-coord-get-saved-char coord)) 2564 coord) 2565 (artist-2point-get-shapeinfo line))) 2566 2567;; 2568;; Drawing and undrawing straight lines 2569;; 2570 2571(defun artist-draw-sline (x1 y1 x2 y2) 2572 "Draw a strait line from X1, Y1 to X2, Y2. 2573Straight lines are vertical, horizontal or diagonal lines. 2574They are faster to draw and most often they are what you need 2575when drawing a simple image. 2576 2577Output is a straight line, which is a list on the form 2578\(END-POINT-1 END-POINT-2 SHAPE-INFO). 2579 2580END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 2581SHAPE-INFO is a vector [START-X START-Y LENGTH-OF-LINE DIRECTION 2582 ORIGINAL-CHAR-1 ORIGINAL-CHAR-2 ... ]." 2583 (let* ((line (artist-save-chars-under-sline (artist-sline x1 y1 x2 y2))) 2584 (x (aref line 0)) 2585 (y (aref line 1)) 2586 (length (+ (aref line 2) 4)) 2587 (direction (aref line 3)) 2588 (line-char (artist-direction-char direction)) 2589 (i 4) 2590 (endpoint1 (artist-make-endpoint x y)) 2591 (endpoint2 nil)) 2592 (while (< i length) 2593 (artist-move-to-xy x y) 2594 (if artist-line-char-set 2595 (artist-replace-char artist-line-char) 2596 (artist-replace-char (artist-intersection-char 2597 line-char 2598 (aref line i)))) 2599 (if (not (< (1+ i) length)) 2600 ;; This is the last element. Set the second endpoint 2601 (setq endpoint2 (artist-make-endpoint x y))) 2602 (setq x (+ x (artist-direction-step-x direction))) 2603 (setq y (+ y (artist-direction-step-y direction))) 2604 (setq i (1+ i))) 2605 (artist-make-2point-object endpoint1 endpoint2 line))) 2606 2607 2608(defun artist-undraw-sline (line) 2609 "Undraw a straight line LINE." 2610 (if line 2611 (let* ((shape-info (artist-2point-get-shapeinfo line)) 2612 (x (aref shape-info 0)) 2613 (y (aref shape-info 1)) 2614 (length (+ (aref shape-info 2) 4)) 2615 (direction (aref shape-info 3)) 2616 (i 4)) 2617 (while (< i length) 2618 (artist-move-to-xy x y) 2619 (artist-replace-char (aref shape-info i)) 2620 (setq x (+ x (artist-direction-step-x direction))) 2621 (setq y (+ y (artist-direction-step-y direction))) 2622 (setq i (1+ i)))))) 2623 2624 2625;; 2626;; Drawing and undrawing rectangles and squares 2627;; 2628 2629(defun artist-draw-rect (x1 y1 x2 y2) 2630 "Draws a rectangle with corners at X1, Y1 and X2, Y2. 2631 2632Output is a rectangle, which is a list on the form 2633\(END-POINT-1 END-POINT-2 SHAPE-INFO). 2634 2635END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 2636SHAPE-INFO is a list of four straight lines." 2637 (let* ((artist-line-char (artist-compute-line-char)) 2638 (artist-line-char-set artist-line-char) 2639 (line1 (artist-draw-sline x1 y1 x2 y1)) 2640 (line2 (artist-draw-sline x2 y1 x2 y2)) 2641 (line3 (artist-draw-sline x2 y2 x1 y2)) 2642 (line4 (artist-draw-sline x1 y2 x1 y1)) 2643 (endpoint1 (artist-make-endpoint x1 y1)) 2644 (endpoint2 (artist-make-endpoint x2 y2))) 2645 (artist-make-2point-object endpoint1 2646 endpoint2 2647 (list line1 line2 line3 line4)))) 2648 2649(defun artist-undraw-rect (rectangle) 2650 "Undraws RECTANGLE." 2651 (if rectangle 2652 (let ((shape-info (artist-2point-get-shapeinfo rectangle))) 2653 (artist-undraw-sline (elt shape-info 3)) 2654 (artist-undraw-sline (elt shape-info 2)) 2655 (artist-undraw-sline (elt shape-info 1)) 2656 (artist-undraw-sline (elt shape-info 0))))) 2657 2658 2659(defun artist-rect-corners-squarify (x1 y1 x2 y2) 2660 "Compute square corners from rectangle corners at X1, Y1 and X2, Y2. 2661The square's first corner will be X1, Y1. The position of the second corner 2662depends on which of X2 and Y2 is most far away from X1, Y1." 2663 (let* ((delta-x (- x2 x1)) 2664 (delta-y (- y2 y1)) 2665 (delta-x-sign (if (< delta-x 0) -1 1)) 2666 (delta-y-sign (if (< delta-y 0) -1 1)) 2667 (new-x2) ; set below 2668 (new-y2)) ; set below 2669 2670 ;; Check which of x2 and y2 is most distant 2671 ;; take care to the aspect ratio 2672 (if (> (abs delta-x) (abs delta-y)) 2673 2674 ;; *** x2 more distant than y2 (with care taken to aspect ratio) 2675 (progn 2676 (setq new-x2 x2) 2677 (setq new-y2 (+ y1 (round (/ (* (abs delta-x) delta-y-sign) 2678 artist-aspect-ratio))))) 2679 2680 ;; *** y2 more distant than x2 (with care taken to aspect ratio) 2681 (progn 2682 (setq new-x2 (round (+ x1 (* (* (abs delta-y) delta-x-sign) 2683 artist-aspect-ratio)))) 2684 (setq new-y2 y2))) 2685 2686 ;; Return this 2687 (list x1 y1 new-x2 new-y2))) 2688 2689 2690(defun artist-draw-square (x1 y1 x2 y2) 2691 "Draw a square with corners at X1, Y1 and X2, Y2. 2692 2693Output is a square, which is a list on the form 2694\(END-POINT-1 END-POINT-2 SHAPE-INFO). 2695 2696END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 2697SHAPE-INFO is a list of four straight lines." 2698 (let* ((artist-line-char (artist-compute-line-char)) 2699 (artist-line-char-set artist-line-char) 2700 (square-corners (artist-rect-corners-squarify x1 y1 x2 y2)) 2701 (new-x1 (elt square-corners 0)) 2702 (new-y1 (elt square-corners 1)) 2703 (new-x2 (elt square-corners 2)) 2704 (new-y2 (elt square-corners 3)) 2705 (endpoint1 (artist-make-endpoint new-x1 new-y1)) 2706 (endpoint2 (artist-make-endpoint new-x2 new-y2)) 2707 (line1 (artist-draw-sline new-x1 new-y1 new-x2 new-y1)) 2708 (line2 (artist-draw-sline new-x2 new-y1 new-x2 new-y2)) 2709 (line3 (artist-draw-sline new-x2 new-y2 new-x1 new-y2)) 2710 (line4 (artist-draw-sline new-x1 new-y2 new-x1 new-y1))) 2711 (artist-make-2point-object endpoint1 2712 endpoint2 2713 (list line1 line2 line3 line4)))) 2714 2715(defun artist-undraw-square (square) 2716 "Undraws SQUARE." 2717 (if square 2718 (let ((shape-info (artist-2point-get-shapeinfo square))) 2719 (artist-undraw-sline (elt shape-info 3)) 2720 (artist-undraw-sline (elt shape-info 2)) 2721 (artist-undraw-sline (elt shape-info 1)) 2722 (artist-undraw-sline (elt shape-info 0))))) 2723 2724;; 2725;; Filling rectangles and squares 2726;; 2727 2728(defun artist-fill-rect (rect x1 y1 x2 y2) 2729 "Fill rectangle RECT from X1,Y1 to X2,Y2." 2730 (let ((x (1+ (min x1 x2))) 2731 (y (1+ (min y1 y2))) 2732 (x-max (max x1 x2)) 2733 (y-max (max y1 y2))) 2734 (let ((w (- x-max x))) 2735 (while (< y y-max) 2736 (artist-move-to-xy x y) 2737 (artist-replace-chars artist-fill-char w) 2738 (setq y (1+ y)))))) 2739 2740(defun artist-fill-square (square x1 y1 x2 y2) 2741 "Fills a SQUARE from X1,Y1 to X2,Y2." 2742 (let* ((square-corners (artist-rect-corners-squarify x1 y1 x2 y2)) 2743 (new-x1 (elt square-corners 0)) 2744 (new-y1 (elt square-corners 1)) 2745 (new-x2 (elt square-corners 2)) 2746 (new-y2 (elt square-corners 3)) 2747 (x (1+ (min new-x1 new-x2))) 2748 (y (1+ (min new-y1 new-y2))) 2749 (x-max (max new-x1 new-x2)) 2750 (y-max (max new-y1 new-y2)) 2751 (w (- x-max x))) 2752 (while (< y y-max) 2753 (artist-move-to-xy x y) 2754 (artist-replace-chars artist-fill-char w) 2755 (setq y (1+ y))))) 2756 2757 2758;; 2759;; Pen drawing 2760;; 2761 2762(defun artist-pen (x1 y1) 2763 "Draws a character at X1, Y1. 2764The character is replaced with the character in `artist-fill-char'." 2765 (artist-move-to-xy x1 y1) 2766 (artist-replace-char (if artist-line-char-set 2767 artist-line-char 2768 (if artist-fill-char-set 2769 artist-fill-char 2770 artist-default-fill-char)))) 2771 2772 2773(defun artist-pen-line (x1 y1) 2774 "Draws a line from last pen position to X1, Y1. 2775The character is replaced with the character in `artist-fill-char'. 2776This will store all points in `artist-key-poly-point-list' in reversed 2777order (I assume it is faster to cons to the beginning of the list than 2778to append to the end of the list, when doing free-hand drawing)." 2779 (let ((artist-line-char (if artist-line-char-set 2780 artist-line-char 2781 (if artist-fill-char-set 2782 artist-fill-char 2783 artist-default-fill-char)))) 2784 2785 ;; Draw line from last point to this 2786 (let ((x-last (car (car artist-key-poly-point-list))) 2787 (y-last (cdr (car artist-key-poly-point-list)))) 2788 (artist-move-to-xy x-last y-last) 2789 (artist-replace-char artist-line-char) 2790 (artist-draw-line x-last y-last x1 y1)) 2791 2792 ;; Update the point-list 2793 (setq artist-key-poly-point-list 2794 (cons (cons x1 y1) artist-key-poly-point-list)))) 2795 2796(defun artist-pen-reset-last-xy (x1 y1) 2797 "Reset the last x and y points to X1, Y1 when doing pen-drawing." 2798 (artist-clear-arrow-points) 2799 (setq artist-key-poly-point-list (list (cons x1 y1)))) 2800 2801 2802(defun artist-pen-set-arrow-points (x1 y1) 2803 "Set arrow points for pen drawing using X1, Y1. 2804Also, the `artist-key-poly-point-list' is reversed." 2805 2806 (setq artist-key-poly-point-list 2807 (artist-uniq artist-key-poly-point-list)) 2808 2809 (if (>= (length artist-key-poly-point-list) 2) 2810 2811 ;; Only set arrow-points if the point-list has two or more entries 2812 (let ((xn (car (car artist-key-poly-point-list))) 2813 (yn (cdr (car artist-key-poly-point-list))) 2814 (xn-1 (car (car (cdr artist-key-poly-point-list)))) 2815 (yn-1 (cdr (car (cdr artist-key-poly-point-list)))) 2816 (dirn)) ; direction for point n 2817 (setq artist-key-poly-point-list (reverse artist-key-poly-point-list)) 2818 (let ((x0 (car (car artist-key-poly-point-list))) 2819 (y0 (cdr (car artist-key-poly-point-list))) 2820 (x1 (car (car (cdr artist-key-poly-point-list)))) 2821 (y1 (cdr (car (cdr artist-key-poly-point-list)))) 2822 (dir0)) ; direction for point 0 2823 (setq dir0 (artist-find-direction x1 y1 x0 y0)) 2824 (setq dirn (artist-find-direction xn-1 yn-1 xn yn)) 2825 (setq artist-arrow-point-1 (artist-make-arrow-point x0 y0 dir0)) 2826 (setq artist-arrow-point-2 (artist-make-arrow-point xn yn dirn)))))) 2827 2828 2829;; 2830;; Text rendering 2831;; 2832(defun artist-figlet-run (text font extra-args) 2833 "Run figlet rendering TEXT using FONT. 2834EXTRA-ARGS for figlet, for the command line, may be specified." 2835 (let* ((figlet-args (cond ((and font extra-args) 2836 (cons (concat "-f" font) 2837 (artist-string-split extra-args "[ \t]+"))) 2838 (font (concat "-f" font)) 2839 (extra-args 2840 (artist-string-split extra-args "[ \t]+")) 2841 (t nil))) 2842 (figlet-output (artist-system artist-figlet-program text figlet-args)) 2843 (exit-code (elt figlet-output 0)) 2844 (stdout (elt figlet-output 1)) 2845 (stderr (elt figlet-output 2))) 2846 (if (not (= exit-code 0)) 2847 (error "Failed to render font: %s (%d)" stderr exit-code)) 2848 stdout)) 2849 2850(defun artist-figlet-get-font-list () 2851 "Read fonts in with the shell command. 2852Returns a list of strings." 2853 (let* ((cmd-interpreter "/bin/sh") 2854 (ls-cmd artist-figlet-list-fonts-command) 2855 (result (artist-system cmd-interpreter ls-cmd nil)) 2856 (exit-code (elt result 0)) 2857 (stdout (elt result 1)) 2858 (stderr (elt result 2))) 2859 (if (not (= exit-code 0)) 2860 (error "Failed to read available fonts: %s (%d)" stderr exit-code)) 2861 (artist-string-split stdout ".flf\n"))) 2862 2863(defun artist-figlet-choose-font () 2864 "Read any extra arguments for figlet." 2865 (interactive) 2866 (let* ((avail-fonts (artist-figlet-get-font-list)) 2867 (font (completing-read (concat "Select font (default " 2868 artist-figlet-default-font 2869 "): ") 2870 (mapcar 2871 (lambda (font) (cons font font)) 2872 avail-fonts)))) 2873 (if (string= font "") artist-figlet-default-font font))) 2874 2875(defun artist-figlet-get-extra-args () 2876 "Read any extra arguments for figlet." 2877 (let ((extra-args (read-string "Extra args to figlet: "))) 2878 (if (string= extra-args "") 2879 nil 2880 extra-args))) 2881 2882(defun artist-figlet (text) 2883 "Render TEXT using figlet." 2884 (let* ((figlet-font (artist-figlet-choose-font)) 2885 (figlet-extra-args (artist-figlet-get-extra-args))) 2886 (artist-figlet-run text figlet-font figlet-extra-args))) 2887 2888 2889(defun artist-text-insert-common (x y text see-thru) 2890 "At position X, Y, insert text TEXT. 2891If SEE-THRU is non-nil, then blanks in TEXT does not replace text 2892in the buffer." 2893 (let* ((string-list (artist-string-split text "\n")) 2894 (i 0) 2895 (len (length string-list))) 2896 (while (< i len) 2897 (artist-move-to-xy x (+ y i)) 2898 (artist-replace-string (car string-list) see-thru) 2899 (setq string-list (cdr string-list)) 2900 (setq i (1+ i))))) 2901 2902(defun artist-text-insert-see-thru (x y text) 2903 "At position X, Y, insert text TEXT. 2904Let text already in buffer shine thru the TEXT inserted." 2905 (artist-text-insert-common x y text t)) 2906 2907(defun artist-text-insert-overwrite (x y text) 2908 "At position X, Y, insert text TEXT. 2909Let blanks in TEXT overwrite any text already in the buffer." 2910 (artist-text-insert-common x y text nil)) 2911 2912(defun artist-text-see-thru (x y) 2913 "Prompt for text to render, render it at X,Y. 2914This is done by calling the function specified by 2915`artist-text-renderer-function', which must return a list of strings, 2916to be inserted in the buffer. 2917 2918Text already in the buffer ``shines thru'' blanks in the rendered text." 2919 (let* ((input-text (read-string "Type text to render: ")) 2920 (rendered-text (artist-funcall artist-text-renderer-function input-text))) 2921 (artist-text-insert-see-thru x y rendered-text))) 2922 2923 2924(defun artist-text-overwrite (x y) 2925 "Prompt for text to render, render it at X,Y. 2926This is done by calling the function specified by 2927`artist-text-renderer-function', which must return a list of strings, 2928to be inserted in the buffer. 2929 2930Blanks in the rendered text overwrites any text in the buffer." 2931 (let* ((input-text (read-string "Type text to render: ")) 2932 (rendered-text (artist-funcall artist-text-renderer-function input-text))) 2933 (artist-text-insert-overwrite x y rendered-text))) 2934 2935;; 2936;; Spraying 2937;; 2938 2939(defun artist-spray-get-interval () 2940 "Retrieves the interval for repeated spray." 2941 artist-spray-interval) 2942 2943(defun artist-spray-random-points (n radius) 2944 "Generate N random points within a radius of RADIUS. 2945Returns a list of points. Each point is on the form (X1 . Y1)." 2946 (let ((points)) 2947 (while (> n 0) 2948 (let* ((angle (* (random 359) (/ pi 180))) 2949 (dist (random radius)) 2950 (point (cons (round (* dist (cos angle))) 2951 (round (* dist (sin angle)))))) 2952 (setq points (cons point points))) 2953 (setq n (- n 1))) 2954 points)) 2955 2956(defun artist-spray (x1 y1) 2957 "Spray at X1, Y1." 2958 (let* ((num-points (* artist-spray-radius artist-spray-radius)) 2959 (spray-points (artist-spray-random-points num-points 2960 artist-spray-radius))) 2961 (while spray-points 2962 ;; Replace one spray point 2963 (let* ((point (car spray-points)) 2964 (x (+ x1 (car point))) 2965 (y (+ y1 (cdr point))) 2966 (buf-c (artist-get-char-at-xy-conv x y)) 2967 (this-c (memq buf-c artist-spray-chars)) 2968 (next-c (cond ((null this-c) artist-spray-new-char) 2969 ((null (cdr this-c)) (car this-c)) 2970 (t (car (cdr this-c)))))) 2971 (artist-move-to-xy x y) 2972 (artist-replace-char next-c)) 2973 2974 ;; Step to next spray point 2975 (setq spray-points (cdr spray-points))))) 2976 2977(defun artist-spray-clear-circle (circle x1 y1 x2 y2) 2978 "Clears circle CIRCLE at X1, Y1 through X2, Y2." 2979 (artist-undraw-circle circle)) 2980 2981(defun artist-spray-set-radius (circle x1 y1 x2 y2) 2982 "Set spray radius from CIRCLE at X1, Y1 through X2, Y2." 2983 (let ((dx (- x2 x1)) 2984 (dy (- y2 y1))) 2985 (setq artist-spray-radius (round (sqrt (+ (* dx dx) (* dy dy))))) 2986 (if (= 0 artist-spray-radius) 2987 (setq artist-spray-radius 1)))) 2988 2989;; 2990;; Erasing 2991;; 2992 2993(defun artist-erase-char (x1 y1) 2994 "Erases a character at X1, Y1. 2995The character is replaced with the character in `artist-erase-char'." 2996 (artist-move-to-xy x1 y1) 2997 (artist-replace-char artist-erase-char)) 2998 2999(defun artist-erase-rect (rect x1 y1 x2 y2) 3000 "Erase rectangle RECT from X1, Y1, X2, Y2." 3001 (let ((artist-line-char-set t) 3002 (artist-fill-char-set t) 3003 (artist-line-char artist-erase-char) 3004 (artist-fill-char artist-erase-char)) 3005 (artist-draw-rect x1 y1 x2 y2) 3006 (artist-fill-rect rect x1 y1 x2 y2))) 3007 3008 3009;; 3010;; Vaporizing (erasing) line and lines 3011;; 3012 3013 3014(defun artist-vap-find-endpoint (x1 y1 step-x step-y accept-set reject-set) 3015 "Find one endpoint for line through X1, Y1. 3016The endpoint is searched for in the direction defined by STEP-X, STEP-Y, 3017accepting characters in the list ACCEPT-SET, stopping immediately 3018when finding characters in the list REJECT-SET. Fuzziness, that is 3019the number of consecutive characters not in ACCEPT-SET to allow as 3020part of the line, is determined by the variable `artist-vaporize-fuzziness'. 3021An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3022 (let ((x x1) 3023 (y y1) 3024 (x-last x1) 3025 (y-last y1) 3026 (done nil)) 3027 (while (not done) 3028 (let ((c (artist-get-char-at-xy-conv x y))) 3029 (cond ((memq c reject-set) 3030 (setq done t)) 3031 3032 ;; We found a character we are accepting as part of the line. 3033 ;; Update position 3034 ((memq c accept-set) 3035 (setq x-last x 3036 y-last y 3037 x (+ x step-x) 3038 y (+ y step-y)) 3039 (if (or (< x 0) (< y 0)) ;stop at the edge 3040 (setq done t))) 3041 3042 ;; We found a character we are not accepting as part of 3043 ;; the line Search `artist-vaporize-fuzziness' 3044 ;; characters away from this position in the same 3045 ;; direction to see if there are any characters in the 3046 ;; accept-set. If not, we have found the endpoint. 3047 (t 3048 (let ((fuzziness artist-vaporize-fuzziness) 3049 (x-tmp x) 3050 (y-tmp y)) 3051 3052 ;; while we have more fuzziness left and we have not 3053 ;; found a character accepted as a line, move 3054 ;; forward! 3055 (while (and (> fuzziness 0) (not (memq c accept-set))) 3056 (setq x-tmp (+ x-tmp step-x)) 3057 (setq y-tmp (+ y-tmp step-y)) 3058 (setq c (artist-get-char-at-xy-conv x-tmp y-tmp)) 3059 (setq fuzziness (- fuzziness 1))) 3060 (if (memq c accept-set) 3061 3062 ;; The line continues on the other side of the 3063 ;; not-accepted character. 3064 (setq x x-tmp 3065 y y-tmp) 3066 3067 ;; Else: We couldn't find any line on the other side. 3068 ;; That means we are done searching for the endpoint. 3069 (setq done t))))))) 3070 (cons x-last y-last))) 3071 3072 3073(defun artist-vap-find-endpoints-horiz (x y) 3074 "Find endpoints for a horizontal line through X, Y. 3075An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3076 (list (artist-vap-find-endpoint x y 1 0 '(?- ?+) '(?\s)) 3077 (artist-vap-find-endpoint x y -1 0 '(?- ?+) '(?\s)))) 3078 3079(defun artist-vap-find-endpoints-vert (x y) 3080 "Find endpoints for a vertical line through X, Y. 3081An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3082 (list (artist-vap-find-endpoint x y 0 1 '(?| ?+) '(?\s)) 3083 (artist-vap-find-endpoint x y 0 -1 '(?| ?+) '(?\s)))) 3084 3085(defun artist-vap-find-endpoints-swne (x y) 3086 "Find endpoints for a diagonal line (made by /'s) through X, Y. 3087An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3088 (list (artist-vap-find-endpoint x y 1 -1 '(?/ ?X) '(?\s)) 3089 (artist-vap-find-endpoint x y -1 1 '(?/ ?X) '(?\s)))) 3090 3091(defun artist-vap-find-endpoints-nwse (x y) 3092 "Find endpoints for a diagonal line (made by \\'s) through X, Y. 3093An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3094 (list (artist-vap-find-endpoint x y 1 1 '(?\\ ?X) '(?\s)) 3095 (artist-vap-find-endpoint x y -1 -1 '(?\\ ?X) '(?\s)))) 3096 3097 3098(defun artist-vap-find-endpoints (x y) 3099 "Given a point X1, Y1, return a list of endpoints of lines through X, Y. 3100An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3101 (if artist-line-char-set 3102 nil 3103 (let ((c (artist-get-char-at-xy-conv x y))) 3104 (cond ((eq c ?-) (artist-vap-find-endpoints-horiz x y)) 3105 ((eq c ?|) (artist-vap-find-endpoints-vert x y)) 3106 ((eq c ?/) (artist-vap-find-endpoints-swne x y)) 3107 ((eq c ?\\) (artist-vap-find-endpoints-nwse x y)) 3108 ((eq c ?+) (append (artist-vap-find-endpoints-horiz x y) 3109 (artist-vap-find-endpoints-vert x y))) 3110 ((eq c ?X) (append (artist-vap-find-endpoints-swne x y) 3111 (artist-vap-find-endpoints-nwse x y))) 3112 3113 ;; We don't know how to find directions when we are on 3114 ;; another character 3115 (t nil))))) 3116 3117 3118(defun artist-vap-group-in-pairs (l) 3119 "Group elements in list L in pairs." 3120 (cond ((null l) nil) 3121 ((null (cdr l)) l) ; unevent number of elements in list 3122 (t (append (list (list (car l) (car (cdr l)))) 3123 (artist-vap-group-in-pairs (cdr (cdr l))))))) 3124 3125(defun artist-vaporize-by-endpoints (endpoint1 endpoint2) 3126 "Given ENDPOINT1 and ENDPOINT2, vaporize the line between them. 3127An endpoint is a pair (X . Y)." 3128 (let* ((x1 (car endpoint1)) 3129 (y1 (cdr endpoint1)) 3130 (x2 (car endpoint2)) 3131 (y2 (cdr endpoint2)) 3132 (dir (artist-find-direction x1 y1 x2 y2)) 3133 (x-step (aref [1 1 0 -1 -1 -1 0 1] dir)) 3134 (y-step (aref [0 1 1 1 0 -1 -1 -1] dir)) 3135 (line-c (aref [?- ?\\ ?| ?/ ?- ?\\ ?| ?/] dir)) 3136 (line-len (elt (list (abs (- x2 x1)) 3137 (abs (- x2 x1)) 3138 (abs (- y2 y1)) 3139 (abs (- y2 y1)) 3140 (abs (- x1 x2)) 3141 (abs (- x1 x2)) 3142 (abs (- y1 y2)) 3143 (abs (- y1 y2))) 3144 dir)) 3145 (x x1) 3146 (y y1)) 3147 (while (>= line-len 0) 3148 (let* ((buffer-c (artist-get-char-at-xy-conv x y)) 3149 (new-c (artist-unintersection-char line-c buffer-c))) 3150 (artist-move-to-xy x y) 3151 (artist-replace-char new-c)) 3152 (setq x (+ x x-step) 3153 y (+ y y-step) 3154 line-len (- line-len 1))))) 3155 3156 3157(defun artist-vaporize-line (x1 y1) 3158 "Vaporize (erase) the straight line through X1, Y1. 3159Do this by replacing the characters that forms the line with 3160`artist-erase-char'. Output is a list of endpoints for lines 3161through X1, Y1. An endpoint is a cons pair, (ENDPOINT-X . ENDPOINT-Y)." 3162 (let ((endpoints (artist-vap-find-endpoints x1 y1))) 3163 (mapcar 3164 (lambda (endpoints) 3165 (let ((ep1 (car endpoints)) 3166 (ep2 (car (cdr endpoints)))) 3167 (artist-vaporize-by-endpoints ep1 ep2))) 3168 (artist-vap-group-in-pairs endpoints)) 3169 endpoints)) 3170 3171 3172;; Implementation note: This depends on artist-vaporize-line doing 3173;; unintersections of intersecting lines. 3174;; 3175;; Example: 3176;; Suppose the buffer looks like this and that we start vaporizing 3177;; lines at (3,0) (at the ``*''). 3178;; 3179;; 0123456 3180;; 0+--*--+ 3181;; 1| | 3182;; 2| | 3183;; 3+-----+ 3184;; 3185;; We will then push (0,0) and (6,0) on the stack, and vaporize the 3186;; topmost horizontal line: 3187;; 3188;; 0123456 3189;; 0| | 3190;; 1| | 3191;; 2| | 3192;; 3+-----+ 3193;; 3194;; We will then pop (0,0) and remove the left-most vertival line while 3195;; pushing the lower left corner (0,3) on the stack, and so on until 3196;; the entire rectangle is vaporized. 3197;; 3198;; Now, What if the `+' in the upper left and upper right corners, 3199;; had not been changed to `|' but to spaces instead? We would 3200;; have failed when popping (0,0) and vaporizing that line because 3201;; we wouldn't find any line at (0,0): 3202;; 3203;; 0123456 3204;; 0 3205;; 1| | 3206;; 2| | 3207;; 3+-----+ 3208;; 3209;; That's why we depend on artist-vaporize-line doing unintersecting 3210;; of crossing lines. There are alternative ways to handle this 3211;; if it becomes too much a trouble. 3212;; 3213(defun artist-vaporize-lines (x1 y1) 3214 "Vaporize lines reachable from point X1, Y1." 3215 (let ((ep-stack nil)) 3216 (mapcar 3217 (lambda (ep) (push ep ep-stack)) 3218 (artist-vap-find-endpoints x1 y1)) 3219 (while (not (null ep-stack)) 3220 (let* ((vaporize-point (pop ep-stack)) 3221 (new-endpoints (artist-vaporize-line (car vaporize-point) 3222 (cdr vaporize-point)))) 3223 (mapcar 3224 (lambda (endpoint) (push endpoint ep-stack)) 3225 new-endpoints))))) 3226 3227 3228;; 3229;; Circles and ellipses 3230;; 3231(defun artist-ellipse-generate-quadrant (x-radius y-radius) 3232 "Create a point-list for first quadrant. 3233Points go from (X-RADIUS, 0) to (0, Y-RADIUS). 3234Quadrant is generated around origo." 3235 (let* ((rx2 (* x-radius x-radius)) 3236 (ry2 (* y-radius y-radius)) 3237 (2rx2 (* 2 rx2)) 3238 (2ry2 (* 2 ry2)) 3239 (p) 3240 (x 0) 3241 (y y-radius) 3242 (px 0) 3243 (py (* 2rx2 y)) 3244 (point-list nil)) 3245 (artist-put-pixel point-list x y) 3246 (setq p (round (+ ry2 (- (* rx2 y-radius)) (* 0.25 rx2)))) 3247 (while (< px py) 3248 (setq x (1+ x) 3249 px (+ px 2ry2)) 3250 (if (< p 0) 3251 (setq p (+ p ry2 px)) 3252 (setq y (- y 1) 3253 py (- py 2rx2) 3254 p (+ p ry2 px (- py)))) 3255 (artist-put-pixel point-list x y)) 3256 (setq p (round (+ (* ry2 (+ x 0.5) (+ x 0.5)) 3257 (* rx2 (- y 1) (- y 1)) 3258 (- (* rx2 ry2))))) 3259 (while (> y 0) 3260 (setq y (- y 1) 3261 py (- py 2rx2)) 3262 (if (> p 0) 3263 (setq p (+ p rx2 (- py))) 3264 (setq x (1+ x) 3265 px (+ px 2ry2) 3266 p (+ p rx2 (- py) px))) 3267 (artist-put-pixel point-list x y)) 3268 point-list)) 3269 3270(defsubst artist-new-fill-item (x y width) 3271 "Create a new item at X, Y, with WIDTH. 3272This is for use in fill-info in ellipses and circles." 3273 (let ((new-item (make-vector 3 x))) 3274 (aset new-item 1 y) 3275 (aset new-item 2 width) 3276 new-item)) 3277 3278(defsubst artist-fill-item-get-x (fill-item) 3279 "Retrieve the x component of a FILL-ITEM." 3280 (aref fill-item 0)) 3281 3282(defsubst artist-fill-item-set-x (fill-item new-x) 3283 "Set the x component of a FILL-ITEM to NEW-X." 3284 (aset fill-item 0 new-x) 3285 fill-item) 3286 3287(defsubst artist-fill-item-get-y (fill-item) 3288 "Retrieve the y component of a FILL-ITEM." 3289 (aref fill-item 1)) 3290 3291(defsubst artist-fill-item-set-y (fill-item new-y) 3292 "Set the y component of a FILL-ITEM to NEW-Y." 3293 (aset fill-item 1 new-y) 3294 fill-item) 3295 3296(defsubst artist-fill-item-get-width (fill-item) 3297 "Retrieve the width component of a FILL-ITEM." 3298 (aref fill-item 2)) 3299 3300(defsubst artist-fill-item-set-width (fill-item new-width) 3301 "Set the width component of a FILL-ITEM to NEW-WIDTH." 3302 (aset fill-item 2 new-width) 3303 fill-item) 3304 3305 3306(defun artist-ellipse-point-list-add-center (x-center y-center point-list) 3307 "Add offsets X-CENTER and Y-CENTER to coordinates in POINT-LIST." 3308 (mapcar 3309 (lambda (p) 3310 (artist-coord-set-x p (+ x-center (artist-coord-get-x p))) 3311 (artist-coord-set-y p (+ y-center (artist-coord-get-y p)))) 3312 point-list)) 3313 3314 3315(defun artist-ellipse-fill-info-add-center (x-center y-center fill-info) 3316 "Add offsets X-CENTER and Y-CENTER to fill-items in FILL-INFO." 3317 (mapcar 3318 (lambda (p) 3319 (artist-fill-item-set-x p (+ x-center (artist-fill-item-get-x p))) 3320 (artist-fill-item-set-y p (+ y-center (artist-fill-item-get-y p)))) 3321 fill-info)) 3322 3323(defun artist-ellipse-remove-0-fills (fill-info) 3324 "Remove fill-infos from FILL-INFO that fills a zero-width field." 3325 (cond ((null fill-info) 3326 nil) 3327 ((= 0 (artist-fill-item-get-width (car fill-info))) 3328 (artist-ellipse-remove-0-fills (cdr fill-info))) 3329 (t 3330 (append (list (car fill-info)) 3331 (artist-ellipse-remove-0-fills (cdr fill-info)))))) 3332 3333 3334(defun artist-ellipse-compute-fill-info (point-list) 3335 "Compute fill info for ellipse around 0,0 from POINT-LIST. 3336The POINT-LIST is expected to cover the first quadrant." 3337 (let ((first-half nil) 3338 (both-halves nil) 3339 (last-y nil)) 3340 3341 ;; Create first half (the lower one (since y grows downwards)) from 3342 ;; the first quadrant. 3343 (mapcar 3344 (lambda (coord) 3345 (let* ((x (artist-coord-get-x coord)) 3346 (y (artist-coord-get-y coord)) 3347 (width (max (- (* 2 x) 1) 0)) 3348 (left-edge (- x width))) 3349 (if (or (null last-y) (not (= y last-y))) 3350 ;; This was either the first time, 3351 ;; or it was the first time on a new line 3352 (setq first-half 3353 (append first-half 3354 ;; Fill info item starts at left-edge on line y 3355 (list (artist-new-fill-item left-edge y width))))) 3356 (setq last-y y))) 3357 point-list) 3358 3359 ;; Create the other half by mirroring the first half. 3360 (setq both-halves 3361 (append first-half 3362 (mapcar 3363 (lambda (i) 3364 (artist-new-fill-item (artist-fill-item-get-x i) 3365 (- (artist-fill-item-get-y i)) 3366 (artist-fill-item-get-width i))) 3367 ;; The cdr below is so we don't include fill-info for 3368 ;;; the middle line twice 3369 (cdr (reverse first-half))))) 3370 (artist-ellipse-remove-0-fills both-halves))) 3371 3372 3373(defun artist-ellipse-mirror-quadrant (point-list) 3374 "Mirror a POINT-LIST describing first quadrant to create a complete ellipse." 3375 (let ((right-half nil) 3376 (left-half nil)) 3377 3378 ;; First, if last char in that quadrant is `/', then replace it with `)' 3379 ;; This way we avoids things 3380 ;; --------- --------- 3381 ;; / \ / \ 3382 ;; that look like: \ / instead we get: ( ) 3383 ;; \ / \ / 3384 ;; --------- --------- 3385 (let ((last-coord (car (last point-list)))) 3386 (if (= (artist-coord-get-new-char last-coord) ?/) 3387 (artist-coord-set-new-char last-coord artist-ellipse-right-char))) 3388 3389 ;; Create the other part of the right half by mirroring the first part 3390 (setq right-half 3391 (append 3392 point-list 3393 (mapcar 3394 (lambda (coord) 3395 (let ((c (artist-coord-get-new-char coord))) 3396 (artist-new-coord (artist-coord-get-x coord) 3397 (- (artist-coord-get-y coord)) 3398 (cond ((= c ?/) ?\\) 3399 ((= c ?\\) ?/) 3400 (t c))))) 3401 ;; The cdr below is so we don't draw the middle right char twice 3402 (cdr (reverse point-list))))) 3403 3404 ;; Create the left half by mirroring the right half. 3405 (setq left-half 3406 (mapcar 3407 (lambda (coord) 3408 (let ((c (artist-coord-get-new-char coord))) 3409 (artist-new-coord (- (artist-coord-get-x coord)) 3410 (artist-coord-get-y coord) 3411 (cond ((= c ?/) ?\\) 3412 ((= c ?\\) ?/) 3413 ((= c artist-ellipse-right-char) 3414 artist-ellipse-left-char) 3415 (t c))))) 3416 ;; The cdr and butlast below is so we don't draw the middle top 3417 ;; and middle bottom char twice. 3418 (butlast (cdr (reverse right-half))))) 3419 (append right-half left-half))) 3420 3421 3422(defun artist-draw-ellipse-general (x1 y1 x-radius y-radius) 3423 "Draw an ellipse with center at X1, Y1 and X-RADIUS and Y-RADIUS. 3424 3425Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO). 3426 3427END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 3428SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO]. 3429 3430POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR]. 3431FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE]. 3432 3433Ellipses with zero Y-RADIUS are not drawn correctly." 3434 (let* ((point-list (artist-ellipse-generate-quadrant x-radius y-radius)) 3435 (fill-info (artist-ellipse-compute-fill-info point-list)) 3436 (shape-info (make-vector 2 0))) 3437 3438 (setq point-list (artist-calculate-new-chars point-list)) 3439 (setq point-list (artist-ellipse-mirror-quadrant point-list)) 3440 (setq point-list (artist-ellipse-point-list-add-center x1 y1 point-list)) 3441 (setq fill-info (artist-ellipse-fill-info-add-center x1 y1 fill-info)) 3442 3443 ;; Draw the ellipse 3444 (setq point-list 3445 (mapcar 3446 (lambda (coord) 3447 (artist-move-to-xy (artist-coord-get-x coord) 3448 (artist-coord-get-y coord)) 3449 (if artist-line-char-set 3450 (artist-replace-char artist-line-char) 3451 (artist-replace-char (artist-coord-get-new-char coord))) 3452 coord) 3453 (artist-modify-new-chars 3454 (artist-save-chars-under-point-list point-list)))) 3455 3456 (aset shape-info 0 point-list) 3457 (aset shape-info 1 fill-info) 3458 (artist-make-2point-object (artist-make-endpoint x1 y1) 3459 (artist-make-endpoint x-radius y-radius) 3460 shape-info))) 3461 3462(defun artist-draw-ellipse-with-0-height (x1 y1 x-radius y-radius) 3463 "Draw an ellipse with center at X1, Y1 and X-RADIUS and Y-RADIUS. 3464 3465Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO). 3466 3467END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 3468SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO]. 3469 3470POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR]. 3471FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE]. 3472 3473The Y-RADIUS must be 0, but the X-RADIUS must not be 0." 3474 (let ((point-list nil) 3475 (width (max (- (abs (* 2 x-radius)) 1))) 3476 (left-edge (1+ (- x1 (abs x-radius)))) 3477 (line-char (if artist-line-char-set artist-line-char ?-)) 3478 (i 0) 3479 (point-list nil) 3480 (fill-info nil) 3481 (shape-info (make-vector 2 0))) 3482 (while (< i width) 3483 (let* ((line-x (+ left-edge i)) 3484 (line-y y1) 3485 (new-coord (artist-new-coord line-x line-y))) 3486 (artist-coord-add-saved-char new-coord 3487 (artist-get-char-at-xy line-x line-y)) 3488 (artist-move-to-xy line-x line-y) 3489 (artist-replace-char line-char) 3490 (setq point-list (append point-list (list new-coord))) 3491 (setq i (1+ i)))) 3492 (aset shape-info 0 point-list) 3493 (aset shape-info 1 fill-info) 3494 (artist-make-2point-object (artist-make-endpoint x1 y1) 3495 (artist-make-endpoint x-radius y-radius) 3496 shape-info))) 3497 3498(defun artist-draw-ellipse (x1 y1 x2 y2) 3499 "Draw an ellipse with center at X1, Y1 and point X2,Y2. 3500 3501Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO). 3502 3503END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 3504SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO]. 3505 3506POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR]. 3507FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE]." 3508 (let* ((artist-line-char (artist-compute-line-char)) 3509 (artist-line-char-set artist-line-char) 3510 (width (abs (- x2 x1))) 3511 (height (abs (- y2 y1))) 3512 ;; 3513 ;; When we draw our ellipse, we want it to go through the cursor 3514 ;; position, but since x1,y1, x2,y2 marks the corners of one 3515 ;; of the quadrants, we have to enlarge the ellipse a bit. 3516 ;; Ok, so then why by sqrt(2)? 3517 ;; It comes from the equation for the ellipse (where a is the 3518 ;; x-radius and b is the y-radius): 3519 ;; f(x,y) = x^2 / a^2 + y^2 / b^2 - 1 = 0 3520 ;; and the fact that we want the enlarged ellipse to have the 3521 ;; same proportions as the smaller square, therefore we have: 3522 ;; a/b = x/y 3523 ;; Solving this yields a-in-larger-ellipse = a-in-smaller * sqrt(2) 3524 (x-radius (round (* width (sqrt 2)))) 3525 (y-radius (round (* height (sqrt 2)))) 3526 (x x1) 3527 (y y1)) 3528 (if (and (= y1 y2) (not (= x1 x2))) 3529 (artist-draw-ellipse-with-0-height x y x-radius y-radius) 3530 (artist-draw-ellipse-general x y x-radius y-radius)))) 3531 3532 3533(defun artist-undraw-ellipse (ellipse) 3534 "Undraw ELLIPSE." 3535 (if ellipse 3536 (let ((point-list (aref (artist-2point-get-shapeinfo ellipse) 0))) 3537 (mapcar 3538 (lambda (coord) 3539 (artist-move-to-xy (artist-coord-get-x coord) 3540 (artist-coord-get-y coord)) 3541 (artist-replace-char (artist-coord-get-saved-char coord)) 3542 coord) 3543 point-list)))) 3544 3545 3546(defun artist-draw-circle (x1 y1 x2 y2) 3547 "Draw a circle with center at X1, Y1 and point X2,Y2. 3548 3549Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO). 3550 3551END-POINT-1 and END-POINT-2 are two-element vectors on the form [X Y]. 3552SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO]. 3553 3554POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR]. 3555FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE]." 3556 (let* ((artist-line-char (artist-compute-line-char)) 3557 (artist-line-char-set artist-line-char) 3558 (width (abs (- x2 x1))) 3559 (height (abs (- y2 y1))) 3560 ;; When drawing our circle, we want it to through the cursor 3561 ;; just as when drawing the ellispe, but we have to take 3562 ;; care for the aspect-ratio. 3563 ;; The equation for the ellipse (where a is the x-radius and 3564 ;; b is the y-radius): 3565 ;; f(x,y) = x^2 / a^2 + y^2 / b^2 - 1 = 0 3566 ;; together with the relationship 3567 ;; a = aspect-ratio * b 3568 ;; gives 3569 ;; a = sqrt( x^2 + (aspect-ratio * y)^2 ) and 3570 ;; b = a / aspect-ratio 3571 (x-radius (round (sqrt (+ (* width width) 3572 (* (* artist-aspect-ratio height) 3573 (* artist-aspect-ratio height)))))) 3574 (y-radius (round (/ x-radius artist-aspect-ratio)))) 3575 (artist-draw-ellipse-general x1 y1 x-radius y-radius))) 3576 3577(defalias 'artist-undraw-circle 'artist-undraw-ellipse) 3578 3579 3580; 3581; Filling ellipses 3582; 3583(defun artist-fill-ellipse (ellipse x y x-radius y-radius) 3584 "Fill an ELLIPSE centered at X,Y with radius X-RADIUS and Y-RADIUS." 3585 (let ((fill-info (aref (artist-2point-get-shapeinfo ellipse) 1))) 3586 (mapcar 3587 (lambda (fill-item) 3588 (artist-move-to-xy (artist-fill-item-get-x fill-item) 3589 (artist-fill-item-get-y fill-item)) 3590 (artist-replace-chars artist-fill-char 3591 (artist-fill-item-get-width fill-item)) 3592 fill-item) 3593 fill-info))) 3594 3595(defalias 'artist-fill-circle 'artist-fill-ellipse) 3596 3597 3598;; 3599;; Cutting, copying and pasting rectangles and squares 3600;; (filling functions) 3601;; 3602 3603(defun artist-cut-rect (rect x1 y1 x2 y2) 3604 "Copy rectangle RECT drawn from X1, Y1 to X2, Y2, then clear it." 3605 (artist-undraw-rect rect) 3606 (artist-copy-generic x1 y1 x2 y2) 3607 (artist-erase-rect rect x1 y1 x2 y2)) 3608 3609(defun artist-cut-square (square x1 y1 x2 y2) 3610 "Copy a SQUARE drawn from X1, Y1 to X2, Y2 (made square), then clears it." 3611 (artist-undraw-square square) 3612 (let* ((square-corners (artist-rect-corners-squarify x1 y1 x2 y2)) 3613 (new-x1 (elt square-corners 0)) 3614 (new-y1 (elt square-corners 1)) 3615 (new-x2 (elt square-corners 2)) 3616 (new-y2 (elt square-corners 3))) 3617 (artist-copy-generic new-x1 new-y1 new-x2 new-y2) 3618 (artist-erase-rect square new-x1 new-y1 new-x2 new-y2))) 3619 3620 3621(defun artist-get-buffer-contents-at-xy (x y width) 3622 "Retrieve contents from the buffer at X, Y. WIDTH characters are returned." 3623 (artist-move-to-xy x y) 3624 (let ((here (point)) 3625 (there (save-excursion (artist-move-to-xy (+ x width) y) (point)))) 3626 (untabify here there) 3627 (setq there (save-excursion (artist-move-to-xy (+ x width) y) (point))) 3628 (buffer-substring here there))) 3629 3630 3631(defun artist-copy-generic (x1 y1 x2 y2) 3632 "Copy a rectangular area with corners at X1, Y1 and X2, Y2. 3633Output is a copy buffer, a list of strings, representing the 3634original contents of that area in the buffer." 3635 (let* ((x (min x1 x2)) 3636 (y (min y1 y2)) 3637 (x-max (max x1 x2)) 3638 (y-max (max y1 y2)) 3639 (w (+ (- x-max x) 1)) 3640 (l nil)) 3641 (while (<= y y-max) 3642 (setq l (cons (artist-get-buffer-contents-at-xy x y w) l)) 3643 (setq y (1+ y))) 3644 (if artist-interface-with-rect 3645 (setq killed-rectangle (reverse l)) 3646 (setq artist-copy-buffer (reverse l))))) 3647 3648 3649(defun artist-copy-rect (rect x1 y1 x2 y2) 3650 "Copy rectangle RECT drawn from X1, Y1 to X2, Y2." 3651 (artist-undraw-rect rect) 3652 (artist-copy-generic x1 y1 x2 y2)) 3653 3654(defun artist-copy-square (square x1 y1 x2 y2) 3655 "Copies a SQUARE drawn from X1, Y1 to X2, Y2 (but made square)." 3656 (artist-undraw-square square) 3657 (let* ((square-corners (artist-rect-corners-squarify x1 y1 x2 y2)) 3658 (new-x1 (elt square-corners 0)) 3659 (new-y1 (elt square-corners 1)) 3660 (new-x2 (elt square-corners 2)) 3661 (new-y2 (elt square-corners 3))) 3662 (artist-copy-generic new-x1 new-y1 new-x2 new-y2))) 3663 3664(defun artist-paste (x y) 3665 "Pastes the contents of the copy-buffer at X,Y." 3666 (let ((copy-buf (if artist-interface-with-rect 3667 killed-rectangle 3668 artist-copy-buffer))) 3669 (if (not (null copy-buf)) 3670 (while (not (null copy-buf)) 3671 (artist-move-to-xy x y) 3672 (artist-replace-string (car copy-buf)) 3673 (setq copy-buf (cdr copy-buf)) 3674 (setq y (1+ y))) 3675 (message "Nothing to paste")))) 3676 3677 3678;; 3679;; Flood filling 3680;; 3681(defun artist-ff-too-far-right (x) 3682 "Determine if the position X is too far to the right." 3683 (cond ((numberp artist-flood-fill-right-border) 3684 (> x artist-flood-fill-right-border)) 3685 ((eq artist-flood-fill-right-border 'window-width) 3686 (> x (- (window-width) 2))) 3687 ((eq artist-flood-fill-right-border 'fill-column) 3688 (> x fill-column)) 3689 (t (error "Invalid value for `artist-flood-fill-right-border'")))) 3690 3691(defun artist-ff-get-rightmost-from-xy (x y) 3692 "Find the rightmost position in this run, starting at X, Y." 3693 (save-excursion 3694 (let ((char-at-xy (artist-get-char-at-xy-conv x y)) 3695 (last-x x)) 3696 (setq x (1+ x)) 3697 (while (and (not (artist-ff-too-far-right x)) 3698 (= char-at-xy (artist-get-char-at-xy-conv x y))) 3699 (setq last-x x) 3700 (setq x (1+ x))) 3701 last-x))) 3702 3703(defun artist-ff-is-topmost-line (x y) 3704 "Determine whether the position X,Y is on the topmost line or not." 3705 (= y 0)) 3706 3707(defun artist-ff-is-bottommost-line (x y) 3708 "Determine whether the position X,Y is on the bottommost line or not." 3709 (save-excursion 3710 (goto-char (point-max)) 3711 (beginning-of-line) 3712 (let ((last-line (artist-current-line))) 3713 (if (= (point) (point-max)) 3714 3715 ;; Last line is empty, don't paint on it, report previous line 3716 ;; as last line 3717 (>= y (- last-line 1)) 3718 (>= y last-line))))) 3719 3720(defun artist-flood-fill (x1 y1) 3721 "Flood-fill starting at X1, Y1. Fill with the char in `artist-fill-char'." 3722 (let ((stack nil) 3723 (input-queue nil) 3724 ;; We are flood-filling the area that has this character. 3725 (c (artist-get-char-at-xy-conv x1 y1)) 3726 (artist-fill-char (if artist-fill-char-set 3727 artist-fill-char 3728 artist-default-fill-char))) 3729 3730 ;; Fill only if the fill-char is not the same as the character whose 3731 ;; area we are about to fill, or, in other words, don't fill if we 3732 ;; needn't. 3733 (if (not (= c artist-fill-char)) 3734 (push (artist-new-coord x1 y1) stack)) 3735 3736 (while (not (null stack)) 3737 (let* ((coord (pop stack)) 3738 (x (artist-coord-get-x coord)) 3739 (y (artist-coord-get-y coord)) 3740 3741 ;; Here we keep track of the leftmost and rightmost position 3742 ;; for this run 3743 (x-leftmost 0) 3744 (x-rightmost 0) 3745 (last-x 0) 3746 3747 ;; Remember if line above and below are accessible 3748 ;; Lines below the last one, and prior to the first-one 3749 ;; are not accessible. 3750 (lines-above nil) 3751 (lines-below nil) 3752 3753 ;; Remember char for position on line above and below, so we 3754 ;; can find the rightmost positions on the runs. 3755 (last-c-above -1) 3756 (last-c-below -1)) 3757 3758 (setq x-rightmost (artist-ff-get-rightmost-from-xy x y)) 3759 (setq lines-above (not (artist-ff-is-topmost-line x y))) 3760 (setq lines-below (not (artist-ff-is-bottommost-line x y))) 3761 (setq last-x x-rightmost) 3762 (setq x x-rightmost) 3763 3764 ;; Search line above, push rightmost positions of runs for that line 3765 (while (and (>= x 0) (= c (artist-get-char-at-xy-conv x y))) 3766 (if lines-above 3767 (let ((c-above (artist-get-char-at-xy-conv x (- y 1)))) 3768 (if (and (= c-above c) (/= c-above last-c-above)) 3769 (push (artist-new-coord x (- y 1)) stack)) 3770 (setq last-c-above c-above))) 3771 (setq last-x x) 3772 (setq x (- x 1))) 3773 3774 ;; Remember the left-most position on this run 3775 (setq x-leftmost last-x) 3776 3777 ;; Search line below, push rightmost positions of runs for that line 3778 (setq x x-rightmost) 3779 (while (>= x x-leftmost) 3780 (if lines-below 3781 (let ((c-below (artist-get-char-at-xy-conv x (1+ y)))) 3782 (if (and (= c-below c) (/= c-below last-c-below)) 3783 (push (artist-new-coord x (1+ y)) stack)) 3784 (setq last-c-below c-below))) 3785 (setq x (- x 1))) 3786 3787 (artist-move-to-xy x-leftmost y) 3788 (artist-replace-chars artist-fill-char (1+ (- x-rightmost x-leftmost))) 3789 3790 ;; If we are to show incrementally, we have to remove any pending 3791 ;; input from the input queue, because processing of pending input 3792 ;; always has priority over display updates (although this input 3793 ;; won't be processed until we are done). Later on we will queue 3794 ;; the input on the input queue again. 3795 (if artist-flood-fill-show-incrementally 3796 (progn 3797 (if (input-pending-p) 3798 (discard-input)) 3799 (artist-update-display))))))) 3800 3801;; 3802;; Accessors to arrow-points 3803;; 3804 3805(defun artist-make-arrow-point (x y direction &optional state) 3806 "Create an arrow point at X, Y for a line in direction DIRECTION. 3807Optional argument STATE can be used to set state (default is nil)." 3808 (save-excursion 3809 (let* ((arrow-point (make-vector 4 0)) 3810 (arrow-marker (make-marker))) 3811 (artist-move-to-xy x y) 3812 (set-marker arrow-marker (point)) 3813 (aset arrow-point 0 arrow-marker) 3814 (aset arrow-point 1 (artist-get-char-at-xy x y)) 3815 (aset arrow-point 2 direction) 3816 (aset arrow-point 3 state) 3817 arrow-point))) 3818 3819(defsubst artist-arrow-point-get-marker (arrow-point) 3820 "Retrieve the marker component of an ARROW-POINT." 3821 (aref arrow-point 0)) 3822 3823(defsubst artist-arrow-point-get-orig-char (arrow-point) 3824 "Retrieve the orig char component of an ARROW-POINT." 3825 (aref arrow-point 1)) 3826 3827(defsubst artist-arrow-point-get-direction (arrow-point) 3828 "Retrieve the direction component of an ARROW-POINT." 3829 (aref arrow-point 2)) 3830 3831(defsubst artist-arrow-point-get-state (arrow-point) 3832 "Retrieve the state component of an ARROW-POINT." 3833 (aref arrow-point 3)) 3834 3835(defsubst artist-arrow-point-set-state (arrow-point new-state) 3836 "Set the state component of an ARROW-POINT to NEW-STATE." 3837 (aset arrow-point 3 new-state)) 3838 3839 3840(defun artist-clear-arrow-points () 3841 "Clear current endpoints." 3842 (setq artist-arrow-point-1 nil) 3843 (setq artist-arrow-point-2 nil)) 3844 3845(defun artist-set-arrow-points-for-poly (point-list) 3846 "Generic function for setting arrow-points for poly-shapes from POINT-LIST." 3847 (let* ((ep1 (elt point-list 0)) 3848 (ep2 (elt point-list 1)) 3849 (x1 (artist-endpoint-get-x ep1)) 3850 (y1 (artist-endpoint-get-y ep1)) 3851 (x2 (artist-endpoint-get-x ep2)) 3852 (y2 (artist-endpoint-get-y ep2)) 3853 (dir1 (artist-find-direction x2 y2 x1 y1)) 3854 (epn (car (last point-list))) 3855 (epn-1 (car (last point-list 2))) 3856 (xn (artist-endpoint-get-x epn)) 3857 (yn (artist-endpoint-get-y epn)) 3858 (xn-1 (artist-endpoint-get-x epn-1)) 3859 (yn-1 (artist-endpoint-get-y epn-1)) 3860 (dirn (artist-find-direction xn-1 yn-1 xn yn))) 3861 (setq artist-arrow-point-1 (artist-make-arrow-point x1 y1 dir1)) 3862 (setq artist-arrow-point-2 (artist-make-arrow-point xn yn dirn)))) 3863 3864 3865(defun artist-set-arrow-points-for-2points (shape x1 y1 x2 y2) 3866 "Generic function for setting arrow-points for 2-point shapes. 3867The 2-point shape SHAPE is drawn from X1, Y1 to X2, Y2." 3868 (let* ((endpoint1 (artist-2point-get-endpoint1 shape)) 3869 (endpoint2 (artist-2point-get-endpoint2 shape)) 3870 (x1 (artist-endpoint-get-x endpoint1)) 3871 (y1 (artist-endpoint-get-y endpoint1)) 3872 (x2 (artist-endpoint-get-x endpoint2)) 3873 (y2 (artist-endpoint-get-y endpoint2))) 3874 (setq artist-arrow-point-1 3875 (artist-make-arrow-point x1 y1 3876 (artist-find-direction x2 y2 x1 y1))) 3877 (setq artist-arrow-point-2 3878 (artist-make-arrow-point x2 y2 3879 (artist-find-direction x1 y1 x2 y2))))) 3880 3881 3882;; 3883;; Common routine for drawing/undrawing shapes based 3884;; on the draw-how 3885;; 3886 3887(defun artist-key-undraw-continously (x y) 3888 "Undraw current continous shape with point at X, Y." 3889 ;; No undraw-info for continous shapes 3890 nil) 3891 3892(defun artist-key-undraw-poly (x y) 3893 "Undraw current poly shape with point at X, Y." 3894 (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)) 3895 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 3896 (y1 (artist-endpoint-get-y artist-key-endpoint1))) 3897 (artist-funcall undraw-fn artist-key-shape))) 3898 3899(defun artist-key-undraw-1point (x y) 3900 "Undraw current 1-point shape at X, Y." 3901 ;; No undraw-info for 1-point shapes 3902 nil) 3903 3904(defun artist-key-undraw-2points (x y) 3905 "Undraw current 2-point shape at X, Y." 3906 (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)) 3907 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 3908 (y1 (artist-endpoint-get-y artist-key-endpoint1))) 3909 (artist-funcall undraw-fn artist-key-shape))) 3910 3911(defun artist-key-undraw-common () 3912 "Common routine undrawing current shape." 3913 (let ((draw-how (artist-go-get-draw-how-from-symbol artist-curr-go)) 3914 (col (artist-current-column)) 3915 (row (artist-current-line))) 3916 3917 ;; Depending on what we are currently drawing, call other routines 3918 ;; that knows how to do the job 3919 ;; 3920 (cond ((eq draw-how 'artist-do-continously) 3921 (artist-key-undraw-continously col row)) 3922 ((eq draw-how 'artist-do-poly) 3923 (artist-key-undraw-poly col row)) 3924 ((and (numberp draw-how) (= draw-how 1)) 3925 (artist-key-undraw-1point col row)) 3926 ((and (numberp draw-how) (= draw-how 2)) 3927 (artist-key-undraw-2points col row)) 3928 (t (message "Undrawing \"%s\"s is not yet implemented" draw-how))) 3929 3930 ;; Now restore the old position 3931 ;; 3932 (artist-move-to-xy col row))) 3933 3934 3935 3936;; Implementation note: This really should honor the interval-fn entry 3937;; in the master table, `artist-mt', which would mean leaving a timer 3938;; that calls `draw-fn' every now and then. That timer would then have 3939;; to be cancelled and reinstalled whenever the user moves the cursor. 3940;; This could be done, but what if the user suddenly switches to another 3941;; drawing mode, or even kills the buffer! In the mouse case, it is much 3942;; simpler: when at the end of `artist-mouse-draw-continously', the 3943;; user has released the button, so the timer will always be cancelled 3944;; at that point. 3945(defun artist-key-draw-continously (x y) 3946 "Draws current continous shape at X,Y." 3947 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go))) 3948 (setq artist-key-shape (artist-funcall draw-fn x y)))) 3949 3950(defun artist-key-draw-poly (x y) 3951 "Draws current poly-point shape with nth point at X,Y." 3952 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 3953 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 3954 (y1 (artist-endpoint-get-y artist-key-endpoint1))) 3955 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x y)))) 3956 3957(defun artist-key-draw-1point (x y) 3958 "Draws current 1-point shape at X,Y." 3959 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go))) 3960 (setq artist-key-shape (artist-funcall draw-fn x y)))) 3961 3962 3963(defun artist-key-draw-2points (x y) 3964 "Draws current 2-point shape at X,Y." 3965 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 3966 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 3967 (y1 (artist-endpoint-get-y artist-key-endpoint1))) 3968 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x y)))) 3969 3970(defun artist-key-draw-common () 3971 "Common routine for drawing current shape." 3972 (let ((draw-how (artist-go-get-draw-how-from-symbol artist-curr-go)) 3973 (col (artist-current-column)) 3974 (row (artist-current-line))) 3975 3976 ;; Depending on what we are currently drawing, call other routines 3977 ;; that knows how to do the job 3978 ;; 3979 (cond ((eq draw-how 'artist-do-continously) 3980 (artist-key-draw-continously col row)) 3981 ((eq draw-how 'artist-do-poly) 3982 (artist-key-draw-poly col row)) 3983 ((and (numberp draw-how) (= draw-how 1)) 3984 (artist-key-draw-1point col row)) 3985 ((and (numberp draw-how) (= draw-how 2)) 3986 (artist-key-draw-2points col row)) 3987 (t (message "Drawing \"%s\"s is not yet implemented" draw-how))) 3988 3989 ;; Now restore the old position 3990 ;; 3991 (artist-move-to-xy col row))) 3992 3993 3994 3995;; 3996;; Functions related to trimming line-endings 3997;; The region between the topmost and bottommost visited line is 3998;; called a draw-region. 3999;; 4000 4001(defun artist-draw-region-reset () 4002 "Reset the current draw-region." 4003 (setq artist-draw-region-max-y 0) 4004 (setq artist-draw-region-min-y 1000000)) 4005 4006(defun artist-draw-region-trim-line-endings (min-y max-y) 4007 "Trim lines in current draw-region from MIN-Y to MAX-Y. 4008Trimming here means removing white space at end of a line." 4009 ;; Safetyc check: switch min-y and max-y if if max-y is smaller 4010 (if (< max-y min-y) 4011 (let ((tmp min-y)) 4012 (setq min-y max-y) 4013 (setq max-y tmp))) 4014 (save-excursion 4015 (let ((curr-y min-y)) 4016 (while (<= curr-y max-y) 4017 (artist-move-to-xy 0 curr-y) 4018 (end-of-line) 4019 (delete-horizontal-space) 4020 (setq curr-y (1+ curr-y)))))) 4021 4022;; 4023;; Drawing shapes by using keys 4024;; 4025 4026(defun artist-key-do-continously-continously (x y) 4027 "Update current continous shape at X,Y." 4028 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go))) 4029 (artist-funcall draw-fn x y))) 4030 4031 4032(defun artist-key-do-continously-poly (x y) 4033 "Update current poly-point shape with nth point at X,Y." 4034 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4035 (undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)) 4036 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 4037 (y1 (artist-endpoint-get-y artist-key-endpoint1)) 4038 (x2 x) 4039 (y2 y)) 4040 ;; If not rubber-banding, then move the 2 4041 ;; Otherwise re-draw the shape to the new position 4042 ;; 4043 (if (not artist-rubber-banding) 4044 (progn 4045 (artist-no-rb-unset-point2) 4046 (artist-no-rb-set-point2 x y)) 4047 (progn 4048 (artist-funcall undraw-fn artist-key-shape) 4049 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x2 y2)))))) 4050 4051 4052(defun artist-key-do-continously-1point (x y) 4053 "Update current 1-point shape at X,Y." 4054 ;; Nothing to do continously for operations 4055 ;; where we have only one input point 4056 nil) 4057 4058(defun artist-key-do-continously-2points (x y) 4059 "Update current 2-point shape with 2nd point at X,Y." 4060 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4061 (undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)) 4062 (x1 (artist-endpoint-get-x artist-key-endpoint1)) 4063 (y1 (artist-endpoint-get-y artist-key-endpoint1)) 4064 (x2 x) 4065 (y2 y)) 4066 ;; If not rubber-banding, then move the 2 4067 ;; Otherwise re-draw the shape to the new position 4068 ;; 4069 (if (not artist-rubber-banding) 4070 (progn 4071 (artist-no-rb-unset-point2) 4072 (artist-no-rb-set-point2 x y)) 4073 (progn 4074 (artist-funcall undraw-fn artist-key-shape) 4075 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x2 y2)))))) 4076 4077 4078(defun artist-key-do-continously-common () 4079 "Common routine for updating current shape." 4080 (let ((draw-how (artist-go-get-draw-how-from-symbol artist-curr-go)) 4081 (col (artist-current-column)) 4082 (row (artist-current-line))) 4083 4084 ;; Depending on what we are currently drawing, call other routines 4085 ;; that knows how to do the job 4086 ;; 4087 (cond ((eq draw-how 'artist-do-continously) 4088 (artist-key-do-continously-continously col row)) 4089 ((eq draw-how 'artist-do-poly) 4090 (artist-key-do-continously-poly col row)) 4091 ((and (numberp draw-how) (= draw-how 1)) 4092 (artist-key-do-continously-1point col row)) 4093 ((and (numberp draw-how) (= draw-how 2)) 4094 (artist-key-do-continously-2points col row)) 4095 (t (message "Drawing \"%s\"s is not yet implemented" draw-how))) 4096 4097 ;; Now restore the old position 4098 ;; 4099 (artist-move-to-xy col row))) 4100 4101 4102(defun artist-key-set-point-continously (x y) 4103 "Set point for current continous shape at X,Y." 4104 ;; Maybe set arrow-points for continous shapes 4105 (let ((arrow-pred (artist-go-get-arrow-pred-from-symbol artist-curr-go)) 4106 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol artist-curr-go)) 4107 (init-fn (artist-go-get-init-fn-from-symbol artist-curr-go)) 4108 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol artist-curr-go)) 4109 (exit-fn (artist-go-get-exit-fn-from-symbol artist-curr-go))) 4110 4111 (if (not artist-key-is-drawing) 4112 ;; *** We are about to begin drawing 4113 (progn 4114 (artist-funcall init-fn x y)) 4115 4116 ;; *** We are about to stop drawing 4117 (progn 4118 4119 (artist-funcall prep-fill-fn x y) 4120 (if (artist-funcall arrow-pred) 4121 (artist-funcall arrow-set-fn x y) 4122 (artist-clear-arrow-points)) 4123 (artist-funcall exit-fn x y)))) 4124 4125 ;; Toggle the is-drawing flag 4126 (setq artist-key-is-drawing (not artist-key-is-drawing))) 4127 4128 4129 4130(defun artist-key-set-point-poly (x y &optional this-is-last-point) 4131 "Set point for current poly-point shape at X,Y. 4132If optional argument THIS-IS-LAST-POINT is non-nil, this point is the last." 4133 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4134 (init-fn (artist-go-get-init-fn-from-symbol artist-curr-go)) 4135 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol artist-curr-go)) 4136 (exit-fn (artist-go-get-exit-fn-from-symbol artist-curr-go)) 4137 (fill-pred (artist-go-get-fill-pred-from-symbol artist-curr-go)) 4138 (fill-fn (artist-go-get-fill-fn-from-symbol artist-curr-go)) 4139 (arrow-pred (artist-go-get-arrow-pred-from-symbol artist-curr-go)) 4140 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol artist-curr-go))) 4141 4142 (if (not artist-key-is-drawing) 4143 4144 ;; *** We were not drawing ==> set first point 4145 (progn 4146 4147 (artist-funcall init-fn x y) 4148 4149 ;; If not rubber-banding, set first point. 4150 ;; Otherwise, draw the shape from x,y to x,y 4151 (if (not artist-rubber-banding) 4152 (artist-no-rb-set-point1 x y) 4153 (setq artist-key-shape (artist-funcall draw-fn x y x y))) 4154 4155 ;; Set first endpoint 4156 (setq artist-key-endpoint1 (artist-make-endpoint x y)) 4157 4158 ;; Set point-list to contain start point 4159 (setq artist-key-poly-point-list (list (artist-make-endpoint x y))) 4160 4161 ;; Since we are not ready, set the arrow-points to nil 4162 (artist-clear-arrow-points) 4163 4164 ;; Change state to drawing 4165 (setq artist-key-is-drawing t) 4166 4167 ;; Feedback 4168 (message "%s" (substitute-command-keys 4169 (concat "First point set. " 4170 "Set next with \\[artist-key-set-point], " 4171 "set last with C-u \\[artist-key-set-point]")))) 4172 4173 4174 ;; *** We were drawing ==> we are about to set nth point 4175 ;; (last point if the argument this-is-last-point is non-nil) 4176 ;; 4177 (let ((x1 (artist-endpoint-get-x artist-key-endpoint1)) 4178 (y1 (artist-endpoint-get-y artist-key-endpoint1)) 4179 (x2 x) 4180 (y2 y)) 4181 4182 ;; If not rubber-banding, undraw the 1's and 2's, then 4183 ;; draw the shape (if we were rubber-banding, then the 4184 ;; shape is already drawn in artist-key-do-continously-2points.) 4185 ;; 4186 (if (not artist-rubber-banding) 4187 (progn 4188 (artist-no-rb-unset-points) 4189 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x2 y2)))) 4190 4191 ;; Set x2 and y2 from shape's second point 4192 ;; (which might be different from the mouse's second point, 4193 ;; if, for example, we are drawing a straight line) 4194 ;; 4195 (if (not (null artist-key-shape)) 4196 (let ((endpoint2 (artist-2point-get-endpoint2 artist-key-shape))) 4197 (setq x2 (artist-endpoint-get-x endpoint2)) 4198 (setq y2 (artist-endpoint-get-y endpoint2)))) 4199 4200 ;; Add the endpoint to the list of poly-points 4201 (setq artist-key-poly-point-list 4202 (append artist-key-poly-point-list 4203 (list (artist-make-endpoint x2 y2)))) 4204 4205 ;; Now do handle the case when this is the last point, 4206 ;; and the case when this point isn't the last 4207 ;; 4208 (if (not this-is-last-point) 4209 ;; ** This is not the last point 4210 (progn 4211 ;; Start drawing a new 2-point-shape from last endpoint. 4212 4213 ;; First set the start-point 4214 (setq x1 x2) 4215 (setq y1 y2) 4216 (setq artist-key-endpoint1 (artist-make-endpoint x1 y1)) 4217 4218 ;; If we are not rubber-banding, then place the '1 4219 ;; Otherwise, draw the shape from x1,y1 to x1,y1 4220 (if (not artist-rubber-banding) 4221 (artist-no-rb-set-point1 x1 y1) 4222 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x1 y1))) 4223 4224 ;; Feedback 4225 (message "Point set")) 4226 4227 ;; ** This is the last point 4228 (progn 4229 4230 (artist-funcall prep-fill-fn artist-key-poly-point-list) 4231 4232 ;; Maybe fill 4233 (if (artist-funcall fill-pred) 4234 (artist-funcall fill-fn artist-key-shape 4235 artist-key-poly-point-list)) 4236 4237 ;; Set the arrow-points 4238 (if (artist-funcall arrow-pred) 4239 (artist-funcall arrow-set-fn artist-key-poly-point-list) 4240 (artist-clear-arrow-points)) 4241 4242 (artist-funcall exit-fn artist-key-poly-point-list) 4243 4244 ;; Change state to not drawing 4245 (setq artist-key-shape nil) 4246 (setq artist-key-endpoint1 nil) 4247 (setq artist-key-is-drawing nil))))))) 4248 4249 4250(defun artist-key-set-point-1point (x y) 4251 "Set point for current 1-point shape at X,Y." 4252 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4253 (init-fn (artist-go-get-init-fn-from-symbol artist-curr-go)) 4254 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol artist-curr-go)) 4255 (exit-fn (artist-go-get-exit-fn-from-symbol artist-curr-go)) 4256 (draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4257 (arrow-pred (artist-go-get-arrow-pred-from-symbol artist-curr-go)) 4258 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol artist-curr-go))) 4259 (artist-funcall init-fn x y) 4260 (artist-funcall draw-fn x y) 4261 (artist-funcall prep-fill-fn x y) 4262 (if (artist-funcall arrow-pred) 4263 (artist-funcall arrow-set-fn x y) 4264 (artist-clear-arrow-points)) 4265 (artist-funcall exit-fn x y)) 4266 (setq artist-key-shape nil) 4267 (setq artist-key-is-drawing nil)) 4268 4269 4270(defun artist-key-set-point-2points (x y) 4271 "Set first or second point in current 2-point shape at X,Y." 4272 (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go)) 4273 (init-fn (artist-go-get-init-fn-from-symbol artist-curr-go)) 4274 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol artist-curr-go)) 4275 (exit-fn (artist-go-get-exit-fn-from-symbol artist-curr-go)) 4276 (fill-pred (artist-go-get-fill-pred-from-symbol artist-curr-go)) 4277 (fill-fn (artist-go-get-fill-fn-from-symbol artist-curr-go)) 4278 (arrow-pred (artist-go-get-arrow-pred-from-symbol artist-curr-go)) 4279 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol artist-curr-go))) 4280 (if (not artist-key-is-drawing) 4281 4282 ;; *** We were not drawing ==> set first point 4283 (progn 4284 4285 (artist-funcall init-fn x y) 4286 4287 ;; If not rubber-banding, set first point. 4288 ;; Otherwise, draw the shape from x,y to x,y 4289 (if (not artist-rubber-banding) 4290 (artist-no-rb-set-point1 x y) 4291 (setq artist-key-shape (artist-funcall draw-fn x y x y))) 4292 4293 ;; Set first endpoint 4294 (setq artist-key-endpoint1 (artist-make-endpoint x y)) 4295 4296 ;; Since we are not ready, clear the arrow-points 4297 (artist-clear-arrow-points) 4298 4299 ;; Change state to drawing 4300 (setq artist-key-is-drawing t)) 4301 4302 ;; *** We were drawing ==> we are about to set 2nd point 4303 ;; and end the drawing operation 4304 4305 (let ((x1 (artist-endpoint-get-x artist-key-endpoint1)) 4306 (y1 (artist-endpoint-get-y artist-key-endpoint1)) 4307 (x2 x) 4308 (y2 y)) 4309 4310 ;; If not rubber-banding, undraw the 1's and 2's, then 4311 ;; draw the shape (if we were rubber-banding, then the 4312 ;; shape is already drawn in artist-key-do-continously-2points.) 4313 ;; 4314 (if (not artist-rubber-banding) 4315 (progn 4316 (artist-no-rb-unset-points) 4317 (setq artist-key-shape (artist-funcall draw-fn x1 y1 x2 y2)))) 4318 4319 (artist-funcall prep-fill-fn artist-key-shape x1 y1 x2 y2) 4320 4321 ;; Maybe fill 4322 ;; 4323 (if (artist-funcall fill-pred) 4324 (artist-funcall fill-fn artist-key-shape x1 y1 x2 y2)) 4325 4326 ;; Maybe set the arrow-points 4327 ;; 4328 (if (artist-funcall arrow-pred) 4329 (artist-funcall arrow-set-fn artist-key-shape x1 y1 x2 y2) 4330 (artist-clear-arrow-points)) 4331 4332 (artist-funcall exit-fn artist-key-shape x1 y1 x2 y2) 4333 4334 ;; Change state to not drawing 4335 (setq artist-key-is-drawing nil))))) 4336 4337 4338(defun artist-key-set-point-common (arg) 4339 "Common routine for setting point in current shape. 4340With non-nil ARG, set the last point." 4341 (let ((draw-how (artist-go-get-draw-how-from-symbol artist-curr-go)) 4342 (col (artist-current-column)) 4343 (row (artist-current-line)) 4344 (was-drawing artist-key-is-drawing)) 4345 4346 ;; First, if we are about to draw, then reset the draw-region 4347 (if (not artist-key-is-drawing) 4348 (artist-draw-region-reset)) 4349 4350 ;; Depending on what we are currently drawing, call other routines 4351 ;; that knows how to do the job 4352 ;; 4353 (cond ((eq draw-how 'artist-do-continously) 4354 (artist-key-set-point-continously col row) 4355 ;; Do this now, otherwise nothing will happen until we move. 4356 (artist-key-do-continously-continously col row)) 4357 ((eq draw-how 'artist-do-poly) 4358 (artist-key-set-point-poly col row arg)) 4359 ((and (numberp draw-how) (= draw-how 1)) 4360 (artist-key-set-point-1point col row)) 4361 ((and (numberp draw-how) (= draw-how 2)) 4362 (artist-key-set-point-2points col row)) 4363 (t (message "Drawing \"%s\"s is not yet implemented" draw-how))) 4364 4365 ;; Maybe trim line endings 4366 (if (and artist-trim-line-endings 4367 was-drawing 4368 (not artist-key-is-drawing)) 4369 (artist-draw-region-trim-line-endings artist-draw-region-min-y 4370 artist-draw-region-max-y)) 4371 4372 ;; Now restore the old position 4373 ;; 4374 (artist-move-to-xy col row) 4375 (artist-mode-line-show-curr-operation artist-key-is-drawing))) 4376 4377;; 4378;; Key navigation 4379;; 4380 4381(defun artist-previous-line (&optional n) 4382 "Move cursor up optional N lines (default is 1), updating current shape. 4383If N is negative, move cursor down." 4384 (interactive "p") 4385 (let ((col (artist-current-column))) 4386 (if (not artist-key-is-drawing) 4387 (progn 4388 (previous-line n) 4389 (move-to-column col t)) 4390 (previous-line n) 4391 (move-to-column col t) 4392 (artist-key-do-continously-common)))) 4393 4394 4395(defun artist-next-line (&optional n) 4396 "Move cursor down optional N lines (default is 1), updating current shape. 4397If N is negative, move cursor up." 4398 (interactive "p") 4399 (let ((col (artist-current-column))) 4400 (if (not artist-key-is-drawing) 4401 (progn 4402 (next-line n) 4403 (move-to-column col t)) 4404 (next-line n) 4405 (move-to-column col t) 4406 (artist-key-do-continously-common)))) 4407 4408(defun artist-backward-char (&optional n) 4409 "Move cursor backward optional N chars (default is 1), updating curr shape. 4410If N is negative, move forward." 4411 (interactive "p") 4412 (if (> n 0) 4413 (artist-forward-char (- n)) 4414 (artist-forward-char n))) 4415 4416(defun artist-forward-char (&optional n) 4417 "Move cursor forward optional N chars (default is 1), updating curr shape. 4418If N is negative, move backward." 4419 (interactive "p") 4420 (let* ((step-x (if (>= n 0) 1 -1)) 4421 (distance (abs n)) 4422 (curr-col (artist-current-column)) 4423 (new-col (max 0 (+ curr-col (* distance step-x))))) 4424 (if (not artist-key-is-drawing) 4425 (move-to-column new-col t) 4426 (move-to-column new-col t) 4427 (artist-key-do-continously-common)))) 4428 4429 4430(defun artist-key-set-point (&optional arg) 4431 "Set a point for the current shape. With optional ARG, set the last point." 4432 (interactive "P") 4433 (artist-key-set-point-common arg)) 4434 4435 4436(defun artist-select-fill-char (c) 4437 "Set current fill character to be C." 4438 (interactive "cType fill char (type RET to turn off): ") 4439 (cond ((eq c ?\r) (setq artist-fill-char-set nil) 4440 (message "Fill cancelled")) 4441 (t (setq artist-fill-char-set t) 4442 (setq artist-fill-char c) 4443 (message "Fill set to \"%c\"" c)))) 4444 4445 4446(defun artist-select-line-char (c) 4447 "Set current line character to be C." 4448 (interactive "cType line char (type RET to turn off): ") 4449 (cond ((eq c ?\r) (setq artist-line-char-set nil) 4450 (message "Normal lines")) 4451 (t (setq artist-line-char-set t) 4452 (setq artist-line-char c) 4453 (message "Line drawn with \"%c\"" c))) 4454 (if artist-key-is-drawing 4455 (artist-key-do-continously-common))) 4456 4457 4458(defun artist-select-erase-char (c) 4459 "Set current erase character to be C." 4460 (interactive "cType char to use when erasing (type RET for normal): ") 4461 (cond ((eq c ?\r) (setq artist-erase-char ?\s) 4462 (message "Normal erasing")) 4463 (t (setq artist-erase-char c) 4464 (message "Erasing with \"%c\"" c))) 4465 (if artist-key-is-drawing 4466 (artist-key-do-continously-common))) 4467 4468(defun artist-charlist-to-string (char-list) 4469 "Convert a list of characters, CHAR-LIST, to a string." 4470 (let ((result "")) 4471 (while (not (null char-list)) 4472 (setq result (concat result (char-to-string (car char-list)))) 4473 (setq char-list (cdr char-list))) 4474 result)) 4475 4476(defun artist-string-to-charlist (str) 4477 "Convert a string, STR, to list of characters." 4478 (append str nil)) 4479 4480(defun artist-select-spray-chars (chars initial-char) 4481 "Set current spray characters to be CHARS, starting with INITIAL-CHAR." 4482 ;; This huge unreadable `interactive'-clause does the following 4483 ;; 1. Asks for a string of spray-characters 4484 ;; 2. Asks for the initial character (default is the first), 4485 ;; and loops if the answer is not a char within the string in 1. 4486 (interactive 4487 (let* ((str (read-string "Select spray-can characters, lightest first: " 4488 (artist-charlist-to-string artist-spray-chars))) 4489 (char-list (artist-string-to-charlist str)) 4490 (initial (let* ((err-msg "") 4491 (ok nil) 4492 (first-char-as-str (char-to-string (car char-list))) 4493 (first-s) (first-c)) 4494 (while (not ok) 4495 (setq first-s 4496 (read-string 4497 (format (concat "%sSelect initial-character, " 4498 "one of \"%s\" (%s): ") 4499 err-msg str first-char-as-str))) 4500 (if (equal first-s "") 4501 (setq first-s first-char-as-str)) 4502 (setq first-c (car (artist-string-to-charlist first-s))) 4503 (setq ok (not (null (member first-c char-list)))) 4504 (if (not ok) 4505 (setq err-msg (format 4506 "Not in spray-chars: \"%s\". " 4507 (char-to-string first-c))))) 4508 first-c))) 4509 (list char-list initial))) 4510 (setq artist-spray-chars chars) 4511 (setq artist-spray-new-char initial-char) 4512 (message "Spray-chars set to \"%s\", initial: \"%s\"" 4513 (artist-charlist-to-string chars) (char-to-string initial-char))) 4514 4515 4516(defun artist-select-operation (op-str) 4517 "Select drawing operation OP-STR." 4518 (interactive (list (completing-read "Select operation: " 4519 artist-key-compl-table))) 4520 (let* ((op-symbol (artist-mt-get-symbol-from-keyword op-str)) 4521 (draw-how (if op-symbol 4522 (artist-go-get-draw-how-from-symbol op-symbol) 4523 nil))) 4524 ;; First check that the string was valid 4525 (if (null op-symbol) 4526 (error "Unknown drawing method: %s" op-str)) 4527 4528 ;; Second, check that we are not about to switch to a different 4529 ;; kind of shape (do that only if we are drawing with keys; 4530 ;; otherwise this function cannot get called). 4531 (if (and artist-key-is-drawing 4532 (not (equal artist-key-draw-how draw-how))) 4533 (error "Cannot switch to a different kind of shape while drawing")) 4534 4535 ;; If we were drawing, undraw the shape 4536 (if (and artist-key-is-drawing 4537 artist-rubber-banding) 4538 (artist-key-undraw-common)) 4539 4540 ;; Set the current operation and draw-how 4541 (setq artist-curr-go op-symbol) 4542 (setq artist-key-draw-how draw-how) 4543 4544 ;; If we were drawing, redraw the shape (but don't if shape 4545 ;; is drawn by setting only one point) 4546 (if (and artist-key-is-drawing 4547 artist-rubber-banding 4548 (not (eq artist-key-draw-how 1))) 4549 (artist-key-draw-common))) 4550 4551 ;; Feedback 4552 (artist-mode-line-show-curr-operation artist-key-is-drawing)) 4553 4554 4555(defun artist-toggle-rubber-banding (&optional state) 4556 "Toggle rubber-banding. 4557If optional argument STATE is positive, turn rubber-banding on." 4558 (interactive) 4559 (if artist-key-is-drawing 4560 (error "Cannot toggle rubber-banding while drawing")) 4561 (if (setq artist-rubber-banding 4562 (if (null state) (not artist-rubber-banding) 4563 (> (prefix-numeric-value state) 0))) 4564 (message "Rubber-banding is now on") 4565 (message "Rubber-banding is now off"))) 4566 4567 4568(defun artist-toggle-trim-line-endings (&optional state) 4569 "Toggle trimming of line-endings. 4570If optional argument STATE is positive, turn trimming on." 4571 (interactive) 4572 (if (setq artist-trim-line-endings 4573 (if (null state) (not artist-trim-line-endings) 4574 (> (prefix-numeric-value state) 0))) 4575 (message "Trimming is now on") 4576 (message "Trimming is now off"))) 4577 4578 4579(defun artist-toggle-borderless-shapes (&optional state) 4580 "Toggle borders of shapes. 4581If optional argument STATE is positive, turn borders on." 4582 (interactive) 4583 (if (setq artist-borderless-shapes 4584 (if (null state) (not artist-borderless-shapes) 4585 (> (prefix-numeric-value state) 0))) 4586 (message "Borders are now off") 4587 (message "Borders are now on"))) 4588 4589 4590(defun artist-toggle-first-arrow () 4591 "Toggle first arrow for shape, if possible." 4592 (interactive) 4593 (save-excursion 4594 (if (not (null artist-arrow-point-1)) 4595 (let* ((arrow-point artist-arrow-point-1) 4596 (arrow-state (artist-arrow-point-get-state arrow-point)) 4597 (arrow-marker (artist-arrow-point-get-marker arrow-point)) 4598 (direction (artist-arrow-point-get-direction arrow-point)) 4599 (orig-char (artist-arrow-point-get-orig-char arrow-point)) 4600 (arrow-char (aref artist-arrows direction)) 4601 (new-state (not arrow-state))) 4602 4603 (goto-char (marker-position arrow-marker)) 4604 4605 (if new-state 4606 (if arrow-char 4607 (artist-replace-char arrow-char)) 4608 (artist-replace-char orig-char)) 4609 4610 (artist-arrow-point-set-state artist-arrow-point-1 new-state))))) 4611 4612(defun artist-toggle-second-arrow () 4613 "Toggle second arrow for shape, if possible." 4614 (interactive) 4615 (save-excursion 4616 (if (not (null artist-arrow-point-2)) 4617 (let* ((arrow-point artist-arrow-point-2) 4618 (arrow-state (artist-arrow-point-get-state arrow-point)) 4619 (arrow-marker (artist-arrow-point-get-marker arrow-point)) 4620 (direction (artist-arrow-point-get-direction arrow-point)) 4621 (orig-char (artist-arrow-point-get-orig-char arrow-point)) 4622 (arrow-char (aref artist-arrows direction)) 4623 (new-state (not arrow-state))) 4624 4625 (goto-char (marker-position arrow-marker)) 4626 4627 (if new-state 4628 (if arrow-char 4629 (artist-replace-char arrow-char)) 4630 (artist-replace-char orig-char)) 4631 4632 (artist-arrow-point-set-state artist-arrow-point-2 new-state))))) 4633 4634 4635(defun artist-select-op-line () 4636 "Select drawing lines." 4637 (interactive) 4638 (artist-select-operation "line")) 4639 4640(defun artist-select-op-straight-line () 4641 "Select drawing straight lines." 4642 (interactive) 4643 (artist-select-operation "straight line")) 4644 4645(defun artist-select-op-rectangle () 4646 "Select drawing rectangles." 4647 (interactive) 4648 (artist-select-operation "rectangle")) 4649 4650(defun artist-select-op-square () 4651 "Select drawing squares." 4652 (interactive) 4653 (artist-select-operation "square")) 4654 4655(defun artist-select-op-poly-line () 4656 "Select drawing poly-lines." 4657 (interactive) 4658 (artist-select-operation "poly-line")) 4659 4660(defun artist-select-op-straight-poly-line () 4661 "Select drawing straight poly-lines." 4662 (interactive) 4663 (artist-select-operation "straight poly-line")) 4664 4665(defun artist-select-op-ellipse () 4666 "Select drawing ellipses." 4667 (interactive) 4668 (artist-select-operation "ellipse")) 4669 4670(defun artist-select-op-circle () 4671 "Select drawing circles." 4672 (interactive) 4673 (artist-select-operation "circle")) 4674 4675(defun artist-select-op-text-see-thru () 4676 "Select rendering text (see thru)." 4677 (interactive) 4678 (artist-select-operation "text see-thru")) 4679 4680(defun artist-select-op-text-overwrite () 4681 "Select rendering text (overwrite)." 4682 (interactive) 4683 (artist-select-operation "text overwrite")) 4684 4685(defun artist-select-op-spray-can () 4686 "Select spraying." 4687 (interactive) 4688 (artist-select-operation "spray-can")) 4689 4690(defun artist-select-op-spray-set-size () 4691 "Select setting size for spraying." 4692 (interactive) 4693 (artist-select-operation "spray set size")) 4694 4695(defun artist-select-op-erase-char () 4696 "Select erasing characters." 4697 (interactive) 4698 (artist-select-operation "erase char")) 4699 4700(defun artist-select-op-erase-rectangle () 4701 "Select erasing rectangles." 4702 (interactive) 4703 (artist-select-operation "erase rectangle")) 4704 4705(defun artist-select-op-vaporize-line () 4706 "Select vaporizing single lines." 4707 (interactive) 4708 (artist-select-operation "vaporize line")) 4709 4710(defun artist-select-op-vaporize-lines () 4711 "Select vaporizing connected lines." 4712 (interactive) 4713 (artist-select-operation "vaporize lines")) 4714 4715(defun artist-select-op-cut-rectangle () 4716 "Select cutting rectangles." 4717 (interactive) 4718 (artist-select-operation "cut rectangle")) 4719 4720(defun artist-select-op-cut-square () 4721 "Select cutting squares." 4722 (interactive) 4723 (artist-select-operation "cut square")) 4724 4725(defun artist-select-op-copy-rectangle () 4726 "Select copying rectangles." 4727 (interactive) 4728 (artist-select-operation "copy rectangle")) 4729 4730(defun artist-select-op-copy-square () 4731 "Select copying squares." 4732 (interactive) 4733 (artist-select-operation "cut square")) 4734 4735(defun artist-select-op-paste () 4736 "Select pasting." 4737 (interactive) 4738 (artist-select-operation "paste")) 4739 4740(defun artist-select-op-flood-fill () 4741 "Select flood-filling." 4742 (interactive) 4743 (artist-select-operation "flood-fill")) 4744 4745 4746;; Drawing lines by using mouse 4747;; Mouse button actions 4748;; 4749 4750(defun artist-update-pointer-shape () 4751 "Perform the update of the X Windows pointer shape." 4752 (set-mouse-color nil)) 4753 4754(defun artist-set-pointer-shape (new-pointer-shape) 4755 "Set the shape of the X Windows pointer to NEW-POINTER-SHAPE." 4756 (setq x-pointer-shape new-pointer-shape) 4757 (artist-update-pointer-shape)) 4758 4759(defsubst artist-event-is-shifted (ev) 4760 "Check whether the shift-key is pressed in event EV." 4761 (memq 'shift (event-modifiers ev))) 4762 4763(defun artist-do-nothing () 4764 "Function that does nothing." 4765 (interactive)) 4766 4767(defun artist-down-mouse-1 (ev) 4768 "Perform drawing action for event EV." 4769 (interactive "@e") 4770 (let* ((real (artist-go-get-symbol-shift 4771 artist-curr-go (artist-event-is-shifted ev))) 4772 (draw-how (artist-go-get-draw-how-from-symbol real)) 4773 ;; Remember original values for draw-region-min-y and max-y 4774 ;; in case we are interrupting a key-draw operation. 4775 (orig-draw-region-min-y artist-draw-region-min-y) 4776 (orig-draw-region-max-y artist-draw-region-max-y) 4777 (orig-pointer-shape (if (eq window-system 'x) x-pointer-shape nil)) 4778 (echo-keystrokes 10000) ; a lot of seconds 4779 ;; Remember original binding for the button-up event to this 4780 ;; button-down event. 4781 (key (let* ((basic (event-basic-type ev)) 4782 (unshifted basic) 4783 (shifted (make-symbol (concat "S-" (symbol-name basic))))) 4784 (if (artist-event-is-shifted ev) 4785 (make-vector 1 shifted) 4786 (make-vector 1 unshifted)))) 4787 (orig-button-up-binding (lookup-key (current-global-map) key))) 4788 4789 (unwind-protect 4790 (progn 4791 (if (eq window-system 'x) 4792 (artist-set-pointer-shape artist-pointer-shape)) 4793 4794 ;; Redefine the button-up binding temporarily (the original 4795 ;; binding is restored in the unwind-forms below). This is to 4796 ;; avoid the phenomenon outlined in this scenario: 4797 ;; 4798 ;; 1. A routine which reads something from the mini-buffer (such 4799 ;; as the text renderer) is called from below. 4800 ;; 2. Meanwhile, the users releases the mouse button. 4801 ;; 3. As a (funny :-) coincidence, the binding for the 4802 ;; button-up event is often mouse-set-point, so Emacs 4803 ;; sets the point to where the button was released, which is 4804 ;; in the buffer where the user wants to place the text. 4805 ;; 4. The user types C-x o (or uses the mouse once again) 4806 ;; until he reaches the mini-buffer which is still prompting 4807 ;; for some text to render. 4808 ;; 4809 ;; To do this foolproof, all local and minor-mode maps should 4810 ;; be searched and temporarily changed as well, since they 4811 ;; too might have some binding for the button-up event, 4812 ;; but I hope dealing with the global map will suffice. 4813 (define-key (current-global-map) key 'artist-do-nothing) 4814 4815 (artist-draw-region-reset) 4816 4817 (artist-mode-line-show-curr-operation t) 4818 4819 (cond ((eq draw-how 'artist-do-continously) 4820 (artist-mouse-draw-continously ev)) 4821 ((eq draw-how 'artist-do-poly) 4822 (artist-mouse-draw-poly ev)) 4823 ((and (numberp draw-how) (= draw-how 1)) 4824 (artist-mouse-draw-1point ev)) 4825 ((and (numberp draw-how) (= draw-how 2)) 4826 (artist-mouse-draw-2points ev)) 4827 (t (message "Drawing \"%s\"s is not yet implemented" 4828 draw-how))) 4829 4830 (if artist-trim-line-endings 4831 (artist-draw-region-trim-line-endings artist-draw-region-min-y 4832 artist-draw-region-max-y)) 4833 (setq artist-draw-region-min-y orig-draw-region-min-y) 4834 (setq artist-draw-region-max-y orig-draw-region-max-y)) 4835 4836 ; This is protected 4837 (if (eq window-system 'x) 4838 (artist-set-pointer-shape orig-pointer-shape)) 4839 4840 (if orig-button-up-binding 4841 (define-key (current-global-map) key orig-button-up-binding)) 4842 4843 (artist-mode-line-show-curr-operation artist-key-is-drawing)))) 4844 4845 4846(defun artist-mouse-choose-operation (ev op) 4847 "Choose operation for event EV and operation OP." 4848 (interactive 4849 (progn 4850 (select-window (posn-window (event-start last-input-event))) 4851 (list last-input-event 4852 (x-popup-menu last-nonmenu-event artist-popup-menu-table)))) 4853 4854 (let ((draw-fn (artist-go-get-draw-fn-from-symbol (car op))) 4855 (set-fn (artist-fc-get-fn-from-symbol (car op)))) 4856 (cond 4857 4858 ;; *** It was a draw-function 4859 ((not (listp draw-fn)) 4860 (let* ((unshifted (artist-go-get-symbol-shift (car op) nil)) 4861 (shifted (artist-go-get-symbol-shift (car op) t)) 4862 (shift-state (artist-event-is-shifted ev)) 4863 (selected-op (if shift-state shifted unshifted)) 4864 (keyword (artist-go-get-keyword-from-symbol selected-op))) 4865 (artist-select-operation keyword))) 4866 4867 ;; *** It was a set/unset function 4868 ((not (listp set-fn)) 4869 (call-interactively set-fn))))) 4870 4871 4872(defun artist-down-mouse-3 (ev) 4873 "Erase character or rectangle, depending on event EV." 4874 (interactive "@e") 4875 (let ((artist-curr-go 'erase-char)) 4876 (artist-down-mouse-1 ev)) 4877 ;; Restore mode-line 4878 (artist-mode-line-show-curr-operation artist-key-is-drawing)) 4879 4880 4881;; 4882;; Mouse routines 4883;; 4884 4885(defsubst artist-shift-has-changed (shift-state ev) 4886 "From the last SHIFT-STATE and EV, determine if the shift-state has changed." 4887 ;; This one simply doesn't work. 4888 ;; 4889 ;; There seems to be no way to tell whether the user has pressed shift 4890 ;; while dragging the cursor around when we are in a track-mouse 4891 ;; form. Calling (event-modifiers ev) yields nil :-( Neither is the 4892 ;; (event-basic-type ev) of any help (it is simply `mouse-movement'). 4893 ;; 4894 ;; So this doesn't work: 4895 ;; (cond ((and shift-state (not (artist-event-is-shifted ev))) t) 4896 ;; ((and (not shift-state) (artist-event-is-shifted ev)) t) 4897 ;; (t nil)) 4898 nil) 4899 4900(defun artist-coord-win-to-buf (coord) 4901 "Convert a window-relative coordinate COORD to a buffer-relative coordinate." 4902 (let ((window-x (car coord)) 4903 (window-y (cdr coord)) 4904 (window-start-x (window-hscroll)) 4905 (window-start-y (save-excursion (goto-char (window-start)) 4906 (artist-current-line)))) 4907 (cons (+ window-x window-start-x) 4908 (+ window-y window-start-y)))) 4909 4910 4911(defun artist-mouse-draw-continously (ev) 4912 "Generic function for shapes that requires 1 point as input. 4913Operation is done continously while the mouse button is hold down. 4914The event, EV, is the mouse event." 4915 (let* ((unshifted (artist-go-get-symbol-shift artist-curr-go nil)) 4916 (shifted (artist-go-get-symbol-shift artist-curr-go t)) 4917 (shift-state (artist-event-is-shifted ev)) 4918 (op (if shift-state shifted unshifted)) 4919 (draw-how (artist-go-get-draw-how-from-symbol op)) 4920 (init-fn (artist-go-get-init-fn-from-symbol op)) 4921 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol op)) 4922 (exit-fn (artist-go-get-exit-fn-from-symbol op)) 4923 (draw-fn (artist-go-get-draw-fn-from-symbol op)) 4924 (interval-fn (artist-go-get-interval-fn-from-symbol op)) 4925 (interval (artist-funcall interval-fn)) 4926 (arrow-pred (artist-go-get-arrow-pred-from-symbol op)) 4927 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol op)) 4928 (ev-start (event-start ev)) 4929 (initial-win (posn-window ev-start)) 4930 (ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start))) 4931 (x1 (car ev-start-pos)) 4932 (y1 (cdr ev-start-pos)) 4933 (shape) 4934 (timer)) 4935 (select-window (posn-window ev-start)) 4936 (artist-funcall init-fn x1 y1) 4937 (if (not artist-rubber-banding) 4938 (artist-no-rb-set-point1 x1 y1)) 4939 (track-mouse 4940 (while (or (mouse-movement-p ev) 4941 (member 'down (event-modifiers ev))) 4942 (setq ev-start-pos (artist-coord-win-to-buf 4943 (posn-col-row (event-start ev)))) 4944 (setq x1 (car ev-start-pos)) 4945 (setq y1 (cdr ev-start-pos)) 4946 4947 ;; Cancel previous timer 4948 (if timer 4949 (cancel-timer timer)) 4950 4951 (if (not (eq initial-win (posn-window (event-start ev)))) 4952 ;; If we moved outside the window, do nothing 4953 nil 4954 4955 ;; Still in same window: 4956 ;; 4957 ;; Check if user presses or releases shift key 4958 (if (artist-shift-has-changed shift-state ev) 4959 4960 ;; First check that the draw-how is the same as we 4961 ;; already have. Otherwise, ignore the changed shift-state. 4962 (if (not (eq draw-how 4963 (artist-go-get-draw-how-from-symbol 4964 (if (not shift-state) shifted unshifted)))) 4965 (message "Cannot switch to shifted operation") 4966 4967 ;; progn is "implicit" since this is the else-part 4968 (setq shift-state (not shift-state)) 4969 (setq op (if shift-state shifted unshifted)) 4970 (setq draw-how (artist-go-get-draw-how-from-symbol op)) 4971 (setq draw-fn (artist-go-get-draw-fn-from-symbol op)))) 4972 4973 ;; Draw the new shape 4974 (setq shape (artist-funcall draw-fn x1 y1)) 4975 (artist-move-to-xy x1 y1) 4976 4977 ;; Start the timer to call `draw-fn' repeatedly every 4978 ;; `interval' second 4979 (if (and interval draw-fn) 4980 (setq timer (run-at-time interval interval draw-fn x1 y1)))) 4981 4982 ;; Read next event 4983 (setq ev (read-event)))) 4984 4985 ;; Cancel any timers 4986 (if timer 4987 (cancel-timer timer)) 4988 4989 (artist-funcall prep-fill-fn x1 y1) 4990 4991 (if (artist-funcall arrow-pred) 4992 (artist-funcall arrow-set-fn x1 y1) 4993 (artist-clear-arrow-points)) 4994 4995 (artist-funcall exit-fn x1 y1) 4996 (artist-move-to-xy x1 y1))) 4997 4998 4999 5000(defun artist-mouse-draw-poly (ev) 5001 "Generic function for shapes requiring several points as input. 5002The event, EV, is the mouse event." 5003 (interactive "@e") 5004 (message "Mouse-1: set new point, mouse-2: set last point") 5005 (let* ((unshifted (artist-go-get-symbol-shift artist-curr-go nil)) 5006 (shifted (artist-go-get-symbol-shift artist-curr-go t)) 5007 (shift-state (artist-event-is-shifted ev)) 5008 (op (if shift-state shifted unshifted)) 5009 (draw-how (artist-go-get-draw-how-from-symbol op)) 5010 (init-fn (artist-go-get-init-fn-from-symbol op)) 5011 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol op)) 5012 (exit-fn (artist-go-get-exit-fn-from-symbol op)) 5013 (draw-fn (artist-go-get-draw-fn-from-symbol op)) 5014 (undraw-fn (artist-go-get-undraw-fn-from-symbol op)) 5015 (fill-pred (artist-go-get-fill-pred-from-symbol op)) 5016 (fill-fn (artist-go-get-fill-fn-from-symbol op)) 5017 (arrow-pred (artist-go-get-arrow-pred-from-symbol op)) 5018 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol op)) 5019 (ev-start (event-start ev)) 5020 (initial-win (posn-window ev-start)) 5021 (ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start))) 5022 (x1-last (car ev-start-pos)) 5023 (y1-last (cdr ev-start-pos)) 5024 (x2 x1-last) 5025 (y2 y1-last) 5026 (is-down t) 5027 (shape nil) 5028 (point-list nil) 5029 (done nil)) 5030 (select-window (posn-window ev-start)) 5031 (artist-funcall init-fn x1-last y1-last) 5032 (if (not artist-rubber-banding) 5033 (artist-no-rb-set-point1 x1-last y1-last)) 5034 (track-mouse 5035 (while (not done) 5036 ;; decide what to do 5037 (cond 5038 5039 ;; *** Mouse button is released. 5040 ((and is-down 5041 (or (member 'click (event-modifiers ev)) 5042 (member 'drag (event-modifiers ev)))) 5043 ;; First, if not rubber-banding, draw the line. 5044 ;; 5045 (if (not artist-rubber-banding) 5046 (progn 5047 (artist-no-rb-unset-points) 5048 (setq shape (artist-funcall draw-fn x1-last y1-last x2 y2)))) 5049 5050 ;; Set the second point to the shape's second point 5051 ;; (which might be different from the mouse's second point, 5052 ;; if, for example, we are drawing a straight line) 5053 ;; 5054 (if (not (null shape)) 5055 (let ((endpoint2 (artist-2point-get-endpoint2 shape))) 5056 (setq x1-last (artist-endpoint-get-x endpoint2)) 5057 (setq y1-last (artist-endpoint-get-y endpoint2)))) 5058 (setq point-list (cons (artist-make-endpoint x1-last y1-last) 5059 point-list)) 5060 (setq shape nil) 5061 (setq is-down nil)) 5062 5063 ;; *** Mouse button 2 or 3 down 5064 ((and (member 'down (event-modifiers ev)) 5065 (or (equal (event-basic-type ev) 'mouse-2) 5066 (equal (event-basic-type ev) 'mouse-3))) 5067 ;; Ignore 5068 nil) 5069 5070 ;; *** Mouse button 2 or 3 released 5071 ((and (or (member 'click (event-modifiers ev)) 5072 (member 'drag (event-modifiers ev))) 5073 (or (equal (event-basic-type ev) 'mouse-2) 5074 (equal (event-basic-type ev) 'mouse-3))) 5075 5076 ;; This means the end of our poly-line drawing-session. 5077 ;; 5078 (setq done t)) 5079 5080 ;; *** Mouse button 1 went down 5081 ((and (not is-down) 5082 (member 'down (event-modifiers ev)) 5083 (equal (event-basic-type ev) 'mouse-1)) 5084 ;; Check whether the (possibly new, that depends on if shift 5085 ;; has been pressed or released) symbol has the same draw-how 5086 ;; information as the previous had. If it hasn't, we can't 5087 ;; proceed. 5088 ;; 5089 (if (not (eq draw-how 5090 (artist-go-get-draw-how-from-symbol 5091 (if (not shift-state) shifted unshifted)))) 5092 (message "Cannot switch operation") 5093 (progn 5094 ;; Decide operation 5095 ;; 5096 (setq unshifted 5097 (artist-go-get-symbol-shift artist-curr-go nil) 5098 shifted 5099 (artist-go-get-symbol-shift artist-curr-go t) 5100 shift-state (artist-event-is-shifted ev) 5101 op (if shift-state shifted unshifted) 5102 draw-how (artist-go-get-draw-how-from-symbol op) 5103 draw-fn (artist-go-get-draw-fn-from-symbol op) 5104 undraw-fn (artist-go-get-undraw-fn-from-symbol op) 5105 fill-pred (artist-go-get-fill-pred-from-symbol op) 5106 fill-fn (artist-go-get-fill-fn-from-symbol op)) 5107 5108 ;; Draw shape from last place to this place 5109 5110 ;; set x2 and y2 5111 ;; 5112 (setq ev-start-pos (artist-coord-win-to-buf 5113 (posn-col-row (event-start ev)))) 5114 (setq x2 (car ev-start-pos)) 5115 (setq y2 (cdr ev-start-pos)) 5116 5117 ;; Draw the new shape (if not rubber-banding, place both marks) 5118 ;; 5119 (if artist-rubber-banding 5120 (setq shape (artist-funcall draw-fn x1-last y1-last x2 y2)) 5121 (progn 5122 (artist-no-rb-set-point1 x1-last y1-last) 5123 (artist-no-rb-set-point2 x2 y2))) 5124 5125 ;; Show new operation in mode-line 5126 (let ((artist-curr-go op)) 5127 (artist-mode-line-show-curr-operation t)))) 5128 5129 (setq is-down t)) 5130 5131 5132 ;; *** Mouse moved, button is down and we are still in orig window 5133 ((and (mouse-movement-p ev) 5134 is-down 5135 (eq initial-win (posn-window (event-start ev)))) 5136 ;; Draw shape from last place to this place 5137 ;; 5138 ;; set x2 and y2 5139 (setq ev-start-pos (artist-coord-win-to-buf 5140 (posn-col-row (event-start ev)))) 5141 (setq x2 (car ev-start-pos)) 5142 (setq y2 (cdr ev-start-pos)) 5143 5144 ;; First undraw last shape 5145 ;; (unset last point if not rubberbanding) 5146 ;; 5147 (artist-funcall undraw-fn shape) 5148 5149 ;; Draw the new shape (if not rubberbanding, set 2nd mark) 5150 ;; 5151 (if artist-rubber-banding 5152 (setq shape (artist-funcall draw-fn x1-last y1-last x2 y2)) 5153 (progn 5154 (artist-no-rb-unset-point2) 5155 (artist-no-rb-set-point2 x2 y2))) 5156 ;; Move cursor 5157 (artist-move-to-xy x2 y2)) 5158 5159 ;; *** Mouse moved, button is down but we are NOT in orig window 5160 ((and (mouse-movement-p ev) 5161 is-down 5162 (not (eq initial-win (posn-window (event-start ev))))) 5163 ;; Ignore 5164 nil) 5165 5166 5167 ;; *** Moving mouse while mouse button is not down 5168 ((and (mouse-movement-p ev) (not is-down)) 5169 ;; don't do anything. 5170 nil) 5171 5172 5173 ;; *** Mouse button 1 went down, first time 5174 ((and is-down 5175 (member 'down (event-modifiers ev)) 5176 (equal (event-basic-type ev) 'mouse-1)) 5177 ;; don't do anything 5178 nil) 5179 5180 5181 ;; *** Another event 5182 (t 5183 ;; End drawing 5184 ;; 5185 (setq done t))) 5186 5187 ;; Read next event (only if we should not stop) 5188 (if (not done) 5189 (setq ev (read-event))))) 5190 5191 ;; Reverse point-list (last points are cond'ed first) 5192 (setq point-list (reverse point-list)) 5193 5194 (artist-funcall prep-fill-fn point-list) 5195 5196 ;; Maybe fill 5197 (if (artist-funcall fill-pred) 5198 (artist-funcall fill-fn point-list)) 5199 5200 ;; Maybe set arrow points 5201 (if (and point-list (artist-funcall arrow-pred)) 5202 (artist-funcall arrow-set-fn point-list) 5203 (artist-clear-arrow-points)) 5204 5205 (artist-funcall exit-fn point-list) 5206 (artist-move-to-xy x2 y2))) 5207 5208 5209(defun artist-mouse-draw-1point (ev) 5210 "Generic function for shapes requiring only 1 point as input. 5211Operation is done once. The event, EV, is the mouse event." 5212 (interactive "@e") 5213 (let* ((unshifted (artist-go-get-symbol-shift artist-curr-go nil)) 5214 (shifted (artist-go-get-symbol-shift artist-curr-go t)) 5215 (shift-state (artist-event-is-shifted ev)) 5216 (op (if shift-state shifted unshifted)) 5217 (draw-how (artist-go-get-draw-how-from-symbol op)) 5218 (init-fn (artist-go-get-init-fn-from-symbol op)) 5219 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol op)) 5220 (exit-fn (artist-go-get-exit-fn-from-symbol op)) 5221 (draw-fn (artist-go-get-draw-fn-from-symbol op)) 5222 (arrow-pred (artist-go-get-arrow-pred-from-symbol op)) 5223 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol op)) 5224 (ev-start (event-start ev)) 5225 (ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start))) 5226 (x1 (car ev-start-pos)) 5227 (y1 (cdr ev-start-pos))) 5228 (select-window (posn-window ev-start)) 5229 (artist-funcall init-fn x1 y1) 5230 (artist-funcall draw-fn x1 y1) 5231 (artist-funcall prep-fill-fn x1 y1) 5232 (if (artist-funcall arrow-pred) 5233 (artist-funcall arrow-set-fn x1 y1) 5234 (artist-clear-arrow-points)) 5235 (artist-funcall exit-fn x1 y1) 5236 (artist-move-to-xy x1 y1))) 5237 5238 5239(defun artist-mouse-draw-2points (ev) 5240 "Generic function for shapes requiring 2 points as input. 5241The event, EV, is the mouse event." 5242 (interactive "@e") 5243 (let* ((unshifted (artist-go-get-symbol-shift artist-curr-go nil)) 5244 (shifted (artist-go-get-symbol-shift artist-curr-go t)) 5245 (shift-state (artist-event-is-shifted ev)) 5246 (op (if shift-state shifted unshifted)) 5247 (draw-how (artist-go-get-draw-how-from-symbol op)) 5248 (init-fn (artist-go-get-init-fn-from-symbol op)) 5249 (prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol op)) 5250 (exit-fn (artist-go-get-exit-fn-from-symbol op)) 5251 (draw-fn (artist-go-get-draw-fn-from-symbol op)) 5252 (undraw-fn (artist-go-get-undraw-fn-from-symbol op)) 5253 (fill-pred (artist-go-get-fill-pred-from-symbol op)) 5254 (fill-fn (artist-go-get-fill-fn-from-symbol op)) 5255 (arrow-pred (artist-go-get-arrow-pred-from-symbol op)) 5256 (arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol op)) 5257 (ev-start (event-start ev)) 5258 (initial-win (posn-window ev-start)) 5259 (ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start))) 5260 (x1 (car ev-start-pos)) 5261 (y1 (cdr ev-start-pos)) 5262 (x2) 5263 (y2) 5264 (shape)) 5265 (select-window (posn-window ev-start)) 5266 (artist-funcall init-fn x1 y1) 5267 (if (not artist-rubber-banding) 5268 (artist-no-rb-set-point1 x1 y1)) 5269 (track-mouse 5270 (while (or (mouse-movement-p ev) 5271 (member 'down (event-modifiers ev))) 5272 (setq ev-start-pos (artist-coord-win-to-buf 5273 (posn-col-row (event-start ev)))) 5274 (setq x2 (car ev-start-pos)) 5275 (setq y2 (cdr ev-start-pos)) 5276 5277 (if (not (eq initial-win (posn-window (event-start ev)))) 5278 ;; If we moved outside the window, do nothing 5279 nil 5280 5281 ;; Still in same window: 5282 ;; 5283 ;; First undraw last shape (unset last point if not rubberbanding) 5284 (if artist-rubber-banding 5285 (artist-funcall undraw-fn shape) 5286 (artist-no-rb-unset-point2)) 5287 5288 ;; Check if user presses or releases shift key 5289 (if (artist-shift-has-changed shift-state ev) 5290 5291 ;; First check that the draw-how is the same as we 5292 ;; already have. Otherwise, ignore the changed shift-state. 5293 (if (not (eq draw-how 5294 (artist-go-get-draw-how-from-symbol 5295 (if (not shift-state) shifted unshifted)))) 5296 (message "Cannot switch to shifted operation") 5297 5298 (message "Switching") 5299 ;; progn is "implicit" since this is the else-part 5300 (setq shift-state (not shift-state)) 5301 (setq op (if shift-state shifted unshifted)) 5302 (setq draw-how (artist-go-get-draw-how-from-symbol op)) 5303 (setq draw-fn (artist-go-get-draw-fn-from-symbol op)) 5304 (setq undraw-fn (artist-go-get-undraw-fn-from-symbol op)) 5305 (setq fill-pred (artist-go-get-fill-pred-from-symbol op)) 5306 (setq fill-fn (artist-go-get-fill-fn-from-symbol op)))) 5307 5308 ;; Draw the new shape 5309 (if artist-rubber-banding 5310 (setq shape (artist-funcall draw-fn x1 y1 x2 y2)) 5311 (artist-no-rb-set-point2 x2 y2)) 5312 ;; Move cursor 5313 (artist-move-to-xy x2 y2)) 5314 5315 5316 ;; Read next event 5317 (setq ev (read-event)))) 5318 5319 ;; If we are not rubber-banding (that is, we were moving around the `2') 5320 ;; draw the shape 5321 (if (not artist-rubber-banding) 5322 (progn 5323 (artist-no-rb-unset-points) 5324 (setq shape (artist-funcall draw-fn x1 y1 x2 y2)))) 5325 5326 (artist-funcall prep-fill-fn shape x1 y1 x2 y2) 5327 5328 ;; Maybe fill 5329 (if (artist-funcall fill-pred) 5330 (artist-funcall fill-fn shape x1 y1 x2 y2)) 5331 5332 ;; Maybe set arrow-points 5333 (if (artist-funcall arrow-pred) 5334 (artist-funcall arrow-set-fn shape x1 y1 x2 y2) 5335 (artist-clear-arrow-points)) 5336 5337 (artist-funcall exit-fn shape x1 y1 x2 y2) 5338 (artist-move-to-xy x2 y2))) 5339 5340 5341;; 5342;; Bug-report-submitting 5343;; 5344(defun artist-submit-bug-report () 5345 "Submit via mail a bug report on Artist." 5346 (interactive) 5347 (require 'reporter) 5348 (if (y-or-n-p "Do you want to submit a bug report on Artist? ") 5349 (let ((to artist-maintainer-address) 5350 (vars '(window-system 5351 window-system-version 5352 ;; 5353 artist-rubber-banding 5354 artist-interface-with-rect 5355 artist-aspect-ratio 5356 ;; Now the internal ones 5357 artist-curr-go 5358 artist-key-poly-point-list 5359 artist-key-shape 5360 artist-key-draw-how 5361 artist-arrow-point-1 5362 artist-arrow-point-2))) 5363 ;; Remove those variables from vars that are not bound 5364 (mapcar 5365 (function 5366 (lambda (x) 5367 (if (not (and (boundp x) (symbol-value x))) 5368 (setq vars (delq x vars))))) vars) 5369 (reporter-submit-bug-report 5370 artist-maintainer-address 5371 (concat "artist.el " artist-version) 5372 vars 5373 nil nil 5374 (concat "Hello Tomas,\n\n" 5375 "I have a nice bug report on Artist for you! Here it is:"))))) 5376 5377 5378;; 5379;; Now provide this minor mode 5380;; 5381 5382(provide 'artist) 5383 5384 5385;;; About adding drawing modes 5386;;; -------------------------- 5387 5388;; If you are going to add a new drawing mode, read the following 5389;; sketchy outlines to get started a bit easier. 5390;; 5391;; 1. If your new drawing mode falls into one of the following 5392;; categories, goto point 2, otherwise goto point 3. 5393;; 5394;; - Modes where the shapes are drawn continously, as long as 5395;; the mouse button is held down (continous modes). 5396;; Example: the erase-char mode, the pen and pen-line modes. 5397;; 5398;; - Modes where the shape is made up of from 2 points to an 5399;; arbitrary number of points (poly-point modes). 5400;; Example: the poly-line mode 5401;; 5402;; - Modes where the shape is made up of 2 points (2-point 5403;; modes). 5404;; Example: lines, rectangles 5405;; 5406;; - Modes where the shape is made up of 1 point (1-point 5407;; modes). This mode differs from the continous modes in 5408;; that the shape is drawn only once when the mouse button 5409;; is pressed. 5410;; Examples: paste, a flood-fill, vaporize modes 5411;; 5412;; 5413;; 2. To make it easier and more flexible to program new drawing 5414;; modes, you might choose to specify 5415;; init-fn: a function to be called at the very beginning 5416;; of the drawing phase, 5417;; prep-fill-fn: a function to be called before filling, 5418;; arrow-set-fn: a function for setting arrows, to be called 5419;; after filling, and 5420;; exit-fn: a function to be called at the very end of 5421;; the drawing phase. 5422;; For each of the cases below, the arguments given to the init-fn, 5423;; prep-fill-fn, arrow-set-fn and exit-fn are stated. 5424;; 5425;; If your mode matches the continous mode or the 1-point mode: 5426;; 5427;; a. Create a draw-function that draws your shape. Your function 5428;; must take x and y as arguments. The return value is not 5429;; used. 5430;; 5431;; b. Add your mode to the master table, `artist-mt'. 5432;; 5433;; init-fn: x y 5434;; prep-fill-fn: x y 5435;; arrow-set-fn: x y 5436;; exit-fn: x y 5437;; 5438;; If your mode matches the 2-point mode: 5439;; 5440;; a. Create one draw-function that draws your shape and one 5441;; undraw-function that undraws it. 5442;; 5443;; The draw-function must take x1, y1, x2 and y2 as 5444;; arguments. It must return a list with three elements: 5445;; Endpoint1: a vector [x1 y1] 5446;; Endpoint2: a vector [x2 y2] 5447;; Shapeinfo: all info necessary for your undraw-function to 5448;; be able to undraw the shape 5449;; Use the artist-endpoint-* accessors to create and inspect 5450;; the endpoints. 5451;; 5452;; If applicable, you must be able to draw your shape without 5453;; borders if the `artist-borderless-shapes' is non-nil. 5454;; See `artist-draw-rect' for an example. 5455;; 5456;; The undraw-function must take one argument: the list created 5457;; by your draw-function. The return value is not used. 5458;; 5459;; b. If you want to provide a fill-function, then create a 5460;; function that takes 5 arguments: the list created by your 5461;; draw-function, x1, y1, x2 and y2. The return value is not 5462;; used. 5463;; 5464;; c. Add your mode to the master table, `artist-mt'. 5465;; 5466;; init-fn: x1 y1 5467;; prep-fill-fn: shape x1 y1 x2 y2 5468;; arrow-set-fn: shape x1 y1 x2 y2 5469;; exit-fn: shape x1 y1 x2 y2 5470;; 5471;; If your mode matches the poly-point mode: 5472;; 5473;; a. Create one draw-function that draws your shape and one 5474;; undraw-function that undraws it. The draw- and 5475;; undraw-functions are used to draw/undraw a segment of 5476;; your poly-point mode between 2 points. The draw- and 5477;; undraw-functions are then really 2-point mode functions. 5478;; They must take the same arguments and return the same 5479;; values as those of the 2-point mode. 5480;; 5481;; If applicable, you must be able to draw your shape without 5482;; borders if the `artist-borderless-shapes' is non-nil. 5483;; See `artist-draw-rect' for an example. 5484;; 5485;; b. If you want to provide a fill-function, then create a 5486;; function that takes 1 argument: a list of points where each 5487;; point is a vector, [x, y]. 5488;; 5489;; c. Add your mode to the master table, `artist-mt'. 5490;; 5491;; init-fn: x1 y1 5492;; prep-fill-fn: point-list 5493;; arrow-set-fn: point-list 5494;; exit-fn: point-list 5495;; 5496;; The arrow-set-fn must set the variables `artist-arrow-point-1' 5497;; and `artist-arrow-point-2'. If your mode does not take arrows, 5498;; you must set the variables to nil. Use the accessors 5499;; artist-arrow-point-* to create and inspect arrow-points. 5500;; 5501;; 5502;; 3. If your mode doesn't match any of the categories, you are facing 5503;; a bit more work, and I cannot be as detailed as above. Here is a 5504;; brief outline of what you have to do: 5505;; 5506;; a. Decide on a name for your type of mode. Let's assume that 5507;; you decided on `xxx'. Then you should use the draw-how 5508;; symbol artist-do-xxx. 5509;; 5510;; b. Create a function artist-mouse-draw-xxx for drawing with 5511;; mouse. It should be called from `artist-down-mouse-1'. 5512;; 5513;; The all coordinates must be converted from window-relative 5514;; to buffer relative before saved or handed over to 5515;; any other function. Converting is done with 5516;; the function `artist-coord-win-to-buf'. 5517;; 5518;; It must take care to the `artist-rubber-banding' variable 5519;; and perform rubber-banding accordingly. Use the 5520;; artist-no-rb-* functions if not rubber-banding. 5521;; 5522;; If applicable, you must be able to draw your shape without 5523;; borders if the `artist-borderless-shapes' is non-nil. 5524;; See `artist-draw-rect' for an example. 5525;; 5526;; You must call the init-fn, the prep-fill-fn, arrow-set-fn 5527;; and the exit-fn at the apropriate points. 5528;; 5529;; When artist-mouse-draw-xxx ends, the shape for your mode 5530;; must be completely drawn. 5531;; 5532;; c. Create functions for drawing with keys: 5533;; 5534;; - artist-key-set-point-xxx for setting a point in the 5535;; mode, to be called from `artist-key-set-point-common'. 5536;; 5537;; - artist-key-do-continously-xxx to be called from 5538;; `artist-key-do-continously-common' whenever the user 5539;; moves around. 5540;; 5541;; As for the artist-mouse-draw-xxx, these two functions must 5542;; take care to do rubber-banding, borderless shapes and to 5543;; set arrows. 5544;; 5545;; These functions should set the variable `artist-key-shape' 5546;; to the shape drawn. 5547;; 5548;; d. Create artist-key-draw-xxx and artist-key-undraw-xxx for 5549;; drawing and undrawing. These are needed when the user 5550;; switches operation to draw another shape of the same type 5551;; of drawing mode. 5552;; 5553;; You should provide these functions. You might think that 5554;; only you is using your type of mode, so noone will be able 5555;; to switch to another operation of the same type of mode, 5556;; but someone else might base a new drawing mode upon your 5557;; work. 5558;; 5559;; You must call the init-fn, the prep-fill-fn, arrow-set-fn 5560;; and the exit-fn at the apropriate points. 5561;; 5562;; e. Add your new mode to the master table, `artist-mt'. 5563;; 5564;; 5565;; Happy hacking! Please let me hear if you add any drawing modes! 5566;; Don't hesitate to ask me any questions. 5567 5568 5569;;; arch-tag: 3e63b881-aaaa-4b83-a072-220d4661a8a3 5570;;; artist.el ends here 5571