From 0703e6f0675b963cb12fcbd7b296fc1b8853a3d3 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 16 Apr 2021 23:46:31 -0400 Subject: [PATCH] REF move org-x-cluster (now org-x-agg) to own file --- etc/conf.org | 8 +- local/lib/org-x/org-x-agg.el | 467 ++++++++++++ local/lib/org-x/org-x.el | 705 ++++-------------- .../lib/org-x/test/org-x-test-buffer-state.el | 10 +- 4 files changed, 625 insertions(+), 565 deletions(-) create mode 100644 local/lib/org-x/org-x-agg.el diff --git a/etc/conf.org b/etc/conf.org index b5fd855..a9272a2 100644 --- a/etc/conf.org +++ b/etc/conf.org @@ -2419,8 +2419,8 @@ Org mode has no way of detecting if conflicts exist. It also has no way of alert 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")) +(setq org-x-agg-filtered-files '("incubator" "peripheral") + org-x-agg-filtered-keywords '("CANC" "DONE")) #+end_src *** agenda :PROPERTIES: @@ -4209,8 +4209,8 @@ The function keys are nice because they are almost (not always) free in every mo (global-set-key (kbd "") 'org-agenda) (global-set-key (kbd "") 'org-capture) (global-set-key (kbd "") 'cfw:open-org-calendar) -(global-set-key (kbd "C-") 'org-x-cluster-show-conflicts) -(global-set-key (kbd "C-S-") 'org-x-cluster-show-overloads) +(global-set-key (kbd "C-") 'org-x-agg-show-conflicts) +(global-set-key (kbd "C-S-") 'org-x-agg-show-overloads) (global-set-key (kbd "") 'org-clock-goto) (global-set-key (kbd "C-") 'org-tomato-user-get-summary) (global-set-key (kbd "C-S-") 'org-tomato-user-pomodoro-goto) diff --git a/local/lib/org-x/org-x-agg.el b/local/lib/org-x/org-x-agg.el new file mode 100644 index 0000000..31d08b8 --- /dev/null +++ b/local/lib/org-x/org-x-agg.el @@ -0,0 +1,467 @@ +;;; org-x-agg.el --- Org Aggregation Commands -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Nathan Dwarshuis + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Functions to aggregate headlines, usually on the basis of timestamps (eg +;; finding conflicting timestamps and similar operations). + +;; Most of this code was written under intense sleep deprivation at a hackathon +;; after failing to get a project off the ground. The code has been cleaned +;; since ;) + +;;; Code: + +(require 'org) +(require 'org-ml) +(require 'dash) + +;;; CUSTOMIZABLE VARS + +(defvar org-x-agg-filtered-files nil + "Files that should be excluded from aggregation analysis. +These are pattern-matched so they do not need to be exact names +or paths.") + +(defvar org-x-agg-filtered-keywords nil + "TODO keywords that should be filtered from aggregation analysis.") + +(defvar org-x-agg-filter-past t + "Set to t to exclude files from before now in aggregation analysis.") + +(defvar org-x-agg-filter-habit nil + "Set to t to exclude habits from aggregation analysis.") + +;;; INTERNAL FUNCTIONS + +;; In order to aggregate headlines, get a list of metadata called 'timespans' +;; which contain the 'active' timestamp from a headline, its range, and +;; offset/file information so I can trace the timespan back to the original +;; headline. The 'active' timestamp of a headline is either the scheduled +;; timestamp if the headline is a todo item (task) or the first active timestamp +;; otherwise. + +(defun org-x-agg--make-timespan (start-time range offset filepath) + "Construct a timespan to be used in further processing. + +'Timespans' are plists with the following keys: + +- START-TIME is a list from `org-ml-timestamp-get-start-time' +- RANGE is the duration of the timestamp (could be 0) +- OFFSET is the character offset of the timestamp in its file +- FILEPATH is the path to the file in which the timestamp + resides" + (list :start-time start-time + :range range + :offset offset + :filepath filepath)) + +(defun org-x-agg--timestamp-to-timespan (headline filepath timestamp) + "Parse a TIMESTAMP belonging to HEADLINE in file at FILEPATH. +TIMESTAMP is an object as described in the org-element API. +Returns a new timespan." + (when timestamp + (let ((offset (org-element-property :begin headline)) + (start-time (org-ml-timestamp-get-start-time timestamp)) + (range (org-ml-timestamp-get-range timestamp))) + (org-x-agg--make-timespan start-time range offset filepath)))) + +(defun org-x-agg--effort-to-seconds (effort-str) + "Return EFFORT-STR as an integer in seconds." + (-some->> effort-str (org-duration-to-minutes) (round) (* 60))) + +(defun org-x-agg--headline-get-timespan-scheduled (headline filepath) + "Return timestamp from HEADLINE in FILEPATH as timespan. +Only the scheduled timestamp is considered if any." + (-when-let (ts (-some->> (org-ml-headline-get-planning headline) + (org-ml-get-property :scheduled))) + (let* ((effort-raw (org-ml-headline-get-node-property "Effort" headline)) + (effort (if effort-raw (org-x-agg--effort-to-seconds effort-raw) 0)) + (offset (org-ml-get-property :begin headline)) + (start-time (org-ml-timestamp-get-start-time ts))) + (org-x-agg--make-timespan start-time effort offset filepath)))) + +;; TODO this should be in org-ml +(defun org-x-agg--get-logbook-config () + "Return a config list with current logbook settings. +This is a plist meant to be consumed by +`org-ml-headline-get-supercontents' and friends." + (list :log-into-drawer org-log-into-drawer + :clock-into-drawer org-clock-into-drawer + :clock-out-notes org-log-note-clock-out)) + +(defun org-x-agg--headline-get-timespan-active (headline filepath) + "Return timestamp from HEADLINE in FILEPATH as timespan. +Only the first active timestamp is considered if any." + (-some->> headline + (org-ml-headline-get-contents (org-x-agg--get-logbook-config)) + (apply #'org-ml-build-section) + (org-ml-match '(:first :any * (:and timestamp + (:or (:type 'active) + (:type 'active-range))))) + (car) + (org-x-agg--timestamp-to-timespan headline filepath))) + +(defun org-x-agg--headline-get-timespans (headline filepath) + "Return timestamp from HEADLINE in FILEPATH as new timespan. +If HEADLINE has a todo keyword, only consider the scheduled +timestamp. Else only consider the first active timestamp in the +contents of HEADLINE. Return nil if no timestamps exists meeting +these conditions." + (if (org-ml-get-property :todo-keyword headline) + (org-x-agg--headline-get-timespan-scheduled headline filepath) + (org-x-agg--headline-get-timespan-active headline filepath))) + +(defun org-x-agg--headlines-filter-keywords (headlines) + "Return HEADLINES without keywords in `org-x-agg-filtered-keywords'." + (if (not org-x-agg-filtered-keywords) headlines + (--remove (member (org-element-property :todo-keyword it) + org-x-agg-filtered-keywords) + headlines))) + +(defun org-x-agg--filter-files (filepaths) + "Return FILEPATHS with paths meeting a pattern filtered out." + (if (not org-x-agg-filtered-files) filepaths + (--remove + (-find (lambda (s) (string-match-p s it)) org-x-agg-filtered-files) + filepaths))) + +(defun org-x-agg--timespans-remove-past (timespans) + "Return TIMESPANS without those starting in the past." + (if (not org-x-agg-filter-past) timespans + (let ((ft (float-time))) + (--remove (< (plist-get it :unixtime) ft) timespans)))) + +(defun org-x-agg--headlines-remove-habits (headlines) + "Return HEADLINES without those that are habits." + (if (not org-x-agg-filter-habit) headlines + (--remove (org-element-property :STYLE it) headlines))) + +(defun org-x-agg--get-timespans-from-buffer (filepath) + "Return timespans for current buffer. +FILEPATH is the path to the current buffer." + (->> (org-ml-parse-headlines 'all) + (org-x-agg--headlines-filter-keywords) + (org-x-agg--headlines-remove-habits) + (--map (org-x-agg--headline-get-timespans it filepath)) + (-non-nil))) + +(defun org-x-agg--get-timespans-from-file (filepath) + "Return timespans from org-file at FILEPATH." + (with-current-buffer (find-file-noselect filepath t) + (org-x-agg--get-timespans-from-buffer filepath))) + +(defun org-x-agg--get-all-timespans () + "Return a list of timespans with desired filter settings." + (->> (org-agenda-files) + (org-x-agg--filter-files) + (-mapcat #'org-x-agg--get-timespans-from-file))) + +(defun org-x-agg--timespans-append-unixtime (timespans) + "Append a :unixtime property to TIMESPANS. +The new property will contain an integer representing the unix +time of the :start-time property." + (cl-flet + ((append-unixtime + (span) + `(:unixtime ,(org-ml-time-to-unixtime (plist-get span :start-time)) ,@span))) + (-map #'append-unixtime timespans))) + +;; get conflict headlines +;; +;; This algorithm builds a list of pairs, with each pair being a two tasks that +;; conflicts. It should be O(n) (best case/no conflicts) to O(n^2) (worst +;; case/everything conflicts), although this relies on the list being sorted +;; which should be O(nlog(n)) (merge sort?). +;; +;; Steps for this: +;; 1. Sort timespan list +;; 2. For each timespan: +;; 2.1 For each timespan after the current timespan +;; If conflict found, add the two timespans being compared to new list, +;; else break out of inner loop and advance outer loop at (2.) +;; +;; NOTE: sorting ensures that timespans can be skipped once one non-conflict is +;; found, which is what makes this algorithm approach O(n) as the number of +;; conflicts -> 0. + +(defun org-x-agg--timespans-are-conflicting-p (span-a span-b) + "Return t if timespans SPAN-A and SPAN-B conflict." + ;; assume that a starts before b + (let ((start-a (plist-get span-a :unixtime)) + (start-b (plist-get span-b :unixtime))) + (or (= start-a start-b) (< start-b (+ start-a (plist-get span-a :range)))))) + +(defun org-x-agg--timespan-append-conflict (cur-timespan timespans conlist) + "Test if CUR-TIMESPAN conflicts with any in TIMESPANS. +Each conflicting timespan will be paired with TIMESPAN like +\(CUR CONFLICTING) and appended to CONLIST. New CONLIST is +returned." + (->> timespans + (--take-while (org-x-agg--timespans-are-conflicting-p cur-timespan it)) + (--map (list cur-timespan it)) + (append conlist))) + +(defun org-x-agg--timespans-build-conlist (timespans) + "Return conflicting pairs from TIMESPANS." + (let ((conlist)) + (while (< 1 (length timespans)) + (setq conlist (org-x-agg--timespan-append-conflict (car timespans) + (cdr timespans) + conlist) + timespans (cdr timespans))) + conlist)) + +(defun org-x-agg--timespans-group-conflicts (timespans) + "Return TIMESPANS that conflict with each other. +The returned list will be a list of pairs of timespans +like (SPAN-a SPAN-b) which are two timespans that conflict." + (->> (--filter (org-ml-time-is-long (plist-get it :start-time)) timespans) + (org-x-agg--timespans-append-unixtime) + (org-x-agg--timespans-remove-past) + (--sort (< (plist-get it :unixtime) (plist-get other :unixtime))) + (org-x-agg--timespans-build-conlist))) + +;; get overloaded days +;; +;; Overloads are defined as days that have more than 24 hours worth of scheduled +;; material. The algorithm itself is O(n) as it is basically just a bunch of +;; filtering functions that walk through the list, but it assumes the list is +;; sorted which can be achieved with O(nlog(n)) (merge sort?). +;; +;; Steps for the algorithm: +;; 1. filter only ranged entries (unranged entries have zero time) +;; 2. split timespans if they span multiple days +;; 3. sort from earliest to latest starting time +;; 4. partition list by starting day +;; 5. sum the timespans in each day, keeping those that exceed 24 hours + +(defun org-x-agg--split-timespan-by-day (timespan) + "Split TIMESPAN if it spans multiple days." + ;; NOTE: `encode-time' seems pretty slow but this is necessary since some + ;; barbarians in power insist on keep daylight savings time, which means I + ;; can't just do straight modular arithmetic to find where each day boundary + ;; lies. + (cl-flet + ((encode-float-time + (time) + (round (float-time (encode-time time))))) + (-let (((&plist :start-time :range :offset :filepath) timespan)) + (if (= range 0) (list timespan) + ;; `encode-time' and `decode-time' might not use the right time zone + ;; unless specified manually + (-let* ((tz (current-time-zone)) + (start-time* (if (org-ml-time-is-long start-time) start-time + `(,@(-take 3 start-time) 0 0))) + ((y m d H M) start-time*) + (start-epoch (encode-float-time `(0 ,M ,H ,d ,m ,y nil nil ,tz))) + (end-epoch (+ start-epoch range)) + (next t) + (split-epoch nil) + ((M* H* d* m* y*) '(nil nil nil nil nil)) + (acc nil)) + (while next + ;; get the projected ending time + (-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch tz)))) + ;; Get the epoch time on which to split. If not on a day boundary, + ;; calculate the epoch time of the most recent day boundary. If on a + ;; day boundary, split on the boundary one full day earlier by + ;; decrementing day by one + (when (and (= 0 M*) (= 0 H*)) + (setq d* (1- d*))) + (setq split-epoch (encode-float-time `(0 0 0 ,d* ,m* ,y* nil nil ,tz))) + ;; If the split-epoch is less than or equal to the start, loop is + ;; done. Else add a new entry and reset the projected ending time to + ;; the current split time; rinse and repeat. + (if (< start-epoch split-epoch) + (setq acc (cons (org-x-agg--make-timespan + `(,y* ,m* ,d* 0 0) (- end-epoch split-epoch) + offset filepath) + acc) + end-epoch split-epoch) + (setq next nil + acc (cons (org-x-agg--make-timespan + start-time* (- end-epoch start-epoch) offset filepath) + acc)))) + acc))))) + +(defun org-x-agg--timespans-partition-by-day (timespans) + "Return TIMESPANS partitioned by day. +Assume TIMESPANS is sorted according to :start-time." + (--partition-by (-take 3 (plist-get it :start-time)) timespans)) + +(defun org-x-agg--timespan-is-overloaded-p (timespans) + "Return t if sum of TIMESPANS exceeds 24 hours. +It is assumed the TIMESPANS all start within one day." + (<= 86400 (-sum (--map (plist-get it :range) timespans)))) + +(defun org-x-agg--timespans-group-overloads (timespans) + "Group TIMESPANS by overloaded day. +A day is overloaded if it has timespans whose :range properties +sum to greater than 24 hours. Timespans across multiple days will +be split along day boundaries according to local time zone before +grouping is performed. Returned list will be a list of lists +like (SPAN1 SPAN2 ...) which are timespans in a single day that +is overloaded." + (->> timespans + (--filter (< 0 (plist-get it :range))) + (-mapcat #'org-x-agg--split-timespan-by-day) + (org-x-agg--timespans-append-unixtime) + (org-x-agg--timespans-remove-past) + (--sort (< (plist-get it :unixtime) (plist-get other :unixtime))) + (org-x-agg--timespans-partition-by-day) + (--filter (org-x-agg--timespan-is-overloaded-p it)))) + +;;; AGENDA 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-agg--get-headline-text (timespan) + "Return string for headline text represented by TIMESPAN. +Returned string will have text properties to enable wizzy, fun +things in the agenda like jumpy to the target headline from the +agenda buffer." + (-let* (((&plist :offset :filepath) timespan) + (ts-marker (with-current-buffer (find-file-noselect filepath) + (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 ts-date ts-date-pair txt + inherited-tags) + + (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) + 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 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-agg--format-timespan (timespan) + "Return formatted day-level timestamp for TIMESPAN." + (format-time-string "[%Y-%m-%d]" (plist-get timespan :unixtime))) + +(defun org-x-agg--format-conflict (grouped-timespans) + "Return GROUPED-TIMESPANS formatted for conflict agenda buffer." + (format "On %s\n%s\n" + (org-x-agg--format-timespan (car grouped-timespans)) + (mapconcat #'org-x-agg--get-headline-text grouped-timespans "\n"))) + +(defun org-x-agg--format-overload (grouped-timespans) + "Return GROUPED-TIMESPANS formatted for overload agenda buffer." + (format "On %s\n%s\n" + (org-x-agg--format-timespan (car grouped-timespans)) + (mapconcat #'org-x-agg--get-headline-text grouped-timespans "\n"))) + +(defun org-x-agg--show-agenda (short-name title cluster-fun format-fun arg) + "Show an inter-headline cluster agenda buffer. +SHORT-NAME is a one-word name describing the buffer which will be +used in the name of the buffer. TITLE will be displayed at the +top of the buffer. CLUSTER-FUN is a function that takes a list of +timespans and returned a grouped list of timespans. FORMAT-FUN is +a function that takes one member from the list provided by +CLUSTER-FUN and returns a string with text properties to be +inserted into the agenda buffer. ARG is an argument provided by +some calling interactive function." + (when org-agenda-overriding-arguments + (setq arg org-agenda-overriding-arguments)) + + (when (and (stringp arg) (not (string-match "\\S-" arg))) + (setq arg nil)) + + (let ((completion-ignore-case t) + (org-agenda-prefix-format '((agenda . " %-12:c %-5:e ")))) + + (catch 'exit + (when org-agenda-sticky + (setq org-agenda-buffer-name (format "*Org %s*" short-name))) + + (org-agenda-prepare) + (org-compile-prefix-format 'agenda) + + (setq org-agenda-redo-command '(org-x-agg--show-overloads)) + + (insert (format "%s: \n" title)) + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading short-name)) + (org-agenda-mark-header-line (point-min)) + + (-some-> (funcall cluster-fun (org-x-agg--get-all-timespans)) + (--each (insert (funcall format-fun it)))) + + ;; 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-agg-show-conflicts (&optional arg) + "Show list of conflicting headlines in agenda buffer. +ARG is something that I'm not sure if I need." + (interactive "P") + (org-x-agg--show-agenda "Conflicts" "Conflicting Headlines" + #'org-x-agg--timespans-group-conflicts + #'org-x-agg--format-conflict + arg)) + +(defun org-x-agg-show-overloads (&optional arg) + "Show list of overloaded days in agenda buffer. +ARG is something that I'm not sure if I need." + (interactive "P") + (org-x-agg--show-agenda "Overloads" "Overloaded Days" + #'org-x-agg--timespans-group-overloads + #'org-x-agg--format-overload + arg)) + +(provide 'org-x-agg) +;;; org-x-agg.el ends here diff --git a/local/lib/org-x/org-x.el b/local/lib/org-x/org-x.el index 52a8f47..1976803 100644 --- a/local/lib/org-x/org-x.el +++ b/local/lib/org-x/org-x.el @@ -31,6 +31,7 @@ (require 'dash) (require 's) (require 'org) +(require 'org-x-agg) ;; constants @@ -66,35 +67,8 @@ 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 - "If true, don't show incubator headings.") - (defvar org-x-agenda-hasprop-filter nil) ;; list @@ -487,6 +461,8 @@ should be this function again)." (t (error (concat "invalid keyword detected: " keyword))))))) +;; iterators + (defun org-x--clone-get-iterator-project-status (kw) (cond ((or (org-x-is-scheduled-heading-p) @@ -560,6 +536,8 @@ Allowed statuscodes are in list `nd/get-iter-statuscodes.' where (setq prev-point (point)) (org-forward-heading-same-level 1 t))) cur-status)) + +;; periodicals (defun org-x-get-periodical-status () "Get the status of a periodical. @@ -628,28 +606,9 @@ function will simply return the point of the next headline." (not (cl-intersection neg-tags-list heading-tags :test 'equal))) (org-x-skip-heading))))) -;; interactive functions +;;; INTERACTIVE FUNCTIONS -(defun org-x-mark-subtree-keyword (new-keyword &optional exclude no-log) - "Change the todo keyword of all tasks in a subtree to NEW-KEYWORD. -If EXCLUDE is given, it should be a list of todo keywords; any headline -matching a keyword in this list will not be changed. If NO-LOG is t, -don't log changes in the logbook." - (let ((subtree-end (save-excursion (org-end-of-subtree t))) - (org-todo-log-states (unless no-log org-todo-log-states))) - (if (not (listp exclude)) - (error "Exclude must be a list if provided")) - (save-excursion - (while (< (point) subtree-end) - (let ((keyword (org-x-is-todoitem-p))) - (if (and keyword (not (member keyword exclude))) - (org-todo new-keyword))) - (outline-next-heading))))) - -(defun org-x-mark-subtree-done () - "Mark all tasks in subtree as DONE unless they are already CANC." - (interactive) - (org-x-mark-subtree-keyword "DONE" '("CANC"))) +;; cloning (defun org-x--reset-headline (headline) "Reset HEADLINE node to incomplete state. @@ -723,7 +682,6 @@ SHIFT is a string specifier denoting the amount to shift, eg (-let (((T unit) (convert-shift shift))) (--map-indexed (shift-timestamps T unit (1+ it-index) it) headlines)))))) -;; TODO make "CREATED" timestamp reflect when these things are cloned (defun org-x-clone-subtree-with-time-shift (n) "Like `org-clone-subtree-with-time-shift' except reset items and todos. N is the number of clones to produce." @@ -763,6 +721,31 @@ N is the number of clones to produce." (org-ml-match-do '(section property-drawer) (lambda (it) (org-ml-fold it)) post) (org-ml-match-do '(headline) (lambda (it) (org-ml-fold it)) post)))) +;; marking subtrees + +(defun org-x-mark-subtree-keyword (new-keyword &optional exclude no-log) + "Change the todo keyword of all tasks in a subtree to NEW-KEYWORD. +If EXCLUDE is given, it should be a list of todo keywords; any headline +matching a keyword in this list will not be changed. If NO-LOG is t, +don't log changes in the logbook." + (let ((subtree-end (save-excursion (org-end-of-subtree t))) + (org-todo-log-states (unless no-log org-todo-log-states))) + (if (not (listp exclude)) + (error "Exclude must be a list if provided")) + (save-excursion + (while (< (point) subtree-end) + (let ((keyword (org-x-is-todoitem-p))) + (if (and keyword (not (member keyword exclude))) + (org-todo new-keyword))) + (outline-next-heading))))) + +(defun org-x-mark-subtree-done () + "Mark all tasks in subtree as DONE unless they are already CANC." + (interactive) + (org-x-mark-subtree-keyword "DONE" '("CANC"))) + +;; logbook + (defun org-x-log-delete () "Delete logbook drawer of subtree." (interactive) @@ -778,11 +761,6 @@ N is the number of clones to produce." (delete-region (region-beginning) (region-end)) (org-remove-empty-drawer-at (point))))) -(defun org-x-delete-subtree () - "Delete the entire subtree under the current heading without sending to kill ring." - (interactive) - (org-back-to-heading t) - (delete-region (point) (+ 1 (save-excursion (org-end-of-subtree))))) (defun org-x-clock-range (&optional arg) "Add a completed clock entry to the current heading. @@ -804,6 +782,7 @@ ARG, ask for a range in minutes in place of the second date." (t (let ((s (org-ml-unixtime-to-time-long t1)) (e (org-ml-unixtime-to-time-long t2))) + ;; TODO rewrite this in terms of org-ml code (save-excursion (org-clock-find-position nil) (org-indent-line) @@ -811,6 +790,67 @@ ARG, ask for a range in minutes in place of the second date." (org-ml-to-string) (insert)))))))) +(defun org-x-refile-logbook () + "Refile the current headline with it's logbook. +The original target headline is left in place but without the +logbook. Intended use is for habits and repeating tasks that +build up massive logbook entries that will make my org files huge +and slow." + (interactive) + (let ((acat (org-get-category)) + (atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1))) + (afile (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (error "No file associated to buffer")))) + (apath (s-join "/" (org-get-outline-path))) + (atags (->> (org-get-tags) + (--filter (get-text-property 0 'inherited it)) + (s-join " "))) + (config (list :log-into-drawer org-log-into-drawer + :clock-into-drawer org-clock-into-drawer))) + ;; TODO this is basically a function version of org-archive and could + ;; be refactored/reused as a separate function + (cl-flet + ((archive + (atime afile _apath acat atodo atags target headline) + (let* ((level-shift (-some-> (org-ml-get-property :level headline) + (1-) + (-))) + (headline* + (->> (org-ml-clone-node headline) + (org-ml-set-property :todo-keyword "DONE") + (org-ml-headline-map-planning* + (let ((time (->> (float-time) + (org-ml-unixtime-to-time-long)))) + (org-ml-planning-set-timestamp! :closed time it))) + (org-ml-headline-set-node-property "ARCHIVE_TIME" atime) + (org-ml-headline-set-node-property "ARCHIVE_FILE" afile) + (org-ml-headline-set-node-property "ARCHIVE_OLPATH" afile) + (org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat) + (org-ml-headline-set-node-property "ARCHIVE_TODO" atodo) + (org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags) + (org-ml-shift-property :level level-shift) + (org-ml-match-map* '(:any * headline) + (org-ml-shift-property :level level-shift it))))) + ;; TODO this currently does not refile under specific headlines + (with-current-buffer (find-file-noselect target) + (org-ml-insert (point-max) headline*))))) + (org-ml-update-this-subtree* + (let ((atodo (org-ml-get-property :todo-keyword it)) + (target (format "%s_archive" afile))) + (archive atime afile apath acat atodo atags target it) + (org-ml-headline-map-supercontents* config + (org-ml-supercontents-set-logbook nil it) + it)))))) + +(defun org-x-delete-subtree () + "Delete entire subtree under point without sending to kill ring." + (interactive) + (org-back-to-heading t) + (delete-region (point) (1+ (save-excursion (org-end-of-subtree))))) + +;; lift buffer commands into agenda context + (defmacro org-x-agenda-cmd-wrapper (get-head &rest body) "Execute BODY in context of agenda buffer. Specifically, navigate to the original header, execute BODY, then @@ -866,60 +906,30 @@ It will clone the last entry in the selected subtree." nil (call-interactively #'org-x-clock-range))) -(defun org-x-agenda-filter-non-context () - "Filter all tasks with context tags." - (interactive) - (let* ((tags-list (mapcar #'car org-tag-alist)) - (context-tags (append - (org-x-filter-list-prefix "@" tags-list) - (org-x-filter-list-prefix "#" tags-list)))) - (setq org-agenda-tag-filter - (mapcar (lambda (tag) (concat "-" tag)) context-tags)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag))) - -(defun org-x-agenda-filter-non-peripheral () - "Filter all tasks that don't have peripheral tags." - (interactive) - (let* ((peripheral-tags '("PERIPHERAL"))) - (setq org-agenda-tag-filter - (mapcar (lambda (tag) (concat "-" tag)) peripheral-tags)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag))) - -(defun org-x-agenda-filter-non-effort () - "Filter agenda by non-effort tasks." - (interactive) - (setq org-x-agenda-hasprop-filter '("-Effort")) - (org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop)) - -(defun org-x-agenda-filter-delegate () - "Filter agenda by tasks with an external delegate." - (interactive) - (setq org-x-agenda-hasprop-filter '("+DELEGATE")) - (org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop)) +;; agenda heading navigation functions (defun org-x-agenda--seek-heading (&optional back) "Go to next or previous agenda heading. If BACK is t seek backward, else forward. Ignore blank lines." - (let* ((limit (if back (point-min) (point-max))) - (inc (if back -1 1)) - (is-valid-header - (lambda () - (let ((h (buffer-substring (line-beginning-position) - (line-end-position)))) - (and - (not (equal h "")) + (cl-flet + ((is-valid-header + () + (let ((h (buffer-substring (line-beginning-position) + (line-end-position)))) + (and (not (equal h "")) (get-text-property 0 'org-agenda-structural-header h))))) - (next - (let ((header-point)) - (save-excursion - (while (and (< 0 (abs (- limit (point)))) - (not header-point)) - (forward-line inc) - (when (funcall is-valid-header) - (setq header-point (point)))) - header-point)))) - (if next (goto-char next) - (message (if back "Cannot move up" "Cannot move down"))))) + (let* ((limit (if back (point-min) (point-max))) + (inc (if back -1 1)) + (next + (let ((header-point)) + (save-excursion + (while (and (< 0 (abs (- limit (point)))) (not header-point)) + (forward-line inc) + (when (is-valid-header) + (setq header-point (point)))) + header-point)))) + (if next (goto-char next) + (message (if back "Cannot move up" "Cannot move down")))))) (defun org-x-agenda-previous-heading () "Go to the previous agenda heading or end of buffer." @@ -931,6 +941,9 @@ If BACK is t seek backward, else forward. Ignore blank lines." (interactive) (org-x-agenda--seek-heading)) +;; timestamp shifter + +;; TODO refactor in terms of org-ml to make cleaner/safer (defun org-x-time-shift () "Shift all scheduled and deadlined timestamps in the current subtree." (interactive) @@ -963,6 +976,8 @@ If BACK is t seek backward, else forward. Ignore blank lines." (funcall shift-ts-maybe 'deadline) (outline-next-heading))))) +;; agenda filtering + ;; In order to implement the =hasprop= filter, the functions ;; =org-agenda-filter-make-matcher= and =org-agenda-filter-remove-all= need to ;; be advised in order to add the functionality for the =hasprop= filter type. @@ -973,6 +988,37 @@ If BACK is t seek backward, else forward. Ignore blank lines." ;; to different filter types). Note this does not give a shiny indicator at the ;; bottom of spaceline like the built-in filter does...oh well. +(defun org-x-agenda-filter-non-context () + "Filter all tasks with context tags." + (interactive) + (let* ((tags-list (mapcar #'car org-tag-alist)) + (context-tags (append + (org-x-filter-list-prefix "@" tags-list) + (org-x-filter-list-prefix "#" tags-list)))) + (setq org-agenda-tag-filter + (mapcar (lambda (tag) (concat "-" tag)) context-tags)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag))) + +(defun org-x-agenda-filter-non-peripheral () + "Filter all tasks that don't have peripheral tags." + (interactive) + (let* ((peripheral-tags '("PERIPHERAL"))) + (setq org-agenda-tag-filter + (mapcar (lambda (tag) (concat "-" tag)) peripheral-tags)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag))) + +(defun org-x-agenda-filter-non-effort () + "Filter agenda by non-effort tasks." + (interactive) + (setq org-x-agenda-hasprop-filter '("-Effort")) + (org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop)) + +(defun org-x-agenda-filter-delegate () + "Filter agenda by tasks with an external delegate." + (interactive) + (setq org-x-agenda-hasprop-filter '("+DELEGATE")) + (org-agenda-filter-apply org-x-agenda-hasprop-filter 'hasprop)) + (defun org-x-agenda-filter-make-matcher-prop (filter type &rest _args) "Override the standard match filter. This will return matching matcher form for FILTER and TYPE @@ -1079,458 +1125,5 @@ If ARG is non-nil use long timestamp format." (add-hook 'org-capture-before-finalize-hook #'org-x-set-creation-time) -(defun org-x-refile-logbook () - "Refile the current headline with it's logbook. -The original target headline is left in place but without the -logbook. Intended use is for habits and repeating tasks that -build up massive logbook entries that will make my org files huge -and slow." - (interactive) - (let ((acat (org-get-category)) - (atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1))) - (afile (abbreviate-file-name - (or (buffer-file-name (buffer-base-buffer)) - (error "No file associated to buffer")))) - (apath (s-join "/" (org-get-outline-path))) - (atags (->> (org-get-tags) - (--filter (get-text-property 0 'inherited it)) - (s-join " "))) - (config (list :log-into-drawer org-log-into-drawer - :clock-into-drawer org-clock-into-drawer))) - ;; TODO this is basically a function version of org-archive and could - ;; be refactored/reused as a separate function - (cl-flet - ((archive - (atime afile _apath acat atodo atags target headline) - (let* ((level-shift (-some-> (org-ml-get-property :level headline) - (1-) - (-))) - (headline* - (->> (org-ml-clone-node headline) - (org-ml-set-property :todo-keyword "DONE") - (org-ml-headline-map-planning* - (let ((time (->> (float-time) - (org-ml-unixtime-to-time-long)))) - (org-ml-planning-set-timestamp! :closed time it))) - (org-ml-headline-set-node-property "ARCHIVE_TIME" atime) - (org-ml-headline-set-node-property "ARCHIVE_FILE" afile) - (org-ml-headline-set-node-property "ARCHIVE_OLPATH" afile) - (org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat) - (org-ml-headline-set-node-property "ARCHIVE_TODO" atodo) - (org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags) - (org-ml-shift-property :level level-shift) - (org-ml-match-map* '(:any * headline) - (org-ml-shift-property :level level-shift it))))) - ;; TODO this currently does not refile under specific headlines - (with-current-buffer (find-file-noselect target) - (org-ml-insert (point-max) headline*))))) - (org-ml-update-this-subtree* - (let ((atodo (org-ml-get-property :todo-keyword it)) - (target (format "%s_archive" afile))) - (archive atime afile apath acat atodo atags target it) - (org-ml-headline-map-supercontents* config - (org-ml-supercontents-set-logbook nil it) - it)))))) - -;; inter-headline 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 (start-time range offset fp) - "Construct a timestamp plist to be used in further processing. - -The fields are as follows: - -- START-TIME is a list from `org-ml-timestamp-get-start-time' -- RANGE is the duration of the timestamp (could be 0) -- OFFSET is the character offset of the timestamp in its file -- FP the path to the file in which the timestamp resides" - (list :start-time start-time - :range range - :offset offset - :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 (hl fp ts) - "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)) - (start-time (org-ml-timestamp-get-start-time ts)) - (range (org-ml-timestamp-get-range ts))) - (org-x-cluster-make-tsp start-time range offset fp)))) - -(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) (round) (* 60))) - -(defun org-x-cluster-extract-hl-sched (hl fp) - "Extract scheduled timestamp from headline HL in filepath FP. -Create a new timestamp-plist and add to accumulator ACC." - (-when-let (ts (-some->> (org-ml-headline-get-planning hl) - (org-ml-get-property :scheduled))) - (let* ((effort-raw (org-ml-headline-get-node-property "Effort" hl)) - (effort (if effort-raw (org-x-cluster-effort-seconds effort-raw) 0)) - (offset (org-ml-get-property :begin hl)) - (start-time (org-ml-timestamp-get-start-time ts))) - (org-x-cluster-make-tsp start-time effort offset fp)))) - -(defun org-x-cluster-extract-hl-ts (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." - (-some->> hl - (org-ml-headline-get-contents - (list :log-into-drawer org-log-into-drawer - :clock-into-drawer org-clock-into-drawer - :clock-out-notes org-log-note-clock-out)) - (apply #'org-ml-build-section) - (org-ml-match '(:first :any * (:and timestamp - (:or (:type 'active) - (:type 'active-range))))) - (car) - (org-x-cluster-parse-ts hl fp))) - -(defun org-x-cluster-extract-hl (hl fp) - "Extract timestamps from headline HL in filepath FP and store in ACC." - (if (org-ml-get-property :todo-keyword hl) - (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-buffer (fp) - "Extract headlines from the current buffer for clustering analysis. -FP is the filepath to the current buffer." - (->> (org-ml-parse-headlines 'all) - (org-x-cluster-filter-todo) - (org-x-cluster-filter-habit) - (--map (org-x-cluster-extract-hl it fp)) - (-non-nil))) - -(defun org-x-cluster-extract-file (fp) - "Extract timestamps from filepath FP and add to accumulator ACC." - (with-current-buffer (find-file-noselect fp t) - (org-x-cluster-extract-buffer fp))) - -(defun org-x-cluster-append-unixtime (tsps) - "Append a :unixtime property to TSPS. -The new property will contain an integer representing the unix -time of the :start-time property." - (--map (append (list :unixtime (org-ml-time-to-unixtime (plist-get it :start-time))) it) tsps)) - -(defun org-x-cluster-get-unprocessed () - "Return a list of timestamp-plists with desired filter settings." - (->> (org-agenda-files) - (org-x-cluster-filter-files) - (-mapcat #'org-x-cluster-extract-file))) - -;; 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 TSP-A and TSP-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))) - (or (= start-a start-b) (< start-b (+ start-a (plist-get tsp-a :range)))))) - -(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." - (->> (--take-while (org-x-cluster-conflicting-p tsp it) tsps) - (--map (list 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-group-conflicts (tsps) - "Return TSPS that conflict with each other. -The returned list will be a list of pairs of TSPs like (TSP-a TSP-b) which -are two TSPs that conflict." - (->> (--filter (org-ml-time-is-long (plist-get it :start-time)) tsps) - (org-x-cluster-append-unixtime) - (org-x-cluster-filter-past) - (--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-tsp-maybe (tsp) - "Split TSP if it spans multiple days." - ;; NOTE: `encode-time' seems pretty slow but this is necessary since some - ;; barbarians in power insist on keep daylight savings time, which means I - ;; can't just do straight modular arithmetic to find where each day boundary - ;; lies. - (cl-flet - ((encode-float-time - (time) - (round (float-time (encode-time time))))) - (-let (((&plist :start-time :range :offset :filepath) tsp)) - (if (= range 0) (list tsp) - ;; `encode-time' and `decode-time' might not use the right time zone - ;; unless specified manually - (-let* ((tz (current-time-zone)) - (start-time* (if (org-ml-time-is-long start-time) start-time - `(,@(-take 3 start-time) 0 0))) - ((y m d H M) start-time*) - (start-epoch (encode-float-time `(0 ,M ,H ,d ,m ,y nil nil ,tz))) - (end-epoch (+ start-epoch range)) - (next t) - (split-epoch nil) - ((M* H* d* m* y*) '(nil nil nil nil nil)) - (acc nil)) - (while next - ;; get the projected ending time - (-setq (M* H* d* m* y*) (-take 5 (cdr (decode-time end-epoch tz)))) - ;; Get the epoch time on which to split. If not on a day boundary, - ;; calculate the epoch time of the most recent day boundary. If on a - ;; day boundary, split on the boundary one full day earlier by - ;; decrementing day by one - (when (and (= 0 M*) (= 0 H*)) - (setq d* (1- d*))) - (setq split-epoch (encode-float-time `(0 0 0 ,d* ,m* ,y* nil nil ,tz))) - ;; If the split-epoch is less than or equal to the start, loop is - ;; done. Else add a new entry and reset the projected ending time to - ;; the current split time; rinse and repeat. - (if (< start-epoch split-epoch) - (setq acc (cons (org-x-cluster-make-tsp - `(,y* ,m* ,d* 0 0) (- end-epoch split-epoch) - offset filepath) - acc) - end-epoch split-epoch) - (setq next nil - acc (cons (org-x-cluster-make-tsp - start-time* (- end-epoch start-epoch) offset filepath) - acc)))) - acc))))) - -(defun org-x-cluster-daily-split (tsps) - "Group timestamp-plist TSPS into sublists for each day." - (--partition-by (-take 3 (plist-get it :start-time)) tsps)) - -(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." - (<= 86400 (-sum (--map (plist-get it :range) tsps)))) - -(defun org-x-cluster-group-overloads (tsps) - "Group TSPS by overloaded day. -A day is overloaded if it has TSPs whose :range properties sum to -greater than 24 hours. TSPs which span multiple days will be -split along day boundaries according to local time zone before -grouping is performed. Returned list will be a list of lists -like (TSP1 TSP2 ...) which are TSPs in a single day that is -overloaded." - (->> tsps - (--filter (< 0 (plist-get it :range))) - (-mapcat #'org-x-cluster-split-tsp-maybe) - (org-x-cluster-append-unixtime) - (org-x-cluster-filter-past) - (--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 (tsp) - "Return string for headline text represented by TSP. -Returned string will have text properties to enable wizzy, fun -things in the agenda like jumpy to the target headline from the -agenda buffer." - (-let* (((&plist :offset :filepath) tsp) - (ts-marker (with-current-buffer (find-file-noselect filepath) - (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 (tsp) - "Return formatted day-level timestamp for TSP." - (format-time-string "[%Y-%m-%d]" (plist-get tsp :unixtime))) - -(defun org-x-cluster-format-conflict (grouped-tsp) - "Return GROUPED-TSPs formatted for conflict agenda buffer." - (format "On %s\n%s\n" - (org-x-cluster-ts-fmt (car grouped-tsp)) - (mapconcat #'org-x-cluster-headline-text grouped-tsp "\n"))) - -(defun org-x-cluster-format-overload (grouped-tsp) - "Return GROUPED-TSPs formatted for overload agenda buffer." - (format "On %s\n%s\n" - (org-x-cluster-ts-fmt (car grouped-tsp)) - (mapconcat #'org-x-cluster-headline-text grouped-tsp "\n"))) - -(defun org-x-cluster-show-agenda (short-name title cluster-fun format-fun arg) - "Show an inter-headline cluster agenda buffer. -SHORT-NAME is a one-word name describing the buffer which will be -used in the name of the buffer. TITLE will be displayed at the -top of the buffer. CLUSTER-FUN is a function that takes a list of -TSPs and returned a grouped list of TSPs. FORMAT-FUN is a -function that takes one member from the list provided by -CLUSTER-FUN and returns a string with text properties to be -inserted into the agenda buffer. ARG is an argument provided by some -calling interactive function." - (when org-agenda-overriding-arguments - (setq arg org-agenda-overriding-arguments)) - - (when (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 (format "*Org %s*" short-name))) - - (org-agenda-prepare) - (org-compile-prefix-format 'agenda) - - (setq org-agenda-redo-command '(org-x-cluster-show-overloads)) - - (insert (format "%s: \n" title)) - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-agenda-structure - 'short-heading short-name)) - (org-agenda-mark-header-line (point-min)) - - (-some-> (funcall cluster-fun (org-x-cluster-get-unprocessed)) - (--each (insert (funcall format-fun it)))) - - ;; 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-conflicts (&optional arg) - "Show list of conflicting headlines in agenda buffer. -ARG is something that I'm not sure if I need." - (interactive "P") - (org-x-cluster-show-agenda "Conflicts" "Conflicting Headlines" - #'org-x-cluster-group-conflicts - #'org-x-cluster-format-conflict - arg)) - -(defun org-x-cluster-show-overloads (&optional arg) - "Show list of overloaded days in agenda buffer. -ARG is something that I'm not sure if I need." - (interactive "P") - (org-x-cluster-show-agenda "Overloads" "Overloaded Days" - #'org-x-cluster-group-overloads - #'org-x-cluster-format-overload - arg)) - (provide 'org-x) ;;; org-x.el ends here diff --git a/local/lib/org-x/test/org-x-test-buffer-state.el b/local/lib/org-x/test/org-x-test-buffer-state.el index 26886d8..1da9e06 100644 --- a/local/lib/org-x/test/org-x-test-buffer-state.el +++ b/local/lib/org-x/test/org-x-test-buffer-state.el @@ -429,8 +429,8 @@ Forms are denoted like %(FORM)%." (org-x--test-buffer-strings "Conflicts" - (->> (org-x-cluster-extract-buffer "fp") - (org-x-cluster-group-conflicts) + (->> (org-x-agg--get-timespans-from-buffer "fp") + (org-x-agg--timespans-group-conflicts) ;; drop the :unixtime key from the front to make testing easier (--map (--map (-drop 2 it) it))) @@ -517,8 +517,8 @@ Forms are denoted like %(FORM)%." (:start-time (2022 1 1 12 10) :range 900 :offset 157 :filepath "fp")))) (org-x--test-buffer-strings "Overloads" - (->> (org-x-cluster-extract-buffer "fp") - (org-x-cluster-group-overloads) + (->> (org-x-agg--get-timespans-from-buffer "fp") + (org-x-agg--timespans-group-overloads) ;; drop the :unixtime key from the front to make testing easier (--map (--map (-drop 2 it) it))) @@ -608,7 +608,7 @@ Forms are denoted like %(FORM)%." (input* (append input extra)) (output* (--map (append it extra) output))) `(it ,title - (expect (org-x-cluster-split-tsp-maybe ',input*) + (expect (org-x-agg--split-timespan-by-day ',input*) :to-equal ',output*))))))) `(describe "Time splitter"