| 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 | ;;; strokes.el ends here |