; .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))))