;;
;; period.scm
;;
;; 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 period))

(module
 period
 (
  period-since
  period-before
  period-scomment
  period-bcomment
  period-markers->periods
  periods-duration
  month-in-periods?
  periods->string
  periods-match
  period-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken sort)
	 (chicken time)
	 (chicken time posix)
	 (chicken format)
	 (chicken string)
	 month
	 testing
	 configuration)

 ;; Creates a new period value with optional since and before
 ;; comments.
 (define (make-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 since before scomment bcomment)))

 ;; Simple accessors
 (define period-since car)
 (define period-before cadr)
 (define period-scomment caddr)
 (define period-bcomment cadddr)

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

 ;; Converts list of start/stop markers to list of pairs of months -
 ;; periods.
 (define (period-markers->periods l)
   (let loop ((l (sort-period-markers l))
	      (ps '())
	      (cb #f))
     (if (null? l)
	 (list #t
	       (if cb
		   (reverse (cons (make-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-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 (period->duration p)
   (let* ((b (period-since p))
	  (e (period-before p))
	  (e- (if e e (*current-month*))))
     (month-diff b e-)))

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

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

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

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

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

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

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

 )