From 0dbf837cbf94daf44a7ae6b7c237d7fd0618fb62 Mon Sep 17 00:00:00 2001 From: Madeleine Sydney Date: Tue, 19 Nov 2024 18:53:18 -0700 Subject: [PATCH] init --- README.org | 4 ++ evil-leap.el | 114 +++++++++++++++++++++++++++++++++ scratch.el | 177 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 295 insertions(+) create mode 100644 README.org create mode 100644 evil-leap.el create mode 100644 scratch.el diff --git a/README.org b/README.org new file mode 100644 index 0000000..f7188b9 --- /dev/null +++ b/README.org @@ -0,0 +1,4 @@ +#+title: evil-leap +#+author: Madeleine Sydney + +Evil's answer to Neovim's answer to the mouse diff --git a/evil-leap.el b/evil-leap.el new file mode 100644 index 0000000..da8840b --- /dev/null +++ b/evil-leap.el @@ -0,0 +1,114 @@ +;;; evil-leap.el --- Evil's answer to Neovim's answer to the mouse -*- lexical-binding: t; -*- +;; +;; Copyright (C) 2024 Madeleine Sydney +;; +;; Author: Madeleine Sydney +;; Maintainer: Madeleine Sydney +;; Created: October 06, 2024 +;; Modified: October 06, 2024 +;; Version: 0.0.1 +;; Keywords: evil movement +;; Homepage: https://github.com/crumbtoo/leap.el +;; Package-Requires: ((emacs "24.3")) +;; +;; This file is not part of GNU Emacs. +;; +;;; Commentary: +;; +;; +;; +;;; Code: + +(defcustom evil-leap-safe-labels + (string-to-list "sfnut/SFNLHMUGTZ?") + "TODO A list of characters that you will never use immediately after an evil-leap +jump." + :group 'evil-leap + :type "List of characters") + +(defcustom evil-leap-labels + (string-to-list "sfnjklhodweimbuyvrgtaqpcxz/SFNJKLHODWEIMBUYVRGTAQPCXZ?") + ;; (append evil-leap-safe-labels + ;; (string-to-list "jklhodweimbyvrgaqpcxzJKODWEIBYVRAQPCX")) + "TODO A list of characters to use as labels." + :group 'evil-leap + :type "List of characters") + +;; (defun evil-leap--collect-keys (&optional forward?) +;; (let ((collected-keys nil)) +;; (dolist (i '(0 1) collected-keys) +;; (let ((prompt (format ">%s" (mapconcat #'char-to-string collected-keys)))) +;; (appendq! collected-keys (list (evil-read-key prompt))))))) + +(defcustom evil-leap-character-aspect-ratio + 0.3 + "TODO" + :group 'evil-leap + :type "Number") + +(defcustom evil-leap-equivalence-classes '((?\s ?\n ?\t ?\r)) + "TODO" + :group 'evil-leap + :type "List of lists of characters") + +(defun evil-leap--gather-targets-forward (regexp) + (let ((end-of-visible (window-end)) + targets) + (save-excursion + (while (re-search-forward regexp end-of-visible t) + (save-excursion + (goto-char (match-beginning 0)) + (push (list (point) (current-column) (line-number-at-pos)) + targets)))) + (reverse targets))) + +(defun evil-leap--euclidean-distance (x1 y1 x2 y2) + (let* ((width (abs (- x1 x2))) + (height (* (abs (- y1 y2)) + evil-leap-character-aspect-ratio)) + (hypotenuse (sqrt (+ (* width width) + (* height height))))) + hypotenuse)) + +(defun evil-leap--sort-by-euclidean-distance-from-point (targets) + (let ((point-x (current-column)) + (point-y (line-number-at-pos))) + (sort targets + :lessp + (lambda (pos1 pos2) + (pcase-let ((`(,_ ,pos1-x ,pos1-y) pos1) + (`(,_ ,pos2-x ,pos2-y) pos2)) + (< (evil-leap--euclidean-distance point-x point-y pos1-x pos1-y) + (evil-leap--euclidean-distance point-x point-y pos2-x pos2-y))))))) + +;; (defun evil-leap--label-targets (targets) +;; (let ((ht (make-hash-table :test 'equal))) +;; (dolist (c )))) + +;; define-inline? +(defun evil-leap-jump-to (target) + (goto-char (car target))) + +(defun evil-leap (&rest args) + "TODO Something something something. + +Keyword arguments + :backward-p BOOL + :action ACTION + :targets TARGETS A list of targets, or a Lisp procedure returning such a + list. Each target should be a list of form + (POS LINE COLUMN . XS)." + (let ((backward-p (plist-get args :backward-p)) + (action (or (plist-get args :action) #'evil-leap-jump-to)) + (targets (plist-get args :targets))) + )) + +(evil-define-motion evil-leap-s (count keys) + "TODO" + :jump t + :type 'exclusive + (interactive) + (evil-leap--collect-keys)) + +(provide 'evil-leap) +;;; evil-leap.el ends here diff --git a/scratch.el b/scratch.el new file mode 100644 index 0000000..9b3589c --- /dev/null +++ b/scratch.el @@ -0,0 +1,177 @@ +;; -*- lexical-binding: t -*- +;;;; core ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'ht) + +(defun syd/remove-highlights () + (remove-overlays nil nil 'category 'evil-leap)) + +(defun syd/add-label (pos label) + "TODO returns overlay" + ;; The label shall be displayed two characters /after/ `pos'. This ensures + ;; the user is able to see the entirety of the target; that is, the first + ;; character, located at `pos', and the second, immediately following. + (let ((overlay (make-overlay (+ pos 2) (+ pos 3))) + (label-string (string label))) + (put-text-property 0 1 'face (list :background "red") label-string) + (overlay-put overlay 'category 'evil-leap) + (overlay-put overlay 'before-string label-string) + ;; Normally, we want the labels to cover the buffer's text, rather than + ;; shifting it to the side; however, doing so unconditionally will cover + ;; newlines, collapsing multiple visual lines onto one. + (unless (= (char-after (+ pos 2)) ?\n) + (overlay-put overlay 'invisible t)) + overlay)) + +(defun syd/label-targets-safe (targets) + "TODO returns a hash table mapping labels to targets and overlays" + ;; Nasty! While I'd prefer to iterate over `zip evil-leap-safe-labels + ;; targets`, this isn't Haskell; each iteration through `targets', we pop + ;; `labels'. + (let ((labels evil-leap-safe-labels) + (labeled-targets (ht-create 'eq))) + ;; The first target is assigned the label -1, to indicate that it can be + ;; auto-jumped to. The remaining targets are labeled as you'd expect. + (ht-set! labeled-targets -1 (cons (car targets) nil)) + (dolist (tgt (cdr targets) labeled-targets) + (pcase-let* ((`(,pos ,_ ,_) tgt) + (lbl (pop labels)) + (overlay (syd/add-label pos lbl))) + (ht-set! labeled-targets lbl (cons tgt overlay)))))) + +(defun syd/label-targets-unsafe (targets) + "TODO returns a hash table mapping labels to targets and overlays" + ;; TODO: space labels don't work + (let ((labels (append evil-leap-labels (-cycle '(?\s)))) + (labeled-targets (ht-create 'eq))) + (dolist (tgt targets labeled-targets) + (pcase-let* ((`(,pos ,_ ,_) tgt) + (lbl (pop labels)) + (overlay (syd/add-label pos lbl))) + (ht-set! labeled-targets lbl (cons tgt overlay)))))) + +(defun syd/label-targets (targets) + "TODO returns a hash table mapping labels to targets and overlays" + (let ((safe? (<= (length targets) (length evil-leap-safe-labels)))) + ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ;; FIXME: I think this should be (+ 1 (length evil-leap-safe-labels)). + (if safe? + (syd/label-targets-safe targets) + (syd/label-targets-unsafe targets)))) + +(defun syd/do-auto-jump (action labeled-targets) + (when-let ((tgt-and-overlay (ht-get labeled-targets -1))) + (funcall action (car tgt-and-overlay)))) + +(defun syd/select-targets (opts targets) + ;; Safe labels are preferred, but are not available when there are more + ;; targets than safe labels. + (unwind-protect + (let ((labeled-targets (syd/label-targets targets)) + (action (plist-get opts :action))) + (syd/do-auto-jump action labeled-targets) + (if-let ((given-key (evil-read-key)) + (selected-target-and-overlay (ht-get labeled-targets given-key))) + (funcall action (car selected-target-and-overlay)) + (error "TODO no such label"))) + (syd/remove-highlights))) + +(defun syd/select-labeled-targets (opts labeled-targets) + (unwind-protect + (let ((action (plist-get opts :action))) + (syd/do-auto-jump action labeled-targets) + (if-let ((given-key (evil-read-key)) + (selected-target-and-overlay (ht-get labeled-targets given-key))) + (funcall action (car selected-target-and-overlay)) + (error "TODO no such label")))) + (syd/remove-highlights)) + +;;;; gathering ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun syd/insert-branch-target (table second-char target) + (ht-set! table + second-char + (cons target (ht-get table second-char)))) + +(defun syd/gather-branches-forward (first-char) + "Traverse each visible two-character sequence of FIRST-CHAR followed by +another character. The returned value will be a hash map, mapping discovered +second characters to a list of targets representing their occurences." + (let ((end-of-visible (window-end)) + (pattern (rx-to-string `(seq ,first-char (group anychar)))) + ;; (pattern (string first-char ?.)) + (table (ht-create 'equal))) + (save-excursion + (while (re-search-forward pattern end-of-visible t) + ;; We are forced to save-excursion a second time, lest we enter a + ;; feedback loop, where `re-search-forward' moves to a match, and + ;; `goto-char' jumps to a position *preceding* the match. + (save-excursion + (goto-char (match-beginning 0)) + (let ((second-char (aref (match-string 1) 0)) ; string->char + (target (list (point) (current-column) (line-number-at-pos)))) + (syd/insert-branch-target table second-char target))))) + ;; Reverse each list of targets. + (ht-each (lambda (k v) (ht-set! table k (reverse v))) + table) + table)) + +;;;; entry point ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defun syd/gather-targets-forward (regexp) +;; (let ((end-of-visible (window-end)) +;; targets) +;; (save-excursion +;; (while (re-search-forward regexp end-of-visible t) +;; ;; We are forced to save-excursion a second time, lest we enter a +;; ;; feedback loop, where `re-search-forward' moves to a match, and +;; ;; `goto-char' jumps to a position *preceding* the match. +;; (save-excursion +;; (goto-char (match-beginning 0)) +;; (push (list (point) (current-column) (line-number-at-pos)) +;; targets)))) +;; (reverse targets))) + +(defun syd/label-branch-targets (branches) + "Mutate BRANCHES by calling `syd/label-targets' on each value, and replacing +it with the result." + (ht-each (lambda (k tgts) + (ht-set! branches k (syd/label-targets tgts))) + branches)) + +(defun syd/unlabel-other-branches (second-char branches) + "Delete every overlay referenced by BRANCHES, *except* those under the branch +with key SECOND-CHAR." + (ht-each (lambda (k labeled-tgts) + (unless (eq k second-char) + (ht-each (lambda (lbl tgt-and-overlay) + ;; cdr may be nil in precense of auto-jump. + (when-let ((overlay (cdr tgt-and-overlay))) + (delete-overlay overlay))) + labeled-tgts))) + branches)) + +(evil-define-motion syd/leap-forward (count) + "TODO" + :jump t + :type 'exclusive + (interactive) + (let* ((action (lambda (x) (goto-char (car x)))) + (first-char (evil-read-key)) + (branches (syd/gather-branches-forward first-char)) + (_ (syd/label-branch-targets branches)) + (second-char (evil-read-key)) + (_ (syd/unlabel-other-branches second-char branches)) + (labeled-targets (ht-get branches second-char))) + ;; (print branches) + ;; (print labeled-targets) + ;; nil + (syd/select-labeled-targets + (list :action (lambda (x) (goto-char (car x)))) + labeled-targets) + )) + +;; (defun syd/demo-targets (regexp) +;; (syd/select-targets +;; (list :action (lambda (x) (goto-char (car x)))) +;; (syd/gather-targets-forward regexp)))