From e822f7b81245c919eda8bd8ad4b482df075e0508 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Fri, 24 Jan 2020 20:21:41 +0100
Subject: Start of new date structures.

---
 module/srfi/srfi-19/alt.scm      | 348 +++++++++++++++++++++++++++++++++++++++
 module/srfi/srfi-19/alt/util.scm | 107 ++++++++++++
 module/srfi/srfi-19/util.scm     |  28 ----
 3 files changed, 455 insertions(+), 28 deletions(-)
 create mode 100644 module/srfi/srfi-19/alt.scm
 create mode 100644 module/srfi/srfi-19/alt/util.scm

(limited to 'module/srfi/srfi-19')

diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm
new file mode 100644
index 00000000..b3e8a478
--- /dev/null
+++ b/module/srfi/srfi-19/alt.scm
@@ -0,0 +1,348 @@
+(define-module (srfi srfi-19 alt)
+  :export (date? year month day
+                 hour minute second
+                 time? datetime?
+                 )
+
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9)
+  :use-module (srfi srfi-9 gnu)
+  :use-module (ice-9 match)
+
+  :use-module (util)
+  )
+
+(define-many define-public
+  (jan january   ) 1
+  (feb february  ) 2
+  (mar mars      ) 3
+  (apr april     ) 4
+  (may           ) 5
+  (jun june      ) 6
+  (jul july      ) 7
+  (aug august    ) 8
+  (sep september ) 9
+  (oct october   ) 10
+  (nov november  ) 11
+  (dec december  ) 12
+  )
+
+(define-immutable-record-type <date>
+  (make-date year month day)
+  date?
+  (year year) (month month) (day day))
+
+(set-record-type-printer!
+ <date>
+ (lambda (r p)
+   (format p "~4'0d­~2'0d­~2'0d"
+           (year r) (month r) (day r))))
+
+(define*-public (date key: (year 0) (month 0) (day 0))
+  (make-date year month day))
+
+
+;; int -> bool
+(define-public (leap-year? year)
+  (and (zero? (remainder year 4))
+       (or (zero? (remainder year 400))
+           (not (zero? (remainder year 100))))))
+
+;; Returns number of days month for a given date. Just looks at the year and month components.
+(define-public (days-in-month date)
+  (case* (month date)
+         ((jan mar may jul aug oct dec) 31)
+         ((apr jun sep nov) 30)
+         ((feb)
+          (if (leap-year? (year date))
+              29 28))))
+
+(define-public (days-in-year date)
+  (if (leap-year? (year date))
+      366 365))
+
+;; 2020-01-10 + 0-0-30 = 2020-02-09
+;; 10 + 30 = 40                            ; day + day
+;; 40 > 31                                 ; target days > days in month
+;; 2020-02-00 + 0-0- (40 - 31)             ;
+;; 2020-02-09
+
+(define-public (date= a b)
+  (and (= (year a) (year b))
+       (= (month a) (month b))
+       (= (day a) (day b))))
+
+(define-public date=? date=)
+
+(define (date+% base change)
+
+  ;; while (day base) > (days-in-month base)
+  ;;     month++; days -= (days-in-month base)
+  (define days-fixed
+    (let loop ((target (set (day base) = (+ (day change)))))
+      (if (> (day target) (days-in-month target))
+          (loop (set-> target
+                       (month = (+ 1))
+                       (day = (- (days-in-month target)))))
+          target)))
+
+  ;; while (month base) > 12
+  ;;     year++; month -= 12
+  (define months-fixed
+    (let loop ((target (set (month days-fixed) = (+ (month change)))))
+      (if (> (month target) 12)
+          (loop (set-> target
+                       (year = (+ 1))
+                       (month = (- 12))))
+          target)))
+
+  (set (year months-fixed) = (+ (year change))))
+
+(define-public (date+ base . rest)
+  (fold date+% base rest))
+
+(define-public (date- base change)
+
+  (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))))
+          (values (set (day target) = (- (day change)))
+                  (set (day change) 0)))))
+
+  (define-values (month-fixed change**)
+    (let loop ((target days-fixed) (change change*))
+      (if (>= (month change) (month target))
+          (loop (set-> target
+                       (year = (- 1))
+                       (month 12))
+                (set (month change) = (- (month target))))
+          (values (set (month target) = (- (month change)))
+                  (set (month change) 0)))))
+
+  ;; change** should here should have both month and date = 0
+
+  (set (year month-fixed) = (- (year change))))
+
+(define-public (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)))))
+
+  ;; change** should here should have both month and date = 0
+
+  (set (hour month-fixed) = (- (hour change)))
+  )
+
+
+
+(define-immutable-record-type <time>
+  (make-time hour minute second utc)
+  time?
+  (hour hour) (minute minute) (second second)
+  (utc utc)                             ; bool
+  )
+
+(set-record-type-printer!
+ <time>
+ (lambda (r p)
+   (format p "~2'0d:~2'0d:~2'0d~a"
+           (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))
+
+(define-public (time+% base change)
+
+  ;; while (day base) > (days-in-month base)
+  ;;     month++; days -= (days-in-month base)
+  (define second-fixed
+    (let loop ((target (set (second base) = (+ (second change)))))
+      (if (>= (second target) 60)
+          (loop (set-> target
+                       (minute = (+ 1))
+                       (second = (- 60))))
+          target)))
+
+  ;; while (month base) > 12
+  ;;     year++; month -= 12
+  (define minute-fixed
+    (let loop ((target (set (minute second-fixed) = (+ (minute change)))))
+      (if (>= (minute target) 60)
+          (loop (set-> target
+                       (hour = (+ 1))
+                       (minute = (- 60))))
+          target)))
+
+  ;;  ahtns auoe htns a oeuhnstaoue nhts aoeu nshtaoeu snht oeuia htns oaeu nsht aoeuö ntshaouentsh oaesnuthg aoeu nsthaoeu nshtaou eshtnnh toaeuhnst oeuhtns 
+  (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change))))
+
+  ;; (format #t "~s ~s ~s~%" second-fixed minute-fixed hour-almost-fixed)
+
+  (if (<= 24 (hour hour-almost-fixed))
+      (let* ((div remainder (floor/ (hour hour-almost-fixed) 24)))
+        (values (set (hour hour-almost-fixed) remainder) div))
+      (values hour-almost-fixed 0)))
+
+(define-public (time+ base . rest)
+  (fold time+% base rest))
+
+(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 (make-datetime*
+                 key:
+                 (year 0) (month 0) (day 0)
+                 (hour 0) (minute 0) (second 0)
+                 (tz #f))
+  (make-datetime (make-date year month day)
+                 (make-time hour minute second #f)
+                 tz))
+
+(define-public datetime
+  (match-lambda*
+    [(date time) (make-datetime date time #f)]
+    [(date time tz) (make-datetime date time #f)]
+    [args (apply make-datetime* args)]))
+
+(define-public (datetime+ base change)
+  (let* ((time overflow (time+ (get-time base) (get-time change))))
+    (date+ (get-date base)
+           (get-date change)
+           (date day: overflow))))
+
+
+
+(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<)
+
+  (datetime<?) datetime<
+  (datetime> datetime>?) (swap datetime<))
+
+
+
+;; substring to number, local here
+(define (s->n str from to)
+  (string->number (substring/read-only str from to)))
+
+(define-public (parse-date str)
+  (date year:  (s->n str 0 4)
+        month: (s->n str 4 6)
+        day:   (s->n str 6 8)))
+
+(define-public (parse-time str)
+  (time hour:   (s->n str 0 2)
+        minute: (s->n str 2 4)
+        second: (s->n str 4 6)
+        ;; TODO UTC
+        ))
+
+(define-public (parse-datetime str)
+  (let* (((datestr timestr) (string-split str #\T)))
+    (datetime (parse-date datestr)
+              (parse-time timestr))))
+
+
+(define-public (current-date)
+  (let ((d ((@ (srfi srfi-19) current-date))))
+    (date year:  ((@ (srfi srfi-19) date-year) d)
+          month: ((@ (srfi srfi-19) date-month) d)
+          day:   ((@ (srfi srfi-19) date-day) d))))
+
+
+
+
+
+;; Reader extensions
+
+(define (parse-date% str)
+  (let* (((year month day) (map string->number (string-split str #\-))))
+    `(date year: ,year month: ,month day: ,day)))
+
+(define (parse-time% timestr)
+  (let* (((hour minute second) (string-split timestr #\:)))
+    (let ((utc? (string-contains second "Z")))
+      (let ((hour (string->number hour))
+            (minute (string->number minute))
+            (second (string->number (if utc? (string-drop-right second 1) second))))
+        `(time hour: ,hour minute: ,minute second: ,second utc: ,utc?)))))
+
+(define (parse-datetime% str)
+  (let* (((date time) (string-split str #\T)))
+    `(datetime ,(parse-date date)
+               ,(parse-time time))))
+
+(define (date-reader chr port)
+  (unread-char chr port)
+  (let ((line (symbol->string (read port))))
+    (cond [(string-contains line "T") (parse-datetime% line)]
+          [(string-contains line ":") (parse-time% line)]
+          [(string-contains line "-") (parse-date% line)])))
+
+(read-hash-extend #\0 date-reader)
+(read-hash-extend #\1 date-reader)
+(read-hash-extend #\2 date-reader)
diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm
new file mode 100644
index 00000000..9b394105
--- /dev/null
+++ b/module/srfi/srfi-19/alt/util.scm
@@ -0,0 +1,107 @@
+(define-module (srfi srfi-19 alt util)
+  :use-module (srfi srfi-19 alt)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-26)
+  :use-module (srfi srfi-41)
+  :use-module (util)
+  )
+
+(define-public (start-of-month date)
+  (set (day date) 0))
+
+
+(define-public (parse-freeform-date str)
+  (let* (((year month day) (map string->number (string-split str #\-))))
+    (date year: year month: month day: day)
+    ))
+
+(define-public (day-stream start-day)
+  (stream-iterate (cut date+ <> #0-0-1)
+                  start-day))
+
+(define (as-date date/-time)
+  (if (date? date/-time)
+      date/-time
+      (get-date date/-time)))
+
+(define (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 date/-time<? date/-time<)
+
+(define*-public (date->string date optional: (fmt "~Y-~m-~d"))
+  (with-output-to-string
+    (lambda ()
+      (fold (lambda (token state)
+              (case state
+                ((#\~)
+                 (case token
+                   ((#\~) (display "~"))
+                   ((#\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)))
+                 #f)
+                (else (unless (char=? #\~ token) (display token)) token)))
+            #f
+            (string->list fmt)))))
+
+(define*-public (time->string time optional: (fmt "~H:~M:~S"))
+  (with-output-to-string
+    (lambda ()
+      (fold (lambda (token state)
+              (case state
+                ((#\~)
+                 (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)))
+                 #f)
+                (else (unless (char=? #\~ token) (display token)) token)))
+            #f
+            (string->list fmt)))))
+
+
+;; @verbatim
+;;    A          B          C          D          E         ¬F
+;; |s1|     :     |s2| : |s1|     :     |s2| :          : |s1|
+;; |  |     :     |  | : |  ||s2| : |s1||  | : |s1||s2| : |  |
+;; |  ||s2| : |s1||  | : |  ||  | : |  ||  | : |  ||  | :
+;;     |  | : |  |     : |  ||  | : |  ||  | : |  ||  | :     |s2|
+;;     |  | : |  |     : |  |     :     |  | :          :     |  |
+;; @end verbatim
+;; 
+;; E is covered by both case A and B.
+(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
+  "Return whetever or not two timespans overlap."
+  (or
+   ;; A
+   (and (date/-time<? s2-begin s1-end)
+        (date/-time<? s1-begin s2-end))
+
+   ;; B
+   (and (date/-time<? s1-begin s2-end)
+        (date/-time<? s2-begin s1-end))
+
+   ;; C
+   (and (date/-time<? s1-begin s2-begin)
+        (date/-time<? s2-end s1-end))
+
+   ;; D
+   (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 (remove-day date)
+  (date- date (date day: 1)))
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
index 77e824ca..f5bd1964 100644
--- a/module/srfi/srfi-19/util.scm
+++ b/module/srfi/srfi-19/util.scm
@@ -73,34 +73,6 @@ attribute set to 0. Can also be seen as \"Start of day\""
 (define (remove-day time)
   (add-duration time (make-duration (- (* 60 60 24)))))
 
-;; @verbatim
-;;    A          B          C          D          E         ¬F
-;; |s1|     :     |s2| : |s1|     :     |s2| :          : |s1|
-;; |  |     :     |  | : |  ||s2| : |s1||  | : |s1||s2| : |  |
-;; |  ||s2| : |s1||  | : |  ||  | : |  ||  | : |  ||  | :
-;;     |  | : |  |     : |  ||  | : |  ||  | : |  ||  | :     |s2|
-;;     |  | : |  |     : |  |     :     |  | :          :     |  |
-;; @end verbatim
-;; 
-;; E is covered by both case A and B.
-(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
-  "Return whetever or not two timespans overlap."
-  (or
-   ;; A
-   (and (time<? s2-begin s1-end)
-        (time<? s1-begin s2-end))
-
-   ;; B
-   (and (time<? s1-begin s2-end)
-        (time<? s2-begin s1-end))
-
-   ;; C
-   (and (time<? s1-begin s2-begin)
-        (time<? s2-end s1-end))
-
-   ;; D
-   (and (time<? s2-begin s1-begin)
-        (time<? s1-end s2-end))))
 
 (define-public (normalize-date date)
   (time-utc->date (date->time-utc date)
-- 
cgit v1.2.3