279 lines
6.5 KiB
Scheme
279 lines
6.5 KiB
Scheme
;;
|
|
;; cal-day.scm
|
|
;;
|
|
;; Day 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 cal-day))
|
|
|
|
(module
|
|
cal-day
|
|
(
|
|
make-cal-day
|
|
|
|
cal-day?
|
|
|
|
cal-day-year
|
|
cal-day-month
|
|
cal-day-day
|
|
|
|
cal-day->month
|
|
|
|
cal-day->string
|
|
string->cal-day
|
|
parse-cal-day/month
|
|
|
|
cal-day=?
|
|
cal-day<?
|
|
cal-day<=?
|
|
cal-day>=?
|
|
cal-day>?
|
|
|
|
cal-day/month<?
|
|
|
|
cal-day/month->string
|
|
|
|
cal-day-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken format)
|
|
(chicken string)
|
|
util-tag
|
|
cal-month
|
|
testing)
|
|
|
|
;; Type tag
|
|
(define TAG-CAL-DAY (make-tag CAL-DAY))
|
|
|
|
;; Creates new calendar day representation
|
|
(define (make-cal-day y m d)
|
|
(list TAG-CAL-DAY
|
|
y m d))
|
|
|
|
;; Returns true if this is a leap year
|
|
(define (cal-year-leap? y)
|
|
(and (= (modulo y 4) 0)
|
|
(or (not (= (modulo y 100) 0))
|
|
(= (modulo y 400) 0))))
|
|
|
|
;; Returns the number of days of given month
|
|
(define (cal-month-days y/m . ms)
|
|
(let* ((year (if (null? ms)
|
|
(cal-month-year y/m)
|
|
y/m))
|
|
(month (if (null? ms)
|
|
(cal-month-month y/m)
|
|
(car ms)))
|
|
(leap? (cal-year-leap? year))
|
|
;; 1 2
|
|
(mdays `(31
|
|
,(if leap? 29 28)
|
|
;;3 4 5 6 7 8 9 10 11 12
|
|
31 30 31 30 31 31 30 31 30 31)))
|
|
(list-ref mdays (sub1 month))))
|
|
|
|
;; Returns true if given value is a valid calendar day
|
|
(define (cal-day? v)
|
|
(and (list? v)
|
|
(not (null? v))
|
|
(eq? TAG-CAL-DAY (car v))
|
|
(not (null? (cdr v)))
|
|
(integer? (cadr v))
|
|
(>= (cadr v) 1000)
|
|
(<= (cadr v) 9999)
|
|
(not (null? (cddr v)))
|
|
(integer? (caddr v))
|
|
(>= (caddr v) 1)
|
|
(<= (caddr v) 12)
|
|
(not (null? (cdddr v)))
|
|
(integer? (cadddr v))
|
|
(>= (cadddr v) 1)
|
|
(let ((days (cal-month-days (cadr v) (caddr v))))
|
|
(<= (cadddr v) days))))
|
|
|
|
;; Simple accessors
|
|
(define cal-day-year cadr)
|
|
(define cal-day-month caddr)
|
|
(define cal-day-day cadddr)
|
|
|
|
;; Convert to month representation
|
|
(define (cal-day->month v . stop?s)
|
|
(let* ((stop? (if (null? stop?s)
|
|
#f
|
|
(car stop?s)))
|
|
(M (make-cal-month (cal-day-year v)
|
|
(cal-day-month v))))
|
|
(if (and stop?
|
|
(> (cal-day-day v) 1))
|
|
(cal-month-add M 1)
|
|
M)))
|
|
|
|
;; Converts day to ISO date string
|
|
(define (cal-day->string v)
|
|
(let ((y (cal-day-year v))
|
|
(m (cal-day-month v))
|
|
(d (cal-day-day v)))
|
|
(format "~A-~A-~A"
|
|
y
|
|
(if (> m 9)
|
|
m
|
|
(format "0~A" m))
|
|
(if (> d 9)
|
|
d
|
|
(format "0~A" d)))))
|
|
|
|
;; Converts ISO date string to cal-day
|
|
(define (string->cal-day s)
|
|
(let ((l (string-split s "-")))
|
|
(if (= (length l) 3)
|
|
(apply make-cal-day (map string->number l))
|
|
#f)))
|
|
|
|
;; Parses given string as either day or month
|
|
(define (parse-cal-day/month s)
|
|
(let ((d (string->cal-day s)))
|
|
(or d
|
|
(string->cal-month s))))
|
|
|
|
;; Date equality
|
|
(define (cal-day=? a b)
|
|
(and (cal-day? a)
|
|
(cal-day? b)
|
|
(eq? (cal-day-year a)
|
|
(cal-day-year b))
|
|
(eq? (cal-day-month a)
|
|
(cal-day-month b))
|
|
(eq? (cal-day-day a)
|
|
(cal-day-day b))))
|
|
|
|
;; Strict date inequality
|
|
(define (cal-day<? a b)
|
|
(and (cal-day? a)
|
|
(cal-day? b)
|
|
(or (< (cal-day-year a)
|
|
(cal-day-year b))
|
|
(and (= (cal-day-year a)
|
|
(cal-day-year b))
|
|
(or (< (cal-day-month a)
|
|
(cal-day-month b))
|
|
(and (= (cal-day-month a)
|
|
(cal-day-month b))
|
|
(< (cal-day-day a)
|
|
(cal-day-day b))))))))
|
|
|
|
;; Non-strict inequality
|
|
(define (cal-day<=? a b)
|
|
(or (cal-day=? a b)
|
|
(cal-day<? a b)))
|
|
|
|
;; Inequality the other way
|
|
(define (cal-day>=? a b)
|
|
(not (cal-day<? a b)))
|
|
|
|
;; Strict inequality the other way
|
|
(define (cal-day>? a b)
|
|
(not (cal-day<=? a b)))
|
|
|
|
;; Universal sorting comparator
|
|
(define (cal-day/month<? a b)
|
|
(if (and (cal-day? a)
|
|
(cal-day? b))
|
|
(cal-day<? a b)
|
|
(if (and (cal-month? a)
|
|
(cal-month? b))
|
|
(cal-month<? a b)
|
|
(error 'cal-day/month<?
|
|
"Requires two arguments of the same type"
|
|
(list a b)))))
|
|
|
|
;; Semi-universal string conversion
|
|
(define (cal-day/month->string v)
|
|
(if (cal-day? v)
|
|
(cal-day->string v)
|
|
(if (cal-month? v)
|
|
(cal-month->string v)
|
|
"")))
|
|
|
|
;; Module self-tests
|
|
(define (cal-day-tests!)
|
|
(run-tests
|
|
cal-day
|
|
(test-equal? make-cal-day
|
|
(make-cal-day 2023 5 10)
|
|
`(,TAG-CAL-DAY 2023 5 10))
|
|
(test-true cal-year-leap?
|
|
(cal-year-leap? 2000))
|
|
(test-true cal-year-leap?
|
|
(cal-year-leap? 2024))
|
|
(test-false cal-year-leap?
|
|
(cal-year-leap? 2023))
|
|
(test-false cal-year-leap?
|
|
(cal-year-leap? 1900))
|
|
(test-eq? cal-month-days
|
|
(cal-month-days 2023 5)
|
|
31)
|
|
(test-eq? cal-month-days
|
|
(cal-month-days 2023 2)
|
|
28)
|
|
(test-eq? cal-month-days
|
|
(cal-month-days 2024 2)
|
|
29)
|
|
(test-true cal-day?
|
|
(cal-day? (make-cal-day 2023 5 10)))
|
|
(test-false cal-day?
|
|
(cal-day? (make-cal-day 2023 2 29)))
|
|
(test-true cal-day?
|
|
(cal-day? (make-cal-day 2024 2 29)))
|
|
(test-equal? cal-day->string
|
|
(cal-day->string (make-cal-day 2024 2 29))
|
|
"2024-02-29")
|
|
(test-equal? string->cal-day
|
|
(string->cal-day "2023-05-11")
|
|
(make-cal-day 2023 5 11))
|
|
(test-true parse-cal-day/month
|
|
(cal-day? (parse-cal-day/month "2023-05-11")))
|
|
(test-true parse-cal-day/month
|
|
(cal-month? (parse-cal-day/month "2023-05")))
|
|
(test-true cal-day/month<?
|
|
(cal-day/month<? (make-cal-day 2023 5 21)
|
|
(make-cal-day 2023 5 22)))
|
|
(test-exn cal-day/month<?
|
|
(cal-day/month<? (make-cal-day 2023 5 21)
|
|
(make-cal-month 2023 5)))
|
|
(test-true cal-day/month<?
|
|
(cal-day/month<? (make-cal-month 2023 4)
|
|
(make-cal-month 2023 5)))
|
|
(test-false cal-day/month<?
|
|
(cal-day/month<? (make-cal-day 2023 5 22)
|
|
(make-cal-day 2023 5 22)))
|
|
(test-equal? cal-day/month->string
|
|
(cal-day/month->string (make-cal-day 2023 5 22))
|
|
"2023-05-22")
|
|
(test-equal? cal-day/month->string
|
|
(cal-day/month->string (make-cal-month 2023 5))
|
|
"2023-05")
|
|
))
|
|
|
|
)
|
|
|