ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF put cluster code in terms of org-ml

This commit is contained in:
Nathan Dwarshuis 2021-04-11 23:35:34 -04:00
parent d9bc5863a1
commit e92e2dd945
2 changed files with 92 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
etc/conf.org
View File

@ -1698,7 +1698,9 @@ Save all org buffers 1 minute before the hour.
Org extras Org extras
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
(use-package org-ml (use-package org-ml
:straight t) :straight t
:config
(setq org-ml-memoize-match-patterns t))
(add-to-list 'load-path (nd/expand-lib-directory "org-x")) (add-to-list 'load-path (nd/expand-lib-directory "org-x"))
(require 'org-x) (require 'org-x)

169
local/lib/org-x/org-x.el
View File

@ -1161,92 +1161,65 @@ The fields are as follows:
"Return non-nil if the timestamp TS has hours/minutes." "Return non-nil if the timestamp TS has hours/minutes."
(org-element-property :hour-start ts)) (org-element-property :hour-start ts))
(defun org-x-cluster-parse-ts (ts hl fp) (defun org-x-cluster-parse-ts (hl fp ts)
"Parse a timestamp TS belonging to headline HL and filepath FP. "Parse a timestamp TS belonging to headline HL and filepath FP.
TS is an object as described in the org-element API. Only active TS is an object as described in the org-element API. Only active
or active-range types are considered. Returns a new timestamp-plist or active-range types are considered. Returns a new timestamp-plist
for TS." for TS."
(when ts (when ts
(let* ((offset (org-element-property :begin hl)) (let ((offset (org-element-property :begin hl))
(hardness (org-x-cluster-ts-hard-p ts)) (hardness (org-x-cluster-ts-hard-p ts))
(split (start (->> (org-ml-timestamp-get-start-time ts)
(lambda (ts &optional end) (org-ml-time-to-unixtime)))
(--> ts (range (org-ml-timestamp-get-range ts)))
(org-timestamp-split-range it end) (org-x-cluster-make-tsp start 0 offset fp hardness))))
(org-element-property :raw-value it)
(org-2ft it))))
(start (funcall split ts)))
(if (eq (org-element-property :type ts) 'active-range)
(let ((range (--> ts (funcall split it t) (- it start))))
(org-x-cluster-make-tsp start range offset fp hardness))
(org-x-cluster-make-tsp start 0 offset fp hardness)))))
(defun org-x-cluster-effort-seconds (effort-str) (defun org-x-cluster-effort-seconds (effort-str)
"Convert EFFORT-STR into an integer in seconds from HH:MM format." "Convert EFFORT-STR into an integer in seconds from HH:MM format."
(-some->> effort-str (org-duration-to-minutes) (* 60))) (-some->> effort-str (org-duration-to-minutes) (* 60)))
;; (let ((effort-str (string-trim effort-str)))
;; (save-match-data
;; (cond
;; ((string-match "^\\([0-9]+\\):\\([0-6][0-9]\\)$" effort-str)
;; (let ((hours (->> effort-str
;; (match-string 1)
;; string-to-number
;; (* 60))))
;; (->> effort-str
;; (match-string 2)
;; string-to-number
;; (+ hours)
;; (* 60))))
;; (t (error (format "Unknown effort: %s'" effort-str)))))))
(defun org-x-cluster-extract (acc fun objs &rest args) ;; (defun org-x-cluster-extract (acc fun objs &rest args)
"Run FUN on each of OBJS and put results into accumulator ACC. ;; "Run FUN on each of OBJS and put results into accumulator ACC.
FUN is a function that takes the accumulator as its first argument, ;; FUN is a function that takes the accumulator as its first argument,
one member of OBJS as the second, and ARGS as the rest if supplied." ;; one member of OBJS as the second, and ARGS as the rest if supplied."
(while objs ;; (while objs
(setq acc (apply fun acc (car objs) args) ;; (setq acc (apply fun acc (car objs) args)
objs (cdr objs))) ;; objs (cdr objs)))
acc) ;; acc)
(defun org-x-cluster-extract-hl-sched (acc hl fp) (defun org-x-cluster-extract-hl-sched (hl fp)
"Extract scheduled timestamp from headline HL in filepath FP. "Extract scheduled timestamp from headline HL in filepath FP.
Create a new timestamp-plist and add to accumulator ACC." Create a new timestamp-plist and add to accumulator ACC."
(let* ((ts (org-element-property :scheduled hl)) (-when-let (ts (-some->> (org-ml-headline-get-planning hl)
(unixtime (->> ts (org-element-property :raw-value) org-2ft)) (org-ml-get-property :scheduled)))
(range (-some->> hl (let* ((effort-raw (org-ml-headline-get-node-property "Effort" hl))
(org-element-property :EFFORT) (effort (if effort-raw (org-x-cluster-effort-seconds effort-raw) 0))
org-x-cluster-effort-seconds)) (offset (org-ml-get-property :begin hl))
(hardness (org-x-cluster-ts-hard-p ts)) (start-time (org-ml-timestamp-get-start-time ts))
(offset (org-element-property :begin hl))) (start-epoch (org-ml-time-to-unixtime start-time))
(if (= 0 unixtime) acc (is-long (org-ml-time-is-long start-time)))
(-> unixtime (org-x-cluster-make-tsp start-epoch effort offset fp is-long))))
(org-x-cluster-make-tsp range offset fp hardness 'scheduled)
(cons acc)))))
(defun org-x-cluster-extract-hl-ts (acc hl fp) (defun org-x-cluster-extract-hl-ts (hl fp)
"Extract timestamps from headline HL in filepath FP. "Extract timestamps from headline HL in filepath FP.
All active timestamps that are not in drawers or the planning header All active timestamps that are not in drawers or the planning header
are considered. Each timestamp is converted into a new timestamp-plist are considered. Each timestamp is converted into a new timestamp-plist
and added to accumulator ACC." and added to accumulator ACC."
(--> hl (-some->> hl
(assoc 'section it) (org-ml-headline-get-contents
(org-element-contents it) (list :log-into-drawer org-log-into-drawer
(--remove :clock-into-drawer org-clock-into-drawer
(or (eq 'planning (org-element-type it)) :clock-out-notes org-log-note-clock-out))
(eq 'property-drawer (org-element-type it)) (apply #'org-ml-build-section)
(eq 'drawer (org-element-type it))) (org-ml-match '(:first :any * (:and timestamp
it) (:or (:type 'active)
(org-element-map it 'timestamp #'identity) (:type 'active-range)))))
(--filter (car)
(or (eq 'active (org-element-property :type it)) (org-x-cluster-parse-ts hl fp)))
(eq 'active-range (org-element-property :type it)))
it)
(--map (org-x-cluster-parse-ts it hl fp) it)
(append acc it)))
(defun org-x-cluster-extract-hl (acc hl fp) (defun org-x-cluster-extract-hl (hl fp)
"Extract timestamps from headline HL in filepath FP and store in ACC." "Extract timestamps from headline HL in filepath FP and store in ACC."
(-> acc (if (org-ml-get-property :todo-keyword hl)
(org-x-cluster-extract-hl-sched hl fp) (org-x-cluster-extract-hl-sched hl fp)
(org-x-cluster-extract-hl-ts hl fp))) (org-x-cluster-extract-hl-ts hl fp)))
@ -1276,25 +1249,28 @@ and added to accumulator ACC."
(if (not org-x-cluster-filter-habit) hls (if (not org-x-cluster-filter-habit) hls
(--remove (org-element-property :STYLE it) hls))) (--remove (org-element-property :STYLE it) hls)))
(defun org-x-cluster-extract-file (acc fp) (defun org-x-cluster-extract-buffer (fp)
"Extract headlines from the current buffer for clustering analysis."
(->> (org-ml-parse-headlines 'all)
(org-x-cluster-filter-todo)
(org-x-cluster-filter-habit)
(--reduce-from (let ((new (org-x-cluster-extract-hl it fp)))
(if new (cons new acc) acc))
nil)))
(defun org-x-cluster-extract-file (fp)
"Extract timestamps from filepath FP and add to accumulator ACC." "Extract timestamps from filepath FP and add to accumulator ACC."
(--> (with-current-buffer (find-file-noselect fp t)
fp (org-x-cluster-extract-buffer fp)))
(find-file-noselect it t)
(with-current-buffer it (org-element-parse-buffer))
(org-element-map it 'headline #'identity)
(org-x-cluster-filter-todo it)
(org-x-cluster-filter-habit it)
(org-x-cluster-extract acc #'org-x-cluster-extract-hl it fp)))
(defun org-x-cluster-get-unprocessed () (defun org-x-cluster-get-unprocessed ()
"Return a list of timestamp-plists with desired filter settings." "Return a list of timestamp-plists with desired filter settings."
(->> (->> (org-agenda-files)
;; (list "~/Org/reference/testconflict.org") (org-x-cluster-filter-files)
(org-agenda-files) (--reduce-from (let ((new (org-x-cluster-extract-file it)))
org-x-cluster-filter-files (if new (append new acc) acc))
(org-x-cluster-extract nil #'org-x-cluster-extract-file) nil)
org-x-cluster-filter-past)) (org-x-cluster-filter-past)))
;; get conflict headlines ;; get conflict headlines
;; ;;
@ -1357,6 +1333,25 @@ Each member in the cons cell is a timestamp-plist."
;; 3. sort from earliest to latest starting time ;; 3. sort from earliest to latest starting time
;; 4. sum the range of timestamps in each day, keeping those that exceed 24 hours ;; 4. sum the range of timestamps in each day, keeping those that exceed 24 hours
;; (defun org-x-cluster-split-tsp-maybe (tsp)
;; "Split TIMESTAMP if it spans multiple days."
;; (-let (((&plist :start-time :range) tsp))
;; (if (= range 0) (list tsp)
;; ;; assume long time (for now)
;; (let* (((y m d H M) start-time)
;; (et* (encode-time `(0 ,M ,M ,d ,m ,y nil nil nil)))
;; ((M* H* d* m* y*) (-take 5 (cdr (decode-time et*)))))
;; (if (or (< d d*) (< m m*) (< y y*))
;; (let ((range* (- (float-time et*)
;; (float-time (encode-time `(0 0 0 ,d* ,m* ,y* nil nil nil))))))
;; (
;; (start-offset-sec (if (and H M) (* 60 (+ M (* 60 H))) 0))
;; (spanned-days (1- (/ (+ start-offset-sec range) (* 24 60 60)))))
;; (if (= 0 spanned-days) (list (list :start-time start-time :range range))
;; (let ((first-range (- (* 24 60 60) start-offset-sec))
;; (last-range (% (+ start-offset-sec range) (* 24 60 60))))
(defun org-x-cluster-split-day-bounds (tsps) (defun org-x-cluster-split-day-bounds (tsps)
"Split timestamp-plists in TSPS via daily boundaries. "Split timestamp-plists in TSPS via daily boundaries.
Returns a new timestamp-plist with equal or greater length depending Returns a new timestamp-plist with equal or greater length depending
@ -1376,7 +1371,12 @@ on how many members needed splitting."
(lambda (start end tsp) (lambda (start end tsp)
(let* ((tzs-a (-> start current-time-zone car)) (let* ((tzs-a (-> start current-time-zone car))
(tzs-b (-> end current-time-zone car)) (tzs-b (-> end current-time-zone car))
(start* (-> end (+ tzs-b) (ceiling 86400) 1- (* 86400) (- tzs-b)))) (start* (-> end
(+ tzs-b)
(ceiling 86400)
(1-)
(* 86400)
(- tzs-b))))
(if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a))) (if (> start* (-> start (+ tzs-a) (floor 86400) (* 86400) (- tzs-a)))
(cons (funcall new start* end tsp) (cons (funcall new start* end tsp)
(funcall split start start* tsp)) (funcall split start start* tsp))
@ -1416,12 +1416,11 @@ day."
Anything present represents all the tasks in a single day if that day Anything present represents all the tasks in a single day if that day
is overloaded. If a day is not overloaded there will be nothing for it is overloaded. If a day is not overloaded there will be nothing for it
in the returned list." in the returned list."
(->> (->> (org-x-cluster-get-unprocessed)
(org-x-cluster-get-unprocessed)
(--filter (< 0 (plist-get it :range))) (--filter (< 0 (plist-get it :range)))
org-x-cluster-split-day-bounds (org-x-cluster-split-day-bounds)
(--sort (< (plist-get it :unixtime) (plist-get other :unixtime))) (--sort (< (plist-get it :unixtime) (plist-get other :unixtime)))
org-x-cluster-daily-split (org-x-cluster-daily-split)
(--filter (org-x-cluster-overloaded-p it)))) (--filter (org-x-cluster-overloaded-p it))))
;; conflict/overload frontend ;; conflict/overload frontend