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