diff --git a/CombinatorialOptimisation/SAT.hi b/CombinatorialOptimisation/SAT.hi deleted file mode 100644 Binary files a/CombinatorialOptimisation/SAT.hi and /dev/null differ diff --git a/CombinatorialOptimisation/SAT.hs~ b/CombinatorialOptimisation/SAT.hs~ deleted file mode 100644 --- a/CombinatorialOptimisation/SAT.hs~ +++ /dev/null @@ -1,186 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : CombinatorialOptimisation.SAT --- Copyright : (c) Richard Senington 2011 --- License : GPL-style --- --- Maintainer : Richard Senington --- Stability : provisional --- Portability : portable --- --- A library for the representation and manipulation of satisfiability problems. --- Currently this is expected to only be 3-SAT however I do not think the --- code is particularly limited to 3-SAT. The approach taken is that there --- is a complex data structure called SATProblem, which contains both the --- problem and the solution (settings of variables). In addition it contains --- a number additional fields that allow for making changes quickly, such --- as a table of clause positions. This is a Map from clause index to the --- number of variable terms that are currently set to true. --- --- Currently the only function for quickly changing a problem is the flipping --- of a single variable. I think some other low level operations for finding --- clauses not currently evaluating to true and so on would be useful. ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} - -module CombinatorialOptimisation.SAT( - SATProblem(SATProblem,numClauses,numSATEDClauses,numVariables,variableLookUp,variablePosition,clausePosition,clauseLookUp), - numUnSATEDClauses,getTrueFalseCount,summariseSAT,makeRandomSATProblem,flipVariable,satproblem,setAllVars,randomiseVariables -)where - -import qualified Data.Map as M -import qualified Data.Array as A -import Data.List -import System.Random -import System.IO.Unsafe -import Data.Char - -data SATProblem = SATProblem { numClauses :: Int, - numSATEDClauses :: Int, - numVariables :: Int, - variableLookUp :: Int->([Int],[Int]), - clauseLookUp :: Int->([Int],[Int]), - variablePosition :: M.Map Int Bool, - clausePosition :: M.Map Int Int} - -instance Eq SATProblem where - (==) s1 s2 = (numSATEDClauses s1) == (numSATEDClauses s2) && (variablePosition s1) == (variablePosition s2) - -instance Ord SATProblem where - compare s1 s2 = compare (numSATEDClauses s2) (numSATEDClauses s1) - -instance Show SATProblem where - show s = showSATLogic s ++"\n"++ showVARPosition s ++"\n"++ summariseSAT s++"\n"++(show $ getTrueFalseCount s) - -{- | For the purposes of getting a general impression of the state of the system, - it returns the number of variables in the True, and False positions. -} - -getTrueFalseCount :: SATProblem->(Int,Int) -getTrueFalseCount s = let ls = M.elems $ variablePosition s - in (length (filter (==True) ls),length (filter (==False) ls)) - -{- | The number of unsatisfied clauses in the problem, the inverse of numSATEDClauses -} - -numUnSATEDClauses :: SATProblem->Int -numUnSATEDClauses s = numClauses s - numSATEDClauses s - -{- | Partial display function, for usage in show, this displays the logic of the problem. -} - -showSATLogic :: SATProblem->String -showSATLogic s = concat (intersperse " /\\\n" (map writeClause [0 .. numClauses s -1])) ++ "\n" - where - writeClause c = let (as,bs) = clauseLookUp s c - (as',bs') = (map (\a->(a,' ')) as,map (\a->(a,'!')) bs) - cs = sortBy (\a b->compare (fst a) (fst b)) $ as' ++ bs' - in '(' : (concat $ intersperse " \\/ " $ [ d :'x':show c | (c,d)<-cs]) ++ ")" - -{- | Partial display function, for usage in show, displays some general statistics about - the solution status. -} - -summariseSAT :: SATProblem->String -summariseSAT s = concat ["number of clauses : ",show (numClauses s),"\n", - "number of variables : ",show (numVariables s),"\n", - "satisfied clauses : ",show (numSATEDClauses s),"\n", - satMessage,"\n"] - where - sat = (numSATEDClauses s) == (numClauses s) - satMessage = if sat then "SATisfied" else "unSATisfied" - -{- | Partial display function, for usage in show, displays the setting of each variable. -} - -showVARPosition :: SATProblem->String -showVARPosition s = concat [concat [" x",show v," = ",show t,"\n" ] |(v,t)<- M.assocs (variablePosition s)] - -{- | Alternative constructor for the data structure. Takes only those elements that can - not be derived and correctly initialises the other components, such as calculating - how many clauses are currently evaluating to true. Requires the number of clauses, - the number of variables, the lookup function for variables (variable index - returning two lists, the first is the indexes of clauses in which this variable - is present, the second list the indexes of clauses in which the inverse of this variable - is present), the lookup table for clauses (clause index to lists of variable indexes) - and the current settings of each variable. -} - -satproblem :: Int->Int->(Int->([Int],[Int]))->(Int->([Int],[Int]))->M.Map Int Bool->SATProblem -satproblem nClauses nVars varLookup claLookup varPosition - = SATProblem nClauses satClause nVars varLookup claLookup varPosition finalClausePosition - where - varList = [0 .. nVars -1] - initialClausePositions = M.fromList $ zip [0 .. nClauses -1] $ repeat 0 - finalClausePosition = foldl f M.empty [0 .. nVars -1] - f m v = let (ords,negs) = varLookup v - varPos = varPosition M.! v - in if varPos then foldl (\m' c->M.adjust (+1) c m') m ords else foldl (\m' c->M.adjust (+1) c m') m negs - satClause = sum $ map (\x->if x ==0 then 0 else 1) (M.elems finalClausePosition) - -{- | For rapid initialisation of problem instances. This fixes the setting of - all variables to either true or false. The effect this has on the number - of clauses that evaluate to true is unknown until it is carried out. -} - -setAllVars :: Bool->SATProblem->SATProblem -setAllVars b s = satproblem (numClauses s) (numVariables s) (variableLookUp s) (clauseLookUp s) initialVarPosition - where - initialVarPosition = M.fromList $ zip [0 .. numVariables s -1] $ repeat b - -{- | For rapid initialisation of problem instances for usage in stochastic algorithms. - Specifically expected to be used for genetic algorithms and other forms of - stochastic meta-heuristic. -} - -randomiseVariables :: RandomGen g=>g->SATProblem->SATProblem -randomiseVariables g s = satproblem (numClauses s) (numVariables s) (variableLookUp s) (clauseLookUp s) varpos - where - varpos = M.fromList $ zip [0 .. (numVariables s) -1] $ (randoms g :: [Bool]) - -{- | I am not sure how often this will be used in practice, as randomly created problems - often seem to be quite easy to solve. Requires a source of random numbers, the number - of variables and the number of clauses to create, in that order. It is assumed - that 3-SAT problems are the type wanted. -} - -makeRandomSATProblem :: RandomGen g=>g->Int->Int->SATProblem -makeRandomSATProblem gen numVariables numClauses - = satproblem numClauses numVariables varLookup claLookup initialVarPosition - where - initialVarPosition = M.fromList $ zip [0 .. numVariables -1] $ repeat False - clauses = take numClauses $ nub (unfoldr generateRandomClause gen) - generateRandomClause g = let f (ms,ns) gen' - | length ms + length ns == 3 = (ms,ns,gen') - | otherwise = let (l :: Int,gen'') = randomR (0,1) gen' - (n :: Int,gen''') = randomR (0,numVariables -1) gen'' - already = elem n ms || elem n ns - in if already then f (ms,ns) gen''' - else if l ==0 then f (n:ms,ns) gen''' - else f (ms,n:ns) gen''' - (ords,negs,g') = f ([],[]) g - in Just ((sort ords,sort negs),g') - emptyClauseData = M.fromList $ zip [0 .. numVariables -1] (repeat ([],[])) - basicClauseLookup = foldl constructClauseLookup emptyClauseData $ zip [0..] clauses - varLookup = ((A.listArray (0,numVariables-1) (M.elems basicClauseLookup)) A.!) - constructClauseLookup m (clauseIndex,(ords,negs)) = let addNeg m' x = M.adjust (\(as,bs)->(as,clauseIndex:bs)) x m' - addOrd m' x = M.adjust (\(as,bs)->(clauseIndex:as,bs)) x m' - in foldl addNeg (foldl addOrd m ords) negs - claLookup = ((A.listArray (0,numVariables-1) clauses) A.!) - -{- | The first low level operation. Takes a problem and changes the - setting of the indexed variable from true to false. This is - expected to be used in conjunction with other program logic - to select which index to flip. -} - -flipVariable :: Int->SATProblem->(SATProblem,Int) -flipVariable v s - = let modifiedVarPos = M.insert v changedVar (variablePosition s) - in (s{numSATEDClauses=numSATEDClauses s + overAllChange,variablePosition=modifiedVarPos,clausePosition=modifiedClausePos},overAllChange) - where - overAllChange = ordChange + negChange - changedVar = not $ (variablePosition s) M.! v - (ords,negs) = (variableLookUp s) v - cp = clausePosition s - (cp',ordChange) = if changedVar then foldl countInc (cp,0) ords else foldl countDec (cp,0) ords - (modifiedClausePos,negChange) = if changedVar then foldl countDec (cp',0) negs else foldl countInc (cp',0) negs - countInc (positions,counter) i = let current = positions M.! i - counter' = if current == 0 then counter+1 else counter - in (M.insert i (current+1) positions,counter') - countDec (positions,counter) i = let current = positions M.! i - counter' = if current == 1 then counter-1 else counter - in (M.insert i (current-1) positions,counter') - - diff --git a/CombinatorialOptimisation/SAT.o b/CombinatorialOptimisation/SAT.o deleted file mode 100644 Binary files a/CombinatorialOptimisation/SAT.o and /dev/null differ diff --git a/CombinatorialOptimisation/TSP.hi b/CombinatorialOptimisation/TSP.hi deleted file mode 100644 Binary files a/CombinatorialOptimisation/TSP.hi and /dev/null differ diff --git a/CombinatorialOptimisation/TSP.hs b/CombinatorialOptimisation/TSP.hs --- a/CombinatorialOptimisation/TSP.hs +++ b/CombinatorialOptimisation/TSP.hs @@ -42,7 +42,8 @@ ----------------------------------------------------------------------------- module CombinatorialOptimisation.TSP( - TSPProblem(TSPProblem,currentPrice,routeMap,edgePrices,numCities,routeElementToIndex,indexToRouteElement), + TSPProblem(TSPProblem,routeMap,numCities,routeElementToIndex,indexToRouteElement), + edgeCost,solutionValue,getTSPPathAsList, InternalStorage(ExplicitMatrix,TriangularMatrix,Recomputation), showEdgeWeights, exchangeCities, @@ -60,6 +61,10 @@ import System.Random import Data.List +-- going to use a fixed point internal representation, only doing additiona afterall + +import CombinatorialOptimisation.TSP.FixedPoint + {- | The data type for carrying the combination problem and solution to the TSP. The route is stored as a dictionary of associations from vertex name to a pair of values, the name of the preceding @@ -74,14 +79,28 @@ very different parts of the cycle. -} -data TSPProblem = TSPProblem { currentPrice :: Float, +data TSPProblem = TSPProblem { solutionValueI :: FP, routeMap :: M.Map Int (Int,Int), - edgePrices :: (Int->Int->Float), + edgeCostI :: (Int->Int->FP), numCities :: Int, routeElementToIndex :: M.Map Int Int, indexToRouteElement :: M.Map Int Int } +{- | Internally the value of the solution is stored as a fixed point value, stored in an Int64 data type. + For external visibility however this function is provided, converting the value into a floating point numbers. +-} + +solutionValue :: Floating a=>TSPProblem->a +solutionValue = realToFrac . solutionValueI + +{- | Internally all edge costs are stored as a fixed point values. + For external visibility however this function is provided, converting the values into floating point numbers. +-} + +edgeCost :: Floating a=>TSPProblem->Int->Int->a +edgeCost t a b = realToFrac $ edgeCostI t a b + {- | There are three possible internal storage forms. A full explicit matrix, an upper triangular matrix or recomputation from data points. The advantage of full explicit is speed, but it takes more memory. It is also the only option for asymmetric TSP problems. The triangular matrix is also fast, but can only be used in symmetric problems, and also @@ -94,12 +113,13 @@ instance Show TSPProblem where show t = concat ["TSPProblem of ",show . numCities $ t, - " cities\n Current Solution ",show r, - "\n Costing ",show . currentPrice $ t,"\n"] - where - rm = snd . ((M.!) (routeMap t)) - r = 0:(takeWhile (\x->x/=0) $ iterate rm (rm 0))++[0] + " cities\n Current Solution ",show . getTSPPathAsList $ t, + "\n Costing ",show . solutionValue $ t,"\n"] +getTSPPathAsList :: TSPProblem->[Int] +getTSPPathAsList t = let rm = snd . ((M.!) (routeMap t)) + in 0:(takeWhile (\x->x/=0) $ iterate rm (rm 0))++[0] + {- | Converts the lookup table of a problem into a comma and newline delimited string. This should facilitate copying into spreadsheets for checking the problem being used and validating solutions by hand. -} @@ -107,7 +127,7 @@ showEdgeWeights :: TSPProblem->String showEdgeWeights t = headerRow ++ concatMap makeRow nc where - ep = edgePrices t + ep = edgeCost t nc = [0 .. numCities t-1] headerRow = ',': concat (intersperse "," $ map show [0..numCities t-1]) ++ "\n" makeRow i = show i ++ "," ++ concat (intersperse "," [ show (ep i' i) | i'<-nc]) ++"\n" @@ -117,23 +137,24 @@ @exchangeCitiesOnIndex@. -} exchangeCities :: Int->Int->TSPProblem->TSPProblem -exchangeCities a b t = exchangeCitiesOnIndex (min i1 i2) (max i1 i2) t +exchangeCities a b t = exchangeCitiesOnIndex i1 i2 t where i1 = routeElementToIndex t M.! a i2 = routeElementToIndex t M.! b {- | Performs the bulk of the work for exchanging elements of the cycle. - It assumes that the order of the indexes is increasing (e.g. 0 2 not 2 0). - While changing the order it will also calculate the change in value of the - route and update this. This is performed fairly efficiently by finding the - edges being removed, and the edges being created and adding the difference - between the two to the current price. -} + This version no longer assumes the indices are ordered due to confusion this + caused in my own code. In addition there was an oversight, when exchanging indices + 0 and last. This is now fixed. + -} exchangeCitiesOnIndex :: Int->Int->TSPProblem->TSPProblem exchangeCitiesOnIndex i1 i2 t + | i1 > i2 = exchangeCitiesOnIndex i2 i1 t | d == 0 = t - | d == 1 = t{routeMap=rAdj,currentPrice=currentPrice t + priceChangeAdj,routeElementToIndex=t2',indexToRouteElement=t1'} - | otherwise = t{routeMap=r',currentPrice=currentPrice t + priceChange,routeElementToIndex=t2',indexToRouteElement=t1'} + | d == 1 = t{routeMap=rAdj,solutionValueI=solutionValueI t + priceChangeAdj,routeElementToIndex=t2',indexToRouteElement=t1'} + | d == (numCities t -1) = t{routeMap=rAdj',solutionValueI=solutionValueI t + priceChangeAdj',routeElementToIndex=t2',indexToRouteElement=t1'} + | otherwise = t{routeMap=r',solutionValueI=solutionValueI t + priceChange,routeElementToIndex=t2',indexToRouteElement=t1'} where d = abs (i1 - i2) @@ -141,7 +162,7 @@ r = (routeMap t) a = indexToRouteElement t M.! i1 b = indexToRouteElement t M.! i2 - p = edgePrices t + p = edgeCostI t ((a1,a2),(b1,b2)) = (r M.! a,r M.! b) -- usual code @@ -155,15 +176,19 @@ t1' = M.insert i1 b (M.insert i2 a t1) -- adjacent exchange, special case - priceChangeAdj = sum [p a1 b,p b a,p a b2] - sum [p a1 a,p a b,p b b2] + -- failed code => priceChangeAdj = sum [p a1 b,p b a,p a b2] - sum[p a1 a,p a b,p b b2] + priceChangeAdj = sum $ zipWith (-) [p a1 b,p b a,p a b2] [p a1 a,p a b,p b b2] rAdj = foldl' (\m (k,f) -> M.adjust f k m) r [(a1,\(x,y)->(x,b)),(b2,\(x,y)->(a,y)),(a,\_->(b,b2)),(b,\_->(a1,a))] + -- special adjacent, first and last + priceChangeAdj' = sum $ zipWith (-) [p b1 a,p a b,p b a2] [p b1 b,p b a,p a a2] + rAdj' = foldl' (\m (k,f) -> M.adjust f k m) r [(a2,\(x,y)->(b,y)),(b1,\(x,y)->(x,a)),(a,\_->(b1,b)),(b,\_->(a,a2))] {- | A brute force recalculation of the current length of the path. Use sparingly.-} evaluateRouteNaive :: TSPProblem->TSPProblem -evaluateRouteNaive t = t{currentPrice=evalRoute 0} +evaluateRouteNaive t = t{solutionValueI=evalRoute 0} where - ep = edgePrices t + ep = edgeCostI t rm = snd . ((M.!) (routeMap t)) evalRoute x = let n = rm x in if n==0 then ep x n @@ -202,11 +227,11 @@ conjunction with @setRoute@ or @randomiseRoute@ to initialise for local search. Internal data structure is always fully explicit matrix.-} -makeASymmetricTSPMap :: RandomGen g=>(Float,Float)->Int->g->TSPProblem +makeASymmetricTSPMap :: RandomGen g=>(Double,Double)->Int->g->TSPProblem makeASymmetricTSPMap distanceLimits numCities g = let cities = [0 ..(numCities-1)] cityCoords = [(a,b) | a<-cities,b<-cities,a/=b] - matrix = M.fromList $ zip cityCoords (randomRs distanceLimits g) + matrix = M.fromList $ zip cityCoords (map realToFrac $ randomRs distanceLimits g) -- p' = (\x y->M.findWithDefault 0 (x,y) matrix) explicit = A.listArray (0,numCities*numCities-1) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-cities] in TSPProblem 0 M.empty (\x y->explicit A.! (y * numCities + x)) numCities M.empty M.empty @@ -220,13 +245,13 @@ does not create locations and calculate distances, but rather randomly assigns distances to each edge, making them symmetric. -} -makeSymmetricTSPMap :: RandomGen g=>InternalStorage->(Float,Float)->Int->g->TSPProblem +makeSymmetricTSPMap :: RandomGen g=>InternalStorage->(Double,Double)->Int->g->TSPProblem makeSymmetricTSPMap Recomputation _ _ _ = error "Cannot support recomputation, please use alternative storage, or makeEuclideanTSPMap" makeSymmetricTSPMap storageType distanceLimits numCities g = let cities = [0 ..(numCities-1)] cityCoords = [(a,b) | a<-cities,b<-take (a+1) cities,a/=b ] f e ((a,b),c) = M.insert (b,a) c (M.insert (a,b) c e) - matrix = foldl f M.empty (zip cityCoords (randomRs distanceLimits g)) + matrix = foldl f M.empty (zip cityCoords (map realToFrac $ randomRs distanceLimits g)) explicit = A.listArray (0,numCities*numCities-1) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-cities] triangular = A.listArray (0,sum [0..numCities]) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-[0..a]] p = if storageType == ExplicitMatrix then (\x y->explicit A.! (y * numCities + x)) @@ -239,7 +264,7 @@ are calculated, so this supports all internal storage types. -} -makeEuclideanTSPMap :: RandomGen g=>InternalStorage->(Float,Float)->(Float,Float)->Int->g->TSPProblem +makeEuclideanTSPMap :: RandomGen g=>InternalStorage->(Double,Double)->(Double,Double)->Int->g->TSPProblem makeEuclideanTSPMap storageType xRange yRange numCities g = let cities = [0 ..(numCities-1)] (genA,genB) = split g @@ -255,8 +280,8 @@ Recomputation -> \a b->if a == b then 0 else euclidianDistance (posArr A.! a) (posArr A.! b) in TSPProblem 0 M.empty p numCities M.empty M.empty where - euclidianDistance :: (Float,Float)->(Float,Float)->Float - euclidianDistance (a,b) (c,d) = sqrt ((a-c)*(a-c)+(b-d)*(b-d)) + euclidianDistance :: (Double,Double)->(Double,Double)->FP + euclidianDistance (a,b) (c,d) = realToFrac $ sqrt ((a-c)*(a-c)+(b-d)*(b-d)) diff --git a/CombinatorialOptimisation/TSP.hs~ b/CombinatorialOptimisation/TSP.hs~ deleted file mode 100644 --- a/CombinatorialOptimisation/TSP.hs~ +++ /dev/null @@ -1,262 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : CombinatorialOptimisation.TSP --- Copyright : (c) Richard Senington 2011 --- License : GPL-style --- --- Maintainer : Richard Senington --- Stability : provisional --- Portability : portable --- --- A library for the representation and manipulation of travelling salesperson --- problems. --- The approach taken is the creation of a complex data structure called --- TSPProblem which contains both the problem, the current solution and --- the current value of the route. --- The route is stored as a dictionary (@Data.Map@) of vertex indexes --- to a pair of values, the previous vertex and the next vertex in the --- sequence. This is to facilitate changing the route quickly, and --- avoid searching for data in lists. --- --- The data structure also contains two additional fields, the --- @routeElementToIndex@ and @indexToRouteElement@ components. --- These exist to allow manipulation either by the vertex number --- or the position in the current solution. --- Solutions are hamiltonian cycles. --- For ease of reasoning it is recommended that users do not --- attempt to move vertex 0, or index 0, so that solutions --- are cycles from 0 to 0. I may change this in the future to --- lock this down a bit. In the meantime, there is no --- actual problem with making these changes, however --- later manipulations may not match up clearly with --- the way the show routines work. --- --- Currently only two functions are provided for manipulating routes, --- either by position in the sequence (@exchangeCitiesOnIndex@) or --- by vertex name (@exchangeCities@). --- --- I am not sure how this will clearly support meta-heuristics that --- work by deleting edges and recombining subsequences. However --- since I am storing association lists I think it should be possible --- to make this work, I will worry about it later. ------------------------------------------------------------------------------ - -module CombinatorialOptimisation.TSP( - TSPProblem(TSPProblem,currentPrice,routeMap,edgePrices,numCities,routeElementToIndex,indexToRouteElement), - InternalStorage(ExplicitMatrix,TriangularMatrix,Recomputation), - showEdgeWeights, - exchangeCities, - exchangeCitiesOnIndex, - evaluateRouteNaive, - randomiseRoute, - setRoute, - makeASymmetricTSPMap, - makeSymmetricTSPMap, - makeEuclideanTSPMap -)where - -import qualified Data.Map as M -import qualified Data.Array as A -import System.Random -import Data.List - -{- | The data type for carrying the combination problem and solution to - the TSP. The route is stored as a dictionary of associations - from vertex name to a pair of values, the name of the preceding - vertex and the next vertex. This forms an infinite loop, so - use carefully. - - The @routeElementToIndex@\/@indexToRouteElement@ pair store - fixed indexes to the cities. This is intended to allow - a dumb heuristic to decide to switch elements 0 and 2, - knowing they must be separated by 1 element, rather than - vertices 0 and 2, which may be next to each other, or - very different parts of the cycle. --} - -data TSPProblem = TSPProblem { currentPrice :: Float, - routeMap :: M.Map Int (Int,Int), - edgePrices :: (Int->Int->Float), - numCities :: Int, - routeElementToIndex :: M.Map Int Int, - indexToRouteElement :: M.Map Int Int - } - -{- | There are three possible internal storage forms. A full explicit matrix, an upper triangular matrix or recomputation - from data points. The advantage of full explicit is speed, but it takes more memory. It is also the only option for - asymmetric TSP problems. The triangular matrix is also fast, but can only be used in symmetric problems, and also - still requires quite a bit of memory. Recomputation is the last option, it is slow because it is no longer a lookup - table, but will take much less room. Can only be used with problems where the distance between two points can be - calculated. Currently I am only supporting symmetric TSPs for this. --} - -data InternalStorage = ExplicitMatrix | TriangularMatrix | Recomputation deriving (Show,Eq) -- just in case I need these - -instance Show TSPProblem where - show t = concat ["TSPProblem of ",show . numCities $ t, - " cities\n Current Solution ",show r, - "\n Costing ",show . currentPrice $ t,"\n"] - where - rm = snd . ((M.!) (routeMap t)) - r = 0:(takeWhile (\x->x/=0) $ iterate rm (rm 0))++[0] - -{- | Converts the lookup table of a problem into a comma and newline delimited - string. This should facilitate copying into spreadsheets for checking the - problem being used and validating solutions by hand. -} - -showEdgeWeights :: TSPProblem->String -showEdgeWeights t = headerRow ++ concatMap makeRow nc - where - ep = edgePrices t - nc = [0 .. numCities t-1] - headerRow = ',': concat (intersperse "," $ map show [0..numCities t-1]) ++ "\n" - makeRow i = show i ++ "," ++ concat (intersperse "," [ show (ep i' i) | i'<-nc]) ++"\n" - -{- | Will perform a switch of 2 cities in the path. This is by city name, not current index - in the path. It looks up the current indexes by city name and passes the work off to - @exchangeCitiesOnIndex@. -} - -exchangeCities :: Int->Int->TSPProblem->TSPProblem -exchangeCities a b t = exchangeCitiesOnIndex (min i1 i2) (max i1 i2) t - where - i1 = routeElementToIndex t M.! a - i2 = routeElementToIndex t M.! b - -{- | Performs the bulk of the work for exchanging elements of the cycle. - It assumes that the order of the indexes is increasing (e.g. 0 2 not 2 0). - While changing the order it will also calculate the change in value of the - route and update this. This is performed fairly efficiently by finding the - edges being removed, and the edges being created and adding the difference - between the two to the current price. -} - -exchangeCitiesOnIndex :: Int->Int->TSPProblem->TSPProblem -exchangeCitiesOnIndex i1 i2 t - | d == 0 = t - | d == 1 = t{routeMap=rAdj,currentPrice=currentPrice t + priceChangeAdj,routeElementToIndex=t2',indexToRouteElement=t1'} - | otherwise = t{routeMap=r',currentPrice=currentPrice t + priceChange,routeElementToIndex=t2',indexToRouteElement=t1'} - where - d = abs (i1 - i2) - - -- basic setup - r = (routeMap t) - a = indexToRouteElement t M.! i1 - b = indexToRouteElement t M.! i2 - p = edgePrices t - ((a1,a2),(b1,b2)) = (r M.! a,r M.! b) - - -- usual code - priceChange = sum [p a1 b,p b a2,p b1 a,p a b2] - sum [p a a2,p b b2,p a1 a,p b1 b] - r' = foldl' (\m (k,f) -> M.adjust f k m) r [(a,\_->(b1,b2)),(b,\_->(a1,a2)),(a1,\(x,y)->(x,b)),(a2,\(x,y)->(b,y)),(b1,\(x,y)->(x,a)),(b2,\(x,y)->(a,y))] - - -- index exchange - t1 = indexToRouteElement t - t2 = routeElementToIndex t - t2' = M.insert b i1 (M.insert a i2 t2) - t1' = M.insert i1 b (M.insert i2 a t1) - - -- adjacent exchange, special case - priceChangeAdj = sum [p a1 b,p b a,p a b2] - sum [p a1 a,p a b,p b b2] - rAdj = foldl' (\m (k,f) -> M.adjust f k m) r [(a1,\(x,y)->(x,b)),(b2,\(x,y)->(a,y)),(a,\_->(b,b2)),(b,\_->(a1,a))] - -{- | A brute force recalculation of the current length of the path. Use sparingly.-} - -evaluateRouteNaive :: TSPProblem->TSPProblem -evaluateRouteNaive t = t{currentPrice=evalRoute 0} - where - ep = edgePrices t - rm = snd . ((M.!) (routeMap t)) - evalRoute x = let n = rm x - in if n==0 then ep x n - else ep x n + evalRoute n - -{- | Take a path through the system and a problem, insert the path into the system, - calculating distances and setting up appropriate look up tables. It does not - validate the list in terms of going through all the cities, or going through - a city more than once (though this is likely to break other parts of the system - very very fast). It does organise the list so that the starting node is vertex 0. - - Uses the @evaluateRouteNaive@ to calculate the length of the path via a brute - force method. This is not expected to be used frequently. -} - -setRoute :: [Int]->TSPProblem->TSPProblem -setRoute path t = evaluateRouteNaive t{routeMap=newRoute,indexToRouteElement=in1,routeElementToIndex=in2} - where - l = dropWhile (/=0) $ cycle path - l' = tail l - l'' = tail l' - (k,k':_) = span (\(_,x,_)->x/=0) $ zip3 l l' l'' - newRoute = foldl' (\m (a,b,c) -> M.insert b (a,c) m) M.empty (k':k) - in1 = M.fromList $ zip [0..] (take (numCities t) l) - in2 = M.fromList . (map swap) . M.assocs $ in1 - swap (a,b) = (b,a) - -{- | Shuffles a simple list of cities and then passes off the work to setRoute. -} - -randomiseRoute :: RandomGen g=>g->TSPProblem->TSPProblem -randomiseRoute g t = setRoute (0:map snd (sort (zip (randoms g :: [Float]) [1 .. numCities t -1]))) t - -{- | Construct a TSPProblem instance for an Asymmetric TSP. That is, the distance - from A-B is the not necessarily the same as B-A. The actual route will - not be set up initially, the dictionaries will be empty. This could be - used directly for a global search system (branch and bound), or use in - conjunction with @setRoute@ or @randomiseRoute@ to initialise for local search. - Internal data structure is always fully explicit matrix.-} - -makeASymmetricTSPMap :: RandomGen g=>(Float,Float)->Int->g->TSPProblem -makeASymmetricTSPMap distanceLimits numCities g - = let cities = [0 ..(numCities-1)] - cityCoords = [(a,b) | a<-cities,b<-cities,a/=b] - matrix = M.fromList $ zip cityCoords (randomRs distanceLimits g) - -- p' = (\x y->M.findWithDefault 0 (x,y) matrix) - explicit = A.listArray (0,numCities*numCities-1) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-cities] - in TSPProblem 0 M.empty (\x y->explicit A.! (y * numCities + x)) numCities M.empty M.empty - -- TSPProblem 0 M.empty p numCities M.empty M.empty - -{- | Construct a TSPProblem instance for a Symmetric TSP. That is, the distance - from A-B is the same as B-A. The actual route will not be set up initially, - the dictionaries will be empty. This could be used directly for a global - search system (branch and bound), or use in conjunction with @setRoute@ or - @randomiseRoute@ to initialise for local search. Should be noted that this - does not create locations and calculate distances, but rather randomly - assigns distances to each edge, making them symmetric. -} - -makeSymmetricTSPMap :: RandomGen g=>InternalStorage->(Float,Float)->Int->g->TSPProblem -makeSymmetricTSPMap Recomputation _ _ _ = error "Cannot support recomputation, please use alternative storage, or makeEuclideanTSPMap" -makeSymmetricTSPMap storageType distanceLimits numCities g - = let cities = [0 ..(numCities-1)] - cityCoords = [(a,b) | a<-cities,b<-take (a+1) cities,a/=b ] - f e ((a,b),c) = M.insert (b,a) c (M.insert (a,b) c e) - matrix = foldl f M.empty (zip cityCoords (randomRs distanceLimits g)) - explicit = A.listArray (0,numCities*numCities-1) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-cities] - triangular = A.listArray (0,sum [0..numCities]) [M.findWithDefault 0 (a,b) matrix | a<-cities,b<-[0..a]] - p = if storageType == ExplicitMatrix then (\x y->explicit A.! (y * numCities + x)) - else (\x y->let x' = min x y; y' = max x y in triangular A.! (div (y'*y'+y') 2 + x')) - in TSPProblem 0 M.empty p numCities M.empty M.empty - -{- | Construct a TSPProblem instance for a Symmetric TSP. The route will not be - initially set up, the dictionaries will be empty. This does create the - vertices of the graph as points in a 2d space, and the lengths of edges - are calculated, so this supports all internal storage types. --} - -makeEuclideanTSPMap :: RandomGen g=>InternalStorage->(Float,Float)->(Float,Float)->Int->g->TSPProblem -makeEuclideanTSPMap storageType xRange yRange numCities g - = let cities = [0 ..(numCities-1)] - (genA,genB) = split g - positions = take numCities $ zip (randomRs xRange genA) (randomRs yRange genB) - posArr = A.listArray (0 , numCities-1) positions - - explicit = A.listArray (0,numCities*numCities-1) [euclidianDistance (posArr A.! a) (posArr A.! b) | a<-cities,b<-cities] - triangular = A.listArray (0,sum [0..numCities]) [euclidianDistance (posArr A.! a) (posArr A.! b) | a<-cities,b<-[0..a]] - - p = case storageType of - ExplicitMatrix -> \x y->explicit A.! (x * numCities + y) - TriangularMatrix -> (\x y->let x' = min x y; y' = max x y in triangular A.! (div (y'*y'+y') 2 + x')) - Recomputation -> \a b->if a == b then 0 else euclidianDistance (posArr A.! a) (posArr A.! b) - in TSPProblem 0 M.empty p numCities M.empty M.empty - where - euclidianDistance :: (Float,Float)->(Float,Float)->Float - euclidianDistance (a,b) (c,d) = sqrt ((a-c)*(a-c)+(b-d)*(b-d)) - - - diff --git a/CombinatorialOptimisation/TSP.o b/CombinatorialOptimisation/TSP.o deleted file mode 100644 Binary files a/CombinatorialOptimisation/TSP.o and /dev/null differ diff --git a/CombinatorialOptimisation/TSP/FixedPoint.hs b/CombinatorialOptimisation/TSP/FixedPoint.hs new file mode 100644 --- /dev/null +++ b/CombinatorialOptimisation/TSP/FixedPoint.hs @@ -0,0 +1,74 @@ +----------------------------------------------------------------------------- +-- | +-- Module : CombinatorialOptimisation.TSP.FixedPoint +-- Copyright : (c) Richard Senington 2011 +-- License : GPL-style +-- +-- Maintainer : Richard Senington +-- Stability : provisional +-- Portability : portable +-- +-- Simple library for fixed point arithmetic. Pure Haskell style, +-- unlikely to be efficient. Really this has been added as a bit of +-- a hack at the present time to remove rounding errors in the TSP +-- implementation (which was having them from the use of Float and Double). +-- Not intended to be a full library on it's own, but I guess I see what happens. +-- +-- Internally uses Int64 as the data type and this is then divided to 32 bits below +-- the point, 31 above and the sign is still in place. +-- Basic arithmetic becomes simple integer arithmetic (what I really really want), +-- multiplication and division has to make use of conversion to Integer type and +-- shifting, probably not that fast. +----------------------------------------------------------------------------- + +module CombinatorialOptimisation.TSP.FixedPoint (FP(FP)) where + +import Data.Int +import Data.Bits +import Data.Ratio + +-- simple fixed point library, using 64 bit integers as the basis and 32 bits below the point (leaves 31 above, these are still signed) + +fixedPoint = 32 +divConstI = 2^fromIntegral fixedPoint +divConstD = 2**fromIntegral fixedPoint +fpOne = fromInteger 1 + +newtype FP = FP Int64 deriving (Eq,Ord) + +instance Show FP where + show x@(FP a) = "FP internal:"++(show a)++" floating:"++(show . (realToFrac :: FP->Double) $ x) + +instance Num FP where + (+) (FP a) (FP b) = FP (a+b) + (*) (FP a) (FP b) = FP $ fromIntegral $ shiftR ((toInteger a) * (toInteger b)) fixedPoint -- bad, but will not be using it much myself + (-) (FP a) (FP b) = FP (a-b) + negate (FP a) = FP (-a) + abs (FP a) = FP (abs a) + signum (FP a) = FP (signum a) + fromInteger i = FP (shiftL (fromInteger i) fixedPoint) + +instance Fractional FP where + (/) (FP a) (FP b) = FP $ fromInteger (div (shiftL (toInteger a) fixedPoint) (toInteger b)) + recip = (/) fpOne + fromRational x = doubleToFP $ fromRational x + +instance Real FP where + toRational (FP a) = (fromIntegral a) % divConstI + +doubleToFP :: Double->FP +doubleToFP x = let (a,b) = properFraction x + in fromInteger a + FP (floor (b * divConstD)) + +five,six :: FP +five = fromInteger 5 +six = fromInteger 6 + +-- needs good test + + + + + + + diff --git a/FileFormat/SATLIB.hi b/FileFormat/SATLIB.hi deleted file mode 100644 Binary files a/FileFormat/SATLIB.hi and /dev/null differ diff --git a/FileFormat/SATLIB.hs~ b/FileFormat/SATLIB.hs~ deleted file mode 100644 --- a/FileFormat/SATLIB.hs~ +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FileFormat.SATLIB --- Copyright : (c) Richard Senington 2011 --- License : GPL-style --- --- Maintainer : Richard Senington --- Stability : provisional --- Portability : portable --- --- The loading routines for the Conjuntive Normal Form (cnf) styled files --- that can be found on the SATLIB website. Relies upon the --- @CombinatorialOptimisation.SAT@ library for the data structures. ------------------------------------------------------------------------------ - -module FileFormat.SATLIB(loadCNFFile,saveAsCNF)where - -import CombinatorialOptimisation.SAT - -import Data.List -import qualified Data.Map as M -import qualified Data.Array as A - -{- | Loading routine that takes the file path and returns a SATProblem. All variables will be set to false in the initial -setup, and the truth values of all clauses set appropriately. -} - -loadCNFFile :: FilePath->IO(SATProblem) -loadCNFFile fName - = do rawContents<-readFile fName - let ls = (filter (\x->head x /= 'c')) $ lines rawContents - let problemLine = words $ head $ filter (\x->head x == 'p') ls - let (varCount,clauseCount) = if problemLine !! 1 /= "cnf" then error "This is not a CNF file" - else (read $ problemLine !! 2,read $ problemLine !! 3) :: (Int,Int) - let clauseLines = (map processClause) . (mySplit 0) . (map read) . (concatMap words) . tail $ ls - let clauseMap = foldl f (M.fromList (zip [0 .. varCount -1] $ repeat ([],[]))) (zip [0..] clauseLines) - let varLook = ((A.listArray (0,varCount -1) (M.elems clauseMap)) A.!) - let claLook = ((A.listArray (0,clauseCount -1) clauseLines) A.!) - return $ satproblem clauseCount varCount varLook claLook (M.fromList $ zip [0 .. varCount -1] $ repeat False) - where - mySplit target xs = mySplit' [] xs - where - mySplit' [] [] =[] - mySplit' ns [] = [reverse ns] - mySplit' ns (x:xs) | x == target = (reverse ns) : mySplit' [] xs - | otherwise = mySplit' (x:ns) xs - processClause cs = let (as,bs) = partition (>0) cs in (map ((+) (-1)) as,map ((+) (-1)) $ map abs bs) - f m (clauseIndex,(ords,negs)) = let addNeg m' x = M.adjust (\(as,bs)->(as,clauseIndex:bs)) x m' - addOrd m' x = M.adjust (\(as,bs)->(clauseIndex:as,bs)) x m' - in foldl addNeg (foldl addOrd m ords) negs - -{- | Save routine for SATProblem, outputs back into SATLIB cnf format. The code @(loadCNFFile f) >>= (saveAsCNF f)@ should -have no effect upon the file. All information such as variable settings and the truth values of clauses is lost. -To save extra information use standard prelude write file function with show. I will try to improve on that -at some point. -} - -saveAsCNF :: FilePath->SATProblem->IO () -saveAsCNF fName s = writeFile fName $ fixedHeader++problemHeader++concatMap prepareClause [0.. (numClauses s)-1] - where - fixedHeader = concat ["c\n","c SAT instance in DIMACS CNF input format.\n","c\n"] - problemHeader = concat ["p cnf ",show . numVariables $ s," ",show . numClauses $ s,"\n"] - prepareClause c = let (as,bs) = clauseLookUp s c - (as',bs') = (map (\a->(a,a+1)) as,map (\a->(a,-(a+1))) bs) - cs = map snd (sortBy (\a b->compare (fst a) (fst b)) $ as' ++ bs') - in (init . init . concat $ [show k++" " | k<-cs ++ [0]]) ++ "\n" - - - diff --git a/FileFormat/SATLIB.o b/FileFormat/SATLIB.o deleted file mode 100644 Binary files a/FileFormat/SATLIB.o and /dev/null differ diff --git a/FileFormat/TSPLIB.hi b/FileFormat/TSPLIB.hi deleted file mode 100644 Binary files a/FileFormat/TSPLIB.hi and /dev/null differ diff --git a/FileFormat/TSPLIB.hs b/FileFormat/TSPLIB.hs --- a/FileFormat/TSPLIB.hs +++ b/FileFormat/TSPLIB.hs @@ -32,19 +32,24 @@ import qualified Data.Array as A import Data.List +-- going to use a fixed point internal representation, only doing addition afterall +-- not happy about how I have bolted this in. + +import CombinatorialOptimisation.TSP.FixedPoint + {- | Simple 2d Euclidian. -} -euclidianDistance :: (Float,Float)->(Float,Float)->Float +euclidianDistance :: (Double,Double)->(Double,Double)->Double euclidianDistance (a,b) (c,d) = sqrt ((a-c)*(a-c)+(b-d)*(b-d)) {- | Always rounded up Euclidian. -} -euclidianDistanceCeil :: (Float,Float)->(Float,Float)->Float +euclidianDistanceCeil :: (Double,Double)->(Double,Double)->Double euclidianDistanceCeil a b = fromIntegral . ceiling $ euclidianDistance a b {- | For only two types of file. Basically a form of rounded Euclidian. -} -pseudoEuclideanDistance :: (Float,Float)->(Float,Float)->Float +pseudoEuclideanDistance :: (Double,Double)->(Double,Double)->Double pseudoEuclideanDistance (a,b) (c,d) = let e = sqrt (((a-c)*(a-c)+(b-d)*(b-d)) /10 ) f = fromIntegral (floor e) in if f(Float,Float)->Float +geoDistance :: (Double,Double)->(Double,Double)->Double geoDistance (x1,y1) (x2,y2) = encodeFloat (floor dij) 0 where q1 = cos (lon1 - lon2) @@ -150,16 +155,16 @@ cities = [0 ..(numCities-1)] - explicit = A.listArray (0,numCities*numCities-1) [distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-cities] - triangular = A.listArray (0,sum [0..numCities]) [distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-[0..a]] + explicit = A.listArray (0,numCities*numCities-1) [realToFrac $ distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-cities] + triangular = A.listArray (0,sum [0..numCities]) [realToFrac $ distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-[0..a]] p = case storageType of ExplicitMatrix -> \x y->explicit A.! (x * numCities + y) TriangularMatrix -> (\x y->let x' = min x y; y' = max x y in triangular A.! (div (y'*y'+y') 2 + x')) - Recomputation -> \a b->distFunc (posArr A.! a) (posArr A.! b) + Recomputation -> \a b->realToFrac $ distFunc (posArr A.! a) (posArr A.! b) in TSPProblem 0 M.empty p numCities M.empty M.empty where - readF = read :: (String->Float) + readF = read :: (String->Double) distanceFunctionSpec = fromJust $ lookup "EdgeWeightType" spec distFunc = case distanceFunctionSpec of "GEO" -> geoDistance @@ -178,7 +183,7 @@ | storageType == TriangularMatrix = TSPProblem 0 M.empty (\x y->let x' = min x y; y' = max x y in triangularArray A.! (div (y'*y'+y') 2 + x')) numCities M.empty M.empty | storageType == ExplicitMatrix = TSPProblem 0 M.empty (\x y->explicitArray A.! (y * numCities + x)) numCities M.empty M.empty where - readF = read :: (String->Float) + readF = realToFrac . (read :: (String->Double)) distanceFunctionSpec = fromJust $ lookup "EdgeWeightType" spec inputNumberSequence = concatMap ((map readF) . words) d -- not entirely trusting line breaks in file format, so turning into list of numbers, and putting in coords later cities = [0 ..(numCities-1)] diff --git a/FileFormat/TSPLIB.hs~ b/FileFormat/TSPLIB.hs~ deleted file mode 100644 --- a/FileFormat/TSPLIB.hs~ +++ /dev/null @@ -1,204 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FileFormat.TSPLIB --- Copyright : (c) Richard Senington 2011 --- License : GPL-style --- --- Maintainer : Richard Senington --- Stability : provisional --- Portability : portable --- --- Partial loading routines for the TSPLIB file format. --- The format itself has a large number of variations, --- and this has only been designed to load the @tsp@ and --- @atsp@ variants. It has been tried on all the files --- from the repository in these classes and it parses --- them at least. --- --- Relies upon the @CombinatorialOptimisation.TSP@ library. --- --- Currently this does not use the Haskell parsing --- libraries, nor ByteString, just some custom built --- routines. ------------------------------------------------------------------------------ - -module FileFormat.TSPLIB( - loadTSPFile - )where - -import CombinatorialOptimisation.TSP -import Data.Maybe -import qualified Data.Map as M -import qualified Data.Array as A -import Data.List - -{- | Simple 2d Euclidian. -} - -euclidianDistance :: (Float,Float)->(Float,Float)->Float -euclidianDistance (a,b) (c,d) = sqrt ((a-c)*(a-c)+(b-d)*(b-d)) - -{- | Always rounded up euclidian. -} - -euclidianDistanceCeil :: (Float,Float)->(Float,Float)->Float -euclidianDistanceCeil a b = fromIntegral . ceiling $ euclidianDistance a b - -{- | For only two types of file. Basically a form of rounded euclidian. -} - -pseudoEuclideanDistance :: (Float,Float)->(Float,Float)->Float -pseudoEuclideanDistance (a,b) (c,d) = let e = sqrt (((a-c)*(a-c)+(b-d)*(b-d)) /10 ) - f = fromIntegral (floor e) - in if f(Float,Float)->Float -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.0-q1)*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 - -{- | A data type for representing bits of the specification section of a file. - Assumed to be used later as a list of Specifications. -} - -data Specification = IGNORE String | USEFUL String String | ENDSPEC String | FAIL String deriving Show - -{- | Test for filtering specification lines, so we only get data we might want to use. Could be - got rid of as most of the time I do dictionary lookups on the output of the specification - reading routines. -} - -isUsefulSpec (USEFUL _ _) = True -isUsefulSpec _ = False - -{- | Helper routine for @readSpecification@. Reads a single line (assumes - that input is already line by line). -} - -readSpecificationLine :: String->Specification -readSpecificationLine s - | likeString "NAME" s = IGNORE s - | likeString "TYPE" s = USEFUL "Type" (trim s) - | likeString "NODE_COORD_SECTION" s = ENDSPEC "NODE COORD" - | likeString "EDGE_WEIGHT_SECTION" s = ENDSPEC "EDGE WEIGHT" - | likeString "COMMENT" s = IGNORE s - | likeString "DIMENSION" s = USEFUL "Dimension" (trim s) - | likeString "DISPLAY_DATA_TYPE" s = IGNORE s - | likeString "EDGE_WEIGHT_TYPE" s = USEFUL "EdgeWeightType" (trim s) - | likeString "EDGE_WEIGHT_FORMAT" s = USEFUL "EdgeWeightFormat" (trim s) - | otherwise = FAIL $ "unrecognised field in specification : "++s - where - likeString q s = take (length q) s == q - trim s = let s' = (dropWhile (==' ')) . (drop 1) . (dropWhile (/=':')) $ s - in reverse . (dropWhile (==' ')) . reverse $ s' - -{- | Helper routine for @loadTSPFile@. Reads the specification section of a file. -} - -readSpecification :: [String]->([Specification],[String]) -readSpecification [] = ([FAIL "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 "DATA PART TYPE" k],ss) - IGNORE _ -> (p:rs,es) - FAIL _ -> (p:rs,es) - USEFUL _ _ -> (p:rs,es) - -{- | Loads a TSPLIB style file. The first parameter is the internal - storage type from @CombinatorialProblems.TSP@. It allows for - full matrix, triangular matrix and full recalculation. If the - requested internal storage cannot be used with the file, this - will throw an error (e.g. recomputation where you are given a - full matrix in the file). - - The second parameter is the file path. -} - -loadTSPFile :: InternalStorage->FilePath->IO TSPProblem -loadTSPFile storageType fName - = do rawContents<-readFile fName - let (spec,remainder) = readSpecification $ lines rawContents - - -- mapM_ print spec - -- print "" - - let specList = map (\(USEFUL a b)->(a,b)) . filter isUsefulSpec $ spec - -- print specList - let dataPart = fromJust $ lookup "DATA PART TYPE" specList - let numNodes = read $ fromJust $ lookup "Dimension" specList - case dataPart of - "NODE COORD" -> return $ loadFromNodePositions storageType numNodes specList (takeWhile (/="EOF") remainder) - "EDGE WEIGHT" -> return $ loadFromMatrix storageType numNodes specList (takeWhile (/="EOF") remainder) - _ -> error "Unsupported data section" - -{- | Helper routine for @loadTSPFile@. This assumes the input is just points and the - distances must be calculated. -} - -loadFromNodePositions :: InternalStorage->Int->[(String,String)]->[String]->TSPProblem -loadFromNodePositions storageType numCities spec d - = let d' = map ((\[a,b]->(a,b)) . (map readF) . (drop 1) . words) d - posArr = A.listArray (0 , numCities-1) d' - - cities = [0 ..(numCities-1)] - - explicit = A.listArray (0,numCities*numCities-1) [distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-cities] - triangular = A.listArray (0,sum [0..numCities]) [distFunc (posArr A.! a) (posArr A.! b) | a<-cities,b<-[0..a]] - - p = case storageType of - ExplicitMatrix -> \x y->explicit A.! (x * numCities + y) - TriangularMatrix -> (\x y->let x' = min x y; y' = max x y in triangular A.! (div (y'*y'+y') 2 + x')) - Recomputation -> \a b->distFunc (posArr A.! a) (posArr A.! b) - in TSPProblem 0 M.empty p numCities M.empty M.empty - where - readF = read :: (String->Float) - distanceFunctionSpec = fromJust $ lookup "EdgeWeightType" spec - distFunc = case distanceFunctionSpec of - "GEO" -> geoDistance - "EUC_2D" -> euclidianDistance - "ATT" -> pseudoEuclideanDistance - "CEIL_2D"-> euclidianDistanceCeil - _ -> error $ "unsupported distance function : "++distanceFunctionSpec - -{- | Helper routine for @loadTSPFile@. This assumes the input data is a matrix of some form, - and loads it. -} - -loadFromMatrix :: InternalStorage->Int->[(String,String)]->[String]->TSPProblem -loadFromMatrix Recomputation _ _ _ = error "Cannot load matrix and store in recomputation form" -loadFromMatrix storageType numCities spec d - | distanceFunctionSpec /= "EXPLICIT" = error "loading from non explicit matrix? (does not make sense)" - | storageType == TriangularMatrix = TSPProblem 0 M.empty (\x y->let x' = min x y; y' = max x y in triangularArray A.! (div (y'*y'+y') 2 + x')) numCities M.empty M.empty - | storageType == ExplicitMatrix = TSPProblem 0 M.empty (\x y->explicitArray A.! (y * numCities + x)) numCities M.empty M.empty - where - readF = read :: (String->Float) - distanceFunctionSpec = fromJust $ lookup "EdgeWeightType" spec - inputNumberSequence = concatMap ((map readF) . words) d -- not entirely trusting line breaks in file format, so turning into list of numbers, and putting in coords later - cities = [0 ..(numCities-1)] - - 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 = case fromJust $ lookup "EdgeWeightFormat" spec of - "FULL_MATRIX" -> foldl' (\m (d,c)->M.insert d c m) M.empty (zip [(a,b) | a<-cities,b<-cities] inputNumberSequence) - "UPPER_ROW" -> makeFromTri $ zip [(a,b) | a<-cities,b<-[a..(numCities - 1)],a/=b] inputNumberSequence - "LOWER_ROW" -> makeFromTri $ zip [(a,b) | a<-cities,b<-[0..a],a/=b] inputNumberSequence - "UPPER_DIAG_ROW" -> makeFromTri $ zip [(a,b) | a<-cities,b<-[a..(numCities - 1)]] inputNumberSequence - "LOWER_DIAG_ROW" -> makeFromTri $ zip [(a,b) | a<-cities,b<-[0..a]] inputNumberSequence - - "UPPER_COL" -> makeFromTri $ zip [(b,a) | a<-cities,b<-[a..(numCities - 1)],a/=b] inputNumberSequence - "LOWER_COL" -> makeFromTri $ zip [(b,a) | a<-cities,b<-[0..a],a/=b] inputNumberSequence - "UPPER_DIAG_COL" -> makeFromTri $ zip [(b,a) | a<-cities,b<-[a..(numCities - 1)]] inputNumberSequence - "LOWER_DIAG_COL" -> makeFromTri $ zip [(b,a) | a<-cities,b<-[0..a]] inputNumberSequence - - explicitArray = A.listArray (0,numCities*numCities-1) [loadedMap M.! (a,b) | a<-cities,b<-cities] - triangularArray = A.listArray (0,sum [0..numCities]) [loadedMap M.! (a,b) | a<-cities,b<-[0..a]] - diff --git a/FileFormat/TSPLIB.o b/FileFormat/TSPLIB.o deleted file mode 100644 Binary files a/FileFormat/TSPLIB.o and /dev/null differ diff --git a/Test.hs~ b/Test.hs~ deleted file mode 100644 --- a/Test.hs~ +++ /dev/null @@ -1,106 +0,0 @@ -import CombinatorialOptimisation.SAT -import CombinatorialOptimisation.TSP -import FileFormat.SATLIB -import FileFormat.TSPLIB - -import System.Random -import qualified Data.Map as M - -import System.Directory - -{- -main :: IO() -main = do s<-loadCNFFile "./CBS_k3_n100_m403_b10_0.cnf" - print s - saveAsCNF "test.cnf" s - --} - -{- --- checking basic Symmetric TSP code and mutator algorithms -main :: IO() -main = do gen<-newStdGen - let meep = makeSymmetricTSPMap (2,5) 5 gen - -- print meep - let meep' = randomiseRoute gen meep - print meep' - print $ routeElementToIndex meep' - print $ indexToRouteElement meep' - print "" - let meep'' = exchangeCities 1 1 meep' - print meep'' - print $ routeElementToIndex meep'' - print $ indexToRouteElement meep'' - putStrLn $ showEdgeWeights meep'' - --} - -{- -main :: IO() -main = do let gen = mkStdGen 5 - let meep = makeSymmetricTSPMap ExplicitMatrix (2,5) 50 gen - let meep' = makeSymmetricTSPMap TriangularMatrix (2,5) 50 gen - putStrLn $ show $ showEdgeWeights meep == showEdgeWeights meep' - --} - -{- --- checking stability of arrays, rather than map -main :: IO() -main = do let gen = mkStdGen 5 - let gen' = mkStdGen 10 - let meep = makeEuclideanTSPMap ExplicitMatrix (2,8) (2,8) 100 gen - let meep' = makeEuclideanTSPMap TriangularMatrix (2,8) (2,8) 100 gen - let meep'' = makeEuclideanTSPMap Recomputation (2,8) (2,8) 100 gen - putStrLn $ showEdgeWeights meep - putStrLn "" - putStrLn $ showEdgeWeights meep' - putStrLn $ show $ (showEdgeWeights meep == showEdgeWeights meep') && (showEdgeWeights meep == showEdgeWeights meep'') --} - -{- --- checking loading TSPs -main :: IO() -main = do b<-loadTSPFile Recomputation "../exampleProblems/ali535.tsp" - c<-loadTSPFile TriangularMatrix "../exampleProblems/ali535.tsp" - d<-loadTSPFile ExplicitMatrix "../exampleProblems/ali535.tsp" - putStrLn $ show $ (showEdgeWeights d == showEdgeWeights c) && (showEdgeWeights d == showEdgeWeights b) --} - -{- --- still checking the loading of TSPs -main :: IO() -main = do b<-loadTSPFile ExplicitMatrix "../exampleProblems/brazil58.tsp" - putStrLn $ showEdgeWeights b -} - --- brute force loading -main :: IO() -main = do xs<-getDirectoryContents "../exampleProblems" >>= (\x->return (drop 2 x)) - mapM_ (\x->do b<-loadTSPFile ExplicitMatrix ("../exampleProblems/"++x) - if (numCities b < 1000) then print $ getLastEdge b - else print $ x++" too big for explicit") xs - main2 - where - getLastEdge t = let m = numCities t -1 in edgePrices t m m - -problemFiles = ["brazil58.tsp","bayg29.tsp","bays29.tsp","brg180.tsp","dantzig42.tsp"] - -customFilter :: [String]->IO [String] -customFilter [] = return [] -customFilter (x:xs) = do b<-loadTSPFile ExplicitMatrix ("../exampleProblems/"++x) - if numCities b <1000 then customFilter xs - else do ps<-customFilter xs - return (x:ps) - -main2 :: IO() -main2 = do xs<-getDirectoryContents "../exampleProblems" >>= (\x->return (drop 2 x)) - xs' <-customFilter xs - print xs' - mapM_ (\x->do print x - b<-loadTSPFile Recomputation ("../exampleProblems/"++x) - print $ getLastEdge b ) xs' - where - getLastEdge t = let m = numCities t -1 in edgePrices t m m - - - diff --git a/build.sh~ b/build.sh~ deleted file mode 100644 --- a/build.sh~ +++ /dev/null @@ -1,3 +0,0 @@ -runghc Setup configure -runghc Setup build -runghc Setup hscolour diff --git a/combinatorial-problems.cabal b/combinatorial-problems.cabal --- a/combinatorial-problems.cabal +++ b/combinatorial-problems.cabal @@ -1,5 +1,5 @@ Name: combinatorial-problems -Version: 0.0.2 +Version: 0.0.3 Synopsis: A number of data structures to represent and allow the manipulation of standard combinatorial problems, used as test problems in computer science. Description: In computer science there are a number of standard test problems that are used for testing algorithms, especially those related to Artificial Intelligence and Operations Research. Online there are a number @@ -32,6 +32,7 @@ FileFormat.TSPLIB CombinatorialOptimisation.SAT CombinatorialOptimisation.TSP + CombinatorialOptimisation.TSP.FixedPoint Build-Depends: base >= 2.0 && <=5, random >= 1.0.0.1, containers >= 0.2.0.1, diff --git a/combinatorial-problems.cabal~ b/combinatorial-problems.cabal~ deleted file mode 100644 --- a/combinatorial-problems.cabal~ +++ /dev/null @@ -1,38 +0,0 @@ -Name: combinatorial-problems -Version: 0.0.2 -Synopsis: A number of data structures to represent and allow the manipulation of standard combinatorial problems, used as test problems in computer science. -Description: In computer science there are a number of standard test problems that are used for testing algorithms, - especially those related to Artificial Intelligence and Operations Research. Online there are a number - of repositories for collections of known interesting problems, for example the TSPLIB at - and the SATLIB at - . - . - This library seeks to provide implementations of data structures to store these problems, along with - functions for manipulating the problems and routines to load problem files from various sources. - . - At present it only supports TSP\/TSPLIB and SAT\/SATLIB, however it is hoped that the loading routines - can be expanded and the range of problems expanded to cover problems like scheduling and timetabling. - The internal data structures make heavy use of the @Data.Map@ library and @Data.Array@. It is not currently - using unboxed values. The library does not use the @bytestring@ library for loading and saving data either, - which will probably need to be changed later. - -Stability: experimental -Category: Optimisation -Author: Richard Senington -License: GPL -license-file: LICENSE -Copyright: Copyright (c) 2011 Richard Senington -Homepage: http://www.comp.leeds.ac.uk/sc06r2s/Projects/HaskellCombinatorialProblems -Maintainer: sc06r2s@leeds.ac.uk -Build-Type: Simple -Cabal-Version: >= 1.2 - -library - Exposed-Modules: FileFormat.SATLIB - CombinatorialOptimisation.SAT - CombinatorialOptimisation.TSP - Build-Depends: base >= 2.0 && <=5, - random >= 1.0.0.1, - containers >= 0.2.0.1, - array >= 0.2.0.0 - extensions: diff --git a/meep~ b/meep~ deleted file mode 100644 # file too large to diff: meep~ diff --git a/new file~ b/new file~ deleted file mode 100644 --- a/new file~ +++ /dev/null