;;
;; cal-period.scm
;;
;; Calendar month periods.
;;
;; 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-period))

(module
    cal-period
    (
     current-year
     *current-month*
     *current-day*

     set-current-month!
     set-current-day!

     with-current-month
     with-current-day
  
     make-cal-period

     cal-period-since
     cal-period-before
     cal-period-scomment
     cal-period-bcomment

     set-cal-period-scomment
  
     period-markers->cal-periods
  
     cal-periods-duration
  
     cal-month-in-period?
     cal-month-in-periods?

     cal-month-find-period

     cal-day-in-period?
     cal-day-in-periods?
  
     cal-periods->string
     cal-periods-match
  
     make-cal-period-lookup-table
     lookup-by-cal-period

     cal-ensure-month
     cal-ensure-day
  
     cal-period-tests!
     )

  (import scheme
	  (chicken base)
	  (chicken sort)
	  (chicken time)
	  (chicken time posix)
	  (chicken format)
	  (chicken string)
	  cal-month
	  testing
	  util-tag
	  cal-day)

  ;; Type tag
  (define TAG-CAL-PERIOD (make-tag CAL-PERIOD))

  (define (current-year)
    (cal-month-year (*current-month*)))

  ;; Current month - if changed, we get the actual state for given month.
  (define *current-month*
    (make-parameter
     (let ((d (seconds->local-time (current-seconds))))
       (make-cal-month (+ 1900 (vector-ref d 5))
		       (+ (vector-ref d 4) 1)))))

  ;; Current month - if changed, we get the actual state for given month.
  (define *current-day*
    (make-parameter
     (let ((d (seconds->local-time (current-seconds))))
       (make-cal-day (+ 1900 (vector-ref d 5))
		     (+ (vector-ref d 4) 1)
		     (vector-ref d 3)))))

  ;; Changes both current-month and current-day based on given month
  (define (set-current-month! m)
    (*current-month* m)
    (*current-day* (cal-ensure-day m)))

  ;; Changes both current-day and current-month based on given day
  (define (set-current-day! d)
    (*current-day* d)
    (*current-month* (cal-ensure-month d)))

  ;; Parameterizes both current-month and current-day based on given
  ;; month
  (define-syntax with-current-month
    (syntax-rules ()
      ((_ ms body ...)
       (let ((m ms))
	 (parameterize ((*current-month* m)
			(*current-day* (cal-ensure-day m)))
	   body ...)))))

  ;; Parameterizes both current-day and current-month based on given
  ;; day
  (define-syntax with-current-day
    (syntax-rules ()
      ((_ ds body ...)
       (let ((d ds))
	 (parameterize ((*current-day* d)
			(*current-month* (cal-ensure-month d)))
	   body ...)))))

  ;; Creates a new period value with optional since and before
  ;; comments.
  (define (make-cal-period since before . args)
    (let ((scomment (if (not (null? args)) (car args) #f))
	  (bcomment (if (and (not (null? args))
			     (not (null? (cdr args))))
			(cadr args)
			#f)))
      (list TAG-CAL-PERIOD since before scomment bcomment)))

  ;; Simple accessors
  (define cal-period-since cadr)
  (define cal-period-before caddr)
  (define cal-period-scomment cadddr)
  (define cal-period-bcomment (compose cadddr cdr))

  ;; Direct updater
  (define (set-cal-period-scomment p c)
    (list TAG-CAL-PERIOD
	  (cal-period-since p)
	  (cal-period-before p)
	  c
	  (cal-period-bcomment p)))

  ;; Type predicate
  (define (cal-period? p)
    (and (pair? p)
	 (eq? (car p)
	      TAG-CAL-PERIOD)))

  ;; Month subtype predicate
  (define (cal-period-month? p)
    (and (cal-period? p)
	 (cal-month? (cal-period-since p))
	 (cal-month? (cal-period-before p))))

  ;; Day subtype predicate
  (define (cal-period-day? p)
    (and (cal-period? p)
	 (cal-day? (cal-period-since p))
	 (cal-day? (cal-period-before p))))

  ;; Validation
  (define (cal-period-valid? p)
    (and (pair? p)
	 (eq? (car p)
	      TAG-CAL-PERIOD)
	 (let ((since (cal-period-since p))
	       (before (cal-period-before p)))
	   (or (and (cal-month? since)
		    (cal-month? before)
		    (cal-month<=? since before))
	       (and (cal-day? since)
		    (cal-day? before)
		    (cal-day<=? since before))))))

  ;; Sorts period markers (be it start or end) chronologically and
  ;; returns the sorted list.
  (define (sort-period-markers l)
    (sort l
	  (lambda (a b)
	    (cal-day/month<? (cadr a) (cadr b)))))

  ;; Converts list of start/stop markers to list of pairs of months -
  ;; periods. The markers are lists in the form (start/stop cal-month).
  (define (period-markers->cal-periods l)
    (let loop ((l (sort-period-markers l))
	       (ps '())
	       (cb #f))
      (if (null? l)
	  (list #t
		(if cb
		    (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
		    (reverse ps))
		""
		-1)
	  (let* ((marker (car l))
		 (rmt (if cb 'stop 'start))
		 (mtype (car marker))
		 (month (cadr marker))
		 (line-number (if (null? (cddr marker))
				  #f
				  (caddr marker)))
		 (comment (if (and line-number
				   (not (null? (cdddr marker))))
			      (cadddr marker)
			      #f)))
	    (if (eq? mtype rmt)
		(if cb
		    (loop (cdr l)
			  (cons (make-cal-period (car cb) month (cadr cb) comment) ps)
			  #f)
		    (loop (cdr l)
			  ps
			  (list month comment)))
		(list #f
		      (reverse ps)
		      (sprintf "Invalid start/stop sequence marker ~A" marker)
		      line-number))))))

  ;; Returns duration of period in months. Start is included, end is
  ;; not. The period contains the month just before the specified end.
  (define (cal-period->duration p)
    (let* ((b (cal-period-since p))
	   (e (cal-period-before p))
	   (e- (if e e (*current-month*))))
      (cal-month-diff b e-)))

  ;; Returns sum of periods lengths.
  (define (cal-periods-duration l)
    (apply + (map cal-period->duration l)))

  ;; True if month belongs to given month period - start inclusive, end
  ;; exclusive.
  (define (cal-month-in-period? p . ml)
    (let ((m (if (null? ml)
		 (*current-month*)
		 (cal-ensure-month (car ml))))
	  (before (cal-ensure-month (cal-period-before p) #t))
	  (since (cal-ensure-month (cal-period-since p))))
      (and (or (not before)
	       (cal-month<? m before))
	   (not (cal-month<? m since)))))

  ;; Returns true if given month is in at least one of the periods
  ;; given. Defaults to current month.
  (define (cal-month-in-periods? ps . ml)
    (let ((m (if (null? ml)
		 (*current-month*)
		 (car ml))))
      (let loop ((ps ps))
	(if (null? ps)
	    #f
	    (if (cal-month-in-period? (car ps) m)
		#t
		(loop (cdr ps)))))))

  ;; Returns true if given month is in at least one of the periods
  ;; given. Defaults to current month.
  (define (cal-month-find-period ps . ml)
    (let ((m (if (null? ml)
		 (*current-month*)
		 (car ml))))
      (let loop ((ps ps))
	(if (null? ps)
	    #f
	    (if (cal-month-in-period? (car ps) m)
		(car ps)
		(loop (cdr ps)))))))

  ;; Checks whether given day belongs to day or month period
  (define (cal-day-in-period? p . dl)
    (let ((d (if (null? dl)
		 (*current-day*)
		 (cal-ensure-day (car dl))))
	  (before (cal-ensure-day (cal-period-before p)))
	  (since (cal-ensure-day (cal-period-since p))))
      (and (or (not before)
	       (cal-day<? d before))
	   (not (cal-day<? d since)))))

  ;; Returns true if the day belongs to at least one period
  (define (cal-day-in-periods? ps . dl)
    (let ((d (if (null? dl)
		 (*current-day*)
		 (cal-ensure-day (car dl)))))
      (let loop ((ps ps))
	(if (null? ps)
	    #f
	    (if (cal-day-in-period? (car ps) d)
		#t
		(loop (cdr ps)))))))

  ;; Returns string representing a month period with possibly open end.
  (define (cal-period->string p)
    (sprintf "~A..~A"
	     (cal-day/month->string (cal-period-since p))
	     (cal-day/month->string (cal-period-before p))))

  ;; Returns a string representing a list of periods.
  (define (cal-periods->string ps)
    (string-intersperse
     (map cal-period->string ps)
     ", "))

  ;; Finds a period the month matches and returns it. If no period
  ;; matches, it returns #f.
  (define (cal-periods-match ps .  ml)
    (let ((m (if (null? ml) (*current-month*) (car ml))))
      (let loop ((ps ps))
	(if (null? ps)
	    #f
	    (if (cal-month-in-period? (car ps) m)
		(car ps)
		(loop (cdr ps)))))))

  ;; Creates lookup table from definition source
  (define (make-cal-period-lookup-table source)
    (let loop ((lst source)
	       (res '())
	       (prev #f))
      (if (null? lst)
	  (reverse
	   (cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
		       (cdr prev))
		 res))
	  (loop (cdr lst)
		(if prev
		    (cons (cons (make-cal-period (apply make-cal-month (car prev))
						 (apply make-cal-month (caar lst)))
				(cdr prev))
			  res)
		    res)
		(car lst)))))

  ;; Looks up current month and returns associated definitions
  (define (lookup-by-cal-period table)
    (let loop ((lst table))
      (if (null? lst)
	  #f
	  (if (cal-month-in-period? (caar lst))
	      (cdar lst)
	      (loop (cdr lst))))))

  ;; Wrapper that accepts either day or month and returns testable month
  (define (cal-ensure-month v . stop?s)
    (if v
	(if (cal-month? v)
	    v
	    (if (cal-day? v)
		(apply cal-day->month v stop?s)
		#f))
	#f))

  ;; Ensures day for checking the periods
  (define (cal-ensure-day v)
    (if v
	(if (cal-day? v)
	    v
	    (if (cal-month? v)
		(make-cal-day (cal-month-year v)
			      (cal-month-month v)
			      1)
		#f))
	#f))

  ;; Performs self-tests of the period module.
  (define (cal-period-tests!)
    (run-tests
     cal-period
     (test-equal? sort-period-markers
		  (sort-period-markers
		   `((start ,(make-cal-month 2023 1))
		     (stop ,(make-cal-month 2022 10))
		     (start ,(make-cal-month 2022 3))))
		  `((start ,(make-cal-month 2022 3))
		    (stop ,(make-cal-month 2022 10))
		    (start ,(make-cal-month 2023 1))))
     (test-equal? period-markers->cal-periods
	          (period-markers->cal-periods
		   `((start ,(make-cal-month 2022 3))
		     (stop ,(make-cal-month 2022 10))
		     (start ,(make-cal-month 2023 1))
		     (stop ,(make-cal-month 2023 4))))
		  `(#t
		    (,(make-cal-period (make-cal-month 2022 3)
				       (make-cal-month 2022 10) #f #f)
		     ,(make-cal-period (make-cal-month 2023 1)
				       (make-cal-month 2023 4) #f #f))
		    ""
		    -1))
     (test-equal? period-markers->cal-periods-open
	          (period-markers->cal-periods
		   `((start ,(make-cal-month 2022 3))
		     (stop ,(make-cal-month 2022 10))
		     (start ,(make-cal-month 2023 1))
		     (stop ,(make-cal-month 2023 4))
		     (start ,(make-cal-month 2023 5))))
		  `(#t
		    (,(make-cal-period (make-cal-month 2022 3)
				       (make-cal-month 2022 10) #f #f)
		     ,(make-cal-period (make-cal-month 2023 1)
				       (make-cal-month 2023 4) #f #f)
		     ,(make-cal-period (make-cal-month 2023 5) #f #f #f))
		    ""
		    -1))
     (test-eq? cal-period->duration
	       (cal-period->duration (make-cal-period (make-cal-month 2023 1)
						      (make-cal-month 2023 4) #f #f))
	       3)
     (parameterize ((*current-month* (make-cal-month 2023 4)))
       (test-eq? cal-period->duration
		 (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
		 3))
     (test-eq? cal-periods-duration
	       (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
							 (make-cal-month 2022 10) #f #f)
				       ,(make-cal-period (make-cal-month 2023 1)
							 (make-cal-month 2023 4) #f #f)))
	       10)
     (test-true cal-month-in-period?
		(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
						       (make-cal-month 2022 4) #f #f)
				      (make-cal-month 2022 3)))
     (test-false cal-month-in-period?
		 (cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
							(make-cal-month 2022 4) #f #f)
				       (make-cal-month 2022 5)))
     (test-true cal-month-in-periods?
		(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
							   (make-cal-month 2022 4) #f #f)
					 ,(make-cal-period (make-cal-month 2023 5)
							   (make-cal-month 2023 10) #f #f))
				       (make-cal-month 2022 3)))
     (test-true cal-month-in-periods?
		(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
							   (make-cal-month 2022 4) #f #f)
					 ,(make-cal-period (make-cal-month 2023 5)
							   (make-cal-month 2023 10) #f #f))
				       (make-cal-month 2023 7)))
     (test-false cal-month-in-periods?
		 (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
							    (make-cal-month 2022 4) #f #f)
					  ,(make-cal-period (make-cal-month 2023 5)
							    (make-cal-month 2023 10) #f #f))
					(make-cal-month 2022 10)))
     (test-equal? cal-period->string
		  (cal-period->string (make-cal-period (make-cal-month 2022 1)
						       (make-cal-month 2022 4) #f #f))
		  "2022-01..2022-04")
     (test-equal? cal-periods->string
	          (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
							   (make-cal-month 2022 4) #f #f)
					 ,(make-cal-period (make-cal-month 2022 12)
							   (make-cal-month 2023 2) #f #f)))
		  "2022-01..2022-04, 2022-12..2023-02")
     (test-false cal-periods-match
		 (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
							(make-cal-month 2022 4) #f #f)
				      ,(make-cal-period (make-cal-month 2022 12)
							(make-cal-month 2023 2) #f #f))
				    (make-cal-month 2022 5)))
     (test-equal? cal-periods-match
		  (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
							 (make-cal-month 2022 4) #f #f)
				       ,(make-cal-period (make-cal-month 2022 12)
							 (make-cal-month 2023 2) #f #f))
				     (make-cal-month 2022 2))
		  (make-cal-period (make-cal-month 2022 1)
				   (make-cal-month 2022 4) #f #f))
     ))

  )