Haskell - 2,475,056

Haskell - 2,475,056 steps

Haskell

Algorithm is similar to the one suggested by MrBackend in the comments. The difference is: his suggestion finds the cheapest path to the highest cost square, mine greedily reduces the graph eccentricity at every step. I will post the total number of turns taken once it finishes evaluating (it's currently doing about 2 puzzles per second, so it will probably finish this evening)

import Data.Array import qualified Data.Map as M import Data.Word import Data.List import Data.Maybe import Data.Function (on) import Data.Monoid import Control.Arrow import Control.Monad (liftM) import System.IO import System.Environment import Control.Parallel.Strategies import Control.DeepSeq type Grid v = Array (Word8,Word8) v main = do (ifn:_) <- getArgs hr <- openFile ifn ReadMode sp <- liftM parseFile $ hGetContents hr let sol = map solve sp `using` parBuffer 3 (evalList rseq) putStrLn $ intercalate "\n" $ map (concatMap show) sol putStrLn $ "\n\nTotal turns: " ++ (show $ genericLength $ concat $ sol) centrepoint :: Grid v -> (Word8,Word8) centrepoint g = let ((x0,y0),(x1,y1)) = bounds g med l h = let t = l + h in t `div` 2 + t `mod` 2 in (med x0 x1, med y0 y1) neighbours :: Grid v -> (Word8,Word8) -> [(Word8,Word8)] neighbours g (x,y) = filter (inRange $ bounds g) [(x,y+1),(x+1,y),(x,y-1),(x-1,y)] areas :: Eq v => Grid v -> [[(Word8,Word8)]] areas g = p $ indices g where p [] = [] p (a:r) = f : p (r \\ f) where f = s g [a] [] s g [] _ = [] s g (h:o) v = let n = filter (((==) `on` (g !)) h) $ neighbours g h in h : s g ((n \\ (o ++ v)) ++ o) (h : v) applyFill :: Eq v => v -> Grid v -> Grid v applyFill c g = g // (zip fa $ repeat c) where fa = s g [centrepoint g] [] solve g = solve' gr' where aa = areas g cp = centrepoint g ca = head $ head $ filter (elem cp) aa gr' = M.fromList $ map ( \r1 -> (head r1, map head $ filter ( \r2 -> head r1 /= head r2 && (not $ null $ intersect (concatMap (neighbours g) r1) r2) ) aa ) ) aa solve' gr | null $ tail $ M.keys $ gr = [] | otherwise = best : solve' ngr where djk _ [] = [] djk v ((n,q):o) = (n,q) : djk (q:v) ( o ++ zip (repeat (n+1)) ((gr M.! q) \\ (v ++ map snd o)) ) dout = djk [] [(0,ca)] din = let m = maximum $ map fst dout s = filter ((== m) . fst) dout in djk [] s rc = filter (flip elem (gr M.! ca) . snd) din frc = let m = minimum $ map fst rc in map snd $ filter ((==m) . fst) rc msq = concat $ filter (flip elem frc . head) aa clr = map (length &&& head) $ group $ sort $ map (g !) msq best = snd $ maximumBy (compare `on` fst) clr ngr = let ssm = filter ((== best) . (g !)) $ map snd rc sml = (concatMap (gr M.!) ssm) ncl = ((gr M.! ca) ++ sml) \\ (ca : ssm) brk = M.insert ca ncl $ M.filterWithKey (\k _ -> (not . flip elem ssm) k ) gr in M.map (\l -> nub $ map (\e -> if e `elem` ssm then ca else e) l) brk parseFile :: String -> [Grid Word8] parseFile f = map mk $ filter (not . null . head) $ groupBy ((==) `on` null) $ map (map ((read :: String -> Word8) . (:[]))) $ lines f where mk :: [[Word8]] -> Grid Word8 mk m = let w = fromIntegral (length $ head m) - 1 h = fromIntegral (length m) - 1 in array ((0,0),(w,h)) [ ((x,y),v) | (y,l) <- zip [h,h-1..] m, (x,v) <- zip [0..] l ] 

Haskell - 2,475,056

Algorithm is similar to the one suggested by MrBackend in the comments. The difference is: his suggestion finds the cheapest path to the highest cost square, mine greedily reduces the graph eccentricity at every step.

import Data.Array import qualified Data.Map as M import Data.Word import Data.List import Data.Maybe import Data.Function (on) import Data.Monoid import Control.Arrow import Control.Monad (liftM) import System.IO import System.Environment import Control.Parallel.Strategies import Control.DeepSeq type Grid v = Array (Word8,Word8) v main = do (ifn:_) <- getArgs hr <- openFile ifn ReadMode sp <- liftM parseFile $ hGetContents hr let (len,sol) = turns (map solve sp `using` parBuffer 3 (evalList rseq)) putStrLn $ intercalate "\n" $ map (concatMap show) sol putStrLn $ "\n\nTotal turns: " ++ (show len) turns :: [[a]] -> (Integer,[[a]]) turns l = rl' 0 l where rl' c [] = (c,[]) rl' c (k:r) = let s = c + genericLength k  (s',l') = s `seq` rl' s r in (s',k:l') centrepoint :: Grid v -> (Word8,Word8) centrepoint g = let ((x0,y0),(x1,y1)) = bounds g med l h = let t = l + h in t `div` 2 + t `mod` 2 in (med x0 x1, med y0 y1) neighbours :: Grid v -> (Word8,Word8) -> [(Word8,Word8)] neighbours g (x,y) = filter (inRange $ bounds g) [(x,y+1),(x+1,y),(x,y-1),(x-1,y)] areas :: Eq v => Grid v -> [[(Word8,Word8)]] areas g = p $ indices g where p [] = [] p (a:r) = f : p (r \\ f) where f = s g [a] [] s g [] _ = [] s g (h:o) v = let n = filter (((==) `on` (g !)) h) $ neighbours g h in h : s g ((n \\ (o ++ v)) ++ o) (h : v) applyFill :: Eq v => v -> Grid v -> Grid v applyFill c g = g // (zip fa $ repeat c) where fa = s g [centrepoint g] [] solve g = solve' gr' where aa = areas g cp = centrepoint g ca = head $ head $ filter (elem cp) aa gr' = M.fromList $ map ( \r1 -> (head r1, map head $ filter ( \r2 -> head r1 /= head r2 && (not $ null $ intersect (concatMap (neighbours g) r1) r2) ) aa ) ) aa solve' gr | null $ tail $ M.keys $ gr = [] | otherwise = best : solve' ngr where djk _ [] = [] djk v ((n,q):o) = (n,q) : djk (q:v) ( o ++ zip (repeat (n+1)) ((gr M.! q) \\ (v ++ map snd o)) ) dout = djk [] [(0,ca)] din = let m = maximum $ map fst dout s = filter ((== m) . fst) dout in djk [] s rc = filter (flip elem (gr M.! ca) . snd) din frc = let m = minimum $ map fst rc in map snd $ filter ((==m) . fst) rc msq = concat $ filter (flip elem frc . head) aa clr = map (length &&& head) $ group $ sort $ map (g !) msq best = snd $ maximumBy (compare `on` fst) clr ngr = let ssm = filter ((== best) . (g !)) $ map snd rc sml = (concatMap (gr M.!) ssm) ncl = ((gr M.! ca) ++ sml) \\ (ca : ssm) brk = M.insert ca ncl $ M.filterWithKey (\k _ -> (not . flip elem ssm) k ) gr in M.map (\l -> nub $ map (\e -> if e `elem` ssm then ca else e) l) brk   parseFile :: String -> [Grid Word8] parseFile f = map mk $ filter (not . null . head) $ groupBy ((==) `on` null) $ map (map ((read :: String -> Word8) . (:[]))) $ lines f where mk :: [[Word8]] -> Grid Word8 mk m = let w = fromIntegral (length $ head m) - 1 h = fromIntegral (length m) - 1 in array ((0,0),(w,h)) [ ((x,y),v) | (y,l) <- zip [h,h-1..] m, (x,v) <- zip [0..] l ]  showGrid :: Grid Word8 -> String showGrid g = intercalate "\n" l where l = map sl $ groupBy ((==) `on` snd) $ sortBy ((flip (compare `on` snd)) <> (compare `on` fst)) $ indices g sl = intercalate " " . map (show . (g !)) testsolve = do hr <- openFile "floodtest" ReadMode sp <- liftM (head . parseFile) $ hGetContents hr let sol = solve sp a = snd $ mapAccumL (\g s -> let g' = applyFill s g in (g',g')) sp sol sequence_ $ map (\g -> putStrLn (showGrid g) >> putStrLn "\n") a 

Algorithm is the one suggested by MrBackend in the comments. I will post the total number of turns taken once it finishes evaluating (it's currently doing about 2 puzzles per second, so it will probably finish this evening)

Algorithm is similar to the one suggested by MrBackend in the comments. The difference is: his suggestion finds the cheapest path to the highest cost square, mine greedily reduces the graph eccentricity at every step. I will post the total number of turns taken once it finishes evaluating (it's currently doing about 2 puzzles per second, so it will probably finish this evening)