nta.pas

本光盘是《国际大学生程序设计竞赛例题解（一）》的配套光盘

type newstring=string[15];
var f1,f2:text;
    n,m:integer;
    dd:array[1..15,1..15] of newstring;
    base:newstring;
    a:array[1..15,1..15] of char;
    mea:array[1..15,1..2] of integer;
    switch,tot:integer;
procedure init;
begin
  assign(f1,'nta.dat');
  assign(f2,'nta.out');
  reset(f1);
  rewrite(f2);
  switch:=6;
  randomize;
end;
procedure finish;
begin
  close(f1);
  close(f2);
  halt(1);
end;
procedure search(x,y:byte);
var i:byte;
begin
  if (x=0) and (y=1) then
    begin
      if (ord(a[1,1])-96) in [n-m+1..n] then
        begin
          writeln(f2,'accept');
          finish;
        end;
      exit;
    end;
  for i:=1 to ord(dd[ord(a[x+1,y])-96,ord(a[x+1,y+1])-96][0]) do
    begin
      a[x,y]:=dd[ord(a[x+1,y])-96,ord(a[x+1,y+1])-96][i];
      search(x-y div x,y mod x+1);
      a[x,y]:=#0;
    end;
end;
procedure measure;
var i,j:integer;
    ch:char;
begin
  fillchar(mea,sizeof(mea),0);
  for i:=1 to n do
    for j:=1 to n do
      begin
        for ch:=chr(n-m+1+96) to chr(n+96) do
          begin
            if pos(ch,dd[i,j])<>0 then
              begin
                inc(mea[i,1]);
                inc(mea[j,2]);
              end;
          end;
      end;
end;
function getmax(x,y:integer):char;
var w:array[1..15] of integer;
    i,j:integer;
    x1,y1:integer;
    ss:newstring;
    ma,nu:integer;
begin
  fillchar(w,sizeof(w),0);
  x1:=ord(a[x+1,y])-96;
  y1:=ord(a[x+1,y+1])-96;
  ss:=dd[x1,y1];
  for i:=1 to length(ss) do
    begin
      w[i]:=mea[ord(ss[i])-96,1]*(x-y+1)+mea[ord(ss[i])-96,2]*y;
    end;
  ma:=-1;
  for i:=1 to length(ss) do
    if w[i]>ma then begin
                      nu:=1;
                      ma:=w[i];
                    end else
                    begin
                      if w[i]=ma then
                        inc(nu);
                    end;
  x1:=random(nu-1)+1;
  nu:=0;
  for i:=1 to length(ss) do
    begin
      if w[i]=ma then
        begin
          inc(nu);
          if nu=x1 then
             begin
               getmax:=ss[i];
               exit;
             end;
        end;
    end;
end;
procedure ran(l:integer);
var j:integer;
begin
  for j:=2 to l-1 do
    begin
      a[l,j]:=getmax(l,j);
    end;
end;
procedure search2(step:integer);
var i,j,k:byte;
begin
  if step=switch-1 then
    search(switch-1,1)
   else
     begin
       for i:=1 to length(dd[ord(a[step+1,1])-96,ord(a[step+1,2])-96]) do
         for j:=1 to length(dd[ord(a[step+1,step])-96,ord(a[step+1,step+1])-96]) do
           begin
             a[step,1]:=dd[ord(a[step+1,1])-96,ord(a[step+1,2])-96][i];
             a[step,step]:=dd[ord(a[step+1,step])-96,ord(a[step+1,step+1])-96][j];
             ran(step);
             search2(step-1);
             for k:=1 to step do
               a[step,k]:=#0;
           end;
     end;
end;
procedure work;
var i,j:integer;
    lb:byte absolute base;
begin
  readln(f1,n,m);
  tot:=0;
  for i:=1 to n do
    for j:=1 to n do
      begin
        readln(f1,dd[i,j]);
        tot:=tot+length(dd[i,j]);
      end;
  if tot>100 then switch:=3;
  readln(f1,base);
  base[0]:=pred(base[0]);
  measure;
  if lb<=switch then
    begin
      fillchar(a,sizeof(a),0);
      for i:=1 to lb do
        a[lb,i]:=base[i];
      search(lb-1,1);
    end else
    begin
      fillchar(a,sizeof(a),0);
      for i:=1 to lb do
        a[lb,i]:=base[i];
      search2(lb-1);
    end;
  writeln(f2,'reject');
end;
begin
  init;
  work;
  finish;
end.