Project Euler Problem 098

import Data.List
import Data.Ord
import Data.Char
import System.IO.Unsafe

-- 回文判定
isparin :: Eq a => [a] -> Bool
isparin n = n == reverse n

-- length=14については、6C2=15回呼ばれる
d2n :: String -> Integer
d2n = foldl ((+).(*10)) 0 . map (fromIntegral . digitToInt)

permOf :: Eq a => [a] -> [a] -> [Int]
permOf [] _ = []
permOf (x:xs) ys = 
    case findIndex (==x) ys of
        Just i -> i:permOf xs ys
        Nothing -> []

permBy :: [Int] -> [a] -> [a]
permBy [] _ = []
permBy (x:xs) ys = (ys!!x):permBy xs ys


wordsUnsafe :: [String]
wordsUnsafe = unsafePerformIO $ readFile "098words.txt" >>= return . (\s -> filter (not.isparin) $ sort (read ("[" ++ s ++ "]") :: [String]))
-- 回文は除外
notPalindromicWords :: [[Char]]
notPalindromicWords = filter (not.isparin) $ wordsUnsafe
-- permOfを借りた
wgroups :: [[[Char]]]
wgroups = sortBy (comparing (length.head)) $ map (map snd) $ filter ((>=2).length) $ sort $ groupBy (\x y -> fst x == fst y) $ sort $ zip (map sort notPalindromicWords) notPalindromicWords
-- これがuniqueなpermutationの一覧
wordperms :: [[Int]]
wordperms = nub $ sortBy (flip $ comparing length) $ [permOf l r| (l:r:_)<-wgroups]
-- permutationの最大長までしかチェック不要
maxlen :: Int
maxlen = length $ head wordperms
sqrs :: [Integer]
sqrs = takeWhile (<(10^maxlen)) $ map (^(2::Integer)) [1..]
sqrsl :: [[Integer]]
sqrsl = groupBy (\x y-> length (show x) == length (show y)) sqrs


ans1imp :: [[Char]]
ans1imp=[max l ss | p<-wordperms,let pool=sqrsl!!(length p-1),s<-pool,let ss=show s,dd p==dd ss,let l=permBy p ss,(d2n l)`elem`pool]
     where
       -- different digits
       dd n = length $ nub $ sort n
ans1 :: [Char]
ans1 = head ans1imp
-- 18769
main :: IO ()
main = print ans1