GitLab

My code -

{-
Example run:

Enter initial state:
12356 784
Enter final state:

123586 74
1 2 3
5 8 6
  7 4

1 2 3
5 8 6
7   4

1 2 3
5   6
7 8 4

1 2 3
5 6
7 8 4

Minimum path length: 3

-}

import Data.List
import Data.List.Split
import Data.Map as Map hiding (map, filter)

swap :: Int -> Int -> State -> State
swap i j (State xs depth) = let (i', j') = if i > j then (j ,i) else (i, j)
                                left = take i' xs
                                middle = drop (i'+1) $ take j' xs
                                i_elem = xs !! i'
                                right = drop (j'+1) xs
                                j_elem = xs !! j'
                                xs' = left ++ [j_elem] ++ middle ++ [i_elem] ++ right
                            in (State xs' depth)

printGrid :: State -> IO()
printGrid (State xs depth) = let [x,y,z] = chunksOf 6 $ intersperse ' ' xs
                             in do putStrLn x
                                   putStrLn y
                                   putStrLn z
                                   putStrLn ""

data State = State {
  state :: [Char],
  depth :: Int
} deriving (Eq, Show, Ord)

getMoves :: State -> [Char]
getMoves (State xs depth) = case ' ' `elemIndex` xs of
  Nothing -> error "Empty block not found"
  Just n -> let l = n `elem` [1,4,7,2,5,8]
                r = n `elem` [0,3,6,1,4,7]
                d = n `elem` [0..5]
                u = n `elem` [3..8]
                pairs = zip [l,r,d,u] ['L','R','D','U']
                filtered = filter (\x -> fst x) pairs
            in map snd filtered

next :: State -> [Char] -> [State]
next (State state depth) cs = case ' ' `elemIndex` state of
  Nothing -> error "Empty block not found"
  Just n -> do c <- cs
               return $ case c of
                         'L' -> swap n (n-1) (State state (depth + 1))
                         'R' -> swap n (n+1) (State state (depth + 1))
                         'U' -> swap n (n-3) (State state (depth + 1))
                         'D' -> swap n (n+3) (State state (depth + 1))

test :: State -> State -> Bool
test state1 state2 = (state state1) == (state state2)

-- loop :: finalState -> open -> closed -> accmulated parentMap -> parentMap
loop :: State -> [State] -> [State] -> Map State State -> Maybe (State, Map State State)
loop final [] _ _ = Nothing
loop final open@(x:xs) closed parentMap = if test final x
  then Just (x, parentMap)
  else let moves = getMoves x
           nextStates = next x moves
           filter_fn = \x -> not (x `elem` open || x `elem` closed)
           filtered = filter filter_fn nextStates
           newMap = insertIntoMap filtered x parentMap
       in loop final (xs ++ filtered) (x:closed) newMap

insertIntoMap :: [State] -> State -> Map State State -> Map State State
insertIntoMap [] _ parentMap = parentMap
insertIntoMap (x:xs) parent parentMap =
 insertIntoMap xs parent (Map.insert x parent parentMap)

printAns :: State -> Map State State -> Int -> IO ()
printAns state parentMap count =
 case Map.lookup state parentMap of
   Just parent -> do printGrid parent
                     printAns parent parentMap (count + 1)
   Nothing -> do putStrLn $ "Minimum path length: " ++ show count
                 return ()

ans :: Maybe (State, Map State State) -> IO ()
ans (Just (final, parentMap)) = do
 printGrid final
 printAns final parentMap 0
ans _ = putStrLn "No answer found."

main :: IO ()
main = do putStrLn "Enter initial state: "
          start <- getLine
          putStrLn "Enter final state: "
          final <- getLine
          ans $ loop (State final 0) [(State start 0)] [] Map.empty

Test Cases I entered in the order:

• Main> main

Enter initial state: 123456 784

Enter final state: 1234567 8mianrrupted.

• Main>
• Main> main

Enter initial state: 12356 784

Enter final state: 123586 74

1 2 3 5 8 6

7 4

1 2 3 5 8 6 7 4

1 2 3 5 6 7 8 4

1 2 3 5 6 7 8 4

Minimum path length: 3

• Main>

<interactive>: panic! (the 'impossible' happened)

(GHC version 8.0.1 for x86_64-unknown-mingw32):

thread blocked indefinitely in an MVar operation

Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug

Trac metadata

Trac field	Value
Version	8.0.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system	Windows
Architecture