metaheuristics-0.0.8: MetaheuristicsDemo/test.hs

{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,FlexibleInstances  #-}

import Control.Metaheuristics
import System.Random
import qualified Data.Stream as S
import qualified SimpleTSP as TSP

import Control.Arrow

instance HasQuality TSP.TSP Float where
  quality (TSP.TSP _ x)= x 



displaySeries :: [TSP.TSP]->IO()
displaySeries [] = print "END"
displaySeries (t:tsps) = do print t
                            displaySeries tsps

-- TEST Hill climbers
testHillClimber = displaySeries $ S.take 100 $ executeMetaheuristic (iterativeImprover (mapArrow TSP.adjacentNeighbourhood  )) [s]    
  where 
    (s,g)=TSP.randomSolution (TSP.keyRandGen)
   
testStochasticClimber = displaySeries $ S.take 100 $ executeMetaheuristic (stochasticIterativeImprover g (mapArrow TSP.adjacentNeighbourhood  )) [s]    
  where 
    (s,g)=TSP.randomSolution (TSP.keyRandGen) 

-- TEST hill climber + escape
-- Not efficient. We create the neighbourhood twice and make sure it will be valid in the second generation
testRestart = displaySeries $ S.take 100 $ executeMetaheuristic (escapeStrategy  esTest  (stochasticIterativeImprover g2 neiArrow )  (replace (S.fromList ss) ) ) [s]
  where
    (g1,g2) = split TSP.keyRandGen
    (s:ss)=TSP.randomSolutions g1
    neiArrow = mapArrow TSP.adjacentNeighbourhood  
    esTest = mapArrow f
    f s | length ns == 0 = Right s
        | otherwise = Left s
     where ns = [ p       |    p<-  TSP.adjacentNeighbourhood s,p<s]


-- TEST TABU
testTABU = displaySeries $ S.take 100 $ executeMetaheuristic (tabu (mapArrow TSP.adjacentNeighbourhood) 5 ) [s]    
  where 
    (s,g)=TSP.randomSolution (TSP.keyRandGen) 
    
-- TEST SA
testSA = displaySeries $ S.take 100 $ executeMetaheuristic (simulatedAnnealing neiArrow rs ts) [s]
  where ts = S.fromList (logCooling 100 0.5 :: [Float])
        (s,g)=TSP.randomSolution (TSP.keyRandGen) 
        rs = S.fromList (randoms g :: [Float])
        neiArrow = mapArrow TSP.adjacentNeighbourhood  

-- TEST GA
testGA = displaySeries $ S.take 100 $ executeMetaheuristic (ga 10 mutateTest mutate  b) initialSols
  where (g1,g2) = split TSP.keyRandGen
        (g3,g4) = split g2
        (g5,g6) = split g3
        initialSols = take 10 $ TSP.randomSolutions g5
        b = breed1 (newArrow (wrappedRecombine g1)) g2 
        wrappedRecombine g xss = let (a,b) = TSP.recombineSolutions g (S.head xss) in S.Cons a (wrappedRecombine b (S.tail xss))
        mutateTest = uniformChoice (0.1) g3
        mutate = replace (S.fromList $ TSP.randomSolutions g6)

-- TEST ACO
testACO = displaySeries $ S.take 100 $ executeMetaheuristic (aco TSP.nullPat 10 TSP.tspToPat (mapArrow TSP.mergePats) mergePair (mapArrow TSP.degradePat) createsolution) initialSols
  where 
    mergePair = mapArrow (uncurry TSP.mergePat)
    (g1,g2) = split TSP.keyRandGen
    initialSols = take 10 $ TSP.randomSolutions g1
    createsolution = newArrow (S.fromList . TSP.createSolutions g2 . S.toList)