CODE FESTIVAL 2016 Final

Submission #995341

Source codeソースコード

{-# LANGUAGE ScopedTypeVariables #-}
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.DeepSeq
import Data.Array
import Data.Bits
import Data.Char
import Data.Functor.Identity
import Data.List
import Data.Maybe
import Data.Ord
import Data.Tree
import Data.Tuple
import qualified System.IO
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Sequence as Q
import qualified Data.ByteString.Char8 as B
import Data.Array.IO

theMod = 1000000007

swp m i j = do
  x <- readArray m i
  y <- readArray m j
  writeArray m i y
  writeArray m j x

rank :: Array (Z,Z) Z -> IO Z
rank mat0 = do
  let ((1,1),(imax,jmax)) = bounds mat0
  m ::  IOArray (Z,Z) Z <- thaw mat0
  let
    f :: Z -> Z -> IO Z
    f 0 _ = return 0
    f _ 0 = return 0
    f ii jj = do
      v <- sequence [readArray m (ii,j) | j<-[1..jj]]
      if all (== 0) v
      then f (ii-1) jj
      else do
        let j2 = head [j | (j,x) <- zip [1..] v, x/=0] 
        sequence_ [swp m (i,jj) (i,j2) | i<-[1..ii]]
        forM_ [1..ii-1] $ \ i -> do
          x <- readArray m (i,jj)
          when (x/=0) $ do
            forM_ [1..jj-1] $ \ j -> do
              x1 <- readArray m (i,j)
              x2 <- readArray m (ii,j)
              writeArray m (i,j) ((x1+x2)`mod`2)
        r <- f (ii-1) (jj-1)
        return $ r+1
  f imax jmax 

distinct xs = length xs == length (nub xs)

main = do
  [h,w] <- readLnList
  sList <- replicateM h getLine
  let s = listArray ((1,1),(h,w)) $ concat sList
  let h2 = (h+1)`div`2
  let w2 = (w+1)`div`2
  let orbit (i,j) = nub [(i,j), (i,w+1-j), (h+1-i,j), (h+1-i,w+1-j)]
  let counts = [f . map (s!) $ orbit (i,j) | i<-[1..h2], j<-[1..w2]]
  let asyms = array ((1,1),(h2,w2)) [((i,j), distinct . map (s!) $ orbit (i,j))  | i<-[1..h2], j<-[1..w2]]
  let
    mat = accumArray (+) 0 ((1,1),(h2+w2, h2*w2)) $
      [ ((i, (i-1)*w2+j), if asyms!(i,j) && j /= w+1-j then 1 else 0)
      | i<-[1..h2], j<-[1..w2]]
      ++
      [ ((h2+j, (i-1)*w2+j), if asyms!(i,j) && i /= h+1-i then 1 else 0)
      | i<-[1..h2], j<-[1..w2]]
  r <- rank mat
  -- print asyms
  -- print mat
  -- print r
  let ans = (2::Integer)^r * product (map fint counts :: [Integer])
  print $ ans `mod`theMod

f [a] = 1
f [a,b] = 1
f [a,b,c,d] = length $ nub
  [[a,b,c,d]
  ,[a,c,d,b]
  ,[a,d,b,c]
  ,[b,a,d,c]
  ,[b,c,a,d]
  ,[b,d,c,a]
  ,[c,a,b,d]
  ,[c,b,d,a]
  ,[c,d,a,b]
  ,[d,a,c,b]
  ,[d,b,a,c]
  ,[d,c,b,a]
  ]

type Z = Int
type Q = Rational
type R = Double
type S = String

fint :: (Integral a, Num b) => a -> b
fint = fromIntegral

getInt = fst . fromJust . B.readInt <$> B.getLine
getIntPair = (\[a,b]->(a,b)) <$> getInts
getInts = map (fst . fromJust . B.readInt) . B.words <$> B.getLine
getStr = B.unpack <$> B.getLine

yesNo :: Bool -> String
yesNo True = "Yes"
yesNo False = "No"

printList :: (Show a) => [a] -> IO ()
printList = putStrLn . unwords . map show

readLnList :: (Read a) => IO [a]
readLnList = map read . words <$> getLine


-----  Union-find
type UnionFindT v m a = StateT (M.Map v (UnionFindVal v)) m a
newtype UnionFindVal v = UnionFindVal v

runUnionFindT :: (Monad m) => UnionFindT v m a -> m a
runUnionFindT = flip evalStateT $ M.empty

runUnionFind = runIdentity . runUnionFindT

ufFresh :: (Monad m, Ord v) => v -> UnionFindT v m ()
ufFresh v = modify $ M.insert v (UnionFindVal v)

ufClass :: (Monad m, Ord v) => v -> UnionFindT v m v
ufClass v = do
  (UnionFindVal pv) <- gets (M.! v)
  if v == pv
    then return v
    else do
      c <- ufClass pv
      modify $ M.insert v (UnionFindVal c)
      return c

ufUnify v w = do
  cv <- ufClass v
  cw <- ufClass w
  modify $ M.insert cw (UnionFindVal cv)
  return $ cv /= cw

Submission

Task問題 I - Reverse Grid
User nameユーザ名 tos
Created time投稿日時
Language言語 Haskell (GHC 7.10.3)
Status状態 AC
Score得点 1900
Source lengthソースコード長 3851 Byte
File nameファイル名
Exec time実行時間 772 ms
Memory usageメモリ使用量 158332 KB

Test case

Set

Set name Score得点 / Max score Cases
sample - sample-01.txt,sample-02.txt
all 1900 / 1900 sample-01.txt,sample-02.txt,01-01.txt,01-02.txt,01-03.txt,01-04.txt,01-05.txt,01-06.txt,01-07.txt,01-08.txt,01-09.txt,01-10.txt,01-11.txt,01-12.txt,01-13.txt,01-14.txt,01-15.txt,01-16.txt,01-17.txt,01-18.txt,01-19.txt,01-20.txt,01-21.txt,01-22.txt,01-23.txt,01-24.txt,01-25.txt,01-26.txt,01-27.txt,01-28.txt,01-29.txt,01-30.txt,01-31.txt,01-32.txt,01-33.txt,01-34.txt,01-35.txt

Test case

Case name Status状態 Exec time実行時間 Memory usageメモリ使用量
01-01.txt AC 3 ms 508 KB
01-02.txt AC 3 ms 508 KB
01-03.txt AC 3 ms 508 KB
01-04.txt AC 3 ms 508 KB
01-05.txt AC 3 ms 508 KB
01-06.txt AC 5 ms 1148 KB
01-07.txt AC 5 ms 1148 KB
01-08.txt AC 5 ms 1148 KB
01-09.txt AC 5 ms 1148 KB
01-10.txt AC 208 ms 37500 KB
01-11.txt AC 213 ms 36732 KB
01-12.txt AC 224 ms 38524 KB
01-13.txt AC 208 ms 37500 KB
01-14.txt AC 60 ms 10748 KB
01-15.txt AC 78 ms 13820 KB
01-16.txt AC 752 ms 158332 KB
01-17.txt AC 759 ms 158332 KB
01-18.txt AC 763 ms 157308 KB
01-19.txt AC 766 ms 157308 KB
01-20.txt AC 764 ms 156284 KB
01-21.txt AC 772 ms 157308 KB
01-22.txt AC 7 ms 1404 KB
01-23.txt AC 236 ms 48124 KB
01-24.txt AC 756 ms 156284 KB
01-25.txt AC 763 ms 158332 KB
01-26.txt AC 763 ms 158332 KB
01-27.txt AC 19 ms 3708 KB
01-28.txt AC 33 ms 5884 KB
01-29.txt AC 7 ms 1660 KB
01-30.txt AC 45 ms 8188 KB
01-31.txt AC 754 ms 156284 KB
01-32.txt AC 768 ms 156284 KB
01-33.txt AC 755 ms 157308 KB
01-34.txt AC 756 ms 157308 KB
01-35.txt AC 756 ms 157308 KB
sample-01.txt AC 3 ms 508 KB
sample-02.txt AC 3 ms 508 KB