Международная олимпиада по программированию 1994г. Задач "Матрица простых чисел".

  program Project2;
 
{$APPTYPE CONSOLE}
 
uses
  windows;
const
 N = 5;
 M = 800;//експерементально определено при 23 максимальное количество простых чисел 756(округлил до 800)
type
 PRow = ^TRow;
 TRow = record
   row:array[0..N-1] of Integer; 
   s:Integer;
   end;
 PSearch= ^ TSearch;
 TSearch=array[0..9] of PRow;//нужна для не большого ускорения поиска
 TStroka =array[0..M-1] of PRow;
var
 Matr:array[0..M-1] of  TRow;
 MaskMatr:array[1..N-1] of record
                    count:Integer;
                    pr:TStroka;
                end;    
 TestMatr:record
    List:array[0..N-1]of PRow;
    Ld,Rd:Integer;
 end;    
 {TestList:array [0..N-2] of record
   Count:Integer;
   M:array[0..M-1] of PRow;
 end;}
 MSearch: TSearch;
 Count:Integer;
 CountMatr:Integer;
 S:Integer;
 
function conv(row:PRow):Integer;
begin
 result:=row.row[0]*10000 +row.row[1]*1000+row.row[2]*100+row.row[3]*10+row.row[4];
end;
function CreateMaskPoint(id:Integer;min,max:PRow):Integer;
var p:^TStroka;
 pi:PInteger;
 i,mx:Integer;
 pr:PRow;
begin
 p:=@MaskMatr[id].pr;
 pi:=@MaskMatr[id].count;
i:=(dword(MSearch[min^.row[0]])- dword(@matr[0])) div sizeof(Trow);
 mx:=conv(max);
Result:=-1;
pr:=@matr[i];
while (i<= Mx) do
begin
 if (pr^.row[0] <= max^.row[0])and(pr^.row[1] <= max^.row[1]) and(pr^.row[2] <= max^.row[2])
 and(pr^.row[3] <= max^.row[3]) and(pr^.row[4] <= max^.row[4])  then
if (pr^.row[0] >= min^.row[0])and(pr^.row[1] >= min^.row[1]) and(pr^.row[2]>= min^.row[2])
 and(pr^.row[3] >= min^.row[3]) and(pr^.row[4] >= min^.row[4])  then
begin
  inc(Result);
  p^[Result]:=pr;
end;
inc(i);
inc(pr);
if i>Count then break;
end;
pi^:=Result;
end;
function IS_(b:Integer):integer;
var
 t:Integer;
begin Result:=-1;
if b <3 then exit;
 t:=round(sqrt(b))+1;
 //t:=(b div 2)+1;
for t:=t downto 2 do
 if (b mod t) =0 then exit;
Result:=b;
end;
procedure Init(a:integer);
var
 a1,i,a2,a3,a4,a5:Integer;
 f:TextFile;
begin
 FillChar(matr,sizeof(matr),-1);
 i:=-1;
AssignFile(f,'c:\matr.txt');
Rewrite(f);
Append(f);
Writeln(f,a);
for a1:=1 to 9 do  {for(i=10000;i<=99999; i++)}
begin
MSearch[a1]:=@matr[i+1];
  for a2:=0 to 9 do
   for a3:=0 to 9 do
    for a4:=0 to 9 do
     for a5:=0 to 9 do
      if (a1+a2+a3+a4+a5)= A then
       if IS_(a1*10000+a2*1000+a3*100+a4*10+a5)  <> -1 then
         begin
          inc(i);
          matr[i].s:=a1*10000+a2*1000+a3*100+a4*10+a5;
          matr[i].row[0]:=a1;
          matr[i].row[1]:=a2;
          matr[i].row[2]:=a3;
          matr[i].row[3]:=a4;
          matr[i].row[4]:=a5;
       //   writeln(f,a1,a2,a3,a4,a5);
         //   writeln(a1,a2,a3,a4,a5);
         end;
end;         
CloseFile(f);
S:=A;
Count:=i;
end;
 
 
function AddRow(oldrow,newrow:PRow):BOOL; //слажывает две строки
var i:Integer;
begin
Result:=false;
for i:=0 to N-1 do
begin
 newrow^.row[i]:=NewRow^.row[i]+oldrow^.row[i];
if newrow^.row[i]>S then Result:=true;
end;
end;
procedure ZeroRow(row:PRow);
var i:Integer;
begin
 for i:=0 to n-1 do
  row^.row[i]:=0;
end;
//определяет макс. и мин. строку которую можна добавить в матрицу
function CalcMaxMinRow(cur,max,min:PRow;id:Integer):BOOL;
var i:Integer;
begin
Result:=true;
max^.row[0]:=S-cur^.row[0]-(N-id)+1;
min^.row[0]:=(S-Cur^.row[0])-9*(N-id-1);
if min^.row[0]<0 then min^.row[0]:=1;
if max^.row[0]<=0 then max^.row[0]:=1;
for i:=1 to N-1 do
 begin
  max^.row[i]:=S-cur^.row[i];
  min^.row[i]:=(S-Cur^.row[i])-9*(N-id-1);
  if min^.row[i]<0  then min^.row[i]:=0;
  if max^.row[i]<0 then exit;
 end;
for i:=0 to n-1 do
begin
if min^.row[i]>9 then
 min^.row[i]:=9;
if max^.row[i]>9 then
 max^.row[i]:=9;
end;  
Result:=false;
end;
function Chek(cur,min,max:PRow):BOOL;
var i:Integer;
begin
Result:=false;
for i:=0 to N-1 do
if (cur^.row[i]<min^.row[i])or(cur^.row[i]>max^.row[i]) then
 Exit;
Result:=true;
end;
procedure PRint;
{var
 i:Integer;
 f: TextFile;   }
var
 i{,j}:integer;{
 s1,s2,s3:integer;}
begin
{s2:=0;s3:=0;
for i:=0 to 4 do
begin
s1:=0;
 for j:=0 to 4 do
   s1:=s1+TestMatr.List[j]^.row[i];
if s1<>S then
 asm
 int 3;
 end;
s2:=s2+TestMatr.List[i]^.row[i];
s3:=s3+TestMatr.List[4-i]^.row[4-i];
end;
if (s2<>S)or(s3<>S) then
 asm
 int 3;
 end;}
inc(CountMatr);
{
AssignFile(f,'c:\matr.txt');
Append(f);         }
 for i:=0 to N-1 do
 {begin
  Writeln(f,conv(TestMatr.list[i])); }
  Writeln(conv(TestMatr.list[i]));    {
 end;
writeln(f,'--------');
CloseFile(f);         }
writeln('--------');
end;
function AddRowList(row:PRow;id:Integer):BOOL;//добавляет строку к вероятной матрице
var
 i:Integer;
begin
Result:=false;
TestMatr.List[id]:=nil;
TestMatr.Ld:=0;
TestMatr.Rd:=0;
for i:=0 to id-1 do //проверка сум диагоналей
begin
 inc(TestMatr.Ld,Testmatr.list[i]^.row[i]);
 inc(TestMatr.rd,Testmatr.list[i]^.row[N-i-1]);
end;
 inc(TestMatr.Ld,row^.row[id]);
 inc(TestMatr.rd,row^.row[N-id-1]);
if id <>(N-1) then
begin
if ((TestMatr.Ld)>=S) or
 ((TestMatr.Rd)>=S)  then
exit;
end else
begin
TestMatr.List[id]:=row;
if  ((TestMatr.Ld)=S) and
 ((TestMatr.Rd)=S) then
 PRint;
 exit;
end;
TestMatr.List[id]:=row;
Result:=true;
end;
 
procedure Fast(id:integer;cur:PRow);
var
 pr:^TStroka;
 i,k,j:Integer;
 mi,mx:TRow;
begin
pr:=@MaskMatr[id].pr;
CalcMaxMinRow(cur,@mx,@mi,id);
k:=CreateMaskPoint(id,@mi,@mx);
if k=-1 then  exit;
for i:=0 to k do
if Chek(pr^[i],@Mi,@Mx) then
 if AddRowList(pr^[i],id) then
  if AddRow(pr^[i],Cur)=false then
  begin
    Fast(id+1,cur);
   for j:=0 to N-1 do
    dec(cur^.row[j],pr^[i].row[j]);
  end;
end;
var
 i{,k}:Integer;
 cr:TRow;
 FirstMax:Integer;
begin
Init(13); // создает массив простых чисел  
FirstMax:=S-4;
ZeroRow(@cr);
for i:=Count downto 0 do
if  matr[i].row[0]>FirstMax then Continue
else begin
if AddRowList(@Matr[i],0) then
if AddRow(@matr[i],@cr) then Continue;
 Fast(1,@cr);
ZeroRow(@cr);
end;
writeln('finish: ',CountMatr);
readln;
end.