;;; shorten.el --- component-wise string shortener
;; Copyright (C) 2013 John J Foerch <jjfoerch@earthlink.net>
;; Keywords: extensions
;; Author: John J Foerch <jjfoerch@earthlink.net>
;; URL: https://github.com/jorgenschaefer/circe/blob/master/shorten.el
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is a component-wise string shortener, meaning that, given a list
;; of strings, it breaks each string into parts, then computes shortest
;; prefix of each part with respect to others of the same 'depth', such
;; that when joined back together, the shortened form of the whole string
;; remains unique within the resulting list. Many styles of shortening
;; are made possible via three functions that the caller may provide: the
;; split function, the join function, and the validate-component function.
;;
;; Strings are broken with the value of `shorten-split-function' (a
;; procedure string->list), and shortened components are rejoined with the
;; value of `shorten-join-function' (a procedure list->string[*]). The
;; default split and join functions break the string on word boundaries,
;; and rejoin on the empty string. Potential shortened forms of
;; components are tested with `shorten-validate-component-function'; its
;; default value passes only if its argument contains at least one
;; word-constituent character (regexp \w), meaning that by default,
;; components consisting entirely of non-word characters will not be
;; shortened, and components that start with non-word characters will only
;; be shortened so much that they have at least one word-constituent
;; character in them.
;;
;; The main entry point is `shorten-strings', which takes a list of strings
;; as its argument and returns an alist ((STRING . SHORTENED-STRING) ...).
;;
;; [*] Also takes a second argument; see docstring of
;; `shorten-join-function'.
;;; History:
;; - Version 0.1 (March 7, 2013): initial release
;;; Code:
;; Tree utils
;;
(defsubst shorten-make-tree-root ()
(cons nil nil))
(defsubst shorten-tree-make-entry (token short full)
(list token short full nil))
(defsubst shorten-tree-token (entry)
(car entry))
(defsubst shorten-tree-fullname (entry)
(nth 2 entry))
(defsubst shorten-tree-descendants (entry)
(nthcdr 3 entry))
(defsubst shorten-tree-set-shortened (entry short)
(setcar (cdr entry) short))
(defsubst shorten-tree-set-fullname (entry full)
(setcar (nthcdr 2 entry) full))
(defsubst shorten-tree-insert (node item)
(when (car node)
(setcdr node (cons (car node) (cdr node))))
(setcar node item))
;; Caller configuration
;;
(defun shorten-split (s)
(split-string s "\\b" t))
(defun shorten-join (lst &optional tail-count)
(mapconcat #'identity lst ""))
(defun shorten-join-sans-tail (lst tail-count)
"A shorten-join that drops unnecessary tail components."
(shorten-join (butlast lst tail-count)))
(defun shorten-validate-component (str)
(string-match-p "\\w" str))
(defvar shorten-split-function #'shorten-split
"Value should be a function of string->list that breaks a
string into components. The default breaks on word-boundaries.
To get simple prefix shortening, bind this to `list'.
Users should not generally change the global value of this
variable; instead, bind it dynamically around calls to
`shorten-strings'.")
(defvar shorten-join-function #'shorten-join
"A function that takes a list of components and a tail-count,
and returns a joined string. Tail-count is the number of
components on the end of the list that are not needed to uniquify
the result, and so may be safely dropped if aggressive shortening
is desired. The default preserves tail components, and joins the
list on the empty string.
Users should not generally change the global value of this
variable; instead, bind it dynamically around calls to
`shorten-strings'.")
(defvar shorten-validate-component-function #'shorten-validate-component
"Predicate that returns t if a proposed shortened form of a
single component is acceptable, nil if a longer one should be
tried. The default validates only when the candidate contains at
least one word-constituent character, thus strings consisting of
punctuation will not be shortened. For aggressive shortening,
bind to a procedure that always returns t.
Users should not generally change the global value of this
variable; instead, bind it dynamically around calls to
`shorten-strings'.")
;; Main procedures
;;
(defun shorten-one (str others)
"Return shortest unique prefix of STR among OTHERS, or STR if
it cannot be shortened. If STR is a member of OTHERS (tested
with `eq') that entry is ignored. The value of
`shorten-validate-component-function' will be used to validate
any prefix."
(let ((max (length str))
(len 1))
(or (catch 'return
(while (< len max)
(let ((prefix (substring str 0 len)))
(when (funcall shorten-validate-component-function prefix)
(when (catch 'return
(dolist (other others t)
(when (and (>= (length other) len)
(string= (substring other 0 len) prefix)
(not (eq other str)))
(throw 'return nil))))
(throw 'return prefix)))
(setq len (1+ len)))))
str)))
(defun shorten-walk-internal (node path tail-count result-out)
(let ((others (mapcar #'car node)))
(setq tail-count (if (cdr node) 0 (1+ tail-count)))
(dolist (entry node)
(let* ((token (shorten-tree-token entry))
(shortened (shorten-one token others))
(path (cons shortened path))
(fullname (shorten-tree-fullname entry))
(descendants (shorten-tree-descendants entry))
(have-descendants (not (equal '(nil) descendants))))
(shorten-tree-set-shortened entry shortened)
;; if this entry has a fullname, add to result-out
(when fullname
(let ((joined (funcall shorten-join-function
(reverse path)
(if have-descendants 0 tail-count))))
(shorten-tree-insert result-out (cons fullname joined))))
;; if this entry has descendants, recurse
(when have-descendants
(shorten-walk-internal descendants path
(if fullname -1 tail-count)
result-out))))))
(defun shorten-walk (tree)
"Takes a tree of the type made by `shorten-make-tree' and
returns an alist ((STRING . SHORTENED-STRING) ...). Uses
`shorten-join-function' to join shortened components back
together into SHORTENED-STRING. See also
`shorten-validate-component-function'."
(let ((result-out (shorten-make-tree-root)))
(shorten-walk-internal tree '() -1 result-out)
(if (equal '(nil) result-out) nil result-out)))
(defun shorten-make-tree (strings)
"Takes a list of strings and returns a tree of the type used by
`shorten-walk' to generate shortened strings. Uses
`shorten-split-function' to split the strings."
(let ((tree (shorten-make-tree-root)))
(dolist (s strings)
(let ((node tree)
(tokens (funcall shorten-split-function s))
(entry nil))
;; create a path in tree for tokens
(dolist (token tokens)
(setq entry (assoc token node))
(when (not entry)
(setq entry (shorten-tree-make-entry token nil nil))
(shorten-tree-insert node entry))
(setq node (shorten-tree-descendants entry)))
;; for the last token, set 'fullname'
(shorten-tree-set-fullname entry s)))
(if (equal tree '(nil)) nil tree)))
;;;###autoload
(defun shorten-strings (strings)
"Takes a list of strings and returns an alist ((STRING
. SHORTENED-STRING) ...). Uses `shorten-split-function' to split
the strings, and `shorten-join-function' to join shortened
components back together into SHORTENED-STRING. See also
`shorten-validate-component-function'."
(shorten-walk (shorten-make-tree strings)))
(provide 'shorten)
;;; shorten.el ends here
