ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF move clustering code to org-x

This commit is contained in:
Nathan Dwarshuis 2021-04-11 21:20:02 -04:00
parent 8990cb417d
commit d9bc5863a1
2 changed files with 487 additions and 483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

491
etc/conf.org
View File

@ -2413,488 +2413,13 @@ The modeline is a nice place to indicate if something is clocked in or out. Unfo
(setq spaceline-highlight-face-func 'nd/spaceline-highlight-face-clocked)
#+END_SRC
*** clustering
Org mode has no way of detecting if conflicts exist. It also has no way of alerting someone if they have overbooked their schedule
**** extraction filters
:PROPERTIES:
:ID: 8384e715-dfe2-4197-9b0e-88bb32c3afa0
:END:
These control which types of headlines are processed by org-cluster
#+BEGIN_SRC emacs-lisp
(defvar nd/org-cluster-filter-files t
"Set to t if files should be filtered in org-cluster.
This option does nothing unless `nd/org-cluster-filtered-files' is
also non-nil.")
Org mode has no way of detecting if conflicts exist. It also has no way of alerting someone if they have overbooked their schedule.
(defconst nd/org-cluster-filtered-files
'("incubator" "peripheral")
"Files that should be excluded from org-cluster analysis.
These are pattern-matched so they do not need to be exact names
or paths.")
(defvar nd/org-cluster-filter-todo t
"Set to t if todo keywords should be filtered in org-cluster.
This option does nothing unless `nd/org-cluster-filtered-todo' is
also non-nil.")
(defconst nd/org-cluster-filtered-todo
'("CANC" "DONE")
"TODO keywords that should be filtered from org-cluster analysis.")
(defvar nd/org-cluster-filter-past t
"Set to t to exclude files from before now in org-cluster analysis.")
(defvar nd/org-cluster-filter-habit nil
"Set to t to exclude habits from org-cluster analysis.")
#+END_SRC
**** timestamp extraction and filtering
:PROPERTIES:
:ID: 3f39fe19-b89e-47f1-80d4-e6a532788527
:END:
Conflicts and overloads begin with the same list to process, which is created using =org-element-parse-buffer= and a variety of filtering functions to extract relevent timestamps.
The main object that is passed around during extraction and processing is the timestamp-plist as described in =nd/org-cluster-make-tsp= below.
#+BEGIN_SRC emacs-lisp
(defun nd/org-cluster-make-tsp (unixtime range offset fp hardness
&optional type)
"Construct a timestamp plist to be used in further processing.
UNIXTIME is the unixtime of the timestamp as an integer, RANGE is the
duration of the timestamp (could be 0), OFFSET is the character offset
of the timestamp in the file represented with filepath FP, HARDNESS
is a boolean denoting if the timestamp is 'hard' (has minutes and
hours) or 'soft' (only a date). TYPE can be optionally supplied to
denote kinds of timestamps (only 'scheduled' for now)."
(list :unixtime (round unixtime)
:range (or range 0)
:offset offset
:type type
:hardness hardness
:filepath fp))
(defun nd/org-cluster-ts-hard-p (ts)
"Return non-nil if the timestamp TS has hours/minutes."
(org-element-property :hour-start ts))
(defun nd/org-cluster-parse-ts (ts hl fp)
"Parse a timestamp TS belonging to headline HL and filepath FP.
TS is an object as described in the org-element API. Only active
or active-range types are considered. Returns a new timestamp-plist
for TS."
(when ts
(let* ((offset (org-element-property :begin hl))
(hardness (nd/org-cluster-ts-hard-p ts))
(split
(lambda (ts &optional end)
(--> ts
(org-timestamp-split-range it end)
(org-element-property :raw-value it)
(org-2ft it))))
(start (funcall split ts)))
(if (eq (org-element-property :type ts) 'active-range)
(let ((range (--> ts (funcall split it t) (- it start))))
(nd/org-cluster-make-tsp start range offset fp hardness))
(nd/org-cluster-make-tsp start 0 offset fp hardness)))))
(defun nd/org-cluster-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
((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/org-cluster-extract (acc fun objs &rest args)
"Run FUN on each of OBJS and put results into accumulator ACC.
FUN is a function that takes the accumulator as its first argument,
one member of OBJS as the second, and ARGS as the rest if supplied."
(while objs
(setq acc (apply fun acc (car objs) args)
objs (cdr objs)))
acc)
(defun nd/org-cluster-extract-hl-sched (acc hl fp)
"Extract scheduled timestamp from headline HL in filepath FP.
Create a new timestamp-plist and add to accumulator ACC."
(let* ((ts (org-element-property :scheduled hl))
(unixtime (->> ts (org-element-property :raw-value) org-2ft))
(range (-some->> hl
(org-element-property :EFFORT)
nd/org-cluster-effort-seconds))
(hardness (nd/org-cluster-ts-hard-p ts))
(offset (org-element-property :begin hl)))
(if (= 0 unixtime) acc
(-> unixtime
(nd/org-cluster-make-tsp range offset fp hardness 'scheduled)
(cons acc)))))
(defun nd/org-cluster-extract-hl-ts (acc hl fp)
"Extract timestamps from headline HL in filepath FP.
All active timestamps that are not in drawers or the planning header
are considered. Each timestamp is converted into a new timestamp-plist
and added to accumulator ACC."
(--> 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)
(--map (nd/org-cluster-parse-ts it hl fp) it)
(append acc it)))
(defun nd/org-cluster-extract-hl (acc hl fp)
"Extract timestamps from headline HL in filepath FP and store in ACC."
(-> acc
(nd/org-cluster-extract-hl-sched hl fp)
(nd/org-cluster-extract-hl-ts hl fp)))
(defun nd/org-cluster-filter-todo (hls)
"Filter certain TODO keywords from headline list HLS."
(if (not nd/org-cluster-filter-todo) hls
(--remove
(member (org-element-property :todo-keyword it)
nd/org-cluster-filtered-todo)
hls)))
(defun nd/org-cluster-filter-files (fps)
"Filter certain file names from files list FPS."
(if (not nd/org-cluster-filter-files) fps
(--remove
(-find (lambda (s) (string-match-p s it)) nd/org-cluster-filtered-files)
fps)))
(defun nd/org-cluster-filter-past (tsps)
"Filter out timestamp-plists in list TSPS if they start in the past."
(if (not nd/org-cluster-filter-past) tsps
(let ((ft (float-time)))
(--remove (< (plist-get it :unixtime) ft) tsps))))
(defun nd/org-cluster-filter-habit (hls)
"Filter headlines from headline list HLS that are habits."
(if (not nd/org-cluster-filter-habit) hls
(--remove (org-element-property :STYLE it) hls)))
(defun nd/org-cluster-extract-file (acc fp)
"Extract timestamps from filepath FP and add to accumulator ACC."
(-->
fp
(find-file-noselect it t)
(with-current-buffer it (org-element-parse-buffer))
(org-element-map it 'headline #'identity)
(nd/org-cluster-filter-todo it)
(nd/org-cluster-filter-habit it)
(nd/org-cluster-extract acc #'nd/org-cluster-extract-hl it fp)))
(defun nd/org-cluster-get-unprocessed ()
"Return a list of timestamp-plists with desired filter settings."
(->>
;; (list "~/Org/reference/testconflict.org")
(org-agenda-files)
nd/org-cluster-filter-files
(nd/org-cluster-extract nil #'nd/org-cluster-extract-file)
nd/org-cluster-filter-past))
#+END_SRC
**** conflict detection
:PROPERTIES:
:ID: 6b777ec6-3898-4855-8664-84b13f468920
:END:
This algorithm builds a list of pairs, with each pair being a two tasks that conflict and should be O(n) (best case/no conflicts) to O(n^2) (worst case/everything conflicts).
Steps for this:
1. make a list of all entries containing timestamps (active and scheduled)
2. sort timestamp list
3. Walk through list and compare entries immediately after (sorting ensures that entries can be skipped once one non-conflict is found). If conflicts are found push the pair to new list.
#+BEGIN_SRC emacs-lisp
(defun nd/org-cluster-conflicting-p (tsp-a tsp-b)
"Return t if timestamps TS-A and TS-B conflict."
;; assume that ts-a starts before ts-b
(let* ((start-a (plist-get tsp-a :unixtime))
(start-b (plist-get tsp-b :unixtime))
(end-a (-> tsp-a (plist-get :range) (+ start-a))))
(or (= start-a start-b) (< start-b end-a))))
(defun nd/org-cluster-find-conflict (tsp tsps conlist)
"Test if timestamp-plist TSP conflicts with any in TSPS.
If found, anything in TSPS is cons'd with TSP and added to CONLIST
as a pair. New CONLIST is returned."
(->> tsps
(--take-while (nd/org-cluster-conflicting-p tsp it))
(--map (cons tsp it))
(append conlist)))
(defun nd/org-cluster-build-conlist (tsps)
"Build a list of conflict pairs from timestamp-plist TSPS."
(let ((conlist))
(while (< 1 (length tsps))
(setq conlist (nd/org-cluster-find-conflict (car tsps)
(cdr tsps)
conlist)
tsps (cdr tsps)))
conlist))
(defun nd/org-cluster-get-conflicts ()
"Return a list of cons cells representing conflict pairs.
Each member in the cons cell is a timestamp-plist."
(->>
(nd/org-cluster-get-unprocessed)
(--filter (plist-get it :hardness))
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
nd/org-cluster-build-conlist))
#+END_SRC
**** overload detection
:PROPERTIES:
:ID: fe65a792-6b2c-47c0-84a1-98fc4115a04b
:END:
Overloads are defined as days that have more than 24 hours worth of scheduled material. The algorithm is O(n) as it is basically just a bunch of filtering functions that walk through the list.
Steps for the algorithm:
1. filter only ranged entries (unranged entries have zero time)
2. maybe split timestamps if they span multiple days
3. sort from earliest to latest starting time
4. sum the range of timestamps in each day, keeping those that exceed 24 hours
#+BEGIN_SRC emacs-lisp
(defun nd/org-cluster-split-day-bounds (tsps)
"Split timestamp-plists in TSPS via daily boundaries.
Returns a new timestamp-plist with equal or greater length depending
on how many members needed splitting."
(letrec
((new
(lambda (start end tsp)
(nd/org-cluster-make-tsp start
(- end start)
(plist-get tsp :offset)
(plist-get tsp :filepath)
(plist-get tsp :hardness)
(plist-get tsp :type))))
;; need to temporarily offset the epoch time so day
;; boundaries line up in local time
(split
(lambda (start end tsp)
(let* ((tzs-a (-> start current-time-zone car))
(tzs-b (-> end current-time-zone car))
(start* (-> end (+ tzs-b) (ceiling 86400) 1- (* 86400) (- tzs-b))))
(if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a)))
(cons (funcall new start* end tsp)
(funcall split start start* tsp))
(list (funcall new start end tsp))))))
(split-maybe
(lambda (tsp)
(let* ((start (plist-get tsp :unixtime))
(end (+ start (plist-get tsp :range)))
(tzs (-> start current-time-zone car)))
(if (< (-> start (+ tzs) (ceiling 86400)) end)
(funcall split start end tsp)
tsp)))))
(--mapcat (funcall split-maybe it) tsps)))
(defun nd/org-cluster-daily-split (tsps)
"Group timestamp-plist TSPS into sublists for each day."
(letrec ((tz-shift (lambda (tsp) (-> tsp current-time-zone car (+ tsp)))))
(->>
tsps
(--partition-by (--> it
(plist-get it :unixtime)
(funcall tz-shift it)
(floor it 86400))))))
(defun nd/org-cluster-overloaded-p (tsps)
"Return t if total time of timestamp-plists in TSPS exceeds 24 hours.
It is assumed the TSPS represents tasks and appointments within one
day."
(letrec ((ts2diff
(lambda (tsp)
(let ((start (plist-get tsp :unixtime)))
(- (-> tsp (plist-get :range) (+ start)) start)))))
(->> tsps (--map (funcall ts2diff it)) -sum (<= 86400))))
(defun nd/org-cluster-get-overloads ()
"Return list of lists of timestamp-plists grouped by day.
Anything present represents all the tasks in a single day if that day
is overloaded. If a day is not overloaded there will be nothing for it
in the returned list."
(->>
(nd/org-cluster-get-unprocessed)
(--filter (< 0 (plist-get it :range)))
nd/org-cluster-split-day-bounds
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
nd/org-cluster-daily-split
(--filter (nd/org-cluster-overloaded-p it))))
#+END_SRC
**** frontend
:PROPERTIES:
:ID: 43ad0b41-43a7-4d66-a260-0c0e3767469b
:END:
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.
#+BEGIN_SRC emacs-lisp
(defun nd/org-cluster-headline-text (ts-entry)
"Return string with text properties representing the org header for
MARKER for use in the conflict agenda view."
(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))
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 ts-marker)
(save-excursion
(goto-char ts-marker)
(setq marker (org-agenda-new-marker (point))
category (org-get-category)
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
txt (org-get-heading t)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'todo org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags-at nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'priority priority
'level level
'ts-date ts-date
'type "timestamp")))))
(defun nd/org-cluster-ts-fmt (ts)
(let ((fmt "[%Y-%m-%d]"))
(--> ts (plist-get it :unixtime) (format-time-string fmt it))))
;; TODO...waaaaay too wet (not DRY)
(defun nd/org-cluster-show-conflicts (&optional arg)
(interactive "P")
(if org-agenda-overriding-arguments
(setq arg org-agenda-overriding-arguments))
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
(let* ((today (org-today))
(date (calendar-gregorian-from-absolute today))
(completion-ignore-case t)
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))
rtn rtnall files file pos)
(catch 'exit
(when org-agenda-sticky (setq org-agenda-buffer-name "*Org Conflicts*"))
(org-agenda-prepare)
;; (org-compile-prefix-format 'todo)
(org-compile-prefix-format 'agenda)
;; (org-set-sorting-strategy 'todo)
(setq org-agenda-redo-command '(nd/org-cluster-show-conflicts))
(insert "Conflicting Headings: \n")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading "Conflicts"))
(org-agenda-mark-header-line (point-min))
(-some->
(nd/org-cluster-get-conflicts)
(--each
(insert (concat
"At " (nd/org-cluster-ts-fmt (car it)) "\n"
(nd/org-cluster-headline-text (car it)) "\n"
(nd/org-cluster-headline-text (cdr it)) "\n"
"\n"))))
;; clean up and finalize
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type agenda
org-last-args ,arg
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
(defun nd/org-cluster-show-overloads (&optional arg)
(interactive "P")
(if org-agenda-overriding-arguments
(setq arg org-agenda-overriding-arguments))
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
(let* ((today (org-today))
(date (calendar-gregorian-from-absolute today))
(completion-ignore-case t)
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))
rtn rtnall files file pos)
(catch 'exit
(when org-agenda-sticky (setq org-agenda-buffer-name "*Org Overloads*"))
(org-agenda-prepare)
;; (org-compile-prefix-format 'todo)
(org-compile-prefix-format 'agenda)
;; (org-set-sorting-strategy 'todo)
(setq org-agenda-redo-command '(nd/org-cluster-show-overloads))
(insert "Overloaded Days: \n")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading "Overloads"))
(org-agenda-mark-header-line (point-min))
(-some->
(nd/org-cluster-get-overloads)
(--each
(insert (concat
"On " (nd/org-cluster-ts-fmt (car it)) "\n"
(mapconcat #'nd/org-cluster-headline-text it "\n")
"\n"))))
;; clean up and finalize
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type agenda
org-last-args ,arg
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
#+END_SRC
The main code is defined in =org-x= so the following is only to set some domain-specific options.
#+begin_src emacs-lisp
(setq org-x-cluster-filtered-files '("incubator" "peripheral")
org-x-cluster-filtered-todo '("CANC" "DONE"))
#+end_src
*** agenda
:PROPERTIES:
:ID: 73c154c8-e13e-4e90-8a1d-77c3be067502
@ -4674,8 +4199,8 @@ The function keys are nice because they are almost (not always) free in every mo
(global-set-key (kbd "<f1>") 'org-agenda)
(global-set-key (kbd "<f2>") 'org-capture)
(global-set-key (kbd "<f3>") 'cfw:open-org-calendar)
(global-set-key (kbd "C-<f3>") 'nd/org-cluster-show-conflicts)
(global-set-key (kbd "C-S-<f3>") 'nd/org-cluster-show-overloads)
(global-set-key (kbd "C-<f3>") 'org-x-cluster-show-conflicts)
(global-set-key (kbd "C-S-<f3>") 'org-x-cluster-show-overloads)
(global-set-key (kbd "<f4>") 'org-clock-goto)
(global-set-key (kbd "C-<f4>") 'org-tomato-user-get-summary)
(global-set-key (kbd "C-S-<f4>") 'org-tomato-user-pomodoro-goto)

479
local/lib/org-x/org-x.el
View File

@ -66,6 +66,30 @@
Currently used to tell skip functions when they can hop over
entire subtrees to save time and ignore tasks")
(defvar org-x-cluster-filter-files t
"Set to t if files should be filtered in org-cluster.
This option does nothing unless `org-x-cluster-filtered-files' is
also non-nil.")
(defvar org-x-cluster-filtered-files nil
"Files that should be excluded from org-cluster analysis.
These are pattern-matched so they do not need to be exact names
or paths.")
(defvar org-x-cluster-filter-todo t
"Set to t if todo keywords should be filtered in org-cluster.
This option does nothing unless `org-x-cluster-filtered-todo' is
also non-nil.")
(defvar org-x-cluster-filtered-todo nil
"TODO keywords that should be filtered from org-cluster analysis.")
(defvar org-x-cluster-filter-past t
"Set to t to exclude files from before now in org-cluster analysis.")
(defvar org-x-cluster-filter-habit nil
"Set to t to exclude habits from org-cluster analysis.")
;; internal vars
(defvar org-x-agenda-hide-incubator-tags t
@ -1108,5 +1132,460 @@ and slow."
(org-ml-supercontents-set-logbook nil it)
it))))))
;; clustering
;;
;; Conflicts and overloads begin with the same list to process, which is created
;; using `org-element-parse-buffer' and a variety of filtering functions to
;; extract relevent timestamps.
(defun org-x-cluster-make-tsp (unixtime range offset fp hardness &optional type)
"Construct a timestamp plist to be used in further processing.
The fields are as follows:
- UNIXTIME is the unixtime of the timestamp as an integer
- RANGE is the duration of the timestamp (could be 0)
- OFFSET is the character offset of the timestamp in its file
- HARDNESS is a boolean denoting if the timestamp is 'hard' (has minutes and
hours) or 'soft' (only a date).
- TYPE can be optionally supplied to denote kinds of timestamps
(only 'scheduled' for now).
- FP the path to the file in which the timestamp resides"
(list :unixtime (round unixtime)
:range (or range 0)
:offset offset
:type type
:hardness hardness
:filepath fp))
(defun org-x-cluster-ts-hard-p (ts)
"Return non-nil if the timestamp TS has hours/minutes."
(org-element-property :hour-start ts))
(defun org-x-cluster-parse-ts (ts hl fp)
"Parse a timestamp TS belonging to headline HL and filepath FP.
TS is an object as described in the org-element API. Only active
or active-range types are considered. Returns a new timestamp-plist
for TS."
(when ts
(let* ((offset (org-element-property :begin hl))
(hardness (org-x-cluster-ts-hard-p ts))
(split
(lambda (ts &optional end)
(--> ts
(org-timestamp-split-range it end)
(org-element-property :raw-value it)
(org-2ft it))))
(start (funcall split ts)))
(if (eq (org-element-property :type ts) 'active-range)
(let ((range (--> ts (funcall split it t) (- it start))))
(org-x-cluster-make-tsp start range offset fp hardness))
(org-x-cluster-make-tsp start 0 offset fp hardness)))))
(defun org-x-cluster-effort-seconds (effort-str)
"Convert EFFORT-STR into an integer in seconds from HH:MM format."
(-some->> effort-str (org-duration-to-minutes) (* 60)))
;; (let ((effort-str (string-trim effort-str)))
;; (save-match-data
;; (cond
;; ((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 org-x-cluster-extract (acc fun objs &rest args)
"Run FUN on each of OBJS and put results into accumulator ACC.
FUN is a function that takes the accumulator as its first argument,
one member of OBJS as the second, and ARGS as the rest if supplied."
(while objs
(setq acc (apply fun acc (car objs) args)
objs (cdr objs)))
acc)
(defun org-x-cluster-extract-hl-sched (acc hl fp)
"Extract scheduled timestamp from headline HL in filepath FP.
Create a new timestamp-plist and add to accumulator ACC."
(let* ((ts (org-element-property :scheduled hl))
(unixtime (->> ts (org-element-property :raw-value) org-2ft))
(range (-some->> hl
(org-element-property :EFFORT)
org-x-cluster-effort-seconds))
(hardness (org-x-cluster-ts-hard-p ts))
(offset (org-element-property :begin hl)))
(if (= 0 unixtime) acc
(-> unixtime
(org-x-cluster-make-tsp range offset fp hardness 'scheduled)
(cons acc)))))
(defun org-x-cluster-extract-hl-ts (acc hl fp)
"Extract timestamps from headline HL in filepath FP.
All active timestamps that are not in drawers or the planning header
are considered. Each timestamp is converted into a new timestamp-plist
and added to accumulator ACC."
(--> 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)
(--map (org-x-cluster-parse-ts it hl fp) it)
(append acc it)))
(defun org-x-cluster-extract-hl (acc hl fp)
"Extract timestamps from headline HL in filepath FP and store in ACC."
(-> acc
(org-x-cluster-extract-hl-sched hl fp)
(org-x-cluster-extract-hl-ts hl fp)))
(defun org-x-cluster-filter-todo (hls)
"Filter certain TODO keywords from headline list HLS."
(if (not org-x-cluster-filter-todo) hls
(--remove
(member (org-element-property :todo-keyword it)
org-x-cluster-filtered-todo)
hls)))
(defun org-x-cluster-filter-files (fps)
"Filter certain file names from files list FPS."
(if (not org-x-cluster-filter-files) fps
(--remove
(-find (lambda (s) (string-match-p s it)) org-x-cluster-filtered-files)
fps)))
(defun org-x-cluster-filter-past (tsps)
"Filter out timestamp-plists in list TSPS if they start in the past."
(if (not org-x-cluster-filter-past) tsps
(let ((ft (float-time)))
(--remove (< (plist-get it :unixtime) ft) tsps))))
(defun org-x-cluster-filter-habit (hls)
"Filter headlines from headline list HLS that are habits."
(if (not org-x-cluster-filter-habit) hls
(--remove (org-element-property :STYLE it) hls)))
(defun org-x-cluster-extract-file (acc fp)
"Extract timestamps from filepath FP and add to accumulator ACC."
(-->
fp
(find-file-noselect it t)
(with-current-buffer it (org-element-parse-buffer))
(org-element-map it 'headline #'identity)
(org-x-cluster-filter-todo it)
(org-x-cluster-filter-habit it)
(org-x-cluster-extract acc #'org-x-cluster-extract-hl it fp)))
(defun org-x-cluster-get-unprocessed ()
"Return a list of timestamp-plists with desired filter settings."
(->>
;; (list "~/Org/reference/testconflict.org")
(org-agenda-files)
org-x-cluster-filter-files
(org-x-cluster-extract nil #'org-x-cluster-extract-file)
org-x-cluster-filter-past))
;; get conflict headlines
;;
;; This algorithm builds a list of pairs, with each pair being a two tasks that
;; conflict and should be O(n) (best case/no conflicts) to O(n^2) (worst
;; case/everything conflicts).
;;
;; Steps for this:
;; 1. make a list of all entries containing timestamps (active and scheduled)
;; 2. sort timestamp list
;; 3. Walk through list and compare entries immediately after (sorting ensures
;; that entries can be skipped once one non-conflict is found). If conflicts
;; are found push the pair to new list.
(defun org-x-cluster-conflicting-p (tsp-a tsp-b)
"Return t if timestamps TS-A and TS-B conflict."
;; assume that ts-a starts before ts-b
(let* ((start-a (plist-get tsp-a :unixtime))
(start-b (plist-get tsp-b :unixtime))
(end-a (-> tsp-a (plist-get :range) (+ start-a))))
(or (= start-a start-b) (< start-b end-a))))
(defun org-x-cluster-find-conflict (tsp tsps conlist)
"Test if timestamp-plist TSP conflicts with any in TSPS.
If found, anything in TSPS is cons'd with TSP and added to CONLIST
as a pair. New CONLIST is returned."
(->> tsps
(--take-while (org-x-cluster-conflicting-p tsp it))
(--map (cons tsp it))
(append conlist)))
(defun org-x-cluster-build-conlist (tsps)
"Build a list of conflict pairs from timestamp-plist TSPS."
(let ((conlist))
(while (< 1 (length tsps))
(setq conlist (org-x-cluster-find-conflict (car tsps)
(cdr tsps)
conlist)
tsps (cdr tsps)))
conlist))
(defun org-x-cluster-get-conflicts ()
"Return a list of cons cells representing conflict pairs.
Each member in the cons cell is a timestamp-plist."
(->>
(org-x-cluster-get-unprocessed)
(--filter (plist-get it :hardness))
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
org-x-cluster-build-conlist))
;; get overloaded days
;;
;; Overloads are defined as days that have more than 24 hours worth of scheduled
;; material. The algorithm is O(n) as it is basically just a bunch of filtering
;; functions that walk through the list.
;;
;; Steps for the algorithm:
;; 1. filter only ranged entries (unranged entries have zero time)
;; 2. maybe split timestamps if they span multiple days
;; 3. sort from earliest to latest starting time
;; 4. sum the range of timestamps in each day, keeping those that exceed 24 hours
(defun org-x-cluster-split-day-bounds (tsps)
"Split timestamp-plists in TSPS via daily boundaries.
Returns a new timestamp-plist with equal or greater length depending
on how many members needed splitting."
(letrec
((new
(lambda (start end tsp)
(org-x-cluster-make-tsp start
(- end start)
(plist-get tsp :offset)
(plist-get tsp :filepath)
(plist-get tsp :hardness)
(plist-get tsp :type))))
;; need to temporarily offset the epoch time so day
;; boundaries line up in local time
(split
(lambda (start end tsp)
(let* ((tzs-a (-> start current-time-zone car))
(tzs-b (-> end current-time-zone car))
(start* (-> end (+ tzs-b) (ceiling 86400) 1- (* 86400) (- tzs-b))))
(if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a)))
(cons (funcall new start* end tsp)
(funcall split start start* tsp))
(list (funcall new start end tsp))))))
(split-maybe
(lambda (tsp)
(let* ((start (plist-get tsp :unixtime))
(end (+ start (plist-get tsp :range)))
(tzs (-> start current-time-zone car)))
(if (< (-> start (+ tzs) (ceiling 86400)) end)
(funcall split start end tsp)
tsp)))))
(--mapcat (funcall split-maybe it) tsps)))
(defun org-x-cluster-daily-split (tsps)
"Group timestamp-plist TSPS into sublists for each day."
(letrec ((tz-shift (lambda (tsp) (-> tsp current-time-zone car (+ tsp)))))
(->>
tsps
(--partition-by (--> it
(plist-get it :unixtime)
(funcall tz-shift it)
(floor it 86400))))))
(defun org-x-cluster-overloaded-p (tsps)
"Return t if total time of timestamp-plists in TSPS exceeds 24 hours.
It is assumed the TSPS represents tasks and appointments within one
day."
(letrec ((ts2diff
(lambda (tsp)
(let ((start (plist-get tsp :unixtime)))
(- (-> tsp (plist-get :range) (+ start)) start)))))
(->> tsps (--map (funcall ts2diff it)) -sum (<= 86400))))
(defun org-x-cluster-get-overloads ()
"Return list of lists of timestamp-plists grouped by day.
Anything present represents all the tasks in a single day if that day
is overloaded. If a day is not overloaded there will be nothing for it
in the returned list."
(->>
(org-x-cluster-get-unprocessed)
(--filter (< 0 (plist-get it :range)))
org-x-cluster-split-day-bounds
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
org-x-cluster-daily-split
(--filter (org-x-cluster-overloaded-p it))))
;; conflict/overload frontend
;; 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.
(defun org-x-cluster-headline-text (ts-entry)
"Return string with text properties representing the org header for
MARKER for use in the conflict agenda view."
(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))
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 ts-marker)
(save-excursion
(goto-char ts-marker)
(setq marker (org-agenda-new-marker (point))
category (org-get-category)
ts-date-pair (org-agenda-entry-get-agenda-timestamp (point))
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
txt (org-get-heading t)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
(memq 'todo org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags-at nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? )
txt (org-agenda-format-item "" txt level category tags t)
priority (1+ (org-get-priority txt)))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'priority priority
'level level
'ts-date ts-date
'type "timestamp")))))
(defun org-x-cluster-ts-fmt (ts)
(let ((fmt "[%Y-%m-%d]"))
(--> ts (plist-get it :unixtime) (format-time-string fmt it))))
;; TODO...waaaaay too wet (not DRY)
(defun org-x-cluster-show-conflicts (&optional arg)
(interactive "P")
(if org-agenda-overriding-arguments
(setq arg org-agenda-overriding-arguments))
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
(let* ((today (org-today))
(date (calendar-gregorian-from-absolute today))
(completion-ignore-case t)
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))
rtn rtnall files file pos)
(catch 'exit
(when org-agenda-sticky (setq org-agenda-buffer-name "*Org Conflicts*"))
(org-agenda-prepare)
;; (org-compile-prefix-format 'todo)
(org-compile-prefix-format 'agenda)
;; (org-set-sorting-strategy 'todo)
(setq org-agenda-redo-command '(org-x-cluster-show-conflicts))
(insert "Conflicting Headings: \n")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading "Conflicts"))
(org-agenda-mark-header-line (point-min))
(-some->
(org-x-cluster-get-conflicts)
(--each
(insert (concat
"At " (org-x-cluster-ts-fmt (car it)) "\n"
(org-x-cluster-headline-text (car it)) "\n"
(org-x-cluster-headline-text (cdr it)) "\n"
"\n"))))
;; clean up and finalize
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type agenda
org-last-args ,arg
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
(defun org-x-cluster-show-overloads (&optional arg)
(interactive "P")
(if org-agenda-overriding-arguments
(setq arg org-agenda-overriding-arguments))
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
(let* ((today (org-today))
(date (calendar-gregorian-from-absolute today))
(completion-ignore-case t)
(org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))
rtn rtnall files file pos)
(catch 'exit
(when org-agenda-sticky (setq org-agenda-buffer-name "*Org Overloads*"))
(org-agenda-prepare)
;; (org-compile-prefix-format 'todo)
(org-compile-prefix-format 'agenda)
;; (org-set-sorting-strategy 'todo)
(setq org-agenda-redo-command '(org-x-cluster-show-overloads))
(insert "Overloaded Days: \n")
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure
'short-heading "Overloads"))
(org-agenda-mark-header-line (point-min))
(-some->
(org-x-cluster-get-overloads)
(--each
(insert (concat
"On " (org-x-cluster-ts-fmt (car it)) "\n"
(mapconcat #'org-x-cluster-headline-text it "\n")
"\n"))))
;; clean up and finalize
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type agenda
org-last-args ,arg
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t))))
(provide 'org-x)
;;; org-x.el ends here