248 lines
9.7 KiB
EmacsLisp
248 lines
9.7 KiB
EmacsLisp
;;; citeproc-disamb.el --- disambiguate ambiguous cites -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2017 András Simonyi
|
|
|
|
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
|
|
|
;; 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/>.
|
|
|
|
;; This file is not part of GNU Emacs.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Functions to disambiguate cites of different bibliography items that would
|
|
;; have the same rendering. Disambiguation steps (e.g., adding more names,
|
|
;; expanding names, adding year-suffixes) are performed according to the
|
|
;; disambiguation rules specified by the CSL style in use.
|
|
|
|
;;; Code:
|
|
|
|
(require 'dash)
|
|
(require 'cl-lib)
|
|
(require 'subr-x)
|
|
|
|
(require 'citeproc-itemdata)
|
|
|
|
(defun citeproc-itd-inc-disamb-level (key itd type)
|
|
"Increment the disambiguation level of KEY in itemdata ITD.
|
|
TYPE is either `add-names' or `show-given-names.'"
|
|
(let ((vv (citeproc-itemdata-varvals itd)))
|
|
(if (alist-get type vv)
|
|
(let* ((cur-level (alist-get key (alist-get type vv)))
|
|
(new-level (if cur-level (1+ cur-level) 1)))
|
|
(setf (alist-get key (alist-get type vv)) new-level))
|
|
(push `(,type . ((,key . 1))) (citeproc-itemdata-varvals itd))))
|
|
(setf (citeproc-itemdata-rc-uptodate itd) nil))
|
|
|
|
(defun citeproc-itd-add-name (itd style &optional _first-step)
|
|
"Perform an add-name disambig. step on itemdata ITD with STYLE.
|
|
FIRST-STEP is ignored -- it is there to get the same signature as
|
|
the other two disamb. step functions. Return nil if no disambiguation
|
|
could be performed and t otherwise. Disambiguation is performed
|
|
from left to right: an item is attempted to be expanded only if
|
|
no previous items to the left could be."
|
|
(let* ((vars (citeproc-itd-namevars itd style))
|
|
(cite (citeproc-itd-plain-cite itd style))
|
|
(vv (citeproc-itemdata-varvals itd))
|
|
(levels (alist-get 'add-names vv))
|
|
(remaining-vars (if levels (memq (caar levels) vars) vars))
|
|
(success nil))
|
|
(while (and (not success) remaining-vars)
|
|
(citeproc-itd-inc-disamb-level (car remaining-vars) itd 'add-names)
|
|
(if (string= cite (citeproc-itd-plain-cite itd style))
|
|
(pop remaining-vars)
|
|
(setq success t)))
|
|
success))
|
|
|
|
(defun citeproc-itd-add-given (itd style &optional first-step)
|
|
"Perform an add-given disambig. step on itemdata ITD with STYLE.
|
|
Unless FIRST-STEP is non-nil, remove the last previously added
|
|
given name if the last added given name is shown in its entirety.
|
|
Return nil if no disambig. step could be performed and t
|
|
otherwise."
|
|
(let* ((nids (citeproc-itd-nameids itd style))
|
|
(cite (citeproc-itd-plain-cite itd style))
|
|
(vv (citeproc-itemdata-varvals itd))
|
|
(levels (alist-get 'show-given-names vv))
|
|
(remaining-nids (if levels (memq (caar levels) nids) nids))
|
|
(success nil))
|
|
(while (and (not success) remaining-nids)
|
|
(let* ((current-nid (car remaining-nids))
|
|
(vv (citeproc-itemdata-varvals itd))
|
|
(levels (alist-get 'show-given-names vv))
|
|
(current-level (alist-get current-nid levels)))
|
|
(if (and current-level (>= current-level 2))
|
|
(pop remaining-nids)
|
|
(citeproc-itd-inc-disamb-level current-nid itd 'show-given-names)
|
|
(unless (string= cite (citeproc-itd-plain-cite itd style))
|
|
(setq success t)
|
|
(unless (or first-step current-level)
|
|
(let ((ls (alist-get 'show-given-names vv)))
|
|
(setf (alist-get 'show-given-names vv)
|
|
(cons (car ls) (cddr ls))))
|
|
(setf (citeproc-itemdata-rc-uptodate itd) nil))))))
|
|
success))
|
|
|
|
(defun citeproc-itd-addgiven-with-addname (itd style &optional first-step)
|
|
"Perform a combined disambig. step on itemdata ITD with STYLE.
|
|
If FIRST-STEP is non-nil then (i) add a new name even if the last
|
|
add-given step showed only initials, (ii) don't remove the
|
|
previously added given name. Return nil if no disambig. step
|
|
could be performed and t otherwise."
|
|
(let* ((vv (citeproc-itemdata-varvals itd))
|
|
(gn (alist-get 'show-given-names vv))
|
|
(success nil)
|
|
(remaining-names t))
|
|
(if (and (not first-step) gn (= 1 (cdar gn)) (citeproc-itd-add-given itd style))
|
|
t
|
|
(while (and (not success) remaining-names)
|
|
(let ((nids (citeproc-itd-nameids itd style)))
|
|
(if (citeproc-itd-add-name itd style)
|
|
(let* ((new-nids (citeproc-itd-nameids itd style))
|
|
(new-nid (car (cl-set-difference new-nids nids))))
|
|
;;next sexp is to direct the add-given function to the just added name
|
|
(when first-step
|
|
(setf (alist-get new-nid
|
|
(alist-get 'show-given-names
|
|
(citeproc-itemdata-varvals itd)))
|
|
0))
|
|
(when (citeproc-itd-add-given itd style first-step)
|
|
(setq success t)))
|
|
(setq remaining-names nil))))
|
|
success)))
|
|
|
|
(defun citeproc-disamb--different-cites-p (itds style)
|
|
"Whether some itemdata in ITDS have different cites with STYLE."
|
|
(--any-p (not (string= (citeproc-itd-plain-cite it style)
|
|
(citeproc-itd-plain-cite (car itds) style)))
|
|
(cdr itds)))
|
|
|
|
(defun citeproc-disamb--with-method (itds style disamb-fun)
|
|
"Disambiguate itemdatas in ITDS for STYLE with DISAMB-FUN.
|
|
Return t if the disambiguation was (at least partially)
|
|
successful and nil otherwise."
|
|
(let ((orig-settings (copy-tree (citeproc-disamb--settings itds)))
|
|
success
|
|
(first-step t))
|
|
(while (and (not success)
|
|
(--all-p (funcall disamb-fun it style first-step) itds))
|
|
(setq first-step nil)
|
|
(when (citeproc-disamb--different-cites-p itds style)
|
|
(setq success t)))
|
|
(unless success
|
|
(citeproc-disamb--restore-settings itds orig-settings))
|
|
success))
|
|
|
|
(defun citeproc-disamb--settings (itds)
|
|
"Return a list with the disamb settings of ITDS."
|
|
(--map (cons (citeproc-itd-getvar it 'add-names)
|
|
(citeproc-itd-getvar it 'show-given-names))
|
|
itds))
|
|
|
|
(defun citeproc-disamb--restore-settings (itds settings)
|
|
"Restore the disamb settings of ITDS from SETTINGS.
|
|
SETTINGS should have the structure produced by citeproc--disamb-settings."
|
|
(cl-loop for itd in itds
|
|
for (add-names-val . show-given-val) in settings do
|
|
(citeproc-itd-setvar itd 'add-names add-names-val)
|
|
(citeproc-itd-setvar itd 'show-given-names show-given-val)))
|
|
|
|
(defun citeproc-disamb--num-to-yearsuffix (n)
|
|
"Return year-suffix no. N (starting from 0)."
|
|
(cond ((< n 26)
|
|
(char-to-string (+ 97 n)))
|
|
((< n 702)
|
|
(let* ((rem (% n 26))
|
|
(d (/ (- n rem) 26)))
|
|
(concat (char-to-string (+ 96 d))
|
|
(char-to-string (+ 97 rem)))))
|
|
(t (error "Number too large to convert into a year-suffix"))))
|
|
|
|
(defun citeproc-disamb--add-yearsuffix (itds _style)
|
|
"Disambiguate itemdata in ITDS by adding year suffices.
|
|
Return t (for the sake of consistency with other disamb methods)."
|
|
(--each-indexed (--sort (< (string-to-number (citeproc-itd-getvar it 'citation-number))
|
|
(string-to-number (citeproc-itd-getvar other 'citation-number)))
|
|
itds)
|
|
(citeproc-itd-setvar it 'year-suffix (citeproc-disamb--num-to-yearsuffix it-index))
|
|
(setf (citeproc-itemdata-rc-uptodate it) nil))
|
|
t)
|
|
|
|
(defun citeproc-disamb--set-fields (itds)
|
|
"Disambiguate ITDS by setting their disambiguate fields."
|
|
(--each itds
|
|
(citeproc-itd-setvar it 'disambiguate t)))
|
|
|
|
(defun citeproc-disamb-amb-itds (itds style name given yearsuff)
|
|
"Disambiguate ITDS ambigous for STYLE with the given methods.
|
|
NAME, GIVEN and YEARSUFF are generalized booleans specifying
|
|
whether or not the add-name, show-given or add-year-suffix
|
|
disambiguation methods should be used. Return t if the
|
|
disambiguation was (at least partially) successful, nil
|
|
otherwise."
|
|
(or (and name (citeproc-disamb--with-method itds style 'citeproc-itd-add-name))
|
|
(and given (citeproc-disamb--with-method itds style 'citeproc-itd-add-given))
|
|
(and name given
|
|
(citeproc-disamb--with-method itds style 'citeproc-itd-addgiven-with-addname))
|
|
(progn
|
|
(citeproc-disamb--set-fields itds)
|
|
(citeproc-disamb--different-cites-p itds style))
|
|
(and yearsuff
|
|
(citeproc-disamb--add-yearsuffix itds style)
|
|
(citeproc-disamb--different-cites-p itds style))))
|
|
|
|
(defun citeproc-amb-itds (itds style)
|
|
"Return a list of ambigous sets in ITDS for STYLE.
|
|
The returned value is a (possibly empty) list of lists."
|
|
(let* ((sorted (-sort (lambda (x y)
|
|
(string< (citeproc-itd-plain-cite x style)
|
|
(citeproc-itd-plain-cite y style)))
|
|
itds))
|
|
(result nil)
|
|
(remaining (cdr sorted))
|
|
(act (car sorted))
|
|
(act-list (list act))
|
|
(ambig nil))
|
|
(while remaining
|
|
(let ((next (car remaining)))
|
|
(if (string= (citeproc-itd-plain-cite act style)
|
|
(citeproc-itd-plain-cite next style))
|
|
(progn
|
|
(push next act-list)
|
|
(setq ambig t))
|
|
(when ambig (push act-list result))
|
|
(setq act-list (list next)
|
|
act next
|
|
ambig nil))
|
|
(pop remaining)))
|
|
(when ambig (push act-list result))
|
|
result))
|
|
|
|
(defun citeproc-disamb-itds (itds style name given yearsuff)
|
|
"Disambiguate itemdatas in list ITDS for STYLE.
|
|
NAME, GIVEN and YEARSUFF are generalized booleans specifying
|
|
whether or not the add-name, show-given or add-year-suffix
|
|
disambiguation methods should be used."
|
|
(let ((amb-itds (citeproc-amb-itds itds style)))
|
|
(while amb-itds
|
|
(let ((act-set (pop amb-itds)))
|
|
(citeproc-disamb-amb-itds act-set style name given yearsuff)
|
|
(when (citeproc-disamb--different-cites-p act-set style)
|
|
(-when-let (new-ambs (citeproc-amb-itds act-set style))
|
|
(setq amb-itds (nconc new-ambs amb-itds))))))))
|
|
|
|
(provide 'citeproc-disamb)
|
|
|
|
;;; citeproc-disamb.el ends here
|