module Algorithms.Concorde.LinKern
(
tsp, R2
, Config(..), defConfig
) where
import Control.Monad
import Control.Exception
import Data.Maybe
import System.Exit
import System.IO
import System.IO.Temp
import Text.Printf
import Safe
import qualified Data.IntMap as IM
import qualified System.Process as P
errStr :: String -> String
errStr = ("Algorithms.Concorde.LinKern: " ++)
data Config = Config
{
executable :: FilePath
, verbose :: Bool
, timeBound :: Maybe Double
, steps :: Maybe Int
, runs :: Int
, otherArgs :: [String]
} deriving (Eq, Ord, Read, Show)
defConfig :: Config
defConfig = Config
{ executable = "linkern"
, verbose = False
, timeBound = Nothing
, steps = Nothing
, runs = 1
, otherArgs = [] }
type R2 = (Double, Double)
tsp
:: Config
-> (a -> R2)
-> [a]
-> IO [a]
tsp cfg getCoord xs =
withSystemTempFile "log" $ \_ logHdl ->
withSystemTempFile "coords" $ \coordsPath coordsHdl ->
withSystemTempFile "tour" $ \tourPath tourHdl -> do
let pts = IM.fromList $ zip [0..] xs
mapM_ (hPutStrLn coordsHdl)
[ "TYPE:TSP"
, "DIMENSION:" ++ show (IM.size pts)
, "EDGE_WEIGHT_TYPE:EUC_2D"
, "NODE_COORD_SECTION" ]
forM_ (IM.toList pts) $ \(i,p) -> do
let (x,y) = getCoord p
hPrintf coordsHdl "%d %f %f\n" i x y
hPutStrLn coordsHdl "EOF"
hClose coordsHdl
let optArg flag fmt proj = case proj cfg of
Nothing -> []
Just x -> [flag, printf fmt x]
allArgs = concat [ ["-o", tourPath]
, ["-r", show (runs cfg)]
, optArg "-t" "%f" timeBound
, optArg "-R" "%d" steps
, otherArgs cfg
, [coordsPath] ]
subOut = if verbose cfg then P.Inherit else P.UseHandle logHdl
procCfg = (P.proc (executable cfg) allArgs) { P.std_out = subOut }
(Nothing, Nothing, Nothing, procHdl) <- P.createProcess procCfg
ec <- P.waitForProcess procHdl
case ec of
ExitSuccess -> return ()
ExitFailure n -> throwIO . ErrorCall . errStr $
("process exited with code " ++ show n ++ extra) where
extra | n == 127 = "; program not installed or not in path?"
| otherwise = ""
lns <- lines `fmap` hGetContents tourHdl
_ <- evaluate (length lns)
let get = headMay >=> readMay >=> flip IM.lookup pts
fj = fromMaybe (error (errStr "internal error in lookup"))
return $ map (fj . get . words) (drop 1 lns)