Project Euler Problem 037

import Control.Monad hiding (join)
import Data.Char
import Data.List hiding (union)
--003より
primes :: [Integer]
primes = 2 : ([3,5..] `minus` join [[p*p, p*p+2*p..] | p <- primes']) 
  where
    primes' = 3 : ([5,7..] `minus` join [[p*p, p*p+2*p..] | p <- primes'])   
    join  ((x:xs):t)    = x : union xs (join (pairs t))
    pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t                      
    union (x:xs) (y:ys) = case (compare x y) of 
      LT -> x : union  xs  (y:ys)
      EQ -> x : union  xs     ys 
      GT -> y : union (x:xs)  ys
    union  xs     []    = xs
    union  []     ys    = ys
    minus (x:xs) (y:ys) = case (compare x y) of 
      LT -> x : minus  xs  (y:ys)
      EQ ->     minus  xs     ys
      GT ->     minus (x:xs)  ys
    minus  xs     _     = xs
isprime :: Integer -> Bool
isprime 1 = False    
isprime nn = imp nn primes where
  imp n (x:xs) = if x*x>n then True
                 else if rem n x==0 then False
                      else imp n xs      

truncatable :: Integer -> Bool
truncatable nn =  leftt nn && rightt nn where
  leftt n | n<10 = isprime n
  leftt n = let l = foldl (\a c->a*10+c) 0 $ map (fromIntegral.digitToInt) $ tail $ show n in
    isprime l && leftt l
  rightt n | n<10 = isprime n
  rightt n = let r = quot n 10 in isprime r && rightt r


ansl :: [Integer]
ansl = filter isprime $ filter truncatable [10..1000000]
ans1 :: Integer
ans1 = sum ansl

list :: Integer -> [Integer]
list n = filter isLeftTruncatable $ if isprime n then n:ns else []
  where ns = concatMap (list . ((10*n) +)) [1,3,7,9]
isLeftTruncatable :: Integer -> Bool
isLeftTruncatable = all isprime . map read . init . tail . tails . show
ans2 :: Integer
ans2 = sum $ filter (>=10) $ concatMap list [2,3,5,7]

--748317
main :: IO ()
main = print ans2