org-agenda-dych-mode/org-agenda-dych-mode.el

;;; org-agenda-dych-mode.el --- Dynamic scheduling for your daily agenda!  -*- lexical-binding: t; -*-

;; Copyright (C) 2022  c1-g

;; Author: c1-g <char1iegordon@protonmail.com>
;; Keywords: 

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; 

;;; Code:
(require 'org-agenda)
(require 'calc)
(require 'cl-lib)

(define-minor-mode org-agenda-dych-mode
  "Keep optimum proportions of time devoted to particular tasks in your agenda."
  :global nil
  :init-value nil
  :lighter " Dych"
  :keymap '(([remap org-agenda-schedule] . org-agenda-dych)
            ([remap org-agenda-set-effort] . org-agenda-dych-set-effort)
            ([remap org-agenda-redo] . org-agenda-dych-recompute)
            ([remap org-agenda-redo-all] . org-agenda-dych-redo-all)
            ([remap org-agenda-clock-in] . org-agenda-dych-begin-entry)))

(defcustom org-agenda-dych-default-work-hour "8h"
  "The length of your schedule in hours.")

(defcustom org-agenda-dych-default-end "16:00"
  "The length of your schedule in hours.")

(defcustom org-agenda-dych-default-start "08:00"
  "The default start time to start the working day."
  :group 'org-properties
  :type 'string)

(defvar org-agenda-dych-overriding-start nil
  "When set, override any other start time for the agenda.")

;; Borrowed from Org-ql; org-ql-regexp-part-ts-repeaters.
(defvar org-agenda-dych-repeater-re
  (rx (repeat 1 2 (seq " " (repeat 1 2 (any "-+:.")) (1+ digit) (any "hdwmy")
                       (optional "/" (1+ digit) (any "hdwmy")))))
  "Matches the repeater part of an Org timestamp.
Includes leading space character.")

(defun org-agenda-dych-get-start ()
  "Get the schedule time of the earliest task."
  (or (bound-and-true-p org-agenda-dych-overriding-start)
      (car (alist-get 'org-agenda-dych-overriding-start
                      (nth 2 (org-get-at-bol 'org-series-cmd))))
      org-agenda-dych-default-start))

;;; Utilities
(defun org-agenda-dych-next-item (n)
  "The essential form of `org-agenda-next-item' that doesn't do anything extra."
  (dotimes (_ n)
    (if (next-single-property-change (point-at-eol) 'org-marker)
        (progn
          (move-end-of-line 1)
          (goto-char (next-single-property-change (point) 'org-marker)))
      (goto-char (point-max))
      nil)))

(defun org-agenda-dych-previous-item (n)
  "The essential form of `org-agenda-previous-item' that doesn't do anything extra."
  (interactive "p")
  (dotimes (_ n)
    (let ((col (current-column))
          (goto (save-excursion
		  (move-end-of-line 0)
		  (previous-single-property-change (point) 'org-marker))))
      (when goto (goto-char goto))
      (org-move-to-column col))))


(defun org-agenda-dych-map-entries (cmd &optional beg end match-fn)
  "Call CMD  on entries between BEG END.
CMD is called on the beginning of the line.
For example,

(org-agenda-dych-map-entries
 (lambda ()
   (org-get-at-bol 'priority))
 1 500)

will list all priorities of every entry that lays between the 1st
character of the agenda buffer and the 500th character."
  (setq beg (or beg (point-min)))
  (setq end (or end (point-max)))
  (save-excursion
    (goto-char beg)
    (let ((mend (move-marker (make-marker) end))
          (index 0)
          (res))
      (while (< (point) mend)
        (if (or (not (org-get-at-bol 'org-marker))
                (and match-fn
                     (not (funcall match-fn))))
            (org-agenda-dych-next-item 1)
          (push (funcall cmd) res)
          (org-agenda-dych-next-item 1)))
      (nreverse res))))

(defun org-agenda-dych-fix ()
  "Prevent a task from being automatically optimized by Dych.

If some tasks must start at a specific hour, user can schedule them
with `org-agenda-dych'."
  (interactive)
  (when-let* ((hdmarker (org-get-at-bol 'org-marker))
              (inhibit-read-only t))
    (org-entry-put hdmarker "FIXED" "t")))

(defun org-agenda-dych-make-rigid ()
  "Prevent a task's effort estimate from being automatically shrink or expanded."
  (interactive)
  (when-let* ((hdmarker (org-get-at-bol 'org-marker))
              (inhibit-read-only t))
    (org-entry-put hdmarker "RIGID" "t")
    (org-entry-put hdmarker "EFFORT" (org-entry-get hdmarker "TIME_ESTIMATE"))))

(defun org-agenda-dych-fixed-indicator (&optional marker boolean)
  "Return a string \"F\" when a task in MARKER is fixed. Or a `t' when BOOLEAN is non-nil.

This should be used in `org-agenda-prefix-format'."
  (let (fixed s)
    (setq fixed (org-entry-get marker "FIXED"))
    (if (and fixed
             (setq fixed (not (string-empty-p fixed))))
        (setq s (propertize "F" 'fixed t))
      (setq s (propertize "-" 'fixed nil)))
    (if boolean
        fixed
      s)))

(defun org-agenda-dych-rigid-indicator (&optional marker boolean)
  "Return a string \"R\" when a task in MARKER is rigid. Or a `t' when BOOLEAN is non-nil.
This should be used in `org-agenda-prefix-format'."
  (let (rigid s)
    (setq rigid (org-entry-get marker "RIGID"))
    (if (and rigid
             (setq rigid (not (string-empty-p rigid))))
        (setq s (propertize "R" 'rigid t))
      (setq s (propertize "-" 'rigid nil)))
    (if boolean
        rigid
      s)))

(defun org-agenda-dych-maybe-schedule (arg &optional time)
  "Schedule the item at point when TIME is not on the same date as the old one.

ARG is passed through to `org-agenda-schedule'."
  (if (and time (equal (apply #'encode-time (org-read-date-analyze time (decode-time) (decode-time)))
                       (org-get-scheduled-time (org-get-at-bol 'org-hd-marker))))
      (setq org-last-inserted-timestamp
            (org-agenda-dych-h:mm-to-full-ts time)))
  (org-agenda-schedule arg time))

;; TODO: Expand this
(defun org-agenda-dych-get-workhours ()
  "Get the length of your schedule in hours."
  (cond
   ((bound-and-true-p org-overriding-work-hours))
   ((let ((m (org-get-at-bol 'org-hd-marker)))
      (and m (with-current-buffer (marker-buffer m)
               (- (org-duration-to-minutes org-agenda-dych-default-end)
                  (org-duration-to-minutes (org-agenda-dych-get-start)))))))
   ((let ((m (next-single-property-change (point-min) 'org-hd-marker)))
      (and m (let ((m (get-text-property m 'org-hd-marker)))
               (with-current-buffer (marker-buffer m)
                 (- (org-duration-to-minutes org-agenda-dych-default-end)
                    (org-duration-to-minutes (org-agenda-dych-get-start))))))))
   (t (- (org-duration-to-minutes org-agenda-dych-default-end)
         (org-duration-to-minutes (org-agenda-dych-get-start))))))

(defun org-agenda-dych-get-dotime (&optional point)
  "Get the scheduled time of the current entry or the entry at POINT."
  (setq point (or point (point-at-bol)))
  (if (and (get-text-property point 'org-habit-p)
           (stringp (get-text-property point 'dotime)))
      (replace-regexp-in-string org-agenda-dych-repeater-re ""
                                (get-text-property point 'dotime))
    (get-text-property point 'dotime)))

(defun org-agenda-dych-time-less-than-tomorrow-p (time)
  "Return true when TIME is in today."
  (time-less-p time (apply #'encode-time (org-read-date-analyze "24:00" (decode-time) (decode-time)))))

(defun org-agenda-dych-entry-eligible-p ()
  (or (and (member (org-get-at-bol 'type) (list "scheduled" "past-scheduled"))
           (not (eq (org-get-at-bol 'face) (org-get-at-bol 'done-face))))
      (= (point) (point-max))))

(defun org-agenda-dych-h:mm-to-full-ts (time)
  "Convert HH:MM to full org time stamp."
  (format-time-string
   (org-time-stamp-format 'long)
   (apply #'encode-time
          (org-read-date-analyze time (decode-time) (decode-time)))))

(defun org-agenda-dych-time-of-day-to-hh:mm (time-of-day)
  "A reverse of `org-get-time-of-day' which convert TIME-OF-DAY to HH:MM format

TIME-OF-DAY can be a string or a number from `org-get-time-of-day'.

This function returns a string."
  (when (numberp time-of-day)
    (setq time-of-day (number-to-string time-of-day)))

  (pcase (string-width time-of-day)
    (3 (concat "0" (substring time-of-day 0 1) ":" (substring time-of-day 1)))
    (4 (concat (substring time-of-day 0 2) ":" (substring time-of-day 2)))))

(defun org-agenda-dych-first-entry-check ()
  "Check the first (earliest) task of the day in the agenda.

First, it checks if whether or not the first task is fixed, if
not, ask user to fix it.

Second, checks if the task starts at `org-agenda-dych-default-start', if not,
have the user confirm to set its scheduled time as the start of the day."
  (goto-char (point-min))
  (let ((pos (point))
        (last-time 2400)
        (earliest-task)
        (tasks))
    (while (setq pos (next-single-property-change pos 'time-of-day))
      (when (get-text-property pos 'org-hd-marker)
        (push (list
               :start (get-text-property pos 'time-of-day)
               :txt (get-text-property pos 'txt)
               :marker (get-text-property pos 'org-hd-marker)
               :line (org-current-line pos))
              tasks)))

      (setq earliest-task
            (car (sort tasks (lambda (e1 e2)
                               (< (plist-get e1 :start)
                                  (plist-get e2 :start))))))

      (goto-line (plist-get earliest-task :line))

    (if (org-agenda-dych-fixed-indicator (plist-get earliest-task :marker) t)
        (if (= (plist-get earliest-task :start)
               (org-get-time-of-day (org-agenda-dych-get-start)))
            (setq org-last-inserted-timestamp
                  (org-agenda-dych-h:mm-to-full-ts (org-agenda-dych-get-start)))
          (if (eq (org-get-at-bol 'face) (org-get-at-bol 'done-face))
              (setq org-last-inserted-timestamp
                    (org-agenda-dych-h:mm-to-full-ts (org-agenda-dych-get-start)))
            (if (eq (org-get-at-bol 'face) (org-get-at-bol 'done-face))
                (setq org-last-inserted-timestamp
                      (format-time-string
                       (org-time-stamp-format 'long)
                       (org-get-scheduled-time (plist-get earliest-task :marker)))))
            (if (yes-or-no-p (format "The earliest task (%s) starts at %s which are not the same as the default (%s). Want to start working at %s for this buffer only? "
                                     (plist-get earliest-task :txt)
                                     (org-agenda-dych-time-of-day-to-hh:mm
                                      (plist-get earliest-task :start))
                                     (org-agenda-dych-get-start)
                                     (org-agenda-dych-time-of-day-to-hh:mm
                                      (plist-get earliest-task :start))))
                (and (set (make-local-variable 'org-agenda-overriding-cmd)
                          (progn (push `(org-agenda-dych-overriding-start
                                         ,(org-agenda-dych-time-of-day-to-hh:mm
                                           (plist-get earliest-task :start)))
                                       (car (nthcdr 2 (org-get-at-bol 'org-series-cmd))))
                                 (org-get-at-bol 'org-series-cmd)))
                     (setq org-agenda-dych-current-start
                           (org-agenda-dych-time-of-day-to-hh:mm
                            (plist-get earliest-task :start))))
              (user-error "Please schedule a task to start at %s" (org-agenda-dych-get-start))))
        (if (yes-or-no-p (format "The first entry is not fixed to be the start of the working day (%s). Want to set it as the first task of the day? " (org-agenda-dych-get-start)))
            (progn (org-agenda-dych-maybe-schedule nil (org-agenda-dych-get-start))
                   (goto-line (plist-get earliest-task :line)) (org-agenda-dych-fix))
          (user-error "Please schedule a task to start at %s" (org-agenda-dych-get-start)))))))

;; TODO: Documentation
(defun org-agenda-dych-recompute ()
  "Keep all effort estimates in the agenda equal."
  (interactive)
  (save-excursion
    (let ((block-start (goto-char (point-min)))
          (bound (point-max))
          (rigid-minute 0) (rigid-count 0)
          (effort-plists) (count 0)
          (neffort)
          (lrigid)
          (leffort))

      (org-agenda-dych-first-entry-check)
      
      (setq lrigid (org-agenda-dych-rigid-indicator
                    (org-get-at-bol 'org-hd-marker) t))
      (setq leffort (or (org-get-at-bol 'effort-minutes) 0.0))

      (setq block-start (point))
            
      (while (text-property-search-forward 'fixed t)
        (when (org-agenda-dych-entry-eligible-p)
          (setq count 0)
          (setq rigid-count 0)
          (setq rigid-minute 0)
          (setq effort-plists
                (org-agenda-dych-map-entries
                 (lambda ()
                   (cl-incf count)
                   (list
                    :index (org-current-line)
                    :effort (org-get-at-bol 'effort)
                    :dotime (org-agenda-dych-get-dotime)
                    :fixed (org-agenda-dych-fixed-indicator
                            (org-get-at-bol 'org-hd-marker) t)
                    :rigid (and (org-agenda-dych-rigid-indicator
                                 (org-get-at-bol 'org-hd-marker) t)
                                (setq rigid-minute
                                      (string-to-number
                                       (calc-eval (format "%f+%f" rigid-minute
                                                          (org-get-at-bol 'effort-minutes)))))
                                (cl-incf rigid-count))))

                 block-start
                 (setq bound (save-excursion (org-agenda-dych-previous-item 1)
                                             (point-at-eol)))
                 #'org-agenda-dych-entry-eligible-p))

        
          (setq neffort (abs (string-to-number
                              (calc-eval (format "(%f-%f-%f)/%d"
                                                 (or (ignore-errors
                                                       (org-duration-to-minutes
                                                        (and (not (eq (org-agenda-dych-get-dotime) 'time))
                                                             (org-agenda-dych-get-dotime))))
                                                     (org-agenda-dych-get-workhours))
                                                 (org-duration-to-minutes
                                                  (or (org-agenda-dych-get-dotime block-start)
                                                      "0:00"))
                                                 rigid-minute
                                                 (- count rigid-count))))))
          (setq block-start (point))
        
          (save-excursion
            (dolist (pl effort-plists)
              (goto-line (plist-get pl :index))
              (if (and (plist-get pl :fixed)
                       (string= (org-get-at-bol 'type) "scheduled"))
                  (setq org-last-inserted-timestamp
                        (org-agenda-dych-h:mm-to-full-ts
                         (plist-get pl :dotime)))
                (let ((ntime (seconds-to-time
                              (string-to-number
                               (calc-eval (format "(%f*60)+%f"
                                                  (if lrigid leffort neffort)
                                                  (org-time-string-to-seconds
                                                   (if org-last-inserted-timestamp
                                                       (substring org-last-inserted-timestamp 1 -1)
                                                     (org-agenda-dych-h:mm-to-full-ts (org-agenda-dych-get-start))))))))))
                  (when (org-agenda-dych-time-less-than-tomorrow-p ntime)
                    (org-agenda-dych-maybe-schedule
                     nil (format-time-string (org-time-stamp-format t) ntime)))))
              
              (unless (org-entry-get (org-get-at-bol 'org-hd-marker) "TIME_ESTIMATE")
                (org-entry-put (org-get-at-bol 'org-hd-marker) "TIME_ESTIMATE" (plist-get pl :effort)))
              (setq lrigid (plist-get pl :rigid))
              (if (plist-get pl :rigid)
                  (setq leffort (org-get-at-bol 'effort-minutes))
                (org-entry-put (org-get-at-bol 'org-hd-marker) "EFFORT" (org-duration-from-minutes
                                                                neffort)))))))))
  (org-agenda-redo)
  (org-agenda-dych-mode 1))

;;; Agenda

(defun org-agenda-dych-add-properties ()
  "Add FIXED and RIGID property to entries in agenda."
  (goto-char (point-min))
  (while (not (eobp))
    (forward-line 1)
    (when (org-get-at-bol 'org-marker)
      (put-text-property (point-at-bol) (point-at-eol) 'fixed (org-agenda-dych-fixed-indicator (org-get-at-bol 'org-marker) t))
      (put-text-property (point-at-bol) (point-at-eol) 'rigid (org-agenda-dych-rigid-indicator (org-get-at-bol 'org-marker) t)))))

(add-hook 'org-agenda-finalize-hook #'org-agenda-dych-add-properties)

;;; Wrappers
;; Wrappers are necessary because I want the minor mode to be togglable.
;;;###autoload
(defun org-agenda-dych (arg &optional time)
  "Like `org-agenda-schedule' but fixes the entry at point & recompute afterwards.
When `org-agenda-dych-mode' is enabled, this command will replace `org-agenda-schedule'
\\<org-agenda-mode-map> when the user presses '\\[org-agenda-schedule]' in the agenda buffer"
  (interactive "P")
  (org-agenda-schedule arg time)
  (org-agenda-dych-fix)
  (org-agenda-dych-recompute))

;;;###autoload
(defun org-agenda-dych-begin-entry (&optional arg)
  "Schedule the current entry to now."
  (interactive "P")
  (org-agenda-schedule nil (format-time-string "%H:%M" (current-time)))
  (org-agenda-dych-fix)
  (org-agenda-clock-in arg)
  (org-agenda-dych-recompute))

;;;###autoload
(defun org-agenda-dych-redo-all (&optional exhaustive)
  "Like `org-agenda-redo-all' but call `org-agenda-dych-recompute' afterwards.
When `org-agenda-dych-mode' is enabled, this command will replace `org-agenda-redo-all'
\\<org-agenda-mode-map> when the user presses '\\[org-agenda-redo-all]' in the agenda buffer"
  (interactive "P")
  (org-agenda-dych-recompute)
  (org-agenda-redo-all exhaustive)
  (org-agenda-dych-mode 1))

;;;###autoload
(defun org-agenda-dych-set-effort ()
  "Like `org-agenda-set-effort' but call `org-agenda-dych-recompute' afterwards.
When `org-agenda-dych-mode' is enabled, this command will replace `org-agenda-set-effort'
\\<org-agenda-mode-map> when the user presses '\\[org-agenda-set-effort]' in the agenda buffer"
  (interactive)
  (org-agenda-set-effort)
  (org-agenda-dych-recompute))

(provide 'org-agenda-dych-mode)
;;; org-agenda-dych-mode.el ends here