diff options
Diffstat (limited to 'module/srfi/srfi-19')
-rw-r--r-- | module/srfi/srfi-19/alt.scm | 137 | ||||
-rw-r--r-- | module/srfi/srfi-19/alt/util.scm | 113 | ||||
-rw-r--r-- | module/srfi/srfi-19/setters.scm | 6 | ||||
-rw-r--r-- | module/srfi/srfi-19/util.scm | 14 |
4 files changed, 225 insertions, 45 deletions
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm index eda1b1f3..a9359a32 100644 --- a/module/srfi/srfi-19/alt.scm +++ b/module/srfi/srfi-19/alt.scm @@ -71,9 +71,6 @@ (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)) @@ -113,12 +110,23 @@ ((apr jun sep nov) 30) ((feb) (if (leap-year? (year date)) - 29 28)))) + 29 28)) + (else (error "No month ~a (~a)" (month date) date)))) (define-public (days-in-year date) (if (leap-year? (year date)) 366 365)) + +(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) + (time))) ;;; EQUIALENCE @@ -147,7 +155,7 @@ (time=?) time= (datetime=?) datetime=) -(define-public (date< a b) +(define (date<% a b) (let ((ay (year a)) (by (year b))) (if (= ay ay) @@ -158,6 +166,14 @@ (< am bm))) (< ay by)))) +(define-public date< + (match-lambda* + [() #t] + [(_) #t] + [(first second . rest) + (and (date<% first second) + (apply date< second rest))])) + (define-public (time< a b) (let ((ah (hour a)) @@ -176,25 +192,39 @@ (time< (get-time a) (get-time b)) (date< (get-date a) (get-date b)))) +(define-public (date/-time< a b) + (if (date< (as-date a) (as-date b)) + #t + (time< (as-time a) (as-time b)))) (define-many define-public (date<?) date< (date> date>?) (swap date<) + (date<= date<=?) (negate date>) + (date>= date>=?) (negate date<) (time<?) time< (time> time>?) (swap time<) - (time<= time<=?) (negate time>) (time>= time>=?) (negate time<) (datetime<?) datetime< - (datetime> datetime>?) (swap datetime<)) + (datetime> datetime>?) (swap datetime<) + (datetime<= datetime<=?) (negate datetime>) + (datetime>= datetime>=?) (negate datetime<) + + (date/-time<?) date/-time< + (date/-time> date/-time>?) (swap date/-time<) + (date/-time<= date/-time<=?) (negate date/-time>) + (date/-time>= date/-time>=?) (negate date/-time<) + ) ;;; OPERATIONS ;; Base and change inverted to better work with fold in the exported date+ +#; (define (date+% change base) ;; while (day base) > (days-in-month base) @@ -219,18 +249,82 @@ (set (year months-fixed) = (+ (year change)))) +(define-public (date-zero? date) + (= 0 (year date) (month date) (day date))) + +(define (date+%% change base) + + (define-values (days-fixed change*) + (let loop ((target base) (change change)) + ;; (format (current-error-port) "1 ~s : ~s~%" target change) + (if (> (days-in-month target) (+ (day change) (day target))) + ;; No date overflow, just add the change + (values (set-> target (day = (+ (day change)))) + (set-> change (day 0))) + ;; Date (and possibly year) overflow + (loop (if (= 12 (month target)) + (set-> target + (year = (+ 1)) + (month 1) + (day 1)) + (set-> target + (month = (+ 1)) + (day 1))) + (set-> change (day = (- (1+ (- (days-in-month target) (day target)))))))))) + + (define-values (month-fixed change**) + (if (date-zero? change*) + (values days-fixed change*) + (let loop ((target days-fixed) (change change*)) + ;; (format (current-error-port) "2 ~s : ~s~%" target change) + (if (>= 12 (+ (month change) (month target))) + (values (set (month target) = (+ (month change))) + (set (month change) 0)) + + (loop (set-> target + (year = (+ 1)) + (month 1)) + (set (month change) = (- 12 (month target)))) + )))) + + ;; change** should here should have both month and date = 0 + + (set (year month-fixed) = (+ (year change**)))) + +(define (date+% change base) + + (when (or (negative? (year change)) + (negative? (month change)) + (negative? (day change))) + (error "Change can't be negative")) + + (when (or (negative? (month base)) + (negative? (day base))) + (error "Base month or day can't be negative")) + + (date+%% change base) + ) + +;; @var{base} MUST be a valid real date. all rest arguments can however +;; be "invalid" dates, such as 0000-00-10 (define-public (date+ base . rest) (fold date+% base rest)) -(define (date-% change base) - +(define (date-%% change base) (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)))) + (let ((new-change (set (day change) = (- (day target))))) + (loop (if (= 1 (month target)) + (set-> target + (year = (- 1)) + (month 12) + (day 31) ; days in december + ) + (set-> target + (month = (- 1)) + (day (days-in-month (set (month target) = (- 1)))))) + new-change)) (values (set (day target) = (- (day change))) (set (day change) 0))))) @@ -246,7 +340,21 @@ ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (- (year change)))) + (set (year month-fixed) = (- (year change**)))) + +(define (date-% change base) + + (when (or (negative? (year change)) + (negative? (month change)) + (negative? (day change))) + (error "Change can't be negative")) + + (when (or (negative? (month base)) + (negative? (day base))) + (error "Base month or day can't be negative")) + + (date-%% change base) + ) (define-public (date- base . rest) (fold date-% base rest)) @@ -384,7 +492,6 @@ day: ((@ (srfi srfi-19) date-day) d)))) - ;; Reader extensions 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))) diff --git a/module/srfi/srfi-19/setters.scm b/module/srfi/srfi-19/setters.scm index 45876382..7a13c654 100644 --- a/module/srfi/srfi-19/setters.scm +++ b/module/srfi/srfi-19/setters.scm @@ -1,7 +1,7 @@ -(define-module (srfi srfi-19 setters) +(define-module (srfi srfi-19 setters) #:use-module (srfi srfi-19) ; Date/Time ;; (record-type-fields (@@ (srfi srfi-19) date)) - #:export (nanosecond second minute hour day month year zone-offset)) + #:export (nanosecond second minute hour day month year zone-offset tz)) (define nanosecond (make-procedure-with-setter date-nanosecond (@@ (srfi srfi-19) set-date-nanosecond!))) @@ -12,4 +12,4 @@ (define month (make-procedure-with-setter date-month (@@ (srfi srfi-19) set-date-month!))) (define year (make-procedure-with-setter date-year (@@ (srfi srfi-19) set-date-year!))) (define zone-offset (make-procedure-with-setter date-zone-offset (@@ (srfi srfi-19) set-date-zone-offset!))) - +(define tz zone-offset) diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm index f5bd1964..96f19dc2 100644 --- a/module/srfi/srfi-19/util.scm +++ b/module/srfi/srfi-19/util.scm @@ -166,3 +166,17 @@ attribute set to 0. Can also be seen as \"Start of day\"" ) ;; ( (nsecs b) (zone b)) ) + +;; Rounds a date towards the closest midnight +;; TODO more general rounding +(define-public (date-round date) + (set-> + (if (< 12 (date-hour date)) + ;; round up + (set (date-day date) = (+ 1)) + ;; round down + date) + (date-day = (+ 1)) + (date-hour 0) + (date-minute 0) + (date-second 0))) |