diff options
Diffstat (limited to '')
-rw-r--r-- | module/srfi/srfi-19/alt.scm | 348 | ||||
-rw-r--r-- | module/srfi/srfi-19/alt/util.scm | 107 |
2 files changed, 455 insertions, 0 deletions
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm new file mode 100644 index 00000000..b3e8a478 --- /dev/null +++ b/module/srfi/srfi-19/alt.scm @@ -0,0 +1,348 @@ +(define-module (srfi srfi-19 alt) + :export (date? year month day + hour minute second + time? datetime? + ) + + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (ice-9 match) + + :use-module (util) + ) + +(define-many define-public + (jan january ) 1 + (feb february ) 2 + (mar mars ) 3 + (apr april ) 4 + (may ) 5 + (jun june ) 6 + (jul july ) 7 + (aug august ) 8 + (sep september ) 9 + (oct october ) 10 + (nov november ) 11 + (dec december ) 12 + ) + +(define-immutable-record-type <date> + (make-date year month day) + date? + (year year) (month month) (day day)) + +(set-record-type-printer! + <date> + (lambda (r p) + (format p "~4'0d~2'0d~2'0d" + (year r) (month r) (day r)))) + +(define*-public (date key: (year 0) (month 0) (day 0)) + (make-date year month day)) + + +;; int -> bool +(define-public (leap-year? year) + (and (zero? (remainder year 4)) + (or (zero? (remainder year 400)) + (not (zero? (remainder year 100)))))) + +;; Returns number of days month for a given date. Just looks at the year and month components. +(define-public (days-in-month date) + (case* (month date) + ((jan mar may jul aug oct dec) 31) + ((apr jun sep nov) 30) + ((feb) + (if (leap-year? (year date)) + 29 28)))) + +(define-public (days-in-year date) + (if (leap-year? (year date)) + 366 365)) + +;; 2020-01-10 + 0-0-30 = 2020-02-09 +;; 10 + 30 = 40 ; day + day +;; 40 > 31 ; target days > days in month +;; 2020-02-00 + 0-0- (40 - 31) ; +;; 2020-02-09 + +(define-public (date= a b) + (and (= (year a) (year b)) + (= (month a) (month b)) + (= (day a) (day b)))) + +(define-public date=? date=) + +(define (date+% base change) + + ;; while (day base) > (days-in-month base) + ;; month++; days -= (days-in-month base) + (define days-fixed + (let loop ((target (set (day base) = (+ (day change))))) + (if (> (day target) (days-in-month target)) + (loop (set-> target + (month = (+ 1)) + (day = (- (days-in-month target))))) + target))) + + ;; while (month base) > 12 + ;; year++; month -= 12 + (define months-fixed + (let loop ((target (set (month days-fixed) = (+ (month change))))) + (if (> (month target) 12) + (loop (set-> target + (year = (+ 1)) + (month = (- 12)))) + target))) + + (set (year months-fixed) = (+ (year change)))) + +(define-public (date+ base . rest) + (fold date+% base rest)) + +(define-public (date- base change) + + (define-values (days-fixed change*) + (let loop ((target base) (change change)) + (if (>= (day change) (day target)) + (loop (set-> target + (month = (- 1)) + (day (days-in-month (set (month target) = (- 1))))) + (set (day change) = (- (day target)))) + (values (set (day target) = (- (day change))) + (set (day change) 0))))) + + (define-values (month-fixed change**) + (let loop ((target days-fixed) (change change*)) + (if (>= (month change) (month target)) + (loop (set-> target + (year = (- 1)) + (month 12)) + (set (month change) = (- (month target)))) + (values (set (month target) = (- (month change))) + (set (month change) 0))))) + + ;; change** should here should have both month and date = 0 + + (set (year month-fixed) = (- (year change)))) + +(define-public (time- base change) + + (define-values (second-fixed change*) + (let loop ((target base) (change change)) + (if (> (second change) (second target)) + (loop (set-> target + (minute = (- 1)) + (second 60)) + (set (second change) = (- (second target)))) + (values (set (second target) = (- (second change))) + (set (second change) 0))))) + + (define-values (minute-fixed change**) + (let loop ((target second-fixed) (change change*)) + (if (> (minute change) (minute target)) + (loop (set-> target + (hour = (- 1)) + (minute 60)) + (set (minute change) = (- (minute target)))) + (values (set (minute target) = (- (minute change))) + (set (minute change) 0))))) + + ;; change** should here should have both month and date = 0 + + (set (hour month-fixed) = (- (hour change))) + ) + + + +(define-immutable-record-type <time> + (make-time hour minute second utc) + time? + (hour hour) (minute minute) (second second) + (utc utc) ; bool + ) + +(set-record-type-printer! + <time> + (lambda (r p) + (format p "~2'0d:~2'0d:~2'0d~a" + (hour r) (minute r) (second r) + (if (utc r) "Z" "")))) + +(define-public (time->string time _) + (with-output-to-string (lambda () (display time)))) + +(define*-public (time key: (hour 0) (minute 0) (second 0) (utc #f)) + (make-time hour minute second utc)) + +(define-public (time+% base change) + + ;; while (day base) > (days-in-month base) + ;; month++; days -= (days-in-month base) + (define second-fixed + (let loop ((target (set (second base) = (+ (second change))))) + (if (>= (second target) 60) + (loop (set-> target + (minute = (+ 1)) + (second = (- 60)))) + target))) + + ;; while (month base) > 12 + ;; year++; month -= 12 + (define minute-fixed + (let loop ((target (set (minute second-fixed) = (+ (minute change))))) + (if (>= (minute target) 60) + (loop (set-> target + (hour = (+ 1)) + (minute = (- 60)))) + target))) + + ;; ahtns auoe htns a oeuhnstaoue nhts aoeu nshtaoeu snht oeuia htns oaeu nsht aoeuö ntshaouentsh oaesnuthg aoeu nsthaoeu nshtaou eshtnnh toaeuhnst oeuhtns + (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change)))) + + ;; (format #t "~s ~s ~s~%" second-fixed minute-fixed hour-almost-fixed) + + (if (<= 24 (hour hour-almost-fixed)) + (let* ((div remainder (floor/ (hour hour-almost-fixed) 24))) + (values (set (hour hour-almost-fixed) remainder) div)) + (values hour-almost-fixed 0))) + +(define-public (time+ base . rest) + (fold time+% base rest)) + +(define-immutable-record-type <datetime> + (make-datetime date time tz) + datetime? + (date get-date set-date!) + (time get-time set-time!) + (tz get-tz set-tz!)) + +(export get-date get-time get-tz) + +(define*-public (make-datetime* + key: + (year 0) (month 0) (day 0) + (hour 0) (minute 0) (second 0) + (tz #f)) + (make-datetime (make-date year month day) + (make-time hour minute second #f) + tz)) + +(define-public datetime + (match-lambda* + [(date time) (make-datetime date time #f)] + [(date time tz) (make-datetime date time #f)] + [args (apply make-datetime* args)])) + +(define-public (datetime+ base change) + (let* ((time overflow (time+ (get-time base) (get-time change)))) + (date+ (get-date base) + (get-date change) + (date day: overflow)))) + + + +(define-public (date< a b) + (let ((ay (year a)) + (by (year b))) + (if (= ay ay) + (let ((am (month a)) + (bm (month b))) + (if (= am bm) + (< (day a) (day b)) + (< am bm))) + (< ay by)))) + + +(define-public (time< a b) + (let ((ah (hour a)) + (bh (hour b))) + (if (= ah ah) + (let ((am (minute a)) + (bm (minute b))) + (if (= am bm) + (< (second a) (second b)) + (< am bm))) + (< ah bh)))) + + +(define-public (datetime< a b) + (if (date= (get-date a) (get-date b)) + (time< (get-time a) (get-time b)) + (date< (get-date a) (get-date b)))) + + +(define-many define-public + (date<?) date< + (date> date>?) (swap date<) + + (time<?) time< + (time> time>?) (swap time<) + + (datetime<?) datetime< + (datetime> datetime>?) (swap datetime<)) + + + +;; substring to number, local here +(define (s->n str from to) + (string->number (substring/read-only str from to))) + +(define-public (parse-date str) + (date year: (s->n str 0 4) + month: (s->n str 4 6) + day: (s->n str 6 8))) + +(define-public (parse-time str) + (time hour: (s->n str 0 2) + minute: (s->n str 2 4) + second: (s->n str 4 6) + ;; TODO UTC + )) + +(define-public (parse-datetime str) + (let* (((datestr timestr) (string-split str #\T))) + (datetime (parse-date datestr) + (parse-time timestr)))) + + +(define-public (current-date) + (let ((d ((@ (srfi srfi-19) current-date)))) + (date year: ((@ (srfi srfi-19) date-year) d) + month: ((@ (srfi srfi-19) date-month) d) + day: ((@ (srfi srfi-19) date-day) d)))) + + + + + +;; Reader extensions + +(define (parse-date% str) + (let* (((year month day) (map string->number (string-split str #\-)))) + `(date year: ,year month: ,month day: ,day))) + +(define (parse-time% timestr) + (let* (((hour minute second) (string-split timestr #\:))) + (let ((utc? (string-contains second "Z"))) + (let ((hour (string->number hour)) + (minute (string->number minute)) + (second (string->number (if utc? (string-drop-right second 1) second)))) + `(time hour: ,hour minute: ,minute second: ,second utc: ,utc?))))) + +(define (parse-datetime% str) + (let* (((date time) (string-split str #\T))) + `(datetime ,(parse-date date) + ,(parse-time time)))) + +(define (date-reader chr port) + (unread-char chr port) + (let ((line (symbol->string (read port)))) + (cond [(string-contains line "T") (parse-datetime% line)] + [(string-contains line ":") (parse-time% line)] + [(string-contains line "-") (parse-date% line)]))) + +(read-hash-extend #\0 date-reader) +(read-hash-extend #\1 date-reader) +(read-hash-extend #\2 date-reader) diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm new file mode 100644 index 00000000..9b394105 --- /dev/null +++ b/module/srfi/srfi-19/alt/util.scm @@ -0,0 +1,107 @@ +(define-module (srfi srfi-19 alt util) + :use-module (srfi srfi-19 alt) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-41) + :use-module (util) + ) + +(define-public (start-of-month date) + (set (day date) 0)) + + +(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 (day-stream start-day) + (stream-iterate (cut date+ <> #0-0-1) + start-day)) + +(define (as-date date/-time) + (if (date? date/-time) + date/-time + (get-date date/-time))) + +(define (as-time date/-time) + (if (datetime? date/-time) + (get-time date/-time) + #00:00:00)) + +(define-public (date/-time< a b) + (if (date< (as-date a) (as-date b)) + #t + (time< (as-time a) (as-time b)))) + +(define-public date/-time<? date/-time<) + +(define*-public (date->string date optional: (fmt "~Y-~m-~d")) + (with-output-to-string + (lambda () + (fold (lambda (token state) + (case state + ((#\~) + (case token + ((#\~) (display "~")) + ((#\Y) (format #t "~4'0d" (year date))) + ((#\m) (format #t "~2'0d" (month date))) + ((#\d) (format #t "~2'0d" (day date))) + (else (error "Invalid format token ~a" token))) + #f) + (else (unless (char=? #\~ token) (display token)) token))) + #f + (string->list fmt))))) + +(define*-public (time->string time optional: (fmt "~H:~M:~S")) + (with-output-to-string + (lambda () + (fold (lambda (token state) + (case state + ((#\~) + (case token + ((#\~) (display "~")) + ((#\H) (format #t "~2'0d" (hour date))) + ((#\M) (format #t "~2'0d" (minute date))) + ((#\S) (format #t "~2'0d" (second date))) + (else (error "Invalid format token ~a" token))) + #f) + (else (unless (char=? #\~ token) (display token)) token))) + #f + (string->list fmt))))) + + +;; @verbatim +;; A B C D E ¬F +;; |s1| : |s2| : |s1| : |s2| : : |s1| +;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | | +;; | ||s2| : |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 date) + (date+ date (date day: 1))) + +(define-public (remove-day date) + (date- date (date day: 1))) |