gistfile2.txt

TSP.hs

import Data.List
import Data.Maybe
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Tree
import Data.Graph.Inductive.Internal.RootPath
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Query.MST
import Control.Applicative
import Control.Monad
import Text.Printf
import System.Random

-- Utilities
randomRnIO :: Random a => Int -> (a, a) -> IO [a]
randomRnIO n r = sequence $ replicate n (randomRIO r)

pathEdges :: Path -> [Edge]
pathEdges p = zip p (tail p)

-- Spanning Tree Graph
type SGr = Gr () ()

rTreeToGraph :: RTree -> SGr
rTreeToGraph t = mkUGraph (nub $ concat t) (nub $ concatMap pathEdges t)

lrTreeToGraph :: LRTree b -> SGr
lrTreeToGraph = rTreeToGraph . unlabLRTree
  where
    unlabLRTree :: LRTree b -> RTree
    unlabLRTree = map lPathToPath

    lPathToPath :: LPath a -> Path
    lPathToPath (LP p) = map fst p

msGraph :: Real b => Gr a b -> SGr
msGraph = lrTreeToGraph . msTree

hamiltonPath :: SGr -> Path
hamiltonPath g = let p = udfs' g in last p:p

-- Euclidean Metric Graph
type Norm = Float
type Point = (Int, Int)
type EGr = Gr Point Norm
type ENode = LNode Point
type EEdge = LEdge Norm

genEGraph :: Int -> (Int, Int) -> (Int, Int) -> IO EGr
genEGraph n xr yr = undir <$> mkEGraph <$> genPoints
  where
    genPoints :: IO [(Int, Int)]
    genPoints = liftM2 zip (randomRnIO n xr) (randomRnIO n yr)

    mkEGraph :: [Point] -> EGr
    mkEGraph vs = let ns = zip [0..] vs in mkGraph ns (mkEdges ns)

    mkEdges :: [ENode] -> [EEdge]
    mkEdges [] = []
    mkEdges (n:ns) = (mkEdges' n ns) ++ mkEdges ns

    mkEdges' :: ENode -> [ENode] -> [EEdge]
    mkEdges' n = map $ mkEdge n

    mkEdge :: ENode -> ENode -> EEdge
    mkEdge (n, (x, y)) (n', (x', y')) = let dx = fromIntegral (x - x')
                                            dy = fromIntegral (y - y')
                                        in (n, n', sqrt $ dx ** 2 + dy ** 2)

-- SVG
type Pen = (String, Int)

svg :: Int -> Int -> [(ENode, Pen)] -> [(Edge, Pen)] -> String
svg w h ns es = header ++ edges ++ nodes ++ footer
  where
    lns = map fst ns
    header = printf "<svg xml:space=\"default\" width=\"%d\" height=\"%d\">" w h
    node ((_, (x, y)), (c, s)) = printf "<circle cx=\"%d\" cy=\"%d\" r=\"5\" fill=\"white\" stroke=\"%s\" stroke-width=\"%d\" />" x y c s
    nodes = concatMap node ns
    edge ((n, n'), b) = edge' b (fromJust $ lookup n lns) (fromJust $ lookup n' lns)
    edge' (c, s) (x, y) (x', y') = printf "<line x1=\"%d\" y1=\"%d\" x2=\"%d\" y2=\"%d\" stroke=\"%s\" stroke-width=\"%d\" />" x y x' y' c s
    edges = concatMap edge es
    footer = "</svg>"

main = do
  let w = 1000; h = 1000
  g <- genEGraph 100 (0, w) (0, h)
  let nb = ("black", 3)
      eb = ("green", 1)
      heb = ("blue", 3)
      ns = labNodes g
      es = edges g
      sg = msGraph g
      hp = hamiltonPath sg
      hes = pathEdges hp
      cns = zip ns (repeat nb)
      ces = zip (es \\ hes) (repeat eb)
      ches = zip hes (repeat heb)
  putStrLn $ svg w h cns (ces ++ ches)