contrib/schedule.el

   1 ;;; schedule.el --- calculate schedule completion time
   2
   3 ;; Copyright (C) 1999, 2000, 2008 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 ;; This version of schedule.el is part of Planner.  It is not part of
  12 ;; GNU Emacs.
  13
  14 ;; Planner is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; Planner is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with Planner; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This file provides a single Lisp function:
  32 ;; `schedule-completion-time'.  It takes an Emacs time object and a
  33 ;; quantity of seconds.  It returns an Emacs time object that
  34 ;; represents when the given number of seconds will be completed,
  35 ;; assuming that work can only be done during work hours.
  36 ;;
  37 ;; The available work hours are affected by several factors:
  38 ;;
  39 ;;   1. If timeclock.el is being used, the amount of time left
  40 ;;      in the current workday (timeclock-workday-remaining)
  41 ;;   2. The amount of time in each workday (schedule-workday)
  42 ;;   3. The definition of a work week (schedule-week)
  43 ;;   4. Any holidays defined in the Emacs calendar
  44 ;;   5. Any appointments in the Emacs diary
  45 ;;
  46 ;; Taking all of the "block out" periods into account,
  47 ;; `schedule-completion-time' will compute when the given number of
  48 ;; seconds will be done, based on your current definitions of time
  49 ;; available.
  50 ;;
  51 ;; As an example, here's a function which, given a list of durations
  52 ;; in seconds, will return a list of completion times starting from
  53 ;; the current moment:
  54 ;;
  55 ;;   (defun compute-completion-times (&rest durations)
  56 ;;     "Compute completion times for a list of DURATIONS (in seconds)."
  57 ;;     (let ((now (current-time)))
  58 ;;       (mapcar
  59 ;;        (function
  60 ;;         (lambda (dura)
  61 ;;           (setq now (schedule-completion-time now dura))))
  62 ;;        durations)))
  63 ;;
  64 ;; To call this function:
  65 ;;
  66 ;;    (compute-completion-times 3600 7200 3600)
  67
  68 ;;; Code:
  69
  70 (require 'calendar)
  71 (require 'diary-lib)
  72 (require 'holidays)
  73
  74 (defconst schedule-version "2.0"
  75   "This version of schedule.")
  76
  77 (defgroup schedule nil
  78   "A mode to help keep track of project schedules."
  79   :group 'tasks)
  80
  81 ;;; User Variables:
  82
  83 (defvar schedule-week-length nil
  84   "The length of the week in seconds.
  85 This variable is computed whenever `schedule-week' is set.")
  86
  87 (defcustom schedule-workday (if (boundp 'timeclock-workday)
  88                                 timeclock-workday
  89                               (* 8 60 60))
  90   "*The length of a work period.
  91 If the `timeclock' package is being used, it will be consulted in
  92 order to determine a proper default value."
  93   :type 'integer
  94   :group 'schedule)
  95
  96 (defun schedule-duration-to-seconds (code)
  97   "Convert the given CODE into a integer quantity of seconds."
  98   (if (string-match "\\([0-9.]+\\)\\([smhdw]\\)" code)
  99       (let ((amount (string-to-number (match-string 1 code)))
 100             (kind (match-string 2 code)))
 101         (cond ((equal kind "s")
 102                amount)
 103               ((equal kind "m")
 104                (* amount 60))
 105               ((equal kind "h")
 106                (* amount 3600))
 107               ((equal kind "d")
 108                (* amount schedule-workday))
 109               ((equal kind "w")
 110                (* amount schedule-week-length))
 111               (t
 112                (error "Invalid duration code"))))
 113     (error "Invalid duration code")))
 114
 115 (defvar schedule-computed-week nil
 116   "The meaning of `schedule-week', converted into numeric form.")
 117
 118 (defun schedule-calculate-week ()
 119   "Convert `schedule-week' into `schedule-computed-week'."
 120   (setq
 121    schedule-week-length 0
 122    schedule-computed-week
 123    (mapcar
 124     (function
 125      (lambda (day)
 126        (when day
 127          (let ((start (car day)))
 128            (if (functionp start)
 129                (setq start (funcall start)))
 130            (if (string-match "^\\([0-9]+\\):\\([0-9]+\\)\\([ap]\\)m?$" start)
 131                (let ((hour (string-to-number (match-string 1 start)))
 132                      (min (string-to-number (match-string 2 start)))
 133                      (ampm (match-string 3 start)))
 134                  (if (and (= hour 12) (string= ampm "a"))
 135                      (setq hour 0))
 136                  (if (and (< hour 12) (string= ampm "p"))
 137                      (setq hour (+ hour 12)))
 138                  (let ((length
 139                         (if (functionp (cadr day))
 140                             (funcall (cadr day))
 141                           (schedule-duration-to-seconds (cadr day)))))
 142                    (setq schedule-week-length
 143                          (+ schedule-week-length length))
 144                    (list hour min length)))
 145              nil)))))
 146     (symbol-value 'schedule-week))))    ; to quiet byte compiler
 147
 148 (defcustom schedule-week
 149   '(nil
 150     ("9:00a" "8h")
 151     ("9:00a" "8h")
 152     ("9:00a" "8h")
 153     ("9:00a" "8h")
 154     ("9:00a" "8h")
 155     nil)
 156   "*A description of what your regular week looks like.
 157 The list should be seven elements long, the first entry being for
 158 Sunday.  Each entry is either nil, or a list of the form (TIME-IN
 159 DURATION).  TIME-IN should be a string of the form \"11:30a\", or a
 160 function returning such a string; DURATION should be a duration
 161 string, such as \"8h\", or a function returning a quantity of
 162 seconds."
 163   :set (lambda (symbol value)
 164          (setq schedule-week value)
 165          (schedule-calculate-week)
 166          schedule-week)
 167   :type '(repeat (choice (const :tag "No work" nil)
 168                          (list :tag "Workday"
 169                                (choice (string :tag "Time in")
 170                                        function)
 171                                (choice (string :tag "Duration")
 172                                        function))))
 173   :group 'schedule)
 174
 175 (defcustom schedule-diary-period nil
 176   "*How many days at a time we should look through the diary.
 177 If you have lots of repeating appointments, things may go faster if
 178 you decrease this number.  If this variable is set to nil, the diary
 179 won't be consulted."
 180   :set (lambda (symbol value)
 181          (if value
 182              (require 'diary-lib))
 183          (setq schedule-diary-period value))
 184   :type '(choice (integer :tag "Quantum of days to examine")
 185                  (const :tag "Don't consult diary" nil))
 186   :group 'schedule)
 187
 188 ;;; Internal Variables:
 189
 190 (defvar schedule-day-remainder nil
 191   "The number of seconds remaining today.
 192 Used in calculations only.")
 193
 194 (defvar schedule-diary-entries nil
 195   "A list of diary entries in a period.")
 196
 197 (defvar schedule-diary-entries-begin nil
 198   "The time of the beginning of `schedule-diary-entries'.")
 199
 200 (defvar schedule-holiday-list nil
 201   "A list of dates on which holidays will fall.")
 202
 203 (defvar schedule-initialized nil
 204   "Non-nil if the scheduling code has been initialized.")
 205
 206 ;;; User Functions:
 207
 208 ;;;###autoload
 209 (defun schedule-completion-time (then count)
 210   "Advance THEN by COUNT seconds, skipping the weekends and holidays.
 211 THEN must not already be in a holiday or non-worktime.  Make sure that
 212 `schedule-align-now' is called at least once before this function ever
 213 gets called."
 214   (unless schedule-initialized
 215     (schedule-initialize))
 216   ;; determine how much time is left in the current day
 217   (if (and (featurep 'timeclock)
 218            (timeclock-currently-in-p)
 219            (> (timeclock-workday-remaining) 0))
 220       (setq schedule-day-remainder (timeclock-workday-remaining))
 221     (setq then (schedule-align-now then)
 222           schedule-day-remainder
 223           (cdr (schedule-nearest-workday then))))
 224   ;; now calculate when the timeframe will actually end
 225   (while (> count 0)
 226     (if (< count schedule-day-remainder)
 227         (setq then (schedule-time-add-seconds then count)
 228               schedule-day-remainder
 229               (- schedule-day-remainder
 230                  count)
 231               count 0)
 232       (setq count (- count schedule-day-remainder)
 233             then (schedule-align-now (schedule-advance-day then))
 234             schedule-day-remainder
 235             (cdr (schedule-nearest-workday then)))))
 236   then)
 237
 238 ;;; Internal Functions:
 239
 240 (defun schedule-initialize ()
 241   "Initialize the scheduling computation code."
 242   ;; initialize the cached diary entry lists
 243   (setq schedule-diary-entries nil
 244         schedule-diary-entries-begin nil)
 245
 246   ;; if someone changes these values outside the customize buffer,
 247   ;; they will have to reload this module.
 248   (unless schedule-computed-week
 249     (schedule-calculate-week))
 250
 251   ;; determine the holidays that will apply
 252   (setq schedule-holiday-list nil)
 253   (let ((h calendar-holidays))
 254     (while h
 255       (if (eq (caar h) 'holiday-fixed)
 256           (setq schedule-holiday-list
 257                 (cons (list (nth 1 (car h))
 258                             (nth 2 (car h)))
 259                       schedule-holiday-list)))
 260       (setq h (cdr h))))
 261
 262   (setq schedule-initialized t))
 263
 264 (defsubst schedule-time-add-seconds (time seconds)
 265   "To TIME, add SECONDS.  Return result as a time value."
 266   (let* ((secint (truncate seconds))
 267          (hi (/ secint 65536))
 268          (lo (% secint 65536))
 269          (calc (+ (cadr time) lo)))
 270     (if (< calc 65536)
 271         (list (+ (car time) hi) calc)
 272       (list (+ (car time) (1+ hi)) (% calc 65536)))))
 273
 274 (defsubst schedule-advance-day (then &optional count)
 275   "Given a time THEN, advance it by COUNT days."
 276   (schedule-time-add-seconds then (* 86400 (or count 1))))
 277
 278 (defsubst schedule-time-to-seconds (time)
 279   "Convert TIME to a floating point number."
 280   (+ (* (car time) 65536.0)
 281      (cadr time)
 282      (/ (or (car (cdr (cdr time))) 0) 1000000.0)))
 283
 284 (defsubst schedule-seconds-to-time (seconds)
 285   "Convert SECONDS (a floating point number) to an Emacs time structure."
 286   (list (floor seconds 65536)
 287         (floor (mod seconds 65536))
 288         (floor (* (- seconds (ffloor seconds)) 1000000))))
 289
 290 (defsubst schedule-time-diff (t1 t2)
 291   "Return the difference in seconds between T1 and T2."
 292   (- (schedule-time-to-seconds t1)
 293      (schedule-time-to-seconds t2)))
 294
 295 (defsubst schedule-time-less-p (t1 t2)
 296   "Say whether time T1 is less than time T2."
 297   (or (< (car t1) (car t2))
 298       (and (= (car t1) (car t2))
 299            (< (nth 1 t1) (nth 1 t2)))))
 300
 301 (defsubst schedule-time-date (then)
 302   "Return the DATE part of THEN, in calendar friendly format."
 303   (let* ((elems (decode-time then)))
 304     (list (nth 4 elems)
 305           (nth 3 elems)
 306           (nth 5 elems))))
 307
 308 (defun schedule-seconds-to-duration (seconds)
 309   "Convert SECONDS to a compact time string."
 310   (let ((string
 311          (cond ((< seconds 60)
 312                 (format "%ds" seconds))
 313                ((< seconds 3600)
 314                 (format "%.1fm" (/ (float seconds) 60.0)))
 315                ((< seconds schedule-workday)
 316                 (format "%.1fh" (/ (float seconds) 3600.0)))
 317                ((< seconds schedule-week-length)
 318                 (format "%.1fd" (/ (float seconds) schedule-workday)))
 319                (t
 320                 (format "%.1fw"
 321                         (/ (float seconds) schedule-week-length))))))
 322     (if (string-match "\\.0\\([mhdw]\\)" string)
 323         (replace-match "\\1" t nil string)
 324       string)))
 325
 326 (defun schedule-day-begin (then)
 327   "Given a time THEN, return its beginning time and length.
 328 `schedule-week' is consulted to determine what the typical begin time
 329 and length are for a given day of the week.  The return value is a
 330 cons cell, with the car being a time value, and the cdr the number of
 331 seconds during that day."
 332   (let* ((elems (decode-time then))
 333          (dow (nth 6 elems))
 334          (today (nth dow schedule-computed-week)))
 335     (if (not today)
 336         (cons then 0)
 337       (cons (apply 'encode-time 0 (cadr today) (car today)
 338                    (nthcdr 3 elems))
 339             (nth 2 today)))))
 340
 341 ;; This is from "cal-desk-calendar.el".  It should be part of Emacs.
 342 (defun schedule-diary-entry-times (s)
 343   "List of times at beginning of string S in military-style integers.
 344 For example, returns 1325 for 1:25pm.  Returns -9999 if no time is
 345 recognized.  The recognized forms are XXXX or X:XX or XX:XX (military
 346 time), XXam or XXpm, and XX:XXam or XX:XXpm.  If a range is given, the
 347 list contains two elements which will be the start and end of the
 348 range.  If only one time is given, both elements of the list will
 349 contain the time given."
 350   (cond
 351    ;; Hour and minute range XX:XX-XX:XX[ap]m
 352    ((string-match
 353      "^[        ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
 354      s)
 355     (list
 356      (+ (* 100 (% (string-to-int
 357                    (substring s (match-beginning 1) (match-end 1)))
 358                   12))
 359         (string-to-int (substring s (match-beginning 2) (match-end 2)))
 360         (if (string-equal "a"
 361                           (substring s (match-beginning 5) (match-end 5)))
 362             0 1200))
 363      (+ (* 100 (% (string-to-int
 364                    (substring s (match-beginning 3) (match-end 3)))
 365                   12))
 366         (string-to-int (substring s (match-beginning 4) (match-end 4)))
 367         (if (string-equal "a"
 368                           (substring s (match-beginning 5) (match-end 5)))
 369             0 1200))
 370      (substring s (+ 2 (match-end 5)))))
 371
 372    ;; Military time range
 373    ((string-match
 374      "^[        ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)-\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\|[^ap]\\)"
 375      s)
 376     (list
 377      (+ (* 100 (string-to-int
 378                 (substring s (match-beginning 1) (match-end 1))))
 379         (string-to-int (substring s (match-beginning 2) (match-end 2))))
 380      (+ (* 100 (string-to-int
 381                 (substring s (match-beginning 3) (match-end 3))))
 382         (string-to-int (substring s (match-beginning 4) (match-end 4))))
 383      (substring s (1+ (match-end 4)))))
 384
 385    ;; Hour range HH[ap]m-HH[ap]m
 386    ((string-match
 387      "^[        ]*\\([0-9]?[0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 388     (list
 389      (+ (* 100 (% (string-to-int
 390                    (substring s (match-beginning 1) (match-end 1)))
 391                   12))
 392         (if (string-equal "a"
 393                           (substring s (match-beginning 2) (match-end 2)))
 394             0 1200))
 395      (+ (* 100 (% (string-to-int
 396                    (substring s (match-beginning 3) (match-end 3)))
 397                   12))
 398         (if (string-equal "a"
 399                           (substring s (match-beginning 4) (match-end 4)))
 400             0 1200))
 401      (substring s (+ 2 (match-end 4)))))
 402
 403    ;; Hour range HH-HH[ap]m
 404    ((string-match
 405      "^[        ]*\\([0-9]?[0-9]\\)-\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 406     (list
 407      (+ (* 100 (% (string-to-int
 408                    (substring s (match-beginning 1) (match-end 1)))
 409                   12))
 410         (if (string-equal "a"
 411                           (substring s (match-beginning 3) (match-end 3)))
 412             0 1200))
 413      (+ (* 100 (% (string-to-int
 414                    (substring s (match-beginning 2) (match-end 2)))
 415                   12))
 416         (if (string-equal "a"
 417                           (substring s (match-beginning 3) (match-end 3)))
 418             0 1200))
 419      (substring s (+ 2 (match-end 3)))))
 420
 421    ;; Hour and minute range XX:XX[ap]m-XX:XX[ap]m
 422    ((string-match
 423      "^[        ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m-\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>"
 424      s)
 425     (list
 426      (+ (* 100 (% (string-to-int
 427                    (substring s (match-beginning 1) (match-end 1)))
 428                   12))
 429         (string-to-int (substring s (match-beginning 2) (match-end 2)))
 430         (if (string-equal "a"
 431                           (substring s (match-beginning 3) (match-end 3)))
 432             0 1200))
 433      (+ (* 100 (% (string-to-int
 434                    (substring s (match-beginning 4) (match-end 4)))
 435                   12))
 436         (string-to-int (substring s (match-beginning 5) (match-end 5)))
 437         (if (string-equal "a"
 438                           (substring s (match-beginning 6) (match-end 6)))
 439             0 1200))
 440      (substring s (+ 2 (match-end 6)))))
 441
 442    ;; Military time
 443    ((string-match
 444      "^[        ]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
 445     (let ((time (+ (* 100 (string-to-int
 446                            (substring s (match-beginning 1)
 447                                       (match-end 1))))
 448                    (string-to-int (substring s (match-beginning 2)
 449                                              (match-end 2))))))
 450       (list time time (substring s (1+ (match-end 2))))))
 451
 452    ;; Hour only XXam or XXpm
 453    ((string-match
 454      "^[        ]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 455     (let ((time (+ (* 100 (% (string-to-int
 456                               (substring s (match-beginning 1) (match-end 1)))
 457                              12))
 458                    (if (string-equal
 459                         "a" (substring s (match-beginning 2) (match-end 2)))
 460                        0 1200))))
 461       (list time time (substring s (+ 2 (match-end 2))))))
 462
 463    ;; Hour and minute XX:XXam or XX:XXpm
 464    ((string-match
 465      "^[        ]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
 466     (let ((time (+ (* 100 (% (string-to-int
 467                               (substring s (match-beginning 1)
 468                                          (match-end 1)))
 469                              12))
 470                    (string-to-int (substring s (match-beginning 2)
 471                                              (match-end 2)))
 472                    (if (string-equal
 473                         "a" (substring s (match-beginning 3) (match-end 3)))
 474                        0 1200))))
 475       (list time time (substring s (+ 2 (match-end 3))))))
 476
 477    ;; Sunrise/sunset produced by %%(diary-sunrise-sunset)
 478    ((string-match
 479      "^[        ]*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)
 480     (let ((sunrise-time
 481            (+ (* 100 (% (string-to-int
 482                          (substring s (match-beginning 1) (match-end 1)))
 483                         12))
 484               (string-to-int (substring s (match-beginning 2) (match-end 2)))
 485               (if (string-equal "a"
 486                                 (substring s (match-beginning 3) (match-end 3)))
 487                   0 1200)))
 488           (sunset-time
 489            (+ (* 100 (% (string-to-int
 490                          (substring s (match-beginning 4) (match-end 4)))
 491                         12))
 492               (string-to-int (substring s (match-beginning 5) (match-end 5)))
 493               (if (string-equal "a"
 494                                 (substring s (match-beginning 6) (match-end 6)))
 495                   0 1200))))
 496       (list sunrise-time sunrise-time
 497             (concat "Sunrise "
 498                     (substring s (match-beginning 1) (match-end 2)) "am"
 499                     (substring s (1+ (match-end 6)))
 500                     (substring s (match-beginning 7) (match-end 7)))
 501             sunset-time sunset-time
 502             (concat "Sunset "
 503                     (substring s (match-beginning 4) (match-end 5)) "pm"
 504                     (substring s (1+ (match-end 6)))
 505                     (substring s (match-beginning 7) (match-end 7))))))
 506
 507    ;; Lunar phase produced by %%(diary-phases-of-moon)
 508    ((string-match
 509      "^[        ]*\\(New\\|First Quarter\\|Full\\|Last Quarter\\) Moon \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s)
 510     (let ((time
 511            (+ (* 100 (% (string-to-int
 512                          (substring s (match-beginning 2) (match-end 2)))
 513                         12))
 514               (string-to-int (substring s (match-beginning 3) (match-end 3)))
 515               (if (string-equal
 516                    "a" (substring s (match-beginning 4) (match-end 4)))
 517                   0 1200))))
 518       (list time time s)))
 519
 520    ;; Equinox/Solstice produced by %%(diary-equinoxes-solstices)
 521    ((string-match
 522      "^[        ]*\\(Vernal Equinox\\|Summer Solstice\\|Autumnal Equinox\\|Winter Solstice\\) \\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\> ([A-Z0-9+-]*)" s)
 523     (let ((time
 524            (+ (* 100 (% (string-to-int
 525                          (substring s (match-beginning 2) (match-end 2)))
 526                         12))
 527               (string-to-int (substring s (match-beginning 3) (match-end 3)))
 528               (if (string-equal
 529                    "a" (substring s (match-beginning 4) (match-end 4)))
 530                   0 1200))))
 531       (list time time s)))
 532
 533    ;; Unrecognizable
 534    (t (list -9999 -9999 s))))
 535
 536 (defun schedule-convert-diary-time (date diary-time)
 537   "Convert the given DATE and DIARY-TIME into a time value.
 538 DIARY-TIME is an integer of the form HHMM, as returned by
 539 `schedule-diary-entry-times'."
 540   (let ((minutes (* (+ (* (/ diary-time 100) 60)
 541                        (% diary-time 100)) 60)))
 542     (encode-time 0 (% minutes 60) (truncate (/ minutes 60))
 543                  (cadr date) (car date) (nth 2 date) nil)))
 544
 545 (defun schedule-get-diary-entries (then)
 546   "Find if there are any diary entries occurring THEN (a time value).
 547 Return the amount of time they are scheduled to consume."
 548   (let ((then-date (schedule-time-date then))
 549         (day-length (schedule-day-begin then))
 550         (diff (and schedule-diary-entries-begin
 551                    (truncate
 552                     (/ (schedule-time-diff
 553                         then schedule-diary-entries-begin) 86400)))))
 554     (if (or (not schedule-diary-entries)
 555             (> diff schedule-diary-period))
 556         (let ((display-hook diary-display-hook))
 557           (unwind-protect
 558               (save-window-excursion
 559                 (setq diary-display-hook nil
 560                       schedule-diary-entries
 561                       (list-diary-entries then-date
 562                                           schedule-diary-period)
 563                       schedule-diary-entries-begin then))
 564             (setq diary-display-hook display-hook))))
 565     (let ((entry schedule-diary-entries)
 566           (length 0))
 567       (while entry
 568         (let ((date (caar entry)))
 569           (if (equal date then-date)
 570               (let* ((times (schedule-diary-entry-times
 571                              (cadr (car entry))))
 572                      (first (schedule-convert-diary-time
 573                              (cadr (car entry)) (car times)))
 574                      (last (schedule-convert-diary-time
 575                             (cadr (car entry)) (cadr times))))
 576                 (if (and (schedule-time-less-p (car day-length)
 577                                                first)
 578                          (schedule-time-less-p
 579                           last (schedule-time-add-seconds
 580                                 (car day-length) (cdr day-length))))
 581                     (setq length
 582                           (+ length (- (schedule-time-diff last first))))))))
 583         (setq entry (cdr entry)))
 584       length)))
 585
 586 (defun schedule-nearest-workday (then)
 587   "Given a time THEN, find the nearest workday."
 588   (let ((max 8) entry)
 589     (while (and (> max 0)
 590                 (setq entry (schedule-day-begin then))
 591                 (or (not entry) (= (cdr entry) 0)))
 592       (setq then (schedule-advance-day then)
 593             max (1- max)))
 594     (if (= max 0)
 595         (error "There are is no work time defined during the week"))
 596     (and schedule-diary-period
 597          (setcdr entry (- (cdr entry)
 598                           (schedule-get-diary-entries then))))
 599     entry))
 600
 601 (defun schedule-nearest-true-workday (then)
 602   "Given a time THEN, find the nearest real workday (not a holiday)."
 603   (let ((max 365) entry)
 604     (while (and (> max 0)
 605                 (setq entry (schedule-nearest-workday then))
 606                 ;; jww (1999-04-23): this will need to be updated to
 607                 ;; handle floating holidays
 608                 (let* ((date (schedule-time-date (car entry)))
 609                        (mon-day (list (car date) (cadr date))))
 610                   (member mon-day schedule-holiday-list)))
 611       (setq then (car entry)
 612             then (schedule-advance-day then)
 613             max (1- max)))
 614     (if (= max 0)
 615         (error "There is no time available for at least a year"))
 616     entry))
 617
 618 (defun schedule-align-now (then)
 619   "Given a time THEN, move it ahead to the next valid moment."
 620   (let ((day (schedule-nearest-true-workday then)))
 621     (if (schedule-time-less-p then (car day))
 622         (car day)
 623       (if (> (- (schedule-time-diff then (car day)))
 624              (cdr day))
 625           (car (schedule-nearest-true-workday
 626                 (schedule-advance-day then)))
 627         then))))
 628
 629 (provide 'schedule)
 630
 631 ;;; schedule.el ends here