2016 Facebook Hacker Cup Round 3 A/B/C (CF.Gym)

fhc/2016r3/A.hs

@@ -0,0 +1,44 @@
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Text.Printf
+
+newtype Matrix a = Matrix [[a]]
+  deriving (Show)
+
+instance Num a => Num (Matrix a) where
+  Matrix a + Matrix b = Matrix $ zipWith (zipWith (+)) a b
+  Matrix a - Matrix b = Matrix $ zipWith (zipWith (-)) a b
+  Matrix a * Matrix b =
+    Matrix [[sum $ zipWith (*) i j | j <- transpose b] | i <- a]
+  abs = undefined
+  signum = undefined
+  fromInteger n = Matrix [[fromInteger n, 0], [0, fromInteger n]]
+    -- I am cheating here @fromInteger 1@ will be called in 'pow'
+
+solve :: (Int, Double, Double, Double, Double) -> Double
+solve (n, ww, wb, lw, lb)
+  | n == 1 = ww
+  | otherwise = ansx
+  where
+  wx = max ww wb
+  wy = max (1 - ww) (1 - wb)
+  lx = max lw lb
+  ly = max (1 - lw) (1 - lb)
+  firstRound = Matrix [[lw], [1 - lw]]
+  middleRound = Matrix [[lx, 1 - ly], [1 - lx, ly]]
+  lastRound = Matrix [[wx, 1 - wy], [1 - wx, wy]]
+  Matrix [[ansx], [_]] = lastRound * middleRound ^ (n - 2) * firstRound
+
+main :: IO ()
+main = do
+  re <- read <$> getLine
+  forM_ [1::Int .. re] $ \ri -> do
+    ans <- solve <$> getInput
+    printf "Case #%d: %.20f\n" ri ans
+  where
+  getInput = do
+    n <- read <$> getLine
+    (ww:wb:_) <- map read . words <$> getLine
+    (lw:lb:_) <- map read . words <$> getLine
+    return (n, ww, wb, lw, lb)

fhc/2016r3/B.hs

@@ -0,0 +1,52 @@
+import Control.Applicative
+import Control.Monad
+import Data.Array.Unboxed
+import qualified Data.IntMap as Map
+import Data.List
+
+-- Assume:
+--  A   B    C    D
+-- _|   |_    _  _
+--           |    |
+
+solve :: (Int, Int, Int, [[Char]]) -> Int
+solve (nrow, ncol, limit, grid) = total - maximum (elems dpn)
+  where
+  total = nrow * (ncol - 1) + ncol * (nrow - 1)
+  dp0 = listArray (0, limit) $ repeat 0
+  dpn = foldl' next dp0 $ rows ++ cols
+  rows = map (gao $ \c -> c == 'A' || c == 'D') grid
+  cols = map (gao $ \c -> c == 'A' || c == 'B') (transpose grid)
+
+  next :: UArray Int Int -> [Int] -> UArray Int Int
+  next pre cost = {-# SCC next #-} listArray (0, limit) $
+    [ maximum [pre!(i-j) + k | (j, k) <- takeWhile ((<=i) . fst) cost']
+    | i <- [0..limit]
+    ]
+    where
+    -- constant optimization
+    cost' = Map.toList $ Map.fromListWith max $ cost `zip` [0..]
+
+gao :: (Char -> Bool) -> [Char] -> [Int]
+gao _ [] = undefined
+gao isLeft (x:xs) = {-# SCC gao #-} go xs (toLeft x [0]) (toRight x [0])
+  where
+  toLeft c = if isLeft c then id else map (+1)
+  toRight c = if isLeft c then map (+1) else id
+  go [] left right = zipWith min left right
+  go (c:cs) left right = go cs (toLeft c left') (toRight c right')
+    where
+    left' = zipWith min (0: left) (right ++ [maxBound])
+    right' = 0: zipWith min left right
+
+main :: IO ()
+main = do
+  re <- read <$> getLine
+  forM_ [1 .. re] $ \ri -> do
+    ans <- solve <$> getInput
+    putStrLn $ "Case #" ++ show ri ++ ": " ++ show ans
+  where
+  getInput = do
+    (m:n:k:_) <- map read . words <$> getLine
+    a <- replicateM m $ take n <$> getLine
+    return (m, n, k, a)

fhc/2016r3/C.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE BangPatterns #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Data.Bits
+import Data.Function
+import Data.Int (Int64)
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Word (Word64)
+import qualified Data.ByteString.Char8 as C
+
+newtype Max a = Max { getMax :: a }
+  deriving (Show)
+
+instance (Bounded a, Ord a) => Monoid (Max a) where
+  mempty = Max minBound
+  Max a `mappend` Max b = Max $ max a b
+
+solve :: (Int, [(Int, Int)]) -> Int
+solve (s0, p0) = gao p `max` gao p'
+  where
+  s = fromIntegral s0
+  p = map (\i@((x,_):_) -> (x, map snd i)) $
+    groupBy ((==) `on` fst) $ sort $ map (fromIntegral *** fromIntegral) p0
+  p' = reverse $ map (first negate) p
+
+  toWord64 :: Int64 -> Word64
+  toWord64 = let offset = 2 ^ 60 in fromIntegral . (offset+)
+
+  gao a = let ans = evalState go (Nil, Nil) in maximum ans
+    where
+    go = forM a $ \(x, ts) -> do
+      from <- forM ts $ \t -> do
+        let y = toWord64 $ x - s * t
+        Max ret <- gets $ query y . fst
+        modify $ first $ bump y
+        return $ max ret 0
+      to <- fmap reverse $ forM (reverse ts) $ \t -> do
+        let y = toWord64 $ x + s * t
+        Max ret <- gets $ query y . snd
+        modify $ second $ bump y
+        return $ max ret 0
+      let from' = scanl1 max $ zipWith (-) from [0..]
+          to' = zipWith (+) to [1..]
+      return $ maximum $ zipWith (+) from' to'
+
+main :: IO ()
+main = do
+  re <- readInt <$> C.getLine
+  forM_ [1 .. re] $ \ri -> do
+    ans <- solve <$> getInput
+    putStrLn $ "Case #" ++ show ri ++ ": " ++ show ans
+  where
+  readInt = fst . fromJust . C.readInt
+  getPair = do
+    (a:b:_) <- map readInt . C.words <$> C.getLine
+    return (a, b)
+  getInput = do
+    (n, s) <- getPair
+    p <- replicateM n getPair
+    return (s, p)
+
+-- -----------------------------------------------------------------------------
+-- IntMap-like Tree
+
+data Tree a
+  = Bin {-# UNPACK #-} !Word64    -- ^ Prefix
+        {-# UNPACK #-} !Word64    -- ^ Mask
+        !(Max a)                  -- ^ Aggregate value
+        !(Tree a)                 -- ^ Left
+        !(Tree a)                 -- ^ Right
+  | Tip {-# UNPACK #-} !Word64    -- ^ Key
+        !a                        -- ^ Value
+  | Nil
+
+getValue :: (Bounded a, Ord a) => Tree a -> Max a
+getValue !root = case root of
+  Bin _ _ value _ _ -> value
+  Tip _ value -> Max value
+  Nil -> mempty
+
+prefixMask :: Word64 -> Word64 -> (Word64, Word64)
+prefixMask !a !b = (prefix, mask)
+  where
+  !prefix = a .&. b .&. complement (mask - 1)
+  !mask = m `xor` (m `unsafeShiftR` 1)
+    where
+    m = f 32 . f 16 . f 8 . f 4 . f 2 . f 1 $ a `xor` b
+    f !k !i = i .|. unsafeShiftR i k
+
+-- a_k += 1
+bump :: (Bounded a, Num a, Ord a) => Word64 -> Tree a -> Tree a
+bump !k = go
+  where
+  go bin@(Bin prefix mask v l r)
+    | k < prefix = Bin prefix' mask' v (Tip k 1) bin
+    | k >= prefix + (mask `unsafeShiftL` 1) = Bin prefix' mask' v bin (Tip k 1)
+    | k .&. mask == 0 = let t = go l in Bin prefix mask (v <> getValue t) t r
+    | otherwise = let t = go r in Bin prefix mask (v <> getValue t) l t
+    where
+    (prefix', mask') = prefixMask prefix k
+  go tip@(Tip i v)
+    | i < k = Bin prefix mask (Max v) tip (Tip k 1)
+    | i > k = Bin prefix mask (Max v) (Tip k 1) tip
+    | otherwise = Tip k $ v + 1
+    where
+    (prefix, mask) = prefixMask i k
+  go Nil = Tip k 1
+
+-- max_{i>=k}{a_i}
+query :: (Bounded a, Num a, Ord a) => Word64 -> Tree a -> Max a
+query !k = go
+  where
+  go (Bin prefix mask v l r)
+    | k <= prefix = v
+    | k >= prefix + (mask `unsafeShiftL` 1) = mempty
+    | k .&. mask == 0 = query k l <> getValue r
+    | otherwise = query k r
+  go (Tip i v)
+    | i >= k = Max v
+    | otherwise = mempty
+  go Nil = mempty
+
+-- #30: 11044 ms  76100 KB
+-- #40: 19560 ms  77100 KB
+-- #48: 28484 ms  68900 KB
+
+-- > prefix + (mask `unsafeShiftL` 1)
+-- is faster than
+-- > prefix + mask + mask

fhc/2016r3/Tree.qc.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE BangPatterns #-}
+
+import Data.Bits
+import Data.Monoid
+import Data.Word (Word64)
+import Text.Printf
+import qualified Data.Map.Strict as Map
+import Test.QuickCheck (quickCheck)
+
+newtype Max a = Max { getMax :: a }
+  deriving (Eq, Show)
+
+instance (Bounded a, Ord a) => Monoid (Max a) where
+  mempty = Max minBound
+  Max a `mappend` Max b = Max $ max a b
+
+data Tree a
+  = Bin {-# UNPACK #-} !Word64    -- ^ Prefix
+        {-# UNPACK #-} !Word64    -- ^ Mask
+        !(Max a)                  -- ^ Aggregate value
+        !(Tree a)                 -- ^ Left
+        !(Tree a)                 -- ^ Right
+  | Tip {-# UNPACK #-} !Word64    -- ^ Key
+        !a                        -- ^ Value
+  | Nil
+
+instance (PrintfArg a, Show a) => Show (Tree a) where
+  show (Bin prefix mask v l r) =
+    printf "Bin %04b %04b (%d)\n%s%s" prefix mask (getMax v) (f l) (f r)
+    where
+    f = unlines . map ("  "++) . lines . show
+  show (Tip k v) = printf "Tip %04b %d (%d)" k k v
+  show Nil = "Nil"
+
+getValue :: (Bounded a, Ord a) => Tree a -> Max a
+getValue !root = case root of
+  Bin _ _ value _ _ -> value
+  Tip _ value -> Max value
+  Nil -> mempty
+
+prefixMask :: Word64 -> Word64 -> (Word64, Word64)
+prefixMask !a !b = (prefix, mask)
+  where
+  prefix = a .&. b .&. (complement $ mask - 1)
+  mask = (f 32 . f 16 . f 8 . f 4 . f 2 . f 1 $ a `xor` b) `unsafeShiftR` 1 + 1
+  f !k !i = i .|. unsafeShiftR i k
+
+-- a_k += 1
+bump :: (Bounded a, Num a, Ord a) => Word64 -> Tree a -> Tree a
+bump !k = go
+  where
+  go bin@(Bin prefix mask v l r)
+    | k < prefix = Bin prefix' mask' (v <> Max 1) (Tip k 1) bin
+    | k >= prefix + mask + mask = Bin prefix' mask' (v <> Max 1) bin (Tip k 1)
+    | k .&. mask == 0 = let t = go l in Bin prefix mask (v <> getValue t) t r
+    | otherwise = let t = go r in Bin prefix mask (v <> getValue t) l t
+    where
+    (prefix', mask') = prefixMask prefix k
+  go tip@(Tip i v)
+    | i < k = Bin prefix mask (Max v) tip (Tip k 1)
+    | i > k = Bin prefix mask (Max v) (Tip k 1) tip
+    | otherwise = Tip k $ v + 1
+    where
+    (prefix, mask) = prefixMask i k
+  go Nil = Tip k 1
+
+-- max_{i>=k}{a_i}
+query :: (Bounded a, Num a, Ord a) => Word64 -> Tree a -> Max a
+query !k = go
+  where
+  go (Bin prefix mask v l r)
+    | k <= prefix = v
+    | k >= prefix + mask + mask = mempty
+    | k .&. mask == 0 = query k l <> getValue r
+    | otherwise = query k r
+  go (Tip i v)
+    | i >= k = Max v
+    | otherwise = mempty
+  go Nil = mempty
+
+test :: [Word64] -> [Word64] -> Bool
+test x y =
+  all (\i -> query i t == mconcat [Max v | (k, v) <- Map.toList m, k >= i]) y
+  where
+  t = foldr bump Nil x
+  m = Map.fromListWith (+) $ x `zip` repeat (1 :: Int)
+
+main :: IO ()
+main = quickCheck test