{*
 * @(#) s_words.pas - Special word-list sorting program (problem 2).
 * (c) 1995 Ivan Maidanski <ivmai@chat.ru> http://ivmai.chat.ru
 * Freeware program source. All rights reserved.
 **
 * Language: Turbo Pascal
 * Tested with: Turbo Pascal v6.0
 * Last modified: 1995-03-02 20:35:00 GMT+03:00
 *}

program Sort_WordList;

{$B-}
const Max= 6;
type TLen= 1..Max;
type TNumber= 1..MaxInt;
type TStr= String[Max];
type TStack= ^TRecStack;
     TRecStack= record
                  D: TStr;
                  P: TStack
                end;
type TList= ^TRecList;
     TRecList= record
                 N: TNumber;
                 D: TStr;
                 P: TList
               end;
type TData= array[TLen] of TList;
var Stack: TStack;
var Data: TData;
procedure InitStack(var P: TStack);
 begin
   New(P);
   P^.P:=Nil
 end;
procedure DoneStack(var P: TStack);
 var Aux: TStack;
 begin
   repeat
     Aux:=P;
     P:=P^.P;
     Dispose(Aux)
   until P=Nil
 end;
procedure ReverseStack(P: TStack);
 var Aux,L: TStack;
 begin
   L:=Nil;
   while P^.P<>Nil
     do begin
          Aux:=P^.P;
          P^.P:=Aux^.P;
          Aux^.P:=L;
          L:=Aux
        end;
   P^.P:=L
 end;
procedure PutToStack(P: TStack; D: TStr);
 var Aux: TStack;
 begin
   New(Aux);
   Aux^.D:=D;
   Aux^.P:=P^.P;
   P^.P:=Aux
 end;
function GetFromStack(P: TStack; var D: TStr): Boolean;
 var Aux: TStack;
 begin
   Aux:=P^.P;
   if Aux<>Nil
     then begin
            D:=Aux^.D;
            P^.P:=Aux^.P;
            Dispose(Aux);
            GetFromStack:=True
          end
     else GetFromStack:=False
 end;
procedure InitList(var P: TList);
 begin
   New(P);
   P^.P:=Nil
 end;
procedure DoneList(var P: TList);
 var Aux: TList;
 begin
   repeat
     Aux:=P;
     P:=P^.P;
     Dispose(Aux)
   until P=Nil
 end;
procedure PutToList(P: TList; N: TNumber; D: TStr);
 var Aux: TList;
 begin
   while (P^.P<>Nil) and (P^.P^.D<D)
     do P:=P^.P;
   if (P^.P=Nil) or (P^.P^.D>D)
     then begin
            New(Aux);
            Aux^.N:=N;
            Aux^.D:=D;
            Aux^.P:=P^.P;
            P^.P:=Aux
          end
 end;
function GetFromList(P: TList; var N: TNumber; var D: TStr): Boolean;
 var Aux: TList;
 begin
   Aux:=P^.P;
   if Aux<>Nil
     then begin
            N:=Aux^.N;
            D:=Aux^.D;
            P^.P:=Aux^.P;
            Dispose(Aux);
            GetFromList:=True
          end
     else GetFromList:=False
 end;
procedure InitData;
 var Len: TLen;
 begin
   for Len:=1 to Max
     do InitList(Data[Len])
 end;
procedure DoneData;
 var Len: TLen;
 begin
   for Len:=1 to Max
     do DoneList(Data[Len])
 end;
procedure TestCond(Cond: Boolean);
 begin
   if not Cond
     then begin
            WriteLn('Invalid Data!');
            Halt(1)
          end
 end;
procedure GetChar(var Ch: Char);
 begin
   repeat
     Read(Ch)
   until Ch>=' ';
   Ch:=UpCase(Ch);
   TestCond((Ch>='A') and (Ch<='Z') or (Ch=',') or (Ch='.'))
 end;
function GetWord: Boolean;
 var Ch: Char;
 var S: TStr;
 begin
   S:='';
   repeat
     GetChar(Ch);
     if (Ch<>',') and (Ch<>'.')
       then S:=S+Ch
   until (Ch=',') or (Ch='.');
   TestCond((Length(S)>=1) and (Length(S)<=Max));
   PutToStack(Stack,S);
   GetWord:=Ch='.'
 end;
procedure ReadData;
 begin
   InitStack(Stack);
   WriteLn('Enter Source Data:');
   repeat
   until GetWord
 end;
procedure ViewData;
 var N: TNumber;
 var S: TStr;
 begin
   InitData;
   ReverseStack(Stack);
   WriteLn('View Source Data:');
   N:=1;
   while GetFromStack(Stack,S)
     do begin
          PutToList(Data[Length(S)],N,S);
          WriteLn(S);
          Inc(N)
        end;
   DoneStack(Stack)
 end;
procedure PrintOneList(P: TList);
 var N: TNumber;
 var S: TStr;
 begin
   while GetFromList(P,N,S)
     do WriteLn(N: 6,': ',S: Max)
 end;
procedure PrintResult;
 var Len: TLen;
 begin
   WriteLn('Result:');
   for Len:=1 to Max
     do PrintOneList(Data[Len]);
   DoneData;
   WriteLn
 end;
begin
  ReadData;
  ViewData;
  PrintResult
end.