Haskell: DDCC2017 qual

流石に競技中は C++ を使ったけど Haskell で解き直した。

A 問題

main = getLine >>= putStrLn . yesno . solve
 
yesno :: Bool -> String
yesno True = "Yes"
yesno False = "No"
 
solve :: String -> Bool
solve [a, b, c, d] = a == b && b /= c && c == d

B 問題

A 問題の方が本当のプログラミング初心者にとっては難しいのはないだろうか。12 進表記と見なせて foldl が使える。

{-# LANGUAGE ScopedTypeVariables #-}
main = getLine >>= print . foldl1 (\x y -> x*12 + y) . map (read :: String -> Int) . words

C 問題

二分探索で書いた。ソートしてから先頭 x 個を切り出し、all (< c) $ zipWith (+) a (reverse a) ならば OK。

import Control.Monad
import Data.List
 
main = do
  [n, c] <- map read . words <$> getLine
  replicateM n readLn >>= print . (solve c) . sort
 
solve :: Int -> [Int] -> Int
solve c a = let x = binarySearch f 0 (n + 1) in n - x + (x + 1) `div` 2
  where
    n = length a
    f :: Int -> Bool
    f x = let a' = take x a in all (< c) $ zipWith (+) a' (reverse a')
 
binarySearch :: (Int -> Bool) -> Int -> Int -> Int
binarySearch f ok ng
  | ng - ok == 1 = ok
  | otherwise    = let mid = (ok + ng) `div` 2
                   in if f mid then binarySearch f mid ng
                               else binarySearch f ok mid

D 問題

実装をいかにミスらないようにするかが本質の問題だった。初期状態で余分なマスが存在するか否かでスコアが変わるので注意。

import Control.Applicative
import Control.Monad
import Data.List
 
main = do
  [h, w] <- map read . words <$> getLine
  [a, b] <- map read . words <$> getLine
  g <- replicateM h getLine
  print $ solve g a b
 
solve :: [String] -> Int -> Int -> Int
solve g a b = max scoreA scoreB
  where
    scoreA = foo (makeQuad g) a b
    scoreB = foo (makeQuad . transpose $ g) b a
 
foo :: [(Char, Char, Char, Char)] -> Int -> Int -> Int
foo g a b = let (s, d) = foldl' f (0, 10^9) g in s + a + b - d
  where
    f :: (Int, Int) -> (Char, Char, Char, Char) -> (Int, Int)
    f (s, d) (a00, a10, a01, a11)
      | c == 0                               = (s, d)
      | c == 1                               = (s, 0)
      | c == 2 && (a00 == a11 || a10 == a01) = (s, 0)
      | c == 2 && (a00 == a01 || a10 == a11) = (s, 0)
      | c == 2 && (a00 == a10 || a01 == a11) = (s + a, min d a)
      | c == 3                               = (s + a, 0)
      | otherwise                            = (s + a + b + max a b, min d (a + b))
      where c = sum . map toint $ [a00, a10, a01, a11]
      
toint :: Char -> Int
toint 'S' = 1
toint '.' = 0
 
makeQuad :: [String] -> [(Char, Char, Char, Char)]
makeQuad g = zip4 a00 a10 a01 a11
  where
    a00 = concat . quarter $ g
    a10 = concat . quarter . reverse $ g
    a01 = concat . quarter . map reverse $ g
    a11 = concat . quarter . map reverse . reverse $ g
 
quarter :: [String] -> [String]
quarter g = let h = length g; w = length . head $ g
            in take (h `div` 2) . map (take $ w `div` 2) $ g