|
|
@@ -0,0 +1,224 @@
|
|
|
+;;; 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
|
c1-g