Оптимизируй это: Travelling Salesman Problem

TestData-1

23
20833.3333 17100.0000
20900.0000 17066.6667
21300.0000 13016.6667
21600.0000 14150.0000
21600.0000 14966.6667
21600.0000 16500.0000
22183.3333 13133.3333
22583.3333 14300.0000
22683.3333 12716.6667
23616.6667 15866.6667
23700.0000 15933.3333
23883.3333 14533.3333
24166.6667 13250.0000
25149.1667 12365.8333
26133.3333 14500.0000
26150.0000 10550.0000
26283.3333 12766.6667
26433.3333 13433.3333
26550.0000 13850.0000
26733.3333 11683.3333
27026.1111 13051.9444
27096.1111 13415.8333
27153.6111 13203.3333

Ответ: 24522.408, считается около минуты
Если хочется проблему побольше, возьмите отсюда нужное число строчек: http://www.tsp.gatech.edu/world/wi29.tsp

TestData-2

14
16.47 96.10
16.47 94.44
20.09 92.54
22.39 93.37
25.23 97.24
22.00 96.05
20.47 97.02
17.20 96.29
16.30 97.38
14.05 98.12
16.53 97.38
21.52 95.59
19.41 97.13
20.09 94.55

Ответ: 30.8785, считается практически мгновенно

TSP.hs

module Main where

import Control.Monad.ST
import Control.Monad
import Data.Bits
import Data.Functor
import qualified Data.Vector.Unboxed as V
import qualified Data.Vector.Unboxed.Mutable as M

import Debug.Trace

type Coord = (Float, Float)
type DistVec = V.Vector Float

noway :: Float
noway = 999999999999999

readCity :: String -> Coord
readCity s = let [x,y] = map read $ words s
              in (x,y)

vidx :: Int -> Int -> Int -> Int
vidx size a b = b * size + a

setSize :: Int -> Int
setSize = popCount

setsOf :: Int -> Int -> [Int]
setsOf nelems size = filter (\v -> setSize v == size) [1,3 .. 2 ^ nelems - 1]

membersOf :: Int -> [Int]
membersOf s = filter (\v -> testBit s (v - 1)) [2 .. bitSize s]

setIndex :: Int -> Int
setIndex n = (n - 1) `div` 2

cityIndex :: Int -> Int
cityIndex n = n - 1

main :: IO()
main = do
    header:body <- lines <$> getContents
    let ncities = read header
    let cities = map readCity body
-- строим матрицу расстояний между городами
    let distmap = let p2 x = x ^ (2 :: Int)
                   in V.fromList [sqrt (p2 (x1 - x2)  + p2 (y1 - y2)) | (x1, y1) <- cities, (x2, y2) <- cities]
    
    print ncities
    print cities
    print distmap

    let z = runST $ do
        let msize = 2 ^ ncities `div` 2
        let mvidx s c = vidx msize (setIndex s) (cityIndex c)
-- создаем массив, проиндексированый по x битмасками возможных наборов городов, по y индексами городов
        mv <- M.new (msize * ncities)
-- начальные значения: нулевое расстояние за единственный шаг от исходного города до самого себя, бесконечность до остальных
        M.write mv 0 0
        forM_ [1 .. 2 ^ ncities - 2] $ \i -> M.write mv i noway

        -- перебираем маршруты всевозможной длины
        forM_ [2..ncities] $ \m ->
            -- перебираем подмножества городов этой длины
            trace (show m) $ forM_ (setsOf ncities m) $ \s -> do
                let jks = membersOf s
                -- перебираем города из этих подмножеств
                forM_ jks $ \j -> do
                    -- ищем длины маршрутов от других городов множества до искомого j
                    dists <- forM (1:jks) $ \k -> if k == j then return noway
                                    else do
                                        let pidx = mvidx (clearBit s (j - 1)) k
                                        let cost = distmap `V.unsafeIndex` vidx ncities (k - 1) (j - 1)
                                        prev <- M.read mv pidx
                                        return $ if prev == noway then noway
                                                         else prev + cost
                    let idx = mvidx s j
                    M.write mv idx (minimum dists)
        
        -- постобработка и ответ
        res <- forM [2 .. ncities] $ \j -> do
                pcost <- M.read mv (mvidx (2 ^ ncities - 1) j)
                return $ pcost + (distmap V.! (j - 1))

        return $ minimum res

    print z