1 |
;; Calculator for GNU Emacs, part II [calc-forms.el] |
;; Calculator for GNU Emacs, part II [calc-forms.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
39 |
(string-to-int (substring time 11 13)) |
(string-to-int (substring time 11 13)) |
40 |
(string-to-int (substring time 14 16)) |
(string-to-int (substring time 14 16)) |
41 |
(string-to-int (substring time 17 19))) |
(string-to-int (substring time 17 19))) |
42 |
(list 'hms 24 0 0))))) |
(list 'hms 24 0 0)))))) |
|
) |
|
|
|
|
|
|
|
|
|
|
43 |
|
|
44 |
(defun calc-to-hms (arg) |
(defun calc-to-hms (arg) |
45 |
(interactive "P") |
(interactive "P") |
48 |
(if (eq calc-angle-mode 'rad) |
(if (eq calc-angle-mode 'rad) |
49 |
(calc-unary-op ">rad" 'calcFunc-rad arg) |
(calc-unary-op ">rad" 'calcFunc-rad arg) |
50 |
(calc-unary-op ">deg" 'calcFunc-deg arg)) |
(calc-unary-op ">deg" 'calcFunc-deg arg)) |
51 |
(calc-unary-op ">hms" 'calcFunc-hms arg))) |
(calc-unary-op ">hms" 'calcFunc-hms arg)))) |
|
) |
|
52 |
|
|
53 |
(defun calc-from-hms (arg) |
(defun calc-from-hms (arg) |
54 |
(interactive "P") |
(interactive "P") |
55 |
(calc-invert-func) |
(calc-invert-func) |
56 |
(calc-to-hms arg) |
(calc-to-hms arg)) |
|
) |
|
57 |
|
|
58 |
|
|
59 |
(defun calc-hms-notation (fmt) |
(defun calc-hms-notation (fmt) |
69 |
"%s" (math-match-substring fmt 5)) |
"%s" (math-match-substring fmt 5)) |
70 |
t) |
t) |
71 |
(setq-default calc-hms-format calc-hms-format)) ; for minibuffer |
(setq-default calc-hms-format calc-hms-format)) ; for minibuffer |
72 |
(error "Bad hours-minutes-seconds format."))) |
(error "Bad hours-minutes-seconds format.")))) |
|
) |
|
73 |
|
|
74 |
(defun calc-date-notation (fmt arg) |
(defun calc-date-notation (fmt arg) |
75 |
(interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP") |
(interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP") |
147 |
(and lfmt (if time |
(and lfmt (if time |
148 |
(setq fullfmt (cons (nreverse lfmt) fullfmt)) |
(setq fullfmt (cons (nreverse lfmt) fullfmt)) |
149 |
(setq fullfmt (nconc lfmt fullfmt)))) |
(setq fullfmt (nconc lfmt fullfmt)))) |
150 |
(calc-change-mode 'calc-date-format (nreverse fullfmt) t))) |
(calc-change-mode 'calc-date-format (nreverse fullfmt) t)))) |
|
) |
|
151 |
|
|
152 |
|
|
153 |
(defun calc-hms-mode () |
(defun calc-hms-mode () |
154 |
(interactive) |
(interactive) |
155 |
(calc-wrapper |
(calc-wrapper |
156 |
(calc-change-mode 'calc-angle-mode 'hms) |
(calc-change-mode 'calc-angle-mode 'hms) |
157 |
(message "Angles measured in degrees-minutes-seconds.")) |
(message "Angles measured in degrees-minutes-seconds."))) |
|
) |
|
158 |
|
|
159 |
|
|
160 |
(defun calc-now (arg) |
(defun calc-now (arg) |
161 |
(interactive "P") |
(interactive "P") |
162 |
(calc-date-zero-args "now" 'calcFunc-now arg) |
(calc-date-zero-args "now" 'calcFunc-now arg)) |
|
) |
|
163 |
|
|
164 |
(defun calc-date-part (arg) |
(defun calc-date-part (arg) |
165 |
(interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ") |
(interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ") |
174 |
calcFunc-minute calcFunc-second |
calcFunc-minute calcFunc-second |
175 |
calcFunc-weekday calcFunc-yearday |
calcFunc-weekday calcFunc-yearday |
176 |
calcFunc-time)) |
calcFunc-time)) |
177 |
(calc-top-n 1)))) |
(calc-top-n 1))))) |
|
) |
|
178 |
|
|
179 |
(defun calc-date (arg) |
(defun calc-date (arg) |
180 |
(interactive "p") |
(interactive "p") |
181 |
(if (or (< arg 1) (> arg 6)) |
(if (or (< arg 1) (> arg 6)) |
182 |
(error "Between one and six arguments are allowed")) |
(error "Between one and six arguments are allowed")) |
183 |
(calc-wrapper |
(calc-wrapper |
184 |
(calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))) |
(calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg))))) |
|
) |
|
185 |
|
|
186 |
(defun calc-julian (arg) |
(defun calc-julian (arg) |
187 |
(interactive "P") |
(interactive "P") |
188 |
(calc-date-one-arg "juln" 'calcFunc-julian arg) |
(calc-date-one-arg "juln" 'calcFunc-julian arg)) |
|
) |
|
189 |
|
|
190 |
(defun calc-unix-time (arg) |
(defun calc-unix-time (arg) |
191 |
(interactive "P") |
(interactive "P") |
192 |
(calc-date-one-arg "unix" 'calcFunc-unixtime arg) |
(calc-date-one-arg "unix" 'calcFunc-unixtime arg)) |
|
) |
|
193 |
|
|
194 |
(defun calc-time-zone (arg) |
(defun calc-time-zone (arg) |
195 |
(interactive "P") |
(interactive "P") |
196 |
(calc-date-zero-args "zone" 'calcFunc-tzone arg) |
(calc-date-zero-args "zone" 'calcFunc-tzone arg)) |
|
) |
|
197 |
|
|
198 |
(defun calc-convert-time-zones (old &optional new) |
(defun calc-convert-time-zones (old &optional new) |
199 |
(interactive "sFrom time zone: ") |
(interactive "sFrom time zone: ") |
212 |
(if (eq (car-safe new) 'error) |
(if (eq (car-safe new) 'error) |
213 |
(error "Error in expression: " (nth 1 new))) |
(error "Error in expression: " (nth 1 new))) |
214 |
(calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv |
(calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv |
215 |
(calc-top-n 1) old new)))) |
(calc-top-n 1) old new))))) |
|
) |
|
216 |
|
|
217 |
(defun calc-new-week (arg) |
(defun calc-new-week (arg) |
218 |
(interactive "P") |
(interactive "P") |
219 |
(calc-date-one-arg "nwwk" 'calcFunc-newweek arg) |
(calc-date-one-arg "nwwk" 'calcFunc-newweek arg)) |
|
) |
|
220 |
|
|
221 |
(defun calc-new-month (arg) |
(defun calc-new-month (arg) |
222 |
(interactive "P") |
(interactive "P") |
223 |
(calc-date-one-arg "nwmn" 'calcFunc-newmonth arg) |
(calc-date-one-arg "nwmn" 'calcFunc-newmonth arg)) |
|
) |
|
224 |
|
|
225 |
(defun calc-new-year (arg) |
(defun calc-new-year (arg) |
226 |
(interactive "P") |
(interactive "P") |
227 |
(calc-date-one-arg "nwyr" 'calcFunc-newyear arg) |
(calc-date-one-arg "nwyr" 'calcFunc-newyear arg)) |
|
) |
|
228 |
|
|
229 |
(defun calc-inc-month (arg) |
(defun calc-inc-month (arg) |
230 |
(interactive "p") |
(interactive "p") |
231 |
(calc-date-one-arg "incm" 'calcFunc-incmonth arg) |
(calc-date-one-arg "incm" 'calcFunc-incmonth arg)) |
|
) |
|
232 |
|
|
233 |
(defun calc-business-days-plus (arg) |
(defun calc-business-days-plus (arg) |
234 |
(interactive "P") |
(interactive "P") |
235 |
(calc-wrapper |
(calc-wrapper |
236 |
(calc-binary-op "bus+" 'calcFunc-badd arg)) |
(calc-binary-op "bus+" 'calcFunc-badd arg))) |
|
) |
|
237 |
|
|
238 |
(defun calc-business-days-minus (arg) |
(defun calc-business-days-minus (arg) |
239 |
(interactive "P") |
(interactive "P") |
240 |
(calc-wrapper |
(calc-wrapper |
241 |
(calc-binary-op "bus-" 'calcFunc-bsub arg)) |
(calc-binary-op "bus-" 'calcFunc-bsub arg))) |
|
) |
|
242 |
|
|
243 |
(defun calc-date-zero-args (prefix func arg) |
(defun calc-date-zero-args (prefix func arg) |
244 |
(calc-wrapper |
(calc-wrapper |
246 |
(calc-enter-result 1 prefix (list func (calc-top-n 1))) |
(calc-enter-result 1 prefix (list func (calc-top-n 1))) |
247 |
(calc-enter-result 0 prefix (if arg |
(calc-enter-result 0 prefix (if arg |
248 |
(list func (prefix-numeric-value arg)) |
(list func (prefix-numeric-value arg)) |
249 |
(list func))))) |
(list func)))))) |
|
) |
|
250 |
|
|
251 |
(defun calc-date-one-arg (prefix func arg) |
(defun calc-date-one-arg (prefix func arg) |
252 |
(calc-wrapper |
(calc-wrapper |
255 |
(calc-enter-result 1 prefix (if arg |
(calc-enter-result 1 prefix (if arg |
256 |
(list func (calc-top-n 1) |
(list func (calc-top-n 1) |
257 |
(prefix-numeric-value arg)) |
(prefix-numeric-value arg)) |
258 |
(list func (calc-top-n 1)))))) |
(list func (calc-top-n 1))))))) |
|
) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
259 |
|
|
260 |
|
|
261 |
;;;; Hours-minutes-seconds forms. |
;;;; Hours-minutes-seconds forms. |
295 |
(<= (+ (math-numdigs (nth 1 s)) (nth 2 s)) |
(<= (+ (math-numdigs (nth 1 s)) (nth 2 s)) |
296 |
(- 2 calc-internal-prec))) |
(- 2 calc-internal-prec))) |
297 |
(setq s 0)) |
(setq s 0)) |
298 |
(list 'hms h m s)) |
(list 'hms h m s))) |
|
) |
|
299 |
|
|
300 |
;;; Convert A from ANG or current angular mode to HMS format. |
;;; Convert A from ANG or current angular mode to HMS format. |
301 |
(defun math-to-hms (a &optional ang) ; [X R] [Public] |
(defun math-to-hms (a &optional ang) ; [X R] [Public] |
320 |
(list 'hms |
(list 'hms |
321 |
(car hmd) |
(car hmd) |
322 |
(cdr hmd) |
(cdr hmd) |
323 |
(math-sub b (math-mul hm 60))))))) |
(math-sub b (math-mul hm 60)))))))) |
|
) |
|
324 |
(defun calcFunc-hms (h &optional m s) |
(defun calcFunc-hms (h &optional m s) |
325 |
(or (Math-realp h) (math-reject-arg h 'realp)) |
(or (Math-realp h) (math-reject-arg h 'realp)) |
326 |
(or m (setq m 0)) |
(or m (setq m 0)) |
334 |
(math-to-hms (math-add h |
(math-to-hms (math-add h |
335 |
(math-add (math-div (or m 0) 60) |
(math-add (math-div (or m 0) 60) |
336 |
(math-div (or s 0) 3600))) |
(math-div (or s 0) 3600))) |
337 |
'deg)) |
'deg))) |
|
) |
|
338 |
|
|
339 |
;;; Convert A from HMS format to ANG or current angular mode. |
;;; Convert A from HMS format to ANG or current angular mode. |
340 |
(defun math-from-hms (a &optional ang) ; [R X] [Public] |
(defun math-from-hms (a &optional ang) ; [R X] [Public] |
356 |
'(float 6 1)) |
'(float 6 1)) |
357 |
(nth 2 a)) |
(nth 2 a)) |
358 |
60) |
60) |
359 |
(nth 1 a)))) |
(nth 1 a))))) |
|
) |
|
|
|
|
|
|
|
360 |
|
|
361 |
;;;; Date forms. |
;;;; Date forms. |
362 |
|
|
406 |
(list year month day |
(list year month day |
407 |
(/ time 3600) |
(/ time 3600) |
408 |
(% (/ time 60) 60) |
(% (/ time 60) 60) |
409 |
(math-add (% time 60) (nth 2 parts))))) |
(math-add (% time 60) (nth 2 parts)))))) |
|
) |
|
410 |
|
|
411 |
(defun math-dt-to-date (dt) |
(defun math-dt-to-date (dt) |
412 |
(or (integerp (nth 1 dt)) |
(or (integerp (nth 1 dt)) |
424 |
(* (nth 4 dt) 60)) |
(* (nth 4 dt) 60)) |
425 |
(nth 5 dt)) |
(nth 5 dt)) |
426 |
'(float 864 2))) |
'(float 864 2))) |
427 |
date)) |
date))) |
|
) |
|
428 |
|
|
429 |
(defun math-date-parts (value &optional offset) |
(defun math-date-parts (value &optional offset) |
430 |
(let* ((date (math-floor value)) |
(let* ((date (math-floor value)) |
434 |
(ftime (math-floor time))) |
(ftime (math-floor time))) |
435 |
(list date |
(list date |
436 |
ftime |
ftime |
437 |
(math-sub time ftime))) |
(math-sub time ftime)))) |
|
) |
|
438 |
|
|
439 |
|
|
440 |
(defun math-this-year () |
(defun math-this-year () |
441 |
(string-to-int (substring (current-time-string) -4)) |
(string-to-int (substring (current-time-string) -4))) |
|
) |
|
442 |
|
|
443 |
(defun math-leap-year-p (year) |
(defun math-leap-year-p (year) |
444 |
(if (Math-lessp year 1752) |
(if (Math-lessp year 1752) |
447 |
(= (math-imod year 4) 0)) |
(= (math-imod year 4) 0)) |
448 |
(setq year (math-imod year 400)) |
(setq year (math-imod year 400)) |
449 |
(or (and (= (% year 4) 0) (/= (% year 100) 0)) |
(or (and (= (% year 4) 0) (/= (% year 100) 0)) |
450 |
(= year 0))) |
(= year 0)))) |
|
) |
|
451 |
|
|
452 |
(defun math-days-in-month (year month) |
(defun math-days-in-month (year month) |
453 |
(if (and (= month 2) (math-leap-year-p year)) |
(if (and (= month 2) (math-leap-year-p year)) |
454 |
29 |
29 |
455 |
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))) |
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) |
|
) |
|
456 |
|
|
457 |
(defun math-day-number (year month day) |
(defun math-day-number (year month day) |
458 |
(let ((day-of-year (+ day (* 31 (1- month))))) |
(let ((day-of-year (+ day (* 31 (1- month))))) |
465 |
(or (> month 9) |
(or (> month 9) |
466 |
(and (= month 9) (>= day 14))) |
(and (= month 9) (>= day 14))) |
467 |
(setq day-of-year (- day-of-year 11))) |
(setq day-of-year (- day-of-year 11))) |
468 |
day-of-year) |
day-of-year)) |
|
) |
|
469 |
|
|
470 |
(defun math-absolute-from-date (year month day) |
(defun math-absolute-from-date (year month day) |
471 |
(if (eq year 0) (setq year -1)) |
(if (eq year 0) (setq year -1)) |
485 |
(math-add (if (= (cdr res) 0) |
(math-add (if (= (cdr res) 0) |
486 |
-1 |
-1 |
487 |
0) |
0) |
488 |
(car res))))))) |
(car res)))))))) |
|
) |
|
489 |
|
|
490 |
|
|
491 |
;;; It is safe to redefine these in your .emacs file to use a different |
;;; It is safe to redefine these in your .emacs file to use a different |
520 |
math-format-date-cache)) |
math-format-date-cache)) |
521 |
(and (setq dt (nthcdr 10 math-format-date-cache)) |
(and (setq dt (nthcdr 10 math-format-date-cache)) |
522 |
(setcdr dt nil)) |
(setcdr dt nil)) |
523 |
fmt))) |
fmt)))) |
|
) |
|
524 |
(setq math-format-date-cache nil) |
(setq math-format-date-cache nil) |
525 |
|
|
526 |
(defun math-format-date-part (x) |
(defun math-format-date-part (x) |
686 |
(let ((calc-float-format |
(let ((calc-float-format |
687 |
(list 'fix (min (- 12 calc-internal-prec) |
(list 'fix (min (- 12 calc-internal-prec) |
688 |
0)))) |
0)))) |
689 |
(math-format-number second))))))) |
(math-format-number second)))))))) |
|
) |
|
690 |
|
|
691 |
|
|
692 |
(defun math-parse-date (str) |
(defun math-parse-date (str) |
834 |
(setq year (math-neg (math-abs year)))) |
(setq year (math-neg (math-abs year)))) |
835 |
|
|
836 |
(math-parse-date-validate year bigyear month day |
(math-parse-date-validate year bigyear month day |
837 |
hour minute second)))) |
hour minute second))))) |
|
) |
|
838 |
|
|
839 |
(defun math-parse-date-validate (year bigyear month day hour minute second) |
(defun math-parse-date-validate (year bigyear month day hour minute second) |
840 |
(and (not bigyear) (natnump year) (< year 100) |
(and (not bigyear) (natnump year) (< year 100) |
854 |
(if (or (math-negp second) (not (Math-lessp second 60))) |
(if (or (math-negp second) (not (Math-lessp second 60))) |
855 |
(throw 'syntax "Seconds value is out of range")))) |
(throw 'syntax "Seconds value is out of range")))) |
856 |
(list 'date (math-dt-to-date (append (list year month day) |
(list 'date (math-dt-to-date (append (list year month day) |
857 |
(and hour (list hour minute second))))) |
(and hour (list hour minute second)))))) |
|
) |
|
858 |
|
|
859 |
(defun math-parse-date-word (names &optional front) |
(defun math-parse-date-word (names &optional front) |
860 |
(let ((n 1)) |
(let ((n 1)) |
870 |
(setq str (concat (substring str 0 (match-beginning 0)) |
(setq str (concat (substring str 0 (match-beginning 0)) |
871 |
(if front "" " ") |
(if front "" " ") |
872 |
(substring str (match-end 0)))) |
(substring str (match-end 0)))) |
873 |
n))) |
n)))) |
|
) |
|
874 |
|
|
875 |
(defun math-parse-standard-date (str with-time) |
(defun math-parse-standard-date (str with-time) |
876 |
(let ((case-fold-search t) |
(let ((case-fold-search t) |
1028 |
hour minute second)) |
hour minute second)) |
1029 |
(if yearday |
(if yearday |
1030 |
(setq day (math-add day (1- yearday)))) |
(setq day (math-add day (1- yearday)))) |
1031 |
day)))) |
day))))) |
|
) |
|
1032 |
|
|
1033 |
|
|
1034 |
(defun calcFunc-now (&optional zone) |
(defun calcFunc-now (&optional zone) |
1041 |
'(float 864 2))) |
'(float 864 2))) |
1042 |
date) |
date) |
1043 |
(calc-record-why "*Unable to interpret current date from system") |
(calc-record-why "*Unable to interpret current date from system") |
1044 |
(append (list 'calcFunc-now) (and zone (list zone))))) |
(append (list 'calcFunc-now) (and zone (list zone)))))) |
|
) |
|
1045 |
|
|
1046 |
(defun calcFunc-year (date) |
(defun calcFunc-year (date) |
1047 |
(car (math-date-to-dt date)) |
(car (math-date-to-dt date))) |
|
) |
|
1048 |
|
|
1049 |
(defun calcFunc-month (date) |
(defun calcFunc-month (date) |
1050 |
(nth 1 (math-date-to-dt date)) |
(nth 1 (math-date-to-dt date))) |
|
) |
|
1051 |
|
|
1052 |
(defun calcFunc-day (date) |
(defun calcFunc-day (date) |
1053 |
(nth 2 (math-date-to-dt date)) |
(nth 2 (math-date-to-dt date))) |
|
) |
|
1054 |
|
|
1055 |
(defun calcFunc-weekday (date) |
(defun calcFunc-weekday (date) |
1056 |
(if (eq (car-safe date) 'date) |
(if (eq (car-safe date) 'date) |
1057 |
(setq date (nth 1 date))) |
(setq date (nth 1 date))) |
1058 |
(or (math-realp date) |
(or (math-realp date) |
1059 |
(math-reject-arg date 'datep)) |
(math-reject-arg date 'datep)) |
1060 |
(math-mod (math-add (math-floor date) 6) 7) |
(math-mod (math-add (math-floor date) 6) 7)) |
|
) |
|
1061 |
|
|
1062 |
(defun calcFunc-yearday (date) |
(defun calcFunc-yearday (date) |
1063 |
(let ((dt (math-date-to-dt date))) |
(let ((dt (math-date-to-dt date))) |
1064 |
(math-day-number (car dt) (nth 1 dt) (nth 2 dt))) |
(math-day-number (car dt) (nth 1 dt) (nth 2 dt)))) |
|
) |
|
1065 |
|
|
1066 |
(defun calcFunc-hour (date) |
(defun calcFunc-hour (date) |
1067 |
(if (eq (car-safe date) 'hms) |
(if (eq (car-safe date) 'hms) |
1068 |
(nth 1 date) |
(nth 1 date) |
1069 |
(or (nth 3 (math-date-to-dt date)) 0)) |
(or (nth 3 (math-date-to-dt date)) 0))) |
|
) |
|
1070 |
|
|
1071 |
(defun calcFunc-minute (date) |
(defun calcFunc-minute (date) |
1072 |
(if (eq (car-safe date) 'hms) |
(if (eq (car-safe date) 'hms) |
1073 |
(nth 2 date) |
(nth 2 date) |
1074 |
(or (nth 4 (math-date-to-dt date)) 0)) |
(or (nth 4 (math-date-to-dt date)) 0))) |
|
) |
|
1075 |
|
|
1076 |
(defun calcFunc-second (date) |
(defun calcFunc-second (date) |
1077 |
(if (eq (car-safe date) 'hms) |
(if (eq (car-safe date) 'hms) |
1078 |
(nth 3 date) |
(nth 3 date) |
1079 |
(or (nth 5 (math-date-to-dt date)) 0)) |
(or (nth 5 (math-date-to-dt date)) 0))) |
|
) |
|
1080 |
|
|
1081 |
(defun calcFunc-time (date) |
(defun calcFunc-time (date) |
1082 |
(let ((dt (math-date-to-dt date))) |
(let ((dt (math-date-to-dt date))) |
1083 |
(if (nth 3 dt) |
(if (nth 3 dt) |
1084 |
(cons 'hms (nthcdr 3 dt)) |
(cons 'hms (nthcdr 3 dt)) |
1085 |
(list 'hms 0 0 0))) |
(list 'hms 0 0 0)))) |
|
) |
|
1086 |
|
|
1087 |
(defun calcFunc-date (date &optional month day hour minute second) |
(defun calcFunc-date (date &optional month day hour minute second) |
1088 |
(and (math-messy-integerp month) (setq month (math-trunc month))) |
(and (math-messy-integerp month) (setq month (math-trunc month))) |
1114 |
(list 'date date) |
(list 'date date) |
1115 |
(if (eq (car date) 'date) |
(if (eq (car date) 'date) |
1116 |
(nth 1 date) |
(nth 1 date) |
1117 |
(math-reject-arg date 'datep)))) |
(math-reject-arg date 'datep))))) |
|
) |
|
1118 |
|
|
1119 |
(defun calcFunc-julian (date &optional zone) |
(defun calcFunc-julian (date &optional zone) |
1120 |
(if (math-realp date) |
(if (math-realp date) |
1129 |
(math-add '(float (bigpos 235 214 17) -1) |
(math-add '(float (bigpos 235 214 17) -1) |
1130 |
(math-div (calcFunc-tzone zone date) |
(math-div (calcFunc-tzone zone date) |
1131 |
'(float 864 2))))) |
'(float 864 2))))) |
1132 |
(math-reject-arg date 'datep))) |
(math-reject-arg date 'datep)))) |
|
) |
|
1133 |
|
|
1134 |
(defun calcFunc-unixtime (date &optional zone) |
(defun calcFunc-unixtime (date &optional zone) |
1135 |
(if (math-realp date) |
(if (math-realp date) |
1140 |
(if (eq (car date) 'date) |
(if (eq (car date) 'date) |
1141 |
(math-add (nth 1 (math-date-parts (nth 1 date) 719164)) |
(math-add (nth 1 (math-date-parts (nth 1 date) 719164)) |
1142 |
(calcFunc-tzone zone date)) |
(calcFunc-tzone zone date)) |
1143 |
(math-reject-arg date 'datep))) |
(math-reject-arg date 'datep)))) |
|
) |
|
1144 |
|
|
1145 |
(defun calcFunc-tzone (&optional zone date) |
(defun calcFunc-tzone (&optional zone date) |
1146 |
(if zone |
(if zone |
1218 |
(kill-buffer " *Calc Temporary*") |
(kill-buffer " *Calc Temporary*") |
1219 |
(setq var-TimeZone tz) |
(setq var-TimeZone tz) |
1220 |
(calc-refresh-evaltos 'var-TimeZone) |
(calc-refresh-evaltos 'var-TimeZone) |
1221 |
(calcFunc-tzone tz date)))) |
(calcFunc-tzone tz date))))) |
|
) |
|
1222 |
|
|
1223 |
;;; Note: Longer names must appear before shorter names which are |
;;; Note: Longer names must appear before shorter names which are |
1224 |
;;; substrings of them. |
;;; substrings of them. |
1255 |
(setq date (math-float date)) |
(setq date (math-float date)) |
1256 |
(or dt (setq dt (math-date-to-dt date))) |
(or dt (setq dt (math-date-to-dt date))) |
1257 |
(and math-daylight-savings-hook |
(and math-daylight-savings-hook |
1258 |
(funcall math-daylight-savings-hook date dt zone bump))) |
(funcall math-daylight-savings-hook date dt zone bump)))) |
|
) |
|
1259 |
|
|
1260 |
(defun calcFunc-dsadj (date &optional zone) |
(defun calcFunc-dsadj (date &optional zone) |
1261 |
(if zone |
(if zone |
1271 |
(or zadj (math-reject-arg zone "*Unrecognized time zone name")) |
(or zadj (math-reject-arg zone "*Unrecognized time zone name")) |
1272 |
(if (integerp (nth 2 zadj)) |
(if (integerp (nth 2 zadj)) |
1273 |
(nth 2 zadj) |
(nth 2 zadj) |
1274 |
(math-daylight-savings-adjust date zone))) |
(math-daylight-savings-adjust date zone)))) |
|
) |
|
1275 |
|
|
1276 |
(defun calcFunc-tzconv (date z1 z2) |
(defun calcFunc-tzconv (date z1 z2) |
1277 |
(if (math-realp date) |
(if (math-realp date) |
1278 |
(nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) |
(nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) |
1279 |
(calcFunc-unixtime (calcFunc-unixtime date z1) z2)) |
(calcFunc-unixtime (calcFunc-unixtime date z1) z2))) |
|
) |
|
1280 |
|
|
1281 |
(defvar math-daylight-savings-hook 'math-std-daylight-savings) |
(defvar math-daylight-savings-hook 'math-std-daylight-savings) |
1282 |
|
|
1299 |
((= (nth 2 dt) sunday) |
((= (nth 2 dt) sunday) |
1300 |
(if (>= (nth 3 dt) (+ 2 bump)) 0 -1)) |
(if (>= (nth 3 dt) (+ 2 bump)) 0 -1)) |
1301 |
(t 0)))) |
(t 0)))) |
1302 |
(t 0)) |
(t 0))) |
|
) |
|
1303 |
|
|
1304 |
;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given |
;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given |
1305 |
;;; day of the given month. |
;;; day of the given month. |
1308 |
(if (> day (math-days-in-month (car dt) (nth 1 dt))) |
(if (> day (math-days-in-month (car dt) (nth 1 dt))) |
1309 |
(setq day (math-days-in-month (car dt) (nth 1 dt)))) |
(setq day (math-days-in-month (car dt) (nth 1 dt)))) |
1310 |
(let ((zeroth (math-sub (math-floor date) (nth 2 dt)))) |
(let ((zeroth (math-sub (math-floor date) (nth 2 dt)))) |
1311 |
(math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth)) |
(math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth))) |
|
) |
|
1312 |
|
|
1313 |
(defun calcFunc-pwday (date &optional day weekday) |
(defun calcFunc-pwday (date &optional day weekday) |
1314 |
(if (eq (car-safe date) 'date) |
(if (eq (car-safe date) 'date) |
1319 |
(or (integerp day) (math-reject-arg day 'fixnump)) |
(or (integerp day) (math-reject-arg day 'fixnump)) |
1320 |
(if (= day 0) (setq day 31)) |
(if (= day 0) (setq day 31)) |
1321 |
(and (or (< day 7) (> day 31)) (math-reject-arg day 'range)) |
(and (or (< day 7) (> day 31)) (math-reject-arg day 'range)) |
1322 |
(math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0)) |
(math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0))) |
|
) |
|
1323 |
|
|
1324 |
|
|
1325 |
(defun calcFunc-newweek (date &optional weekday) |
(defun calcFunc-newweek (date &optional weekday) |
1332 |
(or (integerp weekday) (math-reject-arg weekday 'fixnump)) |
(or (integerp weekday) (math-reject-arg weekday 'fixnump)) |
1333 |
(and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range)) |
(and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range)) |
1334 |
(setq date (math-floor date)) |
(setq date (math-floor date)) |
1335 |
(list 'date (math-sub date (calcFunc-weekday (math-sub date weekday)))) |
(list 'date (math-sub date (calcFunc-weekday (math-sub date weekday))))) |
|
) |
|
1336 |
|
|
1337 |
(defun calcFunc-newmonth (date &optional day) |
(defun calcFunc-newmonth (date &optional day) |
1338 |
(or day (setq day 1)) |
(or day (setq day 1)) |
1345 |
(and (eq (car dt) 1752) (= (nth 1 dt) 9) |
(and (eq (car dt) 1752) (= (nth 1 dt) 9) |
1346 |
(if (>= day 14) (setq day (- day 11)))) |
(if (>= day 14) (setq day (- day 11)))) |
1347 |
(list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) |
(list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) |
1348 |
(1- day)))) |
(1- day))))) |
|
) |
|
1349 |
|
|
1350 |
(defun calcFunc-newyear (date &optional day) |
(defun calcFunc-newyear (date &optional day) |
1351 |
(or day (setq day 1)) |
(or day (setq day 1)) |
1360 |
(1- day)))) |
(1- day)))) |
1361 |
(if (and (>= day -12) (<= day -1)) |
(if (and (>= day -12) (<= day -1)) |
1362 |
(list 'date (math-dt-to-date (list (car dt) (- day) 1))) |
(list 'date (math-dt-to-date (list (car dt) (- day) 1))) |
1363 |
(math-reject-arg day 'range)))) |
(math-reject-arg day 'range))))) |
|
) |
|
1364 |
|
|
1365 |
(defun calcFunc-incmonth (date &optional step) |
(defun calcFunc-incmonth (date &optional step) |
1366 |
(or step (setq step 1)) |
(or step (setq step 1)) |
1379 |
(and (math-negp (car dt)) (not (math-negp year)) |
(and (math-negp (car dt)) (not (math-negp year)) |
1380 |
(setq year (math-add year 1))) |
(setq year (math-add year 1))) |
1381 |
(list 'date (math-dt-to-date |
(list 'date (math-dt-to-date |
1382 |
(cons year (cons month (cons day (cdr (cdr (cdr dt))))))))) |
(cons year (cons month (cons day (cdr (cdr (cdr dt)))))))))) |
|
) |
|
1383 |
|
|
1384 |
(defun calcFunc-incyear (date &optional step) |
(defun calcFunc-incyear (date &optional step) |
1385 |
(calcFunc-incmonth date (math-mul (or step 1) 12)) |
(calcFunc-incmonth date (math-mul (or step 1) 12))) |
|
) |
|
1386 |
|
|
1387 |
|
|
1388 |
|
|
1397 |
(db (math-to-business-day b))) |
(db (math-to-business-day b))) |
1398 |
(math-add (math-sub (car da) (car db)) |
(math-add (math-sub (car da) (car db)) |
1399 |
(if (and (cdr db) (not (cdr da))) 1 0)))) |
(if (and (cdr db) (not (cdr da))) 1 0)))) |
1400 |
(calcFunc-badd a (math-neg b))) |
(calcFunc-badd a (math-neg b)))) |
|
) |
|
1401 |
|
|
1402 |
(defun calcFunc-badd (a b) |
(defun calcFunc-badd (a b) |
1403 |
(if (eq (car-safe b) 'date) |
(if (eq (car-safe b) 'date) |
1421 |
(setq b (math-div b (cdr hours)))) |
(setq b (math-div b (cdr hours)))) |
1422 |
(calcFunc-badd a b)) |
(calcFunc-badd a b)) |
1423 |
(math-reject-arg nil "*Illegal combination in date arithmetic"))) |
(math-reject-arg nil "*Illegal combination in date arithmetic"))) |
1424 |
(math-reject-arg a 'datep))) |
(math-reject-arg a 'datep)))) |
|
) |
|
1425 |
|
|
1426 |
(defun calcFunc-holiday (a) |
(defun calcFunc-holiday (a) |
1427 |
(if (cdr (math-to-business-day a)) 1 0) |
(if (cdr (math-to-business-day a)) 1 0)) |
|
) |
|
1428 |
|
|
1429 |
|
|
1430 |
(setq math-holidays-cache nil) |
(setq math-holidays-cache nil) |
1469 |
(setq time |
(setq time |
1470 |
(math-sub 1 |
(math-sub 1 |
1471 |
(math-div 1 (math-mul 86400 (cdr hours))))))))) |
(math-div 1 (math-mul 86400 (cdr hours))))))))) |
1472 |
(cons (math-add (math-sub day delta) time) holiday)) |
(cons (math-add (math-sub day delta) time) holiday))) |
|
) |
|
1473 |
|
|
1474 |
|
|
1475 |
;;; Compute the date a certain number of business days since Jan 1, 1 AD. |
;;; Compute the date a certain number of business days since Jan 1, 1 AD. |
1500 |
(if hours |
(if hours |
1501 |
(setq time (math-add (math-mul time (cdr hours)) (car hours))))) |
(setq time (math-add (math-mul time (cdr hours)) (car hours))))) |
1502 |
(and (not (math-setup-holidays day)) |
(and (not (math-setup-holidays day)) |
1503 |
(list 'date (math-add day time))))) |
(list 'date (math-add day time)))))) |
|
) |
|
1504 |
|
|
1505 |
|
|
1506 |
(defun math-setup-holidays (&optional date) |
(defun math-setup-holidays (&optional date) |
1606 |
(t |
(t |
1607 |
(setq done t) |
(setq done t) |
1608 |
nil))) |
nil))) |
1609 |
(or done (setq math-holidays-cache-tag t))))) |
(or done (setq math-holidays-cache-tag t)))))) |
|
) |
|
1610 |
|
|
1611 |
(defun math-setup-year-holidays (year) |
(defun math-setup-year-holidays (year) |
1612 |
(let ((exprs (nth 2 math-holidays-cache))) |
(let ((exprs (nth 2 math-holidays-cache))) |
1619 |
(while (<= (setq var-m (1+ var-m)) 12) |
(while (<= (setq var-m (1+ var-m)) 12) |
1620 |
(math-setup-add-holidays (math-evaluate-expr expr)))) |
(math-setup-add-holidays (math-evaluate-expr expr)))) |
1621 |
(math-setup-add-holidays expr))) |
(math-setup-add-holidays expr))) |
1622 |
(setq exprs (cdr exprs)))) |
(setq exprs (cdr exprs))))) |
|
) |
|
1623 |
|
|
1624 |
(defun math-setup-add-holidays (days) ; uses "year" |
(defun math-setup-add-holidays (days) ; uses "year" |
1625 |
(cond ((eq (car-safe days) 'vec) |
(cond ((eq (car-safe days) 'vec) |
1649 |
((Math-realp days) |
((Math-realp days) |
1650 |
(math-reject-arg (list 'date days) "*Invalid holiday value")) |
(math-reject-arg (list 'date days) "*Invalid holiday value")) |
1651 |
(t |
(t |
1652 |
(math-reject-arg days "*Holiday formula failed to evaluate"))) |
(math-reject-arg days "*Holiday formula failed to evaluate")))) |
|
) |
|
1653 |
|
|
1654 |
|
|
1655 |
|
|
1666 |
(setq sigma (math-abs sigma))) |
(setq sigma (math-abs sigma))) |
1667 |
(if (and (Math-zerop sigma) (Math-scalarp x)) |
(if (and (Math-zerop sigma) (Math-scalarp x)) |
1668 |
x |
x |
1669 |
(list 'sdev x sigma)) |
(list 'sdev x sigma))) |
|
) |
|
1670 |
(defun calcFunc-sdev (x sigma) |
(defun calcFunc-sdev (x sigma) |
1671 |
(math-make-sdev x sigma) |
(math-make-sdev x sigma)) |
|
) |
|
1672 |
|
|
1673 |
|
|
1674 |
|
|
1679 |
(m (math-normalize (nth 2 a)))) |
(m (math-normalize (nth 2 a)))) |
1680 |
(if (and (math-anglep n) (math-anglep m) (math-posp m)) |
(if (and (math-anglep n) (math-anglep m) (math-posp m)) |
1681 |
(math-make-mod n m) |
(math-make-mod n m) |
1682 |
(math-normalize (list 'calcFunc-makemod n m)))) |
(math-normalize (list 'calcFunc-makemod n m))))) |
|
) |
|
1683 |
|
|
1684 |
;;; Build a modulo form. [N R R] |
;;; Build a modulo form. [N R R] |
1685 |
(defun math-make-mod (n m) |
(defun math-make-mod (n m) |
1703 |
(math-mul (math-make-mod (nth 1 n) m) (nth 2 n))) |
(math-mul (math-make-mod (nth 1 n) m) (nth 2 n))) |
1704 |
((memq (car n) '(* ^ var calcFunc-subscr)) |
((memq (car n) '(* ^ var calcFunc-subscr)) |
1705 |
(math-mul (math-make-mod 1 m) n)) |
(math-mul (math-make-mod 1 m) n)) |
1706 |
(t (math-reject-arg n 'anglep)))) |
(t (math-reject-arg n 'anglep))))) |
|
) |
|
1707 |
(defun calcFunc-makemod (n m) |
(defun calcFunc-makemod (n m) |
1708 |
(math-make-mod n m) |
(math-make-mod n m)) |
|
) |
|
1709 |
|
|
1710 |
|
|
1711 |
|
|
1731 |
(list 'intv 2 lo lo) |
(list 'intv 2 lo lo) |
1732 |
(list 'intv mask lo lo)) |
(list 'intv mask lo lo)) |
1733 |
(list 'intv mask lo hi)))) |
(list 'intv mask lo hi)))) |
1734 |
(list 'intv mask lo hi)) |
(list 'intv mask lo hi))) |
|
) |
|
1735 |
(defun calcFunc-intv (mask lo hi) |
(defun calcFunc-intv (mask lo hi) |
1736 |
(if (math-messy-integerp mask) (setq mask (math-trunc mask))) |
(if (math-messy-integerp mask) (setq mask (math-trunc mask))) |
1737 |
(or (natnump mask) (math-reject-arg mask 'fixnatnump)) |
(or (natnump mask) (math-reject-arg mask 'fixnatnump)) |
1738 |
(or (<= mask 3) (math-reject-arg mask 'range)) |
(or (<= mask 3) (math-reject-arg mask 'range)) |
1739 |
(math-make-intv mask lo hi) |
(math-make-intv mask lo hi)) |
|
) |
|
1740 |
|
|
1741 |
(defun math-sort-intv (mask lo hi) |
(defun math-sort-intv (mask lo hi) |
1742 |
(if (Math-lessp hi lo) |
(if (Math-lessp hi lo) |
1743 |
(math-make-intv (aref [0 2 1 3] mask) hi lo) |
(math-make-intv (aref [0 2 1 3] mask) hi lo) |
1744 |
(math-make-intv mask lo hi)) |
(math-make-intv mask lo hi))) |
|
) |
|
1745 |
|
|
1746 |
|
|
1747 |
|
|
1756 |
(setq b d bm dm) |
(setq b d bm dm) |
1757 |
(if (= res 0) |
(if (= res 0) |
1758 |
(setq bm (or bm dm)))) |
(setq bm (or bm dm)))) |
1759 |
(math-make-intv (+ (if am 2 0) (if bm 1 0)) a b)) |
(math-make-intv (+ (if am 2 0) (if bm 1 0)) a b))) |
|
) |
|
1760 |
|
|
1761 |
|
|
1762 |
(defun math-div-mod (a b m) ; [R R R R] (Returns nil if no solution) |
(defun math-div-mod (a b m) ; [R R R R] (Returns nil if no solution) |
1768 |
(setq u1 v1 u3 v3 v1 t1 v3 (cdr q)))) |
(setq u1 v1 u3 v3 v1 t1 v3 (cdr q)))) |
1769 |
(let ((q (math-idivmod a u3))) |
(let ((q (math-idivmod a u3))) |
1770 |
(and (eq (cdr q) 0) |
(and (eq (cdr q) 0) |
1771 |
(math-mod (math-mul (car q) u1) m))))) |
(math-mod (math-mul (car q) u1) m)))))) |
|
) |
|
1772 |
|
|
1773 |
(defun math-mod-intv (a b) |
(defun math-mod-intv (a b) |
1774 |
(let* ((q1 (math-floor (math-div (nth 2 a) b))) |
(let* ((q1 (math-floor (math-div (nth 2 a) b))) |
1782 |
(memq (nth 1 a) '(0 2))) |
(memq (nth 1 a) '(0 2))) |
1783 |
(math-make-intv (nth 1 a) m1 b)) |
(math-make-intv (nth 1 a) m1 b)) |
1784 |
(t |
(t |
1785 |
(math-make-intv 2 0 b)))) |
(math-make-intv 2 0 b))))) |
|
) |
|
1786 |
|
|
1787 |
|
|
1788 |
(defun math-read-angle-brackets () |
(defun math-read-angle-brackets () |
1815 |
(throw 'syntax (nth 2 res))) |
(throw 'syntax (nth 2 res))) |
1816 |
(setq exp-pos (1+ last)) |
(setq exp-pos (1+ last)) |
1817 |
(math-read-token) |
(math-read-token) |
1818 |
res) |
res)) |
|
) |
|
1819 |
|
|
1820 |
|
;;; calc-forms.el ends here |