ENH make timeblock show conflicts

local/lib/org-x/org-x-dag.el

@@ -482,6 +482,7 @@ used for optimization."
   (let* ((line-re (org-x-dag-line-regexp kws))
          (pps (--map (cons it (org-re-property it nil t)) target-props))
          (id-prop (org-re-property "ID" nil t))
+         (effort-prop (org-re-property "Effort" nil t))
          (next-pos (unless (= ?* (following-char))
                      (org-x-dag-next-headline)))
          ;; If not on a headline, check for a property drawer with links in it
@@ -540,8 +541,7 @@ used for optimization."
                                  (append this-tags))))
           (->> (list :point this-point
                      :buffer-parent this-buffer-parent
-                     :effort (when this-title
+                     :effort (org-x-dag-get-local-property pbeg pend effort-prop)
-                               (get-text-property 0 'effort this-title))
                      :level this-level
                      :todo this-todo
                      :title (if this-title (substring-no-properties this-title) "")
@@ -1731,6 +1731,7 @@ removed from, added to, or edited within the DAG respectively."
           (props (->> (pcase group
                         (:action (list org-x-prop-parent-type
                                        org-x-prop-time-shift
+                                       org-x-prop-routine
                                        "ARCHIVE")))
                       (append def-props)))
           (bs-fun (pcase group
@@ -1889,6 +1890,13 @@ If FORCE is non-nil, sync no matter what."
   "Return file for ID."
   (org-x-dag-id->hl-meta-prop id :category))
 
+(defun org-x-dag-id->duration (id)
+  "Return duration in minutes for ID (if it exists)."
+  (condition-case nil
+      (-some->> (org-x-dag-id->hl-meta-prop id :effort)
+        (org-duration-to-minutes))
+    nil))
+
 (defun org-x-dag-id->group (id)
   "Return file group for ID.
 Return one of seven values: :lifetime, :survival, :endpoint,
@@ -1930,6 +1938,9 @@ highest in the tree."
     (let ((local-tags (org-x-dag-id->local-tags id)))
       `(,@local-tags ,@(ascend id nil)))))
 
+(defun org-x-dag-id->node-properties (id)
+  (org-x-dag-id->hl-meta-prop id :props))
+
 ;; (defun org-x-dag-id->bucket (parent-tags id)
 ;;   (-some->> (org-x-dag-id->tags parent-tags id)
 ;;     (--find (= (elt it 0) org-x-tag-category-prefix))
@@ -2078,6 +2089,10 @@ Return value is a list like (BUFFER NON-BUFFER)."
       (cadr)
       (eq :iter-active)))
 
+(defun org-x-dag-id->has-node-property-p (prop value id)
+  (->> (alist-get prop (org-x-dag-id->node-properties id) nil nil #'equal)
+       (equal value)))
+
 ;; files to ids
 
 (defun org-x-dag-file->ids (file)
@@ -2167,6 +2182,31 @@ Return value is a list like (BUFFER NON-BUFFER)."
                                            org-x-tag-category-prefix)
   "Order in which tags should appear in the agenda buffer (from right to left.")
 
+(defun org-x-dag--group-overlaps (interval-fun xs)
+  ;; worst case = O(N^2) (all conflicts)
+  ;; best case = O(N) (no conflicts)
+  ;; interval function returns a list like (START END) where both are numbers
+  (cl-labels
+      ((get-overlaps
+        (acc ss)
+        (-let* (((acc+ acc-) acc)
+                (s0 (car ss))
+                (A (cdr s0)))
+          (-if-let (rest (cdr ss))
+              (let ((a1 (cadr (car s0))))
+                ;; add members while if the starting value is less than the ending
+                ;; value of the current member
+                (-if-let (over (->> (--take-while (< (car (car it)) a1) rest)
+                                    (--map (list A (cdr it)))
+                                    (reverse)))
+                    (get-overlaps `((,@over ,@acc+) ,acc-) rest)
+                  (get-overlaps `(,acc+ (,A ,@acc-)) rest)))
+            `(,acc+ (,A ,@acc-))))))
+    (-let (((over non-over) (->> (-annotate interval-fun xs)
+                                 (--sort (< (car (car it)) (car (car other))))
+                                 (get-overlaps nil))))
+      (list (nreverse over) (nreverse non-over)))))
+
 (defun org-x-dag-collapse-tags (tags)
   "Return TAGS with duplicates removed.
 
@@ -2390,34 +2430,36 @@ FUTURE-LIMIT in a list."
           (time-str (-some->> this-time (apply #'format "%02i:%02i ")))
           ;; negative diff -> past and vice versa
           (diff (org-x-dag-date-diff this-date sel-date))
-          (extra (funcall extra-fun diff))
+          (extra (funcall extra-fun id diff))
-          (face (funcall face-fun diff))
+          (face (funcall face-fun id diff))
-          ((date type) (funcall dt-fun diff this-date))
+          ((date type) (funcall dt-fun id diff this-date))
           (props (org-x-dag-planning-props id face pos date this-date type)))
     (-> (org-x-dag-format-item id extra tags time-str)
         (org-add-props props))))
 
 (defun org-x-dag-format-scheduled-node (sel-date pos datetime tags id)
   (org-x-dag-format-timestamp-node sel-date pos datetime tags id
-    (lambda (diff)
+    (lambda (_ diff)
       ;; hopefully this is right...if it is this seems silly
       (-let (((today past) org-agenda-scheduled-leaders))
         (cond
          ((= 0 diff) today)
          ((< diff 0) (format past (- diff)))
          (t ""))))
-    (lambda (diff)
+    (lambda (_ diff)
       (cond
        ((< diff 0) 'org-scheduled-previously)
-       ((= diff 0) 'org-scheduled-today)
+       ((> diff 0) 'org-scheduled)
-       (t 'org-scheduled)))
+       ((eq (org-x-dag-id->group id) :daily)
-    (lambda (diff this-date)
+        'org-drawer)
+       (t 'org-scheduled-today)))
+    (lambda (_ diff this-date)
       (if (< diff 0) `(,this-date "past-scheduled")
         `(,sel-date "scheduled")))))
 
 (defun org-x-dag-format-deadline-node (sel-date pos datetime tags id)
   (org-x-dag-format-timestamp-node sel-date pos datetime tags id
-    (lambda (diff)
+    (lambda (_ diff)
       (-let* (((now future past) org-agenda-deadline-leaders))
         (cond
          ((< 0 diff) (format future diff))
@@ -2426,12 +2468,12 @@ FUTURE-LIMIT in a list."
     ;; TODO the stock deadline formatter uses the warning time to determine this
     ;; based on percentage; I'm lazy and don't feel like doing that (now) but I
     ;; might in the future
-    (lambda (diff)
+    (lambda (_ diff)
       (cond
        ((< 5 diff) 'org-upcoming-distant-deadline)
        ((< 1 diff) 'org-upcoming-deadline)
        (t 'org-warning)))
-    (lambda (diff this-date)
+    (lambda (_ diff this-date)
       (if (< 0 diff) `(,sel-date "upcoming-deadline")
         `(,this-date "deadline")))))
 
@@ -2772,57 +2814,100 @@ FUTURE-LIMIT in a list."
 
 ;; agenda/calendar
 
+;; TODO add conflict resolution to this
 (defun org-x-dag-itemize-agenda (files sel-date)
-  (cl-flet*
+  (let ((todayp (org-x-dag-date= (org-x-dag-current-date) sel-date)))
-      ((format-timestamps
+    (cl-flet*
-        (todayp sel-date id ts get-datetimes-fun format-datetime-fun)
+        ((get-datetimes
-        (let ((pts (org-x-dag-partition-timestamp ts)))
+          (donep get-fun pts)
-          (-when-let (datetimes (funcall get-datetimes-fun sel-date pts))
+          (if donep
-            ;; TODO this will show all tasks regardless of if they have a
+              (-let (((&plist :datetime) pts))
-            ;; goal/plan or not
+                (when (org-x-dag-date= datetime sel-date)
-            (-let ((tags (org-x-dag-id->tags id))
+                  `(,datetime)))
-                   ((&plist :pos) pts)
+            (-when-let (datetimes (funcall get-fun sel-date pts))
-                   (donep (org-x-dag-id->is-done-p id)))
+              (if todayp datetimes
-              (--> datetimes
+                (--drop-while (org-x-dag-date< it sel-date) datetimes)))))
-                   (--remove (and donep (not (org-x-dag-date= it sel-date))) it)
+         (format-timestamps
-                   (if (not todayp) (--remove (org-x-dag-date< it sel-date) it) it)
+          (donep id which get-fun format-fun)
-                   (--map (funcall format-datetime-fun sel-date pos it tags id) it))))))
+          (-when-let (pts (-some->> (org-x-dag-id->planning-timestamp which id)
-       (format-scheduleds
+                            (org-x-dag-partition-timestamp)))
-        (todayp sel-date id ts)
+            (-when-let (ds (get-datetimes donep get-fun pts))
-        (format-timestamps todayp sel-date id ts
+              (-let ((tags (org-x-dag-id->tags id))
-                           #'org-x-dag-get-scheduled-at
+                     ((&plist :pos) pts))
-                           #'org-x-dag-format-scheduled-node))
+                (--map (list :pos pos :datetime it :tags tags :id id) ds)))))
-       (format-deadlines
+                ;; (--map (funcall format-fun sel-date pos it tags id) ds)))))
-        (todayp sel-date id ts)
+         (format-scheduleds
-        (format-timestamps todayp sel-date id ts
+          (donep id)
-                           #'org-x-dag-get-deadlines-at
+          (format-timestamps donep id :scheduled
-                           #'org-x-dag-format-deadline-node))
+                             #'org-x-dag-get-scheduled-at
-       (with-task-ish
+                             #'org-x-dag-format-scheduled-node))
-        (id todayp)
+         (format-deadlines
-        (append
+          (donep id)
-         (-when-let (dead (org-x-dag-id->planning-timestamp :deadline id))
+          (format-timestamps donep id :deadline
-           (format-deadlines todayp sel-date id dead))
+                             #'org-x-dag-get-deadlines-at
-         (-when-let (sched (org-x-dag-id->planning-timestamp :scheduled id))
+                             #'org-x-dag-format-deadline-node))
-           (format-scheduleds todayp sel-date id sched)))))
+         (add-sched
-    (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
+          (acc id donep)
-      (org-x-dag-with-ids files
+          (-let (((acc-d acc-s) acc)
-        (pcase (either-from-right (org-x-dag-id->bs it) nil)
+                 (ss (format-scheduleds donep id)))
-          (`(:daily :active (:sched ,sched))
+            `(,acc-d (,@ss ,@acc-s))))
-           (-when-let (datetime (org-ml-timestamp-get-start-time sched))
+         (add-dead-sched
-             (when (org-x-dag-date= sel-date datetime)
+          (acc id donep)
-               (format-scheduleds todayp sel-date it sched))))
+          (-let (((acc-d acc-s) acc)
-          (`(:daily :complete ,_)
+                 (ds (format-deadlines donep id))
-           (-when-let (sched (org-x-dag-id->planning-timestamp :scheduled it))
+                 (ss (format-scheduleds donep id)))
-             (when (org-x-dag-date= sel-date (org-ml-timestamp-get-start-time sched))
+            `((,@ds ,@acc-d) (,@ss ,@acc-s))))
-               (format-scheduleds todayp sel-date it sched))))
+         (format-id
-          (`(:sp-task :task-active ,_)
+          (acc id)
-           (with-task-ish it todayp))
+          (pcase (either-from-right (org-x-dag-id->bs id) nil)
-          (`(:sp-task :task-complete ,_)
+            (`(:daily :active (:sched ,sched))
-           (with-task-ish it todayp))
+             (-when-let (dt (org-ml-timestamp-get-start-time sched))
-          (`(:sp-subiter :si-active ,_)
+               (when (org-x-dag-date= sel-date dt)
-           (with-task-ish it todayp))
+                 (add-sched acc id nil))))
-          (`(:sp-subiter :si-complete ,_)
+            (`(:daily :complete ,_)
-           (with-task-ish it todayp)))))))
+             (add-sched acc id t))
+            (`(:sp-task :task-active ,_)
+             (add-dead-sched acc id nil))
+            (`(:sp-task :task-complete ,_)
+             (add-dead-sched acc id t))
+            (`(:sp-subiter :si-active ,_)
+             (add-dead-sched acc id nil))
+            (`(:sp-subiter :si-complete ,_)
+             (add-dead-sched acc id t))
+            (_ acc)))
+         (get-interval
+          (x)
+          (-let* (((&plist :datetime :id) x)
+                  (duration (or (org-x-dag-id->duration id) 0))
+                  (start (org-ml-time-to-unixtime datetime)))
+            `(,start ,(+ start (* 60 duration)))))
+         (format-dtl
+          (fun dtl conflict)
+          (-let* (((&plist :datetime :id :tags :pos) dtl)
+                  (s (funcall fun sel-date pos datetime tags id)))
+            (if conflict (org-add-props s nil 'x-conflict-id conflict) s)))
+         (format-dead
+          (dtl conflict)
+          (format-dtl #'org-x-dag-format-deadline-node dtl conflict))
+         (format-sched
+          (dtl conflict)
+          (format-dtl #'org-x-dag-format-scheduled-node dtl conflict))
+         (can-conflict-p
+          (dtl)
+          (-let (((&plist :datetime :id) dtl))
+            (and (org-ml-time-is-long datetime)
+                 (not (org-x-dag-id->is-done-p id))))))
+      (with-temp-buffer
+        (org-mode)
+        (-let* (((ds ss) (->> (org-x-dag-files->ids files)
+                              (-reduce-from #'format-id nil)))
+                ((long-ss short-ss) (-separate #'can-conflict-p ss))
+                ((long-ss+ long-ss-)
+                 (org-x-dag--group-overlaps #'get-interval long-ss)))
+          (append
+           (--map (format-dead it nil) ds)
+           (--map (format-sched it nil) (append long-ss- short-ss))
+           (--map (format-sched (car it) (plist-get (cadr it) :id)) long-ss+)))))))
 
 ;;; BUFFER MANIPULATION
 
@@ -4046,6 +4131,7 @@ FUTURE-LIMIT in a list."
          ((arg start-day span with-hour) (or org-agenda-overriding-arguments
                                              (list nil start-day 'day nil))))
     (catch 'exit
+      ;; ASSUME this is run already via `org-agenda-run-series'
       (org-agenda-prepare "DAG-DAILY")
       (org-compile-prefix-format 'agenda)
       (org-set-sorting-strategy 'agenda)
@@ -4079,10 +4165,36 @@ FUTURE-LIMIT in a list."
                            org-last-args (,arg ,start-day ,span)
                            org-redo-cmd ,org-agenda-redo-command
                            org-series-cmd ,org-cmd))
+        ;; ASSUME this will be run via `org-agenda-run-series'
         (org-agenda-finalize)
         (setq buffer-read-only t)))))
 
-;; agenda helper functions
+;; agenda helper functions/macros
+
+;; (defmacro org-x-dag-with-raw-headline (agenda-line &rest body)
+;;   "Execute BODY on original headline referred to with AGENDA-LINE."
+;;   (declare (indent 1))
+;;   `(-when-let (marker (get-text-property 1 'org-marker ,agenda-line))
+;;      (with-current-buffer (marker-buffer marker)
+;;        (goto-char marker)
+;;        ,@body)))
+
+;; (defun org-x-dag-mk-super-agenda-pred (body)
+;;   "Return a predicate function with BODY.
+;; The function will be a lambda form that takes one argument, the
+;; current agenda line, and executes BODY at the point in the
+;; original buffer pointed at by the agenda line."
+;;   `(lambda (agenda-line)
+;;      (org-x-dag-with-raw-headline agenda-line ,@body)))
+
+;; (defmacro org-x-dag-def-super-agenda-pred (name &rest body)
+;;   "Make super agenda predicate form with NAME and BODY.
+;; Key-pairs at the end of BODY will be interpreted as a plist to append
+;; to the end of the predicate form."
+;;   (declare (indent 1))
+;;   (-let* (((pred-body plist) (--split-with (not (keywordp it)) body))
+;;           (pred (org-x-dag-mk-super-agenda-pred pred-body)))
+;;     `(quote (:name ,name :pred ,pred ,@plist))))
 
 (defun org-x-dag-agenda-run-series (name files cmds)
   (declare (indent 2))
@@ -4162,6 +4274,14 @@ event of an error or nonlocal exit."
 ;; understand `org-agenda-files' (the variable) as pointing to a function which
 ;; references files in the dag after the dag is initialized
 
+;; TODO put this somewhere more obvious
+;;
+;; In case this is mysterious, this will tell the agenda prep functions to
+;; not scan every single file (possibly multiple times) to "refresh" properties
+;; that I don't use. I do use effort, but the DAG builder is set up to parse
+;; effort by itself, so not even this is necessary
+;; (setq org-agenda-ignore-properties '(effort stats appt category))
+
 (defun org-x-dag-agenda-timeblock ()
   "Show the timeblock agenda view.
 
@@ -4170,25 +4290,34 @@ In the order of display
 2. daily calendar (for thing that begin today at a specific time)
 3. evening tasks (to do immediately before sleeping)"
   (interactive)
-  (let ((files (cons (org-x-dag->planning-file :daily)
+  (cl-flet
-                     (org-x-dag->action-files))))
+      ((routine-form
-    (org-x-dag-agenda-call-inner "Timeblock" 'agenda "" files
+        (name order prop value)
-      `((org-agenda-sorting-strategy '(time-up deadline-up scheduled-up category-keep))
+        (let ((f `(lambda (line)
-        (org-super-agenda-groups
+                    (->> (get-text-property 1 'x-id line)
-         `(,(nd/org-def-super-agenda-pred "Morning routine"
+                         (org-x-dag-id->has-node-property-p ,prop ,value)))))
-              (org-x-headline-has-property org-x-prop-routine
+          `(:name ,name :order ,order :pred ,f))))
-                                           org-x-prop-routine-morning)
+    (let ((files (cons (org-x-dag->planning-file :daily)
-              :order 0)
+                       (org-x-dag->action-files)))
-           ,(nd/org-def-super-agenda-pred "Evening routine"
+          (conflict-fun (lambda (a)
-              (org-x-headline-has-property org-x-prop-routine
+                          (-when-let (i (get-text-property 1 'x-conflict-id a))
-                                           org-x-prop-routine-evening)
+                            (->> (org-x-dag-id->title i)
-              :order 2)
+                                 (format "Conflict: %s"))))))
-           (:name "Calendar" :order 1 :time-grid t
+      (org-x-dag-agenda-call-inner "Timeblock" 'agenda "" files
-                  :transformer (if (equal (get-text-property 1 'org-category it) "daily")
+        `((org-agenda-sorting-strategy '(time-up category-keep))
-                                   (propertize it 'face 'org-todo)
+          (org-super-agenda-groups
-                                 it))
+           '((:auto-map ,conflict-fun :order 5)
-           (:name "Deadlined" :order 3 :deadline t)
+             ,(routine-form "Morning Routine"
-           (:name "Scheduled" :order 4 :scheduled t)))))))
+                            0
+                            org-x-prop-routine
+                            org-x-prop-routine-morning)
+             ,(routine-form "Evening Routine"
+                            2
+                            org-x-prop-routine
+                            org-x-prop-routine-evening)
+             (:name "Calendar" :order 1 :time-grid t)
+             (:name "Deadlined" :order 3 :deadline t)
+             (:name "Scheduled" :order 4 :scheduled t))))))))
 
 (defun org-x-dag-agenda-goals ()
   (interactive)