Week 12

cis194/week12/zhansongl/Risk.hs

@@ -0,0 +1,96 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Risk where
+
+import Control.Monad (replicateM)
+import Data.List (sortBy, sort, group)
+--import Debug.Trace (trace)
+import System.Random (StdGen)
+
+-- monadrandom
+import Control.Monad.Random (MonadRandom(..), Random(..), Rand)
+-- monad-loops
+import Control.Monad.Loops (iterateUntilM)
+
+------------------------------------------------------------
+-- Die values
+
+newtype DieValue = DV { unDV :: Int } 
+  deriving (Eq, Ord, Show, Num)
+
+first :: (a -> b) -> (a, c) -> (b, c)
+first f (a, c) = (f a, c)
+
+instance Random DieValue where
+  random           = first DV . randomR (1,6)
+  randomR (low,hi) = first DV . randomR (max 1 (unDV low), min 6 (unDV hi))
+
+die :: Rand StdGen DieValue
+die = getRandom
+
+------------------------------------------------------------
+-- Risk
+
+type Army = Int
+
+data Battlefield = Battlefield { attackers :: Army, defenders :: Army }
+  deriving (Show, Eq)
+
+battleOutcome :: Battlefield -> [DieValue] -> [DieValue] -> Battlefield
+battleOutcome field attackRolls defendRolls = Battlefield attackOutcome defendOutcome
+  where attackOutcome = attackers field - (length . filter not $ result)
+        defendOutcome = defenders field - (length . filter id $ result)
+        result = zipWith (>) attackRollsSorted defendRollsSorted
+        attackRollsSorted = sortBy (flip compare) attackRolls
+        defendRollsSorted = sortBy (flip compare) defendRolls
+
+battle :: Battlefield -> Rand StdGen Battlefield
+battle field
+  | (attackers field <= 1 || defenders field <= 0) = pure field
+  | otherwise = replicateM attackArmy die >>= \attackRolls ->
+                replicateM defendArmy die >>= \defendRolls ->
+                pure $ battleOutcome field attackRolls defendRolls
+      where attackArmy = min 3 (attackers field - 1)
+            defendArmy = min 2 (defenders field)
+
+invade :: Battlefield -> Rand StdGen Battlefield
+invade = iterateUntilM battleOver battle
+  where battleOver (Battlefield a d) = a <= 1 || d <= 0
+
+successProb :: Battlefield -> Rand StdGen Double
+successProb b = (/) <$> (fromIntegral <$> successCount) <*> pure 10000
+  where rs = replicateM 10000 . invade $ b
+        successCount = (length . filter winning) <$> rs
+        winning (Battlefield a _) = a > 1
+
+cartProd :: [m a] -> [m a] -> [(m a, m a)]
+cartProd o1 o2 = [(x,y) | x <- o1, y <- o2]
+
+outcome :: Int -> [[Int]]
+outcome 0 = []
+outcome 1 = [[1], [2], [3], [4], [5], [6]]
+outcome n = fmap (sortBy $ flip compare) . fmap (uncurry (++)) $ cartProd (outcome 1) (outcome $ n-1)
+
+fightOutcome :: ([Int], [Int]) -> (Int, Int)
+fightOutcome (as, ds) = (aloss, dloss)
+  where r = zipWith (>) as ds
+        dloss = length . filter id $ r
+        aloss = length . filter not $ r
+
+outcomeProb :: Int -> Int -> [(Int, Int, Double)]
+outcomeProb a d = zipWith p (fmap head . group $ r) (fmap length . group $ r)
+  where r = sort . fmap fightOutcome $ cartProd (outcome a) (outcome d)
+        denom = length r
+        p (aloss, dloss) num = (aloss, dloss, fromIntegral num / fromIntegral denom)
+
+exactSuccessProb :: Battlefield -> Double
+exactSuccessProb (Battlefield a d)
+  | a <= 1 = 0
+  | d <= 0 = 1
+  | otherwise = sum
+              . fmap (\(aloss, dloss, prob)
+                      -> (exactSuccessProb $ Battlefield (a - aloss) (d - dloss)) * prob)
+              $ outcomeProb as ds
+  where as = min 3 (a-1)
+        ds = min 2 d

cis194/week12/zhansongl/TestRisk.hs

@@ -0,0 +1,24 @@
+import Risk
+
+import Control.Monad.Trans.Random.Lazy (evalRand)
+import System.Random (mkStdGen)
+
+import Test.Hspec
+
+main = hspec $ do
+  describe "battle" $ do
+    it "should do nothing when there isn't enough attackers" $ do
+      (battle (Battlefield 0 12) `evalRand` mkStdGen 42) `shouldBe` (Battlefield 0 12)
+      (battle (Battlefield 1 12) `evalRand` mkStdGen 42) `shouldBe` (Battlefield 1 12)
+    it "should do nothing when there isn't enough defenders" $ do
+      (battle (Battlefield 12 0) `evalRand` mkStdGen 42) `shouldBe` (Battlefield 12 0)
+
+    describe "battleOutcome" $ do
+      it "should produce the correct outcome given enough attackers and defenders" $ do
+        (battleOutcome (Battlefield 3 5) (fmap DV [3,5]) (fmap DV [4,3])) `shouldBe` (Battlefield 2 4)
+        (battleOutcome (Battlefield 12 12) (fmap DV [1,4,2]) (fmap DV [3,5])) `shouldBe` (Battlefield 10 12)
+
+  describe "invade" $ do
+    it "should battle until either army is depleted" $ do
+      (invade (Battlefield 100 10) `evalRand` mkStdGen 42) `shouldSatisfy` \(Battlefield a d) -> d <= 0
+      (invade (Battlefield 300 10000) `evalRand` mkStdGen 42) `shouldSatisfy` \(Battlefield a d) -> a <= 1