/[cl-libtai]/cl-libtai/cl-libtai.lisp
ViewVC logotype

Contents of /cl-libtai/cl-libtai.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Thu Dec 29 15:27:09 2005 UTC (8 years, 3 months ago) by lvecsey
Branch: MAIN, main
CVS Tags: version1, HEAD
Changes since 1.1: +0 -0 lines


1 (in-package "COMMON-LISP-USER")
2
3 (defpackage #:cl-libtai
4 (:use #:common-lisp)
5 (:export :leapsecs-add :*leapsecs* :*leapsecs-strings*
6 :tai-unpack
7 :taia-unpack
8 :tai-now
9 :caldate-scan
10 :caldate-mjd
11 :caldate-frommjd
12 :caltime-tai
13 :caltime-utc
14 :leapsecs-gen
15 :leapsecs-add
16 :leapsecs-sub
17 :make-caldate
18 :make-caltime
19 :make-tai64-internal
20 :make-tai64na-internal))
21
22 (in-package "CL-LIBTAI")
23
24 (defvar times365 (list 0 365 730 1095))
25 (defvar times36524 (list 0 36524 73048 109572))
26 (defvar montab (list 0 31 61 92 122 153 184 214 245 275 306 337))
27
28 (defun make-tai64-internal(s)
29 (pairlis '(x) (list s)))
30
31 (defun make-tai64na-internal(s a n)
32 (pairlis '(sec atto nano) (list s a n)))
33
34 (defun make-caldate(y m d)
35 (list :year y :month m :day d))
36
37 (defun make-caltime(cd h m s o)
38 (pairlis '(date hour minute second offset) (list cd h m s o)))
39
40 ; http://maia.usno.navy.mil/leapsec.html
41 ; http://maia.usno.navy.mil/ser7/leapsec.dat
42
43 (defvar *leapsecs-strings* (list
44 "+1972-06-30"
45 "+1972-12-31"
46 "+1973-12-31"
47 "+1974-12-31"
48 "+1975-12-31"
49 "+1976-12-31"
50 "+1977-12-31"
51 "+1978-12-31"
52 "+1979-12-31"
53 "+1981-06-30"
54 "+1982-06-30"
55 "+1983-06-30"
56 "+1985-06-30"
57 "+1987-12-31"
58 "+1989-12-31"
59 "+1990-12-31"
60 "+1992-06-30"
61 "+1993-06-30"
62 "+1994-06-30"
63 "+1995-12-31"
64 "+1997-06-30"
65 "+1998-12-31"
66 "+2005-12-31"))
67
68 (defun leapsecs-add(t2 hit leapsecs)
69 (let ((u (cdr (assoc 'x t2))))
70 (loop for a in leapsecs for m = (cdr (assoc 'x a))
71 do (if (< u m) (loop-finish)
72 (if (or (= hit 0) (> u m)) (setf u (1+ u))))
73 finally (return (make-tai64-internal u)))))
74
75 (defun leapsecs-sub(t2 leapsecs)
76 (let ((u (cdr (assoc 'x t2))))
77 (loop for a in leapsecs for s = 0 then (1+ s)
78 do (if (< u (cdr (assoc 'x a))) (return (values (make-tai64-internal (- u s)) 0)))
79 (if (= u (cdr (assoc 'x a))) (return (values (make-tai64-internal (- u (1+ s))) 1)))
80 finally (return (values (make-tai64-internal (- u s)) 0)))))
81
82 (defun tai-now()
83 (make-tai64-internal (+ (- 4611686018427387914 2208988800) (get-universal-time))))
84
85 (defun tai-pack(tai64i)
86 (format nil "~x" (cdr (assoc 'x tai64i))))
87
88 (defun tai-unpack(s)
89 (make-tai64-internal (parse-integer s :radix 16)))
90
91 (defun taia-pack(tai64nai)
92 (format nil "~x~x~x" (cdr (assoc 'sec tai64nai))
93 (cdr (assoc 'atto tai64nai))
94 (cdr (assoc 'nano tai64nai))))
95
96 (defun taia-unpack(s)
97 (let ((tai-s (subseq s 0 8)) (atto-s (subseq s 8 12)) (nano-s (subseq s 12 16 )))
98 (make-tai64na-internal (parse-integer tai-s :radix 16)
99 (parse-integer atto-s :radix 16)
100 (parse-integer nano-s :radix 16))))
101
102 (defun display-numeric(tai-s atto-s nano-s)
103 (format t "~a ~a ~a" (parse-integer tai-s :radix 16)
104 (parse-integer atto-s :radix 16)
105 (parse-integer nano-s :radix 16)))
106
107 (defun caldate-mjd (cd)
108 (defun final-yd(y d)
109 (+ d
110 (nth (logand #x3 y) times365)
111 (* 1461 (rem (floor (/ y 4)) 25))
112 (nth (logand #x3 (floor (/ y 100))) times36524)))
113 (defun mjd-ycheck1(year m day)
114 (let ((y (rem year 400)) (d (+ (* (floor (/ year 400)) 146097) (+ day (+ (nth m montab))))))
115 (if (< y 0) (final-yd (+ y 400) (- d 146097)) (final-yd y d))))
116 (defun mcheck2(year month d)
117 (let ((y (+ year (floor (/ month 12)))) (m (rem month 12)))
118 (if (< m 0) (mjd-ycheck1 (- y 1) (+ m 12) d) (mjd-ycheck1 y m d))))
119 (defun mcheck1(y m d)
120 (if (>= m 2) (mcheck2 y (- m 2) d) (mcheck2 (- y 1) (+ m 10) d)))
121 (destructuring-bind (&key year month day) cd
122 (mcheck1 (rem year 400) (- month 1) (+ (* 146097 (floor (/ year 400))) (- day 678882)))))
123
124 (defun caldate-frommjd(day)
125 (let ((pwday 0))
126 (defun daydec(n acc)
127 (if (>= n 146097) (daydec (- n 146097) (1+ acc)) (values n acc)))
128 (defun check5(yday y m d)
129 (values (make-caldate y (+ m 1) (+ d 1)) pwday yday))
130 (defun check4(yday year day)
131 (let ((da (* 10 day)))
132 (let ((m (floor (/ (+ 5 da) 306))) (d (floor (/ (rem (+ da 5) 306) 10))))
133 (if (>= m 10) (check5 (- yday 306) (+ year 1) (- m 10) d) (check5 (+ yday 59) year (+ m 2) d)))))
134 (defun check3(year day)
135 (let ((yday (if (< day 306) 1 0)))
136 (if (eq day 1460) (check4 yday (+ year 3) 365) (check4 yday (+ year (floor (/ day 365))) (rem day 365)))))
137 (defun check2(year day)
138 (let ((y (* 4 (+ (floor (/ day 1461)) (* year 25)))) (d (rem day 1461)))
139 (check3 y d)))
140 (defun fmjd-ycheck1(year day)
141 (let ((y (* year 4)))
142 (if (eq day 146096) (check2 (+ y 3) 36524) (check2 (+ y (floor (/ day 36524))) (rem day 36524)))))
143 (let ((year (floor (/ day 146097))) (d (+ 678881 (rem day 146097))))
144 (multiple-value-bind (newday yeardiff)
145 (daydec d 0)
146 (progn (setf pwday (mod (+ 3 newday) 7))
147 (fmjd-ycheck1 (+ year yeardiff) newday))))))
148
149 (defun caldate-normalize(cd)
150 (caldate-frommjd (caldate-mjd cd)))
151
152 (defun caldate-scan(s)
153 (let* ((sign (if (eq (char s 0) #\-) -1 1)) (r (string-trim "-+" s)) (p1 (position #\- r)) (p2 (position #\- r :start (1+ p1))))
154 (make-caldate (* (parse-integer r :end p1) sign) (parse-integer r :start (1+ p1) :end p2) (parse-integer r :start (1+ p2)))))
155
156 (defun leapsecs-gen(ls)
157 (loop for a in ls for leaps = 0 then (1+ leaps)
158 collect (make-tai64-internal (+ leaps (+ 4611686014920671114 (* 86400 (1+ (caldate-mjd (caldate-scan a)))))))))
159
160 (defparameter *leapsecs* (leapsecs-gen *leapsecs-strings*))
161
162 (defun caltime-tai(ct)
163 (defun m60p(mul syp)
164 (+ (cdr (assoc syp ct)) (* 60 mul)))
165 (defun inner() (m60p (cdr (assoc 'hour ct)) 'minute))
166 (defun xval(d)
167 (+ 4611686014920671114 (* 86400 d) (m60p (- (inner) (cdr (assoc 'offset ct))) 'second)))
168 (let ((day (caldate-mjd (cdr (assoc 'date ct)))))
169 (leapsecs-add (make-tai64-internal (xval day)) (if (= 60 (cdr (assoc 'second ct))) 1 0) *leapsecs*)))
170
171 (defun caltime-utc(tai64i)
172 (multiple-value-bind (tn leap)
173 (leapsecs-sub tai64i *leapsecs*)
174 (let ((u (+ 58486 (cdr (assoc 'x tn)))))
175 (let ((s (rem u 86400)))
176 (make-caltime (caldate-frommjd (logand #xFFFFFFFF (- (floor (/ u 86400)) 53375995543064))) (floor (/ s 3600)) (rem (floor (/ s 60)) 60) (+ leap (rem s 60)) 0)))))
177

  ViewVC Help
Powered by ViewVC 1.1.5