----------------------------------------------------------------------------- -- | -- Module : Control.Search.Local.Transformation -- Copyright : (c) Richard Senington & David Duke 2010 -- License : GPL-style -- -- Maintainer : Richard Senington <sc06r2s@leeds.ac.uk> -- Stability : provisional -- Portability : portable -- -- Transformations for capturing characteristics of algorithms. ----------------------------------------------------------------------------- module Control.Search.Local.Transformation ( improvement, nShuffle, nSort, nReverse, tabu, thresholdWorsening, varyingThresholdWorsening, multiLevelApply, sImprovement ) where import Control.Search.Local.Tree import Control.Search.Local.Neighbourhood import Data.List import System.Random {- | A basic recursive filter. This will check every neighbourhood, and remove those neighbours that do not improve upon their parent solution. -} improvement :: Ord nme=>LSTree nme -> LSTree nme improvement = multiLevelApply (repeat sImprovement) {- | A single level improvement transformation, that will remove from the top neighbourhood of the tree those solutions that do not improve upon the parent solution. It is used by both the recursive improvement transformation, and one of the attempts to encode Simulated Annealing. -} sImprovement :: Ord nme=>LSTree nme -> LSTree nme sImprovement t = let ns' = filter (<t) (treeNodeChildren t) in LSTree (treeNodeName t) ns' {- | A helper function for shuffling lists, based upon a randomised sequence of numbers (expected). -} shuffle :: (Ord b)=>[b]->[a]->[a] shuffle rs xs = map snd (sortBy (\(a,_) (b,_)->compare a b) $ zip rs xs) {- | Another helper, to generate a specific number of random values from a generator, and return them with the updated generator. -} makeLimitedRands :: (Random a,RandomGen g)=>g->Int->([a],g) makeLimitedRands g l = foldl f ([],g) [1..l] where f (a,b) _ = let (c,b') = random b in (c:a,b') -- | Recursive neighbourhood shuffling transformation, all neighbourhoods will become randomised. nShuffle :: RandomGen g=>g->LSTree nme -> LSTree nme nShuffle g t = LSTree (treeNodeName t) ns' where ns = treeNodeChildren t (rs,g') = makeLimitedRands g $ length ns ns' = map (nShuffle g') (shuffle (rs :: [Int]) ns) {- | Single level neighbourhood ordering transformation. -} sSort :: Ord nme=>LSTree nme -> LSTree nme sSort t = LSTree (treeNodeName t) (sort (treeNodeChildren t)) {- | Recursive neighbourhood ordering transformation. Implemented using multi-apply. -} nSort :: Ord nme=>LSTree nme -> LSTree nme nSort = multiLevelApply (repeat sSort) {- | Single level reversal of neighbourhood order. To be used in conjunction with sorting for moving between finding largest and smallest elements. -} sReverse :: LSTree nme -> LSTree nme sReverse t = LSTree (treeNodeName t) (reverse $ treeNodeChildren t) {- | Recursive neighbourhood reversal transformation. Implemented using multi-apply. -} nReverse :: LSTree nme -> LSTree nme nReverse = multiLevelApply (repeat sReverse) {- | A simple (very simple) TABU system. Based upon a limited Queue, and direct node comparison (not the way it is usually used in the OR community). Acts as a recursive filter based upon memory. -} tabu :: Eq nme=>Int->[nme]->LSTree nme->LSTree nme tabu queueSize q t = LSTree nme ns'' where nme = treeNodeName t q' = take queueSize $ nme:q ns' = filter (\n->not $ elem (treeNodeName n) q') (treeNodeChildren t) ns'' = map (tabu queueSize q') ns' {- | Takes advantage of numerically priced solutions, rather than just ordering, to allow through solutions that are worse than the current solution, but only to a limited extent. Would require some understanding of the maximum and minimum differences likely in a solution set. -} thresholdWorsening :: NumericallyPriced nme a=>a->LSTree nme->LSTree nme thresholdWorsening thresh t = LSTree nme ns' where nme = treeNodeName t tP = priceSolution nme ns = filter (\n->(priceSolution.treeNodeName) n - tP<thresh) $ treeNodeChildren t ns' = map (thresholdWorsening thresh) ns {- | An adaptation of the above. We now have a list of thresholds, constructed in some way (user defined) and then applied each to a different level of the tree. Used in one of the Simulated Annealing experiments. -} varyingThresholdWorsening :: NumericallyPriced nme a=>[a]->LSTree nme->LSTree nme varyingThresholdWorsening (thresh:thresh') t = LSTree nme ns' where nme = treeNodeName t tP = priceSolution nme ns = filter (\n->(priceSolution.treeNodeName) n - tP<thresh) $ treeNodeChildren t ns' = map (varyingThresholdWorsening thresh') ns {- | Takes a list of single level transformations, and applies them each to a different level of a tree. These are also generated in a user defined way, and this function is used in the other Simulated Annealing experiment. -} multiLevelApply :: [LSTree nme->LSTree nme]->LSTree nme->LSTree nme multiLevelApply (x:xs) t = let ns = map (multiLevelApply xs) (treeNodeChildren $ x t) in LSTree (treeNodeName t) ns