code.delx.au - gnu-emacs-elpa/blob - packages/ace-window/avy.el

   1 ;;; avy.el --- set-based completion -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; For a full copy of the GNU General Public License
  20 ;; see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Given a LIST and KEYS, `avy-tree' will build a balanced tree of
  25 ;; degree B, where B is the length of KEYS.
  26 ;;
  27 ;; The corresponding member of KEYS is placed in each internal node of
  28 ;; the tree.  The leafs are the members of LIST.  They can be obtained
  29 ;; in the original order by traversing the tree depth-first.
  30
  31 ;;; Code:
  32
  33 (defmacro avy-multipop (lst n)
  34   "Remove LST's first N elements and return them."
  35   `(if (<= (length ,lst) ,n)
  36        (prog1 ,lst
  37          (setq ,lst nil))
  38      (prog1 ,lst
  39        (setcdr
  40         (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
  41         nil))))
  42
  43 (defun avy-tree (lst keys)
  44   "Coerce LST into a balanced tree.
  45 The degree of the tree is the length of KEYS.
  46 KEYS are placed appropriately on internal nodes."
  47   (let ((len (length keys)))
  48     (cl-labels
  49         ((rd (ls)
  50            (let ((ln (length ls)))
  51              (if (< ln len)
  52                  (cl-pairlis keys
  53                              (mapcar (lambda (x) (cons 'leaf x)) ls))
  54                (let ((ks (copy-sequence keys))
  55                      res)
  56                  (dolist (s (avy-subdiv ln len))
  57                    (push (cons (pop ks)
  58                                (if (eq s 1)
  59                                    (cons 'leaf (pop ls))
  60                                  (rd (avy-multipop ls s))))
  61                          res))
  62                  (nreverse res))))))
  63       (rd lst))))
  64
  65 (defun avy-subdiv (n b)
  66   "Distribute N in B terms in a balanced way."
  67   (let* ((p (1- (floor (log n b))))
  68          (x1 (expt b p))
  69          (x2 (* b x1))
  70          (delta (- n x2))
  71          (n2 (/ delta (- x2 x1)))
  72          (n1 (- b n2 1)))
  73     (append
  74      (make-list n1 x1)
  75      (list
  76       (- n (* n1 x1) (* n2 x2)))
  77      (make-list n2 x2))))
  78
  79 (defun avy-traverse (tree walker &optional recur-key)
  80   "Traverse TREE generated by `avy-tree'.
  81 WALKER is a function that takes KEYS and LEAF.
  82
  83 RECUR-KEY is used in recursion.
  84
  85 LEAF is a member of LST argument of `avy-tree'.
  86
  87 KEYS is the path from the root of `avy-tree' to LEAF."
  88   (dolist (br tree)
  89     (let ((key (cons (car br) recur-key)))
  90       (if (eq (cadr br) 'leaf)
  91           (funcall walker key (cddr br))
  92         (avy-traverse (cdr br) walker key)))))
  93
  94 (defun avy-read (tree display-fn cleanup-fn)
  95   "Select a leaf from TREE using consecutive `read-char'.
  96
  97 DISPLAY-FN should take CHAR and LEAF and signify that LEAFs
  98 associated with CHAR will be selected if CHAR is pressed.  This is
  99 commonly done by adding a CHAR overlay at LEAF position.
 100
 101 CLEANUP-FN should take no arguments and remove the effects of
 102 multiple DISPLAY-FN invokations."
 103   (catch 'done
 104     (while tree
 105       (avy-traverse tree display-fn)
 106       (let ((char (read-char))
 107             branch)
 108         (funcall cleanup-fn)
 109         (if (setq branch (assoc char tree))
 110             (if (eq (car (setq tree (cdr branch))) 'leaf)
 111                 (throw 'done (cdr tree)))
 112           (signal 'user-error (list "No such candidate" char))
 113           (throw 'done nil))))))
 114
 115 (provide 'avy)
 116
 117 ;;; avy.el ends here