Project Euler Problem 043

import Control.Monad
import Data.Char
import Data.List


ispan :: String -> Bool
ispan n = "0123456789" == (nub $ sort $ n)

str2n :: Num b => [Char] -> b
str2n s = fromIntegral $ foldl (\a c->10*a+c) 0 $ map (digitToInt) s

check :: [Char] -> Bool
check s = imp (tail s) pl where
  pl = [2,3,5,7,11,13,17]
  imp [] _ = True
  imp _ [] = True
  imp l@(_:_) [n] = let r = take 3 l in
    str2n r `rem` n == 0
  imp l@(_:xs) (n:ns) = let r = take 3 l in
    (str2n r `rem` n == 0) && imp xs ns
listn :: (Enum a, Num a, Show a) => a -> [[Char]]
listn nn = map (f.show) $ [nn,2*nn..999] where --0うめを追加
  f n | length n<3 = f ('0':n)
      | otherwise = n
lists :: [[[Char]]]
lists = map listn (reverse [1,2,3,5,7,11,13,17]::[Integer]) --大きいのから試す

ans1r :: [[String]] -> String -> [String]
ans1r [] acc | head acc /= '0' && check acc && ispan acc = [acc]
ans1r [] _ | otherwise = []
ans1r (n:ns) [] = concat [ans1r ns x | x<-n]
ans1r (n:ns) acc= concat [ans1r ns (addhead:acc) |
                          x<-n,
                          let acctop2 = take 2 acc,
                          let xleft = tail x,
                          acctop2==xleft, --追加するやつと、既存のリスト2つはかぶり
                          let accleft = drop 2 acc,
                          let addhead = head x,
                          intersect [addhead] accleft==[]
                          ]

an1 :: [String]
an1 = sort $ ans1r lists [] 

ans1 :: Integer
ans1 = sum $ map read $ an1
 --16695334890
main :: IO ()
main = print ans1