Форум: "Основная";
Текущий архив: 2002.04.11;
Скачать: [xml.tar.bz2];

Вниз

Строки   Найти похожие ветки 

← →
Crime134   (2002-03-31 22:21) [0]

Люди, как сделать чтобы программа считала слова тексте?

---

← →
Dialogig   (2002-03-31 22:34) [1]

Испоьзуй delete pos и length, объясни что именно ты хечешь сделать я тебе помогу :)

---

← →
Anatoly Podgoretsky   (2002-03-31 23:01) [2]

Задайся вопросом, что такое слова, остальное дело техники

---

← →
lipskiy   (2002-04-01 00:02) [3]

Взял из свой программки.
Считает в Мемо число слов, слогов, символов и время в секундах, необходимое для произнесения текста вслух (из утилитки для рекламных агентств - просчитывать текст рекламных роликов).
Писалась с лету за пару часов, поэтому может быть неоптимальной.

procedure TForm1.Calculation;
var i,j,t:integer;
bs,word:string;
Letter:boolean;
MaxLetter:integer;
CurLetter:integer;
Slog:integer;
AllLet:integer;
ActMem:TMemo;
begin
case PageControl1.ActivePageIndex of
0: ActMem:= Memo1;
1: ActMem:= MemoClip;
end;
if ActMem = nil then exit;

CntWord:=0;
MaxLetter:=0;
CurLetter:=0;
Slog:=0;
AllLet:=0;
word:="";

for i:= 0 to ActMem.Lines.Count-1 do
begin
bs:= ActMem.Lines[i];
for j:=1 to length(bs) do
if bs[j] = " " then
begin
inc(AllLet);
if Letter then if
(word <> "-") and
(word <> ".") and
(word <> ",") and
(word <> "?") and
(word <> "!") and
(word <> ":") and
(word <> ";") and
(word <> "(") and
(word <> ")")
then inc(CntWord);
Letter:=false;
if CurLetter>MaxLetter then MaxLetter:=CurLetter;
CurLetter:=0;
word:="";
end
else
begin
inc(AllLet);
word:=word+bs[j];
Letter:=true;
inc(CurLetter);
if j=length(bs) then
if bs<>"" then
begin
inc(CntWord);
if CurLetter>MaxLetter then MaxLetter:=CurLetter;
end;

for t:= 0 to 31 do
if arGL[t] = bs[j] then
begin
inc(Slog);
break;
end;

end;
end;
Label10.Caption:= inttostr(Slog);
Label2.Caption:= inttostr(CntWord);
Label4.Caption:= inttostr(AllLet);
if CheckBox1.Checked then
Label6.Caption:=FloatToStrf(Slog/4,fffixed,4,1) else
Label6.Caption:=FloatToStrf(CntWord/2,fffixed,4,1);
Label8.Caption:= inttostr(MaxLetter);
end;

---

← →
lipskiy   (2002-04-01 00:04) [4]

Лешнее надо выдрать, ессно :)

---

← →
lipskiy   (2002-04-01 00:06) [5]

Да, забыл еще описание массивчика для подсчета слогов:
const
arGL:array [0..31] of char =
("у","е","ы","а","о","э","я","и","ю","ё","У","Е","Ы","А","О","Э","Я","И","Ю","Ё",
"e","y","u","i","o","a","E","Y","U","I","O","A");

---

← →
cutter   (2002-04-01 00:58) [6]

Может так? Если правильно понял вопрос?
count1:=0;
pos1:=pos(" ",s1);
While pos1<>0 do
begin
inc(count1);
delete(s1,1,pos1);
pos1:=pos(" ",s1)
end;
if count1<>0 then inc(count1);

---

← →
Sergey_n   (2002-04-01 02:31) [7]

Ну если Я првильно понял, то слова разделяются прбелами (вариант несолько пробелов между словами исключается), то считай кол-во пробелов, ну а слов получаеся кол-во пробелов + 1.

---

← →
MBo   (2002-04-01 07:46) [8]

сначала определись в том, что сказал Anatoly Podgoretsky
если слова разделяются пробелами, запятыми и точками, подойдет
такой вариант. Если есть другие разделители, обрати внимание
на выделенную строку.

procedure TForm1.Button1Click(Sender: TObject);
var sl,sl1:tstringlist;
i,cnt:integer;
begin
cnt:=0;
sl:=tstringlist.create;
sl1:=tstringlist.create;
sl.loadfromfile("e:\aa.txt");

sl.text:=StringReplace(sl.text, "." , "," ,[rfReplaceAll]);

for i:=0 to sl.Count-1 do begin
sl1.commatext:=sl[i];
cnt:=cnt+sl1.count;
end;
sl.free;
sl1.free;
label1.caption:=inttostr(cnt);
end;

---

← →
Song   (2002-04-01 08:35) [9]

2MBo
Ваш вариант можно немного упростить. Допустим разделитель - точка. И все слова в оригинале идут через точку:

...
Sl.text:=StringReplace(Sl.Text,"." ,#13#10 ,[rfReplaceAll]);
ShowMessage("У Вас "+InToStr(Sl.Count)+" слов.");
...


---

← →
MBo   (2002-04-01 08:39) [10]

>Song
>все слова в оригинале идут через точку

думаю, это слишком общее предположение

---

← →
Катерина   (2002-04-01 09:58) [11]

Я для себя написала подпрограмму перевода строки текста (s) в массив слов (ss) по указанносу разделителю (dilimiter). Побочный результат (Str_to_strs) - количество слов. Пока работает.

function Str_to_strs (s : string; dilimiter : char; var ss : Array of String) : integer;
var l,k,i,n1 : word;
begin
l := length(s);
k := 0;
i := 0;
repeat
repeat i := i+1 until not((i <= l) and (s[i] = dilimiter));
n1 := i; repeat i := i+1 until not((i <= l) and (s[i] <> dilimiter));
if (n1 < i) then
begin
ss[k] := copy(s,n1,i-n1);
k := k+1;
end;
until (i >= l) or (k > High(ss));

Str_to_strs := k;

end;

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.04.11;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.47 MB
Время: 0.006 c