From e00be6120c606582a0fa1b6ac74d9b218c663a52 Mon Sep 17 00:00:00 2001 From: Sacha Chua Date: Sun, 2 Oct 2022 19:36:26 -0400 Subject: Refactor emacsconf-schedule --- emacsconf-schedule.el | 429 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 429 insertions(+) create mode 100644 emacsconf-schedule.el (limited to 'emacsconf-schedule.el') diff --git a/emacsconf-schedule.el b/emacsconf-schedule.el new file mode 100644 index 0000000..23bdc86 --- /dev/null +++ b/emacsconf-schedule.el @@ -0,0 +1,429 @@ +;;; emacsconf-schedule.el --- Scheduling support -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Sacha Chua + +;; Author: Sacha Chua +;; Keywords: calendar + +;; 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 . + +;;; Commentary: + +;; + +;;; Code: + +(defvar emacsconf-scheduling-strategies nil "List of scheduling functions. +Each function should take the info and manipulate it as needed, returning the new info.") + +(defvar emacsconf-schedule-max-time 30) +(defun emacsconf-schedule-allocate-at-most (info) + "Allocate at most `emacsconf-schedule-max-time' to the talks." + (mapcar (lambda (o) + (when (plist-get o :max-time) + (plist-put o :time + (number-to-string + (min + (string-to-number (plist-get o :max-time)) + emacsconf-max-time)))) + o) + info)) + + +(defvar emacsconf-schedule-break-time 10 "Number of minutes for break.") +(defvar emacsconf-schedule-lunch-time 45 "Number of minutes for lunch.") + +(defun emacsconf-schedule-override-breaks (info) + (mapcar (lambda (o) + (when (string-match "BREAK" (plist-get o :title)) + (plist-put o :time (number-to-string emacsconf-schedule-break-time))) + (when (string-match "LUNCH" (plist-get o :title)) + (plist-put o :time (number-to-string emacsconf-schedule-lunch-time))) + o) + info)) + +(defun emacsconf-schedule-prepare (&optional info) + (emacsconf-schedule-based-on-info + (seq-reduce (lambda (prev val) (funcall val prev)) + emacsconf-scheduling-strategies + (or info (emacsconf-get-talk-info))))) + +(defun emacsconf-schedule-summarize-breaks (&optional list) + (setq list (or list (emacsconf-schedule-summarize))) + (let ((list (or list (emacsconf-schedule-summarize))) + (title-field 5)) + (append + (cdr (seq-filter (lambda (o) (string-match "BREAK" (elt o title-field))) + list)) + '(hline) + (cdr (seq-filter (lambda (o) (string-match "LUNCH" (elt o title-field))) + list))))) + +(defun emacsconf-schedule-strategy-pack-everything-in-just-as-confirmed (&optional info) + (let* ((emacsconf-schedule-break-time 10) + (emacsconf-schedule-lunch-time 30) + (emacsconf-schedule-max-time 30) + (emacsconf-schedule-default-buffer-minutes 5) + (emacsconf-schedule-default-buffer-minutes-for-live-q-and-a 10) + (emacsconf-schedule-tweaked-allocations '(("indieweb" . 20) + ("maint" . 20) + ("workflows" . 20))) + (emacsconf-scheduling-strategies '(emacsconf-schedule-allocate-buffer-time + emacsconf-schedule-override-breaks + emacsconf-schedule-allocate-buffer-time-at-most-max-time + emacsconf-schedule-allocate-max-time + emacsconf-schedule-allocate-at-most + emacsconf-schedule-tweak-allocations))) + (emacsconf-schedule-prepare info))) + +(defun emacsconf-schedule-allocate-buffer-time-at-most-max-time (info) + (mapcar (lambda (o) + (when (plist-get o :slug) + (plist-put o :buffer + (number-to-string + (if (string-match "live" (plist-get o :q-and-a)) + (min (string-to-number (plist-get o :max-time)) + emacsconf-schedule-default-buffer-minutes-for-live-q-and-a) + emacsconf-schedule-default-buffer-minutes)))) + o) + info)) + +(defun emacsconf-schedule-dump-sexp (info &optional include-time) + (mapcar (lambda (o) + (cond + ((plist-get o :slug) (if include-time (cons (plist-get o :slug) (plist-get o :time)) (intern (plist-get o :slug)))) + ((plist-get o :fixed-time) (cons (plist-get o :title) (format-time-string "%Y-%m-%d %H:%M" (plist-get o :start-time)))) + (t (if include-time + (cons (plist-get o :title) (or (plist-get o :time) (plist-get o :max-time))) + (plist-get o :title))))) + info)) + +(defun emacsconf-schedule-validate-and-summarize (schedule) + (let ((validation-results (emacsconf-validate-time-constraints schedule)) + (sched (emacsconf-summarize-schedule schedule))) + (append + (list (list (format "%d talks" (length (emacsconf-filter-talks arranged))))) + (mapcar (lambda (o) (list nil nil nil nil nil o)) validation-results) + (if show-breaks + (append + (emacsconf-summarize-schedule + (seq-filter (lambda (o) (string-match "BREAK\\|LUNCH" (plist-get o :title))) + schedule)) + '(hline))) + sched nil))) + +(defun emacsconf-schedule-inflate-sexp (sequence &optional info include-time) + "Pairs with `emacsconf-schedule-dump-sexp'." + (setq info (or info (emacsconf-get-talk-info))) + (let ((by-assoc (mapcar (lambda (o) (cons (intern (plist-get o :slug)) o)) (emacsconf-filter-talks info)))) + (mapcar + (lambda (seq) + (if include-time + (error "Not yet implemented") + (cond + ((eq seq 'break) + (list :title "BREAK" :time emacsconf-schedule-break-time)) + ((eq seq 'lunch) + (list :title "LUNCH" :time emacsconf-schedule-lunch-time)) + ((and (listp seq) (member (car seq) '(break lunch)) (stringp (cdr seq))) + (list :title (if (eq (car seq) 'lunch) "LUNCH" "BREAK") + :scheduled (format-time-string (car org-time-stamp-formats) (date-to-time (cdr seq))) + :start-time (date-to-time (cdr seq)) + :fixed-time t + :time (if (eq (car seq) 'lunch) emacsconf-schedule-lunch-time emacsconf-schedule-break-time))) + ((and (listp seq) (member (car seq) '(break lunch)) (numberp (cdr seq))) + (list :title (if (eq (car seq) 'lunch) "LUNCH" "BREAK") + :time (string-to-number (cdr seq)))) + ;; Named thing with fixed time + ((and (listp seq) (stringp (car seq)) (stringp (cdr seq))) + (append + (seq-find (lambda (o) (string= (plist-get o :title) (car seq))) info) + (list :title (car seq) + :scheduled (format-time-string (car org-time-stamp-formats) (date-to-time (cdr seq))) + :start-time (date-to-time (cdr seq)) + :fixed-time t))) + ;; Named thing with duration + ((and (listp seq) (stringp (car seq)) (numberp (cdr seq))) + (append + (seq-find (lambda (o) (string= (plist-get o :title) (car seq))) info) + (list :title (car seq) + :time (number-to-string (cdr seq))))) + ;; Named thing + ((stringp seq) + (append + (seq-find (lambda (o) (string= (plist-get o :title) seq)) info) + (list :title seq))) + ;; Slug with time + ((and (listp seq) (symbolp (car seq)) (stringp (cdr seq))) + (append (assoc-default seq by-assoc) + (list :scheduled (format-time-string (car org-time-stamp-formats) (date-to-time (cdr seq))) + :start-time (date-to-time (cdr seq)) + :fixed-time t))) + ;; Slug with duration + ((and (listp seq) (symbolp (car seq)) (numberp (cdr seq))) + (append (assoc-default seq by-assoc) + (list :override-time t + :time (number-to-string (cdr seq))))) + ;; Just the slug + ((symbolp seq) + (assoc-default seq by-assoc)) + (t (error "Unknown %s" (prin1-to-string seq)))))) + sequence))) + +(defun emacsconf-format-schedule-summary-row (o) + (pcase emacsconf-focus + ('status + (list + (plist-get o :status) + (if (plist-get o :slug) + (org-link-make-string (plist-get o :url) + (plist-get o :slug)) + "") + (if (plist-get o :scheduled) + (emacsconf-format-short-time (plist-get o :scheduled)) + "") + (or (plist-get o :time) "") + (or (plist-get o :buffer) "") + (org-link-make-string (org-link-heading-search-string (plist-get o :title)) + (plist-get o :title)) + (or (plist-get o :speakers) "") + (or (plist-get o :q-and-a) "") + (or (plist-get o :availability) ""))) + ('time + (list + (if (plist-get o :slug) + (org-link-make-string (plist-get o :url) (plist-get o :slug)) + "------") + (if (and (plist-get o :scheduled) + (not (plist-get o :fixed-time))) + (emacsconf-format-short-time (plist-get o :scheduled) t) + "") + (or (plist-get o :time) "") + (or (plist-get o :buffer) "") + (if (< (string-to-number (or (plist-get o :time) "")) + (string-to-number (or (plist-get o :max-time) ""))) + (plist-get o :max-time) + "") + (org-link-make-string (org-link-heading-search-string (plist-get o :title)) + (plist-get o :title)) + (if (plist-get o :scheduled) ; time is here twice so we can easily check it against availability + (emacsconf-format-short-time (plist-get o :scheduled)) + "") + (or (plist-get o :availability) ""))))) + +(defun emacsconf-schedule-summarize (&optional info) + (cons + (if (eq emacsconf-focus 'time) + (list "Slug" "Schedule" "Time" "Buffer" "Max" "Title" "Time" "Availability") + (list "Status" "Slug" "Schedule" "Time" "Buffer" "Title" "Name" "Q&A" "Availability")) + (mapcar #'emacsconf-schedule-format-summary-row (or info (emacsconf-get-talk-info))))) + +(defun emacsconf-update-schedules-from-info (info) + (emacsconf-schedule-update info) + (save-window-excursion + (save-excursion + (mapc (lambda (talk) + (emacsconf-go-to-talk (plist-get talk :slug)) + (org-entry-put (point) "TIME" (plist-get talk :time))) + (emacsconf-filter-talks info))))) + + + + + +(defun emacsconf-summarize-track-as-svg (svg base-x base-y width height start-time end-time info &optional vertical) + (let ((scale (/ (if vertical height width) + (float-time (time-subtract end-time start-time))))) + (mapc + (lambda (o) + (let* ((offset (floor (* scale (float-time (time-subtract (plist-get o :start-time) start-time))))) + (size (floor (* scale (float-time (time-subtract (plist-get o :end-time) (plist-get o :start-time)))))) + (x (if vertical base-x (+ base-x offset))) + (y (if vertical (+ base-y offset) base-y))) + (dom-append-child + svg + (dom-node + 'a + `((href . ,(plist-get o :url)) + (title . ,(plist-get o :title))) + (dom-node + 'rect + `((x . ,x) + (y . ,y) + (width . ,(if vertical width size)) + (height . ,(1- (if vertical size height))) + (stroke . "black") + (fill . ,(if (plist-get o :invalid) "red" "gray")))) + (dom-node + 'g + `((transform . ,(format "translate(%d,%d)" + (+ x (if vertical width size) -2) (+ y (if vertical size height) -2)))) + (dom-node + 'text + '((fill . "black") + (x . 0) + (y . 0) + (font-size . 10) + (transform . "rotate(-90)")) + (svg--encode-text (or (plist-get o :slug) (plist-get o :title))))))))) + (emacsconf-filter-talks info)))) + +(defun emacsconf-summarize-schedule-as-svg (width height start end tracks &optional vertical) + (let* ((svg (svg-create width height :background "white")) + (track-width (if vertical (/ width (length tracks)) width)) + (grid-margin 10) + (track-height (if vertical height (/ (- height grid-margin) (length tracks)))) + (x 0) (y 0) + (scale (/ (if vertical height width) + (float-time (time-subtract end start)))) + (time start)) + (svg-rectangle svg 0 0 width height :fill "white") + ;; draw grid + (while (time-less-p time end) + (let ((x (* (float-time (time-subtract time start)) scale))) + (dom-append-child + svg + (dom-node + 'g + `((transform . ,(format "translate(%d,0)" x))) + (dom-node + 'line + `((stroke . "gray") + (x1 . 0) + (y1 . 0) + (x2 . 0) + (y2 . ,(- height grid-margin)))) + (dom-node + 'text + `((fill . "gray") + (x . 0) + (y . ,(- height 2)) + (font-size . 5)) + (svg--encode-text (format-time-string "%-l" time))))) + (setq time (time-add time (seconds-to-time 3600)))) + + ) + (mapc (lambda (track) + (emacsconf-summarize-track-as-svg + svg x y track-width track-height + start end track vertical) + (if vertical + (setq x (+ x track-width)) + (setq y (+ y track-height)))) + tracks) + svg)) + +(defun emacsconf-schedule-get-subsequence (info start &optional end) + "START and END are regexps to match against the title in INFO." + (seq-subseq info + (1+ (seq-position info start + (lambda (o match) (string-match match (plist-get o :title))))) + (if end + (seq-position info end + (lambda (o match) (string-match match (plist-get o :title)))) + (length info)))) + +;;; Schedule summary + +(defun emacsconf-schedule-round-start-to-five (o) + (let* ((start-time (plist-get o :start)) + (decoded-time (decode-time start-time "America/Toronto")) + (duration (* (string-to-number (plist-get o :time)) 60)) + (minutes (elt decoded-time 1)) + offset end-time) + (unless (= (mod minutes 5) 0) + (setq offset (seconds-to-time (* 60 (- 5 (mod minutes 5)))) + end-time (time-add start-time (time-to-seconds duration))) + (plist-put o :scheduled (format "%s-%s" (format-time-string "%Y-%m-%d %H:%M" (time-add start-time offset)) + (format-time-string "%H:%M" (time-add end-time offset)))) + (plist-put o :start-time (time-add start-time offset)) + (plist-put o :end-time (time-add end-time offset))))) + +;(emacsconf-update-schedules #'emacsconf-round-start-to-five) +(defvar emacsconf-schedule-default-buffer-minutes-for-live-q-and-a 15) +(defvar emacsconf-schedule-default-buffer-minutes 5) +(defun emacsconf-schedule-allocate-buffer-time (info) + (mapcar (lambda (o) + (when (plist-get o :slug) + (plist-put o :buffer + (number-to-string + (if (string-match "live" (plist-get o :q-and-a)) + emacsconf-schedule-default-buffer-minutes-for-live-q-and-a + emacsconf-schedule-default-buffer-minutes)))) + o) + info)) + +(defun emacsconf-schedule-allocate-max-time (info) + (mapcar (lambda (o) + (when (plist-get o :max-time) + (plist-put o :time (plist-get o :max-time))) + o) + info)) + +(defvar emacsconf-schedule-tweaked-allocations nil "Alist of slug . time") +(defun emacsconf-schedule-tweak-allocations (info) + (mapcar (lambda (o) + (let ((talk-times emacsconf-schedule-tweaked-allocations)) + (when (assoc (plist-get o :slug) emacsconf-schedule-tweaked-allocations) + (plist-put o :time + (number-to-string + (assoc-default (plist-get o :slug) emacsconf-schedule-tweaked-allocations))))) + o) + info)) + +(defun emacsconf-schedule-based-on-info (info) + (let (current-time end-time duration) + (mapcar + (lambda (talk) + (when (plist-get talk :fixed-time) + (setq current-time (plist-get talk :start-time))) + (when (and (plist-get talk :time) + (not (string= (plist-get talk :status) "CANCELLED"))) + (setq duration (* (string-to-number (plist-get talk :time)) 60) + end-time (time-add current-time (seconds-to-time duration))) + (plist-put talk :scheduled + (format "<%s-%s>" (format-time-string "%Y-%m-%d %a %H:%M" current-time) + (format-time-string "%H:%M" end-time))) + (plist-put talk :start-time current-time) + (plist-put talk :end-time end-time) + (setq current-time (time-add end-time (* (string-to-number (or (plist-get talk :buffer) "0")) 60)))) + talk) + info))) + +(defun emacsconf-schedule-update (&optional modify-func) + "Schedule the talks based on TIME and BUFFER. +Talks with a FIXED_TIME property are not moved." + (interactive) + (save-excursion + (org-with-wide-buffer + (let (current-time end-time duration) + (org-map-entries + (lambda () + (when (or (org-entry-get (point) "TIME") (org-entry-get (point) "FIXED_TIME")) + (let ((talk (emacsconf-get-talk-info-for-subtree))) + (when (org-entry-get (point) "FIXED_TIME") + (setq current-time (plist-get talk :start-time))) + (when (and (plist-get talk :time) + (not (string= (plist-get talk :status) "CANCELLED"))) + (setq duration (* (string-to-number (plist-get talk :time)) 60) + end-time (time-add current-time (seconds-to-time duration))) + (org-set-property "SCHEDULED" (format "%s-%s" (format-time-string "%Y-%m-%d %H:%M" current-time) + (format-time-string "%H:%M" end-time))) + (when (functionp modify-func) + (funcall modify-func)) + (setq end-time (time-add (org-get-scheduled-time (point)) (seconds-to-time duration))) + (setq current-time (time-add end-time (* (string-to-number (or (plist-get talk :buffer) "0")) 60)))))))))))) + +(provide 'emacsconf-schedule) +;;; emacsconf-schedule.el ends here -- cgit v1.2.3