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