Transformation.hs

-----------------------------------------------------------------------------
-- |
-- 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

-- | Transformations for the trees, to capture specific characteristics of different local search algorithms.

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