Технический форум - Помогите, пожалуйста, написать программу с символьными данными

Технический форум (http://www.tehnari.ru/)

- Помощь студентам (http://www.tehnari.ru/f41/)

Вообще-то я не считаю этичным влезать в творчество коллеги и потому прошу меня извинить, но поскольку Евгений исчез, а оставлять задачу незавершенной не годится, выложу свой вариант решения. У меня без файлов и можно ставить пробелы (даже несколько подряд) в начале строки и между запятой и первой буквой следующего слова. А можно и не ставить. Отработает.

Код:

Var

 W:Array[1..20] of String[10];

 Rep:Array[1..20] of Integer;

 S,C:String[200];

 i,j,k,N,L:integer;



Begin

 Writeln('Enter the string');

 Readln(S);

 L:=Length(S);

 Writeln;

 j:=1;

 i:=0;

 Repeat

  W[j]:='';

  repeat

   Inc(i);

  until S[i]<>' ';

  if i<L then

   begin

    while (S[i]<>',') and (S[i]<>'.') do

     begin

      W[j]:=W[j]+S[i];

      Inc(i);

     end;

   end;

  if i<L then Inc(j);

 Until i>=L;

 N:=j;



 for i:=1 to N do Rep[i]:=1;



 for i:=1 to N-1 do

  for j:=i+1 to N do

   if W[i]=W[j] then

    begin

     Inc(Rep[i]);

     for k:=j+1 to N do W[k-1]:=W[k];

     Dec(N);

    end;



 for i:=1 to N-1 do

  for j:=1 to N-i do

   if W[j]>W[j+1] then

    begin

     C:=W[j+1];

     W[j+1]:=W[j];

     W[j]:=C;

    end;



 for i:=1 to N do

  writeln(W[i]+' (',Rep[i],')');



 Readln

End.

Поправил:
const n=20;
type Z= array[1..n] of string;
var f,f1: Text;
s,s1: string;
c: char;
j,i,t: byte;
A: Z;
begin
Readln(s);
Assign(f,'Text_in.txt'); Rewrite(f);
Writeln(f,s);
Reset(f);
s1:=''; t:=1;
While not Eof(f) do
Readln(f,s);
for i:=1 to Length(s) do begin
c:= s[i];
if (c<>',') and (c<>'.') then
s1:= s1+c
else begin
A[t]:= s1;
Inc(t);
s1:='';
if (t>n) then Break;
end;
end;
for i:=1 to n-1 do
for j:=1 to n-i do
if A[j]>A[j+1] then begin
s:= A[j];
A[j]:= A[j+1];
A[j+1]:= s
end;
Assign(f1,'Text_out.txt');
Rewrite(f1);
i:=1;t:=1; s1:='';
repeat
if A[i]=s1 then Inc(i)
else
if A[i]=A[i+1] then begin
Inc(t);
if i= n-1 then
Writeln(f1,A[i],'-',t);
Inc(i)
end else begin
Writeln(f1,A[i],'-',t);
t:=1;
Inc(i)
end;
until i=n;
if (i=n) and (A[i]<>A[i-1]) then
Writeln(f1,A[i],'-1');
Close(f);
Close(f1);
end.