org-reschedule-overdue.el (7378B)
1 (require 'org) 2 (require 'calendar) 3 4 ;;; ------------------------------------------------------------------- 5 ;;; Low-level date helpers (operate on "absolute day numbers", i.e. the 6 ;;; integers returned by `time-to-days', so arithmetic is just +/- 1). 7 ;;; ------------------------------------------------------------------- 8 9 (defun org-reschedule-overdue--weekend-day-p (day) 10 "Non-nil if absolute DAY number falls on Saturday or Sunday." 11 (memq (calendar-day-of-week (calendar-gregorian-from-absolute day)) '(0 6))) 12 13 (defun org-reschedule-overdue--next-non-weekend-day (day) 14 "Return the first day >= DAY that is not a weekend." 15 (while (org-reschedule-overdue--weekend-day-p day) 16 (setq day (1+ day))) 17 day) 18 19 (defun org-reschedule-overdue--day-to-date-string (day) 20 "Convert absolute DAY number to an \"YYYY-MM-DD\" string." 21 (let ((greg (calendar-gregorian-from-absolute day))) 22 (format "%04d-%02d-%02d" (nth 2 greg) (nth 0 greg) (nth 1 greg)))) 23 24 ;;; ------------------------------------------------------------------- 25 ;;; Entry predicates 26 ;;; ------------------------------------------------------------------- 27 28 (defun org-reschedule-overdue--habit-p () 29 "Non-nil if the entry at point is tagged :HABIT:." 30 (member "HABIT" (org-get-tags))) 31 32 (defun org-reschedule-overdue--habits-on-day (day files) 33 "Return markers of not-done :HABIT: entries scheduled on absolute DAY, across FILES." 34 (let (markers) 35 (org-map-entries 36 (lambda () 37 (let ((sched (org-get-scheduled-time (point)))) 38 (when (and sched 39 (= (time-to-days sched) day) 40 (not (org-entry-is-done-p)) 41 (org-reschedule-overdue--habit-p)) 42 (push (point-marker) markers)))) 43 nil files) 44 (nreverse markers))) 45 46 ;;; ------------------------------------------------------------------- 47 ;;; HABIT conflict resolution 48 ;;; ------------------------------------------------------------------- 49 50 (defun org-reschedule-overdue--resolve-habit-conflicts (start-day files) 51 "Ensure no day from START-DAY onward has 2+ scheduled HABIT entries. 52 53 Walks forward day by day starting at START-DAY. On any (non-weekend) 54 day where two or more not-done HABIT-tagged entries are scheduled, 55 all but the first of them are pushed to the next non-weekend day. 56 Because that target day is always later, and the day-by-day walk 57 continues until no more work is pending, conflicts cascade correctly 58 even if they ripple across several days." 59 (let ((day start-day) 60 (last-day-with-work start-day)) 61 (while (<= day last-day-with-work) 62 (unless (org-reschedule-overdue--weekend-day-p day) 63 (let ((habits (org-reschedule-overdue--habits-on-day day files))) 64 (when (> (length habits) 2) 65 ;; Keep the first habit where it is; bump the rest forward. 66 (dolist (m (cdr habits)) 67 (let ((next-day (org-reschedule-overdue--next-non-weekend-day (1+ day)))) 68 (org-with-point-at m 69 (org-schedule nil (org-reschedule-overdue--day-to-date-string next-day))) 70 (when (> next-day last-day-with-work) 71 (setq last-day-with-work next-day))))))) 72 (setq day (1+ day))))) 73 74 (defun org-reschedule-overdue--schedule-and-cascade (marker day files) 75 "Schedule the entry at MARKER onto absolute DAY, then cascade-resolve 76 any :HABIT: pile-up that scheduling just created, starting at DAY and 77 walking forward through FILES." 78 (org-with-point-at marker 79 (org-schedule nil (org-reschedule-overdue--day-to-date-string day))) 80 (org-reschedule-overdue--resolve-habit-conflicts day files)) 81 82 ;;; ------------------------------------------------------------------- 83 ;;; Main entry points 84 ;;; ------------------------------------------------------------------- 85 86 ;;;###autoload 87 (defun org-reschedule-overdue-tasks () 88 "Reschedule overdue TODO entries in `org-agenda-files'. 89 90 Prompts for a starting date. Every currently overdue, not-done entry 91 \(i.e. its SCHEDULED timestamp is earlier than today) is rescheduled 92 onto the first day on or after the starting date that is not a 93 Saturday or Sunday. 94 95 Each overdue task is handled one at a time: it is scheduled onto the 96 target day, and then entries tagged :HABIT: are immediately checked 97 day by day starting at that target day. Whenever a day ends up with 98 two or more scheduled HABIT entries, all but the first are pushed 99 forward to the next non-weekend day, cascading forward as necessary 100 so that no day ever holds more than one HABIT entry -- before the 101 next overdue task is even scheduled." 102 (interactive) 103 (let* ((start-str (org-read-date nil nil nil 104 "Reschedule overdue tasks starting from: ")) 105 (start-day (time-to-days (org-time-string-to-time start-str))) 106 (target-day (org-reschedule-overdue--next-non-weekend-day start-day)) 107 (today-day (time-to-days (current-time))) 108 (files (org-agenda-files)) 109 overdue-markers) 110 (unless files 111 (user-error "`org-agenda-files' is empty")) 112 ;; 1. Collect overdue, not-done entries. 113 (org-map-entries 114 (lambda () 115 (let ((sched (org-get-scheduled-time (point)))) 116 (when (and sched 117 (not (org-entry-is-done-p)) 118 (< (time-to-days sched) today-day)) 119 (push (point-marker) overdue-markers)))) 120 nil files) 121 (setq overdue-markers (nreverse overdue-markers)) 122 (unless overdue-markers 123 (user-error "No overdue tasks found")) 124 ;; 2. Reschedule each overdue task onto TARGET-DAY, and immediately 125 ;; cascade-resolve any HABIT clash that scheduling it just created, 126 ;; before moving on to the next task. 127 (dolist (m overdue-markers) 128 (org-reschedule-overdue--schedule-and-cascade m target-day files)) 129 (message "Rescheduled %d overdue task(s) onto %s (HABIT clashes resolved)." 130 (length overdue-markers) 131 (org-reschedule-overdue--day-to-date-string target-day)))) 132 133 ;;;###autoload 134 (defun org-reschedule-overdue-schedule-at-point-with-cascade () 135 "Schedule the org heading at point, applying the same cascading rules 136 as `org-reschedule-overdue-reschedule-overdue-tasks'. 137 138 Prompts for a date. The heading at point is scheduled onto the first 139 day on or after that date which is not a Saturday or Sunday. If that 140 placement gives the day two or more scheduled :HABIT: entries, all 141 but the first are pushed forward to the next non-weekend day, 142 cascading forward as necessary so that no day ever holds more than 143 one HABIT entry." 144 (interactive) 145 (save-excursion 146 (org-back-to-heading t) 147 (let* ((date-str (org-read-date nil nil nil "Schedule for: ")) 148 (day (time-to-days (org-time-string-to-time date-str))) 149 (target-day (org-reschedule-overdue--next-non-weekend-day day)) 150 (files (org-agenda-files)) 151 (marker (point-marker))) 152 (org-reschedule-overdue--schedule-and-cascade marker target-day files) 153 (message "Scheduled onto %s (HABIT clashes resolved)." 154 (org-reschedule-overdue--day-to-date-string target-day))))) 155 156 (defun org-reschedule-overdue-org-schedule-wrapper (arg &optional time) 157 (interactive "P") 158 (cond ((equal arg '(256)) 159 (org-reschedule-overdue-schedule-at-point-with-cascade)) 160 (t (org-schedule arg time)))) 161 162 (provide 'org-reschedule-overdue)