From b55c0314817b713741b3fae62033b9b410f95696 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Tue, 9 May 2023 19:26:50 +0200 Subject: [PATCH] Initial import of new cal-period. --- src/cal-period.scm | 284 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 284 insertions(+) create mode 100644 src/cal-period.scm diff --git a/src/cal-period.scm b/src/cal-period.scm new file mode 100644 index 0000000..eade89f --- /dev/null +++ b/src/cal-period.scm @@ -0,0 +1,284 @@ +;; +;; cal-period.scm +;; +;; Calendar month periods. +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; 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) + (monthperiods 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)) + (monthstring 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)) + )) + + )