Once again compiles.

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)))