Initial import of new cal-period.
This commit is contained in:
parent
cd787c7319
commit
b55c031481
1 changed files with 284 additions and 0 deletions
284
src/cal-period.scm
Normal file
284
src/cal-period.scm
Normal file
|
|
@ -0,0 +1,284 @@
|
|||
;;
|
||||
;; cal-period.scm
|
||||
;;
|
||||
;; Calendar 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 cal-period))
|
||||
|
||||
(module
|
||||
cal-period
|
||||
(
|
||||
*current-month*
|
||||
|
||||
make-cal-period
|
||||
|
||||
cal-period-since
|
||||
cal-period-before
|
||||
cal-period-scomment
|
||||
cal-period-bcomment
|
||||
|
||||
period-markers->cal-periods
|
||||
|
||||
cal-periods-duration
|
||||
|
||||
cal-month-in-period?
|
||||
cal-month-in-periods?
|
||||
|
||||
cal-periods->string
|
||||
cal-periods-match
|
||||
|
||||
make-cal-period-lookup-table
|
||||
lookup-by-cal-period
|
||||
|
||||
cal-period-tests!
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken sort)
|
||||
(chicken time)
|
||||
(chicken time posix)
|
||||
(chicken format)
|
||||
(chicken string)
|
||||
cal-month
|
||||
testing
|
||||
configuration)
|
||||
|
||||
;; Current month - if changed, we get the actual state for given month.
|
||||
(define *current-month*
|
||||
(make-parameter
|
||||
(let ((d (seconds->local-time (current-seconds))))
|
||||
(list (+ 1900 (vector-ref d 5))
|
||||
(+ (vector-ref d 4) 1)))))
|
||||
|
||||
;; Creates a new period value with optional since and before
|
||||
;; comments.
|
||||
(define (make-period since before . args)
|
||||
(let ((scomment (if (not (null? args)) (car args) #f))
|
||||
(bcomment (if (and (not (null? args))
|
||||
(not (null? (cdr args))))
|
||||
(cadr args)
|
||||
#f)))
|
||||
(list since before scomment bcomment)))
|
||||
|
||||
;; Simple accessors
|
||||
(define period-since car)
|
||||
(define period-before cadr)
|
||||
(define period-scomment caddr)
|
||||
(define period-bcomment cadddr)
|
||||
|
||||
;; 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 (make-period (car cb) #f (cadr cb)) 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)))
|
||||
(comment (if (and line-number
|
||||
(not (null? (cdddr marker))))
|
||||
(cadddr marker)
|
||||
#f)))
|
||||
(if (eq? mtype rmt)
|
||||
(if cb
|
||||
(loop (cdr l)
|
||||
(cons (make-period (car cb) month (cadr cb) comment) ps)
|
||||
#f)
|
||||
(loop (cdr l)
|
||||
ps
|
||||
(list month comment)))
|
||||
(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 (period-since p))
|
||||
(e (period-before 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 (period-before p))
|
||||
(month<? m (period-before p)))
|
||||
(not (month<? m (period-since 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 (period-since p))
|
||||
(month->string (period-before 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)))))))
|
||||
|
||||
;; Creates lookup table from definition source
|
||||
(define (make-period-lookup-table source)
|
||||
(let loop ((lst source)
|
||||
(res '())
|
||||
(prev #f))
|
||||
(if (null? lst)
|
||||
(reverse
|
||||
(cons (cons (make-period (car prev) #f)
|
||||
(cdr prev))
|
||||
res))
|
||||
(loop (cdr lst)
|
||||
(if prev
|
||||
(cons (cons (make-period (car prev) (caar lst))
|
||||
(cdr prev))
|
||||
res)
|
||||
res)
|
||||
(car lst)))))
|
||||
|
||||
;; Looks up current month and returns associated definitions
|
||||
(define (lookup-by-period table)
|
||||
(let loop ((lst table))
|
||||
(if (null? lst)
|
||||
#f
|
||||
(if (month-in-period? (caar lst))
|
||||
(cdar lst)
|
||||
(loop (cdr lst))))))
|
||||
|
||||
;; 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) #f #f)
|
||||
((2023 1) (2023 4) #f #f))
|
||||
""
|
||||
-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) #f #f)
|
||||
((2023 1) (2023 4) #f #f)
|
||||
((2023 5) #f #f #f))
|
||||
""
|
||||
-1))
|
||||
(test-eq? period-duration
|
||||
(period->duration '((2023 1) (2023 4) #f #f)) 3)
|
||||
(parameterize ((*current-month* (list 2023 4)))
|
||||
(test-eq? period-duration
|
||||
(period->duration '((2023 1) #f #f #f)) 3))
|
||||
(test-eq? periods-duration
|
||||
(periods-duration '(((2022 3) (2022 10) #f #f)
|
||||
((2023 1) (2023 4) #f #f)))
|
||||
10)
|
||||
(test-true month-in-period?
|
||||
(month-in-period? '((2022 1) (2022 4) #f #f) '(2022 3)))
|
||||
(test-false month-in-period?
|
||||
(month-in-period? '((2022 1) (2022 4) #f #f) '(2022 5)))
|
||||
(test-true month-in-periods?
|
||||
(month-in-periods? '(((2022 1) (2022 4) #f #f)
|
||||
((2023 5) (2023 10) #f #f))
|
||||
'(2022 3)))
|
||||
(test-true month-in-periods?
|
||||
(month-in-periods? '(((2022 1) (2022 4) #f #f)
|
||||
((2023 5) (2023 10) #f #f))
|
||||
'(2023 7)))
|
||||
(test-false month-in-periods?
|
||||
(month-in-periods? '(((2022 1) (2022 4) #f #f)
|
||||
((2023 5) (2023 10) #f #f))
|
||||
'(2022 10)))
|
||||
(test-equal? period->string
|
||||
(period->string '((2022 1) (2022 4) #f #f))
|
||||
"2022-01..2022-04")
|
||||
(test-equal? periods->string
|
||||
(periods->string '(((2022 1) (2022 4) #f #f)
|
||||
((2022 12) (2023 2) #f #f)))
|
||||
"2022-01..2022-04, 2022-12..2023-02")
|
||||
(test-false periods-match (periods-match '(((2022 1) (2022 4) #f #f)
|
||||
((2022 12) (2023 2) #f #f))
|
||||
'(2022 5)))
|
||||
(test-equal? periods-match (periods-match '(((2022 1) (2022 4) #f #f)
|
||||
((2022 12) (2023 2) #f #f))
|
||||
'(2022 2))
|
||||
'((2022 1) (2022 4) #f #f))
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue