grasp-0.1.0.0: src/GRASP.hs

-- | Higher order GRASP algorithm.
module GRASP (
  -- * Types
  Cost
  , GParams (..)
  -- * GRASP
  , grasp
  , graspM
    -- * Auxiliar functions
  , constructM
  , localM
  ) where

import Control.Monad.Extra
import Control.Monad.Identity
import Control.Monad.Random
import Control.Monad.Trans
import Data.Foldable
import Data.Maybe
import Data.Ord
import Debug.Trace

-- | Cost of something.
type Cost = Int


-- | All the parameters that define a problem susceptible to be solved using a GRASP algorithm.
data GParams sol cand m = GParams {
   alpha :: Double -- ^ Alpha. Used to define the Restricted Candidate List (RCL).
  , maxitr :: Int -- ^ Iterations.
  , costf :: sol -> m Cost -- ^ Cost function.
  , correctf :: sol -> m Bool -- ^ Verification function.
  , start :: m sol -- ^ Empty solution.
  , append :: sol -> cand -> m sol -- ^ Function to append a candidate to the solution.
  , genCandidates :: sol -> m [(cand, Cost)] -- ^ Generator of candidates paired with their
                               -- greedily estimated cost increase.
  , neighbors :: sol -> m [sol] -- ^ Neighborhood generator.
}

-- | Higher order implementation of a Greedy Randomized Adaptive Search Procedure.
grasp :: Monad m => GParams sol cand m -> RandT StdGen m (Maybe (sol, Cost)) -- ^ Returns best solution found with its associated cost.
grasp GParams{..} =
  graspM alpha maxitr costf correctf start append genCandidates neighbors


-- | Monadic version of 'grasp'.
graspM ::
  Monad m  => Double -- ^ Alpha. Used to define the Restricted Candidate List (RCL).
  -> Int -- ^ Iterations.
  -> (sol -> m Cost) -- ^ Cost function.
  -> (sol -> m Bool) -- ^ Verification function.
  -> m sol -- ^ Empty solution.
  -> (sol -> cand -> m sol) -- ^ Function to append a candidate to the solution.
  -> (sol -> m [(cand, Cost)]) -- ^ Generator of candidates paired with their
                               -- greedily estimated cost increase.
  -> (sol -> m [sol]) -- ^ Neighborhood generator.
  -> RandT StdGen m (Maybe (sol, Cost)) -- ^ Returns best solution found with its associated cost.
graspM alpha maxitr f correct start append genCandidates neighb =
  step maxitr Nothing
  where
    step 0 best = return best
    step it best = do
      traceM $ "iteration " ++ show it
      x <- constructM start append genCandidates alpha
        >>= lift . (\s -> (s,) <$> f s)
      cor <- lift $ correct (fst x)
      if
        | cor -> do
            x1 <- trace ("Constructed: " ++ show (snd x)) $ localM f neighb x
            step (it - 1) (keepBest best (Just x1))

        | otherwise -> step (it - 1) Nothing
        where
          keepBest :: Maybe (sol, Cost) -> Maybe (sol, Cost) -> Maybe (sol, Cost)
          keepBest a b
            | null cm = Nothing
            | otherwise = Just $ minimumBy (comparing snd) cm
            where cm = catMaybes [a, b]

-- | Construction of an starting solution.
constructM ::
  Monad m
  => m sol -- ^ Empty solution.
  -> (sol -> cand -> m sol) -- ^ Function to append a candidate to the solution.
  -> (sol -> m [(cand, Cost)]) -- ^ Generator of candidates paired with their
                               -- greedily estimated cost increase.
  -> Double -- ^ Alpha.
  -> RandT StdGen m sol -- ^ Generated solution.
constructM start append genCandidates alpha = lift start >>= step
  where
    step solution = do
      candidates <- lift $ genCandidates solution
      if
        | null candidates -> return solution
        | otherwise -> do
            let smin = (minimum . map snd) candidates
                smax = (maximum . map snd) candidates
                rcl = [ c | (c, gc') <- candidates
                          , gc' <= smin + floor (alpha*fromIntegral (smax - smin))]
            uniform rcl >>= lift . append solution >>= step


-- | Local search.
localM ::
  Monad m
  => (sol -> m Cost) -- ^ Cost function.
  -> (sol -> m [sol]) -- ^ Neighborhood generator.
  -> (sol, Cost) -- ^ Starting solution paired with its cost.
  -> RandT StdGen m (sol, Cost)
localM cost neighb sol@(best, costbest) = do
  h <- lift $ neighb best
    >>= mapMaybeM processNeighb
  if
    | null h -> return sol
    | otherwise -> trace ("localM: " ++ show costbest) $ do
        let w = head h
        localM cost neighb w
          where processNeighb n = do
                  costn <- cost n
                  return $ if
                    | costn < costbest -> Just (n, costn)
                    | otherwise -> Nothing