Split out period module.

period.scm

@@ -0,0 +1,179 @@
+;;
+;; 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.
+;;
+
+(module
+ period
+ (
+  *current-month*
+  sort-period-markers
+  period-markers->periods
+  period->duration
+  periods-duration
+  month-in-period?
+  month-in-periods?
+  period->string
+  periods->string
+  period-tests!
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken sort)
+	 (chicken time)
+	 (chicken time posix)
+	 (chicken format)
+	 (chicken string)
+	 month
+	 testing)
+
+ (define *current-month*
+   (make-parameter
+    (let ((d (seconds->local-time (current-seconds))))
+      (list (vector-ref d 5)
+	    (vector-ref d 4)))))
+
+ ;; 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<? (cdr a) (cdr b)))))
+
+ ;; Converts list of start/stop markers to list of pairs of months -
+ ;; periods.
+ (define (period-markers->periods l)
+   (let loop ((l l)
+	      (ps '())
+	      (cb #f))
+     (if (null? l)
+	 (if cb
+	     (reverse (cons (cons cb #f) ps))
+	     (reverse ps))
+	 (let ((m (car l))
+	       (rmt (if cb 'stop 'start)))
+	   (if (eq? (car m) rmt)
+	       (if cb
+		   (loop (cdr l)
+			 (cons (cons cb (cdr m)) ps)
+			 #f)
+		   (loop (cdr l)
+			 ps
+			 (cdr m)))
+	       (error 'period-markers->periods "Invalid start/stop sequence marker" m))))))
+
+ ;; 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 m)
+   (and (month<? m (cdr p))
+	(not (month<? m (car p)))))
+
+ ;; Returns true if given month is in at least one of the periods
+ ;; given.
+ (define (month-in-periods? ps m)
+   (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))
+	    (if (cdr p)
+		(month->string (cdr p))
+		"....-..")))
+
+ ;; Returns a string representing a list of periods.
+ (define (periods->string ps)
+   (string-intersperse
+    (map period->string ps)
+    ", "))
+
+ (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)))
+		 '(((2022 3) . (2022 10))
+		   ((2023 1) . (2023 4))))
+    (test-equal? period-markers->periods-open
+	         (period-markers->periods
+		  '((start 2022 3) (stop 2022 10) (start 2023 1) (stop 2023 4) (start 2023 5)))
+		 '(((2022 3) . (2022 10))
+		   ((2023 1) . (2023 4))
+		   ((2023 5) . #f)))
+    (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")
+    ))
+
+ )