;; Calculator for GNU Emacs, part II [calc-forms.el];; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.;; Written by Dave Gillespie, daveg@synaptics.com.;; This file is part of GNU Emacs.;; GNU Emacs is distributed in the hope that it will be useful,;; but WITHOUT ANY WARRANTY. No author or distributor;; accepts responsibility to anyone for the consequences of using it;; or for whether it serves any particular purpose or works at all,;; unless he says so in writing. Refer to the GNU Emacs General Public;; License for full details.;; Everyone is granted permission to copy, modify and redistribute;; GNU Emacs, but only under the conditions described in the;; GNU Emacs General Public License. A copy of this license is;; supposed to have been given to you along with GNU Emacs so you;; can know your rights and responsibilities. It should be in a;; file named COPYING. Among other things, the copyright notice;; and this notice must be preserved on all copies.;; This file is autoloaded from calc-ext.el.(require'calc-ext)(require'calc-macs)(defuncalc-Need-calc-forms()nil)(defuncalc-time()(interactive)(calc-wrapper(let((time(current-time-string)))(calc-enter-result0"time"(list'mod(list'hms(string-to-int(substringtime1113))(string-to-int(substringtime1416))(string-to-int(substringtime1719)))(list'hms2400))))))(defuncalc-to-hms(arg)(interactive"P")(calc-wrapper(if(calc-is-inverse)(if(eqcalc-angle-mode'rad)(calc-unary-op">rad"'calcFunc-radarg)(calc-unary-op">deg"'calcFunc-degarg))(calc-unary-op">hms"'calcFunc-hmsarg))))(defuncalc-from-hms(arg)(interactive"P")(calc-invert-func)(calc-to-hmsarg))(defuncalc-hms-notation(fmt)(interactive"sHours-minutes-seconds format (hms, @ ' \", etc.): ")(calc-wrapper(if(string-match"\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'"fmt)(progn(calc-change-mode'calc-hms-format(concat"%s"(math-match-substringfmt1)(math-match-substringfmt2)"%s"(math-match-substringfmt3)(math-match-substringfmt4)"%s"(math-match-substringfmt5))t)(setq-defaultcalc-hms-formatcalc-hms-format)); for minibuffer(error"Bad hours-minutes-seconds format."))))(defuncalc-date-notation(fmtarg)(interactive"sDate format (e.g., M/D/YY h:mm:ss): \nP")(calc-wrapper(if(equalfmt"")(setqfmt"1"))(if(string-match"\\` *[0-9] *\\'"fmt)(setqfmt(nth(string-to-intfmt)calc-standard-date-formats)))(or(string-match"[a-zA-Z]"fmt)(error"Bad date format specifier"))(andarg(>=(setqarg(prefix-numeric-valuearg))0)(<=arg9)(setqcalc-standard-date-formats(copy-sequencecalc-standard-date-formats))(setcar(nthcdrargcalc-standard-date-formats)fmt))(let((case-fold-searchnil))(and(not(string-match"<.*>"fmt))(string-match"\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*[bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'"fmt)(string-match(concat"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*"(regexp-quote(math-match-substringfmt1))"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*")fmt)(setqfmt(concat(substringfmt0(match-beginning0))"<"(substringfmt(match-beginning0)(match-end0))">"(substringfmt(match-end0))))))(let((lfmtnil)(fullfmtnil)(timenil)pospos2symtemp)(let((case-fold-searchnil))(and(setqtemp(string-match":[BS]S"fmt))(asetfmttemp?C)))(while(setqpos(string-match"[<>a-zA-Z]"fmt))(if(>pos0)(setqlfmt(cons(substringfmt0pos)lfmt)))(setqpos2(1+pos))(cond((=(areffmtpos)?\<)(andtime(error"Nested <'s not allowed"))(andlfmt(setqfullfmt(nconclfmtfullfmt)lfmtnil))(setqtimet))((=(areffmtpos)?\>)(ortime(error"Misplaced > in format"))(andlfmt(setqfullfmt(cons(nreverselfmt)fullfmt)lfmtnil))(setqtimenil))(t(if(string-match"\\`[^a-zA-Z]*[bB][a-zA-Z]"fmt)(setqpos2(1+pos2)))(while(and(<pos2(lengthfmt))(=(upcase(areffmtpos2))(upcase(areffmt(1-pos2)))))(setqpos2(1+pos2)))(setqsym(intern(substringfmtpospos2)))(or(memqsym'(YYYBYYYYYYYYaaAAaaaAAAaaaaAAAAbbBBbbbBBBbbbbBBBBMMMBMmmmMmmMmmmMMMMMMMDDDBDddddbddWwwwWwwWwwwWWWWWWWhhhbhHHHBHpPppPPppppPPPPmmmbmsssbssSSBSCNnJjUb))(and(eqsym'X)(notlfmt)(notfullfmt))(error"Bad format code: %s"sym))(and(memqsym'(bbBBbbbBBBbbbbBBBB))(setqlfmt(cons'blfmt)))(setqlfmt(conssymlfmt))))(setqfmt(substringfmtpos2)))(or(equalfmt"")(setqlfmt(consfmtlfmt)))(andlfmt(iftime(setqfullfmt(cons(nreverselfmt)fullfmt))(setqfullfmt(nconclfmtfullfmt))))(calc-change-mode'calc-date-format(nreversefullfmt)t))))(defuncalc-hms-mode()(interactive)(calc-wrapper(calc-change-mode'calc-angle-mode'hms)(message"Angles measured in degrees-minutes-seconds.")))(defuncalc-now(arg)(interactive"P")(calc-date-zero-args"now"'calcFunc-nowarg))(defuncalc-date-part(arg)(interactive"NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ")(if(or(<arg1)(>arg9))(error"Part code out of range"))(calc-wrapper(calc-enter-result1(ntharg'(nil"year""mnth""day""hour""minu""sec""wday""yday""hmst"))(list(ntharg'(nilcalcFunc-yearcalcFunc-monthcalcFunc-daycalcFunc-hourcalcFunc-minutecalcFunc-secondcalcFunc-weekdaycalcFunc-yeardaycalcFunc-time))(calc-top-n1)))))(defuncalc-date(arg)(interactive"p")(if(or(<arg1)(>arg6))(error"Between one and six arguments are allowed"))(calc-wrapper(calc-enter-resultarg"date"(cons'calcFunc-date(calc-top-list-narg)))))(defuncalc-julian(arg)(interactive"P")(calc-date-one-arg"juln"'calcFunc-julianarg))(defuncalc-unix-time(arg)(interactive"P")(calc-date-one-arg"unix"'calcFunc-unixtimearg))(defuncalc-time-zone(arg)(interactive"P")(calc-date-zero-args"zone"'calcFunc-tzonearg))(defuncalc-convert-time-zones(old&optionalnew)(interactive"sFrom time zone: ")(calc-wrapper(if(equalold"$")(calc-enter-result3"tzcv"(cons'calcFunc-tzconv(calc-top-list-n3)))(if(equalold"")(setqold"local"))(ornew(setqnew(read-string(concat"From time zone: "old", to zone: "))))(if(stringpold)(setqold(math-read-exprold)))(if(eq(car-safeold)'error)(error"Error in expression: "(nth1old)))(if(equalnew"")(setqnew"local"))(if(stringpnew)(setqnew(math-read-exprnew)))(if(eq(car-safenew)'error)(error"Error in expression: "(nth1new)))(calc-enter-result1"tzcv"(list'calcFunc-tzconv(calc-top-n1)oldnew)))))(defuncalc-new-week(arg)(interactive"P")(calc-date-one-arg"nwwk"'calcFunc-newweekarg))(defuncalc-new-month(arg)(interactive"P")(calc-date-one-arg"nwmn"'calcFunc-newmontharg))(defuncalc-new-year(arg)(interactive"P")(calc-date-one-arg"nwyr"'calcFunc-newyeararg))(defuncalc-inc-month(arg)(interactive"p")(calc-date-one-arg"incm"'calcFunc-incmontharg))(defuncalc-business-days-plus(arg)(interactive"P")(calc-wrapper(calc-binary-op"bus+"'calcFunc-baddarg)))(defuncalc-business-days-minus(arg)(interactive"P")(calc-wrapper(calc-binary-op"bus-"'calcFunc-bsubarg)))(defuncalc-date-zero-args(prefixfuncarg)(calc-wrapper(if(consparg)(calc-enter-result1prefix(listfunc(calc-top-n1)))(calc-enter-result0prefix(ifarg(listfunc(prefix-numeric-valuearg))(listfunc))))))(defuncalc-date-one-arg(prefixfuncarg)(calc-wrapper(if(consparg)(calc-enter-result2prefix(consfunc(calc-top-list-n2)))(calc-enter-result1prefix(ifarg(listfunc(calc-top-n1)(prefix-numeric-valuearg))(listfunc(calc-top-n1)))))));;;; Hours-minutes-seconds forms.(defunmath-normalize-hms(a)(let((h(math-normalize(nth1a)))(m(math-normalize(nth2a)))(s(let((calc-internal-prec(max(-calc-internal-prec4)3)))(math-normalize(nth3a)))))(if(math-negph)(progn(if(math-posps)(setqs(math-adds-60)m(math-addm1)))(if(math-pospm)(setqm(math-addm-60)h(math-addh1)))(if(not(Math-lessp-60s))(setqs(math-adds60)m(math-addm-1)))(if(not(Math-lessp-60m))(setqm(math-addm60)h(math-addh-1))))(if(math-negps)(setqs(math-adds60)m(math-addm-1)))(if(math-negpm)(setqm(math-addm60)h(math-addh-1)))(if(not(Math-lessps60))(setqs(math-adds-60)m(math-addm1)))(if(not(Math-lesspm60))(setqm(math-addm-60)h(math-addh1))))(if(and(eq(car-safes)'float)(<=(+(math-numdigs(nth1s))(nth2s))(-2calc-internal-prec)))(setqs0))(list'hmshms)));;; Convert A from ANG or current angular mode to HMS format.(defunmath-to-hms(a&optionalang); [X R] [Public](cond((eq(car-safea)'hms)a)((eq(car-safea)'sdev)(math-make-sdev(math-to-hms(nth1a))(math-to-hms(nth2a))))((not(Math-numberpa))(list'calcFunc-hmsa))((math-negpa)(math-neg(math-to-hms(math-nega)ang)))((eq(orangcalc-angle-mode)'rad)(math-to-hms(math-diva(math-pi-over-180))'deg))((memq(car-safea)'(cplxpolar))a)(t;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3))); (math-normalize a)))(math-normalize(let*((b(math-mula3600))(hm(math-trunc(math-divb60)))(hmd(math-idivmodhm60)))(list'hms(carhmd)(cdrhmd)(math-subb(math-mulhm60))))))))(defuncalcFunc-hms(h&optionalms)(or(Math-realph)(math-reject-argh'realp))(orm(setqm0))(or(Math-realpm)(math-reject-argm'realp))(ors(setqs0))(or(Math-realps)(math-reject-args'realp))(if(and(not(Math-lesspm0))(Math-lesspm60)(not(Math-lessps0))(Math-lessps60))(math-add(math-to-hmsh)(list'hms0ms))(math-to-hms(math-addh(math-add(math-div(orm0)60)(math-div(ors0)3600)))'deg)));;; Convert A from HMS format to ANG or current angular mode.(defunmath-from-hms(a&optionalang); [R X] [Public](cond((not(eq(car-safea)'hms))(if(Math-numberpa)a(if(eq(car-safea)'sdev)(math-make-sdev(math-from-hms(nth1a)ang)(math-from-hms(nth2a)ang))(if(eq(orangcalc-angle-mode)'rad)(list'calcFunc-rada)(list'calcFunc-dega)))))((math-negpa)(math-neg(math-from-hms(math-nega)ang)))((eq(orangcalc-angle-mode)'rad)(math-mul(math-from-hmsa'deg)(math-pi-over-180)))(t(math-add(math-div(math-add(math-div(nth3a)'(float61))(nth2a))60)(nth1a)))));;;; Date forms.;;; Some of these functions are adapted from Edward Reingold's "calendar.el".;;; These versions are rewritten to use arbitrary-size integers.;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian;;; calendar is used; the first day after 9/2/1752 is 9/14/1752.;;; A numerical date is the number of days since midnight on;;; the morning of January 1, 1 A.D. If the date is a non-integer,;;; it represents a specific date and time.;;; A "dt" is a list of the form, (year month day), corresponding to;;; an integer code, or (year month day hour minute second), corresponding;;; to a non-integer code.(defunmath-date-to-dt(value)(if(eq(car-safevalue)'date)(setqvalue(nth1value)))(or(math-realpvalue)(math-reject-argvalue'datep))(let*((parts(math-date-partsvalue))(date(carparts))(time(nth1parts))(month1)day(year(math-quotient(math-adddate(if(Math-lesspdate711859)365; for speed, we take-108)); >1950 as a special case(if(math-negpvalue)366365))); this result may be an overestimatetemp)(while(Math-lesspdate(setqtemp(math-absolute-from-dateyear11)))(setqyear(math-addyear-1)))(if(eqyear0)(setqyear-1))(setqdate(1+(math-subdatetemp)))(and(eqyear1752)(>=date247)(setqdate(+date11)))(setqtemp(if(math-leap-year-pyear)[1326192122153183214245275306336999][1326091121152182213244274305335999]))(while(>=date(areftempmonth))(setqmonth(1+month)))(setqday(1+(-date(areftemp(1-month)))))(if(math-integerpvalue)(listyearmonthday)(listyearmonthday(/time3600)(%(/time60)60)(math-add(%time60)(nth2parts))))))(defunmath-dt-to-date(dt)(or(integerp(nth1dt))(math-reject-arg(nth1dt)'fixnump))(if(or(<(nth1dt)1)(>(nth1dt)12))(math-reject-arg(nth1dt)"Month value is out of range"))(or(integerp(nth2dt))(math-reject-arg(nth2dt)'fixnump))(if(or(<(nth2dt)1)(>(nth2dt)31))(math-reject-arg(nth2dt)"Day value is out of range"))(let((date(math-absolute-from-date(cardt)(nth1dt)(nth2dt))))(if(nth3dt)(math-add(math-floatdate)(math-div(math-add(+(*(nth3dt)3600)(*(nth4dt)60))(nth5dt))'(float8642)))date)))(defunmath-date-parts(value&optionaloffset)(let*((date(math-floorvalue))(time(math-round(math-mul(math-subvalue(oroffsetdate))86400)(and(>calc-internal-prec12)(-calc-internal-prec12))))(ftime(math-floortime)))(listdateftime(math-subtimeftime))))(defunmath-this-year()(string-to-int(substring(current-time-string)-4)))(defunmath-leap-year-p(year)(if(Math-lesspyear1752)(if(math-negpyear)(=(math-imod(math-negyear)4)1)(=(math-imodyear4)0))(setqyear(math-imodyear400))(or(and(=(%year4)0)(/=(%year100)0))(=year0))))(defunmath-days-in-month(yearmonth)(if(and(=month2)(math-leap-year-pyear))29(aref[312831303130313130313031](1-month))))(defunmath-day-number(yearmonthday)(let((day-of-year(+day(*31(1-month)))))(if(>month2)(progn(setqday-of-year(-day-of-year(/(+23(*4month))10)))(if(math-leap-year-pyear)(setqday-of-year(1+day-of-year)))))(and(eqyear1752)(or(>month9)(and(=month9)(>=day14)))(setqday-of-year(-day-of-year11)))day-of-year))(defunmath-absolute-from-date(yearmonthday)(if(eqyear0)(setqyear-1))(let((yearm1(math-subyear1)))(math-sub(math-add(math-day-numberyearmonthday)(math-add(math-mul365yearm1)(if(math-pospyear)(math-quotientyearm14)(math-sub365(math-quotient(math-sub3year)4)))))(if(or(Math-lesspyear1753)(and(eqyear1752)(<=month9)))1(let((correction(math-mul(math-quotientyearm1100)3)))(let((res(math-idivmodcorrection4)))(math-add(if(=(cdrres)0)-10)(carres))))))));;; It is safe to redefine these in your .emacs file to use a different;;; language.(defvarmath-long-weekday-names'("Sunday""Monday""Tuesday""Wednesday""Thursday""Friday""Saturday"))(defvarmath-short-weekday-names'("Sun""Mon""Tue""Wed""Thu""Fri""Sat"))(defvarmath-long-month-names'("January""February""March""April""May""June""July""August""September""October""November""December"))(defvarmath-short-month-names'("Jan""Feb""Mar""Apr""May""Jun""Jul""Aug""Sep""Oct""Nov""Dec"))(defunmath-format-date(date)(if(eq(car-safedate)'date)(setqdate(nth1date)))(let((entry(listdatecalc-internal-preccalc-date-format)))(or(cdr(assocentrymath-format-date-cache))(let*((dtnil)(calc-group-digitsnil)(calc-leading-zerosnil)(calc-number-radix10)yearmonthdayweekdayhourminutesecond(bc-flagnil)(fmt(apply'concat(mapcar'math-format-date-partcalc-date-format))))(setqmath-format-date-cache(cons(consentryfmt)math-format-date-cache))(and(setqdt(nthcdr10math-format-date-cache))(setcdrdtnil))fmt))))(setqmath-format-date-cachenil)(defunmath-format-date-part(x)(cond((stringpx)x)((listpx)(if(math-integerpdate)""(apply'concat(mapcar'math-format-date-partx))))((eqx'X)"")((eqx'N)(math-format-numberdate))((eqx'n)(math-format-number(math-floordate)))((eqx'J)(math-format-number(math-adddate'(float(bigpos23521417)-1))))((eqx'j)(math-format-number(math-add(math-floordate)'(bigpos4247211))))((eqx'U)(math-format-number(nth1(math-date-partsdate719164))))((progn(ordt(progn(setqdt(math-date-to-dtdate)year(cardt)month(nth1dt)day(nth2dt)weekday(math-mod(math-add(math-floordate)6)7)hour(nth3dt)minute(nth4dt)second(nth5dt))(and(memq'bcalc-date-format)(math-negpyear)(setqyear(math-negyear)bc-flagt))))(memqx'(YYYBY)))(if(and(integerpyear)(>year1940)(<year2040))(format(cond((eqx'YY)"%02d")((eqx'BYY)"%2d")(t"%d"))(%year100))(if(and(natnumpyear)(<year100))(format"+%d"year)(math-format-numberyear))))((eqx'YYY)(math-format-numberyear))((eqx'YYYY)(if(and(natnumpyear)(<year100))(format"+%d"year)(math-format-numberyear)))((eqx'b)"")((eqx'aa)(and(notbc-flag)"ad"))((eqx'AA)(and(notbc-flag)"AD"))((eqx'aaa)(and(notbc-flag)"ad "))((eqx'AAA)(and(notbc-flag)"AD "))((eqx'aaaa)(and(notbc-flag)"a.d."))((eqx'AAAA)(and(notbc-flag)"A.D."))((eqx'bb)(andbc-flag"bc"))((eqx'BB)(andbc-flag"BC"))((eqx'bbb)(andbc-flag" bc"))((eqx'BBB)(andbc-flag" BC"))((eqx'bbbb)(andbc-flag"b.c."))((eqx'BBBB)(andbc-flag"B.C."))((eqx'M)(format"%d"month))((eqx'MM)(format"%02d"month))((eqx'BM)(format"%2d"month))((eqx'mmm)(downcase(nth(1-month)math-short-month-names)))((eqx'Mmm)(nth(1-month)math-short-month-names))((eqx'MMM)(upcase(nth(1-month)math-short-month-names)))((eqx'Mmmm)(nth(1-month)math-long-month-names))((eqx'MMMM)(upcase(nth(1-month)math-long-month-names)))((eqx'D)(format"%d"day))((eqx'DD)(format"%02d"day))((eqx'BD)(format"%2d"day))((eqx'W)(format"%d"weekday))((eqx'www)(downcase(nthweekdaymath-short-weekday-names)))((eqx'Www)(nthweekdaymath-short-weekday-names))((eqx'WWW)(upcase(nthweekdaymath-short-weekday-names)))((eqx'Wwww)(nthweekdaymath-long-weekday-names))((eqx'WWWW)(upcase(nthweekdaymath-long-weekday-names)))((eqx'd)(format"%d"(math-day-numberyearmonthday)))((eqx'ddd)(format"%03d"(math-day-numberyearmonthday)))((eqx'bdd)(format"%3d"(math-day-numberyearmonthday)))((eqx'h)(andhour(format"%d"hour)))((eqx'hh)(andhour(format"%02d"hour)))((eqx'bh)(andhour(format"%2d"hour)))((eqx'H)(andhour(format"%d"(1+(%(+hour11)12)))))((eqx'HH)(andhour(format"%02d"(1+(%(+hour11)12)))))((eqx'BH)(andhour(format"%2d"(1+(%(+hour11)12)))))((eqx'p)(andhour(if(<hour12)"a""p")))((eqx'P)(andhour(if(<hour12)"A""P")))((eqx'pp)(andhour(if(<hour12)"am""pm")))((eqx'PP)(andhour(if(<hour12)"AM""PM")))((eqx'pppp)(andhour(if(<hour12)"a.m.""p.m.")))((eqx'PPPP)(andhour(if(<hour12)"A.M.""P.M.")))((eqx'm)(andminute(format"%d"minute)))((eqx'mm)(andminute(format"%02d"minute)))((eqx'bm)(andminute(format"%2d"minute)))((eqx'C)(andsecond(not(math-zeropsecond))":"))((memqx'(sssbsSSBS))(andsecond(not(and(memqx'(SSBS))(math-zeropsecond)))(if(integerpsecond)(format(cond((memqx'(ssSS))"%02d")((memqx'(bsBS))"%2d")(t"%d"))second)(concat(if(Math-lesspsecond10)(cond((memqx'(ssSS))"0")((memqx'(bsBS))" ")(t""))"")(let((calc-float-format(list'fix(min(-12calc-internal-prec)0))))(math-format-numbersecond))))))))(defunmath-parse-date(str)(catch'syntax(or(math-parse-standard-datestrt)(math-parse-standard-datestrnil)(and(string-match"\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'"str)(list'date(math-read-number(math-match-substringstr1))))(let((case-fold-searcht)(yearnil)(monthnil)(daynil)(weekdaynil)(hournil)(minutenil)(secondnil)(bc-flagnil)(anil)(bnil)(cnil)(bigyearnil)temp);; Extract the time, if any.(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)(string-match"\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)"str))(let((ampm(math-match-substringstr6)))(setqhour(string-to-int(math-match-substringstr1))minute(math-match-substringstr2)second(math-match-substringstr4)str(concat(substringstr0(match-beginning0))(substringstr(match-end0))))(if(equalminute"")(setqminute0)(setqminute(string-to-intminute)))(if(equalsecond"")(setqsecond0)(setqsecond(math-read-numbersecond)))(if(equalampm"")(if(>hour23)(throw'syntax"Hour value out of range"))(setqampm(upcase(arefampm0)))(if(memqampm'(?N?M))(if(and(=hour12)(=minute0)(eqsecond0))(if(eqampm?M)(setqhour0))(throw'syntax"Time must be 12:00:00 in this context"))(if(or(=hour0)(>hour12))(throw'syntax"Hour value out of range"))(if(eq(=ampm?A)(=hour12))(setqhour(%(+hour12)24)))))));; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign.(while(string-match"[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]"str)(progn(setqstr(copy-sequencestr))(asetstr(match-beginning1)?\/)));; Extract obvious month or weekday names.(if(string-match"[a-zA-Z]"str)(progn(setqmonth(math-parse-date-wordmath-long-month-names))(setqweekday(math-parse-date-wordmath-long-weekday-names))(ormonth(setqmonth(math-parse-date-wordmath-short-month-names)))(orweekday(math-parse-date-wordmath-short-weekday-names))(orhour(if(setqtemp(math-parse-date-word'("noon""midnight""mid")))(setqhour(if(=temp1)120)minute0second0)))(or(math-parse-date-word'("ad""a.d."))(if(math-parse-date-word'("bc""b.c."))(setqbc-flagt)))(if(string-match"[a-zA-Z]+"str)(throw'syntax(format"Bad word in date: \"%s\""(math-match-substringstr0))))));; If there is a huge number other than the year, ignore it.(while(and(string-match"[-+]?0*[1-9][0-9][0-9][0-9][0-9]+"str)(setqtemp(concat(substringstr0(match-beginning0))(substringstr(match-end0))))(string-match"[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'"temp))(setqstrtemp));; If there is a number with a sign or a large number, it is a year.(if(or(string-match"\\([-+][0-9]+\\)[^-]*\\'"str)(string-match"\\(0*[1-9][0-9][0-9]+\\)"str))(setqyear(math-match-substringstr1)str(concat(substringstr0(match-beginning1))(substringstr(match-end1)))year(math-read-numberyear)bigyeart));; Collect remaining numbers.(setqtemp0)(while(string-match"[0-9]+"strtemp)(andc(throw'syntax"Too many numbers in date"))(setqc(string-to-int(math-match-substringstr0)))(orb(setqbccnil))(ora(setqabbnil))(setqtemp(match-end0)));; Check that we have the right amount of information.(setqtemp(+(ifyear10)(ifmonth10)(ifday10)(ifa10)(ifb10)(ifc10)))(if(>temp3)(throw'syntax"Too many numbers in date")(if(or(<temp2)(andyear(=temp2)))(throw'syntax"Not enough numbers in date")(if(=temp2); if year omitted, assume current year(setqyear(math-this-year)))));; A large number must be a year.(oryear(if(anda(or(>a31)(<a1)))(setqyearaabbccnil)(if(andb(or(>b31)(<b1)))(setqyearbbccnil)(if(andc(or(>c31)(<c1)))(setqyearccnil)))));; A medium-large number must be a day.(ifyear(if(anda(>a12))(setqdayaabbccnil)(if(andb(>b12))(setqdaybbccnil)(if(andc(>c12))(setqdayccnil)))));; We may know enough to sort it out now.(if(andyearday)(ormonth(setqmontha))(if(andyearmonth)(setqdaya);; Interpret order of numbers as same as for display format.(setqtempcalc-date-format)(whiletemp(cond((not(symbolp(cartemp))))((memq(cartemp)'(YYYBYYYYYYYY))(oryear(setqyearaabbc)))((memq(cartemp)'(MMMBMmmmMmmMmmmMMMMMMM))(ormonth(setqmonthaabbc)))((memq(cartemp)'(DDDBD))(orday(setqdayaabbc))))(setqtemp(cdrtemp)));; If display format was not complete, assume American style.(ormonth(setqmonthaabbc))(orday(setqdayaabbc))(oryear(setqyearaabbc))))(ifbc-flag(setqyear(math-neg(math-absyear))))(math-parse-date-validateyearbigyearmonthdayhourminutesecond)))))(defunmath-parse-date-validate(yearbigyearmonthdayhourminutesecond)(and(notbigyear)(natnumpyear)(<year100)(setqyear(+year(if(<year40)20001900))))(if(eqyear0)(throw'syntax"Year value is out of range"))(if(or(<month1)(>month12))(throw'syntax"Month value is out of range"))(if(or(<day1)(>day(math-days-in-monthyearmonth)))(throw'syntax"Day value is out of range"))(andhour(progn(if(or(<hour0)(>hour23))(throw'syntax"Hour value is out of range"))(if(or(<minute0)(>minute59))(throw'syntax"Minute value is out of range"))(if(or(math-negpsecond)(not(Math-lesspsecond60)))(throw'syntax"Seconds value is out of range"))))(list'date(math-dt-to-date(append(listyearmonthday)(andhour(listhourminutesecond))))))(defunmath-parse-date-word(names&optionalfront)(let((n1))(while(andnames(not(string-match(if(equal(carnames)"Sep")"Sept?"(regexp-quote(carnames)))str)))(setqnames(cdrnames)n(1+n)))(andnames(or(notfront)(=(match-beginning0)0))(progn(setqstr(concat(substringstr0(match-beginning0))(iffront""" ")(substringstr(match-end0))))n))))(defunmath-parse-standard-date(strwith-time)(let((case-fold-searcht)(okayt)num(fmtcalc-date-format)thisnext(gnextnil)(yearnil)(monthnil)(daynil)(bigyearnil)(yeardaynil)(hournil)(minutenil)(secondnil)(bc-flagnil))(while(andfmtokay)(setqthis(carfmt)fmt(setqfmt(or(cdrfmt)(prog1gnext(setqgnextnil))))next(carfmt))(if(conspnext)(setqnext(carnext)))(or(cond((listpthis)(or(notwith-time)(notthis)(setqgnextfmtfmtthis)))((stringpthis)(if(and(<=(lengththis)(lengthstr))(equalthis(substringstr0(lengththis))))(setqstr(substringstr(lengththis)))))((eqthis'X)t)((memqthis'(nNjJ))(and(string-match"\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?"str)(setqnum(math-match-substringstr0)str(substringstr(match-end0))num(math-date-to-dt(math-read-numbernum))num(math-subnum(if(memqthis'(nN))0(if(or(eqthis'j)(math-integerpnum))'(bigpos4247211)'(float(bigpos23521417)-1))))hour(or(nth3num)hour)minute(or(nth4num)minute)second(or(nth5num)second)year(carnum)month(nth1num)day(nth2num))))((eqthis'U)(and(string-match"\\`[-+]?[0-9]+"str)(setqnum(math-match-substringstr0)str(substringstr(match-end0))num(math-date-to-dt(math-add719164(math-div(math-read-numbernum)'(float8642))))hour(nth3num)minute(nth4num)second(nth5num)year(carnum)month(nth1num)day(nth2num))))((memqthis'(mmmMmmMMM))(setqmonth(math-parse-date-wordmath-short-month-namest)))((memqthis'(MmmmMMMM))(setqmonth(math-parse-date-wordmath-long-month-namest)))((memqthis'(wwwWwwWWW))(math-parse-date-wordmath-short-weekday-namest))((memqthis'(WwwwWWWW))(math-parse-date-wordmath-long-weekday-namest))((memqthis'(pP))(if(string-match"\\`a"str)(setqhour(if(=hour12)0hour)str(substringstr1))(if(string-match"\\`p"str)(setqhour(if(=hour12)12(%(+hour12)24))str(substringstr1)))))((memqthis'(ppPPppppPPPP))(if(string-match"\\`am\\|a\\.m\\."str)(setqhour(if(=hour12)0hour)str(substringstr(match-end0)))(if(string-match"\\`pm\\|p\\.m\\."str)(setqhour(if(=hour12)12(%(+hour12)24))str(substringstr(match-end0))))))((memqthis'(YYYBYYYYYYYY))(and(if(memqnext'(MMDDdddhhHHmmssSS))(if(memqthis'(YYYBYY))(string-match"\\` *[0-9][0-9]"str)(string-match"\\`[0-9][0-9][0-9][0-9]"str))(string-match"\\`[-+]?[0-9]+"str))(setqyear(math-match-substringstr0)bigyear(or(eqthis'YYY)(memq(arefstr0)'(?\+?\-)))str(substringstr(match-end0))year(math-read-numberyear))))((eqthis'b)t)((memqthis'(aaAAaaaaAAAA))(if(string-match"\\` *\\(ad\\|a\\.d\\.\\)"str)(setqstr(substringstr(match-end0)))))((memqthis'(aaaAAA))(if(string-match"\\` *ad *"str)(setqstr(substringstr(match-end0)))))((memqthis'(bbBBbbbBBBbbbbBBBB))(if(string-match"\\` *\\(bc\\|b\\.c\\.\\)"str)(setqstr(substringstr(match-end0))bc-flagt)))((memqthis'(sssbsSSBS))(and(if(memqnext'(YYYYYYMMDDhhHHmm))(string-match"\\` *[0-9][0-9]\\(\\.[0-9]+\\)?"str)(string-match"\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?"str))(setqsecond(math-match-substringstr0)str(substringstr(match-end0))second(math-read-numbersecond))))((eqthis'C)(if(string-match"\\`:[0-9][0-9]"str)(setqstr(substringstr1))t))((or(not(if(and(memqthis'(dddMMDDhhHHmm))(memqnext'(YYYYYYMMDDdddhhHHmmssSS)))(if(eqthis'ddd)(string-match"\\` *[0-9][0-9][0-9]"str)(string-match"\\` *[0-9][0-9]"str))(string-match"\\` *[0-9]+"str)))(and(setqnum(string-to-int(math-match-substringstr0))str(substringstr(match-end0)))nil))nil)((eqthis'W)(and(>=num0)(<num7)))((memqthis'(ddddbdd))(setqyeardaynum))((memqthis'(MMMBM))(setqmonthnum))((memqthis'(DDDBD))(setqdaynum))((memqthis'(hhhbhHHHBH))(setqhournum))((memqthis'(mmmbm))(setqminutenum)))(setqokaynil)))(ifyearday(if(andmonthday)(setqyeardaynil)(setqmonth1day1)))(if(andokay(equalstr""))(andmonthday(or(not(orhourminutesecond))(andhourminute))(progn(oryear(setqyear(math-this-year)))(orsecond(setqsecond0))(ifbc-flag(setqyear(math-neg(math-absyear))))(setqday(math-parse-date-validateyearbigyearmonthdayhourminutesecond))(ifyearday(setqday(math-addday(1-yearday))))day)))))(defuncalcFunc-now(&optionalzone)(let((date(let((calc-date-formatnil))(math-parse-date(current-time-string)))))(if(conspdate)(ifzone(math-adddate(math-div(math-sub(calcFunc-tzonenildate)(calcFunc-tzonezonedate))'(float8642)))date)(calc-record-why"*Unable to interpret current date from system")(append(list'calcFunc-now)(andzone(listzone))))))(defuncalcFunc-year(date)(car(math-date-to-dtdate)))(defuncalcFunc-month(date)(nth1(math-date-to-dtdate)))(defuncalcFunc-day(date)(nth2(math-date-to-dtdate)))(defuncalcFunc-weekday(date)(if(eq(car-safedate)'date)(setqdate(nth1date)))(or(math-realpdate)(math-reject-argdate'datep))(math-mod(math-add(math-floordate)6)7))(defuncalcFunc-yearday(date)(let((dt(math-date-to-dtdate)))(math-day-number(cardt)(nth1dt)(nth2dt))))(defuncalcFunc-hour(date)(if(eq(car-safedate)'hms)(nth1date)(or(nth3(math-date-to-dtdate))0)))(defuncalcFunc-minute(date)(if(eq(car-safedate)'hms)(nth2date)(or(nth4(math-date-to-dtdate))0)))(defuncalcFunc-second(date)(if(eq(car-safedate)'hms)(nth3date)(or(nth5(math-date-to-dtdate))0)))(defuncalcFunc-time(date)(let((dt(math-date-to-dtdate)))(if(nth3dt)(cons'hms(nthcdr3dt))(list'hms000))))(defuncalcFunc-date(date&optionalmonthdayhourminutesecond)(and(math-messy-integerpmonth)(setqmonth(math-truncmonth)))(andmonth(not(integerpmonth))(math-reject-argmonth'fixnump))(and(math-messy-integerpday)(setqday(math-truncday)))(andday(not(integerpday))(math-reject-argday'fixnump))(if(and(eq(car-safehour)'hms)(notminute))(setqsecond(nth3hour)minute(nth2hour)hour(nth1hour)))(and(math-messy-integerphour)(setqhour(math-trunchour)))(andhour(not(integerphour))(math-reject-arghour'fixnump))(and(math-messy-integerpminute)(setqminute(math-truncminute)))(andminute(not(integerpminute))(math-reject-argminute'fixnump))(and(math-messy-integerpsecond)(setqsecond(math-truncsecond)))(andsecond(not(math-realpsecond))(math-reject-argsecond'realp))(ifmonth(progn(and(math-messy-integerpdate)(setqdate(math-truncdate)))(anddate(not(math-integerpdate))(math-reject-argdate'integerp))(ifday(ifhour(list'date(math-dt-to-date(listdatemonthdayhour(orminute0)(orsecond0))))(list'date(math-dt-to-date(listdatemonthday))))(list'date(math-dt-to-date(list(math-this-year)datemonth)))))(if(math-realpdate)(list'datedate)(if(eq(cardate)'date)(nth1date)(math-reject-argdate'datep)))))(defuncalcFunc-julian(date&optionalzone)(if(math-realpdate)(list'date(if(math-integerpdate)(math-subdate'(bigpos4247211))(setqdate(math-subdate'(float(bigpos23521417)-1)))(math-subdate(math-div(calcFunc-tzonezonedate)'(float8642)))))(if(eq(cardate)'date)(math-add(nth1date)(if(math-integerp(nth1date))'(bigpos4247211)(math-add'(float(bigpos23521417)-1)(math-div(calcFunc-tzonezonedate)'(float8642)))))(math-reject-argdate'datep))))(defuncalcFunc-unixtime(date&optionalzone)(if(math-realpdate)(progn(setqdate(math-add719164(math-divdate'(float8642))))(list'date(math-subdate(math-div(calcFunc-tzonezonedate)'(float8642)))))(if(eq(cardate)'date)(math-add(nth1(math-date-parts(nth1date)719164))(calcFunc-tzonezonedate))(math-reject-argdate'datep))))(defuncalcFunc-tzone(&optionalzonedate)(ifzone(cond((math-realpzone)(math-round(math-mulzone3600)))((eq(carzone)'hms)(math-round(math-mul(math-from-hmszone'deg)3600)))((eq(carzone)'+)(math-add(calcFunc-tzone(nth1zone)date)(calcFunc-tzone(nth2zone)date)))((eq(carzone)'-)(math-sub(calcFunc-tzone(nth1zone)date)(calcFunc-tzone(nth2zone)date)))((eq(carzone)'var)(let((name(upcase(symbol-name(nth1zone))))found)(if(setqfound(assocnamemath-tzone-names))(calcFunc-tzone(math-add(nth1found)(if(integerp(nth2found))(nth2found)(or(math-daylight-savings-adjustdate(carfound))0)))date)(if(equalname"LOCAL")(calcFunc-tzonenildate)(math-reject-argzone"*Unrecognized time zone name")))))(t(math-reject-argzone"*Expected a time zone")))(if(calc-var-value'var-TimeZone)(calcFunc-tzone(calc-var-value'var-TimeZone)date)(let((pmath-tzone-names)(offset0)(tz'(varerrorvar-error)))(save-excursion(set-buffer(get-buffer-create" *Calc Temporary*"))(erase-buffer)(call-process"date"nilt)(goto-char1)(let((case-fold-searcht))(while(andp(not(search-forward(car(carp))nilt)))(setqp(cdrp))))(if(looking-at"\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)")(setqoffset(math-add(string-to-int(buffer-substring(match-beginning1)(match-end1)))(if(match-beginning2)(math-div(string-to-int(buffer-substring(match-beginning2)(match-end2)))60)0)))))(ifp(progn(setqp(carp));; Try to convert to a generalized time zone.(if(integerp(nth2p))(let((genmath-tzone-names))(while(andgen(not(equal(nth2(cargen))(carp)))(not(equal(nth3(cargen))(carp)))(not(equal(nth4(cargen))(carp)))(not(equal(nth5(cargen))(carp))))(setqgen(cdrgen)))(andgen(setqgen(cargen))(equal(math-daylight-savings-adjustnil(cargen))(nth2p))(setqpgen))))(setqtz(math-add(list'var(intern(carp))(intern(concat"var-"(carp))))offset))))(kill-buffer" *Calc Temporary*")(setqvar-TimeZonetz)(calc-refresh-evaltos'var-TimeZone)(calcFunc-tzonetzdate)))));;; Note: Longer names must appear before shorter names which are;;; substrings of them.(defvarmath-tzone-names'(("MEGT"-1"MET""METDST"); Middle Europe("METDST"-1-1)("MET"-10)("MEGZ"-1"MEZ""MESZ")("MEZ"-10)("MESZ"-1-1)("WEGT"0"WET""WETDST"); Western Europe("WETDST"0-1)("WET"00)("BGT"0"GMT""BST")("GMT"00)("BST"0-1); Britain("NGT"(float35-1)"NST""NDT"); Newfoundland("NST"(float35-1)0)("NDT"(float35-1)-1)("AGT"4"AST""ADT")("AST"40)("ADT"4-1); Atlantic("EGT"5"EST""EDT")("EST"50)("EDT"5-1); Eastern("CGT"6"CST""CDT")("CST"60)("CDT"6-1); Central("MGT"7"MST""MDT")("MST"70)("MDT"7-1); Mountain("PGT"8"PST""PDT")("PST"80)("PDT"8-1); Pacific("YGT"9"YST""YDT")("YST"90)("YDT"9-1); Yukon))(defunmath-daylight-savings-adjust(datezone&optionaldt)(ordate(setqdate(nth1(calcFunc-now))))(let(bump)(if(eq(car-safedate)'date)(setqbump0date(nth1date))(if(anddate(math-realpdate))(let((zadj(assoczonemath-tzone-names)))(ifzadj(setqbump-1date(math-subdate(math-div(nth1zadj)'(float240))))))(math-reject-argdate'datep)))(setqdate(math-floatdate))(ordt(setqdt(math-date-to-dtdate)))(andmath-daylight-savings-hook(funcallmath-daylight-savings-hookdatedtzonebump))))(defuncalcFunc-dsadj(date&optionalzone)(ifzone(or(eq(car-safezone)'var)(math-reject-argzone"*Time zone variable expected"))(setqzone(or(calc-var-value'var-TimeZone)(progn(calcFunc-tzone)(calc-var-value'var-TimeZone)))))(setqzone(and(eq(car-safezone)'var)(upcase(symbol-name(nth1zone)))))(let((zadj(assoczonemath-tzone-names)))(orzadj(math-reject-argzone"*Unrecognized time zone name"))(if(integerp(nth2zadj))(nth2zadj)(math-daylight-savings-adjustdatezone))))(defuncalcFunc-tzconv(datez1z2)(if(math-realpdate)(nth1(calcFunc-tzconv(list'datedate)z1z2))(calcFunc-unixtime(calcFunc-unixtimedatez1)z2)))(defvarmath-daylight-savings-hook'math-std-daylight-savings)(defunmath-std-daylight-savings(datedtzonebump)"Standard North American daylight savings algorithm.This implements the rules for the U.S. and Canada as of 1987.Daylight savings begins on the first Sunday of April at 2 a.m.,and ends on the last Sunday of October at 2 a.m."(cond((<(nth1dt)4)0)((=(nth1dt)4)(let((sunday(math-prev-weekday-in-monthdatedt70)))(cond((<(nth2dt)sunday)0)((=(nth2dt)sunday)(if(>=(nth3dt)(+3bump))-10))(t-1))))((<(nth1dt)10)-1)((=(nth1dt)10)(let((sunday(math-prev-weekday-in-monthdatedt310)))(cond((<(nth2dt)sunday)-1)((=(nth2dt)sunday)(if(>=(nth3dt)(+2bump))0-1))(t0))))(t0)));;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given;;; day of the given month.(defunmath-prev-weekday-in-month(datedtdaywday)(orday(setqday(nth2dt)))(if(>day(math-days-in-month(cardt)(nth1dt)))(setqday(math-days-in-month(cardt)(nth1dt))))(let((zeroth(math-sub(math-floordate)(nth2dt))))(math-sub(nth1(calcFunc-newweek(math-addzerothday)))zeroth)))(defuncalcFunc-pwday(date&optionaldayweekday)(if(eq(car-safedate)'date)(setqdate(nth1date)))(or(math-realpdate)(math-reject-argdate'datep))(if(math-messy-integerpday)(setqday(math-truncday)))(or(integerpday)(math-reject-argday'fixnump))(if(=day0)(setqday31))(and(or(<day7)(>day31))(math-reject-argday'range))(math-prev-weekday-in-monthdate(math-date-to-dtdate)day(orweekday0)))(defuncalcFunc-newweek(date&optionalweekday)(if(eq(car-safedate)'date)(setqdate(nth1date)))(or(math-realpdate)(math-reject-argdate'datep))(orweekday(setqweekday0))(and(math-messy-integerpweekday)(setqweekday(math-truncweekday)))(or(integerpweekday)(math-reject-argweekday'fixnump))(and(or(<weekday0)(>weekday6))(math-reject-argweekday'range))(setqdate(math-floordate))(list'date(math-subdate(calcFunc-weekday(math-subdateweekday)))))(defuncalcFunc-newmonth(date&optionalday)(orday(setqday1))(and(math-messy-integerpday)(setqday(math-truncday)))(or(integerpday)(math-reject-argday'fixnump))(and(or(<day0)(>day31))(math-reject-argday'range))(let((dt(math-date-to-dtdate)))(if(or(=day0)(>day(math-days-in-month(cardt)(nth1dt))))(setqday(math-days-in-month(cardt)(nth1dt))))(and(eq(cardt)1752)(=(nth1dt)9)(if(>=day14)(setqday(-day11))))(list'date(math-add(math-dt-to-date(list(cardt)(nth1dt)1))(1-day)))))(defuncalcFunc-newyear(date&optionalday)(orday(setqday1))(and(math-messy-integerpday)(setqday(math-truncday)))(or(integerpday)(math-reject-argday'fixnump))(let((dt(math-date-to-dtdate)))(if(and(>=day0)(<=day366))(let((max(if(eq(cardt)1752)355(if(math-leap-year-p(cardt))366365))))(if(or(=day0)(>daymax))(setqdaymax))(list'date(math-add(math-dt-to-date(list(cardt)11))(1-day))))(if(and(>=day-12)(<=day-1))(list'date(math-dt-to-date(list(cardt)(-day)1)))(math-reject-argday'range)))))(defuncalcFunc-incmonth(date&optionalstep)(orstep(setqstep1))(and(math-messy-integerpstep)(setqstep(math-truncstep)))(or(math-integerpstep)(math-reject-argstep'integerp))(let*((dt(math-date-to-dtdate))(year(cardt))(month(math-add(1-(nth1dt))step))(extra(calcFunc-idivmonth12))(day(nth2dt)))(setqmonth(1+(math-submonth(math-mulextra12)))year(math-addyearextra)day(minday(math-days-in-monthyearmonth)))(and(math-posp(cardt))(not(math-pospyear))(setqyear(math-subyear1))); did we go past the year zero?(and(math-negp(cardt))(not(math-negpyear))(setqyear(math-addyear1)))(list'date(math-dt-to-date(consyear(consmonth(consday(cdr(cdr(cdrdt))))))))))(defuncalcFunc-incyear(date&optionalstep)(calcFunc-incmonthdate(math-mul(orstep1)12)))(defuncalcFunc-bsub(ab)(or(eq(car-safea)'date)(math-reject-arga'datep))(if(eq(car-safeb)'date)(if(math-lessp(nth1a)(nth1b))(math-neg(calcFunc-bsubba))(math-setup-holidaysb)(let*((da(math-to-business-daya))(db(math-to-business-dayb)))(math-add(math-sub(carda)(cardb))(if(and(cdrdb)(not(cdrda)))10))))(calcFunc-badda(math-negb))))(defuncalcFunc-badd(ab)(if(eq(car-safeb)'date)(if(eq(car-safea)'date)(math-reject-argnil"*Illegal combination in date arithmetic")(calcFunc-baddba))(if(eq(car-safea)'date)(if(Math-realpb)(if(Math-zeropb)a(let*((d(math-to-business-daya))(bb(math-add(card)(if(and(cdrd)(Math-pospb))(math-subb1)b))))(or(math-from-business-daybb)(calcFunc-baddab))))(if(eq(car-safeb)'hms)(let((hours(nth7math-holidays-cache)))(setqb(math-div(math-from-hmsb'deg)24))(ifhours(setqb(math-divb(cdrhours))))(calcFunc-baddab))(math-reject-argnil"*Illegal combination in date arithmetic")))(math-reject-arga'datep))))(defuncalcFunc-holiday(a)(if(cdr(math-to-business-daya))10))(setqmath-holidays-cachenil)(setqmath-holidays-cache-tagt);;; Compute the number of business days since Jan 1, 1 AD.(defunmath-to-business-day(date&optionalneed-year)(if(eq(car-safedate)'date)(setqdate(nth1date)))(or(Math-realpdate)(math-reject-argdate'datep))(let*((day(math-floordate))(time(math-subdateday))(dt(math-date-to-dtday))(delta0)(holidaynil))(or(notneed-year)(eq(cardt)need-year)(math-reject-arg(list'dateday)"*Generated holiday has wrong year"))(math-setup-holidaysdate)(let((days(carmath-holidays-cache)))(while(and(setqdays(cdrdays))(<(cardays)day))(setqdelta(1+delta)))(anddays(=day(cardays))(setqholidayt)))(let*((weekdays(nth3math-holidays-cache))(weeks(1-(/(+day6)7)))(wkday(-day1(*weeks7))))(setqdelta(+delta(*weeks(lengthweekdays))))(while(andweekdays(<(carweekdays)wkday))(setqweekdays(cdrweekdays)delta(1+delta)))(andweekdays(eqwkday(carweekdays))(setqholidayt)))(let((hours(nth7math-holidays-cache)))(ifhours(progn(setqtime(math-div(math-subtime(carhours))(cdrhours)))(if(Math-lessptime0)(setqtime0))(or(Math-lessptime1)(setqtime(math-sub1(math-div1(math-mul86400(cdrhours)))))))))(cons(math-add(math-subdaydelta)time)holiday)));;; Compute the date a certain number of business days since Jan 1, 1 AD.;;; If this returns NIL, holiday table was adjusted; redo calculation.(defunmath-from-business-day(num)(let*((day(math-floornum))(time(math-subnumday)))(or(integerpday)(math-reject-argnil"*Date is outside valid range"))(math-setup-holidays)(let((days(nth1math-holidays-cache))(delta0))(while(and(setqdays(cdrdays))(<(cardays)day))(setqdelta(1+delta)))(setqday(+daydelta)))(let*((weekdays(nth3math-holidays-cache))(bweek(-7(lengthweekdays)))(weeks(1-(/(+day(1-bweek))bweek)))(wkday(-day1(*weeksbweek)))(w0))(setqday(+day(*weeks(lengthweekdays))))(while(if(memqwweekdays)(setqday(1+day))(>(setqwkday(1-wkday))0))(setqw(1+w)))(let((hours(nth7math-holidays-cache)))(ifhours(setqtime(math-add(math-multime(cdrhours))(carhours)))))(and(not(math-setup-holidaysday))(list'date(math-adddaytime))))))(defunmath-setup-holidays(&optionaldate)(or(eq(calc-var-value'var-Holidays)math-holidays-cache-tag)(let((h(calc-var-value'var-Holidays))(wdnames'((sun.0)(mon.1)(tue.2)(wed.3)(thu.4)(fri.5)(sat.6)))(daysnil)(weekdaysnil)(exprsnil)(limitnil)(hoursnil))(or(math-vectorph)(math-reject-argh"*Holidays variable must be a vector"))(while(setqh(cdrh))(cond((or(and(eq(car-safe(carh))'date)(integerp(nth1(carh))))(and(eq(car-safe(carh))'intv)(eq(car-safe(nth2(carh)))'date))(eq(car-safe(carh))'vec))(setqdays(cons(carh)days)))((and(eq(car-safe(carh))'var)(assq(nth1(carh))wdnames))(setqweekdays(cons(cdr(assq(nth1(carh))wdnames))weekdays)))((and(eq(car-safe(carh))'intv)(eq(car-safe(nth2(carh)))'hms)(eq(car-safe(nth3(carh)))'hms))(ifhours(math-reject-arg(carh)"*Only one hours interval allowed in Holidays"))(setqhours(math-div(carh)'(hms2400)))(if(or(Math-lessp(nth2hours)0)(Math-lessp1(nth3hours)))(math-reject-arg(carh)"*Hours interval out of range"))(setqhours(cons(nth2hours)(math-sub(nth3hours)(nth2hours))))(if(Math-zerop(cdrhours))(math-reject-arg(carh)"*Degenerate hours interval")))((or(and(eq(car-safe(carh))'intv)(Math-integerp(nth2(carh)))(Math-integerp(nth3(carh))))(and(integerp(carh))(>(carh)1900)(<(carh)2100)))(iflimit(math-reject-arg(carh)"*Only one limit allowed in Holidays"))(setqlimit(calcFunc-vint(carh)'(intv312737)))(if(equallimit'(vec))(math-reject-arg(carh)"*Limit is out of range")))((or(math-expr-contains(carh)'(varyvar-y))(math-expr-contains(carh)'(varmvar-m)))(setqexprs(cons(carh)exprs)))(t(math-reject-arg(carh)"*Holidays must contain a vector of holidays"))))(if(=(lengthweekdays)7)(math-reject-argnil"*Too many weekend days"))(setqmath-holidays-cache(list(list-1); 0: days list(list-1); 1: inverse-days listnil; 2: exprs(sortweekdays'<)(orlimit'(intv312737))nil; 5: (lo.hi) expanded years(consexprsdays)hours); 7: business hoursmath-holidays-cache-tag(calc-var-value'var-Holidays))))(ifdate(let((year(calcFunc-yeardate))(limits(nth5math-holidays-cache))(donenil))(or(eq(calcFunc-inyear(nth4math-holidays-cache))1)(progn(or(eq(car-safedate)'date)(setqdate(list'datedate)))(math-reject-argdate"*Date is outside valid range")))(unwind-protect(let((days(nth6math-holidays-cache)))(ifdays(let((yearnil)); see below(setcar(nthcdr6math-holidays-cache)nil)(math-setup-add-holidays(cons'vec(cdrdays)))(setcar(nthcdr2math-holidays-cache)(cardays))))(cond((not(nth2math-holidays-cache))(setqdonet)nil)((notlimits)(setcar(nthcdr5math-holidays-cache)(consyearyear))(math-setup-year-holidaysyear)(setqdonet))((<year(carlimits))(message"Computing holidays, %d .. %d"year(1-(carlimits)))(calc-set-command-flag'clear-message)(while(<year(carlimits))(setcarlimits(1-(carlimits)))(math-setup-year-holidays(carlimits)))(setqdonet))((>year(cdrlimits))(message"Computing holidays, %d .. %d"(1+(cdrlimits))year)(calc-set-command-flag'clear-message)(while(>year(cdrlimits))(setcdrlimits(1+(cdrlimits)))(math-setup-year-holidays(cdrlimits)))(setqdonet))(t(setqdonet)nil)))(ordone(setqmath-holidays-cache-tagt))))))(defunmath-setup-year-holidays(year)(let((exprs(nth2math-holidays-cache)))(whileexprs(let*((var-yyear)(var-mnil)(expr(math-evaluate-expr(carexprs))))(if(math-expr-containsexpr'(varmvar-m))(let((var-m0))(while(<=(setqvar-m(1+var-m))12)(math-setup-add-holidays(math-evaluate-exprexpr))))(math-setup-add-holidaysexpr)))(setqexprs(cdrexprs)))))(defunmath-setup-add-holidays(days); uses "year"(cond((eq(car-safedays)'vec)(while(setqdays(cdrdays))(math-setup-add-holidays(cardays))))((eq(car-safedays)'intv)(let((day(math-ceiling(nth2days))))(or(eq(calcFunc-indaydays)1)(setqday(math-addday1)))(while(eq(calcFunc-indaydays)1)(math-setup-add-holidaysday)(setqday(math-addday1)))))((eq(car-safedays)'date)(math-setup-add-holidays(nth1days)))((eqdays0))((integerpdays)(let((b(math-to-business-daydaysyear)))(or(cdrb); don't register holidays twice!(let((prev(carmath-holidays-cache))(iprev(nth1math-holidays-cache)))(while(and(cdrprev)(<(nth1prev)days))(setqprev(cdrprev)iprev(cdriprev)))(setcdrprev(consdays(cdrprev)))(setcdriprev(cons(carb)(cdriprev)))(while(setqiprev(cdriprev))(setcariprev(1-(cariprev))))))))((Math-realpdays)(math-reject-arg(list'datedays)"*Invalid holiday value"))(t(math-reject-argdays"*Holiday formula failed to evaluate"))));;;; Error forms.;;; Build a standard deviation form. [X X X](defunmath-make-sdev(xsigma)(if(memq(car-safex)'(datemodsdevintvvec))(math-reject-argx'realp))(if(memq(car-safesigma)'(datemodsdevintvvec))(math-reject-argsigma'realp))(if(or(Math-negpsigma)(memq(car-safesigma)'(cplxpolar)))(setqsigma(math-abssigma)))(if(and(Math-zeropsigma)(Math-scalarpx))x(list'sdevxsigma)))(defuncalcFunc-sdev(xsigma)(math-make-sdevxsigma));;;; Modulo forms.(defunmath-normalize-mod(a)(let((n(math-normalize(nth1a)))(m(math-normalize(nth2a))))(if(and(math-anglepn)(math-anglepm)(math-pospm))(math-make-modnm)(math-normalize(list'calcFunc-makemodnm)))));;; Build a modulo form. [N R R](defunmath-make-mod(nm)(setqcalc-previous-modulom)(andn(cond((not(Math-anglepm))(math-reject-argm'anglep))((not(math-pospm))(math-reject-argm'posp))((Math-anglepn)(if(or(Math-negpn)(not(Math-lesspnm)))(list'mod(math-modnm)m)(list'modnm)))((memq(carn)'(+-/vecneg))(math-normalize(cons(carn)(mapcar(function(lambda(x)(math-make-modxm)))(cdrn)))))((and(eq(carn)'*)(Math-anglep(nth1n)))(math-mul(math-make-mod(nth1n)m)(nth2n)))((memq(carn)'(*^varcalcFunc-subscr))(math-mul(math-make-mod1m)n))(t(math-reject-argn'anglep)))))(defuncalcFunc-makemod(nm)(math-make-modnm));;;; Interval forms.;;; Build an interval form. [X S X X](defunmath-make-intv(masklohi)(if(memq(car-safelo)'(cplxpolarmodsdevintvvec))(math-reject-arglo'realp))(if(memq(car-safehi)'(cplxpolarmodsdevintvvec))(math-reject-arghi'realp))(or(eq(eq(car-safelo)'date)(eq(car-safehi)'date))(math-reject-arg(if(eq(car-safelo)'date)hilo)'datep))(if(and(or(Math-realplo)(eq(carlo)'date))(or(Math-realphi)(eq(carhi)'date)))(let((cmp(math-comparelohi)))(if(=cmp0)(if(=mask3)lo(list'intvmasklohi))(if(>cmp0)(if(=mask3)(list'intv2lolo)(list'intvmasklolo))(list'intvmasklohi))))(list'intvmasklohi)))(defuncalcFunc-intv(masklohi)(if(math-messy-integerpmask)(setqmask(math-truncmask)))(or(natnumpmask)(math-reject-argmask'fixnatnump))(or(<=mask3)(math-reject-argmask'range))(math-make-intvmasklohi))(defunmath-sort-intv(masklohi)(if(Math-lessphilo)(math-make-intv(aref[0213]mask)hilo)(math-make-intvmasklohi)))(defunmath-combine-intervals(aambbmccmddm)(let(res)(if(=(setqres(math-compareac))1)(setqacamcm)(if(=res0)(setqam(oramcm))))(if(=(setqres(math-comparebd))-1)(setqbdbmdm)(if(=res0)(setqbm(orbmdm))))(math-make-intv(+(ifam20)(ifbm10))ab)))(defunmath-div-mod(abm); [R R R R] (Returns nil if no solution)(and(Math-integerpa)(Math-integerpb)(Math-integerpm)(let((u11)(u3b)(v10)(v3m))(while(not(eqv30)); See Knuth sec 4.5.2, exercise 15(let*((q(math-idivmodu3v3))(t1(math-subu1(math-mulv1(carq)))))(setqu1v1u3v3v1t1v3(cdrq))))(let((q(math-idivmodau3)))(and(eq(cdrq)0)(math-mod(math-mul(carq)u1)m))))))(defunmath-mod-intv(ab)(let*((q1(math-floor(math-div(nth2a)b)))(q2(math-floor(math-div(nth3a)b)))(m1(math-sub(nth2a)(math-mulq1b)))(m2(math-sub(nth3a)(math-mulq2b))))(cond((equalq1q2)(math-sort-intv(nth1a)m1m2))((and(math-equal-int(math-subq2q1)1)(math-zeropm2)(memq(nth1a)'(02)))(math-make-intv(nth1a)m1b))(t(math-make-intv20b)))))(defunmath-read-angle-brackets()(let*((last(or(math-check-for-commast)(lengthexp-str)))(str(substringexp-strexp-poslast))(res(if(string-match"\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:"str)(let((str1(substringstr0(1-(match-end0))))(str2(substringstr(match-end0)))(calc-hashes-used0))(setqstr1(math-read-expr(concat"["str1"]")))(if(eq(car-safestr1)'error)str1(setqstr2(math-read-exprstr2))(if(eq(car-safestr2)'error)str2(append'(calcFunc-lambda)(cdrstr1)(liststr2)))))(if(string-match"#"str)(let((calc-hashes-used0))(and(setqstr(math-read-exprstr))(if(eq(car-safestr)'error)str(append'(calcFunc-lambda)(calc-invent-argscalc-hashes-used)(liststr)))))(math-parse-datestr)))))(if(stringpres)(throw'syntaxres))(if(eq(car-saferes)'error)(throw'syntax(nth2res)))(setqexp-pos(1+last))(math-read-token)res))