#267168 (Haskell) No.3 ビットすごろく

• 問題: No.3 ビットすごろく
• ユーザー: nobsun
• 提出日時: 2018-06-19 15:09:13
• 言語: Haskell (9.8.2)
• 結果: WA
• 実行時間: -
• コード長: 7,642 bytes
• コンパイル時間: 2,225 ms
• コンパイル使用メモリ: 203,940 KB
• 実行使用メモリ: 94,172 KB
• 最終ジャッジ日時: 2023-09-13 07:07:18
• 合計ジャッジ時間: 8,978 ms
• ジャッジサーバーID （参考情報）: judge13 / judge12

入力	結果	実行時間; 実行使用メモリ
testcase_00	AC	3 ms; 94,172 KB
testcase_01	AC	3 ms; 7,756 KB
testcase_02	WA	-
testcase_03	TLE	-
testcase_04	--	-
testcase_05	--	-
testcase_06	--	-
testcase_07	--	-
testcase_08	--	-
testcase_09	--	-
testcase_10	--	-
testcase_11	--	-
testcase_12	--	-
testcase_13	--	-
testcase_14	--	-
testcase_15	--	-
testcase_16	--	-
testcase_17	--	-
testcase_18	--	-
testcase_19	--	-
testcase_20	--	-
testcase_21	--	-
testcase_22	--	-
testcase_23	--	-
testcase_24	--	-
testcase_25	--	-
testcase_26	--	-
testcase_27	--	-
testcase_28	--	-
testcase_29	--	-
testcase_30	--	-
testcase_31	--	-
testcase_32	--	-

コンパイルメッセージ

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

ソースコード

{-# 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 . countPath . read)

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

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

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

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

count :: Vertex -> Graph -> (Vertex, [Vertex]) -> Int
count e g = memo (undefined :: Memo M.Map (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)

{- -
{-# LANGUAGE MultiParamTypeClasses #-}
module WildCardMemo where

import Data.Bool
import Control.Applicative (Applicative(..),(<$>))
import Control.Monad.State
import Control.Arrow ((***))
import Data.Function (fix)
import qualified Data.Map as M

main :: IO ()
main = interact (mkwc' . lines)

type SzStr  = (Int,String)
type WSzStr = (SzStr,String)

toSzStr :: String -> SzStr
toSzStr = flip (,) <*> length

fromSzStr :: SzStr -> String
fromSzStr = snd

wlcsF :: Applicative f => ((WSzStr, SzStr) -> f WSzStr) -> (WSzStr, SzStr) -> f WSzStr
wlcsF f (xs@(ms@(m,s),ws),ys@(n,t)) = case ws of
  ""      -> case n of
    0       -> pure ((0,""),"")
    _       -> pure ((0,""),"*")
  '*':ws' -> addStar <$> f ((ms,ws'),ys)
  _  :ws' -> case s of
    c:cs    -> case t of
      ""      -> pure ((0,""),"")
      d:ds
        | c == d    -> cons c <$> f (((pred m,cs),ws'),(pred n,ds))
        | otherwise -> bool <$> zs1 <*> zs2 <*> ((<) <$> m1 <*> m2)
            where
              zs1 = addStar <$> f (((pred m,cs),ws'),ys)
              zs2 = addStar <$> f (xs,(pred n,ds))
              m1  = (fst . fst) <$> zs1
              m2  = (fst . fst) <$> zs2

addStar :: WSzStr -> WSzStr
addStar wsz@(_,'*':_) = wsz
addStar (ms,ws)       = (ms,'*':ws)

cons :: Char -> WSzStr -> WSzStr
cons c ((m,s),w) = ((succ m,c:s),c:w)

wlcs' :: M.Map (WSzStr, SzStr) WSzStr -> (WSzStr, SzStr) -> (M.Map (WSzStr, SzStr) WSzStr, WSzStr)
wlcs' = memo' wlcsF

mkwc' :: [String] -> String
mkwc' (x:xs) = snd . snd $ foldl (\ (t,w) s -> wlcs' t (w,s)) (emptyMemoTable,((length x,x),x))
                         $ map (flip (,) <*> length) xs

-- -}
{- -}
-- メモ化関数のための仕組は以下

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)


{-
-- Hackage にある memoize パッケージを使えれば以下のコードですっきり書ける

import Data.Bool
import Data.Function.Memoize -- http://hackage.haskell.org/package/memoize

main :: IO ()
main = interact (mkWStr . lines)

type SzStr  = (Int, String)
type WSzStr = (SzStr, String)

mkWStr :: [String] -> String
mkWStr [] = error "no String"
mkWStr (x:xs) = snd $ foldl wlcs (toSzStr x,x) (map toSzStr xs)
  where
    toSzStr s = (length s, s)

wlcs :: WSzStr -> SzStr -> WSzStr
wlcs = memoFix2 wlcsF

wlcsF :: (WSzStr -> SzStr -> WSzStr) -> WSzStr -> SzStr -> WSzStr
wlcsF f xs@(ms@(m,s),ws) ys@(n,t) = case ws of
  ""      -> case n of
    0       -> ((0,""),"")
    _       -> ((0,""),"*")
  '*':ws' -> addStar (f (ms,ws') ys)
  _  :ws' -> case s of
      c:cs    -> case t of
        ""      -> ((0,""),"")
        d:ds
          | c == d    -> cons c (f ((pred m,cs),ws') (pred n,ds))
          | otherwise -> bool zs1 zs2 (m1 < m2) -- if m1 < m2 then zs2 else zs1
              where
                zs1 = addStar (f ((pred m,cs),ws') ys)
                zs2 = addStar (f xs (pred n,ds))
                m1 = (fst . fst) zs1
                m2 = (fst . fst) zs2

mkWStr' :: [String] -> String
mkWStr' [] = error "no String"
mkWStr' (x:xs) = snd $ foldl (curry wlcs') (toSzStr x,x) (map toSzStr xs)
  where
    toSzStr s = (length s, s)

wlcs' :: (WSzStr,SzStr) -> WSzStr
wlcs' = memoFix wlcsF'

wlcsF' :: ((WSzStr,SzStr) -> WSzStr) -> (WSzStr,SzStr) -> WSzStr
wlcsF' f (xs@(ms@(m,s),ws),ys@(n,t)) = case ws of
  ""      -> case n of
    0       -> ((0,""),"")
    _       -> ((0,""),"*")
  '*':ws' -> addStar $ f ((ms,ws'),ys)
  _  :ws' -> case s of
      c:cs    -> case t of
        ""      -> ((0,""),"")
        d:ds
          | c == d    -> cons c $ f (((pred m,cs),ws'),(pred n,ds))
          | otherwise -> bool zs1 zs2 $ (m1 < m2) -- if m1 < m2 then zs2 else zs1
              where
                zs1 = addStar $ f (((pred m,cs),ws'),ys)
                zs2 = addStar $ f (xs,(pred n,ds))
                m1 = (fst . fst) $ zs1
                m2 = (fst . fst) $ zs2
                
addStar :: WSzStr -> WSzStr
addStar wsz@(_,'*':_) = wsz
addStar (ms,ws) = (ms,'*':ws)

cons :: Char -> WSzStr -> WSzStr
cons c ((m,s),w) = ((succ m,c:s),c:w)
-}

-- -}