/[emacs]/emacs/lisp/calc/calc-forms.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-forms.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:04:02 2001 UTC
# Line 1  Line 1 
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.
# Line 39  Line 39 
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")
# Line 52  Line 48 
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)
# Line 75  Line 69 
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")
# Line 154  Line 147 
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): ")
# Line 184  Line 174 
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: ")
# Line 227  Line 212 
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
# Line 268  Line 246 
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
# Line 278  Line 255 
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.
# Line 325  Line 295 
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]
# Line 351  Line 320 
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))
# Line 366  Line 334 
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]
# Line 389  Line 356 
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    
# Line 442  Line 406 
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))
# Line 461  Line 424 
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))
# Line 472  Line 434 
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)
# Line 487  Line 447 
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)))))
# Line 507  Line 465 
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))
# Line 528  Line 485 
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
# Line 564  Line 520 
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)
# Line 731  Line 686 
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)
# Line 880  Line 834 
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)
# Line 901  Line 854 
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))
# Line 918  Line 870 
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)
# Line 1077  Line 1028 
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)
# Line 1091  Line 1041 
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)))
# Line 1174  Line 1114 
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)
# Line 1190  Line 1129 
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)
# Line 1202  Line 1140 
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
# Line 1281  Line 1218 
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.
# Line 1319  Line 1255 
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
# Line 1336  Line 1271 
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    
# Line 1366  and ends on the last Sunday of October a Line 1299  and ends on the last Sunday of October a
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.
# Line 1376  and ends on the last Sunday of October a Line 1308  and ends on the last Sunday of October a
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)
# Line 1388  and ends on the last Sunday of October a Line 1319  and ends on the last Sunday of October a
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)
# Line 1402  and ends on the last Sunday of October a Line 1332  and ends on the last Sunday of October a
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))
# Line 1416  and ends on the last Sunday of October a Line 1345  and ends on the last Sunday of October a
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))
# Line 1432  and ends on the last Sunday of October a Line 1360  and ends on the last Sunday of October a
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))
# Line 1452  and ends on the last Sunday of October a Line 1379  and ends on the last Sunday of October a
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    
# Line 1472  and ends on the last Sunday of October a Line 1397  and ends on the last Sunday of October a
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)
# Line 1497  and ends on the last Sunday of October a Line 1421  and ends on the last Sunday of October a
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)
# Line 1547  and ends on the last Sunday of October a Line 1469  and ends on the last Sunday of October a
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.
# Line 1579  and ends on the last Sunday of October a Line 1500  and ends on the last Sunday of October a
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)
# Line 1686  and ends on the last Sunday of October a Line 1606  and ends on the last Sunday of October a
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)))
# Line 1700  and ends on the last Sunday of October a Line 1619  and ends on the last Sunday of October a
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)
# Line 1731  and ends on the last Sunday of October a Line 1649  and ends on the last Sunday of October a
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    
# Line 1749  and ends on the last Sunday of October a Line 1666  and ends on the last Sunday of October a
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    
# Line 1764  and ends on the last Sunday of October a Line 1679  and ends on the last Sunday of October a
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)
# Line 1789  and ends on the last Sunday of October a Line 1703  and ends on the last Sunday of October a
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    
# Line 1819  and ends on the last Sunday of October a Line 1731  and ends on the last Sunday of October a
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    
# Line 1847  and ends on the last Sunday of October a Line 1756  and ends on the last Sunday of October a
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)
# Line 1860  and ends on the last Sunday of October a Line 1768  and ends on the last Sunday of October a
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)))
# Line 1875  and ends on the last Sunday of October a Line 1782  and ends on the last Sunday of October a
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 ()
# Line 1909  and ends on the last Sunday of October a Line 1815  and ends on the last Sunday of October a
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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26