結果

問題 No.3 ビットすごろく
ユーザー nobsunnobsun
提出日時 2018-06-19 18:49:56
言語 Haskell
(9.8.2)
結果
WA  
実行時間 -
コード長 3,867 bytes
コンパイル時間 1,246 ms
コンパイル使用メモリ 201,192 KB
実行使用メモリ 151,168 KB
最終ジャッジ日時 2023-09-13 07:12:12
合計ジャッジ時間 13,131 ms
ジャッジサーバーID
（参考情報） 		judge11 / judge14
このコードへのチャレンジ
（要ログイン）

テストケース

テストケース表示
入力 結果 実行時間
実行使用メモリ
testcase_00 AC 2 ms
7,708 KB
testcase_01 AC 3 ms
7,688 KB
testcase_02 AC 2 ms
7,524 KB
testcase_03 AC 52 ms
20,884 KB
testcase_04 AC 12 ms
12,296 KB
testcase_05 AC 222 ms
56,100 KB
testcase_06 AC 62 ms
23,484 KB
testcase_07 AC 32 ms
16,020 KB
testcase_08 WA -
testcase_09 WA -
testcase_10 WA -
testcase_11 WA -
testcase_12 AC 223 ms
52,144 KB
testcase_13 AC 42 ms
18,468 KB
testcase_14 AC 534 ms
98,032 KB
testcase_15 AC 844 ms
145,100 KB
testcase_16 WA -
testcase_17 WA -
testcase_18 AC 32 ms
16,768 KB
testcase_19 WA -
testcase_20 WA -
testcase_21 AC 2 ms
7,372 KB
testcase_22 AC 552 ms
113,548 KB
testcase_23 AC 864 ms
151,168 KB
testcase_24 WA -
testcase_25 WA -
testcase_26 AC 3 ms
7,192 KB
testcase_27 WA -
testcase_28 WA -
testcase_29 WA -
testcase_30 AC 4 ms
8,144 KB
testcase_31 AC 4 ms
8,424 KB
testcase_32 WA -
権限があれば一括ダウンロードができます
コンパイルメッセージ
Loaded package environment from /home/judge/.ghc/x86_64-linux-9.6.1/environments/default
[1 of 2] Compiling Main             ( Main.hs, Main.o )
[2 of 2] Linking a.out

ソースコード

diff # 

{-# LANGUAGE MultiParamTypeClasses #-}
module Main where

import Control.Arrow
import Control.Applicative (Applicative(..),(<$>))
import Control.Monad.Trans.State
import Data.Array
import Data.Bool
import Data.Function
import Data.Graph
import Data.List
import qualified Data.Map as M

main :: IO ()
main = interact (show . (bool (-1) <*> (100000 >)) . countPath . read)

graph :: Gr -> Graph
graph (g,_,_) = g

type Nd = Int
type Id = Int
type Gr = (Graph, Vertex -> (Nd,Id,[Id]), Id -> Maybe Vertex)
data Pair a b = Pair a b

instance (Eq a) => Eq (Pair a b) where
  Pair x _ == Pair y _ = x == y

instance (Ord a) => Ord (Pair a b) where
  Pair x _ `compare` Pair y _ = x `compare` y

countPath :: Int -> Int
countPath = ($ Pair 0 []) . (count . pred  <*> graph . graphFromEdges . series)

countF :: Vertex -> Graph
       -> (Pair Vertex [Vertex] -> State (M.Map (Pair Vertex [Vertex]) Int) Int)
       -> Pair Vertex [Vertex]
       -> State (M.Map (Pair Vertex [Vertex]) Int) Int
countF e g f (Pair s vs)
  | s == e    = pure 1
  | otherwise = case g ! s \\ vs of
      []  -> pure 100000
      xs  -> succ . minimum <$> mapM (\ x -> f (Pair x (insertBy (flip compare) s vs))) xs

count :: Vertex -> Graph -> (Pair Vertex [Vertex]) -> Int
count e g = memo (undefined :: Memo M.Map (Pair Vertex [Vertex]) Int) (countF e g)

series :: Int -> [(Int,Int,[Int])]
series n = take n $ map (rmout n) $ zipWith mkEdge [1..] $ concat $ unfoldr phi [0]
  where
    phi xs = Just (ys, zs)
      where
        ys = map succ xs
        zs = xs ++ ys

mkEdge :: Int -> Int -> (Int,Int,[Int])
mkEdge k n = (n,k,[k+n,k-n])

rmout :: Int -> (Int,Int,[Int]) -> (Int,Int,[Int])
rmout n (nd,k,es) = (nd,k,filter (uncurry (&&) . ((0<) &&& (<=n))) es)

-- memoisation

class MemoTable t where
  emptyMemoTable  :: Ord a => t a b
  lookupMemoTable :: Ord a => a -> t a b -> Maybe b
  insertMemoTable :: Ord a => a -> b -> t a b -> t a b

class (Monad m) => MemoTableT t m where
  emptyMemoTableT  :: Ord a => t a (m b)
  lookupMemoTableT :: Ord a => a -> t a (m b) -> Maybe (m b)
  insertMemoTableT :: Ord a => a -> m b -> t a (m b) -> t a (m b)

instance MemoTable M.Map where
  emptyMemoTable  = M.empty
  lookupMemoTable = M.lookup
  insertMemoTable = M.insert

instance MemoTableT M.Map [] where
  emptyMemoTableT  = M.empty
  lookupMemoTableT = M.lookup
  insertMemoTableT = M.insert

type Memo t a b = a -> State (t a b) b

memoise :: (MemoTable t, Ord a) => Memo t a b -> Memo t a b
memoise mf x = do prev <- find x
                  case prev of
                    Just y  -> return y
                    Nothing -> do y    <- mf x
                                  ins x y
                                  return y
               where find k  = get >>= return . lookupMemoTable k
                     ins k v = get >>= put . insertMemoTable k v

evalMemo :: (MemoTable t, Ord a) => (Memo t) a b -> a -> b
evalMemo m v = evalState (m v) emptyMemoTable

runMemo :: (MemoTable t, Ord a) => t a b -> (Memo t) a b -> a -> (b, t a b)
runMemo tb m v = runState (m v) tb

gfun :: (b -> c) -> (c -> b) -> c
gfun = (fix .) . (.)

memoising :: (Ord a, MemoTable t) => ((a -> State (t a b) b) -> Memo t a b) -> a -> State (t a b) b
memoising = gfun memoise

-- | makes memo function from functional specified by the second argument.
--   The first argument is only for imforming type of memo table will be used.
memo :: (MemoTable t, Ord a)
     => (a -> State (t a b) b)
     -> ((a -> State (t a b) b) -> Memo t a b)
     -> (a -> b)
memo g f = evalMemo (asTypeOf (memoising f) g)

-- | makes memo function which also takes and returns memo table
-- , which can be reused.
memo' :: (MemoTable t, Ord a)
     => ((a -> State (t a b) b) -> Memo t a b)
     -> t a b
     -> (a -> (t a b, b))
memo' = ((swap .) .) . flip runMemo . memoising

swap :: (a, b) -> (b, a)
swap (x,y) = (y,x)
0