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