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