Second Big Bang

Main.hs

@@ -1,10 +1,19 @@
 module Main2 where
 
 import System.Random
+import Data.List
 import Packs
 
 data Timestamp = Ts Integer Integer Integer
-data DataPack = Dp String Integer deriving (Eq, Show)
+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
@@ -15,6 +24,15 @@ 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
 
@@ -57,13 +75,13 @@ setLegalTimer d = setTimer 3 d
 setInRotTimer :: DataPack -> DataPack
 setInRotTimer d = setTimer (-1) d
 
-dropOldestLegal :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+dropOldestLegal :: State -> State
-dropOldestLegal (p, l, r) = (newPool, (drop 2 l), r) 
+dropOldestLegal (l, p, b, r) = ((drop 2 l), newPool, b, r) 
    where
       newPool = p ++ (map setLegalTimer (take 2 l))
 
-addNewPack :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+addNewPack :: State -> State
-addNewPack (p, l, r) = (pPool, l ++ [(setInRotTimer nPack)], nR)
+addNewPack (l, p, b, r) = (l ++ [(setInRotTimer nPack)], pPool, b, nR)
    where
       nPool = length $ legalPoolChoices p
       (iPack, nR) = randomR (0, nPool-1) r
@@ -71,8 +89,16 @@ addNewPack (p, l, r) = (pPool, l ++ [(setInRotTimer nPack)], nR)
       nPackName = (\(Dp n _) -> n) nPack
       pPool = filter (\(Dp n _) -> n /= nPackName) p
 
-newRotation :: ([DataPack], [DataPack], StdGen) -> ([DataPack], [DataPack], StdGen)
+rotate :: Integer -> [a] -> [a]
-newRotation (p, l, r) = addNewPack . addNewPack $ dropOldestLegal (updatePackAge p, l, r)
+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
@@ -80,26 +106,36 @@ 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 :: Timestamp -> State
-getCurrentRotation t = strictApplyN n newRotation initialRotation
+getCurrentRotation t = strictApplyN n newRotation initialState
    where
       n = t `monthsSince` initialTimestamp
 
-getPreview :: Timestamp -> ([DataPack], [DataPack], StdGen) -> Maybe ([DataPack], [DataPack])
+type Preview = ([DataPack], [DataPack], BigBox, BigBox)
-getPreview n (p, l, r)
+
-   | isPreviewSeason n = Just $ diffRot nl l
+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
-      (_, nl, _) = newRotation (p, l, r)
+      packsChange = diffRot nl l
+      (nl, _, _, _) = newRotation (l, p, b, r)
+
+cleanMaybe :: BigBox -> [String]
+cleanMaybe (Bb (Just x)) = [x]
+cleanMaybe (Bb Nothing) = []
+
+printPreview :: Preview -> [String]
+printPreview (i, o, bi, bo) = [
+     ("In : " ++ (intercalate ", " $ (cleanDP i) ++ cbi))
+   , ("Out: " ++ (intercalate ", " $ (cleanDP o) ++ cbo))
+   ]      
+   where
+      rmEmp = filter (/="")
+      cbi = cleanMaybe bi
+      cbo = cleanMaybe bo
+      cleanDP = map (\(Dp n _) -> n)

Packs.hs

@@ -1,6 +1,5 @@
 module Packs where
 
-
 bigBoxes :: [String]
 bigBoxes = [
      "Creation and Control"

Test.hs

@@ -0,0 +1,4 @@
+cleanMaybe :: Maybe String -> [String]
+cleanMaybe (Just x) = [x]
+cleanMaybe Nothing = []
+