From 89c076cc5e1699049817ecde7c3b1541a78b4cc6 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 12 Feb 2022 17:17:42 -0500
Subject: [PATCH] ADD functions for allocationc

---
 local/lib/org-x/org-x-dag.el | 65 ++++++++++++++++++++++++++++++++++--
 1 file changed, 62 insertions(+), 3 deletions(-)

diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el
index 811586b..bb81597 100644
--- a/local/lib/org-x/org-x-dag.el
+++ b/local/lib/org-x/org-x-dag.el
@@ -369,15 +369,17 @@ A date like (YEAR MONTH DAY).")
 (defun org-x-dag-headline-add-id (headline)
   (org-ml-headline-set-node-property "ID" (org-id-new) headline))
 
-(defun org-x-qtp-build-goal-headline (ids title)
+(defun org-x-qtp-build-goal-headline (ids title allocation)
+  ;; ASSUME the allocation is in a valid format
   (let ((d (org-x-dag-build-parent-link-drawer ids)))
     (->> (org-ml-build-headline! :level 3
                                  :title-text title
                                  :todo-keyword org-x-kw-todo
                                  :section-children (list d))
-         (org-x-dag-headline-add-id))))
+         (org-x-dag-headline-add-id)
+         (org-ml-headline-set-node-property org-x-prop-allocate allocation))))
 
-(defun org-x-qtp-add-goal-ids (quarter ids title)
+(defun org-x-qtp-add-goal-ids (quarter ids title allocation)
   (->> (org-x-qtp-build-goal-headline ids title)
        (org-x-qtp-add-goal quarter)))
 
@@ -1624,5 +1626,62 @@ FUTURE-LIMIT in a list."
    (--remove-first (equal (car it) id) it)
    headline))
 
+;;; ALLOCATION
+
+(defun org-x-dag-quarter-to-date (quarter)
+  (-let (((y q) quarter))
+    (list y (1+ (* q 3)) 1)))
+
+(defun org-x-dag-shift-quarter (quarter n unit)
+  (-let (((y q) quarter))
+    (pcase unit
+      (`year `(,(+ n y) ,q))
+      (`quarter
+       (let* ((x (+ q n))
+              (q* (mod x 4))
+              (y* (+ y (floor (/ x 4.0)))))
+         `(,y* ,q*))))))
+
+(defun org-x-dag-quarter-diff (quarter1 quarter2)
+  (cl-flet
+      ((qt-to-abs
+        (q)
+        (->> (org-x-dag-quarter-to-date q)
+             (org-x-dag-date-to-gregorian)
+             (calendar-absolute-from-gregorian))))
+    (- (qt-to-abs quarter1) (qt-to-abs quarter2))))
+
+(pcase-defmacro regexp (capture regexp)
+  `(and x (let ,capture (s-match ,regexp x))))
+
+;; this function can also be used to check the format of an allocation during
+;; assignment
+(defun org-x-dag-allocation-fraction (quarter allocation)
+  (cl-flet
+      ((hhmm-to-mins
+        (H M)
+        (let ((H* (string-to-number H))
+              (M* (string-to-number M)))
+          (+ (* 60.0 H*) M*))))
+    (let* ((qt-days (-> (org-x-dag-shift-quarter quarter 1 'quarter)
+                        (org-x-dag-quarter-diff quarter)
+                        (float)))
+           (qt-mins (* qt-days 1440))
+           (hhmm-regexp "\\(2[0-4]\\|[0-1][0-9]\\|[0-9]\\):\\([0-6][0-9]\\)"))
+      (pcase allocation
+        ;; match 'X%' where X is a flat percent of the quarter
+        ((regexp `(,_ ,percent) "^\\([0-9]+\\)%$")
+         (/ (string-to-number percent) 100.0))
+        ;; match 'H:M' where H is hours and M is minutes (both clock digits)
+        ((regexp `(,_ ,H ,M) (format "^%s$" hhmm-regexp))
+         (/ (hhmm-to-mins H M) 1440.0))
+        ;; match 'H:M/Dd' where H/M are like above and D is number of days
+        ;; per quarter
+        ((regexp `(,_ ,H ,M ,d) (format "^%s/\\([0-9]+\\)d$" hhmm-regexp))
+         (let ((d* (string-to-number d))
+               (mins (hhmm-to-mins H M)))
+           (/ (* mins d*) qt-mins)))
+        (e (error "Invalid allocation: %s" e))))))
+
 (provide 'org-x-dag)
 ;;; org-x-dag.el ends here