lisp/strokes.el

   1 ;;; strokes.el --- control Emacs through mouse strokes
   2
   3 ;; Copyright (C) 1997, 2000, 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: David Bakhash <cadet@alum.mit.edu>
   6 ;; Maintainer: FSF
   7 ;; Keywords: lisp, mouse, extensions
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This is the strokes package.  It is intended to allow the user to
  29 ;; control Emacs by means of mouse strokes.  Once strokes is loaded, you
  30 ;; can always get help be invoking `strokes-help':
  31
  32 ;; > M-x strokes-help
  33
  34 ;; and you can learn how to use the package.  A mouse stroke, for now,
  35 ;; can be defined as holding the shift key and the middle button, for
  36 ;; instance, and then moving the mouse in whatever pattern you wish,
  37 ;; which you have set Emacs to understand as mapping to a given
  38 ;; command.  For example, you may wish the have a mouse stroke that
  39 ;; looks like a capital `C' which means `copy-region-as-kill'.  Treat
  40 ;; strokes just like you do key bindings.  For example, Emacs sets key
  41 ;; bindings globally with the `global-set-key' command.  Likewise, you
  42 ;; can do
  43
  44 ;; > M-x strokes-global-set-stroke
  45
  46 ;; to interactively program in a stroke.  It would be wise to set the
  47 ;; first one to this very command, so that from then on, you invoke
  48 ;; `strokes-global-set-stroke' with a stroke.  Likewise, there may
  49 ;; eventually be a `strokes-local-set-stroke' command, also analogous
  50 ;; to `local-set-key'.
  51
  52 ;; You can always unset the last stroke definition with the command
  53
  54 ;; > M-x strokes-unset-last-stroke
  55
  56 ;; and the last stroke that was added to `strokes-global-map' will be
  57 ;; removed.
  58
  59 ;; Other analogies between strokes and key bindings are as follows:
  60
  61 ;;    1) To describe a stroke binding, you can type
  62
  63 ;;       > M-x strokes-describe-stroke
  64
  65 ;;       analogous to `describe-key'.  It's also wise to have a stroke,
  66 ;;       like an `h', for help, or a `?', mapped to `describe-stroke'.
  67
  68 ;;    2) stroke bindings are set internally through the Lisp function
  69 ;;       `strokes-define-stroke', similar to the `define-key' function.
  70 ;;       some examples for a 3x3 stroke grid would be
  71
  72 ;;       (strokes-define-stroke c-mode-stroke-map
  73 ;;                      '((0 . 0) (1 . 1) (2 . 2))
  74 ;;                      'kill-region)
  75 ;;       (strokes-define-stroke strokes-global-map
  76 ;;                      '((0 . 0) (0 . 1) (0 . 2) (1 . 2) (2 . 2))
  77 ;;                      'list-buffers)
  78
  79 ;;       however, if you would probably just have the user enter in the
  80 ;;       stroke interactively and then set the stroke to whatever he/she
  81 ;;       entered. The Lisp function to interactively read a stroke is
  82 ;;       `strokes-read-stroke'.  This is especially helpful when you're
  83 ;;       on a fast computer that can handle a 9x9 stroke grid.
  84
  85 ;;       NOTE: only global stroke bindings are currently implemented,
  86 ;;       however mode- and buffer-local stroke bindings may eventually
  87 ;;       be implemented in a future version.
  88
  89 ;; The important variables to be aware of for this package are listed
  90 ;; below.  They can all be altered through the customizing package via
  91
  92 ;; > M-x customize
  93
  94 ;; and customizing the group named `strokes'.  You can also read
  95 ;; documentation on the variables there.
  96
  97 ;; `strokes-minimum-match-score' (determines the threshold of error that
  98 ;; makes a stroke acceptable or unacceptable.  If your strokes aren't
  99 ;; matching, then you should raise this variable.
 100
 101 ;; `strokes-grid-resolution' (determines the grid dimensions that you use
 102 ;; when defining/reading strokes.  The finer the grid your computer can
 103 ;; handle, the more you can do, but even a 3x3 grid is pretty cool.)
 104 ;; The default value (9) should be fine for most decent computers.
 105 ;; NOTE: This variable should not be set to a number less than 3.
 106
 107 ;; `strokes-display-strokes-buffer' will allow you to hide the strokes
 108 ;; buffer when doing simple strokes.  This is a speedup for slow
 109 ;; computers as well as people who don't want to see their strokes.
 110
 111 ;; If you find that your mouse is accelerating too fast, you can
 112 ;; execute an X command to slow it down.  A good possibility is
 113
 114 ;; % xset m 5/4 8
 115
 116 ;; which seems, heuristically, to work okay, without much disruption.
 117
 118 ;; Whenever you load in the strokes package, you will be able to save
 119 ;; what you've done upon exiting Emacs.  You can also do
 120
 121 ;; > M-x strokes-prompt-user-save-strokes
 122
 123 ;; and it will save your strokes in ~/.strokes, or you may wish to change
 124 ;; this by setting the variable `strokes-file'.
 125
 126 ;; Note that internally, all of the routines that are part of this
 127 ;; package are able to deal with complex strokes, as they are a superset
 128 ;; of simple strokes.  However, the default of this package will map
 129 ;; S-mouse-2 to the command `strokes-do-stroke', and M-mouse-2 to
 130 ;; `strokes-do-complex-stroke'.  Complex strokes are terminated
 131 ;; with mouse button 3.
 132
 133 ;; You can also toggle between strokes mode by simple typing
 134
 135 ;; > M-x strokes-mode
 136
 137 ;; I hope that, with the help of others, this package will be useful
 138 ;; in entering in pictographic-like language text using the mouse
 139 ;; (i.e. Korean).  Japanese and Chinese are a bit trickier, but I'm
 140 ;; sure that with help it can be done.  The next version will allow
 141 ;; the user to enter strokes which "remove the pencil from the paper"
 142 ;; so to speak, so one character can have multiple strokes.
 143
 144 ;; You can read more about strokes at:
 145
 146 ;; http://www.mit.edu/people/cadet/strokes-help.html
 147
 148 ;; If you're interested in using strokes for writing English into Emacs
 149 ;; using strokes, then you'll want to read about it on the web page above
 150 ;; or just download from http://www.mit.edu/people/cadet/strokes-abc.el,
 151 ;; which is nothing but a file with some helper commands for inserting
 152 ;; alphanumerics and punctuation.
 153
 154 ;; Great thanks to Rob Ristroph for his generosity in letting me use
 155 ;; his PC to develop this, Jason Johnson for his help in algorithms,
 156 ;; Euna Kim for her help in Korean, and massive thanks to the helpful
 157 ;; guys on the help instance on athena (zeno, jered, amu, gsstark,
 158 ;; ghudson, etc) Special thanks to Steve Baur, Kyle Jones, and Hrvoje
 159 ;; Niksic for all their help.  And special thanks to Dave Gillespie
 160 ;; for all the elisp help--he is responsible for helping me use the cl
 161 ;; macros at (near) max speed.
 162
 163 ;; Tasks: (what I'm getting ready for future version)...
 164 ;; 2) use 'strokes-read-complex-stroke for Korean, etc.
 165 ;; 4) buffer-local 'strokes-local-map, and mode-stroke-maps would be nice
 166 ;; 6) add some hooks, like `strokes-read-stroke-hook'
 167 ;; 7) See what people think of the factory settings.  Should I change
 168 ;;    them?  They're all pretty arbitrary in a way.  I guess they
 169 ;;    should be minimal, but computers are getting lots faster, and
 170 ;;    if I choose the defaults too conservatively, then strokes will
 171 ;;    surely disappoint some people on decent machines (until they
 172 ;;    figure out M-x customize).  I need feedback.
 173 ;; Other: I always have the most beta version of strokes, so if you
 174 ;;        want it just let me know.
 175
 176 ;; Fixme: Use pbm instead of xpm for pixmaps to work generally.
 177
 178 ;;; Code:
 179
 180 ;;; Requirements and provisions...
 181
 182 (autoload 'mail-position-on-field "sendmail")
 183 (eval-when-compile (require 'cl))
 184
 185 ;;; Constants...
 186
 187 (defconst strokes-lift :strokes-lift
 188   "Symbol representing a stroke lift event for complex strokes.
 189 Complex strokes are those which contain two or more simple strokes.")
 190
 191 (defconst strokes-xpm-header "/* XPM */
 192 static char * stroke_xpm[] = {
 193 /* width height ncolors cpp [x_hot y_hot] */
 194 \"33 33 9 1 26 23\",
 195 /* colors */
 196 \"      c none s none\",
 197 \"*     c #000000 s foreground\",
 198 \"R     c #FFFF00000000\",
 199 \"O     c #FFFF80000000\",
 200 \"Y     c #FFFFFFFF0000\",
 201 \"G     c #0000FFFF0000\",
 202 \"B     c #00000000FFFF\",
 203 \"P     c #FFFF0000FFFF\",
 204 \".     c #45458B8B0000\",
 205 /* pixels */\n"
 206   "The header to all xpm buffers created by strokes.")
 207
 208 ;;; user variables...
 209
 210 (defgroup strokes nil
 211   "Control Emacs through mouse strokes"
 212   :link '(emacs-commentary-link "strokes")
 213   :link '(url-link "http://www.mit.edu/people/cadet/strokes-help.html")
 214   :group 'mouse)
 215
 216 (defcustom strokes-modeline-string " Strokes"
 217   "*Modeline identification when Strokes mode is on \(default is \" Strokes\"\)."
 218   :type 'string
 219   :group 'strokes)
 220
 221 (defcustom strokes-character ?@
 222   "*Character used when drawing strokes in the strokes buffer.
 223 \(The default is `@', which works well.\)"
 224   :type 'character
 225   :group 'strokes)
 226
 227 (defcustom strokes-minimum-match-score 1000
 228   "*Minimum score for a stroke to be considered a possible match.
 229 Setting this variable to 0 would require a perfectly precise match.
 230 The default value is 1000, but it's mostly dependent on how precisely
 231 you manage to replicate your user-defined strokes.  It also depends on
 232 the value of `strokes-grid-resolution', since a higher grid resolution
 233 will correspond to more sample points, and thus more distance
 234 measurements.  Usually, this is not a problem since you first set
 235 `strokes-grid-resolution' based on what your computer seems to be able
 236 to handle (though the defaults are usually more than sufficient), and
 237 then you can set `strokes-minimum-match-score' to something that works
 238 for you.  The only purpose of this variable is to insure that if you
 239 do a bogus stroke that really doesn't match any of the predefined
 240 ones, then strokes should NOT pick the one that came closest."
 241   :type 'integer
 242   :group 'strokes)
 243
 244 (defcustom strokes-grid-resolution 9
 245   "*Integer defining dimensions of the stroke grid.
 246 The grid is a square grid, where STROKES-GRID-RESOLUTION defaults to
 247 `9', making a 9x9 grid whose coordinates go from (0 . 0) on the top
 248 left to ((STROKES-GRID-RESOLUTION - 1) . (STROKES-GRID-RESOLUTION - 1))
 249 on the bottom right.  The greater the resolution, the more intricate
 250 your strokes can be.
 251 NOTE: This variable should be odd and MUST NOT be less than 3 and need
 252       not be greater than 33, which is the resolution of the pixmaps.
 253 WARNING: Changing the value of this variable will gravely affect the
 254          strokes you have already programmed in.  You should try to
 255          figure out what it should be based on your needs and on how
 256          quick the particular platform(s) you're operating on, and
 257          only then start programming in your custom strokes."
 258   :type 'integer
 259   :group 'strokes)
 260
 261 (defcustom strokes-file (convert-standard-filename "~/.strokes")
 262   "*File containing saved strokes for stroke-mode (default is ~/.strokes)."
 263   :type 'file
 264   :group 'strokes)
 265
 266 (defvar strokes-buffer-name " *strokes*"
 267   "The name of the buffer that the strokes take place in.")
 268
 269 (defcustom strokes-use-strokes-buffer t
 270   "*If non-nil, the strokes buffer is used and strokes are displayed.
 271 If nil, strokes will be read the same, however the user will not be
 272 able to see the strokes.  This be helpful for people who don't like
 273 the delay in switching to the strokes buffer."
 274   :type 'boolean
 275   :group 'strokes)
 276
 277 ;;; internal variables...
 278
 279 (defvar strokes-window-configuration nil
 280   "The special window configuration used when entering strokes.
 281 This is set properly in the function `strokes-update-window-configuration'.")
 282
 283 (defvar strokes-last-stroke nil
 284   "Last stroke entered by the user.
 285 Its value gets set every time the function
 286 `strokes-fill-stroke' gets called,
 287 since that is the best time to set the variable")
 288
 289 (defvar strokes-global-map '()
 290   "Association list of strokes and their definitions.
 291 Each entry is (STROKE . COMMAND) where STROKE is itself a list of
 292 coordinates (X . Y) where X and Y are lists of positions on the
 293 normalized stroke grid, with the top left at (0 . 0).  COMMAND is the
 294 corresponding interactive function")
 295
 296 (defvar strokes-load-hook nil
 297   "Function or functions to be called when `strokes' is loaded.")
 298
 299 ;;; ### NOT IMPLEMENTED YET ###
 300 ;;(defvar edit-strokes-menu
 301 ;;  '("Edit-Strokes"
 302 ;;    ["Add stroke..." strokes-global-set-stroke t]
 303 ;;    ["Delete stroke..." strokes-edit-delete-stroke t]
 304 ;;    ["Change stroke"  strokes-smaller t]
 305 ;;    ["Change definition"      strokes-larger  t]
 306 ;;    ["[Re]List Strokes chronologically"       strokes-list-strokes    t]
 307 ;;    ["[Re]List Strokes alphabetically"        strokes-list-strokes    t]
 308 ;;    ["Quit"           strokes-edit-quit               t]
 309 ;;    ))
 310
 311 ;;; Macros...
 312
 313 ;; unused
 314 ;; (defmacro strokes-while-inhibiting-garbage-collector (&rest forms)
 315 ;;   "Execute FORMS without interference from the garbage collector."
 316 ;;   `(let ((gc-cons-threshold 134217727))
 317 ;;      ,@forms))
 318
 319 (defsubst strokes-click-p (stroke)
 320   "Non-nil if STROKE is really click."
 321   (< (length stroke) 2))
 322
 323 ;;; old, but worked pretty good (just in case)...
 324 ;;(defmacro strokes-define-stroke (stroke-map stroke def)
 325 ;;  "Add STROKE to STROKE-MAP alist with given command DEF"
 326 ;;  (list 'if (list '< (list 'length stroke) 2)
 327 ;;      (list 'error
 328 ;;            "That's a click, not a stroke.  See `strokes-click-command'")
 329 ;;      (list 'setq stroke-map (list 'cons (list 'cons stroke def)
 330 ;;                                   (list 'remassoc stroke stroke-map)))))
 331
 332 (defsubst strokes-remassoc (key list)
 333   (let (elt)
 334     (while (setq elt (assoc key list))
 335       (setq list (delete elt list))))
 336   list)
 337
 338 (defmacro strokes-define-stroke (stroke-map stroke def)
 339   "Add STROKE to STROKE-MAP alist with given command DEF."
 340   `(if (strokes-click-p ,stroke)
 341        (error "That's a click, not a stroke")
 342      (setq ,stroke-map (cons (cons ,stroke ,def)
 343                              (strokes-remassoc ,stroke ,stroke-map)))))
 344
 345 (defsubst strokes-square (x)
 346   "Return the square of the number X."
 347   (* x x))
 348
 349 (defsubst strokes-distance-squared (p1 p2)
 350   "Gets the distance (squared) between to points P1 and P2.
 351 P1 and P2 are cons cells in the form (X . Y)."
 352   (let ((x1 (car p1))
 353         (y1 (cdr p1))
 354         (x2 (car p2))
 355         (y2 (cdr p2)))
 356     (+ (strokes-square (- x2 x1))
 357        (strokes-square (- y2 y1)))))
 358
 359 ;;; Functions...
 360
 361 (defsubst strokes-mouse-event-p (event)
 362   (and (consp event) (symbolp (car event))
 363        (or (eq (car event) 'mouse-movement)
 364            (memq 'click (get (car event) 'event-symbol-elements))
 365            (memq 'down (get (car event) 'event-symbol-elements))
 366            (memq 'drag (get (car event) 'event-symbol-elements)))))
 367
 368 (defsubst strokes-button-press-event-p (event)
 369   (and (consp event) (symbolp (car event))
 370        (memq 'down (get (car event) 'event-symbol-elements))))
 371
 372 (defsubst strokes-button-release-event-p (event)
 373   (and (consp event) (symbolp (car event))
 374        (or (memq 'click (get (car event) 'event-symbol-elements))
 375            (memq 'drag (get (car event) 'event-symbol-elements)))))
 376
 377 (defun strokes-event-closest-point-1 (window &optional line)
 378   "Return position of start of line LINE in WINDOW.
 379 If LINE is nil, return the last position visible in WINDOW."
 380   (let* ((total (- (window-height window)
 381                    (if (window-minibuffer-p window)
 382                        0 1)))
 383          (distance (or line total)))
 384     (save-excursion
 385       (goto-char (window-start window))
 386       (if (= (vertical-motion distance) distance)
 387           (if (not line)
 388               (forward-char -1)))
 389       (point))))
 390
 391 (defun strokes-event-closest-point (event &optional start-window)
 392   "Return the nearest position to where EVENT ended its motion.
 393 This is computed for the window where EVENT's motion started,
 394 or for window START-WINDOW if that is specified."
 395   (or start-window (setq start-window (posn-window (event-start event))))
 396   (if (eq start-window (posn-window (event-end event)))
 397       (if (eq (posn-point (event-end event)) 'vertical-line)
 398           (strokes-event-closest-point-1 start-window
 399                                          (cdr (posn-col-row (event-end event))))
 400         (if (eq (posn-point (event-end event)) 'mode-line)
 401             (strokes-event-closest-point-1 start-window)
 402           (posn-point (event-end event))))
 403     ;; EVENT ended in some other window.
 404     (let* ((end-w (posn-window (event-end event)))
 405            (end-w-top)
 406            (w-top (nth 1 (window-edges start-window))))
 407       (setq end-w-top
 408             (if (windowp end-w)
 409                 (nth 1 (window-edges end-w))
 410               (/ (cdr (posn-x-y (event-end event)))
 411                  (frame-char-height end-w))))
 412       (if (>= end-w-top w-top)
 413           (strokes-event-closest-point-1 start-window)
 414         (window-start start-window)))))
 415
 416 (defun strokes-lift-p (object)
 417   "Return non-nil if OBJECT is a stroke-lift."
 418   (eq object strokes-lift))
 419
 420 (defun strokes-unset-last-stroke ()
 421   "Undo the last stroke definition."
 422   (interactive)
 423   (let ((command (cdar strokes-global-map)))
 424     (if (y-or-n-p
 425          (format "Really delete last stroke definition, defined to `%s'? "
 426                  command))
 427         (progn
 428           (setq strokes-global-map (cdr strokes-global-map))
 429           (message "That stroke has been deleted"))
 430       (message "Nothing done"))))
 431
 432 ;;;###autoload
 433 (defun strokes-global-set-stroke (stroke command)
 434   "Interactively give STROKE the global binding as COMMAND.
 435 Operated just like `global-set-key', except for strokes.
 436 COMMAND is a symbol naming an interactively-callable function.  STROKE
 437 is a list of sampled positions on the stroke grid as described in the
 438 documentation for the `strokes-define-stroke' function."
 439   (interactive
 440    (list
 441     (and (or strokes-mode (strokes-mode t))
 442          (strokes-read-complex-stroke
 443           "Draw with mouse button 1 (or 2).  End with button 3..."))
 444     (read-command "Command to map stroke to: ")))
 445   (strokes-define-stroke strokes-global-map stroke command))
 446
 447 ;;(defun global-unset-stroke (stroke); FINISH THIS DEFUN!
 448 ;;  "delete all strokes matching STROKE from `strokes-global-map',
 449 ;; letting the user input
 450 ;; the stroke with the mouse"
 451 ;;  (interactive
 452 ;;   (list
 453 ;;    (strokes-read-stroke "Enter the stroke you want to delete...")))
 454 ;;  (strokes-define-stroke 'strokes-global-map stroke command))
 455
 456 (defun strokes-get-grid-position (stroke-extent position &optional grid-resolution)
 457   "Map POSITION to a new grid position.
 458 Do so  based on its STROKE-EXTENT and GRID-RESOLUTION.
 459 STROKE-EXTENT as a list \(\(XMIN . YMIN\) \(XMAX . YMAX\)\).
 460 If POSITION is a `strokes-lift', then it is itself returned.
 461 Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION.
 462 The grid is a square whose dimension is [0,GRID-RESOLUTION)."
 463   (cond ((consp position)               ; actual pixel location
 464          (let ((grid-resolution (or grid-resolution strokes-grid-resolution))
 465                (x (car position))
 466                (y (cdr position))
 467                (xmin (caar stroke-extent))
 468                (ymin (cdar stroke-extent))
 469                ;; the `1+' is there to insure that the
 470                ;; formula evaluates correctly at the boundaries
 471                (xmax (1+ (car (cadr stroke-extent))))
 472                (ymax (1+ (cdr (cadr stroke-extent)))))
 473            (cons (floor (* grid-resolution
 474                            (/ (float (- x xmin))
 475                               (- xmax xmin))))
 476                  (floor (* grid-resolution
 477                            (/ (float (- y ymin))
 478                               (- ymax ymin)))))))
 479         ((strokes-lift-p position)      ; stroke lift
 480          strokes-lift)))
 481
 482 (defun strokes-get-stroke-extent (pixel-positions)
 483   "From a list of absolute PIXEL-POSITIONS, return absolute spatial extent.
 484 The return value is a list ((XMIN . YMIN) (XMAX . YMAX))."
 485   (if pixel-positions
 486       (let ((xmin (caar pixel-positions))
 487             (xmax (caar pixel-positions))
 488             (ymin (cdar pixel-positions))
 489             (ymax (cdar pixel-positions))
 490             (rest (cdr pixel-positions)))
 491         (while rest
 492           (if (consp (car rest))
 493               (let ((x (caar rest))
 494                     (y (cdar rest)))
 495                 (if (< x xmin)
 496                     (setq xmin x))
 497                 (if (> x xmax)
 498                     (setq xmax x))
 499                 (if (< y ymin)
 500                     (setq ymin y))
 501                 (if (> y ymax)
 502                     (setq ymax y))))
 503           (setq rest (cdr rest)))
 504         (let ((delta-x (- xmax xmin))
 505               (delta-y (- ymax ymin)))
 506           (if (> delta-x delta-y)
 507               (setq ymin (- ymin
 508                             (/ (- delta-x delta-y)
 509                                2))
 510                     ymax (+ ymax
 511                             (/ (- delta-x delta-y)
 512                                2)))
 513             (setq xmin (- xmin
 514                           (/ (- delta-y delta-x)
 515                              2))
 516                   xmax (+ xmax
 517                           (/ (- delta-y delta-x)
 518                              2))))
 519           (list (cons xmin ymin)
 520                 (cons xmax ymax))))
 521     nil))
 522
 523 (defun strokes-eliminate-consecutive-redundancies (entries)
 524   "Return a list with no consecutive redundant entries."
 525   ;; defun a grande vitesse grace a Dave G.
 526   (loop for element on entries
 527         if (not (equal (car element) (cadr element)))
 528         collect (car element)))
 529 ;;  (loop for element on entries
 530 ;;        nconc (if (not (equal (car el) (cadr el)))
 531 ;;                  (list (car el)))))
 532 ;; yet another (orig) way of doing it...
 533 ;;  (if entries
 534 ;;      (let* ((current (car entries))
 535 ;;           (rest (cdr entries))
 536 ;;           (non-redundant-list (list current))
 537 ;;           (next nil))
 538 ;;      (while rest
 539 ;;        (setq next (car rest))
 540 ;;        (if (equal current next)
 541 ;;            (setq rest (cdr rest))
 542 ;;          (setq non-redundant-list (cons next non-redundant-list)
 543 ;;                current next
 544 ;;                rest (cdr rest))))
 545 ;;      (nreverse non-redundant-list))
 546 ;;    nil))
 547
 548 (defun strokes-renormalize-to-grid (positions &optional grid-resolution)
 549   "Map POSITIONS to a new grid whose dimensions are based on GRID-RESOLUTION.
 550 POSITIONS is a list of positions and stroke-lifts.
 551 Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION.
 552 The grid is a square whose dimension is [0,GRID-RESOLUTION)."
 553   (or grid-resolution (setq grid-resolution strokes-grid-resolution))
 554   (let ((stroke-extent (strokes-get-stroke-extent positions)))
 555     (mapcar (function
 556              (lambda (pos)
 557                (strokes-get-grid-position stroke-extent pos grid-resolution)))
 558             positions)))
 559
 560 (defun strokes-fill-stroke (unfilled-stroke &optional force)
 561   "Fill in missing grid locations in the list of UNFILLED-STROKE.
 562 If FORCE is non-nil, then fill the stroke even if it's `stroke-click'.
 563 NOTE: This is where the global variable `strokes-last-stroke' is set."
 564   (setq strokes-last-stroke             ; this is global
 565         (if (and (strokes-click-p unfilled-stroke)
 566                  (not force))
 567             unfilled-stroke
 568           (loop for grid-locs on unfilled-stroke
 569                 nconc (let* ((current (car grid-locs))
 570                              (current-is-a-point-p (consp current))
 571                              (next (cadr grid-locs))
 572                              (next-is-a-point-p (consp next))
 573                              (both-are-points-p (and current-is-a-point-p
 574                                                      next-is-a-point-p))
 575                              (x1 (and current-is-a-point-p
 576                                       (car current)))
 577                              (y1 (and current-is-a-point-p
 578                                       (cdr current)))
 579                              (x2 (and next-is-a-point-p
 580                                       (car next)))
 581                              (y2 (and next-is-a-point-p
 582                                       (cdr next)))
 583                              (delta-x (and both-are-points-p
 584                                            (- x2 x1)))
 585                              (delta-y (and both-are-points-p
 586                                            (- y2 y1)))
 587                              (slope (and both-are-points-p
 588                                          (if (zerop delta-x)
 589                                              nil ; undefined vertical slope
 590                                            (/ (float delta-y)
 591                                               delta-x)))))
 592                         (cond ((not both-are-points-p)
 593                                (list current))
 594                               ((null slope) ; undefined vertical slope
 595                                (if (>= delta-y 0)
 596                                    (loop for y from y1 below y2
 597                                          collect (cons x1 y))
 598                                  (loop for y from y1 above y2
 599                                        collect (cons x1 y))))
 600                               ((zerop slope) ; (= y1 y2)
 601                                (if (>= delta-x 0)
 602                                    (loop for x from x1 below x2
 603                                          collect (cons x y1))
 604                                  (loop for x from x1 above x2
 605                                        collect (cons x y1))))
 606                               ((>= (abs delta-x) (abs delta-y))
 607                                (if (> delta-x 0)
 608                                    (loop for x from x1 below x2
 609                                          collect (cons x
 610                                                        (+ y1
 611                                                           (round (* slope
 612                                                                     (- x x1))))))
 613                                  (loop for x from x1 above x2
 614                                        collect (cons x
 615                                                      (+ y1
 616                                                         (round (* slope
 617                                                                   (- x x1))))))))
 618                               (t        ; (< (abs delta-x) (abs delta-y))
 619                                (if (> delta-y 0)
 620                                    (loop for y from y1 below y2
 621                                          collect (cons (+ x1
 622                                                           (round (/ (- y y1)
 623                                                                     slope)))
 624                                                        y))
 625                                  (loop for y from y1 above y2
 626                                        collect (cons (+ x1
 627                                                         (round (/ (- y y1)
 628                                                                   slope)))
 629                                                      y))))))))))
 630
 631 (defun strokes-rate-stroke (stroke1 stroke2)
 632   "Rates STROKE1 with STROKE2 and return a score based on a distance metric.
 633 Note: the rating is an error rating, and therefore, a return of 0
 634 represents a perfect match.  Also note that the order of stroke
 635 arguments is order-independent for the algorithm used here."
 636   (if (and stroke1 stroke2)
 637       (let ((rest1 (cdr stroke1))
 638             (rest2 (cdr stroke2))
 639             (err (strokes-distance-squared (car stroke1)
 640                                            (car stroke2))))
 641         (while (and rest1 rest2)
 642           (while (and (consp (car rest1))
 643                       (consp (car rest2)))
 644             (setq err (+ err
 645                          (strokes-distance-squared (car rest1)
 646                                                    (car rest2)))
 647                   stroke1 rest1
 648                   stroke2 rest2
 649                   rest1 (cdr stroke1)
 650                   rest2 (cdr stroke2)))
 651           (cond ((and (strokes-lift-p (car rest1))
 652                       (strokes-lift-p (car rest2)))
 653                  (setq rest1 (cdr rest1)
 654                        rest2 (cdr rest2)))
 655                 ((strokes-lift-p (car rest2))
 656                  (while (consp (car rest1))
 657                    (setq err (+ err
 658                                 (strokes-distance-squared (car rest1)
 659                                                           (car stroke2)))
 660                          rest1 (cdr rest1))))
 661                 ((strokes-lift-p (car rest1))
 662                  (while (consp (car rest2))
 663                    (setq err (+ err
 664                                 (strokes-distance-squared (car stroke1)
 665                                                           (car rest2)))
 666                          rest2 (cdr rest2))))))
 667         (if (null rest2)
 668             (while (consp (car rest1))
 669               (setq err (+ err
 670                            (strokes-distance-squared (car rest1)
 671                                                      (car stroke2)))
 672                     rest1 (cdr rest1))))
 673         (if (null rest1)
 674             (while (consp (car rest2))
 675               (setq err (+ err
 676                            (strokes-distance-squared (car stroke1)
 677                                                      (car rest2)))
 678                     rest2 (cdr rest2))))
 679         (if (or (strokes-lift-p (car rest1))
 680                 (strokes-lift-p (car rest2)))
 681             (setq err nil)
 682           err))
 683     nil))
 684
 685 (defun strokes-match-stroke (stroke stroke-map)
 686   "Find the best matching command of STROKE in STROKE-MAP.
 687 Returns the corresponding match as (COMMAND . SCORE)."
 688   (if (and stroke stroke-map)
 689       (let ((score (strokes-rate-stroke stroke (caar stroke-map)))
 690             (command (cdar stroke-map))
 691             (map (cdr stroke-map)))
 692         (while map
 693           (let ((newscore (strokes-rate-stroke stroke (caar map))))
 694             (if (or (and newscore score (< newscore score))
 695                     (and newscore (null score)))
 696                 (setq score newscore
 697                       command (cdar map)))
 698             (setq map (cdr map))))
 699         (if score
 700             (cons command score)
 701           nil))
 702     nil))
 703
 704 ;;;###autoload
 705 (defun strokes-read-stroke (&optional prompt event)
 706   "Read a simple stroke (interactively) and return the stroke.
 707 Optional PROMPT in minibuffer displays before and during stroke reading.
 708 This function will display the stroke interactively as it is being
 709 entered in the strokes buffer if the variable
 710 `strokes-use-strokes-buffer' is non-nil.
 711 Optional EVENT is acceptable as the starting event of the stroke"
 712   (save-excursion
 713     (let ((pix-locs nil)
 714           (grid-locs nil)
 715           (safe-to-draw-p nil))
 716       (if strokes-use-strokes-buffer
 717           ;; switch to the strokes buffer and
 718           ;; display the stroke as it's being read
 719           (save-window-excursion
 720             (set-window-configuration strokes-window-configuration)
 721             (when prompt
 722               (message prompt)
 723               (setq event (read-event))
 724               (or (strokes-button-press-event-p event)
 725                   (error "You must draw with the mouse")))
 726             (unwind-protect
 727                 (track-mouse
 728                   (or event (setq event (read-event)
 729                                   safe-to-draw-p t))
 730                   (while (not (strokes-button-release-event-p event))
 731                     (if (strokes-mouse-event-p event)
 732                         (let ((point (strokes-event-closest-point event)))
 733                           (if (and point safe-to-draw-p)
 734                               ;; we can draw that point
 735                               (progn
 736                                 (goto-char point)
 737                                 (subst-char-in-region point (1+ point)
 738                                                       ?\  strokes-character))
 739                             ;; otherwise, we can start drawing the next time...
 740                             (setq safe-to-draw-p t))
 741                           (push (cdr (mouse-pixel-position))
 742                                 pix-locs)))
 743                     (setq event (read-event)))))
 744             ;; protected
 745             ;; clean up strokes buffer and then bury it.
 746             (when (equal (buffer-name) strokes-buffer-name)
 747               (subst-char-in-region (point-min) (point-max)
 748                                     strokes-character ?\ )
 749               (goto-char (point-min))
 750               (bury-buffer))))
 751       ;; Otherwise, don't use strokes buffer and read stroke silently
 752       (when prompt
 753         (message prompt)
 754         (setq event (read-event))
 755         (or (strokes-button-press-event-p event)
 756             (error "You must draw with the mouse")))
 757       (track-mouse
 758         (or event (setq event (read-event)))
 759         (while (not (strokes-button-release-event-p event))
 760           (if (strokes-mouse-event-p event)
 761               (push (cdr (mouse-pixel-position))
 762                     pix-locs))
 763           (setq event (read-event))))
 764       (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs)))
 765       (strokes-fill-stroke
 766        (strokes-eliminate-consecutive-redundancies grid-locs)))))
 767
 768 ;;;###autoload
 769 (defun strokes-read-complex-stroke (&optional prompt event)
 770   "Read a complex stroke (interactively) and return the stroke.
 771 Optional PROMPT in minibuffer displays before and during stroke reading.
 772 Note that a complex stroke allows the user to pen-up and pen-down.  This
 773 is implemented by allowing the user to paint with button 1 or button 2 and
 774 then complete the stroke with button 3.
 775 Optional EVENT is acceptable as the starting event of the stroke"
 776   (save-excursion
 777     (save-window-excursion
 778       (set-window-configuration strokes-window-configuration)
 779       (let ((pix-locs nil)
 780             (grid-locs nil))
 781         (if prompt
 782             (while (not (strokes-button-press-event-p event))
 783               (message prompt)
 784               (setq event (read-event))))
 785         (unwind-protect
 786             (track-mouse
 787               (or event (setq event (read-event)))
 788               (while (not (and (strokes-button-press-event-p event)
 789                                (eq 'mouse-3
 790                                    (car (get (car event)
 791                                              'event-symbol-elements)))))
 792                 (while (not (strokes-button-release-event-p event))
 793                   (if (strokes-mouse-event-p event)
 794                       (let ((point (strokes-event-closest-point event)))
 795                         (when point
 796                           (goto-char point)
 797                           (subst-char-in-region point (1+ point)
 798                                                 ?\  strokes-character))
 799                         (push (cdr (mouse-pixel-position))
 800                               pix-locs)))
 801                   (setq event (read-event)))
 802                 (push strokes-lift pix-locs)
 803                 (while (not (strokes-button-press-event-p event))
 804                   (setq event (read-event))))
 805               ;; ### KLUDGE! ### sit and wait
 806               ;; for some useless event to
 807               ;; happen to fix the minibuffer bug.
 808               (while (not (strokes-button-release-event-p (read-event))))
 809               (setq pix-locs (nreverse (cdr pix-locs))
 810                     grid-locs (strokes-renormalize-to-grid pix-locs))
 811               (strokes-fill-stroke
 812                (strokes-eliminate-consecutive-redundancies grid-locs)))
 813           ;; protected
 814           (when (equal (buffer-name) strokes-buffer-name)
 815             (subst-char-in-region (point-min) (point-max)
 816                                   strokes-character ?\ )
 817             (goto-char (point-min))
 818             (bury-buffer)))))))
 819
 820 (defun strokes-execute-stroke (stroke)
 821   "Given STROKE, execute the command which corresponds to it.
 822 The command will be executed provided one exists for that stroke,
 823 based on the variable `strokes-minimum-match-score'.
 824 If no stroke matches, nothing is done and return value is nil."
 825   (let* ((match (strokes-match-stroke stroke strokes-global-map))
 826          (command (car match))
 827          (score (cdr match)))
 828     (cond ((and match (<= score strokes-minimum-match-score))
 829            (message "%s" command)
 830            (command-execute command))
 831           ((null strokes-global-map)
 832            (if (file-exists-p strokes-file)
 833                (and (y-or-n-p
 834                      (format "No strokes loaded.  Load `%s'? "
 835                              strokes-file))
 836                     (strokes-load-user-strokes))
 837              (error "No strokes defined; use `strokes-global-set-stroke'")))
 838           (t
 839            (error
 840             "No stroke matches; see variable `strokes-minimum-match-score'")
 841            nil))))
 842
 843 ;;;###autoload
 844 (defun strokes-do-stroke (event)
 845   "Read a simple stroke from the user and then execute its command.
 846 This must be bound to a mouse event."
 847   (interactive "e")
 848   (or strokes-mode (strokes-mode t))
 849   (strokes-execute-stroke (strokes-read-stroke nil event)))
 850
 851 ;;;###autoload
 852 (defun strokes-do-complex-stroke (event)
 853   "Read a complex stroke from the user and then execute its command.
 854 This must be bound to a mouse event."
 855   (interactive "e")
 856   (or strokes-mode (strokes-mode t))
 857   (strokes-execute-stroke (strokes-read-complex-stroke nil event)))
 858
 859 ;;;###autoload
 860 (defun strokes-describe-stroke (stroke)
 861   "Displays the command which STROKE maps to, reading STROKE interactively."
 862   (interactive
 863    (list
 864     (strokes-read-complex-stroke
 865      "Enter stroke to describe; end with button 3...")))
 866   (let* ((match (strokes-match-stroke stroke strokes-global-map))
 867          (command (car match))
 868          (score (cdr match)))
 869     (if (and match
 870              (<= score strokes-minimum-match-score))
 871         (message "That stroke maps to `%s'" command)
 872       (message "That stroke is undefined"))
 873     (sleep-for 1)))                     ; helpful for recursive edits
 874
 875 ;;;###autoload
 876 (defun strokes-help ()
 877   "Get instruction on using the `strokes' package."
 878   (interactive)
 879   (with-output-to-temp-buffer "*Help with Strokes*"
 880     (princ
 881      "This is help for the strokes package.
 882
 883 ------------------------------------------------------------
 884
 885 ** Strokes...
 886
 887 The strokes package allows you to define strokes, made with
 888 the mouse or other pointer device, that Emacs can interpret as
 889 corresponding to commands, and then executes the commands.  It does
 890 character recognition, so you don't have to worry about getting it
 891 right every time.
 892
 893 Strokes also allows you to compose documents graphically.  You can
 894 fully edit documents in Chinese, Japanese, etc. based on Emacs
 895 strokes.  Once you've done so, you can ASCII compress-and-encode them
 896 and then safely save them for later use, send letters to friends
 897 \(using Emacs, of course).  Strokes will later decode these documents,
 898 extracting the strokes for editing use once again, so the editing
 899 cycle can continue.
 900
 901 Strokes are easy to program and fun to use.  To start strokes going,
 902 you'll want to put the following line in your .emacs file as mentioned
 903 in the commentary to strokes.el.
 904
 905 This will load strokes when and only when you start Emacs on a window
 906 system, with a mouse or other pointer device defined.
 907
 908 To toggle strokes-mode, you just do
 909
 910 > M-x strokes-mode
 911
 912 ** Strokes for controlling the behavior of Emacs...
 913
 914 When you're ready to start defining strokes, just use the command
 915
 916 > M-x strokes-global-set-stroke
 917
 918 You will see a ` *strokes*' buffer which is waiting for you to enter in
 919 your stroke.  When you enter in the stroke, you draw with button 1 or
 920 button 2, and then end with button 3.  Next, you enter in the command
 921 which will be executed when that stroke is invoked.  Simple as that.
 922 For now, try to define a stroke to copy a region.  This is a popular
 923 edit command, so type
 924
 925 > M-x strokes-global-set-stroke
 926
 927 Then, in the ` *strokes*' buffer, draw the letter `C' (for `copy')
 928 and then, when it asks you to enter the command to map that to, type
 929
 930 > copy-region-as-kill
 931
 932 That's about as hard as it gets.
 933 Remember: paint with button 1 or button 2 and then end with button 3.
 934
 935 If ever you want to know what a certain strokes maps to, then do
 936
 937 > M-x strokes-describe-stroke
 938
 939 and you can enter in any arbitrary stroke.  Remember: The strokes
 940 package lets you program in simple and complex (multi-lift) strokes.
 941 The only difference is how you *invoke* the two.  You will most likely
 942 use simple strokes, as complex strokes were developed for
 943 Chinese/Japanese/Korean.  So the shifted middle mouse button (S-mouse-2) will
 944 invoke the command `strokes-do-stroke'.
 945
 946 If ever you define a stroke which you don't like, then you can unset
 947 it with the command
 948
 949 > M-x strokes-unset-last-stroke
 950
 951 You can always get an idea of what your current strokes look like with
 952 the command
 953
 954 > M-x strokes-list-strokes
 955
 956 Your strokes will be displayed in alphabetical order (based on command
 957 names) and the beginning of each simple stroke will be marked by a
 958 color dot.  Since you may have several simple strokes in a complex
 959 stroke, the dot colors are arranged in the rainbow color sequence,
 960 `ROYGBIV'.  If you want a listing of your strokes from most recent
 961 down, then use a prefix argument:
 962
 963 > C-u M-x strokes-list-strokes
 964
 965 Your strokes are stored as you enter them.  They get saved in a file
 966 called ~/.strokes, along with other strokes configuration variables.
 967 You can change this location by setting the variable `strokes-file'.
 968 You will be prompted to save them when you exit Emacs, or you can save
 969 them with
 970
 971 > M-x strokes-save-strokes
 972
 973 Your strokes get loaded automatically when you enable `strokes-mode'.
 974 You can also load in your user-defined strokes with
 975
 976 > M-x strokes-load-user-strokes
 977
 978 ** Strokes for pictographic editing...
 979
 980 If you'd like to create graphical files with strokes, you'll have to
 981 be running a version of Emacs with XPM support.  You use the binding
 982 to `strokes-compose-complex-stroke' to start drawing your strokes.
 983 These are just complex strokes, and thus continue drawing with mouse-1
 984 or mouse-2 and end with mouse-3.  Then the stroke image gets inserted
 985 into the buffer.  You treat it somewhat like any other character,
 986 which you can copy, paste, delete, move, etc.  When all is done, you
 987 may want to send the file, or save it.  This is done with
 988
 989 > M-x strokes-encode-buffer
 990
 991 Likewise, to decode the strokes from a strokes-encoded buffer you do
 992
 993 > M-x strokes-decode-buffer
 994
 995 ** A few more important things...
 996
 997 o The command `strokes-do-complex-stroke' is invoked with M-mouse-2,
 998   so that you can execute complex strokes (i.e. with more than one lift)
 999   if preferred.
1000
1001 o Strokes are a bit computer-dependent in that they depend somewhat on
1002   the speed of the computer you're working on.  This means that you
1003   may have to tweak some variables.  You can read about them in the
1004   commentary of `strokes.el'.  Better to just use \\[apropos] and read their
1005   docstrings.  All variables/functions start with `strokes'.  The one
1006   variable which many people wanted to see was
1007   `strokes-use-strokes-buffer' which allows the user to use strokes
1008   silently--without displaying the strokes.  All variables can be set
1009   by customizing the group `strokes' via \[customize-group].")
1010     (set-buffer standard-output)
1011     (help-mode)
1012     (print-help-return-message)))
1013
1014 (defalias 'strokes-report-bug 'report-emacs-bug)
1015
1016 (defsubst strokes-fill-current-buffer-with-whitespace ()
1017   "Erase the contents of the current buffer and fill it with whitespace."
1018   (erase-buffer)
1019   (loop repeat (frame-height) do
1020         (insert-char ?\  (1- (frame-width)))
1021         (newline))
1022   (goto-char (point-min)))
1023
1024 (defun strokes-window-configuration-changed-p ()
1025   "Non-nil if the `strokes-window-configuration' frame properties changed.
1026 This is based on the last time `strokes-window-configuration' was updated."
1027   (compare-window-configurations (current-window-configuration)
1028                                  strokes-window-configuration))
1029
1030 (defun strokes-update-window-configuration ()
1031   "Ensure that `strokes-window-configuration' is up-to-date."
1032   (interactive)
1033   (let ((current-window (selected-window)))
1034     (cond ((or (window-minibuffer-p current-window)
1035                (window-dedicated-p current-window))
1036            ;; don't try to update strokes window configuration
1037            ;; if window is dedicated or a minibuffer
1038            nil)
1039           ((or (interactive-p)
1040                (not (buffer-live-p (get-buffer strokes-buffer-name)))
1041                (null strokes-window-configuration))
1042            ;; create `strokes-window-configuration' from scratch...
1043            (save-excursion
1044              (save-window-excursion
1045                (get-buffer-create strokes-buffer-name)
1046                (set-window-buffer current-window strokes-buffer-name)
1047                (delete-other-windows)
1048                (fundamental-mode)
1049                (auto-save-mode 0)
1050                (if (featurep 'font-lock)
1051                    (font-lock-mode 0))
1052                (abbrev-mode 0)
1053                (buffer-disable-undo (current-buffer))
1054                (setq truncate-lines nil)
1055                (strokes-fill-current-buffer-with-whitespace)
1056                (setq strokes-window-configuration (current-window-configuration))
1057                (bury-buffer))))
1058           ((strokes-window-configuration-changed-p) ; simple update
1059            ;; update the strokes-window-configuration for this
1060            ;; specific frame...
1061            (save-excursion
1062              (save-window-excursion
1063                (set-window-buffer current-window strokes-buffer-name)
1064                (delete-other-windows)
1065                (strokes-fill-current-buffer-with-whitespace)
1066                (setq strokes-window-configuration (current-window-configuration))
1067                (bury-buffer)))))))
1068
1069 ;;;###autoload
1070 (defun strokes-load-user-strokes ()
1071   "Load user-defined strokes from file named by `strokes-file'."
1072   (interactive)
1073   (cond ((and (file-exists-p strokes-file)
1074               (file-readable-p strokes-file))
1075          (load-file strokes-file))
1076         ((interactive-p)
1077          (error "Trouble loading user-defined strokes; nothing done"))
1078         (t
1079          (message "No user-defined strokes, sorry"))))
1080
1081 (defun strokes-prompt-user-save-strokes ()
1082   "Save user-defined strokes to file named by `strokes-file'."
1083   (interactive)
1084   (save-excursion
1085     (let ((current strokes-global-map))
1086       (unwind-protect
1087           (progn
1088             (setq strokes-global-map nil)
1089             (strokes-load-user-strokes)
1090             (if (and (not (equal current strokes-global-map))
1091                      (or (interactive-p)
1092                          (yes-or-no-p "Save your strokes? ")))
1093                 (progn
1094                   (require 'pp)         ; pretty-print variables
1095                   (message "Saving strokes in %s..." strokes-file)
1096                   (get-buffer-create "*saved-strokes*")
1097                   (set-buffer "*saved-strokes*")
1098                   (erase-buffer)
1099                   (emacs-lisp-mode)
1100                   (goto-char (point-min))
1101                   (insert
1102                    ";;   -*- emacs-lisp -*-\n")
1103                   (insert (format ";;; saved strokes for %s, as of %s\n\n"
1104                                   (user-full-name)
1105                                   (format-time-string "%B %e, %Y" nil)))
1106                   (message "Saving strokes in %s..." strokes-file)
1107                   (insert (format "(setq strokes-global-map\n'%s)"
1108                                   (pp current)))
1109                   (message "Saving strokes in %s..." strokes-file)
1110                   (indent-region (point-min) (point-max) nil)
1111                   (write-region (point-min)
1112                                 (point-max)
1113                                 strokes-file))
1114               (message "(no changes need to be saved)")))
1115         ;; protected
1116         (if (get-buffer "*saved-strokes*")
1117             (kill-buffer (get-buffer "*saved-strokes*")))
1118         (setq strokes-global-map current)))))
1119
1120 (defun strokes-toggle-strokes-buffer (&optional arg)
1121   "Toggle the use of the strokes buffer.
1122 In other words, toggle the variable `strokes-use-strokes-buffer'.
1123 With ARG, use strokes buffer if and only if ARG is positive or true.
1124 Returns value of `strokes-use-strokes-buffer'."
1125   (interactive "P")
1126   (setq strokes-use-strokes-buffer
1127         (if arg (> (prefix-numeric-value arg) 0)
1128           (not strokes-use-strokes-buffer))))
1129
1130 (defun strokes-xpm-for-stroke (&optional stroke bufname b/w-only)
1131   "Create an XPM pixmap for the given STROKE in buffer ` *strokes-xpm*'.
1132 If STROKE is not supplied, then `strokes-last-stroke' will be used.
1133 Optional BUFNAME to name something else.
1134 The pixmap will contain time information via rainbow dot colors
1135 where each individual strokes begins.
1136 Optional B/W-ONLY non-nil will create a mono pixmap, not intended
1137 for trying to figure out the order of strokes, but rather for reading
1138 the stroke as a character in some language."
1139   (interactive)
1140   (save-excursion
1141     (let ((buf (get-buffer-create (or bufname " *strokes-xpm*")))
1142           (stroke (strokes-eliminate-consecutive-redundancies
1143                    (strokes-fill-stroke
1144                     (strokes-renormalize-to-grid (or stroke
1145                                                      strokes-last-stroke)
1146                                                  31))))
1147           (lift-flag t)
1148           (rainbow-chars (list ?R ?O ?Y ?G ?B ?P))) ; ROYGBIV w/o indigo
1149       (set-buffer buf)
1150       (erase-buffer)
1151       (insert strokes-xpm-header)
1152       (loop repeat 33 do
1153             (insert ?\")
1154             (insert-char ?\  33)
1155             (insert "\",")
1156             (newline)
1157             finally
1158             (forward-line -1)
1159             (end-of-line)
1160             (insert "}\n"))
1161       (loop for point in stroke
1162             for x = (car-safe point)
1163             for y = (cdr-safe point) do
1164             (cond ((consp point)
1165                    ;; draw a point, and possibly a starting-point
1166                    (if (and lift-flag (not b/w-only))
1167                        ;; mark starting point with the appropriate color
1168                        (let ((char (or (car rainbow-chars) ?\.)))
1169                          (loop for i from 0 to 2 do
1170                                (loop for j from 0 to 2 do
1171                                      (goto-line (+ 16 i y))
1172                                      (forward-char (+ 1 j x))
1173                                      (delete-char 1)
1174                                      (insert char)))
1175                          (setq rainbow-chars (cdr rainbow-chars)
1176                                lift-flag nil))
1177                      ;; Otherwise, just plot the point...
1178                      (goto-line (+ 17 y))
1179                      (forward-char (+ 2 x))
1180                      (subst-char-in-region (point) (1+ (point)) ?\  ?\*)))
1181                   ((strokes-lift-p point)
1182                    ;; a lift--tell the loop to X out the next point...
1183                    (setq lift-flag t))))
1184       (when (interactive-p)
1185         (pop-to-buffer " *strokes-xpm*")
1186         ;;      (xpm-mode 1)
1187         (goto-char (point-min))
1188         (put-image (create-image (buffer-string) 'xpm t :ascent 100)
1189                    (line-end-position))))))
1190
1191 ;;; Strokes Edit stuff... ### NOT IMPLEMENTED YET ###
1192
1193 ;;(defun strokes-edit-quit ()
1194 ;;  (interactive)
1195 ;;  (or (one-window-p t 0)
1196 ;;      (delete-window))
1197 ;;  (kill-buffer "*Strokes List*"))
1198
1199 ;;(define-derived-mode edit-strokes-mode list-mode
1200 ;;  "Edit-Strokes"
1201 ;;  "Major mode for `edit-strokes' and `list-strokes' buffers.
1202
1203 ;;Editing commands:
1204
1205 ;;\\{edit-strokes-mode-map}"
1206 ;;  (setq truncate-lines nil
1207 ;;      auto-show-mode nil              ; don't want problems here either
1208 ;;      mode-popup-menu edit-strokes-menu) ; what about extent-specific stuff?
1209 ;;  (and (featurep 'menubar)
1210 ;;       current-menubar
1211 ;;       (set (make-local-variable 'current-menubar)
1212 ;;          (copy-sequence current-menubar))
1213 ;;       (add-submenu nil edit-strokes-menu)))
1214
1215 ;;(let ((map edit-strokes-mode-map))
1216 ;;  (define-key map "<" 'beginning-of-buffer)
1217 ;;  (define-key map ">" 'end-of-buffer)
1218 ;;  ;;  (define-key map "c" 'strokes-copy-other-face)
1219 ;;  ;;  (define-key map "C" 'strokes-copy-this-face)
1220 ;;  ;;  (define-key map "s" 'strokes-smaller)
1221 ;;  ;;  (define-key map "l" 'strokes-larger)
1222 ;;  ;;  (define-key map "b" 'strokes-bold)
1223 ;;  ;;  (define-key map "i" 'strokes-italic)
1224 ;;  (define-key map "e" 'strokes-list-edit)
1225 ;;  ;;  (define-key map "f" 'strokes-font)
1226 ;;  ;;  (define-key map "u" 'strokes-underline)
1227 ;;  ;;  (define-key map "t" 'strokes-truefont)
1228 ;;  ;;  (define-key map "F" 'strokes-foreground)
1229 ;;  ;;  (define-key map "B" 'strokes-background)
1230 ;;  ;;  (define-key map "D" 'strokes-doc-string)
1231 ;;  (define-key map "a" 'strokes-global-set-stroke)
1232 ;;  (define-key map "d" 'strokes-list-delete-stroke)
1233 ;;  ;;  (define-key map "n" 'strokes-list-next)
1234 ;;  ;;  (define-key map "p" 'strokes-list-prev)
1235 ;;  ;;  (define-key map " " 'strokes-list-next)
1236 ;;  ;;  (define-key map "\C-?" 'strokes-list-prev)
1237 ;;  (define-key map "g" 'strokes-list-strokes) ; refresh display
1238 ;;  (define-key map "q" 'strokes-edit-quit)
1239 ;;  (define-key map [(control c) (control c)] 'bury-buffer))
1240
1241 ;;;;;###autoload
1242 ;;(defun strokes-edit-strokes (&optional chronological strokes-map)
1243 ;;  ;; ### DEAL WITH THE 2nd ARGUMENT ISSUE! ###
1244 ;;  "Edit strokes in a pop-up buffer containing strokes and their definitions.
1245 ;;If STROKES-MAP is not given, `strokes-global-map' will be used instead.
1246
1247 ;;Editing commands:
1248
1249 ;;\\{edit-faces-mode-map}"
1250 ;;  (interactive "P")
1251 ;;  (pop-to-buffer (get-buffer-create "*Strokes List*"))
1252 ;;  (reset-buffer (current-buffer))     ; handy function from minibuf.el
1253 ;;  (setq strokes-map (or strokes-map
1254 ;;                      strokes-global-map
1255 ;;                      (progn
1256 ;;                        (strokes-load-user-strokes)
1257 ;;                        strokes-global-map)))
1258 ;;  (or chronological
1259 ;;      (setq strokes-map (sort (copy-sequence strokes-map)
1260 ;;                            'strokes-alphabetic-lessp)))
1261 ;;  ;;  (push-window-configuration)
1262 ;;  (insert
1263 ;;   "Command                                     Stroke\n"
1264 ;;   "-------                                     ------")
1265 ;;  (loop for def in strokes-map
1266 ;;      for i from 0 to (1- (length strokes-map)) do
1267 ;;      (let ((stroke (car def))
1268 ;;            (command-name (symbol-name (cdr def))))
1269 ;;        (strokes-xpm-for-stroke stroke " *strokes-xpm*")
1270 ;;        (newline 2)
1271 ;;        (insert-char ?\  45)
1272 ;;        (beginning-of-line)
1273 ;;        (insert command-name)
1274 ;;        (beginning-of-line)
1275 ;;        (forward-char 45)
1276 ;;        (set (intern (format "strokes-list-annotation-%d" i))
1277 ;;             (make-annotation (make-glyph
1278 ;;                               (list
1279 ;;                                (vector 'xpm
1280 ;;                                        :data (buffer-substring
1281 ;;                                               (point-min " *strokes-xpm*")
1282 ;;                                               (point-max " *strokes-xpm*")
1283 ;;                                               " *strokes-xpm*"))
1284 ;;                                [string :data "[Stroke]"]))
1285 ;;                              (point) 'text))
1286 ;;        (set-annotation-data (symbol-value (intern (format "strokes-list-annotation-%d" i)))
1287 ;;                             def))
1288 ;;      finally do (kill-region (1+ (point)) (point-max)))
1289 ;;  (edit-strokes-mode)
1290 ;;  (goto-char (point-min)))
1291
1292 ;;;;;###autoload
1293 ;;(defalias 'edit-strokes 'strokes-edit-strokes)
1294
1295 (eval-when-compile (defvar view-mode-map))
1296
1297 ;;;###autoload
1298 (defun strokes-list-strokes (&optional chronological strokes-map)
1299   "Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP.
1300 With CHRONOLOGICAL prefix arg \(\\[universal-argument]\) list strokes
1301 chronologically by command name.
1302 If STROKES-MAP is not given, `strokes-global-map' will be used instead."
1303   (interactive "P")
1304   (setq strokes-map (or strokes-map
1305                         strokes-global-map
1306                         (progn
1307                           (strokes-load-user-strokes)
1308                           strokes-global-map)))
1309   (if (not chronological)
1310       ;; then alphabetize the strokes based on command names...
1311       (setq strokes-map (sort (copy-sequence strokes-map)
1312                               (function strokes-alphabetic-lessp))))
1313   (let ((config (current-window-configuration)))
1314     (set-buffer (get-buffer-create "*Strokes List*"))
1315     (setq buffer-read-only nil)
1316     (erase-buffer)
1317     (insert
1318      "Command                                     Stroke\n"
1319      "-------                                     ------")
1320     (loop for def in strokes-map do
1321           (let ((stroke (car def))
1322                 (command-name (symbol-name (cdr def))))
1323             (strokes-xpm-for-stroke stroke " *strokes-xpm*")
1324             (newline 2)
1325             (insert-char ?\  45)
1326             (beginning-of-line)
1327             (insert command-name)
1328             (beginning-of-line)
1329             (forward-char 45)
1330             (insert-image (create-image (with-current-buffer " *strokes-xpm*"
1331                                           (buffer-string))
1332                                         'xpm t)))
1333           finally do (kill-region (1+ (point)) (point-max)))
1334     (view-buffer "*Strokes List*" nil)
1335     (set (make-local-variable 'view-mode-map)
1336          (let ((map (copy-keymap view-mode-map)))
1337            (define-key map "q" `(lambda ()
1338                                   (interactive)
1339                                   (View-quit)
1340                                   (set-window-configuration ,config)))
1341            map))
1342     (goto-char (point-min))))
1343
1344 (defun strokes-alphabetic-lessp (stroke1 stroke2)
1345   "T iff command name for STROKE1 is less than STROKE2's in lexicographic order."
1346   (let ((command-name-1 (symbol-name (cdr stroke1)))
1347         (command-name-2 (symbol-name (cdr stroke2))))
1348     (string-lessp command-name-1 command-name-2)))
1349
1350 (defvar strokes-mode-map
1351   (let ((map (make-sparse-keymap)))
1352     (define-key map [(shift down-mouse-2)] 'strokes-do-stroke)
1353     (define-key map [(meta down-mouse-2)] 'strokes-do-complex-stroke)
1354     map))
1355
1356 ;;;###autoload
1357 (define-minor-mode strokes-mode
1358   "Toggle Strokes global minor mode.\\<strokes-mode-map>
1359 With ARG, turn strokes on if and only if ARG is positive.
1360 Strokes are pictographic mouse gestures which invoke commands.
1361 Strokes are invoked with \\[strokes-do-stroke].  You can define
1362 new strokes with \\[strokes-global-set-stroke].  See also
1363 \\[strokes-do-complex-stroke] for `complex' strokes.
1364
1365 To use strokes for pictographic editing, such as Chinese/Japanese, use
1366 \\[strokes-compose-complex-stroke], which draws strokes and inserts them.
1367 Encode/decode your strokes with \\[strokes-encode-buffer],
1368 \\[strokes-decode-buffer].
1369
1370 \\{strokes-mode-map}"
1371   nil strokes-modeline-string strokes-mode-map
1372   :group 'strokes :global t
1373   (cond ((not (display-mouse-p))
1374          (error "Can't use Strokes without a mouse"))
1375         (strokes-mode                   ; turn on strokes
1376          (and (file-exists-p strokes-file)
1377               (null strokes-global-map)
1378               (strokes-load-user-strokes))
1379          (add-hook 'kill-emacs-query-functions
1380                    'strokes-prompt-user-save-strokes)
1381          (add-hook 'select-frame-hook
1382                    'strokes-update-window-configuration)
1383          (strokes-update-window-configuration))
1384         (t                              ; turn off strokes
1385          (if (get-buffer strokes-buffer-name)
1386              (kill-buffer (get-buffer strokes-buffer-name)))
1387          (remove-hook 'select-frame-hook
1388                       'strokes-update-window-configuration))))
1389
1390
1391 ;;;; strokes-xpm stuff (later may be separate)...
1392
1393 ;; This is the stuff that will eventually be used for composing letters in
1394 ;; any language, compression, decompression, graphics, editing, etc.
1395
1396 (defface strokes-char-face '((t (:background "lightgray")))
1397   "Face for strokes characters."
1398   :version "21.1"
1399   :group 'strokes)
1400
1401 (put 'strokes 'char-table-extra-slots 0)
1402 (defconst strokes-char-table (make-char-table 'strokes) ;
1403   "The table which stores values for the character keys.")
1404 (aset strokes-char-table ?0 0)
1405 (aset strokes-char-table ?1 1)
1406 (aset strokes-char-table ?2 2)
1407 (aset strokes-char-table ?3 3)
1408 (aset strokes-char-table ?4 4)
1409 (aset strokes-char-table ?5 5)
1410 (aset strokes-char-table ?6 6)
1411 (aset strokes-char-table ?7 7)
1412 (aset strokes-char-table ?8 8)
1413 (aset strokes-char-table ?9 9)
1414 (aset strokes-char-table ?a 10)
1415 (aset strokes-char-table ?b 11)
1416 (aset strokes-char-table ?c 12)
1417 (aset strokes-char-table ?d 13)
1418 (aset strokes-char-table ?e 14)
1419 (aset strokes-char-table ?f 15)
1420 (aset strokes-char-table ?g 16)
1421 (aset strokes-char-table ?h 17)
1422 (aset strokes-char-table ?i 18)
1423 (aset strokes-char-table ?j 19)
1424 (aset strokes-char-table ?k 20)
1425 (aset strokes-char-table ?l 21)
1426 (aset strokes-char-table ?m 22)
1427 (aset strokes-char-table ?n 23)
1428 (aset strokes-char-table ?o 24)
1429 (aset strokes-char-table ?p 25)
1430 (aset strokes-char-table ?q 26)
1431 (aset strokes-char-table ?r 27)
1432 (aset strokes-char-table ?s 28)
1433 (aset strokes-char-table ?t 29)
1434 (aset strokes-char-table ?u 30)
1435 (aset strokes-char-table ?v 31)
1436 (aset strokes-char-table ?w 32)
1437 (aset strokes-char-table ?x 33)
1438 (aset strokes-char-table ?y 34)
1439 (aset strokes-char-table ?z 35)
1440 (aset strokes-char-table ?A 36)
1441 (aset strokes-char-table ?B 37)
1442 (aset strokes-char-table ?C 38)
1443 (aset strokes-char-table ?D 39)
1444 (aset strokes-char-table ?E 40)
1445 (aset strokes-char-table ?F 41)
1446 (aset strokes-char-table ?G 42)
1447 (aset strokes-char-table ?H 43)
1448 (aset strokes-char-table ?I 44)
1449 (aset strokes-char-table ?J 45)
1450 (aset strokes-char-table ?K 46)
1451 (aset strokes-char-table ?L 47)
1452 (aset strokes-char-table ?M 48)
1453 (aset strokes-char-table ?N 49)
1454 (aset strokes-char-table ?O 50)
1455 (aset strokes-char-table ?P 51)
1456 (aset strokes-char-table ?Q 52)
1457 (aset strokes-char-table ?R 53)
1458 (aset strokes-char-table ?S 54)
1459 (aset strokes-char-table ?T 55)
1460 (aset strokes-char-table ?U 56)
1461 (aset strokes-char-table ?V 57)
1462 (aset strokes-char-table ?W 58)
1463 (aset strokes-char-table ?X 59)
1464 (aset strokes-char-table ?Y 60)
1465 (aset strokes-char-table ?Z 61)
1466
1467 (defconst strokes-base64-chars
1468   ;; I wanted to make this a vector of individual like (vector ?0
1469   ;; ?1 ?2 ...), but `concat' refuses to accept single
1470   ;; characters.
1471   (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
1472           "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
1473           "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "A" "B" "C" "D"
1474           "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S"
1475           "T" "U" "V" "W" "X" "Y" "Z")
1476 ;;  (vector [?0] [?1] [?2] [?3] [?4] [?5] [?6] [?7] [?8] [?9]
1477 ;;        [?a] [?b] [?c] [?d] [?e] [?f] [?g] [?h] [?i] [?j]
1478 ;;        [?k] [?l] [?m] [?n] [?o] [?p] [?q] [?r] [?s] [?t]
1479 ;;        [?u] [?v] [?w] [?x] [?y] [?z]
1480 ;;        [?A] [?B] [?C] [?D] [?E] [?F] [?G] [?H] [?I] [?J]
1481 ;;        [?K] [?L] [?M] [?N] [?O] [?P] [?Q] [?R] [?S] [?T]
1482 ;;        [?U] [?V] [?W] [?X] [?Y] [?Z])
1483   "Character vector for fast lookup of base-64 encoding of numbers in [0,61].")
1484
1485 (defsubst strokes-xpm-char-on-p (char)
1486   "Non-nil if CHAR represents an `on' bit in the XPM."
1487   (eq char ?*))
1488
1489 (defsubst strokes-xpm-char-bit-p (char)
1490   "Non-nil if CHAR represents an `on' or `off' bit in the XPM."
1491   (or (eq char ?\ )
1492       (eq char ?*)))
1493
1494 ;;(defsubst strokes-xor (a b)  ### Should I make this an inline function? ###
1495 ;;  "T iff one and only one of A and B is non-nil; otherwise, returns nil.
1496 ;;NOTE: Don't use this as a numeric xor since it treats all non-nil
1497 ;;      values as t including `0' (zero)."
1498 ;;  (eq (null a) (not (null b))))
1499
1500 (defsubst strokes-xpm-encode-length-as-string (length)
1501   "Given some LENGTH in [0,62) do a fast lookup of its encoding."
1502   (aref strokes-base64-chars length))
1503
1504 (defsubst strokes-xpm-decode-char (character)
1505   "Given a CHARACTER, do a fast lookup to find its corresponding integer value."
1506   (aref strokes-char-table character))
1507
1508 (defun strokes-xpm-to-compressed-string (&optional xpm-buffer)
1509   "Convert XPM in XPM-BUFFER to compressed string representing the stroke.
1510 XPM-BUFFER defaults to ` *strokes-xpm*'."
1511   (save-excursion
1512     (set-buffer (setq xpm-buffer (or xpm-buffer " *strokes-xpm*")))
1513     (goto-char (point-min))
1514     (search-forward "/* pixels */")     ; skip past header junk
1515     (forward-char 2)
1516     ;; a note for below:
1517     ;; the `current-char' is the char being counted -- NOT the char at (point)
1518     ;; which happens to be called `char-at-point'
1519     (let ((compressed-string "+/")      ; initialize the output
1520           (count 0)                     ; keep a current count of
1521                                         ; `current-char'
1522           (last-char-was-on-p t)        ; last entered stream
1523                                         ; represented `on' bits
1524           (current-char-is-on-p nil)    ; current stream represents `on' bits
1525           (char-at-point (char-after))) ; read the first char
1526       (while (not (eq char-at-point ?})) ; a `}' denotes the
1527                                         ; end of the pixmap
1528         (cond ((zerop count)            ; must restart counting
1529                ;; check to see if the `char-at-point' is an actual pixmap bit
1530                (when (strokes-xpm-char-bit-p char-at-point)
1531                  (setq count 1
1532                        current-char-is-on-p (strokes-xpm-char-on-p char-at-point)))
1533                (forward-char 1))
1534               ((= count 61)             ; maximum single char's
1535                                         ; encoding length
1536                (setq compressed-string
1537                      (concat compressed-string
1538                              ;; add a zero-length encoding when
1539                              ;; necessary
1540                              (when (eq last-char-was-on-p
1541                                        current-char-is-on-p)
1542                                ;; "0"
1543                                (strokes-xpm-encode-length-as-string 0))
1544                              (strokes-xpm-encode-length-as-string 61))
1545                      last-char-was-on-p current-char-is-on-p
1546                      count 0))          ; note that we just set
1547                                         ; count=0 and *don't* advance
1548                                         ; (point)
1549               ((strokes-xpm-char-bit-p char-at-point) ; an actual xpm bit
1550                (if (eq current-char-is-on-p
1551                        (strokes-xpm-char-on-p char-at-point))
1552                    ;; yet another of the same bit-type, so we continue
1553                    ;; counting...
1554                    (progn
1555                      (incf count)
1556                      (forward-char 1))
1557                  ;; otherwise, it's the opposite bit-type, so we do a
1558                  ;; write and then restart count ### NOTE (for myself
1559                  ;; to be aware of) ### I really should advance
1560                  ;; (point) in this case instead of letting another
1561                  ;; iteration go through and letting the case: count=0
1562                  ;; take care of this stuff for me.  That's why
1563                  ;; there's no (forward-char 1) below.
1564                  (setq compressed-string
1565                        (concat compressed-string
1566                                ;; add a zero-length encoding when
1567                                ;; necessary
1568                                (when (eq last-char-was-on-p
1569                                          current-char-is-on-p)
1570                                  ;; "0"
1571                                  (strokes-xpm-encode-length-as-string 0))
1572                                (strokes-xpm-encode-length-as-string count))
1573                        count 0
1574                        last-char-was-on-p current-char-is-on-p)))
1575               (t                        ; ELSE it's some other useless
1576                                         ; char, like `"' or `,'
1577                (forward-char 1)))
1578         (setq char-at-point (char-after)))
1579       (concat compressed-string
1580               (when (> count 0)
1581                 (concat (when (eq last-char-was-on-p
1582                                   current-char-is-on-p)
1583                           ;; "0"
1584                           (strokes-xpm-encode-length-as-string 0))
1585                         (strokes-xpm-encode-length-as-string count)))
1586               "/"))))
1587
1588 ;;;###autoload
1589 (defun strokes-decode-buffer (&optional buffer force)
1590   "Decode stroke strings in BUFFER and display their corresponding glyphs.
1591 Optional BUFFER defaults to the current buffer.
1592 Optional FORCE non-nil will ignore the buffer's read-only status."
1593   (interactive)
1594   ;;  (interactive "*bStrokify buffer: ")
1595   (save-excursion
1596     (set-buffer (setq buffer (get-buffer (or buffer (current-buffer)))))
1597     (when (or (not buffer-read-only)
1598               force
1599               inhibit-read-only
1600               (y-or-n-p
1601                (format "Buffer %s is read-only.  Strokify anyway? " buffer)))
1602       (let ((inhibit-read-only t))
1603         (message "Strokifying %s..." buffer)
1604         (goto-char (point-min))
1605         (let (ext string image)
1606           ;; The comment below is what I'd have to do if I wanted to
1607           ;; deal with random newlines in the midst of the compressed
1608           ;; strings.  If I do this, I'll also have to change
1609           ;; `strokes-xpm-to-compress-string' to deal with the newline,
1610           ;; and possibly other whitespace stuff.  YUCK!
1611           ;;      (while (re-search-forward "\\+/\\(\\w\\|\\)+/" nil t nil (get-buffer buffer))
1612           (while (with-current-buffer buffer
1613                    (when (re-search-forward "\\+/\\(\\w+\\)/" nil t nil)
1614                      (setq string (match-string 1))
1615                      (goto-char (match-end 0))
1616                      (replace-match " ")
1617                      t))
1618             (strokes-xpm-for-compressed-string string " *strokes-xpm*")
1619             (setq image (create-image (with-current-buffer " *strokes-xpm*"
1620                                         (buffer-string))
1621                                       'xpm t))
1622             (insert-image image
1623                           (propertize " "
1624                                       'type 'stroke-glyph
1625                                       'stroke-glyph image
1626                                       'data string))))
1627         (message "Strokifying %s...done" buffer)))))
1628
1629 (defun strokes-encode-buffer (&optional buffer force)
1630   "Convert the glyphs in BUFFER to their base-64 ASCII representations.
1631 Optional BUFFER defaults to the current buffer.
1632 Optional FORCE non-nil will ignore the buffer's read-only status."
1633   ;; ### NOTE !!! ### (for me)
1634   ;; For later on, you can/should make the inserted strings atomic
1635   ;; extents, so that the users have a clue that they shouldn't be
1636   ;; editing inside them.  Plus, if you make them extents, you can
1637   ;; very easily just hide the glyphs, so if you unstrokify, and the
1638   ;; restrokify, then those that already are glyphed don't need to be
1639   ;; re-calculated, etc.  It's just nicer that way.  The only things
1640   ;; to worry about is cleanup (i.e. do the glyphs get gc'd when the
1641   ;; buffer is killed?
1642   ;;  (interactive "*bUnstrokify buffer: ")
1643   (interactive)
1644   (save-excursion
1645     (set-buffer (setq buffer (or buffer (current-buffer))))
1646     (when (or (not buffer-read-only)
1647               force
1648               inhibit-read-only
1649               (y-or-n-p
1650                (format "Buffer %s is read-only.  Encode anyway? " buffer)))
1651       (message "Encoding strokes in %s..." buffer)
1652       ;;      (map-extents
1653       ;;       (lambda (ext buf)
1654       ;;         (when (eq (extent-property ext 'type) 'stroke-glyph)
1655       ;;           (goto-char (extent-start-position ext))
1656       ;;           (delete-char 1)  ; ### What the hell do I do here? ###
1657       ;;           (insert "+/" (extent-property ext 'data) "/")
1658       ;;       (delete-extent ext))))))
1659       (let ((inhibit-read-only t)
1660             (start nil)
1661             glyph)
1662         (while (or (and (bobp)
1663                         (get-text-property (point) 'type))
1664                    (setq start (next-single-property-change (point) 'type)))
1665           (when (eq 'stroke-glyph (get-text-property (point) 'type))
1666             (goto-char start)
1667             (setq start (point-marker)
1668                   glyph  (get-text-property start 'display))
1669             (insert "+/" (get-text-property (point) 'data) ?/)
1670             (delete-char 1)
1671             (add-text-properties start (point)
1672                                  (list 'type 'stroke-string
1673                                        'face 'strokes-char-face
1674                                        'stroke-glyph glyph
1675                                        'display nil))))
1676         (message "Encoding strokes in %s...done" buffer)))))
1677
1678 (defun strokes-xpm-for-compressed-string (compressed-string &optional bufname)
1679   "Convert the stroke represented by COMPRESSED-STRING into an XPM.
1680 Store XPM in buffer BUFNAME if supplied \(default is ` *strokes-xpm*'\)"
1681   (save-excursion
1682     (or bufname (setq bufname " *strokes-xpm*"))
1683     (set-buffer (get-buffer-create bufname))
1684     (erase-buffer)
1685     (insert compressed-string)
1686     (goto-char (point-min))
1687     (let ((current-char-is-on-p nil))
1688       (while (not (eobp))
1689         (insert-char
1690          (if current-char-is-on-p
1691              ?*
1692            ?\ )
1693          (strokes-xpm-decode-char (char-after)))
1694         (delete-char 1)
1695         (setq current-char-is-on-p (not current-char-is-on-p)))
1696       (goto-char (point-min))
1697       (loop repeat 33 do
1698             (insert ?\")
1699             (forward-char 33)
1700             (insert "\",\n"))
1701       (goto-char (point-min))
1702       (insert strokes-xpm-header))))
1703
1704 ;;;###autoload
1705 (defun strokes-compose-complex-stroke ()
1706   ;; ### NOTE !!! ###
1707   ;; Even though we don't have lexical scoping, it's somewhat ugly how I
1708   ;; pass around variables in the global name space.  I can/should
1709   ;; change this.
1710   "Read a complex stroke and insert its glyph into the current buffer."
1711   (interactive "*")
1712   (let ((strokes-grid-resolution 33))
1713     (strokes-read-complex-stroke)
1714     (strokes-xpm-for-stroke nil " *strokes-xpm*" t)
1715     (insert (strokes-xpm-to-compressed-string " *strokes-xpm*"))
1716     (strokes-decode-buffer)
1717     ;; strokes-decode-buffer does a save-excursion.
1718     (forward-char)))
1719
1720 (defun strokes-unload-hook ()
1721   (strokes-mode -1)
1722   (remove-hook 'kill-emacs-query-functions 'strokes-prompt-user-save-strokes))
1723
1724 (run-hooks 'strokes-load-hook)
1725 (provide 'strokes)
1726
1727 ;;; arch-tag: 8377f60e-43fb-467a-bbcd-2774f91f833e
1728 ;;; strokes.el ends here