From 525b4fcb547349e9deb7279ac52f1684e1e88f4b Mon Sep 17 00:00:00 2001
From: SqrtMinusOne <thexcloud@gmail.com>
Date: Sat, 13 Jul 2024 22:39:13 +0300
Subject: [PATCH] emacs: experiments with sequential headers in org-mode

---
 .emacs.d/init.el | 115 ++++++++++++++++++++++++++++++++++++++++-
 Emacs.org        | 130 +++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 240 insertions(+), 5 deletions(-)

diff --git a/.emacs.d/init.el b/.emacs.d/init.el
index c7de949..f2872c8 100644
--- a/.emacs.d/init.el
+++ b/.emacs.d/init.el
@@ -3787,7 +3787,21 @@ With ARG, repeats or can move backward if negative."
   :commands (org-clock-agg)
   :init
   (with-eval-after-load 'org
-    (my-leader-def "ol" #'org-clock-agg)))
+    (my-leader-def "ol" #'org-clock-agg))
+  :config
+  (push
+   (cons "Agenda+Archive"
+         (append
+          (org-agenda-files)
+          (thread-last "/projects/archive"
+                       (concat org-directory)
+                       (directory-files)
+                       (mapcar (lambda (f)
+                                 (concat
+                                  org-directory "/projects/archive/" f)))
+                       (seq-filter (lambda (f)
+                                     (not (file-directory-p f)))))))
+   org-clock-agg-files-preset))
 
 (with-eval-after-load 'org
   (setq org-clock-persist 'clock)
@@ -4006,7 +4020,15 @@ TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
                                 (not (property "MEETING"))
                                 (ts :from -7))
                    :super-groups '((:auto-outline-path-file t))))
-       (cons "Review: Meeting" #'my/org-ql-meeting-tasks)))
+       (cons "Review: Meeting" #'my/org-ql-meeting-tasks)
+       (cons "Fix: tasks without TASK_KIND"
+             (lambda ()
+               (interactive)
+               (org-ql-search (current-buffer)
+                 '(and (olp "Tasks")
+                       (not (property "TASK_KIND"))
+                       (clocked))
+                 :super-groups '((:auto-outline-path-file t)))))))
 
 (defun my/org-ql-view--format-element-override (element)
   "Format ELEMENT for `org-ql-view'.
@@ -4323,6 +4345,95 @@ KEYS is a list of cons cells like (<label> . <time>)."
                   (buffer-string)))))
     (goto-char beg)))
 
+(defun my/org--headings-in-outline ()
+  (org-ql-query
+    :select (lambda () (propertize
+                        (substring-no-properties (org-get-heading t t t))
+                        'marker (copy-marker (point))))
+    :from (append
+           (list (buffer-file-name))
+           (let ((archive
+                  (concat (file-name-directory (buffer-file-name))
+                          "archive/"
+                          (file-name-nondirectory (buffer-file-name)))))
+             (when (file-exists-p archive)
+               (list archive))))
+    :where `(and (outline-path ,@(org-get-outline-path))
+                 (level ,(org-current-level)))))
+
+(defun my/org--heading-strip (heading)
+  (thread-last
+    heading
+    (substring-no-properties)
+    (replace-regexp-in-string (rx (| "(" "[") (+ alnum) (| "]" ")")) "")
+    (replace-regexp-in-string (rx " " (+ (or digit "."))) " ")
+    (replace-regexp-in-string (rx (+ " ")) " ")
+    (string-trim)))
+
+(defun my/org--headings-group-seq (headings)
+  (thread-last
+    headings
+    (seq-group-by #'my/org--heading-strip)
+    (seq-sort-by #'car #'string-lessp)
+    (mapcar (lambda (group)
+              (cons (car group)
+                    (seq-sort-by
+                     (lambda (heading)
+                       (save-match-data
+                         (or
+                          (and (string-match (rx (group (+ digit)))
+                                             heading)
+                               (string-to-number (match-string 1 heading)))
+                          -1)))
+                     #'<
+                     (cdr group)))))))
+
+(defun my/org-headings-seq ()
+  (interactive)
+  (let* ((headings (my/org--headings-in-outline))
+         (headings-seq (my/org--headings-group-seq headings))
+         (buffer (generate-new-buffer "*Sequential Headings in Outline*")))
+    (with-current-buffer buffer
+      (outline-mode)
+      (setq-local widget-push-button-prefix "")
+      (setq-local widget-push-button-suffix "")
+      (dolist (group headings-seq)
+        (insert (format "* %s\n" (car group)))
+        (dolist (heading (cdr group))
+          (widget-create 'push-button
+                         :marker (get-text-property 0 'marker heading)
+                         :notify (lambda (widget &rest ignore)
+                                   (let ((marker (widget-get widget :marker)))
+                                     (pop-to-buffer (marker-buffer marker))
+                                     (goto-char marker)))
+                         (concat "** " (substring-no-properties heading)))
+          (insert "\n")))
+      (widget-setup)
+      (setq buffer-read-only t)
+      (goto-char (point-min)))
+    (pop-to-buffer buffer)))
+
+(defun my/org-heading-seq-insert ()
+  (interactive)
+  (let* ((headings (my/org--headings-in-outline))
+         (headings-seq (my/org--headings-group-seq headings))
+         (heading (completing-read "Headings: " headings-seq))
+         (last-number
+          (thread-last headings-seq
+                       (assoc heading)
+                       (cdr)
+                       (mapcar (lambda (x)
+                                 (save-match-data
+                                   (or
+                                    (when (string-match (rx (group (+ digit)))
+                                                        x)
+                                      (string-to-number (match-string 1 x)))
+                                    1))))
+                       (seq-max)
+                       (1+))))
+    (org-insert-heading '(4))
+    (insert (format "FUTURE %s %s" heading last-number))))
+
 (defun my/org-archive--get-file ()
   "Get an archive version of the file."
   (let ((archive-file
diff --git a/Emacs.org b/Emacs.org
index fd5c13b..3f88cfe 100644
--- a/Emacs.org
+++ b/Emacs.org
@@ -5291,7 +5291,21 @@ It's been somewhat complicated to integrate into my workflow, but I think it's b
   :commands (org-clock-agg)
   :init
   (with-eval-after-load 'org
-    (my-leader-def "ol" #'org-clock-agg)))
+    (my-leader-def "ol" #'org-clock-agg))
+  :config
+  (push
+   (cons "Agenda+Archive"
+         (append
+          (org-agenda-files)
+          (thread-last "/projects/archive"
+                       (concat org-directory)
+                       (directory-files)
+                       (mapcar (lambda (f)
+                                 (concat
+                                  org-directory "/projects/archive/" f)))
+                       (seq-filter (lambda (f)
+                                     (not (file-directory-p f)))))))
+   org-clock-agg-files-preset))
 #+end_src
 
 The following enables org-clock persistence between Emacs sessions.
@@ -5566,7 +5580,15 @@ Putting all the above in =org-ql-views=.
                                 (not (property "MEETING"))
                                 (ts :from -7))
                    :super-groups '((:auto-outline-path-file t))))
-       (cons "Review: Meeting" #'my/org-ql-meeting-tasks)))
+       (cons "Review: Meeting" #'my/org-ql-meeting-tasks)
+       (cons "Fix: tasks without TASK_KIND"
+             (lambda ()
+               (interactive)
+               (org-ql-search (current-buffer)
+                 '(and (olp "Tasks")
+                       (not (property "TASK_KIND"))
+                       (clocked))
+                 :super-groups '((:auto-outline-path-file t)))))))
 #+end_src
 
 ***** Custom format element
@@ -5855,7 +5877,7 @@ I don't have any idea why, but evaluating =(my/org-alert-mode)= just after =org=
     (add-hook 'emacs-startup-hook #'my/org-alert-mode)))
 #+end_src
 
-**** Copying records
+**** Seqeuential headers
 I like to add numbers to repeating events, like meetings. E.g.
 
 #+begin_example
@@ -5866,6 +5888,7 @@ SCHEDULED: <2022-11-14 16:00>
 ...
 #+end_example
 
+***** Copying records
 Naturally, I want a way to copy such records. Org Mode already has a function called =org-clone-subtree-with-time-shift=, that does everything I want except for updating the numbers.
 
 Unfortunately, I see no way to advise the original function, so here's my version that makes use of =evil-numbers=:
@@ -5956,6 +5979,107 @@ Unfortunately, I see no way to advise the original function, so here's my versio
 #+end_src
 
 My addition to that is the form with =evil-numbers/inc-at-pt=.
+***** Keeping consistency among sequential records
+I also like to keep such headers consistent. Here are a few tools to help with that.
+
+First, I need to find and group and such headers. =org-ql= can help with that:
+#+begin_src emacs-lisp
+(defun my/org--headings-in-outline ()
+  (org-ql-query
+    :select (lambda () (propertize
+                        (substring-no-properties (org-get-heading t t t))
+                        'marker (copy-marker (point))))
+    :from (append
+           (list (buffer-file-name))
+           (let ((archive
+                  (concat (file-name-directory (buffer-file-name))
+                          "archive/"
+                          (file-name-nondirectory (buffer-file-name)))))
+             (when (file-exists-p archive)
+               (list archive))))
+    :where `(and (outline-path ,@(org-get-outline-path))
+                 (level ,(org-current-level)))))
+
+(defun my/org--heading-strip (heading)
+  (thread-last
+    heading
+    (substring-no-properties)
+    (replace-regexp-in-string (rx (| "(" "[") (+ alnum) (| "]" ")")) "")
+    (replace-regexp-in-string (rx " " (+ (or digit "."))) " ")
+    (replace-regexp-in-string (rx (+ " ")) " ")
+    (string-trim)))
+
+(defun my/org--headings-group-seq (headings)
+  (thread-last
+    headings
+    (seq-group-by #'my/org--heading-strip)
+    (seq-sort-by #'car #'string-lessp)
+    (mapcar (lambda (group)
+              (cons (car group)
+                    (seq-sort-by
+                     (lambda (heading)
+                       (save-match-data
+                         (or
+                          (and (string-match (rx (group (+ digit)))
+                                             heading)
+                               (string-to-number (match-string 1 heading)))
+                          -1)))
+                     #'<
+                     (cdr group)))))))
+#+end_src
+
+Then, display all such headings a buffer:
+#+begin_src emacs-lisp
+(defun my/org-headings-seq ()
+  (interactive)
+  (let* ((headings (my/org--headings-in-outline))
+         (headings-seq (my/org--headings-group-seq headings))
+         (buffer (generate-new-buffer "*Sequential Headings in Outline*")))
+    (with-current-buffer buffer
+      (outline-mode)
+      (setq-local widget-push-button-prefix "")
+      (setq-local widget-push-button-suffix "")
+      (dolist (group headings-seq)
+        (insert (format "* %s\n" (car group)))
+        (dolist (heading (cdr group))
+          (widget-create 'push-button
+                         :marker (get-text-property 0 'marker heading)
+                         :notify (lambda (widget &rest ignore)
+                                   (let ((marker (widget-get widget :marker)))
+                                     (pop-to-buffer (marker-buffer marker))
+                                     (goto-char marker)))
+                         (concat "** " (substring-no-properties heading)))
+          (insert "\n")))
+      (widget-setup)
+      (setq buffer-read-only t)
+      (goto-char (point-min)))
+    (pop-to-buffer buffer)))
+#+end_src
+
+And insert a similar heading:
+#+begin_src emacs-lisp
+(defun my/org-heading-seq-insert ()
+  (interactive)
+  (let* ((headings (my/org--headings-in-outline))
+         (headings-seq (my/org--headings-group-seq headings))
+         (heading (completing-read "Headings: " headings-seq))
+         (last-number
+          (thread-last headings-seq
+                       (assoc heading)
+                       (cdr)
+                       (mapcar (lambda (x)
+                                 (save-match-data
+                                   (or
+                                    (when (string-match (rx (group (+ digit)))
+                                                        x)
+                                      (string-to-number (match-string 1 x)))
+                                    1))))
+                       (seq-max)
+                       (1+))))
+    (org-insert-heading '(4))
+    (insert (format "FUTURE %s %s" heading last-number))))
+#+end_src
+
 **** Archiving records
 - *CREDIT*: thanks [[https://emacs.ch/@grinn][Amy]] for pointing me to the right functionality of =org-refile=.