diff --git a/.Main.hs.swp b/.Main.hs.swp deleted file mode 100644 index 5bf84e3..0000000 Binary files a/.Main.hs.swp and /dev/null differ diff --git a/Config.hs b/Config.hs new file mode 100644 index 0000000..221bc67 --- /dev/null +++ b/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 diff --git a/Format.hs b/Format.hs new file mode 100644 index 0000000..0181f7d --- /dev/null +++ b/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) diff --git a/Main b/Main deleted file mode 100755 index dd58abd..0000000 Binary files a/Main and /dev/null differ diff --git a/Main.hi b/Main.hi deleted file mode 100644 index cc6f8f0..0000000 Binary files a/Main.hi and /dev/null differ diff --git a/Main.hs b/Main.hs index 6accab5..21a8d7b 100644 --- a/Main.hs +++ b/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 diff --git a/Main.o b/Main.o deleted file mode 100644 index 24ba2fe..0000000 Binary files a/Main.o and /dev/null differ diff --git a/Packs.hi b/Packs.hi deleted file mode 100644 index 3ebae5d..0000000 Binary files a/Packs.hi and /dev/null differ diff --git a/Packs.hs b/Packs.hs index d18b0db..669abe9 100644 --- a/Packs.hs +++ b/Packs.hs @@ -1,51 +1,58 @@ module Packs where -bigBoxes :: [String] -bigBoxes = [ - "Creation and Control" - , "Honor and Profit" - , "Order and Chaos" - , "Data and Destiny" - , "Reign and Reverie" - , "Terminal Directive" - ] +data BigBox = + cc | hp | oc | dd | td | rr -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" - ] +instance Show BigBox where + Show cc = "Creation and Control" + Show hp = "Honor and Profit" + Show oc = "Order and Chaos" + Show dd = "Data and Destiny" + Show td = "Terminal Directive" + Show rr = "Reign and Reverie" + +data DataPack = + lunar1 | lunar2 | lunar3 | lunar4 | lunar5 | lunar6 + | sansan1 | sansan2 | sansan3 | sansan4 | sansan5 | sansan6 + | mumbad1 | mumbad2 | mumbad3 | mumbad4 | mumbad5 | mumbad6 + | flash1 | flash2 | flash3 | flash4 | flash5 | flash6 + | red1 | red2 | red3 | red4 | red5 | red6 + | kitara1 | kitara2 | kitara3 | kitara4 | kitara5 | kitara6 + +instance Show DataPack where + Show lunar1 = "Upstalk" + Show lunar2 = "The Spaces Between" + Show lunar3 = "First Contact" + Show lunar4 = "Up and Over" + Show lunar5 = "All That Remains" + Show lunar6 = "The Source" + Show sansan1 = "The Valley" + Show sansan2 = "Breaker Bay" + Show sansan3 = "Chrome City" + Show sansan4 = "The Underway" + Show sansan5 = "Old Hollywood" + Show sansan6 = "The Universe of Tomorrow" + Show mumbad1 = "Kala Ghoda" + Show mumbad2 = "Business First" + Show mumbad3 = "Democracy and Dogma" + Show mumbad4 = "Salsette Island" + Show mumbad5 = "The Liberated Mind" + Show mumbad6 = "Fear the Masses" + Show flash1 = "23 Seconds" + Show flash2 = "Blood Money" + 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" diff --git a/Packs.o b/Packs.o deleted file mode 100644 index 31f559c..0000000 Binary files a/Packs.o and /dev/null differ diff --git a/Preview.hs b/Preview.hs new file mode 100644 index 0000000..6d8a253 --- /dev/null +++ b/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 diff --git a/State.hs b/State.hs new file mode 100644 index 0000000..ad37f2f --- /dev/null +++ b/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 diff --git a/Timestamp.hs b/Timestamp.hs new file mode 100644 index 0000000..756691a --- /dev/null +++ b/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