%PROCESS MACRO, MDECK; (subscriptrange, size): BlackBox: procedure options (main, reorder); /* */ /*--------------------------------------------------------------------- */ /* Algorithmic Conjurings: Natural Algorithms */ /* */ /* BlackBox.PLI (PL/I) */ /* version 1.0.0 */ /*--------------------------------------------------------------------- */ /* */ /* COPYRIGHT NOTICE, DISCLAIMER, and LICENSE: */ /* */ /* If you modify this file, you may insert additional notices */ /* immediately following this sentence. */ /* PL/I version prepared by R. A. Vowels, 9 November 2001, */ /* derived from Fortran version 1.0.0. */ /* Copyright 1994-2001 Scott Robert Ladd. */ /* All rights reserved, except as noted herein. */ /* */ /* This computer program source file is supplied "AS IS". Scott Robert */ /* Ladd (hereinafter referred to as "Author") disclaims all warranties,*/ /* expressed or implied, including, without limitation, the warranties */ /* of merchantability and of fitness for any purpose. The Author */ /* assumes no liability for direct, indirect, incidental, special, */ /* exemplary, or consequential damages, which may result from the use */ /* of this software, even if advised of the possibility of such damage.*/ /* */ /* The Author hereby grants anyone permission to use, copy, modify, and*/ /* distribute this source code, or portions hereof, for any purpose, */ /* without fee, subject to the following restrictions: */ /* */ /* 1. The origin of this source code must not be misrepresented. */ /* */ /* 2. Altered versions must be plainly marked as such and must not */ /* be misrepresented as being the original source. */ /* */ /* 3. This Copyright notice may not be removed or altered from any */ /* source or altered source distribution. */ /* */ /* The Author specifically permits (without fee) and encourages the use*/ /* of this source code for entertainment, education, or decoration. If */ /* you use this source code in a product, acknowledgment is not required*/ /* but would be appreciated. */ /* */ /* Acknowledgement: */ /* This license is based on the wonderful simple license that */ /* accompanies libpng. */ /* */ /*--------------------------------------------------------------------- */ /* */ /* For more information on this software package, please visit */ /* Scott's web site, Coyote Gulch Productions, at: */ /* */ /* http:/*www.coyotegulch.com */ /* */ /*--------------------------------------------------------------------- */ declare true bit(1) value ('1'b), false bit(1) value ('0'b); /*------------------------------------------------------------------------------ */ /* constants */ %declare precision character; %precision = 31; /* change for specific compiler/platform */ /*------------------------------------------------------------------------------ */ /* main program */ /* Initialize the random number generator, for a non-default seed value. */ declare r fixed binary (precision); r = RANDOM(SECS() - DAYSTOSECS(DAYS())); /* call optimization routine */ call Optimize(100,50,1.0,0.1,true,true); /*------------------------------------------------------------------------------ */ /* internal procedures and functions */ /* where the work happens */ /* btest: procedure (a, p) returns (bit(1)); declare a fixed binary (precision), p fixed binary; return ( iand (a, isll (1, p)) ^= 0 ); end btest; ibset: procedure (a, p) returns (fixed binary (precision)); declare a fixed binary (precision), p fixed binary (precision); return ( ior (a, isll (1, p)) ); end ibset; ibclr: procedure (a, p) returns (fixed binary (precision)); declare a fixed binary (precision), p fixed binary (precision); return ( iand (a, inot(isll (1, p))) ); end ibclr; */ %btest: procedure (a, p); declare (a, p) character; answer ( '(iand (' || a ||', isll (1,' || p || ')) ^= 0)' ); %end btest; %ibset: procedure (a, p); declare (a, p) character; answer( 'ior (' ||a || ', isll (1,' || p || '))' ); %end ibset; %ibclr: procedure (a, p); declare (a, p) character; answer ( 'iand (' || a || ', inot(isll (1,' || p || ')))' ); %end ibclr; %activate btest, ibset, ibclr; Optimize: procedure (pop_size_arg, max_gen_arg, cross_rate_arg, mute_rate_arg, elitism, scaling); /* arguments */ declare (pop_size_arg, max_gen_arg) fixed binary; declare (cross_rate_arg, mute_rate_arg) float; declare (elitism, scaling) bit (1); /* local values set from arguments */ declare (pop_size, max_gen) fixed binary (precision); declare (cross_rate, mute_rate) float; /* local constants */ declare all_bits_mask fixed binary (precision) value (-2147483647); /* working storage */ declare (most_fit, high_fit, low_fit, mask) fixed binary (precision); declare (total_fit, avg_fit, r) float; declare (i, generation, selection, father, mother, start, bit_no) fixed binary (precision); declare population (*) fixed binary (precision) controlled; declare children (*) fixed binary (precision) controlled; declare fitness (*) fixed binary controlled; declare status (0:1) character (5) initial ('false', 'true'); /* display header */ put ('BlackBox Optimization (PL/I)' ); put skip list ('----------------------------------'); /* adjust arguments */ if (pop_size_arg < 10) then pop_size = 10; else pop_size = pop_size_arg; if (max_gen_arg < 1) then max_gen = 1; else max_gen = max_gen_arg; if (cross_rate_arg < 0.0) then cross_rate = 0.0; else if (cross_rate_arg > 1.0) then cross_rate = 1.0; else cross_rate = cross_rate_arg; if (mute_rate_arg < 0.0) then mute_rate = 0.0; else if (mute_rate_arg > 1.0) then mute_rate = 1.0; else mute_rate = mute_rate_arg; /* display parameters */ put skip edit ( ' population size: ', trim(pop_size)) (a); put skip edit ( "maximum generations: ", trim(max_gen) ) (a); put skip edit ( " crossover rate: ", cross_rate * 100.0, "%" ) (a); put skip edit ( " mutation rate: ", mute_rate * 100.0, "%" ) (a); put skip edit ( " scaling: ", status(scaling)) (a); put skip edit ( " elitism: ", status(elitism)) (a); /* on storage snap begin; put skip list ( "*** error allocating arrays" ); resignal storage; end; */ /* allocate arrays */ allocate population(pop_size), children(pop_size), fitness(pop_size); /* fill population with random values */ do i = 1 to pop_size; population(i) = FLOOR(2147483000.0 * RANDOM()); end; /* start the main loop */ generation = 0; main_loop: do forever; /* increment generation */ generation = generation + 1; /* initialize fitness testing */ low_fit = 1000; /* must be higher than max possible fitness (32) */ high_fit = -1; total_fit = 0.0; /* fitness testing */ do i = 1 to pop_size; /* call fitness routine and store result */ fitness(i) = BlackBoxTest(population(i)); /* track highest fitness */ if fitness(i) > high_fit then do; high_fit = fitness(i); most_fit = population(i); end; /* track lowest fitness */ if fitness(i) < low_fit then low_fit = fitness(i); /* accumulate total fitness */ total_fit = total_fit + fitness(i); end; /* exit if we have zero total fitness */ if (total_fit = 0.0) then do; put skip list ( "*** population has zero fitness... terminating" ); leave main_loop; end; /* display stats for this generation */ avg_fit = total_fit / pop_size; put skip edit ( generation, " best: ", most_fit, ", fitness = ", high_fit )(a); /* are we done? */ if (high_fit = 32) then do; put skip list ( "Optimization complete!" ); leave main_loop; end; /* exit if we've reached the maximum generation */ if (generation = max_gen) then do; put skip list ( "Done!"); return; end; /* if scaling enabled, do it */ if (scaling) then do; /* ensure lowest fitness is at least one, to avoid divide by zero */ if (low_fit < 1) then low_fit = 1; /* recalc total fitness based on scaled values */ total_fit = 0; do i = 1 to pop_size; fitness(i) = fitness(i) - low_fit; /* reduce by smallest fitness */ fitness(i) = fitness(i) * fitness(i); /* square result of above */ total_fit = total_fit + fitness(i); /* accumulate; */ end; end; /* elitist selection, if requested */ if elitism then do; children(1) = most_fit; start = 2; end; else start = 1; /* breed children */ do i = start to pop_size; /* roulette-select first parent */ selection = FLOOR(total_fit * RANDOM()); father = 1; do while (selection > fitness(father)); selection = selection - fitness(father); father = father + 1; end; /* crossover */ r = RANDOM(); if (r < cross_rate) then do; /* roulette-select second parent */ selection = FLOOR(total_fit * RANDOM()); mother = 1; do while (selection > fitness(mother)); selection = selection - fitness(mother); mother = mother + 1; end; /* mask off bits to be copied from first parent */ mask = ISLL(all_bits_mask, FLOOR((precision+1) * RANDOM())); /* combine parents to create child */ children(i) = IOR(IAND(mask,population(father)),IAND(INOT(mask), population(mother))); end; else /* asexual reproduction */ children(i) = population(father); /* mutation */ r = RANDOM(); if r < mute_rate then do; /* pick the bit to flip */ r = RANDOM(); bit_no = FLOOR((precision+1) * r); /* flip the bit */ if BTEST(children(i),bit_no) then children(i) = IBCLR(children(i),bit_no); else children(i) = IBSET(children(i),bit_no); end; end; /* replace population by its children */ population = children; end; /* deallocate arrays */ free population, children, fitness; end Optimize; /* the magical function that we're trying to maximize */ BlackBoxTest: procedure (x) returns (fixed binary (precision)); /* arguments */ declare x fixed binary (precision); /* local variables */ declare BlackBoxTestResult fixed binary (precision); /* local constants */ declare secret fixed binary (precision) value (299792458); /* local working storage */ declare test_bit fixed binary; /* count the bits (yeah, this ain't efficient, but it works)... */ /* ...a hardcoded table for "secret" would be faster, but unique */ /* to a specific value of secret. If this were a performance */ /* app, I'd come up with something better. */ BlackBoxTestResult = 0; do test_bit = 0 to precision; if (IAND(x,ISLL(1,test_bit)) = IAND(secret, ISLL(1,test_bit))) then BlackBoxTestResult = BlackBoxTestResult + 1; end; return (BlackBoxTestResult); end BlackBoxTest; end BlackBox;