задача на тексты(pascal)

[Bapr]

Определить, сколько раз встречается каждое слово в тексте. Вывести на экран самое короткое и самое длинное слово текста.

var
f:textfile;
str,word:string;
i,j,m,n:integer;
arrstr:array of string;
begin
assignfile(f,'test.txt');
reset(f);
n:=0;
while not eof(f) do
begin
readln(f,str);
m:=Length(str);
i:=0;
while i<=m do
begin
case str[i] of
'а'..'я','А'..'Я':
begin
word:=word+str[i];
inc(i);
end;
else
begin
if word<>'' then
begin
inc(n);
SetLength(arrstr,n);
word:=AnsiLowerCase(word);
arrstr[n-1]:=word;
word:='';
end;
inc(i);
end;
end;
end;
end;
for i:=0 to n-1 do
begin
if arrstr[i]='' then continue;
m:=1;
for j:=i+1 to n-1 do
begin
if arrstr[j]='' then continue;
if arrstr[i]=arrstr[j] then
begin
inc(m);
arrstr[j]:='';
end;
end;
writeln(arrstr[i]+' '+IntToStr(m));
arrstr[i]:='';
end;
end;
а как определить сколько раз встречается каждое слово в тексте вообще не понял

[пауэрлифтинг]

А это что за прога?

[Bapr]

часть нужной =)

[Bapr]

up!!!!!!!!!!!!!!!!!

[Bapr]

uses crt;
var  min, max, len, i : integer;
   c, w, s, str, max_str, min_str : string;
k,a,wc:byte;
BEGIN
clrscr;
readln(s);
max := 0;
min := length(s); { dlina stroki}
len := 0; {obnulyaem peremennuyu}
max_str := ''; { obnulyaem peremennuyu}
min_str := ''; { obnulyaem peremennuyu}
str := ''; {obnulyaem peremennuyu}
for i:=1 to length(s) do { ciklom prohodimsya po vsey stroke - ot 1-go simvola i do poslednego}
	if s[i]<>' ' then begin { esli simvol ne yavlyaetsya probelom, to:
		inc(len); { uvelichivaem dlinu slova na 1}
		str := str + s[i]; { prisvaevaem tekuschiy simvol stroke, po odnomu simvolu budet sobirat'sya slovo polnost'yu}
	end else begin
		if len>max then begin { esli dlina poslednego naydennogo slova bol'she predyduschego (maksimal'nogo) }
			max := len; {prisvaevaem dlinu etogo slova}
			max_str := str; {a eto samo slovo kotoroe sobirali po odnomu simvolу}
		end;
		if len<min then begin {esli dlina poslednego naydennogo slova men'she predyduschego (minimal'nogo) }
			min := len; {dlina slova}
			min_str := str; { samo slovo}
		end;
		len := 0; { obnulyaem dlya togo chtoby iskat' dlinu sleduyuschego slova}
		str := ''; {obnulyaem chtob zapisyvat' sleduyuschee naydennoe slovo}
	end;
writeln('max = ', max_str);
writeln('min = ', min_str);
readln;
begin
clrscr;
writeln('vvedite text'+c);
readln(c);
c:=c+' ';
k:=Pos(' ',c);
while (k>0) do
  begin
  w:=copy(c,1,k-1);
  s:=copy(c,k+1,255);
  a:=Pos(' '+w+' ',' '+c);
  wc:=1;
  while (i>0) do
    begin
    inc(wc);
    c:=copy(c,1,a-1)+copy(c,a+length(w)+1,255);
    a:=Pos(' '+w+' ',' '+c);
    end;
  writeln('word: ''',w:15,''' has been met ',wc,' times');
  k:=Pos(' ',c);
  end;
  readln;
  end;
END.

как то так

[Bapr]

чуток косяк гдет

[Serge_Bliznykov]

сразу видно. в разных местах нашли два исходника.
второй сделан качественно, я бы даже сказал - остроумно. И работает так, как от него требуется.
Первая же часть - не работоспособная.
Поэтому берём второе решение.
К нему прикручиваем проверку на длину слов.
и всё, готово:

uses crt;
var s, w: string;
  max_str, min_str: string;
  k, i, wc: byte;
begin
  clrscr;
  writeln('vvedite text' + s);
  {readln(s);}
  s := 'clock is lock or lock his door';

  {это для поиска слов с минимальной/максимальной длиной}
  max_str := ''; 
  min_str := s; 


  s := s + ' ';
  k := Pos(' ', s);
  while (k > 0) do
  begin
    w := copy(s, 1, k - 1);

  {проверка на слово с максимальной длиной}
    if length(w) >= length(max_str) then max_str := w;
  {проверка на слово с минимальной длиной}
    if length(w) <= length(min_str) then min_str := w;

    s := copy(s, k + 1, 255);
    i := Pos(' ' + w + ' ', ' ' + s);
    wc := 1;
    while (i > 0) do
    begin
      inc(wc);
      s := copy(s, 1, i - 1) + copy(s, i + length(w) + 1, 255);
      i := Pos(' ' + w + ' ', ' ' + s);
    end;
    writeln('word: ''', w: 15, ''' has been met ', wc, ' times');
    k := Pos(' ', s);
  end;
  WriteLn;
  WriteLn('Word with minimum length: ', min_str);
  WriteLn('Word with maximal length: ', max_str);
  readln;
end.

[Bapr]

сказали что надо не только пробелы но и остальные символы
c:set of char;
c:=[' ','.','!','?',',',';'];

[Bapr]

апапапапап

[Serge_Bliznykov]

перед строчками:
s := s + ' ';
k := Pos(' ', s);

вставьте код

c:=[' ','.','!','?',',',';']; 
for i:=1 to length(s)
  if s[i] in c then s[i]:=' ';

тем самым мы все символы разделители заменим на пробелы.
Дальше всё должно работать.