Salsa helpers (version 2)

salsa.ch

import Control.Monad
import Data.List
import Data.Ord
import Text.Printf

men =
  [ (3, 3),
    (1, 3),
    (3, 3),
    (3, 3),
    (3, 3),
    (3, 3),
    (1, 1),
    (2, 2),
    (1, 1),
    (3, 3),
    (2, 2) -- ,
    -- (6, 6),
    -- (6, 7),
    -- (4, 7),
    -- (5, 6),
    -- (7, 7),
    -- (7, 7),
    -- (3, 7),
    -- (2, 2),
    -- (4, 5),
    -- (6, 7),
    -- (7, 7),
    -- (4, 7)
  ]

women =
  [ (2, 2),
    (3, 3),
    (0, 3),
    (3, 3),
    (2, 2),
    (2, 3),
    (1, 2),
    (1, 3),
    (1, 3),
    (1, 2) -- ,
    -- (4, 7),
    -- (5, 7),
    -- (6, 7),
    -- (3, 3),
    -- (4, 7),
    -- (6, 7),
    -- (6, 7),
    -- (6, 7),
    -- (3, 4),
    -- (4, 7),
    -- (7, 7),
    -- (6, 7)
  ]

menShowUps = sum $ map fst men

menSignUps = sum $ map snd men

womenShowUps = sum $ map fst women

womenSignUps = sum $ map snd women

manRate = fromIntegral menShowUps / fromIntegral menSignUps

womanRate = fromIntegral womenShowUps / fromIntegral womenSignUps

factorial n = product [2 .. n]

showupProb :: Double -> Double -> Double -> Double
showupProb rate signups i =
  ( factorial i
      * factorial (signups - i)
      / factorial signups
  )
    * (rate ** i)
    * ((1 - rate) ** (signups - i))

manProb :: Double -> Double -> Double
manProb = showupProb manRate

womanProb :: Double -> Double -> Double
womanProb = showupProb womanRate

combinedProb :: (Double, Double) -> (Double, Double) -> Double
combinedProb (mSignups, wSignups) (m, w) = manProb mSignups m * womanProb wSignups w

trouble :: (Double, Double, Double) -> Double
trouble (m, w, h) =
  balanceTrouble (m - w + h) + helperTrouble (m, w, h)

helperTrouble :: (Double, Double, Double) -> Double
helperTrouble (m, w, h)
  | m + h > w + 2 && h > 0 = 10 * min (abs h) (m + h - w - 2)
  | m < w - h - 2 && h < 0 = 10 * min (abs h) (w - h - m - 2)
  | otherwise = 0

balanceTrouble :: Double -> Double
balanceTrouble x = (x ^^ 2) / 2

evTrouble :: (Double, Double) -> Double -> Double
evTrouble signups@(manSignups, womanSignups) h =
  sum
    [ combinedProb signups (i, j) * trouble (i, j, h)
      | i <- [0 .. manSignups],
        j <- [0 .. womanSignups]
    ]

main :: IO ()
main = do
  putStrLn $ unlines ["Men rate:", printf "%.2f %%" (manRate * 100)]
  putStrLn $ unlines ["Women rate:", printf "%.2f %%" (womanRate * 100)]
  let signups :: (Double, Double)
      --   signups@(manSignups, womanSignups) = (7, 3)
      signups@(manSignups, womanSignups) = (4, 5)
  putStrLn $
    unwords
      [ "If",
        printf "%.0f" manSignups,
        "men and",
        printf "%.0f" womanSignups,
        "women have signed up"
      ]
  let tups = [(h, evTrouble signups h) | h <- [-10 .. 10]]
  forM_ tups $ \(h, t) -> do
    putStrLn $
      unwords
        [ case compare h 0 of
            EQ -> "no helpers:     "
            GT -> "male helpers:   "
            LT -> "female helpers: ",
          show (abs h),
          printf "%.5f" t
        ]

  let (bestH, _) = minimumBy (comparing snd) tups

  putStrLn $
    unwords
      [ "\nThe optimale approach is to invite",
        case compare bestH 0 of
          EQ -> "no helpers"
          GT -> printf "%.0f" bestH <> " men"
          LT -> printf "%.0f" (abs bestH) <> " women"
      ]