1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
{-# 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
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
|
