Описание
Всем известны правила игры «в города»: первый игрок называет произвольный город, следующий – город, название которого начинается на ту же букву, на которую заканчивается название предыдущего города, и т.д. Аналогичным образом можно играть не в названия городов, а, например, в названия животных. Задан список допустимых для описанной игры слов, слова в нем могут повторяться
Задание
Напишите программу, определяющую, в каком порядке в процессе игры должны быть названы слова из списка, чтобы каждое слово было использовано ровно столько раз, сколько оно в нем встречается
Входные данные
В первой строке входного файла записано целое число N – количество слов в списке (1≤N≤1000), а в последующих N строках – сами слова. Каждое из них является последовательностью не более чем из 10 строчных английских букв
Выходные данные
Выведите в выходной файл слова в искомом порядке, либо сообщение "NO", если такого порядка не существует. Каждое слово должно быть выведено в отдельную строку выходного файла
Например:
PUN.IN
4
b
ab
bc
bb
PUN.OUT
ab
bb
b
bc
Идеи
Эйлеров путь
Комментарии
Составим ориентированный мультиграф (мультиграфом называется граф, в котором пары вершин могут быть соединены более чем одним ребром), вершинами которого будут являться буквы от a до z. Каждому слову из списка сопоставим ребро, соединяющее первую и последнюю буквы этого слова. В полученном мультиграфе требуется найти эйлеров путь (т.е. путь, проходящий по каждому ребру ровно один раз). Алгоритм построения такого пути можно найти, например, в [Липский 88, п.2.7].
Решение
{$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+}
{$M 65520,0,655360}
program pun;
const
InFile='pun.in';
OutFile='pun.out';
MaxN=1000;
type
TWord=String[10];
PWordList=^TWordList;
TWordList=Record
Item:TWord;
Next:PWordList;
end;
var
A:Array['a'..'z','a'..'z']Of LongInt;
NIn,NOut:Array['a'..'z']Of LongInt;
WLib:Array['a'..'z','a'..'z']Of PWordList;
Can:Boolean;
N:Word;
NInWay:LongInt;
Way:Array[1..MaxN+1]Of Char;
Procedure Load;
Var
I:Word;
W:TWord;
PL:PWordList;
Begin
Assign(Input,InFile);
ReSet(Input);
FillChar(A,SizeOf(A),0);
FillChar(NIn,SizeOf(NIn),0);
FillChar(NOut,SizeOf(NOut),0);
FillChar(WLib,SizeOf(WLib),0);
ReadLn(N);
For I:=1 To N Do Begin
ReadLn(W);
Inc(A[W[1],W[Length(W)]]);
New(PL);
PL^.Next:=WLib[W[1],W[Length(W)]];
PL^.Item:=W;
WLib[W[1],W[Length(W)]]:=PL;
Inc(NOut[W[1]]);
Inc(NIn[W[Length(W)]]);
End;
Close(Input);
End;
Procedure Solve;
Var
NStart,NFinish,NMiddle,NBad:LongInt;
I,J:LongInt;
AStart,AFinish:Char;
Ch:Char;
Procedure InsertChar(Before:LongInt; Ch:Char);
Var
I:LongInt;
Begin
For I:=NInWay DownTo Before Do Way[I+1]:=Way[I];
Way[Before]:=Ch;
Inc(NInWay);
End;
Function Euler:Boolean;
Var
Cur,Temp:Char;
Final:Boolean;
I:LongInt;
Ch:Char;
CWay:LongInt;
Begin
If AStart=' ' Then Begin
For Ch:='a' To 'z' Do If NOut[Ch]>0 Then AStart:=Ch;
End;
If AFinish=' ' Then AFinish:=AStart;
NInWay:=1;
Way[1]:=AStart;
Repeat
Final:=True;
For I:=1 To NInWay Do If NOut[Way[I]]>0 Then Begin
Final:=False;
Temp:=Way[I];
Cur:=Temp;
CWay:=I+1;
Repeat
For Ch:='a' to 'z' Do If A[Cur,Ch]>0 Then Begin
Dec(A[Cur,Ch]);
Dec(NOut[Cur]);
Dec(NIn[Ch]);
InsertChar(CWay,Ch);
Cur:=Ch;
Inc(CWay);
Break;
End;
Until NOut[Cur]=0;
End;
Until Final;
Euler:=NInWay=(N+1);
End;
Begin
NStart:=0;
NFinish:=0;
NMiddle:=0;
NBad:=0;
AStart:=' ';
AFinish:=' ';
For Ch:='a' To 'z' Do Case NOut[Ch]-NIn[Ch] Of
1:Begin Inc(NStart); AStart:=Ch; End;
0:Inc(NMiddle);
-1:Begin Inc(NFinish); AFinish:=Ch; End;
Else Inc(NBad);
End;
If (NBad>0) Or (NStart>1) Or (NFinish>1) Then Begin Can:=False; Exit; End;
NInWay:=0;
Can:=Euler;
End;
Procedure Save;
Var
I:LongInt;
Begin
Assign(Output,OutFile);
ReWrite(Output);
If Can Then Begin
For I:=1 To NInWay-1 Do Begin
WriteLn(WLib[Way[I],Way[I+1]]^.Item);
WLib[Way[I],Way[I+1]]:=WLib[Way[I],Way[I+1]]^.Next;
End;
End Else WriteLn('NO');
Release(HeapOrg);
Close(Output);
End;
Begin
Load;
Solve;
Save;
End.
|