branch: master commit 36043c1d768b309ba3471d5b3aa79b0520e0e34b Merge: 9f5c4e0 11843e2 Author: Stephen Leake <stephen_le...@stephe-leake.org> Commit: Stephen Leake <stephen_le...@stephe-leake.org>
Merge commit '11843e2db4a24aaec2ad9a827ed4f079588dcf58' --- externals-list | 3 +- packages/el-search/NEWS | 15 + packages/el-search/el-search.el | 676 +++++++++++++++++++++++++++------------- packages/sokoban/sokoban.el | 99 ++++-- 4 files changed, 542 insertions(+), 251 deletions(-) diff --git a/externals-list b/externals-list index b2dd210..b6459a7 100644 --- a/externals-list +++ b/externals-list @@ -83,8 +83,7 @@ ("gnome-c-style" :subtree "https://github.com/ueno/gnome-c-style.git") ("gnorb" :subtree "https://github.com/girzel/gnorb") ("gpastel" :external "https://gitlab.petton.fr/DamienCassou/gpastel") - ;; FIXME: Waiting for copyright paperwork - ;; ("greader" :external "https://gitlab.com/michelangelo-rodriguez/greader") + ("greader" :external "https://gitlab.com/michelangelo-rodriguez/greader") ("highlight-escape-sequences" :subtree "https://github.com/dgutov/highlight-escape-sequences/") ("hyperbole" :external "http://git.savannah.gnu.org/r/hyperbole.git") ("ioccur" :subtree "https://github.com/thierryvolpiatto/ioccur.git") diff --git a/packages/el-search/NEWS b/packages/el-search/NEWS index e158df9..07bea82 100644 --- a/packages/el-search/NEWS +++ b/packages/el-search/NEWS @@ -1,6 +1,21 @@ Some of the user visible news were: +Version: 1.9.7 + + Changed default binding schemes: For reasons of harmonization, in + both searches and in el-search-occur both of basic keys s, r and n, p + now move to the next or previous match. + + The default binding of 'el-search-continue-in-next-buffer' therefore + has been moved from n to x respectively. + +Version: 1.9.5 + + 'string' and derived pattern types now support expressions evaluting + to regexps as arguments. This means you can use 'rx' to construct + regexps in 'string' patterns, for example. + Version: 1.9.0 This version adds some help commands available through the C-h help diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el index c85197c..b4981fe 100644 --- a/packages/el-search/el-search.el +++ b/packages/el-search/el-search.el @@ -7,7 +7,7 @@ ;; Created: 29 Jul 2015 ;; Keywords: lisp ;; Compatibility: GNU Emacs 25 -;; Version: 1.9.4 +;; Version: 1.9.7 ;; Package-Requires: ((emacs "25") (stream "2.2.4") (cl-print "1.0")) @@ -119,7 +119,7 @@ ;; C-O or M-RET (from a search pattern prompt) ;; Execute this search command as occur. ;; -;; C-N, M-s e n (`el-search-continue-in-next-buffer') +;; C-X, M-s e x (`el-search-continue-in-next-buffer') ;; Skip over current buffer or file. ;; ;; C-D, M-s e d (`el-search-skip-directory') @@ -249,7 +249,7 @@ ;; `el-search-jump-to-search-head' (C-J; M-s e j): this command jumps ;; to the last match and re-activates the search. ;; -;; `el-search-continue-in-next-buffer' (C-N; n) skips all remaining +;; `el-search-continue-in-next-buffer' (C-X; x) skips all remaining ;; matches in the current buffer and continues searching in the next ;; buffer. `el-search-skip-directory' (C-D; d) even skips all ;; subsequent files under a specified directory. @@ -474,6 +474,21 @@ "Expression based search and replace for Emacs Lisp." :group 'lisp) +(defcustom el-search-display-mb-hints t + "Whether to show hints in the search pattern prompt." + :type 'boolean) + +(defcustom el-search-mb-hints-delay 0.8 + "Time before displaying minibuffer hints. + +Setting this has only an effect if `el-search-display-mb-hints' +is non-nil." + :type 'number) + +(defcustom el-search-mb-hints-timeout 15 + "How long to display minibuffer hints." + :type 'number) + (defface el-search-match '((((class color) (min-colors 88) (background dark)) (:background "#600000")) (((class color) (min-colors 88) (background light)) @@ -788,11 +803,18 @@ nil." (unless ,done ,@unwindforms))))) +(defvar el-search--last-message nil + "Internal var helping to avoid echo area stuttering ") + (defun el-search--message-no-log (format-string &rest args) "Like `message' but with `message-log-max' bound to nil." (let ((message-log-max nil)) (apply #'message format-string args))) +(defun el-search--set-this-command-refresh-message-maybe () + (when (eq (setq this-command 'el-search-pattern) last-command) + (message "%s" el-search--last-message))) + (defalias 'el-search-read (if (boundp 'force-new-style-backquotes) (lambda (&optional stream) @@ -863,10 +885,13 @@ nil." input) (symbol-value histvar))))) +(defun el-search--pattern-is-unquoted-symbol-p (pattern) + (and (symbolp pattern) + (not (eq pattern '_)) + (not (keywordp pattern)))) + (defun el-search--maybe-warn-about-unquoted-symbol (pattern) - (when (and (symbolp pattern) - (not (eq pattern '_)) - (not (keywordp pattern))) + (when (el-search--pattern-is-unquoted-symbol-p pattern) (message "Free variable `%S' (missing a quote?)" pattern) (sit-for 2.))) @@ -876,7 +901,115 @@ nil." (el-search--pushnew-to-history input histvar) (if (not (string= input "")) input (car (symbol-value histvar))))) -(defun el-search-read-pattern-for-interactive (&optional prompt) +(defvar el-search--display-match-count-in-prompt nil) +(defvar el-search--mb-hints-timer nil) +(defvar el-search--reading-input-for-query-replace nil) + +(defun el-search-read-pattern-trigger-mb-hints () + (if (not (timerp el-search--mb-hints-timer)) + (setq el-search--mb-hints-timer (run-at-time 3 nil #'el-search-read-display-mb-hints)) + (timer-set-time el-search--mb-hints-timer (time-add (current-time) el-search-mb-hints-delay)) + (timer-activate el-search--mb-hints-timer))) + +(defvar el-search--this-session-match-count-data nil) + +(defun el-search-read-pattern-setup-mb () + ;; This is for minibuffer-setup-hook. + ;; Note: this doesn't care about stopping the + ;; 'el-search--mb-hints-timer'. + (when el-search-display-mb-hints + (setq el-search--this-session-match-count-data nil) + (when (timerp el-search--mb-hints-timer) (cancel-timer el-search--mb-hints-timer)) + (setq el-search--mb-hints-timer nil) + (add-hook 'post-command-hook #'el-search-read-pattern-trigger-mb-hints t t))) + +(defvar el-search--search-pattern-1-do-fun nil) +(defvar el-search--busy-animation + ;; '("." "o" "O" "o" "." " ") + ;; '("|" "/" "-" "\\") + '("* " " * " " * " " *" " * " " * ")) +(defvar el-search-mb-anim-time .33) + +(defun el-search--make-display-animation-function (display-fun) + (let ((last-update (seconds-to-time 0)) + (anim (copy-sequence el-search--busy-animation))) + (setcdr (last anim) anim) + (lambda () + (let ((now (current-time))) + (when (< el-search-mb-anim-time (float-time (time-subtract now last-update))) + (setq last-update now) + (funcall display-fun (pop anim))))))) + +(defun el-search-read-display-mb-hints () + (when (minibufferp) + (while-no-input + (let (err) + (cl-macrolet ((try (&rest body) + (let ((err-data (make-symbol "err-data"))) + `(condition-case ,err-data + (progn ,@body) + (error (setq err ,err-data) + nil))))) + (let* ((input (minibuffer-contents)) + (pattern (pcase (ignore-errors (read-from-string input)) + (`(,expr . ,(or (guard el-search--reading-input-for-query-replace) + (pred (= (length input))))) + expr))) + (matcher (and pattern (try (el-search-make-matcher pattern))))) + (let* ((base-win (minibuffer-selected-window)) + (buf (window-buffer base-win))) + (if (and el-search--display-match-count-in-prompt matcher) + (progn (with-current-buffer buf + (setq el-search--current-search + (el-search-make-search + pattern + (let ((b (current-buffer))) + (lambda () (stream (list b))))))) + (let ((ol (make-overlay (point-max) (point-max) nil t t))) + (unwind-protect + (cl-flet ((display-message + (lambda (message &rest args) + (setq message + (propertize (apply #'format message args) + 'face 'shadow)) + (put-text-property 0 1 'cursor t message) + (overlay-put ol 'after-string message) + (redisplay)))) + (when (el-search--pattern-is-unquoted-symbol-p pattern) + ;; A very common mistake: input "foo" instead of "'foo" + (display-message + " [Free variable `%S' (missing a quote?)]" pattern) + (sit-for 2)) + (let ((el-search--search-pattern-1-do-fun + (el-search--make-display-animation-function + (lambda (icon) + (display-message (concat " " icon)))))) + (display-message + " %-12s" + (or (try (with-current-buffer buf + (cl-letf (((point) (window-point base-win))) + (el-search-display-match-count 'dont-message)))) + (error-message-string err)))) + (sit-for el-search-mb-hints-timeout)) + (delete-overlay ol)))) + (unless (string= input "") + (catch 'no-message + (let ((minibuffer-message-timeout el-search-mb-hints-timeout)) + (minibuffer-message + (propertize + (format " [%s]" + (cond + ((not pattern) "invalid") + (err (error-message-string err)) + (el-search--display-match-count-in-prompt "No match") + (t (throw 'no-message t)))) + 'face 'shadow))))))))))) + (when quit-flag + ;; When `quit-flag' is bound here, it had been set by `while-no-input' + ;; meaning the user explicitly quit. This means we must: + (funcall (key-binding [(control ?g)]))))) + +(defun el-search-read-pattern-for-interactive (&optional prompt display-match-count) "Read an \"el-search\" pattern from the minibuffer, prompting with PROMPT. This function is designed to be used in the interactive form of @@ -886,12 +1019,18 @@ from reading the pattern it also sets `this-command' to `el-search-pattern-history' and `el-search-query-replace-history'. PROMPT defaults to \"El-search pattern: \". The return value is the -`read' input pattern." - (let* ((input (el-search--read-pattern (or prompt "El-search pattern: ") - (car el-search-pattern-history))) +`read' input pattern. + +With optional argument DISPLAY-MATCH-COUNT non-nil display a +match count for the current buffer." + (let* ((input + (unwind-protect (minibuffer-with-setup-hook #'el-search-read-pattern-setup-mb + (let ((el-search--display-match-count-in-prompt display-match-count)) + (el-search--read-pattern (or prompt "El-search pattern: ") + (car el-search-pattern-history)))) + (when (timerp el-search--mb-hints-timer) + (cancel-timer el-search--mb-hints-timer)))) (pattern (el-search-read input))) - ;; A very common mistake: input "foo" instead of "'foo" - (el-search--maybe-warn-about-unquoted-symbol pattern) (setq this-command 'el-search-pattern) ;in case we come from isearch ;; Make input available also in query-replace history (el-search--pushnew-to-history input 'el-search-query-replace-history) @@ -1154,6 +1293,8 @@ be specified as fourth argument, and COUNT becomes the fifth argument." (let ((match-beg nil) current-expr) (if (catch 'no-match (while (not match-beg) + (when el-search--search-pattern-1-do-fun + (funcall el-search--search-pattern-1-do-fun)) (condition-case nil (setq current-expr (el-search--ensure-sexp-start)) (end-of-buffer (throw 'no-match t))) @@ -1654,7 +1795,7 @@ With ALLOW-LEADING-WHITESPACE non-nil, the match may be preceded by whitespace." (el-search--looking-at-1 (el-search-make-matcher pattern) allow-leading-whitespace)) -(defun el-search--all-matches (search) +(defun el-search--all-matches (search &optional dont-copy) "Return a stream of all matches of SEARCH. The returned stream will always start searching from the beginning anew even when SEARCH has been used interactively or @@ -1668,7 +1809,7 @@ The elements of the returned stream will have the form where BUFFER or FILE is the buffer or file where a match has been found (exactly one of the two will be nil), and MATCH-BEG is the position of the beginning of the match." - (let* ((search (el-search-reset-search (copy-el-search-object search))) + (let* ((search (if dont-copy search (el-search-reset-search (copy-el-search-object search)))) (head (el-search-object-head search))) (seq-filter #'identity ;we use `nil' as a "skip" tag @@ -1754,6 +1895,8 @@ in, in order, when called with no arguments." (keybind emacs-lisp-mode-map ?s #'el-search-pattern) (keybind emacs-lisp-mode-map ?r #'el-search-pattern-backward) + (keybind emacs-lisp-mode-map ?n #'el-search-pattern) + (keybind emacs-lisp-mode-map ?p #'el-search-pattern-backward) (keybind emacs-lisp-mode-map ?% #'el-search-query-replace) (keybind emacs-lisp-mode-map ?h #'el-search-this-sexp) ;h like in "highlight" or "here" (keybind global-map ?j #'el-search-jump-to-search-head) @@ -1761,7 +1904,7 @@ in, in order, when called with no arguments." (keybind global-map ?< #'el-search-from-beginning) (keybind emacs-lisp-mode-map ?> #'el-search-last-buffer-match) (keybind global-map ?d #'el-search-skip-directory) - (keybind global-map ?n #'el-search-continue-in-next-buffer) + (keybind global-map ?x #'el-search-continue-in-next-buffer) (keybind global-map ?o #'el-search-occur) @@ -1806,7 +1949,7 @@ any case." Go back to the place where the search had been started." (interactive) (setq el-search--success nil) - (el-search-hl-post-command-fun) ;clear highlighting + (el-search-hl-post-command-fun 'stop) ;clear highlighting (let ((w (cadr el-search--search-origin))) (when (window-live-p w) (select-frame-set-input-focus (window-frame w)) @@ -2087,51 +2230,72 @@ Introduction to El-Search ;;;; Additional pattern type definitions -(defun el-search-regexp-like-p (thing) - "Return non-nil when THING is regexp like. +(defun el-search--simple-regexp-like-p (object) + (or (atom object) + (functionp object) + (and (consp object) + (if (fboundp 'proper-list-p) (proper-list-p object) t) + (not (consp (car object)))))) -In el-search, a regexp-like is either a normal regexp (i.e. a -string), or a predicate accepting a string argument, or a list of -the form +(defun el-search-regexp-like-p (object) + "Return non-nil when OBJECT is regexp like. - \(bindings regexp\) +In el-search, a regexp-like is either an expression evaluating to +a normal regexp (e.g. a string or an `rx' form; it is evaluated +once when a pattern is compiled) or a function accepting a string +argument that can be used directly as a predicate for match +testing, or a list of the form -where REGEXP is the actual regexp to match and BINDINGS is a -let-style list of variable bindings. + \(BINDINGS X\) -Example: (((case-fold-search nil)) \"foo\") is a regexp like -matching \"foo\", but not \"Foo\" even when `case-fold-search' is -currently enabled." - (pcase thing - ((or (pred stringp) (pred functionp)) t) +where BINDINGS is a let-style list of variable bindings and X one +of the above. + +Example: (((case-fold-search nil)) (rx bos \"a\")) is a +regexp-like matching any string starting with lower case \"a\"." + (pcase object + ((pred el-search--simple-regexp-like-p) t) (`(,(and (pred listp) bindings) - ,(pred stringp)) + ,(pred el-search--simple-regexp-like-p)) (cl-every - (lambda (binding) (pcase binding ((or (pred symbolp) `(,(pred symbolp)) `(,(pred symbolp) ,_)) t))) + (lambda (binding) + (pcase binding ((or (pred symbolp) `(,(pred symbolp)) `(,(pred symbolp) ,_)) t))) bindings)))) (defun el-search--string-matcher (regexp-like) "Return a compiled match predicate for REGEXP-LIKE. -That's a predicate returning non-nil when the +This is a predicate returning non-nil when the `el-search-regexp-like-p' REGEXP-LIKE matches the (only) argument (that should be a string)." - (let ((match-bindings ()) regexp) - (pcase regexp-like - ((pred stringp) (setq regexp regexp-like)) - (`(,binds ,real-regexp) + (let ((regexp) (match-bindings ())) + (pcase-exhaustive regexp-like + ((pred el-search--simple-regexp-like-p) (setq regexp regexp-like)) + (`(,(and (pred listp) binds) ,real-regexp) (setq regexp real-regexp) (setq match-bindings binds))) - (if (functionp regexp-like) - (if (or (symbolp regexp-like) (byte-code-function-p regexp-like)) - regexp-like - (byte-compile regexp-like)) + (cl-flet ((wrap-let + (lambda (bindings body) + (if (null bindings) body + `(let ,bindings ,body))))) (byte-compile (let ((string (make-symbol "string"))) - `(lambda (,string) (let ,match-bindings (string-match ,regexp ,string)))))))) + `(lambda (,string) + ,(wrap-let + match-bindings + (if (functionp regexp) + `(funcall #',regexp ,string) + `(string-match + ,(pcase (eval regexp t) + ((and (pred stringp) s) s) + (_ (error "Expression in regexp-like doesn't eval to a string: %S" regexp))) + ,string))))))))) (el-search-defpattern string (&rest regexps) "Matches any string that is matched by all REGEXPS. -Any of the REGEXPS is `el-search-regexp-like-p'." +Any of the REGEXPS is `el-search-regexp-like-p'. + +If multiple REGEXPS are given, they don't need to match in order, +so (string \"bar\" \"foo\") matches \"foobar\" for example." (declare (heuristic-matcher (lambda (&rest regexps) (let ((matchers (mapcar #'el-search--string-matcher regexps))) @@ -2150,11 +2314,16 @@ Any of the REGEXPS is `el-search-regexp-like-p'." "Matches any symbol whose name is matched by all REGEXPS. Any of the REGEXPS is `el-search-regexp-like-p'. +This pattern is equivalent to + + `(and (pred symbolp) + (app symbol-name (string ,@regexps))) + Example: to replace all symbols with names starting with \"foo-\" to start with \"bar-\" instead, you would use `el-search-query-replace' with a rule like this: - (and (symbol \"\\\\`foo-\\\\(.*\\\\)\") s) > + (and (symbol (rx bos \"foo-\" (group (+ nonl)))) s) > (intern (concat \"bar-\" (match-string 1 (symbol-name s))))" (declare (heuristic-matcher (lambda (&rest regexps) @@ -2447,94 +2616,115 @@ absolute name must be matched by all of them." "Holds information for displaying a match count. The value is a list of elements - \(SEARCH BUFFER-CHARS-MOD-TICK BUFFER-MATCHES\) - -BUFFER-MATCHES is a stream of matches in this buffer. SEARCH is -the active search and BUFFER-CHARS-MOD-TICK the return value of -`buffer-chars-modified-tick' from when this stream had been -created.") - -(defun el-search-display-match-count () - "Display an x/y-style match count in the echo area." - (when (and el-search--success (not el-search--wrap-flag)) - (while-no-input - - ;; Check whether cached stream of buffer matches is still valid - (pcase el-search--buffer-match-count-data - (`(,(pred (eq el-search--current-search)) ,(pred (eq (buffer-chars-modified-tick))) . ,_)) - (_ - ;; (message "Refreshing match count data") (sit-for 1) - (redisplay) ;don't delay highlighting - (setq-local el-search--buffer-match-count-data - (let ((stream-of-buffer-matches - (seq-map #'cadr - (el-search--all-matches - (el-search-make-search - (el-search--current-pattern) - (let ((current-buffer (current-buffer))) - (lambda () (stream (list current-buffer))))))))) - (list - el-search--current-search - (buffer-chars-modified-tick) - stream-of-buffer-matches))))) - - (let ((pos-here (point)) (matches-<=-here 1) total-matches - (defun-bounds (or (el-search--bounds-of-defun) (cons (point) (point)))) - (matches-<=-here-in-defun 1) (total-matches-in-defun 0) - (largest-match-start-not-after-pos-here nil)) - (pcase-let ((`(,_ ,_ ,matches) el-search--buffer-match-count-data)) - (setq total-matches (let ((inhibit-message t)) (seq-length matches))) - (while (and (not (stream-empty-p matches)) (< (stream-first matches) (cdr defun-bounds))) - (when (<= (stream-first matches) pos-here) - (setq largest-match-start-not-after-pos-here (stream-first matches)) - (unless (= (stream-first matches) pos-here) - (cl-incf matches-<=-here))) - (when (<= (car defun-bounds) (stream-first matches)) - (cl-incf total-matches-in-defun) - (when (< (stream-first matches) pos-here) - (cl-incf matches-<=-here-in-defun))) - (stream-pop matches)) - (if (zerop total-matches) ;this can happen for el-search-this-sexp - (el-search--message-no-log "No matches") - (let* ((at-a-match-but-not-at-match-beginning - (and largest-match-start-not-after-pos-here - (and (< largest-match-start-not-after-pos-here pos-here) - (save-excursion - (goto-char largest-match-start-not-after-pos-here) - (<= pos-here (el-search--end-of-sexp)))))) - (at-a-match - (and largest-match-start-not-after-pos-here - (or (= pos-here largest-match-start-not-after-pos-here) - at-a-match-but-not-at-match-beginning)))) - (when (or at-a-match-but-not-at-match-beginning - (not at-a-match)) - (cl-decf matches-<=-here) - (cl-decf matches-<=-here-in-defun)) - (if at-a-match - (el-search--message-no-log - "%s %d/%d %s" - (let ((head (el-search-object-head el-search--current-search))) - (or (el-search-head-file head) - (buffer-name (el-search-head-buffer head)))) - matches-<=-here - total-matches - (propertize - (format (pcase (save-excursion - (goto-char (car defun-bounds)) - (el-search-read (current-buffer))) - (`(,a ,b . ,_) (format "(%s %%d/%%d)" - (truncate-string-to-width - (format "%S %S" a b) - 40 nil nil 'ellipsis))) - (_ "(%d/%d)")) - matches-<=-here-in-defun total-matches-in-defun) - 'face 'shadow)) - (el-search--message-no-log - (concat "[Not at a match] " - (if (= matches-<=-here total-matches) - (format "(%s/%s <-)" matches-<=-here total-matches) - (format "(-> %s/%s)" (1+ matches-<=-here) total-matches)))))))))) - (when quit-flag (el-search-keyboard-quit 'dont-quit)))) + \(SEARCH BUFFER-CHARS-MOD-TICK (POINT-MIN POINT-MAX) MATCHES\) + +MATCHES is a stream of matches in this buffer. The other values +are used to check validity.") + +(defun el-search-display-match-count (&optional just-count) + "Display an x/y-style match count in the echo area. +With optional argument JUST-COUNT non-nil, only return a string, +don't display anything" + (when (or just-count (and el-search--success (not el-search--wrap-flag))) + (prog1 + (while-no-input + (apply (if just-count #'format + (lambda (&rest args) + (setq el-search--last-message (apply #'el-search--message-no-log args)))) + (progn + + ;; Check whether cached stream of buffer matches is still valid + (pcase el-search--buffer-match-count-data + ((or + (and `(,(and (pred el-search-object-p) + (pred (eq el-search--current-search))) + . ,_) + (pred (eq el-search--this-session-match-count-data))) + `(,(pred (eq el-search--current-search)) + ,(pred (eq (buffer-chars-modified-tick))) + (,(pred (eq (point-min))) ,(pred (eq (point-max)))) . ,_))) + + (_ + ;; (message "Refreshing match count data") (sit-for 1) + (redisplay) ;don't delay highlighting + (setq-local el-search--buffer-match-count-data + (let ((stream-of-buffer-matches + (seq-map #'cadr + (el-search--all-matches + (el-search-make-search + (el-search--current-pattern) + (let ((current-buffer (current-buffer))) + (lambda () (stream (list current-buffer))))) + 'dont-copy)))) + (list + el-search--current-search + (buffer-chars-modified-tick) + `(,(point-min) ,(point-max)) + stream-of-buffer-matches))) + (setq el-search--this-session-match-count-data + el-search--buffer-match-count-data))) + + (let ((pos-here (point)) (matches-<=-here 1) total-matches + (defun-bounds (or (el-search--bounds-of-defun) (cons (point) (point)))) + (matches-<=-here-in-defun 1) (total-matches-in-defun 0) + (largest-match-start-not-after-pos-here nil)) + (pcase-let ((`(,_ ,_ ,_ ,matches) el-search--buffer-match-count-data)) + (setq total-matches (let ((inhibit-message t)) (seq-length matches))) + (while (and (not (stream-empty-p matches)) (< (stream-first matches) (cdr defun-bounds))) + (when (<= (stream-first matches) pos-here) + (setq largest-match-start-not-after-pos-here (stream-first matches)) + (unless (= (stream-first matches) pos-here) + (cl-incf matches-<=-here))) + (when (<= (car defun-bounds) (stream-first matches)) + (cl-incf total-matches-in-defun) + (when (< (stream-first matches) pos-here) + (cl-incf matches-<=-here-in-defun))) + (stream-pop matches)) + (if (zerop total-matches) + (list "(No matches)") + (let* ((at-a-match-but-not-at-match-beginning + (and largest-match-start-not-after-pos-here + (and (< largest-match-start-not-after-pos-here pos-here) + (save-excursion + (goto-char largest-match-start-not-after-pos-here) + (<= pos-here (el-search--end-of-sexp)))))) + (at-a-match + (and largest-match-start-not-after-pos-here + (or (= pos-here largest-match-start-not-after-pos-here) + at-a-match-but-not-at-match-beginning)))) + (when (or at-a-match-but-not-at-match-beginning + (not at-a-match)) + (cl-decf matches-<=-here) + (cl-decf matches-<=-here-in-defun)) + (if at-a-match + (let ((buffer-or-file + (let ((head (el-search-object-head el-search--current-search))) + (or (el-search-head-file head) + (buffer-name (el-search-head-buffer head)))))) + (if just-count + (list "%d/%d" matches-<=-here total-matches) + (list + "%s %d/%d %s" + buffer-or-file + matches-<=-here + total-matches + (propertize + (format (pcase (save-excursion + (goto-char (car defun-bounds)) + (el-search-read (current-buffer))) + (`(,a ,b . ,_) (format "(%s %%d/%%d)" + (truncate-string-to-width + (format "%S %S" a b) + 40 nil nil 'ellipsis))) + (_ "(%d/%d)")) + matches-<=-here-in-defun total-matches-in-defun) + 'face 'shadow)))) + (list + (concat (if (not just-count) "[Not at a match] " "") + (if (= matches-<=-here total-matches) + (format "(%s/%s <-)" matches-<=-here total-matches) + (format "(-> %s/%s)" (1+ matches-<=-here) total-matches)))))))))))) + (when quit-flag (el-search-keyboard-quit 'dont-quit))))) (defun el-search-hl-other-matches (matcher) "Highlight all visible matches. @@ -2567,18 +2757,47 @@ local binding of `window-scroll-functions'." (setq el-search-hl-other-overlays '()) (el-search-rehide-invisible)) -(defun el-search-hl-post-command-fun () - (pcase this-command - ('el-search-query-replace) - ((guard (el-search--entering-prefix-arg-p))) ; don't hide key input feedback - ('el-search-pattern (el-search-display-match-count)) - ((pred el-search-keep-session-command-p)) - (_ (unless el-search-keep-hl - (el-search-hl-remove) - (remove-hook 'post-command-hook 'el-search-hl-post-command-fun t) - (setq el-search--temp-buffer-flag nil) - (el-search-kill-left-over-search-buffers) - (el-search-close-quick-help-maybe))))) +(defvar el-search-hl-post-command-fun--last-animator nil) + +(defun el-search-hl-post-command-fun (&optional stop) + "Do cleanup when last search has obviously been terminated. + +If a search is active, arrange to count matches in the background +and show a match count when done. + +With argument STOP non-nil, force cleanup." + (cl-flet ((stop (lambda () + (el-search-hl-remove) + (remove-hook 'post-command-hook 'el-search-hl-post-command-fun t) + (setq el-search--temp-buffer-flag nil) + (el-search-kill-left-over-search-buffers) + (el-search-close-quick-help-maybe) + (setq el-search--this-session-match-count-data nil)))) + (pcase this-command + ((guard stop) (stop)) + ('el-search-query-replace) + ((guard (el-search--entering-prefix-arg-p))) ; don't hide key input feedback + ('el-search-pattern + (let ((el-search--search-pattern-1-do-fun + (if (eq this-command last-command) + el-search-hl-post-command-fun--last-animator + (setq el-search-hl-post-command-fun--last-animator + (el-search--make-display-animation-function + (lambda (icon) + (let ((inhibit-message nil)) + (setq el-search--last-message + (el-search--message-no-log + "%s %s" + (let ((head (el-search-object-head el-search--current-search))) + (or (el-search-head-file head) + (el-search-head-buffer head))) + icon))))))))) + (condition-case err (el-search-display-match-count) + (error + (el-search--message-no-log + "Error counting matches: %s" (error-message-string err)))))) + ((pred el-search-keep-session-command-p)) + (_ (unless el-search-keep-hl (stop)))))) (defun el-search--pending-search-p () (memq #'el-search-hl-post-command-fun post-command-hook)) @@ -2700,7 +2919,7 @@ make current." (if (numberp arg) arg 1))))) (when (and (numberp arg) (not match-pos)) (setq el-search--success nil) - (el-search-hl-post-command-fun) + (el-search-hl-post-command-fun 'stop) (goto-char (car el-search--search-origin)) (user-error "No match there")) (unless (or (numberp arg) (eq (point) match-pos)) @@ -2732,81 +2951,83 @@ be the current buffer, and the search will be resumed from point instead of the position where the search would normally be continued." (interactive "P") - (setq this-command 'el-search-pattern) + (el-search--set-this-command-refresh-message-maybe) (unless (eq last-command this-command) (el-search--set-search-origin-maybe) (el-search-compile-pattern-in-search el-search--current-search)) (el-search-protect-search-head - (unwind-protect - (let* ((old-current-buffer (current-buffer)) - (head (el-search-object-head el-search--current-search)) - (current-search-buffer - (or (el-search-head-buffer head) - (el-search--next-buffer el-search--current-search)))) - (when from-here - (cond - ((eq (current-buffer) current-search-buffer) - (setf (el-search-head-position head) (copy-marker (point)))) - ((and current-search-buffer (buffer-live-p current-search-buffer)) - (user-error "Please resume from buffer %s" (buffer-name current-search-buffer))) - (current-search-buffer - (user-error "Search head points to a killed buffer")))) - (let ((match nil) - (matcher (el-search--current-matcher)) - (heuristic-matcher (el-search--current-heuristic-matcher))) - (while (and (el-search-head-buffer head) - (not (setq match (with-current-buffer (el-search-head-buffer head) - (save-excursion - (goto-char (el-search-head-position head)) - (el-search--search-pattern-1 - matcher t nil heuristic-matcher)))))) - (el-search--next-buffer el-search--current-search)) - (if (not match) - (progn - (if (not (or el-search--success - (and from-here - (save-excursion - (goto-char (point-min)) - (el-search--search-pattern-1 matcher t nil heuristic-matcher))))) - (progn - (el-search--message-no-log "No matches") - (sit-for .7)) - (el-search--set-wrap-flag 'forward) - (let ((keys (car (where-is-internal 'el-search-pattern)))) - (el-search--message-no-log - (if keys - (format "No (more) matches - Hit %s to wrap search" - (key-description keys)) - "No (more) matches"))))) - (let (match-start) - ;; If (el-search-head-buffer head) is only a worker buffer, replace it - ;; with a buffer created with `find-file-noselect' - (with-current-buffer (el-search-head-buffer head) - (goto-char match) - (setq match-start (point)) - (when el-search--temp-file-buffer-flag - (let ((file-name buffer-file-name)) - (setq buffer-file-name nil) ;prevent f-f-ns to find this buffer - (let ((buffer-list-before (buffer-list)) - (new-buffer (find-file-noselect file-name))) - (setf (el-search-head-buffer head) new-buffer) - (unless (memq new-buffer buffer-list-before) - (with-current-buffer new-buffer - (setq-local el-search--temp-buffer-flag t))))))) - (pop-to-buffer (el-search-head-buffer head) el-search-display-next-buffer-action) - (goto-char match-start)) - (setf (el-search-object-last-match el-search--current-search) - (copy-marker (point))) - (setf (el-search-head-position head) - (copy-marker (point))) - (el-search-hl-sexp) - (unless (and (eq this-command last-command) - el-search--success - (eq (current-buffer) old-current-buffer)) - (el-search-hl-other-matches matcher)) - (setq el-search--success t))) - (el-search-prefix-key-maybe-set-transient-map)) - (el-search-kill-left-over-search-buffers)))) + (el-search-when-unwind + (unwind-protect + (let* ((old-current-buffer (current-buffer)) + (head (el-search-object-head el-search--current-search)) + (current-search-buffer + (or (el-search-head-buffer head) + (el-search--next-buffer el-search--current-search)))) + (when from-here + (cond + ((eq (current-buffer) current-search-buffer) + (setf (el-search-head-position head) (copy-marker (point)))) + ((and current-search-buffer (buffer-live-p current-search-buffer)) + (user-error "Please resume from buffer %s" (buffer-name current-search-buffer))) + (current-search-buffer + (user-error "Search head points to a killed buffer")))) + (let ((match nil) + (matcher (el-search--current-matcher)) + (heuristic-matcher (el-search--current-heuristic-matcher))) + (while (and (el-search-head-buffer head) + (not (setq match (with-current-buffer (el-search-head-buffer head) + (save-excursion + (goto-char (el-search-head-position head)) + (el-search--search-pattern-1 + matcher t nil heuristic-matcher)))))) + (el-search--next-buffer el-search--current-search)) + (if (not match) + (progn + (if (not (or el-search--success + (and from-here + (save-excursion + (goto-char (point-min)) + (el-search--search-pattern-1 matcher t nil heuristic-matcher))))) + (progn + (el-search--message-no-log "No matches") + (sit-for .7)) + (el-search--set-wrap-flag 'forward) + (let ((keys (car (where-is-internal 'el-search-pattern)))) + (el-search--message-no-log + (if keys + (format "No (more) matches - Hit %s to wrap search" + (key-description keys)) + "No (more) matches"))))) + (let (match-start) + ;; If (el-search-head-buffer head) is only a worker buffer, replace it + ;; with a buffer created with `find-file-noselect' + (with-current-buffer (el-search-head-buffer head) + (goto-char match) + (setq match-start (point)) + (when el-search--temp-file-buffer-flag + (let ((file-name buffer-file-name)) + (setq buffer-file-name nil) ;prevent f-f-ns to find this buffer + (let ((buffer-list-before (buffer-list)) + (new-buffer (find-file-noselect file-name))) + (setf (el-search-head-buffer head) new-buffer) + (unless (memq new-buffer buffer-list-before) + (with-current-buffer new-buffer + (setq-local el-search--temp-buffer-flag t))))))) + (pop-to-buffer (el-search-head-buffer head) el-search-display-next-buffer-action) + (goto-char match-start)) + (setf (el-search-object-last-match el-search--current-search) + (copy-marker (point))) + (setf (el-search-head-position head) + (copy-marker (point))) + (el-search-hl-sexp) + (unless (and (eq this-command last-command) + el-search--success + (eq (current-buffer) old-current-buffer)) + (el-search-hl-other-matches matcher)) + (setq el-search--success t))) + (el-search-prefix-key-maybe-set-transient-map)) + (el-search-kill-left-over-search-buffers)) + (el-search-hl-post-command-fun 'stop)))) (defun el-search-skip-directory (directory) "Skip all subsequent matches in files located under DIRECTORY." @@ -2827,14 +3048,14 @@ continued." (string-match-p "\\`\\.\\." (file-relative-name buffer-or-file-name directory))))) (el-search-prefix-key-maybe-set-transient-map)) -(defun el-search-pattern--interactive (&optional prompt) +(defun el-search-pattern--interactive (&optional prompt display-match-count) (list (if (or ;;Hack to make a pop-up buffer search from occur "stay active" (el-search--pending-search-p) (and (eq this-command last-command) (or el-search--success el-search--wrap-flag))) (el-search--current-pattern) - (el-search-read-pattern-for-interactive prompt)))) + (el-search-read-pattern-for-interactive prompt display-match-count)))) ;;;###autoload (defun el-search-pattern (pattern) @@ -2858,7 +3079,7 @@ types defined with `el-search-defpattern'. See `el-search-defined-patterns' for a list of defined patterns." (declare (interactive-only el-search-forward)) - (interactive (el-search-pattern--interactive)) + (interactive (el-search-pattern--interactive nil 'display-match-count)) (cond ((eq el-search--wrap-flag 'forward) (progn @@ -3028,7 +3249,7 @@ direction. See `el-search-forward' for details." "Search the current buffer backward for matches of PATTERN. See the command `el-search-pattern' for more information." (declare (interactive-only el-search-backward)) - (interactive (el-search-pattern--interactive)) + (interactive (el-search-pattern--interactive nil 'display-match-count)) (if (eq pattern (el-search--current-pattern)) (progn (el-search-compile-pattern-in-search el-search--current-search) @@ -3042,7 +3263,7 @@ See the command `el-search-pattern' for more information." ;; Make this buffer the current search buffer so that a following C-S ;; doesn't delete highlighting (el-search--next-buffer el-search--current-search)) - (setq this-command 'el-search-pattern) + (el-search--set-this-command-refresh-message-maybe) (when (eq el-search--wrap-flag 'backward) (el-search--set-wrap-flag nil) (el-search--message-no-log "[Wrapped backward search]") @@ -3120,7 +3341,7 @@ Use the normal search commands to seize the search." "Jump to the first match starting after `window-end'." (interactive) (el-search-barf-if-not-search-buffer) - (setq this-command 'el-search-pattern) + (el-search--set-this-command-refresh-message-maybe) (let ((here (point))) (goto-char (window-end)) (if (el-search--search-pattern-1 (el-search--current-matcher) t nil @@ -3134,7 +3355,7 @@ Use the normal search commands to seize the search." "Jump to the hindmost match starting before `window-start'." (interactive) (el-search-barf-if-not-search-buffer) - (setq this-command 'el-search-pattern) + (el-search--set-this-command-refresh-message-maybe) (let ((here (point))) (goto-char (window-start)) (if (el-search--search-backward-1 (el-search--current-matcher) t nil @@ -3322,6 +3543,8 @@ Prompt for a new pattern and revert." (define-key map [(shift tab)] #'el-search-occur-cycle) (define-key map [?p] #'el-search-occur-previous-match) (define-key map [?n] #'el-search-occur-next-match) + (define-key map [?r] #'el-search-occur-previous-match) + (define-key map [?s] #'el-search-occur-next-match) (define-key map [?e] #'el-search-edit-occur-pattern) (define-key map [?c ?n] #'el-search-occur-no-context) (define-key map [?c ?d] #'el-search-occur-defun-context) @@ -4370,8 +4593,13 @@ Don't save this buffer and all following buffers; don't ask again")))) (el-search-read (car el-search-query-replace-history))) (car el-search-query-replace-history) (car el-search-pattern-history)))))) - (el-search--read-pattern "Query replace pattern: " nil - 'el-search-query-replace-history))) + ;; We only want error hints so we don't bind el-search--display-match-count-in-prompt + (unwind-protect (minibuffer-with-setup-hook #'el-search-read-pattern-setup-mb + (let ((el-search--reading-input-for-query-replace t)) + (el-search--read-pattern "Query replace pattern: " nil + 'el-search-query-replace-history))) + (when (timerp el-search--mb-hints-timer) + (cancel-timer el-search--mb-hints-timer))))) from to read-from read-to) (with-temp-buffer (emacs-lisp-mode) diff --git a/packages/sokoban/sokoban.el b/packages/sokoban/sokoban.el index 4698450..128d59a 100644 --- a/packages/sokoban/sokoban.el +++ b/packages/sokoban/sokoban.el @@ -1,11 +1,13 @@ -;;; sokoban.el --- Implementation of Sokoban for Emacs. +;;; sokoban.el --- Implementation of Sokoban for Emacs. -*- lexical-binding: t -*- -;; Copyright (C) 1998, 2013, 2017 Free Software Foundation, Inc. +;; Copyright (C) 1998, 2013, 2017, 2019 Free Software Foundation, Inc. ;; Author: Glynn Clements <glynn.cleme...@xemacs.org> ;; Maintainer: Dieter Deyke <dieter.de...@gmail.com> -;; Version: 1.4.6 -;; Package-Requires: ((emacs "23.1")) +;; Version: 1.4.8 +;; Comment: While we set lexical-binding, it currently doesn't make use +;; of closures, which is why it can still work in Emacs-23.1. +;; Package-Requires: ((emacs "23.1") (cl-lib "0.5")) ;; Created: 1997-09-11 ;; Keywords: games ;; Package-Type: multi @@ -52,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) (require 'xml) @@ -508,6 +509,8 @@ static char * player_on_target_xpm[] = { (define-key map "r" 'sokoban-restart-level) (define-key map "g" 'sokoban-goto-level) (define-key map "F" 'fit-frame-to-buffer) + (define-key map "s" 'sokoban-save) + (define-key map "l" 'sokoban-load) (define-key map [left] 'sokoban-move-left) (define-key map [right] 'sokoban-move-right) @@ -536,7 +539,7 @@ static char * player_on_target_xpm[] = { (dolist (SokobanLevels tree) (dolist (LevelCollection (xml-get-children SokobanLevels 'LevelCollection)) (dolist (Level (xml-get-children LevelCollection 'Level)) - (incf n) + (cl-incf n) (insert (format ";LEVEL %d\n" n)) (dolist (L (xml-get-children Level 'L)) (insert (car (xml-node-children L))) @@ -561,7 +564,7 @@ static char * player_on_target_xpm[] = { (setq r 0) (while (not (or (eobp) (looking-at sokoban-comment-regexp))) - (incf r) + (cl-incf r) (setq sokoban-height (max sokoban-height r) sokoban-width (max sokoban-width (- (line-end-position) (line-beginning-position)))) (forward-line)))) @@ -626,10 +629,10 @@ static char * player_on_target_xpm[] = { (cond ((or (eq c sokoban-target) (eq c sokoban-player-on-target)) - (incf sokoban-targets)) + (cl-incf sokoban-targets)) ((eq c sokoban-block-on-target) - (incf sokoban-targets) - (incf sokoban-done)) + (cl-incf sokoban-targets) + (cl-incf sokoban-done)) ((= c ?\040) ;; treat space characters in level file as floor (aset (aref sokoban-level-map y) x sokoban-floor))))))) @@ -650,14 +653,14 @@ static char * player_on_target_xpm[] = { (let ((y sokoban-score-y)) (dolist (string (list (format "Moves: %05d" sokoban-moves) (format "Pushes: %05d" sokoban-pushes) - (format "Done: %d/%d" + (format "Done: %d/%d " sokoban-done sokoban-targets))) (let* ((len (length string))) (dotimes (x len) (gamegrid-set-cell (+ sokoban-score-x x) y (aref string x)))) - (incf y))) + (cl-incf y))) (setq mode-line-format (format "Sokoban: Level: %d/%d Moves: %05d Pushes: %05d Done: %d/%d" sokoban-level (length sokoban-level-data) sokoban-moves sokoban-pushes @@ -666,13 +669,13 @@ static char * player_on_target_xpm[] = { (defun sokoban-add-move (dx dy) (push (list 'move dx dy) sokoban-undo-list) - (incf sokoban-moves) + (cl-incf sokoban-moves) (sokoban-draw-score)) (defun sokoban-add-push (dx dy) (push (list 'push dx dy) sokoban-undo-list) - (incf sokoban-moves) - (incf sokoban-pushes) + (cl-incf sokoban-moves) + (cl-incf sokoban-pushes) (sokoban-draw-score)) (defun sokoban-targetp (x y) @@ -714,21 +717,21 @@ static char * player_on_target_xpm[] = { (y (+ sokoban-y dy))) (sokoban-set-floor x y) (if (sokoban-targetp x y) - (decf sokoban-done)) + (cl-decf sokoban-done)) (sokoban-set-block sokoban-x sokoban-y) (if (sokoban-targetp sokoban-x sokoban-y) - (incf sokoban-done))) + (cl-incf sokoban-done))) (setq sokoban-x (- sokoban-x dx)) (setq sokoban-y (- sokoban-y dy)) (sokoban-set-player sokoban-x sokoban-y) - (decf sokoban-pushes) - (decf sokoban-moves)) + (cl-decf sokoban-pushes) + (cl-decf sokoban-moves)) ((eq type 'move) (sokoban-set-floor sokoban-x sokoban-y) (setq sokoban-x (- sokoban-x dx)) (setq sokoban-y (- sokoban-y dy)) (sokoban-set-player sokoban-x sokoban-y) - (decf sokoban-moves)) + (cl-decf sokoban-moves)) (t (message "Invalid entry in sokoban-undo-list"))) (sokoban-draw-score)))) @@ -752,14 +755,14 @@ static char * player_on_target_xpm[] = { (cond ((or (eq cc sokoban-floor) (eq cc sokoban-target)) (if (sokoban-targetp x y) - (decf sokoban-done)) + (cl-decf sokoban-done)) (sokoban-set-block xx yy) (sokoban-set-player x y) (sokoban-set-floor sokoban-x sokoban-y) (setq sokoban-x x sokoban-y y) (if (sokoban-targetp xx yy) - (incf sokoban-done)) + (cl-incf sokoban-done)) (sokoban-add-push dx dy) (cond ((= sokoban-done sokoban-targets) (let ((level sokoban-level)) @@ -867,14 +870,58 @@ static char * player_on_target_xpm[] = { (setq sokoban-level 0) (sokoban-next-level)) -(put 'sokoban-mode 'mode-class 'special) +(defvar sokoban-grid-state) + +(defconst sokoban-state-variables '( + sokoban-level + sokoban-level-map + sokoban-targets + sokoban-x + sokoban-y + sokoban-moves + sokoban-pushes + sokoban-done + sokoban-undo-list + sokoban-grid-state + )) +(defun sokoban-save (filename) + "Save current Sokoban state." + (interactive "FSave file: ") + (let ((buf (current-buffer))) + (setq sokoban-grid-state nil) + (dotimes (y sokoban-height) + (dotimes (x sokoban-width) + (push (gamegrid-get-cell x y) sokoban-grid-state))) + (setq sokoban-grid-state (reverse sokoban-grid-state)) + (with-temp-file filename + (dolist (var sokoban-state-variables) + (print + (with-current-buffer buf (eval var)) + (current-buffer)))))) + +(defun sokoban-load (filename) + "Restore saved Sokoban state." + (interactive "fLoad file: ") + (let ((buf (current-buffer))) + (with-temp-buffer + (insert-file-contents filename) + (goto-char (point-min)) + (dolist (var sokoban-state-variables) + (let ((value (read (current-buffer)))) + (with-current-buffer buf (set var value)))))) + (dotimes (y sokoban-height) + (dotimes (x sokoban-width) + (gamegrid-set-cell x y (pop sokoban-grid-state)))) + (sokoban-draw-score)) (easy-menu-define sokoban-popup-menu nil "Popup menu for Sokoban mode." '("Sokoban Commands" ["Restart this level" sokoban-restart-level] ["Start new game" sokoban-start-game] ["Go to specific level" sokoban-goto-level] - ["Fit frame to buffer" fit-frame-to-buffer])) + ["Fit frame to buffer" fit-frame-to-buffer] + ["Save current state" sokoban-save] + ["Restore saved state" sokoban-load])) (define-key sokoban-mode-map [down-mouse-3] sokoban-popup-menu) (define-derived-mode sokoban-mode special-mode "Sokoban" @@ -904,6 +951,8 @@ sokoban-mode keybindings: \\[sokoban-restart-level] Restarts the current level \\[sokoban-goto-level] Jumps to a specified level \\[fit-frame-to-buffer] Fit frame to buffer +\\[sokoban-save] Save current state +\\[sokoban-load] Restore saved state \\[sokoban-move-left] Move one square to the left \\[sokoban-move-right] Move one square to the right \\[sokoban-move-up] Move one square up