Start work on new calendar day structure.

src/cal-day.scm

@@ -0,0 +1,112 @@
+;;
+;; cal-day.scm
+;;
+;; Day processing support.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Brmlab, z.s.
+;; Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+
+(declare (unit cal-day))
+
+(module
+ cal-day
+ (
+  make-cal-day
+
+  cal-day?
+
+  cal-day-year
+  cal-day-month
+  cal-day-day
+
+  cal-day->cal-month
+  )
+
+ (import scheme
+	 util-tag
+	 cal-month)
+
+ ;; Type tag
+ (define TAG-CAL-DAY (make-tag CAL-DAY))
+
+ ;; Creates new calendar day representation
+ (define (make-cal-day y m d)
+   (list TAG-CAL-DAY
+	 y m d))
+
+ ;; Returns true if this is a leap year
+ (define (cal-year-leap y)
+   #f)
+
+ ;; Returns the number of days of given month
+ (define (cal-month-days y/m . ms)
+   (let* ((year (if (null? ms)
+		    (cal-month-year y/m)
+		    y/m))
+	  (month (if (null? ms)
+		     (cal-month-month y/m)
+		     (car ms)))
+	  (leap? (cal-year-leap? year))
+	  ;;        1  2
+	  (mdays `(31
+		   ,(if leap? 29 28)
+		   ;;3 4  5  6  7  8  9 10 11 12
+		   31 30 31 30 31 31 30 31 30 31)))
+     (list-ref mdays (sub1 month))))
+
+ ;; Returns true if given value is a valid calendar day
+ (define (cal-day? v)
+   (and (list? v)
+	(not (null? v))
+	(eq? TAG-CAL-DAY (car v))
+	(not (null? (cdr v)))
+	(integer? (cadr v))
+	(>= (cadr v) 1000)
+	(<= (cadr v) 9999)
+	(not (null? (cddr v)))
+	(integer? (caddr v))
+	(>= (caddr v) 1)
+	(<= (caddr v) 12)
+	(not (null? (cdddr v)))
+	(integer? (cadddr v))
+	(>= (cadddr v) 1)
+	(let ((days (cal-month-days (cadr v) (caddr v))))
+	  (<= (cadddr v) days))))
+
+ ;; Simple accessors
+ (define cal-day-year cadr)
+ (define cal-day-month caddr)
+ (define cal-day-day cadddr)
+
+ ;; Convert to month representation
+ (define (cal-day->month v . stop?s)
+   (let* ((stop? (if (null? stop?s)
+		    #f
+		    (car stop?s)))
+	  (M (make-cal-month (cal-day-year v)
+			     (cal-day-month v))))
+     (if (and stop?
+	      (> (cal-day-day v) 1))
+	 (cal-month-add M 1)
+	 M)))
+
+ )
+