[emacs] Add task management in org.

- We can add a task ID to a heading, like PRO-231
- We can associate a task with another task
- Blocking is marked explicitly now

2 files changed, 198 insertions, 1 deletions

diff --git a/emacs/.emacs.d/init/ycp-org.el b/emacs/.emacs.d/init/ycp-org.el
index b20f33e..815216c 100644
--- a/emacs/.emacs.d/init/ycp-org.el
+++ b/emacs/.emacs.d/init/ycp-org.el
@@ -155,6 +155,13 @@
 
 (my-package org-agenda
   (:delay 10)
+  ;; We want to prevent switching not-done to done for items with
+  ;; not-done children or checkboxes (see
+  ;; `org-enforce-todo-dependencies' and
+  ;; `org-enforce-todo-checkbox-dependencies' but we don't want them
+  ;; marked as blocked, because blocked should be marked explicitly
+  ;; and dimmed when they are truly blocked by a task somewhere else.
+  (my-override org-entry-blocked-p)
   (my-keybind global-map "C-c g" 'my-org-store-agenda-view-A)
   (setq org-agenda-confirm-kill t)
   (setq org-agenda-follow-indirect t)
@@ -165,7 +172,7 @@
   (setq org-agenda-todo-ignore-with-date 'all)
   (setq org-agenda-todo-ignore-timestamp 'all)
   (setq org-agenda-tags-todo-honor-ignore-options t)
-  (setq org-agenda-dim-blocked-tasks nil)
+  (setq org-agenda-dim-blocked-tasks t)
   (setq org-agenda-sticky t)
   (setq org-agenda-inhibit-startup t)
   (my-setq-from-local org-agenda-files)
@@ -307,6 +314,10 @@
   (setq org-use-speed-commands t)
   (setq org-speed-commands
         '(("User commands")
+          ("." . my-org-task-add-id)
+          ("'" . my-org-task-associate)
+          ("!" . my-org-task-remove-id)
+          ("\"" . my-org-task-dissociate)
           ("T" . my-org-swap-referral-with-headline)
           ("D" . my-org-clean-up-entry)
           ("g" . org-delete-property)
diff --git a/emacs/.emacs.d/lisp/my/my-org.el b/emacs/.emacs.d/lisp/my/my-org.el
index 69a4a9b..2516b6d 100644
--- a/emacs/.emacs.d/lisp/my/my-org.el
+++ b/emacs/.emacs.d/lisp/my/my-org.el
@@ -1420,5 +1420,191 @@ or filename if no title."
                             :priority prio)
       link)))
 
+;;; task management
+(defcustom my-org-task-categories nil
+  "Task categories for org custom_id creation."
+  :group 'my-org
+  :type '(repeat symbol))
+
+(defcustom my-org-task-next-id-file (locate-user-emacs-file "org-task-ids")
+  "Files to store the next id of each task category."
+  :group 'my-org
+  :type 'file)
+
+(defcustom my-org-task-property-name "TASK_ID"
+  "The property field name for task ids."
+  :group 'my-org
+  :type 'string)
+
+;; (defvar my-org-task-next-ids nil
+;;   "An alist of next IDs for each task category, will be read from
+;;   and written to")
+
+(defun my-org-task-init ()
+  "Initialise next ids and write them to `my-org-task-next-id-file'."
+  (my-org-task-write-next-ids
+   (mapcar
+    (lambda (cat)
+      `(,cat . 0))
+    my-org-task-categories)))
+
+(defun my-org-task-read-next-ids ()
+  "Read next ids from `my-org-task-next-id-file'."
+  (when (file-exists-p my-org-task-next-id-file)
+    (with-temp-buffer
+      (insert-file-contents my-org-task-next-id-file)
+      (goto-char (point-min))
+      (read (current-buffer)))))
+
+(defun my-org-task-write-next-ids (next-ids)
+  "Write NEXT-IDS to `my-org-task-next-id-file'."
+  (with-temp-buffer
+    (insert (prin1-to-string next-ids))
+    (write-region nil nil my-org-task-next-id-file)))
+
+(defun my-org-task-increment-id (category)
+  "Increment the next id of CATEGORY.
+
+Return the next id before incrementing."
+  (let* ((next-ids (my-org-read-next-ids))
+         (next-id (alist-get category next-ids)))
+    (setf (alist-get category next-ids)
+          (1+ next-id))
+    (my-org-task-write-next-ids next-ids)
+    next-id))
+
+(defun my-org-task-remove-id ()
+  "Remove id from task at point."
+  (interactive)
+  (let* ((headline (org-entry-get (point) "ITEM"))
+         (old-id (org-entry-get (point) my-org-task-property-name))
+         (new-headline (replace-regexp-in-string
+                        (format "^%s" (if old-id (format "%s " old-id) ""))
+                        ""
+                        headline)))
+    (org-entry-delete (point) my-org-task-property-name)
+    (org-edit-headline new-headline)))
+
+(defun my-org-task-add-id (category)
+  "Add id of CATEGORY to task at point."
+  (interactive (list (intern (completing-read
+                              "Category: "
+                              (mapcar
+                               (lambda (cat) (format "%s" cat))
+                               my-org-task-categories)))))
+  (my-org-task-remove-id)
+  (let* ((id (format "%s-%d" category (my-org-task-increment-id category)))
+         (headline (org-entry-get (point) "ITEM"))
+         (new-headline (format "%s %s" id headline)))
+    (org-entry-put (point) my-org-task-property-name id)
+    (org-edit-headline new-headline)))
+
+(defvar my-org-task-relations
+  '(("BLOCKS" . "BLOCKED_BY")
+    ("CAUSES" . "CAUSED_BY")
+    ("DUPLICATES" . "DUPLICATED_BY")
+    ("RELATED" . "RELATED")
+    ("BLOCKED_BY" . "BLOCKS")
+    ("CAUSED_BY" . "CAUSES")
+    ("DUPLICATED_BY" . "DUPLICATES"))
+  "Task relations and their dual relations.")
+
+(defcustom my-org-properties-separator ", "
+  "Separator in a property value field."
+  :group 'my-org
+  :type 'string)
+
+(defun my-org-entry-add (pom property value)
+  "Add VALUE to the values in PROPERTY at POM.
+
+The values are separated by `my-org-properties-separator'.
+See also `org-entry-add-to-multivalued-property'."
+  (let ((old (org-entry-get pom property)))
+    (if old
+        (org-entry-put
+         pom property
+         (format "%s%s%s" old my-org-properties-separator value))
+      (org-entry-put pom property value))))
+
+(defun my-org-entry-remove (pom property value)
+  "Remove VALUE from the values in PROPERTY at POM.
+
+The values are separated by `my-org-properties-separator'.
+See also `org-entry-remove-from-multivalued-property'."
+  (let* ((old (org-entry-get pom property))
+         (new (replace-regexp-in-string
+               ;; Remove value when it is the only one in the property
+               (regexp-quote value)
+               ""
+               (replace-regexp-in-string
+                ;; Remove the non-first occurrence of the value
+                (regexp-quote (format "%s%s" my-org-properties-separator value))
+                ""
+                (replace-regexp-in-string
+                 ;; Remove the non-last occurrence of the value
+                 (regexp-quote (format "%s%s" value my-org-properties-separator))
+                 ""
+                 old)))))
+    (if (string-empty-p new)
+        (org-entry-delete pom property)
+      (org-entry-put pom property new))))
+
+(defun my-org-task-associate-internal (relation)
+  "Add the last stored link as RELATION to the task at point."
+  (when-let ((link (pop org-stored-links)))
+    (my-org-entry-add (point) relation
+                      (format "[[%s][%s]]" (car link) (cadr link)))))
+
+(defun my-org-task-dissociate-internal (relation)
+  "Remove the last stored link as RELATION from the task at point."
+  (when-let ((link (pop org-stored-links)))
+    (my-org-entry-remove (point) relation
+                         (format "[[%s][%s]]" (car link) (cadr link)))))
+
+(defun my-org-task-associate ()
+  "Associate the task at point with another task.
+
+Use `org-goto' to choose the task to associate with. Adds the
+dual relation link-back on that task."
+  (interactive)
+  (let* ((relation
+          (completing-read "Relation: "
+                           (mapcar 'car my-org-task-relations) nil t))
+         (dual (alist-get relation my-org-task-relations nil nil 'equal)))
+    (call-interactively 'org-store-link)
+    (save-excursion
+      (call-interactively 'org-goto)
+      (my-org-task-associate-internal dual)
+      (call-interactively 'org-store-link))
+    (my-org-task-associate-internal relation)))
+
+;; TODO: Choose from associated tasks rather than all possible
+;; headlines.
+(defun my-org-task-dissociate ()
+  "Dissociate the task at point with another task.
+
+Use `org-goto' to choose the task to dissociate from. Removes the
+dual relation link-back on that task."
+  (interactive)
+  (let* ((properties (org-entry-properties))
+         (relation
+          (completing-read "Relation: "
+                           (mapcar 'car my-org-task-relations)
+                           (lambda (prop) (alist-get prop properties nil nil 'equal))
+                           t))
+         (dual (alist-get relation my-org-task-relations nil nil 'equal)))
+    (call-interactively 'org-store-link)
+    (save-excursion
+      (call-interactively 'org-goto)
+      (my-org-task-dissociate-internal dual)
+      (call-interactively 'org-store-link))
+    (my-org-task-dissociate-internal relation)))
+
+;; to override `org-entry-blocked-p'.
+(defun my-org-entry-blocked-p ()
+  "Non-nil if entry at point is blocked."
+  (and (org-entry-get (point) "BLOCKED_BY")
+       (member (org-entry-get nil "TODO") org-not-done-keywords)))
+
 (provide 'my-org)
 ;;; my-org.el ends here