----------------------------------------------------------------------------- -- | -- 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) {- | Recursive neighbourhood ordering transformation. Could be reimplemented in the future in a similar way to improvement, with a single level transformation, this would allow odd combinations in lists to be used in other multi-apply configurations. -} nSort :: Ord nme=>LSTree nme -> LSTree nme nSort t = let ns = sort (treeNodeChildren t) in LSTree (treeNodeName t) ns {- | Reversal, recursive again. To be used in combination with sorting to place in ascending or descending order, depending on what you want. -} nReverse :: LSTree nme -> LSTree nme nReverse t = LSTree (treeNodeName t) (reverse $ treeNodeChildren t) {- | 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