From 30be540f098dc1df3b8af152c5662258b1237b00 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Mon, 13 Mar 2023 20:18:01 +0100
Subject: [PATCH] Split out period module.

---
 brmsaptool-orig.scm | 132 +-------------------------------
 brmsaptool.scm      |   4 +-
 period.scm          | 179 ++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 184 insertions(+), 131 deletions(-)
 create mode 100644 period.scm

diff --git a/brmsaptool-orig.scm b/brmsaptool-orig.scm
index 20ef568..32735af 100644
--- a/brmsaptool-orig.scm
+++ b/brmsaptool-orig.scm
@@ -33,17 +33,13 @@
 	(chicken process-context)
 	testing
 	dictionary
-	month)
+	month
+	period)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Static default configuration
 
 (define *members-directory* (make-parameter "members"))
-(define *current-month*
-  (make-parameter
-   (let ((d (seconds->local-time (current-seconds))))
-     (list (vector-ref d 5)
-	   (vector-ref d 4)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Testing
@@ -65,130 +61,6 @@
 	 (display ".")
 	 (error 'unit-test name)))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Periods
-
-;; 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!)
-  (display "[test] period ")
-  (unit-test 'sort-period-markers
-	     (equal? (sort-period-markers '((start 2023 1) (stop 2022 10) (start 2022 3)))
-		     '((start 2022 3) (stop 2022 10) (start 2023 1))))
-  (unit-test 'period-markers->periods
-	     (equal? (period-markers->periods
-		      '((start 2022 3) (stop 2022 10) (start 2023 1) (stop 2023 4)))
-		     '(((2022 3) . (2022 10))
-		       ((2023 1) . (2023 4)))))
-  (unit-test 'period-markers->periods-open
-	     (equal? (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))))
-  (unit-test 'period-duration
-	     (eq? (period->duration '((2023 1) . (2023 4))) 3))
-  (parameterize ((*current-month* (list 2023 4)))
-    (unit-test 'period-duration
-	       (eq? (period->duration '((2023 1) . #f)) 3)))
-  (unit-test 'periods-duration
-	     (eq? (periods-duration '(((2022 3) . (2022 10))
-				      ((2023 1) . (2023 4))))
-		  10))
-  (unit-test 'month-in-period?
-	     (month-in-period? '((2022 1) . (2022 4)) '(2022 3)))
-  (unit-test 'month-in-period?-not
-	     (not (month-in-period? '((2022 1) . (2022 4)) '(2022 5))))
-  (unit-test 'month-in-periods?
-	     (month-in-periods? '(((2022 1) . (2022 4))
-				  ((2023 5) . (2023 10)))
-				'(2022 3)))
-  (unit-test 'month-in-periods?2
-	     (month-in-periods? '(((2022 1) . (2022 4))
-				  ((2023 5) . (2023 10)))
-				'(2023 7)))
-  (unit-test 'month-in-periods?-not
-	     (not (month-in-periods? '(((2022 1) . (2022 4))
-				       ((2023 5) . (2023 10)))
-				     '(2022 10))))
-  (unit-test 'period->string
-	     (equal? (period->string '((2022 1) . (2022 4)))
-		     "2022-01..2022-04"))
-  (unit-test 'periods->string
-	     (equal? (periods->string '(((2022 1) . (2022 4))
-					((2022 12). (2023 2))))
-		     "2022-01..2022-04, 2022-12..2023-02"))
-  (print " ok."))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Member info data file
 
diff --git a/brmsaptool.scm b/brmsaptool.scm
index da752da..8912fcd 100644
--- a/brmsaptool.scm
+++ b/brmsaptool.scm
@@ -26,7 +26,8 @@
 (import testing
 	listing
 	dictionary
-	month)
+	month
+	period)
 
 ;; Print banner
 (print "brmsaptool 0.2 (c) 2023 Brmlab, z.s.")
@@ -36,4 +37,5 @@
 (listing-tests!)
 (dictionary-tests!)
 (month-tests!)
+(period-tests!)
 (newline)
diff --git a/period.scm b/period.scm
new file mode 100644
index 0000000..a6848a7
--- /dev/null
+++ b/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")
+    ))
+
+ )