1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/.emacs.d/lib/org-timeline.el Fri Aug 30 17:07:30 2024 -0400
1.3@@ -0,0 +1,660 @@
1.4+;;; org-timeline.el --- Add graphical view of agenda to agenda buffer. -*- lexical-binding: t -*-
1.5+
1.6+;; Copyright (C) 2017 Matúš Goljer
1.7+
1.8+;; Author: Matúš Goljer <matus.goljer@gmail.com>
1.9+;; Maintainer: Matúš Goljer <matus.goljer@gmail.com>
1.10+;; Version: 0.3.0
1.11+;; Created: 16th April 2017
1.12+;; Package-requires: ((dash "2.13.0") (emacs "24.3"))
1.13+;; Keywords: calendar
1.14+;; URL: https://github.com/Fuco1/org-timeline/
1.15+
1.16+;; This program is free software; you can redistribute it and/or
1.17+;; modify it under the terms of the GNU General Public License
1.18+;; as published by the Free Software Foundation; either version 3
1.19+;; of the License, or (at your option) any later version.
1.20+
1.21+;; This program is distributed in the hope that it will be useful,
1.22+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
1.23+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1.24+;; GNU General Public License for more details.
1.25+
1.26+;; You should have received a copy of the GNU General Public License
1.27+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
1.28+
1.29+;;; Commentary:
1.30+
1.31+;; Add graphical view of agenda to agenda buffer.
1.32+
1.33+;; This package adds a graphical view of the agenda after the last
1.34+;; agenda line. By default the display starts at 5 AM today and
1.35+;; goes up to 4 AM next day (this covers 24 hours).
1.36+
1.37+;; Scheduled tasks or tasks with time ranges are rendered in the
1.38+;; display with `org-timeline-block' face. Clocked entires are
1.39+;; displayed in `org-timeline-clocked' face.
1.40+
1.41+;; You can use custom color for a task by adding the property
1.42+;; `TIMELINE_FACE' with either a string which is a color name or a
1.43+;; list which specifies the face properties or a symbol which is
1.44+;; taken to be a face name.
1.45+
1.46+;;; Code:
1.47+
1.48+(require 'dash)
1.49+
1.50+(require 'org-agenda)
1.51+
1.52+(defgroup org-timeline ()
1.53+ "Graphical view of agenda in agenda buffer."
1.54+ :group 'org
1.55+ :prefix "org-timeline-")
1.56+
1.57+(defgroup org-timeline-faces ()
1.58+ "Faces for org-timeline."
1.59+ :group 'org-timeline)
1.60+
1.61+(defcustom org-timeline-default-duration 60
1.62+ "Default event duration in minutes"
1.63+ :type 'integer
1.64+ :group 'org-timeline)
1.65+
1.66+(defcustom org-timeline-prepend nil
1.67+ "Option to prepend the timeline to the agenda."
1.68+ :type 'boolean
1.69+ :group 'org-timeline)
1.70+
1.71+(defcustom org-timeline-show-clocked t
1.72+ "Option to show or hide clocked items."
1.73+ :type 'boolean
1.74+ :group 'org-timeline)
1.75+
1.76+(defcustom org-timeline-dedicated-clocked-line t
1.77+ "Option to show clocked items in a dedicated line with 'group-name' '$'."
1.78+ :type 'boolean
1.79+ :group 'org-timeline)
1.80+
1.81+(defcustom org-timeline-overlap-in-new-line nil
1.82+ "Option to create new lines for blocks that would otherwise overlap."
1.83+ :type 'boolean
1.84+ :group 'org-timeline)
1.85+
1.86+(defcustom org-timeline-emphasize-next-block nil
1.87+ "Option to apply the face `org-timeline-next-block' to the next block happening today."
1.88+ :type 'boolean
1.89+ :group 'org-timeline)
1.90+
1.91+(defcustom org-timeline-show-text-in-blocks nil
1.92+ "Option to show the text of the event in the block.
1.93+
1.94+If the item has a property `TIMELINE_TEXT', use this as a title.
1.95+Otherwise, the title will be the item's headline, stripped of its todo state."
1.96+ :type 'boolean
1.97+ :group 'org-timeline)
1.98+
1.99+(defcustom org-timeline-beginning-of-day-hour 5
1.100+ "When the timeline begins.
1.101+
1.102+Due to the way 'org-agenda' works, if you set this to any other value than 0
1.103+\(e.g. 5), then events that happen after midnight will not appear (even though
1.104+the timeline shows the slots).
1.105+If you view the agenda in week mode, those events will not appear in any of
1.106+the week's day.
1.107+
1.108+The workaround for this in day view is to use `org-timeline-keep-elapsed' that
1.109+will make the timeline show you a 24h cycle. See this variable's documentation
1.110+for more information."
1.111+ :type 'integer
1.112+ :group 'org-timeline)
1.113+
1.114+(defcustom org-timeline-keep-elapsed -1
1.115+ "In day view, for today, keep only this number of fully elapsed hours.
1.116+
1.117+For negative values, do not hide elapsed hours.
1.118+
1.119+This can be used to see a rolling 24h cycle in the timeline.
1.120+In order to do that, set `org-timeline-beginning-of-day-hour' to 0, and set
1.121+`org-timeline-keep-elapsed' to any positive number.
1.122+Set `org-agenda-span' to 2, and open the day agenda view for today.
1.123+You will see a rolling 24h cycle, starting `org-timeline-keep-elapsed' hours ago."
1.124+ :type 'integer
1.125+ :group 'org-timeline)
1.126+
1.127+(defcustom org-timeline-insert-before-text "\u275A"
1.128+ "String inserted before the block's text.
1.129+
1.130+It makes consecutive blocks distinct.
1.131+
1.132+The default value '\u275A' is a heavy vertical bar ❚."
1.133+ :type 'string
1.134+ :group 'org-timeline)
1.135+
1.136+(defvar org-timeline-first-line-in-agenda-buffer 0
1.137+ "Line number of the first line of the timeline in the agenda buffer.")
1.138+
1.139+(defvar org-timeline-height 0
1.140+ "Final height of the timeline.")
1.141+
1.142+(defvar org-timeline-current-info nil
1.143+ "Current displayed info. Used to fix flickering of info.")
1.144+
1.145+(defvar org-timeline-slotline (concat (mapconcat 'not (number-sequence 0 24) "| ") "|")
1.146+ "The undecorated slotline string.")
1.147+
1.148+(defvar org-timeline-next-task-today nil
1.149+ "The next task happening today.")
1.150+
1.151+(cl-defstruct org-timeline-task
1.152+ id
1.153+ beg ; in minutes
1.154+ end ; in minutes
1.155+ offset-beg ; in points
1.156+ offset-end ; in points
1.157+ info ; copy of the agenda buffer's line
1.158+ line-in-agenda-buffer
1.159+ face
1.160+ day ; absolute, see `calendar-absolute-from-gregorian'
1.161+ type ; "scheduled", "clocked" ...
1.162+ text
1.163+ group-name
1.164+ do-not-overlap-p ; make sure this block doesn't overlap with any other
1.165+ )
1.166+
1.167+
1.168+(defface org-timeline-block
1.169+ '((t (:inherit secondary-selection)))
1.170+ "Face used for printing blocks with time range information.
1.171+
1.172+These are blocks that are scheduled for specific time range or
1.173+have an active timestamp with a range."
1.174+ :group 'org-timeline-faces)
1.175+
1.176+(defface org-timeline-elapsed
1.177+ '((t (:inherit region)))
1.178+ "Face used for highlighting clocked items."
1.179+ :group 'org-timeline-faces)
1.180+
1.181+(defface org-timeline-clocked
1.182+ '((t (:inherit highlight)))
1.183+ "Face used for printing clocked blocks.
1.184+
1.185+Clocked blocks appear in the agenda when `org-agenda-log-mode' is
1.186+activated."
1.187+ :group 'org-timeline-faces)
1.188+
1.189+(defface org-timeline-overlap
1.190+ '((t (:background "dark red")))
1.191+ "Face used for printing overlapping blocks."
1.192+ :group 'org-timeline-faces)
1.193+
1.194+(defface org-timeline-next-block
1.195+ '((t (:background "dark olive green")))
1.196+ "Face used for printing the next block happening today.
1.197+
1.198+Used when `org-timeline-emphasize-next-block' is non-nil."
1.199+ :group 'org-timeline-faces)
1.200+
1.201+
1.202+(defmacro org-timeline-with-each-line (&rest body)
1.203+ "Execute BODY on each line in buffer."
1.204+ (declare (indent 0)
1.205+ (debug (body)))
1.206+ `(save-excursion
1.207+ (goto-char (point-min))
1.208+ ,@body
1.209+ (while (= (forward-line) 0)
1.210+ ,@body)))
1.211+
1.212+(defun org-timeline--get-face (type)
1.213+ "Get the face with which to draw the current block, according to TYPE."
1.214+ (--if-let (org-entry-get (org-get-at-bol 'org-marker) "TIMELINE_FACE" t)
1.215+ (let ((read-face (car (read-from-string it))))
1.216+ (if (stringp read-face)
1.217+ (list :background read-face)
1.218+ read-face))
1.219+ (if (string= type "clock")
1.220+ (list 'org-timeline-clocked)
1.221+ (list 'org-timeline-block))))
1.222+
1.223+(defun org-timeline--get-block-text ()
1.224+ "Get the text to print inside the current block."
1.225+ (let ((item-marker (org-get-at-bol 'org-marker)))
1.226+ (--if-let (org-entry-get item-marker "TIMELINE_TEXT" t)
1.227+ it
1.228+ (with-current-buffer (marker-buffer item-marker)
1.229+ (save-excursion
1.230+ (goto-char item-marker)
1.231+ (outline-previous-heading)
1.232+ (org-element-property :raw-value (org-element-context)))))))
1.233+
1.234+(defun org-timeline--get-group-name (type)
1.235+ "Get the current block's 'group-name' according to TYPE.
1.236+
1.237+The first three chars will be printed at the beginning of the block's line."
1.238+ (--if-let (org-entry-get (org-get-at-bol 'org-marker) "TIMELINE_GROUP" t)
1.239+ (if (< (length it) 3)
1.240+ (concat (substring " " 0 (- 3 (length it))) it)
1.241+ (substring it 0 3))
1.242+ (if (and (string= type "clock") org-timeline-dedicated-clocked-line)
1.243+ " $"
1.244+ " ")))
1.245+
1.246+(defun org-timeline--get-do-not-overlap (type)
1.247+ "Whether the current block is allowed to overlap in the timeline according to TYPE."
1.248+ (--if-let (org-entry-get (org-get-at-bol 'org-marker) "TIMELINE_DO_NOT_OVERLAP" t)
1.249+ it
1.250+ (if (and (not (string= type "clock")) org-timeline-overlap-in-new-line)
1.251+ t
1.252+ nil)))
1.253+
1.254+(defun org-timeline--overlapping-at-point (task)
1.255+ "List of points where an already drawn blocks would overlap with TASK."
1.256+ (save-excursion
1.257+ (let (overlap-points)
1.258+ (goto-char (+ (line-beginning-position) (org-timeline-task-offset-beg task)))
1.259+ (while (and (<= (point) (+ (line-beginning-position) (org-timeline-task-offset-end task)))
1.260+ (< (point) (point-max)))
1.261+ (when (get-text-property (point) 'org-timeline-occupied)
1.262+ (push (point) overlap-points))
1.263+ (forward-char))
1.264+ overlap-points)))
1.265+
1.266+(defun org-timeline--new-overlap-line-required-at-point-p (task)
1.267+ "Whether a new overlap line needs to be created to insert TASK."
1.268+ (let* ((overlapping (org-timeline--overlapping-at-point task))
1.269+ (overlapping-blocks-that-do-not-overlap
1.270+ (delq nil (mapcar (lambda (point) (get-text-property point 'org-timeline-do-not-overlap)) overlapping))))
1.271+ (and (not (eq overlapping nil))
1.272+ (or (org-timeline-task-do-not-overlap-p task)
1.273+ (not (eq overlapping-blocks-that-do-not-overlap nil))))))
1.274+
1.275+(defun org-timeline--add-elapsed-face (string)
1.276+ "Add `org-timeline-elapsed' to STRING's elapsed portion.
1.277+
1.278+Return new copy of STRING."
1.279+ (let* ((string-copy (copy-sequence string))
1.280+ (start-offset (* org-timeline-beginning-of-day-hour 60))
1.281+ (current-time (+ (* 60 (string-to-number (format-time-string "%H")))
1.282+ (string-to-number (format-time-string "%M"))))
1.283+ (current-offset (/ (- current-time start-offset) 10)))
1.284+ (when (< 0 current-offset)
1.285+ (put-text-property 0 (+ 1 current-offset) 'font-lock-face (list 'org-timeline-elapsed) string-copy))
1.286+ string-copy))
1.287+
1.288+(defun org-timeline--kill-info ()
1.289+ "Kill the info line."
1.290+ (save-excursion
1.291+ (goto-line org-timeline-first-line-in-agenda-buffer)
1.292+ (while (and (not (get-text-property (point) 'org-timeline-info-line))
1.293+ (eq (forward-line) 0)))
1.294+ (unless (eq (point) (point-max)) ; info line not found
1.295+ (let ((inhibit-read-only t))
1.296+ (kill-whole-line)))))
1.297+
1.298+(defun org-timeline--decorate-info (info)
1.299+ "Make INFO string clickable."
1.300+ (let ((info-keymap (make-sparse-keymap)))
1.301+ (define-key info-keymap [mouse-1] 'org-agenda-goto)
1.302+ (define-key info-keymap [mouse-2] 'org-find-file-at-mouse)
1.303+ (propertize info 'keymap info-keymap
1.304+ 'help-echo "mouse-1 jump to org file"
1.305+ 'org-timeline-info-line t)))
1.306+
1.307+(defun org-timeline--draw-new-info (win info)
1.308+ "Displays INFO about a hovered block.
1.309+
1.310+WIN is the agenda buffer's window."
1.311+ (unless (eq info org-timeline-current-info) ; prevents flickering
1.312+ (setq org-timeline-current-info info)
1.313+ (save-window-excursion
1.314+ (save-excursion
1.315+ (select-window win) ; because one can hover blocks without being in the agenda window.
1.316+ (org-timeline--kill-info)
1.317+ (goto-line org-timeline-first-line-in-agenda-buffer)
1.318+ (forward-line (- org-timeline-height 2))
1.319+ (let ((inhibit-read-only t))
1.320+ (insert (org-timeline--decorate-info info) "\n"))))))
1.321+
1.322+(defun org-timeline--move-to-task-in-agenda-buffer ()
1.323+ "Move to a block's correponding task in the agenda buffer."
1.324+ (interactive)
1.325+ (let ((line (get-text-property (point) 'org-timeline-task-line)))
1.326+ (when org-timeline-prepend
1.327+ (setq line (+ line org-timeline-height -1)))
1.328+ (goto-line line)
1.329+ (search-forward (get-text-property (point) 'time)))) ; makes point more visible to user.
1.330+
1.331+(defun org-timeline--list-tasks ()
1.332+ "Build the list of tasks to display."
1.333+ (let* ((tasks nil)
1.334+ (id 0)
1.335+ (start-offset (* org-timeline-beginning-of-day-hour 60))
1.336+ (current-time (+ (* 60 (string-to-number (format-time-string "%H")))
1.337+ (string-to-number (format-time-string "%M")))))
1.338+ (org-timeline-with-each-line
1.339+ (-when-let* ((time-of-day (org-get-at-bol 'time-of-day))
1.340+ (marker (org-get-at-bol 'org-marker))
1.341+ (type (org-get-at-bol 'type))
1.342+ (duration (or (org-get-at-bol 'duration)
1.343+ org-timeline-default-duration)))
1.344+ (when (member type (list "past-scheduled" "scheduled" "clock" "timestamp"))
1.345+ (when (and (numberp duration)
1.346+ (< duration 0))
1.347+ (cl-incf duration 1440))
1.348+ (let* ((hour (/ time-of-day 100))
1.349+ (minute (mod time-of-day 100))
1.350+ (beg (+ (* hour 60) minute))
1.351+ (end (round (+ beg duration))))
1.352+ (setq beg (max beg start-offset))
1.353+ (setq end (min end (+ start-offset (* 24 60))))
1.354+ (setq duration (- end beg))
1.355+ (when (eq end (* 24 60)) (cl-incf end -1)) ; FIXME fixes a bug that shouldn't happen (crash when events end at midnight).
1.356+ (when (and (>= end start-offset)
1.357+ (<= beg (+ start-offset (* 24 60)))
1.358+ (or org-timeline-show-clocked
1.359+ (not (string= type "clock"))))
1.360+ (push (make-org-timeline-task
1.361+ :id id
1.362+ :beg beg
1.363+ :end end
1.364+ :offset-beg (+ 5 (- (/ beg 10) (* 6 org-timeline-beginning-of-day-hour)))
1.365+ :offset-end (+ 5 (- (/ end 10) (* 6 org-timeline-beginning-of-day-hour)))
1.366+ :info (buffer-substring (line-beginning-position) (line-end-position))
1.367+ :line-in-agenda-buffer (line-number-at-pos)
1.368+ :face (org-timeline--get-face type)
1.369+ :day (org-get-at-bol 'day)
1.370+ :type type
1.371+ :text (org-timeline--get-block-text)
1.372+ :group-name (org-timeline--get-group-name type)
1.373+ :do-not-overlap-p (org-timeline--get-do-not-overlap type)
1.374+ )
1.375+ tasks)
1.376+ (cl-incf id))))))
1.377+ ;; find the next task
1.378+ (setq org-timeline-next-task nil)
1.379+ (dolist (task tasks)
1.380+ (let* ((beg (org-timeline-task-beg task))
1.381+ (end (org-timeline-task-end task))
1.382+ (today (calendar-absolute-from-gregorian (calendar-current-date)))
1.383+ (is-today (eq today (org-timeline-task-day task)))
1.384+ (is-now (and (<= beg current-time)
1.385+ (>= end current-time)))
1.386+ (is-after (> beg current-time))
1.387+ (is-closer-to-now (and is-after
1.388+ (or (eq org-timeline-next-task nil)
1.389+ (< beg (org-timeline-task-beg org-timeline-next-task))))))
1.390+ (when (and is-today (or is-now is-closer-to-now))
1.391+ (setq org-timeline-next-task task))))
1.392+ ;; change the next task's face
1.393+ (when (and org-timeline-emphasize-next-block
1.394+ org-timeline-next-task)
1.395+ (dolist (task tasks)
1.396+ (when (eq (org-timeline-task-id task) (org-timeline-task-id org-timeline-next-task))
1.397+ (setf (org-timeline-task-face task) (list 'org-timeline-next-block)))))
1.398+ (nreverse tasks)))
1.399+
1.400+(defun org-timeline--goto-block-position (task)
1.401+ "Go to TASK's block's line and position cursor in line...
1.402+
1.403+Return t if this task will overlap another one when inserted."
1.404+ (let* ((slotline (org-timeline--add-elapsed-face org-timeline-slotline))
1.405+ (offset-beg (org-timeline-task-offset-beg task))
1.406+ (offset-end (org-timeline-task-offset-end task))
1.407+ (day (org-timeline-task-day task))
1.408+ (group-name (org-timeline-task-group-name task))
1.409+ (do-not-overlap (org-timeline-task-do-not-overlap-p task)))
1.410+ (goto-char 1)
1.411+ (while (and (not (eq (get-text-property (point) 'org-timeline-day) day))
1.412+ (not (eq (forward-line) 1))))
1.413+ (unless (eq (get-text-property (point) 'org-timeline-day) day)
1.414+ (insert (concat "\n" ; creating the necessary lines, up to the current task's day
1.415+ (mapconcat (lambda (line-day)
1.416+ (propertize (concat (calendar-day-name (mod line-day 7) t t) ; found in https://github.com/deopurkar/org-timeline
1.417+ " "
1.418+ slotline)
1.419+ 'org-timeline-day line-day 'org-timeline-group-name " "))
1.420+ (if-let ((last-day (get-text-property (line-beginning-position) 'org-timeline-day)))
1.421+ (number-sequence (+ 1 last-day) day)
1.422+ (list day))
1.423+ "\n"))))
1.424+ ;; cursor is now at beginning of the task's day's first line
1.425+ (while (and (not (string= (get-text-property (point) 'org-timeline-group-name) group-name))
1.426+ (eq (get-text-property (point) 'org-timeline-day) day))
1.427+ (forward-line))
1.428+ (unless (string= (-if-let (group-here (get-text-property (point) 'org-timeline-group-name)) group-here " ") group-name)
1.429+ (when (not (eq (line-end-position) (point-max))) (forward-line -1))
1.430+ (goto-char (line-end-position))
1.431+ (insert "\n"
1.432+ (propertize (concat group-name " " slotline) 'org-timeline-day day 'org-timeline-group-name group-name)))
1.433+ ;; cursor is now at beginning of the task's group's first line
1.434+ (let ((new-overlap-line-required-flag (org-timeline--new-overlap-line-required-at-point-p task)))
1.435+ (while (and (org-timeline--new-overlap-line-required-at-point-p task)
1.436+ (eq (get-text-property (point) 'org-timeline-day) day)
1.437+ (eq (get-text-property (point) 'org-timeline-group-name) group-name)
1.438+ (not (eq (line-end-position) (point-max))))
1.439+ (setq new-overlap-line-required-flag t)
1.440+ (forward-line))
1.441+ (let ((decorated-slotline (propertize (concat " " " " slotline)
1.442+ 'org-timeline-day day
1.443+ 'org-timeline-group-name group-name)))
1.444+ (when new-overlap-line-required-flag
1.445+ (end-of-line)
1.446+ (insert "\n" decorated-slotline))))
1.447+ ;; cursor is now placed on the right line, at the right position.
1.448+ (goto-char (+ (line-beginning-position) offset-beg))))
1.449+
1.450+(defun org-timeline--make-basic-block (task)
1.451+ "Make TASK's block and return it as a propertized string.
1.452+
1.453+This does not take the block's context (e.g. overlap) into account."
1.454+ (let* ((blank-block (mapconcat 'not (number-sequence 1 24) " "))
1.455+ (id (org-timeline-task-id task))
1.456+ (offset-beg (org-timeline-task-offset-beg task))
1.457+ (offset-end (org-timeline-task-offset-end task))
1.458+ (info (org-timeline-task-info task))
1.459+ (face (org-timeline-task-face task))
1.460+ (line (org-timeline-task-line-in-agenda-buffer task))
1.461+ (group-name (org-timeline-task-group-name task))
1.462+ (do-not-overlap (org-timeline-task-do-not-overlap-p task))
1.463+ (move-to-task-map '(keymap mouse-1 . org-timeline--move-to-task-in-agenda-buffer))
1.464+ (block-length (- offset-end offset-beg))
1.465+ (props (list 'font-lock-face face
1.466+ 'org-timeline-occupied t
1.467+ 'org-timeline-do-not-overlap do-not-overlap
1.468+ 'org-timeline-task-id id
1.469+ 'org-timeline-group-name group-name
1.470+ 'mouse-face '(:highlight t :box t)
1.471+ 'keymap move-to-task-map
1.472+ 'task-info info
1.473+ 'help-echo (lambda (w obj pos) ; called on block hover
1.474+ (org-timeline--draw-new-info w info)
1.475+ info)
1.476+ 'org-timeline-task-line line))
1.477+ (title (concat org-timeline-insert-before-text
1.478+ (org-timeline-task-text task)
1.479+ blank-block))
1.480+ (block (if org-timeline-show-text-in-blocks
1.481+ title
1.482+ blank-block)))
1.483+ (add-text-properties 0 block-length props block)
1.484+ (substring block 0 block-length)))
1.485+
1.486+(defun org-timeline--make-and-insert-block (task)
1.487+ "Insert the TASK's block at the right position in the timeline.
1.488+
1.489+Changes the block's face according to context."
1.490+ (org-timeline--goto-block-position task)
1.491+ (let ((overlapp (not (eq (org-timeline--overlapping-at-point task) nil)))
1.492+ (is-next (if (not (eq org-timeline-next-task nil))
1.493+ (eq (org-timeline-task-id task) (org-timeline-task-id org-timeline-next-task))
1.494+ nil))
1.495+ (block (org-timeline--make-basic-block task)))
1.496+ (when overlapp (setq block (propertize block 'font-lock-face (list 'org-timeline-overlap))))
1.497+ (when is-next (setq block (propertize block 'font-lock-face (list 'org-timeline-next-block))))
1.498+ (unless (get-text-property (- (point) 1) 'org-timeline-overline)
1.499+ (add-text-properties 0 (length block)
1.500+ (list 'org-timeline-overline t
1.501+ 'font-lock-face (append (get-text-property 0 'font-lock-face block) '((:overline t)))
1.502+ 'mouse-face (append (get-text-property 0 'mouse-face block) '((:overline t))))
1.503+ block))
1.504+ (setq block (substring block 0 (min (length block) (- (line-end-position) (point)))))
1.505+ (delete-char (length block))
1.506+ (insert block)))
1.507+
1.508+(defun org-timeline--merge-for-24h-cycle ()
1.509+ "Kill elapsed columns in day's line according to `org-timeline-keep-elapsed'.
1.510+
1.511+Move tomorrow's line to the right of today's line, to show a complete 24h cycle.
1.512+See the documentation of `org-timeline-keep-elapsed' for more information."
1.513+ ;; FIXME: quite hacky. This should probably be done directly when making the tasks list,
1.514+ ;; maybe by making all those events happen the same fake '0' day and change the offsets accordingly.
1.515+ (let* ((today (calendar-absolute-from-gregorian (calendar-current-date)))
1.516+ (current-hour (string-to-number (format-time-string "%H")))
1.517+ (current-time (+ (* 60 current-hour)
1.518+ (string-to-number (format-time-string "%M"))))
1.519+ (elapsed-hours (- (floor (/ current-time 60)) org-timeline-beginning-of-day-hour))
1.520+ (number-of-columns-tomorrow (max 0 (- elapsed-hours org-timeline-keep-elapsed)))
1.521+ (number-of-columns-today (- 24 number-of-columns-tomorrow))
1.522+ (hourline-piece (delete-and-extract-region 6 (+ 6 (* 6 number-of-columns-tomorrow))))
1.523+ (today-line-pieces nil)
1.524+ (tomorrow-line-pieces nil)
1.525+ (cycle-offset (* 6 (- (max org-timeline-beginning-of-day-hour (- current-hour org-timeline-keep-elapsed)) org-timeline-beginning-of-day-hour)))
1.526+ (blank-today-line-piece (concat " " (substring (org-timeline--add-elapsed-face org-timeline-slotline)
1.527+ cycle-offset
1.528+ (+ cycle-offset (* 6 number-of-columns-today)))
1.529+ "|"))
1.530+ (blank-tomorrow-line-piece (concat " " (substring org-timeline-slotline 0 (* 6 number-of-columns-tomorrow)))))
1.531+ (goto-char 1)
1.532+ (goto-char (line-end-position))
1.533+ (insert hourline-piece)
1.534+ ;; build (today|tomorrow)-line-pieces lists.
1.535+ (while (not (eq (line-end-position) (point-max)))
1.536+ (forward-line)
1.537+ (let* ((lbeg (line-beginning-position))
1.538+ (lend (line-end-position))
1.539+ (today-portion (concat (buffer-substring lbeg (+ lbeg 4))
1.540+ (buffer-substring (- lend (* 6 number-of-columns-today) 1) lend)))
1.541+ (tomorrow-portion (buffer-substring (+ 5 lbeg) (+ 5 lbeg (* 6 number-of-columns-tomorrow)))))
1.542+ (when (eq (get-text-property lbeg 'org-timeline-day) today)
1.543+ (setq today-line-pieces (append today-line-pieces (list today-portion))))
1.544+ (when (eq (get-text-property lbeg 'org-timeline-day) (+ today 1))
1.545+ (setq tomorrow-line-pieces (append tomorrow-line-pieces (list tomorrow-portion))))))
1.546+ ;; handle groups and balance lines
1.547+ ;; FIXME: not efficient, doesn't jump once group done
1.548+ ;; (print "today")
1.549+ ;; (dolist (line today-line-pieces) (print line))
1.550+ ;; (print "tomorrow")
1.551+ ;; (dolist (line tomorrow-line-pieces) (print line))
1.552+ (let (groups-handled)
1.553+ (dotimes (i (length today-line-pieces))
1.554+ (let* ((group-handled (get-text-property 0 'org-timeline-group-name (seq-elt today-line-pieces i)))
1.555+ (group-handled-p (lambda (piece) (string= (get-text-property 1 'org-timeline-group-name piece) group-handled)))
1.556+ (prev-pieces-today (seq-take today-line-pieces i))
1.557+ (next-pieces-today (seq-drop today-line-pieces i))
1.558+ (same-group-pieces-today (seq-filter group-handled-p next-pieces-today))
1.559+ (rest-of-pieces-today (seq-remove group-handled-p next-pieces-today))
1.560+ (prev-pieces-tomorrow (seq-take tomorrow-line-pieces i))
1.561+ (next-pieces-tomorrow (seq-drop tomorrow-line-pieces i))
1.562+ (same-group-pieces-tomorrow (seq-filter group-handled-p next-pieces-tomorrow))
1.563+ (rest-of-pieces-tomorrow (seq-remove group-handled-p next-pieces-tomorrow)))
1.564+ ;; balance groups
1.565+ (let* ((line-diff (- (length same-group-pieces-tomorrow) (length same-group-pieces-today)))
1.566+ (number-of-blank-lines-to-add-today (max 0 line-diff))
1.567+ (number-of-blank-lines-to-add-tomorrow (max 0 (- 0 line-diff))))
1.568+ (dotimes (n number-of-blank-lines-to-add-today)
1.569+ (setq same-group-pieces-today (append same-group-pieces-today (list blank-today-line-piece))))
1.570+ (dotimes (n number-of-blank-lines-to-add-tomorrow)
1.571+ (setq same-group-pieces-tomorrow (append same-group-pieces-tomorrow (list blank-tomorrow-line-piece)))))
1.572+ ;; rebuild the pieces lists
1.573+ (setq today-line-pieces (append prev-pieces-today same-group-pieces-today rest-of-pieces-today))
1.574+ (setq tomorrow-line-pieces (append prev-pieces-tomorrow same-group-pieces-tomorrow rest-of-pieces-tomorrow))))
1.575+ (let* ((unhandled-groups-tomorrow (seq-drop tomorrow-line-pieces (length today-line-pieces))))
1.576+ (dolist (piece unhandled-groups-tomorrow)
1.577+ (if (member (get-text-property 0 'org-timeline-group-name piece) groups-handled)
1.578+ (setq today-line-pieces (append today-line-pieces (list blank-today-line-piece)))
1.579+ (setq today-line-pieces (append today-line-pieces (list (concat (get-text-property 0 'org-timeline-group-name piece)
1.580+ (substring blank-today-line-piece 3 nil))))))
1.581+ (push (get-text-property 0 'org-timeline-group-name piece) groups-handled))))
1.582+ ;; (print "today")
1.583+ ;; (dolist (line today-line-pieces) (print line))
1.584+ ;; (print "tomorrow")
1.585+ ;; (dolist (line tomorrow-line-pieces) (print line))
1.586+ ;; insert them
1.587+ (goto-char 1)
1.588+ (let ((hourline (buffer-substring 1 (line-end-position))))
1.589+ (delete-region (point-min) (point-max))
1.590+ (insert hourline))
1.591+ (dolist (piece today-line-pieces)
1.592+ (insert "\n" piece))
1.593+ (goto-line 2)
1.594+ (dolist (piece tomorrow-line-pieces)
1.595+ (goto-char (line-end-position))
1.596+ (insert piece)
1.597+ (forward-line))
1.598+ ;; remove elapsed face from tomorrow lines
1.599+ (goto-char 1)
1.600+ (put-text-property (+ 5 (* 6 number-of-columns-today)) (line-end-position) 'face nil)
1.601+ (while (and (eq (forward-line) 0)
1.602+ (not (eq (point) (point-max))))
1.603+ (forward-char (+ 5 (* 6 number-of-columns-today)))
1.604+ (dotimes (i (- (line-end-position) (point)))
1.605+ (when (not (get-text-property (point) 'org-timeline-occupied))
1.606+ (put-text-property (point) (+ (point) 1) 'face nil))
1.607+ (forward-char)))))
1.608+
1.609+;; Some ideas for the the generation of the timeline were inspired by the
1.610+;; forked repo: https://github.com/deopurkar/org-timeline.
1.611+(defun org-timeline--generate-timeline ()
1.612+ "Generate the timeline string that will represent current agenda view."
1.613+ (let* ((hourline (concat " "
1.614+ (org-timeline--add-elapsed-face
1.615+ (concat "|"
1.616+ (mapconcat (lambda (x) (format "%02d:00" (mod x 24)))
1.617+ (number-sequence org-timeline-beginning-of-day-hour (+ org-timeline-beginning-of-day-hour 23))
1.618+ "|")
1.619+ "|"))))
1.620+ (tasks (org-timeline--list-tasks))
1.621+ (today (calendar-absolute-from-gregorian (calendar-current-date)))
1.622+ (today-onlyp (eq 0 (length (delq nil (mapcar (lambda (task) (if (eq (org-timeline-task-day task) today) nil task)) tasks)))))
1.623+ (today-or-tomorrow-only-p (eq 0 (length (delq nil (mapcar (lambda (task) (if (member (org-timeline-task-day task) `(,today ,(+ today 1))) nil task)) tasks))))))
1.624+ (with-temp-buffer
1.625+ (insert hourline)
1.626+ (dolist (task tasks)
1.627+ ;; (print (buffer-substring (point-min) (point-max)))
1.628+ (org-timeline--make-and-insert-block task))
1.629+ ;; (print (buffer-substring (point-min) (point-max)))
1.630+ (when (and (>= org-timeline-keep-elapsed 0)
1.631+ today-or-tomorrow-only-p
1.632+ (> (length tasks) 0))
1.633+ (org-timeline--merge-for-24h-cycle))
1.634+ ;; display the next block's info
1.635+ (goto-char (point-max))
1.636+ (unless (eq (length tasks) 0)
1.637+ (insert "\n"
1.638+ (if (eq org-timeline-next-task nil)
1.639+ (propertize " no incoming event" 'org-timeline-info-line t)
1.640+ (org-timeline--decorate-info (org-timeline-task-info org-timeline-next-task)))))
1.641+ (buffer-string))))
1.642+
1.643+;;;###autoload
1.644+(defun org-timeline-insert-timeline ()
1.645+ "Insert graphical timeline into agenda buffer."
1.646+ (unless (buffer-narrowed-p)
1.647+ (goto-char (point-min))
1.648+ (unless org-timeline-prepend
1.649+ (while (and (eq (get-text-property (line-beginning-position) 'org-agenda-type) 'agenda)
1.650+ (not (eobp)))
1.651+ (forward-line)))
1.652+ (forward-line)
1.653+ (let ((inhibit-read-only t))
1.654+ (setq org-timeline-first-line-in-agenda-buffer (line-number-at-pos))
1.655+ (insert (propertize (concat (make-string (window-width) ?─)) 'face 'org-time-grid) "\n")
1.656+ (insert (org-timeline--generate-timeline))
1.657+ (insert (propertize (concat "\n" (make-string (window-width) ?─)) 'face 'org-time-grid 'org-timeline-end t) "\n")
1.658+ (setq org-timeline-height (- (line-number-at-pos) org-timeline-first-line-in-agenda-buffer)))
1.659+ ;; enable `font-lock-mode' in agenda view to display the "chart"
1.660+ (font-lock-mode)))
1.661+
1.662+(provide 'org-timeline)
1.663+;;; org-timeline.el ends here
