| 1 | ;; Calculator for GNU Emacs, part II [calc-forms.el] |
| 2 | ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
| 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. |
| 4 | |
| 5 | ;; This file is part of GNU Emacs. |
| 6 | |
| 7 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 8 | ;; but WITHOUT ANY WARRANTY. No author or distributor |
| 9 | ;; accepts responsibility to anyone for the consequences of using it |
| 10 | ;; or for whether it serves any particular purpose or works at all, |
| 11 | ;; unless he says so in writing. Refer to the GNU Emacs General Public |
| 12 | ;; License for full details. |
| 13 | |
| 14 | ;; Everyone is granted permission to copy, modify and redistribute |
| 15 | ;; GNU Emacs, but only under the conditions described in the |
| 16 | ;; GNU Emacs General Public License. A copy of this license is |
| 17 | ;; supposed to have been given to you along with GNU Emacs so you |
| 18 | ;; can know your rights and responsibilities. It should be in a |
| 19 | ;; file named COPYING. Among other things, the copyright notice |
| 20 | ;; and this notice must be preserved on all copies. |
| 21 | |
| 22 | |
| 23 | |
| 24 | ;; This file is autoloaded from calc-ext.el. |
| 25 | (require 'calc-ext) |
| 26 | |
| 27 | (require 'calc-macs) |
| 28 | |
| 29 | (defun calc-Need-calc-forms () nil) |
| 30 | |
| 31 | |
| 32 | (defun calc-time () |
| 33 | (interactive) |
| 34 | (calc-wrapper |
| 35 | (let ((time (current-time-string))) |
| 36 | (calc-enter-result 0 "time" |
| 37 | (list 'mod |
| 38 | (list 'hms |
| 39 | (string-to-int (substring time 11 13)) |
| 40 | (string-to-int (substring time 14 16)) |
| 41 | (string-to-int (substring time 17 19))) |
| 42 | (list 'hms 24 0 0))))) |
| 43 | ) |
| 44 | |
| 45 | |
| 46 | |
| 47 | |
| 48 | (defun calc-to-hms (arg) |
| 49 | (interactive "P") |
| 50 | (calc-wrapper |
| 51 | (if (calc-is-inverse) |
| 52 | (if (eq calc-angle-mode 'rad) |
| 53 | (calc-unary-op ">rad" 'calcFunc-rad arg) |
| 54 | (calc-unary-op ">deg" 'calcFunc-deg arg)) |
| 55 | (calc-unary-op ">hms" 'calcFunc-hms arg))) |
| 56 | ) |
| 57 | |
| 58 | (defun calc-from-hms (arg) |
| 59 | (interactive "P") |
| 60 | (calc-invert-func) |
| 61 | (calc-to-hms arg) |
| 62 | ) |
| 63 | |
| 64 | |
| 65 | (defun calc-hms-notation (fmt) |
| 66 | (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ") |
| 67 | (calc-wrapper |
| 68 | (if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt) |
| 69 | (progn |
| 70 | (calc-change-mode 'calc-hms-format |
| 71 | (concat "%s" (math-match-substring fmt 1) |
| 72 | (math-match-substring fmt 2) |
| 73 | "%s" (math-match-substring fmt 3) |
| 74 | (math-match-substring fmt 4) |
| 75 | "%s" (math-match-substring fmt 5)) |
| 76 | t) |
| 77 | (setq-default calc-hms-format calc-hms-format)) ; for minibuffer |
| 78 | (error "Bad hours-minutes-seconds format."))) |
| 79 | ) |
| 80 | |
| 81 | (defun calc-date-notation (fmt arg) |
| 82 | (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP") |
| 83 | (calc-wrapper |
| 84 | (if (equal fmt "") |
| 85 | (setq fmt "1")) |
| 86 | (if (string-match "\\` *[0-9] *\\'" fmt) |
| 87 | (setq fmt (nth (string-to-int fmt) calc-standard-date-formats))) |
| 88 | (or (string-match "[a-zA-Z]" fmt) |
| 89 | (error "Bad date format specifier")) |
| 90 | (and arg |
| 91 | (>= (setq arg (prefix-numeric-value arg)) 0) |
| 92 | (<= arg 9) |
| 93 | (setq calc-standard-date-formats |
| 94 | (copy-sequence calc-standard-date-formats)) |
| 95 | (setcar (nthcdr arg calc-standard-date-formats) fmt)) |
| 96 | (let ((case-fold-search nil)) |
| 97 | (and (not (string-match "<.*>" fmt)) |
| 98 | (string-match "\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*[bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'" fmt) |
| 99 | (string-match (concat "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*" |
| 100 | (regexp-quote (math-match-substring fmt 1)) |
| 101 | "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*") fmt) |
| 102 | (setq fmt (concat (substring fmt 0 (match-beginning 0)) |
| 103 | "<" |
| 104 | (substring fmt (match-beginning 0) (match-end 0)) |
| 105 | ">" |
| 106 | (substring fmt (match-end 0)))))) |
| 107 | (let ((lfmt nil) |
| 108 | (fullfmt nil) |
| 109 | (time nil) |
| 110 | pos pos2 sym temp) |
| 111 | (let ((case-fold-search nil)) |
| 112 | (and (setq temp (string-match ":[BS]S" fmt)) |
| 113 | (aset fmt temp ?C))) |
| 114 | (while (setq pos (string-match "[<>a-zA-Z]" fmt)) |
| 115 | (if (> pos 0) |
| 116 | (setq lfmt (cons (substring fmt 0 pos) lfmt))) |
| 117 | (setq pos2 (1+ pos)) |
| 118 | (cond ((= (aref fmt pos) ?\<) |
| 119 | (and time (error "Nested <'s not allowed")) |
| 120 | (and lfmt (setq fullfmt (nconc lfmt fullfmt) |
| 121 | lfmt nil)) |
| 122 | (setq time t)) |
| 123 | ((= (aref fmt pos) ?\>) |
| 124 | (or time (error "Misplaced > in format")) |
| 125 | (and lfmt (setq fullfmt (cons (nreverse lfmt) fullfmt) |
| 126 | lfmt nil)) |
| 127 | (setq time nil)) |
| 128 | (t |
| 129 | (if (string-match "\\`[^a-zA-Z]*[bB][a-zA-Z]" fmt) |
| 130 | (setq pos2 (1+ pos2))) |
| 131 | (while (and (< pos2 (length fmt)) |
| 132 | (= (upcase (aref fmt pos2)) |
| 133 | (upcase (aref fmt (1- pos2))))) |
| 134 | (setq pos2 (1+ pos2))) |
| 135 | (setq sym (intern (substring fmt pos pos2))) |
| 136 | (or (memq sym '(Y YY BY YYY YYYY |
| 137 | aa AA aaa AAA aaaa AAAA |
| 138 | bb BB bbb BBB bbbb BBBB |
| 139 | M MM BM mmm Mmm Mmmm MMM MMMM |
| 140 | D DD BD d ddd bdd |
| 141 | W www Www Wwww WWW WWWW |
| 142 | h hh bh H HH BH |
| 143 | p P pp PP pppp PPPP |
| 144 | m mm bm s ss bss SS BS C |
| 145 | N n J j U b)) |
| 146 | (and (eq sym 'X) (not lfmt) (not fullfmt)) |
| 147 | (error "Bad format code: %s" sym)) |
| 148 | (and (memq sym '(bb BB bbb BBB bbbb BBBB)) |
| 149 | (setq lfmt (cons 'b lfmt))) |
| 150 | (setq lfmt (cons sym lfmt)))) |
| 151 | (setq fmt (substring fmt pos2))) |
| 152 | (or (equal fmt "") |
| 153 | (setq lfmt (cons fmt lfmt))) |
| 154 | (and lfmt (if time |
| 155 | (setq fullfmt (cons (nreverse lfmt) fullfmt)) |
| 156 | (setq fullfmt (nconc lfmt fullfmt)))) |
| 157 | (calc-change-mode 'calc-date-format (nreverse fullfmt) t))) |
| 158 | ) |
| 159 | |
| 160 | |
| 161 | (defun calc-hms-mode () |
| 162 | (interactive) |
| 163 | (calc-wrapper |
| 164 | (calc-change-mode 'calc-angle-mode 'hms) |
| 165 | (message "Angles measured in degrees-minutes-seconds.")) |
| 166 | ) |
| 167 | |
| 168 | |
| 169 | (defun calc-now (arg) |
| 170 | (interactive "P") |
| 171 | (calc-date-zero-args "now" 'calcFunc-now arg) |
| 172 | ) |
| 173 | |
| 174 | (defun calc-date-part (arg) |
| 175 | (interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ") |
| 176 | (if (or (< arg 1) (> arg 9)) |
| 177 | (error "Part code out of range")) |
| 178 | (calc-wrapper |
| 179 | (calc-enter-result 1 |
| 180 | (nth arg '(nil "year" "mnth" "day" "hour" "minu" |
| 181 | "sec" "wday" "yday" "hmst")) |
| 182 | (list (nth arg '(nil calcFunc-year calcFunc-month |
| 183 | calcFunc-day calcFunc-hour |
| 184 | calcFunc-minute calcFunc-second |
| 185 | calcFunc-weekday calcFunc-yearday |
| 186 | calcFunc-time)) |
| 187 | (calc-top-n 1)))) |
| 188 | ) |
| 189 | |
| 190 | (defun calc-date (arg) |
| 191 | (interactive "p") |
| 192 | (if (or (< arg 1) (> arg 6)) |
| 193 | (error "Between one and six arguments are allowed")) |
| 194 | (calc-wrapper |
| 195 | (calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))) |
| 196 | ) |
| 197 | |
| 198 | (defun calc-julian (arg) |
| 199 | (interactive "P") |
| 200 | (calc-date-one-arg "juln" 'calcFunc-julian arg) |
| 201 | ) |
| 202 | |
| 203 | (defun calc-unix-time (arg) |
| 204 | (interactive "P") |
| 205 | (calc-date-one-arg "unix" 'calcFunc-unixtime arg) |
| 206 | ) |
| 207 | |
| 208 | (defun calc-time-zone (arg) |
| 209 | (interactive "P") |
| 210 | (calc-date-zero-args "zone" 'calcFunc-tzone arg) |
| 211 | ) |
| 212 | |
| 213 | (defun calc-convert-time-zones (old &optional new) |
| 214 | (interactive "sFrom time zone: ") |
| 215 | (calc-wrapper |
| 216 | (if (equal old "$") |
| 217 | (calc-enter-result 3 "tzcv" (cons 'calcFunc-tzconv (calc-top-list-n 3))) |
| 218 | (if (equal old "") (setq old "local")) |
| 219 | (or new |
| 220 | (setq new (read-string (concat "From time zone: " old |
| 221 | ", to zone: ")))) |
| 222 | (if (stringp old) (setq old (math-read-expr old))) |
| 223 | (if (eq (car-safe old) 'error) |
| 224 | (error "Error in expression: " (nth 1 old))) |
| 225 | (if (equal new "") (setq new "local")) |
| 226 | (if (stringp new) (setq new (math-read-expr new))) |
| 227 | (if (eq (car-safe new) 'error) |
| 228 | (error "Error in expression: " (nth 1 new))) |
| 229 | (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv |
| 230 | (calc-top-n 1) old new)))) |
| 231 | ) |
| 232 | |
| 233 | (defun calc-new-week (arg) |
| 234 | (interactive "P") |
| 235 | (calc-date-one-arg "nwwk" 'calcFunc-newweek arg) |
| 236 | ) |
| 237 | |
| 238 | (defun calc-new-month (arg) |
| 239 | (interactive "P") |
| 240 | (calc-date-one-arg "nwmn" 'calcFunc-newmonth arg) |
| 241 | ) |
| 242 | |
| 243 | (defun calc-new-year (arg) |
| 244 | (interactive "P") |
| 245 | (calc-date-one-arg "nwyr" 'calcFunc-newyear arg) |
| 246 | ) |
| 247 | |
| 248 | (defun calc-inc-month (arg) |
| 249 | (interactive "p") |
| 250 | (calc-date-one-arg "incm" 'calcFunc-incmonth arg) |
| 251 | ) |
| 252 | |
| 253 | (defun calc-business-days-plus (arg) |
| 254 | (interactive "P") |
| 255 | (calc-wrapper |
| 256 | (calc-binary-op "bus+" 'calcFunc-badd arg)) |
| 257 | ) |
| 258 | |
| 259 | (defun calc-business-days-minus (arg) |
| 260 | (interactive "P") |
| 261 | (calc-wrapper |
| 262 | (calc-binary-op "bus-" 'calcFunc-bsub arg)) |
| 263 | ) |
| 264 | |
| 265 | (defun calc-date-zero-args (prefix func arg) |
| 266 | (calc-wrapper |
| 267 | (if (consp arg) |
| 268 | (calc-enter-result 1 prefix (list func (calc-top-n 1))) |
| 269 | (calc-enter-result 0 prefix (if arg |
| 270 | (list func (prefix-numeric-value arg)) |
| 271 | (list func))))) |
| 272 | ) |
| 273 | |
| 274 | (defun calc-date-one-arg (prefix func arg) |
| 275 | (calc-wrapper |
| 276 | (if (consp arg) |
| 277 | (calc-enter-result 2 prefix (cons func (calc-top-list-n 2))) |
| 278 | (calc-enter-result 1 prefix (if arg |
| 279 | (list func (calc-top-n 1) |
| 280 | (prefix-numeric-value arg)) |
| 281 | (list func (calc-top-n 1)))))) |
| 282 | ) |
| 283 | |
| 284 | |
| 285 | |
| 286 | |
| 287 | |
| 288 | |
| 289 | |
| 290 | |
| 291 | ;;;; Hours-minutes-seconds forms. |
| 292 | |
| 293 | (defun math-normalize-hms (a) |
| 294 | (let ((h (math-normalize (nth 1 a))) |
| 295 | (m (math-normalize (nth 2 a))) |
| 296 | (s (let ((calc-internal-prec (max (- calc-internal-prec 4) 3))) |
| 297 | (math-normalize (nth 3 a))))) |
| 298 | (if (math-negp h) |
| 299 | (progn |
| 300 | (if (math-posp s) |
| 301 | (setq s (math-add s -60) |
| 302 | m (math-add m 1))) |
| 303 | (if (math-posp m) |
| 304 | (setq m (math-add m -60) |
| 305 | h (math-add h 1))) |
| 306 | (if (not (Math-lessp -60 s)) |
| 307 | (setq s (math-add s 60) |
| 308 | m (math-add m -1))) |
| 309 | (if (not (Math-lessp -60 m)) |
| 310 | (setq m (math-add m 60) |
| 311 | h (math-add h -1)))) |
| 312 | (if (math-negp s) |
| 313 | (setq s (math-add s 60) |
| 314 | m (math-add m -1))) |
| 315 | (if (math-negp m) |
| 316 | (setq m (math-add m 60) |
| 317 | h (math-add h -1))) |
| 318 | (if (not (Math-lessp s 60)) |
| 319 | (setq s (math-add s -60) |
| 320 | m (math-add m 1))) |
| 321 | (if (not (Math-lessp m 60)) |
| 322 | (setq m (math-add m -60) |
| 323 | h (math-add h 1)))) |
| 324 | (if (and (eq (car-safe s) 'float) |
| 325 | (<= (+ (math-numdigs (nth 1 s)) (nth 2 s)) |
| 326 | (- 2 calc-internal-prec))) |
| 327 | (setq s 0)) |
| 328 | (list 'hms h m s)) |
| 329 | ) |
| 330 | |
| 331 | ;;; Convert A from ANG or current angular mode to HMS format. |
| 332 | (defun math-to-hms (a &optional ang) ; [X R] [Public] |
| 333 | (cond ((eq (car-safe a) 'hms) a) |
| 334 | ((eq (car-safe a) 'sdev) |
| 335 | (math-make-sdev (math-to-hms (nth 1 a)) |
| 336 | (math-to-hms (nth 2 a)))) |
| 337 | ((not (Math-numberp a)) |
| 338 | (list 'calcFunc-hms a)) |
| 339 | ((math-negp a) |
| 340 | (math-neg (math-to-hms (math-neg a) ang))) |
| 341 | ((eq (or ang calc-angle-mode) 'rad) |
| 342 | (math-to-hms (math-div a (math-pi-over-180)) 'deg)) |
| 343 | ((memq (car-safe a) '(cplx polar)) a) |
| 344 | (t |
| 345 | ;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3))) |
| 346 | ; (math-normalize a))) |
| 347 | (math-normalize |
| 348 | (let* ((b (math-mul a 3600)) |
| 349 | (hm (math-trunc (math-div b 60))) |
| 350 | (hmd (math-idivmod hm 60))) |
| 351 | (list 'hms |
| 352 | (car hmd) |
| 353 | (cdr hmd) |
| 354 | (math-sub b (math-mul hm 60))))))) |
| 355 | ) |
| 356 | (defun calcFunc-hms (h &optional m s) |
| 357 | (or (Math-realp h) (math-reject-arg h 'realp)) |
| 358 | (or m (setq m 0)) |
| 359 | (or (Math-realp m) (math-reject-arg m 'realp)) |
| 360 | (or s (setq s 0)) |
| 361 | (or (Math-realp s) (math-reject-arg s 'realp)) |
| 362 | (if (and (not (Math-lessp m 0)) (Math-lessp m 60) |
| 363 | (not (Math-lessp s 0)) (Math-lessp s 60)) |
| 364 | (math-add (math-to-hms h) |
| 365 | (list 'hms 0 m s)) |
| 366 | (math-to-hms (math-add h |
| 367 | (math-add (math-div (or m 0) 60) |
| 368 | (math-div (or s 0) 3600))) |
| 369 | 'deg)) |
| 370 | ) |
| 371 | |
| 372 | ;;; Convert A from HMS format to ANG or current angular mode. |
| 373 | (defun math-from-hms (a &optional ang) ; [R X] [Public] |
| 374 | (cond ((not (eq (car-safe a) 'hms)) |
| 375 | (if (Math-numberp a) |
| 376 | a |
| 377 | (if (eq (car-safe a) 'sdev) |
| 378 | (math-make-sdev (math-from-hms (nth 1 a) ang) |
| 379 | (math-from-hms (nth 2 a) ang)) |
| 380 | (if (eq (or ang calc-angle-mode) 'rad) |
| 381 | (list 'calcFunc-rad a) |
| 382 | (list 'calcFunc-deg a))))) |
| 383 | ((math-negp a) |
| 384 | (math-neg (math-from-hms (math-neg a) ang))) |
| 385 | ((eq (or ang calc-angle-mode) 'rad) |
| 386 | (math-mul (math-from-hms a 'deg) (math-pi-over-180))) |
| 387 | (t |
| 388 | (math-add (math-div (math-add (math-div (nth 3 a) |
| 389 | '(float 6 1)) |
| 390 | (nth 2 a)) |
| 391 | 60) |
| 392 | (nth 1 a)))) |
| 393 | ) |
| 394 | |
| 395 | |
| 396 | |
| 397 | ;;;; Date forms. |
| 398 | |
| 399 | |
| 400 | ;;; Some of these functions are adapted from Edward Reingold's "calendar.el". |
| 401 | ;;; These versions are rewritten to use arbitrary-size integers. |
| 402 | ;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian |
| 403 | ;;; calendar is used; the first day after 9/2/1752 is 9/14/1752. |
| 404 | |
| 405 | ;;; A numerical date is the number of days since midnight on |
| 406 | ;;; the morning of January 1, 1 A.D. If the date is a non-integer, |
| 407 | ;;; it represents a specific date and time. |
| 408 | ;;; A "dt" is a list of the form, (year month day), corresponding to |
| 409 | ;;; an integer code, or (year month day hour minute second), corresponding |
| 410 | ;;; to a non-integer code. |
| 411 | |
| 412 | (defun math-date-to-dt (value) |
| 413 | (if (eq (car-safe value) 'date) |
| 414 | (setq value (nth 1 value))) |
| 415 | (or (math-realp value) |
| 416 | (math-reject-arg value 'datep)) |
| 417 | (let* ((parts (math-date-parts value)) |
| 418 | (date (car parts)) |
| 419 | (time (nth 1 parts)) |
| 420 | (month 1) |
| 421 | day |
| 422 | (year (math-quotient (math-add date (if (Math-lessp date 711859) |
| 423 | 365 ; for speed, we take |
| 424 | -108)) ; >1950 as a special case |
| 425 | (if (math-negp value) 366 365))) |
| 426 | ; this result may be an overestimate |
| 427 | temp) |
| 428 | (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1))) |
| 429 | (setq year (math-add year -1))) |
| 430 | (if (eq year 0) (setq year -1)) |
| 431 | (setq date (1+ (math-sub date temp))) |
| 432 | (and (eq year 1752) (>= date 247) |
| 433 | (setq date (+ date 11))) |
| 434 | (setq temp (if (math-leap-year-p year) |
| 435 | [1 32 61 92 122 153 183 214 245 275 306 336 999] |
| 436 | [1 32 60 91 121 152 182 213 244 274 305 335 999])) |
| 437 | (while (>= date (aref temp month)) |
| 438 | (setq month (1+ month))) |
| 439 | (setq day (1+ (- date (aref temp (1- month))))) |
| 440 | (if (math-integerp value) |
| 441 | (list year month day) |
| 442 | (list year month day |
| 443 | (/ time 3600) |
| 444 | (% (/ time 60) 60) |
| 445 | (math-add (% time 60) (nth 2 parts))))) |
| 446 | ) |
| 447 | |
| 448 | (defun math-dt-to-date (dt) |
| 449 | (or (integerp (nth 1 dt)) |
| 450 | (math-reject-arg (nth 1 dt) 'fixnump)) |
| 451 | (if (or (< (nth 1 dt) 1) (> (nth 1 dt) 12)) |
| 452 | (math-reject-arg (nth 1 dt) "Month value is out of range")) |
| 453 | (or (integerp (nth 2 dt)) |
| 454 | (math-reject-arg (nth 2 dt) 'fixnump)) |
| 455 | (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31)) |
| 456 | (math-reject-arg (nth 2 dt) "Day value is out of range")) |
| 457 | (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt)))) |
| 458 | (if (nth 3 dt) |
| 459 | (math-add (math-float date) |
| 460 | (math-div (math-add (+ (* (nth 3 dt) 3600) |
| 461 | (* (nth 4 dt) 60)) |
| 462 | (nth 5 dt)) |
| 463 | '(float 864 2))) |
| 464 | date)) |
| 465 | ) |
| 466 | |
| 467 | (defun math-date-parts (value &optional offset) |
| 468 | (let* ((date (math-floor value)) |
| 469 | (time (math-round (math-mul (math-sub value (or offset date)) 86400) |
| 470 | (and (> calc-internal-prec 12) |
| 471 | (- calc-internal-prec 12)))) |
| 472 | (ftime (math-floor time))) |
| 473 | (list date |
| 474 | ftime |
| 475 | (math-sub time ftime))) |
| 476 | ) |
| 477 | |
| 478 | |
| 479 | (defun math-this-year () |
| 480 | (string-to-int (substring (current-time-string) -4)) |
| 481 | ) |
| 482 | |
| 483 | (defun math-leap-year-p (year) |
| 484 | (if (Math-lessp year 1752) |
| 485 | (if (math-negp year) |
| 486 | (= (math-imod (math-neg year) 4) 1) |
| 487 | (= (math-imod year 4) 0)) |
| 488 | (setq year (math-imod year 400)) |
| 489 | (or (and (= (% year 4) 0) (/= (% year 100) 0)) |
| 490 | (= year 0))) |
| 491 | ) |
| 492 | |
| 493 | (defun math-days-in-month (year month) |
| 494 | (if (and (= month 2) (math-leap-year-p year)) |
| 495 | 29 |
| 496 | (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))) |
| 497 | ) |
| 498 | |
| 499 | (defun math-day-number (year month day) |
| 500 | (let ((day-of-year (+ day (* 31 (1- month))))) |
| 501 | (if (> month 2) |
| 502 | (progn |
| 503 | (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) |
| 504 | (if (math-leap-year-p year) |
| 505 | (setq day-of-year (1+ day-of-year))))) |
| 506 | (and (eq year 1752) |
| 507 | (or (> month 9) |
| 508 | (and (= month 9) (>= day 14))) |
| 509 | (setq day-of-year (- day-of-year 11))) |
| 510 | day-of-year) |
| 511 | ) |
| 512 | |
| 513 | (defun math-absolute-from-date (year month day) |
| 514 | (if (eq year 0) (setq year -1)) |
| 515 | (let ((yearm1 (math-sub year 1))) |
| 516 | (math-sub (math-add (math-day-number year month day) |
| 517 | (math-add (math-mul 365 yearm1) |
| 518 | (if (math-posp year) |
| 519 | (math-quotient yearm1 4) |
| 520 | (math-sub 365 |
| 521 | (math-quotient (math-sub 3 year) |
| 522 | 4))))) |
| 523 | (if (or (Math-lessp year 1753) |
| 524 | (and (eq year 1752) (<= month 9))) |
| 525 | 1 |
| 526 | (let ((correction (math-mul (math-quotient yearm1 100) 3))) |
| 527 | (let ((res (math-idivmod correction 4))) |
| 528 | (math-add (if (= (cdr res) 0) |
| 529 | -1 |
| 530 | 0) |
| 531 | (car res))))))) |
| 532 | ) |
| 533 | |
| 534 | |
| 535 | ;;; It is safe to redefine these in your .emacs file to use a different |
| 536 | ;;; language. |
| 537 | |
| 538 | (defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday" |
| 539 | "Thursday" "Friday" "Saturday" )) |
| 540 | (defvar math-short-weekday-names '( "Sun" "Mon" "Tue" "Wed" |
| 541 | "Thu" "Fri" "Sat" )) |
| 542 | |
| 543 | (defvar math-long-month-names '( "January" "February" "March" "April" |
| 544 | "May" "June" "July" "August" |
| 545 | "September" "October" "November" "December" )) |
| 546 | (defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun" |
| 547 | "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" )) |
| 548 | |
| 549 | |
| 550 | (defun math-format-date (date) |
| 551 | (if (eq (car-safe date) 'date) |
| 552 | (setq date (nth 1 date))) |
| 553 | (let ((entry (list date calc-internal-prec calc-date-format))) |
| 554 | (or (cdr (assoc entry math-format-date-cache)) |
| 555 | (let* ((dt nil) |
| 556 | (calc-group-digits nil) |
| 557 | (calc-leading-zeros nil) |
| 558 | (calc-number-radix 10) |
| 559 | year month day weekday hour minute second |
| 560 | (bc-flag nil) |
| 561 | (fmt (apply 'concat (mapcar 'math-format-date-part |
| 562 | calc-date-format)))) |
| 563 | (setq math-format-date-cache (cons (cons entry fmt) |
| 564 | math-format-date-cache)) |
| 565 | (and (setq dt (nthcdr 10 math-format-date-cache)) |
| 566 | (setcdr dt nil)) |
| 567 | fmt))) |
| 568 | ) |
| 569 | (setq math-format-date-cache nil) |
| 570 | |
| 571 | (defun math-format-date-part (x) |
| 572 | (cond ((stringp x) |
| 573 | x) |
| 574 | ((listp x) |
| 575 | (if (math-integerp date) |
| 576 | "" |
| 577 | (apply 'concat (mapcar 'math-format-date-part x)))) |
| 578 | ((eq x 'X) |
| 579 | "") |
| 580 | ((eq x 'N) |
| 581 | (math-format-number date)) |
| 582 | ((eq x 'n) |
| 583 | (math-format-number (math-floor date))) |
| 584 | ((eq x 'J) |
| 585 | (math-format-number (math-add date '(float (bigpos 235 214 17) -1)))) |
| 586 | ((eq x 'j) |
| 587 | (math-format-number (math-add (math-floor date) '(bigpos 424 721 1)))) |
| 588 | ((eq x 'U) |
| 589 | (math-format-number (nth 1 (math-date-parts date 719164)))) |
| 590 | ((progn |
| 591 | (or dt |
| 592 | (progn |
| 593 | (setq dt (math-date-to-dt date) |
| 594 | year (car dt) |
| 595 | month (nth 1 dt) |
| 596 | day (nth 2 dt) |
| 597 | weekday (math-mod (math-add (math-floor date) 6) 7) |
| 598 | hour (nth 3 dt) |
| 599 | minute (nth 4 dt) |
| 600 | second (nth 5 dt)) |
| 601 | (and (memq 'b calc-date-format) |
| 602 | (math-negp year) |
| 603 | (setq year (math-neg year) |
| 604 | bc-flag t)))) |
| 605 | (memq x '(Y YY BY))) |
| 606 | (if (and (integerp year) (> year 1940) (< year 2040)) |
| 607 | (format (cond ((eq x 'YY) "%02d") |
| 608 | ((eq x 'BYY) "%2d") |
| 609 | (t "%d")) |
| 610 | (% year 100)) |
| 611 | (if (and (natnump year) (< year 100)) |
| 612 | (format "+%d" year) |
| 613 | (math-format-number year)))) |
| 614 | ((eq x 'YYY) |
| 615 | (math-format-number year)) |
| 616 | ((eq x 'YYYY) |
| 617 | (if (and (natnump year) (< year 100)) |
| 618 | (format "+%d" year) |
| 619 | (math-format-number year))) |
| 620 | ((eq x 'b) "") |
| 621 | ((eq x 'aa) |
| 622 | (and (not bc-flag) "ad")) |
| 623 | ((eq x 'AA) |
| 624 | (and (not bc-flag) "AD")) |
| 625 | ((eq x 'aaa) |
| 626 | (and (not bc-flag) "ad ")) |
| 627 | ((eq x 'AAA) |
| 628 | (and (not bc-flag) "AD ")) |
| 629 | ((eq x 'aaaa) |
| 630 | (and (not bc-flag) "a.d.")) |
| 631 | ((eq x 'AAAA) |
| 632 | (and (not bc-flag) "A.D.")) |
| 633 | ((eq x 'bb) |
| 634 | (and bc-flag "bc")) |
| 635 | ((eq x 'BB) |
| 636 | (and bc-flag "BC")) |
| 637 | ((eq x 'bbb) |
| 638 | (and bc-flag " bc")) |
| 639 | ((eq x 'BBB) |
| 640 | (and bc-flag " BC")) |
| 641 | ((eq x 'bbbb) |
| 642 | (and bc-flag "b.c.")) |
| 643 | ((eq x 'BBBB) |
| 644 | (and bc-flag "B.C.")) |
| 645 | ((eq x 'M) |
| 646 | (format "%d" month)) |
| 647 | ((eq x 'MM) |
| 648 | (format "%02d" month)) |
| 649 | ((eq x 'BM) |
| 650 | (format "%2d" month)) |
| 651 | ((eq x 'mmm) |
| 652 | (downcase (nth (1- month) math-short-month-names))) |
| 653 | ((eq x 'Mmm) |
| 654 | (nth (1- month) math-short-month-names)) |
| 655 | ((eq x 'MMM) |
| 656 | (upcase (nth (1- month) math-short-month-names))) |
| 657 | ((eq x 'Mmmm) |
| 658 | (nth (1- month) math-long-month-names)) |
| 659 | ((eq x 'MMMM) |
| 660 | (upcase (nth (1- month) math-long-month-names))) |
| 661 | ((eq x 'D) |
| 662 | (format "%d" day)) |
| 663 | ((eq x 'DD) |
| 664 | (format "%02d" day)) |
| 665 | ((eq x 'BD) |
| 666 | (format "%2d" day)) |
| 667 | ((eq x 'W) |
| 668 | (format "%d" weekday)) |
| 669 | ((eq x 'www) |
| 670 | (downcase (nth weekday math-short-weekday-names))) |
| 671 | ((eq x 'Www) |
| 672 | (nth weekday math-short-weekday-names)) |
| 673 | ((eq x 'WWW) |
| 674 | (upcase (nth weekday math-short-weekday-names))) |
| 675 | ((eq x 'Wwww) |
| 676 | (nth weekday math-long-weekday-names)) |
| 677 | ((eq x 'WWWW) |
| 678 | (upcase (nth weekday math-long-weekday-names))) |
| 679 | ((eq x 'd) |
| 680 | (format "%d" (math-day-number year month day))) |
| 681 | ((eq x 'ddd) |
| 682 | (format "%03d" (math-day-number year month day))) |
| 683 | ((eq x 'bdd) |
| 684 | (format "%3d" (math-day-number year month day))) |
| 685 | ((eq x 'h) |
| 686 | (and hour (format "%d" hour))) |
| 687 | ((eq x 'hh) |
| 688 | (and hour (format "%02d" hour))) |
| 689 | ((eq x 'bh) |
| 690 | (and hour (format "%2d" hour))) |
| 691 | ((eq x 'H) |
| 692 | (and hour (format "%d" (1+ (% (+ hour 11) 12))))) |
| 693 | ((eq x 'HH) |
| 694 | (and hour (format "%02d" (1+ (% (+ hour 11) 12))))) |
| 695 | ((eq x 'BH) |
| 696 | (and hour (format "%2d" (1+ (% (+ hour 11) 12))))) |
| 697 | ((eq x 'p) |
| 698 | (and hour (if (< hour 12) "a" "p"))) |
| 699 | ((eq x 'P) |
| 700 | (and hour (if (< hour 12) "A" "P"))) |
| 701 | ((eq x 'pp) |
| 702 | (and hour (if (< hour 12) "am" "pm"))) |
| 703 | ((eq x 'PP) |
| 704 | (and hour (if (< hour 12) "AM" "PM"))) |
| 705 | ((eq x 'pppp) |
| 706 | (and hour (if (< hour 12) "a.m." "p.m."))) |
| 707 | ((eq x 'PPPP) |
| 708 | (and hour (if (< hour 12) "A.M." "P.M."))) |
| 709 | ((eq x 'm) |
| 710 | (and minute (format "%d" minute))) |
| 711 | ((eq x 'mm) |
| 712 | (and minute (format "%02d" minute))) |
| 713 | ((eq x 'bm) |
| 714 | (and minute (format "%2d" minute))) |
| 715 | ((eq x 'C) |
| 716 | (and second (not (math-zerop second)) |
| 717 | ":")) |
| 718 | ((memq x '(s ss bs SS BS)) |
| 719 | (and second |
| 720 | (not (and (memq x '(SS BS)) (math-zerop second))) |
| 721 | (if (integerp second) |
| 722 | (format (cond ((memq x '(ss SS)) "%02d") |
| 723 | ((memq x '(bs BS)) "%2d") |
| 724 | (t "%d")) |
| 725 | second) |
| 726 | (concat (if (Math-lessp second 10) |
| 727 | (cond ((memq x '(ss SS)) "0") |
| 728 | ((memq x '(bs BS)) " ") |
| 729 | (t "")) |
| 730 | "") |
| 731 | (let ((calc-float-format |
| 732 | (list 'fix (min (- 12 calc-internal-prec) |
| 733 | 0)))) |
| 734 | (math-format-number second))))))) |
| 735 | ) |
| 736 | |
| 737 | |
| 738 | (defun math-parse-date (str) |
| 739 | (catch 'syntax |
| 740 | (or (math-parse-standard-date str t) |
| 741 | (math-parse-standard-date str nil) |
| 742 | (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" str) |
| 743 | (list 'date (math-read-number (math-match-substring str 1)))) |
| 744 | (let ((case-fold-search t) |
| 745 | (year nil) (month nil) (day nil) (weekday nil) |
| 746 | (hour nil) (minute nil) (second nil) (bc-flag nil) |
| 747 | (a nil) (b nil) (c nil) (bigyear nil) temp) |
| 748 | |
| 749 | ;; Extract the time, if any. |
| 750 | (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" str) |
| 751 | (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" str)) |
| 752 | (let ((ampm (math-match-substring str 6))) |
| 753 | (setq hour (string-to-int (math-match-substring str 1)) |
| 754 | minute (math-match-substring str 2) |
| 755 | second (math-match-substring str 4) |
| 756 | str (concat (substring str 0 (match-beginning 0)) |
| 757 | (substring str (match-end 0)))) |
| 758 | (if (equal minute "") |
| 759 | (setq minute 0) |
| 760 | (setq minute (string-to-int minute))) |
| 761 | (if (equal second "") |
| 762 | (setq second 0) |
| 763 | (setq second (math-read-number second))) |
| 764 | (if (equal ampm "") |
| 765 | (if (> hour 23) |
| 766 | (throw 'syntax "Hour value out of range")) |
| 767 | (setq ampm (upcase (aref ampm 0))) |
| 768 | (if (memq ampm '(?N ?M)) |
| 769 | (if (and (= hour 12) (= minute 0) (eq second 0)) |
| 770 | (if (eq ampm ?M) (setq hour 0)) |
| 771 | (throw 'syntax |
| 772 | "Time must be 12:00:00 in this context")) |
| 773 | (if (or (= hour 0) (> hour 12)) |
| 774 | (throw 'syntax "Hour value out of range")) |
| 775 | (if (eq (= ampm ?A) (= hour 12)) |
| 776 | (setq hour (% (+ hour 12) 24))))))) |
| 777 | |
| 778 | ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign. |
| 779 | (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" str) |
| 780 | (progn |
| 781 | (setq str (copy-sequence str)) |
| 782 | (aset str (match-beginning 1) ?\/))) |
| 783 | |
| 784 | ;; Extract obvious month or weekday names. |
| 785 | (if (string-match "[a-zA-Z]" str) |
| 786 | (progn |
| 787 | (setq month (math-parse-date-word math-long-month-names)) |
| 788 | (setq weekday (math-parse-date-word math-long-weekday-names)) |
| 789 | (or month (setq month |
| 790 | (math-parse-date-word math-short-month-names))) |
| 791 | (or weekday (math-parse-date-word math-short-weekday-names)) |
| 792 | (or hour |
| 793 | (if (setq temp (math-parse-date-word |
| 794 | '( "noon" "midnight" "mid" ))) |
| 795 | (setq hour (if (= temp 1) 12 0) minute 0 second 0))) |
| 796 | (or (math-parse-date-word '( "ad" "a.d." )) |
| 797 | (if (math-parse-date-word '( "bc" "b.c." )) |
| 798 | (setq bc-flag t))) |
| 799 | (if (string-match "[a-zA-Z]+" str) |
| 800 | (throw 'syntax (format "Bad word in date: \"%s\"" |
| 801 | (math-match-substring str 0)))))) |
| 802 | |
| 803 | ;; If there is a huge number other than the year, ignore it. |
| 804 | (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" str) |
| 805 | (setq temp (concat (substring str 0 (match-beginning 0)) |
| 806 | (substring str (match-end 0)))) |
| 807 | (string-match "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp)) |
| 808 | (setq str temp)) |
| 809 | |
| 810 | ;; If there is a number with a sign or a large number, it is a year. |
| 811 | (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" str) |
| 812 | (string-match "\\(0*[1-9][0-9][0-9]+\\)" str)) |
| 813 | (setq year (math-match-substring str 1) |
| 814 | str (concat (substring str 0 (match-beginning 1)) |
| 815 | (substring str (match-end 1))) |
| 816 | year (math-read-number year) |
| 817 | bigyear t)) |
| 818 | |
| 819 | ;; Collect remaining numbers. |
| 820 | (setq temp 0) |
| 821 | (while (string-match "[0-9]+" str temp) |
| 822 | (and c (throw 'syntax "Too many numbers in date")) |
| 823 | (setq c (string-to-int (math-match-substring str 0))) |
| 824 | (or b (setq b c c nil)) |
| 825 | (or a (setq a b b nil)) |
| 826 | (setq temp (match-end 0))) |
| 827 | |
| 828 | ;; Check that we have the right amount of information. |
| 829 | (setq temp (+ (if year 1 0) (if month 1 0) (if day 1 0) |
| 830 | (if a 1 0) (if b 1 0) (if c 1 0))) |
| 831 | (if (> temp 3) |
| 832 | (throw 'syntax "Too many numbers in date") |
| 833 | (if (or (< temp 2) (and year (= temp 2))) |
| 834 | (throw 'syntax "Not enough numbers in date") |
| 835 | (if (= temp 2) ; if year omitted, assume current year |
| 836 | (setq year (math-this-year))))) |
| 837 | |
| 838 | ;; A large number must be a year. |
| 839 | (or year |
| 840 | (if (and a (or (> a 31) (< a 1))) |
| 841 | (setq year a a b b c c nil) |
| 842 | (if (and b (or (> b 31) (< b 1))) |
| 843 | (setq year b b c c nil) |
| 844 | (if (and c (or (> c 31) (< c 1))) |
| 845 | (setq year c c nil))))) |
| 846 | |
| 847 | ;; A medium-large number must be a day. |
| 848 | (if year |
| 849 | (if (and a (> a 12)) |
| 850 | (setq day a a b b c c nil) |
| 851 | (if (and b (> b 12)) |
| 852 | (setq day b b c c nil) |
| 853 | (if (and c (> c 12)) |
| 854 | (setq day c c nil))))) |
| 855 | |
| 856 | ;; We may know enough to sort it out now. |
| 857 | (if (and year day) |
| 858 | (or month (setq month a)) |
| 859 | (if (and year month) |
| 860 | (setq day a) |
| 861 | |
| 862 | ;; Interpret order of numbers as same as for display format. |
| 863 | (setq temp calc-date-format) |
| 864 | (while temp |
| 865 | (cond ((not (symbolp (car temp)))) |
| 866 | ((memq (car temp) '(Y YY BY YYY YYYY)) |
| 867 | (or year (setq year a a b b c))) |
| 868 | ((memq (car temp) '(M MM BM mmm Mmm Mmmm MMM MMMM)) |
| 869 | (or month (setq month a a b b c))) |
| 870 | ((memq (car temp) '(D DD BD)) |
| 871 | (or day (setq day a a b b c)))) |
| 872 | (setq temp (cdr temp))) |
| 873 | |
| 874 | ;; If display format was not complete, assume American style. |
| 875 | (or month (setq month a a b b c)) |
| 876 | (or day (setq day a a b b c)) |
| 877 | (or year (setq year a a b b c)))) |
| 878 | |
| 879 | (if bc-flag |
| 880 | (setq year (math-neg (math-abs year)))) |
| 881 | |
| 882 | (math-parse-date-validate year bigyear month day |
| 883 | hour minute second)))) |
| 884 | ) |
| 885 | |
| 886 | (defun math-parse-date-validate (year bigyear month day hour minute second) |
| 887 | (and (not bigyear) (natnump year) (< year 100) |
| 888 | (setq year (+ year (if (< year 40) 2000 1900)))) |
| 889 | (if (eq year 0) |
| 890 | (throw 'syntax "Year value is out of range")) |
| 891 | (if (or (< month 1) (> month 12)) |
| 892 | (throw 'syntax "Month value is out of range")) |
| 893 | (if (or (< day 1) (> day (math-days-in-month year month))) |
| 894 | (throw 'syntax "Day value is out of range")) |
| 895 | (and hour |
| 896 | (progn |
| 897 | (if (or (< hour 0) (> hour 23)) |
| 898 | (throw 'syntax "Hour value is out of range")) |
| 899 | (if (or (< minute 0) (> minute 59)) |
| 900 | (throw 'syntax "Minute value is out of range")) |
| 901 | (if (or (math-negp second) (not (Math-lessp second 60))) |
| 902 | (throw 'syntax "Seconds value is out of range")))) |
| 903 | (list 'date (math-dt-to-date (append (list year month day) |
| 904 | (and hour (list hour minute second))))) |
| 905 | ) |
| 906 | |
| 907 | (defun math-parse-date-word (names &optional front) |
| 908 | (let ((n 1)) |
| 909 | (while (and names (not (string-match (if (equal (car names) "Sep") |
| 910 | "Sept?" |
| 911 | (regexp-quote (car names))) |
| 912 | str))) |
| 913 | (setq names (cdr names) |
| 914 | n (1+ n))) |
| 915 | (and names |
| 916 | (or (not front) (= (match-beginning 0) 0)) |
| 917 | (progn |
| 918 | (setq str (concat (substring str 0 (match-beginning 0)) |
| 919 | (if front "" " ") |
| 920 | (substring str (match-end 0)))) |
| 921 | n))) |
| 922 | ) |
| 923 | |
| 924 | (defun math-parse-standard-date (str with-time) |
| 925 | (let ((case-fold-search t) |
| 926 | (okay t) num |
| 927 | (fmt calc-date-format) this next (gnext nil) |
| 928 | (year nil) (month nil) (day nil) (bigyear nil) (yearday nil) |
| 929 | (hour nil) (minute nil) (second nil) (bc-flag nil)) |
| 930 | (while (and fmt okay) |
| 931 | (setq this (car fmt) |
| 932 | fmt (setq fmt (or (cdr fmt) |
| 933 | (prog1 |
| 934 | gnext |
| 935 | (setq gnext nil)))) |
| 936 | next (car fmt)) |
| 937 | (if (consp next) (setq next (car next))) |
| 938 | (or (cond ((listp this) |
| 939 | (or (not with-time) |
| 940 | (not this) |
| 941 | (setq gnext fmt |
| 942 | fmt this))) |
| 943 | ((stringp this) |
| 944 | (if (and (<= (length this) (length str)) |
| 945 | (equal this |
| 946 | (substring str 0 (length this)))) |
| 947 | (setq str (substring str (length this))))) |
| 948 | ((eq this 'X) |
| 949 | t) |
| 950 | ((memq this '(n N j J)) |
| 951 | (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" str) |
| 952 | (setq num (math-match-substring str 0) |
| 953 | str (substring str (match-end 0)) |
| 954 | num (math-date-to-dt (math-read-number num)) |
| 955 | num (math-sub num |
| 956 | (if (memq this '(n N)) |
| 957 | 0 |
| 958 | (if (or (eq this 'j) |
| 959 | (math-integerp num)) |
| 960 | '(bigpos 424 721 1) |
| 961 | '(float (bigpos 235 214 17) |
| 962 | -1)))) |
| 963 | hour (or (nth 3 num) hour) |
| 964 | minute (or (nth 4 num) minute) |
| 965 | second (or (nth 5 num) second) |
| 966 | year (car num) |
| 967 | month (nth 1 num) |
| 968 | day (nth 2 num)))) |
| 969 | ((eq this 'U) |
| 970 | (and (string-match "\\`[-+]?[0-9]+" str) |
| 971 | (setq num (math-match-substring str 0) |
| 972 | str (substring str (match-end 0)) |
| 973 | num (math-date-to-dt |
| 974 | (math-add 719164 |
| 975 | (math-div (math-read-number num) |
| 976 | '(float 864 2)))) |
| 977 | hour (nth 3 num) |
| 978 | minute (nth 4 num) |
| 979 | second (nth 5 num) |
| 980 | year (car num) |
| 981 | month (nth 1 num) |
| 982 | day (nth 2 num)))) |
| 983 | ((memq this '(mmm Mmm MMM)) |
| 984 | (setq month (math-parse-date-word math-short-month-names t))) |
| 985 | ((memq this '(Mmmm MMMM)) |
| 986 | (setq month (math-parse-date-word math-long-month-names t))) |
| 987 | ((memq this '(www Www WWW)) |
| 988 | (math-parse-date-word math-short-weekday-names t)) |
| 989 | ((memq this '(Wwww WWWW)) |
| 990 | (math-parse-date-word math-long-weekday-names t)) |
| 991 | ((memq this '(p P)) |
| 992 | (if (string-match "\\`a" str) |
| 993 | (setq hour (if (= hour 12) 0 hour) |
| 994 | str (substring str 1)) |
| 995 | (if (string-match "\\`p" str) |
| 996 | (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) |
| 997 | str (substring str 1))))) |
| 998 | ((memq this '(pp PP pppp PPPP)) |
| 999 | (if (string-match "\\`am\\|a\\.m\\." str) |
| 1000 | (setq hour (if (= hour 12) 0 hour) |
| 1001 | str (substring str (match-end 0))) |
| 1002 | (if (string-match "\\`pm\\|p\\.m\\." str) |
| 1003 | (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) |
| 1004 | str (substring str (match-end 0)))))) |
| 1005 | ((memq this '(Y YY BY YYY YYYY)) |
| 1006 | (and (if (memq next '(MM DD ddd hh HH mm ss SS)) |
| 1007 | (if (memq this '(Y YY BYY)) |
| 1008 | (string-match "\\` *[0-9][0-9]" str) |
| 1009 | (string-match "\\`[0-9][0-9][0-9][0-9]" str)) |
| 1010 | (string-match "\\`[-+]?[0-9]+" str)) |
| 1011 | (setq year (math-match-substring str 0) |
| 1012 | bigyear (or (eq this 'YYY) |
| 1013 | (memq (aref str 0) '(?\+ ?\-))) |
| 1014 | str (substring str (match-end 0)) |
| 1015 | year (math-read-number year)))) |
| 1016 | ((eq this 'b) |
| 1017 | t) |
| 1018 | ((memq this '(aa AA aaaa AAAA)) |
| 1019 | (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" str) |
| 1020 | (setq str (substring str (match-end 0))))) |
| 1021 | ((memq this '(aaa AAA)) |
| 1022 | (if (string-match "\\` *ad *" str) |
| 1023 | (setq str (substring str (match-end 0))))) |
| 1024 | ((memq this '(bb BB bbb BBB bbbb BBBB)) |
| 1025 | (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" str) |
| 1026 | (setq str (substring str (match-end 0)) |
| 1027 | bc-flag t))) |
| 1028 | ((memq this '(s ss bs SS BS)) |
| 1029 | (and (if (memq next '(YY YYYY MM DD hh HH mm)) |
| 1030 | (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" str) |
| 1031 | (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" str)) |
| 1032 | (setq second (math-match-substring str 0) |
| 1033 | str (substring str (match-end 0)) |
| 1034 | second (math-read-number second)))) |
| 1035 | ((eq this 'C) |
| 1036 | (if (string-match "\\`:[0-9][0-9]" str) |
| 1037 | (setq str (substring str 1)) |
| 1038 | t)) |
| 1039 | ((or (not (if (and (memq this '(ddd MM DD hh HH mm)) |
| 1040 | (memq next '(YY YYYY MM DD ddd |
| 1041 | hh HH mm ss SS))) |
| 1042 | (if (eq this 'ddd) |
| 1043 | (string-match "\\` *[0-9][0-9][0-9]" str) |
| 1044 | (string-match "\\` *[0-9][0-9]" str)) |
| 1045 | (string-match "\\` *[0-9]+" str))) |
| 1046 | (and (setq num (string-to-int |
| 1047 | (math-match-substring str 0)) |
| 1048 | str (substring str (match-end 0))) |
| 1049 | nil)) |
| 1050 | nil) |
| 1051 | ((eq this 'W) |
| 1052 | (and (>= num 0) (< num 7))) |
| 1053 | ((memq this '(d ddd bdd)) |
| 1054 | (setq yearday num)) |
| 1055 | ((memq this '(M MM BM)) |
| 1056 | (setq month num)) |
| 1057 | ((memq this '(D DD BD)) |
| 1058 | (setq day num)) |
| 1059 | ((memq this '(h hh bh H HH BH)) |
| 1060 | (setq hour num)) |
| 1061 | ((memq this '(m mm bm)) |
| 1062 | (setq minute num))) |
| 1063 | (setq okay nil))) |
| 1064 | (if yearday |
| 1065 | (if (and month day) |
| 1066 | (setq yearday nil) |
| 1067 | (setq month 1 day 1))) |
| 1068 | (if (and okay (equal str "")) |
| 1069 | (and month day (or (not (or hour minute second)) |
| 1070 | (and hour minute)) |
| 1071 | (progn |
| 1072 | (or year (setq year (math-this-year))) |
| 1073 | (or second (setq second 0)) |
| 1074 | (if bc-flag |
| 1075 | (setq year (math-neg (math-abs year)))) |
| 1076 | (setq day (math-parse-date-validate year bigyear month day |
| 1077 | hour minute second)) |
| 1078 | (if yearday |
| 1079 | (setq day (math-add day (1- yearday)))) |
| 1080 | day)))) |
| 1081 | ) |
| 1082 | |
| 1083 | |
| 1084 | (defun calcFunc-now (&optional zone) |
| 1085 | (let ((date (let ((calc-date-format nil)) |
| 1086 | (math-parse-date (current-time-string))))) |
| 1087 | (if (consp date) |
| 1088 | (if zone |
| 1089 | (math-add date (math-div (math-sub (calcFunc-tzone nil date) |
| 1090 | (calcFunc-tzone zone date)) |
| 1091 | '(float 864 2))) |
| 1092 | date) |
| 1093 | (calc-record-why "*Unable to interpret current date from system") |
| 1094 | (append (list 'calcFunc-now) (and zone (list zone))))) |
| 1095 | ) |
| 1096 | |
| 1097 | (defun calcFunc-year (date) |
| 1098 | (car (math-date-to-dt date)) |
| 1099 | ) |
| 1100 | |
| 1101 | (defun calcFunc-month (date) |
| 1102 | (nth 1 (math-date-to-dt date)) |
| 1103 | ) |
| 1104 | |
| 1105 | (defun calcFunc-day (date) |
| 1106 | (nth 2 (math-date-to-dt date)) |
| 1107 | ) |
| 1108 | |
| 1109 | (defun calcFunc-weekday (date) |
| 1110 | (if (eq (car-safe date) 'date) |
| 1111 | (setq date (nth 1 date))) |
| 1112 | (or (math-realp date) |
| 1113 | (math-reject-arg date 'datep)) |
| 1114 | (math-mod (math-add (math-floor date) 6) 7) |
| 1115 | ) |
| 1116 | |
| 1117 | (defun calcFunc-yearday (date) |
| 1118 | (let ((dt (math-date-to-dt date))) |
| 1119 | (math-day-number (car dt) (nth 1 dt) (nth 2 dt))) |
| 1120 | ) |
| 1121 | |
| 1122 | (defun calcFunc-hour (date) |
| 1123 | (if (eq (car-safe date) 'hms) |
| 1124 | (nth 1 date) |
| 1125 | (or (nth 3 (math-date-to-dt date)) 0)) |
| 1126 | ) |
| 1127 | |
| 1128 | (defun calcFunc-minute (date) |
| 1129 | (if (eq (car-safe date) 'hms) |
| 1130 | (nth 2 date) |
| 1131 | (or (nth 4 (math-date-to-dt date)) 0)) |
| 1132 | ) |
| 1133 | |
| 1134 | (defun calcFunc-second (date) |
| 1135 | (if (eq (car-safe date) 'hms) |
| 1136 | (nth 3 date) |
| 1137 | (or (nth 5 (math-date-to-dt date)) 0)) |
| 1138 | ) |
| 1139 | |
| 1140 | (defun calcFunc-time (date) |
| 1141 | (let ((dt (math-date-to-dt date))) |
| 1142 | (if (nth 3 dt) |
| 1143 | (cons 'hms (nthcdr 3 dt)) |
| 1144 | (list 'hms 0 0 0))) |
| 1145 | ) |
| 1146 | |
| 1147 | (defun calcFunc-date (date &optional month day hour minute second) |
| 1148 | (and (math-messy-integerp month) (setq month (math-trunc month))) |
| 1149 | (and month (not (integerp month)) (math-reject-arg month 'fixnump)) |
| 1150 | (and (math-messy-integerp day) (setq day (math-trunc day))) |
| 1151 | (and day (not (integerp day)) (math-reject-arg day 'fixnump)) |
| 1152 | (if (and (eq (car-safe hour) 'hms) (not minute)) |
| 1153 | (setq second (nth 3 hour) |
| 1154 | minute (nth 2 hour) |
| 1155 | hour (nth 1 hour))) |
| 1156 | (and (math-messy-integerp hour) (setq hour (math-trunc hour))) |
| 1157 | (and hour (not (integerp hour)) (math-reject-arg hour 'fixnump)) |
| 1158 | (and (math-messy-integerp minute) (setq minute (math-trunc minute))) |
| 1159 | (and minute (not (integerp minute)) (math-reject-arg minute 'fixnump)) |
| 1160 | (and (math-messy-integerp second) (setq second (math-trunc second))) |
| 1161 | (and second (not (math-realp second)) (math-reject-arg second 'realp)) |
| 1162 | (if month |
| 1163 | (progn |
| 1164 | (and (math-messy-integerp date) (setq date (math-trunc date))) |
| 1165 | (and date (not (math-integerp date)) (math-reject-arg date 'integerp)) |
| 1166 | (if day |
| 1167 | (if hour |
| 1168 | (list 'date (math-dt-to-date (list date month day hour |
| 1169 | (or minute 0) |
| 1170 | (or second 0)))) |
| 1171 | (list 'date (math-dt-to-date (list date month day)))) |
| 1172 | (list 'date (math-dt-to-date (list (math-this-year) date month))))) |
| 1173 | (if (math-realp date) |
| 1174 | (list 'date date) |
| 1175 | (if (eq (car date) 'date) |
| 1176 | (nth 1 date) |
| 1177 | (math-reject-arg date 'datep)))) |
| 1178 | ) |
| 1179 | |
| 1180 | (defun calcFunc-julian (date &optional zone) |
| 1181 | (if (math-realp date) |
| 1182 | (list 'date (if (math-integerp date) |
| 1183 | (math-sub date '(bigpos 424 721 1)) |
| 1184 | (setq date (math-sub date '(float (bigpos 235 214 17) -1))) |
| 1185 | (math-sub date (math-div (calcFunc-tzone zone date) |
| 1186 | '(float 864 2))))) |
| 1187 | (if (eq (car date) 'date) |
| 1188 | (math-add (nth 1 date) (if (math-integerp (nth 1 date)) |
| 1189 | '(bigpos 424 721 1) |
| 1190 | (math-add '(float (bigpos 235 214 17) -1) |
| 1191 | (math-div (calcFunc-tzone zone date) |
| 1192 | '(float 864 2))))) |
| 1193 | (math-reject-arg date 'datep))) |
| 1194 | ) |
| 1195 | |
| 1196 | (defun calcFunc-unixtime (date &optional zone) |
| 1197 | (if (math-realp date) |
| 1198 | (progn |
| 1199 | (setq date (math-add 719164 (math-div date '(float 864 2)))) |
| 1200 | (list 'date (math-sub date (math-div (calcFunc-tzone zone date) |
| 1201 | '(float 864 2))))) |
| 1202 | (if (eq (car date) 'date) |
| 1203 | (math-add (nth 1 (math-date-parts (nth 1 date) 719164)) |
| 1204 | (calcFunc-tzone zone date)) |
| 1205 | (math-reject-arg date 'datep))) |
| 1206 | ) |
| 1207 | |
| 1208 | (defun calcFunc-tzone (&optional zone date) |
| 1209 | (if zone |
| 1210 | (cond ((math-realp zone) |
| 1211 | (math-round (math-mul zone 3600))) |
| 1212 | ((eq (car zone) 'hms) |
| 1213 | (math-round (math-mul (math-from-hms zone 'deg) 3600))) |
| 1214 | ((eq (car zone) '+) |
| 1215 | (math-add (calcFunc-tzone (nth 1 zone) date) |
| 1216 | (calcFunc-tzone (nth 2 zone) date))) |
| 1217 | ((eq (car zone) '-) |
| 1218 | (math-sub (calcFunc-tzone (nth 1 zone) date) |
| 1219 | (calcFunc-tzone (nth 2 zone) date))) |
| 1220 | ((eq (car zone) 'var) |
| 1221 | (let ((name (upcase (symbol-name (nth 1 zone)))) |
| 1222 | found) |
| 1223 | (if (setq found (assoc name math-tzone-names)) |
| 1224 | (calcFunc-tzone (math-add (nth 1 found) |
| 1225 | (if (integerp (nth 2 found)) |
| 1226 | (nth 2 found) |
| 1227 | (or |
| 1228 | (math-daylight-savings-adjust |
| 1229 | date (car found)) |
| 1230 | 0))) |
| 1231 | date) |
| 1232 | (if (equal name "LOCAL") |
| 1233 | (calcFunc-tzone nil date) |
| 1234 | (math-reject-arg zone "*Unrecognized time zone name"))))) |
| 1235 | (t (math-reject-arg zone "*Expected a time zone"))) |
| 1236 | (if (calc-var-value 'var-TimeZone) |
| 1237 | (calcFunc-tzone (calc-var-value 'var-TimeZone) date) |
| 1238 | (let ((p math-tzone-names) |
| 1239 | (offset 0) |
| 1240 | (tz '(var error var-error))) |
| 1241 | (save-excursion |
| 1242 | (set-buffer (get-buffer-create " *Calc Temporary*")) |
| 1243 | (erase-buffer) |
| 1244 | (call-process "date" nil t) |
| 1245 | (goto-char 1) |
| 1246 | (let ((case-fold-search t)) |
| 1247 | (while (and p (not (search-forward (car (car p)) nil t))) |
| 1248 | (setq p (cdr p)))) |
| 1249 | (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)") |
| 1250 | (setq offset (math-add |
| 1251 | (string-to-int (buffer-substring |
| 1252 | (match-beginning 1) |
| 1253 | (match-end 1))) |
| 1254 | (if (match-beginning 2) |
| 1255 | (math-div (string-to-int (buffer-substring |
| 1256 | (match-beginning 2) |
| 1257 | (match-end 2))) |
| 1258 | 60) |
| 1259 | 0))))) |
| 1260 | (if p |
| 1261 | (progn |
| 1262 | (setq p (car p)) |
| 1263 | ;; Try to convert to a generalized time zone. |
| 1264 | (if (integerp (nth 2 p)) |
| 1265 | (let ((gen math-tzone-names)) |
| 1266 | (while (and gen |
| 1267 | (not (equal (nth 2 (car gen)) (car p))) |
| 1268 | (not (equal (nth 3 (car gen)) (car p))) |
| 1269 | (not (equal (nth 4 (car gen)) (car p))) |
| 1270 | (not (equal (nth 5 (car gen)) (car p)))) |
| 1271 | (setq gen (cdr gen))) |
| 1272 | (and gen |
| 1273 | (setq gen (car gen)) |
| 1274 | (equal (math-daylight-savings-adjust nil (car gen)) |
| 1275 | (nth 2 p)) |
| 1276 | (setq p gen)))) |
| 1277 | (setq tz (math-add (list 'var |
| 1278 | (intern (car p)) |
| 1279 | (intern (concat "var-" (car p)))) |
| 1280 | offset)))) |
| 1281 | (kill-buffer " *Calc Temporary*") |
| 1282 | (setq var-TimeZone tz) |
| 1283 | (calc-refresh-evaltos 'var-TimeZone) |
| 1284 | (calcFunc-tzone tz date)))) |
| 1285 | ) |
| 1286 | |
| 1287 | ;;; Note: Longer names must appear before shorter names which are |
| 1288 | ;;; substrings of them. |
| 1289 | (defvar math-tzone-names |
| 1290 | '( ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe |
| 1291 | ( "METDST" -1 -1 ) ( "MET" -1 0 ) |
| 1292 | ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 ) |
| 1293 | ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe |
| 1294 | ( "WETDST" 0 -1 ) ( "WET" 0 0 ) |
| 1295 | ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain |
| 1296 | ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland |
| 1297 | ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 ) |
| 1298 | ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic |
| 1299 | ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern |
| 1300 | ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central |
| 1301 | ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain |
| 1302 | ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific |
| 1303 | ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon |
| 1304 | )) |
| 1305 | |
| 1306 | |
| 1307 | (defun math-daylight-savings-adjust (date zone &optional dt) |
| 1308 | (or date (setq date (nth 1 (calcFunc-now)))) |
| 1309 | (let (bump) |
| 1310 | (if (eq (car-safe date) 'date) |
| 1311 | (setq bump 0 |
| 1312 | date (nth 1 date)) |
| 1313 | (if (and date (math-realp date)) |
| 1314 | (let ((zadj (assoc zone math-tzone-names))) |
| 1315 | (if zadj (setq bump -1 |
| 1316 | date (math-sub date (math-div (nth 1 zadj) |
| 1317 | '(float 24 0)))))) |
| 1318 | (math-reject-arg date 'datep))) |
| 1319 | (setq date (math-float date)) |
| 1320 | (or dt (setq dt (math-date-to-dt date))) |
| 1321 | (and math-daylight-savings-hook |
| 1322 | (funcall math-daylight-savings-hook date dt zone bump))) |
| 1323 | ) |
| 1324 | |
| 1325 | (defun calcFunc-dsadj (date &optional zone) |
| 1326 | (if zone |
| 1327 | (or (eq (car-safe zone) 'var) |
| 1328 | (math-reject-arg zone "*Time zone variable expected")) |
| 1329 | (setq zone (or (calc-var-value 'var-TimeZone) |
| 1330 | (progn |
| 1331 | (calcFunc-tzone) |
| 1332 | (calc-var-value 'var-TimeZone))))) |
| 1333 | (setq zone (and (eq (car-safe zone) 'var) |
| 1334 | (upcase (symbol-name (nth 1 zone))))) |
| 1335 | (let ((zadj (assoc zone math-tzone-names))) |
| 1336 | (or zadj (math-reject-arg zone "*Unrecognized time zone name")) |
| 1337 | (if (integerp (nth 2 zadj)) |
| 1338 | (nth 2 zadj) |
| 1339 | (math-daylight-savings-adjust date zone))) |
| 1340 | ) |
| 1341 | |
| 1342 | (defun calcFunc-tzconv (date z1 z2) |
| 1343 | (if (math-realp date) |
| 1344 | (nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) |
| 1345 | (calcFunc-unixtime (calcFunc-unixtime date z1) z2)) |
| 1346 | ) |
| 1347 | |
| 1348 | (defvar math-daylight-savings-hook 'math-std-daylight-savings) |
| 1349 | |
| 1350 | (defun math-std-daylight-savings (date dt zone bump) |
| 1351 | "Standard North American daylight savings algorithm. |
| 1352 | This implements the rules for the U.S. and Canada as of 1987. |
| 1353 | Daylight savings begins on the first Sunday of April at 2 a.m., |
| 1354 | and ends on the last Sunday of October at 2 a.m." |
| 1355 | (cond ((< (nth 1 dt) 4) 0) |
| 1356 | ((= (nth 1 dt) 4) |
| 1357 | (let ((sunday (math-prev-weekday-in-month date dt 7 0))) |
| 1358 | (cond ((< (nth 2 dt) sunday) 0) |
| 1359 | ((= (nth 2 dt) sunday) |
| 1360 | (if (>= (nth 3 dt) (+ 3 bump)) -1 0)) |
| 1361 | (t -1)))) |
| 1362 | ((< (nth 1 dt) 10) -1) |
| 1363 | ((= (nth 1 dt) 10) |
| 1364 | (let ((sunday (math-prev-weekday-in-month date dt 31 0))) |
| 1365 | (cond ((< (nth 2 dt) sunday) -1) |
| 1366 | ((= (nth 2 dt) sunday) |
| 1367 | (if (>= (nth 3 dt) (+ 2 bump)) 0 -1)) |
| 1368 | (t 0)))) |
| 1369 | (t 0)) |
| 1370 | ) |
| 1371 | |
| 1372 | ;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given |
| 1373 | ;;; day of the given month. |
| 1374 | (defun math-prev-weekday-in-month (date dt day wday) |
| 1375 | (or day (setq day (nth 2 dt))) |
| 1376 | (if (> day (math-days-in-month (car dt) (nth 1 dt))) |
| 1377 | (setq day (math-days-in-month (car dt) (nth 1 dt)))) |
| 1378 | (let ((zeroth (math-sub (math-floor date) (nth 2 dt)))) |
| 1379 | (math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth)) |
| 1380 | ) |
| 1381 | |
| 1382 | (defun calcFunc-pwday (date &optional day weekday) |
| 1383 | (if (eq (car-safe date) 'date) |
| 1384 | (setq date (nth 1 date))) |
| 1385 | (or (math-realp date) |
| 1386 | (math-reject-arg date 'datep)) |
| 1387 | (if (math-messy-integerp day) (setq day (math-trunc day))) |
| 1388 | (or (integerp day) (math-reject-arg day 'fixnump)) |
| 1389 | (if (= day 0) (setq day 31)) |
| 1390 | (and (or (< day 7) (> day 31)) (math-reject-arg day 'range)) |
| 1391 | (math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0)) |
| 1392 | ) |
| 1393 | |
| 1394 | |
| 1395 | (defun calcFunc-newweek (date &optional weekday) |
| 1396 | (if (eq (car-safe date) 'date) |
| 1397 | (setq date (nth 1 date))) |
| 1398 | (or (math-realp date) |
| 1399 | (math-reject-arg date 'datep)) |
| 1400 | (or weekday (setq weekday 0)) |
| 1401 | (and (math-messy-integerp weekday) (setq weekday (math-trunc weekday))) |
| 1402 | (or (integerp weekday) (math-reject-arg weekday 'fixnump)) |
| 1403 | (and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range)) |
| 1404 | (setq date (math-floor date)) |
| 1405 | (list 'date (math-sub date (calcFunc-weekday (math-sub date weekday)))) |
| 1406 | ) |
| 1407 | |
| 1408 | (defun calcFunc-newmonth (date &optional day) |
| 1409 | (or day (setq day 1)) |
| 1410 | (and (math-messy-integerp day) (setq day (math-trunc day))) |
| 1411 | (or (integerp day) (math-reject-arg day 'fixnump)) |
| 1412 | (and (or (< day 0) (> day 31)) (math-reject-arg day 'range)) |
| 1413 | (let ((dt (math-date-to-dt date))) |
| 1414 | (if (or (= day 0) (> day (math-days-in-month (car dt) (nth 1 dt)))) |
| 1415 | (setq day (math-days-in-month (car dt) (nth 1 dt)))) |
| 1416 | (and (eq (car dt) 1752) (= (nth 1 dt) 9) |
| 1417 | (if (>= day 14) (setq day (- day 11)))) |
| 1418 | (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) |
| 1419 | (1- day)))) |
| 1420 | ) |
| 1421 | |
| 1422 | (defun calcFunc-newyear (date &optional day) |
| 1423 | (or day (setq day 1)) |
| 1424 | (and (math-messy-integerp day) (setq day (math-trunc day))) |
| 1425 | (or (integerp day) (math-reject-arg day 'fixnump)) |
| 1426 | (let ((dt (math-date-to-dt date))) |
| 1427 | (if (and (>= day 0) (<= day 366)) |
| 1428 | (let ((max (if (eq (car dt) 1752) 355 |
| 1429 | (if (math-leap-year-p (car dt)) 366 365)))) |
| 1430 | (if (or (= day 0) (> day max)) (setq day max)) |
| 1431 | (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) |
| 1432 | (1- day)))) |
| 1433 | (if (and (>= day -12) (<= day -1)) |
| 1434 | (list 'date (math-dt-to-date (list (car dt) (- day) 1))) |
| 1435 | (math-reject-arg day 'range)))) |
| 1436 | ) |
| 1437 | |
| 1438 | (defun calcFunc-incmonth (date &optional step) |
| 1439 | (or step (setq step 1)) |
| 1440 | (and (math-messy-integerp step) (setq step (math-trunc step))) |
| 1441 | (or (math-integerp step) (math-reject-arg step 'integerp)) |
| 1442 | (let* ((dt (math-date-to-dt date)) |
| 1443 | (year (car dt)) |
| 1444 | (month (math-add (1- (nth 1 dt)) step)) |
| 1445 | (extra (calcFunc-idiv month 12)) |
| 1446 | (day (nth 2 dt))) |
| 1447 | (setq month (1+ (math-sub month (math-mul extra 12))) |
| 1448 | year (math-add year extra) |
| 1449 | day (min day (math-days-in-month year month))) |
| 1450 | (and (math-posp (car dt)) (not (math-posp year)) |
| 1451 | (setq year (math-sub year 1))) ; did we go past the year zero? |
| 1452 | (and (math-negp (car dt)) (not (math-negp year)) |
| 1453 | (setq year (math-add year 1))) |
| 1454 | (list 'date (math-dt-to-date |
| 1455 | (cons year (cons month (cons day (cdr (cdr (cdr dt))))))))) |
| 1456 | ) |
| 1457 | |
| 1458 | (defun calcFunc-incyear (date &optional step) |
| 1459 | (calcFunc-incmonth date (math-mul (or step 1) 12)) |
| 1460 | ) |
| 1461 | |
| 1462 | |
| 1463 | |
| 1464 | (defun calcFunc-bsub (a b) |
| 1465 | (or (eq (car-safe a) 'date) |
| 1466 | (math-reject-arg a 'datep)) |
| 1467 | (if (eq (car-safe b) 'date) |
| 1468 | (if (math-lessp (nth 1 a) (nth 1 b)) |
| 1469 | (math-neg (calcFunc-bsub b a)) |
| 1470 | (math-setup-holidays b) |
| 1471 | (let* ((da (math-to-business-day a)) |
| 1472 | (db (math-to-business-day b))) |
| 1473 | (math-add (math-sub (car da) (car db)) |
| 1474 | (if (and (cdr db) (not (cdr da))) 1 0)))) |
| 1475 | (calcFunc-badd a (math-neg b))) |
| 1476 | ) |
| 1477 | |
| 1478 | (defun calcFunc-badd (a b) |
| 1479 | (if (eq (car-safe b) 'date) |
| 1480 | (if (eq (car-safe a) 'date) |
| 1481 | (math-reject-arg nil "*Illegal combination in date arithmetic") |
| 1482 | (calcFunc-badd b a)) |
| 1483 | (if (eq (car-safe a) 'date) |
| 1484 | (if (Math-realp b) |
| 1485 | (if (Math-zerop b) |
| 1486 | a |
| 1487 | (let* ((d (math-to-business-day a)) |
| 1488 | (bb (math-add (car d) |
| 1489 | (if (and (cdr d) (Math-posp b)) |
| 1490 | (math-sub b 1) b)))) |
| 1491 | (or (math-from-business-day bb) |
| 1492 | (calcFunc-badd a b)))) |
| 1493 | (if (eq (car-safe b) 'hms) |
| 1494 | (let ((hours (nth 7 math-holidays-cache))) |
| 1495 | (setq b (math-div (math-from-hms b 'deg) 24)) |
| 1496 | (if hours |
| 1497 | (setq b (math-div b (cdr hours)))) |
| 1498 | (calcFunc-badd a b)) |
| 1499 | (math-reject-arg nil "*Illegal combination in date arithmetic"))) |
| 1500 | (math-reject-arg a 'datep))) |
| 1501 | ) |
| 1502 | |
| 1503 | (defun calcFunc-holiday (a) |
| 1504 | (if (cdr (math-to-business-day a)) 1 0) |
| 1505 | ) |
| 1506 | |
| 1507 | |
| 1508 | (setq math-holidays-cache nil) |
| 1509 | (setq math-holidays-cache-tag t) |
| 1510 | |
| 1511 | |
| 1512 | ;;; Compute the number of business days since Jan 1, 1 AD. |
| 1513 | |
| 1514 | (defun math-to-business-day (date &optional need-year) |
| 1515 | (if (eq (car-safe date) 'date) |
| 1516 | (setq date (nth 1 date))) |
| 1517 | (or (Math-realp date) |
| 1518 | (math-reject-arg date 'datep)) |
| 1519 | (let* ((day (math-floor date)) |
| 1520 | (time (math-sub date day)) |
| 1521 | (dt (math-date-to-dt day)) |
| 1522 | (delta 0) |
| 1523 | (holiday nil)) |
| 1524 | (or (not need-year) (eq (car dt) need-year) |
| 1525 | (math-reject-arg (list 'date day) "*Generated holiday has wrong year")) |
| 1526 | (math-setup-holidays date) |
| 1527 | (let ((days (car math-holidays-cache))) |
| 1528 | (while (and (setq days (cdr days)) (< (car days) day)) |
| 1529 | (setq delta (1+ delta))) |
| 1530 | (and days (= day (car days)) |
| 1531 | (setq holiday t))) |
| 1532 | (let* ((weekdays (nth 3 math-holidays-cache)) |
| 1533 | (weeks (1- (/ (+ day 6) 7))) |
| 1534 | (wkday (- day 1 (* weeks 7)))) |
| 1535 | (setq delta (+ delta (* weeks (length weekdays)))) |
| 1536 | (while (and weekdays (< (car weekdays) wkday)) |
| 1537 | (setq weekdays (cdr weekdays) |
| 1538 | delta (1+ delta))) |
| 1539 | (and weekdays (eq wkday (car weekdays)) |
| 1540 | (setq holiday t))) |
| 1541 | (let ((hours (nth 7 math-holidays-cache))) |
| 1542 | (if hours |
| 1543 | (progn |
| 1544 | (setq time (math-div (math-sub time (car hours)) (cdr hours))) |
| 1545 | (if (Math-lessp time 0) (setq time 0)) |
| 1546 | (or (Math-lessp time 1) |
| 1547 | (setq time |
| 1548 | (math-sub 1 |
| 1549 | (math-div 1 (math-mul 86400 (cdr hours))))))))) |
| 1550 | (cons (math-add (math-sub day delta) time) holiday)) |
| 1551 | ) |
| 1552 | |
| 1553 | |
| 1554 | ;;; Compute the date a certain number of business days since Jan 1, 1 AD. |
| 1555 | ;;; If this returns NIL, holiday table was adjusted; redo calculation. |
| 1556 | |
| 1557 | (defun math-from-business-day (num) |
| 1558 | (let* ((day (math-floor num)) |
| 1559 | (time (math-sub num day))) |
| 1560 | (or (integerp day) |
| 1561 | (math-reject-arg nil "*Date is outside valid range")) |
| 1562 | (math-setup-holidays) |
| 1563 | (let ((days (nth 1 math-holidays-cache)) |
| 1564 | (delta 0)) |
| 1565 | (while (and (setq days (cdr days)) (< (car days) day)) |
| 1566 | (setq delta (1+ delta))) |
| 1567 | (setq day (+ day delta))) |
| 1568 | (let* ((weekdays (nth 3 math-holidays-cache)) |
| 1569 | (bweek (- 7 (length weekdays))) |
| 1570 | (weeks (1- (/ (+ day (1- bweek)) bweek))) |
| 1571 | (wkday (- day 1 (* weeks bweek))) |
| 1572 | (w 0)) |
| 1573 | (setq day (+ day (* weeks (length weekdays)))) |
| 1574 | (while (if (memq w weekdays) |
| 1575 | (setq day (1+ day)) |
| 1576 | (> (setq wkday (1- wkday)) 0)) |
| 1577 | (setq w (1+ w))) |
| 1578 | (let ((hours (nth 7 math-holidays-cache))) |
| 1579 | (if hours |
| 1580 | (setq time (math-add (math-mul time (cdr hours)) (car hours))))) |
| 1581 | (and (not (math-setup-holidays day)) |
| 1582 | (list 'date (math-add day time))))) |
| 1583 | ) |
| 1584 | |
| 1585 | |
| 1586 | (defun math-setup-holidays (&optional date) |
| 1587 | (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag) |
| 1588 | (let ((h (calc-var-value 'var-Holidays)) |
| 1589 | (wdnames '( (sun . 0) (mon . 1) (tue . 2) (wed . 3) |
| 1590 | (thu . 4) (fri . 5) (sat . 6) )) |
| 1591 | (days nil) (weekdays nil) (exprs nil) (limit nil) (hours nil)) |
| 1592 | (or (math-vectorp h) |
| 1593 | (math-reject-arg h "*Holidays variable must be a vector")) |
| 1594 | (while (setq h (cdr h)) |
| 1595 | (cond ((or (and (eq (car-safe (car h)) 'date) |
| 1596 | (integerp (nth 1 (car h)))) |
| 1597 | (and (eq (car-safe (car h)) 'intv) |
| 1598 | (eq (car-safe (nth 2 (car h))) 'date)) |
| 1599 | (eq (car-safe (car h)) 'vec)) |
| 1600 | (setq days (cons (car h) days))) |
| 1601 | ((and (eq (car-safe (car h)) 'var) |
| 1602 | (assq (nth 1 (car h)) wdnames)) |
| 1603 | (setq weekdays (cons (cdr (assq (nth 1 (car h)) wdnames)) |
| 1604 | weekdays))) |
| 1605 | ((and (eq (car-safe (car h)) 'intv) |
| 1606 | (eq (car-safe (nth 2 (car h))) 'hms) |
| 1607 | (eq (car-safe (nth 3 (car h))) 'hms)) |
| 1608 | (if hours |
| 1609 | (math-reject-arg |
| 1610 | (car h) "*Only one hours interval allowed in Holidays")) |
| 1611 | (setq hours (math-div (car h) '(hms 24 0 0))) |
| 1612 | (if (or (Math-lessp (nth 2 hours) 0) |
| 1613 | (Math-lessp 1 (nth 3 hours))) |
| 1614 | (math-reject-arg |
| 1615 | (car h) "*Hours interval out of range")) |
| 1616 | (setq hours (cons (nth 2 hours) |
| 1617 | (math-sub (nth 3 hours) (nth 2 hours)))) |
| 1618 | (if (Math-zerop (cdr hours)) |
| 1619 | (math-reject-arg |
| 1620 | (car h) "*Degenerate hours interval"))) |
| 1621 | ((or (and (eq (car-safe (car h)) 'intv) |
| 1622 | (Math-integerp (nth 2 (car h))) |
| 1623 | (Math-integerp (nth 3 (car h)))) |
| 1624 | (and (integerp (car h)) |
| 1625 | (> (car h) 1900) (< (car h) 2100))) |
| 1626 | (if limit |
| 1627 | (math-reject-arg |
| 1628 | (car h) "*Only one limit allowed in Holidays")) |
| 1629 | (setq limit (calcFunc-vint (car h) '(intv 3 1 2737))) |
| 1630 | (if (equal limit '(vec)) |
| 1631 | (math-reject-arg (car h) "*Limit is out of range"))) |
| 1632 | ((or (math-expr-contains (car h) '(var y var-y)) |
| 1633 | (math-expr-contains (car h) '(var m var-m))) |
| 1634 | (setq exprs (cons (car h) exprs))) |
| 1635 | (t (math-reject-arg |
| 1636 | (car h) "*Holidays must contain a vector of holidays")))) |
| 1637 | (if (= (length weekdays) 7) |
| 1638 | (math-reject-arg nil "*Too many weekend days")) |
| 1639 | (setq math-holidays-cache (list (list -1) ; 0: days list |
| 1640 | (list -1) ; 1: inverse-days list |
| 1641 | nil ; 2: exprs |
| 1642 | (sort weekdays '<) |
| 1643 | (or limit '(intv 3 1 2737)) |
| 1644 | nil ; 5: (lo.hi) expanded years |
| 1645 | (cons exprs days) |
| 1646 | hours) ; 7: business hours |
| 1647 | math-holidays-cache-tag (calc-var-value 'var-Holidays)))) |
| 1648 | (if date |
| 1649 | (let ((year (calcFunc-year date)) |
| 1650 | (limits (nth 5 math-holidays-cache)) |
| 1651 | (done nil)) |
| 1652 | (or (eq (calcFunc-in year (nth 4 math-holidays-cache)) 1) |
| 1653 | (progn |
| 1654 | (or (eq (car-safe date) 'date) (setq date (list 'date date))) |
| 1655 | (math-reject-arg date "*Date is outside valid range"))) |
| 1656 | (unwind-protect |
| 1657 | (let ((days (nth 6 math-holidays-cache))) |
| 1658 | (if days |
| 1659 | (let ((year nil)) ; see below |
| 1660 | (setcar (nthcdr 6 math-holidays-cache) nil) |
| 1661 | (math-setup-add-holidays (cons 'vec (cdr days))) |
| 1662 | (setcar (nthcdr 2 math-holidays-cache) (car days)))) |
| 1663 | (cond ((not (nth 2 math-holidays-cache)) |
| 1664 | (setq done t) |
| 1665 | nil) |
| 1666 | ((not limits) |
| 1667 | (setcar (nthcdr 5 math-holidays-cache) (cons year year)) |
| 1668 | (math-setup-year-holidays year) |
| 1669 | (setq done t)) |
| 1670 | ((< year (car limits)) |
| 1671 | (message "Computing holidays, %d .. %d" |
| 1672 | year (1- (car limits))) |
| 1673 | (calc-set-command-flag 'clear-message) |
| 1674 | (while (< year (car limits)) |
| 1675 | (setcar limits (1- (car limits))) |
| 1676 | (math-setup-year-holidays (car limits))) |
| 1677 | (setq done t)) |
| 1678 | ((> year (cdr limits)) |
| 1679 | (message "Computing holidays, %d .. %d" |
| 1680 | (1+ (cdr limits)) year) |
| 1681 | (calc-set-command-flag 'clear-message) |
| 1682 | (while (> year (cdr limits)) |
| 1683 | (setcdr limits (1+ (cdr limits))) |
| 1684 | (math-setup-year-holidays (cdr limits))) |
| 1685 | (setq done t)) |
| 1686 | (t |
| 1687 | (setq done t) |
| 1688 | nil))) |
| 1689 | (or done (setq math-holidays-cache-tag t))))) |
| 1690 | ) |
| 1691 | |
| 1692 | (defun math-setup-year-holidays (year) |
| 1693 | (let ((exprs (nth 2 math-holidays-cache))) |
| 1694 | (while exprs |
| 1695 | (let* ((var-y year) |
| 1696 | (var-m nil) |
| 1697 | (expr (math-evaluate-expr (car exprs)))) |
| 1698 | (if (math-expr-contains expr '(var m var-m)) |
| 1699 | (let ((var-m 0)) |
| 1700 | (while (<= (setq var-m (1+ var-m)) 12) |
| 1701 | (math-setup-add-holidays (math-evaluate-expr expr)))) |
| 1702 | (math-setup-add-holidays expr))) |
| 1703 | (setq exprs (cdr exprs)))) |
| 1704 | ) |
| 1705 | |
| 1706 | (defun math-setup-add-holidays (days) ; uses "year" |
| 1707 | (cond ((eq (car-safe days) 'vec) |
| 1708 | (while (setq days (cdr days)) |
| 1709 | (math-setup-add-holidays (car days)))) |
| 1710 | ((eq (car-safe days) 'intv) |
| 1711 | (let ((day (math-ceiling (nth 2 days)))) |
| 1712 | (or (eq (calcFunc-in day days) 1) |
| 1713 | (setq day (math-add day 1))) |
| 1714 | (while (eq (calcFunc-in day days) 1) |
| 1715 | (math-setup-add-holidays day) |
| 1716 | (setq day (math-add day 1))))) |
| 1717 | ((eq (car-safe days) 'date) |
| 1718 | (math-setup-add-holidays (nth 1 days))) |
| 1719 | ((eq days 0)) |
| 1720 | ((integerp days) |
| 1721 | (let ((b (math-to-business-day days year))) |
| 1722 | (or (cdr b) ; don't register holidays twice! |
| 1723 | (let ((prev (car math-holidays-cache)) |
| 1724 | (iprev (nth 1 math-holidays-cache))) |
| 1725 | (while (and (cdr prev) (< (nth 1 prev) days)) |
| 1726 | (setq prev (cdr prev) iprev (cdr iprev))) |
| 1727 | (setcdr prev (cons days (cdr prev))) |
| 1728 | (setcdr iprev (cons (car b) (cdr iprev))) |
| 1729 | (while (setq iprev (cdr iprev)) |
| 1730 | (setcar iprev (1- (car iprev)))))))) |
| 1731 | ((Math-realp days) |
| 1732 | (math-reject-arg (list 'date days) "*Invalid holiday value")) |
| 1733 | (t |
| 1734 | (math-reject-arg days "*Holiday formula failed to evaluate"))) |
| 1735 | ) |
| 1736 | |
| 1737 | |
| 1738 | |
| 1739 | |
| 1740 | ;;;; Error forms. |
| 1741 | |
| 1742 | ;;; Build a standard deviation form. [X X X] |
| 1743 | (defun math-make-sdev (x sigma) |
| 1744 | (if (memq (car-safe x) '(date mod sdev intv vec)) |
| 1745 | (math-reject-arg x 'realp)) |
| 1746 | (if (memq (car-safe sigma) '(date mod sdev intv vec)) |
| 1747 | (math-reject-arg sigma 'realp)) |
| 1748 | (if (or (Math-negp sigma) (memq (car-safe sigma) '(cplx polar))) |
| 1749 | (setq sigma (math-abs sigma))) |
| 1750 | (if (and (Math-zerop sigma) (Math-scalarp x)) |
| 1751 | x |
| 1752 | (list 'sdev x sigma)) |
| 1753 | ) |
| 1754 | (defun calcFunc-sdev (x sigma) |
| 1755 | (math-make-sdev x sigma) |
| 1756 | ) |
| 1757 | |
| 1758 | |
| 1759 | |
| 1760 | ;;;; Modulo forms. |
| 1761 | |
| 1762 | (defun math-normalize-mod (a) |
| 1763 | (let ((n (math-normalize (nth 1 a))) |
| 1764 | (m (math-normalize (nth 2 a)))) |
| 1765 | (if (and (math-anglep n) (math-anglep m) (math-posp m)) |
| 1766 | (math-make-mod n m) |
| 1767 | (math-normalize (list 'calcFunc-makemod n m)))) |
| 1768 | ) |
| 1769 | |
| 1770 | ;;; Build a modulo form. [N R R] |
| 1771 | (defun math-make-mod (n m) |
| 1772 | (setq calc-previous-modulo m) |
| 1773 | (and n |
| 1774 | (cond ((not (Math-anglep m)) |
| 1775 | (math-reject-arg m 'anglep)) |
| 1776 | ((not (math-posp m)) |
| 1777 | (math-reject-arg m 'posp)) |
| 1778 | ((Math-anglep n) |
| 1779 | (if (or (Math-negp n) |
| 1780 | (not (Math-lessp n m))) |
| 1781 | (list 'mod (math-mod n m) m) |
| 1782 | (list 'mod n m))) |
| 1783 | ((memq (car n) '(+ - / vec neg)) |
| 1784 | (math-normalize |
| 1785 | (cons (car n) |
| 1786 | (mapcar (function (lambda (x) (math-make-mod x m))) |
| 1787 | (cdr n))))) |
| 1788 | ((and (eq (car n) '*) (Math-anglep (nth 1 n))) |
| 1789 | (math-mul (math-make-mod (nth 1 n) m) (nth 2 n))) |
| 1790 | ((memq (car n) '(* ^ var calcFunc-subscr)) |
| 1791 | (math-mul (math-make-mod 1 m) n)) |
| 1792 | (t (math-reject-arg n 'anglep)))) |
| 1793 | ) |
| 1794 | (defun calcFunc-makemod (n m) |
| 1795 | (math-make-mod n m) |
| 1796 | ) |
| 1797 | |
| 1798 | |
| 1799 | |
| 1800 | ;;;; Interval forms. |
| 1801 | |
| 1802 | ;;; Build an interval form. [X S X X] |
| 1803 | (defun math-make-intv (mask lo hi) |
| 1804 | (if (memq (car-safe lo) '(cplx polar mod sdev intv vec)) |
| 1805 | (math-reject-arg lo 'realp)) |
| 1806 | (if (memq (car-safe hi) '(cplx polar mod sdev intv vec)) |
| 1807 | (math-reject-arg hi 'realp)) |
| 1808 | (or (eq (eq (car-safe lo) 'date) (eq (car-safe hi) 'date)) |
| 1809 | (math-reject-arg (if (eq (car-safe lo) 'date) hi lo) 'datep)) |
| 1810 | (if (and (or (Math-realp lo) (eq (car lo) 'date)) |
| 1811 | (or (Math-realp hi) (eq (car hi) 'date))) |
| 1812 | (let ((cmp (math-compare lo hi))) |
| 1813 | (if (= cmp 0) |
| 1814 | (if (= mask 3) |
| 1815 | lo |
| 1816 | (list 'intv mask lo hi)) |
| 1817 | (if (> cmp 0) |
| 1818 | (if (= mask 3) |
| 1819 | (list 'intv 2 lo lo) |
| 1820 | (list 'intv mask lo lo)) |
| 1821 | (list 'intv mask lo hi)))) |
| 1822 | (list 'intv mask lo hi)) |
| 1823 | ) |
| 1824 | (defun calcFunc-intv (mask lo hi) |
| 1825 | (if (math-messy-integerp mask) (setq mask (math-trunc mask))) |
| 1826 | (or (natnump mask) (math-reject-arg mask 'fixnatnump)) |
| 1827 | (or (<= mask 3) (math-reject-arg mask 'range)) |
| 1828 | (math-make-intv mask lo hi) |
| 1829 | ) |
| 1830 | |
| 1831 | (defun math-sort-intv (mask lo hi) |
| 1832 | (if (Math-lessp hi lo) |
| 1833 | (math-make-intv (aref [0 2 1 3] mask) hi lo) |
| 1834 | (math-make-intv mask lo hi)) |
| 1835 | ) |
| 1836 | |
| 1837 | |
| 1838 | |
| 1839 | |
| 1840 | (defun math-combine-intervals (a am b bm c cm d dm) |
| 1841 | (let (res) |
| 1842 | (if (= (setq res (math-compare a c)) 1) |
| 1843 | (setq a c am cm) |
| 1844 | (if (= res 0) |
| 1845 | (setq am (or am cm)))) |
| 1846 | (if (= (setq res (math-compare b d)) -1) |
| 1847 | (setq b d bm dm) |
| 1848 | (if (= res 0) |
| 1849 | (setq bm (or bm dm)))) |
| 1850 | (math-make-intv (+ (if am 2 0) (if bm 1 0)) a b)) |
| 1851 | ) |
| 1852 | |
| 1853 | |
| 1854 | (defun math-div-mod (a b m) ; [R R R R] (Returns nil if no solution) |
| 1855 | (and (Math-integerp a) (Math-integerp b) (Math-integerp m) |
| 1856 | (let ((u1 1) (u3 b) (v1 0) (v3 m)) |
| 1857 | (while (not (eq v3 0)) ; See Knuth sec 4.5.2, exercise 15 |
| 1858 | (let* ((q (math-idivmod u3 v3)) |
| 1859 | (t1 (math-sub u1 (math-mul v1 (car q))))) |
| 1860 | (setq u1 v1 u3 v3 v1 t1 v3 (cdr q)))) |
| 1861 | (let ((q (math-idivmod a u3))) |
| 1862 | (and (eq (cdr q) 0) |
| 1863 | (math-mod (math-mul (car q) u1) m))))) |
| 1864 | ) |
| 1865 | |
| 1866 | (defun math-mod-intv (a b) |
| 1867 | (let* ((q1 (math-floor (math-div (nth 2 a) b))) |
| 1868 | (q2 (math-floor (math-div (nth 3 a) b))) |
| 1869 | (m1 (math-sub (nth 2 a) (math-mul q1 b))) |
| 1870 | (m2 (math-sub (nth 3 a) (math-mul q2 b)))) |
| 1871 | (cond ((equal q1 q2) |
| 1872 | (math-sort-intv (nth 1 a) m1 m2)) |
| 1873 | ((and (math-equal-int (math-sub q2 q1) 1) |
| 1874 | (math-zerop m2) |
| 1875 | (memq (nth 1 a) '(0 2))) |
| 1876 | (math-make-intv (nth 1 a) m1 b)) |
| 1877 | (t |
| 1878 | (math-make-intv 2 0 b)))) |
| 1879 | ) |
| 1880 | |
| 1881 | |
| 1882 | (defun math-read-angle-brackets () |
| 1883 | (let* ((last (or (math-check-for-commas t) (length exp-str))) |
| 1884 | (str (substring exp-str exp-pos last)) |
| 1885 | (res |
| 1886 | (if (string-match "\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:" str) |
| 1887 | (let ((str1 (substring str 0 (1- (match-end 0)))) |
| 1888 | (str2 (substring str (match-end 0))) |
| 1889 | (calc-hashes-used 0)) |
| 1890 | (setq str1 (math-read-expr (concat "[" str1 "]"))) |
| 1891 | (if (eq (car-safe str1) 'error) |
| 1892 | str1 |
| 1893 | (setq str2 (math-read-expr str2)) |
| 1894 | (if (eq (car-safe str2) 'error) |
| 1895 | str2 |
| 1896 | (append '(calcFunc-lambda) (cdr str1) (list str2))))) |
| 1897 | (if (string-match "#" str) |
| 1898 | (let ((calc-hashes-used 0)) |
| 1899 | (and (setq str (math-read-expr str)) |
| 1900 | (if (eq (car-safe str) 'error) |
| 1901 | str |
| 1902 | (append '(calcFunc-lambda) |
| 1903 | (calc-invent-args calc-hashes-used) |
| 1904 | (list str))))) |
| 1905 | (math-parse-date str))))) |
| 1906 | (if (stringp res) |
| 1907 | (throw 'syntax res)) |
| 1908 | (if (eq (car-safe res) 'error) |
| 1909 | (throw 'syntax (nth 2 res))) |
| 1910 | (setq exp-pos (1+ last)) |
| 1911 | (math-read-token) |
| 1912 | res) |
| 1913 | ) |
| 1914 | |