cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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  " 1月")
     17     (2  " 2月")
     18     (3  " 3月")
     19     (4  " 4月")
     20     (5  " 5月")
     21     (6  " 6月")
     22     (7  " 7月")
     23     (8  " 8月")
     24     (9  " 9月")
     25     (10 "10月")
     26     (11 "11月")
     27     (12 "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))