# Solving the wooden snake chain puzzle

My code tries to solve the wooden snake chain puzzle:

I do so by generating all possible link configurations which are then tested. I was hoping that laziness would take care of the very many configurations. But it seems that I was wrong. While the program runs for smaller chains (cf. lengths' which gives the lengths of the individual segments), it won't complete for the full chain (lengths). I have used profile runs to make some modifications but I don't have many ideas left besides starting over. I have also attached the result of a profile run.

What can I do (besides starting over) to optimize the program such that it can solve the complete chain (ie. lengths instead of lengths')?

import Data.Array (Array, array, bounds, range, (//), (!))
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Prelude

{-
- There is a puzzle whit the objectiv of folding a chain of wooden segments
- into a 3x3x3 cube. This program attempts to solve this puzzle by testing
- all the different possible configurations of the links between the segments.
-
- Example: Chain with segment lengths: [3, 3, 3]
-
-     [X][ ][X]
-           [ ]
-           [X][ ][X]
-
- and a possible placement (in the z=0 plane)
-
-     1 1 1
-     0 0 2
-     3 3 2
-
- * The segments are labeled with ids: 1, 2, 3.
- * The link between segments can be in configuration 1, 2, 3, 4.
- * The orientation of the segments: X, X', Y, Y', Z, Z'.
-
-}

lengths = [3, 3, 3, 3, 2, 2, 2, 3, 3, 2, 2, 3, 2, 3, 2, 2, 3] :: [Int]
lengths'= [3, 3, 3, 3, 2, 2, 2, 3, 3, 2] :: [Int]

main = printSolution lengths'

type Grid = Array (Int, Int, Int) Int

data Orientation = X | X' | Y | Y' | Z | Z' deriving (Show)
data Segment = Seg { id :: Int, len :: Int, orientation :: Orientation } deriving Show

show1D grid y z = intercalate " " $map (\i -> show$ grid!(i,y,z)) [0..2]
show2D grid z = let hdr = "z=" ++ show z
body = intercalate "\n" $map (\i -> show1D grid i z) [0..2] in hdr ++ "\n" ++ body show3D grid = intercalate "\n\n"$ map (\i -> show2D grid i) [0..2]
show3D' grid = putStrLn $show3D grid -- Place a segment within the grid. If the placement is possible, return -- Just (grid, endPos) where endPos is the position of the last cube in -- the segment. placeSeg grid pos seg@(Seg id _ _) = let destPositions = placeSeg' pos seg -- The first and last cube overlap. This function chooses the second -- variant (see picture below). Therefore the first cube is handled -- specially. -- -- 1 1 2 1 1 1 -- 0 0 2 versus 2 -- 0 0 2 2 -- curFirstId = grid!pos newFirstId = if curFirstId == 0 then id else curFirstId values = (pos, newFirstId) : (map (\p -> (p, id)) (tail destPositions)) grid' = grid // values in -- We must not check the first destination, it is already taken. if all isValidPos (tail destPositions) then Just (grid', last destPositions) else Nothing where -- Returns the list of positions when placing a segment of a given length -- and orientation. -- eg: placeSeg' (0,0,0) (Seg _ 3 Y) = [(0,0,0), (0, 1, 0), (0, 2, 0)] placeSeg' _ seg@(Seg _ 0 _) = [] placeSeg' pos (Seg _ len orient) = pos : placeSeg' (nextPos pos orient) seg { len = len-1 } isValidPos pos = (isInRange (bounds grid) pos) && (grid ! pos == 0) isInRange ((xmin, ymin, zmin), (xmax, ymax, zmax)) (x,y,z) = isInRange' xmin xmax x && isInRange' ymin ymax y && isInRange' zmin zmax z where isInRange' a b x = a <= x && x <= b nextPos (x,y,z) X = (x+1,y,z) nextPos (x,y,z) X' = (x-1,y,z) nextPos (x,y,z) Y = (x,y+1,z) nextPos (x,y,z) Y' = (x,y-1,z) nextPos (x,y,z) Z = (x,y,z+1) nextPos (x,y,z) Z' = (x,y,z-1) placeChain :: Grid -> [Segment] -> Maybe Grid placeChain grid segments = let start = Just (grid, (0,0,0)) placement = foldl f start segments in placement >>= (\(grid', _) -> Just grid') where f (Just (grid', pos')) seg = placeSeg grid' pos' seg f Nothing _ = Nothing -- Convert the (local) link configuration (1, 2, 3, 4) to the (global) -- orientation. linkConfToOrientation :: Orientation -> Int -> Orientation -- There are many different assignments possible. This is just a possible one. linkConfToOrientation X 1 = Y linkConfToOrientation X 2 = Z linkConfToOrientation Y 1 = Z linkConfToOrientation Y 2 = X linkConfToOrientation Z 1 = X linkConfToOrientation Z 2 = Y -- The assignment for the "negative" orientations is also arbitrary. linkConfToOrientation X' 1 = Y linkConfToOrientation X' 2 = Z' linkConfToOrientation Y' 1 = Z linkConfToOrientation Y' 2 = X' linkConfToOrientation Z' 1 = X linkConfToOrientation Z' 2 = Y' linkConfToOrientation orient conf = reflect$ linkConfToOrientation orient (conf - 2)

reflect :: Orientation -> Orientation
reflect X = X'
reflect X' = X
reflect Y = Y'
reflect Y' = Y
reflect Z = Z'
reflect Z' = Z

chainFromConf :: Orientation -> [Int] -> [Int] -> [Segment]
chainFromConf startOrientation lengths conf =
let
orientations = scanl linkConfToOrientation startOrientation conf
in
zipWith3 Seg [1..(length lengths)] lengths orientations

-- Note: The values of (tail lengths) are not used, only its size.
allLinkConfigs lengths = mapM (const [1..4]) (tail lengths)
placements lengths =
let
chains = map (chainFromConf X lengths) (allLinkConfigs lengths)
bounds = ((0,0,0), (2,2,2))
grid = array bounds [(pos, 0) | pos <- range bounds]
placements' = catMaybes $map (placeChain grid) chains in map show3D placements' printSolution lengths = putStrLn$ intercalate "\n\n" (placements lengths)


    Thu Jan 24 19:45 2019 Time and Allocation Profiling Report  (Final)

woodenCube +RTS -p -RTS

total time  =        2.21 secs   (2214 ticks @ 1000 us, 1 processor)
total alloc = 4,112,689,072 bytes  (excludes profiling overheads)

COST CENTRE                   MODULE    SRC                             %time %alloc

placeSeg.grid'                Main      woodenCube.hs:70:5-26            20.7   12.6
placeSeg.isValidPos           Main      woodenCube.hs:(86,5)-(87,41)     16.0   10.4
placeSeg.isInRange.isInRange' Main      woodenCube.hs:94:9-43            14.5    7.0
placeSeg                      Main      woodenCube.hs:(54,1)-(101,34)    11.6   18.5
placeSeg.placeSeg'            Main      woodenCube.hs:(82,5)-(84,62)      7.2    9.8
chainFromConf                 Main      woodenCube.hs:(142,1)-(146,59)    6.4   13.9
placeSeg.nextPos              Main      woodenCube.hs:(96,5)-(101,34)     5.5    3.7
placeSeg.isInRange            Main      woodenCube.hs:(89,5)-(94,43)      3.5    6.8
chainFromConf.orientations    Main      woodenCube.hs:144:5-68            3.1    6.4
placeChain.placement          Main      woodenCube.hs:107:5-38            2.9    2.7
placeChain.f                  Main      woodenCube.hs:(111,5)-(112,25)    2.2    0.9
placeSeg.values               Main      woodenCube.hs:68:5-75             1.7    3.2
placeChain                    Main      woodenCube.hs:(104,1)-(112,25)    1.3    0.9

individual      inherited
COST CENTRE                               MODULE                   SRC                            no.     entries  %time %alloc   %time %alloc

MAIN                                      MAIN                     <built-in>                      40          0    0.0    0.0   100.0  100.0
CAF                                      GHC.IO.Encoding.CodePage <entire-module>                 68          0    0.0    0.0     0.0    0.0
CAF                                      GHC.IO.Handle.Text       <entire-module>                 65          0    0.0    0.0     0.0    0.0
CAF                                      GHC.IO.Encoding          <entire-module>                 63          0    0.0    0.0     0.0    0.0
CAF                                      GHC.IO.Handle.FD         <entire-module>                 57          0    0.0    0.0     0.0    0.0
CAF                                      Main                     <entire-module>                 47          0    0.0    0.0    99.7  100.0
lengths'                                Main                     woodenCube.hs:30:1-49           88          1    0.0    0.0     0.0    0.0
main                                    Main                     woodenCube.hs:161:1-29          80          1    0.0    0.0    99.7  100.0
printSolution                          Main                     woodenCube.hs:159:1-74          81          1    0.0    0.0    99.7  100.0
placements                            Main                     woodenCube.hs:(150,1)-(157,26)  84          1    0.0    0.0    99.7  100.0
show3D                               Main                     woodenCube.hs:48:1-67          113         12    0.0    0.0     0.0    0.0
show3D.\                            Main                     woodenCube.hs:48:47-59         114         36    0.0    0.0     0.0    0.0
show2D                             Main                     woodenCube.hs:(45,1)-(47,38)   115         36    0.0    0.0     0.0    0.0
show2D.body                       Main                     woodenCube.hs:46:21-80         117         36    0.0    0.0     0.0    0.0
show2D.body.\                    Main                     woodenCube.hs:46:58-72         118        108    0.0    0.0     0.0    0.0
show1D                          Main                     woodenCube.hs:44:1-74          119        108    0.0    0.0     0.0    0.0
show1D.\                       Main                     woodenCube.hs:44:48-66         120        324    0.0    0.0     0.0    0.0
show2D.hdr                        Main                     woodenCube.hs:45:21-40         116         36    0.0    0.0     0.0    0.0
placements.bounds                    Main                     woodenCube.hs:153:5-31         102          1    0.0    0.0     0.0    0.0
placements.chains                    Main                     woodenCube.hs:152:5-67          86          1    0.3    0.6    11.6   22.3
chainFromConf                       Main                     woodenCube.hs:(142,1)-(146,59)  91     262144    6.4   13.9    10.7   20.7
chainFromConf.orientations         Main                     woodenCube.hs:144:5-68          92     262144    3.1    6.4     4.2    6.8
linkConfToOrientation             Main                     woodenCube.hs:(118,1)-(131,85) 108     758436    1.0    0.4     1.2    0.4
reflect                          Main                     woodenCube.hs:(134,1)-(139,14) 109     252812    0.1    0.0     0.1    0.0
allLinkConfigs                      Main                     woodenCube.hs:149:1-59          87          1    0.6    1.0     0.6    1.0
placements.grid                      Main                     woodenCube.hs:154:5-56         101          1    0.0    0.0     0.0    0.0
placements.placements'               Main                     woodenCube.hs:155:5-58          85          1    0.3    0.6    88.1   77.7
placeChain                          Main                     woodenCube.hs:(104,1)-(112,25)  89     262144    1.3    0.9    87.8   77.1
placeChain.placement               Main                     woodenCube.hs:107:5-38          90     262144    2.9    2.7    86.5   76.2
placeChain.f                      Main                     woodenCube.hs:(111,5)-(112,25)  93    2621440    2.2    0.9    83.6   73.5
placeSeg                         Main                     woodenCube.hs:(54,1)-(101,34)   95     767768   11.6   18.5    81.4   72.7
placeSeg.isValidPos             Main                     woodenCube.hs:(86,5)-(87,41)    98    1262072   16.0   10.4    34.1   24.1
placeSeg.isInRange             Main                     woodenCube.hs:(89,5)-(94,43)    99    1262072    3.5    6.8    18.1   13.7
placeSeg.isInRange.isInRange' Main                     woodenCube.hs:94:9-43          104    3587318   14.5    7.0    14.5    7.0
placeSeg.bnds                   Main                     woodenCube.hs:72:5-22          100     767768    0.5    0.4     0.5    0.4
placeSeg.destPositions          Main                     woodenCube.hs:56:5-37           96     767768    0.2    0.3    12.9   13.8
placeSeg.placeSeg'             Main                     woodenCube.hs:(82,5)-(84,62)    97    2535476    7.2    9.8    12.7   13.5
placeSeg.nextPos              Main                     woodenCube.hs:(96,5)-(101,34)  103    1262072    5.5    3.7     5.5    3.7
placeSeg.grid'                  Main                     woodenCube.hs:70:5-26          105     505636   20.7   12.6    20.7   12.6
placeSeg.values                 Main                     woodenCube.hs:68:5-75          106     505636    1.7    3.2     1.7    3.2
placeSeg.values.\              Main                     woodenCube.hs:68:46-52         107     989244    0.0    0.0     0.0    0.0
placeSeg.curFirstId             Main                     woodenCube.hs:66:5-25          111       8798    0.1    0.1     0.1    0.1
placeSeg.newFirstId             Main                     woodenCube.hs:67:5-59          110       8798    0.0    0.0     0.0    0.0
placeChain.start                   Main                     woodenCube.hs:106:5-32          94     262144    0.0    0.0     0.0    0.0
placeChain.\                       Main                     woodenCube.hs:109:35-44        112         12    0.0    0.0     0.0    0.0
main                                     Main                     woodenCube.hs:161:1-29          82          0    0.0    0.0     0.3    0.0
printSolution                           Main                     woodenCube.hs:159:1-74          83          0    0.3    0.0     0.3    0.0

• I changed the title so that it describes what the code does per site goals: "State what your code does in your title, not your main concerns about it.". Feel free to edit and give it a different title if there is something more appropriate. – Sᴀᴍ Onᴇᴌᴀ Jan 24 '19 at 19:45