1% ------------------------------------------------
    2% January 1999
    3% Author: Brian Ross
    4% Dept. of Computer Science, Brock University
    5%
    6% Lamarckian evolution: lamarckian_P(P, K, Select, PCross)
    7% Performs Lamarckian evolution on P% of population, iterating 
    8% each K times using hill-climbing. Hill-climber uses mutation; it is
    9% recommended that prob_terminal_mutation_P parameter be high, or else 
   10% internal mutation will not create good search performance.
   11% Select can be tournament (best, worst) or random.
   12% PCross is prob crossover (prob mutation = 1 - PCross).
   13
   14% lamarckian_evolution also asserts gp_stats with improvement gain obtained
   15% First clause efficiently processes entire population.
   16% Second case is if less than entire population to be used, in which case
   17% selection must be performed.
   18
   19lamarckian_evolution(Gen) :-
   20	lamarckian_P(Percent, K, _, _),
   21	Percent >= 1.0,
   22	writel([nl,'Lamarckian evolution...', nl]),
   23	population_size_P(_, PopSize),
   24	num_list(PopSize, IDs),
   25	lamarck_loop(IDs, 0, FitImpr, 0, MaxImpr, 0, NumGain, K),
   26	assertz(gp_stats(Gen,_,_,_,_,_,_,lamarck(FitImpr,MaxImpr,NumGain))),
   27	!.
   28lamarckian_evolution(Gen) :-
   29	lamarckian_P(Percent, K, Select, _),
   30	Percent < 1.0,
   31	population_size_P(_, PopSize),
   32	N is integer(Percent * PopSize),
   33	writel([nl,'Lamarckian evolution...', nl]),
   34	get_unique_IDs(Select, N, PopSize, [], IDs),
   35	lamarck_loop(IDs, 0, FitImpr, 0, MaxImpr, 0, NumGain, K),
   36	assertz(gp_stats(Gen,_,_,_,_,_,_,lamarck(FitImpr,MaxImpr,NumGain))),
   37	!.
   38
   39% get_unique_IDs retrieves a list of N unique individual ID's, 
   40% selecting each one via Type (random or best/worst tournament selection).
   41
   42get_unique_IDs(_, 0, _, IDs, IDs) :- !.
   43get_unique_IDs(Type, N, PopSize, SoFar, IDs) :-
   44	repeat,  % in case number is repeated (member below)
   45	(Type = random ->
   46		my_random(PopSize, ID)
   47		;
   48		tournament_select(Type, PopSize, ID, _)),
   49	\+ member(ID, SoFar),
   50	M is N - 1,
   51	get_unique_IDs(Type, M, PopSize, [ID|SoFar], IDs),
   52	!.
   53
   54% lamark_loop(List, ImprSoFar, FitImpr, MaxSoFar, MaxImpr, 
   55%		NumSoFar, NumGain, Iter) does best-first Lamarckian evolution.
   56% List = ordered list of individuals+Fitnesses
   57% ImprSoFar, FitImr = Total fitness gain so far / final
   58%  MaxSoFar, MaxImpr = best fitness gain so far/final
   59% NumSoFar, NumGain = number that have been changed so far/final
   60% Iter = # iterations to do
   61%
   62% Note: even if no overall fitness gain achieved, if an altered expression 
   63% was found, it is asserted and treated like a gain: will improve genetic
   64% diversity in population due to its syntactic variation.
   65
   66lamarck_loop([], FitImpr, FitImpr, MaxImpr, MaxImpr, NumGain, NumGain, _) :- !.
   67lamarck_loop([ID|Rest], ImprSoFar, FitImpr, MaxSoFar, MaxImpr, 
   68		NumSoFar, NumGain, Iter) :-
   69	individual(ID, Fit, Expr),
   70	% writel(['L ID=',ID,'* ']),
   71	hill_climb(Iter, (Fit, Expr), (NewFit, NewExpr)),
   72	((NewFit >= Fit ; \+ legal(NewExpr,lamarck))
   73	 	   -> % don't add
   74		writel('-'),
   75		(NewFitImpr,NewMaxImpr,NumSoFar2)=(ImprSoFar,MaxSoFar,NumSoFar)
   76		;
   77		retract(individual(ID, _, _)),  
   78		assert(individual(ID, NewFit, NewExpr)),
   79		NewFitImpr is ImprSoFar + Fit - NewFit,
   80		NewMaxImpr is max(MaxSoFar, Fit - NewFit),
   81		NumSoFar2 is NumSoFar + 1,
   82		writel('+')),
   83	lamarck_loop(Rest, NewFitImpr, FitImpr, NewMaxImpr, MaxImpr, 
   84			NumSoFar2, NumGain, Iter),
   85	!.
   86
   87% hill_climb(K, BestSoFar, Item) does hill-climbing search for 
   88% K iterations.  BestSoFar contains best expression obtained so far with 
   89% mutation,  and it and Item have (Fitness, Expression, Adf) structure.
   90% Note: Failed mutation and repeated mutation is counted as an iteration
   91%       Also, improved hillclimbing step does not count as an iteration.
   92
   93hill_climb(K, Item, Item) :- K =< 0, !.
   94hill_climb(K, (TopFit, TopExpr), Soln) :- % crossover?
   95	lamarckian_P(_, _, _, PC),
   96	maybe(PC),
   97	population_size_P(_, PopSize),
   98	tournament_select(best, PopSize, _, Expr2),
   99	crossover(TopExpr, Expr2, NewExpr1, NewExpr2),
  100	evaluator(NewExpr1, NewFit1),
  101	evaluator(NewExpr2, NewFit2),
  102	select_best((NewFit1, NewExpr1), (TopFit, TopExpr), BestSoFar1),
  103	select_best((NewFit2, NewExpr2), BestSoFar1, BestSoFar2),
  104	(((NewFit1 < TopFit) ; (NewFit2 < TopFit)) -> K2 = K ; K2 is K - 2),
  105	hill_climb(K2, BestSoFar2, Soln),
  106	!.
  107hill_climb(K, (TopFit, TopExpr), Soln) :- % mutation?
  108	sre_mutation(TopExpr, NewExpr),
  109	evaluator(NewExpr, NewFit),
  110	select_best((NewFit, NewExpr), (TopFit, TopExpr), BestSoFar),
  111	(NewFit < TopFit -> K2 = K ; K2 is K - 1),
  112	%K2 is K - 1,
  113	hill_climb(K2, BestSoFar, Soln),
  114	!.
  115hill_climb(K, BestSoFar, Soln) :-
  116	K2 is K - 1,
  117	hill_climb(K2, BestSoFar, Soln), 
  118	!.
  119
  120% select best of expression pairs
  121
  122select_best((F1, E1), (F2, _), (F1, E1)) :- F1 =< F2, !.
  123select_best(_, X, X).
  124
  125
  126sre_mutation(I,C):- mutation(I,C).
  127
  128% some debugging code...
  129
  130test_best_first(Iter, ID) :-
  131	population_size_P(_, PopSize),
  132	tournament_select(best, PopSize, ID, _),
  133	individual(ID, Fit, Expr),
  134	hill_climb(Iter, (Fit, Expr), (NewFit, NewExpr)),
  135	writel(['Initial: ', nl,
  136		'  Fit = ', Fit, nl,
  137		' Expr = ', Expr, nl,
  138		'New: ', nl,
  139		'  Fit = ', NewFit, nl,
  140		' Expr = ', NewExpr, nl]),
  141	!