1 files changed, 140 insertions, 0 deletions

diff --git a/src/CosmicCalendar.hs b/src/CosmicCalendar.hs
new file mode 100644
index 0000000..db29c02
--- /dev/null
+++ b/src/CosmicCalendar.hs
@@ -0,0 +1,140 @@
+{-# OPTIONS_GHC
+  -Wall
+  -Wno-unused-imports
+  -Wno-unused-top-binds
+  -Wno-name-shadowing
+#-}
+{-# language NoImplicitPrelude #-}
+{-# language RecordWildCards #-}
+{-# language FlexibleContexts #-}
+{-# language TemplateHaskell #-}
+{-# language ViewPatterns #-}
+{-# language OverloadedStrings #-}
+{-# language QuasiQuotes #-}
+
+module CosmicCalendar where
+
+import Rebase.Prelude
+import qualified Rebase.Prelude as Prelude
+import Control.Lens hiding ((<|))
+import Data.Foldable (toList)
+import Data.Ratio
+import Text.Printf
+import Data.Time.Calendar.OrdinalDate
+import Data.Time.LocalTime
+import Control.Monad.RWS
+import Data.Time.Calendar.OrdinalDate
+import Data.Text.Format.Numbers
+import NeatInterpolation
+import qualified Data.Text as Text
+import Data.Text (Text, pack, unpack)
+
+import Rebase.Data.Map.Strict (Map)
+import qualified Rebase.Data.Map.Strict as Map
+
+-- 13.787±0.020 billion years.  Source: https://en.wikipedia.org/wiki/Age_of_the_universe#cite_note-Planck_2018-2
+ageOfUniverseInYears :: Integer
+ageOfUniverseInYears = 13787 * 1000 * 1000
+
+-- The point of the cosmic calendar is to mentally visualize or model the scale
+-- of cosmic/geologic/evolutionary events using the existing internal mental
+-- model of the year. This internal mental model of the year is NOT a 365.2422
+-- day earth rotation, but a 365 day calendar year.
+--
+-- In order to make the math of the calendar work out, the functions that look
+-- up calendary entries (and take as input the LocalTime) must check for leap
+-- year, and subtract one day from the input if it is later than February.
+daysPerYear :: NominalDiffTime
+daysPerYear = 365 -- NOT 365.2422
+
+lengthOfDay :: NominalDiffTime
+lengthOfDay = 24 * 60 * 60
+
+lengthOfYear :: NominalDiffTime
+lengthOfYear = daysPerYear * lengthOfDay
+
+ageOfUniverse :: NominalDiffTime
+ageOfUniverse = fromIntegral ageOfUniverseInYears * lengthOfYear
+
+data CalendarEntry = CalendarEntry {
+  calBeginTime :: NominalDiffTime,
+  calEndTime :: Maybe NominalDiffTime,
+  calTitle :: Text,
+  calSubtitle :: Text,
+  calDescription :: Text,
+  calReferences :: Text
+} deriving (Show)
+
+-- TODO: Encode the input times like so:
+--
+-- data CosmicTime = YearsAgo Rational | YearsAfterBigBang Rational | YearsBCE Rational | YearsCE Rational
+--
+-- The absolute time values (YearsBCE and YearsCE) will be computed using the
+-- year at program start:
+
+currentYear :: Integer
+currentYear = unsafePerformIO $ getZonedTime <&> toGregorian . localDay . zonedTimeToLocalTime <&> view _1
+
+years :: Rational -> NominalDiffTime
+years = (* lengthOfYear) . fromRational
+
+yearsAgo :: Rational -> NominalDiffTime
+yearsAgo (fromRational -> n) = lengthOfYear * (1 - (n / fromIntegral ageOfUniverseInYears))
+
+afterBigBang :: NominalDiffTime -> NominalDiffTime
+afterBigBang = (/ ageOfUniverse) . (* lengthOfYear)
+
+thousandYears :: Rational -> NominalDiffTime
+thousandYears = years . (* 1000)
+
+millionYears :: Rational -> NominalDiffTime
+millionYears = thousandYearsAgo . (* 1000)
+
+billionYears :: Rational -> NominalDiffTime
+billionYears = millionYearsAgo . (* 1000)
+
+thousandYearsAgo :: Rational -> NominalDiffTime
+thousandYearsAgo = yearsAgo . (* 1000)
+
+millionYearsAgo :: Rational -> NominalDiffTime
+millionYearsAgo = thousandYearsAgo . (* 1000)
+
+billionYearsAgo :: Rational -> NominalDiffTime
+billionYearsAgo = millionYearsAgo . (* 1000)
+
+yearStart :: LocalTime -> LocalTime
+yearStart (LocalTime d _) = LocalTime d' t'
+  where
+    d' = fromGregorian y 1 1
+    t' = TimeOfDay 0 0 0
+    (y, _, _) = toGregorian d
+
+localTimeToYearElapsed :: LocalTime -> NominalDiffTime
+localTimeToYearElapsed t = t `diffLocalTime` yearStart t
+
+getPreviousCalendarEntry :: Calendar -> LocalTime -> Maybe CalendarEntry
+getPreviousCalendarEntry cal (localTimeToYearElapsed -> t) = snd <$> Map.lookupLT t cal
+
+getCurrentCalendarEntry :: Calendar -> LocalTime -> Maybe CalendarEntry
+getCurrentCalendarEntry cal (localTimeToYearElapsed -> t) = snd <$> Map.lookupLE t cal
+
+type Calendar = Map NominalDiffTime CalendarEntry
+
+getNextCalendarEntry :: Calendar -> LocalTime -> Maybe CalendarEntry
+getNextCalendarEntry cal (localTimeToYearElapsed -> t) = snd <$> Map.lookupGT t cal
+
+buildCalendar :: [CalendarEntry] -> Map NominalDiffTime CalendarEntry
+buildCalendar ls = Map.fromList $ map (\x -> (calBeginTime x, x)) $ map unwrap ls
+
+unwrap :: CalendarEntry -> CalendarEntry
+unwrap x@CalendarEntry{..} = x { calDescription = unwrapText calDescription }
+  where
+    unwrapText :: Text -> Text
+    unwrapText = pack . unlines . map unwords . foldr process [] . lines . unpack
+    process line [] = [[line]]
+    process line ((x:xs):ys) | shouldMerge line x = (line:x:xs):ys
+    process line rest = [line]:rest
+    shouldMerge :: String -> String -> Bool
+    shouldMerge "" _ = False
+    shouldMerge _ "" = False
+    shouldMerge _ _  = True