1 ;;; schedule.el --- calculate schedule completion time
3 ;; Copyright (C) 1999, 2000 John Wiegley.
5 ;; Author: John Wiegley <johnw@gnu.org>
6 ;; Created: 20 Jan 1999
9 ;; X-URL: http://www.newartisans.com/johnw/Emacs/schedule.el
11 ;; The program is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published
13 ;; by the Free Software Foundation; either version 2, or (at your
14 ;; option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; This file provides a single Lisp function:
29 ;; `schedule-completion-time'. It takes an Emacs time object and a
30 ;; quantity of seconds. It returns an Emacs time object that
31 ;; represents when the given number of seconds will be completed,
32 ;; assuming that work can only be done during work hours.
34 ;; The available work hours are affected by several factors:
36 ;; 1. If timeclock.el is being used, the amount of time left
37 ;; in the current workday (timeclock-workday-remaining)
38 ;; 2. The amount of time in each workday (schedule-workday)
39 ;; 3. The definition of a work week (schedule-week)
40 ;; 4. Any holidays defined in the Emacs calendar
41 ;; 5. Any appointments in the Emacs diary
43 ;; Taking all of the "block out" periods into account,
44 ;; `schedule-completion-time' will compute when the given number of
45 ;; seconds will be done, based on your current definitions of time
48 ;; As an example, here's a function which, given a list of durations
49 ;; in seconds, will return a list of completion times starting from
50 ;; the current moment:
52 ;; (defun compute-completion-times (&rest durations)
53 ;; "Compute completion times for a list of DURATIONS (in seconds)."
54 ;; (let ((now (current-time)))
58 ;; (setq now (schedule-completion-time now dura))))
61 ;; To call this function:
63 ;; (compute-completion-times 3600 7200 3600)
71 (defconst schedule-version
"2.0"
72 "This version of schedule.")
74 (defgroup schedule nil
75 "A mode to help keep track of project schedules."
80 (defvar schedule-week-length nil
81 "The length of the week in seconds.
82 This variable is computed whenever `schedule-week' is set.")
84 (defcustom schedule-workday
(if (boundp 'timeclock-workday
)
87 "*The length of a work period.
88 If the `timeclock' package is being used, it will be consulted in
89 order to determine a proper default value."
93 (defun schedule-duration-to-seconds (code)
94 "Convert the given CODE into a integer quantity of seconds."
95 (if (string-match "\\([0-9.]+\\)\\([smhdw]\\)" code
)
96 (let ((amount (string-to-number (match-string 1 code
)))
97 (kind (match-string 2 code
)))
98 (cond ((equal kind
"s")
105 (* amount schedule-workday
))
107 (* amount schedule-week-length
))
109 (error "Invalid duration code"))))
110 (error "Invalid duration code")))
112 (defvar schedule-computed-week nil
113 "The meaning of `schedule-week', converted into numeric form.")
115 (defun schedule-calculate-week ()
116 "Convert `schedule-week' into `schedule-computed-week'."
118 schedule-week-length
0
119 schedule-computed-week
124 (let ((start (car day
)))
125 (if (functionp start
)
126 (setq start
(funcall start
)))
127 (if (string-match "^\\([0-9]+\\):\\([0-9]+\\)\\([ap]\\)m?$" start
)
128 (let ((hour (string-to-number (match-string 1 start
)))
129 (min (string-to-number (match-string 2 start
)))
130 (ampm (match-string 3 start
)))
131 (if (and (= hour
12) (string= ampm
"a"))
133 (if (and (< hour
12) (string= ampm
"p"))
134 (setq hour
(+ hour
12)))
136 (if (functionp (cadr day
))
138 (schedule-duration-to-seconds (cadr day
)))))
139 (setq schedule-week-length
140 (+ schedule-week-length length
))
141 (list hour min length
)))
143 (symbol-value 'schedule-week
)))) ; to quiet byte compiler
145 (defcustom schedule-week
153 "*A description of what your regular week looks like.
154 The list should be seven elements long, the first entry being for
155 Sunday. Each entry is either nil, or a list of the form (TIME-IN
156 DURATION). TIME-IN should be a string of the form \"11:30a\", or a
157 function returning such a string; DURATION should be a duration
158 string, such as \"8h\", or a function returning a quantity of
160 :set
(lambda (symbol value
)
161 (setq schedule-week value
)
162 (schedule-calculate-week)
164 :type
'(repeat (choice (const :tag
"No work" nil
)
166 (choice (string :tag
"Time in")
168 (choice (string :tag
"Duration")
172 (defcustom schedule-diary-period nil
173 "*How many days at a time we should look through the diary.
174 If you have lots of repeating appointments, things may go faster if
175 you decrease this number. If this variable is set to nil, the diary
177 :set
(lambda (symbol value
)
179 (require 'diary-lib
))
180 (setq schedule-diary-period value
))
181 :type
'(choice (integer :tag
"Quantum of days to examine")
182 (const :tag
"Don't consult diary" nil
))
185 ;;; Internal Variables:
187 (defvar schedule-day-remainder nil
188 "The number of seconds remaining today.
189 Used in calculations only.")
191 (defvar schedule-diary-entries nil
192 "A list of diary entries in a period.")
194 (defvar schedule-diary-entries-begin nil
195 "The time of the beginning of `schedule-diary-entries'.")
197 (defvar schedule-holiday-list nil
198 "A list of dates on which holidays will fall.")
200 (defvar schedule-initialized nil
201 "Non-nil if the scheduling code has been initialized.")
206 (defun schedule-completion-time (then count
)
207 "Advance THEN by COUNT seconds, skipping the weekends and holidays.
208 THEN must not already be in a holiday or non-worktime. Make sure that
209 `schedule-align-now' is called at least once before this function ever
211 (unless schedule-initialized
212 (schedule-initialize))
213 ;; determine how much time is left in the current day
214 (if (and (featurep 'timeclock
)
215 (timeclock-currently-in-p)
216 (> (timeclock-workday-remaining) 0))
217 (setq schedule-day-remainder
(timeclock-workday-remaining))
218 (setq then
(schedule-align-now then
)
219 schedule-day-remainder
220 (cdr (schedule-nearest-workday then
))))
221 ;; now calculate when the timeframe will actually end
223 (if (< count schedule-day-remainder
)
224 (setq then
(schedule-time-add-seconds then count
)
225 schedule-day-remainder
226 (- schedule-day-remainder
229 (setq count
(- count schedule-day-remainder
)
230 then
(schedule-align-now (schedule-advance-day then
))
231 schedule-day-remainder
232 (cdr (schedule-nearest-workday then
)))))
235 ;;; Internal Functions:
237 (defun schedule-initialize ()
238 "Initialize the scheduling computation code."
239 ;; initialize the cached diary entry lists
240 (setq schedule-diary-entries nil
241 schedule-diary-entries-begin nil
)
243 ;; if someone changes these values outside the customize buffer,
244 ;; they will have to reload this module.
245 (unless schedule-computed-week
246 (schedule-calculate-week))
248 ;; determine the holidays that will apply
249 (setq schedule-holiday-list nil
)
250 (let ((h calendar-holidays
))
252 (if (eq (caar h
) 'holiday-fixed
)
253 (setq schedule-holiday-list
254 (cons (list (nth 1 (car h
))
256 schedule-holiday-list
)))
259 (setq schedule-initialized t
))
261 (defsubst schedule-time-add-seconds
(time seconds
)
262 "To TIME, add SECONDS. Return result as a time value."
263 (let* ((secint (truncate seconds
))
264 (hi (/ secint
65536))
265 (lo (% secint
65536))
266 (calc (+ (cadr time
) lo
)))
268 (list (+ (car time
) hi
) calc
)
269 (list (+ (car time
) (1+ hi
)) (% calc
65536)))))
271 (defsubst schedule-advance-day
(then &optional count
)
272 "Given a time THEN, advance it by COUNT days."
273 (schedule-time-add-seconds then
(* 86400 (or count
1))))
275 (defsubst schedule-time-to-seconds
(time)
276 "Convert TIME to a floating point number."
277 (+ (* (car time
) 65536.0)
279 (/ (or (car (cdr (cdr time
))) 0) 1000000.0)))
281 (defsubst schedule-seconds-to-time
(seconds)
282 "Convert SECONDS (a floating point number) to an Emacs time structure."
283 (list (floor seconds
65536)
284 (floor (mod seconds
65536))
285 (floor (* (- seconds
(ffloor seconds
)) 1000000))))
287 (defsubst schedule-time-diff
(t1 t2
)
288 "Return the difference in seconds between T1 and T2."
289 (- (schedule-time-to-seconds t1
)
290 (schedule-time-to-seconds t2
)))
292 (defsubst schedule-time-less-p
(t1 t2
)
293 "Say whether time T1 is less than time T2."
294 (or (< (car t1
) (car t2
))
295 (and (= (car t1
) (car t2
))
296 (< (nth 1 t1
) (nth 1 t2
)))))
298 (defsubst schedule-time-date
(then)
299 "Return the DATE part of THEN, in calendar friendly format."
300 (let* ((elems (decode-time then
)))
305 (defun schedule-seconds-to-duration (seconds)
306 "Convert SECONDS to a compact time string."
308 (cond ((< seconds
60)
309 (format "%ds" seconds
))
311 (format "%.1fm" (/ (float seconds
) 60.0)))
312 ((< seconds schedule-workday
)
313 (format "%.1fh" (/ (float seconds
) 3600.0)))
314 ((< seconds schedule-week-length
)
315 (format "%.1fd" (/ (float seconds
) schedule-workday
)))
318 (/ (float seconds
) schedule-week-length
))))))
319 (if (string-match "\\.0\\([mhdw]\\)" string
)
320 (replace-match "\\1" t nil string
)
323 (defun schedule-day-begin (then)
324 "Given a time THEN, return its beginning time and length.
325 `schedule-week' is consulted to determine what the typical begin time
326 and length are for a given day of the week. The return value is a
327 cons cell, with the car being a time value, and the cdr the number of
328 seconds during that day."
329 (let* ((elems (decode-time then
))
331 (today (nth dow schedule-computed-week
)))
334 (cons (apply 'encode-time
0 (cadr today
) (car today
)
338 ;; This is from "cal-desk-calendar.el". It should be part of Emacs.
339 (defun schedule-diary-entry-times (s)
340 "List of times at beginning of string S in military-style integers.
341 For example, returns 1325 for 1:25pm. Returns -9999 if no time is
342 recognized. The recognized forms are XXXX or X:XX or XX:XX (military
343 time), XXam or XXpm, and XX:XXam or XX:XXpm. If a range is given, the
344 list contains two elements which will be the start and end of the
345 range. If only one time is given, both elements of the list will
346 contain the time given."
348 ;; Hour and minute range XX:XX-XX:XX[ap]m
350 "^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
353 (+ (* 100 (%
(string-to-int
354 (substring s
(match-beginning 1) (match-end 1)))
356 (string-to-int (substring s
(match-beginning 2) (match-end 2)))
357 (if (string-equal "a"
358 (substring s
(match-beginning 5) (match-end 5)))
360 (+ (* 100 (%
(string-to-int
361 (substring s
(match-beginning 3) (match-end 3)))
363 (string-to-int (substring s
(match-beginning 4) (match-end 4)))
364 (if (string-equal "a"
365 (substring s
(match-beginning 5) (match-end 5)))
367 (substring s
(+ 2 (match-end 5)))))
369 ;; Military time range
371 "^[ ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\|[^ap]\\)"
374 (+ (* 100 (string-to-int
375 (substring s
(match-beginning 1) (match-end 1))))
376 (string-to-int (substring s
(match-beginning 2) (match-end 2))))
377 (+ (* 100 (string-to-int
378 (substring s
(match-beginning 3) (match-end 3))))
379 (string-to-int (substring s
(match-beginning 4) (match-end 4))))
380 (substring s
(1+ (match-end 4)))))
382 ;; Hour range HH[ap]m-HH[ap]m
384 "^[ ]*\\([0-9]?[0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s
)
386 (+ (* 100 (%
(string-to-int
387 (substring s
(match-beginning 1) (match-end 1)))
389 (if (string-equal "a"
390 (substring s
(match-beginning 2) (match-end 2)))
392 (+ (* 100 (%
(string-to-int
393 (substring s
(match-beginning 3) (match-end 3)))
395 (if (string-equal "a"
396 (substring s
(match-beginning 4) (match-end 4)))
398 (substring s
(+ 2 (match-end 4)))))
400 ;; Hour range HH-HH[ap]m
402 "^[ ]*\\([0-9]?[0-9]\\)-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s
)
404 (+ (* 100 (%
(string-to-int
405 (substring s
(match-beginning 1) (match-end 1)))
407 (if (string-equal "a"
408 (substring s
(match-beginning 3) (match-end 3)))
410 (+ (* 100 (%
(string-to-int
411 (substring s
(match-beginning 2) (match-end 2)))
413 (if (string-equal "a"
414 (substring s
(match-beginning 3) (match-end 3)))
416 (substring s
(+ 2 (match-end 3)))))
418 ;; Hour and minute range XX:XX[ap]m-XX:XX[ap]m
420 "^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
423 (+ (* 100 (%
(string-to-int
424 (substring s
(match-beginning 1) (match-end 1)))
426 (string-to-int (substring s
(match-beginning 2) (match-end 2)))
427 (if (string-equal "a"
428 (substring s
(match-beginning 3) (match-end 3)))
430 (+ (* 100 (%
(string-to-int
431 (substring s
(match-beginning 4) (match-end 4)))
433 (string-to-int (substring s
(match-beginning 5) (match-end 5)))
434 (if (string-equal "a"
435 (substring s
(match-beginning 6) (match-end 6)))
437 (substring s
(+ 2 (match-end 6)))))
441 "^[ ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s
)
442 (let ((time (+ (* 100 (string-to-int
443 (substring s
(match-beginning 1)
445 (string-to-int (substring s
(match-beginning 2)
447 (list time time
(substring s
(1+ (match-end 2))))))
449 ;; Hour only XXam or XXpm
451 "^[ ]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s
)
452 (let ((time (+ (* 100 (%
(string-to-int
453 (substring s
(match-beginning 1) (match-end 1)))
456 "a" (substring s
(match-beginning 2) (match-end 2)))
458 (list time time
(substring s
(+ 2 (match-end 2))))))
460 ;; Hour and minute XX:XXam or XX:XXpm
462 "^[ ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s
)
463 (let ((time (+ (* 100 (%
(string-to-int
464 (substring s
(match-beginning 1)
467 (string-to-int (substring s
(match-beginning 2)
470 "a" (substring s
(match-beginning 3) (match-end 3)))
472 (list time time
(substring s
(+ 2 (match-end 3))))))
474 ;; Sunrise/sunset produced by %%(diary-sunrise-sunset)
476 "^[ ]*Sunrise \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Za-z0-9+-]*), sunset \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Za-z0-9+-]*)\\(.*\\)" s
)
478 (+ (* 100 (%
(string-to-int
479 (substring s
(match-beginning 1) (match-end 1)))
481 (string-to-int (substring s
(match-beginning 2) (match-end 2)))
482 (if (string-equal "a"
483 (substring s
(match-beginning 3) (match-end 3)))
486 (+ (* 100 (%
(string-to-int
487 (substring s
(match-beginning 4) (match-end 4)))
489 (string-to-int (substring s
(match-beginning 5) (match-end 5)))
490 (if (string-equal "a"
491 (substring s
(match-beginning 6) (match-end 6)))
493 (list sunrise-time sunrise-time
495 (substring s
(match-beginning 1) (match-end 2)) "am"
496 (substring s
(1+ (match-end 6)))
497 (substring s
(match-beginning 7) (match-end 7)))
498 sunset-time sunset-time
500 (substring s
(match-beginning 4) (match-end 5)) "pm"
501 (substring s
(1+ (match-end 6)))
502 (substring s
(match-beginning 7) (match-end 7))))))
504 ;; Lunar phase produced by %%(diary-phases-of-moon)
506 "^[ ]*\\(New\\|First Quarter\\|Full\\|Last Quarter\\) Moon \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s
)
508 (+ (* 100 (%
(string-to-int
509 (substring s
(match-beginning 2) (match-end 2)))
511 (string-to-int (substring s
(match-beginning 3) (match-end 3)))
513 "a" (substring s
(match-beginning 4) (match-end 4)))
517 ;; Equinox/Solstice produced by %%(diary-equinoxes-solstices)
519 "^[ ]*\\(Vernal Equinox\\|Summer Solstice\\|Autumnal Equinox\\|Winter Solstice\\) \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s
)
521 (+ (* 100 (%
(string-to-int
522 (substring s
(match-beginning 2) (match-end 2)))
524 (string-to-int (substring s
(match-beginning 3) (match-end 3)))
526 "a" (substring s
(match-beginning 4) (match-end 4)))
531 (t (list -
9999 -
9999 s
))))
533 (defun schedule-convert-diary-time (date diary-time
)
534 "Convert the given DATE and DIARY-TIME into a time value.
535 DIARY-TIME is an integer of the form HHMM, as returned by
536 `schedule-diary-entry-times'."
537 (let ((minutes (* (+ (* (/ diary-time
100) 60)
538 (% diary-time
100)) 60)))
539 (encode-time 0 (% minutes
60) (truncate (/ minutes
60))
540 (cadr date
) (car date
) (nth 2 date
) nil
)))
542 (defun schedule-get-diary-entries (then)
543 "Find if there are any diary entries occurring THEN (a time value).
544 Return the amount of time they are scheduled to consume."
545 (let ((then-date (schedule-time-date then
))
546 (day-length (schedule-day-begin then
))
547 (diff (and schedule-diary-entries-begin
549 (/ (schedule-time-diff
550 then schedule-diary-entries-begin
) 86400)))))
551 (if (or (not schedule-diary-entries
)
552 (> diff schedule-diary-period
))
553 (let ((display-hook diary-display-hook
))
555 (save-window-excursion
556 (setq diary-display-hook nil
557 schedule-diary-entries
558 (list-diary-entries then-date
559 schedule-diary-period
)
560 schedule-diary-entries-begin then
))
561 (setq diary-display-hook display-hook
))))
562 (let ((entry schedule-diary-entries
)
565 (let ((date (caar entry
)))
566 (if (equal date then-date
)
567 (let* ((times (schedule-diary-entry-times
569 (first (schedule-convert-diary-time
570 (cadr (car entry
)) (car times
)))
571 (last (schedule-convert-diary-time
572 (cadr (car entry
)) (cadr times
))))
573 (if (and (schedule-time-less-p (car day-length
)
575 (schedule-time-less-p
576 last
(schedule-time-add-seconds
577 (car day-length
) (cdr day-length
))))
579 (+ length
(- (schedule-time-diff last first
))))))))
580 (setq entry
(cdr entry
)))
583 (defun schedule-nearest-workday (then)
584 "Given a time THEN, find the nearest workday."
586 (while (and (> max
0)
587 (setq entry
(schedule-day-begin then
))
588 (or (not entry
) (= (cdr entry
) 0)))
589 (setq then
(schedule-advance-day then
)
592 (error "There are is no work time defined during the week"))
593 (and schedule-diary-period
594 (setcdr entry
(- (cdr entry
)
595 (schedule-get-diary-entries then
))))
598 (defun schedule-nearest-true-workday (then)
599 "Given a time THEN, find the nearest real workday (not a holiday)."
600 (let ((max 365) entry
)
601 (while (and (> max
0)
602 (setq entry
(schedule-nearest-workday then
))
603 ;; jww (1999-04-23): this will need to be updated to
604 ;; handle floating holidays
605 (let* ((date (schedule-time-date (car entry
)))
606 (mon-day (list (car date
) (cadr date
))))
607 (member mon-day schedule-holiday-list
)))
608 (setq then
(car entry
)
609 then
(schedule-advance-day then
)
612 (error "There is no time available for at least a year"))
615 (defun schedule-align-now (then)
616 "Given a time THEN, move it ahead to the next valid moment."
617 (let ((day (schedule-nearest-true-workday then
)))
618 (if (schedule-time-less-p then
(car day
))
620 (if (> (- (schedule-time-diff then
(car day
)))
622 (car (schedule-nearest-true-workday
623 (schedule-advance-day then
)))
628 ;;; schedule.el ends here