├── test ├── package.lisp └── test.lisp ├── README.md ├── date-calc.asd └── date-calc.lisp /test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :date-calc/test 2 | (:use :cl :date-calc :fiveam :serapeum :alexandria) 3 | (:export :run-date-calc-tests)) 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Date-Calc 2 | 3 | This is a fork of Heiko Schröter’s Date-Calc library, a port of Perl’s Date::Calc library. 4 | 5 | The original was dropped from Quicklisp, but I still use it, so 6 | I’m keeping it on life support. 7 | -------------------------------------------------------------------------------- /date-calc.asd: -------------------------------------------------------------------------------- 1 | (defsystem "date-calc" 2 | :description "Package for simple date calculation" 3 | :author "Heiko Schröter " 4 | :maintainer "Paul M. Rodriguez " 5 | :licence "GPL or Artistic" 6 | :in-order-to ((test-op (test-op "date-calc/test"))) 7 | :version "0.2" 8 | :components 9 | ((:file "date-calc"))) 10 | 11 | (defsystem "date-calc/test" 12 | :description "Test suite for date-calc." 13 | :author "Paul M. Rodriguez " 14 | :license "MIT" 15 | :depends-on ("date-calc" "fiveam" "serapeum") 16 | :perform (test-op (o c) (symbol-call :date-calc/test :run-date-calc-tests)) 17 | :pathname "test/" 18 | :serial t 19 | :components ((:file "package") 20 | (:file "test"))) 21 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :date-calc/test) 2 | 3 | (def-suite date-calc) 4 | (in-suite date-calc) 5 | 6 | (defun run-date-calc-tests () 7 | (run! 'date-calc)) 8 | 9 | (defun gen-year () 10 | (gen-integer :min 1 :max 10000)) 11 | 12 | (defun gen-month () 13 | (gen-integer :min 1 :max 12)) 14 | 15 | (defun gen-day () 16 | (gen-integer :min 1 :max 28)) 17 | 18 | (defun gen-hour () 19 | (gen-integer :min 0 :max 23)) 20 | 21 | (defun gen-minute () 22 | (gen-integer :min 0 :max 59)) 23 | 24 | (defun gen-second () 25 | (gen-integer :min 0 :max 59)) 26 | 27 | (defun gen-ymd () 28 | (fbind ((gen-year (gen-year)) 29 | (gen-month (gen-month)) 30 | (gen-day (gen-day))) 31 | (lambda () 32 | (list (gen-year) 33 | (gen-month) 34 | (gen-day))))) 35 | 36 | (defun gen-hms () 37 | (fbind ((gen-hour (gen-hour)) 38 | (gen-minute (gen-minute)) 39 | (gen-second (gen-second))) 40 | (lambda () 41 | (list (gen-hour) 42 | (gen-minute) 43 | (gen-second))))) 44 | 45 | (defun gen-ymdhms () 46 | (fbind ((gen-ymd (gen-ymd)) 47 | (gen-hms (gen-hms))) 48 | (lambda () 49 | (append (gen-ymd) (gen-hms))))) 50 | 51 | ;;; Tests, based on examples from the Date::Calc documentation and the Perl Cookbook. 52 | 53 | (test cookbook-example-1 54 | (multiple-value-bind (year month day hh mm ss) 55 | (add-delta-dhms 56 | 1973 1 18 3 45 40 ;18/Jan/1973, 3:45:40 AM 57 | 55 2 17 5 ;55 days, 2 hours, 17 minutes, 5 seconds. 58 | ) 59 | (is (eql hh 6) 60 | (eql mm 2) 61 | (eql ss 55) 62 | (eql month 3) 63 | (eql day 14) 64 | (eql year 1974)))) 65 | 66 | (test cookbook-example-2 67 | (multiple-value-bind (year month day) 68 | (add-delta-days 69 | 1973 1 18 70 | 55) 71 | (is (eql month 3) 72 | (eql day 14) 73 | (eql year 1973)))) 74 | 75 | (test cookbook-example-3 76 | (let* ((bree '(1981 6 16)) 77 | (nat '(1973 1 18)) 78 | (difference 79 | (multiple-value-call #'delta-days 80 | (values-list bree) 81 | (values-list nat)))) 82 | (is (eql -3071 difference)))) 83 | 84 | (test cookbook-example-4 85 | (mvlet* ((bree '(1981 6 16 4 35 25)) ;6/16/81 4:35:25 86 | (nat '(1973 1 18 3 45 50)) ;1/18/73, 3:45:50 87 | (days hours minutes seconds 88 | (multiple-value-call #'delta-dhms 89 | (values-list nat) 90 | (values-list bree)))) 91 | (is (eql days 3071) 92 | (eql hours 0) 93 | (eql minutes 49) 94 | (eql seconds 35)))) 95 | 96 | (test days-in-year 97 | (is (eql 31 (days-in-year 1998 1))) 98 | (is (eql 59 (days-in-year 1998 2))) 99 | (is (eql 90 (days-in-year 1998 3)))) 100 | 101 | (test days-in-month 102 | (is (eql 31 (days-in-month 1998 1))) 103 | (is (eql 28 (days-in-month 1998 2))) 104 | (is (eql 29 (days-in-month 2000 2))) 105 | (is (eql 31 (days-in-month 1998 3)))) 106 | 107 | (test leap-year-p 108 | (is-true (leap-year-p 2000)) 109 | (is-false (leap-year-p 2001))) 110 | 111 | (test date-to-days 112 | (is (eql 1 (date-to-days 1 1 1))) 113 | (is (eql 365 (date-to-days 1 12 31))) 114 | (is (eql 366 (date-to-days 2 1 1))) 115 | (is (eql 729510 (date-to-days 1998 5 1)))) 116 | 117 | (test week-of-year 118 | (multiple-value-bind (week year) 119 | (week-of-year 2002 12 31) 120 | (is (eql year 2003)) 121 | (is (eql week 1)))) 122 | 123 | (test check-date 124 | (is-false 125 | (check-date 2000 13 1))) 126 | 127 | (test invert-delta-dhms 128 | "Test that add-delta-dhms is the inverse of delta-dhms." 129 | (for-all ((date1 (gen-ymd)) 130 | (time1 (gen-hms)) 131 | (date2 (gen-ymd)) 132 | (time2 (gen-hms))) 133 | (is (equal 134 | (append date2 time2) 135 | (multiple-value-list 136 | (apply #'add-delta-dhms 137 | `(,@date1 138 | ,@time1 139 | ,@(multiple-value-list 140 | (apply #'delta-dhms 141 | `(,@date1 ,@time1 ,@date2 ,@time2)))))))) 142 | (is (equal 143 | (append date1 time1) 144 | (multiple-value-list 145 | (apply #'add-delta-dhms 146 | `(,@date2 147 | ,@time2 148 | ,@(mapcar #'- 149 | (multiple-value-list 150 | (apply #'delta-dhms 151 | `(,@date1 ,@time1 ,@date2 ,@time2))))))))) 152 | (let ((delta 153 | (multiple-value-list 154 | (apply #'delta-dhms 155 | `(,@date1 ,@time1 ,@date2 ,@time2))))) 156 | (is (equal 157 | delta 158 | (multiple-value-list 159 | (apply #'delta-dhms 160 | `(,@date1 ,@time1 161 | ,@(multiple-value-list 162 | (apply #'add-delta-dhms 163 | `(,@date1 164 | ,@time1 165 | ,@delta))))))))))) 166 | 167 | (test delta-ymd 168 | "Test the \"one-by-one\" semantics of delta-ymd." 169 | (for-all ((date1 (gen-ymd)) 170 | (date2 (gen-ymd))) 171 | (let* ((result 172 | (multiple-value-list 173 | (apply #'delta-ymd (append date1 date2)))) 174 | (neg-result 175 | (mapcar #'- result))) 176 | (is (equal date2 (mapcar #'+ date1 result))) 177 | (is (equal date1 (mapcar #'+ date2 neg-result)))))) 178 | 179 | (test delta-ymdhms 180 | "Test the \"one-by-one\" semantics of delta-ymdhms." 181 | (flet ((normalize (pt) 182 | (append (firstn 2 pt) 183 | (multiple-value-list 184 | (apply #'normalize-dhms (cddr pt)))))) 185 | (for-all ((date1 (gen-ymd)) 186 | (date2 (gen-ymd)) 187 | (time1 (gen-hms)) 188 | (time2 (gen-hms))) 189 | (let* ((pt1 (append date1 time1)) 190 | (pt2 (append date2 time2)) 191 | (result 192 | (multiple-value-list 193 | (apply #'delta-ymdhms 194 | (append pt1 pt2)))) 195 | (neg-result 196 | (mapcar #'- result))) 197 | (is (equal pt2 (normalize (mapcar #'+ pt1 result)))) 198 | (is (equal pt1 (normalize (mapcar #'+ pt2 neg-result)))))))) 199 | 200 | (test canonical 201 | (for-all ((date (gen-ymd))) 202 | (let ((canonical (apply #'date-to-days date))) 203 | (is (equal date 204 | (multiple-value-list 205 | (add-delta-days 1 1 1 (1- canonical)))))))) 206 | 207 | (test invert-delta-days 208 | "Test the add-delta-days is the inverse of delta-days." 209 | (for-all ((date1 (gen-ymd)) 210 | (date2 (gen-ymd))) 211 | (is (equal 212 | date2 213 | (multiple-value-list 214 | (apply #'add-delta-days 215 | `(,@date1 216 | ,(apply #'delta-days 217 | `(,@date1 ,@date2))))))) 218 | (is (equal 219 | date1 220 | (multiple-value-list 221 | (apply #'add-delta-days 222 | `(,@date2 223 | ,(- (apply #'delta-days 224 | `(,@date1 ,@date2)))))))) 225 | (let ((delta 226 | (apply #'delta-days 227 | `(,@date1 ,@date2)))) 228 | (is (eql delta 229 | (apply #'delta-days 230 | `(,@date1 231 | ,@(multiple-value-list 232 | (apply #'add-delta-days 233 | `(,@date1 ,delta)))))))))) 234 | 235 | (test add-delta-dhms 236 | (for-all ((date (gen-ymd)) 237 | (time (gen-hms)) 238 | (offsets 239 | (fbind ((gen (gen-integer :min -100 :max 100))) 240 | (lambda () 241 | (loop repeat 4 collect (gen)))))) 242 | (let ((result 243 | (multiple-value-list 244 | (apply #'add-delta-dhms 245 | (append date time offsets))))) 246 | (is (length= 6 result)) 247 | (is (every #'numberp result)) 248 | (is (equal 249 | (append date time) 250 | (multiple-value-list 251 | (apply #'add-delta-dhms 252 | (append result 253 | (mapcar #'- offsets))))))))) 254 | -------------------------------------------------------------------------------- /date-calc.lisp: -------------------------------------------------------------------------------- 1 | ;;; Package: date-calc.lisp 2 | ;;; Heiko Schroeter, May 2006 3 | ;;; 4 | ;;; Ver 0.3 ALPHA 5 | ;;; License: GNU, Version 2, June 1991 6 | ;;; 7 | ;;; Legal issues: 8 | ;;; ------------- 9 | ;;; This package with all its parts is 10 | ;;; Copyright (c) 2005 by Heiko Schroeter. 11 | 12 | ;;; This package is free software; you can use, modify and redistribute 13 | ;;; under the "GNU General Public License" and the "Artistic License". 14 | 15 | ;;; This package is intended as a date-calc module for "everyday" purposes. It is not intended 16 | ;;; , nor claims to be, 17 | ;;; a bullet proofed implementation of 'scientific' datum calculus. 18 | 19 | ;;; Parts taken from DateCalc.el (EMACS, Doug Alcorn, , Ver. 0.1, 2003) 20 | ;;; and the 21 | ;;; Perl Package "Date::Calc" Version 5.4,Copyright (c) 1995 - 2004 by Steffen Beyer. 22 | 23 | ;;; Some Documentation strings are only slightly edited from DateCalc.el 24 | 25 | ;;; THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR 26 | ;;; IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 27 | ;;; WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 28 | 29 | ;;; The following routines are a sidestep for CL Day Of Week (DOW) conformance. 30 | ;;; (See Hyperspec 25.1.4.1 X3J13). 31 | ;;; "An integer between 0 and 6, inclusive; 0 means Monday, 1 means Tuesday, and so on; 6 means Sunday." 32 | ;;; PERLs Date::Calc module range is from 1(Monday) to 7(Sunday). 33 | 34 | 35 | ;;; CL conform ,Perl' Conform 36 | ;;; ---------- -------------- 37 | ;;; cl-day-of-week day-of-week 38 | ;;; cl-weeks-in-year weeks-in-year 39 | ;;; cl-check-business-p check-business-p 40 | ;;; cl-nth-weekday-of-month-year nth-weekday-of-month-year 41 | ;;; cl-standard-to-business standard-to-business 42 | ;;; cl-business-to-standard business-to-standard 43 | ;;; cl-system-clock system-clock 44 | ;;; cl-decode-day-of-week decode-day-of-week 45 | 46 | ;;; Pls report bugs to schroete @ iup physik uni-bremen de 47 | 48 | 49 | ;;; May 2nd, 2006 Not critical Typo corrected (Thanks to Claus Brunzema): 50 | ;;; Orig: (defparameter eopoc (+ year-of-epoc century-of-epoc) "reference year (epoc)") 51 | ;;; Corrected: (defparameter epoc (+ year-of-epoc century-of-epoc) "reference year (epoc)") 52 | 53 | (in-package #:cl-user) 54 | 55 | (defpackage #:date-calc 56 | (:use #:cl) 57 | (:export #:*language* 58 | #:decode-day-of-week 59 | #:cl-decode-day-of-week 60 | #:decode-month 61 | #:decode-language 62 | #:iso-lc 63 | #:iso-uc 64 | #:year-to-days 65 | #:fixed-window 66 | #:center 67 | #:valid-year-p 68 | #:valid-month-p 69 | #:leap-year 70 | #:leap-year-p 71 | #:days-in-month 72 | #:days-in-year 73 | #:check-date 74 | #:check-business-p 75 | #:check-time-p 76 | #:day-of-year 77 | #:date-to-days 78 | #:day-of-week 79 | #:weeks-in-year 80 | #:delta-days 81 | #:week-number 82 | #:week-of-year 83 | #:add-delta-days 84 | #:monday-of-week 85 | #:nth-weekday-of-month-year 86 | #:standard-to-business 87 | #:business-to-standard 88 | #:delta-hms 89 | #:delta-dhms 90 | #:delta-ymd 91 | #:delta-ymdhms 92 | #:normalize-dhms 93 | #:add-delta-dhms 94 | #:add-year-month 95 | #:add-delta-ym 96 | #:add-delta-ymd 97 | #:add-delta-ymdhms 98 | #:system-clock 99 | #:cl-system-clock 100 | #:gmtime 101 | #:localtime 102 | #:today 103 | #:yesterday 104 | #:tomorrow 105 | #:now 106 | #:today-and-now 107 | #:this-year 108 | #:date-to-text 109 | #:date-to-text-long 110 | #:cl-day-of-week 111 | #:cl-weeks-in-year 112 | #:cl-check-business-p 113 | #:cl-nth-weekday-of-month-year 114 | #:cl-standard-to-business 115 | #:cl-business-to-standard)) 116 | 117 | (in-package #:date-calc) 118 | 119 | ;;;; Parameters 120 | (defparameter year-of-epoc 70 "Year of reference (epoc)") 121 | (defparameter century-of-epoc 1900 "Century of reference (epoc)") 122 | (defparameter epoc (+ year-of-epoc century-of-epoc) "reference year (epoc)") 123 | 124 | (defparameter days-in-year-arr (make-array '(2 13) :initial-contents 125 | '((0 31 59 90 120 151 181 212 243 273 304 334 365) 126 | (0 31 60 91 121 152 182 213 244 274 305 335 366)))) 127 | 128 | (defparameter days-in-month-arr (make-array '(2 13) :initial-contents 129 | '((0 31 28 31 30 31 30 31 31 30 31 30 31) 130 | (0 31 29 31 30 31 30 31 31 30 31 30 31)))) 131 | 132 | (defparameter languages 11) 133 | (defparameter *language* 1) ; Default English 134 | 135 | ;; (defconstant num-of-lingos (1+ languages)) 136 | 137 | (defparameter month-to-text (make-hash-table)) 138 | (setf (gethash 0 month-to-text) 139 | #("???" "???" "???" "???" 140 | "???" "???" "???" "???" 141 | "???" "???" "???" "???" "???")) 142 | ;; English 143 | (setf (gethash 1 month-to-text) 144 | #("???" "January" "February" "March" 145 | "April" "May" "June" "July" "August" 146 | "September" "October" "November" "December")) 147 | ;; Français 148 | (setf (gethash 2 month-to-text) 149 | #("???" "janvier" "février" "mars" 150 | "avril" "mai" "juin" "juillet" "aout" 151 | "septembre" "octobre" "novembre" "décembre")) 152 | ;;; Deutsch 153 | (setf (gethash 3 month-to-text) 154 | #("???" "Januar" "Februar" "März" 155 | "April" "Mai" "Juni" "Juli" "August" 156 | "September" "Oktober" "November" "Dezember")) 157 | ;;; Español 158 | (setf (gethash 4 month-to-text) 159 | #("???" "enero" "febrero" "marzo" 160 | "abril" "mayo" "junio" "julio" "agosto" 161 | "septiembre" "octubre" "noviembre" "diciembre")) 162 | ;;; Português 163 | (setf (gethash 5 month-to-text) 164 | #("???" "janeiro" "fevereiro" "março" 165 | "abril" "maio" "junho" "julho" "agosto" 166 | "setembro" "outubro" "novembro" "dezembro")) 167 | ;;; Dansk 168 | (setf (gethash 6 month-to-text) 169 | #("???" "januari" "februari" "maart" 170 | "april" "mei" "juni" "juli" "augustus" 171 | "september" "october" "november" "december")) 172 | ;;; Italiano 173 | (setf (gethash 7 month-to-text) 174 | #("???" "Gennaio" "Febbraio" "Marzo" 175 | "Aprile" "Maggio" "Giugno" "Luglio" "Agosto" 176 | "Settembre" "Ottobre" "Novembre" "Dicembre")) 177 | ;;; Norsk 178 | (setf (gethash 8 month-to-text) 179 | #("???" "januar" "februar" "mars" 180 | "april" "mai" "juni" "juli" "august" 181 | "september" "oktober" "november" "desember")) 182 | ;;; Svenska 183 | (setf (gethash 9 month-to-text) 184 | #("???" "januari" "februari" "mars" 185 | "april" "maj" "juni" "juli" "augusti" 186 | "september" "oktober" "november" "december")) 187 | ;;; Dansk 188 | (setf (gethash 10 month-to-text) 189 | #("???" "januar" "februar" "marts" 190 | "april" "maj" "juni" "juli" "august" 191 | "september" "oktober" "november" "december")) 192 | ;;; suomi 193 | (setf (gethash 11 month-to-text) 194 | #("???" "tammikuu" "helmikuu" "maaliskuu" 195 | "huhtikuu" "toukokuu" "kesäkuu" "heinäkuu" 196 | "elokuu" "syyskuu" "lokakuu" "marraskuu" "joulukuu")) 197 | ;;; Magyar 198 | (setf (gethash 12 month-to-text) 199 | #("???" "Január" "Február" "Március" "Április" "Május" "Június" 200 | "Július" "Augusztus" "Szeptember" "Október" "November" "December")) 201 | ;;; polski 202 | (setf (gethash 13 month-to-text) 203 | #("???" "Styczeń" "Luty" "Marzec" "Kwiecień" "Maj" "Czerwiec" 204 | "Lipiec" "Sierpień" "Wrzesień" "Październik" "Listopad" "Grudzień")) 205 | ;;; Romaneste 206 | (setf (gethash 14 month-to-text) 207 | #("???" "Ianuarie" "Februarie" "Martie" "Aprilie" "Mai" "Iunie" 208 | "Iulie" "August" "Septembrie" "Octombrie" "Noiembrie" "Decembrie")) 209 | 210 | (defun day-of-week-to-text (n) 211 | (declare (optimize speed)) 212 | (svref 213 | #(#("???" "???" "???" "???" "???" "???" "???" "???") 214 | ;; English 215 | #("???" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") 216 | ;; Français 217 | #("???" "Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche") 218 | ;; Deutsch 219 | #("???" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") 220 | ;; Español 221 | #("???" "Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") 222 | ;; Português 223 | #("???" "Segunda-feira" "Terca-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sábado" "Domingo") 224 | ;; Dansk 225 | #("???" "Maandag" "Dinsdag" "Woensdag" "Donderdag" "Vrijdag" "Zaterdag" "Zondag") 226 | ;; Italiano 227 | #("???" "Lunedì" "Martedì" "Mercoledì" "Giovedì" "Venerdì" "Sabato" "Domenica") 228 | ;; Norsk 229 | #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag" "søndag") 230 | ;; Svenska 231 | #("???" "måndag" "tisdag" "onsdag" "torsdag" "fredag" "lördag" "söndag") 232 | ;; Dansk 233 | #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag" "søndag") 234 | ;; suomi 235 | #("???" "maanantai" "tiistai" "keskiviikko" "torstai" "perjantai" "lauantai" "sunnuntai") 236 | ;; Magyar 237 | #("???" "hétfõ" "kedd" "szerda" "csütörtök" "péntek" "szombat" "vasárnap") 238 | ;; polska 239 | #("???" "poniedziałek" "wtorek" "środa" "czwartek" "piątek" "sobota" "niedziela") 240 | ;; Romaneste 241 | #("???" "Luni" "Marţi" "Miercuri" "Joi" "Vineri" "Sâmbătă" "Duminică")) 242 | n)) 243 | 244 | (defparameter day-of-week-abbreviation (make-hash-table)) 245 | (setf (gethash 0 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 246 | (setf (gethash 1 day-of-week-abbreviation) #("??" "Mon" "Tue" "Wen" "Thu" "Fri" "Sat" "Sun")) 247 | (setf (gethash 2 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 248 | (setf (gethash 3 day-of-week-abbreviation) #("??" "Mo" "Di" "Mi" "Do" "Fr" "Sa" "So")) 249 | (setf (gethash 4 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 250 | (setf (gethash 5 day-of-week-abbreviation) #("???" "2" "3" "4" "5" "6" "Sam" "Dom")) 251 | (setf (gethash 6 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 252 | (setf (gethash 7 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 253 | (setf (gethash 8 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 254 | (setf (gethash 9 day-of-week-abbreviation) #("??" "Mo" "Ti" "On" "To" "Fr" "Lo" "So")) 255 | (setf (gethash 10 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 256 | (setf (gethash 11 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 257 | (setf (gethash 12 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 258 | (setf (gethash 13 day-of-week-abbreviation) #("???" "Pn" "Wt" "Śr" "Cz" "Pt" "So" "Ni")) 259 | (setf (gethash 14 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) 260 | 261 | (defparameter long-format 262 | (make-array '(15) :initial-contents 263 | '(("~A, ~A ~A ~A" :mdy) ; 0 Default, the second value describes order: 264 | ("~A, ~A ~A ~A" :mdy) ; 1 English see #'date-to-text-long 265 | ("~A ~A ~A ~A" :mdy) ; 2 Français 266 | ("~A, den ~A ~A ~A" :dmy) ; 3 Deutsch 267 | ("~A, ~A de ~A de ~A" :mdy) ; 4 Español 268 | ("~A, dia ~A de ~A de ~A" :mdy) ; 5 Portugues 269 | ("~A, ~A ~A ~A" :mdy) ; 6 Nederlands 270 | ("~A, ~A ~A ~A" :mdy) ; 7 Italiano 271 | ("~A, ~A. ~A ~A" :mdy) ; 8 Norsk 272 | ("~A, ~A ~A ~A" :mdy) ; 9 Svenska 273 | ("~A, ~A. ~A ~A" :mdy) ; 10 Dansk 274 | ("~A, ~A. ~Ata ~A" :mdy) ; 11 suomi 275 | ("~A. ~A ~A., ~A" :ymd) ;12 Magyar 276 | ("~A, ~A ~A ~A" :mdy) ;13 polski 277 | ("~A ~A ~A ~A" :mdy) ;14 Romaneste 278 | ))) 279 | 280 | (defparameter language-to-text 281 | (vector "???" "English" "Français" "Deutsch" "Español" 282 | "Português" "Nederlands" "Italiano" "Norsk" 283 | "Svenska" "Dansk" "suomi" "Magyar" "polski" "Romaneste")) 284 | 285 | ;;;; Functions 286 | (defun decode-day-of-week (str) 287 | "Returns number of weekday. STR can partially name the Weekday. DOW is not CL conform." 288 | (let ((week-vector (day-of-week-to-text *language*)) 289 | (i 0)) 290 | (loop for weekday across week-vector 291 | until (search str weekday :test #'char-equal) 292 | do (incf i) 293 | finally (return (if (<= i 7) i nil))))) 294 | 295 | (defun cl-decode-day-of-week (str) 296 | "Returns number of weekday. STR can partially name the Weekday. DOW is CL conform." 297 | (let ((week-vector (day-of-week-to-text *language*)) 298 | (i 0)) 299 | (loop for weekday across week-vector 300 | until (search str weekday :test #'char-equal) 301 | do (incf i) 302 | finally (return (if (<= i 7) (1- i) nil))))) 303 | 304 | (defun decode-month (str) 305 | "Returns number of month. STR can partially name the month. Computes a (search ...:test #'char-equal)." 306 | (let ((month-vector (gethash *language* month-to-text)) 307 | (i 0)) 308 | (loop for month across month-vector 309 | until (search str month :test #'char-equal) 310 | do (incf i) 311 | finally (return (if (<= i 12) i nil))))) 312 | 313 | (defun decode-language (num) 314 | "Returns the Language of number NUM." 315 | (svref language-to-text num)) 316 | 317 | (defun iso-lc (char) 318 | "Returns lower case CHAR." 319 | (char-downcase char)) 320 | 321 | (defun iso-uc (char) 322 | "Returns upper case CHAR." 323 | (char-upcase char)) 324 | 325 | (defun year-to-days (year) 326 | "Returns the number of days for YEAR since 1 Jan 1." 327 | (+ (- (+ (* year 365) (ash year -2)) 328 | (floor (/ (ash year -2) 25))) 329 | (ash (floor (/ (ash year -2) 25)) -2))) 330 | 331 | (defun fixed-window (year) 332 | "Convert two digit YEAR to four digit YEAR; YEAR<=70 -> 2000+YEAR; YEAR<100&&>70 -> 1900+YEAR." 333 | (if (and (> year 70) (< year 100)) 334 | (+ 1900 year) 335 | (+ 2000 year))) 336 | 337 | (defun center (string width) 338 | "Return a string that is WIDTH long with STRING centered in it." 339 | (let* ((pad (- width (length string))) 340 | (lpad (truncate pad 2)) 341 | (rpad (- pad (truncate pad 2)))) 342 | (if (<= pad 0) 343 | string 344 | (concatenate 'string (make-string lpad :initial-element #\Space) string (make-string rpad :initial-element #\Space))))) 345 | 346 | (defun normalize-time (dd dh dm ds) 347 | "Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS)." 348 | (values (+ dd (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24)) ; dd 349 | (- (+ dh (floor (+ dm (floor ds 60)) 60)) 350 | (* (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24) 24)) ; dh 351 | (- (+ dm (floor ds 60)) (* (floor (+ dm (floor ds 60)) 60) 60)) ;dm 352 | (- ds (* (floor ds 60) 60)))) ;ds 353 | 354 | (defun normalize-ranges (dd dh dm ds) 355 | "Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS). This function prevents overflow errors on systems with short longs (e.g. 32-bits) (If need be for CL ???)." 356 | (normalize-time (+ dd (floor dh 24)) 357 | (+ (- dh (* (floor dh 24) 24)) (floor dm 60)) 358 | (- dm (* (floor dm 60) 60)) 359 | ds)) 360 | 361 | (defun normalize-signs (dd dh dm ds) 362 | "Internal fn for normalize-dhms." 363 | (let* ((quot (floor ds 86400)) 364 | (ds1 (- ds (* quot 86400))) 365 | (dd1 (+ dd quot))) 366 | (setq dh 0 dm 0) 367 | (if (not (= dd1 0)) 368 | (if (> dd1 0) 369 | (when (< ds 0) 370 | (setq ds1 (+ ds 86400) 371 | dd1 (1- dd1))) 372 | (when (> ds 0) 373 | (setq ds1 (- ds 86400) 374 | dd1 (1+ dd1))))) 375 | (if (not (= ds1 0)) 376 | (normalize-time dd1 dh dm ds1) 377 | (values dd1 dh dm ds1)))) 378 | 379 | (defun valid-year-p (year) (>= year 1)) 380 | (defun valid-month-p (month) (and month (>= month 1) (<= month 12))) 381 | 382 | (defun leap-year (year) 383 | "This function returns 1 if the given YEAR is a leap year and 0 otherwise." 384 | (if (or (and (zerop (mod year 4)) 385 | (not (zerop (mod year 100)))) 386 | (zerop (mod year 400))) 387 | 1 388 | 0)) 389 | 390 | (defun leap-year-p (year) 391 | "This function returns t if the given YEAR is a leap year and nil otherwise." 392 | (if (or (and (zerop (mod year 4)) 393 | (not (zerop (mod year 100)))) 394 | (zerop (mod year 400))) 395 | t 396 | nil)) 397 | 398 | (defun days-in-month (year month) 399 | "This function returns the number of days in the given MONTH of the given YEAR." 400 | (if (and (valid-year-p year) 401 | (valid-month-p month)) 402 | (aref days-in-month-arr (leap-year year) month))) 403 | 404 | (defun days-in-year (year &optional month) 405 | "This function returns the number of days in the given YEAR and optional MONTH. If MONTH is [1..12], return the number of days in that YEAR as of the last of that MONTH." 406 | (aref days-in-year-arr (leap-year year) (if (and month (>= month 0) (<= month 12)) 407 | month 408 | 12))) 409 | 410 | (defun check-date (year month day) 411 | "This function returns t if the given three numerical values YEAR MONTH DAY constitute a valid date, and nil otherwise." 412 | (and (valid-year-p year) 413 | (valid-month-p month) 414 | (>= day 1) 415 | (<= day (days-in-month year month)))) 416 | 417 | (defun check-time-p (hour min sec) 418 | "This function returns t if the given three numerical values HOUR MIN SEC constitute a valid time, and nil otherwise." 419 | (and (>= hour 0) (< hour 24) 420 | (>= min 0) (< min 60) 421 | (>= sec 0) (< sec 60))) 422 | 423 | (defun day-of-year (year month day) 424 | "This function returns the sum of the number of days in the months starting with January up to and including MONTH in 425 | the given year YEAR. 0 on failure." 426 | (if (check-date year month day) 427 | (+ day (aref days-in-year-arr (leap-year year) (1- month))) 428 | 0)) 429 | 430 | (defun date-to-days (year month day) 431 | "This function returns the (absolute) number of the day of the given date, where counting starts at the 1.Jan 1." 432 | (if (check-date year month day) 433 | (+ (year-to-days (1- year)) 434 | (day-of-year year month day)) 435 | 0)) 436 | 437 | (defun day-of-week (year month day) 438 | "This function returns the DOW of YEAR MONTH DAY. DOW not CL conform." 439 | (let ((days (date-to-days year month day))) 440 | (if (> days 0) 441 | (1+ (mod (1- days) 7)) 442 | days))) 443 | 444 | (defun cl-day-of-week (year month day) 445 | "This function returns the DOW of YEAR MONTH DAY. DOW CL conform." 446 | (let ((days (date-to-days year month day))) 447 | (if (> days 0) 448 | (mod (1- days) 7) 449 | days))) 450 | 451 | (defun weeks-in-year (year) 452 | "This function returns the number of weeks in the given YEAR, i.e., either 52 or 53." 453 | (if (or (= 4 (day-of-week year 1 1)) 454 | (= 4 (day-of-week year 12 31))) 455 | 53 52)) 456 | 457 | (defun cl-weeks-in-year (year) 458 | "This function returns the number of weeks in the given YEAR for CL DOW conform numbering (Monday=0)., i.e., either 52 or 53." 459 | (if (or (= 3 (cl-day-of-week year 1 1)) 460 | (= 3 (cl-day-of-week year 12 31))) 461 | 53 52)) 462 | 463 | (defun check-business-p (year week dow) 464 | "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format, and nil otherwise. Beware that this function does NOT compute whether a given date is a business day (i.e., Monday to Friday)! To do so, use (< (day-of-week year month day) 6) instead. DOW not CL conform." 465 | (and (>= year 1) 466 | (>= week 1) 467 | (<= week (weeks-in-year year)) 468 | (>= dow 1) 469 | (<= dow 7))) 470 | 471 | (defun cl-check-business-p (year week dow) 472 | "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format for CL (Monday=0), and nil otherwise. DOW is CL conform." 473 | (and (>= year 1) 474 | (>= week 1) 475 | (<= week (weeks-in-year year)) 476 | (>= dow 0) 477 | (<= dow 6))) 478 | 479 | (defun delta-days (year1 month1 day1 year2 month2 day2) 480 | "This function returns the difference in days between Y1 M1 D1 and Y2 M2 D2." 481 | (- (date-to-days year2 month2 day2) 482 | (date-to-days year1 month1 day1))) 483 | 484 | (defun week-number (year month day) 485 | "This function returns the number of the week of the given Y M D lies in. If the given date lies in the LAST week of the PREVIOUS year, 0 is returned." 486 | (let ((first-jan (1- (day-of-week year 1 1)))) 487 | (if (< first-jan 4) 488 | (1+ (truncate (+ first-jan (delta-days year 1 1 year month day)) 7)) 489 | (+ 0 (truncate (+ first-jan (delta-days year 1 1 year month day)) 7))))) ; + 0..-> only return one value 490 | 491 | (defun week-of-year (year month day) 492 | "Return (values week year) where week is the week number of YEAR" 493 | (if (not (check-date year month day)) 494 | nil 495 | (progn 496 | (let ((week (week-number year month day))) 497 | (if (= week 0) 498 | (values (weeks-in-year (1- year)) year) 499 | (progn 500 | (if (> week (weeks-in-year year)) 501 | (values 1 (1+ year)) 502 | (values week year)))))))) 503 | 504 | (defun add-delta-days (year month day delta) 505 | "This function returns (values year month day) such that it is YEAR MONTH DAY plus DELTA days" 506 | ;; Be careful when changing things in this fn ! Side effects ! 507 | ;; Fairly direct port from the PERL routine. Pretty imperative style. 508 | (let* ((days (+ (date-to-days year month day) delta)) 509 | (y1 (round (/ days 365.2425))) 510 | (d1 (- days (year-to-days y1)))) 511 | (when (> days 0) 512 | (progn 513 | (if (< d1 1) 514 | (setf d1 (- days (year-to-days (1- y1)))) ; then 515 | (setf y1 (1+ y1))) ; else 516 | (if (> d1 (days-in-year y1)) 517 | (setf d1 (- d1 (days-in-year y1)) 518 | y1 (1+ y1))) 519 | (loop for index downfrom 12 to 1 520 | until (> d1 (days-in-year y1 index)) 521 | finally (return (values y1 (1+ index) (- d1 (days-in-year y1 index))))))))) ; index=month just one to low here after until, thats why (1+ index) as return value 522 | 523 | (defun monday-of-week (week year) 524 | "Return (values year month day) where month and day correspond to the Monday of WEEK in YEAR" 525 | (let ((erst (1- (day-of-week year 1 1)))) 526 | (if (< erst 4) 527 | (add-delta-days year 1 1 (- (* (1- week) 7) erst)) 528 | (add-delta-days year 1 1 (- (* week 7) erst))))) 529 | 530 | (defun nth-weekday-of-month-year (year month dow n) 531 | "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is not CL conform." 532 | (when (and (check-date year month 1) ; check params 533 | (>= dow 1) (<= dow 7) 534 | (> n 0) (< n 5)) 535 | (let* ((erst (day-of-week year month 1)) 536 | (tow (if (< dow erst) 537 | (+ dow 7) 538 | dow))) 539 | (multiple-value-bind (y m d) 540 | (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7))) 541 | (when (= month m) 542 | (values y m d)))))) 543 | 544 | (defun cl-nth-weekday-of-month-year (year month dow n) 545 | "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is CL conform." 546 | (when (and (check-date year month 1) ; check params 547 | (>= dow 0) (<= dow 6) 548 | (> n 0) (< n 5)) 549 | (let* ((erst (cl-day-of-week year month 1)) 550 | (tow (if (< dow erst) 551 | (+ dow 7) 552 | dow))) 553 | (multiple-value-bind (y m d) 554 | (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7))) 555 | (when (= month m) 556 | (values y m d)))))) 557 | 558 | (defun standard-to-business (year month day) 559 | "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week dow. DOW is not CL conform." 560 | (multiple-value-bind (week y) (week-of-year year month day) 561 | (when week 562 | (values y week (day-of-week year month day))))) 563 | 564 | (defun cl-standard-to-business (year month day) 565 | "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week day of week. DOW is CL conform." 566 | (multiple-value-bind (week y) (week-of-year year month day) 567 | (when week 568 | (values y week (cl-day-of-week year month day))))) 569 | 570 | 571 | (defun business-to-standard (year week dow) 572 | "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is not CL conform." 573 | (when (check-business-p year week dow) 574 | (let* ((erst (day-of-week year 1 1)) 575 | (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0))))))) 576 | (add-delta-days year 1 1 delta)))) 577 | 578 | (defun cl-business-to-standard (year week dow) 579 | "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is CL conform." 580 | (when (cl-check-business-p year week dow) 581 | (let* ((erst (cl-day-of-week year 1 1)) 582 | (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0))))))) 583 | (add-delta-days year 1 1 delta)))) 584 | 585 | (defun delta-hms (hour1 min1 sec1 hour2 min2 sec2) 586 | "This function returns the difference of H1 M1 S1 and H2 M2 S2 in (values d h m s)." 587 | (when (and (check-time-p hour1 min1 sec1) 588 | (check-time-p hour2 min2 sec2)) 589 | (normalize-signs 0 0 0 (- (+ sec2 (* 60 (+ min2 (* 60 hour2)))) 590 | (+ sec1 (* 60 (+ min1 (* 60 hour1)))))))) 591 | 592 | (defun delta-dhms (year1 month1 day1 hour1 min1 sec1 year2 month2 day2 hour2 min2 sec2) 593 | "Returns the difference in (values d h m s) between the two given dates with times (Y1 M1 D1 H1 MIN1 SEC1 and Y2 M2 D2 H2 MIN2 SEC2)." 594 | (let ((dd (delta-days year1 month1 day1 year2 month2 day2))) 595 | (multiple-value-bind (d h m s) (delta-hms hour1 min1 sec1 hour2 min2 sec2) 596 | (if d 597 | (values (+ d dd) h m s) 598 | (values d h m s))))) 599 | 600 | (defun delta-ymd (year1 month1 day1 year2 month2 day2) 601 | "This function returns the difference (values YEAR MONTH DAYS) between the two dates Y1M1D1 and Y2M2D2." 602 | (if (and (check-date year1 month1 day1) 603 | (check-date year2 month2 day2)) 604 | (values (- year2 year1)(- month2 month1)(- day2 day1)) 605 | nil)) 606 | 607 | (defun delta-ymdhms (year1 month1 day1 hour1 min1 sec1 608 | year2 month2 day2 hour2 min2 sec2) 609 | "This function returns the difference (values YEAR MONTH DAYS HOUR MINUTE SEC) between 610 | the two dates Y1 M1 D1 H1 MI1 S1 and Y2 M2 D2 H2 MI2 S2." 611 | (multiple-value-bind (y m d) (delta-ymd year1 month1 day1 year2 month2 day2) 612 | (when y 613 | (multiple-value-bind (dd hh mm ss) 614 | (delta-hms hour1 min1 sec1 hour2 min2 sec2) 615 | (when dd 616 | (values y m (+ dd d) hh mm ss)))))) 617 | 618 | (defun normalize-dhms (day hour min sec) 619 | "This function takes four arbitrary values for days, hours, minutes and seconds (which may have different signs) and renormalizes them so that the values for hours, minutes and seconds will lie in the ranges [-23..23], [-59..59] and [-59..59], respectively, and so that they have the same sign." 620 | (multiple-value-bind (dd dh dm ds) (normalize-ranges day hour min sec) 621 | (when ds 622 | (normalize-signs dd dm dh (+ ds (* 60 (+ dm (* 60 dh)))))))) 623 | 624 | (defun add-delta-dhms (year month day hour min sec dd dh dm ds) 625 | "This function serves to add a days, hours, minutes and seconds offset to a given date and time (YEAR MONTH DAY HOUR MINUTE SECOND DDAY DHOUR DMINUTE DSECOND), in order to answer questions like \"today and now plus 7 days but minus 5 hours and then plus 30 minutes, what date and time gives that?\". Returns: (values y m d h min sec)" 626 | (when (and (check-date year month day) 627 | (check-time-p hour min sec)) 628 | (multiple-value-bind (d1 h1 m1 s1) (normalize-ranges dd dh dm ds) 629 | (when d1 630 | (let ((s2 (+ s1 (* 60 (+ m1 (* 60 h1))) (+ sec (* 60 (+ min (* 60 hour))))))) 631 | (cond ((= 0 s2) 632 | (multiple-value-bind (yy mm ddd) (add-delta-days year month day d1) 633 | (values yy mm ddd 0 0 0))) 634 | ((< s2 0) 635 | (multiple-value-bind (dd1 ss2) (truncate s2 86400) 636 | (multiple-value-bind (ddd hh mm ss) (normalize-time (+ d1 dd1) 0 0 ss2) 637 | (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd) 638 | (values yy mmm dddd hh mm ss))))) 639 | ((> s2 0) 640 | (multiple-value-bind (ddd hh mm ss) (normalize-time d1 0 0 s2) 641 | (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd) 642 | (values yy mmm dddd hh mm ss)))))))))) 643 | 644 | (defun add-year-month (year month dy dm) 645 | "This function adds DYEAR and DMONTH offset to YEAR and MONTH." 646 | (let ((mt (+ month dm))) 647 | (if (> mt 0) 648 | (multiple-value-bind (jahre monate) (truncate (1- mt) 12) 649 | (values (+ jahre (+ year dy)) (1+ monate))) 650 | (multiple-value-bind (jahre monate) (truncate mt 12) 651 | (values (+ (+ year dy) jahre -1) (+ 12 monate)))))) 652 | 653 | (defun add-delta-ym (year month day dy dm) 654 | "This function adds DYEAR and DMONTH offset to YEAR MONTH DAY." 655 | (when (check-date year month day) 656 | (multiple-value-bind (jahr monat) (add-year-month year month dy dm) 657 | (values jahr monat day)))) 658 | 659 | (defun add-delta-ymd (year month day dy dm dd) 660 | "This function adds DYEAR DMONTH and DDAY offset to YEAR MONTH DAY." 661 | (when (check-date year month day) 662 | (multiple-value-bind (jahr monat tag) (add-delta-ym year month day dy dm) 663 | (when jahr 664 | (add-delta-days jahr monat tag dd))))) 665 | 666 | (defun add-delta-ymdhms (year month day hour min sec dyear dmonth dday dh dm ds) 667 | "This function is the same as add-delta-ymd except that a time offset may be given in addition to the year, month and day offset" 668 | (multiple-value-bind (jahr monat) (add-year-month year month dyear dmonth) 669 | (when jahr 670 | (add-delta-dhms jahr monat 1 hour min sec (+ dday (1- day)) dh dm ds)))) 671 | 672 | (defun system-clock (gmt time) 673 | "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is not CL conform." 674 | (multiple-value-bind (second minute hour day month year dow daylight-p dst) 675 | (decode-universal-time time) 676 | (declare (ignorable daylight-p)) 677 | (let ((doy (day-of-year year month day))) 678 | (if gmt 679 | (multiple-value-bind (jahr monat tag std min sek) 680 | (add-delta-dhms year month day hour minute second 0 0 dst 0) 681 | (values jahr monat tag std min sek doy (1+ dow) dst)) 682 | (values year month day hour minute second doy (1+ dow) dst))))) 683 | 684 | (defun cl-system-clock (gmt time) 685 | "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is CL conform." 686 | (multiple-value-bind (second minute hour day month year dow daylight-p dst) 687 | (decode-universal-time time) 688 | (declare (ignorable daylight-p)) 689 | (let ((doy (day-of-year year month day))) 690 | (if gmt 691 | (multiple-value-bind (jahr monat tag std min sek) 692 | (add-delta-dhms year month day hour minute second 0 0 dst 0) 693 | (values jahr monat tag std min sek doy dow dst)) 694 | (values year month day hour minute second doy dow dst))))) 695 | 696 | ;;;;;;; Add gmt flag 697 | (defun gmtime () 698 | (system-clock t (get-universal-time))) 699 | 700 | (defun localtime () 701 | (system-clock nil (get-universal-time))) 702 | 703 | (defun today () 704 | "This function returns (year month day) for today." 705 | (multiple-value-bind (sec minute hour day month year) (get-decoded-time) 706 | (declare (ignorable sec minute hour)) 707 | (values year month day))) 708 | 709 | (defun yesterday () 710 | (multiple-value-bind (jahr monat tag) (today) 711 | (add-delta-days jahr monat tag -1))) 712 | 713 | (defun tomorrow () 714 | (multiple-value-bind (jahr monat tag) (today) 715 | (add-delta-days jahr monat tag 1))) 716 | 717 | (defun now () 718 | "This function returns (hour minute second) for right now." 719 | (multiple-value-bind (second minute hour) (get-decoded-time) 720 | (values hour minute second))) 721 | 722 | (defun today-and-now () 723 | "This function returns (year month day hour minute second) for the current date and time." 724 | (multiple-value-bind (second minute hour day month year) (get-decoded-time) 725 | (values year month day hour minute second))) 726 | 727 | (defun this-year () 728 | "This function returns the current year in localtime." 729 | (multiple-value-bind (second minute hour day month year) (get-decoded-time) 730 | (declare (ignorable second minute hour day month)) 731 | year)) 732 | 733 | (defun date-to-text (year month day) 734 | "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(SHORT) DAY MONTH YEAR with a little bit of sorting for language." 735 | (let* ((result (aref long-format *language*)) 736 | (prn (first result))) ; get print format 737 | (multiple-value-bind (a b c) ; What order is the date DMY , MDY .... 738 | (let ((k (second result))) 739 | (case k ; return the order of DMY 740 | (:mdy (values month day year)) 741 | (:dmy (values day month year)) 742 | (:ymd (values year month day)) 743 | (otherwise (values month day year)))) ; return english by default 744 | (format nil prn ; make the return string 745 | (svref (gethash *language* day-of-week-abbreviation) ; Get Name of Weekday 746 | (day-of-week year month day)) 747 | a b c)))) 748 | 749 | (defun date-to-text-long (year month day) 750 | "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(LONG) DAY MONTH YEAR with a little bit of sorting for language." 751 | (let* ((result (aref long-format *language*)) 752 | (prn (first result))) ; get print format 753 | (multiple-value-bind (a b c) ; What order is the date DMY , MDY .... 754 | (let ((k (second result))) 755 | (case k ; return the order of DMY 756 | (:mdy (values month day year)) 757 | (:dmy (values day month year)) 758 | (:ymd (values year month day)) 759 | (otherwise (values month day year)))) ; return english by default 760 | (format nil prn ; make the return string 761 | (svref (day-of-week-to-text *language*) ; Get Name of Weekday 762 | (day-of-week year month day)) 763 | a b c)))) 764 | 765 | --------------------------------------------------------------------------------