-- ********************************************************************* -- * * -- * Eternity II puzzle. Each puzzle piece is represented by a * -- * 5-tuple, in which the first 4 entries represent the four * -- * edge colors in the order left, top, right, bottom, and the * -- * fifth member is the (numerical) identifier for the piece. * -- * * -- ********************************************************************* -- module Solve where import Data.Array.IArray import Control.Parallel import Control.Parallel.Strategies import List import Debug.Trace main = putStrLn (show corns) >> putStrLn (corpic) >> putStrLn "Left sides\n">> putStrLn (pArrayPic (pArray pSides)) >> putStrLn "Right sides\n">> putStrLn (pArrayPic (rightArray ))>> putStrLn (show (length (perims (pArray pSides) corTemp))) >> putStrLn (show (perims (pArray pSides) corTemp))>> putStrLn "done" -- ********************************************************************* -- * * -- * Make a list of all possible perimeters. Run the operation in * -- * parallel over the list of possible corner configurations. * -- * * -- ********************************************************************* perims:: Array (Int) [Int]-> [(Int,Int,Int,Int)]->[[Int]] perims pArray corTemp = concat $ parMap rwhnf (\oneCor->makPerim oneCor pArray ) corTemp -- ********************************************************************* -- * * -- * We build a list of perimeters by constructing each backward * -- * from position 59. However, position 59 needs special handling * -- * because it must match position 0 as well as 58. Each of the * -- * other corners will also need special handling, which is done * -- * by a case statement. * -- * * -- * Note that pArray is organized by the left sides of the pieces, * -- * while in makePerim we need to check the right side of a * -- * against the bottom of the first corner. This results in the * -- * need for rightArray, and some tricky indexing. * -- * * -- ********************************************************************* makPerim :: (Int,Int,Int,Int) -> Array (Int) [Int] -> [[Int]] makPerim oneCor pArray = [a:b | a <- ((rightArray) ! startCol), b <- (restPerim a (pArray // [(left(refPerim!a), (pArray!(left(refPerim!a)))\\[a])]) (rightArray //[(startCol, (rightArray ! startCol) \\ [a])]) oneCor 58), trace (show b) b /=[] ] where startCol = bot (corns !! (fst4 oneCor)) -- ********************************************************************* -- * * -- * Once past the first piece in a perimeter, move to next. * -- * Check for a corner piece, which needs special handling. * -- * If there are no candidates left to match last, terminate * -- * the recursion, indicating there is no way to continue. * -- * Otherwise, construct the list of possible continuations of * -- * the perimeter. * -- * * -- ********************************************************************* -- restPerim last leftRay rightRay oneCor iAm | -- trace ((show iAm)++" "++ (show last)) elem iAm [0,15,30,45] = corner last leftRay rightRay oneCor iAm | useRow /= [] = extend | otherwise = [] where useRow = rightRay ! (left (refPerim ! last)) extend = [b:c | b <- (rightRay ! (left (refPerim ! last))), c <- restPerim b (newLeft b) (newRight b) oneCor (iAm - 1), --trace (show c) c/=[]] newLeft b = leftRay // [((left (refPerim ! b)), (leftRay ! (left (refPerim ! b))) \\ [b])] newRight b = rightRay // [((right (refPerim ! b)), (rightRay ! (right (refPerim ! b))) \\ [b])] -- ********************************************************************* -- * * -- * Corners get special handling. The corner in the upper left is * -- * always piece 1, because of rotational symmetry. * -- * * -- ********************************************************************* -- corner last leftRay rightRay oneCor iAm | -- trace ((show last)++" "++(show iAm)) iAm == 15 = if (gTst3 leftRay rightRay) then goOn (snd4 oneCor) else trace "fail" [] | -- trace "goo" iAm == 30 = goOn (thd4 oneCor) | -- trace "gah" iAm == 45 = goOn (fth4 oneCor) | -- trace "gii" iAm == 0 = if (lastLeft == rightCor 1) then [[1]] else [] | otherwise = error ("\n\n *** You can't get here"++ " *** \n\n") where lastLeft = left (refPerim ! last) rightCor b = right (refPerim ! b) botCor b = bot (refPerim ! b) nLeft b = left (refPerim ! b) goOn q = if (lastLeft /= rightCor q) then [] else [q:c:d | c <- (leftRay ! (botCor q)), d <- -- trace ((show q)++" "++ -- (show c)++"xx ") restPerim c (newleft c) (newright c) oneCor (iAm - 2) ] newleft c = leftRay // [((nLeft c), leftRay!(nLeft c)\\[c])] newright c = rightRay // [((rightCor c), rightRay!(rightCor c)\\ [c])] -- ********************************************************************* -- * * -- * agTst is a simple heuristic test to determine whether it is * -- * possible for a perimeter to be built with the remaining * -- * pieces: it tests to find out whether there are an equal no. of * -- * pieces whose right side matches the left sides of available * -- * pieces, except, perhaps for 1, which will fit a corner piece. * -- * * -- * And it doesn't work, at least at the beginning of the solution.* -- * In the first 10,000,000 passages through corner 15, there is * -- * only 1 fail. * -- * * -- ********************************************************************* gTst :: Array Int [Int] -> Array Int [Int] -> Bool gTst right left = and $ map tryme (indices right) where iList = indices right tryme x | (length (right ! x)) == (length (left ! x)) = True | abs ((length (right ! x))- (length (left ! x))) == 1 = True | otherwise = False gTst1:: Array Int [Int] -> Array Int [Int] -> Bool gTst1 right left = if (sum $ map tryme (indices right)) > 2 then False else True where tryme x = abs ((length (right ! x)) - (length (left ! x))) gTst2 right left = if (length (left ! 2)) > 0 then True else False gTst3 right left = if (lr > ll) then False else True where lr = length (right ! 2) ll = length (left ! 2) -- ********************************************************************* -- * * -- * Here we make up a list of the 6 possible corner configurations * -- * There are only 6 such because the remaining permutations of * -- * corner pieces are merely rotations of the six used here. * -- * * -- ********************************************************************* corTemp :: [(Int,Int,Int,Int)] corTemp = [(1,2,3,4),(1,2,4,3),(1,3,2,4),(1,3,4,2),(1,4,2,3),(1,4,3,2)] corns = [(0,0,0,0,0), (0,0,2,1,1),(0,0,2,3,2),(0,0,4,1,3),(0,0,1,4,4)] -- ********************************************************************* -- * * -- * Construct an array in which each entry is a list of pieces * -- * that have the same color on the left side. This array will be * -- * used to construct the perimeters of the puzzle. * -- * * -- * We use pArray as an array of available pieces, and refPerim * -- * in order to find the matching colors; since it changes a lot, * -- * the reduced item count will reduce overhead from building new * -- * pArray's. * -- * * -- ********************************************************************* pSides:: [(Int,Int,Int,Int,Int)] pSides = [(2,0,2,5,5),(4,0,2,6,6),(2,0,2,7,7),(8,0,2,7,8),(1,0,2,9,9), (3,0,2,10,10),(4,0,2,11,11),(3,0,2,12,12),(8,0,2,12,13), (3,0,2,13,14),(2,0,4,6,15),(1,0,4,14,16),(8,0,4,15,17), (8,0,4,16,18),(4,0,4,10,19),(4,0,4,11,20),(3,0,4,17,21), (2,0,4,18,22),(8,0,4,18,23),(2,0,4,19,24),(2,0,4,13,25), (4,0,1,5,26),(1,0,1,5,27),(1,0,1,6,28),(1,0,1,14,29), (8,0,1,10,30),(4,0,1,11,31),(1,0,1,19,32),(4,0,1,12,33), (3,0,1,12,34),(8,0,1,20,35),(3,0,1,21,36),(2,0,3,14,37), (8,0,3,22,38),(8,0,3,9,39),(4,0,3,16,40),(1,0,3,16,41), (2,0,3,11,42),(4,0,3,11,43),(1,0,3,11,44),(2,0,3,17,45), (3,0,3,19,46),(3,0,3,12,47),(3,0,3,20,48),(8,0,8,5,49), (2,0,8,6,50),(4,0,8,6,51),(2,0,8,7,52),(3,0,8,10,53), (3,0,8,17,54),(8,0,8,17,55),(1,0,8,12,56),(2,0,8,20,57), (8,0,8,20,58),(4,0,8,13,59),(1,0,8,21,60)] pArray:: [(Int,Int,Int,Int,Int)] -> Array (Int) [Int] pArray pSides = accumArray (++) [] (1,8) accumPlist rightArray:: Array (Int) [Int] rightArray = accumArray (++) [] (1,8) rightAccum rightAccum = map (\item ->((right item),[piece item])) pSides accumPlist = map (\item ->((left item),[piece item])) pSides refPerim:: Array (Int) (Int,Int,Int,Int,Int) refPerim = listArray (1,60) (trace "don't get here"(drop 1 corns)++pSides) -- ********************************************************************* -- * * -- * Pretty-printer for corner configurations. * -- * * -- * * -- ********************************************************************* corpic = concat $ map oneSq corTemp oneSq (a,b,c,d) = show (corns !! a) ++ " " ++ show (corns !! b) ++ "\n\n" ++ show (corns !! c)++" "++show (corns !! d) ++ "\n\n\n" -- ********************************************************************* -- * * -- * Ugly-printer for pArray, the array of pieces for the * -- * perimeter. * -- * * -- * * -- ********************************************************************* pArrayPic myray = concatMap (\x-> (show x)++"\n\n") (elems myray) -- ********************************************************************* -- * * -- * Convenience functions. * -- * * -- ********************************************************************* left:: (Int,Int,Int,Int,Int) -> Int left (a,b,c,d,e) = a fst4 (a,b,c,d) = a top (a,b,c,d,e) = b snd4 (a,b,c,d) =b right (a,b,c,d,e) = c thd4 (a,b,c,d) = c bot (a,b,c,d,e) = d fth4 (a,b,c,d) = d piece (a,b,c,d,e) = e