module FileFormat.TSPLIB(
loadTSPFile
)where
import CombinatorialOptimisation.TSP
import Data.Maybe
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Array as A
import qualified Data.Array.Unboxed as U
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lex.Double as BL
import Data.List
import CombinatorialOptimisation.TSP.FixedPoint
euclidianDistance :: Double->Double->Double->Double->Double
euclidianDistance a b c d = sqrt ((ac)*(ac)+(bd)*(bd))
euclidianDistanceCeil :: Double->Double->Double->Double->Double
euclidianDistanceCeil a b c d = fromIntegral . ceiling $ euclidianDistance a b c d
pseudoEuclideanDistance :: Double->Double->Double->Double->Double
pseudoEuclideanDistance a b c d = let e = sqrt (((ac)*(ac)+(bd)*(bd)) /10 )
f = fromIntegral (floor e)
in if f<e then f+1 else f
geoDistance :: Double->Double->Double->Double->Double
geoDistance x1 y1 x2 y2 = encodeFloat (floor dij) 0
where
q1 = cos (lon1 lon2)
q2 = cos (lat1 lat2)
q3 = cos (lat1 + lat2)
lon1 = degConvert y1
lon2 = degConvert y2
lat1 = degConvert x1
lat2 = degConvert x2
dij = 6378.388 * (acos( 0.5*((1.0+q1)*q2 ((1.0q1)*q3) )) ) + 1.0
degConvert m = let deg = encodeFloat (floor m) 0
miN = m deg
in 3.141592 * (deg + (5.0 * miN/3.0))/180.0
data Specification = IGNORE B.ByteString
| USEFUL SpecificationName B.ByteString
| ENDSPEC B.ByteString
| FAIL B.ByteString deriving Show
data SpecificationName = TYPE | DIMENSION | EDGEWEIGHTTYPE | EDGEWEIGHTFORMAT
| DATAPARTTYPE deriving (Show, Eq)
nodeCoordConst = B.pack "NODE COORD"
edgeWeightConst = B.pack "EDGE WEIGHT"
isUsefulSpec (USEFUL _ _) = True
isUsefulSpec _ = False
readSpecificationLine :: B.ByteString->Specification
readSpecificationLine s
| likeString (B.pack "NAME") s = IGNORE s
| likeString (B.pack "TYPE") s = USEFUL TYPE (trim s)
| likeString (B.pack "NODE_COORD_SECTION") s = ENDSPEC nodeCoordConst
| likeString (B.pack "EDGE_WEIGHT_SECTION") s = ENDSPEC edgeWeightConst
| likeString (B.pack "COMMENT") s = IGNORE s
| likeString (B.pack "DIMENSION") s = USEFUL DIMENSION (trim s)
| likeString (B.pack "DISPLAY_DATA_TYPE") s = IGNORE s
| likeString (B.pack "EDGE_WEIGHT_TYPE") s = USEFUL EDGEWEIGHTTYPE (trim s)
| likeString (B.pack "EDGE_WEIGHT_FORMAT") s = USEFUL EDGEWEIGHTFORMAT (trim s)
| otherwise = FAIL $ B.append (B.pack "unrecognised field in specification : ") s
where
likeString q s = B.take (B.length q) s == q
trim s = let s' = (B.dropWhile (==' ')) . (B.drop 1) . (B.dropWhile (/=':')) $ s
in B.reverse . (B.dropWhile (==' ')) . B.reverse $ s'
readSpecification :: [B.ByteString]->([Specification],[B.ByteString])
readSpecification [] = ([FAIL $ B.pack "seem to have run out of data, without ending the specification phase"],[])
readSpecification (s:ss) = let p = readSpecificationLine s
(rs,es) = readSpecification ss
in case p of
ENDSPEC k -> ([USEFUL DATAPARTTYPE k],ss)
IGNORE _ -> (p:rs,es)
FAIL _ -> (p:rs,es)
USEFUL _ _ -> (p:rs,es)
loadTSPFile :: InternalStorage->FilePath->IO TSPProblem
loadTSPFile storageType fName
= do rawContents<-B.readFile fName
let (spec,remainder) = readSpecification $ B.lines rawContents
let specList = map (\(USEFUL a b)->(a,b)) . filter isUsefulSpec $ spec
let dataPart = fromJust $ lookup DATAPARTTYPE specList
let numNodes = fst . fromJust . B.readInt . fromJust $ lookup DIMENSION specList
if dataPart == nodeCoordConst
then return $ loadFromNodePositions storageType numNodes specList (myEOF remainder)
else if dataPart == edgeWeightConst
then return $ loadFromMatrix storageType numNodes specList (myEOF remainder)
else error "Unsupported data section"
where
myEOF = takeWhile (/= (B.pack "EOF"))
loadFromNodePositions :: InternalStorage->Int->[(SpecificationName,B.ByteString)]->[B.ByteString]->TSPProblem
loadFromNodePositions storageType numCities spec d
= let d' = map ((map readF) . (drop 1) . B.words) d
posArrA = U.listArray (0 , numCities1) (map head d')
posArrB = U.listArray (0 , numCities1) (map last d')
cities = [0 ..(numCities1)]
explicit = U.listArray (0,numCities*numCities1)
[unwrappedFP $ distFunc (posArrA A.! a) (posArrB A.! a) (posArrA A.! b) (posArrB A.! b) | a<-cities,b<-cities]
triangular = U.listArray (0,sum [0..numCities])
[unwrappedFP $ distFunc (posArrA A.! a) (posArrB A.! a) (posArrA A.! b) (posArrB A.! b) | a<-cities,b<-[0..a]]
p = case storageType of
ExplicitMatrix -> \x y->FP $ explicit A.! (x * numCities + y)
TriangularMatrix -> (\x y->let x' = min x y; y' = max x y in FP $ triangular A.! (div (y'*y'+y') 2 + x'))
Recomputation -> \a b->realToFrac $ distFunc (posArrA A.! a) (posArrB A.! a) (posArrA A.! b) (posArrB A.! b)
in TSPProblem 0 p numCities IM.empty IM.empty
where
readF :: B.ByteString->Double
readF = fst . fromJust . BL.readDouble
distanceFunctionSpec = fromJust $ lookup EDGEWEIGHTTYPE spec
distFunc = if distanceFunctionSpec == (B.pack "GEO")
then geoDistance
else if distanceFunctionSpec == (B.pack "EUC_2D")
then euclidianDistance
else if distanceFunctionSpec == (B.pack "ATT")
then pseudoEuclideanDistance
else if distanceFunctionSpec == (B.pack "CEIL_2D")
then euclidianDistanceCeil
else error $ "unsupported distance function : "++(show distanceFunctionSpec)
loadFromMatrix :: InternalStorage->Int->[(SpecificationName,B.ByteString)]->[B.ByteString]->TSPProblem
loadFromMatrix Recomputation _ _ _ = error "Cannot load matrix and store in recomputation form"
loadFromMatrix storageType numCities spec d
| distanceFunctionSpec /= B.pack "EXPLICIT" = error "loading from non explicit matrix? (does not make sense)"
| storageType == TriangularMatrix = TSPProblem 0 (\x y->let x' = min x y; y' = max x y in FP $ triangularArray A.! (div (y'*y'+y') 2 + x')) numCities IM.empty IM.empty
| storageType == ExplicitMatrix = TSPProblem 0 (\x y->FP $ explicitArray A.! (y * numCities + x)) numCities IM.empty IM.empty
where
readF = unwrappedFP . (read :: String->Double) . B.unpack
distanceFunctionSpec = fromJust $ lookup EDGEWEIGHTTYPE spec
inputNumberSequence = concatMap ((map readF) . B.words) d
cities = [0 ..(numCities1)]
blankMatrix = foldl' (\m d->M.insert (d,d) 0 m) M.empty cities
fillPair m ((a,b),c) = M.insert (b,a) c $ (M.insert (a,b) c m)
makeFromTri = foldl' fillPair blankMatrix
loadedMap = makeWeightsInternal (fromJust $ lookup EDGEWEIGHTFORMAT spec)
makeWeightsInternal inp
| B.pack "FULL_MATRIX" == inp = foldl' (\m (d,c)->M.insert d c m) M.empty (zip [(a,b) | a<-cities,b<-cities] inputNumberSequence)
| B.pack "UPPER_ROW" == inp = makeFromTri $ zip [(a,b) | a<-cities,b<-[a..(numCities 1)],a/=b] inputNumberSequence
| B.pack "LOWER_ROW" == inp = makeFromTri $ zip [(a,b) | a<-cities,b<-[0..a],a/=b] inputNumberSequence
| B.pack "UPPER_DIAG_ROW" == inp = makeFromTri $ zip [(a,b) | a<-cities,b<-[a..(numCities 1)]] inputNumberSequence
| B.pack "LOWER_DIAG_ROW" == inp = makeFromTri $ zip [(a,b) | a<-cities,b<-[0..a]] inputNumberSequence
| B.pack "UPPER_COL" == inp = makeFromTri $ zip [(b,a) | a<-cities,b<-[a..(numCities 1)],a/=b] inputNumberSequence
| B.pack "LOWER_COL" == inp = makeFromTri $ zip [(b,a) | a<-cities,b<-[0..a],a/=b] inputNumberSequence
| B.pack "UPPER_DIAG_COL" == inp = makeFromTri $ zip [(b,a) | a<-cities,b<-[a..(numCities 1)]] inputNumberSequence
| B.pack "LOWER_DIAG_COL" == inp = makeFromTri $ zip [(b,a) | a<-cities,b<-[0..a]] inputNumberSequence
explicitArray = U.listArray (0,numCities*numCities1) [loadedMap M.! (a,b) | a<-cities,b<-cities]
triangularArray = U.listArray (0,sum [0..numCities]) [loadedMap M.! (a,b) | a<-cities,b<-[0..a]]