182 lines
5 KiB
Scheme
182 lines
5 KiB
Scheme
;;
|
|
;; month.scm
|
|
;;
|
|
;; Month processing support.
|
|
;;
|
|
;; 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 month))
|
|
|
|
(module
|
|
month
|
|
(
|
|
make-month
|
|
month-year
|
|
month-month
|
|
month-valid?
|
|
string->month
|
|
month->string
|
|
month=?
|
|
month<?
|
|
month<=?
|
|
month>=?
|
|
month>?
|
|
month-diff
|
|
month-add
|
|
month-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken format)
|
|
testing)
|
|
|
|
;; Simple wrapper for creating month representation as a list.
|
|
(define (make-month y m)
|
|
(list y m))
|
|
|
|
;; Accessors
|
|
(define month-year car)
|
|
(define month-month cadr)
|
|
|
|
;; Returns true if this is a valid month representation - a list with
|
|
;; two integer elements within the allowed range.
|
|
(define (month-valid? m)
|
|
(and (list? m)
|
|
(car m)
|
|
(cdr m)
|
|
(cadr m)
|
|
(null? (cddr m))
|
|
(integer? (car m))
|
|
(integer? (cadr m))
|
|
(>= (car m) 1000)
|
|
(<= (car m) 9999)
|
|
(>= (cadr m) 1)
|
|
(<= (cadr m) 12)))
|
|
|
|
;; Converts string in a format YYYY-MM to valid month. Returns #f if
|
|
;; the conversion fails.
|
|
(define (string->month s)
|
|
(let ((l (string-split s "-")))
|
|
(if (or (not l)
|
|
(null? l)
|
|
(null? (cdr l))
|
|
(not (null? (cddr l))))
|
|
#f
|
|
(let ((y (string->number (car l)))
|
|
(m (string->number (cadr l))))
|
|
(if (and y m)
|
|
(let ((M (list y m)))
|
|
(if (month-valid? M)
|
|
M
|
|
#f))
|
|
#f)))))
|
|
|
|
;; Formats (valid) month as YYYY-MM string
|
|
(define (month->string M)
|
|
(if M
|
|
(if (month-valid? M)
|
|
(let ((y (car M))
|
|
(m (cadr M)))
|
|
(sprintf "~A-~A~A"
|
|
y
|
|
(if (< m 10) "0" "")
|
|
m))
|
|
(error 'string->month "Invalid month" M))
|
|
"____-__"))
|
|
|
|
;; Returns true if both arguments are a valid month and are equal
|
|
(define (month=? m n)
|
|
(and (month-valid? m)
|
|
(month-valid? n)
|
|
(equal? m n)))
|
|
|
|
;; Returns true if the first argument is a month in the past of the
|
|
;; second argument month
|
|
(define (month<? m n)
|
|
(and (month-valid? m)
|
|
(month-valid? n)
|
|
(or (< (car m) (car n))
|
|
(and (= (car m) (car n))
|
|
(< (cadr m) (cadr n))))))
|
|
|
|
;; Returns true if m is less than or equal n
|
|
(define (month<=? m n)
|
|
(or (month<? m n)
|
|
(month=? m n)))
|
|
|
|
;; Returns true if m is greater than or equal to n
|
|
(define (month>=? m n)
|
|
(not (month<? m n)))
|
|
|
|
;; Returns true if m is greater than n
|
|
(define (month>? m n)
|
|
(not (month<=? m n)))
|
|
|
|
;; Returns the number of months between from f and to t. The first
|
|
;; month is included in the count, the last month is not.
|
|
(define (month-diff f t)
|
|
(if (month-valid? f)
|
|
(if (month-valid? t)
|
|
(let ((F (+ (* (car f) 12) (cadr f) -1))
|
|
(T (+ (* (car t) 12) (cadr t) -1)))
|
|
(- T F))
|
|
(error 'month-diff "Second argument is not a valid month" t))
|
|
(error 'month-diff "First argument is not a valid month" f)))
|
|
|
|
;; Returns a month n months after the month m. The number n defaults
|
|
;; to 1.
|
|
(define (month-add m . ns)
|
|
(let* ((n (if (null? ns)
|
|
1
|
|
(car ns)))
|
|
(mi (+ (* 12 (car m)) (cadr m) n -1)))
|
|
(list (quotient mi 12)
|
|
(+ (remainder mi 12) 1))))
|
|
|
|
;; Performs self-tests of the month module.
|
|
(define (month-tests!)
|
|
(run-tests
|
|
month
|
|
(test-true month-valid? (month-valid? '(2023 5)))
|
|
(test-false month-valid? (month-valid? '(999 8)))
|
|
(test-false month-valid? (month-valid? '(2023 -5)))
|
|
(test-equal? string->month (string->month "2023-01") '(2023 1))
|
|
(test-false string->month (string->month "2023-13"))
|
|
(test-false string->month (string->month "YYYY-01"))
|
|
(test-false string->month (string->month "2023-MMM"))
|
|
(test-equal? month->string (month->string '(2023 1)) "2023-01")
|
|
(test-exn month->string (month->string '(999 12)))
|
|
(test-exn month->string (month->string '(2023 13)))
|
|
(test-true month<? (month<? '(2023 5) '(2023 6)))
|
|
(test-true month<? (month<? '(2022 12) '(2023 1)))
|
|
(test-false month<? (month<? '(2023 1) '(2023 1)))
|
|
(test-false month<? (month<? '(2023 1) '(2023 1)))
|
|
(test-true month=? (month=? '(2023 4) '(2023 4)))
|
|
(test-false month=? (month=? '(2023 4) '(2023 5)))
|
|
(test-eq? month-diff (month-diff '(2023 1) '(2023 2)) 1)
|
|
(test-eq? month-diff (month-diff '(2023 1) '(2023 12)) 11)
|
|
(test-eq? month-diff (month-diff '(2023 1) '(2022 2)) -11)
|
|
(test-eq? month-add (month-add '(2023 1) 2) '(2023 3))
|
|
))
|
|
|
|
)
|