redo conflict detection
This commit is contained in:
ndwarshuis
parent
50cc8c1f6b
commit
7bc64fae32
238
conf.org
238
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/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))))))
|
||||
|
||||
(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
|
||||
(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))))
|
||||
((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)))))))
|
||||
|
||||
;; 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))))
|
||||
(defun nd/org-conflict-extract (acc fun objs &rest args)
|
||||
(while objs
|
||||
(setq acc (apply fun acc (car objs) args)
|
||||
objs (cdr objs)))
|
||||
acc)
|
||||
|
||||
;; match timestamps with only one time
|
||||
(t (setq ts-entry (org-2ft ts))))
|
||||
(list ts-entry ts-range marker ts))))
|
||||
(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)))))
|
||||
|
||||
(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-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))))
|
||||
|
||||
;; 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 (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))))
|
||||
|
||||
;; build a list of conflicts
|
||||
(nd/build-conlist ts-list conflicts)))
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue