diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,7 @@ [![Build Status](https://travis-ci.org/Alexander-Ignatyev/astro.svg?branch=master)](https://travis-ci.org/Alexander-Ignatyev/astro) [![Coverage Status](https://coveralls.io/repos/github/Alexander-Ignatyev/astro/badge.svg)](https://coveralls.io/github/Alexander-Ignatyev/astro) [![Documentation](https://img.shields.io/badge/mltool-documentation-blue.svg)](https://alexander-ignatyev.github.io/astro-docs/doc/index.html) +[![Hackage](https://img.shields.io/hackage/v/astro.svg)](https://hackage.haskell.org/package/astro) ## Usage diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import GHC.Generics -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Maybe (fromMaybe) -import Data.Time.LocalTime (ZonedTime, getZonedTime) -import Options.Applicative -import Data.Monoid((<>)) - --- Astro Imports -import Data.Astro.Time.JulianDate -import Data.Astro.Time.Conv (zonedTimeToLCT, zonedTimeToLCD, lctToZonedTime) - -import Data.Astro.Effects (refract) -import Data.Astro.CelestialObject.RiseSet(riseAndSetLCT, riseAndSet2, RiseSetMB(..), RiseSetLCT(..)) - -import Data.Astro.Sun - -import Data.Astro.Star - -import Data.Astro.Types -import Data.Astro.Coordinate - -import Data.Astro.Moon (moonPosition1, moonDistance1, moonAngularSize) -import Data.Astro.Moon.MoonDetails (j2010MoonDetails, mduToKm) - -import Data.Astro.Planet (Planet(..), planetPosition, planetTrueAnomaly1, planetDistance1, planetAngularDiameter) -import Data.Astro.Planet.PlanetDetails (j2010PlanetDetails) - - -main :: IO () -main = execParser opts >>= run - where opts = info (cmdOptions <**> helper) - ( progDesc "Amateur astronomical computations" - <> header "Astro" ) - - -run :: CmdOptions -> IO () -run cmdOptions = do - defParams <- defaultParams - let params = fromMaybe defParams $ fromMaybe defParams <$> decode <$> B.pack <$> cmdJson cmdOptions - res = processQuery params - B.putStrLn $ encode res - - --- Calcs -calculateSunResult :: Params -> PlanetaiResult -calculateSunResult params = PR { - riseSet = riseSet - , distance = DR distance "km" - , angularSize = angularSize - , position = hcPosition - } - where coords = paramsCoordinates params - date = paramsDate params - lct = paramsDateTime params - jd = lctUniversalTime lct - rs = sunRiseAndSet coords 0.833333 date - riseSet = toRiseSetResult rs - distance = sunDistance jd - DD angularSize = sunAngularSize jd - ec1 = sunPosition2 jd - hcPosition = toHorizonCoordinatesResult coords jd ec1 - - -calculateMoonResult :: Params -> PlanetaiResult -calculateMoonResult params = PR { - riseSet = riseSet - , distance = DR distance "km" - , angularSize = angularSize - , position = hcPosition - } - where position = moonPosition1 j2010MoonDetails - coords = paramsCoordinates params - verticalShift = refract (DD 0) 12 1012 - date = paramsDate params - lct = paramsDateTime params - jd = lctUniversalTime lct - rs = riseAndSet2 0.000001 position coords verticalShift date - riseSet = toRiseSetResult rs - mdu = moonDistance1 j2010MoonDetails jd - distance = mduToKm mdu - DD angularSize = moonAngularSize mdu - ec1 = position jd - hcPosition = toHorizonCoordinatesResult coords jd ec1 - - -calculatePlanetResult :: Params -> Planet -> PlanetaiResult -calculatePlanetResult params planet = PR { - riseSet = riseSet - , distance = DR distance "AU" - , angularSize = angularSize - , position = hcPosition - } - where coords = paramsCoordinates params - verticalShift = refract (DD 0) 12 1012 - date = paramsDate params - lct = paramsDateTime params - jd = lctUniversalTime lct - planetDetails = j2010PlanetDetails planet - earthDetails = j2010PlanetDetails Earth - position = planetPosition planetTrueAnomaly1 planetDetails earthDetails - rs = riseAndSet2 0.000001 position coords verticalShift date - riseSet = toRiseSetResult rs - au = planetDistance1 planetDetails earthDetails jd - AU distance = au - DD angularSize = planetAngularDiameter planetDetails au - ec1 = position jd - hcPosition = toHorizonCoordinatesResult coords jd ec1 - - -calculateStarResult :: Params -> Star -> StarResult -calculateStarResult params star = SR { - starRiseSet = riseSet - , starPosition = hcPosition - } - where coords = paramsCoordinates params - verticalShift = refract (DD 0) 12 1012 - date = paramsDate params - lct = paramsDateTime params - jd = lctUniversalTime lct - ec1 = starCoordinates star - rs = riseAndSetLCT coords date verticalShift ec1 - riseSet = fromRiseSetLCT rs - hcPosition = toHorizonCoordinatesResult coords jd ec1 - - -toRiseSetResult :: RiseSetMB -> RiseSetResult -toRiseSetResult rs = case rs of - RiseSet rise set -> RSR { rise = lctToZonedTime <$> fst <$> rise - , riseAzimuth = ddValue <$> snd <$> rise - , set = lctToZonedTime <$> fst <$> set - , setAzimuth = ddValue <$> snd <$> set - , state = "Rise and/or set" - } - Circumpolar -> RSR Nothing Nothing Nothing Nothing "Circumpolar" - NeverRises -> RSR Nothing Nothing Nothing Nothing "NeverRises" - - -fromRiseSetLCT :: RiseSetLCT -> RiseSetResult -fromRiseSetLCT rs = case rs of - RiseSet rise set -> RSR { rise = Just $ lctToZonedTime $ fst rise - , riseAzimuth = Just $ ddValue $ snd $ rise - , set = Just $ lctToZonedTime $ fst set - , setAzimuth = Just $ ddValue $ snd $ set - , state = "Rise and Set" - } - Circumpolar -> RSR Nothing Nothing Nothing Nothing "Circumpolar" - NeverRises -> RSR Nothing Nothing Nothing Nothing "NeverRises" - - -ddValue :: DecimalDegrees -> Double -ddValue (DD value) = value - -toHorizonCoordinatesResult :: GeographicCoordinates - -> JulianDate - -> EquatorialCoordinates1 - -> HorizonCoordinatesResult -toHorizonCoordinatesResult (GeoC lat long) jd (EC1 delta alpha) = HCR altitude azimuth - where ec2 = EC2 delta (raToHA alpha long jd) - hc = equatorialToHorizon lat ec2 - HC (DD altitude) (DD azimuth) = hc - - - - -processQuery :: Params -> AstroResult -processQuery params = AstroResult { - request = params - , sun = calculateSunResult params - , moon = calculateMoonResult params - , mercury = calculatePlanetResult params Mercury - , venus = calculatePlanetResult params Venus - , mars = calculatePlanetResult params Mars - , jupiter = calculatePlanetResult params Jupiter - , saturn = calculatePlanetResult params Saturn - , uranus = calculatePlanetResult params Uranus - , neptune = calculatePlanetResult params Neptune - , polaris = calculateStarResult params Polaris - , alphaCrucis = calculateStarResult params AlphaCrucis - , sirius = calculateStarResult params Sirius - , betelgeuse = calculateStarResult params Betelgeuse - , rigel = calculateStarResult params Rigel - , vega = calculateStarResult params Vega - , antares = calculateStarResult params Antares - , canopus = calculateStarResult params Canopus - , pleiades = calculateStarResult params Pleiades - } - - --- Command Line Options -data CmdOptions = CmdOptions { - cmdJson :: Maybe String - } - - -cmdOptions :: Parser CmdOptions -cmdOptions = CmdOptions - <$> (optional $ strOption ( long "json" <> short 'j' <> help "JSON-encoded params") ) - - --- Params -data CoordinatesParam = CoordinatesParam { - latitude :: Double - , longitude :: Double - } deriving (Generic, Show) - -instance ToJSON CoordinatesParam -instance FromJSON CoordinatesParam - - -data Params = Params { - coordinates :: CoordinatesParam - , datetime :: ZonedTime - } deriving (Generic, Show) - -instance ToJSON Params -instance FromJSON Params - - -paramsCoordinates :: Params -> GeographicCoordinates -paramsCoordinates params = GeoC (DD $ latitude coords) (DD $ longitude coords) - where coords = coordinates params - - -paramsDateTime :: Params -> LocalCivilTime -paramsDateTime = zonedTimeToLCT . datetime - - -paramsDate :: Params -> LocalCivilDate -paramsDate = zonedTimeToLCD . datetime - - -greenwichCoordinates :: CoordinatesParam -greenwichCoordinates = CoordinatesParam 51.4768 0 - - -defaultParams :: IO (Params) -defaultParams = do - time <- getZonedTime - return Params { - coordinates = greenwichCoordinates - , datetime = time - } - - --- Result -data HorizonCoordinatesResult = HCR { - altitude :: Double - , azimuth :: Double - } deriving (Generic, Show) - -instance ToJSON HorizonCoordinatesResult - -data RiseSetResult = RSR { - rise :: Maybe ZonedTime - , riseAzimuth :: Maybe Double - , set :: Maybe ZonedTime - , setAzimuth :: Maybe Double - , state :: String - } deriving (Generic, Show) - -instance ToJSON RiseSetResult - - -data DistanceResult = DR { - value :: Double - , units :: String - } deriving (Generic, Show) - -instance ToJSON DistanceResult - -data PlanetaiResult = PR { - riseSet :: RiseSetResult - , distance :: DistanceResult - , angularSize:: Double - , position :: HorizonCoordinatesResult - } deriving (Generic, Show) - -instance ToJSON PlanetaiResult - -data StarResult = SR { - starRiseSet :: RiseSetResult - , starPosition :: HorizonCoordinatesResult - } deriving (Generic, Show) - -instance ToJSON StarResult - -data AstroResult = AstroResult { - request :: Params - , sun :: PlanetaiResult - , moon :: PlanetaiResult - , mercury :: PlanetaiResult - , venus :: PlanetaiResult - , mars :: PlanetaiResult - , jupiter :: PlanetaiResult - , saturn :: PlanetaiResult - , uranus :: PlanetaiResult - , neptune :: PlanetaiResult - , polaris :: StarResult - , alphaCrucis :: StarResult - , sirius :: StarResult - , betelgeuse :: StarResult - , rigel :: StarResult - , vega :: StarResult - , antares :: StarResult - , canopus :: StarResult - , pleiades :: StarResult - } deriving (Generic, Show) - -instance ToJSON AstroResult diff --git a/astro.cabal b/astro.cabal --- a/astro.cabal +++ b/astro.cabal @@ -1,6 +1,6 @@ name: astro -version: 0.4.1.1 -synopsis: Astro +version: 0.4.1.2 +synopsis: Amateur astronomical computations description: Please see README.md homepage: https://github.com/alexander-ignatyev/astro license: BSD3 @@ -45,22 +45,29 @@ , matrix default-language: Haskell2010 -executable astro-app - hs-source-dirs: app - main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base - , bytestring - , time - , aeson - , optparse-applicative - , astro - default-language: Haskell2010 - test-suite astro-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + other-modules: Data.Astro.CelestialObject.RiseSetTest + , Data.Astro.CelestialObjectTest + , Data.Astro.CoordinateTest + , Data.Astro.Effects.ParallaxTest + , Data.Astro.EffectsTest + , Data.Astro.MoonTest + , Data.Astro.Planet.PlanetDetailsTest + , Data.Astro.Planet.PlanetMechanicsTest + , Data.Astro.Sun.SunInternalsTest + , Data.Astro.SunTest + , Data.Astro.Time.ConvTest + , Data.Astro.Time.GregorianCalendarTest + , Data.Astro.Time.JulianDateTest + , Data.Astro.Time.SiderealTest + , Data.Astro.TimeTest + , Data.Astro.TypesTest + , Data.Astro.UtilsTest + , Test.HUnit.Approx + build-depends: base , astro , time diff --git a/test/Data/Astro/CelestialObject/RiseSetTest.hs b/test/Data/Astro/CelestialObject/RiseSetTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/CelestialObject/RiseSetTest.hs @@ -0,0 +1,81 @@ +module Data.Astro.CelestialObject.RiseSetTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.Types (DecimalDegrees(..), DecimalHours(..), fromDMS, fromHMS) +import Data.Astro.Coordinate (EquatorialCoordinates1(..)) +import Data.Astro.Time.Sidereal (lstToDH, dhToLST) +import Data.Astro.CelestialObject.RiseSet +import Data.Astro.Star + +tests = [testGroup "riseAndSet" [ + testRiseAndSet "a star, NH" + 0.000001 + (RiseSet (dhToLST 16.721731, DD 64.362370) (dhToLST 6.589380, DD 295.637630)) + (riseAndSet (EC1 (fromDMS 21 42 0) (fromHMS 23 39 20)) verticalShift (DD 30)) + , testRiseAndSet "Polaris, NH" + 0.000001 + Circumpolar + (riseAndSet ecPolaris verticalShift (DD 30)) + , testRiseAndSet "Polaris, SH" + 0.000001 + NeverRises + (riseAndSet ecPolaris verticalShift (DD $ -30)) + , testRiseAndSet "Alpha Crucis, NH" + 0.000001 + NeverRises + (riseAndSet ecAlphaCrucis verticalShift (DD 30)) + , testRiseAndSet "Alpha Crucis, SH" + 0.000001 + Circumpolar + (riseAndSet ecAlphaCrucis verticalShift (DD $ -30)) + , testRiseAndSet "Sirius, NH" + 0.000001 + (RiseSet (dhToLST 2.507612, DD 120.857651) (dhToLST 10.997344, DD 239.142349)) + (riseAndSet ecSirius verticalShift (DD 57)) + , testRiseAndSet "Sirius, SH" + 0.000001 + (RiseSet (dhToLST 23.390844, DD 116.158877) (dhToLST 14.114111, DD 243.841123)) + (riseAndSet ecSirius verticalShift (DD $ -48)) + ] + ] + + +ecPolaris = starCoordinates Polaris +ecAlphaCrucis = starCoordinates AlphaCrucis +ecSirius = starCoordinates Sirius + +verticalShift = (fromDMS 0 34 0) + +testRiseAndSet msg eps expected actual = + testCase msg $ assertRiseAndSet eps expected actual + +assertRiseAndSet eps expected@(RiseSet (etr, DD ear) (ets, DD eas)) actual@(RiseSet (atr, DD aar) (ats, DD aas)) = + unless (eqLST eps etr atr && abs(ear-aar) <= eps + && eqLST eps ets ats && abs(eas-aas) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" +assertRiseAndSet _ Circumpolar Circumpolar = assertString "" +assertRiseAndSet _ Circumpolar actual = assertString msg + where msg = "expected: Circumpolar\n but got: " ++ show actual +assertRiseAndSet _ NeverRises NeverRises = assertString "" +assertRiseAndSet _ NeverRises actual = assertString msg + where msg = "expected: NeverRises\n but got: " ++ show actual + +eqLST eps lst1 lst2 = + let DH dh1 = lstToDH lst1 + DH dh2 = lstToDH lst2 + in abs (dh1 - dh2) < eps diff --git a/test/Data/Astro/CelestialObjectTest.hs b/test/Data/Astro/CelestialObjectTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/CelestialObjectTest.hs @@ -0,0 +1,32 @@ +module Data.Astro.CelestialObjectTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Astro.TypesTest (testDecimalDegrees) + +import Data.Astro.Types (DecimalDegrees(..), DecimalHours(..)) +import Data.Astro.Coordinate (EquatorialCoordinates1(..), EclipticCoordinates(..)) +import Data.Astro.CelestialObject + +tests = [testGroup "angle" [ + testDecimalDegrees "Equatorial: Orionis and Canis Majoris" + 0.000000001 + (DD 23.673849422164192) + (angleEquatorial (EC1 (DD (-8.225)) (DH 5.225472222222222)) (EC1 (DD (-16.68638888888889)) (DH 6.737055555555555))) + , testDecimalDegrees "Ecliptic: Orionis and Canis Majoris" + 0.000000001 + (DD 23.673849422164192) + (angleEcliptic (EcC (DD (-31.12290508933333)) (DD 76.53651836408739)) (EcC (DD (-39.597832824969665)) (DD 103.79168740150627))) + ] + ] diff --git a/test/Data/Astro/CoordinateTest.hs b/test/Data/Astro/CoordinateTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/CoordinateTest.hs @@ -0,0 +1,180 @@ +module Data.Astro.CoordinateTest +( + tests + , testEC1 + , testEcC +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.TypesTest (testDecimalDegrees, testDecimalHours) +import Data.Astro.Time.JulianDate (JulianDate(..), LocalCivilTime(..) + , fromYMDHMS, lctFromYMDHMS) +import Data.Astro.Coordinate +import Data.Astro.Types +import Data.Astro.Utils (reduceToZeroRange) + +ro :: GeographicCoordinates +ro = GeoC (fromDMS 51 28 40) (-(fromDMS 0 0 5)) + +dt :: LocalCivilTime +dt = lctFromYMDHMS (DH 1) 2017 6 25 10 29 0 + +jd :: JulianDate +jd = lctUniversalTime dt + +sunHC :: HorizonCoordinates +sunHC = HC (fromDMS 49 18 21.77) (fromDMS 118 55 19.53) + +sunEC1 :: EquatorialCoordinates1 +sunEC1 = EC1 {e1Declination = DD 23.378295912623855, e1RightAscension = DH 6.29383725890224} + + +tests = [testGroup "RA <-> HA" [ + testDecimalHours "RA 18.53 in 1980-04-22 18:36:51.67 to HA" + 0.0000001 + (DH 9.873237) + (raToHA (DH 18.539167) (DD (-64.0)) $ fromYMDHMS 1980 4 22 18 36 51.67) + , testDecimalHours "HA 9.87 in 1980-04-22 18:36:51.67 to RA" + 0.0000001 + (DH 9.873237) + (raToHA (DH 18.539167) (DD (-64.0)) $ fromYMDHMS 1980 4 22 18 36 51.67) + , testProperty "RA <-> HA property for Novosibirsk" $ prop_HARAConv (DD 83) (JD 2457607.97281) + , testProperty "RA <-> HA property for Rio de Janeiro" $ prop_HARAConv (DD (-43)) (JD 2457607.97281) + ] + , testGroup "EC2 <-> HC" [ + testHC "EC2 23.219 5.862 -> HC 19.334 283.271" + 0.00000001 + (HC (DD 19.334345224) (DD 283.27102726)) + (equatorialToHorizon (DD 52) (EC2 (DD 23.219444444) (DH 5.862222222222222))) + , testEC2 "HC 19.334 283.271 -> EC2 23.219 5.862" + 0.00000001 + (EC2 (DD 23.219444444) (DH 5.862222222222222)) + (horizonToEquatorial (DD 52) (HC (DD 19.334345224) (DD 283.27102726))) + , testProperty "property" prop_EC2HCConv + ] + , testGroup "EC1 <-> HC" [ + testHC "sunEC1 -> sunHC" 0.00000001 sunHC (ec1ToHC ro jd sunEC1) + , testEC1 "sunHC -> sunEC1" 0.00000001 sunEC1 (hcToEC1 ro jd sunHC) + ] + , testGroup "obliquity" [ + testDecimalDegrees "2009-07-06" + 0.000001 + (DD 23.43925285) + (obliquity $ JD 2455018.5) + , testDecimalDegrees "2016-08-12" + 0.000001 + (DD 23.434706359) + (obliquity $ JD 2457612.5) + ] + , testGroup "Ecliptic <-> Equatorial" [ + testEC1 "EcC 4.875 139.6861 on 2009-07-06 to EC1" + 0.000001 + (EC1 (DD 19.535712) (DH 9.581501)) + (eclipticToEquatorial (EcC (DD 4.875277777777778) (DD 139.6861111111111)) (JD 2455018.5)) + , testEcC "EC1 19.535 9.581 to EcC on 2009-07-06" + 0.000001 + (EcC (DD 4.875278) (DD 139.686111)) + (equatorialToEcliptic (EC1 (DD 19.535712) (DH 9.581501)) (JD 2455018.5)) + , testProperty "property" prop_EC1EcCConv + ] + , testGroup "Galactic <-> Equatorial" [ + testGC "EC 10.053 10.35 -> GC" + 0.000001 + (GC (DD 51.12226779935766) (DD 232.24788348766026)) + (equatorialToGalactic (EC1 (DD 10.053055555555556) (DH 10.35))) + , testEC1 "GC 51.122 232.247 -> EC" + 0.000001 + (EC1 (DD 10.053055555555556) (DH 10.35)) + (galacticToEquatorial (GC (DD 51.12226779935766) (DD 232.24788348766026))) + , testProperty "property" prop_EC1GCConv + ] + ] + + + +prop_HARAConv longitude ut dh = + let dh' = reduceToZeroRange 24 dh + DH ra = haToRA (raToHA (DH dh') longitude ut) longitude ut + DH ha = raToHA (haToRA (DH dh') longitude ut) longitude ut + eps = 0.00000001 + in abs (ra - dh') < eps && (ha - dh') < eps + where types = (dh::Double) + +testHC msg eps expected actual = + testCase msg $ assertHC eps expected actual + +assertHC eps expected@(HC (DD eAlt) (DD eAz)) actual@(HC (DD aAlt) (DD aAz)) = + unless (abs(eAlt-aAlt) <= eps && abs(eAz-aAz) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +testEC2 msg eps expected actual = + testCase msg $ assertEC2 eps expected actual + +assertEC2 eps expected@(EC2 (DD eDec) (DH eHa)) actual@(EC2 (DD aDec) (DH aHa)) = + unless (abs(eDec-aDec) <= eps && abs(eHa-aHa) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +prop_EC2HCConv (latitude, up, round) = + let latitude' = DD $ reduceToZeroRange 180 latitude + up' = (reduceToZeroRange 89.9 up) + 0.1 + round' = (reduceToZeroRange 359.9 round) + 0.1 + HC (DD up'') (DD round'') = equatorialToHorizon latitude' $ horizonToEquatorial latitude' (HC (DD up') (DD round')) + eps = 0.00001 + in abs(up'-up'') < eps && abs(round'-round'') < eps + where types = ((latitude, up, round)::(Double, Double, Double)) + + +testEC1 msg eps expected actual = + testCase msg $ assertEC1 eps expected actual + +assertEC1 eps expected@(EC1 (DD e1) (DH e2)) actual@(EC1 (DD a1) (DH a2)) = + unless (abs(e1-a1) <= eps && abs(e2-a2) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + + +testEcC msg eps expected actual = + testCase msg $ assertEcC eps expected actual + +assertEcC eps expected@(EcC (DD eLat) (DD eLon)) actual@(EcC (DD aLat) (DD aLon)) = + unless (abs(eLat-aLat) <= eps && abs(eLon-aLon) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +prop_EC1EcCConv (jd, up, round) = + let jd' = JD $ (reduceToZeroRange 10000 jd) + 2455018.5 + up' = (reduceToZeroRange 90 up) + round' = (reduceToZeroRange 359 round) + EcC (DD up'') (DD round'') = equatorialToEcliptic (eclipticToEquatorial (EcC (DD up') (DD round')) jd') jd' + eps = 0.000001 + in abs(up'-up'') < eps && abs(round'-round'') < eps + where types = ((jd, up, round)::(Double, Double, Double)) + + +testGC msg eps expected actual = + testCase msg $ assertGC eps expected actual + +assertGC eps expected@(GC (DD eLat) (DD eLon)) actual@(GC (DD aLat) (DD aLon)) = + unless (abs(eLat-aLat) <= eps && abs(eLon-aLon) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +prop_EC1GCConv (up, round) = + let up' = (reduceToZeroRange 90 up) + round' = (reduceToZeroRange 359 round) + GC (DD up'') (DD round'') = equatorialToGalactic $ galacticToEquatorial (GC (DD up') (DD round')) + eps = 0.000001 + in abs(up'-up'') < eps && abs(round'-round'') < eps + where types = ((up, round)::(Double, Double)) diff --git a/test/Data/Astro/Effects/ParallaxTest.hs b/test/Data/Astro/Effects/ParallaxTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Effects/ParallaxTest.hs @@ -0,0 +1,47 @@ +module Data.Astro.Effects.ParallaxTest +( + tests +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit +import Test.HUnit.Approx + +import Control.Monad (unless) + +import Data.Astro.CoordinateTest (testEC1) + +import Data.Astro.Types (GeographicCoordinates(..), fromDMS, fromHMS) +import Data.Astro.Time.JulianDate (JulianDate(..)) +import Data.Astro.Coordinate (EquatorialCoordinates1(..)) +import Data.Astro.Effects.Parallax + +tests = [testGroup "parallaxQuantities" [ + testPairOfDoubles "DD 50, 60 metres" + 0.000001 + (0.762422, 0.644060) + (parallaxQuantities 50 60) + , testPairOfDoubles "DD -70, 10 metres" + 0.000001 + (-0.936174, 0.3430361) + (parallaxQuantities (-70) 10) + ] + , testGroup "parallax" [ + testEC1 "the Sun" + 0.0000001 + (EC1 (-(fromDMS 8 44 31.4303)) (fromHMS 22 36 44.2044)) + (parallax (GeoC 50 (-100)) 60 0.9901 (JD 2443931.1979166665) (EC1 (-(fromDMS 8 44 24)) (fromHMS 22 36 44))) + ] + ] + + +testPairOfDoubles msg eps expected actual = + testCase msg $ assertPairOfDoubles eps expected actual + +assertPairOfDoubles eps expected@(e1, e2) actual@(a1, a2) = + unless (abs(e1-a1) <= eps && abs(e2-a2) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" diff --git a/test/Data/Astro/EffectsTest.hs b/test/Data/Astro/EffectsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/EffectsTest.hs @@ -0,0 +1,86 @@ +module Data.Astro.EffectsTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.TypesTest (testDecimalDegrees) +import Data.Astro.CoordinateTest (testEC1, testEcC) + +import Data.Astro.Types (DecimalDegrees(..), DecimalHours(..), fromDMS, fromHMS) +import Data.Astro.Time.JulianDate (JulianDate(..)) +import Data.Astro.Time.Epoch (b1950) +import Data.Astro.Coordinate (EquatorialCoordinates1(..), EclipticCoordinates(..)) +import Data.Astro.Effects + +tests = [testGroup "refraction" [ + testDecimalDegrees "19.33" + 0.000001 + (DD 0.045403) + (refract (DD 19.334345) 13 1008) + , testDecimalDegrees "horizon" + 0.000001 + (DD 0.566569) + (refract (DD 0) 12 1013) + , testDecimalDegrees "azimuth" + 0.000001 + (DD 0) + (refract (DD 90) 12 1012) + , testDecimalDegrees "azimuth" + 0.000001 + (DD 0.007905) + (refract (DD 63.5) 15.5 1012) + ] + , testGroup "precession" [ + testEC1 "low-precision method" + 0.0000001 + (EC1 (fromDMS 14 16 7.8329) (fromHMS 9 12 20.4707)) + (precession1 B1950 (EC1 (fromDMS 14 23 25) (fromHMS 9 10 43)) (JD 2444057.2985)) + , testEC1 "rigorous method" + 0.0000001 + (EC1 (fromDMS 14 16 6.3489) (fromHMS 9 12 20.4458)) + (precession2 b1950 (EC1 (fromDMS 14 23 25) (fromHMS 9 10 43)) (JD 2444057.2985)) + ] + , testGroup "nutation" [ + testDecimalDegrees "Longitude at 1988-09-01 00:00:00" + 0.0000000001 + (DD 0.0015258101) + (nutationLongitude (JD 2447405.5)) + , testDecimalDegrees "Obliquity at 1988-09-01 00:00:00" + 0.0000000001 + (DD 0.0025670999) + (nutationObliquity (JD 2447405.5)) + , testDecimalDegrees "Longitude at 2016-08-12 00:00:00" + 0.0000000001 + (DD (-0.0009839730)) + (nutationLongitude (JD 2457612.5)) + , testDecimalDegrees "Obliquity at 2016-08-12 00:00:00" + 0.0000000001 + (DD (-0.0024250649)) + (nutationObliquity (JD 2457612.5)) + ] + , testGroup "aberration" [ + testEcC "Mars at 1988-09-08" + 0.00000001 + (EcC (-(fromDMS 1 32 56.3319)) (fromDMS 352 37 30.4521)) + (includeAberration (EcC (-(fromDMS 1 32 56.4)) (fromDMS 352 37 10.1)) (JD 2447412.5) (fromDMS 165 33 44.1)) + ] + ] + +testPairOfDD msg eps expected actual = + testCase msg $ assertPairOfDD eps expected actual + +assertPairOfDD eps expected@((DD e1), (DD e2)) actual@((DD a1), (DD a2)) = + unless (abs(e1-a1) <= eps && abs(e2-a2) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" diff --git a/test/Data/Astro/MoonTest.hs b/test/Data/Astro/MoonTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/MoonTest.hs @@ -0,0 +1,74 @@ +module Data.Astro.MoonTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Astro.TypesTest (testDecimalDegrees) +import Data.Astro.CoordinateTest (testEC1) + +import Data.Astro.Time.JulianDate (fromYMD) +import Data.Astro.Coordinate (EquatorialCoordinates1(..)) +import Data.Astro.Moon.MoonDetails (MoonDetails(..), j2010MoonDetails, MoonDistanceUnits(..)) +import Data.Astro.Moon + +tests = [testGroup "moonPosition1"[ + testEC1 "at 2003-09-01 00:00:00 UT" + 0.000001 + (EC1 (-11.525750) 14.211486) + (moonPosition1 j2010MoonDetails (fromYMD 2003 9 1)) + ] + , testGroup "moonDistance" [ + testMDU "at 2016-08-27 00:00:00" + 0.000001 + (MDU 0.953425) + (moonDistance1 j2010MoonDetails (fromYMD 2016 8 26)) + ] + , testGroup "moonAngularSize" [ + testDecimalDegrees "at 0.953425 MDU" + 0.000001 + 0.543409 + (moonAngularSize (MDU 0.953425)) + , testDecimalDegrees "at 1 MDU" + 0.000001 + (mdBigTheta j2010MoonDetails) + (moonAngularSize (MDU 1)) + ] + , testGroup "moonHorizontalParallax" [ + testDecimalDegrees "at 0.953425 MDU" + 0.000001 + 0.997142 + (moonHorizontalParallax (MDU 0.953425)) + , testDecimalDegrees "at 1 MDU" + 0.000001 + (mdPi j2010MoonDetails) + (moonHorizontalParallax (MDU 1)) + ] + , testGroup "moonPhase" [ + testCase "at 2016-08-01 00:00:00" $ assertApproxEqual "" + 0.000001 + 0.042498 + (moonPhase j2010MoonDetails (fromYMD 2016 8 1)) + , testCase "at 2016-08-21 00:00:00" $ assertApproxEqual "" + 0.000001 + 0.911818 + (moonPhase j2010MoonDetails (fromYMD 2016 8 21)) + ] + , testGroup "moonBrightLimbPositionAngle" [ + testDecimalDegrees "at 2016-08-28 00:00:00" + 0.000001 + 82.479138 + (moonBrightLimbPositionAngle (EC1 17.386905 4.897826) (EC1 10.329324 10.342354)) + ] + ] + +testMDU msg eps (MDU e) (MDU a) = testCase msg $ assertApproxEqual "" eps e a diff --git a/test/Data/Astro/Planet/PlanetDetailsTest.hs b/test/Data/Astro/Planet/PlanetDetailsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Planet/PlanetDetailsTest.hs @@ -0,0 +1,25 @@ +module Data.Astro.Planet.PlanetDetailsTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Astro.Planet.PlanetDetails + +tests = [testGroup "inner planets" [ + testCase "Mercury" $ isInnerPlanet (j2010PlanetDetails Mercury) @?= True + , testCase "Venus" $ isInnerPlanet (j2010PlanetDetails Venus) @?= True + , testCase "Jupiter" $ isInnerPlanet (j2010PlanetDetails Jupiter) @?= False + , testCase "Uranus" $ isInnerPlanet (j2010PlanetDetails Uranus) @?= False + , testCase "Earth" $ isInnerPlanet (j2010PlanetDetails Earth) @?= False + ] + ] diff --git a/test/Data/Astro/Planet/PlanetMechanicsTest.hs b/test/Data/Astro/Planet/PlanetMechanicsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Planet/PlanetMechanicsTest.hs @@ -0,0 +1,131 @@ +module Data.Astro.Planet.PlanetMechanicsTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + + +import Data.Astro.TypesTest (testDecimalDegrees) +import Data.Astro.CoordinateTest (testEC1) + +import Data.Astro.Types (DecimalDegrees(..), DecimalHours(..), fromDMS) +import Data.Astro.Time.JulianDate (JulianDate(..)) +import Data.Astro.Time.Epoch (j2010) +import Data.Astro.Coordinate (EquatorialCoordinates1(..)) +import Data.Astro.Planet.PlanetDetails (Planet(..), j2010PlanetDetails) +import Data.Astro.Planet.PlanetMechanics + +nov222003 = JD 2452965.5 +jupiterDetails = j2010PlanetDetails Jupiter +earthDetails = j2010PlanetDetails Earth +mercuryDetails = j2010PlanetDetails Mercury +sunPositionOnNov222003 = EC1 {e1Declination = DD (-19.99330355916915), e1RightAscension = DH 15.803416251173122} + +tests = [testGroup "mechanics" [ + testDecimalDegrees "jupiter mean anomaly" + 0.0000001 + 137.8097641 + (planetMeanAnomaly jupiterDetails nov222003) + , testDecimalDegrees "jupiter true anomaly" + 0.0000001 + 141.5736000 + (planetTrueAnomaly1 jupiterDetails nov222003) + , testDecimalDegrees "planetHeliocentricLongitude" + 0.0000001 + 114.6633 + (planetHeliocentricLongitude jupiterDetails 100) + , testDecimalDegrees "planetHeliocentricLatitude" + 0.0000001 + 1.1220101 + (planetHeliocentricLatitude jupiterDetails 160) + , testCase "planetHeliocentricRadiusVector" $ assertApproxEqual "" + 0.0000001 + 5.4403612 + (planetHeliocentricRadiusVector jupiterDetails 160) + , testDecimalDegrees "planetProjectedLongitude" + 0.0000001 + 159.9935029 + (planetProjectedLongitude jupiterDetails 160) + , testCase "planetProjectedRadiusVector" $ assertApproxEqual "" + 0.0000001 + 5.4387668 + (planetProjectedRadiusVector jupiterDetails 1.22 5.44) + , testDecimalDegrees "planetEclipticLongitude: Jupiter" + 0.0000001 + 169.793671 + (planetEclipticLongitude jupiterDetails 160 5.43 59 0.988) + , testDecimalDegrees "planetEclipticLongitude: Mercury" + 0.000001 + 253.929762 + (planetEclipticLongitude mercuryDetails 287.824406 0.448159 59.274748 0.987847) + , testDecimalDegrees "planetEclipticLatitude: Jupiter" + 0.0000001 + 1.1861236 + (planetEclipticLatitude 1.22 160 5.43 59 0.988 170) + , testDecimalDegrees "planetEclipticLatitude: Mercury" + 0.000001 + (-2.044058) + (planetEclipticLatitude (-6.035842) 287.824406 0.448159 59.274748 0.987847 253.929762) + , testEC1 "planetPosition1: Jupiter" + 0.0000001 + (EC1 (DD 6.3569686) (DH 11.1871664)) + (planetPosition1 jupiterDetails earthDetails nov222003) + , testEC1 "planetPosition1: Mercury" + 0.0000001 + (EC1 (DD (-24.5023748)) (DH 16.8200600)) + (planetPosition1 mercuryDetails earthDetails nov222003) + , testEC1 "planetPosition" + 0.0000001 + (planetPosition1 jupiterDetails earthDetails nov222003) + (planetPosition planetTrueAnomaly1 jupiterDetails earthDetails nov222003) + , testDecimalDegrees "pertubations: Jupiter" + 0.0000001 + 0.0371214 + (planetPertubations Jupiter nov222003) + , testDecimalDegrees "pertubations: Saturn" + 0.0000001 + 0.1317895 -- not sure if this is the right result + (planetPertubations Saturn nov222003) + , testDecimalDegrees "pertubations: Mars" + 0.0000001 + 0 + (planetPertubations Mars nov222003) + , testCase "planetDistance1" $ assertApproxEqual "" + 0.0000001 + 5.6033062 + (planetDistance1 jupiterDetails earthDetails nov222003) + , testDecimalDegrees "planetAngularDiameter" + 0.0000001 + (fromDMS 0 0 35.1114) + (planetAngularDiameter jupiterDetails 5.6033062) + ] + , testGroup "planetPhase" [ + testCase "Jupiter" $ assertApproxEqual "" + 0.0000001 + 0.9922919 + (planetPhase1 jupiterDetails earthDetails nov222003) + , testCase "Mercury" $ assertApproxEqual "" + 0.0000001 + 0.9141158 + (planetPhase1 mercuryDetails earthDetails nov222003) + ] + , testGroup "planetBrightLimbPositionAngle" [ + testDecimalDegrees "Jupiter" + 0.0000001 + 113.2029600 + (planetBrightLimbPositionAngle (EC1 (DD 6.3569686) (DH 11.1871664)) sunPositionOnNov222003) + , testDecimalDegrees "Mercury" + 0.0000001 + 284.7106531 + (planetBrightLimbPositionAngle (EC1 (-24.502375) 16.820060) sunPositionOnNov222003) + ] + ] diff --git a/test/Data/Astro/Sun/SunInternalsTest.hs b/test/Data/Astro/Sun/SunInternalsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Sun/SunInternalsTest.hs @@ -0,0 +1,35 @@ +module Data.Astro.Sun.SunInternalsTest +( + tests +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Astro.Utils (reduceToZeroRange) +import Data.Astro.Sun.SunInternals + +tests = [testGroup "solveKeplerEquation" [ + testCase "a" $ assertApproxEqual "" + 1e-7 + 3.5220041 + (solveKeplerEquation 0.016714 3.528210 1e-7) + , testProperty "property" prop_solveKeplerEquation + ] + ] + +prop_solveKeplerEquation (e, m) = + let eps = 1e-7 + (_, e') = properFraction e + e'' =( e' * 0.01) + 0.1 + m' = (reduceToZeroRange 17 e) - 7 + x = solveKeplerEquation e'' m' eps + dx = x - e''*(sin x) - m' + in abs dx < eps + where types = ((e,m)::(Double, Double)) diff --git a/test/Data/Astro/SunTest.hs b/test/Data/Astro/SunTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/SunTest.hs @@ -0,0 +1,181 @@ +module Data.Astro.SunTest +( + tests +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.TypesTest (testDecimalDegrees, testDecimalHours) +import Data.Astro.CoordinateTest (testEC1) + + +import Data.Astro.Types (DecimalDegrees(..), DecimalHours(..), GeographicCoordinates(..), fromDMS, fromHMS) +import Data.Astro.Time.JulianDate (JulianDate(..), LocalCivilTime(..), lctFromYMDHMS, LocalCivilDate(..), lcdFromYMD) +import Data.Astro.Time.Epoch (j2010) +import Data.Astro.Coordinate (EquatorialCoordinates1(..)) +import Data.Astro.Sun + +tests = [testGroup "sunDetails" [ + testSunDetails "J2010.0" + 0.000001 + (SunDetails j2010 (DD 279.557208) (DD 283.112438) 0.016705) + (sunDetails j2010) + ] + , testGroup "the Sun's coordinates" [ + -- The Astronomycal Almanach gives (EC1 (fromDMS 19 21 16) (fromHMS 8 23 33)) + testEC1 "(1) at 2003-07-27 00:00:00" + 0.000001 + (EC1 (fromDMS 19 21 17.4394) (fromHMS 8 23 32.8286)) + (sunPosition1 j2010SunDetails (JD 2452847.5)) + , testEC1 "(1) at 2016-08-11 13:30:00" + 0.000001 + (EC1 (fromDMS 15 2 5.1480) (fromHMS 9 26 49.9629)) + (sunPosition1 j2010SunDetails (JD 2457612.0625)) + -- The Astronomycal Almanach gives (EC1 (fromDMS 19 12 52) (fromHMS 8 26 3)) + , testEC1 "(1) at 1988-07-27 00:00:00" + 0.000001 + (EC1 (fromDMS 19 12 50.6369) (fromHMS 8 26 3.6147)) + (sunPosition1 j2010SunDetails (JD 2447369.5)) + -- The Astronomycal Almanach gives (EC1 (fromDMS 19 12 52) (fromHMS 8 26 3)) + , testEC1 "(2) at 1988-07-27 00:00:00" + 0.000001 + (EC1 (fromDMS 19 12 48.9604) (fromHMS 8 26 4.1004)) + (sunPosition2 (JD 2447369.5)) + -- The Astronomycal Almanach gives (EC1 (fromDMS 19 21 16) (fromHMS 8 23 33)) + , testEC1 "(2) at 2003-07-27 00:00:00" + 0.000001 + (EC1 (fromDMS 19 21 9.2633) (fromHMS 8 23 35.2376)) + (sunPosition2 (JD 2452847.5)) + ] + , testGroup "distance" [ + testCase "at 1988-07-27 00:00:00" $ assertApproxEqual "" + 1 + 151920130 + (sunDistance (JD 2447369.5)) + , testCase "at 2016-08-12 13:30:00" $ assertApproxEqual "" + 1 + 151577454 + (sunDistance (JD 2457613.0625)) + , testCase "at 2010-10-10 18:00:00" $ assertApproxEqual "" + 1 + 149373939 + (sunDistance (JD 2455480.25)) + ] + , testGroup "angular size" [ + testDecimalDegrees "at 1988-07-27 00:00:00" + 0.000001 + (fromDMS 0 31 29.9308) + (sunAngularSize (JD 2447369.5)) + , testDecimalDegrees "at 2016-08-12 13:30:00" + 0.000001 + (fromDMS 0 31 34.2034) + (sunAngularSize (JD 2457613.0625)) + , testDecimalDegrees "at 2010-10-10 18:00:00" + 0.000001 + (fromDMS 0 32 2.1461) + (sunAngularSize (JD 2455480.25)) + ] + , testGroup "Sun's rise and set" [ + -- sunrise/set times are from http://timeanddate.com + -- coordinates are from http://dateandtime.info + testRiseSet "Venice at 2016-08-12; Rise: 06:08, DD 68; Set: 20:22, DD 292" + 0.000001 + (RiseSet + (Just (lctFromYMDHMS 2 2016 8 12 6 8 1.2955, DD 67.6609383)) + (Just (lctFromYMDHMS 2 2016 8 12 20 22 17.5593, DD 292.0714064))) + (sunRiseAndSet (GeoC (DD 45.43713) (12.33265)) 0.833333 (lcdFromYMD 2 2016 8 12)) + , testRiseSet "Ulaanbaatar at 2016-08-13; Rise: 06:45, DD 67; Set: 21:09, DD 293" + 0.000001 + (RiseSet + (Just (lctFromYMDHMS 9 2016 8 13 6 44 43.1358, DD 66.8644763)) + (Just (lctFromYMDHMS 9 2016 8 13 21 8 49.7896, DD 292.8475000))) + (sunRiseAndSet (GeoC (DD 47.90771) (106.88324)) 0.833333 (lcdFromYMD 9 2016 8 13)) + , testRiseSet "Lima at 2016-08-12; Rise: 06:22, DD 75; Set: 18:04, DD 285" + 0.000001 + (RiseSet + (Just (lctFromYMDHMS (-5) 2016 8 12 6 22 22.2308, DD 75.0822853)) + (Just (lctFromYMDHMS (-5) 2016 8 12 18 3 41.7631, DD 284.7661756))) + (sunRiseAndSet (GeoC (DD $ -12.04318) (DD $ -77.02824)) 0.833333 (lcdFromYMD (-5) 2016 8 12)) + , testRiseSet "Longyearbyen at 2016-08-12; Circumpolar" + 0.000001 + Circumpolar + (sunRiseAndSet (GeoC (DD 78.22) (DD 15.65)) 0.833333 (lcdFromYMD 2 2016 8 12)) + , testRiseSet "Longyearbyen at 2017-01-12; Down all day" + 0.000001 + NeverRises + (sunRiseAndSet (GeoC (DD 78.22) (DD 15.65)) 0.833333 (lcdFromYMD 2 2017 1 12)) + , testRiseSet "Anchorage at 2016-08-13; Rise: 06:05, DD 57; Set: 22:02, DD 302" + 0.000001 + (RiseSet + (Just (lctFromYMDHMS (-8) 2016 8 13 6 4 29.3945, DD 57.0595036)) + (Just (lctFromYMDHMS (-8) 2016 8 13 22 2 8.3067, DD 302.4495529))) + (sunRiseAndSet (GeoC (DD 61.21806) (-149.90028)) 0.833333 (lcdFromYMD (-8) 2016 8 13)) + , testRiseSet "Kazan at 2016-08-18; Rise: 04:21, DD 65; Set: 19:12, DD 295" + 0.000001 + (RiseSet + (Just (lctFromYMDHMS 3 2016 8 18 4 21 19.3153, DD 65.0507218)) + (Just (lctFromYMDHMS 3 2016 8 18 19 11 46.7175,DD 294.5658995))) + (sunRiseAndSet (GeoC 55.78874 49.1221400) 0.833333 $ lcdFromYMD 3 2016 8 18) + ], + testGroup "equationOfTime" [ + testDecimalHours "zero at June" + (1/3600) + (-(fromHMS 0 0 1)) + (equationOfTime $ JD 2457551.5) + , testDecimalHours "minimum at February" + (1/3600) + (-(fromHMS 0 14 7)) + (equationOfTime $ JD 2457429.5) + , testDecimalHours "maximum at November" + (1/3600) + (fromHMS 0 16 18) + (equationOfTime $ JD 2457694.5) + ] + , testGroup "solarElongation" [ + testDecimalDegrees "Mars at 2010-07-27 20:00:00 UT" + 0.0000001 + (DD 24.7905087) + (solarElongation (EC1 (fromDMS 11 57 27) (fromHMS 10 6 45)) (JD 2455405.3333333335)) + ] + ] + +testSunDetails msg eps expected actual = + testCase msg $ assertSunDetails eps expected actual + +assertSunDetails eps expected@(SunDetails (JD eJd) (DD eEps) (DD eOm) eE) actual@(SunDetails (JD aJd) (DD aEps) (DD aOm) aE) = + unless (abs(eJd-aJd) <= eps && abs(eEps-aEps) <= eps + && abs(eOm-aOm) <= eps && abs(eE-aE) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +testRiseSet msg eps expected actual = + testCase msg $ assertRiseSet eps expected actual + +assertRiseSet eps expected@(RiseSet er es) actual@(RiseSet ar as) = + unless (eqMaybeRS eps er ar && eqMaybeRS eps es as) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +assertRiseSet _ Circumpolar Circumpolar = assertString "" +assertRiseSet _ Circumpolar actual = assertString msg + where msg = "expected: Circumpolar\n but got: " ++ show actual +assertRiseSet _ NeverRises NeverRises = assertString "" +assertRiseSet _ NeverRises actual = assertString msg + where msg = "expected: NeverRises\n but got: " ++ show actual + + +eqMaybeRS eps (Just rs1) (Just rs2) = eqRS eps rs1 rs2 +eqMaybeRS _ Nothing Nothing = True +eqMaybeRS _ _ _ = False + +eqRS eps (LCT (DH tz1) (JD j1), DD d1) (LCT (DH tz2) (JD j2), DD d2) = abs (j1-j2) < eps && abs (tz1-tz2) < eps && abs (d1-d2) < eps diff --git a/test/Data/Astro/Time/ConvTest.hs b/test/Data/Astro/Time/ConvTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Time/ConvTest.hs @@ -0,0 +1,50 @@ +module Data.Astro.Time.ConvTest +( + tests +) + +where + +import Data.Astro.Types +import Data.Time.LocalTime +import Data.Astro.Time.Conv +import Data.Astro.Time.JulianDate +import Data.Astro.Time.JulianDateTest (testJD) + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + + +tests = [ testGroup "LCT conversion properties" [ + testProperty "TZ: -5" $ prop_LCTConversion 4 + , testProperty "TZ: 0" $ prop_LCTConversion 0 + , testProperty "TZ: 3" $ prop_LCTConversion 3 + ] + , testGroup "LCD Conversion properties" [ + testProperty "TZ: -5" $ prop_LCDConversion 4 + , testProperty "TZ: 0" $ prop_LCDConversion 0 + , testProperty "TZ: 3" $ prop_LCDConversion 3 + ] + ] + +prop_LCTConversion tz = forAll (choose (0, 999999999)) check + where check n = + let jd = LCT (DH tz) (JD n) + jd2 = zonedTimeToLCT $ lctToZonedTime jd + LCT _ (JD n2) = jd2 + in abs(n - n2) < 0.00000001 + + +prop_LCDConversion tz = forAll (choose (0, 999999999)) check + where check n = + let (jd, _) = splitToDayAndTime (JD n) -- drop time part + lct = LCT (DH tz) jd + lcd2 = zonedTimeToLCD $ lctToZonedTime lct + LCD _ (JD n2) = lcd2 + JD n1 = jd + in abs(n1 - n2) < 0.00000001 + diff --git a/test/Data/Astro/Time/GregorianCalendarTest.hs b/test/Data/Astro/Time/GregorianCalendarTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Time/GregorianCalendarTest.hs @@ -0,0 +1,57 @@ +module Data.Astro.Time.GregorianCalendarTest +( + tests +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck + +import Data.Time.Calendar (fromGregorian, toGregorian) + +import Data.Astro.Time.GregorianCalendar + + +tests = [testGroup "easter day" [ + testCase "2009" easterDay2009 + , testCase "2016" easterDay2016 + , testCase "2027" easterDay2027 + , testProperty "easter properties" prop_Easter + ] + , testGroup "leap year" [ + testCase "2016" (isLeapYear 2016 @?= True) + , testCase "2000" (isLeapYear 2000 @?= True) + , testCase "2015" (isLeapYear 2015 @?= False) + , testCase "1900" (isLeapYear 1900 @?= False) + , testCase "1800" (isLeapYear 1800 @?= False) + ] + , testGroup "day number" [ + testCase "1 Jan of leap year" (dayNumber (fromGregorian 2016 1 1) @?= 1) + , testCase "11 Feb of leap year" (dayNumber (fromGregorian 2016 2 11) @?= 42) + , testCase "10 Mar of leap year" (dayNumber (fromGregorian 2016 3 10) @?= 70) + , testCase "15 Nov of leap year" (dayNumber (fromGregorian 2016 11 15) @?= 320) + , testCase "31 Dec of leap year" (dayNumber (fromGregorian 2016 12 31) @?= 366) + , testCase "1 Jan of non-leap year" (dayNumber (fromGregorian 2015 1 1) @?= 1) + , testCase "11 Feb of non-leap year" (dayNumber (fromGregorian 2015 2 11) @?= 42) + , testCase "10 Mar of non-leap year" (dayNumber (fromGregorian 2015 3 10) @?= 69) + , testCase "15 Nov of non-leap year" (dayNumber (fromGregorian 2015 11 15) @?= 319) + , testCase "31 Dec of non-leap year" (dayNumber (fromGregorian 2015 12 31) @?= 365) + ] + ] + + +easterDay2009 = easterDayInYear 2009 @?= fromGregorian 2009 4 12 +easterDay2016 = easterDayInYear 2016 @?= fromGregorian 2016 3 27 +easterDay2027 = easterDayInYear 2027 @?= fromGregorian 2027 3 28 + +prop_Easter = + forAll (choose (1583, 999900)) $ checkEasterProperties + +checkEasterProperties year = let date = easterDayInYear year + (y, m, _) = toGregorian date + in fromIntegral y == year && (m == 3 || m == 4) + diff --git a/test/Data/Astro/Time/JulianDateTest.hs b/test/Data/Astro/Time/JulianDateTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Time/JulianDateTest.hs @@ -0,0 +1,161 @@ +module Data.Astro.Time.JulianDateTest +( + tests + , testJD + , testLCT +) + +where + + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.Types (DecimalHours(..)) +import Data.Astro.Time.Epoch (b1950, j2000) +import Data.Astro.Time.JulianDate + +tests = [testGroup "to julian day" [ + testCase "19 Jun 2009 18:00" $ fromYMDHMS 2009 6 19 18 0 0 @?= JD 2455002.25 + , testCase "1 Aug 2009 12:00" $ fromYMDHMS 2016 8 1 12 0 0 @?= JD 2457602 + , testCase "Gregorian start day" $ fromYMDHMS 1582 10 15 0 0 0 @?= JD 2299160.5 + , testCase "Gregorian before start" $ fromYMDHMS 1582 10 14 12 0 0 @?= JD 2299170 + , testCase "19 Jun 2009" $ fromYMD 2009 6 19 @?= JD 2455001.5 + , testCase "1 Aug 2009" $ fromYMD 2016 8 1 @?= JD 2457601.5 + ] + , testGroup "from julian day" [ + testCase "19 Jun 2009 18:00" (toYMDHMS (JD 2455002.25) @?= (2009, 6, 19, 18, 0, 0)) + , testCase "1 Aug 2009 12:00" (toYMDHMS (JD 2457602) @?= (2016, 8, 1, 12, 0, 0)) + , testCase "Gregorian start day" (toYMDHMS (JD 2299160.5) @?= (1582, 10, 15, 0, 0, 0)) + , testCase "Gregorian before start" (toYMDHMS (JD 2299160) @?= (1582, 10, 4, 12, 0, 0)) + ] + , testGroup "julian conversion properties" [ + testProperty "before George" prop_JulianConversionsBeforeGeorge + , testProperty "after George" prop_JulianConversionsAfterGeorge + ] + , testGroup "day of the week" [ + testCase "friday at midnight" $ dayOfWeek (JD 2455001.5) @?= 5 + , testCase "friday before moon" $ dayOfWeek (JD 2455001.75) @?= 5 + , testCase "friday after moon" $ dayOfWeek (JD 2455002.25) @?= 5 + , testCase "thursday after moon" $ dayOfWeek (JD 2455001.3) @?= 4 + , testCase "sunday at midnight" $ dayOfWeek (JD 2455003.5) @?= 0 + ] + , testGroup "spliToDayAndTime" [ + testCase "100000.5" $ splitToDayAndTime (JD 100000.5) @?= (JD 100000.5, JD 0) + , testCase "100000.7" $ assertJDPair 0.00001 (JD 100000.5, JD 0.2) $ splitToDayAndTime (JD 100000.7) + , testCase "100001.3" $ assertJDPair 0.00001 (JD 100000.5, JD 0.8) $ splitToDayAndTime (JD 100001.3) + , testCase "2444352.108931" + $ assertJDPair 0.00001 (JD 2444351.5, JD 0.608931) + $ splitToDayAndTime (JD 2444352.108931) + , testProperty "property" prop_splitToDayAndTime + ] + , testGroup "UT <-> LCT" [ + testLCT "2016-08-07 02:10:10 +4 LCT -> UT" + 0.000000001 + (LCT 4 (JD 2457607.423726852)) + (lctFromYMDHMS 4 2016 8 7 2 10 10) + ] + , testGroup "numberOfCenturies" [ + testCase "J2000..2009-06-06" $ assertApproxEqual "" + 0.000000001 + 0.095099247 + (numberOfCenturies j2000 $ JD 2455018.5) + ] + , testGroup "numberOfYears" [ + testCase "B1950..1979-07-02" $ assertApproxEqual "" + 0.000000001 + 29.5 + (numberOfYears b1950 $ JD 2444057.2985) + ] + , testGroup "numberOfDays" [ + testCase "10 .. 15" $ assertApproxEqual "" + 0.000000001 + 5 + (numberOfDays 10 15) + ] + , testGroup "add hours" [ + testJD "+ 12H" + 0.000000001 + (JD 110.5) + (addHours 12 110) + , testJD "+ 0H" + 0.000000001 + (JD 110) + (addHours 0 110) + , testJD "- 6H" + 0.000000001 + (JD 109.75) + (addHours (-6) 110) + ] + , testJD "julian start date" 0.000001 (JD 0) julianStartDateTime + , testGroup "print" [ + testCase "show" $ "1999-09-19 19:29:59.0000 -2.0" @=? show (lctFromYMDHMS (-2) 1999 9 19 19 29 59) + , testCase "printLtcHs" $ "lctFromYMDHMS (-2) 1999 9 19 19 29 59.0000" @=? printLctHs (lctFromYMDHMS (-2) 1999 9 19 19 29 59) + ] + , testCase "lctToYMDHMS" $ (1999, 9, 19, 12, 0, 0) @=? lctToYMDHMS (lctFromYMDHMS (-2) 1999 9 19 12 0 0) + , testGroup "JD: Num instance" [ + testCase "+" $ (JD 17.5) @=? (JD 15.5) + (JD 2) + , testCase "-" $ (JD 13.5) @=? (JD 15.5) - (JD 2) + , testCase "*" $ (JD 31) @=? (JD 15.5) * (JD 2) + , testCase "negate" $ (JD 15.5) @=? negate (JD $ -15.5) + , testCase "abs" $ (JD 15.7) @=? abs (JD (-15.7)) + , testCase "signum > 0" $ (JD 1.0) @=? signum (JD 15.5) + , testCase "signum = 0" $ (JD 0.0) @=? signum (JD 0.0) + , testCase "signum < 0" $ (JD $ -1.0) @=? signum (JD $ -15.5) + , testCase "fromInteger" $ (JD 17) @=? fromInteger 17 + ] + ] + +prop_JulianConversionsAfterGeorge = + forAll (choose (2299161, 999999999)) $ checkJulianConverionProperties + + +prop_JulianConversionsBeforeGeorge = + forAll (choose (0, 2299161)) $ checkJulianConverionProperties + + +checkJulianConverionProperties :: Double -> Bool +checkJulianConverionProperties n = + let jd = JD n + (y, m, d, hs, ms, ss) = toYMDHMS jd + jd2 = fromYMDHMS y m d hs ms ss + JD n2 = jd2 + in abs(n - n2) < 0.00000001 + +assertJDPair :: Double -> (JulianDate, JulianDate) -> (JulianDate, JulianDate) -> Assertion +assertJDPair eps e@(JD e1, JD e2) a@(JD a1, JD a2) = + unless (abs(a1-e1) <= eps && abs(a2-e2) <= eps) (assertFailure msg) + where msg = "expected: " ++ show e ++ "\n but got: " ++ show a ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +prop_splitToDayAndTime = + forAll (choose (0, 999999999)) $ check + where check jd = + let (JD d, JD t) = splitToDayAndTime $ JD jd + eps = 0.0000001 + in abs(jd-d-t) < eps && t >= 0 && t < 1 + +testJD msg eps expected actual = + testCase msg $ assertJD eps expected actual + +assertJD eps (JD expected) (JD actual) = + unless (abs(expected-actual) <= eps) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +testLCT msg eps expected actual = + testCase msg $ assertLCT eps expected actual + + +assertLCT eps expected actual = + unless (eqLCT eps expected actual) (assertFailure msg) + where msg = "expected: " ++ show expected ++ "\nbut got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show eps ++ ")" + +eqLCT eps (LCT (DH tze) (JD jde)) (LCT (DH tza) (JD jda)) = abs (jde-jda) < eps && abs(tze-tza) < eps diff --git a/test/Data/Astro/Time/SiderealTest.hs b/test/Data/Astro/Time/SiderealTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/Time/SiderealTest.hs @@ -0,0 +1,112 @@ +module Data.Astro.Time.SiderealTest +( + tests + , testLST +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Astro.TypesTest (testDecimalHours) +import Data.Astro.Time.JulianDateTest (testJD) + +import Data.Astro.Utils (reduceToZeroRange) +import Data.Astro.Types (DecimalHours(..), fromHMS) +import Data.Astro.Coordinate (DecimalDegrees(..)) +import Data.Astro.Time.JulianDate (JulianDate(..), splitToDayAndTime) +import Data.Astro.Time.Sidereal + + +eps = 1/(24*60*60*10) + +tests = [testGroup "GST <-> UT conversions" [ + testGST "1980-04-22 14:36:51.67 UT -> 1980-04-22 04:40:05.23 GST" + eps + (hmsToGST 4 40 5.23) + (utToGST $ JD 2444352.108931366) + , testGST "2016-08-04 19:28:43.15 UT -> 2016-08-04 16:23:52.94 GST" + eps + (hmsToGST 16 23 52.94) + (utToGST $ JD 2457605.3116105325) + , testJD "1980-04-22 04:40:05.23 GST -> 1980-04-22 14:36:51.67 UT" + eps + (JD 2444352.108931366) + (gstToUT (JD 2444351.5) (hmsToGST 4 40 05.23)) + , testJD "2016-08-04 16:23:52.94 GST -> 2016-08-04 19:28:43.15 UT" + eps + (JD 2457605.3116105325) + (gstToUT (JD 2457604.5) (hmsToGST 16 23 52.94)) + , testProperty "property" prop_siderealTimeConversions + ] + , testGroup "GST <-> LST converions" [ + testLST "04:40:05.23 GST -> 00:24:05.23 LST" + eps + (hmsToLST 0 24 5.23) + (gstToLST (DD $ -64) (hmsToGST 4 40 5.23)) + , testLST "15:25:35.12 GST -> 20:20:27.92 LST" + eps + (hmsToLST 20 20 27.92) + (gstToLST (DD 73.72) (hmsToGST 15 25 35.12)) + , testLST "21:41:25.78 GST -> 04:36:13.78 LST" + eps + (hmsToLST 4 36 13.78) + (gstToLST (DD 103.7) (hmsToGST 21 41 25.78)) + , testGST "00:24:05.23 LST -> 04:40:05.23 GST" + eps + (hmsToGST 4 40 5.23) + (lstToGST (DD $ -64) (hmsToLST 0 24 5.23)) + , testGST "20:20:27.92 LST -> 15:25:35.12 GST" + eps + (hmsToGST 15 25 35.12) + (lstToGST (DD 73.72) (hmsToLST 20 20 27.92)) + ] + , testGST "04:36:13.78 LST -> 21:41:25.78 GST (w/ DC)" + eps + (hmsToGST (-2) (-18) (-34.22)) + (lstToGSTwDC (DD 103.7) (hmsToLST 4 36 13.78)) + , testGST "04:36:13.78 LST -> 21:41:25.78 GST" + eps + (hmsToGST 21 41 25.78) + (lstToGST (DD 103.7) (hmsToLST 4 36 13.78)) + , testProperty "property longitude=-101.13" $ prop_localGlobalConverions (DD $ -101.13) + , testProperty "property longitude=31.7" $ prop_localGlobalConverions (DD 31.7) + ] + +testLST msg eps expected actual = testDecimalHours msg eps (lstToDH expected) (lstToDH actual) +testGST msg eps expected actual = testDecimalHours msg eps (gstToDH expected) (gstToDH actual) + +prop_siderealTimeConversions = + forAll (choose (0, 999999999)) $ check + where check utN = + let utJd = JD utN + gst = utToGST utJd + utJd'@(JD utN') = gstToUT utJd gst + (JD utD, _) = splitToDayAndTime utJd + (_, JD utT') = splitToDayAndTime utJd' + DH diff = fromHMS 0 3 57 + hasAmbigity = utT' < diff + eps = 0.0000001 + in (hasAmbigity || abs(utN-utN') < eps) + + +prop_localGlobalConverions longitude = + forAll (choose (0, 24)) $ check + where check n = + let dh = (DH n) + gst = lstToGST24 longitude $ gstToLST longitude $ dhToGST dh + lst = gstToLST longitude $ lstToGST24 longitude $ dhToLST dh + eps = 0.000000001 + DH a1 = gstToDH gst + DH a2 = lstToDH lst + in abs(n-a1) < eps && abs(n-a2) < eps + lstToGST24 longitude lst = + let gst = lstToGST longitude lst + dh24 = reduceToZeroRange 24 $ gstToDH gst + in dhToGST dh24 diff --git a/test/Data/Astro/TimeTest.hs b/test/Data/Astro/TimeTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/TimeTest.hs @@ -0,0 +1,42 @@ +module Data.Astro.TimeTest +( + tests +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Astro.Time.SiderealTest (testLST) +import Data.Astro.Time.JulianDateTest (testJD, testLCT) +import Data.Astro.Time +import Data.Astro.Time.JulianDate (JulianDate(..), LocalCivilTime(..), lctFromYMDHMS, lcdFromYMD) +import Data.Astro.Types +import Data.Astro.Time.Sidereal + +tests = [testGroup "LCT <-> LST" [ + testLST "1980-04-22 14:36:51.67 LCT -> 1980-04-22 04:24:44.65 LST" + 0.0000001 + (hmsToLST 4 24 44.655) + (lctToLST (DD (-64.0)) (LCT (-4) (JD 2444352.2755980324))) + , testLCT "1980-04-22 04:24:44.65 LST -> 1980-04-22 14:36:51.67 LCT" + 0.001 + (lctFromYMDHMS (-4) 1980 4 22 14 35 51.6704) + (lstToLCT (DD (-64.0)) (lcdFromYMD (-4) 1980 4 22) (hmsToLST 04 24 44.655)) + ] + , testGroup "UT -> LST" [ + testLST "1980-04-22 18:36:51.67 UT -> 04:24:44.65 LST" + 0.0000001 + (hmsToLST 4 24 44.655) + (utToLST (DD (-64.0)) (JD 2444352.2755980324)) + , testLST "1979-02-26 16:45:00 UT -> 04:24:44.65 LST" + 0.0000001 + (hmsToLST 20 28 44.7994) + (utToLST (-100.0) (JD 2443931.1979166665)) + ] + ] diff --git a/test/Data/Astro/TypesTest.hs b/test/Data/Astro/TypesTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/TypesTest.hs @@ -0,0 +1,168 @@ +module Data.Astro.TypesTest +( + tests + , testDecimalDegrees + , testDecimalHours +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Ratio ((%)) +import Data.Astro.Types + +tests = [testGroup "DecimalDegrees <-> DecimalHours" [ + testDecimalDegrees "12.03 H -> 180.45 D" 0.000001 (DD 180.45) $ fromDecimalHours (DH 12.03) + , testDecimalHours "180.45 D -> 12.03 H" 0.000001 (DH 12.03) $ toDecimalHours (DD 180.45) + , testProperty "property" prop_DHConversion + ] + , testGroup "DecimalDegrees <-> Radians" [ + testCase "0 -> 0 (rad)" $ assertApproxEqual "" 0.000000001 0 $ toRadians (DD 0) + , testCase "45 -> PI/4" $ assertApproxEqual "" 0.000000001 (pi*0.25) $ toRadians (DD 45) + , testCase "90 -> PI/2" $ assertApproxEqual "" 0.000000001 (pi*0.5) $ toRadians (DD 90) + , testCase "180 -> PI" $ assertApproxEqual "" 0.000000001 pi $ toRadians (DD 180) + , testCase "360 -> 2*PI" $ assertApproxEqual "" 0.000000001 (pi*2) $ toRadians (DD 360) + , testDecimalDegrees "0 -> 0 (deg)" 0.000000001 (DD 0) (fromRadians 0) + , testDecimalDegrees "pi/4 -> 45" 0.000000001 (DD 45) (fromRadians (pi*0.25)) + , testDecimalDegrees "pi/2 -> 90" 0.000000001 (DD 90) (fromRadians (pi*0.5)) + , testDecimalDegrees "pi -> 180" 0.000000001 (DD 180) (fromRadians pi) + , testDecimalDegrees "2*pi -> 360" 0.000000001 (DD 360) (fromRadians (pi*2)) + ] + , testGroup "DecimalDegrees <-> DMS" [ + testDecimalDegrees "182 31' 27''" 0.00001 (DD 182.52417) $ fromDMS 182 31 27 + , testCase "182.5" $ toDMS (DD 182.5) @?= (182, 30, 0) + , testProperty "property" prop_DMSConversion + ] + , testGroup "DecimalHours <-> HMS" [ + testDecimalHours "HMS -> DH 6:00" 0.00000001 (DH 6.0) (fromHMS 6 0 0) + , testDecimalHours "HMS -> DH 18:00" 0.00000001 (DH 18.0) (fromHMS 18 0 0) + , testDecimalHours "HMS -> DH 18:30" 0.00000001 (DH $ (18*2 + 1) / 2) (fromHMS 18 30 0) + , testDecimalHours "HMS -> DH 00:00:30" 0.00000001 (DH $ 30 / (60*60)) (fromHMS 0 0 30) + , testDecimalHours "HMS -> DH 00:00:10" 0.00000001 (DH 0.002777777778) $ fromHMS 0 0 10 + , testDecimalHours "HMS -> DH 23:59:59.99999" 0.00000001 (DH 24.0) $ fromHMS 23 59 59.99999 + , testCase "DH -> HMS 6:00" $ toHMS (DH 6.0) @?= (6, 0, 0) + , testCase "DH -> HMS 18:00" $ toHMS (DH 18.0) @?= (18, 0, 0) + , testCase "DH -> HMS 18:30" $ toHMS (DH $ (18*2 + 1) / 2) @?= (18, 30, 0) + , testCase "DH -> HMS 00:00:30" $ toHMS (DH $ (30 / (60*60))) @?= (0, 0, 30) + , testProperty "property" prop_HMSConversion + ] + , testGroup "Light travel time" [ + testDecimalHours "7.7 AU" 0.0000001 1.06722 (lightTravelTime 7.7) + ] + , testGroup "DD: standard typeclasses" [ + testCase "show" $ "DD 15.5" @=? show (DD 15.5) + , testCase "showList" $ "[DD 15.3,DD 15.7]" @=? showList [DD 15.3, DD 15.7] "" + , testCase "showsPrec" $ "DD 15.5" @=? showsPrec 0 (DD 15.5) "" + , testCase "== (True)" $ True @=? (DD 15.5) == (DD 15.5) + , testCase "== (False)" $ False @=? (DD 15.3) == (DD 15.5) + , testCase "/= (True)" $ True @=? (DD 15.3) /= (DD 15.5) + , testCase "/= (False)" $ False @=? (DD 15.5) /= (DD 15.5) + , testCase "compare: LT" $ LT @=? (DD 15.3) `compare` (DD 15.5) + , testCase "compare: EQ" $ EQ @=? (DD 15.5) `compare` (DD 15.5) + , testCase "compare: GT" $ GT @=? (DD 15.7) `compare` (DD 15.5) + , testCase "<" $ True @=? (DD 15.3) < (DD 15.7) + , testCase "<=" $ True @=? (DD 15.3) <= (DD 15.7) + , testCase ">" $ False @=? (DD 15.3) > (DD 15.7) + , testCase ">=" $ False @=? (DD 15.3) >= (DD 15.7) + , testCase "max" $ (DD 15.7) @=? max (DD 15.3) (DD 15.7) + , testCase "min" $ (DD 15.3) @=? min (DD 15.3) (DD 15.7) + , testCase "abs" $ (DD 15.7) @=? abs (DD (-15.7)) + , testCase "signum > 0" $ (DD 1.0) @=? signum (DD 15.5) + , testCase "signum = 0" $ (DD 0.0) @=? signum (DD 0.0) + , testCase "signum < 0" $ (DD $ -1.0) @=? signum (DD $ -15.5) + , testCase "toRational" $ (31 % 2) @=? toRational (DD 15.5) + , testCase "recip" $ (DD 0.01) @=? recip (DD 100) + , testCase "properFraction" $ (15, DD 0.5) @=? properFraction (DD 15.5) + ] + , testGroup "DH: standard typeclasses" [ + testCase "show" $ "DH 15.5" @=? show (DH 15.5) + , testCase "showList" $ "[DH 15.3,DH 15.7]" @=? showList [DH 15.3, DH 15.7] "" + , testCase "showsPrec" $ "DH 15.5" @=? showsPrec 0 (DH 15.5) "" + , testCase "== (True)" $ True @=? (DH 15.5) == (DH 15.5) + , testCase "== (False)" $ False @=? (DH 15.3) == (DH 15.5) + , testCase "/= (True)" $ True @=? (DH 15.3) /= (DH 15.5) + , testCase "/= (False)" $ False @=? (DH 15.5) /= (DH 15.5) + , testCase "compare: LT" $ LT @=? (DH 15.3) `compare` (DH 15.5) + , testCase "compare: EQ" $ EQ @=? (DH 15.5) `compare` (DH 15.5) + , testCase "compare: GT" $ GT @=? (DH 15.7) `compare` (DH 15.5) + , testCase "<" $ True @=? (DH 15.3) < (DH 15.7) + , testCase "<=" $ True @=? (DH 15.3) <= (DH 15.7) + , testCase ">" $ False @=? (DH 15.3) > (DH 15.7) + , testCase ">=" $ False @=? (DH 15.3) >= (DH 15.7) + , testCase "max" $ (DH 15.7) @=? max (DH 15.3) (DH 15.7) + , testCase "min" $ (DH 15.3) @=? min (DH 15.3) (DH 15.7) + , testCase "abs" $ (DH 15.7) @=? abs (DH (-15.7)) + , testCase "signum > 0" $ (DH 1.0) @=? signum (DH 15.5) + , testCase "signum = 0" $ (DH 0.0) @=? signum (DH 0.0) + , testCase "signum < 0" $ (DH $ -1.0) @=? signum (DH $ -15.5) + , testCase "toRational" $ (31 % 2) @=? toRational (DH 15.5) + , testCase "recip" $ (DH 0.01) @=? recip (DH 100) + , testCase "properFraction" $ (15, DH 0.5) @=? properFraction (DH 15.5) + ] + , testGroup "AU: standard typeclasses" [ + testCase "show" $ "AU 15.5" @=? show (AU 15.5) + , testCase "showList" $ "[AU 15.3,AU 15.7]" @=? showList [AU 15.3, AU 15.7] "" + , testCase "showsPrec" $ "AU 15.5" @=? showsPrec 0 (AU 15.5) "" + , testCase "== (True)" $ True @=? (AU 15.5) == (AU 15.5) + , testCase "== (False)" $ False @=? (AU 15.3) == (AU 15.5) + , testCase "/= (True)" $ True @=? (AU 15.3) /= (AU 15.5) + , testCase "/= (False)" $ False @=? (AU 15.5) /= (AU 15.5) + , testCase "compare: LT" $ LT @=? (AU 15.3) `compare` (AU 15.5) + , testCase "compare: EQ" $ EQ @=? (AU 15.5) `compare` (AU 15.5) + , testCase "compare: GT" $ GT @=? (AU 15.7) `compare` (AU 15.5) + , testCase "<" $ True @=? (AU 15.3) < (AU 15.7) + , testCase "<=" $ True @=? (AU 15.3) <= (AU 15.7) + , testCase ">" $ False @=? (AU 15.3) > (AU 15.7) + , testCase ">=" $ False @=? (AU 15.3) >= (AU 15.7) + , testCase "max" $ (AU 15.7) @=? max (AU 15.3) (AU 15.7) + , testCase "min" $ (AU 15.3) @=? min (AU 15.3) (AU 15.7) + , testCase "+" $ (AU 17.5) @=? (AU 15.5) + (AU 2) + , testCase "-" $ (AU 13.5) @=? (AU 15.5) - (AU 2) + , testCase "*" $ (AU 31) @=? (AU 15.5) * (AU 2) + , testCase "negate" $ (AU 15.5) @=? negate (AU $ -15.5) + , testCase "abs" $ (AU 15.7) @=? abs (AU (-15.7)) + , testCase "signum > 0" $ (AU 1.0) @=? signum (AU 15.5) + , testCase "signum = 0" $ (AU 0.0) @=? signum (AU 0.0) + , testCase "signum < 0" $ (AU $ -1.0) @=? signum (AU $ -15.5) + , testCase "fromInteger" $ (AU 17) @=? fromInteger 17 + , testCase "toRational" $ (31 % 2) @=? toRational (AU 15.5) + , testCase "/" $ (AU 10) @=? (AU 30) / (AU 3) + , testCase "recip" $ (AU 0.01) @=? recip (AU 100) + , testCase "properFraction" $ (15, AU 0.5) @=? properFraction (AU 15.5) + ] + ] + + +testDecimalDegrees msg eps (DD expected) (DD actual) = + testCase msg $ assertApproxEqual "" eps expected actual + +testDecimalHours msg eps (DH expected) (DH actual) = + testCase msg $ assertApproxEqual "" eps expected actual + +prop_DHConversion n = + let DH h = toDecimalHours . fromDecimalHours $ DH n + DD d = fromDecimalHours . toDecimalHours $ DD n + eps = 0.00000001 + in abs(n-h) < eps && abs(n-d) < eps + where types = (n::Double) + +prop_DMSConversion dd = + let (d, m, s) = toDMS $ DD dd + DD d' = fromDMS d m s + in abs(dd-d') < 0.0000001 + where types = (dd::Double) + +prop_HMSConversion = + forAll (choose (0, 1.0)) $ checkHMSConversionProperties + +checkHMSConversionProperties :: Double -> Bool +checkHMSConversionProperties n = + let (h, m, s) = toHMS $ DH n + DH n2 = fromHMS h m s + in abs (n-n2) < 0.00000001 diff --git a/test/Data/Astro/UtilsTest.hs b/test/Data/Astro/UtilsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Astro/UtilsTest.hs @@ -0,0 +1,86 @@ +module Data.Astro.UtilsTest +( + tests +) + +where + +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.HUnit.Approx +import Test.QuickCheck + +import Data.Fixed(Pico(..)) + +import Data.Astro.Utils + +tests = [testGroup "fromFixed" [ + testProperty "property" prop_fromFixed + , testCase "5.111123" $ assertApproxEqual "" 0.000000001 5.111123 $ fromFixed (toPico 5.111123) + , testCase "-999.9999" $ assertApproxEqual "" 0.000000001 (-999.9999) $ fromFixed (toPico (-999.9999)) + ] + , testGroup "fraction" [ + testProperty "property" prop_fraction + , testCase "5.562" $ assertFraction 5.562 + , testCase "-7.93" $ assertFraction (-7.93) + , testCase "-999.9999" $ assertFraction (-999.9999) + ] + , testGroup "trunc" [ + testProperty "property" prop_trunc + , testCase "5.562" $ 5.0 @=? trunc 5.562 + , testCase "-7.93" $ (-7.0) @=? trunc (-7.93) + ] + , testGroup "reduceToZeroRange" [ + testCase "24 -465.986246" $ assertApproxEqual "" 0.000000001 14.013754 $ reduceToZeroRange 24 (-465.986246) + , testProperty "property for r = 24" $ prop_reduceToZeroRange 24 + , testProperty "property for r = 1" $ prop_reduceToZeroRange 1 + ] + , testGroup "Degrees <-> Radians" [ + testCase "0 -> 0 (rad)" $ assertApproxEqual "" 0.000000001 0 $ toRadians 0 + , testCase "45 -> PI/4" $ assertApproxEqual "" 0.000000001 (pi*0.25) $ toRadians 45 + , testCase "90 -> PI/2" $ assertApproxEqual "" 0.000000001 (pi*0.5) $ toRadians 90 + , testCase "180 -> PI" $ assertApproxEqual "" 0.000000001 pi $ toRadians 180 + , testCase "360 -> 2*PI" $ assertApproxEqual "" 0.000000001 (pi*2) $ toRadians 360 + , testCase "0 -> 0 (deg)" $ assertApproxEqual "" 0.000000001 0 $ fromRadians 0 + , testCase "pi/4 -> 45" $ assertApproxEqual "" 0.000000001 45 $ fromRadians (pi*0.25) + , testCase "pi/2 -> 90" $ assertApproxEqual "" 0.000000001 90 $ fromRadians (pi*0.5) + , testCase "pi -> 180" $ assertApproxEqual "" 0.000000001 180 $ fromRadians pi + , testCase "2*pi -> 360" $ assertApproxEqual "" 0.000000001 360 $ fromRadians (pi*2) + ] + , testGroup "roundToN" [ + testCase "10.12341234 -> 10.12341" $ assertApproxEqual "" 0.000000001 10.12341 $ roundToN 5 10.12341234 + , testCase "-10.123456789 -> -10.123" $ assertApproxEqual "" 0.000000001 (-10.123) $ roundToN 3 (-10.123456789) + , testCase "10.9876543 -> 10.987" $ assertApproxEqual "" 0.000000001 10.988 $ roundToN 3 10.9876543 + , testCase "-10.9876543 -> -10.987" $ assertApproxEqual "" 0.000000001 (-10.9877) $ roundToN 4 (-10.9876543) + ] + ] + +toPico :: Real a => a -> Pico +toPico = realToFrac + +fromFraction :: Real a => (Int, a) -> a +fromFraction (i, f) = f + fromIntegral i + +assertFraction d = assertApproxEqual "" 0.0000001 d $ fromFraction $ fraction d + +prop_fromFixed d = + abs((fromFixed ((realToFrac d)::Pico))-d) < 0.0000001 + where types = (d::Double) + +prop_fraction d = + let (i, f) = fraction d + f' = d - fromIntegral i + in i == truncate d && abs(f'-f) < 0.0000001 + where types = (d::Double) + +prop_trunc d = + let d' = fromIntegral $ truncate d + in abs(d' - trunc d) < 0.0000001 + where types = (d::Double) + +prop_reduceToZeroRange r n = + let k = reduceToZeroRange r n + in k < r && k >= 0 + where types = (n::Double) diff --git a/test/Test/HUnit/Approx.hs b/test/Test/HUnit/Approx.hs new file mode 100644 --- /dev/null +++ b/test/Test/HUnit/Approx.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ImplicitParams, CPP #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE Safe #-} -- Test.HUnit is not Safe in 7.6 and below +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Test.HUnit.Approx +-- Copyright : (C) 2014 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : intended to be stable +-- Portability : not portable (uses implicit parameters) +-- +-- This module exports combinators to allow approximate equality of +-- floating-point values in HUnit tests. +----------------------------------------------------------------------------- + +module Test.HUnit.Approx ( + -- * Assertions + assertApproxEqual, (@~?), (@?~), + + -- * Tests + (~~?), (~?~) + ) where + +import Test.HUnit +import Control.Monad ( unless ) + +-- | Asserts that the specified actual value is approximately equal to the +-- expected value. The output message will contain the prefix, the expected +-- value, the actual value, and the maximum margin of error. +-- +-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted +-- and only the expected and actual values are output. +assertApproxEqual :: (Ord a, Num a, Show a) + => String -- ^ The message prefix + -> a -- ^ Maximum allowable margin of error + -> a -- ^ The expected value + -> a -- ^ The actual value + -> Assertion +assertApproxEqual preface epsilon expected actual = + unless (abs (actual - expected) <= epsilon) (assertFailure msg) + where msg = (if null preface then "" else preface ++ "\n") ++ + "expected: " ++ show expected ++ "\n but got: " ++ show actual ++ + "\n (maximum margin of error: " ++ show epsilon ++ ")" + +-- | Asserts that the specified actual value is approximately equal to the +-- expected value (with the expected value on the right-hand side). The margin +-- of error is specified with the implicit parameter @epsilon@. +(@?~) :: (Ord a, Num a, Show a, ?epsilon :: a) + => a -- ^ The actual value + -> a -- ^ The expected value + -> Assertion +x @?~ y = assertApproxEqual "" ?epsilon y x +infix 1 @?~ + +-- | Asserts that the specified actual value is approximately equal to the +-- expected value (with the expected value on the left-hand side). The margin +-- of error is specified with the implicit parameter @epsilon@. +(@~?) :: (Ord a, Num a, Show a, ?epsilon :: a) + => a -- ^ The expected value + -> a -- ^ The actual value + -> Assertion +x @~? y = assertApproxEqual "" ?epsilon x y +infix 1 @~? + +-- | Shorthand for a test case that asserts approximate equality (with the +-- expected value on the left-hand side, and the actual value on the +-- right-hand side). +(~~?) :: (Ord a, Num a, Show a, ?epsilon :: a) + => a -- ^ The expected value + -> a -- ^ The actual value + -> Test +expected ~~? actual = TestCase (expected @~? actual) +infix 1 ~~? + +-- | Shorthand for a test case that asserts approximate equality (with the +-- actual value on the left-hand side, and the expected value on the +-- right-hand side). +(~?~) :: (Ord a, Num a, Show a, ?epsilon :: a) + => a -- ^ The actual value + -> a -- ^ The expected value + -> Test +actual ~?~ expected = TestCase (actual @?~ expected) +infix 1 ~?~