redo conflict detection
This commit is contained in:
ndwarshuis
parent
50cc8c1f6b
commit
7bc64fae32
242
conf.org
242
conf.org
|
|
@ -1448,7 +1448,7 @@ The modeline is a nice place to indicate if something is clocked in or out. Unfo
|
||||||
*** conflict detection
|
*** conflict detection
|
||||||
Somehow org-mode has no way to detect conflicts between tasks with timestamps (!!??). Luckily I can make my own.
|
Somehow org-mode has no way to detect conflicts between tasks with timestamps (!!??). Luckily I can make my own.
|
||||||
**** backend
|
**** 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:
|
Steps for this algorithm:
|
||||||
1. make a list of all entries with timestamps
|
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)
|
This should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything conflicts)
|
||||||
#+BEGIN_SRC emacs-lisp
|
#+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))
|
(when ts
|
||||||
(rem-ts (cdr ts-list)))
|
(let ((split
|
||||||
(if (nd/are-conflicting-p ts next-ts)
|
(lambda (ts &optional end)
|
||||||
(progn
|
(--> ts
|
||||||
(setq conlist (cons (list ts next-ts) conlist))
|
(org-timestamp-split-range it end)
|
||||||
(if rem-ts (nd/detect-conflict ts rem-ts conlist) conlist))
|
(org-element-property :raw-value it)
|
||||||
conlist)))
|
(org-2ft it)))))
|
||||||
|
(if (eq (org-element-property :type ts) 'active-range)
|
||||||
(defun nd/build-conlist (ts-list conlist)
|
(let ((start (funcall split ts))
|
||||||
"Recursively build a list of timestamp conflicts from TS-LIST.
|
(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)
|
(defun nd/org-conflict-effort-seconds (effort-str)
|
||||||
where timerange is 0 for singular timestamps and a positive number for
|
"Convert EFFORT-STR into an integer in seconds from HH:MM format."
|
||||||
anything with to times or a timestamp range.
|
(let ((effort-str (string-trim effort-str)))
|
||||||
Detected conflicts are stored in CONLIST as pairs of conflicting ts
|
(save-match-data
|
||||||
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
|
|
||||||
(cond
|
(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)
|
||||||
;; match timestamps that have a range (eq two timestamps)
|
(* 60))))
|
||||||
((string-match org-tr-regexp ts)
|
(t (error (format "Unknown effort: %s'" effort-str)))))))
|
||||||
(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))))
|
|
||||||
|
|
||||||
(defun nd/build-conflict-list ()
|
(defun nd/org-conflict-extract (acc fun objs &rest args)
|
||||||
"Scan all org files and make a list of all timestamps that conflict."
|
(while objs
|
||||||
(let ((files (org-agenda-files))
|
(setq acc (apply fun acc (car objs) args)
|
||||||
max-reached ts-list cur-index conflicts)
|
objs (cdr objs)))
|
||||||
;; get all timestamps from org buffers
|
acc)
|
||||||
(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)))))
|
|
||||||
|
|
||||||
;; sort the timestamp list
|
(defun nd/org-conflict-extract-hl-sched (acc hl fp)
|
||||||
;; TODO, need to make range-aware
|
(let ((ts-sched (->> hl
|
||||||
(setq ts-list (sort ts-list (lambda (a b) (< (car a) (car b)))))
|
(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
|
(defun nd/org-conflict-extract-hl-ts (acc hl fp)
|
||||||
(nd/build-conlist ts-list conflicts)))
|
(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
|
#+END_SRC
|
||||||
**** frontend
|
**** 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.
|
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
|
#+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
|
"Return string with text properties representing the org header for
|
||||||
MARKER for use in the conflict agenda view."
|
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
|
'face nil
|
||||||
'done-face 'org-agenda-done
|
'done-face 'org-agenda-done
|
||||||
'org-not-done-regexp org-not-done-regexp
|
'org-not-done-regexp org-not-done-regexp
|
||||||
'org-todo-regexp org-todo-regexp
|
'org-todo-regexp org-todo-regexp
|
||||||
'org-complex-heading-regexp org-complex-heading-regexp
|
'org-complex-heading-regexp org-complex-heading-regexp
|
||||||
'mouse-face 'highlight))
|
'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
|
marker priority category level tags todo-state
|
||||||
ts-date ts-date-type ts-date-pair
|
ts-date ts-date-type ts-date-pair
|
||||||
txt beg end inherited-tags todo-state-end-pos)
|
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
|
(save-excursion
|
||||||
(goto-char conflict-marker)
|
(goto-char ts-marker)
|
||||||
|
|
||||||
(setq marker (org-agenda-new-marker (point))
|
(setq marker (org-agenda-new-marker (point))
|
||||||
category (org-get-category)
|
category (org-get-category)
|
||||||
|
|
@ -1596,6 +1636,10 @@ MARKER for use in the conflict agenda view."
|
||||||
'ts-date ts-date
|
'ts-date ts-date
|
||||||
'type "timestamp")))))
|
'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)
|
(defun nd/org-conflicts (&optional arg)
|
||||||
(interactive "P")
|
(interactive "P")
|
||||||
|
|
||||||
|
|
@ -1626,14 +1670,14 @@ MARKER for use in the conflict agenda view."
|
||||||
'short-heading "Conflicts"))
|
'short-heading "Conflicts"))
|
||||||
(org-agenda-mark-header-line (point-min))
|
(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
|
;; clean up and finalize
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue