diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-07-04 17:44:34 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-07-07 13:10:38 +0200 |
commit | 517d4aca9c65071452ba9bec57e0dedc574b833c (patch) | |
tree | fa4f5f2087f34d4b963e5ec228856defa45fe746 /module | |
parent | Clean up datetime parsing. (diff) | |
download | calp-517d4aca9c65071452ba9bec57e0dedc574b833c.tar.gz calp-517d4aca9c65071452ba9bec57e0dedc574b833c.tar.xz |
Major reordering in datetime.
Diffstat (limited to 'module')
-rw-r--r-- | module/datetime.scm | 1102 |
1 files changed, 549 insertions, 553 deletions
diff --git a/module/datetime.scm b/module/datetime.scm index 126695d1..a95eac47 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -19,6 +19,9 @@ :re-export (locale-month) ) + +;;; Enums + (define-many define-public (jan january ) 1 (feb february ) 2 @@ -31,8 +34,26 @@ (sep september ) 9 (oct october ) 10 (nov november ) 11 - (dec december ) 12 - ) + (dec december ) 12) + +(define-many define-public + (sun) 0 + (mon) 1 + (tue) 2 + (wed) 3 + (thu) 4 + (fri) 5 + (sat) 6) + + +;;; Configuration + +(define-public week-start (make-parameter sun)) + +(define-config week-start sun + "First day of week" + pre: (ensure (lambda (x) (<= sun x sat))) + post: week-start) ;;; RECORD TYPES @@ -151,6 +172,15 @@ (set (tz (tm->datetime (gmtime n))) "UTC")) + +;; this returns UTC time, with a TZ component set to "UTC" +(define-public (current-datetime) + (unix-time->datetime ((@ (guile) current-time)))) + +(define-public (current-date) + (get-date (current-datetime))) + + ;; datetime → datetime @@ -169,9 +199,31 @@ ;; strip tz-name, to conform with my local time. (set (tz (tm->datetime tm)) #f)))) +(define-public (as-date date/-time) + (cond [(datetime? date/-time) (get-date date/-time)] + [(date? date/-time) date/-time] + [(time? date/-time) (date)] + [else (error "Object not a date, time, or datetime object ~a" date/-time)])) + +(define-public (as-time date/-time) + (cond [(datetime? date/-time) (get-time% date/-time)] + [(date? date/-time) (time)] + [(time? date/-time) date/-time] + [else (error "Object not a date, time, or datetime object ~a" date/-time)])) + +(define-public (as-datetime dt) + (cond [(datetime? dt) dt] + [(date? dt) (datetime date: dt time: (time))] + [(time? dt) (datetime time: dt date: (date))] + [else (error "Object not a date, time, or datetime object ~a" dt)])) + -;;; UTIL +(define-public (date-zero? date) + (= 0 (year date) (month date) (day date))) + +(define-public (time-zero? time) + (= 0 (hour time) (minute time) (second time))) ;; int -> bool (define-public (leap-year? year) @@ -193,27 +245,506 @@ (if (leap-year? (year date)) 366 365)) +(define-public (start-of-month date) + (set (day date) 1)) + +(define-public (end-of-month date) + (set (day date) (days-in-month date))) + +(define-public (start-of-year date) + (set-> date + (day 1) + (month 1))) + +(define-public (date-stream date-increment start-day) + (stream-iterate (lambda (d) (date+ d date-increment)) + start-day)) + +(define-public (day-stream start-day) + (date-stream (date day: 1) start-day)) + +(define-public (month-stream start-day) + (date-stream (date month: 1) start-day)) + +(define-public (week-stream start-day) + (date-stream (date day: 7) start-day)) + +(define-public (time-min a b) + (if (time<? a b) a b)) + +(define-public (time-max a b) + (if (time<? a b) b a)) + +(define-public (date-min a b) + (if (date< a b) a b)) + +(define-public (date-max a b) + (if (date< a b) b a)) + +(define-public (datetime-min a b) + (if (datetime< a b) a b)) + +(define-public (datetime-max a b) + (if (datetime< a b) b a)) + +(define*-public (month+ date-object #:optional (change 1)) + (date+ date-object (date month: change))) + +(define*-public (month- date-object #:optional (change 1)) + (date- date-object (date month: change))) + +;; https://projecteuclid.org/euclid.acta/1485888738 +;; 1. Begel. +;; J sei die Zahl des Jahrhunderts, +;; K die Jahrszahl innerhalb desselben, +;; m die Zahl des Monats, +;; q die Zahl des Monatstags, +;; h die Zahl des Wochentags; +(define (zeller J K m q) + (modulo (+ q + (floor-quotient (* 13 (1+ m)) + 5) + K + (floor-quotient K 4) + 5 + (- J)) + 7)) + +;; 0 indexed, starting at sunday. +(define-public (week-day date) + (let* ((J K (floor/ (year date) 100)) + (m (month date))) + (if (memv m '(1 2)) + (zeller J (1- K) (+ m 12) (day date)) + (zeller J K (month date) (day date))))) + + + +;; given a date, returns the date the first week of that year starts on. +;; @example +;; (week-1-start #2020-01-01 mon) +;; ⇒ 2019-12-30 +;; @end example +(define*-public (week-1-start d optional: (wkst (week-start))) + (let* ((ystart (start-of-year d)) + (day-index (modulo (- (week-day ystart) wkst) 7))) + (if (> day-index 3) + (date+ ystart (date day: (- 7 day-index))) + (date- ystart (date day: day-index))))) + +;; (week-number #2020-01-01 mon) ; => 1 +;; (week-number #2019-12-31 mon) ; => 1 +(define*-public (week-number d optional: (wkst (week-start))) + ;; Calculating week number for starts of week was much simpler. + ;; We can both skip the special cases for Jan 1, 2 & 3. It also + ;; solved some weird bug that was here before. + + (let ((d (start-of-week d wkst))) + (cond + [(and (= 12 (month d)) + (memv (day d) '(29 30 31)) + (< (year d) (year (date+ (start-of-week d wkst) + (date day: 3))))) + 1] + + [else + (let* ((w1-start (week-1-start d wkst)) + (week day (floor/ (days-in-interval w1-start d) + 7))) + (1+ week))]))) + +(define*-public (date-starting-week + week-number d + optional: (wkst (week-start))) + (date+ (week-1-start d wkst) + (date day: (* (1- week-number) 7)))) + + +(define*-public (week-day-name week-day-number optional: truncate-to + key: (locale %global-locale)) + + ;; NOTE this allows days larger than 7 (sunday if counting from monday). + (let ((str (catch 'out-of-range + (lambda () (locale-day (1+ (modulo week-day-number 7)) locale)) + (lambda (oor str num) + (scm-error 'out-of-range 'week-day-name + "~a == (~a % 7) + 1" + (list num week-day-number) + (list week-day-number)))))) + ;; I also know about the @var{locale-day-short} method, but I need + ;; strings of length 2. + (if truncate-to + (string-take str truncate-to) + str))) + + +;; @verbatim +;; A B C D E ¬F +;; |s1| : |s2| : |s1| : |s2| : : |s1| +;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | | +;; | ||s2| : |s1|| | : | || | : | || | : | || | : +;; | | : | | : | || | : | || | : | || | : |s2| +;; | | : | | : | | : | | : : | | +;; +;; Infinitely short ---+|s2| : |s1|+--- : two instants don't overlap +;; events, overlap s1 : s2 : +;; @end verbatim +;; +;; E is covered by both case A and B. +(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end) + "Return whetever or not two timespans overlap." + (or + ;; A + (and (date/-time<? s2-begin s1-end) + (date/-time<? s1-begin s2-end)) + + ;; B + (and (date/-time<? s1-begin s2-end) + (date/-time<? s2-begin s1-end)) + + ;; C + (and (date/-time<=? s1-begin s2-begin) + (date/-time<? s2-end s1-end)) + + ;; D + (and (date/-time<=? s2-begin s1-begin) + (date/-time<? s1-end s2-end)))) + + +;; Returns the first instance of the given week-day after @var{d}. +;; @example +;; (find-first-week-day mon #2020-04-01) +;; => #2020-04-06 +;; (find-first-week-day mon #2020-04-10) +;; => #2020-04-13 +;; (find-first-week-day mon #2020-04-30) +;; => #2020-05-04 +;; @end example +(define-public (find-first-week-day wday d) + (let* ((start-day (week-day d)) + (diff (- wday start-day))) + (date+ d (date day: (modulo diff 7))))) + +;; returns instances of the given week-day in month between +;; month-date and end of month. +;; @example +;; (all-wday-in-month mon #2020-06-01) +;; => (#2020-06-01 #2020-06-08 #2020-06-15 #2020-06-22 #2020-06-29) +;; (all-wday-in-month mon #2020-06-10) +;; => (#2020-06-15 #2020-06-22 #2020-06-29) +;; @end example +;; week-day, date → (list date) +(define-public (all-wday-in-month wday month-date) + (stream->list + (stream-take-while + (lambda (d) (= (month d) (month month-date))) + (week-stream (find-first-week-day wday month-date))))) + + +(define-public (all-wday-in-year wday year-date) + (stream->list + (stream-take-while + (lambda (d) (= (year d) (year year-date))) + (week-stream (find-first-week-day wday year-date))))) + +(define-public (add-day d) + (date+ d (date day: 1))) + +(define-public (remove-day d) + (date- d (date day: 1))) + +(define-public (in-date-range? start-date end-date) + (lambda (date) + (date<= start-date date end-date))) + +;; Returns a list of the seven week days, with @var{week-start} +;; as the beginning of the week. +;; @example +;; (weekday-list sun) +;; => (0 1 2 3 4 5 6) +;; @end example +(define-public (weekday-list week-start) + (take (drop (apply circular-list (iota 7)) + week-start) + 7)) + +;; returns the date the week containing d started. +;; (start-of-week #2020-04-02 sun) ; => 2020-03-29 +(define*-public (start-of-week d optional: (week-start (week-start))) + (date- d (date day: (modulo (- (week-day d) + week-start) + 7)))) + +;; (end-of-week #2020-04-01 mon) +;; => 2020-04-05 +(define*-public (end-of-week d optional: (week-start (week-start))) + (date+ (start-of-week d week-start) + (date day: 6))) + + +;; Given a month and and which day the week starts on, +;; returns three lists, which are: +;; The days leading up to the current month, but share a week +;; The days in the current month +;; The days after the current month, but which shares a week. +;; +;; mars 2020 +;; må ti on to fr lö sö +;; 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 +;; @lisp +;; (month-days #2020-03-01 mon) +;; ; ⇒ (2020-02-24 ... 2020-02-29) +;; ; ⇒ (2020-03-01 ... 2020-03-31) +;; ; ⇒ (2020-04-01 ... 2020-04-05) +;; @end lisp +;; Ignores day component of @var{date}. +(define*-public (month-days date optional: (week-start (week-start))) + (let* ((month-len (days-in-month date)) + (prev-month-len (days-in-month (month- date))) + (month-start (modulo (- (week-day date) week-start) 7))) + (values + (map (lambda (d) (set (day (month- date)) d)) + (iota month-start (1+ (- prev-month-len month-start)))) + (map (lambda (d) (set (day date) d)) (iota month-len 1)) + (map (lambda (d) (set (day (month+ date)) d)) + (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) + + +(define-public (days-in-interval start-date end-date) + (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) + (with-streams + (fold + (day diff) + (map days-in-month + (take (+ (month diff) + (* 12 (year diff))) + (month-stream start-date))))))) + +;; Day from start of the year, so 1 feb would be day 32. +;; Also known as Julian day. +(define-public (year-day date) + (days-in-interval (start-of-year date) date)) + + +;; @example +;; (time->decimal-hour #10:30:00) ; => 10.5 +;; @end example +(define-public (time->decimal-hour time) + (exact->inexact (+ (hour time) + (/ (minute time) 60) + (/ (second time) 3600)))) + +(define*-public (datetime->decimal-hour dt optional: start-date) + + (let ((date-diff + (cond [start-date + (let* ((end-date (date+ start-date (get-date dt)))) + (days-in-interval start-date end-date)) ] + [(or (not (zero? (month (get-date dt)))) + (not (zero? (year (get-date dt))))) + (error "Multi-month intervals only supported when start-date is given" dt)] + [else (day (get-date dt))]))) + (+ (time->decimal-hour (get-time% dt)) + (* (1- date-diff) 24)))) + +;; Returns a list of all dates from start to end. +;; both inclusive +;; date, date → [list date] +(define-public (date-range start end) + (stream->list + (stream-take-while (lambda (d) (date<= d end)) + (day-stream start)))) + +;;; Output -(define-public (as-date date/-time) - (cond [(datetime? date/-time) (get-date date/-time)] - [(date? date/-time) date/-time] - [(time? date/-time) (date)] - [else (error "Object not a date, time, or datetime object ~a" date/-time)])) +(define*-public (datetime->string + datetime + optional: (fmt "~Y-~m-~dT~H:~M:~S") + key: allow-unknown?) + (define date (get-date datetime)) + (define time (get-time% datetime)) + (with-output-to-string + (lambda () + (fold (lambda (token state) + (case state + ((#\~) + (case token + ((#\~) (display "~")) + ((#\H) (format #t "~2'0d" (hour time))) + ((#\k) (format #t "~2' d" (hour time))) + ((#\M) (format #t "~2'0d" (minute time))) + ((#\S) (format #t "~2'0d" (second time))) + ((#\Y) (format #t "~4'0d" (year date))) + ((#\m) (format #t "~2'0d" (month date))) + ((#\d) (format #t "~2'0d" (day date))) + ;; Should be same as ~_d + ((#\s) (display (datetime->unix-time datetime))) ; epoch time! + ((#\e) (format #t "~2' d" (day date))) + ((#\1) (format #t "~4'0d-~2'0d-~2'0d" + (year date) (month date) (day date))) + ((#\3) (format #t "~2'0d:~2'0d:~2'0d" + (hour time) (minute time) (second time))) + ((#\A) (display (week-day-name (week-day date)))) + ((#\a) (display (week-day-name (week-day date) 3))) + ((#\b) (display (locale-month-short (month date)))) + ((#\B) (display (locale-month (month date)))) + ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z"))) + (else (unless allow-unknown? + (error 'datetime->string "Invalid format token ~a" token)))) + #f) + (else (unless (char=? #\~ token) (display token)) token))) + #f + (string->list fmt))))) -(define-public (as-time date/-time) - (cond [(datetime? date/-time) (get-time% date/-time)] - [(date? date/-time) (time)] - [(time? date/-time) date/-time] - [else (error "Object not a date, time, or datetime object ~a" date/-time)])) +(define*-public (date->string date + optional: (fmt "~Y-~m-~d") + key: allow-unknown?) + (datetime->string (datetime date: date) + fmt allow-unknown?: allow-unknown?)) -(define-public (as-datetime dt) - (cond [(datetime? dt) dt] - [(date? dt) (datetime date: dt time: (time))] - [(time? dt) (datetime time: dt date: (date))] - [else (error "Object not a date, time, or datetime object ~a" dt)])) +(define*-public (time->string time + optional: (fmt "~H:~M:~S") + key: allow-unknown?) + (datetime->string (datetime time: time) + fmt allow-unknown?: allow-unknown?)) + + + +;;; Input + +(define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z")) + (let loop ((str (string->list str)) + (fmt (string->list fmt)) + (dt (datetime))) + + (define time (get-time% dt)) + (define date (get-date dt)) + (define (as-dt dt) + (cond [(date? dt) (datetime date: dt time: time)] + [(time? dt) (datetime date: date time: dt)] + [else dt])) + + (cond [(null? str) + ;; (warning "Premature end of string") + dt] + [(null? fmt) + ;; (warning "Unsparsed characters at end of string") + dt] + [(eq? #\~ (car fmt)) + (case (cadr fmt) + [(#\~) (if (eq? #\~ (car str)) + (loop (cdr str) + (cddr fmt) + dt) + (error "Non-match"))] + [(#\Z) + (if (eq? #\Z (car str)) + (loop (cdr str) + (cdr fmt) + (set (tz dt) "UTC")) + (loop str + (cdr fmt) + dt))] + [(#\H #\M #\S #\m #\d) + (let* ((pre post (split-at str 2)) + (num (-> pre list->string string->number))) + (loop + post + (cddr fmt) + (as-dt + (case (cadr fmt) + [(#\H) (set (hour time) num)] + [(#\M) (set (minute time) num)] + [(#\S) (set (second time) num)] + [(#\m) (set (month date) num)] + [(#\d) (set (day date) num)]))))] + + [(#\Y) + (let* ((pre post (split-at str 4)) + (num (-> pre list->string string->number))) + (loop + post + (cddr fmt) + (as-dt (set (year date) num))))] + + [else + (error "Unimplemented or incorrect parse token")])] + [else + (if (eq? (car str) (car fmt)) + (loop (cdr str) + (cdr fmt) + dt) + (error (format #f "Mismatched symbol, expected ~a got ~a" + (car fmt) (car str))))]))) + +(define*-public (string->time str optional: (fmt "~H:~M:~S")) + (get-time% (string->datetime str fmt))) + +(define*-public (string->date str optional: (fmt "~Y-~m-~d")) + (get-date (string->datetime str fmt))) + + +(define-public (parse-ics-date str) + (string->date str "~Y~m~d")) + +(define-public (parse-ics-time str) + (string->time str "~H~M~S")) + +(define*-public (parse-ics-datetime str optional: zone) + (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z"))) + (if (tz dt) + dt + (set (tz dt) zone)))) + +(define-public (parse-iso-date str) + (string->date str)) + +(define-public (parse-iso-time str) + (string->time str)) + +(define-public (parse-iso-datetime str) + (string->datetime str)) + +(define-public (parse-freeform-date str) + (parse-iso-datetime str)) + +(define (date->sexp d) + `(date year: ,(year d) + month: ,(month d) + day: ,(day d))) + +(define (time->sexp t) + `(time hour: ,(hour t) + minute: ,(minute t) + second: ,(second t))) + +(define (datetime->sexp dt) + `(datetime date: ,(get-date dt) + time: ,(get-time% dt) + tz: ,(tz dt))) + +(define (date-reader chr port) + (unread-char chr port) + (let ((line (symbol->string (read port)))) + (cond [(string-contains line "T") + (-> line string->datetime datetime->sexp)] + [(string-contains line ":") + (-> line string->time time->sexp)] + [(string-contains line "-") + (-> line string->date date->sexp)]))) + +(read-hash-extend #\0 date-reader) +(read-hash-extend #\1 date-reader) +(read-hash-extend #\2 date-reader) +;;; Everything below really messy + ;;; EQUIALENCE (define-public (date= . args) @@ -332,11 +863,6 @@ ;;; OPERATIONS -(define-public (date-zero? date) - (= 0 (year date) (month date) (day date))) - -(define-public (time-zero? time) - (= 0 (hour time) (minute time) (second time))) ;; TODO +1 month is weird for late days in a month. ;; is the last of january +1 month the last of february, @@ -628,533 +1154,3 @@ (date day: overflow)) (get-date start)) time: fixed-time))) - - - -;; this returns UTC time, with a TZ component set to "UTC" -(define-public (current-datetime) - (unix-time->datetime ((@ (guile) current-time)))) - -(define-public (current-date) - (get-date (current-datetime))) - - - - - -(define-public (parse-freeform-date str) - (let* (((year month day) (map string->number (string-split str #\-)))) - (date year: year month: month day: day) - )) - -(define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z")) - (let loop ((str (string->list str)) - (fmt (string->list fmt)) - (dt (datetime))) - - (define time (get-time% dt)) - (define date (get-date dt)) - (define (as-dt dt) - (cond [(date? dt) (datetime date: dt time: time)] - [(time? dt) (datetime date: date time: dt)] - [else dt])) - - (cond [(null? str) - ;; (warning "Premature end of string") - dt] - [(null? fmt) - ;; (warning "Unsparsed characters at end of string") - dt] - [(eq? #\~ (car fmt)) - (case (cadr fmt) - [(#\~) (if (eq? #\~ (car str)) - (loop (cdr str) - (cddr fmt) - dt) - (error "Non-match"))] - [(#\Z) - (if (eq? #\Z (car str)) - (loop (cdr str) - (cdr fmt) - (set (tz dt) "UTC")) - (loop str - (cdr fmt) - dt))] - [(#\H #\M #\S #\m #\d) - (let* ((pre post (split-at str 2)) - (num (-> pre list->string string->number))) - (loop - post - (cddr fmt) - (as-dt - (case (cadr fmt) - [(#\H) (set (hour time) num)] - [(#\M) (set (minute time) num)] - [(#\S) (set (second time) num)] - [(#\m) (set (month date) num)] - [(#\d) (set (day date) num)]))))] - - [(#\Y) - (let* ((pre post (split-at str 4)) - (num (-> pre list->string string->number))) - (loop - post - (cddr fmt) - (as-dt (set (year date) num))))] - - [else - (error "Unimplemented or incorrect parse token")])] - [else - (if (eq? (car str) (car fmt)) - (loop (cdr str) - (cdr fmt) - dt) - (error (format #f "Mismatched symbol, expected ~a got ~a" - (car fmt) (car str))))]))) - -(define*-public (string->time str optional: (fmt "~H:~M:~S")) - (get-time% (string->datetime str fmt))) - -(define*-public (string->date str optional: (fmt "~Y-~m-~d")) - (get-date (string->datetime str fmt))) - - - -(define-public (parse-ics-date str) - (string->date str "~Y~m~d")) - -(define-public (parse-ics-time str) - (string->time str "~H~M~S")) - -(define*-public (parse-ics-datetime str optional: zone) - (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z"))) - (if (tz dt) - dt - (set (tz dt) zone)))) - -(define-public (parse-iso-date str) - (string->date str)) - -(define-public (parse-iso-time str) - (string->time str)) - -(define-public (parse-iso-datetime str) - (string->datetime str)) - -(define (date->sexp d) - `(date year: ,(year d) - month: ,(month d) - day: ,(day d))) - -(define (time->sexp t) - `(time hour: ,(hour t) - minute: ,(minute t) - second: ,(second t))) - -(define (datetime->sexp dt) - `(datetime date: ,(get-date dt) - time: ,(get-time% dt) - tz: ,(tz dt))) - -(define (date-reader chr port) - (unread-char chr port) - (let ((line (symbol->string (read port)))) - (cond [(string-contains line "T") - (-> line string->datetime datetime->sexp)] - [(string-contains line ":") - (-> line string->time time->sexp)] - [(string-contains line "-") - (-> line string->date date->sexp)]))) - -(read-hash-extend #\0 date-reader) -(read-hash-extend #\1 date-reader) -(read-hash-extend #\2 date-reader) - - - - - -(define-public (start-of-month date) - (set (day date) 1)) - -(define-public (end-of-month date) - (set (day date) (days-in-month date))) - -(define-public (start-of-year date) - (set-> date - (day 1) - (month 1))) - -(define-public (date-stream date-increment start-day) - (stream-iterate (lambda (d) (date+ d date-increment)) - start-day)) - -(define-public (day-stream start-day) - (date-stream (date day: 1) start-day)) - -(define-public (month-stream start-day) - (date-stream (date month: 1) start-day)) - -(define-public (week-stream start-day) - (date-stream (date day: 7) start-day)) - -(define-public (time-min a b) - (if (time<? a b) a b)) - -(define-public (time-max a b) - (if (time<? a b) b a)) - -(define-public (date-min a b) - (if (date< a b) a b)) - -(define-public (date-max a b) - (if (date< a b) b a)) - -(define-public (datetime-min a b) - (if (datetime< a b) a b)) - -(define-public (datetime-max a b) - (if (datetime< a b) b a)) - -(define*-public (month+ date-object #:optional (change 1)) - (date+ date-object (date month: change))) - -(define*-public (month- date-object #:optional (change 1)) - (date- date-object (date month: change))) - -;; https://projecteuclid.org/euclid.acta/1485888738 -;; 1. Begel. -;; J sei die Zahl des Jahrhunderts, -;; K die Jahrszahl innerhalb desselben, -;; m die Zahl des Monats, -;; q die Zahl des Monatstags, -;; h die Zahl des Wochentags; -(define (zeller J K m q) - (modulo (+ q - (floor-quotient (* 13 (1+ m)) - 5) - K - (floor-quotient K 4) - 5 - (- J)) - 7)) - -;; 0 indexed, starting at sunday. -(define-public (week-day date) - (let* ((J K (floor/ (year date) 100)) - (m (month date))) - (if (memv m '(1 2)) - (zeller J (1- K) (+ m 12) (day date)) - (zeller J K (month date) (day date))))) - - -(define-many define-public - (sun) 0 - (mon) 1 - (tue) 2 - (wed) 3 - (thu) 4 - (fri) 5 - (sat) 6 - ) - - -(define-public week-start (make-parameter sun)) - -(define-config week-start sun - "First day of week" - pre: (ensure (lambda (x) (<= sun x sat))) - post: week-start) - -;; given a date, returns the date the first week of that year starts on. -;; @example -;; (week-1-start #2020-01-01 mon) -;; ⇒ 2019-12-30 -;; @end example -(define*-public (week-1-start d optional: (wkst (week-start))) - (let* ((ystart (start-of-year d)) - (day-index (modulo (- (week-day ystart) wkst) 7))) - (if (> day-index 3) - (date+ ystart (date day: (- 7 day-index))) - (date- ystart (date day: day-index))))) - -;; (week-number #2020-01-01 mon) ; => 1 -;; (week-number #2019-12-31 mon) ; => 1 -(define*-public (week-number d optional: (wkst (week-start))) - ;; Calculating week number for starts of week was much simpler. - ;; We can both skip the special cases for Jan 1, 2 & 3. It also - ;; solved some weird bug that was here before. - - (let ((d (start-of-week d wkst))) - (cond - [(and (= 12 (month d)) - (memv (day d) '(29 30 31)) - (< (year d) (year (date+ (start-of-week d wkst) - (date day: 3))))) - 1] - - [else - (let* ((w1-start (week-1-start d wkst)) - (week day (floor/ (days-in-interval w1-start d) - 7))) - (1+ week))]))) - -(define*-public (date-starting-week - week-number d - optional: (wkst (week-start))) - (date+ (week-1-start d wkst) - (date day: (* (1- week-number) 7)))) - - -(define*-public (week-day-name week-day-number optional: truncate-to - key: (locale %global-locale)) - - ;; NOTE this allows days larger than 7 (sunday if counting from monday). - (let ((str (catch 'out-of-range - (lambda () (locale-day (1+ (modulo week-day-number 7)) locale)) - (lambda (oor str num) - (scm-error 'out-of-range 'week-day-name - "~a == (~a % 7) + 1" - (list num week-day-number) - (list week-day-number)))))) - ;; I also know about the @var{locale-day-short} method, but I need - ;; strings of length 2. - (if truncate-to - (string-take str truncate-to) - str))) - -(define*-public (datetime->string - datetime - optional: (fmt "~Y-~m-~dT~H:~M:~S") - key: allow-unknown?) - (define date (get-date datetime)) - (define time (get-time% datetime)) - (with-output-to-string - (lambda () - (fold (lambda (token state) - (case state - ((#\~) - (case token - ((#\~) (display "~")) - ((#\H) (format #t "~2'0d" (hour time))) - ((#\k) (format #t "~2' d" (hour time))) - ((#\M) (format #t "~2'0d" (minute time))) - ((#\S) (format #t "~2'0d" (second time))) - ((#\Y) (format #t "~4'0d" (year date))) - ((#\m) (format #t "~2'0d" (month date))) - ((#\d) (format #t "~2'0d" (day date))) - ;; Should be same as ~_d - ((#\s) (display (datetime->unix-time datetime))) ; epoch time! - ((#\e) (format #t "~2' d" (day date))) - ((#\1) (format #t "~4'0d-~2'0d-~2'0d" - (year date) (month date) (day date))) - ((#\3) (format #t "~2'0d:~2'0d:~2'0d" - (hour time) (minute time) (second time))) - ((#\A) (display (week-day-name (week-day date)))) - ((#\a) (display (week-day-name (week-day date) 3))) - ((#\b) (display (locale-month-short (month date)))) - ((#\B) (display (locale-month (month date)))) - ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z"))) - (else (unless allow-unknown? - (error 'datetime->string "Invalid format token ~a" token)))) - #f) - (else (unless (char=? #\~ token) (display token)) token))) - #f - (string->list fmt))))) - -(define*-public (date->string date - optional: (fmt "~Y-~m-~d") - key: allow-unknown?) - (datetime->string (datetime date: date) - fmt allow-unknown?: allow-unknown?)) - -(define*-public (time->string time - optional: (fmt "~H:~M:~S") - key: allow-unknown?) - (datetime->string (datetime time: time) - fmt allow-unknown?: allow-unknown?)) - - -;; @verbatim -;; A B C D E ¬F -;; |s1| : |s2| : |s1| : |s2| : : |s1| -;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | | -;; | ||s2| : |s1|| | : | || | : | || | : | || | : -;; | | : | | : | || | : | || | : | || | : |s2| -;; | | : | | : | | : | | : : | | -;; -;; Infinitely short ---+|s2| : |s1|+--- : two instants don't overlap -;; events, overlap s1 : s2 : -;; @end verbatim -;; -;; E is covered by both case A and B. -(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end) - "Return whetever or not two timespans overlap." - (or - ;; A - (and (date/-time<? s2-begin s1-end) - (date/-time<? s1-begin s2-end)) - - ;; B - (and (date/-time<? s1-begin s2-end) - (date/-time<? s2-begin s1-end)) - - ;; C - (and (date/-time<=? s1-begin s2-begin) - (date/-time<? s2-end s1-end)) - - ;; D - (and (date/-time<=? s2-begin s1-begin) - (date/-time<? s1-end s2-end)))) - -(define-public (add-day d) - (date+ d (date day: 1))) - -(define-public (remove-day d) - (date- d (date day: 1))) - -(define-public (in-date-range? start-date end-date) - (lambda (date) - (date<= start-date date end-date))) - -;; Returns a list of the seven week days, with @var{week-start} -;; as the beginning of the week. -;; @example -;; (weekday-list sun) -;; => (0 1 2 3 4 5 6) -;; @end example -(define-public (weekday-list week-start) - (take (drop (apply circular-list (iota 7)) - week-start) - 7)) - -;; returns the date the week containing d started. -;; (start-of-week #2020-04-02 sun) ; => 2020-03-29 -(define*-public (start-of-week d optional: (week-start (week-start))) - (date- d (date day: (modulo (- (week-day d) - week-start) - 7)))) - -;; (end-of-week #2020-04-01 mon) -;; => 2020-04-05 -(define*-public (end-of-week d optional: (week-start (week-start))) - (date+ (start-of-week d week-start) - (date day: 6))) - - -;; Given a month and and which day the week starts on, -;; returns three lists, which are: -;; The days leading up to the current month, but share a week -;; The days in the current month -;; The days after the current month, but which shares a week. -;; -;; mars 2020 -;; må ti on to fr lö sö -;; 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 -;; @lisp -;; (month-days #2020-03-01 mon) -;; ; ⇒ (2020-02-24 ... 2020-02-29) -;; ; ⇒ (2020-03-01 ... 2020-03-31) -;; ; ⇒ (2020-04-01 ... 2020-04-05) -;; @end lisp -;; Ignores day component of @var{date}. -(define*-public (month-days date optional: (week-start (week-start))) - (let* ((month-len (days-in-month date)) - (prev-month-len (days-in-month (month- date))) - (month-start (modulo (- (week-day date) week-start) 7))) - (values - (map (lambda (d) (set (day (month- date)) d)) - (iota month-start (1+ (- prev-month-len month-start)))) - (map (lambda (d) (set (day date) d)) (iota month-len 1)) - (map (lambda (d) (set (day (month+ date)) d)) - (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) - - - - -(define-public (days-in-interval start-date end-date) - (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) - (with-streams - (fold + (day diff) - (map days-in-month - (take (+ (month diff) - (* 12 (year diff))) - (month-stream start-date))))))) - -;; Day from start of the year, so 1 feb would be day 32. -;; Also known as Julian day. -(define-public (year-day date) - (days-in-interval (start-of-year date) date)) - - -;; @example -;; (time->decimal-hour #10:30:00) ; => 10.5 -;; @end example -(define-public (time->decimal-hour time) - (exact->inexact (+ (hour time) - (/ (minute time) 60) - (/ (second time) 3600)))) - -(define*-public (datetime->decimal-hour dt optional: start-date) - - (let ((date-diff - (cond [start-date - (let* ((end-date (date+ start-date (get-date dt)))) - (days-in-interval start-date end-date)) ] - [(or (not (zero? (month (get-date dt)))) - (not (zero? (year (get-date dt))))) - (error "Multi-month intervals only supported when start-date is given" dt)] - [else (day (get-date dt))]))) - (+ (time->decimal-hour (get-time% dt)) - (* (1- date-diff) 24)))) - -;; Returns a list of all dates from start to end. -;; both inclusive -;; date, date → [list date] -(define-public (date-range start end) - (stream->list - (stream-take-while (lambda (d) (date<= d end)) - (day-stream start)))) - - - -;; Returns the first instance of the given week-day after @var{d}. -;; @example -;; (find-first-week-day mon #2020-04-01) -;; => #2020-04-06 -;; (find-first-week-day mon #2020-04-10) -;; => #2020-04-13 -;; (find-first-week-day mon #2020-04-30) -;; => #2020-05-04 -;; @end example -(define-public (find-first-week-day wday d) - (let* ((start-day (week-day d)) - (diff (- wday start-day))) - (date+ d (date day: (modulo diff 7))))) - -;; returns instances of the given week-day in month between -;; month-date and end of month. -;; @example -;; (all-wday-in-month mon #2020-06-01) -;; => (#2020-06-01 #2020-06-08 #2020-06-15 #2020-06-22 #2020-06-29) -;; (all-wday-in-month mon #2020-06-10) -;; => (#2020-06-15 #2020-06-22 #2020-06-29) -;; @end example -;; week-day, date → (list date) -(define-public (all-wday-in-month wday month-date) - (stream->list - (stream-take-while - (lambda (d) (= (month d) (month month-date))) - (week-stream (find-first-week-day wday month-date))))) - - -(define-public (all-wday-in-year wday year-date) - (stream->list - (stream-take-while - (lambda (d) (= (year d) (year year-date))) - (week-stream (find-first-week-day wday year-date))))) |