diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/srfi/srfi-19/alt.scm | 233 |
1 files changed, 132 insertions, 101 deletions
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm index 77b3d7d0..eda1b1f3 100644 --- a/module/srfi/srfi-19/alt.scm +++ b/module/srfi/srfi-19/alt.scm @@ -27,6 +27,11 @@ (dec december ) 12 ) + +;;; RECORD TYPES + +;;; DATE + (define-immutable-record-type <date> (make-date year month day) date? @@ -45,6 +50,8 @@ (define*-public (date key: (year 0) (month 0) (day 0)) (make-date year month day)) +;;; TIME + (define-immutable-record-type <time> (make-time hour minute second utc) time? @@ -70,7 +77,28 @@ (define*-public (time key: (hour 0) (minute 0) (second 0) (utc #f)) (make-time hour minute second utc)) +;;; DATETIME + +(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 (datetime + key: date time + (year 0) (month 0) (day 0) + (hour 0) (minute 0) (second 0) + (tz #f)) + (make-datetime (or date (make-date year month day)) + (or time (make-time hour minute second #f)) + tz)) + +;;; UTIL ;; int -> bool (define-public (leap-year? year) @@ -91,6 +119,9 @@ (if (leap-year? (year date)) 366 365)) + +;;; EQUIALENCE + ;; 2020-01-10 + 0-0-30 = 2020-02-09 ;; 10 + 30 = 40 ; day + day ;; 40 > 31 ; target days > days in month @@ -102,8 +133,68 @@ (= (month a) (month b)) (= (day a) (day b)))) -(define-public date=? date=) +(define-public (time= a b) + (and (= (hour a) (hour b)) + (= (minute a) (minute b)) + (= (second a) (second b)))) + +(define-public (datetime= a b) + (and (date= (get-date a) (get-date b)) + (time= (get-time a) (get-time b)))) + +(define-many define-public + (date=?) date= + (time=?) time= + (datetime=?) datetime=) + +(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<) + + (time<= time<=?) (negate time>) + (time>= time>=?) (negate time<) + + (datetime<?) datetime< + (datetime> datetime>?) (swap datetime<)) + + + +;;; 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) @@ -160,37 +251,7 @@ (define-public (date- base . rest) (fold date-% base rest)) -(define (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))))) - - - (if (>= (hour minute-fixed) (hour change)) - (values (set (hour minute-fixed) = (- (hour change))) - 0) - (values (set (hour minute-fixed) 0) - (- (hour change) (hour minute-fixed))))) - -(define-public (time- base . rest) - (fold time-% base rest)) +;;; time ;; time x time → time x int (define-public (time+% base change) @@ -225,6 +286,7 @@ (values (set (hour hour-almost-fixed) remainder) div)) (values hour-almost-fixed 0))) +;;; PLUS (define-public (time+ base . rest) (let ((sum 0)) (let ((time (fold (lambda (next done) @@ -234,25 +296,47 @@ base rest))) (values time sum)))) -(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!)) +(define (time-% base change) -(export get-date get-time get-tz) + (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*-public (datetime - key: date time - (year 0) (month 0) (day 0) - (hour 0) (minute 0) (second 0) - (tz #f)) - (make-datetime (or date (make-date year month day)) - (or time (make-time hour minute second #f)) - tz)) + (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))))) + (if (>= (hour minute-fixed) (hour change)) + (values (set (hour minute-fixed) = (- (hour change))) + 0) + (values (set (hour minute-fixed) 0) + (- (hour change) (hour minute-fixed))))) + +(define-public (time- base . rest) + (let ((sum 0)) + (let ((time (fold (lambda (next done) + (let* ((next-time rem (time-% done next))) + (mod! sum = (+ rem)) + next-time)) + base rest))) + (values time sum)))) + + +;;; DATETIME + (define-public (datetime+ base change) (let* ((time overflow (time+ (get-time base) (get-time change)))) (datetime date: (date+ (get-date base) @@ -267,62 +351,9 @@ (date day: overflow)) time: time))) -(define-public (time= a b) - (and (= (hour a) (hour b)) - (= (minute a) (minute b)) - (= (second a) (second b)))) - -(define-public (datetime= a b) - (and (date= (get-date a) (get-date b)) - (time= (get-time a) (get-time b)))) - - - - -(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<) - - (time<= time<=?) (negate time>) - (time>= time>=?) (negate time<) - - (datetime<?) datetime< - (datetime> datetime>?) (swap datetime<)) +;;; Parsers for vcomponent usage ;; substring to number, local here (define (s->n str from to) |