; .EnTete "Le-Lisp (c) version 15.2" " " "La bibliothe`que des dates"
; .EnPied " " "%" " "
; .SuperTitre "Les bibliothe`ques des Dates"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: libdate.ll,v 4.2 88/06/15 14:38:06 kuczynsk Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'date))
(defvar #:sys-package:colon 'date)
; .Section "Documentation"
;
; L E S D A T E S
;
; (create-date) -> renvoie la structure representant la date
; (verifie et complete).
;
; (prin <date>) -> semantique d'impression d'une date (format court).
;
; (short-string-date <date>) -> date sous la forme d'une chaine.
; (long-string-date <date>) -> idem en format long.
;
; (datep <x>) -> predicat "est une date".
;
; (week-day-number <date>) -> numero du jour de la semaine.
;
; (leap-year-p <annee>) -> predicat "est le numero d'une annee bissextile".
;
; (eqdate <date1> <date2>) -> comparaison de dates.
; (<date <date1> <date2>)
; ...
;
; (date-to-number <date>) -> nombre de jours depuis le 1 janvier 0 a 0 heure.
;
; (number-to-date <n>) -> transformation inverse.
;
; .Section "Interface"
(unless (getdef 'create-date)
(defstruct date
year month day hour minute second msecond week-day))
(de create-date ()
; cre' une date : ve'rifie la re'ponse du syste`me et
; charge les options par de'faut.
(let ((date (date)))
(typevector date 'date)
(unless (fixp (:year date))
(error 'date
#- #:system:foreign-language "mauvaise annee"
#+ #:system:foreign-language "bad year"
date))
(when (or (not (fixp (:month date)))
(< (:month date) 1) (> (:month date) 12))
(error 'date
#- #:system:foreign-language "mauvais mois"
#+ #:system:foreign-language "bad month"
date))
(when (or (not (fixp (:day date)))
(< (:day date) 1) (> (:day date) 31))
(error 'date
#- #:system:foreign-language "mauvais jour"
#+ #:system:foreign-language "bad day"
date))
(when (or (not (fixp (:hour date)))
(< (:hour date) 0) (> (:hour date) 23))
(error 'date
#- #:system:foreign-language "mauvaise heure"
#+ #:system:foreign-language "bad hour"
date))
(when (or (not (fixp (:minute date)))
(< (:minute date) 0) (> (:minute date) 59))
(error 'date
#- #:system:foreign-language "mauvaise minute"
#+ #:system:foreign-language "bad minute"
date))
(unless (:second date) (:second date 0))
(when (or (not (fixp (:second date)))
(< (:second date) 0) (> (:second date) 59))
(error 'date
#- #:system:foreign-language "mauvaise seconde"
#+ #:system:foreign-language "bad second"
date))
(unless (:msecond date) (:msecond date 0))
(when (or (not (fixp (:msecond date)))
(< (:msecond date) 0) (> (:msecond date) 999))
(error 'date
#- #:system:foreign-language "mauvaise mseconde"
#+ #:system:foreign-language "bad msecond"
date))
(unless (:week-day date)
(:week-day date (week-day-number date)))
(when (or (not (fixp (:week-day date)))
(< (:week-day date) 1) (> (:week-day date) 7))
(error 'date
#- #:system:foreign-language "mauvaise week-day"
#+ #:system:foreign-language "bad day of the week"
date))
date))
(de #:date:prin (date)
; impression de la structure "date"
(prin (short-string-date date)))
; .Section "Les donne'es"
;
; De'but de la partie de'pendante du site
; A chaque fois, on a les versions courtes et longues
; Les noms des mois
#- #:system:foreign-language
(defvar short-month-names '((1 . "janv")(2 . "fevr")(3 . "mars")
(4 . "avr")(5 . "mai")(6 . "juin")(7 . "juil")(8 . "aout")
(9 . "sept")(10 . "oct")(11 . "nov")(12 . "dec")))
#+ #:system:foreign-language
(defvar short-month-names '((1 . "jan")(2 . "febr")(3 . "mar")
(4 . "apr")(5 . "may")(6 . "june")(7 . "july")(8 . "aug")
(9 . "sept")(10 . "oct")(11 . "nov")(12 . "dec")))
#- #:system:foreign-language
(defvar long-month-names '((1 . "janvier")(2 . "fevrier")(3 . "mars")
(4 . "avril")(5 . "mai")(6 . "juin")(7 . "juillet")(8 . "aout")
(9 . "septembre")(10 . "octobre")(11 . "novembre")(12 . "decembre")))
#+ #:system:foreign-language
(defvar long-month-names '((1 . "january")(2 . "february")(3 . "march")
(4 . "april")(5 . "may")(6 . "june")(7 . "july")(8 . "august")
(9 . "september")(10 . "october")(11 . "november")(12 . "december")))
; Les noms des jours
#- #:system:foreign-language
(defvar short-day-names '((1 . "lun")(2 . "mar")(3 . "mer")(4 . "jeu")
(5 . "ven")(6 . "sam")(7 . "dim")))
#+ #:system:foreign-language
(defvar short-day-names '((1 . "mon")(2 . "tue")(3 . "wed")(4 . "thu")
(5 . "fri")(6 . "sat")(7 . "sun")))
#- #:system:foreign-language
(defvar long-day-names '((1 . "lundi")(2 . "mardi")(3 . "mercredi")
(4 . "jeudi")(5 . "vendredi")(6 . "samedi")(7 . "dimanche")))
#+ #:system:foreign-language
(defvar long-day-names '((1 . "monday")(2 . "tuesday")(3 . "wednesday")
(4 . "thursday")(5 . "friday")(6 . "saturday")(7 . "sunday")))
; Fin des donne'es de'pendantes du site
; La longueur des mois
(defvar month-lengths '((1 . 31)(2 . 28)(3 . 31)(4 . 30)(5 . 31)
(6 . 30)(7 . 31)(8 . 31)(9 . 30)(10 . 31)(11 . 30)(12 . 31)))
; .Section "Les conversions"
; le format court (24 caracte`res)
(de short-string-date (date)
(ifn (datep date) (error 'short-string-date 'errbpa date))
(let ((year (modulo (:year date) 100))
(month-name (cassq (:month date) short-month-names))
(day (:day date))(hour (:hour date))
(min (:minute date))(sec (:second date))
(day-name (cassq (:week-day date) short-day-names))
(result (makestring 24 #\sp)))
(bltstring result 0 day-name 0)
(bltstring result (- 6 (slength day)) day 0)
(bltstring result 7 month-name 0)
(bltstring result (- 14 (slength year)) year 0)
(bltstring result 15 "00:00:00" 0)
(bltstring result (- 17 (slength hour)) hour 0)
(bltstring result (- 20 (slength min)) min 0)
(bltstring result (- 23 (slength sec)) sec 0)
result))
; Le format long (48 caracteres)
(de long-string-date (date)
(ifn (datep date) (error 'long-string-date 'errbpa date))
(let ((year (:year date))
(month-name (cassq (:month date) long-month-names))
(day (:day date))(hour (:hour date))
(min (:minute date))(sec (:second date))
(msec (:msecond date))
(day-name (cassq (:week-day date) long-day-names))
(result (makestring 48 #\sp)))
(bltstring result (- 3 (div (slength day-name) 3)) day-name 0)
(bltstring result (- 12 (slength day)) day 0)
(bltstring result (- 16 (div (slength month-name) 3)) month-name 0)
(bltstring result (- 27 (slength year)) year 0)
(bltstring result 30 "00h 00mn 00s 000ms" 0)
(bltstring result (- 32 (slength hour)) hour 0)
(bltstring result (- 36 (slength min)) min 0)
(bltstring result (- 41 (slength sec)) sec 0)
(bltstring result (- 46 (slength msec)) msec 0)
result))
; .Section "Les utilitaires"
; Le pre'dicat : est une date
(de datep (date)
(and (vectorp date) (eq (typevector date) 'date)))
; Calcul du nume'ro (1-7) du jour de la semaine (Gre'gorien, year >= 0)
(de week-day-number (date)
(ifn (datep date) (error 'week-day-number 'errbpa date))
(let ((year (:year date))(month (:month date))
(day (:day date))(result 5))
; le premier janvier 0 etait un samedi
(setq result
(+ result year
(leap-number year)
(year-day-number date)))
(setq result (modulo result 7))
(if (eq result 0) 7 result)))
; Calcul du nume'ro du jour dans l'anne'e
(de year-day-number (date)
(ifn (datep date) (error 'year-day-number 'errbpa date))
(let ((year (:year date))(month (:month date))(day (:day date)))
(if (> month 1)
(for (i 1 1 (1- month)) (incr day (month-length i year))))
day))
(de month-length (month year)
(+ (cassq month month-lengths)
(if (and (eq month 2) (leap-year-p year)) 1 0)))
; Le pre'dicat des anne'es bissextiles
(de leap-year-p (year)
(if (eq (modulo year 4) 0)
(if (eq (modulo year 100) 0) (eq (modulo year 400) 0) t)))
; Le nombre d'anne'es bissextiles depuis l'an 0
(de leap-number (year)
(let ((previous (if (> year 0) (1- year) year)))
(+ (div previous 4)
(- (div previous 100))
(div previous 400)
(if (> year 0) 1 0))))
; Un test : Le premier jour (a` Rome) du calendrier gre'gorien
; (eq (week-day-number #[1582 10 15 () () ()]) 5)
; .Section "Les comparaisons"
; L'e'galite' des dates (avec le controle)
(de eqdate (date1 date2)
(and (datep date1) (datep date2) (eqvector date1 date2)))
(synonymq =date eqdate)
(de /=date (date1 date2) (not (=date date1 date2)))
(synonymq <>date /=date)
; La comparaison des dates
(de <?date (date1 date2 equal?)
(ifn (datep date1) (error '<date 'errbpa date1))
(ifn (datep date2) (error '<date 'errbpa date2))
(tag date-cmp
(for (i 0 1 6)
(cond
((< (or (vref date1 i) 0)
(or (vref date2 i) 0))
(exit date-cmp t))
((> (or (vref date1 i) 0)
(or (vref date2 i) 0)) (exit date-cmp ()))))
equal?))
(de <date (date1 date2) (<?date date1 date2 ()))
(de <=date (date1 date2) (<?date date1 date2 t))
(de >date (date1 date2) (<?date date2 date1 ()))
(de >=date (date1 date2) (<?date date2 date1 t))
; .Section "L'arithme'tique"
; necessite les rationnels pour etre exact !
(defvar tropic-year-length 36524220/100000) ; 365.24220
(defvar gregorian-year-length 36524250/100000) ; 365.24250
(defvar tropic-month-length (/ tropic-year-length 12))
(defvar moon-month-length 29530588/1000000) ; 29.530588
; transformation format date -> jours (depuis 1 janvier 0 0h00:00.000)
(de date-to-number (date)
(ifn (datep date) (error 'date-to-number 'errbpa date))
(let ((year (:year date))(month (:month date))
(day (:day date))(hour (:hour date))
(min (:minute date))(sec (:second date))
(msec (or (:msecond date) 0)))
(+ (* 365 year)
(leap-number year)
(year-day-number date)
(* hour 1/24)
(* min 1/1440)
(* sec 1/86400)
(* msec 1/86400000))))
; transformation jours -> date
(de number-to-date (n)
(let ((date (makevector 8 0)))
(typevector date 'date)
(let ((year (fix (/ n tropic-year-length))))
(:year date year)
(setq n (- n (* year 365) (leap-number year))))
(adjust-year)
(let ((month (1+ (fix (/ n tropic-month-length)))))
(:month date month)
(setq n (- n (year-day-number date))))
(let ((day (1+ (fix n))))
(:day date day)
(setq n (- n day)))
(adjust-day)
(:week-day date (week-day-number date))
(let ((hour (fix (* 24 n))))
(:hour date hour)
(setq n (- n (* hour 1/24))))
(let ((min (fix (* 1440 n))))
(:minute date min)
(setq n (- n (* min 1/1440))))
(let ((sec (fix (* 86400 n))))
(:second date sec)
(setq n (- n (* sec 1/86400))))
(let ((msec (fix (* 86400000 n))))
(:msecond date msec)
(setq n (- n (* msec 1/86400000))))
date))
(de adjust-year ()
(cond
((< n 0)
(:year date (1- (:year date)))
(setq n (+ n (if (leap-year-p (:year date)) 366 365)))
(adjust-year))
((or (>= n 367) (and (>= n 366) (not (leap-year-p (:year date)))))
(setq n (- n (if (leap-year-p (:year date)) 366 365)))
(:year date (1+ (:year date)))
(adjust-year))))
(de adjust-day ()
(cond
((< n 0)
(let ((adjust (1+ (fix (abs n)))))
(:day date (- (:day date) adjust))
(setq n (+ n adjust))))
((>= n 1)
(let ((adjust (fix n)))
(:day date (+ (:day date) adjust))
(setq n (- n adjust)))))
(adjust-month))
(de adjust-month ()
(cond
((< (:day date) 1)
(:month date (1- (:month date)))
(:day date
(+ (:day date) (month-length (:month date) (:year date))))
(adjust-month))
((> (:day date) (month-length (:month date) (:year date)))
(:day date
(- (:day date) (month-length (:month date) (:year date))))
(:month date (1+ (:month date)))
(adjust-month))))