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