Download
(require 'cal-desk-calendar)
(define-key calendar-mode-map "w" 'week-graph-view-diary-entries)
(defcustom week-graph-work-week nil
"*If non-nil, only the 5 workdays are displayed (instead of 7)."
:type 'boolean)
(defcustom week-graph-dynamic-width t
"*If non-nil, the graph fully fills the window.
If nil, `weekly-graph-day-width' is used."
:type 'boolean)
(eval-and-compile
(cond
((fboundp 'replace-in-string)
(defalias 'weekly-view-replace-in-string 'replace-in-string))
((fboundp 'replace-regexp-in-string)
(defun replace-in-string (string regexp newtext &optional literal)
(replace-regexp-in-string regexp newtext string nil literal)))
(t
(defun replace-in-string (string regexp newtext &optional literal)
(let ((start 0) tail)
(while (string-match regexp string start)
(setq tail (- (length string) (match-end 0)))
(setq string (replace-match newtext nil literal string))
(setq start (- (length string) tail))))
string))))
(defun week-graph-view-diary-entries ()
"Prepare and display a buffer with diary entries of the current week.
See `view-diary-entries' for more."
(interactive)
(save-excursion
(calendar-cursor-to-nearest-date)
(let ((diary-display-hook 'fancy-diary-display-week-graph)
(day (calendar-day-of-week (calendar-cursor-to-date))))
(unless (= day calendar-week-start-day)
(calendar-beginning-of-week 1))
(view-diary-entries 7))))
(defun week-graph-convert-time (time)
(let ((hour (/ time 100))
(mins (% time 100)))
(+ (* hour 3600) (* mins 60))))
(defun weekly-graph-display-time-format (time)
(format "%2d:%02d" (/ cur 3600) (% (/ cur 60) 60)))
(defun week-graph-day-titles (&optional width)
"Return of a vector whose members are the day names. If WIDTH is
non-nil and non-zero, truncate the day name to that width."
(mapcar
(lambda (s)
(let* ((extra (- width (length s)))
(pre (/ extra 2))
(post (- extra pre)))
(cond
((= extra 0) s)
((> extra 0) (format (format "%%%ds%%%ds" (- width post) post) s ""))
(t (substring s 0 width)))))
calendar-day-name-array))
(defvar weekly-graph-day-width 10
"Width of the each day in the bar graph")
(defvar weekly-graph-day-start 800
"Time to start each day's view in military style integers (i.e. \"8:00am\" is 800)")
(defvar weekly-graph-day-end 1800
"Time to end each day's view in military style integers (i.e. \"8:00am\" is 800)")
(defvar weekly-graph-increment 30
"Increment in minutes for each row on the weekly graph of diary entries")
(defvar weekly-graph-use-hash-marks t
"If non-nill use hash marks '\#' to graph events rather than pertinent event text")
(defvar weekly-graph-default-event-length 60
"Length of events that don't specify an end time in minutes.")
(defvar diary-time-regexp-list
`(
"^[ ]*\\([0-9]?[0-9]\\)-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\|[^ap]\\)"
"^[ ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
"^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>"
"^[ ]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>"
,diary-schedule-sunrise-sunset-pattern
,diary-schedule-lunar-phase-pattern
,diary-schedule-equinox-solstice-pattern
,diary-schedule-morning-pattern
,diary-schedule-workday-pattern
,diary-schedule-all-day-pattern))
(defun fancy-diary-display-week-graph ()
"Given a set of appointment DATA, draw a weekly bar graph of it.
DATA must be a vector of seven elements (for each day of the week),
where each element is a list of cons cells representing the beginning
and ending seconds of each appointment within the day, where midnight
begins at 0 seconds. For example, an appointment for one hour on
Monday at 10am would look like:
[nil ((36000 . 39600)) nil nil nil nil nil]"
(save-excursion
(message "Preparing diary...")
(set-buffer (get-buffer-create fancy-diary-buffer))
(setq buffer-read-only nil)
(make-local-variable 'mode-line-format)
(calendar-set-mode-line " Desk Calendar ")
(erase-buffer)
(let* ((num-days (if week-graph-work-week 5 7))
(day-width (if week-graph-dynamic-width
(/ (- (window-width) 7 num-days) num-days)
weekly-graph-day-width))
(begin (week-graph-convert-time weekly-graph-day-start))
(end (week-graph-convert-time weekly-graph-day-end))
(incr (* weekly-graph-increment 60))
(cur begin)
(day-titles (vconcat (week-graph-day-titles day-width)))
(data (make-vector 7 nil)))
(dolist (elem diary-entries-list)
(let* ((dow (calendar-day-of-week (car elem)))
(day-of-week-ref (aref data dow))
(entry-times (diary-entry-times (cadr elem)))
(entry-text (cadr elem))
(beginning-time (week-graph-convert-time (car entry-times)))
(ending-time (week-graph-convert-time (cadr entry-times)))
entry-alist)
(if (= beginning-time ending-time)
(setq ending-time (+ ending-time (* weekly-graph-default-event-length 60))))
(mapcar (lambda (regexp) (setq entry-text (replace-in-string entry-text regexp "")))
diary-time-regexp-list)
(setq entry-text (replace-in-string entry-text "^[ ]+" ""))
(setq entry-text (replace-in-string entry-text "[ \t\n]+" " "))
(setq entry-text (replace-in-string entry-text "[ \t]+$" ""))
(setq entry-plist `(:beginning ,beginning-time
:ending ,ending-time
:text ,entry-text
:marker ,(nth 3 elem)))
(unless (= (car entry-times) -9999)
(if day-of-week-ref
(nconc day-of-week-ref (list entry-plist))
(aset data dow (list entry-plist))))))
(dotimes (j 7)
(if (= j 0)
(insert " "))
(setq i (% (+ j calendar-week-start-day) 7))
(unless (and week-graph-work-week (or (= i 0) (= i 6)))
(insert "|" (aref day-titles i))))
(insert "|\n"
(make-string (+ 6 (* day-width num-days) num-days) ?-) ?\n)
(while (< cur end)
(dotimes (j 7)
(setq i (% (+ j calendar-week-start-day) 7))
(if (= j 0) (insert (weekly-graph-display-time-format cur)))
(unless (and week-graph-work-week (or (= i 0) (= i 6)))
(insert "|")
(let ((day-of-week-list (aref data i)) (print-text nil) (print-marker nil))
(setq day-of-week-list
(mapcar
(lambda (appt)
(let* ((appt-text (plist-get appt :text))
(beginning (plist-get appt :beginning))
(ending (plist-get appt :ending))
(times-printed (plist-get appt :times-printed))
(start (if times-printed (* times-printed day-width) 0))
(end (if times-printed (* (1+ times-printed) day-width) day-width)))
(message "times printed: %s start: %s end: %s appt: %s" times-printed start end appt-text)
(if (and (>= cur beginning) (< cur ending))
(progn
(unless times-printed
(setq print-marker (plist-get appt :marker)))
(setq print-text
(if (> (length appt-text) end)
(substring appt-text start end)
(if (> start (length appt-text))
(make-string day-width ?#)
(concat
(substring appt-text start (length appt-text))
(make-string (- day-width (- (length appt-text) start)) ?#)))))
(setq appt (plist-put appt :times-printed (if times-printed (1+ times-printed) 1))))
)
appt))
day-of-week-list))
(aset data i day-of-week-list)
(if print-text
(if print-marker
(insert-button print-text 'marker print-marker :type 'diary-entry)
(insert print-text))
(insert (make-string day-width ? ))))))
(insert "|\n")
(setq cur (+ cur incr)))
(insert (make-string (+ 6 (* day-width num-days) num-days) ?-) ?\n))
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(display-buffer fancy-diary-buffer)
(message "Preparing diary...done")))
(provide 'weekly-view)