;;; strokes.el --- control Emacs through mouse strokes
-;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2000-2016 Free Software Foundation, Inc.
;; Author: David Bakhash <cadet@alum.mit.edu>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp, mouse, extensions
;; This file is part of GNU Emacs.
;; > M-x strokes-prompt-user-save-strokes
-;; and it will save your strokes in ~/.strokes, or you may wish to change
-;; this by setting the variable `strokes-file'.
+;; and it will save your strokes in your `strokes-file'.
;; Note that internally, all of the routines that are part of this
;; package are able to deal with complex strokes, as they are a superset
;;; Requirements and provisions...
(autoload 'mail-position-on-field "sendmail")
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; Constants...
\"P c #FFFF0000FFFF\",
\". c #45458B8B0000\",
/* pixels */\n"
- "The header to all xpm buffers created by strokes.")
+ "The header to all XPM buffers created by strokes.")
;;; user variables...
:link '(emacs-commentary-link "strokes")
:group 'mouse)
-(defcustom strokes-modeline-string " Strokes"
- "Modeline identification when Strokes mode is on \(default is \" Strokes\"\)."
+(define-obsolete-variable-alias 'strokes-modeline-string 'strokes-lighter
+ "24.3")
+
+(defcustom strokes-lighter " Strokes"
+ "Mode line identifier for Strokes mode."
:type 'string
:group 'strokes)
(defcustom strokes-character ?@
"Character used when drawing strokes in the strokes buffer.
-\(The default is `@', which works well.\)"
+\(The default is `@', which works well.)"
:type 'character
:group 'strokes)
:type 'integer
:group 'strokes)
-(defcustom strokes-file (convert-standard-filename "~/.strokes")
- "File containing saved strokes for Strokes mode (default is ~/.strokes)."
+(defcustom strokes-file (locate-user-emacs-file "strokes" ".strokes")
+ "File containing saved strokes for Strokes mode."
+ :version "24.4" ; added locate-user-emacs-file
:type 'file
:group 'strokes)
(defvar strokes-last-stroke nil
"Last stroke entered by the user.
-Its value gets set every time the function
-`strokes-fill-stroke' gets called,
-since that is the best time to set the variable.")
+Its value gets set every time the function `strokes-fill-stroke'
+gets called, since that is the best time to set the variable.")
(defvar strokes-global-map '()
"Association list of strokes and their definitions.
Each entry is (STROKE . COMMAND) where STROKE is itself a list of
coordinates (X . Y) where X and Y are lists of positions on the
-normalized stroke grid, with the top left at (0 . 0). COMMAND is the
-corresponding interactive function.")
+normalized stroke grid, with the top left at (0 . 0). COMMAND is
+the corresponding interactive function.")
(defvar strokes-load-hook nil
"Functions to be called when Strokes is loaded.")
(* x x))
(defsubst strokes-distance-squared (p1 p2)
- "Gets the distance (squared) between to points P1 and P2.
+ "Compute the distance (squared) between to points P1 and P2.
P1 and P2 are cons cells in the form (X . Y)."
(let ((x1 (car p1))
(y1 (cdr p1))
(interactive)
(let ((command (cdar strokes-global-map)))
(if (y-or-n-p
- (format "Really delete last stroke definition, defined to `%s'? "
- command))
+ (format-message
+ "Really delete last stroke definition, defined to `%s'? "
+ command))
(progn
(setq strokes-global-map (cdr strokes-global-map))
(message "That stroke has been deleted"))
;;;###autoload
(defun strokes-global-set-stroke (stroke command)
"Interactively give STROKE the global binding as COMMAND.
-Operated just like `global-set-key', except for strokes.
-COMMAND is a symbol naming an interactively-callable function. STROKE
-is a list of sampled positions on the stroke grid as described in the
+Works just like `global-set-key', except for strokes. COMMAND is
+a symbol naming an interactively-callable function. STROKE is a
+list of sampled positions on the stroke grid as described in the
documentation for the `strokes-define-stroke' function.
See also `strokes-global-set-stroke-string'."
(defun strokes-global-set-stroke-string (stroke string)
"Interactively give STROKE the global binding as STRING.
-Operated just like `global-set-key', except for strokes. STRING
+Works just like `global-set-key', except for strokes. STRING
is a string to be inserted by the stroke. STROKE is a list of
sampled positions on the stroke grid as described in the
documentation for the `strokes-define-stroke' function.
(defun strokes-get-grid-position (stroke-extent position &optional grid-resolution)
"Map POSITION to a new grid position.
Do so based on its STROKE-EXTENT and GRID-RESOLUTION.
-STROKE-EXTENT as a list \(\(XMIN . YMIN\) \(XMAX . YMAX\)\).
+STROKE-EXTENT is a list ((XMIN . YMIN) (XMAX . YMAX)).
If POSITION is a `strokes-lift', then it is itself returned.
Optional GRID-RESOLUTION may be used in place of `strokes-grid-resolution'.
The grid is a square whose dimension is [0,GRID-RESOLUTION)."
(defun strokes-eliminate-consecutive-redundancies (entries)
"Return a list with no consecutive redundant entries."
;; defun a grande vitesse grace a Dave G.
- (loop for element on entries
- if (not (equal (car element) (cadr element)))
- collect (car element)))
-;; (loop for element on entries
+ (cl-loop for element on entries
+ if (not (equal (car element) (cadr element)))
+ collect (car element)))
+;; (cl-loop for element on entries
;; nconc (if (not (equal (car el) (cadr el)))
;; (list (car el)))))
;; yet another (orig) way of doing it...
(if (and (strokes-click-p unfilled-stroke)
(not force))
unfilled-stroke
- (loop for grid-locs on unfilled-stroke
- nconc (let* ((current (car grid-locs))
- (current-is-a-point-p (consp current))
- (next (cadr grid-locs))
- (next-is-a-point-p (consp next))
- (both-are-points-p (and current-is-a-point-p
- next-is-a-point-p))
- (x1 (and current-is-a-point-p
- (car current)))
- (y1 (and current-is-a-point-p
- (cdr current)))
- (x2 (and next-is-a-point-p
- (car next)))
- (y2 (and next-is-a-point-p
- (cdr next)))
- (delta-x (and both-are-points-p
- (- x2 x1)))
- (delta-y (and both-are-points-p
- (- y2 y1)))
- (slope (and both-are-points-p
- (if (zerop delta-x)
- nil ; undefined vertical slope
- (/ (float delta-y)
- delta-x)))))
- (cond ((not both-are-points-p)
- (list current))
- ((null slope) ; undefined vertical slope
- (if (>= delta-y 0)
- (loop for y from y1 below y2
- collect (cons x1 y))
- (loop for y from y1 above y2
- collect (cons x1 y))))
- ((zerop slope) ; (= y1 y2)
- (if (>= delta-x 0)
- (loop for x from x1 below x2
- collect (cons x y1))
- (loop for x from x1 above x2
- collect (cons x y1))))
- ((>= (abs delta-x) (abs delta-y))
- (if (> delta-x 0)
- (loop for x from x1 below x2
- collect (cons x
- (+ y1
- (round (* slope
- (- x x1))))))
- (loop for x from x1 above x2
- collect (cons x
- (+ y1
- (round (* slope
- (- x x1))))))))
- (t ; (< (abs delta-x) (abs delta-y))
- (if (> delta-y 0)
- (loop for y from y1 below y2
- collect (cons (+ x1
- (round (/ (- y y1)
- slope)))
- y))
- (loop for y from y1 above y2
- collect (cons (+ x1
- (round (/ (- y y1)
- slope)))
- y))))))))))
+ (cl-loop
+ for grid-locs on unfilled-stroke
+ nconc (let* ((current (car grid-locs))
+ (current-is-a-point-p (consp current))
+ (next (cadr grid-locs))
+ (next-is-a-point-p (consp next))
+ (both-are-points-p (and current-is-a-point-p
+ next-is-a-point-p))
+ (x1 (and current-is-a-point-p
+ (car current)))
+ (y1 (and current-is-a-point-p
+ (cdr current)))
+ (x2 (and next-is-a-point-p
+ (car next)))
+ (y2 (and next-is-a-point-p
+ (cdr next)))
+ (delta-x (and both-are-points-p
+ (- x2 x1)))
+ (delta-y (and both-are-points-p
+ (- y2 y1)))
+ (slope (and both-are-points-p
+ (if (zerop delta-x)
+ nil ; undefined vertical slope
+ (/ (float delta-y)
+ delta-x)))))
+ (cond ((not both-are-points-p)
+ (list current))
+ ((null slope) ; undefined vertical slope
+ (if (>= delta-y 0)
+ (cl-loop for y from y1 below y2
+ collect (cons x1 y))
+ (cl-loop for y from y1 above y2
+ collect (cons x1 y))))
+ ((zerop slope) ; (= y1 y2)
+ (if (>= delta-x 0)
+ (cl-loop for x from x1 below x2
+ collect (cons x y1))
+ (cl-loop for x from x1 above x2
+ collect (cons x y1))))
+ ((>= (abs delta-x) (abs delta-y))
+ (if (> delta-x 0)
+ (cl-loop for x from x1 below x2
+ collect (cons x
+ (+ y1
+ (round (* slope
+ (- x x1))))))
+ (cl-loop for x from x1 above x2
+ collect (cons x
+ (+ y1
+ (round (* slope
+ (- x x1))))))))
+ (t ; (< (abs delta-x) (abs delta-y))
+ (if (> delta-y 0)
+ ;; FIXME: Reduce redundancy between branches.
+ (cl-loop for y from y1 below y2
+ collect (cons (+ x1
+ (round (/ (- y y1)
+ slope)))
+ y))
+ (cl-loop for y from y1 above y2
+ collect (cons (+ x1
+ (round (/ (- y y1)
+ slope)))
+ y))))))))))
(defun strokes-rate-stroke (stroke1 stroke2)
- "Rates STROKE1 with STROKE2 and return a score based on a distance metric.
+ "Rate STROKE1 with STROKE2 and return a score based on a distance metric.
Note: the rating is an error rating, and therefore, a return of 0
represents a perfect match. Also note that the order of stroke
arguments is order-independent for the algorithm used here."
(defsubst strokes-fill-current-buffer-with-whitespace ()
"Erase the contents of the current buffer and fill it with whitespace."
(erase-buffer)
- (loop repeat (frame-height) do
- (insert-char ?\s (1- (frame-width)))
- (newline))
+ (cl-loop repeat (frame-height) do
+ (insert-char ?\s (1- (frame-width)))
+ (newline))
(goto-char (point-min)))
;;;###autoload
The command will be executed provided one exists for that stroke,
based on the variable `strokes-minimum-match-score'.
If no stroke matches, nothing is done and return value is nil."
+ ;; FIXME: Undocument return value. It is not documented for all cases,
+ ;; and doesn't allow differentiating between no stroke matches and
+ ;; command-execute returning nil, anyway.
(let* ((match (strokes-match-stroke stroke strokes-global-map))
(command (car match))
(score (cdr match)))
((null strokes-global-map)
(if (file-exists-p strokes-file)
(and (y-or-n-p
- (format "No strokes loaded. Load `%s'? "
- strokes-file))
+ (format-message "No strokes loaded. Load `%s'? "
+ strokes-file))
(strokes-load-user-strokes))
(error "No strokes defined; use `strokes-global-set-stroke'")))
(t
extracting the strokes for editing use once again, so the editing
cycle can continue.
-Strokes are easy to program and fun to use. To start strokes going,
-you'll want to put the following line in your .emacs file as mentioned
-in the commentary to strokes.el.
-
-This will load strokes when and only when you start Emacs on a window
-system, with a mouse or other pointer device defined.
-
-To toggle strokes-mode, you just do
+To toggle strokes-mode, invoke the command
> M-x strokes-mode
package lets you program in simple and complex (multi-lift) strokes.
The only difference is how you *invoke* the two. You will most likely
use simple strokes, as complex strokes were developed for
-Chinese/Japanese/Korean. So the shifted middle mouse button (S-mouse-2) will
-invoke the command `strokes-do-stroke'.
+Chinese/Japanese/Korean. So the shifted middle mouse button (S-mouse-2)
+will invoke the command `strokes-do-stroke'.
If ever you define a stroke which you don't like, then you can unset
it with the command
> C-u M-x strokes-list-strokes
-Your strokes are stored as you enter them. They get saved in a file
-called ~/.strokes, along with other strokes configuration variables.
-You can change this location by setting the variable `strokes-file'.
-You will be prompted to save them when you exit Emacs, or you can save
-them with
+Your strokes are stored as you enter them. They get saved into the
+file specified by the `strokes-file' variable, along with other strokes
+configuration variables. You will be prompted to save them when you
+exit Emacs, or you can save them with
> M-x strokes-prompt-user-save-strokes
be running a version of Emacs with XPM support. You use the binding
to `strokes-compose-complex-stroke' to start drawing your strokes.
These are just complex strokes, and thus continue drawing with mouse-1
-or mouse-2 and end with mouse-3. Then the stroke image gets inserted
+or mouse-2 and end with mouse-3. Then the stroke image gets inserted
into the buffer. You treat it somewhat like any other character,
which you can copy, paste, delete, move, etc. When all is done, you
may want to send the file, or save it. This is done with
(not strokes-use-strokes-buffer))))
(defun strokes-xpm-for-stroke (&optional stroke bufname b/w-only)
- "Create an XPM pixmap for the given STROKE in buffer ` *strokes-xpm*'.
+ "Create an XPM pixmap for the given STROKE in buffer \" *strokes-xpm*\".
If STROKE is not supplied, then `strokes-last-stroke' will be used.
Optional BUFNAME to name something else.
The pixmap will contain time information via rainbow dot colors
(set-buffer buf)
(erase-buffer)
(insert strokes-xpm-header)
- (loop repeat 33 do
- (insert ?\")
- (insert-char ?\s 33)
- (insert "\",")
- (newline)
- finally
- (forward-line -1)
- (end-of-line)
- (insert "}\n"))
- (loop for point in stroke
- for x = (car-safe point)
- for y = (cdr-safe point) do
- (cond ((consp point)
- ;; draw a point, and possibly a starting-point
- (if (and lift-flag (not b/w-only))
- ;; mark starting point with the appropriate color
- (let ((char (or (car rainbow-chars) ?\.)))
- (loop for i from 0 to 2 do
- (loop for j from 0 to 2 do
- (goto-char (point-min))
- (forward-line (+ 15 i y))
- (forward-char (+ 1 j x))
- (delete-char 1)
- (insert char)))
- (setq rainbow-chars (cdr rainbow-chars)
- lift-flag nil))
- ;; Otherwise, just plot the point...
- (goto-char (point-min))
- (forward-line (+ 16 y))
- (forward-char (+ 2 x))
- (subst-char-in-region (point) (1+ (point)) ?\s ?\*)))
- ((strokes-lift-p point)
- ;; a lift--tell the loop to X out the next point...
- (setq lift-flag t))))
+ (cl-loop repeat 33 do
+ (insert ?\")
+ (insert-char ?\s 33)
+ (insert "\",")
+ (newline)
+ finally
+ (forward-line -1)
+ (end-of-line)
+ (insert "}\n"))
+ (cl-loop for point in stroke
+ for x = (car-safe point)
+ for y = (cdr-safe point) do
+ (cond ((consp point)
+ ;; draw a point, and possibly a starting-point
+ (if (and lift-flag (not b/w-only))
+ ;; mark starting point with the appropriate color
+ (let ((char (or (car rainbow-chars) ?\.)))
+ (cl-loop for i from 0 to 2 do
+ (cl-loop for j from 0 to 2 do
+ (goto-char (point-min))
+ (forward-line (+ 15 i y))
+ (forward-char (+ 1 j x))
+ (delete-char 1)
+ (insert char)))
+ (setq rainbow-chars (cdr rainbow-chars)
+ lift-flag nil))
+ ;; Otherwise, just plot the point...
+ (goto-char (point-min))
+ (forward-line (+ 16 y))
+ (forward-char (+ 2 x))
+ (subst-char-in-region (point) (1+ (point)) ?\s ?\*)))
+ ((strokes-lift-p point)
+ ;; a lift--tell the loop to X out the next point...
+ (setq lift-flag t))))
(when (called-interactively-p 'interactive)
(pop-to-buffer " *strokes-xpm*")
;; (xpm-mode 1)
;; (insert
;; "Command Stroke\n"
;; "------- ------")
-;; (loop for def in strokes-map
+;; (cl-loop for def in strokes-map
;; for i from 0 to (1- (length strokes-map)) do
;; (let ((stroke (car def))
;; (command-name (symbol-name (cdr def))))
;;;###autoload
(defun strokes-list-strokes (&optional chronological strokes-map)
"Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP.
-With CHRONOLOGICAL prefix arg \(\\[universal-argument]\) list strokes
-chronologically by command name.
+With CHRONOLOGICAL prefix arg (\\[universal-argument]) list strokes chronologically
+by command name.
If STROKES-MAP is not given, `strokes-global-map' will be used instead."
(interactive "P")
(setq strokes-map (or strokes-map
(insert
"Command Stroke\n"
"------- ------")
- (loop for def in strokes-map do
- (let ((stroke (car def))
- (command-name (if (symbolp (cdr def))
- (symbol-name (cdr def))
- (prin1-to-string (cdr def)))))
- (strokes-xpm-for-stroke stroke " *strokes-xpm*")
- (newline 2)
- (insert-char ?\s 45)
- (beginning-of-line)
- (insert command-name)
- (beginning-of-line)
- (forward-char 45)
- (insert-image
- (create-image (with-current-buffer " *strokes-xpm*"
- (buffer-string))
- 'xpm t
- :color-symbols
- `(("foreground"
- . ,(frame-parameter nil 'foreground-color))))))
- finally do (unless (eobp)
- (kill-region (1+ (point)) (point-max))))
+ (cl-loop
+ for def in strokes-map do
+ (let ((stroke (car def))
+ (command-name (if (symbolp (cdr def))
+ (symbol-name (cdr def))
+ (prin1-to-string (cdr def)))))
+ (strokes-xpm-for-stroke stroke " *strokes-xpm*")
+ (newline 2)
+ (insert-char ?\s 45)
+ (beginning-of-line)
+ (insert command-name)
+ (beginning-of-line)
+ (forward-char 45)
+ (insert-image
+ (create-image (with-current-buffer " *strokes-xpm*"
+ (buffer-string))
+ 'xpm t
+ :color-symbols
+ `(("foreground"
+ . ,(frame-parameter nil 'foreground-color))))))
+ finally do (unless (eobp)
+ (kill-region (1+ (point)) (point-max))))
(view-buffer "*Strokes List*" nil)
(set (make-local-variable 'view-mode-map)
(let ((map (copy-keymap view-mode-map)))
(define-minor-mode strokes-mode
"Toggle Strokes mode, a global minor mode.
With a prefix argument ARG, enable Strokes mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
+positive, and disable it otherwise. If called from Lisp,
+enable the mode if ARG is omitted or nil.
\\<strokes-mode-map>
Strokes are pictographic mouse gestures which invoke commands.
\\[strokes-decode-buffer].
\\{strokes-mode-map}"
- nil strokes-modeline-string strokes-mode-map
+ nil strokes-lighter strokes-mode-map
:group 'strokes :global t
(cond ((not (display-mouse-p))
(error "Can't use Strokes without a mouse"))
(defun strokes-xpm-to-compressed-string (&optional xpm-buffer)
"Convert XPM in XPM-BUFFER to compressed string representing the stroke.
-XPM-BUFFER defaults to ` *strokes-xpm*'."
+XPM-BUFFER defaults to \" *strokes-xpm*\"."
(with-current-buffer (setq xpm-buffer (or xpm-buffer " *strokes-xpm*"))
(goto-char (point-min))
(search-forward "/* pixels */") ; skip past header junk
;; yet another of the same bit-type, so we continue
;; counting...
(progn
- (incf count)
+ (cl-incf count)
(forward-char 1))
;; otherwise, it's the opposite bit-type, so we do a
;; write and then restart count ### NOTE (for myself
(defun strokes-xpm-for-compressed-string (compressed-string &optional bufname)
"Convert the stroke represented by COMPRESSED-STRING into an XPM.
-Store XPM in buffer BUFNAME if supplied \(default is ` *strokes-xpm*'\)"
+Store XPM in buffer BUFNAME if supplied (default is \" *strokes-xpm*\")"
(or bufname (setq bufname " *strokes-xpm*"))
(with-current-buffer (get-buffer-create bufname)
(erase-buffer)
(delete-char 1)
(setq current-char-is-on-p (not current-char-is-on-p)))
(goto-char (point-min))
- (loop repeat 33 do
- (insert ?\")
- (forward-char 33)
- (insert "\",\n"))
+ (cl-loop repeat 33 do
+ (insert ?\")
+ (forward-char 33)
+ (insert "\",\n"))
(goto-char (point-min))
(insert strokes-xpm-header))))