-
Notifications
You must be signed in to change notification settings - Fork 7
/
calendar.l
7429 lines (6702 loc) · 252 KB
/
calendar.l
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;;
;;;; CALENDRICA 4.0 -- Common Lisp
;;;; E. M. Reingold and N. Dershowitz
;;;;
;;;; ================================================================
;;;;
;;;; The Functions (code, comments, and definitions) contained in this
;;;; file (the "Program") were written by Edward M. Reingold and Nachum
;;;; Dershowitz (the "Authors"), who retain all rights to them except as
;;;; granted in the License and subject to the warranty and liability
;;;; limitations below. These Functions are explained in the Authors'
;;;; book, "Calendrical Calculations", 4th ed. (Cambridge University
;;;; Press, 2016), and are subject to an international copyright.
;;;;
;;;; The Authors' public service intent is more liberal than suggested
;;;; by the License below, as are their licensing policies for otherwise
;;;; nonallowed uses such as--without limitation--those in commercial,
;;;; web-site, and large-scale academic contexts. Please see the
;;;; web-site
;;;;
;;;; http://www.calendarists.com
;;;;
;;;; for all uses not authorized below; in case there is cause for doubt
;;;; about whether a use you contemplate is authorized, please contact
;;;; the Authors (e-mail: reingold@iit.edu). For commercial licensing
;;;; information, contact the first author at the Department of Computer
;;;; Science, Illinois Institute of Technology, Chicago, IL 60616-3729 USA.
;;;;
;;;; 1. LICENSE. The Authors grant you a license for personal use.
;;;; This means that for strictly personal use you may copy and use the
;;;; code, and keep a backup or archival copy also. The Authors grant you a
;;;; license for re-use within non-commercial, non-profit software provided
;;;; prominent credit is given and the Authors' rights are preserved. Any
;;;; other uses, including without limitation, allowing the code or its
;;;; output to be accessed, used, or available to others, is not permitted.
;;;;
;;;; 2. WARRANTY.
;;;;
;;;; (a) THE AUTHORS PROVIDE NO WARRANTIES OF ANY KIND, EITHER
;;;; EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITING THE
;;;; GENERALITY OF THE FOREGOING, ANY IMPLIED WARRANTY OF
;;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
;;;;
;;;; (b) THE AUTHORS SHALL NOT BE LIABLE TO YOU OR ANY THIRD PARTIES
;;;; FOR DAMAGES OF ANY KIND, INCLUDING WITHOUT LIMITATION, ANY LOST
;;;; PROFITS, LOST SAVINGS, OR ANY OTHER INCIDENTAL OR CONSEQUENTIAL
;;;; DAMAGES ARISING OUT OF OR RELATED TO THE USE, INABILITY TO USE,
;;;; OR INACCURACY OF CALCULATIONS, OF THE CODE AND FUNCTIONS
;;;; CONTAINED HEREIN, OR THE BREACH OF ANY EXPRESS OR IMPLIED
;;;; WARRANTY, EVEN IF THE AUTHORS OR PUBLISHER HAVE BEEN ADVISED OF
;;;; THE POSSIBILITY OF THOSE DAMAGES.
;;;;
;;;; (c) THE FOREGOING WARRANTY MAY GIVE YOU SPECIFIC LEGAL
;;;; RIGHTS WHICH MAY VARY FROM STATE TO STATE IN THE U.S.A.
;;;;
;;;; 3. LIMITATION OF LICENSEE REMEDIES. You acknowledge and agree that
;;;; your exclusive remedy (in law or in equity), and Authors' entire
;;;; liability with respect to the material herein, for any breach of
;;;; representation or for any inaccuracy shall be a refund of the license
;;;; fee or service and handling charge which you paid the Authors, if any.
;;;;
;;;; SOME STATES IN THE U.S.A. DO NOT ALLOW THE EXCLUSION OR LIMITATION OF
;;;; LIABILITY FOR INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO THE ABOVE
;;;; EXCLUSIONS OR LIMITATION MAY NOT APPLY TO YOU.
;;;;
;;;; 4. DISCLAIMER. Except as expressly set forth above, the Authors:
;;;;
;;;; (a) make no other warranties with respect to the material in the
;;;; Program and expressly disclaim any others;
;;;;
;;;; (b) do not warrant that the material contained in the Program will
;;;; meet your requirements or that their operation shall be
;;;; uninterrupted or error-free;
;;;;
;;;; (c) license this material on an "as is" basis, and the entire risk
;;;; as to the quality, accuracy, and performance of the Program is
;;;; yours, should the code prove defective (except as expressly
;;;; warranted herein). You alone assume the entire cost of all
;;;; necessary corrections.
;;;;
;;;; Sample values for the functions (useful for debugging) are given in
;;;; Appendix C of the book.
;;;; Last modified 20 December 2016.
(in-package "CC4")
(export '(
acre
advent
akan-day-name
akan-day-name-on-or-before
akan-name
akan-name-difference
akan-name-from-fixed
akan-prefix
akan-stem
alt-asr
alt-fixed-from-gregorian
alt-gregorian-from-fixed
alt-gregorian-year-from-fixed
alt-hindu-sunrise
alt-orthodox-easter
angle
angle-from-degrees
apparent-from-local
apparent-from-universal
april
arithmetic-french-from-fixed
arithmetic-french-leap-year?
arithmetic-persian-from-fixed
arithmetic-persian-leap-year?
arithmetic-persian-year-from-fixed
armenian-date
armenian-from-fixed
arya-jovian-period
arya-lunar-day
arya-lunar-month
arya-solar-month
arya-solar-year
asr
astro-bahai-from-fixed
astro-hindu-lunar-from-fixed
astro-hindu-solar-from-fixed
astro-hindu-sunset
astronomical-easter
auc-year-from-julian-year
august
autumn
ayanamsha
ayyam-i-ha
aztec-correlation
aztec-tonalpohualli-correlation
aztec-tonalpohualli-date
aztec-tonalpohualli-from-fixed
aztec-tonalpohualli-name
aztec-tonalpohualli-number
aztec-tonalpohualli-on-or-before
aztec-tonalpohualli-ordinal
aztec-xihuitl-correlation
aztec-xihuitl-date
aztec-xihuitl-day
aztec-xihuitl-from-fixed
aztec-xihuitl-month
aztec-xihuitl-on-or-before
aztec-xihuitl-ordinal
aztec-xihuitl-tonalpohualli-on-or-before
aztec-xiuhmolpilli-designation
aztec-xiuhmolpilli-from-fixed
aztec-xiuhmolpilli-name
aztec-xiuhmolpilli-number
babylon
babylonian-date
babylonian-day
babylonian-from-fixed
babylonian-leap
babylonian-leap-year?
babylonian-month
babylonian-new-month-on-or-before
babylonian-year
bahai-cycle
bahai-date
bahai-day
bahai-from-fixed
bahai-location
bahai-major
bahai-month
bahai-new-year
bahai-year
bali-asatawara
bali-asatawara-from-fixed
bali-caturwara
bali-caturwara-from-fixed
bali-dasawara
bali-dasawara-from-fixed
bali-day-from-fixed
bali-dwiwara
bali-dwiwara-from-fixed
bali-luang
bali-luang-from-fixed
bali-on-or-before
bali-pancawara
bali-pancawara-from-fixed
bali-pawukon-from-fixed
bali-sadwara
bali-sadwara-from-fixed
bali-sangawara
bali-sangawara-from-fixed
bali-saptawara
bali-saptawara-from-fixed
bali-triwara
bali-triwara-from-fixed
bali-week-from-fixed
balinese-date
bce
begin
birkath-ha-hama
birthday-of-the-bab
blind
bogus
bright
ce
chinese-age
chinese-branch
chinese-cycle
chinese-date
chinese-day
chinese-day-name
chinese-day-name-on-or-before
chinese-from-fixed
chinese-leap
chinese-location
chinese-month
chinese-month-name
chinese-name
chinese-name-difference
chinese-new-year
chinese-new-year-on-or-before
chinese-sexagesimal-name
chinese-solar-longitude-on-or-after
chinese-stem
chinese-year
chinese-year-marriage-augury
chinese-year-name
christmas
classical-passover-eve
clock-from-moment
coptic-christmas
coptic-date
coptic-from-fixed
coptic-in-gregorian
coptic-leap-year?
current-major-solar-term
current-minor-solar-term
dawn
day-number
day-of-week-from-fixed
daylight-saving-end
daylight-saving-start
days-remaining
daytime-temporal-hour
december
deg
direction
diwali
dragon-festival
double-bright
dusk
dynamical-from-universal
easter
eastern-orthodox-christmas
egyptian-date
egyptian-from-fixed
election-day
elevation
end
epiphany
equation-of-time
ethiopic-date
ethiopic-from-fixed
false
feast-of-ridvan
february
first-kday
first-quarter
fixed-from-arithmetic-french
fixed-from-arithmetic-persian
fixed-from-armenian
fixed-from-astro-bahai
fixed-from-astro-hindu-lunar
fixed-from-astro-hindu-solar
fixed-from-babylonian
fixed-from-bahai
fixed-from-chinese
fixed-from-coptic
fixed-from-egyptian
fixed-from-ethiopic
fixed-from-french
fixed-from-gregorian
fixed-from-hebrew
fixed-from-hindu-fullmoon
fixed-from-hindu-lunar
fixed-from-hindu-solar
fixed-from-icelandic
fixed-from-islamic
fixed-from-iso
fixed-from-jd
fixed-from-julian
fixed-from-mayan-long-count
fixed-from-mjd
fixed-from-molad
fixed-from-moment
fixed-from-observational-hebrew
fixed-from-observational-islamic
fixed-from-old-hindu-lunar
fixed-from-old-hindu-solar
fixed-from-persian
fixed-from-roman
fixed-from-saudi-islamic
fixed-from-samaritan
fixed-from-tibetan
french-date
french-from-fixed
french-leap-year?
french-new-year-on-or-before
friday
from-radix
full
gregorian-date
gregorian-date-difference
gregorian-from-fixed
gregorian-leap-year?
gregorian-new-year
gregorian-year-end
gregorian-year-from-fixed
hanukkah
hebrew-birthday-in-gregorian
hebrew-date
hebrew-from-fixed
hebrew-from-molad
hebrew-in-gregorian
hebrew-leap-year?
hebrew-new-year
hebrew-sabbatical-year?
hindu-day-count
hindu-fullmoon-from-fixed
hindu-location
hindu-lunar-date
hindu-lunar-day
hindu-lunar-day-at-or-after
hindu-lunar-from-fixed
hindu-lunar-holiday
hindu-lunar-leap-day
hindu-lunar-leap-month
hindu-lunar-month
hindu-lunar-new-year
hindu-lunar-station
hindu-lunar-year
hindu-solar-date
hindu-solar-from-fixed
hindu-solar-longitude-at-or-after
hindu-standard-from-sundial
hindu-sunrise
hindu-sunset
hour
hr
icelandic-date
icelandic-from-fixed
icelandic-leap-year?
icelandic-month
icelandic-season
icelandic-summer
icelandic-week
icelandic-weekday
icelandic-winter
icelandic-year
ides
ides-of-month
in-range?
independence-day
interval
interval-closed
islamic-date
islamic-from-fixed
islamic-in-gregorian
islamic-leap-year?
islamic-location
islamic-sunrise
islamic-sunset
iso-date
iso-day
iso-from-fixed
iso-long-year?
iso-week
iso-year
january
japanese-location
jd-epoch
jd-from-fixed
jd-from-moment
jerusalem
jewish-dusk
jewish-morning-end
jewish-sabbath-ends
jovian-year
julian-date
julian-from-fixed
julian-in-gregorian
julian-leap-year?
julian-year-from-auc-year
julian-year-from-olympiad
july
june
kajeng-keliwon
kalends
karana
kday-after
kday-before
kday-nearest
kday-on-or-after
kday-on-or-before
korean-location
korean-year
labor-day
last-day-of-gregorian-month
last-day-of-hebrew-month
last-kday
last-month-of-hebrew-year
last-quarter
latitude
list-range
local-from-apparent
local-from-standard
local-from-universal
location
longitude
losar
lunar-altitude
lunar-diameter
lunar-distance
lunar-latitude
lunar-longitude
lunar-phase
lunar-phase-at-or-after
lunar-phase-at-or-before
major-solar-term-on-or-after
march
mawlid
may
mayan-baktun
mayan-calendar-round-on-or-before
mayan-haab-date
mayan-haab-day
mayan-haab-from-fixed
mayan-haab-month
mayan-haab-on-or-before
mayan-katun
mayan-kin
mayan-long-count-date
mayan-long-count-from-fixed
mayan-tun
mayan-tzolkin-date
mayan-tzolkin-from-fixed
mayan-tzolkin-name
mayan-tzolkin-number
mayan-tzolkin-on-or-before
mayan-uinal
mayan-year-bearer-from-fixed
mecca
memorial-day
mesha-samkranti
midday
midnight
minor-solar-term-on-or-after
mins
minute
mjd-epoch
mjd-from-fixed
mn
molad
momemnt-from-unix
moment-from-jd
monday
moonrise
moonset
mt
naw-ruz
new
new-moon-at-or-after
new-moon-before
nighttime-temporal-hour
nones
nones-of-month
november
nowruz
nth-kday
nth-new-moon
observational-hebrew-first-of-nisan
observational-hebrew-from-fixed
observational-islamic-from-fixed
observed-lunar-altitude
october
old-hindu-lunar-date
old-hindu-lunar-day
old-hindu-lunar-from-fixed
old-hindu-lunar-leap
old-hindu-lunar-leap-year?
old-hindu-lunar-month
old-hindu-lunar-year
old-hindu-solar-from-fixed
olympiad
olympiad-cycle
olympiad-from-julian-year
olympiad-start
olympiad-year
omer
orthodox-easter
paris
passover
pentecost
persian-date
persian-from-fixed
persian-new-year-on-or-before
phasis-on-or-after
phasis-on-or-before
positions-in-range
possible-hebrew-days
purim
qing-ming
quotient
rama
rd
refraction
roman-count
roman-date
roman-event
roman-from-fixed
roman-leap
roman-month
roman-year
sacred-wednesdays
samaritan-from-fixed
samaritan-location
saturday
saudi-islamic-from-fixed
season-in-gregorian
sec
seconds
secs
september
sh-ela
shiva
sidereal-from-moment
sidereal-solar-longitude
solar-longitude
solar-longitude-after
spring
standard-day
standard-from-local
standard-from-sundial
standard-from-universal
standard-month
standard-year
summer
sunday
sunrise
sunset
ta-anit-esther
tehran
thursday
tibetan-from-fixed
tibetan-new-year
time-from-clock
time-from-moment
time-of-day
tishah-be-av
to-radix
topocentric-lunar-altitude
true
tuesday
tumpek
ujjain
universal-from-apparent
universal-from-dynamical
universal-from-local
universal-from-standard
unix-epoch
unix-from-moment
unlucky-fridays-in-range
vietnamese-location
wednesday
widow
winter
yahrzeit-in-gregorian
year-rome-founded
yoga
yom-ha-zikkaron
yom-kippur
zone
))
;;;; Section: Basic Code
(defconstant true
;; TYPE boolean
;; Constant representing true.
t)
(defconstant false
;; TYPE boolean
;; Constant representing false.
nil)
(defconstant bogus
;; TYPE string
;; Used to denote nonexistent dates.
"bogus")
(defun quotient (m n)
;; TYPE (real nonzero-real) -> integer
;; Whole part of $m$/$n$.
(floor m n))
(defun amod (x y)
;; TYPE (integer nonzero-integer) -> integer
;; The value of ($x$ mod $y$) with $y$ instead of 0.
(+ y (mod x (- y))))
(defun mod3 (x a b)
;; TYPE (real real real) -> real
;; The value of $x$ shifted into the range
;; [$a$..$b$). Returns $x$ if $a=b$.
(if (= a b)
x
(+ a (mod (- x a) (- b a)))))
(defmacro next (index initial condition)
;; TYPE (* integer (integer->boolean)) -> integer
;; First integer greater or equal to $initial$ such that
;; $condition$ holds.
`(loop for ,index from ,initial
when ,condition
return ,index))
(defmacro final (index initial condition)
;; TYPE (* integer (integer->boolean)) -> integer
;; Last integer greater or equal to $initial$ such that
;; $condition$ holds.
`(loop for ,index from ,initial
when (not ,condition)
return (1- ,index)))
(defmacro sum (expression index initial condition)
;; TYPE ((integer->real) * integer (integer->boolean))
;; TYPE -> real
;; Sum $expression$ for $index$ = $initial$ and successive
;; integers, as long as $condition$ holds.
`(loop for ,index from ,initial
while ,condition
sum ,expression))
(defmacro prod (expression index initial condition)
;; TYPE ((integer->real) * integer (integer->boolean))
;; TYPE -> real
;; Product of $expression$ for $index$ = $initial$ and successive
;; integers, as long as $condition$ holds.
`(apply '*
(loop for ,index from ,initial
while ,condition
collect ,expression)))
(defmacro binary-search (l lo h hi x test end)
;; TYPE (* real * real * (real->boolean)
;; TYPE ((real real)->boolean)) -> real
;; Bisection search for $x$ in [$lo$..$hi$] such that
;; $end$ holds. $test$ determines when to go left.
(let* ((left (gensym)))
`(do* ((,x false (/ (+ ,h ,l) 2))
(,left false ,test)
(,l ,lo (if ,left ,l ,x))
(,h ,hi (if ,left ,x ,h)))
(,end (/ (+ ,h ,l) 2)))))
(defmacro invert-angular (f y r)
;; TYPE (real->angle real interval) -> real
;; Use bisection to find inverse of angular function
;; $f$ at $y$ within interval $r$.
(let* ((varepsilon 1/100000)); Desired accuracy
`(binary-search l (begin ,r) u (end ,r) x
(< (mod (- (,f x) ,y) 360) (deg 180))
(< (- u l) ,varepsilon))))
(defmacro sigma (list body)
;; TYPE (list-of-pairs (list-of-reals->real))
;; TYPE -> real
;; $list$ is of the form ((i1 l1)...(in ln)).
;; Sum of $body$ for indices i1...in
;; running simultaneously thru lists l1...ln.
`(apply '+ (mapcar (function (lambda
,(mapcar 'car list)
,body))
,@(mapcar 'cadr list))))
(defun poly (x a)
;; TYPE (real list-of-reals) -> real
;; Sum powers of $x$ with coefficients (from order 0 up)
;; in list $a$.
(if (equal a nil)
0
(+ (first a) (* x (poly x (rest a))))))
(defun rd (tee)
;; TYPE moment -> moment
;; Identity function for fixed dates/moments. If internal
;; timekeeping is shifted, change $epoch$ to be RD date of
;; origin of internal count. $epoch$ should be an integer.
(let* ((epoch 0))
(- tee epoch)))
(defconstant sunday
;; TYPE day-of-week
;; Residue class for Sunday.
0)
(defconstant monday
;; TYPE day-of-week
;; Residue class for Monday.
1)
(defconstant tuesday
;; TYPE day-of-week
;; Residue class for Tuesday.
2)
(defconstant wednesday
;; TYPE day-of-week
;; Residue class for Wednesday.
3)
(defconstant thursday
;; TYPE day-of-week
;; Residue class for Thursday.
4)
(defconstant friday
;; TYPE day-of-week
;; Residue class for Friday.
5)
(defconstant saturday
;; TYPE day-of-week
;; Residue class for Saturday.
6)
(defun day-of-week-from-fixed (date)
;; TYPE fixed-date -> day-of-week
;; The residue class of the day of the week of $date$.
(mod (- date (rd 0) sunday) 7))
(defun standard-month (date)
;; TYPE standard-date -> standard-month
;; Month field of $date$ = (year month day).
(second date))
(defun standard-day (date)
;; TYPE standard-date -> standard-day
;; Day field of $date$ = (year month day).
(third date))
(defun standard-year (date)
;; TYPE standard-date -> standard-year
;; Year field of $date$ = (year month day).
(first date))
(defun time-of-day (hour minute second)
;; TYPE (hour minute second) -> clock-time
(list hour minute second))
(defun hour (clock)
;; TYPE clock-time -> hour
(first clock))
(defun minute (clock)
;; TYPE clock-time -> minute
(second clock))
(defun seconds (clock)
;; TYPE clock-time -> second
(third clock))
(defun fixed-from-moment (tee)
;; TYPE moment -> fixed-date
;; Fixed-date from moment $tee$.
(floor tee))
(defun time-from-moment (tee)
;; TYPE moment -> time
;; Time from moment $tee$.
(mod tee 1))
(defun from-radix (a b &optional c)
;; TYPE (list-of-reals list-of-rationals list-of-rationals)
;; TYPE -> real
;; The number corresponding to $a$ in radix notation
;; with base $b$ for whole part and $c$ for fraction.
(/ (sum (* (nth i a)
(prod (nth j (append b c))
j i (< j (+ (length b) (length c)))))
i 0 (< i (length a)))
(apply '* c)))
(defun to-radix (x b &optional c)
;; TYPE (real list-of-rationals list-of-rationals)
;; TYPE -> list-of-reals
;; The radix notation corresponding to $x$
;; with base $b$ for whole part and $c$ for fraction.
(if (null c)
(if (null b)
(list x)
(append (to-radix (quotient x (nth (1- (length b)) b))
(butlast b) nil)
(list (mod x (nth (1- (length b)) b)))))
(to-radix (* x (apply '* c)) (append b c))))
(defun clock-from-moment (tee)
;; TYPE moment -> clock-time
;; Clock time hour:minute:second from moment $tee$.
(rest (to-radix tee nil (list 24 60 60))))
(defun time-from-clock (hms)
;; TYPE clock-time -> time
;; Time of day from $hms$ = hour:minute:second.
(/ (from-radix hms nil (list 24 60 60)) 24))
(defun degrees-minutes-seconds (d m s)
;; TYPE (degree minute real) -> angle
(list d m s))
(defun angle-from-degrees (alpha)
;; TYPE angle -> list-of-reals
;; List of degrees-arcminutes-arcseconds from angle $alpha$
;; in degrees.
(let* ((dms (to-radix (abs alpha) nil (list 60 60))))
(if (>= alpha 0)
dms
(list ; degrees-minutes-seconds
(- (first dms)) (- (second dms)) (- (third dms))))))
(defconstant jd-epoch
;; TYPE moment
;; Fixed time of start of the julian day number.
(rd -1721424.5L0))
(defun moment-from-jd (jd)
;; TYPE julian-day-number -> moment
;; Moment of julian day number $jd$.
(+ jd jd-epoch))
(defun jd-from-moment (tee)
;; TYPE moment -> julian-day-number
;; Julian day number of moment $tee$.
(- tee jd-epoch))
(defun fixed-from-jd (jd)
;; TYPE julian-day-number -> fixed-date
;; Fixed date of julian day number $jd$.
(floor (moment-from-jd jd)))
(defun jd-from-fixed (date)
;; TYPE fixed-date -> julian-day-number
;; Julian day number of fixed $date$.
(jd-from-moment date))
(defconstant mjd-epoch
;; TYPE fixed-date
;; Fixed time of start of the modified julian day number.
(rd 678576))
(defun fixed-from-mjd (mjd)
;; TYPE julian-day-number -> fixed-date
;; Fixed date of modified julian day number $mjd$.
(+ mjd mjd-epoch))
(defun mjd-from-fixed (date)
;; TYPE fixed-date -> julian-day-number
;; Modified julian day number of fixed $date$.
(- date mjd-epoch))
(defconstant unix-epoch
;; TYPE fixed-date
;; Fixed date of the start of the Unix second count.
(rd 719163))
(defun moment-from-unix (s)
;; TYPE second -> moment
;; Fixed date from Unix second count $s$
(+ unix-epoch (/ s 24 60 60)))
(defun unix-from-moment (tee)
;; TYPE moment -> second
;; Unix second count from moment $tee$
(* 24 60 60 (- tee unix-epoch)))
(defun sign (y)
;; TYPE real -> {-1,0,+1}
;; Sign of $y$.
(cond
((< y 0) -1)
((> y 0) +1)
(t 0)))
(defun list-of-fixed-from-moments (ell)
;; TYPE list-of-moments -> list-of-fixed-dates
;; List of fixed dates corresponding to list $ell$
;; of moments.
(if (equal ell nil)
nil
(append (list (fixed-from-moment (first ell)))
(list-of-fixed-from-moments (rest ell)))))
(defun interval (t0 t1)
;; TYPE (moment moment) -> interval
;; Half-open interval [$t0$..$t1$).
(list t0 t1))
(defun interval-closed (t0 t1)
;; TYPE (moment moment) -> interval
;; Closed interval [$t0$..$t1$].
(list t0 t1))
(defun begin (range)
;; TYPE interval -> moment
;; Start $t0$ of $range$ [$t0$..$t1$) or [$t0$..$t1$].
(first range))
(defun end (range)
;; TYPE interval -> moment
;; End $t1$ of $range$ [$t0$..$t1$) or [$t0$..$t1$].
(second range))
(defun in-range? (tee range)
;; TYPE (moment interval) -> boolean
;; True if $tee$ is in half-open $range$.
(and (<= (begin range) tee) (< tee (end range))))
(defun list-range (ell range)
;; TYPE (list-of-moments interval) -> list-of-moments
;; Those moments in list $ell$ that occur in $range$.
(if (equal ell nil)
nil
(let* ((r (list-range (rest ell) range)))
(if (in-range? (first ell) range)
(append (list (first ell)) r)
r))))
(defun positions-in-range (p c cap-Delta range)
;; TYPE (nonegative-real positive-real
;; TYPE nonegative-real interval) -> list-of-moments
;; List of occurrences of moment $p$ of $c$-day cycle
;; within $range$.
;; $cap-Delta$ is position in cycle of RD moment 0.
(let* ((a (begin range))
(b (end range))
(date (mod3 (- p cap-Delta) a (+ a c))))
(if (>= date b)
nil
(append (list date)
(positions-in-range p c cap-Delta
(interval (+ a c) b))))))
;;;; Section: Egyptian/Armenian Calendars
(defun egyptian-date (year month day)
;; TYPE (egyptian-year egyptian-month egyptian-day)
;; TYPE -> egyptian-date
(list year month day))
(defconstant egyptian-epoch
;; TYPE fixed-date
;; Fixed date of start of the Egyptian (Nabonasser)
;; calendar.
;; JD 1448638 = February 26, 747 BCE (Julian).
(fixed-from-jd 1448638))
(defun fixed-from-egyptian (e-date)
;; TYPE egyptian-date -> fixed-date
;; Fixed date of Egyptian date $e-date$.
(let* ((month (standard-month e-date))
(day (standard-day e-date))
(year (standard-year e-date)))
(+ egyptian-epoch ; Days before start of calendar
(* 365 (1- year)); Days in prior years
(* 30 (1- month)); Days in prior months this year
day -1))) ; Days so far this month
(defun alt-fixed-from-egyptian (e-date)
;; TYPE egyptian-date -> fixed-date
;; Fixed date of Egyptian date $e-date$.
(+ egyptian-epoch
(sigma ((a (list 365 30 1))
(e-date e-date))
(* a (1- e-date)))))
(defun egyptian-from-fixed (date)
;; TYPE fixed-date -> egyptian-date
;; Egyptian equivalent of fixed $date$.
(let* ((days ; Elapsed days since epoch.
(- date egyptian-epoch))
(year ; Year since epoch.
(1+ (quotient days 365)))
(month; Calculate the month by division.
(1+ (quotient (mod days 365)
30)))
(day ; Calculate the day by subtraction.
(- days
(* 365 (1- year))
(* 30 (1- month))
-1)))