calendar.lisp (6951B)
1 (defpackage :rw.calendar 2 (:use :cl) 3 (:export)) 4 5 (in-package :rw.calendar) 6 7 (defun iso-date (universal-time) 8 (multiple-value-bind (ss mm hh d m y dd dl z) 9 (decode-universal-time universal-time) 10 (declare (ignore ss mm hh dd dl z)) 11 (format nil "~4,'0d-~2,'0d-~2,'0d" y m d))) 12 13 (defun pretty-month (month) 14 #+nil 15 (ecase month 16 (1 " １月") 17 (2 " ２月") 18 (3 " ３月") 19 (4 " ４月") 20 (5 " ５月") 21 (6 " ６月") 22 (7 " ７月") 23 (8 " ８月") 24 (9 " ９月") 25 (10 "１０月") 26 (11 "１１月") 27 (12 "１２月")) 28 (ecase month 29 (1 "Jan") 30 (2 "Feb") 31 (3 "Mar") 32 (4 "Apr") 33 (5 "May") 34 (6 "Jun") 35 (7 "Jul") 36 (8 "Aug") 37 (9 "Sep") 38 (10 "Oct") 39 (11 "Nov") 40 (12 "Dec"))) 41 42 (defun pretty-day (day) 43 #+nil 44 (ecase day 45 (0 " 月") 46 (1 " 火") 47 (2 " 水") 48 (3 " 木") 49 (4 " 金") 50 (5 " 土") 51 (6 " 日")) 52 (ecase day 53 (0 "Mo") 54 (1 "Tu") 55 (2 "We") 56 (3 "Th") 57 (4 "Fr") 58 (5 "Sa") 59 (6 "Su"))) 60 61 (defun pretty-date (universal-time) 62 (multiple-value-bind (se0 mi0 ho0 da0 mo0 ye0 dow0 dst0 tz0) 63 (decode-universal-time (get-universal-time)) 64 (declare (ignore se0 mi0 ho0 dow0 dst0 tz0)) 65 (multiple-value-bind (se mi ho da mo ye dow dst tz) 66 (decode-universal-time universal-time) 67 (declare (ignore se mi ho dow dst tz)) 68 (if (= ye0 ye) 69 (if (and (= mo0 mo) (= da0 da)) 70 "Today" 71 (format nil "~a ~d" (pretty-month mo) da)) 72 (iso-date universal-time))))) 73 74 (defun easter (year) 75 (let* ((h1 (floor year 100)) 76 (h2 (floor year 400)) 77 (m (- (+ 15 h1) h2 (floor (+ 13 (* 8 h1)) 25))) 78 (n (- (+ 4 h1) h2)) 79 (a (mod year 19)) 80 (b (mod year 4)) 81 (c (mod year 7)) 82 (d (mod (+ (* 19 a) m) 30)) 83 (e (mod (+ (* 2 b) (* 4 c) (* 6 d) n) 7)) 84 (f (+ 22 d e))) 85 (when (= 57 f) 86 (setq f 50)) 87 (when (and (= 28 d) (= 6 e) (< 10 a)) 88 (setq f 49)) 89 (values year 90 (if (<= f 31) 91 3 92 (progn (decf f 31) 4)) 93 f))) 94 95 ;; http://seed7.sourceforge.net/algorith/date.htm 96 (defun leap-year-p (year) 97 (or (and (zerop (mod year 4)) 98 (not (zerop (mod year 100)))) 99 (zerop (mod year 400)))) 100 101 (defun days-in-month (year month) 102 (if (member month '(1 3 5 7 8 10 12)) 103 31 104 (if (= 2 month) 105 (if (leap-year-p year) 29 28) 106 30))) 107 108 (defun day-of-year (year month day) 109 (+ day (svref (if (leap-year-p year) 110 #(0 31 60 91 121 152 182 213 244 274 305 335) 111 #(0 31 59 90 120 151 181 212 243 273 304 334)) 112 (1- month)))) 113 114 (defun day-of-week (year month day) 115 (when (<= month 2) 116 (decf year) 117 (incf month 12)) 118 (1+ (mod (+ year 119 (floor year 4) 120 (- (floor year 100)) 121 (floor year 400) 122 (floor (* 31 (- month 2)) 12) 123 day 124 -1) 125 7))) 126 127 (defun week-of-year (year day-of-year) 128 (1+ (floor (+ day-of-year (day-of-week year 1 4) -5) 7))) 129 130 (defun weekend (day) 131 (member day '(5 6))) 132 133 (defun collect (n stream) 134 (loop 135 for i from 0 below n 136 collect (funcall stream))) 137 138 (defun day-generator (year month first-weekday) 139 (let ((d (- first-weekday (day-of-week year month 1) -1)) 140 (n (days-in-month year month))) 141 (lambda () 142 (when (<= 1 (incf d) n) 143 d)))) 144 145 ;;(collect 40 (day-generator 2012 7 0)) 146 ;;(collect 40 (day-generator 2012 7 6)) 147 148 (defun weekday-generator (first-weekday) 149 (let ((x (nthcdr first-weekday '#1=(6 0 1 2 3 4 5 . #1#)))) 150 (lambda () 151 (car (setq x (cdr x)))))) 152 153 ;;(collect 10 (weekday-generator 0)) 154 ;;(collect 10 (weekday-generator 6)) 155 156 (defun week-generator (year month) 157 (let ((w (week-of-year year (day-of-year year month 1))) 158 (n (1+ (week-of-year year (day-of-year year 12 31))))) 159 (lambda () 160 (when (<= 1 (incf w) n) 161 w)))) 162 163 ;;(collect 15 (week-generator 2012 1)) 164 ;;(collect 15 (week-generator 2012 12)) 165 166 (defvar *weekdays* '((#\M #\o #\n) 167 (#\T #\u #\e) 168 (#\W #\e #\d) 169 (#\T #\h #\u) 170 (#\F #\r #\i) 171 (#\S #\a #\t) 172 (#\S #\u #\n))) 173 174 (defvar *months* '((#\J #\a #\n) 175 (#\F #\e #\b) 176 (#\M #\a #\r) 177 (#\A #\p #\r) 178 (#\M #\a #\y) 179 (#\J #\u #\n) 180 (#\J #\u #\l) 181 (#\A #\u #\g) 182 (#\S #\e #\p) 183 (#\O #\c #\t) 184 (#\N #\o #\v) 185 (#\D #\e #\c))) 186 187 (defun decode-rfc822-time (string) ;; TODO complete spec http://asg.web.cmu.edu/rfc/rfc822.html 188 (let ((r (rw:peek-reader (rw:reader string)))) 189 (values (progn 190 (rw:skip r) 191 (position (rw:till r '(#\,)) *weekdays* :test #'equal)) 192 (progn 193 (assert (eql #\, (rw:next r))) 194 (rw:skip r) 195 (rw:next-z0 r)) 196 (progn 197 (rw:skip r) 198 (1+ (position (rw:till r '(#\space)) *months* :test #'equal))) 199 (progn 200 (rw:skip r) 201 (rw:next-z0 r)) 202 (progn 203 (rw:skip r) 204 (rw:next-z0 r)) 205 (progn 206 (assert (eql #\: (rw:next r))) 207 (rw:next-z0 r)) 208 (progn 209 (assert (eql #\: (rw:next r))) 210 (rw:next-z0 r)) 211 (progn 212 (rw:skip r) 213 (ecase (rw:next r) 214 (#\+ (rw:next-z0 r)) 215 (#\- (- (rw:next-z0 r)))))))) 216 217 ;;(decode-rfc822-time "Tue, 22 Oct 2013 17:57:25 +0200") 218 219 (defun encode-rfc822-time (wd d m y hh mm ss tz) 220 (format nil "~{~a~}, ~2,'0d ~{~a~} ~4,'0d ~2,'0d:~2,'0d:~2,'0d ~a~4,'0d" 221 (nth wd *weekdays*) d (nth (1- m) *months*) y hh mm ss 222 (if (plusp tz) #\+ #\-) (abs tz))) 223 224 ;;(encode-rfc822-time 3 24 10 2013 23 0 3 200) 225 226 (defun rfc822-time-to-universal-time (string) 227 (multiple-value-bind (wd d m y hh mm ss tz) (decode-rfc822-time string) 228 (declare (ignore wd)) 229 (encode-universal-time ss mm hh d m y (/ (- tz) 100)))) 230 231 ;;(decode-universal-time (rfc822-time-to-universal-time "Tue, 22 Oct 2013 17:57:25 +0200")) 232 ;;(decode-universal-time (rfc822-time-to-universal-time "Sun, 27 Oct 2013 17:57:25 +0100")) 233 234 (defun universal-time-to-rfc822-time (x) 235 (multiple-value-bind (ss mm hh d m y wd dst tz) (decode-universal-time x) 236 (encode-rfc822-time wd d m y hh mm ss (* 100 (- (if dst (1- tz) tz)))))) 237 238 ;;(universal-time-to-rfc822-time (rfc822-time-to-universal-time "Tue, 22 Oct 2013 17:57:25 +0200")) 239 ;;(universal-time-to-rfc822-time (rfc822-time-to-universal-time "Sun, 27 Oct 2013 17:57:25 +0100")) 240 ;;(universal-time-to-rfc822-time (get-universal-time)) 241 ;;(decode-universal-time (get-universal-time))