redo conflict detection

conf.org

@@ -1448,7 +1448,7 @@ The modeline is a nice place to indicate if something is clocked in or out. Unfo
 *** conflict detection
 Somehow org-mode has no way to detect conflicts between tasks with timestamps (!!??). Luckily I can make my own.
 **** backend
-The algoithm to detect conflicts scans all org files and stores conflicts in a list of pairs of each heading with a conflicting timestamp.
+The algorithm to detect conflicts scans all org files and stores conflicts in a list of pairs of each heading with a conflicting timestamp.
 
 Steps for this algorithm:
 1. make a list of all entries with timestamps
@@ -1457,119 +1457,159 @@ Steps for this algorithm:
 
 This should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything conflicts)
 #+BEGIN_SRC emacs-lisp
-(defun nd/are-conflicting-p (ts-a ts-b)
+;; TODO either need the file path or turn the point into a marker
-  "Return t if timestamps TS-A and TS-B conflict."
+(defun nd/org-conflict-make-entry (ts range offset fp &optional type)
-  (let* ((earlier-a (car ts-a))
+  (list :timestamp ts
-         (earlier-b (car ts-b))
+        :range (or range 0)
-         (later-b (+ earlier-b (nth 1 ts-b))))
+        :offset offset
-    (and (>= earlier-a earlier-b) (<= earlier-a later-b))))
+        :type type
+        :filepath fp))
 
-(defun nd/detect-conflict (ts ts-list conlist)
+(defun nd/org-conflict-parse-ts (ts)
-  "Recursively determine if timestamp TS conflicts with anything in TS-LIST.
+  "Return start and end of timestamp TS depending on if it is a range.
-If detected, conflict pair is added to CONLIST."
+Return value will be (start . range) if range and (start) if not."
-  (let ((next-ts (car ts-list))
-        (rem-ts (cdr ts-list)))
-    (if (nd/are-conflicting-p ts next-ts)
-        (progn
-          (setq conlist (cons (list ts next-ts) conlist))
-          (if rem-ts (nd/detect-conflict ts rem-ts conlist) conlist))
-      conlist)))
-  
-(defun nd/build-conlist (ts-list conlist)
-  "Recursively build a list of timestamp conflicts from TS-LIST.
-
-TS-LIST is comprised of entries in the form (staring-ts timerange marker) 
-where timerange is 0 for singular timestamps and a positive number for
-anything with to times or a timestamp range.
-Detected conflicts are stored in CONLIST as pairs of conflicting ts
-entries from the TS-LIST."
-  (let ((cur-ts (car ts-list))
-        (rem-ts (cdr ts-list)))
-    (if rem-ts
-        (nd/build-conlist rem-ts (nd/detect-conflict cur-ts rem-ts conlist))
-      conlist)))
-
-(defconst nd/org-tsm-regexp
-  "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^]+0-9>\r\n -]+? \\)\\([0-9]\\{1,2\\}:[0-9]\\{2\\}?\\)-\\([0-9]\\{1,2\\}:[0-9]\\{2\\}\\)"
-  "Regular expression for timestamps with two times.")
-
-(defun nd/get-timestamps ()
-  "Get the org-marker and timestamp(s) (multiple if range) or current heading."
-  ;; TODO, what if I care about more than just TIMESTAMPs
-  (let* ((ts (org-entry-get nil "TIMESTAMP"))
-         (marker (point-marker))
-         (ts-range 0)
-         (ts-entry))
   (when ts
+    (let ((split
+           (lambda (ts &optional end)
+             (--> ts
+                  (org-timestamp-split-range it end)
+                  (org-element-property :raw-value it)
+                  (org-2ft it)))))
+      (if (eq (org-element-property :type ts) 'active-range)
+          (let ((start (funcall split ts))
+                (end (funcall split ts t)))
+            (cons start (- end start)))
+        `(,(funcall split ts))))))
+
+(defun nd/org-conflict-effort-seconds (effort-str)
+  "Convert EFFORT-STR into an integer in seconds from HH:MM format."
+  (let ((effort-str (string-trim effort-str)))
+    (save-match-data
       (cond
-       ;; match timestamps that have two times
+       ((string-match "^\\([0-9]+\\):\\([0-6][0-9]\\)$" effort-str)
-       ((string-match nd/org-tsm-regexp ts)
+        (let ((hours (->> effort-str
-        (let* ((ts1 (concat (match-string 1 ts) (match-string 2 ts)))
+                          (match-string 1)
-               (ts2 (concat (match-string 1 ts) (match-string 3 ts)))
+                          string-to-number
-               (ft1 (org-2ft ts1))
+                          (* 60))))
-               (ft2 (org-2ft ts2)))
+          (->> effort-str
-          (setq ts-entry ft1)
+               (match-string 2)
-          (setq ts-range (- ft2 ft1))))
+               string-to-number
+               (+ hours)
+               (* 60))))
+       (t (error (format "Unknown effort: %s'" effort-str)))))))
 
-       ;; match timestamps that have a range (eq two timestamps)
+(defun nd/org-conflict-extract (acc fun objs &rest args)
-       ((string-match org-tr-regexp ts)
+  (while objs
-        (let* ((ts1 (match-string 1 ts))
+    (setq acc (apply fun acc (car objs) args)
-               (ts2 (match-string 2 ts))
+          objs (cdr objs)))
-               (ft1 (org-2ft ts1))
+  acc)
-               (ft2 (org-2ft ts2)))
-          (setq ts-entry ft1)
-          (setq ts-range (- ft2 ft1))))
 
-       ;; match timestamps with only one time
+(defun nd/org-conflict-extract-hl-sched (acc hl fp)
-       (t (setq ts-entry (org-2ft ts))))
+  (let ((ts-sched (->> hl
-      (list ts-entry ts-range marker ts))))
+                       (org-element-property :scheduled)
+                       (org-element-property :raw-value)
+                       (org-2ft)))
+        (range (-some->> hl
+                         (org-element-property :EFFORT)
+                         nd/org-conflict-effort-seconds))
+        (offset (org-element-property :begin hl)))
+    (if (= 0 ts-sched) acc
+      (-> ts-sched
+          (nd/org-conflict-make-entry range offset fp 'scheduled)
+          (cons acc)))))
 
-(defun nd/build-conflict-list ()
+(defun nd/org-conflict-extract-hl-ts (acc hl fp)
-  "Scan all org files and make a list of all timestamps that conflict."
+  (let ((offset (org-element-property :begin hl)))
-  (let ((files (org-agenda-files))
+    (-->
-        max-reached ts-list cur-index conflicts)
+     hl
-    ;; get all timestamps from org buffers
+     (assoc 'section it)
-    (dolist (f files ts-list)
+     (org-element-contents it)
-      (with-current-buffer
+     (--remove
-        (find-file-noselect f)
+      (or (eq 'planning (org-element-type it))
-        (goto-char (point-min))
+          (eq 'property-drawer (org-element-type it))
-        (when (not (outline-on-heading-p)) (outline-next-heading))
+          (eq 'drawer (org-element-type it)))
-        (setq max-reached nil)
+      it)
-        (while (not max-reached)
+     (org-element-map it 'timestamp #'identity)
-          (let ((new-ts (nd/get-timestamps)))
+     (--filter
-            (if new-ts (setq ts-list (cons new-ts ts-list))))
+      (or (eq 'active (org-element-property :type it))
-          (unless (outline-next-heading) (setq max-reached t)))))
+          (eq 'active-range (org-element-property :type it)))
+      it)
+     (mapcar #'nd/org-conflict-parse-ts it)
+     (--map (nd/org-conflict-make-entry (car it) (cdr it) offset fp) it)
+     (append acc it))))
 
-    ;; sort the timestamp list
+(defun nd/org-conflict-extract-hl (acc hl fp)
-    ;; TODO, need to make range-aware
+  (let ((sub (--> (org-element-contents hl)
-    (setq ts-list (sort ts-list (lambda (a b) (< (car a) (car b)))))
+                  (if (assoc 'section it) (cdr it) it))))
+    (-> acc
+        (nd/org-conflict-extract-hl-sched hl fp)
+        (nd/org-conflict-extract-hl-ts hl fp)
+        (nd/org-conflict-extract #'nd/org-conflict-extract-hl sub fp))))
 
-    ;; build a list of conflicts
+(defun nd/org-conflict-extract-file (acc fp)
-    (nd/build-conlist ts-list conflicts)))
+  (-->
+   fp
+   (find-file-noselect it t)
+   (with-current-buffer it (org-element-parse-buffer))
+   (org-element-contents it)
+   (if (assoc 'section it) (cdr it) it)
+   (nd/org-conflict-extract acc #'nd/org-conflict-extract-hl it fp)))
+
+(defun nd/org-conflict-conflicting-p (ts-a ts-b)
+  "Return t if timestamps TS-A and TS-B conflict."
+  (let* ((start-a (plist-get ts-a :timestamp))
+         (start-b (plist-get ts-b :timestamp))
+         (end-a (+ start-a (plist-get ts-a :range)))
+         (end-b (+ start-b (plist-get ts-b :range))))
+    (<= start-a start-b end-a)))
+
+(defun nd/find-conflict (ts ts-list conlist)
+  (->> ts-list
+       (--take-while (nd/org-conflict-conflicting-p ts it))
+       (--map (cons ts it))
+       (append conlist)))
+  
+(defun nd/org-conflict-build-conlist (ts-list)
+  (let ((conlist))
+    (while (< 1 (length ts-list))
+      (setq conlist (nd/find-conflict (car ts-list) (cdr ts-list) conlist)
+            ts-list (cdr ts-list)))
+    conlist))
+
+(defun nd/org-conflict-get ()
+  (->>
+   ;; (list "~/Org/reference/testconflict.org")
+   (org-agenda-files)
+   (nd/org-conflict-extract nil #'nd/org-conflict-extract-file)
+   (--sort (< (plist-get it :timestamp) (plist-get other :timestamp)))
+   nd/org-conflict-build-conlist))
 #+END_SRC
 **** frontend
 To display any conflicts, I could just fetch the org headings and throw them into a new buffer. But that's boring, and quite limiting. I basically want all the perks of an agenda buffer...tab-follow, the nice parent display at the bottom, time adjust hotkeys, etc. So the obvious and hacky solution is to throw together a quick-n-dirty agenda buffer which displays each conflict pair in sequentional fashion.
 #+BEGIN_SRC emacs-lisp
-(defun nd/get-conflict-header-text (conflict-marker)
+(defun nd/get-conflict-header-text (ts-entry)
   "Return string with text properties representing the org header for
 MARKER for use in the conflict agenda view."
-  (let* ((props (list
+  (let* ((offset (plist-get ts-entry :offset))
+         (ts-marker (--> ts-entry
+                         (plist-get it :filepath)
+                         (find-file-noselect it)
+                         (with-current-buffer it
+                           (copy-marker offset))))
+         (props (list
                  'face nil
 		         'done-face 'org-agenda-done
 		         'org-not-done-regexp org-not-done-regexp
 		         'org-todo-regexp org-todo-regexp
 		         'org-complex-heading-regexp org-complex-heading-regexp
 		         'mouse-face 'highlight))
-		         ;; 'help-echo
-		         ;; (format "mouse-2 or RET jump to org file %s"
-			     ;;         (abbreviate-file-name buffer-file-name))))
 	     marker priority category level tags todo-state
 	     ts-date ts-date-type ts-date-pair
 	     txt beg end inherited-tags todo-state-end-pos)
 
-    (with-current-buffer (marker-buffer conflict-marker) 
+    (with-current-buffer (marker-buffer ts-marker) 
       (save-excursion
-	    (goto-char conflict-marker)
+	    (goto-char ts-marker)
 
 	    (setq marker (org-agenda-new-marker (point))
 	          category (org-get-category)
@@ -1596,6 +1636,10 @@ MARKER for use in the conflict agenda view."
 	      'ts-date ts-date
 	      'type "timestamp")))))
 
+(defun nd/org-conflct-ts-fmt (ts)
+  (let ((fmt "[%Y-%m-%d %H:%M]"))
+    (--> ts (plist-get it :timestamp) (format-time-string fmt it))))
+
 (defun nd/org-conflicts (&optional arg)
   (interactive "P")
 
@@ -1626,14 +1670,14 @@ MARKER for use in the conflict agenda view."
 				                 'short-heading "Conflicts"))
 	  (org-agenda-mark-header-line (point-min))
 
-      (setq rtnall (nd/build-conflict-list))
+      (-some->
-      (when rtnall
+       (nd/org-conflict-get)
-        (mapc
+       (--each
-         (lambda (c)
+           (insert (concat
-           (insert (concat "Between " (mapconcat (lambda (ts) (nth 3 ts)) c " and ") "\n"))
+                    "At " (nd/org-conflct-ts-fmt (car it)) "\n"
-           (insert (concat (mapconcat (lambda (ts) (nd/get-conflict-header-text (nth 2 ts))) c "\n") "\n"))
+                    (nd/get-conflict-header-text (car it)) "\n"
-           (insert "\n"))
+                    (nd/get-conflict-header-text (cdr it)) "\n"
-         rtnall))
+                    "\n"))))
 
       ;; clean up and finalize
       (goto-char (point-min))