;;; fun-names.el --- Find names -*- lexical-binding: t -*-
;;
;; Copyright (C) 2024 Free Software Foundation, Inc.
;;
;; Author: Emanuel Berg <incal@dataswamp.org>
;; Created: 2024-07-27
;; Keywords: lisp, matching, tools
;; License: GPL3+
;; Package-Requires: ((emacs "28.1"))
;; URL: https://dataswamp.org/~incal/fun-names.el
;; Version: 6.15.7
;;
;;; Commentary:
;;
;; __________________________________________________________
;; `-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-
;;
;;            fun-names.el -- Find names in Emacs
;;
;; __________________________________________________________
;; `-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-`-
;;
;; Use `fun-names' with a function symbol, a function name or
;; just an arbitrary sequence of words, it will then output a
;; table of other functions that have the same words in their
;; names.
;;
;; As an example, here is the top 10 rows for "end of", as in
;; `end-of-sexp'. As one sees, if you remember just two words
;; that is often enough to find the rest, by using fun-names.
;;
;;         ---------------------------------------
;;         POS          SYMBOL          WRDS  H  P
;;         ---------------------------------------
;;          1. end-of-line              0.80  2  3
;;          2. end-of-buffer            0.80  2  3
;;          3. end-of-defun             0.80  2  3
;;          4. end-of-sexp              0.80  2  3
;;          5. end-of-thing             0.80  2  3
;;          6. end-of-paragraph-text    0.67  2  3
;;          7. end-of-visual-line       0.67  2  3
;;          8. end-of-visible-line      0.67  2  3
;;          9. markdown-end-of-subtree  0.67
;;         10. outline-end-of-subtree   0.67
;;         ---------------------------------------
;;
;; See the `fun-names--words' for how the result is computed.
;;
;; Another use case can be for you to find such functions and
;; put them to use instead of writing new, that are the same.
;;
;; Also try `fun-names-short', faster and without a change of
;; buffer needed.
;;
;; Also see:
;;
;;   `fun-names-vars'       examine the variable names
;;   `fun-names-vars-short' short version
;;
;;   `fun-names-fav'        functions AND variables, the -fav
;;   `fun-names-fav-short'
;;
;;   `fun-names-all'        examine all symbol names
;;   `fun-names-all-short'
;;
;; ----------------------------------------------------------
;;
;; Basic interactive use:
;;
;;   M-x fun-names RET RET (input is `symbol-at-point')
;;   M-x fun-names RET split string buffer RET
;;   M-x fun-names-short RET kill-current-buffer RET
;;
;; ----------------------------------------------------------
;;
;; To enable shortcuts for Emacs Lisp, do for example:
;;
;;   (keymap-set emacs-lisp-mode-map "M-p" #'fun-names)
;;   (keymap-set emacs-lisp-mode-map "M-P" #'fun-names-short)
;;
;; ----------------------------------------------------------
;;
;;; Code:

(require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(require 'thingatpt)

;; interface

(defun fun-names--interface ()
  (let* ((def (symbol-at-point))
         (ps  (format-prompt "fun word(s)" def))
         (fun (read-string ps nil nil def)))
    (list fun)))

;; find functions (#'functionp)

(defun fun-names (fun &optional limit report pred)
  "Examine if the words in FUN appear in any function names.

If the proximity is higher than LIMIT (which defaults to 0.5),
then function function is included in the computation.

If REPORT is

  0   - no report just return result
  8   - make a report,  8 lines long
  nil - make a report, 23 lines ling (default)
  t   - make a report, the full size

PRED is the function to sort the obarray (default `functionp').

Also try: `fun-names-short'

Proximity is based on the same words appearing in the same order."
  (interactive (fun-names--interface))
  (when (symbolp fun)
    (setq fun (symbol-name fun)))
  (unless limit
    (setq limit 0.5))
  (unless report
    (setq report 23))
  (unless pred
    (setq pred #'functionp))
  (let ((similar)
        (estr)
        (ratio)
        (bonus))
    (mapatoms
      (lambda (e)
        (when (funcall pred e)
          (setq estr (symbol-name e))
          (if (string= estr fun)
              (setq ratio 0)
            (setq ratio (fun-names--words-same fun estr)))
          (when (and (<= limit ratio)
                     (<=  ratio 1))
            (setq bonus (fun-names--words-same-pos fun estr))
            (push `(,e ,ratio ,@bonus) similar)))))
    (let* ((sorted (cl-sort similar #'fun-names--words>)))
      (if (and (numberp report) (zerop report))
          sorted
        (fun-names--report sorted (list fun pred) report)))))

(defun fun-names-short (fun &optional _limit _report pred)
  "Tell what function has a name the closest to FUN.
FUN and PRED are used as in `fun-names'.

See `fun-names'."
  (interactive (fun-names--interface))
  (let ((rec (car (fun-names fun nil 0 pred))))
    (if rec
        (pcase-let ((`(,n ,r ,_b ,_p) rec))
          (message (format "%s (%.2f)" n r)))
      (message "unique"))))

;; find variables (#'boundp)

(defun fun-names-vars (fun &optional limit report _pred)
  "Same as `fun-names', but consider variable names.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names fun limit report #'boundp))

(defun fun-names-vars-short (fun &optional limit report _pred)
  "Same as `fun-names-short', but consider variable names.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names-short fun limit report #'boundp))

;; find functions AND variables

(defun fun-names--fun-or-var-p (s)
  (and (symbolp s) (or (functionp s) (boundp s))))

(defun fun-names-fav (fun &optional limit report _pred)
  "Same as `fun-names', but consider functions _and_ variables.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names fun limit report #'fun-names--fun-or-var-p))

(defun fun-names-fav-short (fun &optional limit report _pred)
  "Same as `fun-names-short', but consider functions _and_ variables.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names-short fun limit report #'fun-names--fun-or-var-p))

;; find everything (#'always)

(defun fun-names-all (fun &optional limit report _pred)
  "Same as `fun-names', but consider every symbol name.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names fun limit report #'always))

(defun fun-names-all-short (fun &optional limit report _pred)
  "Same as `fun-names-short', but consider every symbol name.
FUN, LIMIT, REPORT are used as in `fun-names'."
  (interactive (fun-names--interface))
  (fun-names-short fun limit report #'always))

;; output

(defun fun-names--data-string (i n r b p &optional pad)
  (unless pad
    (setq pad 0))
  (unless (stringp n)
    (setq n (symbol-name n)))
  (let ((bp (if (< 0 b) (format " %2d %2d" b p) ""))
        (pad-str (make-string (- pad (length n)) ?\s)))
    (format "%2d. %s%s %.2f%s\n" i n pad-str r bp)))

(defun fun-names--report (data strs &optional lines)
  (if (not data)
      (message "unique")
    (when (numberp lines)
      (setq data (take lines data)))
    (let* ((buf (get-buffer-create "*fun-names*"))
           (pad (1+ (apply #'max (mapcar (lambda (e) (length (symbol-name (car e)))) data))))
           (lab-str "SYMBOL")
           (lab-pad-char ?\ )
           (lab-pad-len       (- pad (length lab-str)))
           (lab-pad-len-left  (/ lab-pad-len 2))
           (lab-pad-len-right (+ lab-pad-len-left (mod lab-pad-len 2)))
           (lab-pad-left  (make-string lab-pad-len-left  lab-pad-char))
           (lab-pad-right (make-string lab-pad-len-right lab-pad-char))
           (lab (format "POS %s%s%s WRDS  H  P\n" lab-pad-left lab-str lab-pad-right))
           (hl  (format "%s\n" (make-string (1- (length lab)) ?-))))
      (with-current-buffer buf
        (erase-buffer)
        (insert hl lab hl)
        (cl-loop
           for i from 1
           for (n r b p) in data do
             (insert (fun-names--data-string i n r b p pad)))
        (insert hl)
        (goto-char (point-min))
        (fun-names--report-insert-metadata strs))
      (pop-to-buffer buf))))

(defun fun-names--report-insert-metadata (strs)
  (save-mark-and-excursion
    (goto-char (point-min))
    (goto-char (pos-eol 3))
    (let* ((col      (current-column))
           (win      (window-width))
           (str1     (format "keys: %s"   (car  strs)))
           (str2     (format "pred: %s" (cadr strs)))
           (str1-len (length str1))
           (str2-len (length str2))
           (pad-len1 (max 0 (- win str1-len col 1)))
           (pad-len2 (max 0 (- win str2-len col 1)))
           (pad-str1 (make-string pad-len1 ?\ ))
           (pad-str2 (make-string pad-len2 ?\ )))
      (insert pad-str2 str2)
      (goto-char (pos-eol -1))
      (insert pad-str1 str1))))

;;     ______________________________
;;    //````````````````````````````\\
;;    $.       new word order        %
;;    $.       --------------        %
;;    $.                             %
;;    $. string proximity by words   %
;;    $. as a non-strict total order %
;;    \\____________________________//
;;     `^^^^^^^^^^^^^^^^^^^^^^^^^^^^`

(defun fun-names--words-from-string (s)
  (split-string (downcase s) "[^[:alnum:]]+" t))

(defun fun-names--words (s1 s2)
  "Compare the he words of S1 to those of S2.
Return a list (WRDS H P).
WRDS - words. How many of the words are shared.
H - hits. The number of shared words that also appear in the
same position. This is the tie braker if WRDS are equal.
P - points. Computed based on where non-shared words appear.
Early non-shared words are considered worse than late.
This is the tie braker if WRDS as well as H are equal."
  (unless (listp s1)
    (setq s1 (fun-names--words-from-string s1)))
  (unless (listp s2)
    (setq s2 (fun-names--words-from-string s2)))
  `(,(fun-names--words-same s1 s2) ,@(fun-names--words-same-pos s1 s2)))

(defun fun-names--words-same (s1 s2)
  (unless (listp s1)
    (setq s1 (fun-names--words-from-string s1)))
  (unless (listp s2)
    (setq s2 (fun-names--words-from-string s2)))
  (if (and s1 s2)
      (let* ((num (+ (length s1) (length s2)))
             (com (- num (length (cl-set-exclusive-or s1 s2 :test #'string=)))))
        (/ com num 1.0))
    0.0))

(defun fun-names--words-same-pos (s1 s2)
  (unless (listp s1)
    (setq s1 (fun-names--words-from-string s1)))
  (unless (listp s2)
    (setq s2 (fun-names--words-from-string s2)))
  (cl-loop
    with short = (min (length s1) (length s2))
    with hits  = 0
    with pnts  = 0
    for i downfrom short
    for a in s1
    for b in s2
    do (when (string= a b)
         (cl-incf hits)
         (cl-incf pnts i))
    finally return (list hits pnts)))

(defun fun-names--words< (p1 p2)
  (pcase-let ((`(,r1 ,b1 ,e1) (last p1 3))
              (`(,r2 ,b2 ,e2) (last p2 3)))
    (or
      (< r1 r2)
      (and (= r1 r2) (< b1 b2))
      (and (= r1 r2) (= b1 b2) (< e1 e2)))))

(defun fun-names--words<= (p1 p2)
  (fun-names--words< p2 p1))

(defun fun-names--words= (p1 p2)
  (or (fun-names--words< p1 p2)
      (fun-names--words< p2 p1)))

(defun fun-names--words>= (p1 p2)
  (fun-names--words< p2 p1))

(defun fun-names--words> (p1 p2)
  (fun-names--words< p2 p1))

(provide 'fun-names)
;;; fun-names.el ends here