diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2020-01-30 22:51:45 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2020-01-30 22:51:45 +0100 |
commit | f852c30bcef530d18a474ab6ab8350a3ef93d563 (patch) | |
tree | 00fc29a6ff1a8c842d0a526f04d4124977dd6e46 /module/srfi/srfi-19/alt/util.scm | |
parent | Update recurrence generate to new date obj. (diff) | |
download | calp-f852c30bcef530d18a474ab6ab8350a3ef93d563.tar.gz calp-f852c30bcef530d18a474ab6ab8350a3ef93d563.tar.xz |
Once again compiles.
Diffstat (limited to '')
-rw-r--r-- | module/srfi/srfi-19/alt/util.scm | 113 |
1 files changed, 86 insertions, 27 deletions
diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm index 877da69f..3310df85 100644 --- a/module/srfi/srfi-19/alt/util.scm +++ b/module/srfi/srfi-19/alt/util.scm @@ -1,6 +1,6 @@ (define-module (srfi srfi-19 alt util) :use-module (srfi srfi-19 alt) - :use-module (srfi srfi-1) + :use-module ((srfi srfi-1) :select (fold)) :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (util) @@ -19,24 +19,64 @@ (stream-iterate (cut date+ <> #0-0-1) start-day)) -(define-public (as-date date/-time) - (if (date? date/-time) - date/-time - (get-date date/-time))) - -(define-public (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 (month-stream start-day) + (stream-iterate (cut date+ <> #0-1-0) + start-day)) -(define-public date/-time<? date/-time<) +(define-public (time-min a b) + (if (time<? a b) a b)) + +(define-public (time-max a b) + (if (time<? a b) b a)) + + +;; 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 (date->string date optional: (fmt "~Y-~m-~d")) +(define-public (week-day-name week-day-number) + ;; TODO internationalization + (case* week-day-number + [(sun 7) "Sön"] + [(mon) "Mån"] + [(tue) "Tis"] + [(wed) "Ons"] + [(thu) "Tor"] + [(fri) "Fre"] + [(sat) "Lör"])) + +(define*-public (date->string date optional: (fmt "~Y-~m-~d") key: allow-unknown?) (with-output-to-string (lambda () (fold (lambda (token state) @@ -47,13 +87,17 @@ ((#\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))) + ((#\1) (format #t "~4'0d-~2'0d-~2'0d" + (year date) (month date) (day date))) + ((#\a) (display (week-day-name (week-day date)))) + (else (unless allow-unknown? + (error 'date->string "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")) +(define*-public (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?) (with-output-to-string (lambda () (fold (lambda (token state) @@ -61,16 +105,19 @@ ((#\~) (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))) + ((#\H) (format #t "~2'0d" (hour time))) + ((#\M) (format #t "~2'0d" (minute time))) + ((#\S) (format #t "~2'0d" (second time))) + (else (unless allow-unknown? + (error 'time->string "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| @@ -100,8 +147,20 @@ (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 (add-day d) + (date+ d (date day: 1))) + +(define-public (remove-day d) + (date- d (date day: 1))) + + +;; Checks if @var{datetime} is within the date +;; given by @var{base-date}. +;; TODO test time zones +;; date x datetime → bool +(define-public (in-day? base-date date/-time) + (date< base-date (as-date date/-time) (date+ base-date (date day: 1)))) -(define-public (remove-day date) - (date- date (date day: 1))) +(define-public (in-date-range? start-date end-date) + (lambda (date) + (date<= start-date date end-date))) |