redo conflict detection

This commit is contained in:
ndwarshuis 2019-01-18 00:00:40 -05:00
parent 50cc8c1f6b
commit 7bc64fae32
1 changed files with 143 additions and 99 deletions

242
conf.org
View File

@ -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))