;;
;; 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-month*
  
  make-cal-period

  cal-period-since
  cal-period-before
  cal-period-scomment
  cal-period-bcomment
  
  period-markers->cal-periods
  
  cal-periods-duration
  
  cal-month-in-period?
  cal-month-in-periods?
  
  cal-periods->string
  cal-periods-match
  
  make-cal-period-lookup-table
  lookup-by-cal-period
  
  cal-period-tests!
  )

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

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

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

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

 ;; 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-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*)
		(car ml))))
     (and (or (not (cal-period-before p))
	      (cal-month<? m (cal-period-before p)))
	  (not (cal-month<? m (cal-period-since p))))))

 ;; 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 string representing a month period with possibly open end.
 (define (cal-period->string p)
   (sprintf "~A..~A"
	    (cal-month->string (cal-period-since p))
	    (cal-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 (car prev) #f)
		      (cdr prev))
		res))
	 (loop (cdr lst)
	       (if prev
		   (cons (cons (make-cal-period (car prev) (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))))))

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

 )