cl-libtai-cvs

Download

cl-libtai-cvs@lists.common-lisp.net

January 2006

1 participants
1 discussions

[cl-libtai-cvs] r1 -
by lvecsey＠common-lisp.net 30 Jan '06

30 Jan '06

Author: lvecsey Date: Mon Jan 30 09:05:38 2006 New Revision: 1 Added: cl-libtai.asd cl-libtai.lisp leapsecs.dat (contents, props changed) test-libtai.lisp Log: Added: cl-libtai.asd ============================================================================== --- (empty file) +++ cl-libtai.asd Mon Jan 30 09:05:38 2006 @@ -0,0 +1,6 @@ +(defsystem "cl-libtai" + :description "TAI - Temps Atomique International; time conversion library" + :version "0.51" + :author "Lester Vecsey" + :licence "LGPL" + :components ((:file "cl-libtai"))) Added: cl-libtai.lisp ============================================================================== --- (empty file) +++ cl-libtai.lisp Mon Jan 30 09:05:38 2006 @@ -0,0 +1,177 @@ +(in-package "COMMON-LISP-USER") + +(defpackage #:cl-libtai + (:use #:common-lisp) + (:export :leapsecs-add :*leapsecs* :*leapsecs-strings* + :tai-unpack + :taia-unpack + :tai-now + :caldate-scan + :caldate-mjd + :caldate-frommjd + :caltime-tai + :caltime-utc + :leapsecs-gen + :leapsecs-add + :leapsecs-sub + :make-caldate + :make-caltime + :make-tai64-internal + :make-tai64na-internal)) + +(in-package "CL-LIBTAI") + +(defvar times365 (list 0 365 730 1095)) +(defvar times36524 (list 0 36524 73048 109572)) +(defvar montab (list 0 31 61 92 122 153 184 214 245 275 306 337)) + +(defun make-tai64-internal(s) + (pairlis '(x) (list s))) + +(defun make-tai64na-internal(s a n) + (pairlis '(sec atto nano) (list s a n))) + +(defun make-caldate(y m d) + (list :year y :month m :day d)) + +(defun make-caltime(cd h m s o) + (pairlis '(date hour minute second offset) (list cd h m s o))) + +; http://maia.usno.navy.mil/leapsec.html +; http://maia.usno.navy.mil/ser7/leapsec.dat + +(defvar *leapsecs-strings* (list +"+1972-06-30" +"+1972-12-31" +"+1973-12-31" +"+1974-12-31" +"+1975-12-31" +"+1976-12-31" +"+1977-12-31" +"+1978-12-31" +"+1979-12-31" +"+1981-06-30" +"+1982-06-30" +"+1983-06-30" +"+1985-06-30" +"+1987-12-31" +"+1989-12-31" +"+1990-12-31" +"+1992-06-30" +"+1993-06-30" +"+1994-06-30" +"+1995-12-31" +"+1997-06-30" +"+1998-12-31" +"+2005-12-31")) + +(defun leapsecs-add(t2 hit leapsecs) + (let ((u (cdr (assoc 'x t2)))) + (loop for a in leapsecs for m = (cdr (assoc 'x a)) + do (if (< u m) (loop-finish) + (if (or (= hit 0) (> u m)) (setf u (1+ u)))) + finally (return (make-tai64-internal u))))) + +(defun leapsecs-sub(t2 leapsecs) + (let ((u (cdr (assoc 'x t2)))) + (loop for a in leapsecs for s = 0 then (1+ s) + do (if (< u (cdr (assoc 'x a))) (return (values (make-tai64-internal (- u s)) 0))) + (if (= u (cdr (assoc 'x a))) (return (values (make-tai64-internal (- u (1+ s))) 1))) + finally (return (values (make-tai64-internal (- u s)) 0))))) + +(defun tai-now() + (make-tai64-internal (+ (- 4611686018427387914 2208988800) (get-universal-time)))) + +(defun tai-pack(tai64i) + (format nil "~x" (cdr (assoc 'x tai64i)))) + +(defun tai-unpack(s) + (make-tai64-internal (parse-integer s :radix 16))) + +(defun taia-pack(tai64nai) + (format nil "~x~x~x" (cdr (assoc 'sec tai64nai)) + (cdr (assoc 'atto tai64nai)) + (cdr (assoc 'nano tai64nai)))) + +(defun taia-unpack(s) + (let ((tai-s (subseq s 0 8)) (atto-s (subseq s 8 12)) (nano-s (subseq s 12 16 ))) + (make-tai64na-internal (parse-integer tai-s :radix 16) + (parse-integer atto-s :radix 16) + (parse-integer nano-s :radix 16)))) + +(defun display-numeric(tai-s atto-s nano-s) + (format t "~a ~a ~a" (parse-integer tai-s :radix 16) + (parse-integer atto-s :radix 16) + (parse-integer nano-s :radix 16))) + +(defun caldate-mjd (cd) + (defun final-yd(y d) + (+ d + (nth (logand #x3 y) times365) + (* 1461 (rem (floor (/ y 4)) 25)) + (nth (logand #x3 (floor (/ y 100))) times36524))) + (defun mjd-ycheck1(year m day) + (let ((y (rem year 400)) (d (+ (* (floor (/ year 400)) 146097) (+ day (+ (nth m montab)))))) + (if (< y 0) (final-yd (+ y 400) (- d 146097)) (final-yd y d)))) + (defun mcheck2(year month d) + (let ((y (+ year (floor (/ month 12)))) (m (rem month 12))) + (if (< m 0) (mjd-ycheck1 (- y 1) (+ m 12) d) (mjd-ycheck1 y m d)))) + (defun mcheck1(y m d) + (if (>= m 2) (mcheck2 y (- m 2) d) (mcheck2 (- y 1) (+ m 10) d))) + (destructuring-bind (&key year month day) cd + (mcheck1 (rem year 400) (- month 1) (+ (* 146097 (floor (/ year 400))) (- day 678882))))) + +(defun caldate-frommjd(day) + (let ((pwday 0)) + (defun daydec(n acc) + (if (>= n 146097) (daydec (- n 146097) (1+ acc)) (values n acc))) + (defun check5(yday y m d) + (values (make-caldate y (+ m 1) (+ d 1)) pwday yday)) + (defun check4(yday year day) + (let ((da (* 10 day))) + (let ((m (floor (/ (+ 5 da) 306))) (d (floor (/ (rem (+ da 5) 306) 10)))) + (if (>= m 10) (check5 (- yday 306) (+ year 1) (- m 10) d) (check5 (+ yday 59) year (+ m 2) d))))) + (defun check3(year day) + (let ((yday (if (< day 306) 1 0))) + (if (eq day 1460) (check4 yday (+ year 3) 365) (check4 yday (+ year (floor (/ day 365))) (rem day 365))))) + (defun check2(year day) + (let ((y (* 4 (+ (floor (/ day 1461)) (* year 25)))) (d (rem day 1461))) + (check3 y d))) + (defun fmjd-ycheck1(year day) + (let ((y (* year 4))) + (if (eq day 146096) (check2 (+ y 3) 36524) (check2 (+ y (floor (/ day 36524))) (rem day 36524))))) + (let ((year (floor (/ day 146097))) (d (+ 678881 (rem day 146097)))) + (multiple-value-bind (newday yeardiff) + (daydec d 0) + (progn (setf pwday (mod (+ 3 newday) 7)) + (fmjd-ycheck1 (+ year yeardiff) newday)))))) + +(defun caldate-normalize(cd) + (caldate-frommjd (caldate-mjd cd))) + +(defun caldate-scan(s) + (let* ((sign (if (eq (char s 0) #\-) -1 1)) (r (string-trim "-+" s)) (p1 (position #\- r)) (p2 (position #\- r :start (1+ p1)))) + (make-caldate (* (parse-integer r :end p1) sign) (parse-integer r :start (1+ p1) :end p2) (parse-integer r :start (1+ p2))))) + +(defun leapsecs-gen(ls) + (loop for a in ls for leaps = 0 then (1+ leaps) + collect (make-tai64-internal (+ leaps (+ 4611686014920671114 (* 86400 (1+ (caldate-mjd (caldate-scan a))))))))) + +(defparameter *leapsecs* (leapsecs-gen *leapsecs-strings*)) + +(defun caltime-tai(ct) + (defun m60p(mul syp) + (+ (cdr (assoc syp ct)) (* 60 mul))) + (defun inner() (m60p (cdr (assoc 'hour ct)) 'minute)) + (defun xval(d) + (+ 4611686014920671114 (* 86400 d) (m60p (- (inner) (cdr (assoc 'offset ct))) 'second))) + (let ((day (caldate-mjd (cdr (assoc 'date ct))))) + (leapsecs-add (make-tai64-internal (xval day)) (if (= 60 (cdr (assoc 'second ct))) 1 0) *leapsecs*))) + +(defun caltime-utc(tai64i) + (multiple-value-bind (tn leap) + (leapsecs-sub tai64i *leapsecs*) + (let ((u (+ 58486 (cdr (assoc 'x tn))))) + (let ((s (rem u 86400))) + (make-caltime (caldate-frommjd (logand #xFFFFFFFF (- (floor (/ u 86400)) 53375995543064))) (floor (/ s 3600)) (rem (floor (/ s 60)) 60) (+ leap (rem s 60)) 0))))) + Added: leapsecs.dat ============================================================================== Binary file. No diff available. Added: test-libtai.lisp ============================================================================== --- (empty file) +++ test-libtai.lisp Mon Jan 30 09:05:38 2006 @@ -0,0 +1,55 @@ +(in-package "COMMON-LISP-USER") + +(defpackage #:cl-test-libtai + (:use #:common-lisp #:cl-libtai)) + +(in-package "CL-TEST-LIBTAI") + +(defvar test-libtai-iit (lisp-implementation-type)) + +(defun report-result (result form) + (format t "~:[FAIL~;pass~] ... ~a~%" result form)) + +(defmacro check (form) + `(report-result ,form ',form)) + +(defmacro check (&body forms) + `(progn + ,@(loop for f in forms collect `(report-result ,f ',f)))) + +(defun test-report() + (format t "lisp-implementation-type: ~a~%" test-libtai-iit)) + +(defun test-leapsecs-add() + (check + (= 4611686019090075928 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075913) 0 *leapsecs*)))) + (= 4611686019090075928 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075913) 1 *leapsecs*)))) + (= 4611686019090075930 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075914) 0 *leapsecs*)))) + (= 4611686019090075929 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075914) 1 *leapsecs*)))) + (= 4611686019090075931 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075915) 0 *leapsecs*)))) + (= 4611686019090075931 (cdr (assoc 'cl-libtai::x (leapsecs-add (make-tai64-internal 4611686019090075915) 1 *leapsecs*)))))) + +(defun test-bench() + (let ((full #x4000000043a72b922e8da9282313e8a8) (full-s "4000000043a72b922e8da9282313e8a8") + (short #x4000000043a72b92) + (short-s "4000000043a72b92")) + (check + (format t "t.x = ~a~%" (cdr (assoc 'x (make-tai64-internal (floor (/ full (expt 2 64))))))) + (tai-unpack short-s) + (taia-unpack full-s) + (caltime-utc (make-tai64-internal short)) + (caltime-utc (tai-now)) + (destructuring-bind (&key year month day) (caldate-scan "+2005-12-26") + (= year 2005) (= month 12) (= day 26)) + (leapsecs-gen (list "+1998-12-31" "+2005-12-31")) + (= 53730 (caldate-mjd (make-caldate 2005 12 26))) + ; MJD 51604 is year 5, day 0. + (destructuring-bind (&key year month day) (caldate-frommjd 51604) + (= year 2000) (= month 3) (= day 1))))) + +(defun test-caltime-tai() + (caltime-tai (make-caltime (make-caldate 2005 12 28) 3 36 10 0))) + +(defun test-libtai() + (progn (test-report) (test-leapsecs-add) (test-bench) (test-caltime-tai))) +

1 0