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