cword.pas

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

program CrossWord;
type
  ptr=^node;
  node=record  {字母树结点}
    n:array['A'..'Z'] of word;  {字母的个数}
    nx:array['A'..'Z'] of ptr;  {下一个字母}
  end;
var
  cw:ptr;  {clown单词树}
  m,n,a,c,len,alen:byte; 
  {a:across单词  c:clown单词  len:整个矩阵的总格数  alen:across单词总长度减去已排入矩阵的across单词总长度}
  aw:array[0..100] of string[20];  {across单词列表}
  mk:array[1..100] of boolean;  {mk[i]表示第i个across单词已用}
  w:array[0..100] of byte;  {第i步搜索用第w[i]个across单词}
  p:array[0..100] of byte;  {第i步搜索的单词放在p[i]位置}
  b:array[1..100] of char;  {搜索中用到的字符矩阵}

procedure selword(l:byte); forward;

procedure init;  {初始化}
var
  f:text;
  i,j:byte;
  st:string;
  q,q1:ptr;
begin
  fillchar(aw,sizeof(aw),0);
  cw:=nil;
  assign(f,'cword.dat');reset(f);
  readln(f,m,n);len:=m*n;
  readln(f,a,c);alen:=0;
  for i:=1 to a do begin readln(f,aw[i]);inc(alen,length(aw[i])) end;
  for i:=1 to c do  {构造clown单词树}
    begin
      readln(f,st);
      q:=nil;q1:=cw;
      for j:=1 to length(st) do
        begin
          if q1=nil then
            begin
              if q1=cw
                then begin new(cw);q1:=cw end
                else begin new(q1);q^.nx[st[j-1]]:=q1 end;
              fillchar(q1^,sizeof(q1^),0);
            end;
          inc(q1^.n[st[j]]);
          q:=q1;q1:=q1^.nx[st[j]];
        end;
    end;
  close(f);
  fillchar(w,sizeof(w),0);
  fillchar(mk,sizeof(mk),0);
  fillchar(b,sizeof(b),0);
  fillchar(p,sizeof(p),0);
  p[0]:=1;
end;

procedure print;  {输出结果}
var
  i:byte;
  ch:char;
  f:text;
begin
  assign(f,'cword.out');rewrite(f);
  for i:=1 to len do
    begin
      if (i>1) and (i mod n=1) then writeln(f);
      if b[i]=#0 then write(f,'* ') else write(f,b[i],' ');
    end;
  close(f);
end;

function match_prv(l,i:byte):boolean;  {检查一行前的不可增加clown单词的合法性}
var
  lal:array['A'..'Z'] of byte;
  c:char;
  j:byte;
  k:integer;
  q:ptr;
begin
  fillchar(lal,sizeof(lal),0);
  for j:=i-n to i-1 do if b[j]<>#0 then inc(lal[b[j]]);
  for j:=i-n to i-1 do if b[j]=#0 then
    begin
      k:=j-n;
      while (k>0) and (b[k]<>#0) do dec(k,n);
      inc(k,n);
      if k<>j then
        begin
          q:=cw;
          while k<j-n do
            begin
              q:=q^.nx[b[k]];
              inc(k,n);
            end;
          if q^.nx[b[k]]<>nil then
            begin
              for c:='A' to 'Z' do
                if q^.n[b[k]]+lal[b[k]]<q^.nx[b[k]]^.n[c] then
                  begin match_prv:=false;exit end;
            end;
        end;
    end;
  match_prv:=true;
end;

procedure put(l,i:byte);  {放入单词}
var j:byte;
begin
  for j:=i to i+length(aw[w[l]])-1 do b[j]:=aw[w[l],j-i+1];
end;

procedure erase(l,i:byte);  {擦除单词}
var j:byte;
begin
  for j:=i to i+length(aw[w[l]])-1 do b[j]:=#0;
end;

function match(l,i:byte):boolean;  {检查合法性}
var
  j:byte;
  k:integer;
  q:ptr;
begin
  if (i mod n<>1) and (i=p[l-1]+length(aw[w[l-1]])) then {不能紧接前一单词，刚好换行则例外}
    begin match:=false;exit end;
  if (i-1) div n<>(i+length(aw[w[l]])-2) div n then  {across单词不在同一行}
    begin match:=false;exit end;
  if len-i+1<alen then begin match:=false;exit end;  {剩余格数不够放剩余单词}
  if i+length(aw[w[l]])-1>len then begin match:=false;exit end;  {放不下}
  put(l,i);  {放入单词}
  for j:=i to i+length(aw[w[l]])-1 do
    begin
      k:=j;
      while (k>0) and (b[k]<>#0) do dec(k,n);
      inc(k,n);
      q:=cw;
      while k<j do
        begin
          if q^.nx[b[k]]=nil then
            begin
              erase(l,i);
              match:=false;exit
            end;
          q:=q^.nx[b[k]];
          inc(k,n);
        end;
      if q^.n[b[k]]=0 then
        begin
          erase(l,i);
          match:=false;exit
        end;
    end;
  match:=true;
end;

procedure dec_cw(l,i:byte);  {调整clown单词树的单词数}
var
  j:byte;
  k:integer;
  q:ptr;
begin
  for j:=i to i+length(aw[w[l]])-1 do
    begin
      k:=j;
      while (k>0) and (b[k]<>#0) do dec(k,n);
      inc(k,n);
      q:=cw;
      while k<j do
        begin
          q:=q^.nx[b[k]];
          inc(k,n);
        end;
      dec(q^.n[b[k]]);
    end;
end;

procedure inc_cw(l,i:byte);  {恢复clown单词树的单词数}
var
  j:byte;
  k:integer;
  q:ptr;
begin
  for j:=i to i+length(aw[w[l]])-1 do
    begin
      k:=j;
      while (k>0) and (b[k]<>#0) do dec(k,n);
      inc(k,n);
      q:=cw;
      while k<j do
        begin
          q:=q^.nx[b[k]];
          inc(k,n);
        end;
      inc(q^.n[b[k]]);
    end;
end;

procedure place(l:byte);  {选择位置}
var i,ma:byte;
begin
  if len>p[l-1]+length(aw[w[l-1]])+n then ma:=len else ma:=p[l-1]+length(aw[w[l-1]])+n;  {计算终止位置}
  for i:=p[l-1]+length(aw[w[l-1]]) to ma do {从上一个单词的结尾位置开始搜索n个位置}
    begin
      if (i>n+n) and (i mod n=1) and (not match_prv(l,i)) then break; {检查一行前的不可增长clown单词的合法性}
      if match(l,i) then  {检查合法性}
        begin
          p[l]:=i;
          dec_cw(l,i);  {调整clown单词树的单词数}
          dec(alen,length(aw[w[l]]));  {减少未用的across单词数}
          selword(l+1);  {进入下一步搜索}
          inc(alen,length(aw[w[l]]));  {恢复未用的across单词数}
          inc_cw(l,i);  {恢复clown单词树的单词数}
          erase(l,i);  {擦除当前across单词，恢复矩阵}
        end;
    end;
end;

procedure selword(l:byte);  {选择单词}
var i:byte;
begin
  if l=a+1 then begin print;halt end  {搜索得到答案，输出结果}
  else
    for i:=1 to a do if not mk[i] then
      begin
        w[l]:=i;
        mk[i]:=true;
        place(l);  {选择当前单词的位置}
        mk[i]:=false;
      end;
end;

begin  {主程序}
  init;  {初始化}
  selword(1);  {开始搜索}
end.