Mercurial > hg > xemacs-beta

comparison lisp/modes/strokes.el @ 177:6075d714658b r20-3b15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b15
author cvs
date Mon, 13 Aug 2007 09:51:16 +0200
parents 25f70ba0133c
children 3d6bfa290dbd
comparison
equal deleted inserted replaced
176:6866abce6aaf 177:6075d714658b
1 ;;; strokes.el Sat May 24 14:18:08 1997 1 ;;; strokes.el -- Control XEmacs through mouse strokes --
2 ;; Mon Jun 2 12:40:41 EDT 1997
2 3
3 ;; Copyright (C) 1997 Free Software Foundation, Inc. 4 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4 5
5 ;; Author: David Bakhash <cadet@mit.edu> 6 ;; Author: David Bakhash <cadet@mit.edu>
6 ;; Maintainer: David Bakhash <cadet@mit.edu> 7 ;; Maintainer: David Bakhash <cadet@mit.edu>
7 ;; Version: 2.3-beta 8 ;; Version: 2.3
8 ;; Created: 12 April 1997 9 ;; Created: 12 April 1997
9 ;; Keywords: lisp, mouse, extensions 10 ;; Keywords: lisp, mouse, extensions
10 11
11 ;; This file is part of XEmacs. 12 ;; This file is part of XEmacs.
12 13
156 ;; Japanese and Chinese are a bit trickier, but I'm sure that with help 157 ;; Japanese and Chinese are a bit trickier, but I'm sure that with help
157 ;; it can be done. The next version will allow the user to enter strokes 158 ;; it can be done. The next version will allow the user to enter strokes
158 ;; which "remove the pencil from the paper" so to speak, so one character 159 ;; which "remove the pencil from the paper" so to speak, so one character
159 ;; can have multiple strokes. 160 ;; can have multiple strokes.
160 161
162 ;; You can read more about strokes at:
163
164 ;; http://www.mit.edu/people/cadet/strokes-help.html
165
166 ;; If you're interested in using strokes for writing English into XEmacs
167 ;; using strokes, then you'll want to read about it on the web page above
168 ;; or just download from http://www.mit.edu/people/cadet/strokes-abc.el,
169 ;; which is nothing but a file with some helper commands for inserting
170 ;; alphanumerics and punctuation.
171
161 ;; Great thanks to Rob Ristroph for his generosity in letting me use his 172 ;; Great thanks to Rob Ristroph for his generosity in letting me use his
162 ;; PC to develop this, Jason Johnson for his help in algorithms, Euna 173 ;; PC to develop this, Jason Johnson for his help in algorithms, Euna
163 ;; Kim for her help in Korean, and massive thanks to the helpful guys 174 ;; Kim for her help in Korean, and massive thanks to the helpful guys
164 ;; on the help instance on athena (zeno, jered, amu, gsstark, ghudson, etc) 175 ;; on the help instance on athena (zeno, jered, amu, gsstark, ghudson, etc)
165 ;; Special thanks to Steve Baur and Hrvoje Niksic for all their help. 176 ;; Special thanks to Steve Baur and Hrvoje Niksic for all their help.
177 ;; And even more thanks to Dave Gillespie for all the elisp help--he
178 ;; is responsible for helping me use the cl macros at (near) max speed.
166 179
167 ;; Tasks: (what I'm getting ready for future version)... 180 ;; Tasks: (what I'm getting ready for future version)...
168 ;; 2) use 'strokes-read-complex-stroke for korean, etc. 181 ;; 2) use 'strokes-read-complex-stroke for korean, etc.
169 ;; 4) buffer-local 'strokes-local-map, and mode-stroke-maps would be nice 182 ;; 4) buffer-local 'strokes-local-map, and mode-stroke-maps would be nice
170 ;; 5) 'list-strokes (kinda important). What do people want? 183 ;; 5) 'list-strokes (kinda important). What do people want?
251 264
252 ;;; Requirements and provisions... 265 ;;; Requirements and provisions...
253 266
254 (autoload 'reporter-submit-bug-report "reporter") 267 (autoload 'reporter-submit-bug-report "reporter")
255 (autoload 'mail-position-on-field "sendmail") 268 (autoload 'mail-position-on-field "sendmail")
269 (eval-when-compile
270 (mapc 'require '(xpm-mode pp annotations reporter advice)))
256 271
257 ;;; Constants... 272 ;;; Constants...
258 273
259 (defconst strokes-version "2.3-beta") 274 (defconst strokes-version "2.3")
260 275
261 (defconst strokes-bug-address "cadet@mit.edu") 276 (defconst strokes-bug-address "cadet@mit.edu")
262 277
263 (defconst strokes-lift :strokes-lift 278 (defconst strokes-lift :strokes-lift
264 "Symbol representing a stroke lift event for complex strokes. 279 "Symbol representing a stroke lift event for complex strokes.
265 Complex strokes are those which contain two or more simple strokes. 280 Complex strokes are those which contain two or more simple strokes.
266 This will be useful for when XEmacs understands Chinese.") 281 This will be useful for when XEmacs understands Chinese.")
282
283 (defconst strokes-xpm-header "/* XPM */
284 static char * stroke_xpm[] = {
285 /* width height ncolors cpp [x_hot y_hot] */
286 \"33 33 9 1 26 23\",
287 /* colors */
288 \" c #D9D9D9D9D9D9\",
289 \"* s iconColor1 m black c black\",
290 \"R c #FFFF00000000\",
291 \"O c #FFFF80000000\",
292 \"Y c #FFFFFFFF0000\",
293 \"G c #0000FFFF0000\",
294 \"B c #00000000FFFF\",
295 \"P c #FFFF0000FFFF\",
296 \". c #45458B8B0000\",
297 /* pixels */\n"
298 "The header to all xpm buffers created by strokes")
267 299
268 ;;; user variables... 300 ;;; user variables...
269 301
270 (defgroup strokes nil 302 (defgroup strokes nil
271 "Control Emacs through mouse strokes" 303 "Control Emacs through mouse strokes"
362 normalized stroke grid, with the top left at (0 . 0). COMMAND is the 394 normalized stroke grid, with the top left at (0 . 0). COMMAND is the
363 corresponding interactive function") 395 corresponding interactive function")
364 396
365 (defvar strokes-load-hook nil 397 (defvar strokes-load-hook nil
366 "Function or functions to be called when `strokes' is loaded.") 398 "Function or functions to be called when `strokes' is loaded.")
399
400 (defvar edit-strokes-menu
401 '("Edit-Strokes"
402 ["Add stroke..." strokes-global-set-stroke t]
403 ["Delete stroke..." strokes-edit-delete-stroke t]
404 ["Change stroke" strokes-smaller t]
405 ["Change definition" strokes-larger t]
406 ["[Re]List Strokes chronologically" strokes-list-strokes t]
407 ["[Re]List Strokes alphabetically" strokes-list-strokes t]
408 ["Quit" strokes-edit-quit t]
409 ))
367 410
368 ;;; Macros... 411 ;;; Macros...
369 412
370 (defsubst strokes-click-p (stroke) 413 (defsubst strokes-click-p (stroke)
371 "Non-nil if STROKE is really click." 414 "Non-nil if STROKE is really click."
480 (strokes-fix-button2-command 'dired-g-x-mouse-toggle) 523 (strokes-fix-button2-command 'dired-g-x-mouse-toggle)
481 (strokes-fix-button2-command 'dired-o-r-mouse-toggle) 524 (strokes-fix-button2-command 'dired-o-r-mouse-toggle)
482 (strokes-fix-button2-command 'dired-o-w-mouse-toggle) 525 (strokes-fix-button2-command 'dired-o-w-mouse-toggle)
483 (strokes-fix-button2-command 'isearch-yank-x-selection) 526 (strokes-fix-button2-command 'isearch-yank-x-selection)
484 (strokes-fix-button2-command 'occur-mode-mouse-goto) 527 (strokes-fix-button2-command 'occur-mode-mouse-goto)
528 (strokes-fix-button2-command 'cvs-mouse-find-file)
485 529
486 ;;; I can fix the customize widget button click, but then 530 ;;; I can fix the customize widget button click, but then
487 ;;; people will get confused when they try to customize 531 ;;; people will get confused when they try to customize
488 ;;; strokes with the mouse and customize tells them that 532 ;;; strokes with the mouse and customize tells them that
489 ;;; `strokes-click-command' is mapped to `ad-Orig-widget-button-click' 533 ;;; `strokes-click-command' is mapped to `ad-Orig-widget-button-click'
635 679
636 (defun strokes-eliminate-consecutive-redundancies (entries) 680 (defun strokes-eliminate-consecutive-redundancies (entries)
637 "Returns a list with no consecutive redundant entries." 681 "Returns a list with no consecutive redundant entries."
638 ;; defun a grande vitesse grace a Dave G. 682 ;; defun a grande vitesse grace a Dave G.
639 (loop for element on entries 683 (loop for element on entries
640 if (not (equal (car element) (cadr element))) 684 if (not (equal (car element) (cadr element)))
641 collect (car element))) 685 collect (car element)))
642 ;; (loop for element on entries 686 ;; (loop for element on entries
643 ;; nconc (if (not (equal (car el) (cadr el))) 687 ;; nconc (if (not (equal (car el) (cadr el)))
644 ;; (list (car el))))) 688 ;; (list (car el)))))
645 ;; yet another (orig) way of doing it... 689 ;; yet another (orig) way of doing it...
646 ;; (if entries 690 ;; (if entries
647 ;; (let* ((current (car entries)) 691 ;; (let* ((current (car entries))
648 ;; (rest (cdr entries)) 692 ;; (rest (cdr entries))
661 (defun strokes-renormalize-to-grid (positions &optional grid-resolution) 705 (defun strokes-renormalize-to-grid (positions &optional grid-resolution)
662 "Map POSITIONS to a new grid whose dimensions are based on GRID-RESOLUTION. 706 "Map POSITIONS to a new grid whose dimensions are based on GRID-RESOLUTION.
663 POSITIONS is a list of positions and stroke-lifts. 707 POSITIONS is a list of positions and stroke-lifts.
664 Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION. 708 Optional GRID-RESOLUTION may be used in place of STROKES-GRID-RESOLUTION.
665 The grid is a square whose dimesion is [0,GRID-RESOLUTION)." 709 The grid is a square whose dimesion is [0,GRID-RESOLUTION)."
710 (or grid-resolution (setq grid-resolution strokes-grid-resolution))
666 (let ((stroke-extent (strokes-get-stroke-extent positions))) 711 (let ((stroke-extent (strokes-get-stroke-extent positions)))
667 (mapcar (function 712 (mapcar (function
668 (lambda (pos) 713 (lambda (pos)
669 (strokes-get-grid-position stroke-extent pos grid-resolution))) 714 (strokes-get-grid-position stroke-extent pos grid-resolution)))
670 positions))) 715 positions)))
853 (if (mouse-event-p event) 898 (if (mouse-event-p event)
854 (let ((point (event-closest-point event))) 899 (let ((point (event-closest-point event)))
855 (when point 900 (when point
856 (goto-char point) 901 (goto-char point)
857 (subst-char-in-region point (1+ point) ?\ strokes-character)) 902 (subst-char-in-region point (1+ point) ?\ strokes-character))
858 (setq pix-locs (cons (cons (event-x-pixel event) 903 (push (cons (event-x-pixel event)
859 (event-y-pixel event)) 904 (event-y-pixel event))
860 pix-locs)))) 905 pix-locs)))
861 (setq event (next-event event)))) 906 (setq event (next-event event))))
862 ;; protected 907 ;; protected
863 ;; clean up strokes buffer and then bury it. 908 ;; clean up strokes buffer and then bury it.
864 (subst-char-in-region (point-min) (point-max) strokes-character ?\ ) 909 (when (equal (buffer-name) strokes-buffer-name)
865 (goto-char (point-min)) 910 (subst-char-in-region (point-min) (point-max) strokes-character ?\ )
866 (bury-buffer))) 911 (goto-char (point-min))
912 (bury-buffer))))
867 ;; Otherwise, don't use strokes buffer and read stroke silently 913 ;; Otherwise, don't use strokes buffer and read stroke silently
868 (if prompt 914 (if prompt
869 (progn 915 (progn
870 (setq event (next-event event prompt)) 916 (setq event (next-event event prompt))
871 (while (not (button-press-event-p event)) 917 (while (not (button-press-event-p event))
872 (dispatch-event event) 918 (dispatch-event event)
873 (setq event (next-event event))))) 919 (setq event (next-event event)))))
874 (setq event (next-event)) 920 (setq event (next-event))
875 (while (not (button-release-event-p event)) 921 (while (not (button-release-event-p event))
876 (if (mouse-event-p event) 922 (if (mouse-event-p event)
877 (setq pix-locs (cons (cons (event-x-pixel event) 923 (push (cons (event-x-pixel event)
878 (event-y-pixel event)) 924 (event-y-pixel event))
879 pix-locs))) 925 pix-locs))
880 (setq event (next-event event)))) 926 (setq event (next-event event))))
881 (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs))) 927 (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs)))
882 (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs))))) 928 (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs)))))
883 929
884 ;;;###autoload 930 ;;;###autoload
899 (while (not (button-press-event-p event)) 945 (while (not (button-press-event-p event))
900 (dispatch-event event) 946 (dispatch-event event)
901 (setq event (next-event event)))) 947 (setq event (next-event event))))
902 (unwind-protect 948 (unwind-protect
903 (progn 949 (progn
950 (setq event (next-event event prompt))
904 (while (not (and (button-press-event-p event) 951 (while (not (and (button-press-event-p event)
905 (eq (event-button event) 3))) 952 (eq (event-button event) 3)))
906 (while (not (button-release-event-p event)) 953 (while (not (button-release-event-p event))
907 (if (mouse-event-p event) 954 (if (mouse-event-p event)
908 (let ((point (event-closest-point event))) 955 (let ((point (event-closest-point event)))
909 (when point 956 (when point
910 (goto-char point) 957 (goto-char point)
911 (subst-char-in-region point (1+ point) ?\ strokes-character)) 958 (subst-char-in-region point (1+ point) ?\ strokes-character))
912 (setq pix-locs (cons (cons (event-x-pixel event) 959 (push (cons (event-x-pixel event)
913 (event-y-pixel event)) 960 (event-y-pixel event))
914 pix-locs)))) 961 pix-locs)))
915 (setq event (next-event event prompt))) 962 (setq event (next-event event prompt)))
916 (setq pix-locs (cons strokes-lift pix-locs)) 963 (push strokes-lift pix-locs)
917 (while (not (button-press-event-p event)) 964 (while (not (button-press-event-p event))
918 (dispatch-event event) 965 (dispatch-event event)
919 (setq event (next-event event prompt)))) 966 (setq event (next-event event prompt))))
920 (setq pix-locs (nreverse (cdr pix-locs)) 967 (setq pix-locs (nreverse (cdr pix-locs))
921 grid-locs (strokes-renormalize-to-grid pix-locs)) 968 grid-locs (strokes-renormalize-to-grid pix-locs))
922 (strokes-fill-stroke 969 (strokes-fill-stroke
923 (strokes-eliminate-consecutive-redundancies grid-locs))) 970 (strokes-eliminate-consecutive-redundancies grid-locs)))
924 ;; protected 971 ;; protected
925 (subst-char-in-region (point-min) (point-max) strokes-character ?\ ) 972 (when (equal (buffer-name) strokes-buffer-name)
926 (goto-char (point-min)) 973 (subst-char-in-region (point-min) (point-max) strokes-character ?\ )
927 (bury-buffer)))))) 974 (goto-char (point-min))
975 (bury-buffer)))))))
928 976
929 (defun strokes-execute-stroke (stroke) 977 (defun strokes-execute-stroke (stroke)
930 "Given STROKE, execute the command which corresponds to it. 978 "Given STROKE, execute the command which corresponds to it.
931 The command will be executed provided one exists for that stroke, 979 The command will be executed provided one exists for that stroke,
932 based on the variable `strokes-minimum-match-score'. 980 based on the variable `strokes-minimum-match-score'.
1076 You can always get an idea of what your current strokes look like with 1124 You can always get an idea of what your current strokes look like with
1077 the command 1125 the command
1078 1126
1079 > M-x list-strokes 1127 > M-x list-strokes
1080 1128
1081 Your strokes will be displayed in from most recent down, and the 1129 Your strokes will be displayed in alphabetical order (based on command
1082 beginning of each simple stroke will be marked by a color dot. Since 1130 names) and the beginning of each simple stroke will be marked by a
1083 you may have several simple strokes in a complex stroke, the dot 1131 color dot. Since you may have several simple strokes in a complex
1084 colors are arranged in the rainbow color sequence, `ROYGBIV'. 1132 stroke, the dot colors are arranged in the rainbow color sequence,
1133 `ROYGBIV'. If you want a listing of your strokes from most recent
1134 down, then use a prefix argument:
1135
1136 > C-u M-x list-strokes
1085 1137
1086 Your strokes are stored as you enter them. They get saved in a file 1138 Your strokes are stored as you enter them. They get saved in a file
1087 called ~/.strokes, along with other strokes configuration variables. 1139 called ~/.strokes, along with other strokes configuration variables.
1088 You can change this location by setting the variable `strokes-file'. 1140 You can change this location by setting the variable `strokes-file'.
1089 You will be prompted to save them when you exit XEmacs, or you can save 1141 You will be prompted to save them when you exit XEmacs, or you can save
1156 (insert " " strokes-version " bug:"))))))))) 1208 (insert " " strokes-version " bug:")))))))))
1157 1209
1158 (defsubst strokes-fill-current-buffer-with-whitespace () 1210 (defsubst strokes-fill-current-buffer-with-whitespace ()
1159 "Erase the contents of the current buffer and fill it with whitespace" 1211 "Erase the contents of the current buffer and fill it with whitespace"
1160 (erase-buffer) 1212 (erase-buffer)
1161 (loop for i from 1 to (frame-height) do 1213 (loop repeat (frame-height) do
1162 (progn 1214 (insert-char ?\ (1- (frame-width)))
1163 (insert-char ?\ (1- (frame-width))) 1215 (newline))
1164 (newline)))
1165 (goto-char (point-min))) 1216 (goto-char (point-min)))
1166 1217
1167 (defun strokes-update-window-configuration () 1218 (defun strokes-update-window-configuration ()
1168 "Insure that `strokes-window-configuration' is up-to-date." 1219 "Insure that `strokes-window-configuration' is up-to-date."
1169 (interactive) 1220 (interactive)
1266 (interactive "P") 1317 (interactive "P")
1267 (setq strokes-use-strokes-buffer 1318 (setq strokes-use-strokes-buffer
1268 (if arg (> (prefix-numeric-value arg) 0) 1319 (if arg (> (prefix-numeric-value arg) 0)
1269 (not strokes-use-strokes-buffer)))) 1320 (not strokes-use-strokes-buffer))))
1270 1321
1271 (defun strokes-xpm-for-stroke (stroke &optional bufname) 1322 (defun strokes-xpm-for-stroke (&optional stroke bufname b/w-only)
1272 "Create an xpm pixmap for the given stroke in buffer `*strokes-xpm*'. 1323 "Create an xpm pixmap for the given STROKE in buffer `*strokes-xpm*'.
1324 If STROKE is not supplied, then `strokes-last-stroke' will be used.
1273 Optional BUFNAME to name something else. 1325 Optional BUFNAME to name something else.
1274 The pixmap will contain time information via rainbow dot colors 1326 The pixmap will contain time information via rainbow dot colors
1275 where each individual strokes begins." 1327 where each individual strokes begins.
1328 Optional B/W-ONLY non-nil will create a mono pixmap, not intended
1329 for trying to figure out the order of strokes, but rather for reading
1330 the stroke as a character in some language."
1331 (interactive)
1276 (save-excursion 1332 (save-excursion
1277 (let ((buf (get-buffer-create (or bufname "*strokes-xpm*"))) 1333 (let ((buf (get-buffer-create (or bufname "*strokes-xpm*")))
1278 (stroke (strokes-eliminate-consecutive-redundancies 1334 (stroke (strokes-eliminate-consecutive-redundancies
1279 (strokes-fill-stroke 1335 (strokes-fill-stroke
1280 (strokes-renormalize-to-grid stroke 31)))) 1336 (strokes-renormalize-to-grid (or stroke
1337 strokes-last-stroke)
1338 31))))
1281 (lift-flag t) 1339 (lift-flag t)
1282 (rainbow-chars (list ?R ?O ?Y ?G ?B ?P)) ; ROYGBIV w/o indigo 1340 (rainbow-chars (list ?R ?O ?Y ?G ?B ?P))) ; ROYGBIV w/o indigo
1283 (header (format "/* XPM */
1284 static char * stroke_xpm[] = {
1285 /* width height ncolors cpp [x_hot y_hot] */
1286 \"33 33 9 1 26 23\",
1287 /* colors */
1288 \" c #FFFFFFFFFFFF\",
1289 \"* s iconColor1 m black c black\",
1290 \"R c #FFFF00000000\",
1291 \"O c #FFFF80000000\",
1292 \"Y c #FFFFFFFF0000\",
1293 \"G c #0000FFFF0000\",
1294 \"B c #00000000FFFF\",
1295 \"P c #FFFF0000FFFF\",
1296 \". c #45458B8B0000\",
1297 /* pixels */")))
1298 (set-buffer buf) 1341 (set-buffer buf)
1299 (erase-buffer) 1342 (erase-buffer)
1300 (insert header) 1343 (insert strokes-xpm-header)
1301 (loop repeat 33 do 1344 (loop repeat 33 do
1302 (newline)
1303 (insert-char ?\") 1345 (insert-char ?\")
1304 (insert-char ?\ 33) 1346 (insert-char ?\ 33)
1305 (insert "\",") 1347 (insert "\",")
1306 finally (insert "}\n")) 1348 (newline)
1349 finally
1350 (forward-line -1)
1351 (end-of-line)
1352 (insert "}\n"))
1307 (loop for point in stroke 1353 (loop for point in stroke
1308 for x = (car-safe point) 1354 for x = (car-safe point)
1309 for y = (cdr-safe point) do 1355 for y = (cdr-safe point) do
1310 (cond ((consp point) 1356 (cond ((consp point)
1311 ;; draw a point, and possibly a starting-point 1357 ;; draw a point, and possibly a starting-point
1312 (if lift-flag 1358 (if (and lift-flag (not b/w-only))
1313 ;; mark starting point with the appropriate color 1359 ;; mark starting point with the appropriate color
1314 (let ((char (or (car rainbow-chars) ?\.))) 1360 (let ((char (or (car rainbow-chars) ?\.)))
1315 (loop for i from 0 to 2 do 1361 (loop for i from 0 to 2 do
1316 (loop for j from 0 to 2 do 1362 (loop for j from 0 to 2 do
1317 (goto-line (+ 16 i y)) 1363 (goto-line (+ 16 i y))
1324 (goto-line (+ 17 y)) 1370 (goto-line (+ 17 y))
1325 (forward-char (+ 2 x)) 1371 (forward-char (+ 2 x))
1326 (subst-char-in-region (point) (1+ (point)) ?\ ?\*))) 1372 (subst-char-in-region (point) (1+ (point)) ?\ ?\*)))
1327 ((strokes-lift-p point) 1373 ((strokes-lift-p point)
1328 ;; a lift--tell the loop to X out the next point... 1374 ;; a lift--tell the loop to X out the next point...
1329 (setq lift-flag t))))))) 1375 (setq lift-flag t))))
1376 (when (interactive-p)
1377 (require 'xpm-mode)
1378 (pop-to-buffer "*strokes-xpm*")
1379 ;; (xpm-mode 1)
1380 (xpm-show-image)
1381 (goto-char (point-min))))))
1382
1383 ;;; Strokes Edit stuff...
1384
1385 (defun strokes-edit-quit ()
1386 (interactive)
1387 (or (one-window-p t 0)
1388 (delete-window))
1389 (kill-buffer "*Strokes List*"))
1390
1391 (define-derived-mode edit-strokes-mode list-mode
1392 "Edit-Strokes"
1393 "Major mode for `edit-strokes' and `list-strokes' buffers.
1394
1395 Editing commands:
1396
1397 \\{edit-strokes-mode-map}"
1398 (setq truncate-lines nil
1399 auto-show-mode nil ; don't want problems here either
1400 mode-popup-menu edit-strokes-menu) ; what about extent-specific stuff?
1401 (and (featurep 'menubar)
1402 current-menubar
1403 (set (make-local-variable 'current-menubar)
1404 (copy-sequence current-menubar))
1405 (add-submenu nil edit-strokes-menu)))
1406
1407 (let ((map edit-strokes-mode-map))
1408 (define-key map "<" 'beginning-of-buffer)
1409 (define-key map ">" 'end-of-buffer)
1410 ;; (define-key map "c" 'strokes-copy-other-face)
1411 ;; (define-key map "C" 'strokes-copy-this-face)
1412 ;; (define-key map "s" 'strokes-smaller)
1413 ;; (define-key map "l" 'strokes-larger)
1414 ;; (define-key map "b" 'strokes-bold)
1415 ;; (define-key map "i" 'strokes-italic)
1416 (define-key map "e" 'strokes-list-edit)
1417 ;; (define-key map "f" 'strokes-font)
1418 ;; (define-key map "u" 'strokes-underline)
1419 ;; (define-key map "t" 'strokes-truefont)
1420 ;; (define-key map "F" 'strokes-foreground)
1421 ;; (define-key map "B" 'strokes-background)
1422 ;; (define-key map "D" 'strokes-doc-string)
1423 (define-key map "a" 'strokes-global-set-stroke)
1424 (define-key map "d" 'strokes-list-delete-stroke)
1425 ;; (define-key map "n" 'strokes-list-next)
1426 ;; (define-key map "p" 'strokes-list-prev)
1427 ;; (define-key map " " 'strokes-list-next)
1428 ;; (define-key map "\C-?" 'strokes-list-prev)
1429 (define-key map "g" 'strokes-list-strokes) ; refresh display
1430 (define-key map "q" 'strokes-edit-quit)
1431 (define-key map [(control c) (control c)] 'bury-buffer))
1330 1432
1331 ;;;###autoload 1433 ;;;###autoload
1332 (defun strokes-list-strokes (&optional stroke-map) 1434 (defun strokes-edit-strokes (&optional chronological strokes-map)
1333 "Pop up a buffer containing a listing of all strokes defined in STROKE-MAP. 1435 ;; ### DEAL WITH THE 2nd ARGUMENT ISSUE! ###
1334 If STROKE-MAP is not given, `strokes-global-map' will be used instead." 1436 "Edit strokes in a pop-up buffer containing strokes and their definitions.
1335 (interactive) 1437 If STROKES-MAP is not given, `strokes-global-map' will be used instead.
1438
1439 Editing commands:
1440
1441 \\{edit-faces-mode-map}"
1442 (interactive "P")
1443 (pop-to-buffer (get-buffer-create "*Strokes List*"))
1444 (reset-buffer (current-buffer)) ; handy function from minibuf.el
1445 (setq strokes-map (or strokes-map
1446 strokes-global-map
1447 (progn
1448 (strokes-load-user-strokes)
1449 strokes-global-map)))
1450 (or chronological
1451 (setq strokes-map (sort (copy-sequence strokes-map)
1452 'strokes-alphabetic-lessp)))
1453 ;; (push-window-configuration)
1454 (insert
1455 "Command Stroke\n"
1456 "------- ------")
1457 (loop for def in strokes-map
1458 for i from 0 to (1- (length strokes-map)) do
1459 (let ((stroke (car def))
1460 (command-name (symbol-name (cdr def))))
1461 (strokes-xpm-for-stroke stroke " *strokes-xpm*")
1462 (newline 2)
1463 (insert-char ?\ 45)
1464 (beginning-of-line)
1465 (insert command-name)
1466 (beginning-of-line)
1467 (forward-char 45)
1468 (set (intern (format "strokes-list-annotation-%d" i))
1469 (make-annotation (make-glyph
1470 (list
1471 (vector 'xpm
1472 :data (buffer-substring
1473 (point-min " *strokes-xpm*")
1474 (point-max " *strokes-xpm*")
1475 " *strokes-xpm*"))
1476 [string :data "[Stroke]"]))
1477 (point) 'text))
1478 (set-annotation-data (symbol-value (intern (format "strokes-list-annotation-%d" i)))
1479 def))
1480 finally do (kill-region (1+ (point)) (point-max)))
1481 (edit-strokes-mode)
1482 (goto-char (point-min)))
1483
1484 ;;;###autoload
1485 (defalias 'edit-strokes 'strokes-edit-strokes)
1486
1487 ;;;###autoload
1488 (defun strokes-list-strokes (&optional chronological strokes-map)
1489 "Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP.
1490 With CHRONOLOGICAL prefix arg \(\\[universal-argument]\) list strokes
1491 chronologically by command name.
1492 If STROKES-MAP is not given, `strokes-global-map' will be used instead."
1493 (interactive "P")
1494 (setq strokes-map (or strokes-map
1495 strokes-global-map
1496 (progn
1497 (strokes-load-user-strokes)
1498 strokes-global-map)))
1499 (if (not chronological)
1500 ;; then alphabetize the strokes based on command names...
1501 (setq strokes-map (sort (copy-sequence strokes-map)
1502 'strokes-alphabetic-lessp)))
1336 (push-window-configuration) 1503 (push-window-configuration)
1337 (set-buffer (get-buffer-create "*Strokes List*")) 1504 (set-buffer (get-buffer-create "*Strokes List*"))
1338 (setq buffer-read-only nil) 1505 (setq buffer-read-only nil)
1339 (erase-buffer) 1506 (erase-buffer)
1340 (insert 1507 (insert
1341 "Command Stroke\n" 1508 "Command Stroke\n"
1342 "------- ------\n\n") 1509 "------- ------")
1343 (loop for def in (or stroke-map strokes-global-map) do 1510 (loop for def in strokes-map do
1344 (let ((stroke (car def)) 1511 (let ((stroke (car def))
1345 (command (cdr def))) 1512 (command-name (symbol-name (cdr def))))
1346 (strokes-xpm-for-stroke stroke " *strokes-xpm*") 1513 (strokes-xpm-for-stroke stroke " *strokes-xpm*")
1347 (insert-char ?\ 60) 1514 (newline 2)
1515 (insert-char ?\ 45)
1348 (beginning-of-line) 1516 (beginning-of-line)
1349 (insert (symbol-name command)) 1517 (insert command-name)
1350 (beginning-of-line) 1518 (beginning-of-line)
1351 (forward-char 45) 1519 (forward-char 45)
1352 (make-annotation (make-glyph 1520 (make-annotation (make-glyph
1353 (list 1521 (list
1354 (vector 'xpm 1522 (vector 'xpm
1355 :data (buffer-substring 1523 :data (buffer-substring
1356 (point-min " *strokes-xpm*") 1524 (point-min " *strokes-xpm*")
1357 (point-max " *strokes-xpm*") 1525 (point-max " *strokes-xpm*")
1358 " *strokes-xpm*")) 1526 " *strokes-xpm*"))
1359 [string :data "[Image]"])) 1527 [string :data "[Image]"]))
1360 (point) 'text) 1528 (point) 'text))
1361 (newline 2))) 1529 finally do (kill-region (1+ (point)) (point-max)))
1362 (view-buffer "*Strokes List*" t) 1530 (view-buffer "*Strokes List*" t)
1363 (goto-char (point-min)) 1531 (goto-char (point-min))
1364 ;; (define-key 1532 (define-key view-minor-mode-map [(q)] (lambda ()
1365 ;; (current-local-map (get-buffer "*Strokes List*")) 1533 (interactive)
1366 ;; [(q)] 1534 (view-quit)
1367 ;; 'pop-window-configuration)) 1535 (pop-window-configuration)
1368 ) 1536 ;; (bury-buffer "*Strokes List*")
1537 (define-key view-minor-mode-map [(q)] 'view-quit))))
1538
1539 (defun strokes-alphabetic-lessp (stroke1 stroke2)
1540 "T iff command name for STROKE1 is less than STROKE2's in lexicographic order."
1541 (let ((command-name-1 (symbol-name (cdr stroke1)))
1542 (command-name-2 (symbol-name (cdr stroke2))))
1543 (string-lessp command-name-1 command-name-2)))
1369 1544
1370 ;;;###autoload 1545 ;;;###autoload
1371 (defalias 'list-strokes 'strokes-list-strokes) 1546 (defalias 'list-strokes 'strokes-list-strokes)
1372 1547
1373 ;;;###autoload 1548 ;;;###autoload
1416 (setq strokes-mode nil)))) 1591 (setq strokes-mode nil))))
1417 (redraw-modeline)) 1592 (redraw-modeline))
1418 1593
1419 (add-minor-mode 'strokes-mode strokes-modeline-string nil nil 'strokes-mode) 1594 (add-minor-mode 'strokes-mode strokes-modeline-string nil nil 'strokes-mode)
1420 1595
1596 (unless (find-face 'strokes-char-face)
1597 (copy-face 'default 'strokes-char-face)
1598 (set-face-background 'strokes-char-face "lightgray"))
1599
1600 (defconst strokes-char-value-hashtable (make-hashtable 62) ;
1601 ; (make-char-table
1602 ; 'syntax)
1603 ; in 20.*
1604 ;; ### This will become a char-table for XEmacs-20 !!! ###
1605 "The table which stores values for the character keys.")
1606 (puthash ?0 0 strokes-char-value-hashtable) ; (put-char-table ?0 0
1607 ; strokes-value-chartable)
1608 ; in 20.*
1609 (puthash ?1 1 strokes-char-value-hashtable)
1610 (puthash ?2 2 strokes-char-value-hashtable)
1611 (puthash ?3 3 strokes-char-value-hashtable)
1612 (puthash ?4 4 strokes-char-value-hashtable)
1613 (puthash ?5 5 strokes-char-value-hashtable)
1614 (puthash ?6 6 strokes-char-value-hashtable)
1615 (puthash ?7 7 strokes-char-value-hashtable)
1616 (puthash ?8 8 strokes-char-value-hashtable)
1617 (puthash ?9 9 strokes-char-value-hashtable)
1618 (puthash ?a 10 strokes-char-value-hashtable)
1619 (puthash ?b 11 strokes-char-value-hashtable)
1620 (puthash ?c 12 strokes-char-value-hashtable)
1621 (puthash ?d 13 strokes-char-value-hashtable)
1622 (puthash ?e 14 strokes-char-value-hashtable)
1623 (puthash ?f 15 strokes-char-value-hashtable)
1624 (puthash ?g 16 strokes-char-value-hashtable)
1625 (puthash ?h 17 strokes-char-value-hashtable)
1626 (puthash ?i 18 strokes-char-value-hashtable)
1627 (puthash ?j 19 strokes-char-value-hashtable)
1628 (puthash ?k 20 strokes-char-value-hashtable)
1629 (puthash ?l 21 strokes-char-value-hashtable)
1630 (puthash ?m 22 strokes-char-value-hashtable)
1631 (puthash ?n 23 strokes-char-value-hashtable)
1632 (puthash ?o 24 strokes-char-value-hashtable)
1633 (puthash ?p 25 strokes-char-value-hashtable)
1634 (puthash ?q 26 strokes-char-value-hashtable)
1635 (puthash ?r 27 strokes-char-value-hashtable)
1636 (puthash ?s 28 strokes-char-value-hashtable)
1637 (puthash ?t 29 strokes-char-value-hashtable)
1638 (puthash ?u 30 strokes-char-value-hashtable)
1639 (puthash ?v 31 strokes-char-value-hashtable)
1640 (puthash ?w 32 strokes-char-value-hashtable)
1641 (puthash ?x 33 strokes-char-value-hashtable)
1642 (puthash ?y 34 strokes-char-value-hashtable)
1643 (puthash ?z 35 strokes-char-value-hashtable)
1644 (puthash ?A 36 strokes-char-value-hashtable)
1645 (puthash ?B 37 strokes-char-value-hashtable)
1646 (puthash ?C 38 strokes-char-value-hashtable)
1647 (puthash ?D 39 strokes-char-value-hashtable)
1648 (puthash ?E 40 strokes-char-value-hashtable)
1649 (puthash ?F 41 strokes-char-value-hashtable)
1650 (puthash ?G 42 strokes-char-value-hashtable)
1651 (puthash ?H 43 strokes-char-value-hashtable)
1652 (puthash ?I 44 strokes-char-value-hashtable)
1653 (puthash ?J 45 strokes-char-value-hashtable)
1654 (puthash ?K 46 strokes-char-value-hashtable)
1655 (puthash ?L 47 strokes-char-value-hashtable)
1656 (puthash ?M 48 strokes-char-value-hashtable)
1657 (puthash ?N 49 strokes-char-value-hashtable)
1658 (puthash ?O 50 strokes-char-value-hashtable)
1659 (puthash ?P 51 strokes-char-value-hashtable)
1660 (puthash ?Q 52 strokes-char-value-hashtable)
1661 (puthash ?R 53 strokes-char-value-hashtable)
1662 (puthash ?S 54 strokes-char-value-hashtable)
1663 (puthash ?T 55 strokes-char-value-hashtable)
1664 (puthash ?U 56 strokes-char-value-hashtable)
1665 (puthash ?V 57 strokes-char-value-hashtable)
1666 (puthash ?W 58 strokes-char-value-hashtable)
1667 (puthash ?X 59 strokes-char-value-hashtable)
1668 (puthash ?Y 60 strokes-char-value-hashtable)
1669 (puthash ?Z 61 strokes-char-value-hashtable)
1670
1671 (defconst strokes-base64-chars
1672 ;; I can easily have made this a vector of single-character strings,
1673 ;; like (vector "0" "1" "2" ...), and then the program would run
1674 ;; faster since it wouldn't then have to call `char-to-string' when it
1675 ;; did the `concat'. I left them as chars here because I want
1676 ;; *them* to change `concat' so that it accepts chars and deals with
1677 ;; them properly. i.e. the form: (concat "abc" ?T "xyz") should
1678 ;; return "abcTxyz" NOT "abc84xyz" (XEmacs 19.*) and NOT an error
1679 ;; (XEmacs 20.*).
1680 ;; (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
1681 ;; "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
1682 ;; "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "A" "B" "C" "D"
1683 ;; "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S"
1684 ;; "T" "U" "V" "W" "X" "Y" "Z")
1685 (vector ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
1686 ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
1687 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z)
1688 "Character vector for fast lookup of base-64 encoding of numbers in [0,61].")
1689
1690 (defsubst strokes-xpm-char-on-p (char)
1691 ;; ### CAUTION: `char-equal' may need to change to `char=' ###
1692 "Non-nil if CHAR represents an `on' bit in the xpm."
1693 (char-equal char ?*))
1694
1695 (defsubst strokes-xpm-char-bit-p (char)
1696 "Non-nil if CHAR represents an `on' or `off' bit in the xpm."
1697 ;; ### CAUTION: `char-equal' may need to change to `char=' ###
1698 (or (char-equal char ?\ )
1699 (char-equal char ?*)))
1700
1701 ;;(defsubst strokes-xor (a b) ### Should I make this an inline function? ###
1702 ;; "T iff one and only one of A and B is non-nil; otherwise, returns nil.
1703 ;;NOTE: Don't use this as a numeric xor since it treats all non-nil
1704 ;; values as t including `0' (zero)."
1705 ;; (eq (null a) (not (null b))))
1706
1707 (defsubst strokes-xpm-encode-length-as-string (length)
1708 "Given some LENGTH in [0,62) do a fast lookup of it's encoding."
1709 (char-to-string (aref strokes-base64-chars length)))
1710
1711 (defsubst strokes-xpm-decode-char (character)
1712 "Given a CHARACTER, do a fast lookup to find its corresponding integer value."
1713 ;; ### NOTE: for XEmacs-20.* this will need to be changed to deal w/
1714 ;; char-tables !!! ###
1715 (gethash character strokes-char-value-hashtable)) ; (get-char-table
1716 ; character
1717 ; strokes-value-chartable)
1718
1719 (defun strokes-xpm-to-compressed-string (&optional xpm-buffer)
1720 "Convert the xpm in XPM-BUFFER into a compressed string representing the stroke.
1721 XPM-BUFFER is an optional argument, and defaults to `*strokes-xpm*'."
1722 (save-excursion
1723 (set-buffer (setq xpm-buffer (or xpm-buffer "*strokes-xpm*")))
1724 (goto-char (point-min))
1725 (search-forward "/* pixels */") ; skip past header junk
1726 (forward-char 2)
1727 ;; a note for below:
1728 ;; the `current-char' is the char being counted -- NOT the char at (point)
1729 ;; which happens to be called `char-at-point'
1730 (let ((compressed-string "+/") ; initialize the output
1731 (count 0) ; keep a current count of
1732 ; `current-char'
1733 (last-char-was-on-p t) ; last entered stream
1734 ; represented `on' bits
1735 (current-char-is-on-p nil) ; current stream represents `on' bits
1736 (char-at-point (char-after))) ; read the first char
1737 (while (not (char-equal char-at-point ?})) ; a `}' denotes the
1738 ; end of the pixmap
1739 (cond ((zerop count) ; must restart counting
1740 ;; check to see if the `char-at-point' is an actual pixmap bit
1741 (when (strokes-xpm-char-bit-p char-at-point)
1742 (setq count 1
1743 current-char-is-on-p (strokes-xpm-char-on-p char-at-point)))
1744 (forward-char 1))
1745 ((= count 61) ; maximum single char's
1746 ; encoding length
1747 (setq compressed-string (concat compressed-string
1748 ;; add a zero-length
1749 ;; encoding when
1750 ;; necessary
1751 (when (eq last-char-was-on-p
1752 current-char-is-on-p)
1753 ;; "0"
1754 (strokes-xpm-encode-length-as-string 0))
1755 (strokes-xpm-encode-length-as-string 61))
1756 last-char-was-on-p current-char-is-on-p
1757 count 0)) ; note that we just set
1758 ; count=0 and *don't* advance
1759 ; (point)
1760 ((strokes-xpm-char-bit-p char-at-point) ; an actual xpm bit
1761 (if (eq current-char-is-on-p
1762 (strokes-xpm-char-on-p char-at-point))
1763 ;; yet another of the same bit-type, so we continue
1764 ;; counting...
1765 (progn
1766 (incf count)
1767 (forward-char 1))
1768 ;; otherwise, it's the opposite bit-type, so we do a
1769 ;; write and then restart count ### NOTE (for myself
1770 ;; to be aware of) ### I really should advance
1771 ;; (point) in this case instead of letting another
1772 ;; iteration go through and letting the case: count=0
1773 ;; take care of this stuff for me. That's why
1774 ;; there's no (forward-char 1) below.
1775 (setq compressed-string (concat compressed-string
1776 ;; add a zero-length
1777 ;; encoding when
1778 ;; necessary
1779 (when (eq last-char-was-on-p
1780 current-char-is-on-p)
1781 ;; "0"
1782 (strokes-xpm-encode-length-as-string 0))
1783 (strokes-xpm-encode-length-as-string count))
1784 count 0
1785 last-char-was-on-p current-char-is-on-p)))
1786 (t ; ELSE it's some other useless
1787 ; char, like `"' or `,'
1788 (forward-char 1)))
1789 (setq char-at-point (char-after)))
1790 (concat compressed-string
1791 (when (> count 0)
1792 (concat (when (eq last-char-was-on-p
1793 current-char-is-on-p)
1794 ;; "0"
1795 (strokes-xpm-encode-length-as-string 0))
1796 (strokes-xpm-encode-length-as-string count)))
1797 "/"))))
1798
1799 (defun strokes-strokify-buffer (&optional buffer)
1800 "Decode stroke strings in BUFFER and display their corresponding glyphs.
1801 BUFFER defaults to the current buffer."
1802 (interactive)
1803 ;; (interactive "*bStrokify buffer: ")
1804 (save-excursion
1805 (set-buffer (or buffer (setq buffer (current-buffer))))
1806 (if (interactive-p)
1807 (message "Strokifying %s..." buffer))
1808 (goto-char (point-min))
1809 (let (ext string)
1810 ;; The comment below is what i'd have to do if I wanted to deal with
1811 ;; random newlines in the midst of the compressed strings.
1812 ;; If I do this, I'll also have to change `strokes-xpm-to-compress-string'
1813 ;; to deal with the newline, and possibly other whitespace stuff. YUCK!
1814 ;; (while (re-search-forward "\\+/\\(\\w\\|
1815 ;;\\)+/" nil t nil (get-buffer buffer))
1816 (while (re-search-forward "\\+/\\w+/" nil t nil (get-buffer buffer))
1817 (setq string (buffer-substring (+ 2 (match-beginning 0))
1818 (1- (match-end 0))))
1819 (strokes-xpm-for-compressed-string string " *strokes-xpm*")
1820 (replace-match " ")
1821 (setq ext (make-extent (1- (point)) (point)))
1822 (set-extent-property ext 'type 'stroke-glyph)
1823 (set-extent-property ext 'start-open t)
1824 (set-extent-property ext 'end-open t)
1825 (set-extent-property ext 'detachable t)
1826 (set-extent-property ext 'duplicable t)
1827 (set-extent-property ext 'data string)
1828 (set-extent-face ext 'strokes-char-face)
1829 (set-extent-end-glyph ext (make-glyph
1830 (list
1831 (vector 'xpm
1832 :data (buffer-substring
1833 (point-min " *strokes-xpm*")
1834 (point-max " *strokes-xpm*")
1835 " *strokes-xpm*"))
1836 [string :data "[Stroke]"])))))
1837 (if (interactive-p)
1838 (message "Strokifying %s...done" buffer))))
1839
1840 (defun strokes-unstrokify-buffer (&optional buffer)
1841 "Convert the glyphs in BUFFER to thier base-64 ASCII representations.
1842 BUFFER defaults to the current buffer"
1843 ;; ### NOTE !!! ### (for me)
1844 ;; For later on, you can/should make the inserted strings atomic
1845 ;; extents, so that the users have a clue that they shouldn't be
1846 ;; editing inside them. Plus, if you make them extents, you can
1847 ;; very easily just hide the glyphs, so if you unstrokify, and the
1848 ;; restrokify, then those that already are glyphed don't need to be
1849 ;; re-calculated, etc. It's just nicer that way. The only things
1850 ;; to worry about is cleanup (i.e. do the glyphs get gc'd when the
1851 ;; buffer is killed?
1852 ;; (interactive "*bUnstrokify buffer: ")
1853 (interactive)
1854 (save-excursion
1855 (set-buffer (setq buffer (or buffer (current-buffer))))
1856 ;; (map-extents
1857 ;; (lambda (ext buf)
1858 ;; (when (eq (extent-property ext 'type) 'stroke-glyph)
1859 ;; (goto-char (extent-start-position ext))
1860 ;; (delete-char 1) ; ### What the hell do I do here? ###
1861 ;; (insert "+/" (extent-property ext 'data) "/")
1862 ;; (delete-extent ext))))))
1863 (let (start)
1864 (map-extents
1865 (lambda (ext buf)
1866 (when (eq (extent-property ext 'type) 'stroke-glyph)
1867 (setq start (goto-char (extent-start-position ext)))
1868 ;; (insert "+/" (extent-property ext 'data) "/")
1869 (insert-string "+/")
1870 (insert-string (extent-property ext 'data))
1871 (insert-string "/")
1872 (delete-char 1)
1873 (set-extent-endpoints ext start (point))
1874 (set-extent-property ext 'type 'stroke-string)
1875 (set-extent-property ext 'atomic t)
1876 ;; (set-extent-property ext 'read-only t)
1877 (set-extent-face ext 'strokes-char-face)
1878 (set-extent-property ext 'stroke-glyph (extent-end-glyph ext))
1879 (set-extent-end-glyph ext nil)))))))
1880
1881 (defun strokes-xpm-for-compressed-string (compressed-string &optional bufname)
1882 "Convert the stroke represented by COMPRESSED-STRING into an xpm.
1883 Store xpm in buffer BUFNAME if supplied \(default is `*strokes-xpm*'\)"
1884 (save-excursion
1885 (or bufname (setq bufname "*strokes-xpm*"))
1886 (erase-buffer (set-buffer (get-buffer-create bufname)))
1887 (insert compressed-string)
1888 (goto-char (point-min))
1889 (let ((current-char-is-on-p nil))
1890 (while (not (eobp))
1891 (insert-char
1892 (if current-char-is-on-p
1893 ?*
1894 ?\ )
1895 (strokes-xpm-decode-char (char-after)))
1896 (delete-char 1)
1897 (setq current-char-is-on-p (not current-char-is-on-p)))
1898 (goto-char (point-min))
1899 (loop repeat 33 do
1900 (insert-char ?\")
1901 (forward-char 33)
1902 (insert "\",\n"))
1903 (goto-char (point-min))
1904 (insert strokes-xpm-header))))
1905
1906 (defun strokes-compose-complex-stroke ()
1907 (interactive "*")
1908 (let ((strokes-grid-resolution 33))
1909 (strokes-read-complex-stroke)
1910 (strokes-xpm-for-stroke nil nil t)
1911 (insert (strokes-xpm-to-compressed-string))
1912 (strokes-strokify-buffer)))
1913
1421 (provide 'strokes) 1914 (provide 'strokes)
1422 (run-hooks 'strokes-load-hook) 1915 (run-hooks 'strokes-load-hook)
1423 1916
1424 ;;; strokes.el ends here 1917 ;;; strokes.el ends here