From 7bc64fae32cabbcd1c0b977cb02d6c6d50a8123c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 18 Jan 2019 00:00:40 -0500 Subject: [PATCH] redo conflict detection --- conf.org | 242 ++++++++++++++++++++++++++++++++----------------------- 1 file changed, 143 insertions(+), 99 deletions(-) diff --git a/conf.org b/conf.org index cd980e1..6cb707d 100644 --- a/conf.org +++ b/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) - "Return t if timestamps TS-A and TS-B conflict." - (let* ((earlier-a (car ts-a)) - (earlier-b (car ts-b)) - (later-b (+ earlier-b (nth 1 ts-b)))) - (and (>= earlier-a earlier-b) (<= earlier-a later-b)))) +;; TODO either need the file path or turn the point into a marker +(defun nd/org-conflict-make-entry (ts range offset fp &optional type) + (list :timestamp ts + :range (or range 0) + :offset offset + :type type + :filepath fp)) -(defun nd/detect-conflict (ts ts-list conlist) - "Recursively determine if timestamp TS conflicts with anything in TS-LIST. -If detected, conflict pair is added to CONLIST." - (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. +(defun nd/org-conflict-parse-ts (ts) + "Return start and end of timestamp TS depending on if it is a range. +Return value will be (start . range) if range and (start) if not." + (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)))))) -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 +(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 nd/org-tsm-regexp ts) - (let* ((ts1 (concat (match-string 1 ts) (match-string 2 ts))) - (ts2 (concat (match-string 1 ts) (match-string 3 ts))) - (ft1 (org-2ft ts1)) - (ft2 (org-2ft ts2))) - (setq ts-entry ft1) - (setq ts-range (- ft2 ft1)))) - - ;; match timestamps that have a range (eq two timestamps) - ((string-match org-tr-regexp ts) - (let* ((ts1 (match-string 1 ts)) - (ts2 (match-string 2 ts)) - (ft1 (org-2ft ts1)) - (ft2 (org-2ft ts2))) - (setq ts-entry ft1) - (setq ts-range (- ft2 ft1)))) - - ;; match timestamps with only one time - (t (setq ts-entry (org-2ft ts)))) - (list ts-entry ts-range marker ts)))) + ((string-match "^\\([0-9]+\\):\\([0-6][0-9]\\)$" effort-str) + (let ((hours (->> effort-str + (match-string 1) + string-to-number + (* 60)))) + (->> effort-str + (match-string 2) + string-to-number + (+ hours) + (* 60)))) + (t (error (format "Unknown effort: %s'" effort-str))))))) -(defun nd/build-conflict-list () - "Scan all org files and make a list of all timestamps that conflict." - (let ((files (org-agenda-files)) - max-reached ts-list cur-index conflicts) - ;; get all timestamps from org buffers - (dolist (f files ts-list) - (with-current-buffer - (find-file-noselect f) - (goto-char (point-min)) - (when (not (outline-on-heading-p)) (outline-next-heading)) - (setq max-reached nil) - (while (not max-reached) - (let ((new-ts (nd/get-timestamps))) - (if new-ts (setq ts-list (cons new-ts ts-list)))) - (unless (outline-next-heading) (setq max-reached t))))) +(defun nd/org-conflict-extract (acc fun objs &rest args) + (while objs + (setq acc (apply fun acc (car objs) args) + objs (cdr objs))) + acc) - ;; sort the timestamp list - ;; TODO, need to make range-aware - (setq ts-list (sort ts-list (lambda (a b) (< (car a) (car b))))) +(defun nd/org-conflict-extract-hl-sched (acc hl fp) + (let ((ts-sched (->> hl + (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))))) - ;; build a list of conflicts - (nd/build-conlist ts-list conflicts))) +(defun nd/org-conflict-extract-hl-ts (acc hl fp) + (let ((offset (org-element-property :begin hl))) + (--> + hl + (assoc 'section it) + (org-element-contents it) + (--remove + (or (eq 'planning (org-element-type it)) + (eq 'property-drawer (org-element-type it)) + (eq 'drawer (org-element-type it))) + it) + (org-element-map it 'timestamp #'identity) + (--filter + (or (eq 'active (org-element-property :type it)) + (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)))) + +(defun nd/org-conflict-extract-hl (acc hl fp) + (let ((sub (--> (org-element-contents hl) + (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)))) + +(defun nd/org-conflict-extract-file (acc fp) + (--> + 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)) - (when rtnall - (mapc - (lambda (c) - (insert (concat "Between " (mapconcat (lambda (ts) (nth 3 ts)) c " and ") "\n")) - (insert (concat (mapconcat (lambda (ts) (nd/get-conflict-header-text (nth 2 ts))) c "\n") "\n")) - (insert "\n")) - rtnall)) + (-some-> + (nd/org-conflict-get) + (--each + (insert (concat + "At " (nd/org-conflct-ts-fmt (car it)) "\n" + (nd/get-conflict-header-text (car it)) "\n" + (nd/get-conflict-header-text (cdr it)) "\n" + "\n")))) ;; clean up and finalize (goto-char (point-min))