Initial Big Bang

Main.hs

@@ -0,0 +1,105 @@
+module Main2 where
+
+import System.Random
+import Packs
+
+data Timestamp = Ts Integer Integer Integer
+data DataPack = Dp String Integer deriving (Eq, Show)
+
+initialTimestamp :: Timestamp
+initialTimestamp = Ts 29 09 1996
+
+seed :: Int
+seed = 69420
+
+initialRNG :: StdGen
+initialRNG = mkStdGen $ seed
+
+isPreviewSeason :: Timestamp -> Bool
+isPreviewSeason (Ts x _ _) = x >= 20
+
+inFuture :: Timestamp -> Timestamp -> Bool
+inFuture (Ts d1 m1 y1) (Ts d2 m2 y2)
+   | y1 /= y2 = y1 > y2
+   | m1 /= m2 = m1 > m2
+   | d1 /= d2 = d1 > d2
+   | otherwise = False
+
+monthsSince :: Timestamp -> Timestamp -> Integer
+monthsSince (Ts d1 m1 y1) (Ts d2 m2 y2)
+   | t1 `inFuture` t2 = (12 * (y1 - y2)) + (m1 - m2)
+   | otherwise = 0
+   where
+      t1 = Ts d1 m1 y1
+      t2 = Ts d2 m2 y2
+
+createDpList :: Integer -> [String] -> [DataPack]
+createDpList t x = map (\n -> Dp n t) x
+
+createLegalList :: [String] -> [DataPack]
+createLegalList x = createDpList (-1) x
+
+createPoolList :: [String] -> [DataPack]
+createPoolList x = createDpList 0 x
+
+legalPoolChoices :: [DataPack] -> [DataPack]
+legalPoolChoices x = filter (\(Dp _ n) -> n == 0) x
+
+updatePackAge :: [DataPack] -> [DataPack]
+updatePackAge p = map (\(Dp s n) -> (Dp s (max 0 (n-1)))) p
+
+setTimer :: Integer -> DataPack -> DataPack
+setTimer x (Dp n _) = Dp n x
+
+setLegalTimer :: DataPack -> DataPack
+setLegalTimer d = setTimer 3 d
+
+setInRotTimer :: DataPack -> DataPack
+setInRotTimer d = setTimer (-1) d
+
+dropOldestLegal :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+dropOldestLegal (p, l, r) = (newPool, (drop 2 l), r) 
+   where
+      newPool = p ++ (map setLegalTimer (take 2 l))
+
+addNewPack :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+addNewPack (p, l, r) = (pPool, l ++ [(setInRotTimer nPack)], nR)
+   where
+      nPool = length $ legalPoolChoices p
+      (iPack, nR) = randomR (0, nPool-1) r
+      nPack = (legalPoolChoices p) !! iPack
+      nPackName = (\(Dp n _) -> n) nPack
+      pPool = filter (\(Dp n _) -> n /= nPackName) p
+
+newRotation :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+newRotation (p, l, r) = addNewPack . addNewPack $ dropOldestLegal (updatePackAge p, l, r)
+
+changes :: Eq a => [a] -> [a] -> [a]
+changes x y = filter (\n -> not $ n `elem` y) x
+
+diffRot :: [DataPack] -> [DataPack] -> ([DataPack], [DataPack])
+diffRot n o = (changes n o, changes o n)
+
+initialRotation :: ([DataPack], [DataPack], StdGen)
+initialRotation = (
+     (createPoolList $ drop n dataPacks)
+   , (createLegalList $ take n dataPacks)
+   , initialRNG
+   )
+   where n = (length dataPacks) `div` 2
+
+strictApplyN :: Integer -> (a -> a) -> a -> a
+strictApplyN 0 _ x = x
+strictApplyN n f x = strictApplyN (n - 1) f $! (f x)
+
+getCurrentRotation :: Timestamp -> ([DataPack], [DataPack], StdGen)
+getCurrentRotation t = strictApplyN n newRotation initialRotation
+   where
+      n = t `monthsSince` initialTimestamp
+
+getPreview :: Timestamp -> ([DataPack], [DataPack], StdGen) -> Maybe ([DataPack], [DataPack])
+getPreview n (p, l, r)
+   | isPreviewSeason n = Just $ diffRot nl l
+   | otherwise = Nothing
+   where
+      (_, nl, _) = newRotation (p, l, r)

Packs.hs

@@ -0,0 +1,52 @@
+module Packs where
+
+
+bigBoxes :: [String]
+bigBoxes = [
+     "Creation and Control"
+   , "Honor and Profit"
+   , "Order and Chaos"
+   , "Data and Destiny"
+   , "Reign and Reverie"
+   , "Terminal Directive"
+   ]
+
+dataPacks :: [String]
+dataPacks = [
+     "Upstalk"
+   , "The Spaces Between"
+   , "First Contact"
+   , "Up and Over"
+   , "All That Remains"
+   , "The Source"
+   , "The Valley"
+   , "Breaker Bay"
+   , "Chrome City"
+   , "The Underway"
+   , "Old Hollywood"
+   , "The Universe of Tomorrow"
+   , "Kala Ghoda"
+   , "Business First"
+   , "Democracy and Dogma"
+   , "Salsette Island"
+   , "The Liberated Mind"
+   , "Fear the Masses"
+   , "23 Seconds"
+   , "Blood Money"
+   , "Escalation"
+   , "Intervention"
+   , "Martial Law"
+   , "Quorum"
+   , "Daedalus Complex"
+   , "Station One"
+   , "Earth's Scion"
+   , "Blood and Water"
+   , "Free Mars"
+   , "Crimson Dust"
+   , "Sovereign Sight"
+   , "Down the White Nile"
+   , "Council of the Crest"
+   , "The Devil and the Dragon"
+   , "Whispers in Nalubaale"
+   , "Kampala Ascendent"
+   ]