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