{-
Randomized Hill Climbing optimization.

Copyright 2016 Ken Takusagawa

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{- Algorithm: From a given start point in N dimensions, choose a
random point within a box (NB not a hypersphere) of width 2*step_size
and evaluate it.  Make it the new start point if the score improves.
After 10^(number of dimensions) consecutive failures, halve the step
size.

Elsewhere, this algorithm is called Adaptive Step Size Random Search.
-}

{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
module HillClimb(randomized_hill_climb) where {
import Data.Function((&));
import Control.Category((>>>));
import Prelude hiding((.),(>>));
import Control.Monad;
import System.Random(RandomGen,Random);
import Control.Monad.Random(getRandomR,evalRand,Rand);
import Control.Monad.State(StateT, evalStateT);
import qualified Control.Monad.State as State;
import Control.Monad.Trans(lift);

-- go until first Just
genericReplicateMaybeM :: (Monad m, Integral i) => i -> m (Maybe a) -> m (Maybe a);
genericReplicateMaybeM n f | n <= 0 = return Nothing
| True = f >>= \case {
Just x -> return $ Just x;
Nothing -> genericReplicateMaybeM (pred n) f;
};

-- a trace of all the executions
go_until_failM :: (Monad m) => m (Maybe a) -> m [a];
go_until_failM f = f >>= \case {
Just x -> do {
y <- go_until_failM f;
return $ x:y;
};
Nothing -> return [];
};

step_delta :: (RandomGen g, Num a, Random a) => a -> Rand g a;
step_delta step_size = getRandomR (negate step_size, step_size);

step_from :: (RandomGen g, Num a, Random a) => a -> [a] -> Rand g [a];
step_from step_size origin = do {
ss <- replicateM (length origin) (step_delta step_size);
return $ zipWith (+) origin ss;
};

try_step :: (RandomGen g, Num a, Random a, Ord b) => a -> [a] -> ([a] -> b) -> b -> Rand g (Maybe ([a],b));
try_step step_size origin f origin_score = do {
nextp <- step_from step_size origin;
let { fnext = f nextp };
if fnext > origin_score
then return $ Just (nextp, fnext)
else return Nothing;
};

-- curse of dimensionality
attempts_per_dimension :: Integer;
attempts_per_dimension = 10;

try_many_steps :: (RandomGen g, Num a, Random a, Ord b) => ([a] -> b) -> a -> ([a], b) -> Rand g (Maybe ([a],b));
try_many_steps f step_size (origin,origin_score) = genericReplicateMaybeM (attempts_per_dimension^(length origin)) $ try_step step_size origin f origin_score;

try_s :: (RandomGen g, Num a, Random a, Ord b) => ([a] -> b) -> a -> StateT ([a],b) (Rand g) (Maybe ([a],b));
try_s f step_size = State.get >>=
(try_many_steps f step_size >>> lift) >>= \case {
Nothing -> return Nothing;
Just new -> do {
State.put new;
return $ Just new;
}};

exhaust_this_step_size :: (RandomGen g, Num a, Random a, Ord b) => ([a] -> b) -> a -> StateT ([a],b) (Rand g) [([a],b)];
exhaust_this_step_size f step_size = go_until_failM $ try_s f step_size;

and_shrink_step_size :: (RandomGen g, Num a, Random a, Fractional a, Eq a, Ord b) => ([a] -> b) -> a -> StateT ([a],b) (Rand g) [([a],b)];
and_shrink_step_size _f 0 = return [];
and_shrink_step_size f step_size = do {
x <- exhaust_this_step_size f step_size;
-- Note: it will take a while before step_size is less than 1e-308
y <- step_size/2 & and_shrink_step_size f;
return $ x ++ y;
};

-- returns a trace of the search.  Printing out the trace has the useful side effect of preventing a space leak.
randomized_hill_climb :: (RandomGen g, Num a, Random a, Fractional a, Eq a, Ord score) => ([a] -> score) -> a -> [a] -> g -> [([a],score)];
randomized_hill_climb f step_size origin = (origin, f origin) & evalStateT (and_shrink_step_size f step_size) & evalRand;

} --end