2
\$\begingroup\$

My code tries to solve the wooden snake chain puzzle:

enter image description here

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')?

Source with pastebin link

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)

Profiler run with pastbin link:

    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
linkConfToOrientation         Main      woodenCube.hs:(118,1)-(131,85)    1.0    0.4
allLinkConfigs                Main      woodenCube.hs:149:1-59            0.6    1.0


                                                                                                                     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
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – Sᴀᴍ Onᴇᴌᴀ Jan 24 at 19:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.