1% ------------------------------------------------
    2% January 1999
    3% Author: Brian Ross
    4% Dept. of Computer Science, Brock University
    5%
    6% Genetic Programming engine II.
    7% 
    8% Tournament, steady state, Lamarckian hill-climbing option.
    9% Parameters set in 'gp_defn' file.
   10% Fitness: lower scores better, 0 is perfect.
   11% Population represented in program database with:
   12%   individual(ID_number, Fitness, Expression)
   13%   newindividual(ID_number, Fitness, Expression) (for separate gen)
   14
   15gp :-   clean_up_1,        
   16	assert(best_so_far(_, _, 1000, _)),
   17	max_runs_P(MaxRuns, RunType, _), % from gp_defn file
   18	!,
   19	meta_run_loop(1, MaxRuns, RunType),
   20	writel(['*** END ***', nl, nl]).
   21
   22meta_run_loop(Runs, MaxRuns, _) :-     
   23	Runs > MaxRuns, !,
   24	best_so_far(Run, Gen, Fitness, Expr),
   25	writel([nl,'--> Max run', MaxRuns, ' reached.',nl,
   26		'Best found in run ', Run, ' gen ', Gen, ':', nl,
   27		'   Expr = ', Expr, nl,
   28		'   Fitness = ', Fitness, nl, nl]),
   29	writel(['--> Finished runs <--', nl, nl]),
   30	!.
   31meta_run_loop(Run, MaxRuns, RunType) :-        
   32	Run =< MaxRuns,
   33	population_size_P(_, PopSize),  % gp_parameters
   34	max_runs_P(_, _, MaxGen),   % gp_parameters
   35	writel([nl, '---------------------  Run ', Run, 
   36		    ' ---------------------', nl]),
   37        since_last_datime(total,retract, _Hour,_Minute,_Sec),
   38        since_last_datime(generation, retract, _, _, _),
   39	do_the_run(0, MaxGen, PopSize),
   40	write('Dumping stats... '),
   41	dump_stats(Run),
   42	write('done'), nl,
   43	set_best_so_far(Run),
   44	((RunType == solution, solved_run) ->
   45		true
   46		;
   47		Run2 is Run + 1,
   48		meta_run_loop(Run2, MaxRuns, RunType)).
   49
   50do_the_run(Gen, MaxGen, _) :- Gen > MaxGen, !.
   51do_the_run(_, _, _) :- solved_run, !.
   52do_the_run(0, MaxGen, PopSize) :-        
   53	clean_up_2,
   54	assert(best_in_run(_, 1000, _)),
   55	writel([nl, '********* Generation ', 0, '*********', nl]),
   56	evaluator_reset(0),
   57	genesis,
   58	set_best_in_run(0),
   59	print_tourn_stats(0),
   60	% dump_population(0),
   61	garbage_collect,
   62	!,
   63	do_the_run(1, MaxGen, PopSize).
   64do_the_run(Gen, MaxGen, PopSize) :-
   65	writel([nl, '********* Generation ', Gen, '*********', nl]),
   66	evaluator_reset(Gen),
   67	elite_migration(1, StartSize), % new: May/00
   68	tournament_loop(StartSize, PopSize),
   69	rename_new_popn,
   70	((lamarckian_P(P,_,_,_), P > 0) -> lamarckian_evolution(Gen) ; true),
   71	set_best_in_run(Gen),
   72	print_tourn_stats(Gen),
   73	Gen2 is Gen + 1,
   74	% dump_population(Gen),
   75	garbage_collect,
   76	!,
   77	do_the_run(Gen2, MaxGen, PopSize).
   78
   79% tournament_loop(NumNew, PopSize) runs until NumNew changes
   80% done reaches PopSize OR run found solution.
   81% Possible that crossover fails (can't find similar nodes in choices, or
   82% children too large), and crossover will fail. 
   83% Else add each child.
   84% Mutation happens if crossover didn't.
   85
   86tournament_loop(K, PopSize) :- K > PopSize, !.
   87tournament_loop(_, _) :- solved_run, !.
   88tournament_loop(K, PopSize) :-
   89	prob_crossover_P(PC),
   90	maybe(PC),		% do crossover ?
   91	tournament_select(best, PopSize, _, Expr1),
   92	tournament_select(best, PopSize, _, Expr2), % might be same ID
   93	(crossover(Expr1, Expr2, NewExpr1, NewExpr2) ->
   94		add_child(c, K, K2, PopSize, NewExpr1),
   95		add_child(c, K2, K3, PopSize, NewExpr2) 
   96		; 
   97		K = K3),  % in case crossover didn't succeed
   98	tournament_loop(K3, PopSize).
   99tournament_loop(K, PopSize) :-  % do mutation
  100	tournament_select(best, PopSize, _, Expr),
  101	(mutation(Expr, NewExpr) ->
  102		add_child(m, K, K2, PopSize, NewExpr)
  103		; 
  104		K = K2),  % in case mutation didn't succeed
  105	tournament_loop(K2, PopSize).
  106
  107% tournament_select(Type, PopSize, ID, Expression) selects the 
  108% Type=best/worst Expression from Num randomly selected individuals 
  109% from population of size PopSize
  110
  111tournament_select(best, PopSize, ID, Expression) :-
  112	tournament_size_P(Num, _),
  113	select_random_IDs(0, Num, PopSize, [], IDs),
  114	select(best, IDs, ID, Expression),
  115	!.
  116tournament_select(worst, PopSize, ID, Expression) :-
  117	tournament_size_P(_, Num),
  118	select_random_IDs(0, Num, PopSize, [], IDs),
  119	select(worst, IDs, ID, Expression),
  120	!.
  121
  122% select_random_IDs(N, Size, PopSize, SoFar, Result) selects Size unique
  123% individual ID's from 1 to PopSize; N is size of temp answer SoFar.
  124
  125select_random_IDs(Size, Size, _, Result, Result) :- !.
  126select_random_IDs(N, Size, PopSize, SoFar, Result) :-
  127	repeat,
  128	my_random(PopSize, K),
  129	\+ member(K, SoFar),
  130	N2 is N + 1,
  131	select_random_IDs(N2, Size, PopSize, [K|SoFar], Result).
  132
  133% select the best or worst in tournament
  134% If a fair worst selection, then all have a chance  to be replaced in
  135% proportion to the number of best individuals in the population.
  136
  137select(Type, [ID1|Rest], ID, Expression) :-
  138	individual(ID1, Fit1, _),
  139	select2(Type, Fit1, ID1, Rest, ID, Expression).
  140
  141select2(_, _, ID, [], ID, Expression) :-
  142	individual(ID, _, Expression),
  143	!.
  144select2(Type, Fit1, _, [ID2|Rest], ID, Expression) :-
  145	individual(ID2, Fit2, _),
  146	((Type == best, Fit2 < Fit1);(Type == worst, Fit2 > Fit1)),
  147	!,
  148	select2(Type, Fit2, ID2, Rest, ID, Expression).
  149select2(Type, Fit1, ID1, [_|Rest], ID, Expression) :- 
  150	select2(Type, Fit1, ID1, Rest, ID, Expression).
  151
  152% adding to population (replacing a weak member) if legal.
  153% Use a reverse tournament selection, finding indiv to replace with child.
  154
  155
  156add_child(T, K, K2, PopSize, Expr) :-
  157	(\+ legal(Expr,main) ->
  158		K2 = K
  159		;
  160		(eval_with_ID_P(yes) ->
  161			evaluator(K, Expr, Fitness)
  162			;
  163			evaluator(Expr, Fitness)),
  164		add_individual(PopSize, Fitness, Expr),
  165		writel(T),    % T=first arg of add_child
  166		K2 is K + 1),
  167	!.
  168		
  169add_individual(_, Fitness, NewExpr) :-
  170	gen_type_P(separate),
  171	!,
  172	assert(newindividual(_, Fitness, NewExpr)).
  173add_individual(PopSize, Fitness, NewExpr) :-
  174	tournament_select(worst, PopSize, ID, _),
  175        retract(individual(ID, _, _)),
  176	assert(individual(ID, Fitness, NewExpr)).
  177
  178% Expression is legal if:
  179% 1. If unique population option is on, then if child exists in population, 
  180%    don't add it
  181% 2. If size of child exceeds max, don't add.
  182% 3. If expression modes set, don't add if expression fails them.
  183% Flag set to 'main' if called in main GP loop; else set to 'lamarck'
  184% (affects if newindividual exists or not; sloppy).
  185
  186legal(Expr,Flag) :-
  187	check_unique(Expr,Flag), 
  188	check_depth(Expr),
  189	!.
  190
  191check_unique(_, _) :-
  192	\+ unique_population_P(yes),
  193	!.
  194check_unique(Expr, main) :-
  195	gen_type_P(separate),
  196	!,
  197	\+ newindividual(_, _, Expr).
  198check_unique(Expr, _) :-
  199	\+ individual(_, _, Expr).
  200
  201% succeed if Expression depth within limits
  202
  203check_depth(Expr) :-
  204	max_depth_P(_, MaxDepth),
  205	tree_depth(Expr, D),
  206	D =< MaxDepth,
  207	!.
  208
  209% succeed if solution criteria satisfied
  210
  211solved_run :-
  212	best_in_run(_, BFitness, _),
  213	error_tolerance_P(Err),
  214	BFitness =< Err,
  215	!.
  216	
  217clean_up_1 :-
  218	set_random_number_gen,
  219	retractall(start_time(_)),
  220	retractall(best_so_far(_, _, _, _)),
  221	garbage_collect,
  222	!.
  223
  224clean_up_2 :-
  225	retractall(best_in_run(_, _, _)),
  226	retractall(gp_stats(_, _, _, _, _, _, _)),
  227	retractall(individual(_, _, _)),
  228	retractall(newindividual(_, _, _)),
  229	retractall(popn_size(_)),
  230	% retractall(trace_count(_,_)),
  231	% retractall(saved_trace(_)),
  232	retractall(popn_cnt(_)),
  233	retractall(temp(_)),
  234	garbage_collect,
  235	!.
  236
  237
  238% for interactive exec...
  239
  240clean_up :- clean_up_1, clean_up_2.
  241
  242% If evaluator_reset_P(Gen) is set to a routine name, then call it before
  243% each generation ensues. It is called if it is the Nth generation (1st gen
  244% is first one a set is created).
  245
  246evaluator_reset(_) :-
  247	evaluator_reset_P(_, no),
  248	!.
  249evaluator_reset(G) :-
  250	evaluator_reset_P(C, N),
  251	0 is mod(G, N),
  252	call(C),
  253	!.
  254evaluator_reset(_).
  255/*
  256evaluator_reset :-
  257	evaluator_reset_P(no),
  258	!.
  259evaluator_reset :-
  260	evaluator_reset_P(C),
  261	call(C),
  262	!.
  263evaluator_reset.
  264*/
  265
  266% If a separate population scheme is being used, then rename the 
  267% newindividual's to individuals, and give them ID numbers.
  268
  269rename_new_popn :-
  270	gen_type_P(separate),
  271	!,
  272	retractall(individual(_,_,_)),
  273	renumber_population.
  274rename_new_popn.
  275
  276% If elite migration is on, and gen_type is separate, then migrate the
  277% N best individuals into new population.
  278% If ReEval = yes, then each has fitness recomputed (assume new generation of
  279% testset done beforehand elsewhere).
  280
  281elite_migration(_, StartSize) :- 
  282	gen_type_P(separate),
  283	elite_migrate_P(N, ReEval), 
  284	N > 0,
  285	!,
  286	setof((V,K), E^individual(K,V,E), Set),
  287	first_K(0, N, Set, Elite),
  288	copy_elite(Elite, ReEval),
  289	StartSize is N + 1.
  290elite_migration(K, K) :- !. % else not done
  291
  292copy_elite([], _) :- !.
  293copy_elite([(V,K)|B], ReEval) :-
  294	individual(K,_,E),
  295	(ReEval=yes -> 
  296		(eval_with_ID_P(yes) -> 
  297			evaluator(K, E, V2)
  298			;
  299			evaluator(E, V2)), 
  300		write('?')
  301		; 
  302		V=V2),
  303	assert(newindividual(K,V2,E)),
  304	!,
  305	copy_elite(B, ReEval).
  306
  307evaluator(_K, E, V2):- evaluator(E, V2)