Dodatek C
Program SCS

Zamieszczamy niżej pełny tekst programu SCS, będącego implementacją uproszczonego systemu klasyfikującego w języku Pascal. Tekst źródłowy został podzielony między piętnaście plików (wyd. C.l-C.15):
.�:.>� �;� �'��:�><*: . ..� .
scs.pas program główny
declare.scs definicjeideklaracjeglobalne
initial.scs inicjalizacja "ł
detector.scs detektory środowiska
report.scs raporty o stanie systemu
timekeep.scs symulacja upływu czasu i koordynacja zdarzeń
environ.scs środowisko dla zadania emulacji multipleksera (6 linii)
perform.scs układprzetwarzaniakomunikatów
aoc.scs układ oceniający :x/"
effector.scs efektory
reinforc.scs procedury wzmacniające
advance.scs aktualizacja rejestru izby rozrachunkowej
ga.scs algorytm genetyczny (reprodukcja, krzyżowanie, mutacja, metoda ścisku)
utility.scs podprogramy pomocnicze
io.scs wejście-wyjście
Program SCS wymaga także dołączenia podprogramów generatora liczb pseudoloso-wych (plik random.apb) zamieszczonych w dodatku B.
Podczas inicjalizacji programu użytkownik musi podać nazwy zewnętrzne pięciu następujących plików:
C. Program SCS
353
cfile daneoklasyfikatorach �,�.,?� � ,
efile dane o środowisku
rflle dane opisujące wzmocnienie
tfile dane o zależnościach czasowych
gfile dane dla algorytmu genetycznego
Przykładowe zawartości powyższych plików zostały zamieszczone na końcu dodatku (wyd. C.16-C.22). Użytkownik musi ponadto podać nazwy zewnętrzne dwóch plików (urządzeń) wyjściowych:
rep plik (urządzenie) przeznaczone dla raportów pfile plik (urządzenie) przeznaczone dla tabel
Raporty drukowane zostają wysłane na urządzenie rep, natomiast sumaryczne statystyki - na urządzenie pfile.
program scs;
{ SCS - A Simple Classifier System ) { (C) David E. Goldberg, 1987 ) { All Rights Reserved )
($1 declare.scs }
{$I random.apb ) �
{$I lo.scs )
($1 utłllty.scs )
($1 environ.scs )
($1 detector.scs )
($1 perform.scs } �<>
{$I aoc.scs )
($1 effector.scs ) . . �
($1 reinforc.scs ) , �
($1 timekeep.scs )
{$1 advance.scs }
($1 ga.scs )
($1 report.scs }
($1 initial.scs }
Wyd. C.1. ProgramgłównySCS(plikscs.pas)
begin ( main ) initialization;
detectors(environrec, detectrec, envmessage); * (�' � ;< report(rep); . ,j , ,
with timekeeprec do repeat
tlmekeeper(timekeeprec); .':><'
environment(environrec);
detectors(environrec, detectrec, envmessage);
matchclassifiers(populatlon, envmessage, matchlist); '
aoc(population, matchlist, clearingrec);
effector(population, clearingrec, environrec);
reinforcement(reinforcementrec, population, clearingrec, environrec);
if reportflag then report(rep);
if consolereportflag then consolereport(reinforcementrec);
if plotreportflag then plotreport(pfile, reinforcementrec);
advance(clearingrec);
if gaflag then begin
ga(garec, population); �.,-��>' until halt;
report(rep); ( final report } -' :; i ' close(pfile); ( close plot file ) end.
Wyd. C.1. (cd.)
{ declare.scs: declaratIons for scs )
const
type
maxposition
maxclass
wildcard
- 50;
- 100;
- -l;
bit - 0..1; ( a binary digit ) trit - -1..1; ( a ternary digit; 0-0; 1-1; -] action bit; ( a binaray decision ) ł conditlon array[l..maxposition] of trit; message - array[l..maxposition] of bit; classtype - record
c:condition;
a:action;
strength, bid, ebid:real;
matchflag:boolean; "t
specificity:integer; end;
classarray - array[l..maxclass] of classtype; classlist - record
clist:array[l..maxclass] of integer;
nactive:integer end; poptype - record
classifier:classarray;
nclassifier, nposition:integer;
pgeneral, cbid, bidsigma, bidtax, lifetax,
bidl, bid2, ebidl, ebid2,
surastrength, raaxstrength, avgstrength, minstrength:real end;
population:poptype; matchlist:classlist; envmessage:message; rep:text;
( population of classifiers } ( who matched ) ( environmental message ) ( report device/file )
Wyd. C.2. Definicje i deklaracje globalne (plik declare.scs)
C. Program SCS
355
{ lnltial.scs: initialization coordination ) '�'�''
procedure lniCrepheader(var rep:text); '
( write a header to speclfied flle/dev. )
begin
writeln(rep,'********************************************');
writeln(rep,' A Simple Classifler System - SCS');
writeln(rep,' (C) Davld E. Goldberg, 1987');
writeln(rep,' All Rights Reserved');
writeln(rep, '********************************************' ) ;
writeln(rep); writeln(rep); end;
procedure interactiveheader;
{ clear screen and print interactive header )
begin
clrscr;
initrepheader(con) end;
procedure Initialization;
{ coordinate input and initialization )
begin
interactiveheader; ,,,s,
{ random number & normal init. } randomize; initrandomnormaldeviate; { file/device init. )
open_input(cflle,
open_input(efile,
open_input(rfile,
open_input(tfile,
open_input(gfile, open_output( rep, open_output(pfile, { segment initialization: class initrepheader(rep); initclassifiers(cfile, population); initrepclassifiers(rep, population); initenvironment(efile, environrec); i initrepenvironment(rep, environrec); initdetectors(efile, detectrec); initrepdetectors(rep, detectrec); inltaoc(clearingrec); initrepaoc(rep, clearingrec); initreinforcement(rfile, reinforcementrec); initrepreinforcement(rep, reinforcementrec); inittimekeeper(tfile, timekeeprec); lnitreptimekeeper(rep, timekeeprec); ' initga(gfile, garec, population); initrepga(rep, garec); end; -,, ,
Wyd. C.3. Podprogramy inicjalizacji (plik initial.scs)
interactive, ' classifier , f n);
interactive, ' environment , fn);
interactive , ' reinforcement , f n);
interactive, ' timekeeper , fn);
interactive, 'gen. algorithm , fn);
interactive, ' report , f n);
interactive, plot file , fn);
obj., det., aoc, reinf., timekeep., ga )
356
C. Program SCS
( detector.scs: convert environmental states to env. message } ( detector data declarations ) . ",., ,: s . ; i.,i< .':�..�
type drecord - record
end; ( For thls problem, no detector record ls
requlred. Normally, the detector record ,, ... , contains information for mapping environmental
state variables to the environmental bit-string. }
var detectrec:drecord; ( dummy detector record }
procedure detectors(var environrec:erecord; var detectrec:drecord;
var envmessage:raessage);
( convert environmental state to env. message } begin with environrec do ( place signal message in env. message )
envmessage : signal end;........ ,. .
procedure writemessage(var rep:text; var mess:message; lmessage:integer); ( write a message in bit-reverse order ) var j:integer; begin for j : lmessage downto 1 do
write(rep,mess[j]:l) end;
procedure reportdetectors(var rep:text; var envmessage:message;
nposition:integer); ( write out environmental message ) begin
writeln(rep);
write(rep, 'Environmental message: '); writemessage(rep, envmessage, nposition); p. writeln(rep);
end; ��
procedure initdetectors(var efile:text; var detectrec:drecord);
( dummy detector initializa>:ion )
begin end; *;
st.K ' �. .
procedure initrepdetectors(var rep:text; var detectrec:drecord);
( dummy initial detectors report )
begin end; -~,-
Wyd. C.4. Implementacjadetektorówśrodowiska(plikdetectorscs)
( report.scs: report coordination routines ) ' *"'
/ * * >*{i
( report declarations ) V * *
var pfile:text; ( plot file )
procedure reportheader(var rep:text);
l send report header to specified file/dev. )
begin
page(rep);
writeln(rep, 'Snapshot Report');
writeln(rep, '--------------');
writeln(rep); end;
Wyd. C.5. Procedura koordynująca drukowanie raportów i podprogramy sporządzające raporty (plik report.scs)
C. Program SCS
357
procedure report(var rep:text); ( report coordination routine ) begin
reportheader(rep); , .
reporttime(rep, timekeeprec); ,
reportenvironment(rep, envtronrec);
reportdetectors(rep, envmessage, population.nposition); ,
reportclassifiers(rep, populatlon);
reportaoc(rep, clearingrec); ....
reportreinforcement(rep, reinforcementrec); end;
procedure consolereport(var reinforcementrec:rrecord); ( wrlte console report )
begin with reinforcementrec do begin
clrscr; ( clear the screen )
writeln(' |............................|');
writeln(' Iteration- ',totalcount:8:0);
writeln(' P correct - ',proportionreward:8:6);
writeln(' P50 correct ',proportionreward50:8:6);
writeln( ' |............................|' ) ;
end end;
procedure plotreport(var pfile:text; var reinforcementrec:rrecord); ( write plot report to pfile )
begin with reinforcementrec do begin Ł,
writeln(pfile, totalcount:8:0,' ',proportionreward:8:6,' ',
proportionreward50:8:6); end end;
Wyd. C.5. (cd.)

{ timekeep.scs: timekeeper routines } ,( � , ' , .,
� i - ' � ''
( data declarations )
const iterationsperblock - 10000; ( 10000 iterations per block }
type trecord - record ( timekeeper record type )
initialiteration, initialblock, iteration, block, reportperiod, gaperiod, consolereportperiod,
^ ,._ plotreportperiod, nextplotreport, nextconsolereport, '** nextreport, nextga:integer;
reportflag, gaflag, consolereportflag, plotreportflag:boolean end;
var tlmekeeprec:trecord;
tfile:text; ' * .....
function addtime(t, dt:integer; var carryflag:boolean):integer; ( increment iterations counter and set carry flag if necessary ) ,. var tempadd:integer; begin
tempadd :- t + dt;
carryflag :- (tempadd >- iterationsperblock);
if carryflag then '>V -'-*�'
tempadd :- tempadd mod iterationsperblock;
addtime :- tempadd end;
Wyd. C.6. Podprogramy do symulacji uptywu czasu i koordynacji zdarzeń (plik timekeep.scs)
358
C. Program SCS
procedure lnittimekeeper(var tfile:text; var timekeeprec:trecord);
( initialize tlmekeeper )
var dummyflag:boolean;
begin with timekeeprec do begin
iteration :- 0; block :- 0;
readln(tfile, initialiteration);
readln(Cfile, initialblock);
readln(tfile, reportperiod);
readln(tfile, consolereportperiod);
readln(tfile, plotreportperiod);
readln(tfile, gaperiod);
iteration :- initialiteration;
block :- initialblock; ';
nextga :-addtime(iteration, gaperiod, dummyflag);
nextreport :- addtime(iteration, reportperiod, dunmyflag);
nextconsolereport :-addtime(iteration, consolereportperiod, dummyflag);
nextplotreport :- addtime(iteration, plotreportperiod, dumnyflag); end end;
procedure initreptimekeeper(var rep:text; ( initial timekeeper report } begin with timekeeprec do begin
writeln(rep);
writeln(rep, 'Timekeeper Parameters');
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep, end end;
'Initial iteration 'Initial block 'Report period 'Console report period 'Plot report period 'Genetic algorithm period
var timekeeprec:trecord);
initialiteration:8); initialblock:8); reportperiod:8); consolereportperiod:8); plotreportperiod:8); gaperiod:8);
procedure timekeeper(var timekeeprec:trecord);
( keep time and set flags for time-driven events )
var carryflag, dummyflag:boolean;
begin with timekeeprec do begin * *"'' ^"*5*'
iteration :- addtime(iteration, 1, carryflag);
if carryflag then block :- block + 1; V
reportflag :- (nextreport - iteration);
if reportflag then { reset )
nextreport :- addtime(iteration, reportperiod, dummyflag);
consolereportflag :- (nextconsolereport - iteration);
if consolereportflag then
nextconsolereport :-addtime(iteration, consolereportperiod, dunmyflag);
plotreportflag :- (nextplotreport - iteration);
if plotreportflag then
nextplotreport : addtime(iteration, plotreportperiod, dummyflag);
gaflag :- (nextga - iteration);
if gaflag then nextga :- addtime(iteration, gaperiod, dummyflag); end end;
procedure reporttime(var rep:text; var timekeeprec:trecord);^ ( print out block and iteration number ) *
begin with timekeeprec do
writeln(rep, '[ Block:Iteration ] - [ ',block,':',iteration, end;
Wyd. C.6. (cd.)
( environ.scs: multlplexer envlronment )
( environment declarations ) type erecordrecord
laddress, ldata, lsignal, address, output, classifieroutput:lnteger; " .
signal:message; end;
var envlronrec:erecord;
efile:text; ' '. '�"
procedure generatesignal(var environrec:erecord); '
( generate random signal } var j:lnteger;
begin with environrec do ''" ** *'^"4^for j :- 1 to lsignal do ' >Ld r! *
if flip(0.5) then signal[j] :- 1 �-
else signal[j] :- 0 �
end;
function decode(var mess:message; start, length:integer):integer; ( decode substring as unsigned binary integer ) var j, accum, powerof2:integer; begin
accum :- 0; powerof2 : 1; for j :- start to start+length-1 do begin accum :- accum + powerof2*mess[j]; powerof2 :- powerof2 * 2; , , *
end: -f, ,,.�
decode :- accum
end;
procedure multiplexeroutput(var environrec:erecord);
( calculate correct multiplexer output )
var j:integer;
begin with environrec do begin
( decode the address )
address : decode(signal,l,laddress); ( set the output )
output : signal[laddress + address + 1] * " ' end end;
procedure environment(var envlronrec:erecord);
( coordinate multiplexer calculations )
begin ....., ':; ,*'".
generatesignal(environrec); '..� .j
multiplexeroutput(4nvironrec); end;
procedure initenvironment(var efile:text; var environrec:erecord);
( initialize the multiplexer environement )
var j:integer;
begin with environrec do begin a f.i, ; , ,, ,���. , ', ,rc.
readln(efile, laddress);
ldata - round(poweri(2.0, laddress));
lsignal - laddress + ldata;
address - 0;
output - 0;
clnssifieroutput :- 0; for J :- 1 to lslgnal do signal[j] :- 0;
end end;
( read number of address lines )
( calculate number of data lines
( calculate length of signal }
( zero out multiplexer )
� .s:'S'
Wyd. C.7. Symulator środowiska dla zadania emulacji multipleksera z 6 liniami wejściowymi (plik environ.scs)
360
C. Program SCS
procedure lnicrepenvlronment(var rep:text; var environrec:erecord); ( write inltial envlronmental report ) begin wlth environrec do begin wrlteln(rep);
writeln(rep, writeln(rep, wrlteln(rep, wrlteln(rep, writeln(rep, end end; 'Environmental Parameters (Multiplexer)'): .......... ___ >\.
'Number of address lines 'Number of data lines 'Total number of lines laddress:8) ldata:8); lsignal:8);
procedure writesignal(var rep:text; var signal:message; lsignal:integer); ( wrlte a signal in bit-reverse order ) var j:integer; begin
for j :- lslgnal downto 1 do write(rep,signal[j]:l) end;
procedure reportenvironment(var rep:text; var environrec:erecord); { write current raultiplexer info ) begin with environrec do begin
writeln(rep);
writeln(rep,'Current Multiplexer Status'
writeln(rep,'-------------------------'
write(rep,'Signal - '
writesignal(rep,signal,lsignal); writeln(rep);
writeln(rep,'Decoded address ', address:8);
writeln(rep,'Multiplexeroutput ', output:8);
writeln(rep,'Classifier output - ', classifieroutput:8); end end;
Wyd.C.7. (cd.) ' '�- ��-.��*.�...,� ; ; .-; . ,
( perform.scs: performance system - classlfier matching }
( performance declarations - most are in declare.scs ) var cfile:text; ( classifier file )
function randomchar(pgeneral:rea^):integer;
( set positlon at random with specified generality probabllity )
begin
lf flip(pgeneral) then randomchar :- wildcard else if flip(0.5) thenrandomchar :- 1 rft t}
else randomchar :- 0 * '
end; /.{H^,.*-i> �.
procedure readcondition(var cfile:text; var c:condition;
var pgeneral:real; var nposition:integer); ( read a single condition ) var ch:char; J:integer; begin
for j :- nposition downto 1 do begin - ł ;> ' �
read(cfile, ch); '� ' > ''�
case ch of
'0':c[j) :- 0; .->
'l':c[jJ :- 1; '#':c[j] :- wildcard; 'R':c[j] :- randomchar(pgeneral); end ; . �
end -.-:<'
end;
Wyd. C.8. Podprogramy układjj przetwarzania komunikatów (plik perform.scs)
procedure readclasslfler(var cflle:text; var class:classtype;
pgeneral:real; nposition:integer);
( read a single classifier )
var ch:char;
begin with class do begin * ''"'
readcondition(cfile, c, pgeneral, nposiCion); ( read(cfile,ch); (
read(cfile, a); (
readln(cfile, strength); (
bid :- 0.0; ebld :- 0.0; matchflag :- false (
end end;
read condtion )
read ":" & ignore )
read acCion, a single Crit )
read strength )
initialization )
function countspecificity(var c:condition; nposition:integer):integer; { count condition specificity ) var temp:inteeer;
begin �. -� ��� ' :--'..-''i-* ^*,^a
temp :- 0; while nposition > 1 do begin
if c[nposition] O wildcard nposition : nposition - 1; end;
countspecificity : temp; end;
then temp : temp + 1;
procedure initclassifiers(var cfile:text; var population:poptype);
( initialize classifiers )
var j:integer; J '�
begin with population do begin '-n->--
readln(cfile,nposition); ;
readln(cfile,nclassifier); '.. ,,,..�>
readln(cfile,pgeneral); > ,
readln(cfile,cbid); \ r�
readln(cfile,bidsigma); ?'.;�
readln(cfile,bidtax); <.'y*
readln(cfile,lifetax); ' ' ..,., ; "
readln(cfile,bidl); readln(cfile,bid2); readln(cfile,ebidl); - readln(cfile,ebid2); for j :- 1 to nclassifier do begin
readclassifier(cfile, classifier[j], pgeneral, nposition); with classifier[j] do specificity :- countspecificity(c, nposition); end; , __ .. , . _ . .,. ,.,,.. ,, ^, (,,;.,.,, -,Jt,.,-
end end; ' ' � "-" ' ' ""�� '�'�'.' � '�.....""'"' ' ' : ' .
procedure initrepclassifiers(var rep:text;
{ Initial report on population parameters
begin with population do begin writeln(rep); writeln(rep,'Population Farameters');
writeln(rep,'.....................' ) ;
writeln(rep,'Number of classifiers -writeln(rep,'Number of positions -writeln(rep,'Bidcoefficient writeln(rep,'Bid spread writeln(rep,'Bldding tax -
writeln(rep,'Existence tax
writeln(rep,'Generality probability -writeln(rep,'Bid specificity base -writeln(rep,'Bid specificity mult. writeln(rep,'Ebid specificity base -writeln(rep,'Ebid specificity mult. -
end end;
var population:poptype);
,nclassifier:8);
,nposition:8);
,cbid:8:4);
,bidsigma:8:4);
,bidtax:8:A);
,lifetax:8:4);
,pgeneral:8:4);
,bidl:8:4);
,bid2:8:4);
,ebidl:8:4);
,ebid2:8:4);
Wyd. C.8. (cd.)
362
C. Program SCS
procedure wrlteconditton(var rep:text; var c:condition; nposltion:lnteger); l convert internal condłtion format to external format and write to ftle/dev. ) var j : lnteger; - .-begin for j :- npositlon downto 1 do
case c[j ] of .",/ -
,"., 1: write(rep,'l'); - ,t <� ,,. �
0: write(rep,'0'); wildcard: write(rep,'#');
end � ' *' '' � '
end;
procedure writeclassifier(var rep:text; class:classtype;
number,nposition:integer);
( write a single classifier ) .>c
begin with class do begin
write(rep, nuraber:5,' ',strength:8:2,' ',bid:8:2,' ',ebid:8:2);
if matchflag then write(rep,' X ') else write(rep,' ');
writecondition(rep, c, nposition); . ,".
writeln(rep,':','[',a,')') end end;
procedure reportclassifiers(var rep:text; var population:poptype);
{ generate classifiers report )
var j:integer;
begin with population do begin '
writeln(rep);
writeln(rep,'No. Strength bid ebidMClassifier ');
writeln(rep,'............-........................................' ) ;
writeln(rep);
for j : 1 to nclassifier do
writeclassifier(rep, classifier[j], j, nposition); end end;
function match(var c:condition; var m:message; nposition:integer):boolean; ( match a single condition to a single message } var matchtemp:boolean;
natchtemp :- true;
while (matchterap - true) and (nposltion > 0) do begin
matchtemp :- (cfnposltion) - wildcard) or (c[nposition] - m[nposition]); nposition :- npositlon - 1 end;
match :- matchtemp . ,* , ,,,
end;
procedure matchclassifiers(var population:poptype; var emess:message;
var matchlist:classlist);
{ match all classifiers against environmental message and create match list } var j:integer; ",; Ł-
begin with population do with matchlist do begin � � nactive : 0; y
for J :- 1 to nclassifier do with classifier[j) do begin ,, matchflag :- match(c, emess, nposition); if matchflag then begin nactive : nactive + 1; clist[nactiveJ :- j end
end end; Wyd.C.8. (cd.)
( aoc.scs: apportionment of credit routines )
( aoc data declaraClons - aoc uses cfile for lnput ) type crecord record
winner, oldwinner:integer;
bucketbrigadeflag:boolean; end;
var clearingrec:crecord;
procedure lnttaoc(var clearingrec:crecord); ' -'
( lnltlallze clearinghouse record ) '
var ch:char; begin wlth clearingrec do begin
readln(cfile, ch);
bucketbrigadeflag :- (ch - 'y') or (ch - 'Y');
wlnner :- 1; oldwinner :- 1 { lst classifler picked as lst oldwlnner ) end end; "' �� �� - ." �. �� " : � � �
procedure lnltrepaoc(var rep:text; var clearingrec:crecord); ( lnitial report of clearinghouse pararaeCers ) begin with clearlngrec do begin wrlteln(rep); writeln(rep, 'Apportionment of Credit Parameters'); :�>., r
writeln(rep, '..................................' ) ;
write(rep, 'Bucketbrigade flag - '); �;oJ; if bucketbrigadeflag then writeln(rep, ' true') else
writeln(rep, 'false'); end end;
function auction(var population:poptype; var matchlist:classlist;
oldwinner:integer):integer; ^.'> '
( auction among currently matched classiflers - return winner } var j, k, winner:integer; bidmaximum:real; begin wlth population do with matchlist do begin
bidmaximum :- 0.0; .<,
winner :- oldwinner; ( if no match, oldwinner wins again } if nactive > 0 then for j :- 1 to nactive do begin k :- clist[j]; with classifier[k] do begin
bid :- cbid * (bidl + bid2 * specificity) * strength; ebid :- cbid * (ebidl + ebid2 * specificity) * strength
+ noise(0.0, bidsigma); if (ebid > bidmaximum) then begin
winner :- k; '�>�� � -"''*'''> � . -:: ' > '.-..i: - �� ' v :
bidmaximum :- ebid end
end end;
auction :- winner end end;
procedure clearinghouse(var population:poptype; var clearingrec:crecord); ( distribute payment from recent winner to oldwinner ) var payment:real;
begin with population do with clearingrec do begin with classifier[winner] do begin ( payment } payment :- bid;
strength :- strength - payment end;
if bucketbrigadeflag then ( pay oldwinner receipt if bb is on ) with classifier[oldwinner] do strength :- strength + payment end end;
Wyd. C.9. Podprogramy algorytmu przyznawania ocen (plik aoc.scs)
.ft,3 .oyW
364
C. Program SCS
procedure taxcollector(var population:poptype);
( collect exlstence and biddlng taxes from population members )
var j:integer; bidtaxswitch:real; .^
begin with population do begin
( life tax from everyone & bidtax from actives )
if (lifetax O 0.0) or (bidtax O 0.0) then for j :- 1 to nclassifier do with classifier[j] do begin
if matchflag then bidtaxswitch :- 1.0 else bidtaxswitch :- 0.0; strength :- strength - lifetax*strength - bidtax*bidtaxswitch*strength; end; end end; . . ,,,... .. , ; , ,
procedure reportaoc(var rep:text; var clearingrec:crecord);
( report who pays to whom }
begin
writeln(rep);
with clearingrec do
writeln(rep, 'Newwinner [',winner,'] : Oldwiriner [',oldwinner,']') end;
procedure aoc(var population:poptype; var matchlist:classlist;
var clearingrec:crecord); ( apportionment of credit coordinator ) begin
with clearingrec do winner :- auction(population, matchlist, oldwinner);
taxcollector(population);
clearinghouse(populaticm, clearingrec); end;
Wyd. C.9. (cd.)
( effector.scs: effector routine ) ��'�
procedure effector(var population:poptype; var clearingrec:crecord;
var environrec:erecord);
( set action in object as dictated by auction winner ) begin with population do with clearingrec do with environrec do classlfieroutput :- classifier[winner].a end;
Wyd.C.10. Implementacjaefektorów(plikeffecfor.scs) ;-
( reinforc.scs: reinforcement and criterion procedures )
( reinforcement data declarations )
type rrecord - record ( reinforcement record type)
reward, rewardcount, totalcount, count50,
rewardcount50, proportionreward,
proportionreward50:real;
lastwinner:integer; ,'� < '
end;
var reinforcementrec:rrecord; ,-...:�-
rfile:text; ( reinforcement file - rfile )
Wyd.C.11. Podprogramywzmacniajace(plikre/nforc.scs)
procedure initreinforcement(var rflle:text; ( initialize reinforcement parameters ) begin with reinforcementrec do begin readln(rfile, reward);
var reinforcementrec:rrecord);
rewardcount rewardcount50 totalcount count50
propor tionreward proportionreward50 lastwinner :- 0; end end;
- 0.0;
- 0.0;
- 0.0;
- 0.0;
- 0.0;
- 0.0;
procedure initrepreinforcement(var rep:text; var reinforceraentrec:rrecord); ( initial reinforcement report ) begin with reinforcementrec do begin
writeln(rep);
writeln(rep, 'Reinforcement Farameters');
writeln(rep, '......------------------');
writeln(rep, 'Reinforceraent reward - ', reward:8:l); end end;
function criterion(var rrec:rrecord; var environrec:erecord):boolean; ( return true if criterion is achieved ) var tempflag:boolean;
begin with rrec do with environrec do begin s;li>:,ic;>;" .Sf.D ,1�.
tempflag :- (output - classifieroutput); totalcount :- totalcount + 1; count50 :- count50 + 1;
( increment reward counters ) '� if tempflag then begin
rewardcount : rewardcount + 1; rewardcount50 : rewardcount50 + 1; end;
{ calculate reward proportions: running & last 50 } proportionreward : rewardcount/totalcount; if ( round(count50 - 50.0) - 0) then begin proportionreward50 :- rewardcount50/50.0; rewardcount50 :- 0.0; count50 :- 0.0 ( reset ) end;
criterion :- tempflag; '''"/
end end;
procedure payreward(var population:poptype; var rrec:rrecord;
var clearingrec:crecord); ( pay reward to appropriate individual )
begin with population do with rrec do with clearingrec do with classifier[winner] do begin strength :- strength + reward; lastwinner :- winner end end;
procedure reportreinforcement(var rep:text; var reinforcementrec:rrecord);
( report award }
begin with reinforcementrec do begin , . , .,
writeln(rep); ,, , ",
writeln(rep, 'Reinforcement Report'); - - -,
writeln(rep,
writeln(rep,
writeln(rep, writeln(rep, end end;
'Proportion Correct (from start)
proportionreward:8:4); 'Proportion Correct (last fifty) -
proportionreward50:8:4); 'Last winning classifier number -
lastwinner:8);
Wyd. C.11. (cd.)
366
C. Program SCS
procedure reinforcement(var reinforcementrec:rrecord; var population:poptype;
var clearingrec:crecord; var envtronrec:erecord); ( make payment if criterion satisfied }
begin , ,.-,,.-
if criterion(relnforcementrec, environrec) then
payreward(population, reinforceraentrec, clearingrec); end;
Wyd.C.11. (cd.)
{ advance.scs: advance variables for next time step )
procedure advance(var clearingrec:crecord);
( advance winner } , 'ii
begin with clearingrec do oldwinner :- winner end;
Wyd. C.12. Procedura aktualizacji rejestru izby rozrachunkowej (plik advance.scs)
( ga.scs: genetic algorithm code for SCS ) ,,
( data declarations ) const maxmating 10;
type rarecord record
matel, raate2, mortl, mort2, sitecross:integer end;
marray - array[l..maxmating] of mrecord; grecord - record
proportionselect, pmutaCion, pcrossover:real; ncrossover, nmutation, crowdingfactor, crowdingsubpop,
nselect;integer;
mating:marray; ( mating records for ga report) end;
var garec:grecord;
gfile:text; �>'� }
procedure initga(var gfile:text; var garec:grecord; var population:poptype);
( initialize ga parameters }
begin with garec do with population do begin
readln(gfile, proportionselect);
readln(gfile, pmutation);
readln(gfile, pcrossover);
readln(gfile, crowdingfactor);
readln(gfile, crowdingsubpop);
nselect :- round(proportlonselect * nclassifier * 0.5);
{ number of mate pairs to select )
nmutatlon :- 0; ncrossover :- 0; end end;
Wyd. C.13. Podprogramy algorytmu genetycznego (plik ga.scs)
C. Program SCS
367
Genecic Algorithm Parameters
procedure initrepga(var rep:text; var garec:grecord);
( initial report )
begin with garec do begin , '��
writeln(rep);
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep,
writeln(rep, end end;
Froportion to select/gen -Number to select Hutation probability Crossover probability -Crowding factor Crowding subpopulation -
proportionselect: 8:4); nselect:8); pmutation:B:4); pcrossover:8:4); crowdingfactor:8); crowdingsubpop:8);
function select(var population:poptype):integer;
( select a single individual according to strength )
var rand, partsum:real;
j : integer; - ; ;.;- ..- �.-' -'' � ' � ''' .�; ;
begin with population do begin
partsum :- 0.0; J :- 0;
rand':- random * sumstrength;
repeat
j :- J + 1;
partsum :- partsum + classifier[j].strength until (partsum >- rand) or (J - nclassifier); select :- j; end end;
function mutation(positionvalue:trit; pmutation:real;
var nrautation:integer):trit; ( mutate a single position with specified probability )
var tempmutation:integer; ,
begin
if flip(pmutation) then begin
tempmutation : (positionvalue + rnd(l,2) + 1) mod nmutation :- nmutation + 1; end
else tempmutation :- positionvalue; mutation : tempmutation end;
function bmutation(positionvalue:bit; pmutation:real;
var nmutation:lnteger):bit;
( mutate a single bit with specified probability ) var tempmutation:integer; begin
if flip(pmutation) then begin
tempmutation :- (positionvalue + 1) mod 2; nmutation :- nmutation + 1; end
else tempmutation : positionvalue;, � bmutation :- tempmutation end;
Wyd. C.13. (cd.)
368
C. Program SCS
procedure crossover(var parentl, parent2, childl, child2:classtype;
pcrossover, pmutation:real; ;,i,,-i-, var sitecross, nposition, ncrossover,
nmutation:integer);
( cross a pair at a given site with mutation on Che trit transfer ) var inheritance:real; j:integer;
begin '.-icv<*fA ,-'i.-'----'.v .�.�' ,'t
if flip(pcrossover) then begin . f
sitecross : rnd(l, nposition); ; ?� .��� i ncrossover : ncrossover + 1;
end �=�'��'� ''�-
else sitecross : nposition + 1 { transfer, but no cross ); ( transfer action part regardless of sitecross ) childl.a :- bmutation(parentl.a, pmutation, nmutation); child2.a : bmutatlon(parent2.a, pmutation, nmutation); { transfer and cross above cross site }
j :- sitecross; � >,.i.e>' -j. !
while (j <- nposition) do begin
child2.c[j] :-mutation(parentl.c[j], pmutation, nmutation); childl.c[j] :-mutation(parent2.c(j], pmutation, nmutation);
j :- J + 1 end;
j : 1; f � ,( transfer only below cross site ) while (j < sitecross) do begin
childl.c[j] :-mutation(parentl.c[j], pmutation, nmutation); child2.c[j] :-mutation(parent2.c[j], pmutation, nmutation); j :- j + 1
end; . .&'.��
( children inherit average of parental strength values ) inheritance :-avg(parentl.strength, parent2.strength);,Sj_ with childl do begin
strength :- inheritance; matchflag :- false; , f $-ebid :- 0.0; bid :- 0.0;
specificity :- countspecificity(c, nposition); end; with child2 do begin
strength :- inheritance; matchflag :- false;
ebid :- 0.0; bid :- 0.0;
specificity :-countspecificity(c, nposition);
end: ' �� ,v. . ; �� . *, - j- t
end;
function worstofn(var population:poptype; n:integer):integer; ( select worst individual from random subpopulation of size n ) varj, worst, candidate:integer; worststrength:real; begin with population do begin
( initialize with random selection ) >?- *�" * � '' worst : rnd(l, nclassifier); '
worststrength :-classifier[worst].strength; '
( select and compare from remalning subpopulation ) if (n > 1) then for j :- 2 to n do begin ' �'
candidate :- rnd(l, nclassifier);
if worststrength > classlfier[candidate].strength then begin worst : candidate;
worststrength :- classifier[worst].strength; end; end;
( return worst } worstofn :- worst; end end;
Wyd. C.13. (cd.)
C. Program SCS
369
function maCchcount(var classifierl, classifier2:classtype;
nposition:integer):integer; ( count number of positlons of simllarlty ) var tempcount, j:integer;
begin '"'�'
lf (classiflerl.a - classifler2.a) then tempcount :- 1
else tempcount :*� 0; for J :- 1 to nposltion do
lf (classlflerl.c[j] - classifier2.c[j]) then tempcount :- tempcount + 1; matchcounC :- tempcount; end;
function crowding(var child:classtype; var populatlon:poptype;
crowdingfactor, crowdingsubpop:integer):integer; ( replacement using modified De Jong crowding ) var popmember, j, match, matchmax, mostsimilar:integer; begin with populatlon do begin matchmax :- -1; mostsimilar :- 0; if (crowdingfactor < 1) then crowdingfactor :- 1; for j : 1 to crowdingfactor do begin
popmember :- worstofn(population, crowdingsubpop); { plck worst of n } match :-matchcount(child, classifler[popmember], npositlon); if match > matchmax then begin matchmax : match; mostslmllar :- popmember; end;
end; :
crowding :- mostsimilar; end end;
procedure statistics(var population:poptype); { population statistics - max, avg, min, sum of strength ) var j :integer";
begin with population do begin with classifler[l] do begin maxstrength - strength; minstrength - strength; sumstrength - strength; end; j :- 2;
while (j <- nclassifier) do with classifier[j] do begin maxstrength :-max(maxstrength, strength); minstrength :-min(minstrength, strength);
sumstrength :- sumstrength + strength; j :- j + 1; end;
avgstrength :- sumstrength / nclassifier; end end;
Wyd. C.13. (cd.;
370
C. Program SCS
min, sumstrength ) ( pick mates ) child2, { cross & mutate )
procedure ga(var garec:grecord; var population:poptype);
( coordinate selection, matlng, crossover, rauCation, & replaceraent )
var j:lnteger; childl, child2:classtype;
begin with garec do with population do begin
statistics(population); ( get average, max,
for j :- 1 to nselect do with mating[j] do begin matel :- select(population); mate2 :- select(population);
crossover(classifler[raatel], classifier[mate2], childl, pcrossover, pmutation, sitecross, nposition, ncrossover, nmutation);
mortl :- crowding(childl, population, crowdingfactor, crowdingsubpop); sumstrength :- sumstrength - classifier[mortl].strength
+ childl.strength; ( update sumstrength )
classifier[mortl] :- childl; ( insert child in mortl's place ) mort2 :- crowding(child2, population, crowdingfactor, crowdingsubpop); sumstrength :- surastrength - classifier[mort2].strength
+ chlld2.strength; ( update sumstrength )
classifier[mort2] :- chlld2;
end; . ' _ .^..>. 8-.j, - ,,.,.,,� ��-;,,< - -.� end end; ''"''" ' ""'"' '� '-J--'''-'-"' ......�"
procedure reportga(var rep:text; var garec:grecord; var population:poptype);
( report on mating, crossover, and replacement }
var j:integer;
begin with garec do with population do begin
page(rep); ."
writeln(rep,'Genetic Algorlthm Report');^
writeln(rep, '..........----......---');
writeln(rep);
writeln(rep,'Pair Matel Mate2 SiteCross Mortl Mort2');
writeln(rep, '...........................................');
for J :- 1 to nselect do with mating[j] do
writeln(rep,j:3,' ',matel:3,'
',mortl:3,' writeln(rep); writeln(rep,'Statlstics Report');
writeln(rep, '.....-----------');
writeln(rep,' Average strength -writeln(rep,' Maximum strength -writeln(rep,' Minimum strength -writeln(rep,' Sum of strength -writeln(rep,' Number of crossings -writeln(rep,' Number of mutations -end end;
Wyd. C.13. (cd.)
,mate2:3<' ',mort2:3);
,sitecross:3,
,avgstrength:8:2); ,maxstrength:8:2); ,minstrength:8:2); ,sums trength:8:2); ,ncrossover:8); ,nmutation:8);
C. Program SCS
371

t utility.scs: utility procedures and functions )
functionpowerl(x:real; i:integer):real; .,,,-,;>,
var powertemp:real; ...... ,�,.."> '-,jj.
begin * ,
powertemp :- 1.0; .,,.. ; ," ,,,j ,,
if 10 then powertemp : 1.0 else if i>0 then
rePeat ;,.�-���L�,
powertemp : powertemp * x; i :- i - 1
until i-0 *-'..-,-'<.
else if i<0 then �''"'' *:'-'"-' :��' < :VV^ .1 repeat " �' ' "",' "" �'
powertemp : powertemp / x; i :- i + 1
until i-0; 4
poweri :- powertemp �
end;
slarf
Jfcr*
{ global variables for randomnormaldeviate - watch for conflicting names } var rndx2:real;
rndcalcflag:boolean; '.' si*'-:.'.->"5 ;;f.'--.'.^- ,'.\':f. ,'--,-,,>'-i.H ;~ *
� - � .' <>Vf>
procedure initrandomnormaldeviate; '
( initialization routine for randomnormaldeviate ) begin rndcalcflag : true end; 'W-?
function randomnormaldeviate:real;
( random normal deviate after ACM algorithm 267 / Box-Muller Method } var t, rndxl:real; begin
if rndcalcflag then begin ' ~t �
rndxl :- sqrt(-2.0*ln(random)); t :- 6.2831853072 * random;
rndx2 :- rndxl * sin(t); � i .1 *�
rndcalcflag : false; � '
randomnormaldeviate :- rndxl * cos(t) - - J endelsebegin *" ->,' >"k
randomnormaldeviate : rndx2; rndcalcflag : true end; end;
^-:n; .' �� -"''.fi*-iO.ri'.)
function noise(mu, sigma:real):real;
( normal noise with specified mean & std dev: mu & sigma ) ;' begin noise :- randomnormaldeviate * sigma + mu end;
function rndreal(lo, hl:real):real; (f,h:
( real random number between specified limits ) ,^-;'r. begin rndreal :- random*(hi-lo) + lo end; tl:
functionmax(x, y:real):real; ( return maximum of two values ) begin if x > y then max :- x else max
:- y end;
functionmin(x, y:real):real;
{ return minimum of two real values )
begin if x < y then min :- x else min :- y end;
Wyd. C.14. Podprogramy pomocnicze (plik utility.scs)
372
C. Program SCS
function avg(x, y:real):real;
{ return average of two real values )
begin avg :- 0.5 * (x + y) end; "'"�'.-�
function halt:boolean;
( Test for key press and query for halt flag }
const times 100;
var temp:boolean; ch:char; j:integer;
begin
j :- 0;
repeat j :- j+1 until keypressed or (j>-times);
temp :- (jif temp then begin write('Halt '^^' temp :- (ch - 'y end;
halt :- temp; end;
:emp then begin
rrite('Halt (y/n)? > '); readln(ch);
:emp :- (ch - 'y') or (ch - 'Y'):
Wyd. C.14. (cd.)
(* 10 Routines- File opening routines *) ;tiixi ; .': type query_type (interactive,batch);
txt - string[80J-; � � � i--
var qflag:query_type; fn:txt;
procedure page(var out:text); , . c.J, - .<�.. beginwrite(out,chr(i2)) end;
procedure open_input(var input:text; query_flag:query_type;
message:txt; var filename:txt); begin
if (query_flag-batch) then assign(input,filenane) ' -r else begin & ;-
write('Enter ',message,' filename: ');readln(fllenane); : assign(input,filename); :,
end;
reset(input); end;
procedure open_output(var output:text; query_flag:query_type;
message:txt; var filename:txt); begin
if (query_flag-batch) thenassign(output,filename) else begin
write('Enter ',message,' filename: ');readln(fllename); assign(output,filename);
6nd: ;h,"* 15! ' 1 - i.":-' .: - �: - , � , ' ,:
rewrite(output); end; �- . , ... , .. , . , .., - ;
Wyd. C.15. Podprogramywejscia-wyjscia(plik/o.scs) "" '�!
C. Program SCS
373
o o
2000
50
50
-1
( initialiteration )
I initialblock )
( reportperiod )
( consolereportperiod )
( ploCreportperlod )
( gaperiod )
( time.dta }
Wyd. C.16. Przykładowy plik tfile (plik time.dta)
2 ( nuniber of address llnes on raultlplexer ) ( envlron.dta )
Wyd. C.17. Przyktedowyplikeff/e(plikenw'ron.dte)
1.0
( reward )
( relnf.dta
Wyd. C.18. Przykładowy plik rfile (plik reinf.dta)
0.20 { proportionselect )
0.02 ( pmutaClon )
1.0 { pcrossover }
3 ( crowdingfactor }
3 ( crowdingsubpop )
Wyd. C.19. Przykładowy plik gfile (plik ga.dta)
( ga.dta )
6 nposicion ) (
10 nclasslfier }
0.5 pgeneral )
0.10 cbid )
0.075 bidsigma )
0.01 bidtax )
0.0 lifetax }
1.0 bid 1 )
0.0 bid 2 )
1.0 ebid 1 }
0.0 ebid 2 )
###000 0 K ) ( perfect rules )
###100 1 K )
##0#01 0 K )
##1#01 1 K )
#0##10 0 K ) - --.... ,
#1##10 1 K ) ' ' .....
0###11 0 1C ) ��'/�
1###11 1 1C )
###### 0 1C ) { generał rules )
jtt#jttjtjtit 1 1C )
n { bucketbrigadeflag )
( perfect.dta }
Wyd. C.20. Przykładowy plik cfile zawiera dane do eksperymentów z zestawem reguł idealnych z rozdz. 6 (plik perfect.dta)
374
C. Program SCS
6
7
0.5
0.1
0.075
0.01
0.00
1.00
0.00
1.00
0.0
###000:0
##0#01:0
#0##10:0
O###ll:0
ftltltlttt^tt * 1
0###11:1
ftltltttll ll' 0
n
( nposition } ( nclasslfier ( pgeneral ) ( cbid ) { bidsigma ) { bidtax } ( llfetax ) { bid 1 ) ( bid 2 ) ( ebid 1 )
{ lessthan(perfect).dta )
10 10 10 10 10 10 10
ebid 1 ebid 2 )
( default hierarchy }
( monkey wrenches ) { bucketbrigadeflag )
Wyd. C.21. Przykładowy plik cfile zawiera dane do eksperymentów z hierarchią domniemań z rozdz. 6 (plik lessthan.dta)
6 ( nposition )
100 ( nclassifier
0.5 ( pgeneral )
0.10 ( cbid )
0.075 ( bidsigma )
0.01 ( bidtax )
0.000 ( lifetax )
0.25 1 bid 1 }
0.125 { bid 2 }
0.25 { ebid 1 )
0.125 ( ebid 2 )
RRRRRR:0 10
RRHRRR:0 10
RRRRRR:0 10
RRRRRR:0 10
RRRRRR:0 10
RRRRRR:0 10
RRRRRR:0 10
RRRRRR:0 10
RRRRRR.-O 10
RRRRRR:0 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
RRRRRR:1 10
n ( bucketb
( classlOO.dta )
Wyd. C.22. Przykładowy plik cfile zawiera dane do eksperymentów ze startem od zera z rozdz. 6 (plik class100.dta). Dla oszczędności zamieszczono tylko po 10 reguł każdego typu