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

238
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 *** 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))
(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 (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 (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 #+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))