secret
Last active — forked from /gist:c83c7ed37eeee7599a1f

  • Download Gist
gistfile1.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
import System.Environment
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import System.Exit
 
maxDepth = 30
 
main :: IO ()
main = do
args <- getArgs
validArg <- parseArgs args
putStrLn $ pretty $ solve 0 Map.empty validArg
 
parseArgs :: [String] -> IO String
parseArgs args = case args of
[s] -> case validateArg s of
True -> return s
False -> putStrLn "Invalid arg" >> exitWith (ExitFailure 1)
_ -> putStrLn "Invalid number of args" >> exitWith (ExitFailure 1)
 
-- extremely slow in general, but fast enough in this case
validateArg :: String -> Bool
validateArg arg = elem arg (permutations "012345678")
 
solve :: Int -> Map.Map String Int -> String -> [String]
solve d m b | d > maxDepth = []
solve d m b = case b of
"012345678" -> [b]
_ -> b : extract (filter (elem "012345678") $ map (solve (d+1) m') $ getMoves m' b)
where m' = Map.insert b 1 m
 
extract :: [[String]] -> [String]
extract [] = [""]
extract ss = head ss
 
getMoves :: Map.Map String Int -> String -> [String]
getMoves m s = filter (\a -> Map.notMember a m) (moveList s)
 
moveList :: String -> [String]
moveList s = [swap e d s | d <- adjacents e]
where e = fromJust $ elemIndex '0' s
 
adjacents :: Int -> [Int]
adjacents a = case a of
0 -> [1, 3]
1 -> [0, 2, 4]
2 -> [1, 5]
3 -> [0, 4, 6]
4 -> [1, 3, 5, 7]
5 -> [2 ,4, 8]
6 -> [3, 7]
7 -> [4, 6, 8]
8 -> [5, 7]
_ -> []
 
swap :: Int -> Int -> [a] -> [a]
swap i j xs = take l xs ++ [xs !! u] ++ (take (u-l-1) $ drop (l+1) xs)
++ [xs !! l] ++ drop (u+1) xs
where l = if i<j then i else j
u = if i>j then i else j
 
pretty :: [String] -> String
pretty ss = foldl (++) "Solution:\n" $ map (subs '0' ' '.brk 0.brk 3.brk 6.brk 10) ss
 
brk :: Int -> String -> String
brk n s = a ++ "\n" ++ b
where (a, b) = splitAt n s
 
subs :: Char -> Char -> String -> String
subs c d s = map (replace c d) s
where replace x y z | z == x = y
| otherwise = z

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.