diff --git a/src/cal-day.scm b/src/cal-day.scm new file mode 100644 index 0000000..77325fe --- /dev/null +++ b/src/cal-day.scm @@ -0,0 +1,112 @@ +;; +;; cal-day.scm +;; +;; Day processing support. +;; +;; 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-day)) + +(module + cal-day + ( + make-cal-day + + cal-day? + + cal-day-year + cal-day-month + cal-day-day + + cal-day->cal-month + ) + + (import scheme + util-tag + cal-month) + + ;; 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) + #f) + + ;; 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))) + + ) +