結果

問題 No.5002 stick xor
ユーザー LeonardoneLeonardone
提出日時 2018-06-01 22:19:33
言語 Haskell
(9.8.2)
結果
AC  
実行時間 713 ms / 1,000 ms
コード長 3,046 bytes
コンパイル時間 26,030 ms
実行使用メモリ 4,868 KB
スコア 38,729
最終ジャッジ日時 2018-06-01 22:20:00
ジャッジサーバーID
（参考情報） 		judge8 /
純コード判定しない問題か言語
このコードへのチャレンジ
（要ログイン）

テストケース

テストケース表示
入力 結果 実行時間
実行使用メモリ
testcase_00 AC 711 ms
4,864 KB
testcase_01 AC 696 ms
4,856 KB
testcase_02 AC 698 ms
4,864 KB
testcase_03 AC 657 ms
4,864 KB
testcase_04 AC 679 ms
4,868 KB
testcase_05 AC 638 ms
4,860 KB
testcase_06 AC 702 ms
4,868 KB
testcase_07 AC 649 ms
4,868 KB
testcase_08 AC 679 ms
4,864 KB
testcase_09 AC 691 ms
4,868 KB
testcase_10 AC 641 ms
4,864 KB
testcase_11 AC 681 ms
4,860 KB
testcase_12 AC 618 ms
4,868 KB
testcase_13 AC 655 ms
4,864 KB
testcase_14 AC 600 ms
4,868 KB
testcase_15 AC 706 ms
4,856 KB
testcase_16 AC 633 ms
4,860 KB
testcase_17 AC 713 ms
4,860 KB
testcase_18 AC 631 ms
4,864 KB
testcase_19 AC 652 ms
4,864 KB
testcase_20 AC 661 ms
4,868 KB
testcase_21 AC 628 ms
4,860 KB
testcase_22 AC 683 ms
4,864 KB
testcase_23 AC 607 ms
4,864 KB
testcase_24 AC 689 ms
4,864 KB
testcase_25 AC 604 ms
4,860 KB
testcase_26 AC 677 ms
4,868 KB
testcase_27 AC 612 ms
4,864 KB
testcase_28 AC 653 ms
4,864 KB
testcase_29 AC 615 ms
4,868 KB
testcase_30 AC 644 ms
4,864 KB
testcase_31 AC 618 ms
4,868 KB
権限があれば一括ダウンロードができます
コンパイルメッセージ
[1 of 1] Compiling Main             ( Main.hs, Main.o )
Linking a.out ...

ソースコード

diff # 

-- Try yukicoder
-- author: Leonardone @ NEETSDKASU

import Data.Char (digitToInt)
import Data.Word (Word64)
import Data.Bits
import Data.List (sortOn)

main = interact $ unlines . map format . solve . parse . lines

parse (nkstr:lsstr:tbstr) = ret where
    [n, k] = map read $ words nkstr
    ls = zip [0..] . map read $ words lsstr
    tb = zip [1..] $ map mf tbstr :: [(Int, Word64)]
    ret = (n, k, ls, tb)
    mf = fromInteger . foldl f 0
    f a b = shiftL a 1 .|. (toInteger $ digitToInt b)

format (True, ((_, l), (y, x))) = unwords $ map show [y, x, y, x + l - 1]
format (_   , ((_, l), (y, x))) = unwords $ map show [x, y, x + l - 1, y]
    
solve (n, k, ls, tb) = ans where
    solve' tb = foldl (fix n) ([], tb)
    base = score tb
    nosol = map (\e -> (True, (e, (1, 1)))) ls
    sorted = sortOn snd ls
    sol1 = solve'' ls
    sol2 = solve'' $ reverse sorted
    sol3 = solve'' $ sorted
    es = [sol1, sol2, sol3] ++ xs
    (ret, _) = foldl cmp (nosol, base) es
    ans = sortOn (fst . snd) ret
    cmp o@(sol, sc) (sol', tb') = ret where
        sc' = score tb'
        ret = if sc < sc' then o else (sol', sc')
    xs = map (solve'' . snd) . take 3 $ iterate shuffle (19831983, ls)
    solve'' xs = ret where
        (ys, zs) = split xs
        (sol1, tb') = solve' tb $ ys
        (sol2, tb'') = solve' (trans n tb') $ zs
        sol1' = map (\e -> (True,  e)) sol1
        sol2' = map (\e -> (False, e)) sol2
        ret = (sol1' ++ sol2', tb'')

fullbits n = shiftL 1 n - 1
    
setbits t x s = t `xor` shiftL x s

getbits x (s, t) = shiftR t s .&. x

find n l t = ret where
    fb = fullbits l
    mf1 s = (s, setbits t fb s)
    mf2 nb = (popCount . getbits fb $ snd nb, nb)
    bs = map mf1 [0..n-l]
    nbs = zip [n-l+1-i | i <- [0..]] bs
    ret = foldl1 f $ map mf2 nbs
    f a b = if fst a < fst b then a else b

get tb n l = ret where
    ret = foldl1 f $ map mf tb
    mf (y, t) = (y, find n l t)
    f a b = if fst (snd a) < fst (snd b) then a else b
    
fix n (r, tb) li@(_, l) = ret where
    (y, (_, (x, (_, b)))) = get tb n l
    ret = ((li,(y, x)):r, swap b (y-1) tb)
    swap u 0 ((i, _):es) = (i, u) : es
    swap u p (e:es) = e : swap u (p-1) es
    
xorshift a = d :: Word64 where
    b = a `xor` shiftL a 13
    c = b `xor` shiftR b 7
    d = c `xor` shiftL c 17

shuffle (xsft, ls) = shake len xsft ls where
    len = fromInteger . toInteger $ length ls
    tohead 0 (x:xs) f = x : f xs
    tohead p (x:xs) f = tohead (p-1) xs (\es -> f $ x:es)
    shake 0 x es = (x, es)
    shake n x es = shake (n-1) x2 es2 where
        x2 = xorshift x
        p = x `mod` len
        es2 = tohead p es id
    
score tb = sc where
    sc = foldl1 (+) $ map (popCount . snd) tb

trans n tb = ret where
    foo k = (k + 1, foldl (fm k) 0 tb)
    fm k a (i, e) = a .|. ((1 .&. shiftR e (n-k-1)) `shiftL` (n-i))
    ret = map foo [0..n-1]

    
split xs = split' xs [] [] where
    split' (e1:e2:es) ys zs = split' es (e1:ys) (e2:zs)
    split' (e:_)      ys zs = ((e:ys), zs)
    split' _          ys zs = (ys, zs)
0