metaheuristics-0.0.8: MetaheuristicsDemo/SimpleTSP.hs

module SimpleTSP where

import qualified Data.Map as M
import qualified System.Random as R

cityCoordinates :: [(Float,Float)]
cityCoordinates = [(8.39816197926126, 15.185014516132743), (5.805977666331062, 8.023032216008712), (16.714739233303042, 13.92861301975959), (17.78946373699672, 4.015830245456648), (14.957102430197795, 5.872523608300993), (3.9898709586837433, 8.971759629020063), (8.293182956694752, 15.09786669714841), (18.350802237395172, 4.276634196229338), (16.816723540931694, 1.7317842244869075), (1.8717215787226338, 0.88215954938345)]

euclideanDistance :: (Float,Float)->(Float,Float)->Float
euclideanDistance (x1,y1) (x2,y2) = sqrt $ (x1-x2)*(x1-x2)+(y1-y2)*(y1-y2)

cityDistances :: M.Map (Int,Int) Float
cityDistances = M.fromList [((a,b),d a b) | a<-cities,b<-cities  ]
  where cities = [0..length cityCoordinates-1]
        d i1 i2 = euclideanDistance (cityCoordinates !! i1) (cityCoordinates !! i2) 

edgeLength x = cityDistances M.! x

data TSP = TSP [Int] Float deriving (Show,Eq)

type TSPPAT = M.Map (Int,Int) Float


instance Ord TSP where
  compare (TSP _ a) (TSP _ b) = compare a b
  



numCities (TSP x _) = length x

mkTSP :: [Int]->TSP
mkTSP x = TSP x (tspValue x)

tspValue :: [Int]->Float
tspValue ts = sum $ map edgeLength edges
  where edges = (last ts,0): zip (0:ts) ts
                 
tspToPat :: TSP->TSPPAT
tspToPat (TSP ts _) = M.fromList (simPat edges)
  where edges = (last ts,0): zip (0:ts) ts
        val = sum $ map edgeLength edges
        simPat [] = []
        simPat ((a,b):xs) = ((a,b),e):((b,a),e):simPat xs
          where e=val/edgeLength (a,b)  

swapCities :: Int->Int->TSP->TSP
swapCities i1 i2 (TSP x _) = mkTSP (zipWith f x [0..])
  where f c i | i==i1 = x !! i2
              | i==i2 = x !! i1
              | otherwise = c

adjacentNeighbourhood :: TSP->[TSP]
adjacentNeighbourhood x = [swapCities a b x |   (a,b)<- zip ps (tail ps)]
  where ps = [0..numCities x-1]

nullPat :: TSPPAT
nullPat = M.empty

degradePat :: TSPPAT->TSPPAT
degradePat t = M.mapMaybe   f    t
  where f a | a<0.01 = Nothing
            | otherwise = Just (a*0.9)  

mergePat :: TSPPAT->TSPPAT->TSPPAT
mergePat a b = M.unionWith (+) a b

mergePats :: [TSPPAT]->TSPPAT
mergePats (x:xs) = foldl mergePat x xs

createSol1 :: R.RandomGen g=>g->TSPPAT->TSP
createSol1 g p = mkTSP (f 0 [1..length cityCoordinates-1] (R.randoms g))
  where f currentCity [] _ = []
        f currentCity cityOpts (r:rs) = let vs = map (weight currentCity) cityOpts
                                            s=sum vs * r
                                            (xs,x,ys) = finder s (zip vs cityOpts)
                                        in x:f x (xs++ys) rs
        finder finalScore ((value,city):others) | value<finalScore = (city:xs,x,ys)
                                                | otherwise = ([],city,map snd others)
          where (xs,x,ys) = finder (finalScore-value) others                                      
        weight c k = M.findWithDefault 1.0 (c,k) p 

createSol :: R.RandomGen g=>g->TSPPAT->(TSP,g)
createSol g p = let (g1,g2) = R.split g in (createSol1 g1 p,g2)

createSolutions g (p:pats) = let (a,b) = createSol g p in a:createSolutions b pats

randomSolution :: R.RandomGen g=>g->(TSP,g)
randomSolution g = createSol g nullPat

randomSolutions :: R.RandomGen g=>g->[TSP]
randomSolutions g = let (a,b) = randomSolution g in a:randomSolutions b

recombineSolutions :: R.RandomGen g=>g->[TSP]->(TSP,g)
recombineSolutions g xs = createSol g (mergePats ps)
  where ps= map tspToPat xs
      


keyRandGen = R.mkStdGen 52



{- iteratedSols = f nullPat keyRandGen
  where f p g = let (g1,g2) = R.split g
                    s = createSol1 g1 p
                    p2=mergePat (degradePat p) (tspToPat s)
                in s:f p2 g2

test= Prelude.map tspValue $ take 10 $ iteratedSols  -}