Skip to content

Commit

Permalink
emacs: experiments with sequential headers in org-mode
Browse files Browse the repository at this point in the history
  • Loading branch information
@SqrtMinusOne
SqrtMinusOne committed Jul 13, 2024
1 parent d0488e6 commit 525b4fc
Show file tree
Hide file tree
Showing 2 changed files with 240 additions and 5 deletions.
115 changes: 113 additions & 2 deletions .emacs.d/init.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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'.
Expand Down Expand Up @@ -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
Expand Down
130 changes: 127 additions & 3 deletions Emacs.org
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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=:
Expand Down Expand Up @@ -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=.

Expand Down

0 comments on commit 525b4fc

Please sign in to comment.