├── screenshot.png
├── screenshot-transpose.png
├── README.org
├── calfw-blocks-org.el
├── calfw-transpose.el
├── LICENSE.md
└── calfw-blocks.el


/screenshot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/haji-ali/calfw-blocks/HEAD/screenshot.png


--------------------------------------------------------------------------------
/screenshot-transpose.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/haji-ali/calfw-blocks/HEAD/screenshot-transpose.png


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
  1 | * calfw-blocks.el
  2 | 
  3 | Visual time blocks and more for the [[https://github.com/haji-ali/emacs-calfw][Emacs Calendar Framework (calfw)]].
  4 | 
  5 | * Fork changelog
  6 | 
  7 | The following features are implemented:
  8 | 
  9 | - Using calendar colours instead of a rotating list of colors for events.
 10 | - Using `cl-lib` functions.
 11 | - Viewing current time indicator only when today is being shown.
 12 | - Word wrapping text in events when possible.
 13 | - Removed separate rows for dates, including them instead in the day-header.
 14 | - Added a marker for the current day.
 15 | - Implemented continuous blocks for all-day events.
 16 | - Changed the grid rendering to use overlines.
 17 | - Cleaned up some of the code, though this is definitely WIP.
 18 | - Various fixes and linting (WIP).
 19 | - TODO: checkdoc
 20 | 
 21 | This fork must be installed with my fork of `calfw`, otherwise it will *not* work.
 22 | 
 23 | * Screenshot
 24 | Weekly block view:
 25 | [[screenshot.png]]
 26 | 
 27 | Transposed two week view:
 28 | [[screenshot-transpose.png]]
 29 | 
 30 | * Installation
 31 | ** Manual Installation
 32 | Clone this git repo (e.g. to `~/.emacs.d/site-lisp/')
 33 | #+begin_src
 34 | cd ~/.emacs.d
 35 | mkdir site-lisp
 36 | cd site-lisp
 37 | git clone https://github.com/ml729/calfw-blocks
 38 | #+end_src
 39 | 
 40 | And add its path to `'load-path':
 41 | #+begin_src emacs lisp
 42 | (add-to-list 'load-path "~/.emacs.d/site-lisp/calfw-blocks")
 43 | #+end_src
 44 | 
 45 | Make sure this package is loaded after calfw.
 46 | 
 47 | * Usage
 48 | This package comes with the following ~calfw~ views that display time blocks:
 49 | #+begin_src
 50 | 'block-day
 51 | 'block-week
 52 | 'block-2-day
 53 | 'block-3-day
 54 | 'block-4-day
 55 | 'block-5-day
 56 | #+end_src
 57 | The ~block-week~ view always starts on Sunday.
 58 | The ~block-day~ and ~block-<n>-day~ views always start on the current day. The top right button labelled ~Week~ uses ~block-week~.
 59 | 
 60 | The package also includes two-column transposed versions of the original calfw views (credit to @novoid for the [[https://github.com/kiwanami/emacs-calfw/issues/22][design]]), where days of the week are displayed vertically rather than horizontally:
 61 | #+begin_src
 62 | 'transpose-8-day
 63 | 'transpose-10-day
 64 | 'transpose-12-day
 65 | 'transpose-14-day
 66 | 'transpose-two-weeks
 67 | #+end_src
 68 | The ~transpose-<n>-day~ views always start on the current day, and ~transpose-two-weeks~ always starts on the most recent Sunday. The top right buttons labelled ~W^T~ and ~2W^T~ use ~transpose-8-day~ and ~transpose-14-day~, respectively.
 69 | 
 70 | You can use these to define functions that directly open calfw with these views.
 71 | Examples:
 72 | #+begin_src emacs lisp
 73 | ;; Calendar showing org-agenda entries
 74 | (defun my-open-calendar-agenda ()
 75 |   (interactive)
 76 |   (cfw:open-calendar-buffer
 77 |    :contents-sources
 78 |    (list
 79 |     (cfw:org-create-source "medium purple"))
 80 |    :view 'block-week))
 81 | 
 82 | ;; Calendar showing org entries from files
 83 | (defun my-open-calendar-files ()
 84 |   (interactive)
 85 |   (cfw:open-calendar-buffer
 86 |    :contents-sources
 87 |    (list
 88 |     (cfw:org-create-file-source "Todos" "~/stuff/todos.org" "green")
 89 |     (cfw:org-create-file-source "Events" "~/stuff/events.org" "blue"))
 90 |    :view 'block-3-day))
 91 | #+end_src
 92 | 
 93 | * Customization
 94 | Notable customization options:
 95 | - ~calfw-blocks-earliest-visible-time~: what time of day the calendar starts at.
 96 | - ~calfw-blocks-show-time-grid~: shows a time grid if non-nil.
 97 | - ~calfw-blocks-default-event-length~: the length in hours of events with a start time but no end time; used to determine the size of the rendered block.
 98 | - ~calfw-blocks-lines-per-hour~: how many lines each hour gets.
 99 | - ~calfw-blocks-min-block-width~: the smallest width a block can be in characters (includes divider character). If there are too many concurrent events, some events are hidden so that all blocks are at least `calfw-blocks-min-block-width' characters wide.
100 | * License
101 | GNU General Public License v3.0 (GPLv3)
102 | 


--------------------------------------------------------------------------------
/calfw-blocks-org.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-blocks-org.el --- A block view for calfw  -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2023, ml729 and Al Haji-Ali
  4 | 
  5 | ;; Author: ml729
  6 | ;; Maintainer: Al Haji-Ali <abdo.haji.ali at gmail.com>
  7 | ;; Created: Author
  8 | ;; Version: 0.0.2
  9 | ;; Package-Requires: ((emacs "28.1") (calfw "2.0"))
 10 | ;; Homepage: https://github.com/haji-ali/maccalfw
 11 | ;; Keywords: calendar
 12 | 
 13 | ;; This program is free software; you can redistribute it and/or modify
 14 | ;; it under the terms of the GNU General Public License as published by
 15 | ;; the Free Software Foundation, either version 3 of the License, or
 16 | ;; (at your option) any later version.
 17 | 
 18 | ;; This program is distributed in the hope that it will be useful,
 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 21 | ;; GNU General Public License for more details.
 22 | 
 23 | ;; You should have received a copy of the GNU General Public License
 24 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 25 | ;;
 26 | ;;
 27 | ;;; Commentary:
 28 | ;;
 29 | ;; This package provides several views for calfw that show events as blocks.
 30 | ;;
 31 | ;;; Code:
 32 | (require 'calfw-org)
 33 | 
 34 | (defun calfw-blocks--cfw-org-get-timerange (text)
 35 |   "Return a range object (begin end text).
 36 | If TEXT does not have a range, return nil."
 37 |   ;; TODO: This is exactly the same as `calfw-org-get-timerange' except that
 38 |   ;; it fixed cur-day = 0
 39 |   (let* ((dotime (calfw-org--tp text 'dotime)))
 40 |     (and (stringp dotime) (string-match org-ts-regexp dotime)
 41 |          (let ((date-string  (match-string 1 dotime))
 42 |                (extra (calfw-org--tp text 'extra)))
 43 |            (if (and extra (string-match "(\\([0-9]+\\)/\\([0-9]+\\)): " extra))
 44 |                (let* (;; (cur-day (string-to-number
 45 |                       ;;           (match-string 1 extra)))
 46 |                       (total-days (string-to-number
 47 |                                    (match-string 2 extra)))
 48 |                       (start-date (org-read-date nil t date-string))
 49 |                       (end-date (time-add
 50 |                                  start-date
 51 |                                  (seconds-to-time (* 3600 24 (- total-days 1))))))
 52 |                  ;; (unless (= cur-day total-days)
 53 |                  (list (calendar-gregorian-from-absolute (time-to-days start-date))
 54 |                        (calendar-gregorian-from-absolute (time-to-days end-date)) text)))))))
 55 | 
 56 | (defun calfw-blocks-org-summary-format (item)
 57 |   "Version of calfw-org-summary-format that adds time data needed to draw blocks."
 58 |   (let* ((time-of-day (calfw-org--tp item 'time-of-day))
 59 |          (start-time (if time-of-day (list (/ time-of-day 100) (mod time-of-day 100))))
 60 |          (duration (calfw-org--tp item 'duration))
 61 |          (end-time (if (and start-time duration) (list (+ (nth 0 start-time) (/ duration 60))
 62 |                                                        (+ (nth 1 start-time) (mod duration 60)))
 63 |                      start-time))
 64 |          (time-str (and time-of-day
 65 |                         (format "%02i:%02i " (/ time-of-day 100) (% time-of-day 100))))
 66 |          ;; (marker (calfw-org--tp item 'org-marker))
 67 |          ;; (buffer (and marker (marker-buffer marker)))
 68 |          (text (calfw-org--extract-summary item))
 69 |          (props (calfw--extract-text-props item 'face 'keymap))
 70 |          (extra (calfw-org--tp item 'extra)))
 71 |     (setq text (substring-no-properties text))
 72 |     (when (and extra (string-match (concat "^" org-deadline-string ".*") extra))
 73 |       (add-text-properties 0 (length text) (list 'face (org-agenda-deadline-face 1.0)) text))
 74 |     (if org-todo-keywords-for-agenda
 75 |         (when (string-match (concat "^[\t ]*\\<\\(" (mapconcat 'identity org-todo-keywords-for-agenda "\\|") "\\)\\>") text)
 76 |           (add-text-properties (match-beginning 1) (match-end 1) (list 'face (org-get-todo-face (match-string 1 text))) text)))
 77 |     ;;; ------------------------------------------------------------------------
 78 |     ;;; act for org link
 79 |     ;;; ------------------------------------------------------------------------
 80 |     (setq text (replace-regexp-in-string "%[0-9A-F]\\{2\\}" " " text))
 81 |     (if (string-match org-link-bracket-re text)
 82 |         (let* ((desc (if (match-end 3) (match-string-no-properties 3 text)))
 83 |                (link (org-link-unescape (match-string-no-properties 1 text)))
 84 |                (help (concat "LINK: " link))
 85 |                (link-props (list
 86 |                             'face 'org-link
 87 |                             'mouse-face 'highlight
 88 |                             'help-echo help
 89 |                             'org-link link)))
 90 |           (if desc
 91 |               (progn
 92 |                 (setq desc (apply 'propertize desc link-props))
 93 |                 (setq text (replace-match desc nil nil text)))
 94 |             (setq link (apply 'propertize link link-props))
 95 |             (setq text (replace-match link nil nil text)))))
 96 |     (when time-str
 97 |       (setq text (concat time-str text)))
 98 |     (propertize
 99 |      (apply 'propertize text props)
100 |      ;; include org filename
101 |      ;; (and buffer (concat " " (buffer-name buffer)))
102 |      'keymap calfw-org-text-keymap
103 |      ;; Delete the display property, since displaying images will break our
104 |      ;; table layout.
105 |      'display nil
106 |      'calfw-blocks-interval (if start-time (cons start-time end-time)))))
107 | 
108 | 
109 | 
110 | ;; TODO: This should be shorter than the previous function.
111 | ;; (defun calfw-blocks-org-summary-format (old-fn item)
112 | ;;   "Version of calfw-org-summary-format that adds time data needed to draw blocks."
113 | ;;   (let* ((time-of-day (calfw-org--tp item 'time-of-day))
114 | ;;          (start-time (if time-of-day (list (/ time-of-day 100) (mod time-of-day 100))))
115 | ;;          (duration (calfw-org--tp item 'duration))
116 | ;;          (end-time (if (and start-time duration) (list (+ (nth 0 start-time) (/ duration 60))
117 | ;;                                                        (+ (nth 1 start-time) (mod duration 60)))
118 | ;;                      start-time)))
119 | ;;     (propertize
120 | ;;      (funcall old-fn item)
121 | ;;      'calfw-blocks-interval (if start-time (cons start-time end-time)))))
122 | 
123 | 
124 | (advice-add 'calfw-org-get-timerange
125 |             :override 'calfw-blocks--cfw-org-get-timerange)
126 | (setq calfw-org-schedule-summary-transformer 'calfw-blocks-org-summary-format)
127 | 
128 | (provide 'calfw-blocks-org)
129 | 


--------------------------------------------------------------------------------
/calfw-transpose.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-transpose.el --- A block view for calfw  -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2023, ml729 and Al Haji-Ali
  4 | 
  5 | ;; Author: ml729
  6 | ;; Maintainer: Al Haji-Ali <abdo.haji.ali at gmail.com>
  7 | ;; Created: Author
  8 | ;; Version: 0.0.2
  9 | ;; Package-Requires: ((emacs "28.1") (calfw "2.0"))
 10 | ;; Homepage: https://github.com/haji-ali/maccalfw
 11 | ;; Keywords: calendar
 12 | 
 13 | ;; This program is free software; you can redistribute it and/or modify
 14 | ;; it under the terms of the GNU General Public License as published by
 15 | ;; the Free Software Foundation, either version 3 of the License, or
 16 | ;; (at your option) any later version.
 17 | 
 18 | ;; This program is distributed in the hope that it will be useful,
 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 21 | ;; GNU General Public License for more details.
 22 | 
 23 | ;; You should have received a copy of the GNU General Public License
 24 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 25 | ;;
 26 | ;;
 27 | ;;; Commentary:
 28 | ;;
 29 | ;; This package provides several views for calfw that show events as blocks.
 30 | ;;
 31 | ;;; Code:
 32 | 
 33 | (require 'calfw-blocks)
 34 | 
 35 | (defcustom calfw-transpose-date-width 17
 36 |   "Width (in characters) of date cell in transpose views."
 37 |   :type 'number
 38 |   :group 'calfw-transpose)
 39 | 
 40 | (defcustom calfw-transpose-day-name-length nil
 41 |   "Number of characters of day of week to display in transpose views.
 42 | Displays full name if nil."
 43 |   :type 'number
 44 |   :group 'calfw-transpose)
 45 | 
 46 | 
 47 | (defun calfw-transpose-render-append-parts (param)
 48 |   "[internal] Append rendering parts to PARAM and return a new list."
 49 |   (let* ((EOL "\n")
 50 |          (date-cell-width (calfw--k 'date-cell-width param))
 51 |          (cell-width (calfw--k 'cell-width param))
 52 |          ;; (columns (calfw--k 'columns param))
 53 |          (num-cell-char
 54 |           (/ cell-width (char-width calfw-fchar-horizontal-line)))
 55 |          (num-date-cell-char
 56 |           (/ date-cell-width (char-width calfw-fchar-horizontal-line))))
 57 |     (append
 58 |      param
 59 |      `((eol . ,EOL) (vl . ,(calfw--rt (make-string 1 calfw-fchar-vertical-line) 'calfw-grid-face))
 60 |        (hline . ,(calfw--rt
 61 |                   (concat
 62 |                    (cl-loop for i from 0 below 2 concat
 63 |                             (concat
 64 |                              (make-string 1 (if (= i 0) calfw-fchar-top-left-corner calfw-fchar-top-junction))
 65 |                              (make-string num-date-cell-char calfw-fchar-horizontal-line)
 66 |                              (make-string 1 (if (= i 0) calfw-fchar-top-left-corner calfw-fchar-top-junction))
 67 |                              (make-string num-cell-char calfw-fchar-horizontal-line)))
 68 |                    (make-string 1 calfw-fchar-top-right-corner) EOL)
 69 |                   'calfw-grid-face))
 70 |        (cline . ,(calfw--rt
 71 |                   (concat
 72 |                    (cl-loop for i from 0 below 2 concat
 73 |                             (concat
 74 |                              (make-string 1 (if (= i 0) calfw-fchar-left-junction calfw-fchar-junction))
 75 |                              (make-string num-date-cell-char calfw-fchar-horizontal-line)
 76 |                              (make-string 1 (if (= i 0) calfw-fchar-left-junction calfw-fchar-junction))
 77 |                              (make-string num-cell-char calfw-fchar-horizontal-line)))
 78 |                    (make-string 1 calfw-fchar-right-junction) EOL) 'calfw-grid-face))))))
 79 | 
 80 | (defun calfw-transpose-view-nday-week-calc-param (n dest)
 81 |   "[internal] Calculate cell size from the reference size and
 82 | return an alist of rendering parameters."
 83 |   (let*
 84 |       ((time-width 5)
 85 |        (time-hline (make-string time-width ? ))
 86 |        (win-width (calfw-dest-width dest))
 87 |        ;; title 2, toolbar 1, header 2, hline 2, footer 1, margin 2 => 10
 88 |        (win-height (max 15 (- (calfw-dest-height dest) 10)))
 89 |        (junctions-width (* (char-width calfw-fchar-junction) 5))
 90 |        (date-cell-width calfw-transpose-date-width)
 91 |        (cell-width (/ (- win-width junctions-width (* 2 date-cell-width)) 2))
 92 |        (cell-height (* 5 win-height)) ;; every cell has essentially unlimited height
 93 |        (total-width (+ (* date-cell-width 2) (* cell-width 2) junctions-width)))
 94 |     `((cell-width . ,cell-width)
 95 |       (date-cell-width . ,date-cell-width)
 96 |       (cell-height . ,cell-height)
 97 |       (total-width . ,total-width)
 98 |       (columns . ,n)
 99 |       (time-width . ,time-width)
100 |       (time-hline . ,time-hline))))
101 | 
102 | (defun calfw-transpose-view-nday-week (n component &optional model)
103 |   "[internal] Render weekly calendar view."
104 |   (let* ((dest (calfw-component-dest component))
105 |          (param (calfw-transpose-render-append-parts
106 |                  (calfw-transpose-view-nday-week-calc-param n dest)))
107 |          (total-width (calfw--k 'total-width param))
108 |          ;; (time-width (calfw--k 'time-width param))
109 |          (EOL (calfw--k 'eol param))
110 |          ;; (VL (calfw--k 'vl param))
111 |          ;; (time-hline (calfw--k 'time-hline param))
112 |          ;; (hline (calfw--k 'hline param))
113 |          (cline (calfw--k 'cline param))
114 |          (model (or model
115 |                     (calfw-blocks-view-block-nday-week-model
116 |                      n (calfw-component-model component))))
117 |          (begin-date (calfw--k 'begin-date model))
118 |          (end-date (calfw--k 'end-date model)))
119 | 
120 |     ;; update model
121 |     (setf (calfw-component-model component) model)
122 |     (setq header-line-format "")
123 |     ;; ;; header
124 |     (insert
125 |      "\n"
126 |      (calfw--rt
127 |       (calfw-render-title-period begin-date end-date)
128 |       'calfw-title-face)
129 |      EOL (calfw-blocks-render-toolbar total-width 'week
130 |                              (calfw-blocks-navi-previous-nday-week-command n)
131 |                              (calfw-blocks-navi-next-nday-week-command n))
132 |      EOL)
133 |     (insert cline)
134 |     ;; contents
135 |     (calfw-transpose-render-calendar-cells-weeks
136 |      model param
137 |      (lambda (date week-day hday)
138 |        (calfw--rt (format "%s" (calendar-extract-day date))
139 |                (if hday 'calfw-sunday-face
140 |                  (calfw--render-get-week-face
141 |                   week-day 'calfw-default-day-face)))))
142 |     ;; footer
143 |     (insert (calfw--render-footer total-width (calfw--model-get-contents-sources model)))))
144 | 
145 | (defun calfw-transpose-render-calendar-cells-weeks (model param title-func)
146 |   "[internal] Insert calendar cells for week based views."
147 |   (let ((all-days (apply 'nconc (calfw--k 'weeks model))))
148 |     (calfw-transpose-render-calendar-cells-days
149 |      model param title-func all-days
150 |      'calfw-blocks-render-content t)))
151 | 
152 | 
153 | (defun calfw-transpose-render-calendar-cells-days
154 |     (model param title-func &optional
155 |            days content-fun _do-weeks)
156 |   "[internal] Insert calendar cells for the linear views."
157 |   (calfw-transpose-render-columns
158 |    (cl-loop with cell-width      = (calfw--k 'cell-width param)
159 |          with days            = (or days (calfw--k 'days model))
160 |          with content-fun     = (or content-fun
161 |                                     'calfw--render-event-days-overview-content)
162 |          with holidays        = (calfw--k 'holidays model)
163 |          with annotations     = (calfw--k 'annotations model)
164 |          with headers         = (calfw--k 'headers  model)
165 |          with raw-periods-all = (calfw-blocks-render-periods-stacks model)
166 |          with sorter          = (calfw-model-get-sorter model)
167 | 
168 |          for date in days ; days columns loop
169 |          for count from 0 below (length days)
170 |          for hday         = (car (calfw--contents-get date holidays))
171 |          for week-day     = (nth (% count 7) headers)
172 |          for ant          = (calfw--rt (calfw--contents-get date annotations)
173 |                                     'calfw-annotation-face)
174 |          for raw-periods  = (calfw--contents-get date raw-periods-all)
175 |          for raw-contents = (calfw--render-sort-contents
176 |                              (funcall content-fun
177 |                                       (calfw-model-get-contents-by-date date model))
178 |                              sorter)
179 |          for prs-contents = (calfw--render-rows-prop
180 |                              (append (calfw-transpose-render-periods-days
181 |                                       date raw-periods cell-width)
182 |                                      (mapcar 'calfw--render-default-content-face
183 |                                              raw-contents)))
184 |          for num-label = (if prs-contents
185 |                              (format "(%s)"
186 |                                      (+ (length raw-contents)
187 |                                         (length raw-periods))) "")
188 |          for tday = (concat
189 |                      ;; " " ; margin
190 |                      (funcall title-func date week-day hday)
191 |                      (if num-label (concat " " num-label)))
192 |          ;; separate holiday from rest of days in transposed view,
193 |          ;; so it can be put on a new line
194 |          for hday-str = (if hday (calfw--rt (substring hday 0)
195 |                                                   'calfw-holiday-face))
196 |          collect
197 |          (cons date (cons (cons tday (cons ant hday-str)) prs-contents)))
198 |    param))
199 | 
200 | (defun calfw-transpose-render-periods-days (_date periods-stack _cell-width)
201 |   "[internal] Insert period texts."
202 |   (when periods-stack
203 |     (let ((stack (sort (copy-sequence periods-stack)
204 |                        (lambda (a b) (< (car a) (car b))))))
205 |       (cl-loop for (_row (begin end content _props interval)) in stack
206 |             ;; for beginp = (equal date begin)
207 |             ;; for endp = (equal date end)
208 |             ;; for width = (- cell-width 2)
209 |             for begintime = (if interval (calfw-blocks-format-time (car interval)))
210 |             for endtime = (if interval (calfw-blocks-format-time (cdr interval)))
211 |             for beginday = (calfw-strtime begin)
212 |             for endday = (calfw-strtime end)
213 |             for title =
214 |             (concat (if (not (string= beginday endday))
215 |                         (concat beginday "-" endday " "))
216 |                     (if (and begintime
217 |                              (string= (substring content 0 5) begintime))
218 |                         (concat begintime "-" endtime (substring content 5))
219 |                       content))
220 |             collect
221 |             (if content
222 |                 (calfw--render-default-content-face title)
223 |               "")))))
224 | 
225 | (defun calfw-transpose-render-columns (day-columns param)
226 |   "Concatenates each row on the days into a string of a physical line.
227 | [internal]
228 | 
229 | DAY-COLUMNS is a list of columns. A column is a list of following
230 | form: (DATE (DAY-TITLE . ANNOTATION-TITLE) STRING STRING...)."
231 |   (let* ((date-cell-width  (calfw--k 'date-cell-width  param))
232 |          (cell-width  (calfw--k 'cell-width  param))
233 |          (cell-height (calfw--k 'cell-height param))
234 |          (EOL (calfw--k 'eol param)) (VL (calfw--k 'vl param))
235 |          ;; (hline (calfw--k 'hline param))
236 |          (cline (calfw--k 'cline param))
237 |          (num-days (length day-columns))
238 |          (first-half (seq-subseq day-columns 0 (/ num-days 2)))
239 |          (second-half (seq-subseq day-columns (/ num-days 2) num-days)))
240 |     (cl-loop for j from 0 below (/ num-days 2)
241 |           for day1 = (nth j first-half)
242 |           for day2 = (nth j second-half)
243 |           do
244 |           (cl-loop with breaked-day-columns =
245 |                 (cl-loop for day-rows in `(,day1 ,day2)
246 |                       for date = (car day-rows)
247 |                       for line = (cddr day-rows)
248 |                       collect
249 |                       (cons date (calfw--render-break-lines
250 |                                   line cell-width cell-height)))
251 |                 with breaked-date-columns =
252 |                 (cl-loop for day-rows in `(,day1 ,day2)
253 |                       for date = (car day-rows)
254 |                       for dayname = (aref calendar-day-name-array
255 |                                           (calendar-day-of-week date))
256 |                       for (tday . (_ant . hday)) = (cadr day-rows)
257 |                       collect
258 |                       (cons date (calfw--render-break-lines
259 |                                   (list
260 |                                    (calfw--tp
261 |                                     (calfw--render-default-content-face
262 |                                      (concat
263 |                                       (substring dayname 0 calfw-transpose-day-name-length)
264 |                                       " "
265 |                                       tday)
266 |                                      'calfw-day-title-face)
267 |                                     'cfw:date date)
268 |                                    hday) date-cell-width cell-height)))
269 |                 with max-height = (max 2
270 |                                        (length (cdr (nth 0 breaked-day-columns)))
271 |                                        (length (cdr (nth 1 breaked-day-columns)))
272 |                                        (length (cdr (nth 0 breaked-date-columns)))
273 |                                        (length (cdr (nth 1 breaked-date-columns))))
274 |                 for i from 1 to max-height
275 |                 do
276 |                 (cl-loop for k from 0 to 1
277 |                       for day-rows = (nth k breaked-day-columns)
278 |                       for date-rows = (nth k breaked-date-columns)
279 |                       for date = (car day-rows)
280 |                       for row = (nth i day-rows)
281 |                       for date-row = (nth i date-rows)
282 |                       do
283 |                       (insert
284 |                        VL (calfw--tp
285 |                            (calfw--render-left date-cell-width (and date-row (format "%s" date-row)))
286 |                            'cfw:date date))
287 |                       (insert
288 |                        VL (calfw--tp
289 |                            (calfw--render-separator
290 |                             (calfw--render-left cell-width (and row (format "%s" row))))
291 |                            'cfw:date date)))
292 |                 (insert VL EOL))
293 |           (insert cline))
294 |     (insert EOL)))
295 | 
296 | 
297 | 
298 | (defun calfw-transpose-view-8-day (component)
299 |   (calfw-transpose-view-nday-week 8 component))
300 | 
301 | (defun calfw-transpose-view-10-day (component)
302 |   (calfw-transpose-view-nday-week 10 component))
303 | 
304 | (defun calfw-transpose-view-12-day (component)
305 |   (calfw-transpose-view-nday-week 12 component))
306 | 
307 | (defun calfw-transpose-view-14-day (component)
308 |   (calfw-transpose-view-nday-week 14 component))
309 | 
310 | (defun calfw-transpose-view-two-weeks (component)
311 |   (calfw-transpose-view-nday-week 14 component
312 |                                          (calfw--view-two-weeks-model
313 |                                           (calfw-component-model component))))
314 | 
315 | 
316 | (defun calfw-transpose-change-view-two-weeks ()
317 |   "change-view-month"
318 |   (interactive)
319 |   (when (calfw-cp-get-component)
320 |     (calfw-cp-set-view (calfw-cp-get-component) 'transpose-two-weeks)))
321 | 
322 | (defun calfw-transpose-change-view-14-day ()
323 |   "change-view-month"
324 |   (interactive)
325 |   (when (calfw-cp-get-component)
326 |     (calfw-cp-set-view (calfw-cp-get-component) 'transpose-14-day)))
327 | 
328 | (defun calfw-transpose-change-view-12-day ()
329 |   "change-view-month"
330 |   (interactive)
331 |   (when (calfw-cp-get-component)
332 |     (calfw-cp-set-view (calfw-cp-get-component) 'transpose-12-day)))
333 | 
334 | (defun calfw-transpose-change-view-10-day ()
335 |   "change-view-month"
336 |   (interactive)
337 |   (when (calfw-cp-get-component)
338 |     (calfw-cp-set-view (calfw-cp-get-component) 'transpose-10-day)))
339 | 
340 | (defun calfw-transpose-change-view-8-day ()
341 |   "change-view-month"
342 |   (interactive)
343 |   (when (calfw-cp-get-component)
344 |     (calfw-cp-set-view (calfw-cp-get-component) 'transpose-8-day)))
345 | 
346 | 
347 | (setq
348 |  calfw-cp-dipatch-funcs
349 |  (append
350 |   calfw-cp-dipatch-funcs
351 |   '((transpose-8-day   .  calfw-transpose-view-8-day)
352 |     (transpose-10-day  .  calfw-transpose-view-10-day)
353 |     (transpose-12-day  .  calfw-transpose-view-12-day)
354 |     (transpose-14-day  .  calfw-transpose-view-14-day)
355 |     (transpose-two-weeks    . calfw-transpose-view-two-weeks))))
356 | 
357 | (setq
358 |  calfw-blocks-toolbar-views
359 |  '(("Day" . block-day)
360 |    ("3-Day" . block-3-day)
361 |    ("Week" . block-week)
362 |    ("Two Week" . two-weeks)
363 |    ("W^T" . transpose-8-day)
364 |    ("2W^T" . transpose-14-day)
365 |    ("Month" . month)))
366 | 
367 | (provide 'calfw-transpose)
368 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
  1 |                     GNU GENERAL PUBLIC LICENSE
  2 |                        Version 3, 29 June 2007
  3 | 
  4 |  Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
  5 |  Everyone is permitted to copy and distribute verbatim copies
  6 |  of this license document, but changing it is not allowed.
  7 | 
  8 |                             Preamble
  9 | 
 10 |   The GNU General Public License is a free, copyleft license for
 11 | software and other kinds of works.
 12 | 
 13 |   The licenses for most software and other practical works are designed
 14 | to take away your freedom to share and change the works.  By contrast,
 15 | the GNU General Public License is intended to guarantee your freedom to
 16 | share and change all versions of a program--to make sure it remains free
 17 | software for all its users.  We, the Free Software Foundation, use the
 18 | GNU General Public License for most of our software; it applies also to
 19 | any other work released this way by its authors.  You can apply it to
 20 | your programs, too.
 21 | 
 22 |   When we speak of free software, we are referring to freedom, not
 23 | price.  Our General Public Licenses are designed to make sure that you
 24 | have the freedom to distribute copies of free software (and charge for
 25 | them if you wish), that you receive source code or can get it if you
 26 | want it, that you can change the software or use pieces of it in new
 27 | free programs, and that you know you can do these things.
 28 | 
 29 |   To protect your rights, we need to prevent others from denying you
 30 | these rights or asking you to surrender the rights.  Therefore, you have
 31 | certain responsibilities if you distribute copies of the software, or if
 32 | you modify it: responsibilities to respect the freedom of others.
 33 | 
 34 |   For example, if you distribute copies of such a program, whether
 35 | gratis or for a fee, you must pass on to the recipients the same
 36 | freedoms that you received.  You must make sure that they, too, receive
 37 | or can get the source code.  And you must show them these terms so they
 38 | know their rights.
 39 | 
 40 |   Developers that use the GNU GPL protect your rights with two steps:
 41 | (1) assert copyright on the software, and (2) offer you this License
 42 | giving you legal permission to copy, distribute and/or modify it.
 43 | 
 44 |   For the developers' and authors' protection, the GPL clearly explains
 45 | that there is no warranty for this free software.  For both users' and
 46 | authors' sake, the GPL requires that modified versions be marked as
 47 | changed, so that their problems will not be attributed erroneously to
 48 | authors of previous versions.
 49 | 
 50 |   Some devices are designed to deny users access to install or run
 51 | modified versions of the software inside them, although the manufacturer
 52 | can do so.  This is fundamentally incompatible with the aim of
 53 | protecting users' freedom to change the software.  The systematic
 54 | pattern of such abuse occurs in the area of products for individuals to
 55 | use, which is precisely where it is most unacceptable.  Therefore, we
 56 | have designed this version of the GPL to prohibit the practice for those
 57 | products.  If such problems arise substantially in other domains, we
 58 | stand ready to extend this provision to those domains in future versions
 59 | of the GPL, as needed to protect the freedom of users.
 60 | 
 61 |   Finally, every program is threatened constantly by software patents.
 62 | States should not allow patents to restrict development and use of
 63 | software on general-purpose computers, but in those that do, we wish to
 64 | avoid the special danger that patents applied to a free program could
 65 | make it effectively proprietary.  To prevent this, the GPL assures that
 66 | patents cannot be used to render the program non-free.
 67 | 
 68 |   The precise terms and conditions for copying, distribution and
 69 | modification follow.
 70 | 
 71 |                        TERMS AND CONDITIONS
 72 | 
 73 |   0. Definitions.
 74 | 
 75 |   "This License" refers to version 3 of the GNU General Public License.
 76 | 
 77 |   "Copyright" also means copyright-like laws that apply to other kinds of
 78 | works, such as semiconductor masks.
 79 | 
 80 |   "The Program" refers to any copyrightable work licensed under this
 81 | License.  Each licensee is addressed as "you".  "Licensees" and
 82 | "recipients" may be individuals or organizations.
 83 | 
 84 |   To "modify" a work means to copy from or adapt all or part of the work
 85 | in a fashion requiring copyright permission, other than the making of an
 86 | exact copy.  The resulting work is called a "modified version" of the
 87 | earlier work or a work "based on" the earlier work.
 88 | 
 89 |   A "covered work" means either the unmodified Program or a work based
 90 | on the Program.
 91 | 
 92 |   To "propagate" a work means to do anything with it that, without
 93 | permission, would make you directly or secondarily liable for
 94 | infringement under applicable copyright law, except executing it on a
 95 | computer or modifying a private copy.  Propagation includes copying,
 96 | distribution (with or without modification), making available to the
 97 | public, and in some countries other activities as well.
 98 | 
 99 |   To "convey" a work means any kind of propagation that enables other
100 | parties to make or receive copies.  Mere interaction with a user through
101 | a computer network, with no transfer of a copy, is not conveying.
102 | 
103 |   An interactive user interface displays "Appropriate Legal Notices"
104 | to the extent that it includes a convenient and prominently visible
105 | feature that (1) displays an appropriate copyright notice, and (2)
106 | tells the user that there is no warranty for the work (except to the
107 | extent that warranties are provided), that licensees may convey the
108 | work under this License, and how to view a copy of this License.  If
109 | the interface presents a list of user commands or options, such as a
110 | menu, a prominent item in the list meets this criterion.
111 | 
112 |   1. Source Code.
113 | 
114 |   The "source code" for a work means the preferred form of the work
115 | for making modifications to it.  "Object code" means any non-source
116 | form of a work.
117 | 
118 |   A "Standard Interface" means an interface that either is an official
119 | standard defined by a recognized standards body, or, in the case of
120 | interfaces specified for a particular programming language, one that
121 | is widely used among developers working in that language.
122 | 
123 |   The "System Libraries" of an executable work include anything, other
124 | than the work as a whole, that (a) is included in the normal form of
125 | packaging a Major Component, but which is not part of that Major
126 | Component, and (b) serves only to enable use of the work with that
127 | Major Component, or to implement a Standard Interface for which an
128 | implementation is available to the public in source code form.  A
129 | "Major Component", in this context, means a major essential component
130 | (kernel, window system, and so on) of the specific operating system
131 | (if any) on which the executable work runs, or a compiler used to
132 | produce the work, or an object code interpreter used to run it.
133 | 
134 |   The "Corresponding Source" for a work in object code form means all
135 | the source code needed to generate, install, and (for an executable
136 | work) run the object code and to modify the work, including scripts to
137 | control those activities.  However, it does not include the work's
138 | System Libraries, or general-purpose tools or generally available free
139 | programs which are used unmodified in performing those activities but
140 | which are not part of the work.  For example, Corresponding Source
141 | includes interface definition files associated with source files for
142 | the work, and the source code for shared libraries and dynamically
143 | linked subprograms that the work is specifically designed to require,
144 | such as by intimate data communication or control flow between those
145 | subprograms and other parts of the work.
146 | 
147 |   The Corresponding Source need not include anything that users
148 | can regenerate automatically from other parts of the Corresponding
149 | Source.
150 | 
151 |   The Corresponding Source for a work in source code form is that
152 | same work.
153 | 
154 |   2. Basic Permissions.
155 | 
156 |   All rights granted under this License are granted for the term of
157 | copyright on the Program, and are irrevocable provided the stated
158 | conditions are met.  This License explicitly affirms your unlimited
159 | permission to run the unmodified Program.  The output from running a
160 | covered work is covered by this License only if the output, given its
161 | content, constitutes a covered work.  This License acknowledges your
162 | rights of fair use or other equivalent, as provided by copyright law.
163 | 
164 |   You may make, run and propagate covered works that you do not
165 | convey, without conditions so long as your license otherwise remains
166 | in force.  You may convey covered works to others for the sole purpose
167 | of having them make modifications exclusively for you, or provide you
168 | with facilities for running those works, provided that you comply with
169 | the terms of this License in conveying all material for which you do
170 | not control copyright.  Those thus making or running the covered works
171 | for you must do so exclusively on your behalf, under your direction
172 | and control, on terms that prohibit them from making any copies of
173 | your copyrighted material outside their relationship with you.
174 | 
175 |   Conveying under any other circumstances is permitted solely under
176 | the conditions stated below.  Sublicensing is not allowed; section 10
177 | makes it unnecessary.
178 | 
179 |   3. Protecting Users' Legal Rights From Anti-Circumvention Law.
180 | 
181 |   No covered work shall be deemed part of an effective technological
182 | measure under any applicable law fulfilling obligations under article
183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or
184 | similar laws prohibiting or restricting circumvention of such
185 | measures.
186 | 
187 |   When you convey a covered work, you waive any legal power to forbid
188 | circumvention of technological measures to the extent such circumvention
189 | is effected by exercising rights under this License with respect to
190 | the covered work, and you disclaim any intention to limit operation or
191 | modification of the work as a means of enforcing, against the work's
192 | users, your or third parties' legal rights to forbid circumvention of
193 | technological measures.
194 | 
195 |   4. Conveying Verbatim Copies.
196 | 
197 |   You may convey verbatim copies of the Program's source code as you
198 | receive it, in any medium, provided that you conspicuously and
199 | appropriately publish on each copy an appropriate copyright notice;
200 | keep intact all notices stating that this License and any
201 | non-permissive terms added in accord with section 7 apply to the code;
202 | keep intact all notices of the absence of any warranty; and give all
203 | recipients a copy of this License along with the Program.
204 | 
205 |   You may charge any price or no price for each copy that you convey,
206 | and you may offer support or warranty protection for a fee.
207 | 
208 |   5. Conveying Modified Source Versions.
209 | 
210 |   You may convey a work based on the Program, or the modifications to
211 | produce it from the Program, in the form of source code under the
212 | terms of section 4, provided that you also meet all of these conditions:
213 | 
214 |     a) The work must carry prominent notices stating that you modified
215 |     it, and giving a relevant date.
216 | 
217 |     b) The work must carry prominent notices stating that it is
218 |     released under this License and any conditions added under section
219 |     7.  This requirement modifies the requirement in section 4 to
220 |     "keep intact all notices".
221 | 
222 |     c) You must license the entire work, as a whole, under this
223 |     License to anyone who comes into possession of a copy.  This
224 |     License will therefore apply, along with any applicable section 7
225 |     additional terms, to the whole of the work, and all its parts,
226 |     regardless of how they are packaged.  This License gives no
227 |     permission to license the work in any other way, but it does not
228 |     invalidate such permission if you have separately received it.
229 | 
230 |     d) If the work has interactive user interfaces, each must display
231 |     Appropriate Legal Notices; however, if the Program has interactive
232 |     interfaces that do not display Appropriate Legal Notices, your
233 |     work need not make them do so.
234 | 
235 |   A compilation of a covered work with other separate and independent
236 | works, which are not by their nature extensions of the covered work,
237 | and which are not combined with it such as to form a larger program,
238 | in or on a volume of a storage or distribution medium, is called an
239 | "aggregate" if the compilation and its resulting copyright are not
240 | used to limit the access or legal rights of the compilation's users
241 | beyond what the individual works permit.  Inclusion of a covered work
242 | in an aggregate does not cause this License to apply to the other
243 | parts of the aggregate.
244 | 
245 |   6. Conveying Non-Source Forms.
246 | 
247 |   You may convey a covered work in object code form under the terms
248 | of sections 4 and 5, provided that you also convey the
249 | machine-readable Corresponding Source under the terms of this License,
250 | in one of these ways:
251 | 
252 |     a) Convey the object code in, or embodied in, a physical product
253 |     (including a physical distribution medium), accompanied by the
254 |     Corresponding Source fixed on a durable physical medium
255 |     customarily used for software interchange.
256 | 
257 |     b) Convey the object code in, or embodied in, a physical product
258 |     (including a physical distribution medium), accompanied by a
259 |     written offer, valid for at least three years and valid for as
260 |     long as you offer spare parts or customer support for that product
261 |     model, to give anyone who possesses the object code either (1) a
262 |     copy of the Corresponding Source for all the software in the
263 |     product that is covered by this License, on a durable physical
264 |     medium customarily used for software interchange, for a price no
265 |     more than your reasonable cost of physically performing this
266 |     conveying of source, or (2) access to copy the
267 |     Corresponding Source from a network server at no charge.
268 | 
269 |     c) Convey individual copies of the object code with a copy of the
270 |     written offer to provide the Corresponding Source.  This
271 |     alternative is allowed only occasionally and noncommercially, and
272 |     only if you received the object code with such an offer, in accord
273 |     with subsection 6b.
274 | 
275 |     d) Convey the object code by offering access from a designated
276 |     place (gratis or for a charge), and offer equivalent access to the
277 |     Corresponding Source in the same way through the same place at no
278 |     further charge.  You need not require recipients to copy the
279 |     Corresponding Source along with the object code.  If the place to
280 |     copy the object code is a network server, the Corresponding Source
281 |     may be on a different server (operated by you or a third party)
282 |     that supports equivalent copying facilities, provided you maintain
283 |     clear directions next to the object code saying where to find the
284 |     Corresponding Source.  Regardless of what server hosts the
285 |     Corresponding Source, you remain obligated to ensure that it is
286 |     available for as long as needed to satisfy these requirements.
287 | 
288 |     e) Convey the object code using peer-to-peer transmission, provided
289 |     you inform other peers where the object code and Corresponding
290 |     Source of the work are being offered to the general public at no
291 |     charge under subsection 6d.
292 | 
293 |   A separable portion of the object code, whose source code is excluded
294 | from the Corresponding Source as a System Library, need not be
295 | included in conveying the object code work.
296 | 
297 |   A "User Product" is either (1) a "consumer product", which means any
298 | tangible personal property which is normally used for personal, family,
299 | or household purposes, or (2) anything designed or sold for incorporation
300 | into a dwelling.  In determining whether a product is a consumer product,
301 | doubtful cases shall be resolved in favor of coverage.  For a particular
302 | product received by a particular user, "normally used" refers to a
303 | typical or common use of that class of product, regardless of the status
304 | of the particular user or of the way in which the particular user
305 | actually uses, or expects or is expected to use, the product.  A product
306 | is a consumer product regardless of whether the product has substantial
307 | commercial, industrial or non-consumer uses, unless such uses represent
308 | the only significant mode of use of the product.
309 | 
310 |   "Installation Information" for a User Product means any methods,
311 | procedures, authorization keys, or other information required to install
312 | and execute modified versions of a covered work in that User Product from
313 | a modified version of its Corresponding Source.  The information must
314 | suffice to ensure that the continued functioning of the modified object
315 | code is in no case prevented or interfered with solely because
316 | modification has been made.
317 | 
318 |   If you convey an object code work under this section in, or with, or
319 | specifically for use in, a User Product, and the conveying occurs as
320 | part of a transaction in which the right of possession and use of the
321 | User Product is transferred to the recipient in perpetuity or for a
322 | fixed term (regardless of how the transaction is characterized), the
323 | Corresponding Source conveyed under this section must be accompanied
324 | by the Installation Information.  But this requirement does not apply
325 | if neither you nor any third party retains the ability to install
326 | modified object code on the User Product (for example, the work has
327 | been installed in ROM).
328 | 
329 |   The requirement to provide Installation Information does not include a
330 | requirement to continue to provide support service, warranty, or updates
331 | for a work that has been modified or installed by the recipient, or for
332 | the User Product in which it has been modified or installed.  Access to a
333 | network may be denied when the modification itself materially and
334 | adversely affects the operation of the network or violates the rules and
335 | protocols for communication across the network.
336 | 
337 |   Corresponding Source conveyed, and Installation Information provided,
338 | in accord with this section must be in a format that is publicly
339 | documented (and with an implementation available to the public in
340 | source code form), and must require no special password or key for
341 | unpacking, reading or copying.
342 | 
343 |   7. Additional Terms.
344 | 
345 |   "Additional permissions" are terms that supplement the terms of this
346 | License by making exceptions from one or more of its conditions.
347 | Additional permissions that are applicable to the entire Program shall
348 | be treated as though they were included in this License, to the extent
349 | that they are valid under applicable law.  If additional permissions
350 | apply only to part of the Program, that part may be used separately
351 | under those permissions, but the entire Program remains governed by
352 | this License without regard to the additional permissions.
353 | 
354 |   When you convey a copy of a covered work, you may at your option
355 | remove any additional permissions from that copy, or from any part of
356 | it.  (Additional permissions may be written to require their own
357 | removal in certain cases when you modify the work.)  You may place
358 | additional permissions on material, added by you to a covered work,
359 | for which you have or can give appropriate copyright permission.
360 | 
361 |   Notwithstanding any other provision of this License, for material you
362 | add to a covered work, you may (if authorized by the copyright holders of
363 | that material) supplement the terms of this License with terms:
364 | 
365 |     a) Disclaiming warranty or limiting liability differently from the
366 |     terms of sections 15 and 16 of this License; or
367 | 
368 |     b) Requiring preservation of specified reasonable legal notices or
369 |     author attributions in that material or in the Appropriate Legal
370 |     Notices displayed by works containing it; or
371 | 
372 |     c) Prohibiting misrepresentation of the origin of that material, or
373 |     requiring that modified versions of such material be marked in
374 |     reasonable ways as different from the original version; or
375 | 
376 |     d) Limiting the use for publicity purposes of names of licensors or
377 |     authors of the material; or
378 | 
379 |     e) Declining to grant rights under trademark law for use of some
380 |     trade names, trademarks, or service marks; or
381 | 
382 |     f) Requiring indemnification of licensors and authors of that
383 |     material by anyone who conveys the material (or modified versions of
384 |     it) with contractual assumptions of liability to the recipient, for
385 |     any liability that these contractual assumptions directly impose on
386 |     those licensors and authors.
387 | 
388 |   All other non-permissive additional terms are considered "further
389 | restrictions" within the meaning of section 10.  If the Program as you
390 | received it, or any part of it, contains a notice stating that it is
391 | governed by this License along with a term that is a further
392 | restriction, you may remove that term.  If a license document contains
393 | a further restriction but permits relicensing or conveying under this
394 | License, you may add to a covered work material governed by the terms
395 | of that license document, provided that the further restriction does
396 | not survive such relicensing or conveying.
397 | 
398 |   If you add terms to a covered work in accord with this section, you
399 | must place, in the relevant source files, a statement of the
400 | additional terms that apply to those files, or a notice indicating
401 | where to find the applicable terms.
402 | 
403 |   Additional terms, permissive or non-permissive, may be stated in the
404 | form of a separately written license, or stated as exceptions;
405 | the above requirements apply either way.
406 | 
407 |   8. Termination.
408 | 
409 |   You may not propagate or modify a covered work except as expressly
410 | provided under this License.  Any attempt otherwise to propagate or
411 | modify it is void, and will automatically terminate your rights under
412 | this License (including any patent licenses granted under the third
413 | paragraph of section 11).
414 | 
415 |   However, if you cease all violation of this License, then your
416 | license from a particular copyright holder is reinstated (a)
417 | provisionally, unless and until the copyright holder explicitly and
418 | finally terminates your license, and (b) permanently, if the copyright
419 | holder fails to notify you of the violation by some reasonable means
420 | prior to 60 days after the cessation.
421 | 
422 |   Moreover, your license from a particular copyright holder is
423 | reinstated permanently if the copyright holder notifies you of the
424 | violation by some reasonable means, this is the first time you have
425 | received notice of violation of this License (for any work) from that
426 | copyright holder, and you cure the violation prior to 30 days after
427 | your receipt of the notice.
428 | 
429 |   Termination of your rights under this section does not terminate the
430 | licenses of parties who have received copies or rights from you under
431 | this License.  If your rights have been terminated and not permanently
432 | reinstated, you do not qualify to receive new licenses for the same
433 | material under section 10.
434 | 
435 |   9. Acceptance Not Required for Having Copies.
436 | 
437 |   You are not required to accept this License in order to receive or
438 | run a copy of the Program.  Ancillary propagation of a covered work
439 | occurring solely as a consequence of using peer-to-peer transmission
440 | to receive a copy likewise does not require acceptance.  However,
441 | nothing other than this License grants you permission to propagate or
442 | modify any covered work.  These actions infringe copyright if you do
443 | not accept this License.  Therefore, by modifying or propagating a
444 | covered work, you indicate your acceptance of this License to do so.
445 | 
446 |   10. Automatic Licensing of Downstream Recipients.
447 | 
448 |   Each time you convey a covered work, the recipient automatically
449 | receives a license from the original licensors, to run, modify and
450 | propagate that work, subject to this License.  You are not responsible
451 | for enforcing compliance by third parties with this License.
452 | 
453 |   An "entity transaction" is a transaction transferring control of an
454 | organization, or substantially all assets of one, or subdividing an
455 | organization, or merging organizations.  If propagation of a covered
456 | work results from an entity transaction, each party to that
457 | transaction who receives a copy of the work also receives whatever
458 | licenses to the work the party's predecessor in interest had or could
459 | give under the previous paragraph, plus a right to possession of the
460 | Corresponding Source of the work from the predecessor in interest, if
461 | the predecessor has it or can get it with reasonable efforts.
462 | 
463 |   You may not impose any further restrictions on the exercise of the
464 | rights granted or affirmed under this License.  For example, you may
465 | not impose a license fee, royalty, or other charge for exercise of
466 | rights granted under this License, and you may not initiate litigation
467 | (including a cross-claim or counterclaim in a lawsuit) alleging that
468 | any patent claim is infringed by making, using, selling, offering for
469 | sale, or importing the Program or any portion of it.
470 | 
471 |   11. Patents.
472 | 
473 |   A "contributor" is a copyright holder who authorizes use under this
474 | License of the Program or a work on which the Program is based.  The
475 | work thus licensed is called the contributor's "contributor version".
476 | 
477 |   A contributor's "essential patent claims" are all patent claims
478 | owned or controlled by the contributor, whether already acquired or
479 | hereafter acquired, that would be infringed by some manner, permitted
480 | by this License, of making, using, or selling its contributor version,
481 | but do not include claims that would be infringed only as a
482 | consequence of further modification of the contributor version.  For
483 | purposes of this definition, "control" includes the right to grant
484 | patent sublicenses in a manner consistent with the requirements of
485 | this License.
486 | 
487 |   Each contributor grants you a non-exclusive, worldwide, royalty-free
488 | patent license under the contributor's essential patent claims, to
489 | make, use, sell, offer for sale, import and otherwise run, modify and
490 | propagate the contents of its contributor version.
491 | 
492 |   In the following three paragraphs, a "patent license" is any express
493 | agreement or commitment, however denominated, not to enforce a patent
494 | (such as an express permission to practice a patent or covenant not to
495 | sue for patent infringement).  To "grant" such a patent license to a
496 | party means to make such an agreement or commitment not to enforce a
497 | patent against the party.
498 | 
499 |   If you convey a covered work, knowingly relying on a patent license,
500 | and the Corresponding Source of the work is not available for anyone
501 | to copy, free of charge and under the terms of this License, through a
502 | publicly available network server or other readily accessible means,
503 | then you must either (1) cause the Corresponding Source to be so
504 | available, or (2) arrange to deprive yourself of the benefit of the
505 | patent license for this particular work, or (3) arrange, in a manner
506 | consistent with the requirements of this License, to extend the patent
507 | license to downstream recipients.  "Knowingly relying" means you have
508 | actual knowledge that, but for the patent license, your conveying the
509 | covered work in a country, or your recipient's use of the covered work
510 | in a country, would infringe one or more identifiable patents in that
511 | country that you have reason to believe are valid.
512 | 
513 |   If, pursuant to or in connection with a single transaction or
514 | arrangement, you convey, or propagate by procuring conveyance of, a
515 | covered work, and grant a patent license to some of the parties
516 | receiving the covered work authorizing them to use, propagate, modify
517 | or convey a specific copy of the covered work, then the patent license
518 | you grant is automatically extended to all recipients of the covered
519 | work and works based on it.
520 | 
521 |   A patent license is "discriminatory" if it does not include within
522 | the scope of its coverage, prohibits the exercise of, or is
523 | conditioned on the non-exercise of one or more of the rights that are
524 | specifically granted under this License.  You may not convey a covered
525 | work if you are a party to an arrangement with a third party that is
526 | in the business of distributing software, under which you make payment
527 | to the third party based on the extent of your activity of conveying
528 | the work, and under which the third party grants, to any of the
529 | parties who would receive the covered work from you, a discriminatory
530 | patent license (a) in connection with copies of the covered work
531 | conveyed by you (or copies made from those copies), or (b) primarily
532 | for and in connection with specific products or compilations that
533 | contain the covered work, unless you entered into that arrangement,
534 | or that patent license was granted, prior to 28 March 2007.
535 | 
536 |   Nothing in this License shall be construed as excluding or limiting
537 | any implied license or other defenses to infringement that may
538 | otherwise be available to you under applicable patent law.
539 | 
540 |   12. No Surrender of Others' Freedom.
541 | 
542 |   If conditions are imposed on you (whether by court order, agreement or
543 | otherwise) that contradict the conditions of this License, they do not
544 | excuse you from the conditions of this License.  If you cannot convey a
545 | covered work so as to satisfy simultaneously your obligations under this
546 | License and any other pertinent obligations, then as a consequence you may
547 | not convey it at all.  For example, if you agree to terms that obligate you
548 | to collect a royalty for further conveying from those to whom you convey
549 | the Program, the only way you could satisfy both those terms and this
550 | License would be to refrain entirely from conveying the Program.
551 | 
552 |   13. Use with the GNU Affero General Public License.
553 | 
554 |   Notwithstanding any other provision of this License, you have
555 | permission to link or combine any covered work with a work licensed
556 | under version 3 of the GNU Affero General Public License into a single
557 | combined work, and to convey the resulting work.  The terms of this
558 | License will continue to apply to the part which is the covered work,
559 | but the special requirements of the GNU Affero General Public License,
560 | section 13, concerning interaction through a network will apply to the
561 | combination as such.
562 | 
563 |   14. Revised Versions of this License.
564 | 
565 |   The Free Software Foundation may publish revised and/or new versions of
566 | the GNU General Public License from time to time.  Such new versions will
567 | be similar in spirit to the present version, but may differ in detail to
568 | address new problems or concerns.
569 | 
570 |   Each version is given a distinguishing version number.  If the
571 | Program specifies that a certain numbered version of the GNU General
572 | Public License "or any later version" applies to it, you have the
573 | option of following the terms and conditions either of that numbered
574 | version or of any later version published by the Free Software
575 | Foundation.  If the Program does not specify a version number of the
576 | GNU General Public License, you may choose any version ever published
577 | by the Free Software Foundation.
578 | 
579 |   If the Program specifies that a proxy can decide which future
580 | versions of the GNU General Public License can be used, that proxy's
581 | public statement of acceptance of a version permanently authorizes you
582 | to choose that version for the Program.
583 | 
584 |   Later license versions may give you additional or different
585 | permissions.  However, no additional obligations are imposed on any
586 | author or copyright holder as a result of your choosing to follow a
587 | later version.
588 | 
589 |   15. Disclaimer of Warranty.
590 | 
591 |   THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
592 | APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
596 | PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
597 | IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
599 | 
600 |   16. Limitation of Liability.
601 | 
602 |   IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
610 | SUCH DAMAGES.
611 | 
612 |   17. Interpretation of Sections 15 and 16.
613 | 
614 |   If the disclaimer of warranty and limitation of liability provided
615 | above cannot be given local legal effect according to their terms,
616 | reviewing courts shall apply local law that most closely approximates
617 | an absolute waiver of all civil liability in connection with the
618 | Program, unless a warranty or assumption of liability accompanies a
619 | copy of the Program in return for a fee.
620 | 
621 |                      END OF TERMS AND CONDITIONS
622 | 
623 |             How to Apply These Terms to Your New Programs
624 | 
625 |   If you develop a new program, and you want it to be of the greatest
626 | possible use to the public, the best way to achieve this is to make it
627 | free software which everyone can redistribute and change under these terms.
628 | 
629 |   To do so, attach the following notices to the program.  It is safest
630 | to attach them to the start of each source file to most effectively
631 | state the exclusion of warranty; and each file should have at least
632 | the "copyright" line and a pointer to where the full notice is found.
633 | 
634 |     <one line to give the program's name and a brief idea of what it does.>
635 |     Copyright (C) <year>  <name of author>
636 | 
637 |     This program is free software: you can redistribute it and/or modify
638 |     it under the terms of the GNU General Public License as published by
639 |     the Free Software Foundation, either version 3 of the License, or
640 |     (at your option) any later version.
641 | 
642 |     This program is distributed in the hope that it will be useful,
643 |     but WITHOUT ANY WARRANTY; without even the implied warranty of
644 |     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
645 |     GNU General Public License for more details.
646 | 
647 |     You should have received a copy of the GNU General Public License
648 |     along with this program.  If not, see <https://www.gnu.org/licenses/>.
649 | 
650 | Also add information on how to contact you by electronic and paper mail.
651 | 
652 |   If the program does terminal interaction, make it output a short
653 | notice like this when it starts in an interactive mode:
654 | 
655 |     <program>  Copyright (C) <year>  <name of author>
656 |     This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
657 |     This is free software, and you are welcome to redistribute it
658 |     under certain conditions; type `show c' for details.
659 | 
660 | The hypothetical commands `show w' and `show c' should show the appropriate
661 | parts of the General Public License.  Of course, your program's commands
662 | might be different; for a GUI interface, you would use an "about box".
663 | 
664 |   You should also get your employer (if you work as a programmer) or school,
665 | if any, to sign a "copyright disclaimer" for the program, if necessary.
666 | For more information on this, and how to apply and follow the GNU GPL, see
667 | <https://www.gnu.org/licenses/>.
668 | 
669 |   The GNU General Public License does not permit incorporating your program
670 | into proprietary programs.  If your program is a subroutine library, you
671 | may consider it more useful to permit linking proprietary applications with
672 | the library.  If this is what you want to do, use the GNU Lesser General
673 | Public License instead of this License.  But first, please read
674 | <https://www.gnu.org/licenses/why-not-lgpl.html>.
675 | 


--------------------------------------------------------------------------------
/calfw-blocks.el:
--------------------------------------------------------------------------------
   1 | ;;; calfw-blocks.el --- A block view for calfw  -*- lexical-binding: t; -*-
   2 | 
   3 | ;; Copyright (C) 2023, ml729 and Al Haji-Ali
   4 | 
   5 | ;; Author: ml729
   6 | ;; Maintainer: Al Haji-Ali <abdo.haji.ali at gmail.com>
   7 | ;; Created: Author
   8 | ;; Version: 0.0.2
   9 | ;; Package-Requires: ((emacs "28.1") (calfw "2.0"))
  10 | ;; Homepage: https://github.com/haji-ali/maccalfw
  11 | ;; Keywords: calendar
  12 | 
  13 | ;; This program is free software; you can redistribute it and/or modify
  14 | ;; it under the terms of the GNU General Public License as published by
  15 | ;; the Free Software Foundation, either version 3 of the License, or
  16 | ;; (at your option) any later version.
  17 | 
  18 | ;; This program is distributed in the hope that it will be useful,
  19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 | ;; GNU General Public License for more details.
  22 | 
  23 | ;; You should have received a copy of the GNU General Public License
  24 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25 | ;;
  26 | ;;
  27 | ;;; Commentary:
  28 | ;;
  29 | ;; This package provides several views for calfw that show events as blocks.
  30 | ;;
  31 | ;;; Code:
  32 | 
  33 | (require 'calfw)
  34 | (require 'mule-util)  ;; for truncate-string-ellipsis
  35 | 
  36 | 
  37 | (defcustom calfw-blocks-fchar-bottom-right-corner calfw-fchar-right-junction
  38 |   "The character used for drawing the bottom-right corner."
  39 |   :group 'calfw-blocks
  40 |   :type 'character)
  41 | 
  42 | (defcustom calfw-blocks-fchar-bottom-left-corner calfw-fchar-left-junction
  43 |   "The character used for drawing the bottom-left corner."
  44 |   :group 'calfw-blocks
  45 |   :type 'character)
  46 | 
  47 | (defcustom calfw-blocks-fchar-bottom-junction calfw-fchar-junction
  48 |   "The character used for drawing junction lines at the bottom side."
  49 |   :group 'calfw-blocks
  50 |   :type 'character)
  51 | 
  52 | (defcustom calfw-blocks-initial-visible-time '(8 0)
  53 |   "Earliest initial visible time as list (hours minutes)."
  54 |   :group 'calfw-blocks
  55 |   :type 'list)
  56 | 
  57 | (defcustom calfw-blocks-lines-per-hour 4
  58 |   "Number of lines per hour in a block."
  59 |   :group 'calfw-blocks
  60 |   :type 'number)
  61 | 
  62 | (defcustom calfw-blocks-default-event-length 1
  63 |   "Length in hours of events with same start and end time.
  64 | Also used for events with a start time and no end time."
  65 |   :group 'calfw-blocks
  66 |   :type 'number)
  67 | (defcustom calfw-blocks-min-block-width 3
  68 |   "Minimum width of blocks in characters."
  69 |   :group 'calfw-blocks
  70 |   :type 'number)
  71 | 
  72 | (defcustom calfw-blocks-show-time-grid t
  73 |   "Whether to show horizontal lines for each hour."
  74 |   :group 'calfw-blocks
  75 |   :type 'boolean)
  76 | 
  77 | (defcustom calfw-blocks-render-multiday-events 'cont
  78 |   "Whether to render (nonblock) multiday events.
  79 | If \\='cont then render them without splitting into cells."
  80 |   :group 'calfw-blocks
  81 |   :type 'symbol)
  82 | 
  83 | (defcustom calfw-blocks-time-grid-lines-on-top t
  84 |   "Whether time grid lines should cut through vertical lines."
  85 |   :group 'calfw-blocks
  86 |   :type 'boolean)
  87 | 
  88 | 
  89 | (defcustom calfw-blocks-show-current-time-indicator t
  90 |   "Whether to show a line indicating the current time."
  91 |   :group 'calfw-blocks
  92 |   :type 'boolean)
  93 | 
  94 | (defcustom calfw-blocks-grid-line-char (propertize " " 'face 'overline)
  95 |   "Whether time grid lines should cut through vertical lines."
  96 |   :group 'calfw-blocks
  97 |   :type 'boolean)
  98 | 
  99 | (defcustom calfw-blocks-display-end-times t
 100 |   "Whether or not to display end times in blocks."
 101 |   :group 'calfw-blocks
 102 |   :type 'boolean)
 103 | 
 104 | (defcustom calfw-blocks-nonshrinking-hours '(9 . 17)
 105 |   "Which hours to never shrink. If nil, shrink all hours.
 106 | Cons of (START . END), inclusive."
 107 |   :group 'calfw-blocks
 108 |   :type 'list)
 109 | 
 110 | (defcustom calfw-blocks-hour-shrink-size 1
 111 |   "How many lines to leave when shrinking an hour.
 112 | An integer, up to `calfw-blocks-lines-per-hour'.
 113 | If nil or equal `calfw-blocks-lines-per-hour', do not shrink
 114 | hours."
 115 |   :group 'calfw-blocks
 116 |   :type 'list)
 117 | 
 118 | (defcustom calfw-blocks-variable-blocks t
 119 |   "Whether or not to have block with different sizes.
 120 | If non-nil, blocks in shrunk hours will not be expanded. See
 121 | `calfw-blocks-hour-shrink-size' and
 122 | `calfw-blocks-nonshrinking-hours'."
 123 |   :group 'calfw-blocks
 124 |   :type 'list)
 125 | 
 126 | (defcustom calfw-blocks-now-indicator-char
 127 |   (propertize "@"
 128 |               'face
 129 |               'calfw-today-title-face
 130 |               'cfw:current-time-marker t)
 131 |   "A string containing a single character to mark current time."
 132 |   :group 'calfw-blocks
 133 |   :type 'string)
 134 | 
 135 | (defvar calfw-blocks-event-start (char-to-string calfw-fchar-vertical-line)
 136 |   "String to add at beginning of event, if not on cell start.")
 137 | 
 138 | (defvar calfw-blocks-period-left-cont "<"
 139 |   "String to add at start of period which continue left.")
 140 | 
 141 | (defvar calfw-blocks-period-right-cont ">"
 142 |   "String to add  at start of period which continue right.")
 143 | 
 144 | (defvar calfw-blocks-event-keymap nil)
 145 | 
 146 | (defvar calfw-blocks-earliest-visible-time '(0 0)
 147 |   "Earliest visible time in a day as list (hours minutes).")
 148 | 
 149 | 
 150 | (defvar calfw-blocks-posframe-buffer " *cfw-calendar-sticky*")
 151 | (defvar-local calfw-blocks-header-line-string nil)
 152 | 
 153 | (defvar-local calfw-blocks-days-per-view nil
 154 |   "Number of days being in a view.")
 155 | 
 156 | ;; Faces
 157 | (defface calfw-blocks-overline-face
 158 |   '((t (:overline t)))
 159 |   "Basic face for overline."
 160 |   :group 'calfw-blocks)
 161 | 
 162 | (defface calfw-blocks-underline-face
 163 |   '((t (:underline t)))
 164 |   "Basic face for underline."
 165 |   :group 'calfw-blocks)
 166 | 
 167 | (defface calfw-blocks-now-indicator-face
 168 |   '((t (:strike-through "red")))
 169 |   "Face for current time indicator."
 170 |   :group 'calfw-blocks)
 171 | 
 172 | (defface calfw-blocks-past-now-indicator-face
 173 |   '((t (:strike-through "#883333")))
 174 |   "Face for current time indicator."
 175 |   :group 'calfw-blocks)
 176 | 
 177 | (defface calfw-blocks-cancelled-event-face
 178 |   '((t (:strike-through t)))
 179 |   "Face for cancelled events."
 180 |   :group 'calfw-blocks)
 181 | 
 182 | (defface calfw-blocks-cancelled-event-bg-face
 183 |   '((t (:foreground "#777a7d" :background "#393c41")))
 184 |   "Face for cancelled events."
 185 |   :group 'calfw-blocks)
 186 | 
 187 | (defface calfw-blocks-time-column-face
 188 |   '((t))
 189 |   "Face for time column. Also used to identify the column."
 190 |   :group 'calfw-blocks)
 191 | 
 192 | (defface calfw-blocks-time-column-now-face
 193 |   '((t (:inherit calfw-today-title-face)))
 194 |   "Face for time column. Also used to identify the column."
 195 |   :group 'calfw-blocks)
 196 | 
 197 | ;; Block views
 198 | 
 199 | (defun calfw-blocks-view-block-nday-week-model (n model)
 200 |   "[internal] Create a logical view model of weekly calendar.
 201 | This function collects and arranges contents.  This function does
 202 | not know how to display the contents in the destinations."
 203 |   (let* ((init-date (calfw--k 'init-date model))
 204 |          (begin-date (calfw-date-before init-date
 205 |                                       (mod (calfw-days-diff
 206 |                                             (calfw-emacs-to-calendar
 207 |                                              (current-time))
 208 |                                             init-date)
 209 |                                            n)))
 210 |          (end-date (calfw-date-after begin-date (1- n))))
 211 |     (calfw-blocks-view-model-make-common-data-for-nday-weeks n model
 212 |                                                              begin-date
 213 |                                                              end-date)))
 214 | 
 215 | (defun calfw-blocks-view-model-make-common-data-for-nday-weeks (n model begin-date end-date)
 216 |   "[internal] Return a model object for week based views."
 217 |   (calfw--model-create-updated-view-data
 218 |    model
 219 |    (calfw--view-model-make-common-data
 220 |     model begin-date end-date
 221 |     `((headers . ,(calfw-blocks-view-model-make-day-names-for-nday-week n begin-date)) ; a list of the index of day-of-week
 222 |       (weeks . ,(calfw-blocks-view-model-make-nday-weeks ; a matrix of day-of-month, which corresponds to the index of `headers'
 223 |                  n
 224 |                  begin-date
 225 |                  end-date))))))
 226 | 
 227 | (defun calfw-blocks-view-model-make-day-names-for-nday-week (n begin-date)
 228 |   "[internal] Return a list of index of day of the week."
 229 |   (let ((begin-day (calendar-day-of-week begin-date)))
 230 |     (cl-loop for i from 0 below n
 231 |              collect (% (+ begin-day i) calfw-week-days))))
 232 | ;;todo replace calendar week start day with day of the week of init date
 233 | 
 234 | (defun calfw-blocks-view-model-make-nday-weeks (n begin-date end-date)
 235 |   "[internal] Return a list of weeks those have 7 days."
 236 |   (let* ((first-day-day (calendar-day-of-week begin-date)) weeks)
 237 |     (cl-loop with i = begin-date
 238 |              with day = first-day-day
 239 |              with week = nil
 240 |              do
 241 |              ;; flush a week
 242 |              (when (and (= 0 (mod (- day first-day-day) n)) week)
 243 |                (push (nreverse week) weeks)
 244 |                (setq week nil)
 245 |                (when (calfw-date-less-equal-p end-date i) (cl-return)))
 246 |              ;; add a day
 247 |              (push i week)
 248 |              ;; increment
 249 |              (setq day (% (1+ day) n))
 250 |              (setq i (calfw-date-after i 1)))
 251 |     (nreverse weeks)))
 252 | 
 253 | (defun calfw-blocks-view-nday-week-calc-param (n dest)
 254 |   "[internal] Calculate cell size from the reference size and
 255 | return an alist of rendering parameters."
 256 |   (let*
 257 |       ((time-width 5)
 258 |        (time-hline (make-string time-width ? ))
 259 |        (win-width (calfw-dest-width dest))
 260 |        ;; title 2, toolbar 1, header 2, hline 2, footer 1, margin 2 => 10
 261 |        ;; (win-height (max 15 (- (calfw-dest-height dest) 10)))
 262 |        (junctions-width (* (char-width calfw-fchar-junction) (1+ n)))
 263 |        (cell-width  (calfw--round-cell-width
 264 |                      (max 5 (/ (- win-width junctions-width time-width) n))))
 265 |        (cell-height (* calfw-blocks-lines-per-hour 24))
 266 |        (total-width (+ time-width (* cell-width n) junctions-width)))
 267 |     `((cell-width . ,cell-width)
 268 |       (cell-height . ,cell-height)
 269 |       (total-width . ,total-width)
 270 |       (columns . ,n)
 271 |       (time-width . ,time-width)
 272 |       (time-hline . ,time-hline))))
 273 | 
 274 | (defun calfw-blocks-view-block-day (component)
 275 |   (calfw-blocks-view-block-nday-week 1 component))
 276 | 
 277 | (defun calfw-blocks-view-block-2-day (component)
 278 |   (calfw-blocks-view-block-nday-week 2 component))
 279 | 
 280 | (defun calfw-blocks-view-block-3-day (component)
 281 |   (calfw-blocks-view-block-nday-week 3 component))
 282 | 
 283 | (defun calfw-blocks-view-block-4-day (component)
 284 |   (calfw-blocks-view-block-nday-week 4 component))
 285 | 
 286 | (defun calfw-blocks-view-block-5-day (component)
 287 |   (calfw-blocks-view-block-nday-week 5 component))
 288 | 
 289 | (defun calfw-blocks-view-block-7-day (component)
 290 |   (calfw-blocks-view-block-nday-week 7 component))
 291 | 
 292 | 
 293 | (defun calfw-blocks-view-block-week (component)
 294 |   (calfw-blocks-view-block-nday-week 7 component
 295 |                                      (calfw--view-week-model
 296 |                                       (calfw-component-model component))))
 297 | 
 298 | ;; Rendering views
 299 | 
 300 | (defun calfw-blocks-view-block-nday-week (n component &optional model)
 301 |   "[internal] Render weekly calendar view."
 302 |   (let* ((dest (calfw-component-dest component))
 303 |          (param (calfw--render-append-parts
 304 |                  (calfw-blocks-view-nday-week-calc-param n dest)))
 305 |          (total-width (calfw--k 'total-width param))
 306 |          (time-width (calfw--k 'time-width param))
 307 |          (EOL (calfw--k 'eol param))
 308 |          (VL (calfw--k 'vl param))
 309 |          (time-hline (calfw--k 'time-hline param))
 310 |          (hline (concat time-hline (calfw--k 'hline param)))
 311 |          (cline (concat time-hline (calfw--k 'cline param)))
 312 |          (model (if model
 313 |                     model
 314 |                   (calfw-blocks-view-block-nday-week-model
 315 |                    n (calfw-component-model component))))
 316 |          (begin-date (calfw--k 'begin-date model))
 317 |          (end-date (calfw--k 'end-date model))
 318 |          day-of-week-names)
 319 |     (setq-local calfw-blocks-days-per-view n)
 320 |     ;; (print model)
 321 |     ;; update model
 322 |     (setf (calfw-component-model component) model)
 323 |     (setq day-of-week-names
 324 |           (cl-loop
 325 |            with date = begin-date
 326 |            for i in (calfw--k 'headers model)
 327 |            with VL = (calfw--k 'vl param) with cell-width = (calfw--k 'cell-width param)
 328 |            concat
 329 |            (concat VL (calfw--tp
 330 |                        (calfw--render-center
 331 |                         cell-width
 332 |                         (concat
 333 |                          (calfw--rt
 334 |                           (calendar-day-name date t)
 335 |                           (calfw--render-get-week-face i 'calfw-header-face))
 336 |                          " "
 337 |                          (calfw--rt
 338 |                           (format "%s%d"
 339 |                                   (if (= (calendar-extract-month date)
 340 |                                          (calendar-extract-month begin-date))
 341 |                                       ""
 342 |                                     (format "%d/" (calendar-extract-month date)))
 343 |                                   (calendar-extract-day date))
 344 |                           (if (equal (calendar-current-date) date)
 345 |                               'calfw-today-title-face
 346 |                             (calfw--render-get-week-face i 'calfw-header-face)))))
 347 |                        'cfw:date date))
 348 |            do
 349 |            (setq date  (calfw-date-after date 1))))
 350 | 
 351 |     (setq calfw-blocks-header-line-string
 352 |           (concat "  "
 353 |                   (calendar-month-name (calendar-extract-month begin-date) t)
 354 |                   " "
 355 |                   day-of-week-names))
 356 |     (setq header-line-format '((:eval
 357 |                                 (if (< (line-number-at-pos (window-start)) 6)
 358 |                                     ""
 359 |                                   calfw-blocks-header-line-string))))
 360 | 
 361 |     ;; header
 362 |     (insert
 363 |      "\n"
 364 |      (calfw--rt
 365 |       (calfw-render-title-period begin-date end-date)
 366 |       'calfw-title-face)
 367 |      EOL (calfw-blocks-render-toolbar total-width
 368 |                                       (calfw-component-view component)
 369 |                                       (calfw-blocks-navi-previous-nday-week-command n)
 370 |                                       (calfw-blocks-navi-next-nday-week-command n))
 371 |      EOL hline)
 372 |     ;; time header
 373 |     (insert (calfw--rt (calfw--render-right time-width "    ")
 374 |                     'default))
 375 |     ;; day names
 376 |     (insert day-of-week-names)
 377 |     (insert VL EOL cline)
 378 |     ;; contents
 379 |     (calfw-blocks-render-calendar-cells-block-weeks
 380 |      model param
 381 |      (lambda (date week-day hday)
 382 |        (calfw--rt (format "%s" (calendar-extract-day date))
 383 |                (if hday 'calfw-sunday-face
 384 |                  (calfw--render-get-week-face
 385 |                   week-day 'calfw-default-day-face)))))
 386 |     ;; footer
 387 |     (insert (calfw--render-footer total-width (calfw--model-get-contents-sources model)))))
 388 | 
 389 | 
 390 | (defun calfw-blocks-compare-time (t1 t2)
 391 |   "Return +1 if T2>T1, -1 if not and 0 if equal."
 392 |   (if (equal t1 t2) 0
 393 |     (cl-destructuring-bind ((a1 b1) (a2 b2)) (list t1 t2)
 394 |       (if (or (< a1 a2)
 395 |               (and (= a1 a2) (< b1 b2)))
 396 |           +1
 397 |         -1))))
 398 | 
 399 | (defun calfw-blocks--next-prop (pt prop dir)
 400 |   "Get the next position where PROP is set.
 401 | Start at PT and go in DIR. Returns a cons of the point and the
 402 | value of the property."
 403 |   (let ((search-fn (if (> dir 0)
 404 |                        #'next-single-property-change
 405 |                      #'previous-single-property-change))
 406 |         prop-value)
 407 |     (while (and pt
 408 |                 (null
 409 |                  (setq prop-value
 410 |                        (get-text-property pt prop))))
 411 |       (setq pt (funcall search-fn pt prop)))
 412 |     (when pt
 413 |       (cons pt prop-value))))
 414 | 
 415 | (defun calfw-blocks-navi-goto-next-event (dir)
 416 |   "Move the cursor forward to next event if visible.
 417 | DIR has to be either 1 or -1 (for previous instead of next)."
 418 |   (interactive (list 1))
 419 |   ;; Get current date and time from cursor.
 420 |   ;; Search for next block with cfw:event
 421 |   ;; If have the same date and future start time, stop
 422 |   ;; Otherwise continue until next.
 423 |   ;; If none found, then allow for future day.
 424 |   (cl-flet ((col-at-pt (lambda (pos) (save-excursion (goto-char pos)
 425 |                                                      (current-column)))))
 426 |     (let* ((search-fn (if (> dir 0)
 427 |                           #'next-single-property-change
 428 |                         #'previous-single-property-change))
 429 |            (reverse-search-fn (if (< dir 0)
 430 |                                   #'next-single-property-change
 431 |                                 #'previous-single-property-change))
 432 |            (cmp-fn (if (> dir 0) #'> #'<))
 433 |            (time-fn (if (> dir 0) #'calfw-event-start-time #'calfw-event-end-time))
 434 |            (component (calfw-cp-get-component))
 435 |            (dest (calfw-component-dest component))
 436 |            (model (calfw-component-model component))
 437 |            ;;;
 438 |            (cur-pt (point))
 439 |            (point-ev (get-text-property cur-pt 'cfw:event))
 440 |            (point-date (when point-ev
 441 |                          (calfw-event-start-date point-ev)))
 442 |            search-for-periods
 443 |            ;;
 444 |            (continue t)
 445 |            time-cmp cur-ev point-col)
 446 |       ;; First move back to beginning of event
 447 |       (when-let (tmp (calfw-blocks--next-prop cur-pt 'cfw:event dir))
 448 |         (setq search-for-periods (get-text-property (car tmp) 'cfw:period)))
 449 | 
 450 |       (when (and (not search-for-periods)
 451 |                  point-ev
 452 |                  (eq point-ev (get-text-property (- cur-pt dir) 'cfw:event)))
 453 |         (setq cur-pt (funcall reverse-search-fn cur-pt 'cfw:event))
 454 |         (if (< dir 1)
 455 |             ;; Go back a smidge to have the same event
 456 |             (setq cur-pt (1- cur-pt))))
 457 | 
 458 |       (setq point-date
 459 |             (or point-date
 460 |                 (cdr (calfw-blocks--next-prop cur-pt 'cfw:date dir))))
 461 | 
 462 |       (when (and point-date cur-pt)
 463 |         (setq point-col (col-at-pt cur-pt))
 464 |         (while continue
 465 |           (if (setq cur-pt
 466 |                     (funcall search-fn cur-pt 'cfw:event))
 467 |               (when (and (setq cur-ev (get-text-property cur-pt 'cfw:event))
 468 |                          (not (eq point-ev cur-ev))
 469 |                          (equal
 470 |                           point-date
 471 |                           (calfw-event-start-date cur-ev))
 472 |                          (eq (get-text-property cur-pt 'cfw:period)
 473 |                              search-for-periods))
 474 |                 (when (or
 475 |                        search-for-periods
 476 |                        (null point-ev)
 477 |                        (funcall cmp-fn
 478 |                                 (setq time-cmp (calfw-blocks-compare-time
 479 |                                                 (funcall time-fn point-ev)
 480 |                                                 (funcall time-fn cur-ev)))
 481 |                                 0) ;; POINT is before CUR
 482 |                        (and (eq time-cmp 0)
 483 |                             (funcall cmp-fn (col-at-pt cur-pt) point-col)))
 484 |                   ;; Future and different event on the same day
 485 |                   ;; stop search.
 486 |                   (setq continue nil)))
 487 |             (setq point-date (calfw-date-after point-date dir))
 488 |             (if (calfw-cp-displayed-date-p component point-date)
 489 |                 (progn
 490 |                   (setq cur-pt (calfw-blocks-find-by-date dest point-date dir)
 491 |                         point-ev nil
 492 |                         point-col (col-at-pt cur-pt))
 493 |                   ;; If already on event, then stop search
 494 |                   (when (and (get-text-property cur-pt 'cfw:event)
 495 |                              (eq search-for-periods
 496 |                                  (get-text-property cur-pt 'cfw:period)))
 497 |                     (setq continue nil)))
 498 |               ;; Next day is not visible, stop search?
 499 |               (cond
 500 |                ((and (< dir 0) (not search-for-periods))
 501 |                 (setq search-for-periods t
 502 |                       point-date (calfw--k 'end-date model)
 503 |                       cur-pt (calfw-dest-point-max dest)
 504 |                       point-col (col-at-pt cur-pt)
 505 |                       point-ev nil))
 506 |                ((and (> dir 0) search-for-periods)
 507 |                 (setq search-for-periods nil
 508 |                       point-date (calfw--k 'begin-date model)
 509 |                       cur-pt (calfw-dest-point-min dest)
 510 |                       point-col (col-at-pt cur-pt)
 511 |                       point-ev nil))
 512 |                (t
 513 |                 (setq continue nil
 514 |                       cur-pt nil)))))))
 515 |       ;; If we have a pt, move to it
 516 |       (if (and cur-pt
 517 |                (get-text-property cur-pt 'cfw:event))
 518 |           (progn
 519 |             (goto-char cur-pt)
 520 |             (recenter))
 521 |         (user-error "No more events in view")))))
 522 | 
 523 | (defun calfw-blocks-find-by-date (dest date dir)
 524 |   "[internal] Return a point where the text property `calfw-date'
 525 | is equal to DATE in the current calender view. If DATE is not
 526 | found in the current view, return nil."
 527 |   (cl-loop
 528 |    with rev = (< dir 0)
 529 |    with pos = (funcall (if rev 'calfw-dest-point-max 'calfw-dest-point-min) dest)
 530 |    with end = (funcall (if rev 'calfw-dest-point-min 'calfw-dest-point-max) dest)
 531 |    for next = (funcall
 532 |                (if rev 'previous-single-property-change
 533 |                  'next-single-property-change)
 534 |                pos 'cfw:date nil end)
 535 |    for text-date = (and next (calfw--cursor-to-date next))
 536 |    while next do
 537 |    (if (and text-date (equal date text-date))
 538 |        (cl-return next))
 539 |    (setq pos next)))
 540 | 
 541 | (defun calfw-blocks-navi-goto-previous-event ()
 542 |   "Move the cursor forward to previous event if visible."
 543 |   (interactive)
 544 |   (calfw-blocks-navi-goto-next-event -1))
 545 | 
 546 | (defmacro calfw-blocks-perserve-buffer-view (&rest body)
 547 |   "Preserve view in current buffer before executing BODY.
 548 | View includes the point, the scroll position. If
 549 | `calfw-blocks-perserve-buffer-view' is bound and nil, then view
 550 | is not perserved."
 551 |   (declare (indent 1) (debug t))
 552 |   `(let* ((wind (get-buffer-window (current-buffer)))
 553 |           (prev-point (point))
 554 |           (prev-window-start (when wind (window-start wind))))
 555 |      (unwind-protect
 556 |          (progn
 557 |            ,@body)
 558 |        (goto-char prev-point)
 559 |        (when wind
 560 |          (set-window-start wind prev-window-start)))))
 561 | 
 562 | (defun calfw-blocks-perserve-buffer-view-advice (old-fn &rest args)
 563 |   (calfw-blocks-perserve-buffer-view
 564 |       (apply old-fn args)))
 565 | 
 566 | (defun calfw-blocks-navi-next-view-command (&optional num)
 567 |   "Move the cursor forward NUM of views. If NUM is nil, 1 is used.
 568 | Moves backward if NUM is negative."
 569 |   (interactive "p")
 570 |   (calfw-blocks-perserve-buffer-view
 571 |       (calfw-navi-next-day-command (* calfw-blocks-days-per-view
 572 |                                     (or num 1)))))
 573 | 
 574 | (defun calfw-blocks-navi-previous-view-command (&optional num)
 575 |   "Move the cursor back NUM of views. If NUM is nil, 1 is used.
 576 | Moves forward if NUM is negative."
 577 |   (interactive "p")
 578 |   (calfw-blocks-perserve-buffer-view
 579 |       (calfw-navi-next-day-command (* (- calfw-blocks-days-per-view)
 580 |                                     (or num 1)))))
 581 | 
 582 | (defun calfw-blocks--cfw-refresh-calendar-buffer (no-resize)
 583 |   "Clear the calendar and render again.
 584 | With prefix arg NO-RESIZE, don't fit calendar to window size."
 585 |   (interactive "P")
 586 |   (calfw-blocks-perserve-buffer-view
 587 |       (let ((cp (calfw-cp-get-component)))
 588 |         (when cp
 589 |           (unless no-resize
 590 |             (calfw-cp-resize cp (window-width) (window-height)))
 591 |           (cl-loop for s in (calfw-cp-get-contents-sources cp t)
 592 |                    for f = (calfw-source-update s)
 593 |                    if f do (funcall f))
 594 |           (cl-loop for s in (calfw-cp-get-annotation-sources cp)
 595 |                    for f = (calfw-source-update s)
 596 |                    if f do (funcall f))
 597 |           (calfw--cp-update cp)))))
 598 | 
 599 | 
 600 | (defun calfw-blocks-navi-goto-now ()
 601 |   "Move the cursor to today."
 602 |   (interactive)
 603 |   (calfw-navi-goto-date (calfw-emacs-to-calendar (current-time)))
 604 |   (goto-char (point-min))
 605 |   (text-property-search-forward 'cfw:current-time-marker t)
 606 |   (recenter))
 607 | 
 608 | (defun calfw-blocks-navi-next-nday-week-command (n)
 609 |   "Move the cursor forward NUM weeks. If NUM is nil, 1 is used.
 610 | Moves backward if NUM is negative."
 611 |   (lambda (&optional num)
 612 |     (interactive "p")
 613 |     (calfw-navi-next-day-command (* n (or num 1)))))
 614 | 
 615 | (defun calfw-blocks-navi-previous-nday-week-command (n)
 616 |   "Move the cursor back NUM weeks. If NUM is nil, 1 is used.
 617 | Moves forward if NUM is negative."
 618 |   (lambda (&optional num)
 619 |     (interactive "p")
 620 |     (calfw-navi-next-day-command (* (- n) (or num 1)))))
 621 | 
 622 | (defvar calfw-blocks-toolbar-views
 623 |   '(("Day" . block-day)
 624 |     ("3-Day" . block-3-day)
 625 |     ("Week" . block-week)
 626 |     ("Two Week" . two-weeks)
 627 |     ("Month" . month)))
 628 | 
 629 | (defun calfw-blocks-render-toolbar (width current-view prev-cmd next-cmd)
 630 |   "[internal] Return a text of the toolbar.
 631 | 
 632 | WIDTH is width of the toolbar. CURRENT-VIEW is a symbol of the
 633 | current view type. This symbol is used to select the button faces
 634 | on the toolbar. PREV-CMD and NEXT-CMD are the moving view
 635 | command, such as `cfw:navi-previous(next)-month-command' and
 636 | `cfw:navi-previous(next)-week-command'."
 637 |   (let* ((prev (calfw--render-button " < " prev-cmd))
 638 |          (today (calfw--render-button "Today" 'calfw-navi-goto-today-command))
 639 |          (next (calfw--render-button " > " next-cmd))
 640 |          (sp  " ")
 641 |          (toolbar-text
 642 |           (calfw--render-add-right
 643 |            width (concat sp prev sp next sp today sp)
 644 |            (cl-loop for (title . view) in calfw-blocks-toolbar-views
 645 |                     for fn = (let ((view view)) ;; Enable lexical-binding
 646 |                                (lambda ()
 647 |                                  (interactive)
 648 |                                  (calfw-cp-set-view (calfw-cp-get-component)
 649 |                                                   view)))
 650 |                     concat
 651 |                     (calfw--render-button
 652 |                      title
 653 |                      fn
 654 |                      (eq current-view view))
 655 |                     concat
 656 |                     sp))))
 657 |     (calfw--render-default-content-face toolbar-text 'calfw-toolbar-face)))
 658 | 
 659 | (let ((lexical-binding t))
 660 |   (cl-loop for a from 0 to 5
 661 |            collect (let ((a a))
 662 |                      (lambda nil a))))
 663 | 
 664 | (defun calfw-blocks-render-calendar-cells-block-weeks (model param title-func)
 665 |   "[internal] Insert calendar cells for week based views."
 666 |   (cl-loop for week in (calfw--k 'weeks model) do
 667 |            ;; (setq week (list (nth 4 week)))
 668 |            ;; (print week)
 669 |            (calfw-blocks-render-calendar-cells-days model param title-func week
 670 |                                                     'calfw-blocks-render-content
 671 |                                                     t)))
 672 | 
 673 | (defun calfw-blocks-default-sorter (x y)
 674 |   "Default sorter for events in calfw-blocks.
 675 | Using this function to sort by start time first."
 676 |   (if-let ((ev-x (get-text-property 0 'cfw:event x))
 677 |            (ev-y (get-text-property 0 'cfw:event y)))
 678 |       (> (calfw-blocks-compare-time (calfw-event-start-time ev-x)
 679 |                                     (calfw-event-start-time ev-y))
 680 |          0)
 681 |     (string-lessp x y)))
 682 | 
 683 | (defun calfw-blocks-render-default-content-face (str &optional default-face)
 684 |   "[internal] Put the default content face. If STR has some
 685 | faces, the faces are remained."
 686 |   (cl-loop
 687 |            with ret = (substring str 0)
 688 |    for i from 0 below (length str)
 689 |    for face = (or default-face
 690 |                            (calfw-blocks--status-face str 'background)
 691 |                            (calfw--render-get-face-content
 692 |                             str 'calfw-default-content-face))
 693 |            unless (get-text-property i 'face ret)
 694 |            do
 695 |            (put-text-property i (1+ i) 'face face ret)
 696 |            (put-text-property i (1+ i) 'font-lock-face face ret)
 697 |            finally return ret))
 698 | 
 699 | (defun calfw-blocks-model-get-contents-by-date (date model)
 700 |   "Return a list of contents on the DATE."
 701 |   ;; This is the same as `calfw-model-get-contents-by-date'
 702 |   ;; excepts that it returns content if they are overlap with DATE
 703 |   ;; rather than being precisely on DATE
 704 |   (let ((contents (calfw--k 'contents model)))
 705 |     (cond
 706 |      ((or (null date) (null contents)) nil)
 707 |      (t
 708 |       (cl-loop for i in contents
 709 |                nconc
 710 |                (cl-loop for j in (cdr i)
 711 |                         for start-date = (calfw-event-start-date j)
 712 |                         for end-date = (calfw-event-end-date j)
 713 |                         if (if (null end-date)
 714 |                                (equal date (car i))
 715 |                              (calfw-date-between start-date end-date date))
 716 |                         collect j))))))
 717 | 
 718 | (defun calfw-blocks-render-calendar-cells-days (model param title-func &optional
 719 |                                                       days content-fun do-weeks)
 720 |   "[internal] Insert calendar cells for the linear views."
 721 |   (let*
 722 |       ((min-hour (or (car-safe calfw-blocks-nonshrinking-hours) 0))
 723 |        (max-hour (or (cdr-safe calfw-blocks-nonshrinking-hours) 23))
 724 |        (day-columns
 725 |         (cl-loop with cell-width      = (calfw--k 'cell-width param)
 726 |                  ;; with show-times      = (make-vector 24 nil)
 727 |                  with days            = (or days (calfw--k 'days model))
 728 |                  with content-fun     = (or content-fun
 729 |                                             'calfw--render-event-days-overview-content)
 730 |                  with holidays        = (calfw--k 'holidays model)
 731 |                  with annotations     = (calfw--k 'annotations model)
 732 |                  with headers         = (calfw--k 'headers  model)
 733 |                  with raw-periods-all = (calfw-blocks-render-periods-stacks model)
 734 |                  with sorter          = (calfw-model-get-sorter model)
 735 |                  for date in days ; days columns loop
 736 |                  for count from 0 below (length days)
 737 |                  for hday         = (car (calfw--contents-get date holidays))
 738 |                  ;; for hday = (if (stringp hday) (list hday) hday)
 739 |                  ;; for prs-hday = (if hday (mapcar (lambda (h) (calfw--rt h 'calfw-holiday-face)) hday))
 740 |                  for week-day     = (nth (% count 7) headers)
 741 |                  for ant          = (calfw--rt (calfw--contents-get date annotations)
 742 |                                             'calfw-annotation-face)
 743 |                  for raw-periods  = (calfw--contents-get date raw-periods-all)
 744 |                  for cfw-contents = (calfw-blocks-model-get-contents-by-date
 745 |                                      ;; calfw-model-get-contents-by-date
 746 |                                      date model)
 747 |                  do (cl-loop
 748 |                      with min-block = (* min-hour calfw-blocks-lines-per-hour)
 749 |                      with max-block = (* max-hour calfw-blocks-lines-per-hour)
 750 |                      for evnt in cfw-contents
 751 |                      for pos = (if (or
 752 |                                     calfw-blocks-variable-blocks
 753 |                                     (equal (calfw-event-start-date evnt)
 754 |                                            (calfw-event-end-date evnt)))
 755 |                                    (calfw-blocks--get-block-vertical-position
 756 |                                 nil evnt)
 757 |                                  ;; If the start/end dates are not equal, we
 758 |                                  ;; need to expand the whole timeline
 759 |                                  (list 0 (* 24 calfw-blocks-lines-per-hour)))
 760 |                              do
 761 |                      (let ((start (car pos))
 762 |                            (end (cadr pos)))
 763 |                        (unless (and calfw-blocks-variable-blocks
 764 |                                     (eq (mod start
 765 |                                              calfw-blocks-lines-per-hour)
 766 |                                         0))
 767 |                          (setq min-block (min min-block start))
 768 |                          (setq max-block (max max-block start)))
 769 |                        (unless (and
 770 |                                 calfw-blocks-variable-blocks
 771 |                                 (eq
 772 |                                  (mod end
 773 |                                       calfw-blocks-lines-per-hour)
 774 |                                  (1- calfw-blocks-lines-per-hour)))
 775 |                          (setq min-block (min min-block end))
 776 |                          (setq max-block (max max-block end))))
 777 |                      finally
 778 |                      (setq min-hour
 779 |                            (min min-hour
 780 |                                 (floor (/ min-block
 781 |                                           (float calfw-blocks-lines-per-hour))))
 782 |                            max-hour
 783 |                            (max max-hour
 784 |                                 (1-
 785 |                                  (ceiling (/ max-block
 786 |                                              (float calfw-blocks-lines-per-hour)))))))
 787 |                  for raw-contents = (sort (funcall content-fun cfw-contents) sorter)
 788 |                  for prs-contents = (append (if do-weeks
 789 |                                                 (calfw-blocks-render-periods
 790 |                                                  date raw-periods cell-width model)
 791 |                                               (calfw-blocks-render-periods-days
 792 |                                                date raw-periods cell-width))
 793 |                                             (mapcar 'calfw-blocks-render-default-content-face
 794 |                                                     raw-contents))
 795 |                  for num-label = (if prs-contents
 796 |                                      (format "(%s)"
 797 |                                              (+ (length raw-contents)
 798 |                                                 (length raw-periods))) "")
 799 |                  for tday = (concat
 800 |                              " " ; margin
 801 |                              (funcall title-func date week-day hday)
 802 |                              (if num-label (concat " " num-label))
 803 |                              (if hday (concat " " (calfw--rt (substring hday 0)
 804 |                                                           'calfw-holiday-face))))
 805 |                  collect
 806 |                  (cons date (cons (cons tday ant) prs-contents)))))
 807 |     (calfw-blocks-render-columns day-columns (cons min-hour max-hour) param)))
 808 | 
 809 | 
 810 | (defun calfw-blocks-render-periods-days (date periods-stack cell-width)
 811 |   "[internal] Insert period texts.
 812 | Modified to not truncate events. TODO"
 813 |   (when periods-stack
 814 |     (let ((stack (sort (copy-sequence periods-stack)
 815 |                        (lambda (a b) (< (car a) (car b))))))
 816 |       (cl-loop for (_ (begin end content)) in stack
 817 |                for beginp = (equal date begin)
 818 |                for endp = (equal date end)
 819 |                for width = (- cell-width 2)
 820 |                for title = (calfw--render-truncate
 821 |                             (concat
 822 |                              (calfw-strtime begin) " - "
 823 |                              (calfw-strtime end) " : "
 824 |                              content) width t)
 825 |                collect
 826 |                (if content
 827 |                    (calfw--rt
 828 |                     (concat
 829 |                      (if beginp "(" " ")
 830 |                      (calfw--render-left width title ?-)
 831 |                      (if endp ")" " "))
 832 |                     (calfw--render-get-face-period content 'calfw-periods-face))
 833 |                  "")))))
 834 | 
 835 | 
 836 | (defun calfw-blocks-render-periods-stacks (model)
 837 |   "Modified version of calfw--render-periods-stacks, where the last element of
 838 | period is a pair containing the start and end of time of each event.
 839 | [internal] Arrange the `periods' records of the model and
 840 | create period-stacks on the each days.
 841 | period-stack -> ((row-num . period) ... )"
 842 |   (let* (periods-each-days)
 843 |     (cl-loop for (begin end event) in (calfw--k 'periods model)
 844 |              for content = (if (calfw-event-p event)
 845 |                                ;; (calfw-event-period-overview event)
 846 |                                (propertize
 847 |                                 (calfw-event-period-overview event)
 848 |                                 'cfw:event event)
 849 |                              event)
 850 |              for period = (list begin end content
 851 |                                 (calfw--extract-text-props content 'face)
 852 |                                 (if (calfw-event-p event) (calfw-blocks-get-time-interval event) nil))
 853 |              for row = (calfw--render-periods-get-min periods-each-days begin end)
 854 |              do
 855 |              (setq periods-each-days (calfw--render-periods-place
 856 |                                       periods-each-days row period)))
 857 |     periods-each-days))
 858 | 
 859 | (defun calfw-blocks-get-time-interval (event)
 860 |   "Return (start-time . end-time) of EVENT, a `cfw:event' struct.
 861 | start-time and end-time are both lists (a b) where a is the hour,
 862 | b is the minute."
 863 |   (when (calfw-event-start-time event)
 864 |     (cons (calfw-event-start-time event)
 865 |           (calfw-event-end-time event))))
 866 | 
 867 | (defun calfw-blocks-render-content (lst)
 868 |   "[internal] Apply `calfw-event-overview' on `cfw:event's in `lst'."
 869 |   (mapcar (lambda (event)
 870 |             (if (calfw-event-p event)
 871 |                 (progn
 872 |                   (propertize
 873 |                    (calfw-event-overview event)
 874 |                    'calfw-blocks-interval (calfw-blocks-get-time-interval event)
 875 |                    'cfw:event event))
 876 |               event))
 877 |           lst))
 878 | 
 879 | (defun calfw-blocks-render-periods (date periods-stack cell-width model)
 880 |   "[internal] This function translates PERIOD-STACK to display content on the DATE."
 881 |   (seq-filter
 882 |    'identity
 883 |    (mapcar (lambda (p)
 884 |              (let* ((content (nth 2 (cadr p)))
 885 |                     (face (calfw--render-get-face-period content 'calfw-periods-face))
 886 |                     (props (append
 887 |                             (list
 888 |                              'keymap calfw-blocks-event-keymap
 889 |                              'cfw:period t
 890 |                              'cfw:row-count (car p)
 891 |                              'face (cons
 892 |                                     'calfw-blocks-overline-face
 893 |                                     face)
 894 |                              'font-lock-face face)
 895 |                             (nth 3 (cadr p))))
 896 |                     (interval (nth 4 (cadr p)))
 897 |                     (begintime (if interval (calfw-blocks-format-time (car interval))))
 898 |                     (endtime (if interval (calfw-blocks-format-time (cdr interval)))))
 899 |                (if (or interval (get-text-property 0 'calfw-blocks-interval content)
 900 |                        (not calfw-blocks-render-multiday-events))
 901 |                    (apply 'propertize
 902 |                           (if (and calfw-blocks-display-end-times
 903 |                                    begintime
 904 |                                    (string= (substring content 0 5) begintime))
 905 |                               (concat begintime "-" endtime (substring content 5))
 906 |                             content)
 907 |                           'calfw-blocks-interval interval
 908 |                           props)
 909 |                  (if (eq calfw-blocks-render-multiday-events 'cont)
 910 |                      (let* ((begin (nth 0 (cadr p)))
 911 |                             (begin-date (calfw--k 'begin-date model))
 912 |                             (beginp (or (equal date begin)
 913 |                                         (and
 914 |                                          (equal date begin-date)
 915 |                                          (< (calendar-absolute-from-gregorian begin)
 916 |                                             (calendar-absolute-from-gregorian begin-date))))))
 917 |                        (when beginp
 918 |                          (let* ((end (nth 1 (cadr p)))
 919 |                                 (end-date (calfw--k 'end-date model))
 920 |                                 (len (1+ (min (calfw-days-diff begin end)
 921 |                                               (calfw-days-diff begin end-date)
 922 |                                               (calfw-days-diff begin-date end)
 923 |                                               (calfw-days-diff begin-date
 924 |                                                                end-date))))
 925 |                                 (left (if (> (calfw-days-diff begin begin-date) 0)
 926 |                                           calfw-blocks-period-left-cont
 927 |                                         ""))
 928 |                                 (right
 929 |                                  (if (> (calfw-days-diff end-date end) 0)
 930 |                                      calfw-blocks-period-right-cont
 931 |                                    "")))
 932 |                            (apply 'propertize
 933 |                                   (concat
 934 |                                    (calfw--render-left
 935 |                                     (+ (1- len) (* len cell-width)
 936 |                                        (- (length right)))
 937 |                                     (concat left content)
 938 |                                     ? )
 939 |                                    right)
 940 |                                   'cfw:cell-span len
 941 |                                   props))))
 942 |                    (let* ((begin (nth 0 (cadr p)))
 943 |                           (end (nth 1 (cadr p)))
 944 |                           (beginp (equal date begin))
 945 |                           (endp (equal date end))
 946 |                           (width (- cell-width
 947 |                                     (if beginp (length calfw-fstring-period-start) 0)
 948 |                                     (if endp (length calfw-fstring-period-end) 0)))
 949 |                           (title (calfw-blocks-render-periods-title
 950 |                                   date begin end content
 951 |                                   (- cell-width
 952 |                                      (if beginp 1 0)
 953 |                                      (if endp 1 0))
 954 |                                   model)))
 955 |                      (apply 'propertize (concat
 956 |                                          (when beginp calfw-fstring-period-start)
 957 |                                          (calfw--render-left width title ? )
 958 |                                          (when endp calfw-fstring-period-end))
 959 |                             props))))))
 960 |            (seq-sort
 961 |             (lambda (a b) (< (car a) (car b)))
 962 |             periods-stack))))
 963 | 
 964 | (defun calfw-blocks-render-periods-title (date begin end content
 965 |                                                cell-width model)
 966 |   "[internal] Return a title string.
 967 | 
 968 | Fix erroneous width in last line, should be fixed upstream in calfw."
 969 |   (let* ((title-begin-abs
 970 |           (max (calendar-absolute-from-gregorian begin)
 971 |                (calendar-absolute-from-gregorian (calfw--k 'begin-date model))))
 972 |          ;;(title-begin (calendar-gregorian-from-absolute title-begin-abs))
 973 |          (num (- (calendar-absolute-from-gregorian date) title-begin-abs)))
 974 |     (when content
 975 |       (cl-loop with title = (substring content 0)
 976 |                for i from 0 below num
 977 |                for pdate = (calendar-gregorian-from-absolute (+ title-begin-abs i))
 978 |                for chopn = (+ (if (equal begin pdate) 1 0) (if (equal end pdate) 1 0))
 979 |                for del = (truncate-string-to-width title (- cell-width chopn))
 980 |                do
 981 |                (setq title (substring title (length del)))
 982 |                finally return
 983 |                (calfw--render-truncate title cell-width (equal end date))))))
 984 | 
 985 | 
 986 | (defun calfw-blocks-format-time (time-obj)
 987 |   (format "%02d:%02d" (car time-obj) (cadr time-obj)))
 988 | 
 989 | (defun calfw-blocks-time-column (cell-height)
 990 |   (let* ((num-hours (floor (/ cell-height calfw-blocks-lines-per-hour)))
 991 |          (start-hour (car calfw-blocks-earliest-visible-time))
 992 |          (start-minute (cadr calfw-blocks-earliest-visible-time)))
 993 |     (cl-loop for x from 0 below num-hours
 994 |              collect
 995 |              (propertize
 996 |               (calfw-blocks-format-time
 997 |                (list (mod (+ x start-hour) 24) start-minute))
 998 |               'face 'calfw-blocks-time-column-face)
 999 |              append
1000 |              (make-list (- calfw-blocks-lines-per-hour 1) nil))))
1001 | 
1002 | (defun calfw-blocks-render-columns (day-columns hour-interval param)
1003 |   "[internal] Concatenate rows on the days into a string of a physical line.
1004 | 
1005 | DAY-COLUMNS is a list of columns. A column is a list of following
1006 | form: (DATE (DAY-TITLE . ANNOTATION-TITLE) STRING STRING...).
1007 | HOUR-INTERVAL is a cons (START . END). Hours outside this
1008 | interval are hidden."
1009 |   (let* ((cell-width  (calfw--k 'cell-width  param))
1010 |          (cell-height (calfw--k 'cell-height param))
1011 |          (time-width (calfw--k 'time-width param))
1012 |          (EOL (calfw--k 'eol param))
1013 |          (VL (calfw--k 'vl param))
1014 |          (time-hline (calfw--k 'time-hline param))
1015 |          ;;(hline (concat time-hline (calfw--k 'hline param)))
1016 |          ;;(cline (concat time-hline (calfw--k 'cline param)))
1017 |          (bline (concat time-hline
1018 |                         (let* ((EOL "\n")
1019 |                                (cell-width (calfw--k 'cell-width param))
1020 |                                (columns (calfw--k 'columns param))
1021 |                                (num-cell-char
1022 |                                 (/ cell-width (char-width calfw-fchar-horizontal-line))))
1023 |                           (calfw--rt
1024 |                            (concat
1025 |                             (cl-loop
1026 |                              for i from 0 below columns
1027 |                              concat
1028 |                              (concat
1029 |                               (make-string
1030 |                                1 (if (= i 0)
1031 |                                      calfw-blocks-fchar-bottom-left-corner
1032 |                                    calfw-blocks-fchar-bottom-junction))
1033 |                               (make-string
1034 |                                num-cell-char
1035 |                                calfw-fchar-horizontal-line)))
1036 |                             (make-string
1037 |                              1 calfw-blocks-fchar-bottom-right-corner)
1038 |                             EOL)
1039 |                            'calfw-grid-face))))
1040 |          (earliest-date (caar day-columns)))
1041 |     (cl-loop with breaked-all-day-columns =
1042 |              (cl-loop for day-rows in day-columns
1043 |                       for (date _ . lines) = day-rows
1044 |                       collect
1045 |                       (cons date (calfw-blocks-render-all-day-events
1046 |                                   lines cell-width cell-height)))
1047 |              with all-day-columns-height = ;;(seq-max (mapcar 'length
1048 |              (seq-max (mapcar (lambda (x)
1049 |                                 (max
1050 |                                  (1- (length x))
1051 |                                  (seq-max
1052 |                                   (or (mapcar
1053 |                                        (lambda (y)
1054 |                                          (1+
1055 |                                           (or (get-text-property
1056 |                                                0 'cfw:row-count y)
1057 |                                               -1)))
1058 |                                        (cdr x))
1059 |                                       '(0)))))
1060 |                               breaked-all-day-columns))
1061 |              with breaked-all-day-rows-padded =
1062 |              (calfw-blocks--pad-and-transpose all-day-columns-height
1063 |                                               breaked-all-day-columns)
1064 |              for dates = (mapcar 'car breaked-all-day-columns)
1065 |              for i from 0 below all-day-columns-height do
1066 |              (insert (calfw--render-left time-width ""))
1067 |              for row = (car breaked-all-day-rows-padded)
1068 |              do
1069 |              (setq breaked-all-day-rows-padded (cdr breaked-all-day-rows-padded))
1070 |              (cl-loop
1071 |               with cur-cell = 0
1072 |               for cell in row
1073 |               for cell-span = (or (get-text-property 0 'cfw:cell-span cell) 1)
1074 |               for date = (nth cur-cell dates)
1075 |               do
1076 |               (setq cur-cell (+ cur-cell cell-span))
1077 |               (insert
1078 |                (if (and calfw-blocks-show-time-grid
1079 |                         calfw-blocks-time-grid-lines-on-top
1080 |                         (= (mod i calfw-blocks-lines-per-hour) 0)
1081 |                         (string= cell (make-string cell-width ?-))
1082 |                         (not (eq date earliest-date)))
1083 |                    ?-
1084 |                  VL)
1085 |                (calfw--tp
1086 |                 (calfw--render-separator
1087 |                  (calfw--render-left (+ (1- cell-span)
1088 |                                      (* cell-span cell-width))
1089 |                                   (and cell (format "%s" cell))))
1090 |                 'cfw:date date)))
1091 |              (insert VL EOL))
1092 |     ;; Need to figure out which times should be hidden and which should not
1093 |     ;; here.
1094 |     (cl-loop with breaked-day-columns =
1095 |              (cl-loop for day-rows in day-columns
1096 |                       for (date _ . lines) = day-rows
1097 |                       collect
1098 |                       (cons date (calfw-blocks-render-event-blocks
1099 |                                   date
1100 |                                   hour-interval
1101 |                                   lines cell-width cell-height)))
1102 |              with curr-time-linum = (calfw-blocks--current-time-vertical-position)
1103 |              with time-columns = (calfw-blocks-time-column cell-height)
1104 |              for i from 1 to cell-height
1105 |              for time = (prog1 (car time-columns)
1106 |                           (setq time-columns (cdr time-columns)))
1107 |              for curVL = (if time
1108 |                              (let ((VL-copy (substring VL)))
1109 |                                (add-face-text-property
1110 |                                 0 (length VL)
1111 |                                 'calfw-blocks-overline-face
1112 |                                 t
1113 |                                 VL-copy)
1114 |                                VL-copy)
1115 |                            VL)
1116 |              for today = (calendar-current-date)
1117 |              for today-shown = (cl-some
1118 |                                 'identity
1119 |                                 (cl-loop for day-rows in breaked-day-columns
1120 |                                          for date = (car day-rows)
1121 |                                          collect
1122 |                                          (equal date today)))
1123 |              for cur-hour = (/ (1- i) calfw-blocks-lines-per-hour)
1124 |              for shrunk-hour = (and calfw-blocks-hour-shrink-size
1125 |                                     (or (< cur-hour (car hour-interval))
1126 |                                         (> cur-hour (cdr hour-interval))))
1127 |              for show-cur-time = (and
1128 |                                   calfw-blocks-show-current-time-indicator
1129 |                                   today-shown
1130 |                                   (= (1- i)
1131 |                                      (if shrunk-hour
1132 |                                          ;; If hour is shrunk, make sure
1133 |                                          ;; current time is displayed on the
1134 |                                          ;; an visible appropriate
1135 |                                          (let ((start (* (/ curr-time-linum
1136 |                                                             calfw-blocks-lines-per-hour)
1137 |                                                          calfw-blocks-lines-per-hour)))
1138 |                                            (+ start
1139 |                                               (floor
1140 |                                                (* (/ (- curr-time-linum start)
1141 |                                                      (float calfw-blocks-lines-per-hour))
1142 |                                                   calfw-blocks-hour-shrink-size))))
1143 |                                        curr-time-linum)))
1144 |              for final-line
1145 |              = (apply #'concat
1146 |                       (append
1147 |                        (list
1148 |                         (progn
1149 |                           (when show-cur-time
1150 |                             (setq time (calfw-blocks-format-time
1151 |                                         (let ((curr-time (decode-time (current-time))))
1152 |                                           (list (nth 2 curr-time)
1153 |                                                 (nth 1 curr-time)))))
1154 |                             (add-face-text-property
1155 |                              0 (length time) 'calfw-blocks-time-column-now-face
1156 |                              t time))
1157 |                           (calfw--render-left time-width time)))
1158 |                        (cl-loop for day-rows in breaked-day-columns
1159 |                                 for date = (car day-rows)
1160 |                                 for row = (nth i day-rows)
1161 |                                 for segment =
1162 |                                 (concat
1163 |                                  (if (and calfw-blocks-show-time-grid
1164 |                                           calfw-blocks-time-grid-lines-on-top
1165 |                                           (= (mod (1- i) calfw-blocks-lines-per-hour) 0)
1166 |                                           (string= row (make-string cell-width ?-))
1167 |                                           (not (eq date earliest-date)))
1168 |                                      ?-
1169 |                                    (if (and show-cur-time (equal date today))
1170 |                                        calfw-blocks-now-indicator-char
1171 |                                      curVL))
1172 |                                  (calfw--tp
1173 |                                   (calfw--render-separator
1174 |                                    (calfw--render-left cell-width (and row (format "%s" row))))
1175 |                                   'cfw:date date))
1176 |                                 do
1177 |                                 (when show-cur-time
1178 |                                   (add-face-text-property
1179 |                                    0 (length segment)
1180 |                                    (if (calfw-date-less-equal-p today date)
1181 |                                        'calfw-blocks-now-indicator-face
1182 |                                      'calfw-blocks-past-now-indicator-face)
1183 |                                    t segment))
1184 |                                 collect segment)
1185 |                        (list curVL EOL)))
1186 |              do
1187 |              ;; (when show-cur-time
1188 |              ;;   (add-face-text-property
1189 |              ;;    time-width (length final-line) 'calfw-blocks-now-indicator-face
1190 |              ;;    t final-line))
1191 |              (when (and shrunk-hour
1192 |                         (> (mod (1- i) calfw-blocks-lines-per-hour)
1193 |                            (1- calfw-blocks-hour-shrink-size)))
1194 |                (add-text-properties 0 (length final-line) '(invisible t)
1195 |                                     final-line))
1196 |              (insert final-line))
1197 |     (insert bline)))
1198 | 
1199 | (defun calfw-blocks--pad-and-transpose (max-len columns)
1200 |   "Return the columns as rows, padded with space when needed"
1201 |   (let* ((col-count (length columns)))
1202 |     (prog1
1203 |         (cl-loop for i from 0 below max-len  ;; Loop over rows
1204 |                  for filled-cells = 0
1205 |                  for rows = (cl-loop
1206 |                              for c being the elements of columns using (index j)
1207 |                              for cols = (cdr c)
1208 |                              when (<= filled-cells j)
1209 |                              if cols
1210 |                              collect
1211 |                              (let* ((col (car cols))
1212 |                                     (on-row (>= i
1213 |                                                 (or (get-text-property
1214 |                                                      0 'cfw:row-count col)
1215 |                                                     i)))
1216 |                                     (cell-span (or (get-text-property
1217 |                                                     0 'cfw:cell-span col)
1218 |                                                    1)))
1219 |                                (if on-row
1220 |                                    (progn
1221 |                                      (setq filled-cells (+ filled-cells
1222 |                                                            cell-span))
1223 |                                      (setcdr c (cdr cols))
1224 |                                      col)
1225 |                                  ;; If (< filled-cells col-count)
1226 |                                  ;; then we need to skip
1227 |                                  (setq filled-cells (+ filled-cells 1))
1228 |                                  ""))
1229 |                              else
1230 |                              collect
1231 |                              (progn
1232 |                                (setq filled-cells (+ filled-cells 1))
1233 |                                "")
1234 |                              end)
1235 |                  collect
1236 |                  (append rows (make-list (- col-count filled-cells) "")))
1237 |       ;; Assert that all columns are moved into rows
1238 |       (cl-assert (not (cl-some (lambda (x) (cdr x)) columns))))))
1239 | 
1240 | 
1241 | ;; Interval helper functions
1242 | 
1243 | (defun calfw-blocks--interval-member? (elem a)
1244 |   "Return t iff ELEM is within interval A."
1245 |   (and (< elem (cadr a)) (>= elem (car a))))
1246 | 
1247 | (defun calfw-blocks--interval-intersect? (a b)
1248 |   "Return t iff intervals A and B intersect.
1249 | Return nil otherwise. Ain interval [a1, a2) is represented as a
1250 | list (a1 a2)."
1251 |   (or (calfw-blocks--interval-member? (car a) b)
1252 |       (calfw-blocks--interval-member? (car b) a)))
1253 | 
1254 | (defun calfw-blocks--interval-intersection (a b)
1255 |   "Compute intersection of intervals A and B.
1256 | An interval [a1, a2) is represented as a list (a1 a2).
1257 | Return nil if intersection is empty."
1258 |   (if (calfw-blocks--interval-intersect? a b)
1259 |       (let ((start (max (car a) (car b)))
1260 |             (end (min (cadr a) (cadr b))))
1261 |         (list start end))))
1262 | 
1263 | (defun calfw-blocks--interval-subtract-many (a lst)
1264 |   "Return interval(s) resulting from removing intervals in LST from A.
1265 | Assume that all intervals in lst are disjoint and subsets of A."
1266 |   (let* ((lst (seq-sort (lambda (x y) (< (car x) (car y))) lst))
1267 |          (endpoints (append (list (car a))
1268 |                             (calfw-flatten lst)
1269 |                             (list (cadr a))))
1270 |          (intervals nil))
1271 |     (while endpoints
1272 |       (let ((start (pop endpoints))
1273 |             (end (pop endpoints)))
1274 |         (if (< start end)
1275 |             (push (list start end) intervals))))
1276 |     (reverse intervals)))
1277 | 
1278 | (defun calfw-blocks--interval-distribute (lst n)
1279 |   "Return N intervals of approx equal size, whose union is the union of LST."
1280 |   (let* ((lst (seq-sort (lambda (x y) (> (- (cadr x) (car x))
1281 |                                          (- (cadr y) (car y)))) lst))
1282 |          (lst-lengths (mapcar (lambda (x) (- (cadr x) (car x))) lst))
1283 |          (avg-len (/ (seq-reduce '+ lst-lengths 0) (float n)))
1284 |          (intervals nil))
1285 |     (while (and lst (< (length intervals) n))
1286 |       (let* ((l (pop lst))
1287 |              (l-len (float (- (cadr l) (car l))))
1288 |              (num-intervals
1289 |               (if (not lst)
1290 |                   (- n (length intervals))
1291 |                 (min (round (/ l-len avg-len))
1292 |                      (- n (length intervals)))))
1293 |              (l-inner-len (/ l-len num-intervals)))
1294 |         ;; (print num-intervals)
1295 |         (dolist (i (number-sequence 0 (1- num-intervals)))
1296 |           (let ((start
1297 |                  (+ (car l)
1298 |                     (if (= i 0)
1299 |                         (floor (* i l-inner-len))
1300 |                       (round (* i l-inner-len)))))
1301 |                 (end
1302 |                  (+ (car l)
1303 |                     (if (= i (1- num-intervals))
1304 |                         (ceiling (* (1+ i) l-inner-len))
1305 |                       (round (* (1+ i) l-inner-len))))))
1306 |             (push (list start end) intervals)))))
1307 |     (seq-sort (lambda (a b) (< (car a) (car b))) intervals)))
1308 | 
1309 | ;; Calculate block sizes and positions
1310 | 
1311 | (defun calfw-blocks--get-intersection-groups (lines-lst)
1312 |   "Return a list of groups of overlapping events in LINES-LST.
1313 | 
1314 | Each group is a cons pair of the form (intersection . indices).
1315 | The first element is the intersection of all vertical position
1316 | intervals of the events in the group, represented as a list
1317 | containing the start and end of the interval. The second element
1318 | is a list of indices (into the original list LINES-LST)
1319 | corresponding to the elements of the group."
1320 |   (let* ((groups '())
1321 |          (prev-line-indices '()))
1322 |     (dotimes (i (length lines-lst))
1323 |       (let* ((i-interval (nth 1 (nth i lines-lst)))
1324 |              (i-intersects-indices '())
1325 |              (i-group (cons i-interval (list i))))
1326 |         (dolist (g groups)
1327 |           (when (and (calfw-blocks--interval-intersect? (car g) i-interval)
1328 |                      (not (member i (cdr g))))
1329 |             (dolist (elem (cdr g)) (push elem i-intersects-indices))
1330 |             (setcdr g (cons i (cdr g)))
1331 |             (setcar g (calfw-blocks--interval-intersection (car g) i-interval))))
1332 |         (dolist (j prev-line-indices)
1333 |           (let ((j-interval (nth 1 (nth j lines-lst))))
1334 |             (when (and (not (member j i-intersects-indices))
1335 |                        (calfw-blocks--interval-intersect? i-interval j-interval))
1336 |               (setcdr i-group (reverse (cons j (reverse (cdr i-group)))))
1337 |               (setcar i-group (calfw-blocks--interval-intersection (car i-group) j-interval)))))
1338 |         (if (not (and i-intersects-indices
1339 |                       (= 1 (length (cdr i-group)))))
1340 |             (push i-group groups)))
1341 |       (push i prev-line-indices))
1342 |     (seq-sort (lambda (a b)
1343 |                 (let ((a-size (length (cdr a)))
1344 |                       (b-size (length (cdr b))))
1345 |                   (if (= a-size b-size)
1346 |                       (< (caar a) (caar b))
1347 |                     (> a-size b-size))))
1348 |               groups)))
1349 | 
1350 | 
1351 | (defun calfw-blocks--get-block-positions (date lines cell-width)
1352 |   "Return LINES with assigned vertical and horizontal positions.
1353 | 
1354 | Each element of the list is a list (event vertical-pos
1355 | horizontal-pos). The vertical-pos and horizontal-pos are both
1356 | half open intervals represented as two element lists, containing
1357 | the start (inclusive) and the end (exclusive). The vertical-pos
1358 | is in unit lines, the horizontal-pos is in unit characters. Both
1359 | positions are given relative to the calendar cell the event
1360 | resides in, which has width CELL-WIDTH.
1361 | 
1362 | The vertical positions represent the time of day the event
1363 | occurs. The horizontal positions are assigned to display
1364 | concurrent events side by side. If there is not enough space for
1365 | all blocks to have width at least `calfw-blocks-min-block-width'
1366 | then some events are not displayed, and an indicator for how many
1367 | events are not displayed is shown."
1368 |   (let* ((lines-lst
1369 |           (seq-sort (lambda (x y) (>= (car (nth 1 x))
1370 |                                       (car (nth 1 y))))
1371 |                     (mapcar (lambda (x)
1372 |                               (list x
1373 |                                     (calfw-blocks--get-block-vertical-position
1374 |                                      date
1375 |                                      (get-text-property 0 'cfw:event x))))
1376 |                             lines)))
1377 |          (groups (calfw-blocks--get-intersection-groups lines-lst))
1378 |          (new-lines-lst nil)
1379 |          (added-indices nil))
1380 |     (dolist (g groups)
1381 |       (let* ((taken-intervals (seq-map (lambda (x) (nth 2 (cdr x)))
1382 |                                        (seq-filter (lambda (x)
1383 |                                                      (and (member (car x) added-indices)
1384 |                                                           (calfw-blocks--interval-intersect? (nth 1 (cdr x)) (car g))))
1385 |                                                    new-lines-lst)))
1386 |              (lines-left-in-group (- (length (cdr g)) (length taken-intervals)))
1387 |              (remaining-intervals (calfw-blocks--interval-subtract-many `(0 ,cell-width) taken-intervals))
1388 |              (remaining-intervals-length (cl-reduce '+ (mapcar (lambda (x) (- (cadr x) (car x))) remaining-intervals)))
1389 |              (exceeded-cell-width (and (> lines-left-in-group 0)
1390 |                                        (< (/ remaining-intervals-length lines-left-in-group) calfw-blocks-min-block-width)))
1391 |              (truncated-lines-left-in-group (if exceeded-cell-width (floor (/ remaining-intervals-length calfw-blocks-min-block-width))
1392 |                                               lines-left-in-group))
1393 |              (lines-left-out (- lines-left-in-group truncated-lines-left-in-group))
1394 |              (distributed-intervals (calfw-blocks--interval-distribute remaining-intervals truncated-lines-left-in-group)))
1395 |         (dolist (x (cdr g))
1396 |           (when (not (member x added-indices))
1397 |             (when (and exceeded-cell-width
1398 |                        (= (length distributed-intervals) 1))
1399 |               (let* ((x-vertical-pos (nth 1 (nth x lines-lst)))
1400 |                      (exceeded-indicator (list (propertize (format "+%dmore" lines-left-out) 'calfw-blocks-exceeded-indicator t)
1401 |                                                (list (nth 0 x-vertical-pos)
1402 |                                                      (max 4 (nth 1 x-vertical-pos)))
1403 |                                                (pop distributed-intervals))))
1404 |                 (push (cons -1 exceeded-indicator) new-lines-lst)))
1405 |             (if (= 0 (length distributed-intervals))
1406 |                 (push x added-indices)
1407 |               (let* ((new-line (append (nth x lines-lst) (list (pop distributed-intervals)))))
1408 |                 (push (cons x new-line) new-lines-lst)
1409 |                 (push x added-indices)))))))
1410 |     (mapcar 'cdr new-lines-lst)))
1411 | 
1412 | 
1413 | (defun calfw-blocks-round-start-time (time)
1414 |   (round time))
1415 | 
1416 | (defun calfw-blocks-round-end-time (time)
1417 |   (round time))
1418 | 
1419 | (defun calfw-blocks-hours-per-line ()
1420 |   (/ 1.0 calfw-blocks-lines-per-hour))
1421 | 
1422 | (defun calfw-blocks--time-pair-to-float (p)
1423 |   (+ (car p) (/ (cadr p) 60.0)))
1424 | 
1425 | (defun calfw-blocks--get-float-time-interval (date event)
1426 |   (let* ((interval (calfw-blocks-get-time-interval event))
1427 |          (start-date (calfw-event-start-date event))
1428 |          (end-date (calfw-event-end-date event))
1429 |          ;; (start (calfw-blocks--time-pair-to-float (car interval)))
1430 |          ;; (end (calfw-blocks--time-pair-to-float (cdr interval)))
1431 |          )
1432 |     (list
1433 |      (calfw-blocks--time-pair-to-float
1434 |       (if (or (null date)
1435 |               (equal start-date date))
1436 |           (car interval)
1437 |         ;; Should've started in an earlier date
1438 |         '(0 0)))
1439 |      (calfw-blocks--time-pair-to-float
1440 |       (if (or
1441 |            (null date)
1442 |            (null end-date)
1443 |               (equal end-date date))
1444 |           (cdr interval)
1445 |         ;; Should end in a later date
1446 |         '(23 59))))))
1447 | 
1448 | (defun calfw-blocks--get-block-vertical-position (date event)
1449 |   "[inclusive, exclusive)"
1450 |   (let* ((float-interval (calfw-blocks--get-float-time-interval date event))
1451 |          (start-time (calfw-blocks--time-pair-to-float
1452 |                       calfw-blocks-earliest-visible-time))
1453 |          ;; (minutes-per-line (/ 60 calfw-blocks-lines-per-hour))
1454 |          (interval-start (car float-interval))
1455 |          (interval-end (if (= interval-start (cadr float-interval))
1456 |                            (+ calfw-blocks-default-event-length interval-start)
1457 |                          (cadr float-interval))))
1458 |     (list (calfw-blocks-round-start-time (* calfw-blocks-lines-per-hour
1459 |                                             (- interval-start start-time)))
1460 |           (calfw-blocks-round-end-time (* calfw-blocks-lines-per-hour
1461 |                                           (- interval-end start-time))))))
1462 | 
1463 | (defun calfw-blocks--current-time-vertical-position ()
1464 |   "Returns vertical position of current time, starting from 0."
1465 |   (let* ((start-time (calfw-blocks--time-pair-to-float
1466 |                       calfw-blocks-earliest-visible-time))
1467 |          (curr-time (decode-time (current-time)))
1468 |          (curr-hour (nth 2 curr-time))
1469 |          (curr-min (nth 1 curr-time))
1470 |          (time-float (+ curr-hour (/ curr-min 60.0))))
1471 |     (truncate (* calfw-blocks-lines-per-hour (- time-float start-time)))))
1472 | 
1473 | (defun calfw-blocks-point-to-time (&optional end-time)
1474 |   "Return the timestamp corresponding to point.
1475 | If in time row, return (MONTH DAY YEAR HOUR MINUTE). If not in a
1476 | time row, return (MONTH DAY YEAR). Return nil if no date on point."
1477 |   (let* ((line-start (save-excursion
1478 |                        (min
1479 |                         (progn (goto-char (point-min))
1480 |                                (text-property-search-forward
1481 |                                 'face 'calfw-blocks-time-column-face)
1482 |                                (line-number-at-pos))
1483 |                         (progn (goto-char (point-min))
1484 |                                (text-property-search-forward
1485 |                                 'face 'calfw-blocks-time-column-now-face)
1486 |                                (line-number-at-pos)))))
1487 |          (cur-line (and line-start
1488 |                         (- (line-number-at-pos) line-start)))
1489 |          (date (calfw--cursor-to-date))
1490 |          (min-per-line (/ 60 calfw-blocks-lines-per-hour))
1491 |          (starting-min (+ (* 60 (car calfw-blocks-earliest-visible-time))
1492 |                           (cadr calfw-blocks-earliest-visible-time)))
1493 |          (minutes (if (> cur-line 0)
1494 |                       (+ starting-min
1495 |                          (* min-per-line
1496 |                             (+ (if end-time 1 0) cur-line)))
1497 |                     0)))
1498 |     (when date
1499 |       (if (>= cur-line 0)
1500 |           (append date
1501 |                   (list (/ minutes 60)
1502 |                         (% minutes 60)))
1503 |         date))))
1504 | 
1505 | (defun calfw-blocks-time-to-line-number (hour minute)
1506 |   "Return the line number corresponding to hour/minute."
1507 |   (let* ((line-start (save-excursion
1508 |                        (min
1509 |                         (progn (goto-char (point-min))
1510 |                                (text-property-search-forward
1511 |                                 'face 'calfw-blocks-time-column-face)
1512 |                                (line-number-at-pos))
1513 |                         (progn (goto-char (point-min))
1514 |                                (text-property-search-forward
1515 |                                 'face 'calfw-blocks-time-column-now-face)
1516 |                                (line-number-at-pos)))))
1517 |          (min-per-line (/ 60 calfw-blocks-lines-per-hour))
1518 |          ;; (starting-min (+ (* 60 (car calfw-blocks-earliest-visible-time))
1519 |          ;;                  (cadr calfw-blocks-earliest-visible-time)))
1520 |          (minutes (+ (* hour 60) minute)))
1521 |     (+ line-start
1522 |        (floor (/ minutes min-per-line)))))
1523 | 
1524 | (defun calfw-blocks-region-to-time ()
1525 |   "Return time corresponding to region.
1526 | Return a list \\=(START END ALL-DAY-P)
1527 | where START is the encoded time corresponding to
1528 | `region-beginning', END is encoded time corresponding to
1529 | `region-end' or nil if region is inactive and ALL-DAY-P is t if
1530 | the region is not in the time section of the calendar."
1531 |   (save-excursion
1532 |     (cl-destructuring-bind
1533 |         (reg-begin &optional reg-end)
1534 |         (if (region-active-p) (list (region-beginning) (region-end))
1535 |           (list (point)))
1536 |       (let* ((time-start
1537 |               (or (progn (goto-char reg-begin)
1538 |                          (unless (calfw--cursor-to-date)
1539 |                            ;; If not on date, go to next one
1540 |                            (goto-char
1541 |                             (or (next-single-property-change
1542 |                                  (point)
1543 |                                  'cfw:date
1544 |                                  nil
1545 |                                  (line-end-position))
1546 |                                 (point-max))))
1547 |                          (calfw-blocks-point-to-time))
1548 |                   (user-error "No date around point")))
1549 |              (time-end (when reg-end
1550 |                          (progn (goto-char reg-end)
1551 |                                 (unless (calfw--cursor-to-date)
1552 |                                   (goto-char
1553 |                                    ;; If not on date, go to previous one
1554 |                                    (or (previous-single-property-change
1555 |                                         (point)
1556 |                                         'cfw:date
1557 |                                         (line-beginning-position))
1558 |                                        (point-min))))
1559 |                                 (calfw-blocks-point-to-time t))))
1560 |              (all-day-p (or (<= (length time-start) 3)
1561 |                             (and time-end (<= (length time-end) 3)))))
1562 |         (list (cl-destructuring-bind
1563 |                   (month day year &optional (hour 0) (minute 0)) time-start
1564 |                 (encode-time (list 0 minute hour day month year)))
1565 |               (when time-end
1566 |                 (cl-destructuring-bind
1567 |                     (month day year &optional (hour 0) (minute 0)) time-end
1568 |                   (encode-time (list 0 minute hour day month year))))
1569 |               all-day-p)))))
1570 | 
1571 | (defun calfw-blocks-generalized-substring (s start end props)
1572 |   (cond ((<= end (length s)) (substring s start end))
1573 |         ((< start (length s)) (concat (substring s start (length s))
1574 |                                       (apply
1575 |                                        #'propertize
1576 |                                        (make-string (- (- end start) (- (length s) start)) ? )
1577 |                                        props)))
1578 |         (t (apply
1579 |             #'propertize
1580 |             (make-string (- end start) ? )
1581 |             props))))
1582 | 
1583 | 
1584 | (defun calfw-blocks--wrap-text (width max-lines &optional word-break)
1585 |   (goto-char (point-min))
1586 |   (while (and (< (point) (point-max))
1587 |               (> max-lines 1))
1588 |     (let* ((forward-by (min width (- (point-max) (point))))
1589 |            (counter forward-by)
1590 |            (word-break (or word-break "-"))
1591 |            prev-point
1592 |            is-whitespace
1593 |            (whitespaces '(?\s ?\t ?\n))
1594 |            c)
1595 |       (forward-char forward-by)
1596 |       (setq prev-point (point))
1597 |       (unless (eobp)
1598 |         (if (or (null (setq c (char-after)))
1599 |                 (member c whitespaces))
1600 |             (progn (when c
1601 |                      (forward-char))
1602 |                    (setq is-whitespace t))
1603 |           (while (not (or (= (setq counter (1- counter)) 0)
1604 |                           (null (setq c (char-before)))
1605 |                           (setq is-whitespace
1606 |                                 (member c whitespaces))))
1607 |             (backward-char)))
1608 |         ;; If not whitespace, but the character immediately after is then just
1609 |         ;; advance
1610 |         (when (and is-whitespace
1611 |                    (> (- prev-point (point)) 1))
1612 |           ;; Find if next space is within width
1613 |           ;; Otherwise, might as well hard-break at this
1614 |           ;; point
1615 |           (let* ((pt (point))
1616 |                  (forward-by (min width (- (point-max) (point))))
1617 |                  (counter forward-by)
1618 |                  is-white)
1619 |             (forward-char)
1620 |             (while (not (or (= (setq counter (1- counter)) 0)
1621 |                             (null (setq c (char-before)))
1622 |                             (setq is-white
1623 |                                   (member c whitespaces))))
1624 |               (forward-char))
1625 |             (if (or (eobp) is-white)
1626 |                 (goto-char pt) ;; It's fine to break there
1627 |               ;; Just break the word
1628 |               (goto-char (1- prev-point))
1629 |               (setq is-whitespace nil))))
1630 |         ;;
1631 |         (if is-whitespace
1632 |             (delete-char -1)
1633 |           ;; hard break
1634 |           (goto-char (1- prev-point))
1635 |           (insert word-break))
1636 |         (insert ?\n)
1637 |         (setq max-lines (1- max-lines))))))
1638 | 
1639 | (defun calfw-blocks--wrap-string (text width max-lines &optional word-break)
1640 |   "Wrap TEXT to a fixed WIDTH without breaking words."
1641 |   ;; Doesn't work with \n in text
1642 |   (with-temp-buffer
1643 |     (insert text)
1644 |     (calfw-blocks--wrap-text width max-lines word-break)
1645 |     (buffer-string)))
1646 | 
1647 | (defun calfw-blocks--to-lines (text width max-lines help-text)
1648 |   "Wrap TEXT to a fixed WIDTH without breaking words.
1649 | Add HELP-TEXT in case the string is truncated."
1650 |   ;; Doesn't work with \n in text
1651 |   (let* ((lines (split-string text "\n"))
1652 |          (line-n (1- (min max-lines (length lines))))
1653 |          (last-line (nth line-n lines))
1654 |          ellips)
1655 |     (when (or
1656 |            (> (length lines) max-lines)
1657 |            (> (length last-line) width))
1658 |       ;; The concat is there to avoid adding properties to
1659 |       ;; (truncate-string-ellipsis) !!
1660 |       (setq ellips (concat (truncate-string-ellipsis) ""))
1661 |       (add-text-properties
1662 |        0 (length ellips)
1663 |        (text-properties-at (1- (length last-line))
1664 |                            last-line)
1665 |        ellips)
1666 |       (setf (nth line-n lines)
1667 |             (concat
1668 |              (substring
1669 |               last-line
1670 |               0
1671 |               (- (min (length last-line) width)
1672 |                  (length ellips)))
1673 |              ellips))
1674 |       (cl-loop for l in lines do
1675 |                (add-text-properties
1676 |                 0 (length l)
1677 |                 (list 'help-echo help-text)
1678 |                 l)))
1679 |     lines))
1680 | 
1681 | (defun calfw-blocks--remove-unicode-chars (str)
1682 |   "Remove any Unicode characters from INPUT-STRING."
1683 |   (cl-loop
1684 |    ;; TODO: Make sure that str maintains its properties.
1685 |    for char across str
1686 |    if (and (>= char 16) (<= char 127))
1687 |    concat (string char)))
1688 | 
1689 | (defun calfw-blocks--status-face (text &optional background)
1690 |   (let* ((event (get-text-property 0 'cfw:event text)))
1691 |     (when event
1692 |     (cl-case (calfw-event-status event)
1693 |       (cancelled (if background
1694 |                      'calfw-blocks-cancelled-event-bg-face
1695 |                      'calfw-blocks-cancelled-event-face))))))
1696 | 
1697 | (defun calfw-blocks-split-single-block (date hour-interval block)
1698 |   "Split event BLOCK into lines of width CELL-WIDTH.
1699 | 
1700 | BLOCK is expected to contain elements of the form (event
1701 | vertical-pos horizontal-pos). Event is a string, vertical-pos and
1702 | horizontal-pos are two element lists representing half open
1703 | intervals. See `calfw-blocks--get-block-positions' for more
1704 | details about vertical-pos and horizontal-pos.
1705 | 
1706 | BLOCK-INTERVAL is a const (START . END). Lines outside this
1707 | interval are assumed to be of height
1708 | `calfw-blocks-hour-shrink-size'.
1709 | 
1710 | An overline is added to the first line of an event block. A character
1711 | is added at the beginning of a block to indicate it is the beginning."
1712 |   (let* ((block-string (car block))
1713 |          (event (get-text-property 0 'cfw:event block-string))
1714 |          (start-date (calfw-event-start-date event))
1715 |          (end-date (calfw-event-end-date event))
1716 |          (block-vertical-pos (cadr block))
1717 |          (block-horizontal-pos (caddr block))
1718 |          (block-width (- (cadr block-horizontal-pos) (car block-horizontal-pos)))
1719 |          intervals
1720 |          (block-height
1721 |           (if calfw-blocks-variable-blocks
1722 |               (progn
1723 |                 (setq intervals
1724 |                       (let* ((x (car block-vertical-pos))
1725 |                              (y (cadr block-vertical-pos))
1726 |                              (w (* (car hour-interval) calfw-blocks-lines-per-hour))
1727 |                              (z (* (1+ (cdr hour-interval)) calfw-blocks-lines-per-hour)))
1728 |                         (let* ((a (max x (min w y)))
1729 |                                (b (min y (max z x)))
1730 |                                (factor (/ calfw-blocks-lines-per-hour
1731 |                                           calfw-blocks-hour-shrink-size)))
1732 |                           (append
1733 |                            (make-list (ceiling (/ (max (- a x) 0)
1734 |                                                   (float calfw-blocks-lines-per-hour)))
1735 |                                       factor)
1736 |                            (make-list (max (- b a) 0) 1)
1737 |                            (make-list (ceiling (/ (max (- y b) 0)
1738 |                                                   (float calfw-blocks-lines-per-hour)))
1739 |                                       factor)))))
1740 |                 (length intervals))
1741 |             (- (cadr block-vertical-pos) (car block-vertical-pos))))
1742 |          (text-height (or
1743 |                        (car-safe (cdddr block))
1744 |                        block-height))
1745 |          ;; (end-of-cell (= (cadr block-horizontal-pos) cell-width))
1746 |          (is-beginning-of-cell (= (car block-horizontal-pos) 0))
1747 |          (block-width-adjusted (if is-beginning-of-cell block-width
1748 |                                  (- block-width
1749 |                                     (string-width calfw-blocks-event-start))))
1750 |          (props (cl-copy-seq (text-properties-at (1- (length block-string)) block-string)))
1751 |          (block-lines (calfw-blocks--to-lines
1752 |                        (calfw-blocks--wrap-string
1753 |                         ;; TODO: Figure out a way to remove unicode characters
1754 |                         ;; while preserving text properties
1755 |                         ;;
1756 |                         ;; (calfw-blocks--remove-unicode-chars block-string)
1757 |                         ;; TODO: Adjust text/faces based on status, state (if
1758 |                         ;; tentative) and if recurring (add a symbol)
1759 |                         (prog1
1760 |                             block-string
1761 |                           (add-face-text-property 0 (length block-string)
1762 |                                                   (calfw-blocks--status-face
1763 |                                                    block-string)
1764 |                                                   t block-string))
1765 |                         block-width-adjusted
1766 |                         text-height ;;block-height
1767 |                         (apply 'propertize "-" props))
1768 |                        block-width-adjusted
1769 |                        block-height
1770 |                        (substring-no-properties block-string)))
1771 |          (rendered-block '())
1772 |          (is-exceeded-indicator (get-text-property
1773 |                                  0 'calfw-blocks-exceeded-indicator
1774 |                                  block-string))
1775 |          tmp (cnt 0))
1776 |     (dolist (i (number-sequence 0 (- block-height 1)))
1777 |       (push (list (+ (car block-vertical-pos) cnt)
1778 |                   (prog1
1779 |                       (setq tmp
1780 |                             (propertize
1781 |                              (concat
1782 |                               ;;TODO some parts of the string won't inherit
1783 |                               ;; the properties of the event might cause
1784 |                               ;; issues with org goto/navigation/etc?
1785 |                               (when (not is-beginning-of-cell)
1786 |                                 (apply 'propertize calfw-blocks-event-start
1787 |                                        props)) ;;(if (= i 0) "*" "|"))
1788 |                               (calfw-blocks-generalized-substring
1789 |                                (car block-lines) 0 block-width-adjusted
1790 |                                props))
1791 |                              'keymap calfw-blocks-event-keymap
1792 |                              'calfw-blocks-horizontal-pos block-horizontal-pos))
1793 |                     ;; (add-face-text-property 0 (length tmp)
1794 |                     ;;                         (calfw--render-get-face-content
1795 |                     ;;                          block-string
1796 |                     ;;                          'calfw-default-content-face)
1797 |                     ;;                         t tmp)
1798 |                     (when (and (= i 0)
1799 |                                (equal start-date date))
1800 |                       (add-face-text-property 0 (length tmp)
1801 |                                               'calfw-blocks-overline-face t tmp))
1802 |                     (when (and (= i (- block-height 1))
1803 |                                (equal end-date date))
1804 |                       (add-face-text-property 0 (length tmp)
1805 |                                               'calfw-blocks-underline-face t tmp))
1806 |                     (when is-exceeded-indicator
1807 |                       (add-face-text-property 0 (length tmp)
1808 |                                               'italic t tmp))
1809 |                     ;; (when (bound-and-true-p 'calfw-blocks-event-box)
1810 |                     ;;   ;; Essentially, we need to put a box on the first character
1811 |                     ;;   ;; and a no-box on the second character.
1812 |                     ;;   (add-face-text-property 0 1 '(:box (:line-width (-1 . 0))) t tmp)
1813 |                     ;;   (add-face-text-property 1 2 '(:box (:line-width (0 . 0))) t tmp))
1814 |                     ))
1815 |             rendered-block)
1816 |       (setq cnt (1+ cnt))
1817 |       ;; Need to pad the lines up to full block-height which will be skipped
1818 |       ;; later.
1819 |       (when intervals
1820 |         (dotimes (_ (min (1- (car intervals))
1821 |                          (- (- (cadr block-vertical-pos)
1822 |                                (car block-vertical-pos))
1823 |                             cnt)))
1824 |           (push (list (+ (car block-vertical-pos) cnt)
1825 |                       (propertize
1826 |                        (string-pad "ignore" block-width)
1827 |                        'calfw-blocks-horizontal-pos block-horizontal-pos))
1828 |                 rendered-block)
1829 |           (setq cnt (1+ cnt))))
1830 |       (setq block-lines (cdr block-lines))
1831 |       (setq intervals (cdr intervals)))
1832 |     (reverse rendered-block)))
1833 | 
1834 | (defun calfw-blocks-render-all-day-events (lines cell-width cell-height)
1835 |   (let ((all-day-lines (seq-filter (lambda (line)
1836 |                                      (not (car (get-text-property 0 'calfw-blocks-interval
1837 |                                                                   line))))
1838 |                                    lines))
1839 |         (calfw-render-line-breaker (if (eq calfw-blocks-render-multiday-events 'cont)
1840 |                                      (lambda (x &rest _) (list x))
1841 |                                    'calfw-render-line-breaker-wordwrap)))
1842 |     (calfw--render-break-lines all-day-lines cell-width cell-height)))
1843 | 
1844 | (defun calfw-blocks-render-event-blocks (date hour-interval lines cell-width cell-height)
1845 |   ""
1846 |   (let* ((interval-lines (seq-filter (lambda (line) (car (get-text-property 0 'calfw-blocks-interval
1847 |                                                                             line)))
1848 |                                      lines))
1849 |          ;; (all-day-lines (seq-filter (lambda (line) (not (car (get-text-property 0 'calfw-blocks-interval
1850 |          ;;                                                                        line))))
1851 |          ;;                            lines))
1852 |          (block-positions (calfw-blocks--get-block-positions date
1853 |                                                              interval-lines
1854 |                                                              cell-width))
1855 |          (split-blocks (seq-sort (lambda (a b) (< (car a) (car b)))
1856 |                                  (mapcan
1857 |                                   (apply-partially
1858 |                                    #'calfw-blocks-split-single-block
1859 |                                    date
1860 |                                    hour-interval)
1861 |                                   block-positions)))
1862 |          (rendered-lines '())
1863 |          ;; (curr-time-grid-line (calfw-blocks--current-time-vertical-position))
1864 |          )
1865 |     (dolist (i (number-sequence 0 (1- cell-height)))
1866 |       (let ((make-time-grid-line (and calfw-blocks-show-time-grid
1867 |                                       (= (mod i calfw-blocks-lines-per-hour) 0)))
1868 |             (current-line-lst '()))
1869 |         (if (or (not split-blocks) (< i (caar split-blocks)))
1870 |             (if make-time-grid-line
1871 |                 (push (propertize (make-string cell-width ? )
1872 |                                   'face (list 'calfw-grid-face
1873 |                                               'calfw-blocks-overline-face))
1874 |                       current-line-lst)
1875 |               (push (make-string cell-width ? ) current-line-lst))
1876 |           (while (and split-blocks (= i (caar split-blocks)))
1877 |             (push (cadr (pop split-blocks)) current-line-lst))
1878 |           (setq current-line-lst (calfw-blocks--pad-block-line
1879 |                                   current-line-lst cell-width make-time-grid-line)))
1880 |         (push (apply 'concat current-line-lst)
1881 |               rendered-lines)))
1882 |     (reverse rendered-lines)))
1883 | 
1884 | (defun calfw-blocks--pad-block-line (block-line cell-width make-time-grid-line)
1885 |   (let* ((block-line (seq-sort (lambda (a b) (< (car (get-text-property 0 'calfw-blocks-horizontal-pos a))
1886 |                                                 (car (get-text-property 0 'calfw-blocks-horizontal-pos b))))
1887 |                                block-line))
1888 |          (padded-line '())
1889 |          (prev-end 0))
1890 |     (dolist (segment block-line (progn
1891 |                                   (if make-time-grid-line
1892 |                                       (push (calfw-blocks--grid-line (- cell-width prev-end)) padded-line))
1893 |                                   (reverse padded-line) ))
1894 |       (let* ((horizontal-pos (get-text-property 0 'calfw-blocks-horizontal-pos segment))
1895 |              (start (car horizontal-pos))
1896 |              (end (cadr horizontal-pos)))
1897 |         (if (< prev-end start)
1898 |             (push (if make-time-grid-line
1899 |                       (calfw-blocks--grid-line (- start prev-end))
1900 |                     (make-string (- start prev-end) ? ))
1901 |                   padded-line))
1902 |         (push segment padded-line)
1903 |         (setq prev-end end)))))
1904 | 
1905 | (defun calfw-blocks--grid-line (n)
1906 |   (propertize (make-string n ? ) 'face (list 'calfw-grid-face
1907 |                                              'calfw-blocks-overline-face)))
1908 | 
1909 | (defun calfw-blocks-dest-ol-today-set (dest)
1910 |   "[internal] Put a highlight face on today."
1911 |   (let ((ols))
1912 |     (calfw-dest-with-region dest
1913 |       (calfw--find-all-by-date
1914 |        dest (calendar-current-date)
1915 |        (lambda (begin end)
1916 |          (let ((overlay (make-overlay begin end)))
1917 |            ;; This is the only difference
1918 |            (if (eq 'calfw-day-title-face
1919 |                    (get-text-property begin 'face))
1920 |                (overlay-put overlay 'face
1921 |                             'calfw-today-title-face))
1922 |            (push overlay ols)))))
1923 |     (setf (calfw-dest-today-ol dest) ols)))
1924 | 
1925 | (defun calfw-blocks--cfw-cp-update (component &optional initial-date)
1926 |   "[internal] Clear and re-draw the component content."
1927 |   (let* ((buf (calfw-cp-get-buffer component))
1928 |          (dest (calfw-component-dest component)))
1929 |     (with-current-buffer buf
1930 |       (calfw-dest-before-update dest)
1931 |       (calfw--dest-ol-today-clear dest)
1932 |       (let* ((buffer-read-only nil))
1933 |         (calfw-dest-with-region dest
1934 |           (calfw-dest-clear dest)
1935 |           (funcall (calfw--cp-dispatch-view-impl
1936 |                     (calfw-component-view component))
1937 |                    component)))
1938 |       (if (eq (calfw-component-view component) 'block-week)
1939 |           (calfw-blocks-dest-ol-today-set dest)
1940 |         (when calfw-highlight-today (calfw--dest-ol-today-set dest)))
1941 |       (when initial-date
1942 |         (calfw-cp-goto-date component initial-date))
1943 |       (calfw-dest-after-update dest)
1944 |       (calfw--cp-fire-update-hooks component))))
1945 | 
1946 | (defun calfw-blocks-get-displayed-events ()
1947 |   "Return a list of displayed events in the current buffer.
1948 | Each item in the list is a cons containing the first position the
1949 | event appears and the cfw:event structure."
1950 |   (let ((cur-pt (point-min))
1951 |         ev evs)
1952 |     (while (setq cur-pt
1953 |                  (next-single-property-change cur-pt 'cfw:event))
1954 |       (when (setq ev (get-text-property cur-pt 'cfw:event))
1955 |         (unless (cl-member ev evs :key 'cdr)
1956 |           (setq evs (append evs (list (cons cur-pt ev)))))))
1957 |     evs))
1958 | 
1959 | 
1960 | (defun calfw-blocks--get-overlapping-block-positions (date lines cell-width)
1961 |   "Return LINES with assigned vertical and horizontal positions.
1962 | 
1963 | Each element of the list is a list (event vertical-pos
1964 | horizontal-pos). The vertical-pos and horizontal-pos are both
1965 | half open intervals represented as two element lists, containing
1966 | the start (inclusive) and the end (exclusive). The vertical-pos
1967 | is in unit lines, the horizontal-pos is in unit characters. Both
1968 | positions are given relative to the calendar cell the event
1969 | resides in, which has width CELL-WIDTH.
1970 | 
1971 | The vertical positions represent the time of day the event
1972 | occurs. The horizontal positions are assigned to display
1973 | concurrent events side by side. If there is not enough space for
1974 | all blocks to have width at least `calfw-blocks-min-block-width'
1975 | then some events are not displayed, and an indicator for how many
1976 | events are not displayed is shown."
1977 |   (let* ((lines-lst
1978 |           (mapcar
1979 |            (lambda (x)
1980 |              (list x (calfw-blocks--get-block-vertical-position
1981 |                       date
1982 |                       (get-text-property 0 'cfw:event x))))
1983 |            lines))
1984 |          ;; Group by vertical start, sorting the groups in ascending order
1985 |          (groups (cl-sort (seq-group-by 'caadr lines-lst)
1986 |                           '< :key 'car))
1987 |          ;; Sort within each group by descending height
1988 |          (groups (cl-loop for g in groups
1989 |                           ;; sort within groups
1990 |                           collect (cons
1991 |                                    (car g)
1992 |                                    (seq-sort
1993 |                                     (lambda (x y)
1994 |                                       (< (- (cadadr x) (caadr x))
1995 |                                          (- (cadadr y) (caadr y))))
1996 |                                     (cdr g))))))
1997 |     (cl-loop
1998 |      with new-lines-lst = nil
1999 |      for g in groups
2000 |      for rem = (length (cdr g)) ;; Remaining segments in this group
2001 |      do (cl-loop for l in (cdr g)
2002 |                  ;; Go over any added indices that vertically intersect with
2003 |                  ;; the current lines. intervals will be a list of (start end
2004 |                  ;; event) which specifies the interval and which event it is
2005 |                  ;; intersection (one at most).
2006 |                  when (> rem 0)
2007 |                  do
2008 |                  (let* ((intervals
2009 |                          (cl-loop
2010 |                           with intervals = nil
2011 |                           with start = 0
2012 |                           with cur-intersection = nil
2013 |                           for x in
2014 |                           (cl-loop for y in new-lines-lst
2015 |                                    if (calfw-blocks--interval-intersect?
2016 |                                        (cadr y) (cadr l))
2017 |                                    collect y into intersection
2018 |                                    finally return
2019 |                                    (cl-sort intersection '<
2020 |                                             :key 'caaddr))
2021 |                           for x-horz = (caddr x)
2022 |                           for sx = (car x-horz)
2023 |                           do (progn
2024 |                                (when (> sx start)
2025 |                                  (push (list start sx
2026 |                                              cur-intersection)
2027 |                                        intervals))
2028 |                                (if (= (caadr x) (car g))
2029 |                                    ;; Same group, take
2030 |                                    ;; out the whole interval
2031 |                                    (setq start (cadr x-horz)
2032 |                                          cur-intersection nil)
2033 |                                  (setq cur-intersection x
2034 |                                        start (1+ sx))))
2035 |                           finally do (when (> cell-width start)
2036 |                                        (push
2037 |                                         (list start cell-width
2038 |                                               cur-intersection)
2039 |                                         intervals))
2040 |                           finally return
2041 |                           (cl-sort intervals
2042 |                                    '> ;; Get largest intervals first
2043 |                                    :key
2044 |                                    (lambda (int) ;; Gets width
2045 |                                      (- (cadr int) (car int))))))
2046 |                         (int (car-safe intervals))
2047 |                         (valid-intervals (cl-count-if
2048 |                                           (lambda (int) ;; Gets width
2049 |                                             (>= (- (cadr int) (car int))
2050 |                                                 calfw-blocks-min-block-width))
2051 |                                           intervals)))
2052 |                    (cond
2053 |                     ((null int)
2054 |                      ;; If we have zero intervals, we're screwed. Need to
2055 |                      ;; issue a warning and eventually come up with a solution
2056 |                      ;; when we run into it.
2057 |                      (warn "Not enough space to show all events in one or more cells!"))
2058 |                     ((and (>= rem 1)
2059 |                           (< (- (cadr int) (car int))
2060 |                              (* rem calfw-blocks-min-block-width)))
2061 |                      ;; If we have one interval of insufficient size, and more
2062 |                      ;; than one event remaining, need to add an +more
2063 |                      ;; indicator.
2064 |                      ;;
2065 |                      ;; TODO: This is problematic if previous blocks have used
2066 |                      ;; up all the remaining space. We should have really
2067 |                      ;; replace the one before the current.
2068 |                      (let* ((x-vertical-pos (nth 1 l))
2069 |                             (exceeded-indicator
2070 |                              (list (propertize
2071 |                                     (format "+%dmore" rem)
2072 |                                     'calfw-blocks-exceeded-indicator t)
2073 |                                    (list (nth 0 x-vertical-pos)
2074 |                                          (max 4 (nth 1 x-vertical-pos)))
2075 |                                    (butlast int))))
2076 |                        (push exceeded-indicator new-lines-lst)
2077 |                        ;; Ignore the rest
2078 |                        (setq rem 0)))
2079 |                     (t (push
2080 |                         (append l
2081 |                                 (list
2082 |                                  (if (or (= rem 1) (> valid-intervals 1))
2083 |                                      (butlast int)
2084 |                                    ;; Split the interval into equal parts
2085 |                                    (let* ((s (car int))
2086 |                                           (e (cadr int))
2087 |                                           (w (- e s)))
2088 |                                      (list s (+ s (/ w rem)))))))
2089 |                         new-lines-lst)))
2090 |                    (when-let ((intersector (and int (nth 2 int))))
2091 |                      ;; Update the text height of the event that intersects
2092 |                      ;; this interval
2093 |                      (let* ((int-start (caadr intersector))
2094 |                             (int-end (cadadr intersector))
2095 |                             (cur-end (caadr l))
2096 |                             (max-height (- cur-end int-start))
2097 |                             (old-height (nth 3 intersector)))
2098 |                        (if old-height
2099 |                            (setcar (nthcdr 3 intersector)
2100 |                                    (min old-height max-height))
2101 |                          (setcdr intersector
2102 |                                  (append (cdr intersector)
2103 |                                          (list (min max-height
2104 |                                                     (- int-end
2105 |                                                        int-start))))))))
2106 |                    (setq rem (1- rem))))
2107 |      finally return new-lines-lst)))
2108 | 
2109 | (defun calfw-blocks--pad-overlapping-block-line (block-line
2110 |                                                  cell-width make-time-grid-line)
2111 |   (let* ((block-line
2112 |           (seq-sort (lambda (a b)
2113 |                       (> (car (get-text-property
2114 |                                0 'calfw-blocks-horizontal-pos a))
2115 |                          (car (get-text-property
2116 |                                0 'calfw-blocks-horizontal-pos b))))
2117 |                     block-line))
2118 |          padded-line (prev-start cell-width))
2119 |     (dolist (segment block-line
2120 |                      (progn
2121 |                        (push (if make-time-grid-line
2122 |                                  (calfw-blocks--grid-line prev-start)
2123 |                                (make-string prev-start ? ))
2124 |                              padded-line)
2125 |                        padded-line))
2126 |       (let* ((horizontal-pos (get-text-property 0 'calfw-blocks-horizontal-pos
2127 |                                                 segment))
2128 |              (start (car horizontal-pos))
2129 |              (end (cadr horizontal-pos)))
2130 |         (if (< end prev-start)
2131 |             (push (if make-time-grid-line
2132 |                       (calfw-blocks--grid-line (- prev-start end))
2133 |                     (make-string (- prev-start end) ? ))
2134 |                   padded-line))
2135 |         (push (substring segment 0 (min
2136 |                                     (- end start)
2137 |                                     (- prev-start start)))
2138 |               padded-line)
2139 |         (setq prev-start start)))))
2140 | 
2141 | (define-minor-mode calfw-blocks-overlapping-mode
2142 |   "Allow blocks to overlap in calfw-blocks."
2143 |   :global t
2144 |   :group 'calfw-blocks
2145 |   :init-value nil
2146 |   (dolist (ad '((calfw-blocks--get-block-positions
2147 |                  . calfw-blocks--get-overlapping-block-positions)
2148 |                 (calfw-blocks--pad-block-line
2149 |                  . calfw-blocks--pad-overlapping-block-line)))
2150 |     (if calfw-blocks-overlapping-mode
2151 |         (advice-add (car ad) :override (cdr ad))
2152 |       (advice-remove (car ad) (cdr ad))))
2153 |   (when-let (buf (get-buffer calfw-calendar-buffer-name))
2154 |     (with-current-buffer buf
2155 |       (calfw-refresh-calendar-buffer nil))))
2156 | 
2157 | (define-minor-mode calfw-blocks-mode
2158 |   "Enable calfw view as blocks."
2159 |   :global t
2160 |   :group 'calfw-blocks
2161 |   :init-value nil
2162 |   (let ((fn-ad (if calfw-blocks-mode
2163 |                    'advice-add
2164 |                  (lambda (symbol _ fn &rest _)
2165 |                    (advice-remove symbol fn))))
2166 |         (fn-list (if calfw-blocks-mode
2167 |                      'add-to-list
2168 |                    (lambda (qlst item)
2169 |                      (set qlst (cl-delete
2170 |                                 item
2171 |                                 (symbol-value qlst)
2172 |                                 :test #'equal))))))
2173 |     (dolist (dispatch '((block-week        .  calfw-blocks-view-block-week)
2174 |                     (block-day         .  calfw-blocks-view-block-day)
2175 |                     (block-2-day       .  calfw-blocks-view-block-2-day)
2176 |                     (block-3-day       .  calfw-blocks-view-block-3-day)
2177 |                     (block-4-day       .  calfw-blocks-view-block-4-day)
2178 |                     (block-5-day       .  calfw-blocks-view-block-5-day)
2179 |                     (block-7-day       .  calfw-blocks-view-block-7-day)))
2180 |       (funcall fn-list 'calfw-cp-dipatch-funcs dispatch))
2181 | 
2182 |     (funcall fn-ad 'calfw--render-toolbar
2183 |             :override 'calfw-blocks-render-toolbar)
2184 |     (funcall fn-ad 'calfw--cp-update :override 'calfw-blocks--cfw-cp-update)
2185 |     (funcall fn-ad 'calfw-refresh-calendar-buffer
2186 |             :override 'calfw-blocks--cfw-refresh-calendar-buffer)
2187 | 
2188 |     (dolist (fn '(calfw-navi-next-month-command
2189 |                   calfw-navi-previous-month-command
2190 |                   calfw-refresh-calendar-buffer
2191 |                   calfw-event-toggle-calendar))
2192 |       (funcall fn-ad fn :around
2193 |                #'calfw-blocks-perserve-buffer-view-advice))))
2194 | 
2195 | (calfw-blocks-mode) ;; Enable mode by default
2196 | 
2197 | (provide 'calfw-blocks)
2198 | ;;; calfw-blocks.el ends here
2199 | 


--------------------------------------------------------------------------------