Бывалый
Профиль
Группа: Участник
Сообщений: 215
Регистрация: 13.11.2006
Репутация: нет
Всего: 1
|
Я вот решил на курсовик прогу написать, которая из данного всписка слов составляет кроссворд. Алгоритм следующий: Есть поле,размером NxN, каждая ячейка имеет свойство - какая буква в ней стоит, и какой флаг она имеет: hor,ver,horver,nothing - соответственно обозначают, относится ли ячейка к гориз, вертик слову, пересечению слов, или там вообще пусто. Есть булевые функции CheckHor и ChekVer - означают, можно ли поставить слово. Сначала я тупо перебирал все возможные варианты, но это было слишком долгим алгоритмом, например для кросворда 11x11 из 7 слов пришлось бы перебрать (11*11)^7 вариантов, а это, согласитесь, офигет как много. Поэтому я решил изменить алгоритм: Ставим первое слово, затем проверяем, есть ли одинаковые буквы у этого первого и следующего слова, если нет - сопоставляем следующее слово, если да - добавляем это слово в список уже использованных слов и ищем одинаковые буквы с другими слова, и так, рекурсивно, доходим до того момента, когда неиспользоуванных слов не осталось - выводим на экран эту комбинацию. Поиск одинаковых букв я реализовал вот как: Я сделал массив от 1 до 255 типа список, и в зависимости от того, какой ord у буквы, заполнял элемент списка информацией о том, какая координата буквы. То есть все буквы "ч" у меня хранились в array[ord('ч')]. Согласитесь, это более скоростной алгоритм, нежели перебирать по ячейке всё поле и искать нужеую букву. Теперь проблема: во-первых выводит кроссворд когда не все слова пересекаются, во-вторых, возможно следствие первой, выводит одинаковые варианты кроссвордов. Третий день уже бьюсь((. Помогите. Головной модуль проги: | Код |
{$M 65384, 0, 655360}
uses crt,SpiMod,dos; {<-- модуль dos для regs}
const N = 10; {<-- поле кроссворда NxN}
type
(* CellCaption_Flags = (NoNothing, HorVer, Hor, Ver, NoThing, AnyThing);
{<-- флаги "клеточек" поля, обозначают что нельзя ставить}
MyChar = record
Value:Char;
Flag :CellCaption_Flags;
end;*)
CharField = array[1..N,1..N] of MyChar; {<--поле майчаров, начинается с левого верхнего угла}
action = (start,stop,PrintRoundAndAllTimeNow);
var
f:text;
i,i1,j:word;
Pole,GlobalTemp:CharField;
S:slova; {<-массив слов}
MS:SpiPtr; {<-список слов}
percent:real;{<-проценты}
C:Cells;
UsedS:slova;
AmountWord:byte; {количество слов}
procedure PrintDumpPole(P:CharField);
var i,j:byte;
begin
gotoxy(1,1);
for j:=1 to N do
begin
for i:=1 to N do
write(P[i,j].Value);
writeln('¦');
end;
for i:=1 to N do write('=');
writeln('-');
end;
procedure PrintScreenCellsPole(C:Cells);
var i,j:byte; TempCell:CellPtr;
begin
for i:=1 to 255 do
begin
TempCell:=C[i];
while TempCell<>nil do
begin
Gotoxy(TempCell^.x+N+1,TempCell^.y);
write(chr(i));
TempCell:=TempCell^.Next;
end;
end;
end;
procedure PrintScreenPole(P:CharField);
var i,j:byte; key:char;
label snova;
begin
clrscr;
{ process(stop);
gotoxy(1,1); }
PrintDumpPole(p);
{ PrintScreenFlags(N+2,1,P);
counter;}
snova:
key:=readkey;
case Key of
'x': begin
halt(1);
end;
{ 'p': begin
printpole(P,DirWhereExe+'output.txt');
writeln('Uda4no sohraneno v ',DirWhereExe);
goto snova;
end;}
end;
{process(start);}
{time(start,50,7);}
end;
{поставить горизонтальное слово}
procedure SetHorWord(x,y:byte;var P:CharField;slovo:MyString);
var i:byte;
begin
for i:=1 to length(slovo) do begin
P[x+i-1,y].Value:=Slovo[i];
if P[x+i-1,y].Flag=Ver
then P[x+i-1,y].Flag:=HorVer
else P[x+i-1,y].Flag:=Hor
end;
if x>1 then P[x-1,y].Flag:=NoNothing;
if x+length(slovo)-1<N then P[x+length(slovo),y].Flag:=NoNothing;
end;
{поставить вертикальное слово}
procedure SetVerWord(x,y:byte;var P:CharField;slovo:MyString);
var i:byte;
begin
for i:=1 to length(slovo) do begin
P[x,y+i-1].Value:=Slovo[i];
if P[x,y+i-1].Flag=Hor
then P[x,y+i-1].Flag:=HorVer
else P[x,y+i-1].Flag:=Ver
end;
if y>1 then P[x,y-1].Flag:=NoNothing;
if y+length(slovo)-1<N then P[x,y+length(slovo)].Flag:=NoNothing;
end;
procedure SetHorInCells(x,y:byte;P:CharField;var C:Cells;slovo:MyString);
var i:byte; TempCell:CellPtr;
begin
for i:=1 to Length(slovo) do
if C[ord(Slovo[i])]<>nil then
begin
TempCell:=C[ord(Slovo[i])];
while TempCell^.Next<>nil do TempCell:=TempCell^.Next;
new(TempCell^.Next);
TempCell^.Next^.x:=x+i-1;
TempCell^.Next^.y:=y;
TempCell^.Next^.Flag:=P[TempCell^.x,TempCell^.y].Flag;
TempCell^.Next^.Next:=nil;
end
else
begin
new(C[ord(Slovo[i])]);
C[ord(Slovo[i])]^.x:=x+i-1;
C[ord(Slovo[i])]^.y:=y;
C[ord(Slovo[i])]^.Flag:=P[C[ord(Slovo[i])]^.Next^.x,C[ord(Slovo[i])]^.Next^.y].Flag;
C[ord(Slovo[i])]^.Next:=nil;
end
end;
procedure SetVerInCells(x,y:byte;P:CharField;var C:Cells;slovo:MyString);
var i:byte; TempCell:CellPtr;
begin
for i:=1 to Length(slovo) do
if C[ord(Slovo[i])]<>nil then
begin
TempCell:=C[ord(Slovo[i])];
while TempCell^.Next<>nil do TempCell:=TempCell^.Next;
new(TempCell^.Next);
TempCell^.Next^.x:=x;
TempCell^.Next^.y:=y+i-1;
TempCell^.Next^.Flag:=P[TempCell^.Next^.x,TempCell^.Next^.y].Flag;
TempCell^.Next^.Next:=nil;
end
else
begin
new(C[ord(Slovo[i])]);
C[ord(Slovo[i])]^.x:=x;
C[ord(Slovo[i])]^.y:=y+i-1;
C[ord(Slovo[i])]^.Flag:=P[C[ord(Slovo[i])]^.x,C[ord(Slovo[i])]^.y].Flag;
C[ord(Slovo[i])]^.Next:=nil;
end;
end;
procedure DelHorInCells(x,y:byte;P:CharField;var C:Cells;slovo:MyString);
var i,k:byte; TempCell,TempCell2:CellPtr;
begin
for i:=1 to Length(slovo) do
begin
k:=ord(Slovo[i]);
if C[k]<>nil then
if(C[k]^.x=x+i-1) and (C[k]^.y=y)
then
begin
TempCell:=C[k]^.Next;
Dispose(C[k]);
C[k]:=TempCell;
end
else
begin
TempCell:=C[k];
while (TempCell^.Next<>nil) do
begin
if(TempCell^.Next^.x=x+i-1) and (TempCell^.Next^.y=y) then
begin
TempCell2:=TempCell^.Next^.Next;
Dispose(TempCell^.Next);
TempCell^.Next:=TempCell2;
break;
end;
TempCell:=TempCell^.Next;
end;
end;
end;
end;
procedure DelVerInCells(x,y:byte;P:CharField;var C:Cells;slovo:MyString);
var i,k:byte; TempCell,TempCell2:CellPtr;
begin
for i:=1 to Length(slovo) do
begin
k:=ord(Slovo[i]);
if C[k]<>nil then
if(C[k]^.x=x) and (C[k]^.y=y+i-1)
then
begin
TempCell:=C[k]^.Next;
Dispose(C[k]);
C[k]:=TempCell;
end
else
begin
TempCell:=C[k];
while (TempCell^.Next<>nil) do
begin
if(TempCell^.Next^.x=x) and (TempCell^.Next^.y=y+i-1) then
begin
TempCell2:=TempCell^.Next^.Next;
Dispose(TempCell^.Next);
TempCell^.Next:=TempCell2;
break;
end;
TempCell:=TempCell^.Next;
end;
end;
end;
end;
procedure tree(i,j:byte;var P:CharField);
begin
if P[i,j].Flag=AnyThing then exit;
P[i,j].flag:=AnyThing;
if (i<N) and (P[i+1,j].Value<>' ') {вправо}
then tree(i+1,j,P);
if (i>1) and (P[i-1,j].Value<>' ') {влево}
then tree(i-1,j,P);
if (j<N) and (P[i,j+1].Value<>' ') {вперёд}
then tree(i,j+1,P);
if (j>1) and (P[i,j-1].Value<>' ') {назад}
then tree(i,j-1,P);
end;
{сравнивает две матрицы}
function IsOdinak(P1,P2:CharField):boolean;
begin
IsOdinak:=True;
for j:=1 to N do
for i:=1 to N do
if P1[j,i].Value<>P2[j,i].Value
then begin IsOdinak:=false; exit; end;
end;
{определяет, пересекаются ли все слова в кроссворде}
function Crossing(P:CharField):boolean;
var
i,j:byte;
Temp:CharField;
label viyti;
begin
crossing:=true;
Temp:=P;
{находим первую букву...}
for j:=1 to N do
for i:=1 to N do
if P[i,j].Value<>' ' then
begin
{Как вода растекается от первой заполненой клетки и ставит флаг AnyThing}
tree(i,j,Temp);
goto viyti; {...и выходим}
end;
viyti:
for j:=1 to N do
for i:=1 to N do
{если до какой-нибудь клетки с буквой вода не смогла дойти...}
if (P[j,i].Value<>' ') and (Temp[j,i].flag<>AnyThing)
{... то это значит что все слова в кроссворде не пересекаются между собой}
then begin crossing:=false; exit; end;
end;
{procedure CheckLetter(x,y:byte;C:Cell;k:boolean);}
{проверяет, можно ли в (x,y) поставить горизонтальное слово}
function CheckHor(x,y:Shortint;P:CharField;slovo:MyString):boolean;
var i:byte;
begin
CheckHor:=True;
If (x<1) or (x+length(slovo)-1>N) or (y<1) or (y>N)
then begin CheckHor:=false; exit end;
for i:=1 to length(slovo) do
if (P[x+i-1,y].flag=NoNothing)
or (P[x+i-1,y].flag=Hor)
or (P[x+i-1,y].Value<>' ') and (P[x+i-1,y].Value<>slovo[i])
then begin CheckHor:=false; exit end;
if (y>1) then
for i:=1 to length(slovo) do
if (P[x+i-1,y-1].flag=Hor) then
begin CheckHor:=false; exit end;
if (y<N) then
for i:=1 to length(slovo) do
if (P[x+i-1,y+1].flag=Hor) then
begin CheckHor:=false; exit end;
if (x>1) and (P[x-1,y].Value<>' ') then
begin CheckHor:=false; exit end;
if (x+length(slovo)-1<N) and (P[x+length(slovo),y].Value<>' ') then
begin CheckHor:=false; exit end;
end;
{проверяет, можно ли в (x,y) поставить вертикальное слово}
function CheckVer(x,y:Shortint;P:CharField;slovo:MyString):boolean;
var i:byte;
begin
CheckVer:=True;
If (y<1) or (y+length(slovo)-1>N) or (x<1) or (x>N)
then begin CheckVer:=false; exit end;
for i:=1 to length(slovo) do
if (P[x,y+i-1].flag=NoNothing)
or (P[x,y+i-1].flag=Ver)
or (P[x,y+i-1].Value<>' ') and (P[x,y+i-1].Value<>slovo[i])
then begin CheckVer:=false; exit end;
if (x>1) then
for i:=1 to length(slovo) do
if (P[x-1,y+i-1].flag=Ver) then
begin CheckVer:=false; exit end;
if (x<N) then
for i:=1 to length(slovo) do
if (P[x+1,y+i-1].flag=Ver) then
begin CheckVer:=false; exit end;
if (y>1) and (P[x,y-1].Value<>' ') then
begin CheckVer:=false; exit end;
if (y+length(slovo)-1<N) and (P[x,y+length(slovo)].Value<>' ') then
begin CheckVer:=false; exit end;
end;
procedure AddWordInUsedS(slovo:MyString;var U:Slova);
var i:byte;
begin
for i:=1 to AmountWord do
If U[i]='' then begin U[i]:=slovo; break; end;
end;
function WordInUsedS(slovo:MyString;U:Slova):boolean;
var i:byte;
begin
WordInUsedS:=false;
for i:=1 to AmountWord do
if U[i]=slovo then begin WordInUsedS:=true; break; end;
end;
procedure OtherHunt(P:CharField;var C:Cells;S:slova;US:slova);
var
i,j,LengthWord,k:byte;
Temp:CharField;
TempCell,TempCell2:CellPtr;
vivod:boolean;
TempUsedS:Slova;
begin
vivod:=true;
{проверяем все слова...}
for k:=2 to AmountWord do
if not WordInUsedS(S[k],US) then
{...и если есть слово, которое мы ещё не использовали, то}
begin
Vivod:=false; {пока не выводим}
LengthWord:=length(S[k]);
TempUsedS:=US;
{добавляем к списку использованных слов это слово}
AddWordInUsedS(S[k],TempUsedS);
{перебираем все буквы слова}
for i:=1 to LengthWord do
begin
TempCell:=C[ ord(S[k][i]) ];
while TempCell<>nil do
begin
{если какая-нибудь буква есть в списке Cells, то ставим...}
If CheckHor(TempCell^.x-i+1,TempCell^.y,P,S[k]) then
begin
Temp:=p;
SetHorWord(TempCell^.x-i+1,TempCell^.y,Temp,S[k]);
SetHorInCells(TempCell^.x-i+1,TempCell^.y,Temp,C,S[k]); {}
{ PrintScreenPole(Temp);
PrintScreenCellsPole(C);
writeln(S[k]);
readkey;}
OtherHunt(Temp,C,S,TempUsedS);
DelHorInCells(TempCell^.x-i+1,TempCell^.y,Temp,C,S[k]);
end;
If CheckVer(TempCell^.x,TempCell^.y-i+1,P,S[k]) then
begin
Temp:=p;
SetVerWord(TempCell^.x,TempCell^.y-i+1,Temp,S[k]);
SetVerInCells(TempCell^.x,TempCell^.y-i+1,Temp,C,S[k]); {}
{ PrintScreenPole(Temp);
PrintScreenCellsPole(C);
readkey;}
OtherHunt(Temp,C,S,TempUsedS);
DelVerInCells(TempCell^.x,TempCell^.y-i+1,Temp,C,S[k]);
end;
TempCell:=TempCell^.Next;
end;
end;
end;
if Vivod {and crossing(P) and not IsOdinak(GlobalTemp,P)} then begin PrintScreenPole(P);
{GlobalTemp:=P;}
{PrintScreenCellsPole(C); } end;
end;
procedure FirstHunt(P:CharField;var C:Cells;S:slova);
var
i2,j2,border,i:byte;
Temp:CharField;
PercentCounter:word;
begin
border:=N-length(S[1])+1;
PercentCounter:=0;
AddWordInUsedS(S[1],UsedS);
for j2:=1 to N do
for i2:=1 to border do
begin
Temp:=p;
{ставим слово в поле}
SetHorWord(i2,j2,Temp,S[1]);
{ставим буквы слова в Cells}
SetHorInCells(i2,j2,Temp,C,S[1]); {}
{переходим к след. слову}
OtherHunt(Temp,C,S,UsedS);
{убираем из Cells для след. варианта}
DelHorInCells(i2,j2,Temp,C,S[1]);
end;
for j2:=1 to border do
for i2:=1 to N do
begin
Temp:=p;
SetVerWord(i2,j2,Temp,S[1]);
SetVerInCells(i2,j2,Temp,C,S[1]);
OtherHunt(Temp,C,S,UsedS);
DelVerInCells(i2,j2,Temp,C,S[1]);
end;
end;
var d:byte;
begin
clrscr;
assign(f,DirWhereExe+'input.txt');
reset(f);
repeat
inc(AmountWord);
readln(f,S[AmountWord]);
until eof(f);
close(f);
for d:=1 to AmountWord do writeln(S[d]);
{ S[1]:='коля';
S[2]:='оля';
S[3]:='таня';
AmountWord:=3;}
for j:=1 to N do for i:=1 to N do begin
Pole[i,j].value:=' ';
Pole[i,j].flag:=Nothing;
end;
{ SetHorWord(3,2,Pole,S[1]);}
NilCells(C);
FirstHunt(Pole,C,S);
{ SetHorInCells(1,3,Pole,C,'коля');
PrintScreenCellsPole(C);
readkey;
clrscr;
SetVerInCells(3,5,Pole,C,'юля');
PrintScreenCellsPole(C);
readkey;
clrscr;
DelHorInCells(1,3,Pole,C,'коля');
PrintScreenCellsPole(C);}
writeln('KONEZ!!');
readkey;
end.
|
Я сам то с трудом разбираюсь, но мож кто-нибудь мне подскажет, в чем ошибка... Заране спасибо.
Присоединённый файл ( Кол-во скачиваний: 14 )
proga.rar 12,00 Kb--------------------
подпись |
составление кроссвордов, не могу найти ошибку... 
Загрузка ...
