Project Euler 解答

Project Euler Problem 084

Project Euler Problem 084

import Control.Monad import Data.Ord import Data.List import Data.Maybe import System.IO.Unsafe import System.Random -- 重複しないだけ保証する (go,a1,cc1,a2,t1,r1,b1,ch1,b2,b3,jail,c1,u1,c2,c3,r2,d1,cc2,d2,d3,fp,e1,ch2,e2,e3,r3,f1,f2,u2,f3,g2j,g1,g2,cc3,g3,r4,ch3,h1,t2,h2) = ("GO","A1","CC1","A2","T1","R1","B1","CH1","B2","B3","JAIL","C1","U1","C2","C3","R2","D1","CC2","D2","D3","FP","E1","CH2","E2","E3","R3","F1","F2","U2","F3","G2J","G1","G2","CC3","G3","R4","CH3","H1","T2","H2") (nextrr,nextuu,return3) = ("NEXTR","NEXTU","RETURN3") --盤面とカードの柄. zzz(検索用) decklen :: Int decklen = 40 --cycleする前の長さ deck :: [[Char]] deck = cycle [go,a1,cc1,a2,t1,r1,b1,ch1,b2,b3,jail,c1,u1,c2,c3,r2,d1,cc2,d2,d3,fp,e1,ch2,e2,e3,r3,f1,f2,u2,f3,g2j,g1,g2,cc3,g3,r4,ch3,h1,t2,h2] cc :: [[Char]] cc = [go,jail] ++ replicate 14 "" ch :: [[Char]] ch = [go,jail,c1,e3,h2,r1,nextrr,nextrr,nextuu,return3] ++ replicate 6 "" i :: [Char] -> Int i x= fromJust $ elemIndex x deck --乱数(目は1-4) dices :: [(Int, Int)] dices = unsafePerformIO $ ((getStdGen >>= return . pairs . randomRs(minv,maxv)) :: IO [(Int,Int)])where minv = 1 maxv = 4 pairs (a:b:l) = (a,b):pairs l pairs l = [] shuffle :: [Int] -> [t] -> [t] shuffle [c] l = l shuffle (c:cs) l@(x:xs)=let (n:ns) = swap 0 c l in n:shuffle cs ns swap :: Int -> Int -> [a] -> [a] swap i j xs | i == j = xs swap i j xs | otherwise = initial ++ (xs !! b) : middle ++ (xs !! a) : end where [a,b] = sort [i,j] initial = take a xs middle = take (b-a-1) (drop (a+1) xs) end = drop (b+1) xs -- 分散が、順に減っていくような16回ずつ繰り返すランダム列。これでuniformな乱数を生成 -- Knuthのアルゴリズム cards :: [Int] cards = msum $ map (`shuffle` [0..(len-1)]) cards3 where len = length cc --降順に出現する乱数の範囲が減っていく乱数列の16個組リスト cards3 = imp len where imp n = unsafePerformIO $ do{g<-getStdGen; let seeds = reverse $ map (\x -> randomRs(0,x) :: StdGen -> [Int]) [0..(len-1)] in return $ transpose $ map ($ g) seeds} --上のcards3と同じ。純粋にテスト用 cards3t :: [[Int]] cards3t = imp 16 where imp n = unsafePerformIO $ do{g<-getStdGen; let seeds = reverse $ map (\x -> randomRs(0,x) :: StdGen -> [Int]) [0..15] in return $ transpose $ map ($ g) seeds} --一つの試行への処理 eval :: Int -> Int -> t -> Int eval c currentpos prevpos = case deck !! currentpos of x | x == g2j -> i jail x | (x == cc1)||(x==cc2)||(x==cc3) -> drawcc currentpos prevpos c x | (x == ch1)||(x==ch2)||(x==ch3) -> drawch currentpos prevpos c x -> i x --CCカードを引く drawcc :: Int -> t -> Int -> Int drawcc currentpos prevpos carddice = let x = cc !! carddice in case x of v | v==go -> i x v | v==jail-> i x _ -> currentpos --CHカードを引く drawch :: Int -> t -> Int -> Int drawch currentpos prevpos carddice = let x = ch !! carddice in case x of x | x == go -> i x x | x == jail -> i x x | x == c1 -> i x x | x == e3 -> i x x | x == h2 -> i x x | x == r1 -> i x x | x == nextrr -> nextr currentpos x | x == nextuu -> nextu currentpos x | x == return3 -> (currentpos + (decklen - 3))`rem`decklen _ -> currentpos findpos :: Char -> Int -> Int findpos c pos = (`rem`(decklen)) $ i $ fromJust $ find ((==c).head) $ drop pos deck --RはR1〜R4の4種類 nextr :: Int -> Int nextr x = findpos 'R' x --UはU1〜U2の2種類 nextu :: Int -> Int nextu x = findpos 'U' x trial :: Integer -> [(Int, Int, Int)] -> [(Int, Int)] -> [Int] -> [Int] trial 0 past dice card = map (\(_,_,x)->x) past -- 初回 trial num past@[] ((x,y):ds) (c:cs)= trial (num-1) ((x,y,this):past) ds cs where this = eval c ((x+y)`rem`decklen) 0 -- 二回目 trial num past@[(d1x,d1y,d1p)] ((x,y):ds) (c:cs)= trial (num-1) ((x,y,this):past) ds cs where this = eval c ((d1p+x+y)`rem`decklen) d1p -- 三回目以降 trial num past@((d1x,d1y,d1p):(d2x,d2y,d2p):_) ((x,y):ds) (c:cs)= trial (num-1) ((x,y,this):past) ds cs where this = case (d1x==d1y)&&(d2x==d2y)&&(x==y) of True -> i "JAIL" _ -> eval c ((d1p+x+y)`rem`decklen) d1p ans :: [Char] ans = concatMap (show.head) $ take 3 $ sortBy (flip $ comparing length) $ group $ sort $ trial 100000 [] dices cards --101524 main :: IO () main = print ans

since 2013