contrib/schedule.el

   1 ;;; schedule.el --- calculate schedule completion time
   2
   3 ;; Copyright (C) 1999, 2000 John Wiegley.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Created: 20 Jan 1999
   7 ;; Version: 2.0
   8 ;; Keywords: calendar
   9 ;; X-URL: http://www.newartisans.com/johnw/Emacs/schedule.el
  10
  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.
  15
  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.
  20
  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.
  25
  26 ;;; Commentary:
  27
  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.
  33 ;;
  34 ;; The available work hours are affected by several factors:
  35 ;;
  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
  42 ;;
  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
  46 ;; available.
  47 ;;
  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:
  51 ;;
  52 ;;   (defun compute-completion-times (&rest durations)
  53 ;;     "Compute completion times for a list of DURATIONS (in seconds)."
  54 ;;     (let ((now (current-time)))
  55 ;;       (mapcar
  56 ;;        (function
  57 ;;         (lambda (dura)
  58 ;;           (setq now (schedule-completion-time now dura))))
  59 ;;        durations)))
  60 ;;
  61 ;; To call this function:
  62 ;;
  63 ;;    (compute-completion-times 3600 7200 3600)
  64
  65 ;;; Code:
  66
  67 (require 'calendar)
  68 (require 'diary-lib)
  69 (require 'holidays)
  70
  71 (defconst schedule-version "2.0"
  72   "This version of schedule.")
  73
  74 (defgroup schedule nil
  75   "A mode to help keep track of project schedules."
  76   :group 'tasks)
  77
  78 ;;; User Variables:
  79
  80 (defvar schedule-week-length nil
  81   "The length of the week in seconds.
  82 This variable is computed whenever `schedule-week' is set.")
  83
  84 (defcustom schedule-workday (if (boundp 'timeclock-workday)
  85                                 timeclock-workday
  86                               (* 8 60 60))
  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."
  90   :type 'integer
  91   :group 'schedule)
  92
  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")
  99                amount)
 100               ((equal kind "m")
 101                (* amount 60))
 102               ((equal kind "h")
 103                (* amount 3600))
 104               ((equal kind "d")
 105                (* amount schedule-workday))
 106               ((equal kind "w")
 107                (* amount schedule-week-length))
 108               (t
 109                (error "Invalid duration code"))))
 110     (error "Invalid duration code")))
 111
 112 (defvar schedule-computed-week nil
 113   "The meaning of `schedule-week', converted into numeric form.")
 114
 115 (defun schedule-calculate-week ()
 116   "Convert `schedule-week' into `schedule-computed-week'."
 117   (setq
 118    schedule-week-length 0
 119    schedule-computed-week
 120    (mapcar
 121     (function
 122      (lambda (day)
 123        (when day
 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"))
 132                      (setq hour 0))
 133                  (if (and (< hour 12) (string= ampm "p"))
 134                      (setq hour (+ hour 12)))
 135                  (let ((length
 136                         (if (functionp (cadr day))
 137                             (funcall (cadr day))
 138                           (schedule-duration-to-seconds (cadr day)))))
 139                    (setq schedule-week-length
 140                          (+ schedule-week-length length))
 141                    (list hour min length)))
 142              nil)))))
 143     (symbol-value 'schedule-week))))    ; to quiet byte compiler
 144
 145 (defcustom schedule-week
 146   '(nil
 147     ("9:00a" "8h")
 148     ("9:00a" "8h")
 149     ("9:00a" "8h")
 150     ("9:00a" "8h")
 151     ("9:00a" "8h")
 152     nil)
 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
 159 seconds."
 160   :set (lambda (symbol value)
 161          (setq schedule-week value)
 162          (schedule-calculate-week)
 163          schedule-week)
 164   :type '(repeat (choice (const :tag "No work" nil)
 165                          (list :tag "Workday"
 166                                (choice (string :tag "Time in")
 167                                        function)
 168                                (choice (string :tag "Duration")
 169                                        function))))
 170   :group 'schedule)
 171
 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
 176 won't be consulted."
 177   :set (lambda (symbol value)
 178          (if 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))
 183   :group 'schedule)
 184
 185 ;;; Internal Variables:
 186
 187 (defvar schedule-day-remainder nil
 188   "The number of seconds remaining today.
 189 Used in calculations only.")
 190
 191 (defvar schedule-diary-entries nil
 192   "A list of diary entries in a period.")
 193
 194 (defvar schedule-diary-entries-begin nil
 195   "The time of the beginning of `schedule-diary-entries'.")
 196
 197 (defvar schedule-holiday-list nil
 198   "A list of dates on which holidays will fall.")
 199
 200 (defvar schedule-initialized nil
 201   "Non-nil if the scheduling code has been initialized.")
 202
 203 ;;; User Functions:
 204
 205 ;;;###autoload
 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
 210 gets called."
 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
 222   (while (> count 0)
 223     (if (< count schedule-day-remainder)
 224         (setq then (schedule-time-add-seconds then count)
 225               schedule-day-remainder
 226               (- schedule-day-remainder
 227                  count)
 228               count 0)
 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)))))
 233   then)
 234
 235 ;;; Internal Functions:
 236
 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)
 242
 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))
 247
 248   ;; determine the holidays that will apply
 249   (setq schedule-holiday-list nil)
 250   (let ((h calendar-holidays))
 251     (while h
 252       (if (eq (caar h) 'holiday-fixed)
 253           (setq schedule-holiday-list
 254                 (cons (list (nth 1 (car h))
 255                             (nth 2 (car h)))
 256                       schedule-holiday-list)))
 257       (setq h (cdr h))))
 258
 259   (setq schedule-initialized t))
 260
 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)))
 267     (if (< calc 65536)
 268         (list (+ (car time) hi) calc)
 269       (list (+ (car time) (1+ hi)) (% calc 65536)))))
 270
 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))))
 274
 275 (defsubst schedule-time-to-seconds (time)
 276   "Convert TIME to a floating point number."
 277   (+ (* (car time) 65536.0)
 278      (cadr time)
 279      (/ (or (car (cdr (cdr time))) 0) 1000000.0)))
 280
 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))))
 286
 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)))
 291
 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)))))
 297
 298 (defsubst schedule-time-date (then)
 299   "Return the DATE part of THEN, in calendar friendly format."
 300   (let* ((elems (decode-time then)))
 301     (list (nth 4 elems)
 302           (nth 3 elems)
 303           (nth 5 elems))))
 304
 305 (defun schedule-seconds-to-duration (seconds)
 306   "Convert SECONDS to a compact time string."
 307   (let ((string
 308          (cond ((< seconds 60)
 309                 (format "%ds" seconds))
 310                ((< seconds 3600)
 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)))
 316                (t
 317                 (format "%.1fw"
 318                         (/ (float seconds) schedule-week-length))))))
 319     (if (string-match "\\.0\\([mhdw]\\)" string)
 320         (replace-match "\\1" t nil string)
 321       string)))
 322
 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))
 330          (dow (nth 6 elems))
 331          (today (nth dow schedule-computed-week)))
 332     (if (not today)
 333         (cons then 0)
 334       (cons (apply 'encode-time 0 (cadr today) (car today)
 335                    (nthcdr 3 elems))
 336             (nth 2 today)))))
 337
 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."
 347   (cond
 348    ;; Hour and minute range XX:XX-XX:XX[ap]m
 349    ((string-match
 350      "^[        ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
 351      s)
 352     (list
 353      (+ (* 100 (% (string-to-int
 354                    (substring s (match-beginning 1) (match-end 1)))
 355                   12))
 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)))
 359             0 1200))
 360      (+ (* 100 (% (string-to-int
 361                    (substring s (match-beginning 3) (match-end 3)))
 362                   12))
 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)))
 366             0 1200))
 367      (substring s (+ 2 (match-end 5)))))
 368
 369    ;; Military time range
 370    ((string-match
 371      "^[        ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\|[^ap]\\)"
 372      s)
 373     (list
 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)))))
 381
 382    ;; Hour range HH[ap]m-HH[ap]m
 383    ((string-match
 384      "^[        ]*\\([0-9]?[0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 385     (list
 386      (+ (* 100 (% (string-to-int
 387                    (substring s (match-beginning 1) (match-end 1)))
 388                   12))
 389         (if (string-equal "a"
 390                           (substring s (match-beginning 2) (match-end 2)))
 391             0 1200))
 392      (+ (* 100 (% (string-to-int
 393                    (substring s (match-beginning 3) (match-end 3)))
 394                   12))
 395         (if (string-equal "a"
 396                           (substring s (match-beginning 4) (match-end 4)))
 397             0 1200))
 398      (substring s (+ 2 (match-end 4)))))
 399
 400    ;; Hour range HH-HH[ap]m
 401    ((string-match
 402      "^[        ]*\\([0-9]?[0-9]\\)-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 403     (list
 404      (+ (* 100 (% (string-to-int
 405                    (substring s (match-beginning 1) (match-end 1)))
 406                   12))
 407         (if (string-equal "a"
 408                           (substring s (match-beginning 3) (match-end 3)))
 409             0 1200))
 410      (+ (* 100 (% (string-to-int
 411                    (substring s (match-beginning 2) (match-end 2)))
 412                   12))
 413         (if (string-equal "a"
 414                           (substring s (match-beginning 3) (match-end 3)))
 415             0 1200))
 416      (substring s (+ 2 (match-end 3)))))
 417
 418    ;; Hour and minute range XX:XX[ap]m-XX:XX[ap]m
 419    ((string-match
 420      "^[        ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
 421      s)
 422     (list
 423      (+ (* 100 (% (string-to-int
 424                    (substring s (match-beginning 1) (match-end 1)))
 425                   12))
 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)))
 429             0 1200))
 430      (+ (* 100 (% (string-to-int
 431                    (substring s (match-beginning 4) (match-end 4)))
 432                   12))
 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)))
 436             0 1200))
 437      (substring s (+ 2 (match-end 6)))))
 438
 439    ;; Military time
 440    ((string-match
 441      "^[        ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
 442     (let ((time (+ (* 100 (string-to-int
 443                            (substring s (match-beginning 1)
 444                                       (match-end 1))))
 445                    (string-to-int (substring s (match-beginning 2)
 446                                              (match-end 2))))))
 447       (list time time (substring s (1+ (match-end 2))))))
 448
 449    ;; Hour only XXam or XXpm
 450    ((string-match
 451      "^[        ]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 452     (let ((time (+ (* 100 (% (string-to-int
 453                               (substring s (match-beginning 1) (match-end 1)))
 454                              12))
 455                    (if (string-equal
 456                         "a" (substring s (match-beginning 2) (match-end 2)))
 457                        0 1200))))
 458       (list time time (substring s (+ 2 (match-end 2))))))
 459
 460    ;; Hour and minute XX:XXam or XX:XXpm
 461    ((string-match
 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)
 465                                          (match-end 1)))
 466                              12))
 467                    (string-to-int (substring s (match-beginning 2)
 468                                              (match-end 2)))
 469                    (if (string-equal
 470                         "a" (substring s (match-beginning 3) (match-end 3)))
 471                        0 1200))))
 472       (list time time (substring s (+ 2 (match-end 3))))))
 473
 474    ;; Sunrise/sunset produced by %%(diary-sunrise-sunset)
 475    ((string-match
 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)
 477     (let ((sunrise-time
 478            (+ (* 100 (% (string-to-int
 479                          (substring s (match-beginning 1) (match-end 1)))
 480                         12))
 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)))
 484                   0 1200)))
 485           (sunset-time
 486            (+ (* 100 (% (string-to-int
 487                          (substring s (match-beginning 4) (match-end 4)))
 488                         12))
 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)))
 492                   0 1200))))
 493       (list sunrise-time sunrise-time
 494             (concat "Sunrise "
 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
 499             (concat "Sunset "
 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))))))
 503
 504    ;; Lunar phase produced by %%(diary-phases-of-moon)
 505    ((string-match
 506      "^[        ]*\\(New\\|First Quarter\\|Full\\|Last Quarter\\) Moon \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s)
 507     (let ((time
 508            (+ (* 100 (% (string-to-int
 509                          (substring s (match-beginning 2) (match-end 2)))
 510                         12))
 511               (string-to-int (substring s (match-beginning 3) (match-end 3)))
 512               (if (string-equal
 513                    "a" (substring s (match-beginning 4) (match-end 4)))
 514                   0 1200))))
 515       (list time time s)))
 516
 517    ;; Equinox/Solstice produced by %%(diary-equinoxes-solstices)
 518    ((string-match
 519      "^[        ]*\\(Vernal Equinox\\|Summer Solstice\\|Autumnal Equinox\\|Winter Solstice\\) \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s)
 520     (let ((time
 521            (+ (* 100 (% (string-to-int
 522                          (substring s (match-beginning 2) (match-end 2)))
 523                         12))
 524               (string-to-int (substring s (match-beginning 3) (match-end 3)))
 525               (if (string-equal
 526                    "a" (substring s (match-beginning 4) (match-end 4)))
 527                   0 1200))))
 528       (list time time s)))
 529
 530    ;; Unrecognizable
 531    (t (list -9999 -9999 s))))
 532
 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)))
 541
 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
 548                    (truncate
 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))
 554           (unwind-protect
 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)
 563           (length 0))
 564       (while entry
 565         (let ((date (caar entry)))
 566           (if (equal date then-date)
 567               (let* ((times (schedule-diary-entry-times
 568                              (cadr (car entry))))
 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)
 574                                                first)
 575                          (schedule-time-less-p
 576                           last (schedule-time-add-seconds
 577                                 (car day-length) (cdr day-length))))
 578                     (setq length
 579                           (+ length (- (schedule-time-diff last first))))))))
 580         (setq entry (cdr entry)))
 581       length)))
 582
 583 (defun schedule-nearest-workday (then)
 584   "Given a time THEN, find the nearest workday."
 585   (let ((max 8) entry)
 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)
 590             max (1- max)))
 591     (if (= max 0)
 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))))
 596     entry))
 597
 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)
 610             max (1- max)))
 611     (if (= max 0)
 612         (error "There is no time available for at least a year"))
 613     entry))
 614
 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))
 619         (car day)
 620       (if (> (- (schedule-time-diff then (car day)))
 621              (cdr day))
 622           (car (schedule-nearest-true-workday
 623                 (schedule-advance-day then)))
 624         then))))
 625
 626 (provide 'schedule)
 627
 628 ;;; schedule.el ends here