diff --git a/Algorithms/Concorde/LinKern.hs b/Algorithms/Concorde/LinKern.hs new file mode 100644 --- /dev/null +++ b/Algorithms/Concorde/LinKern.hs @@ -0,0 +1,116 @@ +-- | Approximate a solution to 2D Euclidean TSP using the Lin-Kernighan +-- heuristic. +module Algorithms.Concorde.LinKern + ( -- * The heuristic + tsp, R2 + -- * Configuration + , 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: " ++) + +-- | Configuration for @'tsp'@. +data Config = Config + { -- | Path to the @linkern@ executable. Searches @$PATH@ by default. + executable :: FilePath + -- | If set, write progress information to standard output. + , verbose :: Bool + -- | Stop looking for better solutions after this many seconds. + , timeBound :: Maybe Double + -- | Run this many optimization steps. Default is the number of points. + , steps :: Maybe Int + -- | Run this many separate optimizations. Default is 1. + , runs :: Int + -- | Other command-line arguments to the @linkern@ executable. + , otherArgs :: [String] + } deriving (Eq, Ord, Read, Show) + +-- | Default configuration. +defConfig :: Config +defConfig = Config + { executable = "linkern" + , verbose = False + , timeBound = Nothing + , steps = Nothing + , runs = 1 + , otherArgs = [] } + +-- | A point in Euclidean two-dimensional space. +type R2 = (Double, Double) + +-- | Approximate a solution to the two-dimensional Euclidean Traveling +-- Salesperson Problem, using the Lin-Kernighan heuristic. +-- +-- Invokes Concorde's @linkern@ executable as an external process. +-- +-- Note: @linkern@ uses Euclidean distance rounded to the nearest integer. +-- You may need to scale up coordinates in the function passed to @'tsp'@. +tsp + :: Config -- ^ Configuration. + -> (a -> R2) -- ^ Gives the rectangular coordinates of each point; see below. + -> [a] -- ^ List of points to visit. + -> IO [a] -- ^ Produces points permuted in tour order. +tsp cfg getCoord xs = + -- Log to a temp file if not verbose. + -- On Unix we could open /dev/null, but this is not portable. + withSystemTempFile "log" $ \_ logHdl -> + withSystemTempFile "coords" $ \coordsPath coordsHdl -> + withSystemTempFile "tour" $ \tourPath tourHdl -> do + + -- Output coordinates in TSPLIB format + 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 + + -- Invoke linkern + 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 = "" + + -- Skip the first line, then read the first int of each remaining + -- line as an index into the original list of points. + 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) Keegan McAllister 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,15 @@ +This package provides a simple interface to Concorde, a solver for the +Traveling Salesperson Problem. Concorde is available from: + + http://www.tsp.gatech.edu/concorde/index.html + + +Documentation for this package is hosted at: + + http://hackage.haskell.org/package/concorde + +To build the documentation yourself, run + + $ cabal configure && cabal haddock --hyperlink-source + +This will produce HTML documentation under dist/doc/html/concorde diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/concorde.cabal b/concorde.cabal new file mode 100644 --- /dev/null +++ b/concorde.cabal @@ -0,0 +1,44 @@ +name: concorde +version: 0.1 +license: BSD3 +license-file: LICENSE +synopsis: Simple interface to the Concorde solver for the Traveling Salesperson Problem +category: Algorithms +author: Keegan McAllister +maintainer: Keegan McAllister +build-type: Simple +cabal-version: >=1.6 +description: + This package provides a simple interface to Concorde, a solver for the + Traveling Salesperson Problem (TSP). Concorde is available from + . + . + This library uses the Lin–Kernighan heuristic via Concorde's @linkern@ + program. It quickly produces good tours, which may not be optimal. You + can directly control the tradeoff between run time and solution quality. + . + An example program is included. + . + Currently, only problems in two-dimensional Euclidean space are supported. + . + More features of Concorde can be added on request. Feature requests and + patches are always welcome. + +extra-source-files: + README + , examples/visualize.hs + +library + exposed-modules: + Algorithms.Concorde.LinKern + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , containers >= 0.4 + , temporary >= 1.1 + , process >= 1.0 + , safe >= 0.3 + +source-repository head + type: git + location: git://github.com/kmcallister/concorde diff --git a/examples/visualize.hs b/examples/visualize.hs new file mode 100644 --- /dev/null +++ b/examples/visualize.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE + DeriveDataTypeable + , RecordWildCards #-} +module Main(main) where + +-- Visualize results of Lin-Kernighan on random points +-- +-- deps : cabal install diagrams cmdargs +-- build: ghc -O --make visualize.hs +-- usage: ./visualize -? + + +import qualified Algorithms.Concorde.LinKern as T + +-- package 'diagrams' and dependencies +import qualified Diagrams.Prelude as D +import qualified Diagrams.Backend.Cairo as D +import qualified Data.Colour.SRGB as D +import qualified Data.Colour.RGBSpace as D +import qualified Data.Colour.RGBSpace.HSV as D + +-- package 'cmdargs' +import qualified System.Console.CmdArgs as Arg +import System.Console.CmdArgs ( (&=), Typeable, Data ) + +import Control.Monad +import Data.List +import Data.Monoid +import System.IO +import System.Random +import System.Exit + + +data Visualize = Visualize + { out :: String + , numPoints :: Int + , linkern :: FilePath + , verbose :: Bool + , timeBound :: Maybe Double + , steps :: Maybe Int + , runs :: Int } + deriving (Show, Typeable, Data) + +argSpec :: Visualize +argSpec = Visualize + { out = "out.pdf" &= Arg.help "Name of output PDF file [out.pdf]" + , numPoints = 1000 &= Arg.help "Number of points [1000]" + , linkern = "linkern" &= Arg.help "Path to linkern executable [search $PATH]" + , verbose = False &= Arg.help "Write progress information to standard output [no]" + , timeBound = Nothing &= Arg.help "Stop looking for better solutions after this many seconds [no]" + , steps = Nothing &= Arg.help "Run this many optimization steps [# points]" + , runs = 1 &= Arg.help "Run this many separate optimizations [1]" } + + &= Arg.summary "Visualize results of Lin-Kernighan on random points" + + +type Diagram = D.Diagram D.Cairo D.R2 + +diaPoints :: Int -> [T.R2] -> Diagram +diaPoints n = mconcat . map circ . zip [0..] where + nn = fromIntegral n + circ (i,p) = D.translate p . D.fc color $ D.circle 40 where + color = D.uncurryRGB D.sRGB (D.hsv (360*i/nn) 1 1) + +diaTour :: [T.R2] -> Diagram +diaTour [] = mempty +diaTour xs@(x:_) = sty . D.fromVertices $ map D.P (xs ++ [x]) where + sty = D.fc D.lightgrey . D.lw 10 + +writePDF :: FilePath -> Diagram -> IO () +writePDF pdfName dia = fst $ D.renderDia D.Cairo opts dia where + opts = D.CairoOptions pdfName (D.PDF (400,400)) + + +main :: IO () +main = do + Visualize{..} <- Arg.cmdArgs argSpec + let cfg = T.Config + { T.executable = linkern + , T.verbose = verbose + , T.timeBound = timeBound + , T.steps = steps + , T.runs = runs + , T.otherArgs = [] } + vOut = if verbose then putStrLn else const (return ()) + + vOut "[*] Generating points" + let rnd = randomRIO (0,10000) + points <- replicateM numPoints (liftM2 (,) rnd rnd) + + vOut "[*] Computing tour" + tour <- T.tsp cfg id points + + vOut "[*] Checking output" + when (sort tour /= sort points) $ do + hPrint stderr (sort tour, sort points) + hPutStrLn stderr "ERROR: tour is not a permutation" + exitFailure + + vOut "[*] Writing PDF" + writePDF out (diaPoints numPoints tour D.<> diaTour tour) + + vOut "Done!"