124 lines
2.7 KiB
Scheme
124 lines
2.7 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-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
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)))
|
|
|
|
;; Module self-tests
|
|
(define (cal-day-tests!)
|
|
(run-tests
|
|
cal-day
|
|
))
|
|
|
|
)
|
|
|