hackerbase/period.scm

;;
;; 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
 (
  *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 (+ 1900 (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)
    ", "))

 ;; 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)))
		 '(((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")
    ))

 )