bir/bir-mercy.el

;;; bir-mercy.el --- Mercy interface for BIR         -*- lexical-binding: t; -*-

;; Copyright (C) 2022  c1-g

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

;; 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 'widget)

(eval-when-compile
  (require 'wid-edit))

(defvar-local bir-mercy--last-edited-field nil)

(defvar-local bir-mercy--total nil)

(defvar-local bir-mercy--origin-buffer nil)

(defun bir-mercy-time-in (days)
  (let ((seconds (* days 60 60 24))
        (now (time-to-seconds)))
    (format-time-string "%b %d, %Y" (seconds-to-time (+ now seconds)))))

(defmacro bir-mercy-with-widget-deactivated (widget &rest body)
  (declare (debug (body)))
  `(let ((widget ,widget))
     (if (widget-apply ,widget :active)
         (progn ,@body)
       (widget-apply ,widget :activate)
       (progn ,@body)
       (widget-apply ,widget :deactivate))))


(defun bir-mercy (&optional match scope &rest skip)
  (interactive)
  (let* ((buf (get-buffer-create "*Mercy scheduling*"))
         (ids (org-map-entries #'org-id-get-create match scope skip))
         (total (length ids))
         (origin (current-buffer))
         (inhibit-read-only t))
    (with-current-buffer buf
      (remove-overlays)
      (erase-buffer)
      (kill-all-local-variables)
      (setq bir-mercy--origin-buffer origin)
      (setq bir-mercy--total total)
      (add-hook 'after-change-functions #'bir-maybe-get-widget-after-change nil t)
      (add-hook 'after-change-functions #'widget-after-change nil t)
      (widget-insert (format "Elements to schedule %s"
                             (propertize (make-string 1 ?\s) 'display '(space :align-to 45))))
      (widget-apply (widget-create 'integer
                                   :size 7
                                   :tag 'total
                                   :format "%v\n\n"
                                   total)
                    :deactivate)
      (widget-insert (make-string fill-column ?-) "\n\n")
      (widget-create 'integer
                     :size 10
                     :valid-regexp "[[:digit:]]+"
                     :tag 'elt-per-day
                     :format (format "Number of elements per day: %s%%v"
                                     (propertize (make-string 1 ?\s) 'display '(space :align-to 45)))
                     total)
      (widget-insert "\n\n")
      (widget-create 'integer
                     :valid-regexp "[[:digit:]]+"
                     :tag 'period
                     :size 10
                     :format (format "Scheduling period: %s%%v"
                                     (propertize (make-string 1 ?\s) 'display '(space :align-to 45)))
                     1)
      (widget-apply (widget-create 'text
                                   :tag 'date
                                   :size 12
                                   :format " %v\n\n"
                                   (bir-mercy-time-in 1))
                    :deactivate)
      (widget-insert (make-string fill-column ?-) "\n\n")
      (widget-insert "Choosing OK will result in scheduling ")
      (widget-apply (widget-create 'integer
                                   :size 7
                                   :tag 'total
                                   :format "%v"
                                   total)
                    :deactivate)
      (widget-insert "  elements collected from\na collecting period of ")
      (widget-apply (widget-create 'integer
                                   :valid-regexp "[[:digit:]]+"
                                   :size 4
                                   :tag 'period
                                   :format "%v"
                                   1)
                    :deactivate)
      (widget-insert " days(s) in a period from today till ")
      (widget-apply (widget-create 'text
                                   :tag 'date
                                   :size 12
                                   :format "%v\n"
                                   (bir-mercy-time-in 1))
                    :deactivate)
      (widget-insert "with ")
      (widget-apply (widget-create 'integer
                                   :valid-regexp "[[:digit:]]+"
                                   :size 5
                                   :tag 'elt-per-day
                                   :format "%v"
                                   total)
                    :deactivate)
      (widget-insert " repetitions per day.")
      (widget-insert "\n\n")
      (widget-insert (propertize (make-string 1 ?\s) 'display '(space :align-to 40)))
      (widget-insert " ")
      (widget-create 'push-button
                     :notify (apply-partially #'bir-mercy-complete ids)
                     :button-face 'org-checkbox-statistics-done
                     "✓ OK")
      (widget-insert " ")
      (widget-create 'push-button
                     :notify (lambda (&rest ignore)
                               (kill-buffer))
                     :button-face 'org-checkbox-statistics-todo
                     "❌ Cancel")
      (widget-insert " ")
      (widget-create 'push-button
                     :notify (lambda (&rest ignore)
                               (bir-mercy-update bir-mercy--last-edited-field))
                     :button-face 'org-date
                     "⭯ Update")
      (widget-insert " ")
      (use-local-map widget-keymap)
      (widget-setup)
      (display-buffer-in-side-window buf '((dedicated . t)
                                           (side . right)))
      (select-window (get-buffer-window buf))
      (let ((fit-window-to-buffer-horizontally t))
        (fit-window-to-buffer)))))

(defun bir-maybe-get-widget-after-change (from to _old)
  (let ((field (widget-field-find from))
        (other (widget-field-find to)))
    (when field
      (unless (eq field other)
        (error "Change in different fields"))
      (setq-local bir-mercy--last-edited-field field))))

(defun bir-mercy-complete (ids &rest _ignore)
  "docstring"
  (let* ((widgets (cl-remove-if-not
                   (lambda (w)
                     (widget-apply w :active))
                   widget-field-list))
         (elt-per-day (widget-value (seq-find (lambda (w)
                                                (eq 'elt-per-day (widget-get w :tag)))
                                              widgets)))
         (period (widget-value (seq-find (lambda (w)
                                           (eq 'period (widget-get w :tag)))
                                         widgets)))
         (ids (seq-partition ids elt-per-day)))
    (with-current-buffer bir-mercy--origin-buffer
      (save-excursion
        (dotimes (i period)
          (dolist (id (nth i ids))
            (goto-char (org-find-entry-with-id id))
            (org-schedule nil (format "+%d" i))))))))

(defun bir-mercy-update (field)
  (when field
    (let* ((widgets (seq-group-by (lambda (w)
                                    (widget-get w :tag))
                                  widget-field-list))

           (active-period-widget (car
                                  (cl-remove-if-not
                                   (lambda (w)
                                     (widget-apply w :active))
                                   (alist-get 'period widgets))))

           (tag (widget-get field :tag))
           (period))
      (when (memq tag '(elt-per-day period))
        (dolist (widget (alist-get tag widgets))
          (bir-mercy-with-widget-deactivated
           widget
           (widget-value-set
            widget
            (widget-value field))))
        (dolist (widget (alist-get (car (delq tag '(elt-per-day period))) widgets))
          (bir-mercy-with-widget-deactivated
           widget
           (widget-value-set
            widget
            (round (/ bir-mercy--total
                      (widget-value field)))))))
      (when active-period-widget
        (dolist (date-widget (alist-get 'date widgets))
          (bir-mercy-with-widget-deactivated
           date-widget
           (widget-value-set
            date-widget
            (bir-mercy-time-in (widget-value active-period-widget))))))
      (widget-setup))))


(provide 'bir-mercy)
;;; bir-mercy.el ends here