One Tough Puzzle

tough_puzzle.hs

import Data.List                                                                 
import Data.List.Split (chunksOf)                                                
import Data.Char                                                                 
                                                                                 
data Suit = Club | Heart | Diamond | Spade           deriving (Show, Read, Eq)   
data Sex  = Out | In                                 deriving (Show, Read, Eq)   
data Side = Side { suit :: Suit , sex :: Sex}        deriving (Show, Read)       
instance Eq Side where x == y = (suit x == suit y) && (sex x /= sex y)           
data Piece = Piece { north :: Side , east  :: Side                               
                   , south :: Side , west  :: Side } deriving (Show, Read, Eq)   
                                                                                 
parsePiece [n,e,s,w] = Piece { north = parseSide n, east = parseSide e           
                             , south = parseSide s, west = parseSide w }         
  where parseSide c = Side { suit = parseSuit c, sex =  parseSex c }             
        parseSuit c | toLower c == 'c' = Club                                    
                    | toLower c == 'd' = Diamond                                 
                    | toLower c == 's' = Spade                                   
                    | otherwise        = Heart                                   
        parseSex  c = if isLower c then In else Out                              
                                                                                 
explore :: ([Piece], [Piece]) -> [([Piece], [Piece])]                            
explore (list, pool) = concatMap pluck [0..(length pool - 1)]                    
  where pluck i = [ (list ++ [c], excise i pool)                                 
                  | c <- take 4 $ iterate rotate (pool!!i)                       
                  ]                                                              
        excise i xs = take i xs ++ drop (i+1) xs                                 
        rotate piece = Piece { north = east piece, east = south piece            
                             , south = west piece, west = north piece }          
                                                                                 
validate :: Int -> [Piece] -> Bool --validates position n, indexed at zero       
validate n xs = (not hasAbove || matchAbove) && (not hasLeft || matchLeft)       
  where hasLeft    = n `mod` 3 /= 0                                              
        hasAbove   = n >= 3                                                      
        matchLeft  = west  (xs!!n) == east  (xs!!(n-1))                          
        matchAbove = north (xs!!n) == south (xs!!(n-3))                          
                                                                                 
step 0 xs = explore ([], xs)                                                     
step n xs = filter (\(xs,_) -> validate n xs) $ concatMap explore $ step (pred n) xs
                                                                                 
renderGrid :: [Piece] -> [String]                                                
renderGrid = intercalate ["----|-----|----"] . map renderRow . chunksOf 3        
 where renderRow xs = [ intercalate " | " $ map (\x -> renderSq x!!n) xs | n <- [0..2] ]
       renderSq p = [ "."          ++ [unParse $ north p] ++ "."                 
                    , [unParse $ west p] ++ " "           ++ [unParse $ east p]  
                    , "."          ++ [unParse $ south p] ++ "."                 
                    ]                                                            
       unParse s                                                                 
         | suit s == Club    = f 'c'                                             
         | suit s == Spade   = f 's'                                             
         | suit s == Diamond = f 'd'                                             
         | otherwise         = f 'h'                                             
         where f = if sex s == Out then toUpper else id                          
                                                                                 
main = do                                                                        
  let allPieces = map parsePiece $ [ "HDdh", "CHsh", "DCcd", "SDsh", "SDhd", "SShc", "CHdc", "HDcc", "HSsc" ]
  let sol = fst $ head $ step 8 allPieces                                        
  mapM_ putStrLn $ renderGrid sol