local-search-0.0.5: Control/Search/Local/Example.hs
{-|
This library has embedded within it two example TSP files drawn from the TSPLIB; burma14 and fl417.
This module provides a loading routine for these two files only. General loading routines for
the TSPLIB format are provided by the Combinatorial Problems library.
This module also provides a collection of simple TSP perturbation and recombination methods for use in the following
examples. Much of the code for these examples, in terms of the TSP implementation, recombination and perturbation
methods is not particularly efficient and only intended for example purposes.
To run these examples first use the following imports;
> import Control.Search.Local
> import Control.Search.Local.Example
> import Control.Search.Local.Strategy
> import Control.Search.Local.Eager
* A simple maximal iterative improver. This will print out all the solutions encountered.
> loadExampleFile BURMA14 >>= return . loopP (maximalii (map adjacentExchangeN))
* A stochastic choice from the improvement neighbourhood
> iiExample
> = do prob<-loadExampleFile FL417
> strat<-newStdGen >>= return . stochasticii rChoice . randoms
> return . loopP (strat (map adjacentExchangeN)) $ prob
> where
> rChoice xs p = xs !! (floor ((p::Float) * fromIntegral (length xs)))
* The standard TABU search, with a TABU list size of 5
> loadExampleFile BURMA14 >>= return . bestSoFar . loopP (standardTabu 5 (map adjacentExchangeN) (map head))
* A more complex TABU search, with a varying neighbourhood and varying TABU list size
> tabuExample
> = do prob<-loadExampleFile FL417
> nF <- newStdGen >>= return . stochasticNeighbourhood 417
> vWin <- newStdGen >>= return . varyWindow . randomRs (5,10)
> return . bestSoFar . loopP (tabu (vWin . window 15) nF (map head)) $ prob
* A simulated annealing search, using an adjacent exchange perturbation and a common geometric cooling strategy.
The values of the cooling strategy have been selected through rather rough and ready quick testing.
> saExample
> = do prob<-loadExampleFile FL417
> (fIs,sIs) <- newStdGen >>= return . (\a->(map head a,map last a)) . chunk 2 . randomRs (0,numCities prob-1)
> let perturb = zipWith3 swapPositions fIs sIs
> choiceRs <-newStdGen >>= return . randoms
> return . bestSoFar . loopP (sa getTSPVal perturb
> (geoCooling 80000 (0.99 :: Float))
> choiceRs) $ prob
* A genetic algorithm which only makes use of recombination.
> gaNoMutate
> = do prob<-loadExampleFile FL417
> recomb<-newStdGen >>= return . stochasticRecombine
> startSols <- newStdGen >>= return . randomStarts 20 prob
> let dist = (++[1]) . takeWhile (<1) $ iterate (*1.0884) (0.2::Float)
> rs <- newStdGen >>= return . randoms
> return . bestSoFar . loopS (ga (makePop 20)
> (recomb . gaSelect 2 dist rs)
> id) $ startSols
* A complete genetic algorithm that mutates in a random pattern (at a rate of 1/20th)
> gaWithMutate
> = do prob<-loadExampleFile FL417
> recomb<-newStdGen >>= return . stochasticRecombine
> startSols <- newStdGen >>= return . randomStarts 20 prob
> pattern <- newStdGen >>= return . map (<(0.05::Float)) . randoms -- boolean pattern
> (fIs,sIs) <- newStdGen >>= return . (\a->(map head a,map last a)) . chunk 2 . randomRs (0,numCities prob-1)
> let dist = (++[1]) . takeWhile (<1) $ iterate (*1.0884) (0.2::Float)
> let mut = nest pattern (zipWith3 swapPositions fIs sIs)
> rs <- newStdGen >>= return . randoms
> return . bestSoFar . loopS (ga (makePop 20)
> (recomb . gaSelect 2 dist rs)
> mut) $ startSols
All these examples are best demonstrated by composition with the following limiting function, parametrised as
seen fit by the user;
> strategy >>= return . limiterTSP 0 10
-}
module Control.Search.Local.Example(
-- * Loading routines
ExampleFiles(FL417,BURMA14),loadExampleFile,
-- * Perturbation functions
swapPositions,adjacentExchange,
-- * Neighbourhood functions
adjacentExchangeN,stochasticNeighbourhood,
-- * Recombination function
stochasticRecombine,
-- * Other TSP interaction functions
randomStarts,getTSPVal,
-- * Functions for terminating the search, not yet folded into the main library
limiter,limiterTSP
)where
import Paths_local_search
import CombinatorialOptimisation.TSP
import FileFormat.TSPLIB
import Control.Search.Local
import qualified Data.IntMap as IM
import qualified Data.Set as S
import System.Random
import Data.List
data ExampleFiles = FL417 | BURMA14
{-| A stream transformation that converts a local search process into a finite list.
The function takes a quality function parameter, that can yield a floating point quality of a solution.
The remaining functions control the limiting process;
(1) When the difference in quality between two solutions is below the second parameter, terminate
(2) The two solutions that we are comparing are divided by the integer parameter
-}
limiter :: (Floating f,Ord f)=>(s->f)->f->Int->StreamT s
limiter quality l i xs = map fst . takeWhile f $ zip xs (drop i xs)
where
f (a,b) = abs (quality a - quality b) > l
{-| Specialisation of limiter, fixing the quality function and the problem data type. -}
limiterTSP = limiter getTSPVal
{-| Demonstration loading routine for only two files stored within this library. After loading this routine also
randomises the initial solution route.
For more general TSP loading routines see 'FileFormat.TSPLIB'.
-}
loadExampleFile :: ExampleFiles->IO TSPProblem
loadExampleFile FL417 = lFile "fl417.tsp"
loadExampleFile BURMA14 = lFile "burma14.tsp"
lFile :: String->IO TSPProblem
lFile s = do p<-getDataFileName s >>= loadTSPFile ExplicitMatrix
g<-newStdGen
return $ randomiseRoute g p
{-| Genetic algorithms require a number of (usually) stochastically generated solutions to begin the process, not 1.
This function is provided for these cases, taking the parameters;
(1) the number of solutions to produce
(2) a sample solution (for edgeweights and problem size)
(3) a random number generator
-}
randomStarts :: RandomGen g=>Int->TSPProblem->g->[TSPProblem]
randomStarts i x g = let rs = (chunk (numCities x) . randoms $ g) :: [[Float]]
routes = map ((0:) . map fst . sortBy (\a b->compare (snd a) (snd b)) . zip [1 .. numCities x -1])
in take i $ map (flip setRoute x) (routes rs)
{-| Not a loading routine, but a synonym for a function within the 'CombinatorialOptimisation.TSP' library.-}
getTSPVal :: Floating f=>TSPProblem->f
getTSPVal = solutionValue
{-| A synonym for the function 'swapCitiesOnIndex' found in the 'CombinatorialOptimisation.TSP' library.
This will form the foundation of our perturbation and neighbourhood functions.-}
swapPositions :: Int->Int->TSPProblem->TSPProblem
swapPositions = swapCitiesOnIndex
{-| Swap a city, indicated by index, with the city after it, indicated by index.-}
adjacentExchange :: Int->TSPProblem->TSPProblem
adjacentExchange i = swapPositions i (i+1)
{-| For a particular path, generate every path that can exist from swapping adjacent cities.-}
adjacentExchangeN :: TSPProblem->[TSPProblem]
adjacentExchangeN a = map (flip adjacentExchange a) [0 .. numCities a -2]
{-| Many strategies benefit from a small manageable neighbourhood, but with the opportunity to access wider options.
This stream transformer provides this, at each step providing a neighbourhood of size N, drawn randomly from the
set of all possible city swaps, adjacent or otherwise.
This does not need to be defined as a stream transformer, but the alternative still requires parametrisation
with values that will be drawn from a source of random numbers. This version would then require lifting to
become a stream transformer, and this introduces more complications in the meta-heuristic code.
-}
stochasticNeighbourhood :: RandomGen g=>Int->g->ExpandT TSPProblem
stochasticNeighbourhood nSize g sols = let as = chunk nSize . chunk 2 . randomRs (0,numCities (head sols) -1) $ g
f s = map (\[a,b]->swapPositions a b s)
in zipWith f sols as
{-| A recombination process, for use in the genetic algorithm examples. This is presented as a contraction, however
it does assume that each population has already been constrained to elements that will form the parents of the
new solution. This process also assumes that there will be exactly 2 parents to each new solution, so it is
an example of a recombination method only. -}
stochasticRecombine :: RandomGen g=>g->ContraT TSPProblem
stochasticRecombine g a = unfoldr f (a,randoms g :: [Double])
where
f ([p1,p2]:ps,rs) = let (fs,rs') = stoRebuild rs (IM.fromList $ zip [0..] [(head c,last c,c) |c<-commonFragments p1edges p2route ])
in Just (setRoute fs p1 ,(ps,rs'))
--unsafePerformIO (print . getTSPVal $ (setRoute fs p1))
where
p1edges = let as = cycle p1route in S.fromList . map fst $ zip (zip as (tail as)) p1route
p2edges = let as = cycle p2route in S.fromList . map fst $ zip (zip as (tail as)) p2route
p2route = IM.elems . routeMap $ p2
p1route = IM.elems . routeMap $ p1
stoRebuild (a:b:xs) lookup
| si == 1 = ((\(_,_,x)->x) (lookup IM.! 0),a:b:xs)
| a' == b' = stoRebuild xs lookup
| S.member (aE,bS) p1edges || S.member (aE,bS) p2edges = stoRebuild xs (linkChunks a' b' (si-1) (aS,bE,a''++b'') lookup)
| S.member (bE,aS) p1edges || S.member (bE,aS) p2edges = stoRebuild xs (linkChunks a' b' (si-1) (bS,aE,b'' ++ a'') lookup)
| head xs <0.3 = stoRebuild (tail xs) (linkChunks a' b' (si-1) (aS,bE,a''++b'') lookup)
| head xs <0.6 = stoRebuild (tail xs) (linkChunks a' b' (si-1) (bS,aE,b''++a'') lookup)
| otherwise = stoRebuild (tail xs) lookup
where
si = IM.size lookup
si' = fromIntegral si
a' = floor (a*si')
b' = floor (b*si')
(aS,aE,a'') = lookup IM.! a'
(bS,bE,b'') = lookup IM.! b'
linkChunks index1 index2 index3 newChunk lookup | index1 > index2 = linkChunks index2 index1 index3 newChunk lookup
| otherwise = IM.delete index3 . IM.insert index2 (lookup IM.! index3) . IM.insert index1 newChunk $ lookup
commonFragments :: Ord t => S.Set (t, t) -> [t] -> [[t]]
commonFragments aEdges (b:bs) = f bs [[b]]
where
f [] [c] = [reverse c]
f [] (c:cs)
| S.member (head c,head $ last cs) aEdges = (reverse c ++ last cs) : init cs
| otherwise = reverse c : cs
f (x:xs) (c:cs)
| S.member (head c,x) aEdges = f xs ((x:c):cs)
| otherwise = f xs ([x] : reverse c : cs)