├── calfw-cal.el
├── calfw-howm.el
├── calfw-ical.el
├── calfw-org.el
├── calfw.el
├── calfw.juth
└── readme.md


/calfw-cal.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-cal.el --- calendar view for emacs diary -*- lexical-binding: t -*-
  2 | 
  3 | ;; Copyright (C) 2011  SAKURAI Masashi
  4 | 
  5 | ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
  6 | ;; Keywords: calendar
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; Display diary items in the calfw buffer.
 24 | 
 25 | ;; (require 'calfw-cal)
 26 | ;;
 27 | ;; M-x cfw:open-diary-calendar
 28 | 
 29 | ;; Key binding
 30 | ;; i : insert an entry on the date
 31 | ;; RET or Click : jump to the entry
 32 | ;; q : kill-buffer
 33 | 
 34 | 
 35 | ;; Thanks for furieux's initial code.
 36 | 
 37 | ;;; Code:
 38 | 
 39 | (require 'calfw)
 40 | (require 'calendar)
 41 | 
 42 | (defvar cfw:cal-diary-regex
 43 |   (let ((time   "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}")
 44 |         (blanks "[[:blank:]]*"))
 45 |     (concat "\\(" time "\\)?"
 46 |             "\\(?:" blanks "-" blanks "\\(" time "\\)\\)?"
 47 |             blanks "\\(.*\\)"))
 48 |   "Regex extracting start/end time and title from a diary string")
 49 | 
 50 | (defun cfw:cal-entry-to-event (date string)
 51 |   "[internal] Add text properties to string, allowing calfw to act on it."
 52 |   (let* ((lines      (split-string
 53 |                       (replace-regexp-in-string
 54 |                        "[\t ]+" " " (string-trim string))
 55 |                       "\n"))
 56 |          (first      (car lines))
 57 |          (desc       (mapconcat 'identity (cdr lines) "\n"))
 58 |          (title      (progn
 59 |                        (string-match cfw:cal-diary-regex first)
 60 |                        (match-string 3 first)))
 61 |          (start      (match-string 1 first))
 62 |          (end        (match-string 2 first))
 63 |          (properties (list 'mouse-face 'highlight
 64 |                            'help-echo string
 65 |                            'cfw-marker (copy-marker (point-at-bol)))))
 66 |     (make-cfw:event :title       (apply 'propertize title properties)
 67 |                     :start-date  date
 68 |                     :start-time  (when start
 69 |                                    (cfw:parse-str-time start))
 70 |                     :end-time    (when end
 71 |                                    (cfw:parse-str-time end))
 72 |                     :description (apply 'propertize desc properties))))
 73 | 
 74 | (defun cfw:cal-onclick ()
 75 |   "Jump to the clicked diary item."
 76 |   (interactive)
 77 |   (let ((marker (get-text-property (point) 'cfw-marker)))
 78 |     (when (and marker (marker-buffer marker))
 79 |       (switch-to-buffer (marker-buffer marker))
 80 |       (goto-char (marker-position marker)))))
 81 | 
 82 | (defvar cfw:cal-text-keymap
 83 |   (let ((map (make-sparse-keymap)))
 84 |     (define-key map [mouse-1] 'cfw:cal-onclick)
 85 |     (define-key map (kbd "<return>") 'cfw:cal-onclick)
 86 |     map)
 87 |   "key map on the calendar item text.")
 88 | 
 89 | (defun cfw:cal-schedule-period-to-calendar (begin end)
 90 |   "[internal] Return calfw calendar items between BEGIN and END
 91 | from the diary schedule data."
 92 |   (let ((all (diary-list-entries
 93 |               begin
 94 |               (1+ (cfw:days-diff begin end)) t))
 95 |         non-periods
 96 |         periods)
 97 |     (cl-loop for i in all
 98 |           ;;for date = (car i)
 99 |           for title = (nth 1 i)
100 |           for date-spec = (nth 2 i)
101 |           ;;for dmarker = (nth 3 i)
102 |           for pspec = (cons date-spec title)
103 |           do
104 |           (if (string-match "%%(diary-block" date-spec)
105 |               (unless (member pspec periods)
106 |                 (push pspec periods))
107 |             (push i non-periods)))
108 |     (append
109 |      (cl-loop
110 |       for (date string . rest) in non-periods
111 |       collect (cfw:cal-entry-to-event date string))
112 |      (list (cons 'periods
113 |                  (map 'list (function (lambda (period)
114 |                                         (let ((spec (read (substring (car period) 2))))
115 |                                           (cond
116 |                                            ((eq calendar-date-style 'american)
117 |                                             (list
118 |                                              (list (nth 1 spec)
119 |                                                    (nth 2 spec)
120 |                                                    (nth 3 spec))
121 |                                              (list (nth 4 spec)
122 |                                                    (nth 5 spec)
123 |                                                    (nth 6 spec))
124 |                                              (cdr period)))
125 |                                            ((eq calendar-date-style 'european)
126 |                                             (list
127 |                                              (list (nth 2 spec)
128 |                                                    (nth 1 spec)
129 |                                                    (nth 3 spec))
130 |                                              (list (nth 5 spec)
131 |                                                    (nth 4 spec)
132 |                                                    (nth 6 spec))
133 |                                              (cdr period)))
134 |                                            ((eq calendar-date-style 'iso)
135 |                                             (list
136 |                                              (list (nth 2 spec)
137 |                                                    (nth 3 spec)
138 |                                                    (nth 1 spec))
139 |                                              (list (nth 5 spec)
140 |                                                    (nth 6 spec)
141 |                                                    (nth 4 spec))
142 |                                              (cdr period)))))))
143 |                       periods))))))
144 | 
145 | (defvar cfw:cal-schedule-map
146 |   (cfw:define-keymap
147 |    '(
148 |      ("q" . kill-buffer)
149 |      ("i" . cfw:cal-from-calendar)
150 |      ))
151 |   "Key map for the calendar buffer.")
152 | 
153 | (defun cfw:cal-create-source (&optional color)
154 |   "Create diary calendar source."
155 |   (make-cfw:source
156 |    :name "calendar diary"
157 |    :color (or color "SaddleBrown")
158 |    :data 'cfw:cal-schedule-period-to-calendar))
159 | 
160 | (defun cfw:open-diary-calendar ()
161 |   "Open the diary schedule calendar in the new buffer."
162 |   (interactive)
163 |   (save-excursion
164 |     (let* ((source1 (cfw:cal-create-source))
165 |            (cp (cfw:create-calendar-component-buffer
166 |                 :view 'month
167 |                 :custom-map cfw:cal-schedule-map
168 |                 :contents-sources (list source1))))
169 |       (switch-to-buffer (cfw:cp-get-buffer cp)))))
170 | 
171 | (defun cfw:cal-from-calendar ()
172 |   "Insert a new item. This command should be executed on the calfw calendar."
173 |   (interactive)
174 |   (let* ((mdy (cfw:cursor-to-nearest-date))
175 |          (m (calendar-extract-month mdy))
176 |          (d (calendar-extract-day   mdy))
177 |          (y (calendar-extract-year  mdy)))
178 |     (diary-make-entry (calendar-date-string (cfw:date m d y) t t))
179 |     ))
180 | 
181 | ;; (progn (eval-current-buffer) (cfw:open-diary-calendar))
182 | 
183 | (provide 'calfw-cal)
184 | ;;; calfw-cal.el ends here
185 | 


--------------------------------------------------------------------------------
/calfw-howm.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-howm.el --- calendar view for howm -*- lexical-binding: t -*-
  2 | 
  3 | ;; Copyright (C) 2011  SAKURAI Masashi
  4 | 
  5 | ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
  6 | ;; Keywords: calendar
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; (eval-after-load "howm-menu" '(progn
 24 | ;;   (require 'calfw-howm)
 25 | ;;   (cfw:install-howm-schedules)
 26 | ;;   (define-key howm-mode-map (kbd "M-C") 'cfw:open-howm-calendar)
 27 | ;; ))
 28 | 
 29 | ;; If you are using Elscreen, here is useful.
 30 | ;; (define-key howm-mode-map (kbd "M-C") 'cfw:elscreen-open-howm-calendar)
 31 | 
 32 | ;; One can open a standalone calendar buffer by
 33 | ;; M-x cfw:open-howm-calendar
 34 | 
 35 | ;; You can display a calendar in your howm menu.
 36 | ;; %here%(cfw:howm-schedule-inline)
 37 | 
 38 | ;;; Code:
 39 | 
 40 | (require 'howm)
 41 | (require 'calfw)
 42 | 
 43 | (defvar cfw:howm-schedule-cache nil "[internal] Cache data for schedule items of howm.")
 44 | 
 45 | (defun cfw:howm-schedule-cache-clear ()
 46 |   "clear cache for howm schedule items."
 47 |   (setq cfw:howm-schedule-cache nil))
 48 | 
 49 | (defvar cfw:howm-schedule-hook nil
 50 |   "Hook which is called after retrieval of howm schedule items.")
 51 | 
 52 | (defun cfw:howm-schedule-get ()
 53 |   "[internal] Return all schedule items in the whole howm data. If cache
 54 | data exists, this function uses the cache."
 55 |   (unless cfw:howm-schedule-cache
 56 |     (let* ((howm-schedule-types howm-schedule-menu-types)
 57 |            (raw (howm-reminder-search howm-schedule-types)))
 58 |       (setq cfw:howm-schedule-cache (howm-schedule-sort-items raw)))
 59 |     (run-hooks 'cfw:howm-schedule-hook))
 60 |   cfw:howm-schedule-cache)
 61 | 
 62 | (defun cfw:to-howm-date (date)
 63 |   "[internal] Convert a date format from the Emacs calendar list
 64 | to the number of howm encoded days."
 65 |   (apply 'howm-encode-day
 66 |          (mapcar 'number-to-string
 67 |                  (list (calendar-extract-day date)
 68 |                        (calendar-extract-month date)
 69 |                        (calendar-extract-year date)))))
 70 | 
 71 | (defun cfw:howm-schedule-period (begin end)
 72 |   "[internal] Return howm schedule items between BEGIN and END."
 73 |   (let* ((from (cfw:to-howm-date begin))
 74 |          (to (cfw:to-howm-date end))
 75 |          (filtered (cl-remove-if
 76 |                     (lambda (item)
 77 |                       (let ((s (howm-schedule-date item)))
 78 |                         (or (< s from)
 79 |                             (< to s))))
 80 |                     (cfw:howm-schedule-get))))
 81 |     (howm-schedule-sort-items filtered)))
 82 | 
 83 | (defvar cfw:howm-schedule-summary-transformer
 84 |   (lambda (line) line)
 85 |   "Transformation function which transforms the howm summary string to calendar title.
 86 | If this function splits into a list of string, the calfw displays those string in multi-lines.")
 87 | 
 88 | (defun cfw:howm-schedule-parse-line (line)
 89 |   "[internal] Parse the given string and return a result list, (date num type summary)."
 90 |   (when (string-match "^\\[\\([^@!]+\\)\\]\\([@!]\\)\\([0-9]*\\) \\(.*\\)$" line)
 91 |     (list
 92 |      (match-string 1 line) (string-to-number (match-string 3 line))
 93 |      (match-string 2 line) (match-string 4 line))))
 94 | 
 95 | (defun cfw:howm-schedule-period-to-calendar (begin end)
 96 |   "[internal] Return calfw calendar items between BEGIN and END
 97 | from the howm schedule data."
 98 |   (loop with contents = nil
 99 |         with periods = nil
100 |         for i in (cfw:howm-schedule-period begin end)
101 |         for date = (cfw:emacs-to-calendar
102 |                     (seconds-to-time (+ 10 (* (howm-schedule-date i) 24 3600))))
103 |         for (datestr num type summary) = (cfw:howm-schedule-parse-line (howm-item-summary i))
104 |         for summary = (funcall cfw:howm-schedule-summary-transformer summary)
105 |         do
106 |         (cond
107 |          ((and (string= type "@") (< 0 num))
108 |           (push (list date (cfw:date-after date (1- num)) summary) periods))
109 |          ((and (string= type "!") (< 0 num))
110 |           (push (list (cfw:date-before date (1- num)) date summary) periods))
111 |          (t
112 |           (setq contents (cfw:contents-add date summary contents))))
113 |         finally return (nconc contents (list (cons 'periods periods)))))
114 | 
115 | (defun cfw:howm-create-source (&optional color)
116 |   "Create a howm source."
117 |   (make-cfw:source
118 |    :name "howm schedule"
119 |    :color (or color "SteelBlue")
120 |    :update 'cfw:howm-schedule-cache-clear
121 |    :data 'cfw:howm-schedule-period-to-calendar))
122 | 
123 | (defvar cfw:howm-schedule-map
124 |   (cfw:define-keymap
125 |    '(
126 |      ("RET" . cfw:howm-from-calendar)
127 |      ("q"   . kill-buffer)
128 |      ))
129 |   "Key map for the howm calendar mode.")
130 | 
131 | (defvar cfw:howm-schedule-contents nil  "A list of cfw:source objects for schedule contents.")
132 | (defvar cfw:howm-annotation-contents nil  "A list of cfw:source objects for annotations.")
133 | 
134 | (defun cfw:open-howm-calendar ()
135 |   "Open a howm schedule calendar in the new buffer."
136 |   (interactive)
137 |   (save-excursion
138 |     (let ((cp (cfw:create-calendar-component-buffer
139 |                :custom-map cfw:howm-schedule-map
140 |                :view 'month
141 |                :contents-sources (append (list (cfw:howm-create-source))
142 |                                          cfw:howm-schedule-contents)
143 |                :annotation-sources cfw:howm-annotation-contents)))
144 |       (switch-to-buffer (cfw:cp-get-buffer cp)))))
145 | 
146 | (defun cfw:howm-from-calendar ()
147 |   "Display a howm schedule summary of the date on the cursor,
148 | searching from the whole howm data.
149 | This command should be executed on the calfw calendar."
150 |   (interactive)
151 |   (let* ((mdy (cfw:cursor-to-nearest-date))
152 |          (m (calendar-extract-month mdy))
153 |          (d (calendar-extract-day   mdy))
154 |          (y (calendar-extract-year  mdy))
155 |          (key (format-time-string
156 |                howm-date-format
157 |                (encode-time 0 0 0 d m y))))
158 |     (howm-keyword-search key)))
159 | 
160 | (defun cfw:howm-from-calendar-fast ()
161 |   "Display a howm schedule summary of the date on the cursor,
162 | searching from the cache. So, this command is faster than `cfw:howm-from-calendar'.
163 | This command should be executed on the calfw calendar."
164 |   (interactive)
165 |   (let* ((mdy (cfw:cursor-to-nearest-date))
166 |          (m (calendar-extract-month mdy))
167 |          (d (calendar-extract-day   mdy))
168 |          (y (calendar-extract-year  mdy))
169 |          (key (format-time-string
170 |                howm-date-format
171 |                (encode-time 0 0 0 d m y)))
172 |          (items (cfw:howm-schedule-period mdy mdy)))
173 |     (cond
174 |      ((= 1 (length items))
175 |       (howm-view-open-item (car items)))
176 |      (t
177 |       (howm-view-summary (format "Schedules : %s" (cfw:strtime mdy))
178 |                          items (list key))
179 |       (howm-view-summary-check t)))))
180 | 
181 | ;; (define-key cfw:howm-schedule-map (kbd "RET") 'cfw:howm-from-calendar-fast)
182 | ;; (define-key cfw:howm-schedule-inline-keymap (kbd "RET") 'cfw:howm-from-calendar-fast)
183 | 
184 | ;;; Region
185 | 
186 | (defvar cfw:howm-schedule-inline-keymap
187 |   (cfw:define-keymap
188 |    '(("RET" . cfw:howm-from-calendar)))
189 |   "Key map for the howm inline calendar.")
190 | 
191 | (defun cfw:howm-schedule-inline (&optional width height view)
192 |   "Inline function for the howm menu. See the comment text on the top of this file for the usage."
193 |   (let ((custom-map (copy-keymap cfw:howm-schedule-inline-keymap)) cp)
194 |     (set-keymap-parent custom-map cfw:calendar-mode-map)
195 |     (setq cp (cfw:create-calendar-component-region
196 |               :width width :height (or height 10)
197 |               :keymap custom-map
198 |               :contents-sources (append (list (cfw:howm-create-source))
199 |                                         cfw:howm-schedule-contents)
200 |               :annotation-sources cfw:howm-annotation-contents
201 |               :view (or view 'month))))
202 |   "") ; for null output
203 | 
204 | ;;; Installation
205 | 
206 | (defun cfw:install-howm-schedules ()
207 |   "Add a schedule collection function to the calfw for the howm
208 | schedule data and set up inline calendar function for the howm menu."
209 |   (interactive)
210 |   (add-hook 'howm-after-save-hook 'cfw:howm-schedule-cache-clear)
211 |   (add-to-list 'howm-menu-allow 'cfw:howm-schedule-inline))
212 | 
213 | ;;; for Elscreen
214 | 
215 | (eval-after-load "elscreen-howm"
216 |   '(progn
217 |      (defun cfw:elscreen-open-howm-calendar ()
218 |        "Open the calendar in the new screen."
219 |        (interactive)
220 |        (save-current-buffer
221 |          (elscreen-create))
222 |        (cfw:open-howm-calendar))
223 | 
224 |      (defun cfw:elscreen-kill-calendar ()
225 |        "Kill the calendar buffer and the screen."
226 |        (interactive)
227 |        (kill-buffer nil)
228 |        (unless (elscreen-one-screen-p)
229 |          (elscreen-kill)))
230 | 
231 |      (define-key cfw:howm-schedule-map (kbd "q") 'cfw:elscreen-kill-calendar)
232 |      ))
233 | 
234 | (provide 'calfw-howm)
235 | ;;; calfw-howm.el ends here
236 | 


--------------------------------------------------------------------------------
/calfw-ical.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-ical.el --- calendar view for ical format -*- lexical-binding: t -*-
  2 | 
  3 | ;; Copyright (C) 2011  SAKURAI Masashi
  4 | 
  5 | ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
  6 | ;; Keywords: calendar
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; A bridge from ical to calfw.
 24 | ;; The API and interfaces have not been confirmed yet.
 25 | 
 26 | ;;; Installation:
 27 | 
 28 | ;; Here is a minimum sample code:
 29 | ;; (require 'calfw-ical)
 30 | ;; To open a calendar buffer, execute the following function.
 31 | ;; (cfw:open-ical-calendar "http://www.google.com/calendar/ical/.../basic.ics")
 32 | 
 33 | ;; Executing the following command, this program clears caches to refresh the ICS data.
 34 | ;; (cfw:ical-data-cache-clear-all)
 35 | 
 36 | ;;; Code:
 37 | 
 38 | (require 'calfw)
 39 | (require 'icalendar)
 40 | (require 'url)
 41 | (require 'url-http)
 42 | 
 43 | 
 44 | (defun cfw:decode-to-calendar (dec)
 45 |   (cfw:date
 46 |    (nth 4 dec) (nth 3 dec) (nth 5 dec)))
 47 | 
 48 | (defun cfw:ical-event-get-dates (event zone-map)
 49 |   "Return date-time information from iCalendar event object:
 50 | period event (list \\='period start-date end-date), time span
 51 | event (list \\='time date start-time end-time). The period
 52 | includes end-date. This function is copied from
 53 | `icalendar--convert-ical-to-diary' and modified. Recursive events
 54 | have not been supported yet."
 55 |   (let*
 56 |       ((dtstart (icalendar--get-event-property event 'DTSTART))
 57 |        (dtstart-zone (icalendar--find-time-zone
 58 |                       (icalendar--get-event-property-attributes event 'DTSTART)
 59 |                       zone-map))
 60 |        (dtstart-dec (icalendar--decode-isodatetime dtstart nil dtstart-zone))
 61 |        (start-d (cfw:decode-to-calendar dtstart-dec))
 62 |        (start-t (cfw:time (nth 2 dtstart-dec) (nth 1 dtstart-dec)))
 63 | 
 64 |        (dtend (icalendar--get-event-property event 'DTEND))
 65 |        (dtend-zone (icalendar--find-time-zone
 66 |                     (icalendar--get-event-property-attributes event 'DTEND)
 67 |                     zone-map))
 68 |        (dtend-dec (icalendar--decode-isodatetime dtend nil dtend-zone))
 69 |        (dtend-1-dec (icalendar--decode-isodatetime dtend -1 dtend-zone))
 70 | 
 71 |        (duration (icalendar--get-event-property event 'DURATION))
 72 | 
 73 |        end-d end-1-d end-t)
 74 | 
 75 |     (when (and dtstart
 76 |                (string=
 77 |                 (cadr (icalendar--get-event-property-attributes
 78 |                        event 'DTSTART))
 79 |                 "DATE"))
 80 |       (setq start-t nil))
 81 | 
 82 |     (when duration
 83 |       (let ((dtend-dec-d (icalendar--add-decoded-times
 84 |                           dtstart-dec
 85 |                           (icalendar--decode-isoduration duration)))
 86 |             (dtend-1-dec-d (icalendar--add-decoded-times
 87 |                             dtstart-dec
 88 |                             (icalendar--decode-isoduration duration t))))
 89 |         (if (and dtend-dec (not (eq dtend-dec dtend-dec-d)))
 90 |             (message "Inconsistent endtime and duration for %s" dtend-dec))
 91 |         (setq dtend-dec dtend-dec-d)
 92 |         (setq dtend-1-dec dtend-1-dec-d)))
 93 |     (setq end-d (if dtend-dec
 94 |                     (cfw:decode-to-calendar dtend-dec)
 95 |                   start-d))
 96 |     (setq end-1-d (if dtend-1-dec
 97 |                       (cfw:decode-to-calendar dtend-1-dec)
 98 |                     start-d))
 99 |     (setq end-t (if (and
100 |                      dtend-dec
101 |                      (not (string=
102 |                            (cadr
103 |                             (icalendar--get-event-property-attributes
104 |                              event 'DTEND))
105 |                            "DATE")))
106 |                     (cfw:time (nth 2 dtend-dec) (nth 1 dtend-dec))
107 |                   start-t))
108 |     (cond
109 |      ((and start-t (equal start-d end-d))
110 |       (list 'time start-d start-t end-t))
111 |      ((equal start-d end-1-d)
112 |       (list 'time start-d nil nil))
113 |      (t
114 |       (list 'period start-d nil end-1-d)))))
115 | 
116 | (defun cfw:ical-sanitize-string (string)
117 |   (when (and string
118 |              (> (length string) 0))
119 |     (replace-regexp-in-string "\\\\n" "\n"
120 |                               (replace-regexp-in-string "\\\\," "," string))))
121 | 
122 | (defun cfw:ical-convert-event (event zone-map)
123 |   (cl-destructuring-bind
124 |       (dtag date start end) (cfw:ical-event-get-dates event zone-map)
125 |     (make-cfw:event
126 |      :start-date  date
127 |      :start-time  start
128 |      :end-date    (when (equal dtag 'period) end)
129 |      :end-time    (when (equal dtag 'time)   end)
130 |      :title       (cfw:ical-sanitize-string
131 |                    (icalendar--get-event-property event 'SUMMARY))
132 |      :location    (cfw:ical-sanitize-string
133 |                    (icalendar--get-event-property event 'LOCATION))
134 |      :description (cfw:ical-sanitize-string
135 |                    (icalendar--get-event-property event 'DESCRIPTION)))))
136 | 
137 | (defun cfw:ical-convert-ical-to-calfw (ical-list)
138 |   (cl-loop with zone-map = (icalendar--convert-all-timezones ical-list)
139 |            for e in (icalendar--all-events ical-list)
140 |            for event = (cfw:ical-convert-event e zone-map)
141 |            if event
142 |            if (cfw:event-end-date event)
143 |            collect event into periods
144 |            else
145 |            collect event into contents
146 |            else do
147 |            (progn
148 |              (message "Ignoring event \"%s\"" e)
149 |              (message "Cannot handle this event, tag: %s" e))
150 |            finally (return `((periods ,periods) ,@contents))))
151 | 
152 | (defun cfw:ical-debug (f)
153 |   (interactive)
154 |   (let ((buf (cfw:ical-url-to-buffer f)))
155 |     (unwind-protect
156 |         (pp-display-expression
157 |          (with-current-buffer buf
158 |            (cfw:ical-normalize-buffer)
159 |            (cfw:ical-convert-ical-to-calfw
160 |             (icalendar--read-element nil nil)))
161 |          "*ical-debug*")
162 |       (kill-buffer buf))))
163 | 
164 | (defvar cfw:ical-calendar-external-shell-command "wget -q -O - ")
165 | (defvar cfw:ical-calendar-tmpbuf " *calfw-tmp*")
166 | (defvar cfw:ical-url-to-buffer-get 'cfw:ical-url-to-buffer-internal)
167 | 
168 | (defun cfw:ical-url-to-buffer-external (url)
169 |   "Retrieve ICS file with an external command."
170 |   (let ((buf (get-buffer-create cfw:ical-calendar-tmpbuf)))
171 |     (buffer-disable-undo buf)
172 |     (with-current-buffer buf
173 |       (erase-buffer))
174 |     (call-process-shell-command
175 |      (concat cfw:ical-calendar-external-shell-command url) nil buf nil)
176 |     buf))
177 | 
178 | (defun cfw:ical-url-to-buffer-internal (url)
179 |   "Retrieve ICS file with the url package."
180 |   (let ((buf (url-retrieve-synchronously url))
181 |         (dbuf (get-buffer-create cfw:ical-calendar-tmpbuf))
182 |         pos)
183 |     (unwind-protect
184 |         (when (setq pos (url-http-symbol-value-in-buffer
185 |                          'url-http-end-of-headers buf))
186 |           (with-current-buffer dbuf
187 |             (erase-buffer)
188 |             (decode-coding-string
189 |              (with-current-buffer buf
190 |                (buffer-substring (1+ pos) (point-max)))
191 |              'utf-8 nil dbuf)))
192 |       (kill-buffer buf))
193 |     dbuf))
194 | 
195 | (defun cfw:ical-url-to-buffer (url)
196 |   (let* ((url-code (url-generic-parse-url url))
197 |          (type (url-type url-code)))
198 |     (cond
199 |      (type
200 |       (funcall cfw:ical-url-to-buffer-get url))
201 |      (t ; assume local file
202 |       (let ((buf (find-file-noselect (expand-file-name url) t)))
203 |         (with-current-buffer buf (set-visited-file-name nil))
204 |         buf)))))
205 | 
206 | (defmacro cfw:ical-with-buffer (url &rest body)
207 |   (let (($buf (gensym)))
208 |     `(let ((,$buf (cfw:ical-url-to-buffer ,url)))
209 |        (unwind-protect
210 |            (with-current-buffer ,$buf
211 |              (goto-char (point-min))
212 |              ,@body)
213 |          (kill-buffer ,$buf)))))
214 | (put 'cfw:ical-with-buffer 'lisp-indent-function 1)
215 | 
216 | (defun cfw:ical-normalize-buffer ()
217 |   (save-excursion
218 |     (goto-char (point-min))
219 |     (while (re-search-forward "\n " nil t)
220 |       (replace-match "")))
221 |   (save-excursion
222 |     (goto-char (point-min))
223 |     (while (re-search-forward "DT\\(START\\|END\\);VALUE=DATE:" nil t)
224 |       (replace-match "DT\\1:")))
225 |   (set-buffer-modified-p nil))
226 | 
227 | (defvar cfw:ical-data-cache nil "a list of (url . ics-data)")
228 | 
229 | (defun cfw:ical-data-cache-clear (url)
230 |   (setq cfw:ical-data-cache
231 |         (cl-loop for i in cfw:ical-data-cache
232 |                  for (u . d) = i
233 |                  unless (equal u url)
234 |                  collect i)))
235 | 
236 | (defun cfw:ical-data-cache-clear-all ()
237 |   (interactive)
238 |   (setq cfw:ical-data-cache nil))
239 | 
240 | (defun cfw:ical-get-data (url)
241 |   (let ((data (assoc url cfw:ical-data-cache)))
242 |     (unless data
243 |       (setq data (let ((cal-list
244 |                         (cfw:ical-with-buffer url
245 |                           (cfw:ical-normalize-buffer)
246 |                           (cfw:ical-convert-ical-to-calfw
247 |                            (icalendar--read-element nil nil)))))
248 |                    (cons url cal-list)))
249 |       (push data cfw:ical-data-cache))
250 |     (cdr data)))
251 | 
252 | (defun cfw:ical-to-calendar (url begin end)
253 |   (cl-loop for event in (cfw:ical-get-data url)
254 |            if (and (listp event)
255 |                    (equal 'periods (car event)))
256 |            collect
257 |            (cons
258 |             'periods
259 |             (cl-loop for evt in (cadr event)
260 |                   if (and
261 |                       (cfw:date-less-equal-p begin (cfw:event-end-date evt))
262 |                       (cfw:date-less-equal-p (cfw:event-start-date evt) end))
263 |                   collect evt))
264 |            else if (cfw:date-between begin end (cfw:event-start-date event))
265 |            collect event))
266 | 
267 | (defun cfw:ical-create-source (name url color)
268 |   (make-cfw:source
269 |    :name (concat "iCal:" name)
270 |    :color color
271 |    :update (lambda () (cfw:ical-data-cache-clear url))
272 |    :data (lambda (begin end)
273 |            (cfw:ical-to-calendar url begin end))))
274 | 
275 | (defun cfw:open-ical-calendar (url)
276 |   "Simple calendar interface. This command displays just one
277 | calendar source."
278 |   (interactive)
279 |   (save-excursion
280 |     (let ((cp (cfw:create-calendar-component-buffer
281 |                :view 'month
282 |                :contents-sources
283 |                (list (cfw:ical-create-source "ical" url "#2952a3")))))
284 |       (switch-to-buffer (cfw:cp-get-buffer cp)))))
285 | 
286 | ;; (progn (eval-current-buffer) (cfw:open-ical-calendar "./ics/test.ics"))
287 | 
288 | (provide 'calfw-ical)
289 | ;;; calfw-ical.el ends here
290 | 


--------------------------------------------------------------------------------
/calfw-org.el:
--------------------------------------------------------------------------------
  1 | ;;; calfw-org.el --- calendar view for org-agenda  -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2011  SAKURAI Masashi
  4 | 
  5 | ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
  6 | ;; Keywords: calendar, org
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; Display org-agenda items in the calfw buffer.
 24 | ;; (Because I don't use the org-agenda mainly,
 25 | ;; I hope someone continue integration with the org.)
 26 | 
 27 | ;; (require 'calfw-org)
 28 | ;;
 29 | ;; ;; use org agenda buffer style keybinding.
 30 | ;; ;; (setq cfw:org-overwrite-default-keybinding t)
 31 | ;;
 32 | ;; M-x cfw:open-org-calendar
 33 | 
 34 | ;;; Code:
 35 | 
 36 | (require 'calfw)
 37 | (require 'org)
 38 | (require 'org-agenda)
 39 | (require 'org-element)
 40 | (require 'org-capture)
 41 | (require 'google-maps nil t)
 42 | 
 43 | (defgroup cfw-org nil
 44 |   "Options about calfw-org."
 45 |   :tag "Calfw Org"
 46 |   :group 'org
 47 |   :group 'cfw)
 48 | 
 49 | (defcustom cfw:org-capture-template nil
 50 |   "org-capture template. If you use `org-capture' with `calfw', you shold set like
 51 | \\='(\"c\" \"calfw2org\" entry (file nil)  \"* %?\n %(cfw:org-capture-day)\")"
 52 |   :group 'cfw-org
 53 |   :version "24.1"
 54 |   :type
 55 |   '(list string string symbol (list symbol (choice file (const nil))) string))
 56 | 
 57 | (defsubst cfw:org-tp (text prop)
 58 |   "[internal] Return text property at position 0."
 59 |   (get-text-property 0 prop text))
 60 | 
 61 | (defvar cfw:org-agenda-schedule-args nil
 62 |   "Default arguments for collecting agenda entries.
 63 | If value is nil, `org-agenda-entry-types' is used.")
 64 | 
 65 | (defvar cfw:org-icalendars nil
 66 |   "Org buffers for exporting icalendars.
 67 | Setting a list of the custom agenda files, one can use the
 68 | different agenda files from the default agenda ones.")
 69 | 
 70 | (defvar cfw:org-overwrite-default-keybinding nil
 71 |   "Overwrites default keybinding. It needs restarting of Emacs(if not work)
 72 | For example,
 73 | 
 74 |  ------------------------------------------------
 75 |   key   | function
 76 |  ------------------------------------------------
 77 |     g   | cfw:refresh-calendar-buffer
 78 |     j   | cfw:org-goto-date
 79 |     k   | org-capture
 80 |     x   | cfw:org-clean-exit
 81 |     d   | cfw:change-view-day
 82 |     v d | cfw:change-view-day
 83 |     v w | cfw:change-view-week
 84 |     v m | cfw:change-view-month
 85 |  ------------------------------------------------")
 86 | 
 87 | (defvar cfw:org-face-agenda-item-foreground-color "Seagreen4"
 88 |   "Variable for org agenda item foreground color.")
 89 | 
 90 | (defun cfw:org-collect-schedules-period (begin end)
 91 |   "[internal] Return org schedule items between BEGIN and END."
 92 |   (let ((org-agenda-prefix-format " "))
 93 |     (setq org-agenda-buffer
 94 |       (when (buffer-live-p org-agenda-buffer)
 95 |         org-agenda-buffer))
 96 |     (org-compile-prefix-format nil)
 97 |     (cl-loop for date in (cfw:enumerate-days begin end) append
 98 |              (cl-loop for file in (or cfw:org-icalendars (org-agenda-files nil 'ifmode))
 99 |                       append
100 |                       (progn
101 |                         (org-check-agenda-file file)
102 |                         (apply 'org-agenda-get-day-entries
103 |                                file date
104 |                                cfw:org-agenda-schedule-args))))))
105 | 
106 | (defun cfw:org-onclick ()
107 |   "Jump to the clicked org item."
108 |   (interactive)
109 |   (let (
110 |     (marker (get-text-property (point) 'org-marker))
111 |     (link   (get-text-property (point) 'org-link))
112 |     (file   (get-text-property (point) 'cfw:org-file))
113 |     (beg    (get-text-property (point) 'cfw:org-h-beg))
114 |     ;; (loc    (get-text-property (point) 'cfw:org-loc))
115 |     )
116 |     (when link
117 |       (org-link-open-from-string link))
118 |     (when (and marker (marker-buffer marker))
119 |       (org-mark-ring-push)
120 |       (switch-to-buffer (marker-buffer marker))
121 |       (widen)
122 |       (goto-char (marker-position marker))
123 |       (when (eq major-mode 'org-mode)
124 |         (org-reveal)))
125 |     (when beg
126 |       (find-file file)
127 |       (goto-char beg)
128 |       (org-cycle))))
129 | 
130 | (defun cfw:org-jump-map ()
131 |   "Jump to the clicked org item."
132 |   (interactive)
133 |   (when (fboundp 'google-maps) ;; TODO: Not sure where this function is from!
134 |     (let ((loc    (get-text-property (point) 'cfw:org-loc)))
135 |       (when loc
136 |         (google-maps loc)))))
137 | 
138 | (defun cfw:org-clean-exit ()
139 |   "Close buffers opened by calfw-org before closing Calendar Framework."
140 |   (interactive)
141 |   (org-release-buffers org-agenda-new-buffers)
142 |   (setq org-agenda-new-buffers nil)
143 |   (bury-buffer))
144 | 
145 | (defvar cfw:org-text-keymap
146 |   (let ((map (make-sparse-keymap)))
147 |     (define-key map [mouse-1] 'cfw:org-onclick)
148 |     (define-key map (kbd "RET") 'cfw:org-onclick)
149 |     (define-key map (kbd "C-c C-o") 'cfw:org-onclick)
150 |     (define-key map (kbd "m") 'cfw:org-jump-map)
151 |     map)
152 |   "key map on the calendar item text.")
153 | 
154 | (defun cfw:org-extract-summary (org-item)
155 |   "[internal] Remove some strings."
156 |   (let* ((item org-item) (tags (cfw:org-tp item 'tags)))
157 |     ;; (when (string-match cfw:org-todo-keywords-regexp item) ; dynamic bind
158 |     ;;   (setq item (replace-match "" nil nil item)))
159 |     (if tags
160 |       (when (string-match (concat "[\t ]*:+" (mapconcat 'identity tags ":+") ":+[\t ]*$") item)
161 |         (setq item (replace-match "" nil nil item))))
162 |     (when (string-match "[0-9]\\{2\\}:[0-9]\\{2\\}\\(-[0-9]\\{2\\}:[0-9]\\{2\\}\\)?[\t ]+" item)
163 |       (setq item (replace-match "" nil nil item)))
164 |     (when (string-match "^ +" item)
165 |       (setq item (replace-match "" nil nil item)))
166 |     (when (= 0 (length item))
167 |       (setq item (cfw:org-tp org-item 'org-category)))
168 |     item))
169 | 
170 | (defun cfw:org-summary-format (item)
171 |   "Format an item. (How should be displayed?)"
172 |   (let* (;; (time (cfw:org-tp item 'time))
173 |          (time-of-day (cfw:org-tp item 'time-of-day))
174 |          (time-str (and time-of-day
175 |                         (format "%02i:%02i " (/ time-of-day 100) (% time-of-day 100))))
176 |          ;; (category (cfw:org-tp item 'org-category))
177 |          ;; (tags (cfw:org-tp item 'tags))
178 |          ;; (marker (cfw:org-tp item 'org-marker))
179 |          ;; (buffer (and marker (marker-buffer marker)))
180 |          (text (cfw:org-extract-summary item))
181 |          (props (cfw:extract-text-props item 'face 'keymap))
182 |          (extra (cfw:org-tp item 'extra)))
183 |     (setq text (substring-no-properties text))
184 |     (when (and extra (string-match (concat "^" org-deadline-string ".*") extra))
185 |       (add-text-properties 0 (length text) (list 'face (org-agenda-deadline-face 1.0)) text))
186 |     (if org-todo-keywords-for-agenda
187 |       (when (string-match (concat "^[\t ]*\\<\\(" (mapconcat 'identity org-todo-keywords-for-agenda "\\|") "\\)\\>") text)
188 |         (add-text-properties (match-beginning 1) (match-end 1) (list 'face (org-get-todo-face (match-string 1 text))) text)))
189 |     ;;; ------------------------------------------------------------------------
190 |     ;;; act for org link
191 |     ;;; ------------------------------------------------------------------------
192 |     (setq text (replace-regexp-in-string "%[0-9A-F]\\{2\\}" " " text))
193 |     (if (string-match org-link-bracket-re text)
194 |       (let* ((desc (if (match-end 3) (match-string-no-properties 3 text)))
195 |              (link (org-link-unescape (match-string-no-properties 1 text)))
196 |              (help (concat "LINK: " link))
197 |              (link-props (list
198 |                           'face 'org-link
199 |                           'mouse-face 'highlight
200 |                           'help-echo help
201 |                           'org-link link)))
202 |         (if desc
203 |             (progn
204 |               (setq desc (apply 'propertize desc link-props))
205 |               (setq text (replace-match desc nil nil text)))
206 |           (setq link (apply 'propertize link link-props))
207 |           (setq text (replace-match link nil nil text)))))
208 |     (when time-str
209 |       (setq text (concat time-str text)))
210 |     (propertize
211 |      (apply 'propertize text props)
212 |      ;; include org filename
213 |      ;; (and buffer (concat " " (buffer-name buffer)))
214 |      'keymap cfw:org-text-keymap
215 |      ;; Delete the display property, since displaying images will break our
216 |      ;; table layout.
217 |      'display nil)))
218 | 
219 | (defvar cfw:org-schedule-summary-transformer 'cfw:org-summary-format
220 |   "Transforms the org item string to calendar title.
221 | If this function splits into a list of string, the calfw displays
222 | those string in multi-lines.")
223 | 
224 | (defun cfw:org-normalize-date (date)
225 |   "Return a normalized date. (MM DD YYYY)."
226 |   (cond
227 |    ((numberp date)
228 |     (calendar-gregorian-from-absolute date))
229 |    (t date)))
230 | 
231 | (defun cfw:org-get-timerange (text)
232 |   "Return a range object (begin end text).
233 | If TEXT does not have a range, return nil."
234 |   (let* ((dotime (cfw:org-tp text 'dotime)))
235 |     (and (stringp dotime) (and dotime (string-match org-ts-regexp dotime))
236 | 	 (let ((date-string  (match-string 1 dotime))
237 | 	       (extra (cfw:org-tp text 'extra)))
238 | 	   (if (and extra (string-match "(\\([0-9]+\\)/\\([0-9]+\\)): " extra))
239 | 	       (let* ((cur-day (string-to-number
240 | 				(match-string 1 extra)))
241 | 		      (total-days (string-to-number
242 | 				   (match-string 2 extra)))
243 | 		      (start-date (time-subtract
244 | 				   (org-read-date nil t date-string)
245 | 				   (seconds-to-time (* 3600 24 (- cur-day 1)))))
246 | 		      (end-date (time-add
247 | 				 (org-read-date nil t date-string)
248 | 				 (seconds-to-time (* 3600 24 (- total-days cur-day))))))
249 | 		 (list (calendar-gregorian-from-absolute (time-to-days start-date))
250 | 		       (calendar-gregorian-from-absolute (time-to-days end-date)) text))
251 | 	     )))))
252 | 
253 | (defun cfw:org-schedule-period-to-calendar (begin end)
254 |   "[internal] Return calfw calendar items between BEGIN and END
255 | from the org schedule data."
256 |   (cl-loop
257 |    ;;with cfw:org-todo-keywords-regexp = (regexp-opt org-todo-keywords-for-agenda) ; dynamic bind
258 |    with contents = nil with periods = nil
259 |    for i in (cfw:org-collect-schedules-period begin end)
260 |    for date = (cfw:org-tp i 'date)
261 |    for line = (funcall cfw:org-schedule-summary-transformer i)
262 |    for range = (cfw:org-get-timerange line)
263 |    if range do
264 |    (unless (member range periods)
265 |      (push range periods))
266 |    else do
267 |    ; dotime is not present if this event was already added as a timerange
268 |    (if (cfw:org-tp i 'dotime)
269 |        (setq contents (cfw:contents-add
270 | 		       (cfw:org-normalize-date date)
271 | 		       line contents)))
272 |    finally return (nconc contents (list (cons 'periods periods)))))
273 | 
274 | (defun cfw:org-schedule-sorter (text1 text2)
275 |   "[internal] Sorting algorithm for org schedule items.
276 | TEXT1 < TEXT2."
277 |   (condition-case _
278 |       (let ((time1 (cfw:org-tp text1 'time-of-day))
279 |             (time2 (cfw:org-tp text2 'time-of-day)))
280 |         (cond
281 |          ((and time1 time2) (< time1 time2))
282 |          (time1 t)   ; time object is moved to upper
283 |          (time2 nil) ;
284 |          (t (string-lessp text1 text2))))
285 |     (error (string-lessp text1 text2))))
286 | 
287 | (defun cfw:org-schedule-sorter2 (text1 text2)
288 |   "[internal] Sorting algorithm for org schedule items.
289 | TEXT1 < TEXT2. This function makes no-time items in front of timed-items."
290 |   (condition-case _
291 |       (let ((time1 (cfw:org-tp text1 'time-of-day))
292 |             (time2 (cfw:org-tp text2 'time-of-day)))
293 |         (cond
294 |          ((and time1 time2) (< time1 time2))
295 |          (time1 nil) ; time object is moved to upper
296 |          (time2 t)   ;
297 |          (t (string-lessp text1 text2))))
298 |     (error (string-lessp text1 text2))))
299 | 
300 | (defun cfw:org-format-title (file h-obj t-obj h-beg loc)
301 |   (propertize
302 |   (concat
303 |    (when  (org-element-property :hour-start t-obj)
304 |      (format "%02i:%02i "
305 |              (org-element-property :hour-start t-obj)
306 |              (org-element-property :minute-start t-obj)))
307 |    (org-element-property :title h-obj))
308 |   'keymap cfw:org-text-keymap
309 |   'display nil
310 |   'cfw:org-file file
311 |   'cfw:org-h-beg h-beg
312 |   'cfw:org-loc loc))
313 | 
314 | (defun cfw:org-format-date (t-obj lst)
315 |   (mapcar
316 |    (lambda (v)
317 |      (org-element-property v t-obj)) lst))
318 | 
319 | (defun cfw:org-filter-datetime (t-obj lst)
320 |   (if (car (cfw:org-format-date t-obj lst))
321 |       (cfw:org-format-date t-obj lst)
322 |     nil))
323 | 
324 | (defun cfw:org-convert-event (file h-obj t-obj h-beg)
325 |   (let ((sdate '(:month-start :day-start :year-start))
326 |         (stime '(:hour-start :minute-start))
327 |         (edate '(:month-end :day-end :year-end))
328 |         (etime '(:hour-end :minute-end))
329 |         (loc (org-element-property :LOCATION h-obj)))
330 |     (make-cfw:event
331 |      :start-date  (cfw:org-format-date t-obj sdate)
332 |      :start-time  (cfw:org-filter-datetime t-obj stime)
333 |      :end-date    (cfw:org-filter-datetime t-obj edate)
334 |      :end-time    (cfw:org-filter-datetime t-obj etime)
335 |      :title       (cfw:org-format-title file h-obj t-obj h-beg loc)
336 |      :location    loc
337 |      :description (if (org-element-property :contents-begin h-obj)
338 |                       (replace-regexp-in-string
339 |                        " *:PROPERTIES:\n  \\(.*\\(?:\n.*\\)*?\\) :END:\n" ""
340 |                        (buffer-substring (org-element-property :contents-begin h-obj)
341 |                                          (org-element-property :contents-end h-obj)))
342 |                     nil))))
343 | 
344 | (defun cfw:org-convert-org-to-calfw (file)
345 |   (save-excursion
346 |     (with-current-buffer
347 |         (find-file-noselect file)
348 |       (let*
349 |           ((elem-obj (org-element-parse-buffer))
350 |            (pos-lst `( ,@(org-element-map elem-obj 'timestamp
351 |                            (lambda (hl) (org-element-property :begin hl) ))
352 |                        ,@(org-element-map (org-element-map elem-obj 'headline
353 |                                             (lambda (hl)
354 |                                  (org-element-property :deadline hl) ) ) 'timestamp
355 |                            (lambda (hl) (org-element-property :begin hl) ))
356 |                        ,@(org-element-map (org-element-map elem-obj 'headline
357 |                                             (lambda (hl)
358 |                                               (org-element-property :scheduled hl) ) ) 'timestamp
359 |                            (lambda (hl) (org-element-property :begin hl) )))))
360 |         (cl-loop for pos in pos-lst
361 |               do (goto-char pos)
362 |               for t-obj =  (org-element-timestamp-parser)
363 |               for h-obj = (progn
364 |                             (org-back-to-heading t)
365 |                             (org-element-headline-parser (point-max) t))
366 |               for h-beg  = (point)
367 |               for event = (cfw:org-convert-event file h-obj t-obj h-beg)
368 |               for ts-type = (org-element-property :type t-obj)
369 |               if (eq 'active-range ts-type)
370 |               collect event into periods
371 |               else if (eq 'active ts-type)
372 |               collect event into contents
373 |               ;; else do
374 |               ;; (message "calfw-org: Cannot handle event")
375 |               finally
376 |               (kill-buffer (get-file-buffer file))
377 |               (cl-return `((periods ,periods) ,@contents)))))))
378 | 
379 | (defun cfw:org-to-calendar (file begin end)
380 |   (cl-loop for event in (cfw:org-convert-org-to-calfw file)
381 |            if (and (listp event)
382 |                    (equal 'periods (car event)))
383 |            collect
384 |            (cons
385 |             'periods
386 |             (cl-loop for evt in (cadr event)
387 |                      if (and
388 |                          (cfw:date-less-equal-p begin (cfw:event-end-date evt))
389 |                          (cfw:date-less-equal-p (cfw:event-start-date evt) end))
390 |                      collect evt))
391 |            else if (cfw:date-between begin end (cfw:event-start-date event))
392 |            collect event))
393 | 
394 | (defun cfw:org-create-file-source (name file color)
395 |   "Create org-element based source. "
396 |   (make-cfw:source
397 |    :name (concat "Org:" name)
398 |    :color color
399 |    :data (lambda (begin end)
400 |            (cfw:org-to-calendar file begin end))))
401 | 
402 | (defun cfw:org-capture-day ()
403 |   (with-current-buffer  (get-buffer-create cfw:calendar-buffer-name)
404 |     (let ((pos (cfw:cursor-to-nearest-date)))
405 |       (concat "<"
406 |               (format-time-string  "%Y-%m-%d %a"
407 |                                    (encode-time 0 0 0
408 |                                                 (calendar-extract-day pos)
409 |                                                 (calendar-extract-month pos)
410 |                                                 (calendar-extract-year pos)))
411 |               ">"))))
412 | 
413 | (when cfw:org-capture-template
414 | (setq org-capture-templates
415 |       (append org-capture-templates (list cfw:org-capture-template))))
416 | 
417 | (defun cfw:org-capture ()
418 |   "Open org-agenda buffer on the selected date."
419 |   (interactive)
420 |   (if cfw:org-capture-template
421 |       (org-capture nil (car cfw:org-capture-template))
422 |     (message "cfw:org-capture-template is not set yet.")))
423 | 
424 | (defun cfw:org-open-agenda-day ()
425 |   "Open org-agenda buffer on the selected date."
426 |   (interactive)
427 |   (let ((date (cfw:cursor-to-nearest-date)))
428 |     (when date
429 |       (org-agenda-list nil (calendar-absolute-from-gregorian date) 'day))))
430 | 
431 | (define-key
432 |   cfw:calendar-mode-map "c" 'cfw:org-capture)
433 | 
434 | (defvar cfw:org-schedule-map
435 |   (cfw:define-keymap
436 |    '(
437 |      ("q"   . bury-buffer)
438 |      ("SPC" . cfw:org-open-agenda-day)
439 |      ))
440 |   "Key map for the calendar buffer.")
441 | 
442 | (defvar cfw:org-custom-map
443 |   (cfw:define-keymap
444 |    '(
445 |      ("g"   . cfw:refresh-calendar-buffer)
446 |      ("j"   . cfw:org-goto-date)
447 |      ("k"   . org-capture)
448 |      ("q"   . bury-buffer)
449 |      ("d"   . cfw:change-view-day)
450 |      ("v d" . cfw:change-view-day)
451 |      ("v w" . cfw:change-view-week)
452 |      ("v m" . cfw:change-view-month)
453 |      ("x"   . cfw:org-clean-exit)
454 |      ("SPC" . cfw:org-open-agenda-day)
455 |      ))
456 |   "Key map for the calendar buffer.")
457 | 
458 | (defun cfw:org-create-source (&optional color)
459 |   "Create org-agenda source."
460 |   (make-cfw:source
461 |    :name "org-agenda"
462 |    :color (or color cfw:org-face-agenda-item-foreground-color)
463 |    :data 'cfw:org-schedule-period-to-calendar))
464 | 
465 | (defun cfw:open-org-calendar ()
466 |   "Open an org schedule calendar in the new buffer."
467 |   (interactive)
468 |   (save-excursion
469 |     (let* ((source1 (cfw:org-create-source))
470 |            (curr-keymap (if cfw:org-overwrite-default-keybinding cfw:org-custom-map cfw:org-schedule-map))
471 |            (cp (cfw:create-calendar-component-buffer
472 |                 :view 'month
473 |                 :contents-sources (list source1)
474 |                 :custom-map curr-keymap
475 |                 :sorter 'cfw:org-schedule-sorter)))
476 |       (switch-to-buffer (cfw:cp-get-buffer cp))
477 |       (when (not org-todo-keywords-for-agenda)
478 |         (message "Warn : open org-agenda buffer first.")))))
479 | 
480 | ;; (defun cfw:org-from-calendar ()
481 | ;;   "Do something. This command should be executed on the calfw calendar."
482 | ;;   (interactive)
483 | ;;   (let* ((mdy (cfw:cursor-to-nearest-date))
484 | ;;          (m (calendar-extract-month mdy))
485 | ;;          (d (calendar-extract-day   mdy))
486 | ;;          (y (calendar-extract-year  mdy)))
487 | ;;     ;; exec org-remember here?
488 | ;;     ))
489 | 
490 | (defun cfw:org-read-date-command ()
491 |   "Move the cursor to the specified date."
492 |   (interactive)
493 |   (cfw:emacs-to-calendar (org-read-date nil 'to-time)))
494 | 
495 | (defun cfw:org-goto-date ()
496 |   "Move the cursor to the specified date."
497 |   (interactive)
498 |   (cfw:navi-goto-date
499 |    (cfw:org-read-date-command)))
500 | 
501 | ;; (progn (eval-current-buffer) (cfw:open-org-calendar))
502 | ;; (setq org-agenda-files '("./org-samples/complex.org"))
503 | 
504 | 
505 | (provide 'calfw-org)
506 | ;;; calfw-org.el ends here
507 | 


--------------------------------------------------------------------------------
/calfw.el:
--------------------------------------------------------------------------------
   1 | ;;; calfw.el --- Calendar view framework -*- lexical-binding: t -*-
   2 | 
   3 | ;; Copyright (C) 2011-2021  SAKURAI Masashi
   4 | 
   5 | ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
   6 | ;; Version: 1.7
   7 | ;; Keywords: calendar
   8 | ;; Package-Requires: ((emacs "28.1"))
   9 | ;; URL: https://github.com/kiwanami/emacs-calfw
  10 | 
  11 | ;; This program is free software; you can redistribute it and/or modify
  12 | ;; it under the terms of the GNU General Public License as published by
  13 | ;; the Free Software Foundation, either version 3 of the License, or
  14 | ;; (at your option) any later version.
  15 | 
  16 | ;; This program is distributed in the hope that it will be useful,
  17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 | ;; GNU General Public License for more details.
  20 | 
  21 | ;; You should have received a copy of the GNU General Public License
  22 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23 | 
  24 | ;;; Commentary:
  25 | 
  26 | ;; This program is a framework for the Calendar component. In the
  27 | ;; Emacs, uses can show schedules in the calendar views, like iCal,
  28 | ;; Outlook and Google Calendar.
  29 | 
  30 | ;;; Installation:
  31 | 
  32 | ;; Place this program in your load path and add following code.
  33 | 
  34 | ;; (require 'calfw)
  35 | 
  36 | ;;; Usage:
  37 | 
  38 | ;; Executing the command `cfw:open-calendar-buffer', switch to the calendar buffer.
  39 | ;; You can navigate the date like calendar.el.
  40 | 
  41 | ;; Schedule data which are shown in the calendar view, are collected
  42 | ;; by the `cfw:source' objects. See the function `cfw:open-debug-calendar' for example.
  43 | 
  44 | ;; This program gets the holidays using the function
  45 | ;; `calendar-holiday-list'. See the document of the holidays.el and
  46 | ;; the Info text for customizing the holidays.
  47 | 
  48 | ;;; Add-ons:
  49 | 
  50 | ;; - calfw-howm.el : Display howm schedules.
  51 | ;; - calfw-ical.el : Display schedules of the iCalendar format.
  52 | ;; - calfw-org.el  : Display orgmode schedules.
  53 | ;; - calfw-cal.el  : Display emacs diary schedules.
  54 | 
  55 | ;;; Code:
  56 | 
  57 | (require 'cl-lib)
  58 | (require 'calendar)
  59 | (require 'holidays)
  60 | (require 'format-spec)
  61 | 
  62 | 
  63 | 
  64 | ;;; Constants
  65 | 
  66 | (defconst cfw:week-sunday    0)
  67 | (defconst cfw:week-monday    1)
  68 | (defconst cfw:week-tuesday   2)
  69 | (defconst cfw:week-wednesday 3)
  70 | (defconst cfw:week-thursday  4)
  71 | (defconst cfw:week-friday    5)
  72 | (defconst cfw:week-saturday  6)
  73 | (defconst cfw:week-days      7)
  74 | 
  75 | ;;; Customs
  76 | 
  77 | (defcustom cfw:fchar-vertical-line ?|
  78 |   "The character used for drawing vertical lines."
  79 |   :group 'cfw
  80 |   :type 'character)
  81 | 
  82 | (defcustom cfw:fchar-horizontal-line ?-
  83 |   "The character used for drawing horizontal lines."
  84 |   :group 'cfw
  85 |   :type 'character)
  86 | 
  87 | (defcustom cfw:fchar-junction ?+
  88 |   "The character used for drawing junction lines."
  89 |   :group 'cfw
  90 |   :type 'character)
  91 | 
  92 | (defcustom cfw:fchar-top-right-corner ?+
  93 |   "The character used for drawing the top-right corner."
  94 |   :group 'cfw
  95 |   :type 'character)
  96 | 
  97 | (defcustom cfw:fchar-top-left-corner ?+
  98 |   "The character used for drawing the top-left corner."
  99 |   :group 'cfw
 100 |   :type 'character)
 101 | 
 102 | (defcustom cfw:fchar-left-junction ?+
 103 |   "The character used for drawing junction lines at the left side."
 104 |   :group 'cfw
 105 |   :type 'character)
 106 | 
 107 | (defcustom cfw:fchar-right-junction ?+
 108 |   "The character used for drawing junction lines at the right side."
 109 |   :group 'cfw
 110 |   :type 'character)
 111 | 
 112 | (defcustom cfw:fchar-top-junction ?+
 113 |   "The character used for drawing junction lines at the top side."
 114 |   :group 'cfw
 115 |   :type 'character)
 116 | 
 117 | (defcustom cfw:fstring-period-start "("
 118 |   "The string used to indicate the beginning of a period."
 119 |   :group 'cfw
 120 |   :type 'string)
 121 | 
 122 | (defcustom cfw:fstring-period-end ")"
 123 |   "The string used to indicate the end of a period."
 124 |   :group 'cfw
 125 |   :type 'string)
 126 | 
 127 | (defcustom cfw:read-date-command 'cfw:read-date-command-simple
 128 |   "The command used to read the date in `cfw:navi-goto-date-command',
 129 | for example `cfw:read-date-command-simple' or `cfw:org-read-date-command'."
 130 |   :group 'cfw
 131 |   :type 'function)
 132 | 
 133 | (defcustom cfw:event-format-overview "%t"
 134 |   "Format string of `cfw:event's for overviews (month-, 2-week-, week-view).
 135 |  See `cfw:event-format' for possible values."
 136 |   :group 'cfw
 137 |   :type 'string)
 138 | 
 139 | (defcustom cfw:event-format-days-overview "%s%e%t"
 140 |   "Format string of `cfw:event's for days overviews.
 141 |  See `cfw:event-format' for possible values."
 142 |   :group 'cfw
 143 |   :type 'string)
 144 | 
 145 | (defcustom cfw:event-format-period-overview "%t%l"
 146 |   "Format string of `cfw:event's for period overviews.
 147 |  See `cfw:event-format' for possible values."
 148 |   :group 'cfw
 149 |   :type 'string)
 150 | 
 151 | (defcustom cfw:event-format-detail "%s%e%t%l%d"
 152 |   "Format string of `cfw:event's for overviews (month-, week-, day-view).
 153 |  See `cfw:event-format' for possible values."
 154 |   :group 'cfw
 155 |   :type 'string)
 156 | 
 157 | (defcustom cfw:event-format-title "%s"
 158 |   "Format string for the title of a `cfw:event'
 159 | %s = title string"
 160 |   :group 'cfw
 161 |   :type 'string)
 162 | 
 163 | (defcustom cfw:event-format-start-date "%Y-%m-%d"
 164 |   "Format string for the start date of a `cfw:event'
 165 | %Y = year
 166 | %m = month
 167 | %d = day"
 168 |   :group 'cfw
 169 |   :type 'string)
 170 | 
 171 | (defcustom cfw:event-format-start-time "%H:%M "
 172 |   "Format string for the start time of a `cfw:event'
 173 | %H = hours
 174 | %M = minutes"
 175 |   :group 'cfw
 176 |   :type 'string)
 177 | 
 178 | (defcustom cfw:event-format-end-date "%Y-%m-%d"
 179 |   "Format string for the end date of a `cfw:event'
 180 | %Y = year
 181 | %m = month
 182 | %d = day"
 183 |   :group 'cfw
 184 |   :type 'string)
 185 | 
 186 | (defcustom cfw:event-format-end-time "- %H:%M "
 187 |   "Format string for the end time of a `cfw:event'
 188 | %H = hours
 189 | %M = minutes"
 190 |   :group 'cfw
 191 |   :type 'string)
 192 | 
 193 | (defcustom cfw:event-format-location "\n  Location:    %s"
 194 |   "Format string for the location of a `cfw:event'
 195 | %s = location string"
 196 |   :group 'cfw
 197 |   :type 'string)
 198 | 
 199 | (defcustom cfw:event-format-description "\n\n%s\n--------------------\n"
 200 |   "Format string for the description of a `cfw:event'
 201 | %s = location string"
 202 |   :group 'cfw
 203 |   :type 'string)
 204 | 
 205 | (defcustom cfw:display-calendar-holidays t
 206 |   "If not-nil, calfw displays holidays."
 207 |   :group 'cfw
 208 |   :type 'boolean)
 209 | 
 210 | ;;; Faces
 211 | 
 212 | (defface cfw:face-title
 213 |   '((((class color) (background light))
 214 |      :foreground "DarkGrey" :weight bold :height 2.0 :inherit variable-pitch)
 215 |     (((class color) (background dark))
 216 |      :foreground "darkgoldenrod3" :weight bold :height 2.0 :inherit variable-pitch)
 217 |     (t :height 1.5 :weight bold :inherit variable-pitch))
 218 |   "Face for title" :group 'calfw)
 219 | 
 220 | (defface cfw:face-header
 221 |   '((((class color) (background light))
 222 |      :foreground "Slategray4" :background "Gray90" :weight bold)
 223 |     (((class color) (background dark))
 224 |      :foreground "maroon2" :weight bold))
 225 |   "Face for headers" :group 'calfw)
 226 | 
 227 | (defface cfw:face-sunday
 228 |   '((((class color) (background light))
 229 |      :foreground "red2" :background "#ffd5e5" :weight bold)
 230 |     (((class color) (background dark))
 231 |      :foreground "red" :weight bold))
 232 |   "Face for Sunday" :group 'calfw)
 233 | 
 234 | (defface cfw:face-saturday
 235 |   '((((class color) (background light))
 236 |      :foreground "Blue" :background "#d4e5ff" :weight bold)
 237 |     (((class color) (background light))
 238 |      :foreground "Blue" :weight bold))
 239 |   "Face for Saturday" :group 'calfw)
 240 | 
 241 | (defface cfw:face-holiday
 242 |   '((((class color) (background light))
 243 |      :background "#ffd5e5")
 244 |     (((class color) (background dark))
 245 |      :background "grey10" :foreground "purple" :weight bold))
 246 |   "Face for holidays" :group 'calfw)
 247 | 
 248 | (defface cfw:face-grid
 249 |   '((((class color) (background light))
 250 |      :foreground "SlateBlue")
 251 |     (((class color) (background dark))
 252 |      :foreground "DarkGrey"))
 253 |   "Face for grids"
 254 |   :group 'calfw)
 255 | 
 256 | (defface cfw:face-default-content
 257 |   '((((class color) (background light))
 258 |      :foreground "#2952a3")
 259 |     (((class color) (background dark))
 260 |      :foreground "green2"))
 261 |   "Face for default contents"
 262 |   :group 'calfw)
 263 | 
 264 | (defface cfw:face-periods
 265 |   '((((class color) (background light))
 266 |      :background "#668cd9" :foreground "White" :slant italic)
 267 |     (((class color) (background dark))
 268 |      :foreground "cyan"))
 269 |   "Face for period" :group 'calfw)
 270 | 
 271 | (defface cfw:face-day-title
 272 |   '((((class color) (background light))
 273 |      :background "#f8f9ff")
 274 |     (((class color) (background dark))
 275 |      :background "grey10"))
 276 |   "Face for day title"
 277 |   :group 'calfw)
 278 | 
 279 | (defface cfw:face-default-day
 280 |   '((((class color) (background light))
 281 |      :weight bold :inherit cfw:face-day-title)
 282 |     (((class color) (background dark))
 283 |      :weight bold :inherit cfw:face-day-title))
 284 |   "Face for default day" :group 'calfw)
 285 | 
 286 | (defface cfw:face-annotation
 287 |   '((((class color)) :foreground "RosyBrown" :inherit cfw:face-day-title))
 288 |   "Face for annotations"
 289 |   :group 'calfw)
 290 | 
 291 | (defface cfw:face-disable
 292 |   '((((class color)) :foreground "DarkGray" :inherit cfw:face-day-title))
 293 |   "Face for days out of focused period"
 294 |   :group 'calfw)
 295 | 
 296 | (defface cfw:face-today-title
 297 |   '((((class color) (background light))
 298 |      :background "#fad163")
 299 |     (((class color) (background dark))
 300 |      :background "red4" :weight bold))
 301 |   "Face for today" :group 'calfw)
 302 | 
 303 | (defface cfw:face-today
 304 |   '((((class color) (background light))
 305 |      :background "#fff7d7")
 306 |     (((class color) (background dark))
 307 |      :foreground "Cyan" :weight bold))
 308 |   "Face for today" :group 'calfw)
 309 | 
 310 | (defvar cfw:face-item-separator-color "SlateBlue"
 311 |   "Color for the separator line of items in a day.")
 312 | 
 313 | (defface cfw:face-calendar-hidden
 314 |   '((((class color) (background light))
 315 |      :foreground "grey"  :strike-through t)
 316 |     (((class color) (background dark))
 317 |      :foreground "grey" :strike-through t)
 318 |     (t :foreground "grey" :strike-through t))
 319 |   "Face for calendars when hidden." :group 'calfw)
 320 | 
 321 | 
 322 | 
 323 | ;;; Utilities
 324 | 
 325 | (defun cfw:k (key alist)
 326 |   "[internal] Get a content by key from the given alist."
 327 |   (cdr (assq key alist)))
 328 | 
 329 | (defun cfw:sym (&rest strings)
 330 |   "[internal] concatenate `strings' and return as symbol."
 331 |   (intern-soft (apply 'concat strings)))
 332 | 
 333 | (defun cfw:rt (text face)
 334 |   "[internal] Put a face to the given text."
 335 |   (unless (stringp text) (setq text (format "%s" (or text ""))))
 336 |   (put-text-property 0 (length text) 'face face text)
 337 |   (put-text-property 0 (length text) 'font-lock-face face text)
 338 |   text)
 339 | 
 340 | (defun cfw:tp (text prop value)
 341 |   "[internal] Put a text property to the entire text string."
 342 |   (unless (stringp text) (setq text (format "%s" text)))
 343 |   (when (< 0 (length text))
 344 |     (put-text-property 0 (length text) prop value text))
 345 |   text)
 346 | 
 347 | (defun cfw:extract-text-props (text &rest excludes)
 348 |   "[internal] Return text properties."
 349 |   (cl-loop with ret = nil
 350 |            with props = (text-properties-at 0 text)
 351 |            for name = (car props)
 352 |            for val = (cadr props)
 353 |            while props
 354 |            do
 355 |            (when (and name (not (memq name excludes)))
 356 |              (setq ret (cons name (cons val ret))))
 357 |            (setq props (cddr props))
 358 |            finally return ret))
 359 | 
 360 | (defun cfw:define-keymap (keymap-list)
 361 |   "[internal] Key map definition utility.
 362 | KEYMAP-LIST is a source list like ((key . command) ... )."
 363 |   (let ((new-key-map (make-sparse-keymap)))
 364 |     (mapc
 365 |      (lambda (i)
 366 |        (define-key new-key-map
 367 |          (if (stringp (car i))
 368 |              (read-kbd-macro (car i)) (car i))
 369 |          (cdr i)))
 370 |      keymap-list)
 371 |     new-key-map))
 372 | 
 373 | (defun cfw:flatten (lst &optional revp)
 374 |   (cl-loop with ret = nil
 375 |            for i in lst
 376 |            do (setq ret (if (consp i)
 377 |                             (nconc (cfw:flatten i t) ret)
 378 |                           (cons i ret)))
 379 |            finally return (if revp ret (nreverse ret))))
 380 | 
 381 | 
 382 | 
 383 | ;;; Date Time Transformation
 384 | 
 385 | (defun cfw:date (month day year)
 386 |   "Construct a date object in the calendar format."
 387 |   (and month day year
 388 |        (list month day year)))
 389 | 
 390 | (defun cfw:time (hours minutes)
 391 |   "Construct a time object (local time) in the calendar format."
 392 |   (and hours minutes
 393 |        (list hours minutes)))
 394 | 
 395 | (defun cfw:emacs-to-calendar (time)
 396 |   "Transform an emacs time format to a calendar one."
 397 |   (let ((dt (decode-time time)))
 398 |     (list (nth 4 dt) (nth 3 dt) (nth 5 dt))))
 399 | 
 400 | (defun cfw:calendar-to-emacs (date)
 401 |   "Transform a calendar time format to an emacs one."
 402 |   (encode-time 0 0 0
 403 |                (calendar-extract-day date)
 404 |                (calendar-extract-month date)
 405 |                (calendar-extract-year date)))
 406 | 
 407 | (defun cfw:month-year-equal-p (date1 date2)
 408 |   "Return `t' if numbers of month and year of DATE1 is equals to
 409 | ones of DATE2. Otherwise is `nil'."
 410 |   (and
 411 |    (= (calendar-extract-month date1)
 412 |       (calendar-extract-month date2))
 413 |    (= (calendar-extract-year date1)
 414 |       (calendar-extract-year date2))))
 415 | 
 416 | (defun cfw:date-less-equal-p (d1 d2)
 417 |   "Return `t' if date value D1 is less than or equals to date value D2.
 418 |  i.e. (D1 <= D2) ? t : nil. "
 419 |   (let ((ed1 (cfw:calendar-to-emacs d1))
 420 |         (ed2 (cfw:calendar-to-emacs d2)))
 421 |     (or (equal ed1 ed2)
 422 |         (time-less-p ed1 ed2))))
 423 | 
 424 | (defun cfw:date-between (begin end date)
 425 |   "Return `t' if date value DATE exists between BEGIN and END."
 426 |   (and (cfw:date-less-equal-p begin date)
 427 |        (cfw:date-less-equal-p date end)))
 428 | 
 429 | (defun cfw:month-year-contain-p (month year date2)
 430 |   "Return `t' if date value DATE2 is included in MONTH and YEAR."
 431 |   (and
 432 |    (= month (calendar-extract-month date2))
 433 |    (= year (calendar-extract-year date2))))
 434 | 
 435 | (defun cfw:date-after (date num)
 436 |   "Return the date after NUM days from DATE."
 437 |   (calendar-gregorian-from-absolute
 438 |    (+ (calendar-absolute-from-gregorian date) num)))
 439 | 
 440 | (defun cfw:date-before (date num)
 441 |   "Return the date before NUM days from DATE."
 442 |   (calendar-gregorian-from-absolute
 443 |    (- (calendar-absolute-from-gregorian date) num)))
 444 | 
 445 | (defun cfw:strtime-emacs (time)
 446 |   "Format emacs time value TIME to the string form YYYY/MM/DD."
 447 |   (format-time-string "%Y/%m/%d" time))
 448 | 
 449 | (defun cfw:strtime (date)
 450 |   "Format calendar date value DATE to the string form YYYY/MM/DD."
 451 |   (cfw:strtime-emacs (cfw:calendar-to-emacs date)))
 452 | 
 453 | (defun cfw:parsetime-emacs (str)
 454 |   "Transform the string format YYYY/MM/DD to an emacs time value."
 455 |   (when (string-match "\\([0-9]+\\)\\/\\([0-9]+\\)\\/\\([0-9]+\\)" str)
 456 |     (apply 'encode-time
 457 |            (let (ret)
 458 |              (dotimes (i 6)
 459 |                (push (string-to-number (or (match-string (+ i 1) str) "0")) ret))
 460 |              ret))))
 461 | 
 462 | (defun cfw:parse-str-time (str)
 463 |   "Parsese a time string of the format HH:MM to an internal format."
 464 |   (when (string-match "\\([[:digit:]]\\{2\\}\\):\\([[:digit:]]\\{2\\}\\)" str)
 465 |     (cfw:time (string-to-number (match-string 1 str))
 466 |               (string-to-number (match-string 2 str)))))
 467 | 
 468 | (defun cfw:parsetime (str)
 469 |   "Transform the string format YYYY/MM/DD to a calendar date value."
 470 |   (cfw:emacs-to-calendar (cfw:parsetime-emacs str)))
 471 | 
 472 | (defun cfw:read-date-command-simple (string-date)
 473 |   "Move the cursor to the specified date."
 474 |   (interactive "sInput Date (YYYY/MM/DD): ")
 475 |   (cfw:parsetime string-date))
 476 | 
 477 | (defun cfw:days-diff (begin end)
 478 |   "Returns the number of days between `begin' and `end'."
 479 |   (- (time-to-days (cfw:calendar-to-emacs end))
 480 |      (time-to-days (cfw:calendar-to-emacs begin))))
 481 | 
 482 | (defun cfw:enumerate-days (begin end)
 483 |   "Enumerate date objects between BEGIN and END."
 484 |   (when (> (calendar-absolute-from-gregorian begin)
 485 |            (calendar-absolute-from-gregorian end))
 486 |     (error "Invalid period : %S - %S" begin end))
 487 |   (let ((d begin) ret (cont t))
 488 |     (while cont
 489 |       (push (copy-sequence d) ret)
 490 |       (setq cont (not (equal d end)))
 491 |       (setq d (cfw:date-after d 1)))
 492 |     (nreverse ret)))
 493 | 
 494 | (defun cfw:week-begin-date (date)
 495 |   "Return date of beginning of the week in which DATE is."
 496 |   (let ((num (- calendar-week-start-day
 497 |                 (calendar-day-of-week date))))
 498 |     (cfw:date-after date (if (< 0 num) (- num cfw:week-days) num))))
 499 | 
 500 | (defun cfw:week-end-date (date)
 501 |   "Return date of end of the week in which DATE is."
 502 |   (let ((num (+ (- calendar-week-start-day 1)
 503 |                 (- cfw:week-days (calendar-day-of-week date)))))
 504 |     (cfw:date-after date (cond
 505 |                           ((> 0 num) (+ num cfw:week-days))
 506 |                           ((<= cfw:week-days num) (- num cfw:week-days))
 507 |                           (t num)))))
 508 | 
 509 | 
 510 | 
 511 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 512 | ;;; Component
 513 | 
 514 | ;; This structure defines attributes of the calendar component.
 515 | ;; These attributes are internal use. Other programs should access
 516 | ;; through the functions of the component interface.
 517 | 
 518 | ;; [cfw:component]
 519 | ;; dest                   : an object of `cfw:dest'
 520 | ;; model                  : an object of the calendar model
 521 | ;; view                   : a symbol of view type (month, week, two-weeks, ...)
 522 | ;; update-hooks           : a list of hook functions for update event
 523 | ;; click-hooks            : a list of hook functions for click event
 524 | 
 525 | (cl-defstruct cfw:component dest model view
 526 |               update-hooks click-hooks)
 527 | 
 528 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 529 | ;;; Data Source
 530 | 
 531 | ;; This structure defines data sources of the calendar.
 532 | 
 533 | ;; [cfw:source]
 534 | ;; name   : data source title
 535 | ;; data   : a function that generates an alist of date-contents
 536 | ;; update : a function that is called when the user needs to update the contents (optional)
 537 | ;; color  : foreground color for normal items (optional)
 538 | ;; period-fgcolor  : foreground color for period items (optional)
 539 | ;; period-bgcolor  : background color for period items (optional)
 540 | ;; opt-face        : a plist of additional face properties for normal items (optional)
 541 | ;; opt-period-face : a plist of additional face properties for period items (optional)
 542 | ;; hidden  :  non-nil when it should be hidden in the current view
 543 | ;;
 544 | ;; If `period-bgcolor' is nil, the value of `color' is used.
 545 | ;; If `period-fgcolor' is nil, the black or white (negative color of `period-bgcolor') is used.
 546 | 
 547 | (cl-defstruct cfw:source name data update color period-bgcolor period-fgcolor opt-face opt-period-face hidden)
 548 | 
 549 | (defun cfw:source-period-bgcolor-get (source)
 550 |   "[internal] Return a background color for period items.
 551 | If `cfw:source-period-bgcolor' is nil, the value of
 552 | `cfw:source-color' is used."
 553 |   (or (cfw:source-period-bgcolor source)
 554 |       (let ((c (cfw:make-bg-color
 555 |                 (cfw:source-color source)
 556 |                 (cfw:source-period-fgcolor source))))
 557 |         (setf (cfw:source-period-bgcolor source) c)
 558 |         c)))
 559 | 
 560 | (defun cfw:source-period-fgcolor-get (source)
 561 |   "[internal] Return a foreground color for period items.
 562 | If `cfw:source-period-fgcolor' is nil, the black or
 563 | white (negative color of `cfw:source-period-bgcolor') is used."
 564 |   (or (cfw:source-period-fgcolor source)
 565 |       (let ((c (cfw:make-fg-color
 566 |                 (cfw:source-color source)
 567 |                 (cfw:source-period-bgcolor source))))
 568 |         (setf (cfw:source-period-fgcolor source) c)
 569 |         c)))
 570 | 
 571 | (defun cfw:make-fg-color (src-color _bg-color)
 572 |   ;; The calfw way
 573 |   ;; (cl-destructuring-bind
 574 |   ;;     (r g b) (color-values (or color "black"))
 575 |   ;;   (if (< 147500 (+ r g b)) "black" "white"))
 576 |                                         ; (* 65536 3 0.75)
 577 |   (cfw:composite-color src-color 0.7 (face-foreground 'default)))
 578 | 
 579 | (defun cfw:make-bg-color (src-color _fg-color)
 580 |   ;;src-color
 581 |   (cfw:composite-color src-color 0.3 (face-background 'default)))
 582 | 
 583 | (defun cfw:composite-color (clr1 alpha clr2)
 584 |   "Return the combination of CLR1 with ALPHA and CLR2.
 585 | CLR2 is composited with 1-ALPHA transpancy."
 586 |   (let* ((result-rgb (cl-mapcar
 587 |                       (lambda (c1 c2)
 588 |                         (+ (* alpha c1)
 589 |                            (* (- 1 alpha) c2)))
 590 |                       (color-name-to-rgb clr1)
 591 |                       (color-name-to-rgb clr2))))
 592 |     (apply 'color-rgb-to-hex (append result-rgb '(2)))))
 593 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 594 | ;;; Calendar event
 595 | 
 596 | ;; This structure defines calendar events.
 597 | (cl-defstruct cfw:event
 598 |   title       ; event title [string]
 599 |   start-date  ; start date of the event [cfw:date]
 600 |   start-time  ; start time of the event (optional)
 601 |   end-date    ; end date of the event [cfw:date] (optional)
 602 |   end-time    ; end of the event (optional)
 603 |   description ; event description [string] (optional)
 604 |   location    ; location [strting] (optional)
 605 |   source      ; [internal] source of the event
 606 |   status       ; 'cancelled, 'tentative, 'confirmed or nil
 607 |   data        ; reference to event data
 608 |   )
 609 | 
 610 | (defun cfw:event-overview (event)
 611 |   "Function that extracts the overview string from a`cfw:event'."
 612 |   (cfw:event-format event cfw:event-format-overview))
 613 | 
 614 | (defun cfw:event-days-overview (event)
 615 |   "Function that extracts the days overview string from a`cfw:event'."
 616 |   (cfw:event-format event cfw:event-format-days-overview))
 617 | 
 618 | (defun cfw:event-period-overview (event)
 619 |   "Function that extracts the period overview string from a`cfw:event'."
 620 |   (cfw:event-format event cfw:event-format-period-overview))
 621 | 
 622 | (defun cfw:event-detail (event)
 623 |   "Function that extracts the details string from a`cfw:event'."
 624 |   (cfw:event-format event cfw:event-format-detail))
 625 | 
 626 | (defun cfw:event-format-field-string (string)
 627 |   "[internal] Used by `cfw:event-format-field' to format string values."
 628 |   `((?s . ,string)))
 629 | 
 630 | (defun cfw:event-format-field-time (time)
 631 |   "[internal] Used by `cfw:event-format-field' to format time values."
 632 |   `((?H . ,(cfw:event-format-field-number (car time) 2))
 633 |     (?M . ,(cfw:event-format-field-number (cadr time) 2))))
 634 | 
 635 | (defun cfw:event-format-field-date (date)
 636 |   "[internal] Used by `cfw:event-format-field' to format date values."
 637 |   `((?Y . ,(cfw:event-format-field-number (caddr date) 4))
 638 |     (?m . ,(cfw:event-format-field-number (car date) 2))
 639 |     (?d . ,(cfw:event-format-field-number (cadr date) 2))))
 640 | 
 641 | (defun cfw:event-format-field-number (num width)
 642 |   "[internal] Like `number-to-string', but with width specifier. Padded with zeros."
 643 |   (format (concat "%0" (number-to-string width) "d") num))
 644 | 
 645 | (defun cfw:event-format-field (event field args-fun)
 646 |   "[internal] format `field' of the `cfw:event' `event' according to
 647 | the string specified in cfw:event-format-`field'."
 648 |   (let* ((s-name        (symbol-name field))
 649 |          (format-string (symbol-value (cfw:sym "cfw:event-format-" s-name)))
 650 |          (field-val     (funcall (cfw:sym "cfw:event-" s-name) event)))
 651 |     (if field-val
 652 |         (format-spec format-string (funcall args-fun field-val))
 653 |       "")))
 654 | 
 655 | (defun cfw:event-format (event format-string)
 656 |   "Format the `cfw:event' `event' according to `format-string'.
 657 | 
 658 | The following values are possible:
 659 | 
 660 | %t = title
 661 | %S = start date
 662 | %s = start time
 663 | %E = end date
 664 | %e = end time
 665 | %l = Location
 666 | %d = Description"
 667 |   (cfw:tp
 668 |    (format-spec
 669 |     format-string
 670 |     (mapcar #'(lambda (field)
 671 |                 `(,(car field) . ,(cfw:event-format-field
 672 |                                    event (cadr field) (caddr field))))
 673 |             '((?t title       cfw:event-format-field-string)
 674 |               (?S start-date  cfw:event-format-field-date)
 675 |               (?s start-time  cfw:event-format-field-time)
 676 |               (?E end-date    cfw:event-format-field-date)
 677 |               (?e end-time    cfw:event-format-field-time)
 678 |               (?l location    cfw:event-format-field-string)
 679 |               (?d description cfw:event-format-field-string))))
 680 |    'cfw:source (cfw:event-source event)))
 681 | 
 682 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 683 | ;;; Rendering Destination
 684 | 
 685 | ;; This structure object is the abstraction of the rendering
 686 | ;; destinations, such as buffers, regions and so on.
 687 | 
 688 | ;; [cfw:dest]
 689 | ;; type        : identify symbol for destination type. (buffer, region, text)
 690 | ;; buffer      : a buffer object of rendering destination.
 691 | ;; min-func    : a function that returns upper limit of rendering destination.
 692 | ;; max-func    : a function that returns lower limit of rendering destination.
 693 | ;; width       : width of the reference size.
 694 | ;; height      : height of the reference size.
 695 | ;; clear-func  : a function that clears the rendering destination.
 696 | ;; before-update-func : a function that is called at the beginning of rendering routine.
 697 | ;; after-update-func  : a function that is called at the end of rendering routine.
 698 | ;; today-ol    : a list of overlays for today
 699 | 
 700 | (cl-defstruct cfw:dest
 701 |   type buffer min-func max-func width height
 702 |   clear-func before-update-func after-update-func today-ol)
 703 | 
 704 | ;; shortcut functions
 705 | (defmacro cfw:dest-with-region (dest &rest body)
 706 |     (let (($dest (gensym)))
 707 |       `(let ((,$dest ,dest))
 708 |          (with-current-buffer (cfw:dest-buffer ,$dest)
 709 |            (save-restriction
 710 |              (narrow-to-region
 711 |               (cfw:dest-point-min ,$dest) (cfw:dest-point-max ,$dest))
 712 |            ,@body)))))
 713 | (put 'cfw:dest-with-region 'lisp-indent-function 1)
 714 | 
 715 | (defun cfw:dest-point-min (c)
 716 |   (funcall (cfw:dest-min-func c)))
 717 | 
 718 | (defun cfw:dest-point-max (c)
 719 |   (funcall (cfw:dest-max-func c)))
 720 | 
 721 | (defun cfw:dest-clear (c)
 722 |   (funcall (cfw:dest-clear-func c)))
 723 | 
 724 | (defun cfw:dest-before-update (c)
 725 |   (when (cfw:dest-before-update-func c)
 726 |     (funcall (cfw:dest-before-update-func c))))
 727 | 
 728 | (defun cfw:dest-after-update (c)
 729 |   (when (cfw:dest-after-update-func c)
 730 |     (funcall (cfw:dest-after-update-func c))))
 731 | 
 732 | ;; private functions
 733 | 
 734 | (defun cfw:dest-ol-today-clear (dest)
 735 |   "[internal] Clear decoration overlays."
 736 |   (cl-loop for i in (cfw:dest-today-ol dest)
 737 |            do (delete-overlay i))
 738 |   (setf (cfw:dest-today-ol dest) nil))
 739 | 
 740 | (defun cfw:dest-ol-today-set (dest)
 741 |   "[internal] Put a highlight face on today."
 742 |   (let (ols)
 743 |     (cfw:dest-with-region dest
 744 |       (cfw:find-all-by-date
 745 |        dest (calendar-current-date)
 746 |        (lambda (begin end)
 747 |          (let ((overlay (make-overlay begin end)))
 748 |            (overlay-put overlay 'face
 749 |                         (if (eq 'cfw:face-day-title
 750 |                                 (get-text-property begin 'face))
 751 |                             'cfw:face-today-title 'cfw:face-today))
 752 |            (push overlay ols)))))
 753 |     (setf (cfw:dest-today-ol dest) ols)))
 754 | 
 755 | 
 756 | 
 757 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 758 | ;;; Low level API
 759 | 
 760 | ;; Buffer
 761 | 
 762 | (defconst cfw:calendar-buffer-name "*cfw-calendar*" "[internal] Default buffer name for the calendar view.")
 763 | 
 764 | (defun cfw:dest-init-buffer (&optional buf width height custom-map)
 765 |   "Create a buffer destination.
 766 | This destination uses an entire buffer and set up the major-mode
 767 | `cfw:calendar-mode' and the key map `cfw:calendar-mode-map'.  BUF
 768 | is a buffer name to render the calendar view. If BUF is nil, the
 769 | default buffer name `cfw:calendar-buffer-name' is used.  WIDTH
 770 | and HEIGHT are reference size of the calendar view. If those are
 771 | nil, the size of calendar is calculated from the window that
 772 | shows BUF or the selected window.  The component
 773 | object is stored at the buffer local variable `cfw:component'.
 774 | CUSTOM-MAP is the additional keymap that is added to default
 775 | keymap `cfw:calendar-mode-map'."
 776 |   (let
 777 |    ((buffer (or buf (get-buffer-create cfw:calendar-buffer-name)))
 778 |     (window (or (and buf (get-buffer-window buf)) (selected-window)))
 779 |     dest)
 780 |    (setq dest
 781 |          (make-cfw:dest
 782 |           :type 'buffer
 783 |           :min-func 'point-min
 784 |           :max-func 'point-max
 785 |           :buffer buffer
 786 |           :width (or width (window-width window))
 787 |           :height (or height (window-height window))
 788 |           :clear-func (lambda ()
 789 |                         (with-current-buffer buffer
 790 |                           (erase-buffer)))))
 791 |    (with-current-buffer buffer
 792 |      (unless (eq major-mode 'cfw:calendar-mode)
 793 |        (cfw:calendar-mode custom-map)))
 794 |    dest))
 795 | 
 796 | ;; Region
 797 | 
 798 | (defun cfw:dest-init-region (buf mark-begin mark-end &optional width height)
 799 |   "Create a region destination.  The calendar is drew between
 800 | MARK-BEGIN and MARK-END in the buffer BUF.  MARK-BEGIN and
 801 | MARK-END are separated by more than one character, such as a
 802 | space.  This destination is employed to be embedded in the some
 803 | application buffer.  Because this destination does not set up
 804 | any modes and key maps for the buffer, the application that uses
 805 | the calfw is responsible to manage the buffer and key maps."
 806 |   (let
 807 |       ((mark-begin mark-begin) (mark-end mark-end)
 808 |        (window (or (get-buffer-window buf) (selected-window))))
 809 |     (make-cfw:dest
 810 |      :type 'region
 811 |      :min-func (lambda () (marker-position mark-begin))
 812 |      :max-func (lambda () (marker-position mark-end))
 813 |      :buffer buf
 814 |      :width (or width (window-width window))
 815 |      :height (or height (window-height window))
 816 |      :clear-func
 817 |      (lambda ()
 818 |        (cfw:dest-region-clear (marker-position mark-begin)
 819 |                               (marker-position mark-end)))
 820 |      )))
 821 | 
 822 | (defun cfw:dest-region-clear (begin end)
 823 |   "[internal] Clear the content text."
 824 |   (when (< 2 (- end begin))
 825 |     (delete-region begin (1- end)))
 826 |   (goto-char begin))
 827 | 
 828 | ;; Inline text
 829 | 
 830 | (defconst cfw:dest-background-buffer " *cfw:dest-background*")
 831 | 
 832 | (defun cfw:dest-init-inline (width height)
 833 |   "Create a text destination."
 834 |   (let
 835 |    ((buffer (get-buffer-create cfw:dest-background-buffer))
 836 |     (window (selected-window))
 837 |     dest)
 838 |    (setq dest
 839 |          (make-cfw:dest
 840 |           :type 'text
 841 |           :min-func 'point-min
 842 |           :max-func 'point-max
 843 |           :buffer buffer
 844 |           :width (or width (window-width window))
 845 |           :height (or height (window-height window))
 846 |           :clear-func (lambda ()
 847 |                         (with-current-buffer buffer
 848 |                           (erase-buffer)))))
 849 |    dest))
 850 | 
 851 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 852 | ;;; Component API
 853 | 
 854 | ;; Create
 855 | 
 856 | (defun cfw:cp-new (dest model view &optional initial-date)
 857 |   "[internal] Create a new component object.
 858 | DEST is a cfw:dest object.  MODEL is a model object.  VIEW is a
 859 | symbol of the view type: month, two-weeks, week and day.
 860 | This function is called by the initialization functions,
 861 | `cfw:create-calendar-component-buffer',
 862 | `cfw:create-calendar-component-region' and
 863 | `cfw:get-calendar-text'."
 864 |   (let ((cp (make-cfw:component
 865 |              :dest  dest
 866 |              :model model
 867 |              :view  (or view 'month))))
 868 |     (cfw:cp-update cp initial-date)
 869 |     cp))
 870 | 
 871 | ;; Getting the component instance
 872 | 
 873 | (defun cfw:cp-get-component (&optional noerror)
 874 |   "Return the component object on the current cursor position.
 875 | Firstly, getting a text property `cfw:component' on the current
 876 | position. If no object is found in the text property, the buffer
 877 | local variable `cfw:component' is tried to get. If no object is
 878 | found at the variable, return nil."
 879 |   (or (get-text-property (point) 'cfw:component)
 880 |       (if (local-variable-p 'cfw:component (current-buffer))
 881 |           (buffer-local-value 'cfw:component (current-buffer))
 882 |         (unless noerror
 883 |           (error "Not found cfw:component attribute...")))))
 884 | 
 885 | ;; Getter
 886 | 
 887 | (defun cfw:cp-get-contents-sources (component &optional exclude-hidden)
 888 |   "Return a list of the content sources."
 889 |   (cfw:model-get-contents-sources (cfw:component-model component)
 890 |                                   exclude-hidden))
 891 | 
 892 | (defun cfw:cp-get-annotation-sources (component)
 893 |   "Return a list of the annotation sources."
 894 |   (cfw:model-get-annotation-sources (cfw:component-model component)))
 895 | 
 896 | (defun cfw:cp-get-view (component)
 897 |   "Return a symbol of the current view type."
 898 |   (cfw:component-view component))
 899 | 
 900 | (defun cfw:cp-get-buffer (component)
 901 |   "Return a buffer object on which the component draws the content."
 902 |   (cfw:dest-buffer (cfw:component-dest component)))
 903 | 
 904 | (defun cfw:cp-displayed-date-p (component date)
 905 |   "Return non-nil if the date is displayed in the current view."
 906 |   (let* ((model (cfw:component-model component))
 907 |          (begin (cfw:k 'begin-date model))
 908 |          (end (cfw:k 'end-date model)))
 909 |     (unless (and begin end) (error "Wrong model : %S" model))
 910 |     (cfw:date-between begin end date)))
 911 | 
 912 | ;; Setter
 913 | (defun cfw:cp-move-cursor (dest date &optional force)
 914 |   "[internal] Just move the cursor onto the date."
 915 |   (when (or force
 916 |             ;; Check if there's a current component, otherwise
 917 |             ;; `cfw:cursor-to-nearest-date' signals an error.
 918 |             (null (cfw:cp-get-component t))
 919 |             (not (equal (cfw:cursor-to-date) date)))
 920 |   (let ((pos (cfw:find-by-date dest date)))
 921 |     (when pos
 922 |       (goto-char pos)
 923 |       (unless (eql (selected-window) (get-buffer-window (current-buffer)))
 924 |           (set-window-point (get-buffer-window (current-buffer)) pos))))))
 925 | 
 926 | (defun cfw:cp-set-contents-sources (component sources)
 927 |   "Set content sources for the component.
 928 | SOURCES is a list of content sources."
 929 |   (cfw:model-set-contents-sources
 930 |    (cfw:component-model component) sources))
 931 | 
 932 | (defun cfw:cp-set-annotation-sources (component sources)
 933 |   "Set annotation sources for the component.
 934 | SOURCES is a list of annotation sources."
 935 |   (cfw:model-set-annotation-sources
 936 |    sources (cfw:component-model component)))
 937 | 
 938 | (defun cfw:cp-set-view (component view)
 939 |   "Change the view type of the component and re-draw the content.
 940 | VIEW is a symbol of the view type."
 941 |   (setf (cfw:component-view component) view)
 942 |   (cfw:cp-update component))
 943 | 
 944 | (defun cfw:cp-resize (component width height)
 945 |   "Resize the component size and re-draw the content."
 946 |   (let* ((dest (cfw:component-dest component))
 947 |          (buf (cfw:dest-buffer dest))
 948 |          (window (or (and buf (get-buffer-window buf)) (selected-window))))
 949 |     (setf (cfw:dest-width dest) (or width (window-width window))
 950 |           (cfw:dest-height dest) (or height (window-height window)))))
 951 | 
 952 | ;; Hook
 953 | 
 954 | (defun cfw:cp-add-update-hook (component hook)
 955 |   "Add the update hook function to the component.
 956 | HOOK is a function that has no argument."
 957 |   (push hook (cfw:component-update-hooks component)))
 958 | 
 959 | (defun cfw:cp-add-click-hook (component hook)
 960 |   "Add the click hook function to the component.
 961 | HOOK is a function that has no argument."
 962 |   (push hook (cfw:component-click-hooks component)))
 963 | 
 964 | 
 965 | 
 966 | ;;; private methods
 967 | 
 968 | (defvar cfw:cp-dipatch-funcs
 969 |   '((month             .  cfw:view-month)
 970 |     (week              .  cfw:view-week)
 971 |     (two-weeks         .  cfw:view-two-weeks)
 972 |     (day               .  cfw:view-day))
 973 |   "Dispatch functions for calfw views.")
 974 | 
 975 | (defun cfw:cp-dispatch-view-impl (view)
 976 |   "[internal] Return a view function which is corresponding to the view symbol.
 977 | VIEW is a symbol of the view type."
 978 |   (or (alist-get view cfw:cp-dipatch-funcs)
 979 |       (error "Not found such view : %s" view)))
 980 | 
 981 | (defvar cfw:highlight-today t
 982 |   "Variable to control whether today is rendered differently than other days.")
 983 | 
 984 | (defun cfw:cp-update (component &optional initial-date)
 985 |   "[internal] Clear and re-draw the component content."
 986 |   (let* ((buf (cfw:cp-get-buffer component))
 987 |          (dest (cfw:component-dest component)))
 988 |     (with-current-buffer buf
 989 |       (cfw:dest-before-update dest)
 990 |       (cfw:dest-ol-today-clear dest)
 991 |       (let ((buffer-read-only nil))
 992 |         (cfw:dest-with-region dest
 993 |                               (cfw:dest-clear dest)
 994 |                               (funcall (cfw:cp-dispatch-view-impl
 995 |                                         (cfw:component-view component))
 996 |                                        component)))
 997 |       (when cfw:highlight-today
 998 |         (cfw:dest-ol-today-set dest))
 999 |       (when initial-date
1000 |         (cfw:cp-goto-date component initial-date))
1001 |       (cfw:dest-after-update dest)
1002 |       (cfw:cp-fire-update-hooks component))))
1003 | 
1004 | (defun cfw:cp-fire-click-hooks (component)
1005 |   "[internal] Call click hook functions of the component with no arguments."
1006 |   (cl-loop for f in (cfw:component-click-hooks component)
1007 |         do (condition-case err
1008 |                (funcall f)
1009 |              (error (message "Calfw: Click / Hook error %S [%s]" f err)))))
1010 | 
1011 | (defun cfw:cp-fire-update-hooks (component)
1012 |   "[internal] Call update hook functions of the component with no arguments."
1013 |   (cl-loop for f in (cfw:component-update-hooks component)
1014 |         do (condition-case err
1015 |                (funcall f)
1016 |              (error (message "Calfw: Update / Hook error %S [%s]" f err)))))
1017 | 
1018 | 
1019 | 
1020 | ;;; Models
1021 | 
1022 | (defvar cfw:default-text-sorter 'string-lessp "[internal] Default sorting criteria in a calendar cell.")
1023 | 
1024 | (defun cfw:model-abstract-new (date contents-sources annotation-sources &optional sorter)
1025 |   "Return an abstract model object.
1026 | DATE is initial date for the calculation of the start date and end one.
1027 | CONTENTS-SOURCES is a list of contents functions.
1028 | ANNOTATION-SOURCES is a list of annotation functions."
1029 |   (unless date (setq date (calendar-current-date)))
1030 |   `((init-date . ,date)
1031 |     (contents-sources . ,contents-sources)
1032 |     (annotation-sources . ,annotation-sources)
1033 |     (sorter . ,(or sorter cfw:default-text-sorter))))
1034 | 
1035 | (defun cfw:model-abstract-derived (date org-model)
1036 |   "Return an abstract model object.
1037 | 
1038 | The contents functions and annotation ones are copied from ORG-MODEL.
1039 | DATE is initial date for the calculation of the start date and end one.
1040 | ORG-MODEL is a model object to inherit."
1041 |   (cfw:model-abstract-new
1042 |    date
1043 |    (cfw:model-get-contents-sources org-model)
1044 |    (cfw:model-get-annotation-sources org-model)
1045 |    (cfw:model-get-sorter org-model)))
1046 | 
1047 | (defun cfw:model-create-updated-view-data (model view-data)
1048 |   "Clear previous view model data from MODEL and return a new model.
1049 | The new model is created with with VIEW-DATA.
1050 | [internal]"
1051 |   (append
1052 |    (cfw:model-abstract-derived
1053 |     (cfw:k 'init-date model) model)
1054 |    view-data))
1055 | 
1056 | ;; public functions
1057 | 
1058 | (defun cfw:model-get-holiday-by-date (date model)
1059 |   "Return a holiday title on the DATE."
1060 |   (cfw:contents-get date (cfw:k 'holidays model)))
1061 | 
1062 | (defun cfw:model-get-contents-by-date (date model)
1063 |   "Return a list of contents on the DATE."
1064 |   (cfw:contents-get date (cfw:k 'contents model)))
1065 | 
1066 | (defun cfw:model-get-annotation-by-date (date model)
1067 |   "Return an annotation on the DATE."
1068 |   (cfw:contents-get date (cfw:k 'annotations model)))
1069 | 
1070 | (defun cfw:model-get-periods-by-date (date model)
1071 |   "Return a list of periods on the DATE."
1072 |   (cl-loop for (begin end event) in (cfw:k 'periods model)
1073 |         for content = (if (cfw:event-p event)
1074 |                           (cfw:event-detail event)
1075 |                         event)
1076 |         if (cfw:date-between begin end date)
1077 |         collect `(,begin ,end ,content)))
1078 | 
1079 | (defun cfw:model-get-sorter (model)
1080 |   "Return a sorter function."
1081 |   (cfw:k 'sorter model))
1082 | 
1083 | ;; private functions
1084 | 
1085 | (defun cfw:model-get-contents-sources (model &optional exclude-hidden)
1086 |   "[internal] Return a list of content sources of the model."
1087 |   (let ((sources (cfw:k 'contents-sources model)))
1088 |     (if exclude-hidden
1089 |         (seq-filter (lambda (s) (not (cfw:source-hidden s)))
1090 |                     sources)
1091 |       sources)))
1092 | 
1093 | (defun cfw:model-get-annotation-sources (model)
1094 |   "[internal] Return a list of annotation sources of the model."
1095 |   (cfw:k 'annotation-sources model))
1096 | 
1097 | (defun cfw:model-set-init-date (date model)
1098 |   "[internal] Set the init-date that is used to calculate the
1099 | display period of the calendar."
1100 |   (let ((cell (assq 'init-date model)))
1101 |     (cond
1102 |      (cell (setcdr cell date))
1103 |      (t (push (cons 'init-date date) model))))
1104 |   date)
1105 | 
1106 | (defun cfw:model-set-contents-sources (sources model)
1107 |   "[internal] Set the content sources of the model."
1108 |   (let ((cell (assq 'contents-sources model)))
1109 |     (cond
1110 |      (cell (setcdr cell sources))
1111 |      (t (push (cons 'contents-sources sources) model))))
1112 |   sources)
1113 | 
1114 | (defun cfw:model-set-annotation-sources (sources model)
1115 |   "[internal] Set the annotation sources of the model."
1116 |   (let ((cell (assq 'annotation-sources model)))
1117 |     (cond
1118 |      (cell (setcdr cell sources))
1119 |      (t (push (cons 'annotation-sources sources) model))))
1120 |   sources)
1121 | 
1122 | (defun cfw:contents-get (date contents)
1123 |   "[internal] Return a list of contents on the DATE."
1124 |   (cdr (cfw:contents-get-internal date contents)))
1125 | 
1126 | (defun cfw:contents-get-internal (date contents)
1127 |   "[internal] Return a cons cell that has the key DATE.
1128 | One can modify the returned cons cell destructively."
1129 |   (cond
1130 |    ((or (null date) (null contents)) nil)
1131 |    (t (cl-loop for i in contents
1132 |             if (equal date (car i))
1133 |             return i
1134 |             finally return nil))))
1135 | 
1136 | (defun cfw:contents-add (date content contents)
1137 |   "[internal] Add a record, DATE as a key and CONTENT as a body,
1138 | to CONTENTS destructively. If CONTENTS has a record for DATE,
1139 | this function appends CONTENT to the record. Return the modified
1140 | contents list."
1141 |   (let* ((prv (cfw:contents-get-internal date contents))
1142 |          (lst (if (listp content) (copy-sequence content) (list content))))
1143 |     (if prv
1144 |         (setcdr prv (append (cdr prv) lst))
1145 |       (push (cons date lst) contents)))
1146 |   contents)
1147 | 
1148 | (defun cfw:contents-merge (begin end sources)
1149 |   "[internal] Return an contents alist between begin date and end one,
1150 | calling functions `:data' function."
1151 |   (cond
1152 |    ((null sources) nil)
1153 |    (t
1154 |     (cl-loop for s in sources
1155 |           for f = (cfw:source-data s)
1156 |           for cnts = (cfw:contents-put-source
1157 |                       (funcall f begin end) s)
1158 |           with contents = nil
1159 |           do
1160 |           (cl-loop for c in cnts
1161 |                 for (d . line) = c
1162 |                 do (setq contents (cfw:contents-add d line contents)))
1163 |           finally return contents))))
1164 | 
1165 | (defun cfw:periods-put-source (periods source)
1166 |   (cl-loop for period in periods
1167 |         collect
1168 |         (cond
1169 |          ((cfw:event-p period)
1170 |           (setf (cfw:event-source period) source)
1171 |           `(,(cfw:event-start-date period)
1172 |             ,(cfw:event-end-date period)
1173 |             ,period))
1174 |          (t
1175 |           (cl-destructuring-bind (begin end . summaries) period
1176 |             (list begin end
1177 |                   (cfw:tp (if (listp summaries)
1178 |                               (mapconcat 'identity (cfw:flatten summaries) " ")
1179 |                             summaries)
1180 |                           'cfw:source source)))))))
1181 | 
1182 | (defun cfw:contents-put-source (contents source)
1183 |   "[internal] Put the source object to the text property
1184 | `cfw:source' in the contents list. During rendering, the source
1185 | object is used to put some face property."
1186 |   (cond
1187 |    ((null source) contents)
1188 |    (t
1189 |     (cl-loop for content in contents
1190 |           collect
1191 |           (cond
1192 |            ((cfw:event-p content)
1193 |             (setf (cfw:event-source content) source)
1194 |             `(,(cfw:event-start-date content) ,content))
1195 |            ((eq (car content) 'periods)
1196 |             (cons 'periods
1197 |                   (cfw:periods-put-source (cdr content) source)))
1198 |            (t
1199 |             (cons (car content)
1200 |                   (cl-loop for i in (cdr content)
1201 |                         collect (cfw:tp i 'cfw:source source)))))))))
1202 | 
1203 | (defun cfw:annotations-merge (begin end sources)
1204 |   "[internal] Return an annotation alist between begin date and end one,
1205 | calling functions `cfw:annotations-functions'."
1206 |   (cond
1207 |    ((null sources) nil)
1208 |    ((= 1 (length sources))
1209 |     (funcall (cfw:source-data (car sources)) begin end))
1210 |    (t
1211 |     (cl-loop for s in sources
1212 |           for f = (cfw:source-data s)
1213 |           for cnts = (funcall f begin end)
1214 |           with annotations = nil
1215 |           do
1216 |           (cl-loop for c in cnts
1217 |                 for (d . line) = c
1218 |                 for prv = (cfw:contents-get-internal d annotations)
1219 |                 if prv
1220 |                 do (setcdr prv (concat (cdr prv) "/" line))
1221 |                 else
1222 |                 do (push (cons d line) annotations))
1223 |           finally return annotations))))
1224 | 
1225 | 
1226 | 
1227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1228 | ;;; Rendering Utilities
1229 | 
1230 | (defun cfw:render-title-month (date)
1231 |   "Render the calendar title for the monthly view."
1232 |   (format "%4s / %s"
1233 |           (calendar-extract-year date)
1234 |           (aref calendar-month-name-array
1235 |                 (1- (calendar-extract-month date)))))
1236 | 
1237 | (defun cfw:render-title-period (begin-date end-date)
1238 |   "Render the calendar title for the period view between BEGIN-DATE and END-DATE."
1239 |   (cond
1240 |    ((eql (calendar-extract-month begin-date) (calendar-extract-month end-date))
1241 |     (format "%4s / %s %s - %s"
1242 |             (calendar-extract-year begin-date)
1243 |             (aref calendar-month-name-array (1- (calendar-extract-month begin-date)))
1244 |             (calendar-extract-day begin-date)
1245 |             (calendar-extract-day end-date)))
1246 |    (t
1247 |     (format "%4s / %s %s - %s %s"
1248 |             (calendar-extract-year begin-date)
1249 |             (aref calendar-month-name-array (1- (calendar-extract-month begin-date)))
1250 |             (calendar-extract-day begin-date)
1251 |             (aref calendar-month-name-array (1- (calendar-extract-month end-date)))
1252 |             (calendar-extract-day end-date)))))
1253 | 
1254 | (defun cfw:render-title-day (date)
1255 |   "Render the calendar title for the day view on DATE."
1256 |   (format "%4s / %s %s"
1257 |           (calendar-extract-year date)
1258 |           (aref calendar-month-name-array
1259 |                 (1- (calendar-extract-month date)))
1260 |           (calendar-extract-day date)))
1261 | 
1262 | (defun cfw:render-center (width string &optional padding)
1263 |   "[internal] Format STRING in the center, padding on the both
1264 | sides with the character PADDING."
1265 |   (let* ((padding (or padding ?\ ))
1266 |          (cnt (or (and string
1267 |                        (cfw:render-truncate string width t))
1268 |                   ""))
1269 |          (len (string-width cnt))
1270 |          (margin (/ (- width len) 2)))
1271 |     (concat
1272 |      (make-string margin padding) cnt
1273 |      (make-string (- width len margin) padding))))
1274 | 
1275 | (defun cfw:render-left (width string &optional padding)
1276 |   "[internal] Format STRING, padding on the right with the character PADDING."
1277 |   (let* ((padding (or padding ?\ ))
1278 |          (cnt (or (and string
1279 |                        (cfw:render-truncate string width t))
1280 |                   ""))
1281 |          (len (string-width cnt))
1282 |          (margin (- width len)))
1283 |     (concat cnt (make-string margin padding))))
1284 | 
1285 | (defun cfw:render-separator (string)
1286 |   "[internal] Add a separator into the ROWS list."
1287 |   (when (get-text-property 0 'cfw:item-separator string)
1288 |     (let ((last-face (get-text-property 0 'face string)))
1289 |       (cond
1290 |        ((or (null last-face) (listp last-face))
1291 |         (setq last-face (append last-face `(:underline ,cfw:face-item-separator-color)))
1292 |         (put-text-property 0 (length string) 'face last-face string)
1293 |         (put-text-property 0 (length string) 'font-lock-face last-face string))
1294 |        ((symbolp last-face)
1295 |         (let ((attrs (face-all-attributes last-face (selected-frame))))
1296 |           (setq attrs ; transform alist to plist
1297 |                 (cl-loop with nattrs = nil
1298 |                       for (n . v) in (append attrs `((:underline . ,cfw:face-item-separator-color)))
1299 |                       do (setq nattrs (cons n (cons v nattrs)))
1300 |                       finally return nattrs))
1301 |           (put-text-property 0 (length string) 'face attrs string)
1302 |           (put-text-property 0 (length string) 'font-lock-face attrs string)))
1303 |        (t
1304 |         (message "DEBUG? CFW: FACE %S / %S" string last-face)))))
1305 |   string)
1306 | 
1307 | (defun cfw:render-right (width string &optional padding)
1308 |   "[internal] Format STRING, padding on the left with the character PADDING."
1309 |   (let* ((padding (or padding ?\ ))
1310 |          (cnt (or (and string
1311 |                        (cfw:render-truncate string width t))
1312 |                   ""))
1313 |          (len (string-width cnt))
1314 |          (margin (- width len)))
1315 |     (concat (make-string margin padding) cnt)))
1316 | 
1317 | (defun cfw:render-add-right (width left right &optional padding)
1318 |   "[internal] Layout strings LEFT and RIGHT within WIDTH."
1319 |   (let* ((padding (or padding ?\ ))
1320 |          (lcnt (or (and left
1321 |                         (cfw:render-truncate left width t))
1322 |                    ""))
1323 |          (llen (string-width lcnt))
1324 |          (rmargin (- width llen))
1325 |          (right (string-trim right))
1326 |          (rcnt (or (and right (> rmargin 0)
1327 |                         (cfw:render-truncate right rmargin))
1328 |                    ""))
1329 |          (cmargin (- width llen (string-width rcnt))))
1330 |     (concat lcnt (if (< 0 cmargin) (make-string cmargin padding)) rcnt)))
1331 | 
1332 | (defun cfw:render-sort-contents (lst sorter)
1333 |   "[internal] Sort the string list LST. Maybe need to improve the sorting rule..."
1334 |   (sort (copy-sequence lst) sorter))
1335 | 
1336 | (defun cfw:render-get-face-period (text default-face)
1337 |   "[internal] Return a face for the source object of the period text."
1338 |   (let* ((src (get-text-property 0 'cfw:source text))
1339 |          (bg-color (and src (cfw:source-period-bgcolor-get src)))
1340 |          (fg-color (and src (cfw:source-period-fgcolor-get src))))
1341 |     (cond
1342 |      ((or (null src) (null bg-color)) default-face)
1343 |      (t (append (list ':background bg-color ':foreground fg-color)
1344 |                 (cfw:source-opt-period-face src))))))
1345 | 
1346 | (defun cfw:render-get-face-content (text default-face)
1347 |   "[internal] Return a face for the source object of the content text."
1348 |   (let* ((src (get-text-property 0 'cfw:source text))
1349 |          (fg-color (and src (cfw:source-color src))))
1350 |     (cond
1351 |      ((or (null src) (null fg-color)) default-face)
1352 |      (t (append (list ':foreground (cfw:make-fg-color fg-color fg-color)
1353 |                       ':background (cfw:make-bg-color fg-color fg-color))
1354 |                 (cfw:source-opt-face src))))))
1355 | 
1356 | (defun cfw:render-default-content-face (str &optional default-face)
1357 |   "[internal] Put the default content face. If STR has some
1358 | faces, the faces are remained."
1359 |   (cl-loop for i from 0 below (length str)
1360 |         with ret = (substring str 0)
1361 |         with face = (or default-face
1362 |                         (cfw:render-get-face-content
1363 |                          str 'cfw:face-default-content))
1364 |         unless (get-text-property i 'face ret)
1365 |         do
1366 |         (put-text-property i (1+ i) 'face face ret)
1367 |         (put-text-property i (1+ i) 'font-lock-face face ret)
1368 |         finally return ret))
1369 | 
1370 | (defun cfw:render-get-week-face (daynum &optional default-face)
1371 |   "[internal] Put the default week face."
1372 |   (cond
1373 |    ((= daynum cfw:week-saturday)
1374 |     'cfw:face-saturday)
1375 |    ((= daynum cfw:week-sunday)
1376 |     'cfw:face-sunday)
1377 |    (t default-face)))
1378 | 
1379 | (defun cfw:render-truncate (org limit-width &optional ellipsis)
1380 |   "Truncate a string ORG with LIMIT-WIDTH, like `truncate-string-to-width'.
1381 | [internal]"
1382 |   (setq org (replace-regexp-in-string "\n" " " org))
1383 |   (if (< limit-width (string-width org))
1384 |       (let ((str (truncate-string-to-width
1385 |                   (substring org 0) limit-width 0 nil ellipsis)))
1386 |         (unless (get-text-property 0 'help-echo str)
1387 |           (cfw:tp str 'help-echo org))
1388 |         str)
1389 |     org))
1390 | 
1391 | (defface cfw:face-toolbar
1392 |   '((((class color) (background light))
1393 |      :foreground "Gray90" :background "Gray90")
1394 |     (((class color) (background dark))
1395 |      :foreground "Steelblue4" :background "Steelblue4"))
1396 |   "Face for toolbar" :group 'calfw)
1397 | 
1398 | (defface cfw:face-toolbar-button-off
1399 |   '((((class color) (background light))
1400 |      :foreground "Lightskyblue4" :background "White")
1401 |     (((class color) (background dark))
1402 |      :foreground "Gray10" :weight bold :background "Steelblue4"))
1403 |   "Face for button on toolbar" :group 'calfw)
1404 | 
1405 | (defface cfw:face-toolbar-button-on
1406 |   '((((class color) (background light))
1407 |      :foreground "Lightpink3" :background "Gray94" )
1408 |     (((class color) (background dark))
1409 |      :foreground "Gray50" :weight bold :background "Steelblue4"))
1410 |   "Face for button on toolbar" :group 'calfw)
1411 | 
1412 | (defun cfw:render-button (title command &optional state)
1413 |   "[internal] Return a decorated text for the toolbar buttons.
1414 | TITLE is a button title.  COMMAND is a interactive command
1415 | function called by clicking.  If STATE is non-nil, the face
1416 | `cfw:face-toolbar-button-on' is applied. Otherwise
1417 | `cfw:face-toolbar-button-off' is applied."
1418 |   (let ((text (concat "[" title "]"))
1419 |         (keymap (make-sparse-keymap)))
1420 |     (cfw:rt text (if state 'cfw:face-toolbar-button-on
1421 |                    'cfw:face-toolbar-button-off))
1422 |     (define-key keymap [mouse-1] command)
1423 |     (cfw:tp text 'keymap keymap)
1424 |     (cfw:tp text 'mouse-face 'highlight)
1425 |     text))
1426 | 
1427 | (defun cfw:render-toolbar (width current-view prev-cmd next-cmd)
1428 |   "[internal] Return a text of the toolbar.
1429 | 
1430 | WIDTH is width of the toolbar. CURRENT-VIEW is a symbol of the
1431 | current view type. This symbol is used to select the button faces
1432 | on the toolbar. PREV-CMD and NEXT-CMD are the moving view
1433 | command, such as `cfw:navi-previous(next)-month-command' and
1434 | `cfw:navi-previous(next)-week-command'."
1435 |   (let* ((prev (cfw:render-button " < " prev-cmd))
1436 |          (today (cfw:render-button "Today" 'cfw:navi-goto-today-command))
1437 |          (next (cfw:render-button " > " next-cmd))
1438 |          (month (cfw:render-button
1439 |                  "Month" 'cfw:change-view-month
1440 |                  (eq current-view 'month)))
1441 |          (tweek (cfw:render-button
1442 |                  "Two Weeks" 'cfw:change-view-two-weeks
1443 |                  (eq current-view 'two-weeks)))
1444 |          (week (cfw:render-button
1445 |                 "Week" 'cfw:change-view-week
1446 |                 (eq current-view 'week)))
1447 |          (day (cfw:render-button
1448 |                "Day" 'cfw:change-view-day
1449 |                (eq current-view 'day)))
1450 |          (sp  " ")
1451 |          (toolbar-text
1452 |           (cfw:render-add-right
1453 |            width (concat sp prev sp next sp today sp)
1454 |            (concat day sp week sp tweek sp month sp))))
1455 |     (cfw:render-default-content-face toolbar-text 'cfw:face-toolbar)))
1456 | 
1457 | (defun cfw:event-mouse-click-toggle-calendar (event)
1458 |   (interactive "e")
1459 |   (when-let ((s (get-text-property
1460 |             (posn-point (event-start event))
1461 |             'cfw:source)))
1462 |     (setf (cfw:source-hidden s)
1463 |           (not (cfw:source-hidden s)))
1464 |     (cfw:cp-update (cfw:cp-get-component))))
1465 | 
1466 | (defun cfw:event-toggle-calendar (source)
1467 |   (interactive (list
1468 |                 (get-text-property (point) 'cfw:source)))
1469 |   (when source
1470 |   (setf (cfw:source-hidden source)
1471 |         (not (cfw:source-hidden source)))
1472 |     (cfw:cp-update (cfw:cp-get-component))))
1473 | 
1474 | (defun cfw:event-toggle-all-calendars ()
1475 |   "Show all calendars in the current view.
1476 | If all calendars are already shown, hide them all."
1477 |   (interactive)
1478 |   (when (cfw:cp-get-component)
1479 |     (let* ((comp (cfw:cp-get-component))
1480 |            (sources (cfw:model-get-contents-sources
1481 |                      (cfw:component-model comp)))
1482 |            (all-shown (not (cl-some
1483 |                             'identity
1484 |                             (cl-loop for s in sources
1485 |                                      collect
1486 |                                      (cfw:source-hidden s))))))
1487 |       (cl-loop for s in sources do
1488 |                (setf (cfw:source-hidden s)
1489 |                      all-shown))
1490 |       (cfw:cp-update comp))))
1491 | 
1492 | (defun cfw:render-footer (_width sources)
1493 |   "[internal] Return a text of the footer."
1494 |   (let* ((spaces (make-string 5 ? ))
1495 |          (whole-text
1496 |           (mapconcat
1497 |            'identity
1498 |            (cl-loop
1499 |             with keymap = (progn
1500 |                             (let ((kmap (make-sparse-keymap)))
1501 |                               (define-key kmap [mouse-1] 'cfw:event-mouse-click-toggle-calendar)
1502 |                               (define-key kmap [13] 'cfw:event-toggle-calendar)
1503 |                               kmap))
1504 |             for s in sources
1505 |             for hidden-p = (cfw:source-hidden s)
1506 |                  for title = (cfw:tp (substring (cfw:source-name s) 0)
1507 |                                      'cfw:source s)
1508 |                  for dot   = (cfw:tp (substring "(==)" 0) 'cfw:source s)
1509 |                  collect
1510 |             (progn
1511 |               (cfw:tp dot 'mouse-face 'highlight)
1512 |                    (propertize
1513 |                  (cfw:render-default-content-face
1514 |                   (concat
1515 |                 "[" (cfw:rt dot
1516 |                             (if hidden-p
1517 |                                 'cfw:face-calendar-hidden
1518 |                               (cfw:render-get-face-period dot 'cfw:face-periods)))
1519 |                    " " title "]")
1520 |                (if hidden-p
1521 |                    'cfw:face-calendar-hidden
1522 |                  (cfw:render-get-face-content title
1523 |                                                     'cfw:face-default-content)))
1524 |                     'keymap keymap)))
1525 |            (concat "\n" spaces))))
1526 |     (concat
1527 |      spaces
1528 |      whole-text)))
1529 | 
1530 | (defun cfw:render-periods (date week-day periods-stack cell-width)
1531 |   "[internal] This function translates PERIOD-STACK to display content on the DATE."
1532 |   (cl-loop with prev-row = -1
1533 |         for (row (begin end content props)) in (sort periods-stack
1534 |                                                      (lambda (a b)
1535 |                                                        (< (car a) (car b))))
1536 |         nconc (make-list (- row prev-row 1) "") ; add empty padding lines
1537 |         do (setq prev-row row)
1538 | 
1539 |         for beginp = (equal date begin)
1540 |         for endp   = (equal date end)
1541 |         for inwidth  = (- cell-width (if beginp 1 0) (if endp 1 0))
1542 |         for title  = (cfw:render-periods-title
1543 |                       date week-day begin end content cell-width inwidth)
1544 |         collect
1545 |         (apply 'propertize
1546 |                (concat (when beginp cfw:fstring-period-start)
1547 |                        (cfw:render-left inwidth title ?-)
1548 |                        (when endp cfw:fstring-period-end))
1549 |                'face (cfw:render-get-face-period content 'cfw:face-periods)
1550 |                'font-lock-face (cfw:render-get-face-period content 'cfw:face-periods)
1551 |                'cfw:period t
1552 |                props)))
1553 | 
1554 | (defun cfw:render-periods-title (date week-day begin end content cell-width inwidth)
1555 |   "[internal] Return a title string."
1556 |   (let* ((week-begin (cfw:date-after date (- week-day)))
1557 |          ;; (month-begin (cfw:date
1558 |          ;;               (calendar-extract-month date)
1559 |          ;;               1 (calendar-extract-year date)))
1560 |          (title-begin-abs
1561 |           (max
1562 |            (calendar-absolute-from-gregorian begin)
1563 |            (calendar-absolute-from-gregorian week-begin)))
1564 |          ;; (title-begin (calendar-gregorian-from-absolute title-begin-abs))
1565 |          (num (- (calendar-absolute-from-gregorian date) title-begin-abs)))
1566 |     (when content
1567 |       (cl-loop with title = (substring content 0)
1568 |             for i from 0 below num
1569 |             for pdate = (calendar-gregorian-from-absolute (+ title-begin-abs i))
1570 |             for chopn = (+ (if (equal begin pdate) 1 0) (if (equal end pdate) 1 0))
1571 |             for del = (truncate-string-to-width title (- cell-width chopn))
1572 |             do
1573 |             (setq title (substring title (length del)))
1574 |             finally return
1575 |             (cfw:render-truncate title inwidth (equal end date))))))
1576 | 
1577 | ;; event periods shifts pos - not one line
1578 | (defun cfw:render-periods-get-min (periods-each-days begin end)
1579 |   "[internal] Find the minimum empty row number of the days between
1580 | BEGIN and END from the PERIODS-EACH-DAYS."
1581 |   (cl-loop for row-num from 0 below 30 ; assuming the number of stacked periods is less than 30
1582 |         unless
1583 |         (cl-loop for d in (cfw:enumerate-days begin end)
1584 |               for periods-stack = (cfw:contents-get d periods-each-days)
1585 |               if (and periods-stack (assq row-num periods-stack))
1586 |               return t)
1587 |         return row-num))
1588 | 
1589 | (defun cfw:render-periods-place (periods-each-days row period)
1590 |   "[internal] Assign PERIOD content to the ROW-th row on the days of the period,
1591 | and append the result to periods-each-days."
1592 |   (cl-loop for d in (cfw:enumerate-days (car period) (cadr period))
1593 |         for periods-stack = (cfw:contents-get-internal d periods-each-days)
1594 |         if periods-stack
1595 |         do (setcdr periods-stack (append (cdr periods-stack)
1596 |                                          (list (list row period))))
1597 |         else
1598 |         do (push (cons d (list (list row period))) periods-each-days))
1599 |   periods-each-days)
1600 | 
1601 | (defun cfw:render-periods-stacks (model)
1602 |   "[internal] Arrange the `periods' records of the model and
1603 | create period-stacks on the each days.
1604 | period-stack -> ((row-num . period) ... )"
1605 |   (let* (periods-each-days)
1606 |     (cl-loop for (begin end event) in (cfw:k 'periods model)
1607 |           for content = (if (cfw:event-p event)
1608 |                             (cfw:event-period-overview event)
1609 |                           event)
1610 |           for period = (list begin end content
1611 |                              (cfw:extract-text-props content 'face))
1612 |           for row = (cfw:render-periods-get-min periods-each-days begin end)
1613 |           do
1614 |           (setq periods-each-days (cfw:render-periods-place
1615 |                                    periods-each-days row period)))
1616 |     periods-each-days))
1617 | 
1618 | (defun cfw:render-columns (day-columns param)
1619 |   "Concatenate each row on the days into a string of a physical line.
1620 | [Internal]
1621 | DAY-COLUMNS is a list of columns. A column is a list of following
1622 | form: (DATE (DAY-TITLE . ANNOTATION-TITLE) STRING STRING...)."
1623 |   (let ((cell-width  (cfw:k 'cell-width  param))
1624 |         (cell-height (cfw:k 'cell-height param))
1625 |         (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param))
1626 |         ;; (hline (cfw:k 'hline param))
1627 |         (cline (cfw:k 'cline param)))
1628 |     ;; day title
1629 |     (cl-loop for day-rows in day-columns
1630 |           for date = (car day-rows)
1631 |           for (tday . ant) = (cadr day-rows)
1632 |           do
1633 |           (insert
1634 |            VL (if date
1635 |                   (cfw:tp
1636 |                    (cfw:render-default-content-face
1637 |                     (cfw:render-add-right cell-width tday ant)
1638 |                     'cfw:face-day-title)
1639 |                    'cfw:date date)
1640 |                 (cfw:render-left cell-width ""))))
1641 |     (insert VL EOL)
1642 |     ;; day contents
1643 |     (cl-loop with breaked-day-columns =
1644 |           (cl-loop for day-rows in day-columns
1645 |                 for (date _ants . lines) = day-rows
1646 |                 collect
1647 |                 (cons date (cfw:render-break-lines
1648 |                             lines cell-width (1- cell-height))))
1649 |           for i from 1 below cell-height do
1650 |           (cl-loop for day-rows in breaked-day-columns
1651 |                 for date = (car day-rows)
1652 |                 for row = (nth i day-rows)
1653 |                 do
1654 |                 (insert
1655 |                  VL (cfw:tp
1656 |                      (cfw:render-separator
1657 |                       (cfw:render-left cell-width (and row (format "%s" row))))
1658 |                      'cfw:date date)))
1659 |           (insert VL EOL))
1660 |     (insert cline)))
1661 | 
1662 | (defvar cfw:render-line-breaker 'cfw:render-line-breaker-simple
1663 |   "A function which breaks a long line into some lines.
1664 | Calfw has 3 strategies: none, simple and wordwrap.
1665 | `cfw:render-line-breaker-none' never breaks lines.
1666 | `cfw:render-line-breaker-simple' breaks lines with rigid
1667 | width (default). `cfw:render-line-breaker-wordwrap' breaks lines
1668 | with the emacs function `fill-region'.
1669 | 
1670 | The arguments of a line-breaking function are STRING, LINE-WIDTH
1671 | and MAX-LINE-NUMBER.")
1672 | 
1673 | (defun cfw:render-break-lines (lines cell-width cell-height)
1674 |   "[internal] Return lines those are split into some lines by the
1675 | algorithm defined at `cfw:render-line-breaker'."
1676 |   (and lines
1677 |        (let ((num (/ cell-height (length lines))))
1678 |          (cond
1679 |           ((> 2 num) lines)
1680 |           (t
1681 |            (cl-loop with total-rows = nil
1682 |                  for line in lines
1683 |                  for rows = (funcall cfw:render-line-breaker line cell-width num)
1684 |                  do
1685 |                  (when total-rows
1686 |                    (cfw:render-add-item-separator-sign total-rows))
1687 |                  (setq total-rows (append total-rows rows))
1688 |                  finally return total-rows))))))
1689 | 
1690 | (defun cfw:render-add-item-separator-sign (rows)
1691 |   "[internal] Add a separator into the ROWS list."
1692 |   (let ((last-line (car (last rows))))
1693 |     (unless (get-text-property 0 'cfw:period last-line)
1694 |       (put-text-property 0 (length last-line) 'cfw:item-separator t last-line))
1695 |     rows))
1696 | 
1697 | (defun cfw:render-line-breaker-none (line _w _n)
1698 |   "Line breaking algorithm: Do nothing."
1699 |   (list line))
1700 | 
1701 | (defun cfw:render-line-breaker-simple (string line-width max-line-num)
1702 |   "Line breaking algorithm: Just splitting a line with the rigid width."
1703 |   (cl-loop with ret = nil    with linenum = 1
1704 |         with curcol = 0   with lastpos = 0
1705 |         with endpos = (1- (length string))
1706 |         for i from 0 upto endpos
1707 |         for c = (aref string i)
1708 |         for w = (char-width c)
1709 |         for wsum = (+ curcol w) do
1710 |         (cond
1711 |          ((and (< i endpos) (<= max-line-num linenum))
1712 |           (push (string-trim
1713 |                  (replace-regexp-in-string
1714 |                   "[\n\r]" " " (substring string lastpos))) ret)
1715 |           (setq i endpos))
1716 |          ((= endpos i)
1717 |           (push (substring string lastpos) ret))
1718 |          ((or (= c 13) (= c 10))
1719 |           (push (substring string lastpos i) ret)
1720 |           (setq lastpos (1+ i) curcol 0)
1721 |           (cl-incf linenum))
1722 |          ((= line-width wsum)
1723 |           (push (substring string lastpos (1+ i)) ret)
1724 |           (setq lastpos (1+ i) curcol 0)
1725 |           (cl-incf linenum))
1726 |          ((< line-width wsum)
1727 |           (push (substring string lastpos i) ret)
1728 |           (setq lastpos i curcol w)
1729 |           (cl-incf linenum))
1730 |          (t (cl-incf curcol w)))
1731 |         finally return (or (and ret (nreverse ret)) '(""))))
1732 | 
1733 | (defun cfw:render-line-breaker-wordwrap (string line-width max-line-num)
1734 |   "Line breaking algorithm: Simple word wrapping with fill-region."
1735 |   (if (<= (length string) line-width)
1736 |       (list string)
1737 |     (let ((fill-column line-width) (use-hard-newlines t))
1738 |       (with-temp-buffer
1739 |         (insert string)
1740 |         (fill-region (point-min) (point-max))
1741 |         ;; collect lines
1742 |         (goto-char (point-min))
1743 |         (let ((cont t) (last (point)) ps ret)
1744 |           (while cont
1745 |             (setq ps (re-search-forward "\n" nil t))
1746 |             (cond
1747 |              ((null ps) (setq cont nil)
1748 |               (when (not (eobp))
1749 |                 (push (buffer-substring last (point-max)) ret)))
1750 |              (t
1751 |               (push (string-trim (buffer-substring last (1- ps))) ret)
1752 |               (when (<= max-line-num (length ret))
1753 |                 (setq cont nil))
1754 |               (setq last ps))))
1755 |           (or (and ret (nreverse ret)) '("")))))))
1756 | 
1757 | (defun cfw:render-append-parts (param)
1758 |   "[internal] Append rendering parts to PARAM and return a new list."
1759 |   (let* ((EOL "\n")
1760 |          (cell-width (cfw:k 'cell-width param))
1761 |          (columns (cfw:k 'columns param))
1762 |          (num-cell-char
1763 |           (/ cell-width (char-width cfw:fchar-horizontal-line))))
1764 |     (append
1765 |      param
1766 |      `((eol . ,EOL) (vl . ,(cfw:rt (make-string 1 cfw:fchar-vertical-line) 'cfw:face-grid))
1767 |        (hline . ,(cfw:rt
1768 |                   (concat
1769 |                    (cl-loop for i from 0 below columns concat
1770 |                          (concat
1771 |                           (make-string 1 (if (= i 0) cfw:fchar-top-left-corner cfw:fchar-top-junction))
1772 |                           (make-string num-cell-char cfw:fchar-horizontal-line)))
1773 |                    (make-string 1 cfw:fchar-top-right-corner) EOL)
1774 |                   'cfw:face-grid))
1775 |        (cline . ,(cfw:rt
1776 |                   (concat
1777 |                    (cl-loop for i from 0 below columns concat
1778 |                          (concat
1779 |                           (make-string 1 (if (= i 0) cfw:fchar-left-junction cfw:fchar-junction))
1780 |                           (make-string num-cell-char cfw:fchar-horizontal-line)))
1781 |                    (make-string 1 cfw:fchar-right-junction) EOL) 'cfw:face-grid))))))
1782 | 
1783 | (defun cfw:render-day-of-week-names (model param)
1784 |   "[internal] Insert week names."
1785 |   (cl-loop for i in (cfw:k 'headers model)
1786 |         with VL = (cfw:k 'vl param) with cell-width = (cfw:k 'cell-width param)
1787 |         for name = (aref calendar-day-name-array i) do
1788 |         (insert VL (cfw:rt (cfw:render-center cell-width name)
1789 |                            (cfw:render-get-week-face i 'cfw:face-header)))))
1790 | 
1791 | (defun cfw:render-calendar-cells-weeks (model param title-func)
1792 |   "[internal] Insert calendar cells for week based views."
1793 |   (cl-loop for week in (cfw:k 'weeks model) do
1794 |         (cfw:render-calendar-cells-days model param title-func week
1795 |                                         'cfw:render-event-overview-content
1796 |                                         t)))
1797 | 
1798 | (defun cfw:render-rows-prop (rows)
1799 |   "[internal] Put a marker as a text property for TAB navigation."
1800 |   (cl-loop with i = 0
1801 |         for line in rows
1802 |         collect
1803 |         (prog1
1804 |             (cfw:tp line 'cfw:row-count i)
1805 |           (if (< 0 (length line)) (cl-incf i)))))
1806 | 
1807 | (defun cfw:render-map-event-content (lst event-fun)
1808 |   "[internal] `lst' is a list of contents and `cfw:event's. Map over `lst',
1809 | where `event-fun' is applied if the element is a `cfw:event'."
1810 |   (mapcar #'(lambda (evt)
1811 |               (if (cfw:event-p evt)
1812 |                   (funcall event-fun evt)
1813 |                 evt))
1814 |           lst))
1815 | 
1816 | (defun cfw:render-event-overview-content (lst)
1817 |   "[internal] Apply `cfw:event-overview' on `cfw:event's in `lst'."
1818 |   (cfw:render-map-event-content lst 'cfw:event-overview))
1819 | 
1820 | (defun cfw:render-event-days-overview-content (lst)
1821 |   "[internal] Apply `cfw:event-days-overview' on `cfw:event's in `lst'."
1822 |   (cfw:render-map-event-content lst 'cfw:event-days-overview))
1823 | 
1824 | (defun cfw:render-event-details-content (lst)
1825 |   "[internal] Apply `cfw:event-detail' on `cfw:event's in `lst'."
1826 |   (cfw:render-map-event-content lst 'cfw:event-detail))
1827 | 
1828 | 
1829 | 
1830 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1831 | ;;; Views
1832 | 
1833 | ;;; view model utilities
1834 | 
1835 | (defun cfw:view-model-make-weeks (begin-date end-date)
1836 |   "[internal] Return a list of weeks those have 7 days."
1837 |   (let* (;; (first-day-day (calendar-day-of-week begin-date))
1838 |          weeks)
1839 |     (cl-loop with i = begin-date
1840 |           with day = calendar-week-start-day
1841 |           with week = nil
1842 |           do
1843 |           ;; flush a week
1844 |           (when (and (= day calendar-week-start-day) week)
1845 |             (push (nreverse week) weeks)
1846 |             (setq week nil)
1847 |             (when (cfw:date-less-equal-p end-date i) (cl-return)))
1848 |           ;; add a day
1849 |           (push i week)
1850 |           ;; increment
1851 |           (setq day (% (1+ day) cfw:week-days))
1852 |           (setq i (cfw:date-after i 1)))
1853 |     (nreverse weeks)))
1854 | 
1855 | (defun cfw:view-model-make-days (begin-date end-date)
1856 |   "[internal] Return a list of days for linear views."
1857 |   (cl-loop with days = nil
1858 |         with i = begin-date
1859 |         do
1860 |         (push i days)
1861 |         (when (cfw:date-less-equal-p end-date i)
1862 |           (cl-return (reverse days)))
1863 |         (setq i (cfw:date-after i 1))))
1864 | 
1865 | (defun cfw:view-model-make-day-names-for-week ()
1866 |   "[internal] Return a list of index of day of the week."
1867 |   (cl-loop for i from 0 below cfw:week-days
1868 |         collect (% (+ calendar-week-start-day i) cfw:week-days)))
1869 | 
1870 | (defun cfw:view-model-make-day-names-for-days (begin-date end-date)
1871 |   "[internal] Return a list of index of day of the week for linear views."
1872 |   (cl-loop with day = (calendar-day-of-week begin-date)
1873 |         with day-names = nil
1874 |         with i = begin-date
1875 |         do
1876 |         (push day day-names)
1877 |         (when (cfw:date-less-equal-p end-date i)
1878 |           (cl-return (reverse day-names)))
1879 |         (setq day (% (1+ day) cfw:week-days))
1880 |         (setq i (cfw:date-after i 1))))
1881 | 
1882 | (defvar displayed-month) ; because these variables are binded dynamically.
1883 | (defvar displayed-year)
1884 | 
1885 | (defun cfw:view-model-make-holidays (date)
1886 |   "[internal] Return an alist of holidays around DATE."
1887 |   (if cfw:display-calendar-holidays
1888 |       (let ((displayed-month (calendar-extract-month date))
1889 |             (displayed-year (calendar-extract-year date)))
1890 |         (calendar-holiday-list))))
1891 | 
1892 | (defun cfw:view-model-make-common-data (model begin-date end-date &optional lst)
1893 |   "[internal] Return an alist of common data for the model."
1894 |   (let* ((contents-all (cfw:contents-merge
1895 |                         begin-date end-date
1896 |                         (cfw:model-get-contents-sources model t))))
1897 |     (append
1898 |      `(; common data
1899 |        (begin-date . ,begin-date) (end-date . ,end-date)
1900 |        (holidays . ,(cfw:view-model-make-holidays begin-date)) ; an alist of holidays, (DATE HOLIDAY-NAME)
1901 |        (annotations . ,(cfw:annotations-merge ; an alist of annotations, (DATE ANNOTATION)
1902 |                         begin-date end-date
1903 |                         (cfw:model-get-annotation-sources model)))
1904 |        (contents . ,(cl-loop for i in contents-all
1905 |                           unless (eq 'periods (car i))
1906 |                           collect i)) ; an alist of contents, (DATE LIST-OF-CONTENTS)
1907 |        (periods . ,(cfw:k 'periods contents-all))) ; a list of periods, (BEGIN-DATE END-DATE SUMMARY)
1908 |      lst)))
1909 | 
1910 | (defun cfw:view-model-make-common-data-for-weeks (model begin-date end-date)
1911 |   "[internal] Return a model object for week based views."
1912 |   (cfw:model-create-updated-view-data
1913 |    model
1914 |    (cfw:view-model-make-common-data
1915 |     model begin-date end-date
1916 |     `((headers . ,(cfw:view-model-make-day-names-for-week)) ; a list of the index of day-of-week
1917 |       (weeks . ,(cfw:view-model-make-weeks ; a matrix of day-of-month, which corresponds to the index of `headers'
1918 |                  (cfw:week-begin-date begin-date)
1919 |                  (cfw:week-end-date   end-date)))))))
1920 | 
1921 | (defun cfw:view-model-make-common-data-for-days (model begin-date end-date)
1922 |   "[internal] Return a model object for linear views."
1923 |   (cfw:model-create-updated-view-data
1924 |    model
1925 |    (cfw:view-model-make-common-data
1926 |     model begin-date end-date
1927 |     `((headers . ,(cfw:view-model-make-day-names-for-days begin-date end-date)) ; a list of the index of day-of-week
1928 |       (days . ,(cfw:view-model-make-days ; a list of days, which corresponds to the index of `headers'
1929 |                 begin-date end-date))))))
1930 | 
1931 | 
1932 | 
1933 | ;;; view-month
1934 | 
1935 | (defun cfw:view-month-model (model)
1936 |   "[internal] Create a logical view model of monthly calendar.
1937 | This function collects and arranges contents.  This function does
1938 | not know how to display the contents in the destinations."
1939 |   (let* ((init-date (cfw:k 'init-date model))
1940 |          (year (calendar-extract-year init-date))
1941 |          (month (calendar-extract-month init-date))
1942 |          (begin-date (cfw:date month 1 year))
1943 |          (end-date (cfw:date month (calendar-last-day-of-month month year) year)))
1944 |     ;; model
1945 |     (append
1946 |      (cfw:view-model-make-common-data-for-weeks model begin-date end-date)
1947 |      `((month . ,month) (year . ,year)))))
1948 | 
1949 | (defun cfw:round-cell-width (width)
1950 |   "[internal] If string-width of `cfw:fchar-horizontal-line' is not 1,
1951 | this function re-calculate and return the adjusted width."
1952 |   (cond
1953 |    ((eql (char-width cfw:fchar-horizontal-line) 1) width)
1954 |    (t (- width (% width (char-width cfw:fchar-horizontal-line))))))
1955 | 
1956 | (defun cfw:view-month-calc-param (dest total-weeks)
1957 |   "[internal] Calculate cell size from the reference size and
1958 | return an alist of rendering parameters."
1959 |   (let*
1960 |       ((win-width (cfw:dest-width dest))
1961 |        ;; title 2, toolbar 1, header 2, hline 7, footer 1, margin 2 => 15
1962 |        (win-height (max 15 (- (cfw:dest-height dest) 15)))
1963 |        (junctions-width (* (char-width cfw:fchar-junction) 8)) ; weekdays+1
1964 |        (cell-width  (cfw:round-cell-width
1965 |                      (max 5 (/ (- win-width junctions-width) 7)))) ; weekdays
1966 |        (cell-height (max 2 (/ win-height total-weeks))) ; max weeks = 6
1967 |        (total-width (+ (* cell-width cfw:week-days) junctions-width)))
1968 |     `((cell-width . ,cell-width)
1969 |       (cell-height . ,cell-height)
1970 |       (total-width . ,total-width)
1971 |       (columns . ,cfw:week-days))))
1972 | 
1973 | (defun cfw:view-month (component)
1974 |   "[internal] Render monthly calendar view."
1975 |   (let* ((dest (cfw:component-dest component))
1976 |          (model (cfw:view-month-model (cfw:component-model component)))
1977 |          (total-weeks (length (cfw:k 'weeks model)))
1978 |          (param (cfw:render-append-parts
1979 |                  (cfw:view-month-calc-param dest total-weeks)))
1980 |          (total-width (cfw:k 'total-width param))
1981 |          (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param))
1982 |          (hline (cfw:k 'hline param)) (cline (cfw:k 'cline param)))
1983 |     ;; update model
1984 |     (setf (cfw:component-model component) model)
1985 |     ;; header
1986 |     (insert
1987 |      (cfw:rt (cfw:render-title-month (cfw:k 'init-date model))
1988 |              'cfw:face-title)
1989 |      EOL (cfw:render-toolbar total-width 'month
1990 |                              'cfw:navi-previous-month-command
1991 |                              'cfw:navi-next-month-command)
1992 |      EOL hline)
1993 |     ;; day names
1994 |     (cfw:render-day-of-week-names model param)
1995 |     (insert VL EOL cline)
1996 |     ;; contents
1997 |     (let ((year (cfw:k 'year model))
1998 |           (month (cfw:k 'month model)))
1999 |       (cfw:render-calendar-cells-weeks
2000 |        model param
2001 |        (lambda (date week-day hday)
2002 |          (cfw:rt
2003 |           (format "%s" (calendar-extract-day date))
2004 |           (cond
2005 |            (hday 'cfw:face-sunday)
2006 |            ((not (cfw:month-year-contain-p month year date)) 'cfw:face-disable)
2007 |            (t (cfw:render-get-week-face week-day 'cfw:face-default-day)))))))
2008 |     ;; footer
2009 |     (insert (cfw:render-footer total-width (cfw:model-get-contents-sources model)))))
2010 | 
2011 | 
2012 | 
2013 | ;;; view-week
2014 | 
2015 | (defun cfw:view-week-model (model)
2016 |   "[internal] Create a logical view model of weekly calendar.
2017 | This function collects and arranges contents.  This function does
2018 | not know how to display the contents in the destinations."
2019 |   (let* ((init-date (cfw:k 'init-date model))
2020 |          (begin-date (cfw:week-begin-date init-date))
2021 |          (end-date (cfw:week-end-date init-date)))
2022 |     (cfw:view-model-make-common-data-for-weeks model begin-date end-date)))
2023 | 
2024 | ;; (cfw:view-week-model (cfw:model-abstract-new (cfw:date 1 1 2011) nil nil))
2025 | 
2026 | (defun cfw:view-week-calc-param (dest)
2027 |   "[internal] Calculate cell size from the reference size and
2028 | return an alist of rendering parameters."
2029 |   (let*
2030 |       ((win-width (cfw:dest-width dest))
2031 |        ;; title 2, toolbar 1, header 2, hline 2, footer 1, margin 2 => 10
2032 |        (win-height (max 15 (- (cfw:dest-height dest) 10)))
2033 |        (junctions-width (* (char-width cfw:fchar-junction) 8))
2034 |        (cell-width  (cfw:round-cell-width
2035 |                      (max 5 (/ (- win-width junctions-width) 7))))
2036 |        (cell-height (max 2 win-height))
2037 |        (total-width (+ (* cell-width cfw:week-days) junctions-width)))
2038 |     `((cell-width . ,cell-width)
2039 |       (cell-height . ,cell-height)
2040 |       (total-width . ,total-width)
2041 |       (columns . ,cfw:week-days))))
2042 | 
2043 | (defun cfw:view-week (component)
2044 |   "[internal] Render weekly calendar view."
2045 |   (let* ((dest (cfw:component-dest component))
2046 |          (param (cfw:render-append-parts (cfw:view-week-calc-param dest)))
2047 |          (total-width (cfw:k 'total-width param))
2048 |          (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param))
2049 |          (hline (cfw:k 'hline param)) (cline (cfw:k 'cline param))
2050 |          (model (cfw:view-week-model (cfw:component-model component)))
2051 |          (begin-date (cfw:k 'begin-date model))
2052 |          (end-date (cfw:k 'end-date model)))
2053 |     ;; update model
2054 |     (setf (cfw:component-model component) model)
2055 |     ;; header
2056 |     (insert
2057 |      (cfw:rt
2058 |       (cfw:render-title-period begin-date end-date)
2059 |       'cfw:face-title)
2060 |      EOL (cfw:render-toolbar total-width 'week
2061 |                              'cfw:navi-previous-week-command
2062 |                              'cfw:navi-next-week-command)
2063 |      EOL hline)
2064 |     ;; day names
2065 |     (cfw:render-day-of-week-names model param)
2066 |     (insert VL EOL cline)
2067 |     ;; contents
2068 |     (cfw:render-calendar-cells-weeks
2069 |      model param
2070 |      (lambda (date week-day hday)
2071 |        (cfw:rt (format "%s" (calendar-extract-day date))
2072 |                (if hday 'cfw:face-sunday
2073 |                  (cfw:render-get-week-face
2074 |                   week-day 'cfw:face-default-day)))))
2075 |     ;; footer
2076 |     (insert (cfw:render-footer total-width (cfw:model-get-contents-sources model)))))
2077 | 
2078 | 
2079 | 
2080 | ;;; view-two-weeks
2081 | 
2082 | (defun cfw:view-two-weeks-model-adjust (model)
2083 |   "view-two-weeks-model-begin
2084 | MODEL"
2085 |   (let ((in-date (cfw:k 'init-date model)))
2086 |     (cond
2087 |      ((eq 'two-weeks (cfw:k 'type model))
2088 |       (let ((old-begin-date (cfw:k 'begin-date model))
2089 |             (old-end-date (cfw:k 'end-date model)))
2090 |         (cond
2091 |          ((cfw:date-between old-begin-date old-end-date in-date)
2092 |           in-date)
2093 |          ((cfw:date-between old-end-date (cfw:date-after old-end-date cfw:week-days) in-date)
2094 |           old-end-date)
2095 |          ((cfw:date-between (cfw:date-after old-begin-date (- cfw:week-days)) old-begin-date in-date)
2096 |           (cfw:date-after old-begin-date (- cfw:week-days)))
2097 |          (t in-date))))
2098 |      (t in-date))))
2099 | 
2100 | (defun cfw:view-two-weeks-model (model)
2101 |   "[internal] Create a logical view model of two-weeks calendar.
2102 | This function collects and arranges contents.  This function does
2103 | not know how to display the contents in the destinations."
2104 |   (let* ((init-date (cfw:view-two-weeks-model-adjust model))
2105 |          (begin-date (cfw:week-begin-date init-date))
2106 |          (end-date (cfw:date-after begin-date (1- (* 2 cfw:week-days)))))
2107 |     ;; model
2108 |     (append
2109 |      (cfw:view-model-make-common-data-for-weeks model begin-date end-date)
2110 |      `((type . two-weeks)))))
2111 | 
2112 | ;; (cfw:view-two-weeks-model (cfw:model-abstract-new (cfw:date 1 1 2011) nil nil))
2113 | 
2114 | (defun cfw:view-two-weeks-calc-param (dest)
2115 |   "[internal] Calculate cell size from the reference size and
2116 | return an alist of rendering parameters."
2117 |   (let*
2118 |       ((win-width (cfw:dest-width dest))
2119 |        ;; title 2, toolbar 1, header 2, hline 3, footer 1, margin 2 => 11
2120 |        (win-height (max 15 (- (cfw:dest-height dest) 11)))
2121 |        (junctions-width (* (char-width cfw:fchar-junction) 8))
2122 |        (cell-width  (cfw:round-cell-width
2123 |                      (max 5 (/ (- win-width junctions-width) 7))))
2124 |        (cell-height (max 2 (/ win-height 2)))
2125 |        (total-width (+ (* cell-width cfw:week-days) junctions-width)))
2126 |     `((cell-width . ,cell-width)
2127 |       (cell-height . ,cell-height)
2128 |       (total-width . ,total-width)
2129 |       (columns . ,cfw:week-days))))
2130 | 
2131 | (defun cfw:view-two-weeks (component)
2132 |   "[internal] Render two-weeks calendar view."
2133 |   (let* ((dest (cfw:component-dest component))
2134 |          (param (cfw:render-append-parts (cfw:view-two-weeks-calc-param dest)))
2135 |          (total-width (cfw:k 'total-width param))
2136 |          (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param))
2137 |          (hline (cfw:k 'hline param)) (cline (cfw:k 'cline param))
2138 |          (model (cfw:view-two-weeks-model (cfw:component-model component)))
2139 |          (begin-date (cfw:k 'begin-date model))
2140 |          (end-date (cfw:k 'end-date model)))
2141 |     ;; update model
2142 |     (setf (cfw:component-model component) model)
2143 |     ;; header
2144 |     (insert
2145 |      (cfw:rt
2146 |       (cfw:render-title-period begin-date end-date)
2147 |       'cfw:face-title)
2148 |      EOL (cfw:render-toolbar total-width 'two-weeks
2149 |                              'cfw:navi-previous-week-command
2150 |                              'cfw:navi-next-week-command)
2151 |      EOL hline)
2152 |     ;; day names
2153 |     (cfw:render-day-of-week-names model param)
2154 |     (insert VL EOL cline)
2155 |     ;; contents
2156 |     (cfw:render-calendar-cells-weeks
2157 |      model param
2158 |      (lambda (date week-day hday)
2159 |        (cfw:rt (format "%s" (calendar-extract-day date))
2160 |                (if hday 'cfw:face-sunday
2161 |                  (cfw:render-get-week-face
2162 |                   week-day 'cfw:face-default-day)))))
2163 |     ;; footer
2164 |     (insert (cfw:render-footer total-width (cfw:model-get-contents-sources model)))))
2165 | 
2166 | 
2167 | 
2168 | ;;; view-day
2169 | 
2170 | (defun cfw:view-day-calc-param (dest &optional num)
2171 |   "[internal] Calculate cell size from the reference size and
2172 | return an alist of rendering parameters."
2173 |   (let*
2174 |       ((num (or num 1))
2175 |        (win-width (cfw:dest-width dest))
2176 |        ;; title 2, toolbar 1, header 2, hline 2, footer 1, margin 2 => 10
2177 |        (win-height (max 15 (- (cfw:dest-height dest) 10)))
2178 |        (junctions-width (* (char-width cfw:fchar-junction) (1+ num)))
2179 |        (cell-width  (cfw:round-cell-width
2180 |                      (max 3 (/ (- win-width junctions-width) num))))
2181 |        (cell-height win-height)
2182 |        (total-width (+ (* cell-width num) junctions-width)))
2183 |     `((cell-width . ,cell-width)
2184 |       (cell-height . ,cell-height)
2185 |       (total-width . ,total-width)
2186 |       (columns . ,num))))
2187 | 
2188 | (defun cfw:view-day (component)
2189 |   "[internal] Render daily calendar view."
2190 |   (let* ((dest (cfw:component-dest component))
2191 |          (param (cfw:render-append-parts (cfw:view-day-calc-param dest)))
2192 |          (total-width (cfw:k 'total-width param))
2193 |          (EOL (cfw:k 'eol param)) (VL (cfw:k 'vl param))
2194 |          (hline (cfw:k 'hline param)) (cline (cfw:k 'cline param))
2195 |          (current-date (cfw:k 'init-date (cfw:component-model component)))
2196 |          (model
2197 |           (cfw:view-model-make-common-data-for-days
2198 |            (cfw:component-model component) current-date current-date)))
2199 |     ;; update model
2200 |     (setf (cfw:component-model component) model)
2201 |     ;; header
2202 |     (insert
2203 |      (cfw:rt
2204 |       (cfw:render-title-day current-date)
2205 |       'cfw:face-title)
2206 |      EOL (cfw:render-toolbar total-width 'day
2207 |                              'cfw:navi-previous-day-command
2208 |                              'cfw:navi-next-day-command)
2209 |      EOL hline)
2210 |     ;; day names
2211 |     (cfw:render-day-of-week-names model param)
2212 |     (insert VL EOL cline)
2213 |     ;; contents
2214 |     (cfw:render-calendar-cells-days
2215 |      model param
2216 |      (lambda (date week-day hday)
2217 |        (cfw:rt (format "%s" (calendar-extract-day date))
2218 |                (if hday 'cfw:face-sunday
2219 |                  (cfw:render-get-week-face
2220 |                   week-day 'cfw:face-default-day)))))
2221 |     ;; footer
2222 |     (insert (cfw:render-footer total-width (cfw:model-get-contents-sources model)))))
2223 | 
2224 | (defun cfw:render-calendar-cells-days (model param title-func &optional
2225 |                                              days content-fun do-weeks)
2226 |   "[internal] Insert calendar cells for the linear views."
2227 |   (cfw:render-columns
2228 |    (cl-loop with cell-width      = (cfw:k 'cell-width param)
2229 |          with days            = (or days (cfw:k 'days model))
2230 |          with content-fun     = (or content-fun
2231 |                                     'cfw:render-event-days-overview-content)
2232 |          with holidays        = (cfw:k 'holidays model)
2233 |          with annotations     = (cfw:k 'annotations model)
2234 |          with headers         = (cfw:k 'headers  model)
2235 |          with raw-periods-all = (cfw:render-periods-stacks model)
2236 |          with sorter          = (cfw:model-get-sorter model)
2237 | 
2238 |          for date in days ; days columns loop
2239 |          for count from 0 below (length days)
2240 |          for hday         = (car (cfw:contents-get date holidays))
2241 |          for week-day     = (nth count headers)
2242 |          for ant          = (cfw:rt (cfw:contents-get date annotations)
2243 |                                     'cfw:face-annotation)
2244 |          for raw-periods  = (cfw:contents-get date raw-periods-all)
2245 |          for raw-contents = (cfw:render-sort-contents
2246 |                              (funcall content-fun
2247 |                                       (cfw:model-get-contents-by-date date model))
2248 |                              sorter)
2249 |          for prs-contents = (cfw:render-rows-prop
2250 |                              (append (if do-weeks
2251 |                                          (cfw:render-periods
2252 |                                           date week-day raw-periods cell-width)
2253 |                                        (cfw:render-periods-days
2254 |                                         date raw-periods cell-width))
2255 |                                      (mapcar 'cfw:render-default-content-face
2256 |                                              raw-contents)))
2257 |          for num-label = (if prs-contents
2258 |                              (format "(%s)"
2259 |                                      (+ (length raw-contents)
2260 |                                         (length raw-periods))) "")
2261 |          for tday = (concat
2262 |                      " " ; margin
2263 |                      (funcall title-func date week-day hday)
2264 |                      (if num-label (concat " " num-label))
2265 |                      (if hday (concat " " (cfw:rt (substring hday 0)
2266 |                                                   'cfw:face-holiday))))
2267 |          collect
2268 |          (cons date (cons (cons tday ant) prs-contents)))
2269 |    param))
2270 | 
2271 | (defun cfw:render-periods-days (date periods-stack cell-width)
2272 |   "[internal] Insert period texts."
2273 |   (when periods-stack
2274 |     (let ((stack (sort (copy-sequence periods-stack)
2275 |                        (lambda (a b) (< (car a) (car b))))))
2276 |       (cl-loop for (_row (begin end content)) in stack
2277 |             for beginp = (equal date begin)
2278 |             for endp = (equal date end)
2279 |             for width = (- cell-width 2)
2280 |             for title = (cfw:render-truncate
2281 |                          (concat
2282 |                           (cfw:strtime begin) " - "
2283 |                           (cfw:strtime end) " : "
2284 |                           content) width t)
2285 |             collect
2286 |             (if content
2287 |                 (cfw:rt
2288 |                  (concat
2289 |                   (if beginp "(" " ")
2290 |                   (cfw:render-left width title ?-)
2291 |                   (if endp ")" " "))
2292 |                  (cfw:render-get-face-period content 'cfw:face-periods))
2293 |               "")))))
2294 | 
2295 | 
2296 | 
2297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2298 | ;;; Navigation
2299 | 
2300 | ;; Following functions assume that the current buffer is a calendar view.
2301 | 
2302 | (defun cfw:cursor-to-date (&optional pos)
2303 |   "[internal] Return the date at the cursor. If the text does not
2304 | have the text-property `cfw:date', return nil."
2305 |   (get-text-property (or pos (point)) 'cfw:date))
2306 | 
2307 | (defun cfw:cursor-to-nearest-date ()
2308 |   "Return the date at the cursor. If the point of cursor does not
2309 | have the date, search the date around the cursor position. If the
2310 | current buffer is not calendar view (it may be bug), this
2311 | function may return nil."
2312 |   (or (cfw:cursor-to-date)
2313 |       (let* ((r (lambda () (when (not (eolp)) (forward-char))))
2314 |              (l (lambda () (when (not (bolp)) (backward-char))))
2315 |              (u (lambda () (when (not (bobp)) (line-move 1))))
2316 |              (d (lambda () (when (not (eobp)) (line-move -1))))
2317 |              (dest (cfw:component-dest (cfw:cp-get-component)))
2318 |              get)
2319 |         (setq get (lambda (cmds)
2320 |                     (save-excursion
2321 |                       (if (null cmds) (cfw:cursor-to-date)
2322 |                         (ignore-errors
2323 |                           (funcall (car cmds)) (funcall get (cdr cmds)))))))
2324 |         (or (cl-loop for i in `((,d) (,r) (,u) (,l)
2325 |                              (,d ,r) (,d ,l) (,u ,r) (,u ,l)
2326 |                              (,d ,d) (,r ,r) (,u ,u) (,l ,l))
2327 |                   for date = (funcall get i)
2328 |                   if date return date)
2329 |             (cond
2330 |              ((> (/ (point-max) 2) (point))
2331 |               (cfw:find-first-date dest))
2332 |              (t (cfw:find-last-date dest)))))))
2333 | 
2334 | (defun cfw:find-first-date (dest)
2335 |   "[internal] Return the first date in the current buffer."
2336 |   (let ((pos (next-single-property-change
2337 |               (cfw:dest-point-min dest) 'cfw:date)))
2338 |     (and pos (cfw:cursor-to-date pos))))
2339 | 
2340 | (defun cfw:find-last-date (dest)
2341 |   "[internal] Return the last date in the current buffer."
2342 |   (let ((pos (previous-single-property-change
2343 |               (cfw:dest-point-max dest) 'cfw:date)))
2344 |     (and pos (cfw:cursor-to-date (1- pos)))))
2345 | 
2346 | (defun cfw:find-by-date (dest date)
2347 |   "[internal] Return a point where the text property `cfw:date'
2348 | is equal to DATE in the current calender view. If DATE is not
2349 | found in the current view, return nil."
2350 |   (cl-loop with pos = (cfw:dest-point-min dest)
2351 |         with end = (cfw:dest-point-max dest)
2352 |         for next = (next-single-property-change pos 'cfw:date nil end)
2353 |         for text-date = (and next (cfw:cursor-to-date next))
2354 |         while (and next (< next end)) do
2355 |         (if (and text-date (equal date text-date))
2356 |             (cl-return next))
2357 |         (setq pos next)))
2358 | 
2359 | (defun cfw:find-all-by-date (dest date func)
2360 |   "[internal] Call the function FUNC in each regions where the
2361 | text-property `cfw:date' is equal to DATE. The argument function FUNC
2362 | receives two arguments, begin position and end one. This function is
2363 | mainly used at functions for putting overlays."
2364 |   (cl-loop with pos = (cfw:dest-point-min dest)
2365 |         with end = (cfw:dest-point-max dest)
2366 |         for next = (next-single-property-change pos 'cfw:date nil end)
2367 |         for text-date = (and next (cfw:cursor-to-date next))
2368 |         while (and next (< next end)) do
2369 |         (if (and text-date (equal date text-date))
2370 |             (let ((cend (next-single-property-change
2371 |                          next 'cfw:date nil end)))
2372 |               (funcall func next cend)))
2373 |         (setq pos next)))
2374 | 
2375 | (defun cfw:find-item (dest date row-count)
2376 |   "[internal] Find the schedule item which has the text properties as
2377 | `cfw:date' = DATE and `cfw:row-count' = ROW-COUNT. If no item is found,
2378 | this function returns nil."
2379 |   (cl-loop with pos = (cfw:dest-point-min dest)
2380 |         with end = (cfw:dest-point-max dest)
2381 |         with last-found = nil
2382 |         for next = (next-single-property-change pos 'cfw:date nil end)
2383 |         for text-date = (and next (cfw:cursor-to-date next))
2384 |         for text-row-count = (and next (get-text-property next 'cfw:row-count))
2385 |         while (and next (< next end)) do
2386 |         (when (and text-date (equal date text-date)
2387 |                    (eql row-count text-row-count))
2388 |           ;; this is needed item
2389 |           (cl-return next))
2390 |         (when (and text-date (equal date text-date)
2391 |                    text-row-count)
2392 |           ;; keep it to search bottom item
2393 |           (setq last-found next))
2394 |         (setq pos next)
2395 |         finally (if (and last-found (< row-count 0))
2396 |                     (cl-return last-found))))
2397 | 
2398 | (defun cfw:cp-goto-date (component date &optional force-move-cursor)
2399 |   "Go to the date on the component. If the current view doesn't contain the date,
2400 | this function updates the view to display the date."
2401 |   (let ((dest (cfw:component-dest component))
2402 |         (model (cfw:component-model component)))
2403 |     (unless (cfw:cp-displayed-date-p component date)
2404 |       (cfw:model-set-init-date date model)
2405 |       (cfw:cp-update component))
2406 |     (cfw:cp-move-cursor dest date force-move-cursor)))
2407 | 
2408 | (defun cfw:navi-goto-date (date)
2409 |   "Move the cursor to DATE.
2410 | If DATE is not included on the current calendar, this function changes the
2411 | calendar view."
2412 |   (let ((cp (cfw:cp-get-component)))
2413 |     (when cp
2414 |       (cfw:cp-goto-date cp date))))
2415 | 
2416 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2417 | ;;; Major Mode / Key bindings
2418 | 
2419 | (defvar cfw:calendar-mode-map
2420 |   (cfw:define-keymap
2421 |    '(
2422 |      ("<right>" . cfw:navi-next-day-command)
2423 |      ("f"       . cfw:navi-next-day-command)
2424 |      ("<left>"  . cfw:navi-previous-day-command)
2425 |      ("b"       . cfw:navi-previous-day-command)
2426 |      ("<down>"  . cfw:navi-next-week-command)
2427 |      ("n"       . cfw:navi-next-week-command)
2428 |      ("<up>"    . cfw:navi-previous-week-command)
2429 |      ("p"       . cfw:navi-previous-week-command)
2430 | 
2431 |      ;; Vi style
2432 |      ("l" . cfw:navi-next-day-command)
2433 |      ("h" . cfw:navi-previous-day-command)
2434 |      ("j" . cfw:navi-previous-week-command)
2435 |      ("k" . cfw:navi-next-week-command)
2436 |      ("^" . cfw:navi-goto-week-begin-command)
2437 |      ("$" . cfw:navi-goto-week-end-command)
2438 | 
2439 |      ("<"   . cfw:navi-previous-month-command)
2440 |      ;;("M-v" . cfw:navi-previous-month-command)
2441 |      (">"   . cfw:navi-next-month-command)
2442 |      ;;("C-v" . cfw:navi-next-month-command)
2443 |      ("<prior>" . cfw:navi-previous-month-command)
2444 |      ("<next>"  . cfw:navi-next-month-command)
2445 |      ("<home>"  . cfw:navi-goto-first-date-command)
2446 |      ("<end>"   . cfw:navi-goto-last-date-command)
2447 | 
2448 |      ("M-g" . cfw:navi-goto-date-command)
2449 |      ("t" . cfw:navi-goto-today-command)
2450 |      ("." . cfw:navi-goto-today-command)
2451 | 
2452 |      ("TAB"       . cfw:navi-next-item-command)
2453 |      ("C-i"       . cfw:navi-next-item-command)
2454 |      ("<backtab>"   . cfw:navi-prev-item-command)
2455 |      ("S-TAB"       . cfw:navi-prev-item-command)
2456 | 
2457 |      ("g"   . cfw:refresh-calendar-buffer)
2458 |      ("SPC" . cfw:show-details-command)
2459 | 
2460 |      ("D" . cfw:change-view-day)
2461 |      ("W" . cfw:change-view-week)
2462 |      ("T" . cfw:change-view-two-weeks)
2463 |      ("M" . cfw:change-view-month)
2464 | 
2465 |      ([mouse-1] . cfw:navi-on-click)
2466 | 
2467 |      ("q" . bury-buffer)
2468 | 
2469 |      ("0" . digit-argument)
2470 |      ("1" . digit-argument)
2471 |      ("2" . digit-argument)
2472 |      ("3" . digit-argument)
2473 |      ("4" . digit-argument)
2474 |      ("5" . digit-argument)
2475 |      ("6" . digit-argument)
2476 |      ("7" . digit-argument)
2477 |      ("8" . digit-argument)
2478 |      ("9" . digit-argument)
2479 | 
2480 |      )) "Default key map of calendar views.")
2481 | 
2482 | (defun cfw:calendar-mode-map (&optional custom-map)
2483 |   "[internal] Return a keymap object for the calendar buffer."
2484 |   (cond
2485 |    (custom-map
2486 |     (set-keymap-parent custom-map cfw:calendar-mode-map)
2487 |     custom-map)
2488 |    (t cfw:calendar-mode-map)))
2489 | 
2490 | (defvar cfw:calendar-mode-hook nil
2491 |   "This hook is called at end of setting up major mode `cfw:calendar-mode'.")
2492 | 
2493 | (defun cfw:calendar-mode (&optional custom-map)
2494 |   "Set up major mode `cfw:calendar-mode'.
2495 | 
2496 | \\{cfw:calendar-mode-map}"
2497 |   (kill-all-local-variables)
2498 |   (setq truncate-lines t)
2499 |   (use-local-map (cfw:calendar-mode-map custom-map))
2500 |   (setq major-mode 'cfw:calendar-mode
2501 |         mode-name "Calendar Mode")
2502 |   (setq buffer-undo-list t
2503 |         buffer-read-only t)
2504 |   (run-hooks 'cfw:calendar-mode-hook))
2505 | 
2506 | ;;; Actions
2507 | 
2508 | (defun cfw:change-view-month ()
2509 |   "change-view-month"
2510 |   (interactive)
2511 |   (when (cfw:cp-get-component)
2512 |     (cfw:cp-set-view (cfw:cp-get-component) 'month)))
2513 | 
2514 | (defun cfw:change-view-week ()
2515 |   "change-view-week"
2516 |   (interactive)
2517 |   (when (cfw:cp-get-component)
2518 |     (cfw:cp-set-view (cfw:cp-get-component) 'week)))
2519 | 
2520 | (defun cfw:change-view-two-weeks ()
2521 |   "change-view-two-weeks"
2522 |   (interactive)
2523 |   (when (cfw:cp-get-component)
2524 |     (cfw:cp-set-view (cfw:cp-get-component) 'two-weeks)))
2525 | 
2526 | (defun cfw:change-view-day ()
2527 |   "change-view-day"
2528 |   (interactive)
2529 |   (when (cfw:cp-get-component)
2530 |     (cfw:cp-set-view (cfw:cp-get-component) 'day)))
2531 | 
2532 | (defun cfw:navi-next-item-command ()
2533 |   "Move the cursor to the next item."
2534 |   (interactive)
2535 |   (let ((cp (cfw:cp-get-component))
2536 |         (date (cfw:cursor-to-date))
2537 |         (rcount (or (get-text-property (point) 'cfw:row-count) -1)))
2538 |     (when (and cp date)
2539 |       (let ((next (cfw:find-item (cfw:component-dest cp) date (1+ rcount))))
2540 |         (if next (goto-char next)
2541 |           (cfw:navi-goto-date date))))))
2542 | 
2543 | (defun cfw:navi-prev-item-command ()
2544 |   "Move the cursor to the previous item."
2545 |   (interactive)
2546 |   (let ((cp (cfw:cp-get-component))
2547 |         (date (cfw:cursor-to-date))
2548 |         (rcount (or (get-text-property (point) 'cfw:row-count) -1)))
2549 |     (when (and cp date)
2550 |       (let ((next (cfw:find-item (cfw:component-dest cp) date (1- rcount))))
2551 |         (if next (goto-char next)
2552 |           (cfw:navi-goto-date date))))))
2553 | 
2554 | (defun cfw:navi-on-click ()
2555 |   "click"
2556 |   (interactive)
2557 |   (let ((cp (cfw:cp-get-component))
2558 |         (date (cfw:cursor-to-date)))
2559 |     (when (and cp date)
2560 |       (cfw:cp-goto-date cp date)
2561 |       (cfw:cp-fire-click-hooks cp))))
2562 | 
2563 | (defun cfw:refresh-calendar-buffer (no-resize)
2564 |   "Clear the calendar and render again.
2565 | With prefix arg NO-RESIZE, don't fit calendar to window size."
2566 |   (interactive "P")
2567 |   (let ((cp (cfw:cp-get-component)))
2568 |     (when cp
2569 |       (unless no-resize
2570 |         (cfw:cp-resize cp (window-width) (window-height)))
2571 |       (cl-loop for s in (cfw:cp-get-contents-sources cp t)
2572 |             for f = (cfw:source-update s)
2573 |             if f do (funcall f))
2574 |       (cl-loop for s in (cfw:cp-get-annotation-sources cp)
2575 |             for f = (cfw:source-update s)
2576 |             if f do (funcall f))
2577 |       (cfw:cp-update cp))))
2578 | 
2579 | (defun cfw:navi-goto-week-begin-command ()
2580 |   "Move the cursor to the first day of the current week."
2581 |   (interactive)
2582 |   (when (cfw:cp-get-component)
2583 |     (cfw:navi-goto-date
2584 |      (cfw:week-begin-date
2585 |       (cfw:cursor-to-nearest-date)))))
2586 | 
2587 | (defun cfw:navi-goto-week-end-command ()
2588 |   "Move the cursor to the last day of the current week."
2589 |   (interactive)
2590 |   (when (cfw:cp-get-component)
2591 |     (cfw:navi-goto-date
2592 |      (cfw:week-end-date
2593 |       (cfw:cursor-to-nearest-date)))))
2594 | 
2595 | (defun cfw:navi-goto-date-command ()
2596 |   "Move the cursor to the specified date."
2597 |   (interactive)
2598 |   (cfw:navi-goto-date (call-interactively cfw:read-date-command)))
2599 | 
2600 | (defun cfw:navi-goto-today-command ()
2601 |   "Move the cursor to today."
2602 |   (interactive)
2603 |   (cfw:navi-goto-date (cfw:emacs-to-calendar (current-time))))
2604 | 
2605 | (defun cfw:navi-next-day-command (&optional num)
2606 |   "Move the cursor forward NUM days. If NUM is nil, 1 is used.
2607 | Moves backward if NUM is negative."
2608 |   (interactive "p")
2609 |   (when (cfw:cp-get-component)
2610 |     (unless num (setq num 1))
2611 |     (let* ((cursor-date (cfw:cursor-to-nearest-date))
2612 |            (new-cursor-date (cfw:date-after cursor-date num)))
2613 |       (cfw:navi-goto-date new-cursor-date))))
2614 | 
2615 | (defun cfw:navi-previous-day-command (&optional num)
2616 |   "Move the cursor back NUM days. If NUM is nil, 1 is used.
2617 | Moves forward if NUM is negative."
2618 |   (interactive "p")
2619 |   (cfw:navi-next-day-command (- (or num 1))))
2620 | 
2621 | (defun cfw:navi-goto-first-date-command ()
2622 |   "Move the cursor to the first day on the current calendar view."
2623 |   (interactive)
2624 |   (cfw:navi-goto-date
2625 |    (cfw:find-first-date
2626 |     (cfw:component-dest (cfw:cp-get-component)))))
2627 | 
2628 | (defun cfw:navi-goto-last-date-command ()
2629 |   "Move the cursor to the last day on the current calendar view."
2630 |   (interactive)
2631 |   (cfw:navi-goto-date
2632 |    (cfw:find-last-date
2633 |     (cfw:component-dest (cfw:cp-get-component)))))
2634 | 
2635 | (defun cfw:navi-next-week-command (&optional num)
2636 |   "Move the cursor forward NUM weeks. If NUM is nil, 1 is used.
2637 | Moves backward if NUM is negative."
2638 |   (interactive "p")
2639 |   (cfw:navi-next-day-command (* cfw:week-days (or num 1))))
2640 | 
2641 | (defun cfw:navi-previous-week-command (&optional num)
2642 |   "Move the cursor back NUM weeks. If NUM is nil, 1 is used.
2643 | Moves forward if NUM is negative."
2644 |   (interactive "p")
2645 |   (cfw:navi-next-day-command (* (- cfw:week-days) (or num 1))))
2646 | 
2647 | (defun cfw:navi-next-month-command (&optional num)
2648 |   "Move the cursor forward NUM months. If NUM is nil, 1 is used.
2649 | Movement is backward if NUM is negative."
2650 |   (interactive "p")
2651 |   (when (cfw:cp-get-component)
2652 |     (unless num (setq num 1))
2653 |     (let* ((cursor-date (cfw:cursor-to-nearest-date))
2654 |            (month (calendar-extract-month cursor-date))
2655 |            (day   (calendar-extract-day   cursor-date))
2656 |            (year  (calendar-extract-year  cursor-date))
2657 |            (last (progn
2658 |                    (calendar-increment-month month year num)
2659 |                    (calendar-last-day-of-month month year)))
2660 |            (day (min last day))
2661 |            (new-cursor-date (cfw:date month day year)))
2662 |       (cfw:navi-goto-date new-cursor-date))))
2663 | 
2664 | (defun cfw:navi-previous-month-command (&optional num)
2665 |   "Move the cursor back NUM months. If NUM is nil, 1 is used.
2666 | Movement is forward if NUM is negative."
2667 |   (interactive "p")
2668 |   (cfw:navi-next-month-command (- (or num 1))))
2669 | 
2670 | ;;; Detail popup
2671 | 
2672 | (defun cfw:show-details-command ()
2673 |   "Show details on the nearest date."
2674 |   (interactive)
2675 |   (let* ((cursor-date (cfw:cursor-to-nearest-date))
2676 |          (cp  (cfw:cp-get-component))
2677 |          (model (and cp (cfw:component-model cp))))
2678 |     (when model
2679 |       (cfw:details-popup
2680 |        (cfw:details-layout cursor-date model)))))
2681 | 
2682 | (defvar cfw:details-buffer-name "*cfw:details*" "[internal]")
2683 | (defvar cfw:details-window-size 20 "Default detail buffer window size.")
2684 | 
2685 | (defvar cfw:before-win-num)
2686 | (defvar cfw:main-buf)
2687 | 
2688 | (defun cfw:details-popup (text)
2689 |   "Popup the buffer to show details.
2690 | TEXT is a content to show."
2691 |   (let ((buf (get-buffer cfw:details-buffer-name))
2692 |         (before-win-num (length (window-list)))
2693 |         (main-buf (current-buffer)))
2694 |     (unless (and buf (eq (buffer-local-value 'major-mode buf)
2695 |                          'cfw:details-mode))
2696 |       (setq buf (get-buffer-create cfw:details-buffer-name))
2697 |       (with-current-buffer buf
2698 |         (cfw:details-mode)
2699 |         (set (make-local-variable 'cfw:before-win-num) before-win-num)))
2700 |     (with-current-buffer buf
2701 |       (let (buffer-read-only)
2702 |         (set (make-local-variable 'cfw:main-buf) main-buf)
2703 |         (erase-buffer)
2704 |         (insert text)
2705 |         (goto-char (point-min))))
2706 |     (pop-to-buffer buf)))
2707 | 
2708 | (defun cfw:details-layout (date model)
2709 |   "Layout details and return the text.
2710 | DATE is a date to show. MODEL is model object."
2711 |   (let* ((EOL "\n")
2712 |          (HLINE (cfw:rt (concat (make-string (window-width) ?-) EOL) 'cfw:face-grid))
2713 |          (holiday (cfw:model-get-holiday-by-date date model))
2714 |          (annotation (cfw:model-get-annotation-by-date date model))
2715 |          (periods (cfw:model-get-periods-by-date date model))
2716 |          (contents (cfw:render-sort-contents
2717 |                     (cfw:render-event-details-content
2718 |                      (cfw:model-get-contents-by-date date model))
2719 |                     (cfw:model-get-sorter model)))
2720 |          (row-count -1))
2721 |     (concat
2722 |      (cfw:rt (concat "Schedule on " (cfw:strtime date) " (") 'cfw:face-header)
2723 |      (cfw:rt (calendar-day-name date)
2724 |              (cfw:render-get-week-face (calendar-day-of-week date) 'cfw:face-header))
2725 |      (cfw:rt (concat ")" EOL) 'cfw:face-header)
2726 |      (when (or holiday annotation)
2727 |        (concat
2728 |         (and holiday (cfw:rt holiday 'cfw:face-holiday))
2729 |         (and holiday annotation " / ")
2730 |         (and annotation (cfw:rt annotation 'cfw:face-annotation))
2731 |         EOL))
2732 |      HLINE
2733 |      (cl-loop for (begin end summary) in periods
2734 |            for prefix = (propertize
2735 |                          (concat (cfw:strtime begin) " - " (cfw:strtime end) " : ")
2736 |                          'face (cfw:render-get-face-period summary 'cfw:face-periods)
2737 |                          'font-lock-face (cfw:render-get-face-period summary 'cfw:face-periods)
2738 |                          'cfw:row-count (cl-incf row-count))
2739 |            concat
2740 |            (concat prefix " " summary EOL))
2741 | 
2742 |      (cl-loop for i in contents
2743 |            for f = (cfw:render-get-face-content i 'cfw:face-default-content)
2744 |            concat
2745 |            (concat "- " (propertize
2746 |                          i 'face f 'font-lock-face f
2747 |                          'cfw:row-count (cl-incf row-count))
2748 |                    EOL)))))
2749 | 
2750 | (defvar cfw:details-mode-map
2751 |   (cfw:define-keymap
2752 |    '(("q"       . cfw:details-kill-buffer-command)
2753 |      ("SPC"     . cfw:details-kill-buffer-command)
2754 |      ("n"       . cfw:details-navi-next-command)
2755 |      ("f"       . cfw:details-navi-next-command)
2756 |      ("<right>" . cfw:details-navi-next-command)
2757 |      ("p"       . cfw:details-navi-prev-command)
2758 |      ("b"       . cfw:details-navi-prev-command)
2759 |      ("<left>"  . cfw:details-navi-prev-command)
2760 |      ("TAB"     . cfw:details-navi-next-item-command)
2761 |      ("C-i"     . cfw:details-navi-next-item-command)
2762 |      ("<backtab>" . cfw:details-navi-prev-item-command)
2763 |      ("S-TAB"     . cfw:details-navi-prev-item-command)
2764 |      ))
2765 |   "Default key map for the details buffer.")
2766 | 
2767 | (defvar cfw:details-mode-hook nil "")
2768 | 
2769 | (defun cfw:details-mode ()
2770 |   "Set up major mode `cfw:details-mode'.
2771 | 
2772 | \\{cfw:details-mode-map}"
2773 |   (kill-all-local-variables)
2774 |   (setq truncate-lines t)
2775 |   (use-local-map cfw:details-mode-map)
2776 |   (setq major-mode 'cfw:details-mode
2777 |         mode-name "Calendar Details Mode")
2778 |   (setq buffer-undo-list t
2779 |         buffer-read-only t)
2780 |   (run-hooks 'cfw:details-mode-hook))
2781 | 
2782 | (defun cfw:details-kill-buffer-command ()
2783 |   "Kill buffer and delete window."
2784 |   (interactive)
2785 |   (let ((win-num (length (window-list)))
2786 |         (next-win (get-buffer-window cfw:main-buf)))
2787 |     (when (and (not (one-window-p))
2788 |                (> win-num cfw:before-win-num))
2789 |       (delete-window))
2790 |     (kill-buffer cfw:details-buffer-name)
2791 |     (when next-win (select-window next-win))))
2792 | 
2793 | (defun cfw:details-navi-next-command (&optional num)
2794 |   (interactive "p")
2795 |   (when cfw:main-buf
2796 |     (with-current-buffer cfw:main-buf
2797 |       (cfw:navi-next-day-command num)
2798 |       (cfw:show-details-command))))
2799 | 
2800 | (defun cfw:details-navi-prev-command (&optional num)
2801 |   (interactive "p")
2802 |   (when cfw:main-buf
2803 |     (with-current-buffer cfw:main-buf
2804 |       (cfw:navi-previous-day-command num)
2805 |       (cfw:show-details-command))))
2806 | 
2807 | (defun cfw:details-navi-next-item-command ()
2808 |   (interactive)
2809 |   (let* ((rcount (or (get-text-property (point) 'cfw:row-count) -1))
2810 |          (next-pos (cfw:details-find-item (1+ rcount))))
2811 |     (goto-char (or next-pos (point-min)))))
2812 | 
2813 | (defun cfw:details-navi-prev-item-command ()
2814 |   (interactive)
2815 |   (let* ((rcount (or (get-text-property (point) 'cfw:row-count) -1))
2816 |          (next-pos (cfw:details-find-item (1- rcount))))
2817 |     (goto-char (or next-pos (point-min)))))
2818 | 
2819 | (defun cfw:details-find-item (row-count)
2820 |   "[internal] Find the schedule item which has the text
2821 | properties as `cfw:row-count' = ROW-COUNT. If no item is found,
2822 | this function returns nil."
2823 |   (cl-loop with pos = (point-min)
2824 |         for next-pos = (next-single-property-change pos 'cfw:row-count)
2825 |         for text-row-count = (and next-pos (get-text-property next-pos 'cfw:row-count))
2826 |         while next-pos do
2827 |         (when (eql row-count text-row-count)
2828 |           (cl-return next-pos))
2829 |         (setq pos next-pos)))
2830 | 
2831 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2832 | ;;; High level API
2833 | 
2834 | ;; buffer
2835 | 
2836 | (cl-defun cfw:open-calendar-buffer
2837 |     (&key date buffer custom-map contents-sources annotation-sources view sorter)
2838 |   "Open a calendar buffer simply.
2839 | DATE is initial focus date. If it is nil, today is selected
2840 | initially.  This function uses the function
2841 | `cfw:create-calendar-component-buffer' internally."
2842 |   (interactive)
2843 |   (let (cp)
2844 |     (save-excursion
2845 |       (setq cp (cfw:create-calendar-component-buffer
2846 | 		:date date :buffer buffer :custom-map custom-map
2847 | 		:contents-sources contents-sources
2848 | 		:annotation-sources annotation-sources :view view :sorter sorter)))
2849 |     (switch-to-buffer (cfw:cp-get-buffer cp))))
2850 | 
2851 | (cl-defun cfw:create-calendar-component-buffer
2852 |   (&key date buffer custom-map contents-sources annotation-sources view sorter)
2853 |   "Return a calendar buffer with some customize parameters.
2854 | 
2855 | This function binds the component object at the
2856 | buffer local variable `cfw:component'.
2857 | 
2858 | The size of calendar is calculated from the window that shows
2859 | BUFFER or the selected window. DATE is initial focus date. If it
2860 | is nil, today is selected initially. BUFFER is the buffer to be
2861 | rendered. If BUFFER is nil, this function creates a new buffer
2862 | named `cfw:calendar-buffer-name'. CUSTOM-MAP is the additional
2863 | keymap that is added to default keymap `cfw:calendar-mode-map'."
2864 |   (let* ((dest  (cfw:dest-init-buffer buffer nil nil custom-map))
2865 |          (model (cfw:model-abstract-new date contents-sources annotation-sources sorter))
2866 |          (cp (cfw:cp-new dest model view date)))
2867 |     (with-current-buffer (cfw:dest-buffer dest)
2868 |       (set (make-local-variable 'cfw:component) cp))
2869 |     cp))
2870 | 
2871 | ;; region
2872 | 
2873 | (cl-defun cfw:create-calendar-component-region
2874 |   (&key date width height keymap contents-sources annotation-sources view sorter)
2875 |   "Display the calendar view.
2876 | 
2877 | This function also inserts markers of the rendering destination
2878 | at current point and returns a component object and stores it at
2879 | the text property `cfw:component'.
2880 | 
2881 | DATE is initial focus date. If it is nil, today is selected
2882 | initially. WIDTH and HEIGHT are reference size of the calendar
2883 | view. If those are nil, the size is calculated from the selected
2884 | window. KEYMAP is the keymap that is put to the text property
2885 | `keymap'. If KEYMAP is nil, `cfw:calendar-mode-map' is used."
2886 |   (let (mark-begin mark-end)
2887 |     (setq mark-begin (point-marker))
2888 |     (insert " ")
2889 |     (setq mark-end (point-marker))
2890 |     (save-excursion
2891 |       (let* ((dest (cfw:dest-init-region (current-buffer) mark-begin mark-end width height))
2892 |              (model (cfw:model-abstract-new date contents-sources annotation-sources sorter))
2893 |              (cp (cfw:cp-new dest model view date))
2894 |              (after-update-func
2895 |               (let ((keymap keymap) (cp cp))
2896 |                 (lambda ()
2897 |                   (cfw:dest-with-region (cfw:component-dest cp)
2898 |                     (let (buffer-read-only)
2899 |                       (put-text-property (point-min) (1- (point-max))
2900 |                                          'cfw:component cp)
2901 |                       (cfw:fill-keymap-property
2902 |                        (point-min) (1- (point-max))
2903 |                        (or keymap cfw:calendar-mode-map))))))))
2904 |         (setf (cfw:dest-after-update-func dest) after-update-func)
2905 |         (funcall after-update-func)
2906 |         cp))))
2907 | 
2908 | (defun cfw:fill-keymap-property (begin end keymap)
2909 |   "[internal] Put the given text property to the region between BEGIN and END.
2910 | If the text already has some keymap property, the text is skipped."
2911 |   (save-excursion
2912 |     (goto-char begin)
2913 |     (cl-loop with pos = begin with nxt = nil
2914 |           until (or (null pos) (<= end pos))
2915 |           when (get-text-property pos 'keymap) do
2916 |           (setq pos (next-single-property-change pos 'keymap))
2917 |           else do
2918 |           (setq nxt (next-single-property-change pos 'keymap))
2919 |           (when (null nxt) (setq nxt end))
2920 |           (put-text-property pos (min nxt end) 'keymap keymap))))
2921 | 
2922 | ;; inline
2923 | 
2924 | (cl-defun cfw:get-calendar-text
2925 |   (width height &key date _keymap contents-sources annotation-sources view sorter)
2926 |   "Return a text that is drew the calendar view.
2927 | 
2928 | In this case, the rendering destination object is disposable.
2929 | 
2930 | WIDTH and HEIGHT are reference size of the calendar view.  If the
2931 | given size is larger than the minimum size (about 45x20), the
2932 | calendar is displayed within the given size. If the given size is
2933 | smaller, the minimum size is used.
2934 | 
2935 | DATE is initial focus date. If it is nil, today is selected initially."
2936 |   (let* ((dest (cfw:dest-init-inline width height))
2937 |          (model (cfw:model-abstract-new date contents-sources annotation-sources sorter))
2938 |          (cp (cfw:cp-new dest model view date))
2939 |          text)
2940 |     (setq text
2941 |           (with-current-buffer (cfw:cp-get-buffer cp)
2942 |             (buffer-substring (point-min) (point-max))))
2943 |     (kill-buffer (cfw:cp-get-buffer cp))
2944 |     text))
2945 | 
2946 | 
2947 | 
2948 | ;;; debug
2949 | 
2950 | (defun cfw:open-debug-calendar ()
2951 |   (let* ((source1
2952 |           (make-cfw:source
2953 |            :name "test1"
2954 |            :color "Lightpink3"
2955 |            :period-bgcolor "Lightpink1"
2956 |            :period-fgcolor "White"
2957 |            :opt-face '(:weight bold)
2958 |            :opt-period-face '(:slant italic)
2959 |            :data
2960 |            (lambda (_b _e)
2961 |              '(((1  1 2011) "A happy new year!")
2962 |                ((1 10 2011) "TEST2" "TEST3")
2963 |                (periods
2964 |                 ((1 8 2011) (1 9 2011) "Range1")
2965 |                 ((1 11 2011) (1 12 2011) "[Sample]Range2 1/8-1/9")
2966 |                 ((1 12 2011) (1 14 2011) "long long title3"))))
2967 |            :update
2968 |            (lambda () (message "SOURCE: test1 update!"))))
2969 |          (source2
2970 |           (make-cfw:source
2971 |            :name "test2"
2972 |            :data
2973 |            (lambda (_b _e)
2974 |              '(((1  2 2011) "The quick brown fox jumped over the lazy dog. The internationalization and Localization are long words.")
2975 |                ((1 10 2011) "PTEST2 title subject" "PTEST3 multi-line sample")
2976 |                (periods
2977 |                 ((1 14 2011) (1 15 2011) "Stack")
2978 |                 ((1 29 2011) (1 31 2011) "PERIOD W"))))))
2979 |          (asource1
2980 |           (make-cfw:source
2981 |            :name "Moon"
2982 |            :data
2983 |            (lambda (_b _e)
2984 |              '(((1  4 2011) . "New Moon")
2985 |                ((1 12 2011) . "Young Moon")
2986 |                ((1 20 2011) . "Full Moon")
2987 |                ((1 26 2011) . "Waning Moon")))))
2988 |          (asource2
2989 |           (make-cfw:source
2990 |            :name "Moon"
2991 |            :data
2992 |            (lambda (_b _e)
2993 |              '(((1  5 2011) . "AN1")
2994 |                ((1 13 2011) . "AN2")
2995 |                ((1 20 2011) . "AN3")
2996 |                ((1 28 2011) . "AN4")))))
2997 |          (event-source
2998 |           (make-cfw:source
2999 |            :name "Events"
3000 |            :color "DarkOrange"
3001 |            :data
3002 |            (lambda (_b _e)
3003 |              `(,(make-cfw:event :title       "Shopping"
3004 |                                 :start-date  '(1 17 2011))
3005 |                ,(make-cfw:event :title       "Other Thing"
3006 |                                 :start-date  '(1 17 2011))
3007 |                ,(make-cfw:event :title       "Spring cleaning"
3008 |                                 :start-date  '(1 15 2011)
3009 |                                 :location    "Home"
3010 |                                 :description "Oh what a joy!!")
3011 |                ,(make-cfw:event :title       "Meeting"
3012 |                                 :start-date  '(1 16 2011)
3013 |                                 :start-time  '(15 00)
3014 |                                 :location    "Office"
3015 |                                 :description "Important talk")
3016 |                ,(make-cfw:event :title       "Lunch"
3017 |                                 :start-date  '(1 15 2011)
3018 |                                 :start-time  '(13 15)
3019 |                                 :end-time    '(14 30)
3020 |                                 :location    "Fancy place"
3021 |                                 :description "Omnomnom")
3022 |                ,(make-cfw:event :title       "Long one"
3023 |                                 :start-date  '(1 17 2011)
3024 |                                 :description "This is a multiline description.
3025 | 
3026 | Some text here.
3027 | 
3028 | But also some here.
3029 | 
3030 | And here.")
3031 |                (periods
3032 |                 ,(make-cfw:event :title      "Vacation bla bli blubb very long"
3033 |                                  :start-date '(1 13 2011)
3034 |                                  :end-date   '(1 20 2011)
3035 |                                  :location    "Beach"
3036 |                                  :description "Enjoy the sun!"))))))
3037 |          (cp (cfw:create-calendar-component-buffer
3038 |               :date (cfw:date 1 10 2011)
3039 |               :view 'two-weeks
3040 |               :contents-sources (list source1 source2 event-source)
3041 |               :annotation-sources (list asource1 asource2))))
3042 |     (cfw:cp-add-update-hook cp (lambda () (message "CFW: UPDATE HOOK")))
3043 |     (cfw:cp-add-click-hook cp (lambda () (message "CFW: CLICK HOOK %S" (cfw:cursor-to-nearest-date))))
3044 |     (switch-to-buffer (cfw:cp-get-buffer cp))))
3045 | 
3046 | (provide 'calfw)
3047 | ;;; calfw.el ends here
3048 | 
3049 | ;; (progn (eval-buffer) (cfw:open-debug-calendar))
3050 | ;; (progn (eval-buffer) (cfw:open-calendar-buffer))
3051 | 


--------------------------------------------------------------------------------
/calfw.juth:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/haji-ali/emacs-calfw/de99e8e848ee03811388f433f7eb0400976b791d/calfw.juth


--------------------------------------------------------------------------------
/readme.md:
--------------------------------------------------------------------------------
  1 | # Calfw - A calendar framework for Emacs
  2 | 
  3 | ## What is calfw?
  4 | 
  5 | This program displays a calendar view in the Emacs buffer.
  6 | 
  7 | ![Calfw image](https://cacoo.com/diagrams/OnjKgBHat0kHs0xp-9E5E0.png?width=600)
  8 | 
  9 | ### Screenshots
 10 | 
 11 | Currently, calfw has 4 views, month, 1week, 2week and day view.
 12 | ![Views](https://cacoo.com/diagrams/OnjKgBHat0kHs0xp-F3756.png?width=600)
 13 | 
 14 | Pushing SPC key, the detail buffer pops up. Pushing SPC key again, the buffer is closed.
 15 | ![Pop up details](https://cacoo.com/diagrams/OnjKgBHat0kHs0xp-83C80.png?width=600)
 16 | 
 17 | Many information items are displayed in the Emacs buffer.
 18 | ![View details](https://cacoo.com/diagrams/OnjKgBHat0kHs0xp-B961B.png?width=600)
 19 | 
 20 | ## Installation
 21 | 
 22 | To use this program, locate this file to load-path directory,
 23 | and add the following code to your .emacs.
 24 | 
 25 | ```el
 26 | (require 'calfw)
 27 | ```
 28 | 
 29 | Executing the command `cfw:open-calendar-buffer`, switch to the calendar buffer.
 30 | You can navigate the date like calendar.el.
 31 | 
 32 | Schedule data which are shown in the calendar view, are collected by a
 33 | list of the struct `cfw:source` objects through the named argument
 34 | variables `:contents-sources` and `:annotation-sources`. The former
 35 | source defines schedule contents. The later one does date
 36 | annotations like the moon phases.
 37 | 
 38 | This program gets the holidays using the function
 39 | `calendar-holiday-list`. See the document for the holidays.el and the Info text.
 40 | 
 41 | ## Fork changelog
 42 | 
 43 | This fork has the following change
 44 | - Applied three external pull requests (See Pull requests for more info)
 45 | - Implement a `noerror` mode for `cp-get-compoonent`
 46 | - Removed highlighting of selected date, preferring more subtle indication.
 47 | - Showing calendars on separate lines and allowing showing/hiding of them
 48 | - Removed everything to do with selecting a date, preferring instead to use
 49 |   the point to indicate selection.
 50 | - Changed coloring of background/foreground.
 51 | - Removed M-v and C-v binding.
 52 | - Cleaned up some of the code and using more standard functions, though much
 53 |   more can be done (WIP).
 54 | 
 55 | I use this package with
 56 | [calfw-blocks](https://github.com/haji-ali/calfw-blocks) and
 57 | [maccalfw](https://github.com/haji-ali/maccalfw/) and I am only testing the
 58 | block views on a regular basis.
 59 | 
 60 | ## Key bindings
 61 | 
 62 | In the calendar buffer and region, you can use following key bindings:
 63 | 
 64 | | Navigation          |                                              | 
 65 | |---------------------|----------------------------------------------| 
 66 | | [left], b, h        | Previous day                                 |
 67 | | [right], f, l       | Next day                                     |
 68 | | [up], p, k          | Previous week                                |
 69 | | [down], n, j        | Next week                                    |
 70 | | ^                   | Week begin                                   |
 71 | | $                   | Week end                                     |
 72 | | [home]              | First date in this month                     |
 73 | | [end]               | Last date in this month                      |
 74 | | M-v, [PgUp], &lt;   | Previous month                               |
 75 | | C-v, [PgDown], &gt; | Next month                                   |
 76 | | t                   | Today                                        |
 77 | | g                   | Absolute date (YYYY/MM/DD)                   |
 78 | | TAB                 | Next item in a day                           |
 79 | 
 80 | | Changing View       |                                              |
 81 | |---------------------|----------------------------------------------|
 82 | | M                   | Month view                                   |
 83 | | W                   | 1 Week view                                  |
 84 | | T                   | 2 Week view                                  |
 85 | | D                   | Day view                                     |
 86 | 
 87 | | Operation           |                                              |
 88 | |---------------------|----------------------------------------------|
 89 | | r                   | Refresh data and re-draw contents            |
 90 | | SPC                 | Pop-up detail buffer (like Quicklook in Mac) |
 91 | | RET, [click]        | Jump (howm, orgmode)                         |
 92 | | q                   | Bury buffer                                  |
 93 | 
 94 | The buttons on the toolbar can be clicked.
 95 | 
 96 | ## Add-ons:
 97 | 
 98 | Following programs are also useful:
 99 | 
100 | - calfw-howm.el : Display howm schedules (http://howm.sourceforge.jp/index.html)
101 | - calfw-ical.el : Display schedules of the iCalendar format, such as the google calendar.
102 | - calfw-org.el  : Display org schedules (http://orgmode.org/)
103 | - calfw-cal.el  : Display diary schedules.
104 | 
105 | ## Setting example:
106 | 
107 | ### For howm users:
108 | 
109 | ```el
110 | (eval-after-load "howm-menu" '(progn
111 |   (require 'calfw-howm)
112 |   (cfw:install-howm-schedules)
113 |   (define-key howm-mode-map (kbd "M-C") 'cfw:open-howm-calendar)
114 | ))
115 | ```
116 | 
117 | If you are using Elscreen, here is useful.
118 | 
119 | ```el
120 | (define-key howm-mode-map (kbd "M-C") 'cfw:elscreen-open-howm-calendar)
121 | ```
122 | 
123 | You can display a calendar in your howm menu file.
124 | 
125 | ```
126 | %here%(cfw:howm-schedule-inline)
127 | ```
128 | 
129 | ![howm menu embedding](https://cacoo.com/diagrams/vrScI4K2QlmDApfd-1F941.png?width=450)
130 | 
131 | ### For org users:
132 | 
133 |     (require 'calfw-org)
134 | 
135 | Then, M-x `cfw:open-org-calendar`.
136 | 
137 | ![org-agenda and calfw-org](https://cacoo.com/diagrams/S6aJntG6giGs44Yn-89CB2.png?width=450)
138 | 
139 | #### Filtering agenda items
140 | 
141 | You can choose agenda items with `cfw:org-agenda-schedule-args`, like following code:
142 | 
143 | ```el
144 | (setq cfw:org-agenda-schedule-args '(:timestamp))
145 | ```
146 | 
147 | This setting restricts items containing a date stamp or date range matching the selected date.
148 | If `cfw:org-agenda-schedule-args` is `nil`, the default customize variable `org-agenda-entry-types` is used. For the further information, please refer the orgmode document.
149 | 
150 | - [Worg: Speeding up custom agenda commands](http://orgmode.org/worg/org-tutorials/org-custom-agenda-commands.html#sec-5)
151 | 
152 | #### Orgmode like key bindng
153 | 
154 | You can use another key binding like org agenda buffer, setting `cfw:org-overwrite-default-keybinding` to non-nil, like following code:
155 | 
156 | ```el
157 | (setq cfw:org-overwrite-default-keybinding t)
158 | ```
159 | 
160 | Then, following key bindings are overwritten:
161 | 
162 | | key   | function
163 | |-------|----------------------------------------
164 | |   g   | Refresh data and re-draw contents (cfw:refresh-calendar-buffer)
165 | |   j   | Goto the specified date (cfw:org-goto-date)
166 | |   k   | org-capture
167 | |   x   | Close calfw and other buffers opened by calfw-org (cfw:org-clean-exit)
168 | |   d   | Day view (cfw:change-view-day)
169 | |   v d | Day view (cfw:change-view-day)
170 | |   v w | 1 Week view (cfw:change-view-week)
171 | |   v m | Month View (cfw:change-view-month)
172 | 
173 | #### Synchronization with google calendar
174 | 
175 | Here is the program which helps synchronization schedule items between org and google calendar, and also collaborates with calfw.
176 | 
177 | - https://github.com/myuhe/org-gcal.el
178 |     - [Org-modeとGoogle calendar間で予定をやりとりするorg-gcal.elというのを作りました](http://sheephead.homelinux.org/2014/03/14/7023/)
179 |     - [calfwとorg-gcalの連携](http://sheephead.homelinux.org/2014/03/15/7035/)
180 | 
181 | ### For iCal (Google Calendar) users:
182 | 
183 | Here is a minimum sample code:
184 | 
185 | ```el
186 | (require 'calfw-ical)
187 | (cfw:open-ical-calendar "http://www.google.com/calendar/ical/.../basic.ics")
188 | ```
189 | 
190 | ![Google Calendar and calfw-ical](https://cacoo.com/diagrams/vrScI4K2QlmDApfd-5E808.png?width=450)
191 | 
192 | Here is the add-on program which communicate with google calendar via API:
193 | 
194 | - [calfwからGoogleカレンダーを編集するcalfw-gcal.elを書いてみた](http://sheephead.homelinux.org/2011/01/18/6559/)
195 |     - https://github.com/myuhe/calfw-gcal.el/blob/master/calfw-gcal.el
196 | 
197 | ### For diary users:
198 | 
199 | Here is a minimum sample code:
200 | 
201 | ```el
202 | (require 'calfw-cal)
203 | ```
204 | 
205 | Then, M-x `cfw:open-diary-calendar`.
206 | 
207 | If you see a blank entry for each day, set the variable `diary-list-include-blanks` to nil.
208 | 
209 | ### General setting
210 | 
211 | The calfw view can display many schedule items, gathering some schedule sources.
212 | Using the function `cfw:open-calendar-buffer` is the general way to display the schedules.
213 | 
214 | Here is the sample code:
215 | 
216 | ```el
217 | (require 'calfw-cal)
218 | (require 'calfw-ical)
219 | (require 'calfw-howm)
220 | (require 'calfw-org)
221 | 
222 | (defun my-open-calendar ()
223 |   (interactive)
224 |   (cfw:open-calendar-buffer
225 |    :contents-sources
226 |    (list
227 |     (cfw:org-create-source "Green")  ; orgmode source
228 |     (cfw:howm-create-source "Blue")  ; howm source
229 |     (cfw:cal-create-source "Orange") ; diary source
230 |     (cfw:ical-create-source "Moon" "~/moon.ics" "Gray")  ; ICS source1
231 |     (cfw:ical-create-source "gcal" "https://..../basic.ics" "IndianRed") ; google calendar ICS
232 |    ))) 
233 | ```
234 | 
235 | The function `cfw:open-calendar-buffer` receives schedules sources via
236 | the named argument `:contents-sources`.
237 | 
238 | One can customize the keymap on the calendar buffer with the named
239 | argument `:custom-map` of `cfw:open-calendar-buffer`.
240 | 
241 | 
242 | ## Customize
243 | 
244 | ### Holidays
245 | 
246 | The calfw collects holidays from the customize variable
247 | `calendar-holidays` which belongs to holidays.el in the Emacs. See the
248 | document and source of holidays.el for details.
249 | 
250 | ### Format of month and week days
251 | 
252 | The calfw uses some customization variables in the calendar.el.
253 | 
254 | Here is a customization code:
255 | 
256 | ```el
257 | ;; Month
258 | (setq calendar-month-name-array
259 |   ["January" "February" "March"     "April"   "May"      "June"
260 |    "July"    "August"   "September" "October" "November" "December"])
261 | 
262 | ;; Week days
263 | (setq calendar-day-name-array
264 |       ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"])
265 | 
266 | ;; First day of the week
267 | (setq calendar-week-start-day 0) ; 0:Sunday, 1:Monday
268 | ```
269 | 
270 | ### Faces
271 | 
272 | One can customize the faces.
273 | 
274 | Here is a template code for face customization:
275 | 
276 | ```el
277 | (custom-set-faces
278 |  '(cfw:face-title ((t (:foreground "#f0dfaf" :weight bold :height 2.0 :inherit variable-pitch))))
279 |  '(cfw:face-header ((t (:foreground "#d0bf8f" :weight bold))))
280 |  '(cfw:face-sunday ((t :foreground "#cc9393" :background "grey10" :weight bold)))
281 |  '(cfw:face-saturday ((t :foreground "#8cd0d3" :background "grey10" :weight bold)))
282 |  '(cfw:face-holiday ((t :background "grey10" :foreground "#8c5353" :weight bold)))
283 |  '(cfw:face-grid ((t :foreground "DarkGrey")))
284 |  '(cfw:face-default-content ((t :foreground "#bfebbf")))
285 |  '(cfw:face-periods ((t :foreground "cyan")))
286 |  '(cfw:face-day-title ((t :background "grey10")))
287 |  '(cfw:face-default-day ((t :weight bold :inherit cfw:face-day-title)))
288 |  '(cfw:face-annotation ((t :foreground "RosyBrown" :inherit cfw:face-day-title)))
289 |  '(cfw:face-disable ((t :foreground "DarkGray" :inherit cfw:face-day-title)))
290 |  '(cfw:face-today-title ((t :background "#7f9f7f" :weight bold)))
291 |  '(cfw:face-today ((t :background: "grey10" :weight bold)))
292 |  '(cfw:face-select ((t :background "#2f2f2f")))
293 |  '(cfw:face-toolbar ((t :foreground "Steelblue4" :background "Steelblue4")))
294 |  '(cfw:face-toolbar-button-off ((t :foreground "Gray10" :weight bold)))
295 |  '(cfw:face-toolbar-button-on ((t :foreground "Gray50" :weight bold))))
296 | ```
297 | 
298 | ### Grid frame
299 | 
300 | Users can have nice unicode grid frame. However, in the some environment, the Emacs can not display the grid characters correctly. Please try following settings.
301 | 
302 | Grid setting example:
303 | 
304 | ```el
305 | ;; Default setting
306 | (setq cfw:fchar-junction ?+
307 |       cfw:fchar-vertical-line ?|
308 |       cfw:fchar-horizontal-line ?-
309 |       cfw:fchar-left-junction ?+
310 |       cfw:fchar-right-junction ?+
311 |       cfw:fchar-top-junction ?+
312 |       cfw:fchar-top-left-corner ?+
313 |       cfw:fchar-top-right-corner ?+ )
314 | 
315 | ;; Unicode characters
316 | (setq cfw:fchar-junction ?╋
317 |       cfw:fchar-vertical-line ?┃
318 |       cfw:fchar-horizontal-line ?━
319 |       cfw:fchar-left-junction ?┣
320 |       cfw:fchar-right-junction ?┫
321 |       cfw:fchar-top-junction ?┯
322 |       cfw:fchar-top-left-corner ?┏
323 |       cfw:fchar-top-right-corner ?┓)
324 |       
325 | ;; Another unicode chars
326 | (setq cfw:fchar-junction ?╬
327 |       cfw:fchar-vertical-line ?║
328 |       cfw:fchar-horizontal-line ?═
329 |       cfw:fchar-left-junction ?╠
330 |       cfw:fchar-right-junction ?╣
331 |       cfw:fchar-top-junction ?╦
332 |       cfw:fchar-top-left-corner ?╔
333 |       cfw:fchar-top-right-corner ?╗)
334 | ```
335 | 
336 | ### Line breaking
337 | 
338 | If a content string is longer than the cell width, the calfw breaks into the multiple lines.
339 | In the current implementation, the Calfw has 3 strategies: none, simple and wordwrap. The variable `cfw:render-line-breaker` selects the strategy to break lines.
340 | 
341 | - `cfw:render-line-breaker-none`
342 |     - Never breaks lines. Longer contents are truncated.
343 | - `cfw:render-line-breaker-simple` (default)
344 |     - This strategy breaks lines with rigid width. This may be not so beautiful, but In the most cases it looks good.
345 | - `cfw:render-line-breaker-wordwrap`
346 |     - This strategy breaks lines with the emacs function `fill-region`. Although, the line breaking algorithm of the Emacs is not so smart as more complicated ones, such as Knuth/Plass algorithm, this strategy is better than the simple one.
347 | 
348 | ## Calfw framework details
349 | 
350 | In this section, I would explain how to add a new calendar source and how to embed the calfw component in the other applications.
351 | 
352 | ### How to add a new calendar source?
353 | 
354 | Defining the `cfw:source` object, one can extend calfw calendar source.
355 | 
356 | #### struct cfw:source details
357 | 
358 | The struct `cfw:source` is a simple data type defined by cl-defstruct.
359 | 
360 | Here is the details of the slot members of `cfw:source`.
361 | 
362 | | slot name       | description                                                                                                                        |
363 | |-----------------|------------------------------------------------------------------------------------------------------------------------------------ |
364 | | name            | [required] Source name. This name is shown at the status bar.                                                                      |
365 | | data            | [required] Data function which returns calendar contents. The function details are described in the next section.                  |
366 | | update          | [option] Update function. Calfw calls this function when this source needs to refresh the data.                                    |
367 | | color           | [option] Color string for this source.  Color names those are shown by `M-x list-colors-display` or RGB hex format like "#abcdef". |
368 | | period-fgcolor  | [option] Foreground color for period items. The default color is white or black.                                                   |
369 | | period-bgcolor  | [option] Background color for period items. The default color is `cfw:source-color`.                                               |
370 | | opt-face        | [option] Additional options for the normal item face.  Ex. `:opt-face '(:weight bold)`                                             |
371 | | opt-period-face | [option] Additional options for the period item face.                                                                              |
372 | 
373 | Only `name` and `data` slots are essential. Many slots are visual options.
374 | 
375 | In many cases, one has to specify only the `color` slot for visual,
376 | because the calfw chooses appropriate colors for the rest color options.
377 | 
378 | #### cfw:source-data details
379 | 
380 | This section explains what objects the function-slot `cfw:source-data` should return.
381 | 
382 | The function-slot `cfw:source-data` receives two arguments, start and
383 | end date of the query period, and returns a list of instances of `cfw:event` struct.
384 | 
385 | Here is a simple example. 
386 | 
387 | `cfw:source-data example1:`
388 | 
389 | ```el
390 | ;; cfw:source-data example
391 | (defun sample-data1 (b e)
392 |   (list
393 |     (make-cfw:event :title "item1"   :start-date  (cfw:date 1 1 2011))
394 |     (make-cfw:event :title "item2-1" :start-date  (cfw:date 1 10 2011))
395 |     (make-cfw:event :title "item2-2" :start-date  (cfw:date 1 10 2011))
396 |     ))
397 | 
398 | (cfw:open-calendar-buffer
399 |   :date (cfw:date 1 1 2011)
400 |   :contents-sources
401 |    (list 
402 |      (make-cfw:source
403 |       :name "test1" :data 'sample-data1)))
404 | ```
405 | 
406 | Evaluating this code in the scratch buffer, following result is displayed.
407 | 
408 | ![Simple source example](https://cacoo.com/diagrams/P6baUrxEQj4NYheV-50310.png?width=450)
409 | 
410 | The date is specified by `cfw:date` type, `([month] [day] [year])`. This format is commonly used in calendar.el and orgmode.
411 | (I diagrammed the exchange ways for some time and date formats in Emacs, [here](https://cacoo.com/diagrams/lsA64PTazlLTbSwR).)
412 | 
413 | Period items are little different. One period item is specified by
414 | `:start-date` and `:end-date`, and the nested list which has the symbol `periods` at the head collects them, like the following code.
415 | 
416 | `cfw:source-data example2:`
417 | 
418 | ```el
419 | ;; cfw:source-data period items
420 | (defun sample-data2 (b e)
421 |   (list
422 |     (make-cfw:event :title "Item1"
423 |           :start-date  (cfw:date 1 15 2011))
424 |     (list 'periods
425 |       (make-cfw:event :title "Period item"
426 |           :start-date (cfw:date 1 8 2011)
427 |           :end-date   (cfw:date 1 9 2011)
428 |           :description "Period item description")
429 |       (make-cfw:event :title "Next item"
430 |           :start-date (cfw:date 1 11 2011)
431 |           :end-date   (cfw:date 1 12 2011)
432 |           :description "Next item description"))))
433 |   
434 | (cfw:open-calendar-buffer
435 |   :date (cfw:date 1 1 2011)
436 |   :contents-sources
437 |    (list 
438 |      (make-cfw:source
439 |       :name "test2" :data 'sample-data2)))
440 | ```
441 | 
442 | Evaluating this code in the scratch buffer, following result is displayed.
443 | 
444 | ![Range items example](https://cacoo.com/diagrams/P6baUrxEQj4NYheV-40315.png?width=450)
445 | 
446 | Here are other detailed specifications.
447 | 
448 | - The both start and end date are included by the query period.
449 | - The items those aren't included in the query period are ignored.
450 | - `cfw:source-data` should return a value as fast as possible, because users are waiting for the result. Caching is good idea.
451 | - Schedule items don't have to be ordered. Duplicated items may be gathered.
452 | - In the day cell, the items are sorted by `string-lessp`, i.e. numerical and alphabetical order.
453 |   - The ordering function can be customized by the named argument `:sorter` of the component construction.
454 | 
455 | In the above examples, the dates of the schedule items are fixed. The actual sources generate result values by the programs. The codes of calfw add-ons may be helpful for your implementation.
456 | 
457 | ##### cfw:event struct detail
458 | 
459 | The `cfw:event` struct:
460 | 
461 | | slot name     | description                                 |
462 | |---------------|---------------------------------------------|
463 | | `title`       | event title [string]                        |
464 | | `start-date`  | start date of the event [cfw:date]          |
465 | | `start-time`  | start time of the event (optional)          |
466 | | `end-date`    | end date of the event [cfw:date] (optional) |
467 | | `end-time`    | end of the event (optional)                 |
468 | | `description` | event description [string] (optional)       |
469 | | `location`    | location [string] (optional)                |
470 | | `source`      | [internal] source of the event              |
471 | 
472 | ##### Event formatting
473 | 
474 | The framework has several formatting functions for `cfw:event` instances.
475 | The functions are used by the calfw plugins (cal,ical, etc) to display in a common way.
476 | 
477 | | Format function             | Description                                                 |
478 | |-----------------------------|-------------------------------------------------------------|
479 | | `cfw:event-overview`        | To get an overview of the event (month, 2-week & week view) |
480 | | `cfw:event-days-overview`   | Overview in day-view.                                       |
481 | | `cfw:event-period-overview` | Overview of periods (same for all views)                    |
482 | | `cfw:event-detail`          | Detailed information of the event for the detail-view       |
483 | 
484 | The formatting can be customized by the user with several formatting strings:
485 | 
486 | - `cfw:event-format-overview`
487 | - `cfw:event-format-days-overview`
488 | - `cfw:event-format-period-overview`
489 | - `cfw:event-format-detail`
490 | - `cfw:event-format-title`
491 | - `cfw:event-format-start-date`
492 | - `cfw:event-format-start-time`
493 | - `cfw:event-format-end-date`
494 | - `cfw:event-format-end-time`
495 | - `cfw:event-format-location`
496 | - `cfw:event-format-description`
497 | 
498 | #### Examples
499 | 
500 | - [calfw-git.el](https://gist.github.com/kiwanami/d77d9669440f3336bb9d)
501 |     - Displaying git commit history items in calfw calendar view
502 | - [calfw-syobocal.el](https://gist.github.com/kiwanami/1fd257fc1e8907d4d92e)
503 |     - Retrieving schedule items via Web API and displaying them in calfw calendar view
504 | 
505 | #### Another way to define schedule items (legacy method)
506 | 
507 | *This subsection explains legacy method to define schedule items, so as for users to read old source codes. We should not use this method in the future.*
508 | 
509 | The function-slot `cfw:source-data` receives two arguments, start and
510 | end date of the query period, and returns an alist that consists of
511 | ([date] . ([item1] [item2] ... )).
512 | 
513 | Here is a simple example. 
514 | 
515 | `cfw:source-data example1:`
516 | 
517 | ```el
518 | ;; cfw:source-data example
519 | (defun sample-data1 (b e)
520 |   '(
521 |     ((1  1 2011) . ("item1"))
522 |     ((1 10 2011) . ("item2-1" "item2-2"))
523 |     ))
524 | 
525 | (cfw:open-calendar-buffer
526 |   :date (cfw:date 1 1 2011)
527 |   :contents-sources
528 |    (list 
529 |      (make-cfw:source
530 |       :name "test1" :data 'sample-data1)))
531 | ```
532 | 
533 | Period items are little different. One period item is specified by
534 | `([start date] [end date] [content])` and the `periods` record of the
535 | alist collects them as a list, like the following code.
536 | 
537 | `cfw:source-data example2:`
538 | 
539 | ```el
540 | ;; cfw:source-data period items
541 | (defun sample-data2 (b e)
542 |   '(
543 |     ((1  8 2011) . ("item1"))
544 |      (periods
545 |       ((1 8 2011) (1 9 2011) "period item")
546 |       ((1 11 2011) (1 12 2011) "next item"))
547 |     ))
548 | ;; (A . (B C) ) is equivalent to (A B C)
549 | 
550 | (cfw:open-calendar-buffer
551 |   :date (cfw:date 1 1 2011)
552 |   :contents-sources
553 |    (list 
554 |      (make-cfw:source
555 |       :name "test2" :data 'sample-data2)))
556 | ```
557 | 
558 | ### How to embed the calfw component in the other applications?
559 | 
560 | In this section, the details of calfw components would be explained so as for users to extend calfw in themselves.
561 | 
562 | Calfw is built on the MVC architecture, using simple structure objects and modules employed by naming rules.
563 | 
564 | #### Calfw component
565 | 
566 | Calfw has three destination components to display the calendar.
567 | 
568 | - Independent buffer
569 | - Region in the other buffer
570 | - Text output
571 | 
572 | ##### Buffer
573 | 
574 | The 'buffer' destination displays the calendar view as ordinary Emacs applications do.
575 | 
576 | The function `cfw:open-calendar-buffer` makes a new calendar buffer (calfw buffer) and displays it by `switch-to-buffer`. The major mode of the calfw buffer is `cfw:calendar-mode` and the keymap `cfw:calendar-mode-map` is bound.
577 | 
578 | This destination is easy to use for applications and users, because the buffer is usual application boundary and users know how to use buffers.
579 | 
580 | ##### Region
581 | 
582 | The 'Region' destination embeds the calendar view in the buffer which is managed by the other applications. This destination can give the other applications a nice calendar view. See the howm embedding for example.
583 | 
584 | Let's try a demonstration. Evaluate this code in your scratch buffer.
585 | 
586 | Region destination example:
587 | 
588 | ```el
589 | ;; Evaluate this code in the scratch buffer
590 | (require 'calfw)
591 | (cfw:create-calendar-component-region :height 10)
592 | ```
593 | 
594 | Then, the calendar view will be embedded in the scratch buffer like the following screenshot. You can navigate the calfw view in the buffer. Undoing for the some times, you can remove the calfw view.
595 | 
596 | ![calfw in the scratch buffer](https://cacoo.com/diagrams/P6baUrxEQj4NYheV-B9649.png?width=600)
597 | 
598 | Because this destination never interacts anything out of the region and has its own key-binds as a text property, users can easily embed a calendar view in the other applications.
599 | 
600 | ##### Text
601 | 
602 | The 'text' destination generates just a text which represent calfw view. The function `cfw:get-calendar-text` returns the text.
603 | 
604 | ##### Destination and View
605 | 
606 | Three destinations are explained as mentioned above. Although they have different appearance, the application can operate the calfw component in the same way.
607 | 
608 | Let us call them 'destination', it is the abstraction of UI components.
609 | 
610 | The similar word 'view' means in which form the calfw displays the contents, for example, monthly form, two-weeks and weekly one and etc.
611 | 
612 | #### Calfw objects
613 | 
614 | ##### Overview
615 | 
616 | The calfw consists of four objects:
617 | 
618 | - `cfw:component` that gathers following objects up.
619 | - `cfw:model` that manages calendar contents.
620 | - `cfw:source` that defines schedule items.
621 | - `cfw:dest` that is abstraction of destinations.
622 | 
623 | The relations between the objects are displayed as UML class diagram ([Diagrammed by astah](http://astah.change-vision.com/ja/:title=Astah)).
624 | 
625 | ![Overview for calfw objects](https://cacoo.com/diagrams/P6baUrxEQj4NYheV-EC8C6.png)
626 | 
627 | `cfw:component` acts as Controller of MVC. It connects model object and destination one, and controls all events. It also gives the interface of calfw objects for the other applications.
628 | 
629 | `cfw:model` and `cfw:source` act as Model of MVC. They manage the schedule contents and calendar logic.
630 | 
631 | `cfw:dest` acts as View of MVC. It abstracts the common interface from UI destinations.
632 | 
633 | ##### cfw:component
634 | 
635 | The object `cfw:component` controls calfw objects and events.
636 | 
637 | The object has following information:
638 | 
639 | - References to `cfw:dest` object and `cfw:model` one.
640 | - Selected date on the calfw component.
641 | - View style.
642 | - Hooks
643 |   - `update-hooks`
644 |   - `selection-change-hooks`
645 |   - `click-hooks`.
646 | 
647 | The object has following operations:
648 | 
649 | - Getting object references to `cfw:dest`, `cfw:model`, belonging buffer and so on.
650 | - Getting and setting the selected date (`get-selected-date` / `set-selected-date`).
651 | - Getting and setting the view style (`get-view` / `set-view`).
652 |   - The view style is a symbol, such as `month`, `two-weeks`, `week` and `day`.
653 | - Resizing and refreshing the view (`resize` / `update`).
654 | - Managing hooks (`add-xxx-hook` / `remove-xxx-hook`)
655 | 
656 | After construction of the calfw component, the destination object can not be changed.
657 | 
658 | The views are defined as a function and dispatched by the function `cfw:cp-dispatch-view-impl`.
659 | 
660 | The instance of the calfw component is stored at following places:
661 | 
662 | - `buffer` destination: the buffer-local variable `cfw:component`
663 | - `region` destination: the text property `cfw:component`
664 | - `text` destination: N/A
665 | 
666 | Calling the utility function `cfw:cp-get-component`, one can obtain the calfw instance at the appropriate places. The stateless functions, such as simple event handler functions, can use this function to get the instance.
667 | 
668 | The applications those have the state-full operations, however, should hold their own calfw instance for the safety object reference.
669 | 
670 | ##### cfw:model
671 | 
672 | The object `cfw:model` gathers schedule sources and gives a common interface for view functions to access the contents.
673 | 
674 | The object has following information:
675 | 
676 | - contents source objects (`contents-sources`)
677 | - annotation source objects (`annotation-sources`)
678 | - sorting function (`sorter`)
679 | 
680 | The model object has no information of views and destinations, just manages schedule contents.
681 | 
682 | The holidays are retrieved from the global function `calendar-holiday-list` of calendar.el.
683 | 
684 | The schedule contents are modified through the model object after the component construction.
685 | 
686 | (In the current implementation, the model object is build by alist. Then, view functions adds some data as view model. I think it is not good solution, so the implementation may be modified in future.)
687 | 
688 | ##### cfw:dest
689 | 
690 | The object `cfw:dest` abstracts rendering destinations and gives a common interface of rendering operation to view functions.
691 | 
692 | The object has following information:
693 | 
694 | - destination buffer object (`buffer`)
695 | - region functions (`min-func`, `max-func`)
696 | - reference size (`width`, `height`)
697 | - clearing function (`clear-func`)
698 | - advice functions (`before-update-func`, `after-update-func`)
699 | - overlay data (`select-ol`, `today-ol`)
700 | 
701 | In the current implementation, `cfw:dest` has three forms, buffer, region and text, mentioned above. Actually, the region destination is what I want. One buffer can have some destination objects, because all data (including local-variables and keymaps) are packed in the `cfw:dest` object.
702 | 
703 | #### Application design
704 | 
705 | In this section, I would describe a simple guide line of application design using calfw.
706 | 
707 | One can use calfw as an application UI (like calfw-howm) or dialog UI for selecting a date (like calendar.el). The user application can choose the destination style: buffer or region. Switching between them is very easy.
708 | 
709 | The data presentation can be achieved by defining `cfw:source` object. It may be straightforward.
710 | 
711 | The input events by the user can be caught by hooks in the `cfw:component`. Then, the selected date is obtained by the function `cfw:cursor-to-nearest-date` or `cfw:cursor-to-date`. The current implementation, calfw can not treat a range on the calendar.
712 | 
713 | Generally, any events can be caught by the custom keymap which is given by the named argument `:custom-map` with component construction. Furthermore, because calfw reserves the text properties (face, keymap and so on) on the text that is returned by `cfw:source` objects, one can control event handling at each characters.
714 | 
715 | Once the model is modified, update function of the `cfw:component` object should be called to refresh the view.
716 | 
717 | The summary diagram is here.
718 | 
719 | ![Summary of application design](https://cacoo.com/diagrams/P6baUrxEQj4NYheV-465D4.png)
720 | 
721 | See the calfw-howm.el code for more details.
722 | 
723 | ## History
724 | 
725 | - 2015/09/24 ver 1.5 : Fixed bugs and added some customize variables.
726 | - 2015/02/27 ver 1.4 : Introduced cfw:event struct, improved some functions, fixed some bugs.
727 | - 2011/10/10 ver 1.3 : Improved visual and navigation: multi-line, moving items in a day, diary mode and so on.
728 | - 2011/07/20 ver 1.2 : Merged many patches and improved many and bug fixed.
729 | - 2011/07/05 ver 1.0 : Refactored the whole implementation and design. Improved UI and views.
730 | - 2011/01/07 ver 0.2.1 : Supporting org-agenda schedules.
731 | - 2011/01/07 ver 0.1 : First release. Supporting howm and iCal schedules.
732 | 
733 | --------------------------------------------------
734 | SAKURAI, Masashi
735 | m.sakurai atmark kiwanami.net
736 | 
737 | Time-stamp: <2015-09-24 11:47:57 sakurai>
738 | 


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