Big Change

Config.hs

@@ -0,0 +1,26 @@
+module Config where
+
+genesis :: Timestamp
+genesis = Ts 29 09 1996
+
+seed :: Int
+seed = 69420
+
+entropy :: StdGen
+entropy = mkStdGen $ seed
+
+initialRotation :: State
+initialRotation = ((i, o), b, r)
+   where
+      i = createInRot [
+           lunar1, lunar2, lunar3, lunar4, lunar5, lunar6
+         , sansan1 , sansan2 , sansan3 , sansan4 , sansan5 , sansan6
+         , mumbad1 , mumbad2 , mumbad3 , mumbad4 , mumbad5 , mumbad6
+         ]
+      o = createOutRot [
+           flash1  , flash2  , flash3  , flash4  , flash5  , flash6
+         , red1    , red2    , red3    , red4    , red5    , red6
+         , kitara1 , kitara2 , kitara3 , kitara4 , kitara5 , kitara6
+         ]
+      b = Bq [Just rr, Just td, Just dd, Just oc, Just hp, Just cc, Nothing]
+      r = entropy

Format.hs

@@ -0,0 +1,50 @@
+module Format where
+
+nextFormat :: State -> State
+nextFormat (p, b, r) = (np, nb, nr)
+   where
+      ip = rotateOld p
+      (np, nr) = addNewPack . addNewPack (ip, r)
+      nb = rotateBox b
+
+legalOutRot :: [OutRot] -> [OutRot]
+legalOutRot x = filter (\(Or _ n) -> n == 0) x
+
+updatePackAge :: [OutRot] -> [OutRot]
+updatePackAge p = map (\(Or s n) -> (Or s $ max 0 (n-1)) p
+
+setIllegal :: InRot -> OutRot
+setIllegal (Ir n) = Or n 3
+
+setLegal :: OutRot -> InRot
+setLegal (Or n _) = Ir n
+
+rotateOld :: Pool -> Pool
+rotateOld (i, o) = (ni, no)
+   where
+      ni = drop 2 i
+      no = o ++ dropped
+      dropped = map setIllegal (take 2 i)
+
+addNewPack :: (Pool, StdGen) -> (Pool, StdGen)
+addNewPack ((i, o), r) = ((ni, no), nr)
+   where
+      lp = length $ legalOutRot o
+      (ip, nr) = randomR (0, lp-1) r
+      np = (legalOutRot o) !! ip
+      ni = i ++ (setLegal np)
+      no = filter (\x -> x /= np) o
+
+rotate :: Integer -> [a] -> [a]
+rotate _ [] = []
+rotate n xs = zipWith const (drop (fromIntegral n) (cycle xs)) xs
+
+rotateBox :: BoxQueue -> BoxQueue
+rotateBox (Bq x) = Bq $ rotate 1 x
+
+changes :: Eq a => [a] -> [a] -> [a]
+changes x y = filter (\n -> not $ n `elem` y) x
+
+strictApplyN :: Integer -> (a -> a) -> a -> a
+strictApplyN 0 _ x = x
+strictApplyN n f x = strictApplyN (n - 1) f $! (f x)

Main.hs

@@ -6,150 +6,9 @@ import Data.Maybe
 import Data.Time.Clock
 import Data.Time.Calendar
 import Packs
+import State
 
-data Timestamp = Ts Integer Integer Integer
-data BigBox = Bb (Maybe String) deriving Show
-data DataPack = Dp String Integer deriving Show
-type Legal = [DataPack]
-type Pool = [DataPack]
-type BanQ = [BigBox]
-type State = (Legal, Pool, BanQ, StdGen) 
 
-instance Eq DataPack where
-   (Dp s1 _) == (Dp s2 _) = s1 == s2
-
-initialTimestamp :: Timestamp
-initialTimestamp = Ts 29 09 1996
-
-seed :: Int
-seed = 69420
-
-initialRNG :: StdGen
-initialRNG = mkStdGen $ seed
-
-initialState :: State
-initialState = (
-     (createPoolList $ drop n dataPacks)
-   , (createLegalList $ take n dataPacks)
-   , map (\x -> Bb x) $ (map Just bigBoxes) ++ [Nothing]
-   , initialRNG
-   )
-   where n = (length dataPacks) `div` 2
-
-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 :: State -> State
-dropOldestLegal (l, p, b, r) = ((drop 2 l), newPool, b, r) 
-   where
-      newPool = p ++ (map setLegalTimer (take 2 l))
-
-addNewPack :: State -> State
-addNewPack (l, p, b, r) = (l ++ [(setInRotTimer nPack)], pPool, b, 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
-
-rotate :: Integer -> [a] -> [a]
-rotate _ [] = []
-rotate n xs = zipWith const (drop (fromIntegral n) (cycle xs)) xs
-
-rotateBigBox :: State -> State
-rotateBigBox (l, p, b, r) = (l, p, (rotate 1 b), r)
-
-newRotation :: State -> State
-newRotation (l, p, b, r) =
-   rotateBigBox . addNewPack . addNewPack $ dropOldestLegal (l, updatePackAge p, b, 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)
-
-strictApplyN :: Integer -> (a -> a) -> a -> a
-strictApplyN 0 _ x = x
-strictApplyN n f x = strictApplyN (n - 1) f $! (f x)
-
-getCurrentRotation :: Timestamp -> State
-getCurrentRotation t = strictApplyN n newRotation initialState
-   where
-      n = t `monthsSince` initialTimestamp
-
-type Preview = ([DataPack], [DataPack], BigBox, BigBox)
-
-getPreview :: Timestamp -> State -> Maybe Preview
-getPreview n (l, p, b, r)
-   | isPreviewSeason n = Just $ (fst packsChange, snd packsChange, head (rotate 1 b), head b)
-   | otherwise = Nothing
-   where
-      packsChange = diffRot nl l
-      (nl, _, _, _) = newRotation (l, p, b, r)
-
-printLegal :: State -> [String]
-printLegal (l, p, b, r) = [
-     "Evergreen: Revised Core Set x3"
-   , "Deluxes  : " ++ (intercalate ", " $ sort $ catMaybes (tail $ map (\(Bb x) -> x) b))
-   , "Datapacks: " ++ (intercalate ", " $ sort $ map (\(Dp n _) -> n) l)
-   ]
-
-printPreview :: Maybe Preview -> [String]
-printPreview (Just (i, o, (Bb bi), (Bb bo))) = [
-     "Upcoming Changes:"
-   , ("In : " ++ (intercalate ", " $ (cleanDP i) ++ cbi))
-   , ("Out: " ++ (intercalate ", " $ (cleanDP o) ++ cbo))
-   ]      
-   where
-      rmEmp = filter (/="")
-      cbi = catMaybes [bi]
-      cbo = catMaybes [bo]
-      cleanDP = map (\(Dp n _) -> n)
-printPreview Nothing = []
-
-toTS :: (Integer, Int, Int) -> Timestamp
-toTS (y,m,d) = Ts (fromIntegral d) (fromIntegral m) y
 
 main :: IO ()
 main = do

Packs.hs

@@ -1,51 +1,58 @@
 module Packs where
 
-bigBoxes :: [String]
+data BigBox =
-bigBoxes = [
+   cc | hp | oc | dd | td | rr
-     "Creation and Control"
-   , "Honor and Profit"
-   , "Order and Chaos"
-   , "Data and Destiny"
-   , "Reign and Reverie"
-   , "Terminal Directive"
-   ]
 
-dataPacks :: [String]
+instance Show BigBox where
-dataPacks = [
+   Show cc = "Creation and Control"
-     "Upstalk"
+   Show hp = "Honor and Profit"
-   , "The Spaces Between"
+   Show oc = "Order and Chaos"
-   , "First Contact"
+   Show dd = "Data and Destiny"
-   , "Up and Over"
+   Show td = "Terminal Directive"
-   , "All That Remains"
+   Show rr = "Reign and Reverie"
-   , "The Source"
+
-   , "The Valley"
+data DataPack =
-   , "Breaker Bay"
+     lunar1  | lunar2  | lunar3  | lunar4  | lunar5  | lunar6
-   , "Chrome City"
+   | sansan1 | sansan2 | sansan3 | sansan4 | sansan5 | sansan6
-   , "The Underway"
+   | mumbad1 | mumbad2 | mumbad3 | mumbad4 | mumbad5 | mumbad6
-   , "Old Hollywood"
+   | flash1  | flash2  | flash3  | flash4  | flash5  | flash6
-   , "The Universe of Tomorrow"
+   | red1    | red2    | red3    | red4    | red5    | red6
-   , "Kala Ghoda"
+   | kitara1 | kitara2 | kitara3 | kitara4 | kitara5 | kitara6
-   , "Business First"
+
-   , "Democracy and Dogma"
+instance Show DataPack where
-   , "Salsette Island"
+   Show lunar1 = "Upstalk"
-   , "The Liberated Mind"
+   Show lunar2 = "The Spaces Between"
-   , "Fear the Masses"
+   Show lunar3 = "First Contact"
-   , "23 Seconds"
+   Show lunar4 = "Up and Over"
-   , "Blood Money"
+   Show lunar5 = "All That Remains"
-   , "Escalation"
+   Show lunar6 = "The Source"
-   , "Intervention"
+   Show sansan1 = "The Valley"
-   , "Martial Law"
+   Show sansan2 = "Breaker Bay"
-   , "Quorum"
+   Show sansan3 = "Chrome City"
-   , "Daedalus Complex"
+   Show sansan4 = "The Underway"
-   , "Station One"
+   Show sansan5 = "Old Hollywood"
-   , "Earth's Scion"
+   Show sansan6 = "The Universe of Tomorrow"
-   , "Blood and Water"
+   Show mumbad1 = "Kala Ghoda"
-   , "Free Mars"
+   Show mumbad2 = "Business First"
-   , "Crimson Dust"
+   Show mumbad3 = "Democracy and Dogma"
-   , "Sovereign Sight"
+   Show mumbad4 = "Salsette Island"
-   , "Down the White Nile"
+   Show mumbad5 = "The Liberated Mind"
-   , "Council of the Crest"
+   Show mumbad6 = "Fear the Masses"
-   , "The Devil and the Dragon"
+   Show flash1 = "23 Seconds"
-   , "Whispers in Nalubaale"
+   Show flash2 = "Blood Money"
-   , "Kampala Ascendent"
+   Show flash3 = "Escalation"
-   ]
+   Show flash4 = "Intervention"
+   Show flash5 = "Martial Law"
+   Show flash6 = "Quorum"
+   Show red1 = "Daedalus Complex"
+   Show red2 = "Station One"
+   Show red3 = "Earth's Scion"
+   Show red4 = "Blood and Water"
+   Show red5 = "Free Mars"
+   Show red6 = "Crimson Dust"
+   Show kitara1 = "Sovereign Sight"
+   Show kitara2 = "Down the White Nile"
+   Show kitara3 = "Council of the Crest"
+   Show kitara4 = "The Devil and the Dragon"
+   Show kitara5 = "Whispers in Nalubaale"
+   Show kitara6 = "Kampala Ascendent"

Preview.hs

@@ -0,0 +1,32 @@
+type Preview = ([DataPack], [DataPack], BigBox, BigBox)
+
+getPreview :: Timestamp -> State -> Maybe Preview
+getPreview n (l, p, b, r)
+   | isPreviewSeason n = Just $ (fst packsChange, snd packsChange, head (rotate 1 b), head b)
+   | otherwise = Nothing
+   where
+      packsChange = diffRot nl l
+      (nl, _, _, _) = newRotation (l, p, b, r)
+
+printLegal :: State -> [String]
+printLegal (l, p, b, r) = [
+     "Evergreen: Revised Core Set x3"
+   , "Deluxes  : " ++ (intercalate ", " $ sort $ catMaybes (tail $ map (\(Bb x) -> x) b))
+   , "Datapacks: " ++ (intercalate ", " $ sort $ map (\(Dp n _) -> n) l)
+   ]
+
+printPreview :: Maybe Preview -> [String]
+printPreview (Just (i, o, (Bb bi), (Bb bo))) = [
+     "Upcoming Changes:"
+   , ("In : " ++ (intercalate ", " $ (cleanDP i) ++ cbi))
+   , ("Out: " ++ (intercalate ", " $ (cleanDP o) ++ cbo))
+   ]
+   where
+      rmEmp = filter (/="")
+      cbi = catMaybes [bi]
+      cbo = catMaybes [bo]
+      cleanDP = map (\(Dp n _) -> n)
+printPreview Nothing = []
+
+toTS :: (Integer, Int, Int) -> Timestamp
+toTS (y,m,d) = Ts (fromIntegral d) (fromIntegral m) y

State.hs

@@ -0,0 +1,17 @@
+module State where
+
+data Timestamp = Ts Integer Integer Integer
+
+type State = (Pool, BoxQueue, StdGen)
+
+data InRot = Ir DataPack
+data OutRot = Or DataPack Integer
+data BoxQueue = Bq [Maybe BigBox]
+
+type Pool = ([InRot], [OutRot])
+
+createInRot :: [DataPack] -> [InRot]
+createInRot x = map (\n -> Ir n) x
+
+createOutRot :: [DataPack] -> [OutRot]
+createOutRot x = map (\n -> Or n 0) x

Timestamp.hs

@@ -0,0 +1,19 @@
+module Timestamp where
+
+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