From lvecsey at common-lisp.net  Mon Jan 30 15:05:38 2006
From: lvecsey at common-lisp.net (lvecsey at common-lisp.net)
Date: Mon, 30 Jan 2006 09:05:38 -0600 (CST)
Subject: [cl-libtai-cvs] r1 - 
Message-ID: <20060130150538.ACB292A01A@common-lisp.net>

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)))
+