Split out period module.
This commit is contained in:
parent
8cc6b8ac43
commit
30be540f09
3 changed files with 184 additions and 131 deletions
|
|
@ -33,17 +33,13 @@
|
||||||
(chicken process-context)
|
(chicken process-context)
|
||||||
testing
|
testing
|
||||||
dictionary
|
dictionary
|
||||||
month)
|
month
|
||||||
|
period)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Static default configuration
|
;; Static default configuration
|
||||||
|
|
||||||
(define *members-directory* (make-parameter "members"))
|
(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
|
;; Testing
|
||||||
|
|
@ -65,130 +61,6 @@
|
||||||
(display ".")
|
(display ".")
|
||||||
(error 'unit-test name)))))
|
(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
|
;; Member info data file
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -26,7 +26,8 @@
|
||||||
(import testing
|
(import testing
|
||||||
listing
|
listing
|
||||||
dictionary
|
dictionary
|
||||||
month)
|
month
|
||||||
|
period)
|
||||||
|
|
||||||
;; Print banner
|
;; Print banner
|
||||||
(print "brmsaptool 0.2 (c) 2023 Brmlab, z.s.")
|
(print "brmsaptool 0.2 (c) 2023 Brmlab, z.s.")
|
||||||
|
|
@ -36,4 +37,5 @@
|
||||||
(listing-tests!)
|
(listing-tests!)
|
||||||
(dictionary-tests!)
|
(dictionary-tests!)
|
||||||
(month-tests!)
|
(month-tests!)
|
||||||
|
(period-tests!)
|
||||||
(newline)
|
(newline)
|
||||||
|
|
|
||||||
179
period.scm
Normal file
179
period.scm
Normal file
|
|
@ -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")
|
||||||
|
))
|
||||||
|
|
||||||
|
)
|
||||||
Loading…
Add table
Add a link
Reference in a new issue