[PATCH] [WIP] org-agenda.el: Make org-entries-lessp more efficient

[Adam Spiers <orgmode@adamspiers.org>]

[This is only lightly tested and therefore probably not quite ready
for merging yet; however I'm submitting now to get feedback.]

org-entries-lessp was not as efficient a multi-criteria comparator as
it could have been, since it evaluated all criteria and then combined
them via (eval (cons 'or ...)), thereby missing a chance for lazy
evaluation via short-circuiting: if one of the earlier criteria in
org-agenda-sorting-strategy-selected evaluates to non-nil, giving a
definitive comparison result, there is no need to evaluate any of the
later criteria.

So instead iterate over the criteria one by one, and return as soon as
we have a definitive result.

Also remove code duplication by adopting a unified approach to
ascending/descending sorting.

Note that the way org-entries-lessp is invoked by
org-agenda-finalize-entries is still inefficient, because the same
values (e.g. timestamps, priorities, etc.) are extracted from every
pair of entries in each comparison within the sort.  In the future,
introducing a Schwartzian transform can probably address this.

However the refactoring in this commit is a step in the right
direction, and it also allows other code to determine which comparison
is decisive in ordering any two elements.

Signed-off-by: Adam Spiers <orgmode@adamspiers.org>
---
 lisp/org-agenda.el | 103 ++++++++++++++++++++-------------------------
 1 file changed, 46 insertions(+), 57 deletions(-)

diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 88bb3f90d..eadc7fedd 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -7187,65 +7187,54 @@ (defsubst org-cmp-habit-p (a b)
     (cond ((and ha (not hb)) -1)
 	  ((and (not ha) hb) +1))))
 
+(defun org-entries-cmp (a b)
+  "Iterate through the sorting criteria in
+`org-agenda-sorting-strategy-selected' until a sorter returns a
+definitive comparison, then return a cons cell (RESULT . SORTER)."
+  (let (sorted-by
+	sort-result
+	(ss org-agenda-sorting-strategy-selected))
+    (while (and ss (not sorted-by))
+      (let* ((sorter (car ss))
+	     (sorter-name (symbol-name sorter))
+	     ;; If sorter symbol ends in "-down" then pass the -up version
+	     ;; to org-entries-cmp-1 and then negate the result.
+	     (sorter-down-p (string-match "-down\\'" sorter-name))
+	     (up-sorter
+	      (if sorter-down-p
+		  (replace-regexp-in-string "-down\\'" "-up" sorter-name)
+		sorter-name)))
+	(setq sort-result (org-entries-cmp-1 a b (intern up-sorter)))
+	(setq ss (cdr ss))
+	(when sort-result
+	  (setq sort-result (if sorter-down-p (- sort-result) sort-result))
+	  (setq sorted-by sorter))))
+    (cons sort-result sorted-by)))
+
+(defun org-entries-cmp-1 (a b sorter)
+  "Compare two entries via the given sorter."
+  (pcase sorter
+    ('timestamp-up    (org-cmp-ts a b ""))
+    ('scheduled-up    (org-cmp-ts a b "scheduled"))
+    ('deadline-up     (org-cmp-ts a b "deadline"))
+    ('tsia-up         (org-cmp-ts a b "timestamp_ia"))
+    ('ts-up           (org-cmp-ts a b "timestamp"))
+    ('time-up         (org-cmp-time a b))
+    ('stats-up        (org-cmp-values a b 'org-stats))
+    ('priority-up     (org-cmp-values a b 'priority))
+    ('effort-up       (org-cmp-effort a b))
+    ('category-up     (org-cmp-category a b))
+    ('category-keep   (if (org-cmp-category a b) +1 nil)) ;; FIXME: check this
+    ('tag-up          (org-cmp-tag a b))
+    ('todo-state-up   (org-cmp-todo-state a b))
+    ('habit-up        (org-cmp-habit-p a b))
+    ('alpha-up        (org-cmp-alpha a b))
+    ('user-defined-up (funcall org-agenda-cmp-user-defined a b))))
+
 (defun org-entries-lessp (a b)
   "Predicate for sorting agenda entries."
-  ;; The following variables will be used when the form is evaluated.
-  ;; So even though the compiler complains, keep them.
-  (let* ((ss org-agenda-sorting-strategy-selected)
-	 (timestamp-up    (and (org-em 'timestamp-up 'timestamp-down ss)
-			       (org-cmp-ts a b "")))
-	 (timestamp-down  (if timestamp-up (- timestamp-up) nil))
-	 (scheduled-up    (and (org-em 'scheduled-up 'scheduled-down ss)
-			       (org-cmp-ts a b "scheduled")))
-	 (scheduled-down  (if scheduled-up (- scheduled-up) nil))
-	 (deadline-up     (and (org-em 'deadline-up 'deadline-down ss)
-			       (org-cmp-ts a b "deadline")))
-	 (deadline-down   (if deadline-up (- deadline-up) nil))
-	 (tsia-up         (and (org-em 'tsia-up 'tsia-down ss)
-			       (org-cmp-ts a b "timestamp_ia")))
-	 (tsia-down       (if tsia-up (- tsia-up) nil))
-	 (ts-up           (and (org-em 'ts-up 'ts-down ss)
-			       (org-cmp-ts a b "timestamp")))
-	 (ts-down         (if ts-up (- ts-up) nil))
-	 (time-up         (and (org-em 'time-up 'time-down ss)
-			       (org-cmp-time a b)))
-	 (time-down       (if time-up (- time-up) nil))
-	 (stats-up        (and (org-em 'stats-up 'stats-down ss)
-			       (org-cmp-values a b 'org-stats)))
-	 (stats-down      (if stats-up (- stats-up) nil))
-	 (priority-up     (and (org-em 'priority-up 'priority-down ss)
-			       (org-cmp-values a b 'priority)))
-	 (priority-down   (if priority-up (- priority-up) nil))
-	 (effort-up       (and (org-em 'effort-up 'effort-down ss)
-			       (org-cmp-effort a b)))
-	 (effort-down     (if effort-up (- effort-up) nil))
-	 (category-up     (and (or (org-em 'category-up 'category-down ss)
-				   (memq 'category-keep ss))
-			       (org-cmp-category a b)))
-	 (category-down   (if category-up (- category-up) nil))
-	 (category-keep   (if category-up +1 nil))
-	 (tag-up          (and (org-em 'tag-up 'tag-down ss)
-			       (org-cmp-tag a b)))
-	 (tag-down        (if tag-up (- tag-up) nil))
-	 (todo-state-up   (and (org-em 'todo-state-up 'todo-state-down ss)
-			       (org-cmp-todo-state a b)))
-	 (todo-state-down (if todo-state-up (- todo-state-up) nil))
-	 (habit-up        (and (org-em 'habit-up 'habit-down ss)
-			       (org-cmp-habit-p a b)))
-	 (habit-down      (if habit-up (- habit-up) nil))
-	 (alpha-up        (and (org-em 'alpha-up 'alpha-down ss)
-			       (org-cmp-alpha a b)))
-	 (alpha-down      (if alpha-up (- alpha-up) nil))
-	 (need-user-cmp   (org-em 'user-defined-up 'user-defined-down ss))
-	 user-defined-up user-defined-down)
-    (when (and need-user-cmp org-agenda-cmp-user-defined
-	       (functionp org-agenda-cmp-user-defined))
-      (setq user-defined-up
-	    (funcall org-agenda-cmp-user-defined a b)
-	    user-defined-down (if user-defined-up (- user-defined-up) nil)))
-    (cdr (assoc
-	  (eval (cons 'or org-agenda-sorting-strategy-selected))
-	  '((-1 . t) (1 . nil) (nil . nil))))))
+  (let ((sort-result (car (org-entries-cmp a b))))
+    (cdr (assoc sort-result '((-1 . t) (1 . nil) (nil . nil))))))
 
 ;;; Agenda restriction lock
 
-- 
2.28.0