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

 ;; 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 (cons cb #f) 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))))
	   (if (eq? mtype rmt)
	       (if cb
		   (loop (cdr l)
			 (cons (cons cb month) ps)
			 #f)
		   (loop (cdr l)
			 ps
			 month))
	       (if (eq? (*member-file-check-syntax*) 'error)
		   (error 'period-markers->periods "Invalid start/stop sequence marker" marker)
		   (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 (car p))
	  (e (cdr 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 (cdr p))
	      (month<? m (cdr p)))
	  (not (month<? m (car 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 (car p))
	    (month->string (cdr 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))
		    ((2023 1) . (2023 4)))
		   ""
		   -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))
		    ((2023 1) . (2023 4))
		    ((2023 5) . #f))
		   ""
		   -1))
    (test-eq? period-duration
	      (period->duration '((2023 1) . (2023 4))) 3)
    (parameterize ((*current-month* (list 2023 4)))
      (test-eq? period-duration
		(period->duration '((2023 1) . #f)) 3))
    (test-eq? periods-duration
	      (periods-duration '(((2022 3) . (2022 10))
				  ((2023 1) . (2023 4))))
	      10)
    (test-true month-in-period?
	       (month-in-period? '((2022 1) . (2022 4)) '(2022 3)))
    (test-false month-in-period?
		(month-in-period? '((2022 1) . (2022 4)) '(2022 5)))
    (test-true month-in-periods?
	       (month-in-periods? '(((2022 1) . (2022 4))
				    ((2023 5) . (2023 10)))
				  '(2022 3)))
    (test-true month-in-periods?
	       (month-in-periods? '(((2022 1) . (2022 4))
				    ((2023 5) . (2023 10)))
				  '(2023 7)))
    (test-false month-in-periods?
		(month-in-periods? '(((2022 1) . (2022 4))
				     ((2023 5) . (2023 10)))
				   '(2022 10)))
    (test-equal? period->string
		 (period->string '((2022 1) . (2022 4)))
		 "2022-01..2022-04")
    (test-equal? periods->string
	         (periods->string '(((2022 1) . (2022 4))
				    ((2022 12). (2023 2))))
		 "2022-01..2022-04, 2022-12..2023-02")
    (test-false periods-match (periods-match '(((2022 1) . (2022 4))
					       ((2022 12). (2023 2)))
					     '(2022 5)))
    (test-equal? periods-match (periods-match '(((2022 1) . (2022 4))
						((2022 12). (2023 2)))
					      '(2022 2))
		 '((2022 1) . (2022 4)))
    ))

 )