----------------------------------------------------------------------------- -- | -- Module : Control.Search.Local.Transformation -- Copyright : (c) Richard Senington & David Duke 2010 -- License : GPL-style -- -- Maintainer : Richard Senington -- 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 ([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[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 - tPLSTree nme]->LSTree nme->LSTree nme multiLevelApply (x:xs) t = let ns = map (multiLevelApply xs) (treeNodeChildren $ x t) in LSTree (treeNodeName t) ns