Merge pull request #1 from techieAgnostic/Refactor

Refactor

.gitignore

@@ -0,0 +1,4 @@
+*.hi
+*.o
+*.swp
+*.aes

Config.hs

@@ -0,0 +1,31 @@
+module Config where
+
+import System.Random
+import State
+import Timestamp
+import Packs
+
+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 Cc, Just Hp, Just Oc, Just Dd, Just Td, Just Rr, Nothing]
+      r = entropy

Format.hs

@@ -0,0 +1,58 @@
+module Format where
+
+import System.Random
+import State
+import Timestamp
+import Config
+
+currentFormat :: Timestamp -> State
+currentFormat t = strictApplyN n nextFormat initialRotation
+   where
+      n = t `monthsSince` genesis
+
+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 = (updatePackAge 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 n xs = take lxs . drop ((fromIntegral n) `mod` lxs) . cycle $ xs
+   where
+      lxs = length xs
+
+rotateBox :: BoxQueue -> BoxQueue
+rotateBox (Bq x) = Bq $ rotate 1 x
+
+strictApplyN :: Integer -> (a -> a) -> a -> a
+strictApplyN 0 _ x = x
+strictApplyN n f x = strictApplyN (n - 1) f $! (f x)

Main.hs

@@ -1,105 +1,90 @@
-module Main2 where
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}
 
-import System.Random
+module Main where
+
+import Data.Time.Clock
+import Data.Time.Calendar
+import Data.List
+import Data.Maybe
 import Packs
+import State
+import Format
+import Timestamp
+import Preview
+import Yesod
+import Config
 
-data Timestamp = Ts Integer Integer Integer
-data DataPack = Dp String Integer deriving (Eq, Show)
+data Chhf = Chhf
 
-initialTimestamp :: Timestamp
-initialTimestamp = Ts 29 09 1996
+io :: MonadIO io => IO a -> io a
+io = liftIO
 
-seed :: Int
-seed = 69420
+putStrLnIO :: MonadIO io => String -> io ()
+putStrLnIO = io . putStrLn
 
-initialRNG :: StdGen
-initialRNG = mkStdGen $ seed
+mkYesod "Chhf" [parseRoutes|
+/ HomeR GET
+|]
 
-isPreviewSeason :: Timestamp -> Bool
-isPreviewSeason (Ts x _ _) = x >= 20
+instance Yesod Chhf
 
-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
+inBoth :: (Eq a) => [a] -> [a] -> [a]
+inBoth x y = filter (\n -> n `elem` y) x
 
-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
+getHomeR :: Handler Html
+getHomeR = do
+   t <- io $ getCurrentTime >>= return . toGregorian . utctDay
+   let ts = toTS t
+   let ((i,o),b,r) = currentFormat ts
+   let bx = (\(Bq x) -> x)
+   let (_,ib,_) = initialRotation
+   let bbout = map show $ catMaybes $ inBoth (bx ib) (tail $ bx b)
+   let dpout = sort $ map show $ map (\(Ir n) -> n) i
+   let pr = getPreview ts
+   defaultLayout [whamlet|
+      <h1>CHHF - A Dunedin Netrunner Format
+      <h2>About
+      <p>The Chris Hay Honourary Format, a post-cancellation Netrunner format. #
+         The format consists of 18 packs at any time, and between 5 and 6 big boxes. #
+         The following rotation rules are in place:
+      <ul>
+         <li> Each month, the two packs that have been in rotation longest are rotated out, and two random packs are rotated in
+         <li> After a pack rotates out, it cannot rotate in for 3 months
+         <li> Each month, in release order, one big box (Including Terminal Directive) is banned for the month
+         <li> On the seventh month, all big boxes are legal
+      <p> The rotation updates on the first of each month, based on whatever time my server is set to (Probably NZ time but who knows really), and from the 20th of each month onwards, a preview of the upcoming changes will be shown.
+      <h2>Current Rotation:
+      <h3>Evergreen:
+      <ul>
+         <li>Revised Core Set x3
+      <h3>Big Boxes:
+      <ul>
+         $forall bb <- bbout
+            <li>#{bb}
+      <h3>Data-packs:
+      <ul>
+         $forall dp <- dpout
+            <li>#{dp}
+      <h2>Upcoming Changes:
+      $maybe (pin, pout, pbin, pbout) <- pr
+         <h3>In:
+         <ul>
+            $maybe pbbin <- pbin
+               <li>#{show pbbin}
+            $forall indp <- pin
+               <li>#{show indp}
+         <h3>Out:
+         <ul>
+            $maybe pbbout <- pbout
+               <li>#{show pbbout}
+            $forall outdp <- pout
+               <li>#{show outdp}
+      $nothing
+         <h3>Coming soon!
+   |]
 
-createDpList :: Integer -> [String] -> [DataPack]
-createDpList t x = map (\n -> Dp n t) x
+main :: IO ()
+main = warp 80 Chhf
 
-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)
+toTS :: (Integer, Int, Int) -> Timestamp
+toTS (y,m,d) = Ts (fromIntegral d) (fromIntegral m) y

Packs.hs

@@ -1,52 +1,58 @@
 module Packs where
 
+data BigBox =
+   Cc | Hp | Oc | Dd | Td | Rr deriving Eq
 
-bigBoxes :: [String]
-bigBoxes = [
-     "Creation and Control"
-   , "Honor and Profit"
-   , "Order and Chaos"
-   , "Data and Destiny"
-   , "Reign and Reverie"
-   , "Terminal Directive"
-   ]
+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"
 
-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"
-   ]
+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 deriving Eq
+
+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"

Preview.hs

@@ -0,0 +1,50 @@
+module Preview where
+
+import Data.List
+import Data.Maybe
+import Packs
+import State
+import Timestamp
+import Format
+
+type Preview = ([DataPack], [DataPack], Maybe BigBox, Maybe BigBox)
+
+changes :: Eq a => [a] -> [a] -> [a]
+changes x y = filter (\n -> not $ n `elem` y) x
+
+diffRot :: [InRot] -> [InRot] -> ([DataPack], [DataPack])
+diffRot c f = (packIn, packOut)
+   where
+      packIn = map clean $ changes f c
+      packOut = map clean $ changes c f
+      clean = (\(Ir n) -> n)
+
+getPreview :: Timestamp -> Maybe Preview
+getPreview n
+   | isPreviewSeason n = Just $ (fst packsChange, snd packsChange, head b, head (rotate 1 b))
+   | otherwise = Nothing
+   where
+      ((i,o), (Bq b), r) = currentFormat n
+      packsChange = diffRot i ni
+      ((ni,_),_,_) = nextFormat ((i,o),(Bq b),r)
+
+printLegal :: State -> [String]
+printLegal ((i,o),(Bq b),_) = [
+     "===Evergreen:\nRevised Core Set x3"
+   , "===Deluxes  :\n" ++ (intercalate "\n" $ sort $ map show $ catMaybes (tail b))
+   , "===Datapacks:\n" ++ (intercalate "\n" $ sort $ map show $ map (\(Ir n) -> n) i)
+   ]
+
+printPreview :: Maybe Preview -> [String]
+printPreview (Just (i, o, bi, bo)) = [
+     "===Upcoming Changes:"
+   , ("===In :\n" ++ (intercalate "\n" $ (map show i) ++ (map show cbi)))
+   , ("===Out:\n" ++ (intercalate "\n" $ (map show o) ++ (map show cbo)))
+   ]
+   where
+      rmEmp = filter (/="")
+      cbi = catMaybes [bi]
+      cbo = catMaybes [bo]
+      cleanDP = map (\(Or n _) -> n)
+printPreview Nothing = []
+

State.hs

@@ -0,0 +1,22 @@
+module State where
+
+import System.Random
+import Packs
+
+type State = (Pool, BoxQueue, StdGen)
+
+data InRot = Ir DataPack deriving (Show, Eq)
+
+data OutRot = Or DataPack Integer
+instance Eq OutRot where
+   (Or d1 _) == (Or d2 _) = d1 == d2
+
+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,21 @@
+module Timestamp where
+
+data Timestamp = Ts Integer Integer Integer deriving Show
+
+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