;;
;; 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->month

  cal-day-tests!
  )

 (import scheme
	 (chicken base)
	 util-tag
	 cal-month
	 testing)

 ;; 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)
   (and (= (modulo y 4) 0)
	(or (not (= (modulo y 100) 0))
	    (= (modulo y 400) 0))))

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

 ;; Module self-tests
 (define (cal-day-tests!)
   (run-tests
    cal-day
    ))

 )