-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdatetime.zp
297 lines (265 loc) · 11.6 KB
/
datetime.zp
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
(module "datetime"
(export
(list :make-datetime make-datetime)
(list :to-ordinal to-ordinal)
(list :from-ordinal from-ordinal)
(list :weekday weekday)
(list :isoweekday isoweekday)
(list :weekday-string weekday-string)
(list :month-string month-string)
(list :to-unix-timestamp to-unix-timestamp)
(list :from-unix-timestamp from-unix-timestamp)
(list :utc? utc?)
(list :to-string to-string)
(list :ddate-for ddate-for)
(list :ddate-from-timestamp ddate-from-timestamp)
(list :isoformat isoformat))
(make-datetime (lambda (year month day . args)
"make a datetime object from year, month and day
(optionally: hours, minutes, seconds, useconds and timezone passed in as a hash-map)"
(define (check-format args)
(define (iffand x y) (if x (eval y) x))
(define h (args "hours"))
(define m (args "minutes"))
(define s (args "seconds"))
(define u (args "usecond"))
(cond
((iffand (not (nil? h)) '(or (< h 0) (> h 23))) [:error "Hours must lie between 0 and 23"])
((iffand (not (nil? m)) '(or (< m 0) (> m 59))) [:error "Minutes must lie between 0 and 59"])
((iffand (not (nil? s)) '(or (< s 0) (> s 59))) [:error "Seconds must lie between 0 and 59"])
((iffand (not (nil? u)) '(or (< u 0) (> u 99999999))) [:error "Nanoseconds must lie between 0 and 99999999"])
(else [:success])))
(cond
((or (> month 12) (< month 1)) (error "Month must lie between 1 and 12"))
((and (= month 2) (> day 29)) (error "Day must lie between 1 and 29"))
((and (= (mod month 2) 1) (> day 30)) (error "Day must lie between 1 and 30"))
((or (> day 31) (< day 1)) (error "Day must lie between 1 and 31"))
(else
(if (null? args)
(make-hash "year" year "month" month "day" day)
(let* ((extra (car args))
(format (check-format extra)))
(if (eqv? (car format) :error)
(error (cadr format))
(make-hash "year" year "month" month "day" day
"hours" (extra "hours")
"min" (extra "minutes")
"sec" (extra "seconds")
"usec" (extra "useconds")
"tz" (extra "timezone")
"tzdelta" (extra "timezone-delta")))))))))
(to-ordinal (lambda (ord . args)
"returns the proleptic gregorian ordinal for a datetime object or a tuple
of the form (year, month, day)"
(if (= 0 (length args))
(_ymd2ord (ord "year") (ord "month") (ord "day"))
(_ymd2ord ord (car args) (cadr args)))))
(from-ordinal (lambda (ord)
"returns a datetime object from a proleptic gregorian ordinal"
(let ((tuple (_ord2ymd ord)))
(make-hash "year" (car tuple) "month" (cadr tuple) "day" (caddr tuple)))))
(weekday (lambda (obj)
"returns the weekday of the given datetime object"
(mod (+ (to-ordinal obj) 6) 7)))
(isoweekday (lambda (obj)
"returns the isoweekday of the given datetime object"
(+ (weekday obj) 1)))
(weekday-string (lambda (obj)
"returns the weekday of the given datetime object"
(_weekday-string (to-ordinal obj))))
(month-string (lambda (obj)
"returns the name of the current month"
(list:ref _MONTHNAMES (obj "month"))))
(to-unix-timestamp (lambda (obj)
"returns the unix timestamp corresponding to the datetime object"
(let ((val-or-zero (lambda (x) (if (null? x) 0 x))))
(_to-unix (obj "year") (obj "month") (obj "day")
(val-or-zero (obj "hours"))
(val-or-zero (obj "min"))
(val-or-zero (obj "sec"))
(val-or-zero (obj "tzdelta"))))))
(from-unix-timestamp (lambda (timestamp)
"returns the datetime object corresponding to the unix timestamp"
(let ((tuple (_from-unix timestamp)))
(make-datetime (car tuple) (cadr tuple) (caddr tuple)
(make-hash "hours" (list:ref tuple 3)
"minutes" (list:ref tuple 4)
"seconds" (list:ref tuple 5))))))
(utc? (lambda (obj)
"returns whether datetime is in utc; if no time zone is set, assume it is"
(if (null? (obj "tz"))
#t
(string-ci=? (obj "tz") "UTC"))))
(to-string (lambda (obj)
"returns date-like string for datetime object"
(let ((val-or (lambda (x dflt) (if (falsy? x) dflt x))))
(_format-time (to-ordinal obj)
(obj "year") (obj "month") (obj "day")
(val-or (obj "hours") 0)
(val-or (obj "min") 0)
(val-or (obj "sec") 0)
(val-or (obj "tz") "GMT")
(val-or (obj "tzdelta") 0)
(val-or (obj "usec") 0)))))
(ddate-from-timestamp (lambda (timestamp)
"returns a ddate string for unix timestamp"
(_hail-eris timestamp)))
(ddate-for (lambda (datetime)
"returns a ddate string for datetime object"
(ddate-from-timestamp (to-unix-timestamp datetime))))
(isoformat (lambda (obj)
"returns a string of the format YYYY-MM-DD"
(++ (number->string (obj "year") 4) "-" (number->string (obj "month") 2) "-" (number->string (obj "day") 2))))
(MINYEAR 1)
(MAXYEAR 9999)
(_MAXORDINAL 3652059)
(_DAYS_IN_MONTH [-1 31 28 31 30 31 30 31 31 30 31 30 31])
(_DAYS_BEFORE_MONTH
(map
(lambda (x)
(let ((el (+ 1 (math:list-sum (list:ref _DAYS_IN_MONTH 0 x)))))
(if (= 1 el) -1 el)))
(range 0 13)))
(_MONTHNAMES ["" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"])
(_DAYNAMES ["" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"])
(_is_leap (lambda (year) "checks whether year is a leap year"
(and (= 0 (mod year 4)) (or (/= 0 (mod year 100)) (= 0 (mod year 400))))))
(_days_before_year (lambda (year) "returns number of days before first day of year"
(let ((y (- year 1)))
(- (+ (* y 365) (/ y 4) (/ y 400)) (/ y 100)))))
(_days_in_month (lambda (year month) "returns number of days in month in year"
(if (and (= month 2) (_is_leap year))
29
(list:ref _DAYS_IN_MONTH month))))
(_days_before_month (lambda (year month) "number of days in year preceding first day of month"
(if (and (> month 2) (_is_leap year))
(+ (list:ref _DAYS_BEFORE_MONTH month) 1)
(list:ref _DAYS_BEFORE_MONTH month))))
(_ymd2ord (lambda (year month day) "ordinal, considering 01-Jan-0001 as day 1"
(let ((dim (_days_in_month year month)))
(+ (_days_before_year year)
(_days_before_month year month)
day))))
(_DI400Y (_days_before_year 401))
(_DI100Y (_days_before_year 101))
(_DI4Y (_days_before_year 5))
(_ord2ymd (lambda (n) "'(year month day), considering 01-Jan-0001 as day 1."
(let* ((n (- n 1))
(tmp (divmod n _DI400Y))
(n400 (car tmp))
(n (cadr tmp))
(year (+ (* n400 400) 1))
(tmp (divmod n _DI100Y))
(n100 (car tmp))
(n (cadr tmp))
(tmp (divmod n _DI4Y))
(n4 (car tmp))
(n (cadr tmp))
(tmp (divmod n 365))
(n1 (car tmp))
(n (cadr tmp))
(year (+ year (* n100 100) (* n4 4) n1)))
(if (or (= n1 4) (= n100 4))
(list (- year 1) 12 31)
(let* ((month (>> (+ n 50) 5))
(prec (+ (list:ref _DAYS_BEFORE_MONTH month)
(if (and (> month 2) (_is_leap year)) 1 0))))
(if (> prec n)
(let* ((month (- month 1))
(prec (- prec (+ (list:ref _DAYS_IN_MONTH month)
(if (and (> month 2) (_is_leap year)) 1 0)))))
(list year month (+ (- n prec) 1)))
(list year month (+ (- n prec) 1))))))))
(_weekday-string (lambda (ordinal)
(list:ref _DAYNAMES (+ (mod (+ ordinal 6) 7) 1))))
(_format-time (lambda (ord y m d hh mm ss tmz tzdelta us)
(let* ((trail (lambda (x) (if (> 2 (length x)) (++ "0" x) x)))
(tzdstr (if (/= 0 tzdelta) (++ " (" (number->string tzdelta) ")") ""))
(fillns (lambda (x)
(define (fill str l)
(if (> l 0)
(fill (++ "0" str) (- l 1))
str))
(fill x (- 6 (length x)))))
(result (++ (_weekday-string ord) " " (number->string d) " "
(list:ref _MONTHNAMES m) " " (number->string y)
" " (trail (number->string hh)) ":" (trail (number->string mm)) ":"
(trail (number->string ss)))))
(if (falsy? us)
(++ result " " tmz tzdstr)
(++ result "." (fillns (number->string us)) " " tmz tzdstr)))))
(_to-unix (lambda (y m d hh mm ss tzdelta)
(let ((yy (reduce
(lambda (acc x)
(if (_is_leap x) (+ 366 acc) (+ 365 acc)))
0
(range 1970 y))))
(+ (* yy 24 60 60)
(* (list:ref _DAYS_BEFORE_MONTH m) 24 60 60)
(* (- d 1) 24 60 60)
(+ (* hh 60 60) tzdelta)
(* mm 60)
ss))))
(_from-unix (lambda (ts)
(let* ((y (/ ts (* 365 24 60 60)))
(ld (- (reduce (lambda (acc n)
(if (_is_leap n) (+ acc 1) acc))
0
(range 1970 (+ y 1971)))
1))
(d (- (/ ts (* 24 60 60)) (* y 365) ld))
(get-m-until (lambda (n)
(reduce (lambda (acc x) (if (< x n) x acc)) 0 _DAYS_BEFORE_MONTH)))
(m (list:index _DAYS_BEFORE_MONTH (get-m-until d)))
(mdays (list:ref _DAYS_BEFORE_MONTH m))
(d (- d mdays))
(tmpy (* y 365 24))
(tmpd (* (+ d ld mdays) 24))
(hh (- (/ ts (* 60 60)) tmpd tmpy))
(tmpy (* tmpy 60))
(tmpd (* tmpd 60))
(tmph (* hh 60))
(mm (- (/ ts 60) tmph tmpd tmpy))
(ss (- ts (* mm 60) (* tmph 60) (* tmpd 60) (* tmpy 60))))
(list (+ y 1970) m d hh mm ss))))
(_SECOND 1)
(_MINUTE (* 60 _SECOND))
(_HOUR (* 60 _MINUTE))
(_DAY (* 24 _HOUR))
(_YEAR (* 365 _DAY))
(_DDAYS {"Sweetmorn" "Boomtime" "Pungenday" "Prickle-Prickle" "Setting Orange"})
(_DSEASONS {"Chaos" "Discord" "Confusion" "Bureaucracy" "The Aftermath"})
(_HOLYDAYS
#{"Chaos" #{5 "Mungday"
50 "Chaoflux"}
"Discord" #{5 "Mojoday"
50 "Discoflux"}
"Confusion" #{5 "Syaday"
50 "Confuflux"}
"Bureaucracy" #{5 "Zaraday"
50 "Bureflux"}
"The Aftermath" #{5 "Maladay"
50 "Afflux"}})
(_hail-eris (lambda (ts)
(let* ((leps (floor (/. ts _YEAR 4)))
(ts (- ts (* leps _DAY)))
(cur (floor (/. (mod ts _YEAR) _DAY)))
(flarf (floor (+ (/. ts _YEAR) 3136)))
(ist (= 0 (mod (- flarf 3130) 4)))
(tabby (and ist (> cur 59)))
(cur (if tabby (sub1 cur) cur))
(gwar (add1 (floor (mod cur 73))))
(sn (floor (/. cur 73)))
(woody (remainder cur 5))
(numstr (lambda (d)
(++ (->string d)
(if (and (> (mod d 100) 11) (< (mod d 100) 21))
"th"
(case (mod d 10)
((1) "st")
((2) "nd")
((3) "rd")
(else "th"))))))
(holy (get-from _HOLYDAYS (list (_DSEASONS sn) gwar) #f)))
(++ (_DDAYS woody) ", " (_DSEASONS sn) " " (numstr gwar) ", " (->string flarf) " YOLD"
(if (truthy? holy) (++ "\nIt's " holy "!") ""))))))