[commit: packages/time] format-widths, ghc, improve-leapseconds, master, posix-perf, tasty, wip/travis: UT1 calendar functions, with test (49c8b0d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/time

On branches: format-widths,ghc,improve-leapseconds,master,posix-perf,tasty,wip/travis
Link       : http://git.haskell.org/packages/time.git/commitdiff/49c8b0dd832c81ebe74516fa479bf131708e4e3b

>---------------------------------------------------------------

commit 49c8b0dd832c81ebe74516fa479bf131708e4e3b
Author: Ashley Yakeley <ashley at semantic.org>
Date:   Mon Mar 7 15:17:45 2005 -0800

    UT1 calendar functions, with test
    
    darcs-hash:20050307231745-ac6dd-24178425239c3be3a07adedddb2914b3af72353e


>---------------------------------------------------------------

49c8b0dd832c81ebe74516fa479bf131708e4e3b
 System/Time/Calendar.hs | 26 +++++++++++++++++++--
 TestTime.hs             | 61 ++++++++++++++++++++++++++++++++++---------------
 TestTime.ref            |  7 ++++++
 3 files changed, 74 insertions(+), 20 deletions(-)

diff --git a/System/Time/Calendar.hs b/System/Time/Calendar.hs
index 60312e8..cb1862b 100644
--- a/System/Time/Calendar.hs
+++ b/System/Time/Calendar.hs
@@ -5,12 +5,17 @@ module System.Time.Calendar
 
 	-- getting the locale time zone
 
-	-- converting times to Gregorian "calendrical" format
+	-- Gregorian "calendrical" format
 	TimeOfDay(..),CalendarDay(..),CalendarTime(..),
 	dayToCalendar,calendarToDay,
+
+	-- converting UTC times to Gregorian "calendrical" format
 	utcToLocalTimeOfDay,localToUTCTimeOfDay,
 	timeToTimeOfDay,timeOfDayToTime,
-	utcToCalendar,calendarToUTC
+	utcToCalendar,calendarToUTC,
+
+	-- converting UT1 times to Gregorian "calendrical" format
+	ut1ToCalendar,calendarToUT1
 
 	-- calendrical arithmetic
     -- e.g. "one month after March 31st"
@@ -167,4 +172,21 @@ calendarToUTC tz (CalendarTime cday tod) = UTCTime (day + i) (timeOfDayToTime to
 	day = calendarToDay cday
 	(i,todUTC) = localToUTCTimeOfDay tz tod
 
+-- | get a TimeOfDay given the fraction of a day since midnight
+dayFractionToTimeOfDay :: Rational -> TimeOfDay
+dayFractionToTimeOfDay df = timeToTimeOfDay (siSecondsToTime (round (df * posixDaySeconds)))
+
+-- | 1st arg is observation meridian in degrees, positive is East
+ut1ToCalendar :: Rational -> ModJulianDate -> CalendarTime
+ut1ToCalendar long date = CalendarTime (dayToCalendar localDay) (dayFractionToTimeOfDay localToDOffset) where
+	localTime = date + long / 360 :: Rational
+	localDay = floor localTime
+	localToDOffset = localTime - (fromIntegral localDay)
+
+-- | get the fraction of a day since midnight given a TimeOfDay
+timeOfDayToDayFraction :: TimeOfDay -> Rational
+timeOfDayToDayFraction tod = timeToSISeconds (timeOfDayToTime tod) / posixDaySeconds
 	
+-- | 1st arg is observation meridian in degrees, positive is East
+calendarToUT1 :: Rational -> CalendarTime -> ModJulianDate
+calendarToUT1 long (CalendarTime cday tod) = (fromIntegral (calendarToDay cday)) + (timeOfDayToDayFraction tod) - (long / 360)
diff --git a/TestTime.hs b/TestTime.hs
index 104801e..d2c47cb 100644
--- a/TestTime.hs
+++ b/TestTime.hs
@@ -11,24 +11,9 @@ showCal d = do
 	putStr ((show d) ++ "=" ++ show (dayToCalendar d))
 	putStrLn (if d == d' then "" else "=" ++ (show d') ++ "!")
 
-showUTCTime :: UTCTime -> String
-showUTCTime (UTCTime d t) =  show d ++ "," ++ show t
-
-for :: (Monad m) => (a -> m ()) -> [a] -> m ()
-for _ [] = return ()
-for f (x:xs) = f x >> for f xs
 
-myzone :: TimeZone
-myzone = hoursToTimezone (- 8)
-
-leapSec1998Cal :: CalendarTime
-leapSec1998Cal = CalendarTime (CalendarDay 1998 12 31) (TimeOfDay 23 59 60 500000000000)
-
-leapSec1998 :: UTCTime
-leapSec1998 = calendarToUTC utc leapSec1998Cal
-
-main :: IO ()
-main = do
+testCal :: IO ()
+testCal = do
 	showCal 0	
 	showCal 40000
 	showCal 50000
@@ -48,7 +33,25 @@ main = do
 	showCal 51604
 	-- years 2000 and 2001, plus some slop
 	for showCal [51540..52280]	
-	--
+
+showUTCTime :: UTCTime -> String
+showUTCTime (UTCTime d t) =  show d ++ "," ++ show t
+
+for :: (Monad m) => (a -> m ()) -> [a] -> m ()
+for _ [] = return ()
+for f (x:xs) = f x >> for f xs
+
+myzone :: TimeZone
+myzone = hoursToTimezone (- 8)
+
+leapSec1998Cal :: CalendarTime
+leapSec1998Cal = CalendarTime (CalendarDay 1998 12 31) (TimeOfDay 23 59 60 500000000000)
+
+leapSec1998 :: UTCTime
+leapSec1998 = calendarToUTC utc leapSec1998Cal
+
+testUTC :: IO ()
+testUTC = do
 	putStrLn ""
 	showCal 51178
 	putStrLn (show leapSec1998Cal)
@@ -57,3 +60,25 @@ main = do
 	putStrLn (show lsMineCal)
 	let lsMine = calendarToUTC myzone lsMineCal
 	putStrLn (showUTCTime lsMine)
+
+neglong :: Rational
+neglong = -120
+
+poslong :: Rational
+poslong = 120
+
+testUT1 :: IO ()
+testUT1 = do
+	putStrLn ""
+	putStrLn (show (ut1ToCalendar 0 51604.0))
+	putStrLn (show (ut1ToCalendar 0 51604.5))
+	putStrLn (show (ut1ToCalendar neglong 51604.0))
+	putStrLn (show (ut1ToCalendar neglong 51604.5))
+	putStrLn (show (ut1ToCalendar poslong 51604.0))
+	putStrLn (show (ut1ToCalendar poslong 51604.5))
+
+main :: IO ()
+main = do
+	testCal
+	testUTC
+	testUT1
diff --git a/TestTime.ref b/TestTime.ref
index ebe832a..0d8e12b 100644
--- a/TestTime.ref
+++ b/TestTime.ref
@@ -758,3 +758,10 @@
 51178,86400500000000000ps
 1998-12-31 15:59:60.5
 51178,86400500000000000ps
+
+2000-03-01 00:00:00
+2000-03-01 12:00:00
+2000-02-29 16:00:00
+2000-03-01 04:00:00
+2000-03-01 08:00:00
+2000-03-01 20:00:00