Just a summer week

There were no big international algorithmic competitions last week (the one that ended on 5th of July), so the time seems right for some boring history digging :)

Between my own archives and the data available on the Internet, my earliest programming contest submission available that scored at least some points seems to be the one to problem 1 of the 1997 Russian Olympiad in Informatics.

The problem was: you're given at most 50 "bad" words of length at most 6, consisting of 3 letters each ("I", "N", and "W" - maybe somebody who was judging that olympiad can shed the light about why those three were chosen?), and each bad word has an associated integer penalty. You need to build a word of the given length (at most 100) consisting of the same three letters, so that the total penalty obtained by summing the penalties for all bad words appearing in it as substrings, is minimized. If a bad word appears multiple times, the penalty is counted multiple times, too.

These days, the problem doesn't seem that difficult, although at that time just 4 contestants have managed to solve it in full, the most famous of which is probably Nikolay Durov. His code uses the dynamic programming approach that seems quite obvious now, although for some reason he uses base-4 representation for the last 5 letters instead of base-3 - maybe to avoid dealing with the first few letters separately.

My own solution did an exhaustive search over all possible output strings, and thus scored just 4 points out of 40. Here it is (note the John Dethridge-style indentation :)

const
inpname='input.txt';
outname='output.txt';
MaxM=50;
MaxL=6;
MaxP=100;
MaxN=100;
type
strin=string[MaxL];
wrd=array[1..MaxM]of strin;
pla=array[1..MaxM]of byte;
var
Next:array[char]of char;
z:wrd;p:pla;
t,r:string;
min,m,n:word;
procedure load;
var f:text;i:byte;s,w:string;cnt:integer;
begin
assign(f,inpname);
reset(f);
readln(f,n);
readln(f,m);
for i:=1 to M do begin
readln(f,s);
z[i]:=copy(s,1,pos(' ',s)-1);
delete(s,1,pos(' ',s));
val(s,p[i],cnt);
end;
close(f);
end;
function getpl(gs:string):word;
var i,j,n:byte;pl:word;
begin
pl:=0;
for i:=1 to M do begin
  n:=0;
  for j:=1 to M-length(z[i])+1 do
    if copy(gs,j,length(z[i]))=z[i] then inc(n);
  inc(pl,n*p[i]);
end;
getpl:=pl;
end;
procedure work;
var mm:word;ps:byte;
begin
min:=65535;
fillchar(t[1],M,'I');
t[0]:=chr(m);
repeat
mm:=getpl(t);
if mm<min then begin min:=mm;r:=t; end;
ps:=M+1;
repeat
dec(ps);
if ps=0 then begin t:='';break; end;
t[ps]:=next[t[ps]];
until t[ps]<>'I';
if t='' then break;
until false;
end;
procedure save;
var f:text;
begin
assign(f,outname);
rewrite(f);
writeln(f,min);
writeln(f,r);
close(f);
end;
begin
next['I']:='N';
next['N']:='W';
next['W']:='I';
load;
work;
save;
end.

Thanks for reading, and check back later today for this week's summary!