;;
;; 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->string
  string->cal-day
  parse-cal-day/month

  cal-day=?
  cal-day<?
  cal-day<=?
  cal-day>=?
  cal-day>?

  cal-day/month<?

  cal-day/month->string

  cal-day-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken format)
	 (chicken string)
	 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)))

 ;; Converts day to ISO date string
 (define (cal-day->string v)
   (let ((y (cal-day-year v))
	 (m (cal-day-month v))
	 (d (cal-day-day v)))
     (format "~A-~A-~A"
	     y
	     (if (> m 9)
		 m
		 (format "0~A" m))
	     (if (> d 9)
		 d
		 (format "0~A" d)))))

 ;; Converts ISO date string to cal-day
 (define (string->cal-day s)
   (let ((l (string-split s "-")))
     (if (= (length l) 3)
	 (apply make-cal-day (map string->number l))
	 #f)))

 ;; Parses given string as either day or month
 (define (parse-cal-day/month s)
   (let ((d (string->cal-day s)))
     (or d
	 (string->cal-month s))))

 ;; Date equality
 (define (cal-day=? a b)
   (and (cal-day? a)
	(cal-day? b)
	(eq? (cal-day-year a)
	     (cal-day-year b))
	(eq? (cal-day-month a)
	     (cal-day-month b))
	(eq? (cal-day-day a)
	     (cal-day-day b))))

 ;; Strict date inequality
 (define (cal-day<? a b)
   (and (cal-day? a)
	(cal-day? b)
	(or (< (cal-day-year a)
	       (cal-day-year b))
	    (and (= (cal-day-year a)
		    (cal-day-year b))
		 (or (< (cal-day-month a)
			(cal-day-month b))
		     (and (= (cal-day-month a)
			     (cal-day-month b))
			  (<  (cal-day-day a)
			      (cal-day-day b))))))))

 ;; Non-strict inequality
 (define (cal-day<=? a b)
   (or (cal-day=? a b)
       (cal-day<? a b)))

 ;; Inequality the other way
 (define (cal-day>=? a b)
   (not (cal-day<? a b)))

 ;; Strict inequality the other way
 (define (cal-day>? a b)
   (not (cal-day<=? a b)))

 ;; Universal sorting comparator
 (define (cal-day/month<? a b)
   (if (and (cal-day? a)
	    (cal-day? b))
       (cal-day<? a b)
       (if (and (cal-month? a)
		(cal-month? b))
	   (cal-month<? a b)
	   (error 'cal-day/month<?
		  "Requires two arguments of the same type"
		  (list a b)))))

 ;; Semi-universal string conversion
 (define (cal-day/month->string v)
   (if (cal-day? v)
       (cal-day->string v)
       (if (cal-month? v)
	   (cal-month->string v)
	   "")))

 ;; Module self-tests
 (define (cal-day-tests!)
   (run-tests
    cal-day
    (test-equal? make-cal-day
		 (make-cal-day 2023 5 10)
		 `(,TAG-CAL-DAY 2023 5 10))
    (test-true cal-year-leap?
	       (cal-year-leap? 2000))
    (test-true cal-year-leap?
	       (cal-year-leap? 2024))
    (test-false cal-year-leap?
		(cal-year-leap? 2023))
    (test-false cal-year-leap?
		(cal-year-leap? 1900))
    (test-eq? cal-month-days
	      (cal-month-days 2023 5)
	      31)
    (test-eq? cal-month-days
	      (cal-month-days 2023 2)
	      28)
    (test-eq? cal-month-days
	      (cal-month-days 2024 2)
	      29)
    (test-true cal-day?
	       (cal-day? (make-cal-day 2023 5 10)))
    (test-false cal-day?
		(cal-day? (make-cal-day 2023 2 29)))
    (test-true cal-day?
	       (cal-day? (make-cal-day 2024 2 29)))
    (test-equal? cal-day->string
		 (cal-day->string (make-cal-day 2024 2 29))
		 "2024-02-29")
    (test-equal? string->cal-day
		 (string->cal-day "2023-05-11")
		 (make-cal-day 2023 5 11))
    (test-true parse-cal-day/month
	       (cal-day? (parse-cal-day/month "2023-05-11")))
    (test-true parse-cal-day/month
	       (cal-month? (parse-cal-day/month "2023-05")))
    (test-true cal-day/month<?
	       (cal-day/month<? (make-cal-day 2023 5 21)
				(make-cal-day 2023 5 22)))
    (test-exn cal-day/month<?
	      (cal-day/month<? (make-cal-day 2023 5 21)
			       (make-cal-month 2023 5)))
    (test-true cal-day/month<?
	       (cal-day/month<? (make-cal-month 2023 4)
				(make-cal-month 2023 5)))
    (test-false cal-day/month<?
		(cal-day/month<? (make-cal-day 2023 5 22)
				 (make-cal-day 2023 5 22)))
    (test-equal? cal-day/month->string
		 (cal-day/month->string (make-cal-day 2023 5 22))
		 "2023-05-22")
    (test-equal? cal-day/month->string
		 (cal-day/month->string (make-cal-month 2023 5))
		 "2023-05")
    ))

 )