diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a8e37e8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +*.hi +*.o +*.swp +*.aes diff --git a/Config.hs b/Config.hs new file mode 100644 index 0000000..ad8be6c --- /dev/null +++ b/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 diff --git a/Format.hs b/Format.hs new file mode 100644 index 0000000..c7d191e --- /dev/null +++ b/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) diff --git a/Main b/Main new file mode 100755 index 0000000..b2ed0f1 Binary files /dev/null and b/Main differ diff --git a/Main.hs b/Main.hs index 9302d9d..d8597be 100644 --- a/Main.hs +++ b/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| +

CHHF - A Dunedin Netrunner Format +

About +

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: +