Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
One Tough Puzzle
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment