;;; strokes.el --- control Emacs through mouse strokes
-;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011, 2012 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."
nil))
nil))
+(defsubst strokes-fill-current-buffer-with-whitespace ()
+ "Erase the contents of the current buffer and fill it with whitespace."
+ (erase-buffer)
+ (cl-loop repeat (frame-height) do
+ (insert-char ?\s (1- (frame-width)))
+ (newline))
+ (goto-char (point-min)))
+
;;;###autoload
(defun strokes-read-stroke (&optional prompt event)
"Read a simple stroke (interactively) and return the stroke.
;; display the stroke as it's being read
(save-window-excursion
(set-window-configuration strokes-window-configuration)
+ ;; The frame has been resized, so we need to refill the
+ ;; strokes buffer so that the strokes canvas is the whole
+ ;; visible buffer.
+ (unless (> 1 (abs (- (line-end-position) (window-width))))
+ (strokes-fill-current-buffer-with-whitespace))
(when prompt
(message "%s" prompt)
(setq event (read-event))
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
(help-mode)
(help-print-return-message)))
-(defalias 'strokes-report-bug 'report-emacs-bug)
-
-(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))
- (goto-char (point-min)))
+(define-obsolete-function-alias 'strokes-report-bug 'report-emacs-bug "24.1")
(defun strokes-window-configuration-changed-p ()
"Non-nil if the `strokes-window-configuration' frame properties changed.
(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)))
;;;###autoload
(define-minor-mode strokes-mode
- "Toggle Strokes global minor mode.\\<strokes-mode-map>
-With ARG, turn strokes on if and only if ARG is positive.
+ "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.
+
+\\<strokes-mode-map>
Strokes are pictographic mouse gestures which invoke commands.
Strokes are invoked with \\[strokes-do-stroke]. You can define
new strokes with \\[strokes-global-set-stroke]. See also
\\[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
(let ((inhibit-read-only t))
(message "Strokifying %s..." buffer)
(goto-char (point-min))
- (let (ext string image)
+ (let (string image)
;; The comment below is what I'd have to do if I wanted to
;; deal with random newlines in the midst of the compressed
;; strings. If I do this, I'll also have to change
(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))))
(run-hooks 'strokes-load-hook)
(provide 'strokes)
-;; arch-tag: 8377f60e-43fb-467a-bbcd-2774f91f833e
;;; strokes.el ends here