Заменя пробелов

← →
Adam (2003-01-27 18:13) [0]

Сдраствуйте мастера!

У меня следующяя проблема:

Имеется строка, в которой слова разделяются проделами. Количество пробелов между двумя словами неизвестно, оно может быть разным. Требуется это количество пробелов заменить всего одним пробелом.. Как это сделать? Помогите, пожалуйста..

← →
Victor_Cr (2003-01-27 18:17) [1]

пока существует хотя бы одна последовательность с двумя пробелами заменяй найденые два на один...

← →
Chubais (2003-01-27 19:17) [2]

> Сдраствуйте

гыыы

← →
Song (2003-01-27 21:07) [3]

S:=StringReplace(S,#32#32,#32,[rfReplaceAll]);
вот так попробуй, мне даже самому интересно, пройдёт или нет.

← →
MAN-In-RED (2003-01-27 21:14) [4]

> Song © (27.01.03 21:07)

Оно та пройдет, только если строго два пробела между словами, а автор ветки говорит, что количество пробелов между двумя словами неизвестно, вот так ;)

← →
Antosya (2003-01-27 21:39) [5]

Вот полностью работоющий код, !
var a,d:string[100]; b,c:integer; begin a:=Edit1.Text; //предположим, это твоя строка d:=" "; b:=pos(d,a); if b<>0 then begin repeat b:=pos(d,a); if b<>0 then delete(a,b,1); until b=0; Edit1.Text:=a;//а вот и строка где только по одному пробелу! end else Edit1.Text:=a;//это если везде по одному пробелу!

← →
MAN-In-RED (2003-01-27 21:44) [6]

Вот мой вариант:
procedure TForm1.Button1Click(Sender: TObject); var Str, S :String; I :Integer; Spc :Boolean; begin Str := "Q W ER T Y U "; for I:=1 to Length(Str) do if Str[i]=#32 then begin if not Spct then begin S := S+" "; Spc := True; end; end else begin S := S+Str[i]; Spc := False; end; ShowMessage(""""+S+""""); end;

← →
MAN-In-RED (2003-01-27 21:50) [7]

Мой быстрее :)

← →
Romkin (2003-01-27 22:36) [8]

Кину и я камень...
function OneSpace(const s: string): string; var newLength, i, k: integer; lastChar: char begin Result := ""; newLength := length(s); if newLength = 0 then exit; SetLength(Result, newLength); lastchar := #0; k := 0; for i := 1 to length(s) do if not ((LastChar = #32) and (s[i] = #32)) then begin inc(k); Result[k] := s[i]; LastChar := s[i]; end; SetLength(Result, k); end;
Без отладки, но, думаю, идея должна быть ясна %-)) - переписываем только одинарные пробелы. Здесь еще страховка насчет нулевой длины и только одного символа в строке... Что в голову пришло, но работать должно быстро

← →
Separator (2003-01-28 08:30) [9]

var i: integer; begin i:= Pos(#32#32, Edit1.Text); while i <> 0 do begin Delete(Edit1.Text, i, 1) i:= Pos(#32#32, Edit1.Text); end end
Правда работать будет долго

← →
Юрий Зотов (2003-01-28 10:04) [10]

function Song(S: string): string;
begin
Result := S;
while Pos(" ", Result) > 0 do // Без цикла не проходит.
Result := StringReplace(Result, " ", " ", [rfReplaceAll])
end;

function Antosya(S: string): string;
var
d: string[100];
b: integer;
begin
Result := S;
d := " ";
b := pos(d, Result);
if b <> 0 then
repeat
b := pos(d, Result);
if b <> 0 then delete(Result, b, 1);
until b = 0
end;

// function ManInRed(const s: string): string;
// Sorry, не дает правильного результата

function Romkin(const s: string): string;
var
NewLength, i, k: integer;
LastChar: char;
begin
Result := "";
NewLength := Length(s);
SetLength(Result, NewLength);
lastchar := #0;
k := 0;
for i := 1 to Length(s) do
if not ((LastChar = #32) and (s[i] = #32)) then
begin
Inc(k);
Result[k] := S[i];
LastChar := S[i]
end;
SetLength(Result, k)
end;

function Separator(S: string): string;
var
P: integer;
begin
Result := S;
P := Pos(" ", Result);
while P > 0 do
begin
Delete(Result, P, 1);
P := Pos(" ", Result)
end
end;

procedure TForm1.Button1Click(Sender: TObject);
const
Src = "Q W ER T Y U ";
var
Tick: DWORD;
i: integer;
S: string;
begin
Tick := GetTickCount;
for i := 1 to 10000 do
// S := Song(Src); // 1523, 1521, 1523
// S := Antosya(Src); // 423, 426, 424
// S := Romkin(Src); // 22, 25, 24
S := Separator(Src); // 215, 213, 214
Tick := GetTickCount - Tick;
Caption := Format("%s : %u", [S, Tick])
end;

← →
kkostik (2003-01-28 10:06) [11]

function StrDelSimv(PrStr : String; Simv : String) : String;
var i : Integer;
begin
i:=1;
While Length(PrStr)>=i Do
if PrStr[i]=Simv then
Delete(PrStr, i, 1)
else i:=i+1;
Result:=PrStr;
end;
Удаление любово символа из строки

← →
Separator (2003-01-28 10:56) [12]

Почти тоже, что и у MAN-In-RED © (27.01.03 21:44)
function StrDelSpace(S: string): string; var i: integer; Space: boolean; begin Space:= false; for i:= 1 to Length(S) do if (S[i] = #32) and (not Space) then begin Space:= true; Result:= Result + #32 end else if (S[i] <> #32) then begin Space:= false; Result:= Result + S[i] end end;

← →
REA (2003-01-28 11:27) [13]

Ну нифига себе проблема! Вы еще GREP подключите.

← →
Бук (2003-01-28 13:25) [14]

Ну вы блин даете!
memo1.Text:=AnsiReplaceText(memo1.Text,#32#32,#32);
Сие действо можно повторить в цикле нужное количество раз. Быстро и сердито.

← →
Юрий Зотов (2003-01-28 15:18) [15]

> Бук (28.01.03 13:25)
> Сие действо можно повторить в цикле нужное количество раз.
> Быстро и сердито.

Результаты теста видели? Самый медленный из рассмотренных алгоритмов. Примерно в 70 раз уступает самому быстрому.

Это насчет "быстро". Что же касается "сердито"... а что это такое - "сердитый алгоритм"?

Который пишется в 2 строки? А всегда ли это хороший критерий?

← →
Мефодий (2003-01-28 15:57) [16]

А что если попроще:

function MySpaceEraser(s: string): string;
begin
while Pos(" ",s) > 0 do {в ковычках два пробела}
System.Delete(s,Pos(" ",s),1);
Result := s;
end;

← →
Sha (2003-01-28 16:24) [17]

Тоже хочется поучаствовать:
function Sha(const s: string): string; const DeleteFirstBlank= false; DeleteLastBlank= false; var p: PChar; i, j, len: integer; ch: char; begin; len:=Length(s); SetLength(Result,len); if len>0 then begin; ch:=#0; if DeleteFirstBlank then ch:=" "; p:=pointer(s); j:=pointer(Result)-p; for i:=0 to len-1 do begin; if ch<>(p+i)^ then ch:=(p+i)^ else if ch=" " then continue; (p+j)^:=ch; inc(j); end; SetLength(Result,j-(pointer(Result)-p)-ord((ch=" ") and DeleteLastBlank)); end; end;

← →
MAN-In-RED (2003-01-28 19:45) [18]

> Юрий Зотов © (28.01.03 10:04)

Я в шоке! Что значит не дает правильного результата, все дает, только брать надо уметь…:)
Я проверял, все прекрасно работает!

Вот моя функция:

function OneSpace(Str: String): String; var S :String; I :Integer; Spc :Boolean; begin for I:=1 to Length(Str) do if Str[i]=#32 then begin if not Spc then begin S := S+" "; Spc := True; end; end else begin S := S+Str[i]; Spc := False; end; Result := S; end;
Пример вызова:

ShowMessage(OneSpace("q wer t y u"));

Результат – q wer t y u

Все пробелы были заменены на один!
Что не так?

> Antosya © (27.01.03 21:39)

> Бук (28.01.03 13:25)

> Мефодий (28.01.03 15:57)

Код типа:
ShowMessage(StringReplace("q w e rty u i o ",#32#32,#32,[rfReplaceAll]));

Не даст нужного результата, разве что в цыкле...

Требую перепросмотра моей функции :)

← →
Юрий Зотов (2003-01-29 01:00) [19]

> MAN-In-RED © (28.01.03 19:45)

> Что не так?

Пустячок - первый Ваш вариант просто не компилируется. А после устранения ошибки может сработать верно, а может и нет. Смотря какой первый символ в строке и на какой случайный мусор попадет переменная Spc (кстати, эта же болячка и во втором варианте - у Вас warning"и отключены, или Вы их просто в голову не берете?).

Ну, ладно, я внял Вашему призыву, что брать тоже надо уметь, и код чуть-чуть подчистил (надеюсь, Вы поверите, что я тоже немного умею кодить и не старался специально его ухудшить?)

Вот результат:
- первый Ваш вариант: 225, 226, 229
- второй Ваш вариант: 278, 273, 281

Так что Ваша апелляция возымела успех. Поздравляю с почетным третьим местом.

← →
Юрий Зотов (2003-01-29 01:29) [20]

Ну уж, чтобы и все приславшие код поучаствовали в конкурсе (кроме kkostik, поскольку его функция несколько из другой оперы).

> Separator © (28.01.03 10:56)
Вы правильно сказали - почти то же, что и у MAN-In-RED. Тоже не дает правильного результата (не верите - вызовите в цикле и увидите, что компилятор не всегда делает предварительную чистку строковых переменных). После поправки кода итог такой - 227, 232, 228. Практически то же, что и в первом варианте MAN-In-RED.

> Мефодий (28.01.03 15:57)
Результат - 280, 281, 283. Практически то же, что и во втором варианте MAN-In-RED, но закодировано, как Вы и говорили, в две простые строчки.

> Sha © (28.01.03 16:24)
Результат - 16, 20, 16. Если я правильно понял суть кода, идея Romkin"а дополнена самостоятельной работой с адресами, не полагаясь на компилятор. Итог - налицо.

← →
Один из вариантов (2003-01-29 06:52) [21]

А как насчет вот такого варианта?
function delspace(s:string):string;
var s:string
begin
while pos(" ",s) > 0 do // Delete " "
delete(s,pos(" ",s),1);
result:=s;
end;

← →
Один из вариантов (2003-01-29 06:54) [22]

sorry после того как отправил заметил что уже такой вариант был

← →
Separator (2003-01-29 07:43) [23]

> Юрий Зотов © (29.01.03 01:29)

Укажите мне на ошибку, а то я её что-то не замечаю. Хоть десять раз по циклу запустить, все равно работает правильно. Все пробелы идущие последовательно и имеющие количество большее одного заменяются на один.

← →
Anatoly Podgoretsky (2003-01-29 08:08) [24]

Ну если не понял, что было тебе сказано, то вот упрощенным русским языком

Нет начальное инициализации возвращаемого значения. Надо в начале сделать Result := "";, Space то ты нинциализировал.

← →
Бук (2003-01-29 08:10) [25]

> Юрий Зотов © (28.01.03 15:18)
Если Вы внимательно читали тему, то вопрос был не о скорости выполнения алгоритма, а о том как. И я не ставил перед собой цель написать высокоскоростной алгоритм удаления пробелов. Что касается скорости - все вопросы к Борланду :))

> Что же касается "сердито"... а что это такое - "сердитый алгоритм"?

Не надо придераться к словам....
-----------------------------------
С уважением Бук

← →
Separator (2003-01-29 08:26) [26]

> Anatoly Podgoretsky © (29.01.03 08:08)

Сапасибо за разъяснение, теперь понял

← →
Digitman (2003-01-29 09:10) [27]

in-place-вариант удаления лишних пробелов:

function ReduceSpaces(Src: PChar): PChar; var i,j,c,f: Integer; k: Boolean; begin Result := Src; if Assigned(Result) then begin if Result[0] <> #0 then begin i:= 0; j:= 0; c:= 0; f:= 0; k:= False; while Result[i] <> #0 do begin if Result[i] <> " " then begin if not k then begin k:= True; c:= 0; Inc(f); end; if i > j then Result[j]:= Result[i]; Inc(j); end else begin if k then begin k:= False; if i > j then Result[j]:= Result[i]; Inc(j); end else begin if (f > 0) and (c = 0) then begin if i > j then Result[j]:= Result[i]; Inc(j); end; end; Inc(c); end; Inc(i); end; if c > 0 then Dec(j); Result[j]:= #0; end else Result := nil; end; end;

← →
Digitman (2003-01-29 09:12) [28]

Преимущества : нет перераспределения памяти
Недостатки : не будет работать с read-only-строкой

← →
Sectey (2003-01-29 09:27) [29]

Люди ну возмите библиотеку QStrings и не надо изобретать велосипед. Там есть функции пости на все случаи жизни. Если кого интеремует намыл.

Я тут произвел небольшой тест и вот что получилось.

Q_SpaceCompress - 688
sha - 797
Romkin - 1468
Separator - 13219
Antosya - 20250
OneSpace - 29845
Song - 389937
StrDelSpace - умер

процедура теста:
procedure TForm1.Button1Click(Sender: TObject); var s : string; t : DWORD; i : integer; begin t := GetTickCount; for i:= 0 to 1000000 do begin s := "ssd sd sd s s sds d s d sd sd s sd s "; Separator(s); end; ShowMessage(s + #13#10 + IntToStr(GetTickCount - t)); end;

← →
Юрий Зотов (2003-01-29 09:29) [30]

> Digitman © (29.01.03 09:10)
> in-place-вариант удаления лишних пробелов

И его результат - 14, 14, 13.
На сегодня это рекорд. Кто хочет посостязаться?

← →
Separator (2003-01-29 09:33) [31]

Кто следующий?

← →
Delirium^.Tremens (2003-01-29 09:36) [32]

Заменя пробелов
А за меня - Забоев.
:-)

← →
Sectey (2003-01-29 09:46) [33]

>Юрий Зотов

Q_SpaceCompress - лучше.

ReduceSpaces - 891

исходный код из QStrings v6.06

Q_SpaceCompress удаляет из строки начальные и конечные пробелы и управляющие символы (меньше пробела). Кроме того, все подряд ущие пробелы и управляющие символы в середине строки заменяются одним пробелом. Исходная строка при этом не изменяется. Эта функция работает медленнее, чем Q_SpaceCompressInPlace

function Q_SpaceCompress(const S: string): string;
asm
PUSH ESI
MOV ESI,EDX
TEST EAX,EAX
JE @@qt
MOV ECX,[EAX-4]
TEST ECX,ECX
JE @@qt
PUSH EBX
MOV EBX,EAX
XOR EDX,EDX
MOV EAX,ESI
CALL System.@LStrFromPCharLen
MOV ECX,[EBX-4]
MOV EDX,[ESI]
@@lp1: CMP BYTE PTR [EBX],$20
JA @@ex1
INC EBX
DEC ECX
JNE @@lp1
JMP @@wq
@@ex1: DEC ECX
@@lp2: CMP BYTE PTR [EBX+ECX],$20
JA @@lp3
DEC ECX
JMP @@lp2
@@lp3: MOV AL,BYTE PTR [EBX]
INC EBX
CMP AL,$20
JBE @@me
@@nx: MOV BYTE PTR [EDX],AL
INC EDX
DEC ECX
JNS @@lp3
@@wq: MOV EAX,[ESI]
MOV BYTE PTR [EDX],0
SUB EDX,EAX
MOV [EAX-4],EDX
POP EBX
POP ESI
RET
@@me: MOV BYTE PTR [EDX],$20
INC EDX
DEC ECX
JS @@wq
@@ml: MOV AL,BYTE PTR [EBX]
INC EBX
CMP AL,$20
JA @@nx
DEC ECX
JNS @@ml
JMP @@wq
@@qt: MOV EAX,ESI
CALL System.@LStrClr
POP ESI
end;

← →
Юрий Зотов (2003-01-29 09:57) [34]

Тест Q_SpaceCompress - 9, 10, 13.
Абсолютный рекорд?

← →
MBo (2003-01-29 10:13) [35]

>Абсолютный рекорд?
Ну так и должно быть - QStrings - хорошо отлаженная и оптимизированная библиотека, обогнать ее довольно сложно, обычно только на специальных, а не на общих задачах.
Кстати, один из ее авторов - Сергей Щербаков (Mover) - входит в число авторов этого сайта.

← →
Johnmen (2003-01-29 10:38) [36]

>Юрий Зотов ©

Q_SpaceCompress не может участвовать в соревновании, т.к. соревнуются коды, написанные на D.

Юрий, как учитывалось время на преобразование string<->pchar в варианте Digitman © ?

← →
REA (2003-01-29 10:58) [37]

Может борду открыть "Нет пробелам"? Или "Состязания по переходу с Delphi на Assembler". В принципе можно просто "Загадочки". Победителям давать малиновые штаны.

← →
Юрий Зотов (2003-01-29 14:08) [38]

> Johnmen © (29.01.03 10:38)
> как учитывалось время на преобразование string<->pchar в
> варианте Digitman?

Оно входило в общее время. Вызов был таким:
S := String(Digitman(PChar(Src)));

Хотя это, возможно, и не совсем корректно - к коду функции фактически добавляется еще несколько машинных команд (хотя, думаю, это мизер по сравнению с количеством команд в самой функции).

Как Вы понимаете, я и не ставил задачей сделать хороший тест. Это всего лишь оценка на скорую руку. Но даже такие и оценочные результаты дают неплохой материал для выводов, не так ли?

← →
Johnmen (2003-01-29 14:36) [39]

> Юрий Зотов © (29.01.03 14:08)
> Оно входило в общее время.

А нет ли здесь ошибки ? После первого же вызова Digitman() строка Scr уже не та, что раньше: все слова в Src разделены одним пробелом. Все последующие итерации цикла просто ничего не делают.

← →
Digitman (2003-01-29 14:51) [40]

> Johnmen

Чего то я тебя не понял)

> После первого же вызова .. строка Srс уже не та,
> что раньше: все слова в Src разделены одним пробелом.

Разумеется ! На то и in-place-алгоритм...
Убирает лишние (ведущие/терминирующие/межсловные) пробелы в указанном блоке памяти со строковыми данными, терминированными #0

> Все последующие итерации цикла просто ничего не делают.

Какие итерации-то ? Вызов уже сделан, Result указывает на тот же блок данных (либо nil, если Src-строка пуста)

← →
Johnmen (2003-01-29 15:57) [41]

>Digitman © (29.01.03 14:51)
>> Johnmen
>Чего то я тебя не понял)

Да, не понял ! Имелась в виду процедура тестирования от Юрий Зотов ©.

← →
Digitman (2003-01-29 16:02) [42]

а-а-а ... я не обратил внимания ...
а чего вхолостую однократно обработанную уже строку гонять в цикле ? если уж на то пошло, нужно было в цикле по десятку тысяч раз прогнать несколько строк с заранее оговоренным содержимым ...

← →
Johnmen (2003-01-29 16:09) [43]

>Digitman © (29.01.03 16:02)

И я про то же ! Тестирование твоего варианта не совсем корректно...

← →
mate (2003-01-29 16:24) [44]

Ну ВЫ тут и написали , а надо всего лишь

while pos(" "+" ",s)<>0 do
delete(s,pos(" "+" ",s),1);

и всё ;)
а что касается " "+" " - это что бы было видно что их два

← →
Digitman (2003-01-29 16:36) [45]

> mate

На тему лаконичности исх.текста, решающего задачу - давно уже проехали, сударь)

Здесь уже бой на тему "кто шустрей")

← →
mate (2003-01-29 16:44) [46]

ну для шустрости можно мой код в поток загнать и приоритет Haigest у потока.

← →
Digitman (2003-01-29 16:48) [47]

> mate

Чушь ты городишь, сударь.
Доп.код.поток никакой "шустрости" не добавляет алгоритму).. Хоть ты ему SuperHighest-приоритет дажк умудришься установить)

← →
mate (2003-01-29 16:52) [48]

этим самым ты хочешь сказать , что время выполнения задачи не зависит от выделяемого процессорного времени? Так?

← →
Андрей Сенченко (2003-01-29 17:00) [49]

Специально не вникал чужие варианты :-)) Возможно, это уже было - но я бы делал так :

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
i: integer;
begin
s := "q wer t y u";
for i := 0 to length(s) do
if s[i] = " " then
while s[i+1] = " " do delete(s,i+1,1);
ShowMessage(s);
end;

Скорее всего Digitman-a не обгоню :-)) , но интесно насколько медленнее.

← →
Андрей Сенченко (2003-01-29 17:02) [50]

Ведущие и терминирующие пробелы не рассматривал.

← →
Sectey (2003-01-29 17:04) [51]

>mate ©
Во первых твой вариант уже предлогоался.
Во вторых ТВОЯ ФУНКЦИЯ - 23002 > Q_SpaceCompress - 688
Получается в 30 раз медленее самого быстрого

← →
Digitman (2003-01-29 17:06) [52]

> mate

> этим самым ты хочешь сказать , что время выполнения задачи
> не зависит от выделяемого процессорного времени? Так?

зависит ! оч даже зависит) .. и организуя доп.код.поток ты даже меньше квантов получишь на выполнение своего кода, ежели если бы был только один осн.код.поток и в его контексте выполнялся тот же твой код.

А приоритет код.потока относителен и квантование времени, выделяемого код.потоку, расчитывается ядром относительно приоритета процесса в целом

← →
Sectey (2003-01-29 17:08) [53]

>Андрей Сенченко ©

Твой алгоритм на 4 месте он дал - 4265

← →
Digitman (2003-01-29 17:14) [54]

> Андрей Сенченко

И не обгонишь)

In-place-алгоритм при всех его видимых недостатках все же в любом случае эффективней будет из-за отсутствия необходимости итеративно перераспределять память с использованием далеко не оптимизированного для таких задач встр.менеджера памяти от Борланда

← →
Johnmen (2003-01-29 17:17) [55]

>Sectey © (29.01.03 17:08)

Огласите весь список, пжалуста....

← →
Юрий Зотов (2003-01-29 17:28) [56]

> Андрей Сенченко © (29.01.03 17:00)

Дык... у Вас же будет гарантированный выход за пределы строки. Причем даже в двух местах.

← →
Андрей Сенченко (2003-01-29 17:43) [57]

Юрий Зотов © (29.01.03 17:28)

В одном вижу - граница цикла должна быть length(s)-1.
А второе ?

← →
Johnmen (2003-01-29 17:46) [58]

Юрий, приведите, пожалуйста, последние результаты тестирования быстродействия предложенных алгоритмов...

← →
Mystic (2003-01-29 17:47) [59]

Еще один вариант замены строки по месту. ;)

К преимуществам следует отнести тот факт, что поддерживается несколько пробельных и конечных символов.

var TBL: array[Byte] of Integer; // Инициализация массива символов, 0 - символы, 1 - разделители, 2 - терминаторы procedure InitTBL; var I: Integer; begin for I := 0 to 255 do TBL[I] := 0; TBL[32] := 1; TBL[9] := 1; TBL[0] := 2; end; // Напрямую к соответсвующей функции из System.pas обратиться не удалось procedure _LStrSetLength(var St: string; Len: Integer); begin SetLength(St, Len); end; procedure Mystic(var St: string); asm PUSH ESI PUSH EDI PUSH EAX CALL UniqueString POP EDX MOV ESI, [EDX] MOV EDI, ESI XOR EAX, EAX INC EAX CLD DEC ESI //JMP @@Loop; @@SkipSpace: INC ESI @@Loop: MOV ECX, EAX MOVZX EAX, [ESI] MOV EAX, [OFFSET TBL].[4*EAX] TEST EAX, ECX JNZ @@SkipSpace MOVSB CMP EAX, 1 JLE @@Loop @@Exit: SUB EDI, ECX MOV EAX, EDX DEC EDI MOV EDX, [EAX] SUB EDI, EDX MOV EDX, EDI POP EDI POP ESI JMP _LStrSetLength end; initialization InitTBL;

← →
Digitman (2003-01-29 17:51) [60]

А тема-то, однако - животрепещущая !
Наверняка DB-developer"ы здесь упражняются в "остроумии")..

Угадал ?

← →
Андрей Сенченко (2003-01-29 17:54) [61]

вот измененный вариант

procedure TForm1.Button1Click(Sender: TObject); var s: string; i: integer; begin s := "q wer t y u"; i := 1; While s[i] > #0 do begin if s[i] = #32 then while s[i+1] = #32 do delete(s,i+1,1); inc(i); end; ShowMessage(s); end;

← →
danilka (2003-01-29 17:57) [62]

так у нас тут битва за скорость?
тогда может стоит уточнить правила: убивать только лишние пробелы или пробелы и непечатные символы, использовать функции или inplace процедуры, определиться с тестированием, у меня, например, вариант Юрия Зотова (28.01.03 10:04) не совсем катит - слишком все быстро, надо текст побольше и сам цикл побольше.

← →
uw (2003-01-29 17:58) [63]

Почему никто не использует goto?

← →
Sectey (2003-01-29 18:04) [64]

>Mystic ©
ругается на MOVZX EAX, [ESI]

← →
Sectey (2003-01-29 18:18) [65]

>Digitman

ну коль перешли на inplace тогда вот немного подумов я кое что нашкрябал.

procedure Sectey(p:PChar); var i : integer; j : integer; c : char; begin i := 0; j := 0; c := #0; while p[i] <> #0 do begin p[j] := p[i]; if (c <> #32) or (p[i] <> #32) then inc(j); c := p[i]; inc(i); end; p[j] := #0; end;

Процедура тестирования:

procedure TForm1.Button1Click(Sender: TObject); const s = "ssd sd sd s s sds d s d sd sd s sd s "; var p : PChar; t : DWORD; i : integer; begin t := GetTickCount; GetMem(p,StrLen(s)); for i:= 0 to 1000000 do begin StrCopy(p, s); ReduceSpaces(p); end; ShowMessage(StrPas(p) + #13#10 + IntToStr(GetTickCount - t)); FreeMem(p); end;

Не знаю как по поводу варианта Mystic на этот вариант быстрее даже Q_SpaceCompress по моим тестам - 578, а твой - 875, вот так.

← →
Mystic (2003-01-29 18:20) [66]

> Sectey © (29.01.03 18:04)

Странно, у меня все нормально.

Можешь заменить на
DB 00h, 46h, 58h, 71h

или на
XOR EAX, EAX MOV AL, [ESI]

← →
Sectey (2003-01-29 18:24) [67]

> Mystic

Да протестил - 1078

← →
Sectey (2003-01-29 18:39) [68]

На 29.01.09 18:26

Top - лист по скорости:
-----------------------

Sectey - 578;
Q_SpaceCompress - 688
sha - 797
Mystic - 1078
Romkin - 1468
Андрей Сенченко - 4265
Separator - 13219
Antosya - 20250
mate - 23002
OneSpace - 29845
Song - 389937
StrDelSpace - умер

Не в одном(кроме своего) алгоритме не разбирался брал как есть и тестировал.

Тестировал для себя. Если кто не согласен с моей оценкой прошу провести собственный тест.

← →
Novice (2003-01-29 18:45) [69]

Inplace - это нечестно.

2 Юрий Зотов ©
Нельзя ли привести текст программы тестирования с результатами?
Интересно, как вы совмещаете тестирование двух разных видов алгоритмов и оцениваете результаты их работы?

← →
Андрей Сенченко (2003-01-29 18:52) [70]

>> Sectey © (29.01.03 18:39)

Я там второй вариант предлагал - его глянь пожалуйста

← →
Novice (2003-01-29 18:54) [71]

2 Sectey © (29.01.03 18:18)
Инплэйс инплэйсом, а кто будет возвращать результат в виде строки в цикле тестирования? Хитроват, батенька :)

← →
MAN-In-RED (2003-01-29 20:04) [72]

Дурдом, хе-хе...

← →
Mystic (2003-01-29 21:24) [73]

Зачем совершенствовать алгоритм, когда можно придумать новый тест, который бы вывел мою процедуру на первое место?! ;)

Поскольку я оптимизил свой код главным образом на длинные входные последовательности (а не на многократный запуск коротких), то решил придумать свой тест - дать на вход каждой функции весь source-код Delphi. Вот результаты (пять испытаний, *10^3):

Mystic 183, 183, 228, 199, 181
Sectey 212, 195, 193, 191, 193
Q_Strings 211, 206, 206, 205, 231
Digitman 273, 290, 294, 319, 272
Sha 305, 296, 270, 286, 269
Romkin 452, 453, 487, 489, 449

Вариант от ManInRed тестировался лишь однократно 21 079
Остальные варианты поумирали (есть там файлик Internet\MSHTML.pas размером 1.5 Мб, вот его не сумели одолеть многие алгоритмы).

Код, использовавшийся для тестирования:

function ProcessFile(const FileName: string): Int64; var S: TStream; St: string; Tick1, Tick2: Int64; begin S := TFileStream.Create(FileName, fmOpenRead); try SetLength(St, S.Size); S.Read(St[1], S.Size); QueryPerformanceCounter(Tick1); //Mystic(St); //Senchenko(St); //Sectey(PChar(St)); //Q_SpaceCompress(St); //ReduceSpaces(PChar(St)); //Sha(St); //Romkin(St); QueryPerformanceCounter(Tick2); Result := Tick2 - Tick1; finally S.Free; end; end; function ProcessDir(const DirName: string): Int64; var sr: TSearchRec; begin Result := 0; if FindFirst(DirName + "\*.pas", faAnyFile and (not faDirectory), sr) = 0 then begin repeat Result := Result + ProcessFile(DirName + "\" + sr.Name); until FindNext(sr) <> 0; FindClose(sr); end; if FindFirst(DirName + "\*.*", faDirectory, sr) = 0 then begin repeat if (sr.Name <> ".") and (sr.Name <> "..") then Result := Result + ProcessDir(DirName + "\" + sr.Name); until FindNext(sr) <> 0; FindClose(sr); end; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(IntToStr(ProcessDir("C:\Program Files\Borland\Delphi6\Source"))); end;

← →
Sha (2003-01-29 23:26) [74]

2 Mystic © (29.01.03 21:24)
Проверь вот это:
function Sha2(const s: string): string; var p, q: pchar; ch: char; label ret; begin; p:=pointer(s); SetLength(Result,Length(s)); q:=pchar(pointer(Result))-1; while true do begin; repeat; ch:=p^; inc(p); until ch<>" "; repeat; if ch=#0 then goto ret; inc(q); q^:=ch; ch:=p^; inc(p); until ch=" "; inc(q); q^:=ch; end; ret: SetLength(Result,(q-pointer(Result))); end;

← →
gsu (2003-01-29 23:39) [75]

>> Дурдом, хе-хе...
угу

>> Top - лист по скорости:
>> Я там второй вариант предлагал - его глянь пожалуйста
>> Проверь вот это:
красавцы (-:|~

← →
MAN-In-RED (2003-01-29 23:43) [76]

Итак, ваш окончательный выбор?
Предлагаю сделать три первых места…

← →
gsu (2003-01-29 23:50) [77]

вот мастеров то набежало ...

← →
Secety (2003-01-30 02:45) [78]

>Mystic ©
Ну согласись сравнивать программы написанную на асме и на делфях скажем не совсе чесно, так чтобы уровнять их шансы вот второй вариант.

Тестю на другой машине, поэтому цифры могут немного не совпадать с предыдущимы.
Sectey (test) Mystic (test)
SecteyAsm 531 ~26000
Mystic 771 ~28500

И наконец сама программа:
procedure SecteyAsm(p : PChar); asm PUSH ESI PUSH EAX PUSH EBX MOV BL, 32 MOV ESI, EAX MOV EDX, EAX CLD XOR EAX, EAX @@LOOP: LODSB MOV [EDX], AL CMP AH, AL JNE @@THENCMP CMP AL, BL JE @@ENDCMP @@THENCMP: INC EDX @@ENDCMP: MOV AH, AL TEST AL, AL JNZ @@LOOP @@EXIT: POP EBX POP EAX POP ESI end;

← →
Sha (2003-01-30 07:00) [79]

Sha © (29.01.03 23:26)
2 Mystic © (29.01.03 21:24)

Sorry. Проверь только скорость, правильность работы можно не проверять :)
Видно, вчера перед сном голова глючила. И продолжает до сих пор - никак не соображу как переставить строчки.
Если кто-нибудь подскажет, поделюсь авторством :) Требования к кандидату:
1. количество inc(q); в цикле = 2,
2. только один оператор if ch=#0 then ...
Все, еду на работу. Там посмотрим.

← →
Sha (2003-01-30 07:15) [80]

> Secety (30.01.03 02:45)
> Ну согласись сравнивать программы написанную на асме и на делфях скажем не совсе чесно.

Важнее даже другое: все программы (или их обертка в цикле тестирования) должны брать const string и возвращать string - иначе вообще невозможно говорить ни о каком сравнении результатов.

А насчет asm - мне даже интересно на сколько процентов будет эффективнее. Думаю, что для моей Sha2 - не больше чем на 10. (Правда она пока еще работает неправильно, зато уже быстро :)
А это как раз и докажет, что не так важно, на чем писать.

← →
Anatoly Podgoretsky (2003-01-30 08:04) [81]

Что бы проводить тестирование, надо сначала договориться о методах и согласовать код тестирования, исходные данные, что бы уменьшить погрешности тестирования.
К тому же нельзя проводить тестирование, только на одной какой то выьранной строке, некоторые алгоритмы, которые покажут плохие результаты на коротких строках вполне могут сильно обогнать на длинный, или при одинаковой длине результаты могут зависить от содержимого. Нужно как минимум не менее трех последовательностей. Кроме того тестирование должно проводиться отдельно для функций и отдельно для замены по месту.

Немаловажное значение имеет выравнивание переменных
и будет давать разные результаты на разных процессорах.
Для теста надо что бы данные были выровнены на границу параграфа.
В группе borland.basm знаимались аналогичным тестированием, но только для Move и там потом пришлось потратить около недели на выработку достоверного теста, в основном для выравнивания на границу параграфа и частично других вещей.

Неправильно или специально подогнанный тест может отдавать предпочтение тому или другому методу.

← →
danilka (2003-01-30 08:10) [82]

ловите вариант на асме.
всера дома накатал.

function Danilka(const s:string):string;
begin
result:=s;
asm
push ebx
push ecx
mov ebx,result
mov edx,[ebx]
mov eax,edx
mov ecx,[edx-4]
push edx
@@loop:
mov bx,[edx]
cmp bx,$2020
je @@space
mov [eax],bl
inc eax
@@space:
inc edx
loop @@loop
sub eax,edx
pop edx
add eax,[edx-4]
dec eax
mov [edx-4],eax
pop ecx
pop ebx
end;
end;

← →
Digitman (2003-01-30 08:55) [83]

> Sectey © (29.01.03 18:18)

> ну коль перешли на inplace

Да никто никуда не переходил !)
Просто я предложил собственный, давно уже сверстанный и работающий в IB UDF вариант. Без in-place в том случае было трудно обойтись, ибо реаллокация памяти по соглашениям IB дает даже большие "тормоза", нежели с использованием менеджера памяти от Борланда. И он меня вполне устраивал все это время, даже в первозданном, неоптимизированном виде, поскольку без сколь-либо заметной задержки "причесывает" строку перед записью в базу. При этом включая и LTrim и RTrim.
Так что меряться в производительности алгоритма я и не думал - мне и этого достаточно. А при желании, конечно, оптимизировать его можно в 10 минут, доведя производительность до "вылизанного" с точностью до маш.инструкции asm-уровня и сохранив при этом исх.текст в синтаксисе Паскаля)

← →
Separator (2003-01-30 09:37) [84]

В общем народ, вопрос конечно очень интересный, но не пора ли закончить?

← →
Anatoly Podgoretsky (2003-01-30 09:40) [85]

danilka (30.01.03 08:10)
Если ты хочешь по быстрее, то надо убрать push ecx (мелочи) и заменить loop @@loop (это уже серьезный тормоз) простыми инструкциями.

← →
Novice (2003-01-30 10:11) [86]

> gsu © (29.01.03 23:39)
> красавцы (-:|~

По этой ветке сразу видно, что не перевелись у нас те, кто любит попрограммировать. Тех, у кого на это нет времени, просьба не беспокоиться.

> All

Привет участникам соревнований! © "Ну, погоди!"
Предлагаю по аналогии со значком © завести значек (R), который присваивается всем призерам соревнований. Соревнование считать состоявшимся, при условии, что в нем участвовал хотя бы один мастер. Цветовую гамму можно изменить.

← →
danilka (2003-01-30 10:19) [87]

Anatoly Podgoretsky © (30.01.03 09:40)
Учту. Только для такой битвы может и правда, сначала более точно поставить задачу, например убивать или нет пробелы в начале/конце строки, если да, то работать ли с многострочным текстом, работать со string или pchar и т.д. Разобраться с методикой тестирования, выложить алгоритм тестирования и в бой. :))

а еще, может более правильным было-бы чтобы другие участники не видели чужой код до окончания тестирования. например, чтобы все слали свои процедуры кому-нибудь на почту, скажем, до 12-00 пятницы, потом этот кто-то все-бы протестировал, и выложил в форум результат всемте с алгоритмами.

← →
Worker (2003-01-30 11:09) [88]

> Adam
Попробуй так, у меня все работает:

function TForm1.DeleteProbel(s: string): string;
var
str_new: string;
begin
Result := Trim(s);
While Pos(" ",Result) <> 0 do begin
str_new := str_new +" "+ copy(Result,0,Pos(" ",Result)-1);
Delete(Result,1,Pos(" ",Result)-1);
Result := Trim(Result);
end;
Result := str_new +" " + Result;
end;

← →
REA (2003-01-30 11:10) [89]

Вашу бы энергию да в мирных целях...

← →
Sha (2003-01-30 11:47) [90]

Думаю, этот вариант не опустится ниже третьего места, пропустив вперед только asm:
function Sha3(const s: string): string; var p, q: pchar; ch: char; label rt; begin; p:=pointer(s); if p<>nil then begin; SetLength(Result,Length(s)); q:=pchar(pointer(Result))-1; while true do begin; repeat; ch:=p^; inc(p); until ch<>" "; if ch=#0 then goto rt; inc(q); repeat; q^:=ch; ch:=p^; inc(q); if ch=#0 then goto rt; inc(p); until ch=" "; q^:=ch; end; rt: SetLength(Result,(q-pointer(Result))); //SetLength(,-1)=SetLength(,0) end else Result:=""; end;

← →
_jek (2003-01-30 12:52) [91]

До кучи. У меня работает давно, но наверно не шедевр

function TForm1.Trim_space(s: string):string;
var
i: integer;
n: integer;
begin
n := 0;
Result := "";
if Trim(s) <> "" then
begin
for i := 1 to length(s) do
begin
if copy(s, i, 1) = " " then
begin
n := n + 1;
end
else begin
n := 0;
end;
if n < 2 then
begin
Result := Result + copy(s, i, 1);
end;
end;
end;
end;

← →
- (2003-01-30 13:33) [92]

slon

← →
Mystic (2003-01-30 15:30) [93]

> danilka (30.01.03 08:10)

Идея оригинальная!

Но:

procedure TForm1.Button3Click(Sender: TObject);
var
St, St0: string;
begin
St := "1 2";
St0 := Danilka(St);
ShowMessage(IntToStr(Length(St0)));
Edit1.Text := St0;
end;

У меня выводит сообщение с текстом "2", а в Edit1.Text выводится
"1 2 2"?

Кроме того, при выполнении команды Result := s не происходит выделение памяти для новой строки, поэтому ты просто будешь изменять в том числе и исходную строку:

St1 := "1 2"; St2 := "3 4"; St := St1 + St2; St0 := Danilka(St); ShowMessage(St);

Выдаст "1 23 4", хотя строка St изменятся не должна.

← →
Danilka (2003-01-30 16:53) [94]

Mystic © (30.01.03 15:30)
:((
дома вечером посмотрю.
не особо силен я в асме, но ежели что быстрое надо сделать, то imho, только на нем.

← →
BlackKing (2003-01-31 01:26) [95]

Ну ладно, и я решил побаловаться :)
Вот мой вариант этого безобразия.

var Ii,Nn:DWord; SSize:DWord; Procedure DelSpace(S:String); Begin SSize:=Length(S); Ii:=1; Nn:=1; While Ii<SSize do Begin S[Nn]:=S[Ii]; If S[Ii]=#32 then While S[Ii]=#32 do Inc(Ii); Inc(Ii); Inc(Nn); End; S[Nn]:=#0; End;

По первому тэсту Sectey © (29.01.03 09:27) выдаёт результат: 950-1050

← →
Song (2003-01-31 06:27) [96]

Ого... вы тему раскатали :-)))))
Ну что ж у меня тоже почётное первое место, правда с конца :)

← →
Sha (2003-01-31 08:01) [97]

> BlackKing (31.01.03 01:26)
> По первому тэсту Sectey © (29.01.03 09:27) выдаёт результат: 950-1050

Как именно выглядел тест? :)

← →
Danilka (2003-01-31 08:11) [98]

Mystic © (30.01.03 15:30)

вроде все ошибки выправил:

function Danilka(const s:string):string;
var
s2:string;
begin
result:=s;
if s<>"" then begin
UniqueString(result);
asm
lea ebx,s
mov eax,edx
mov ecx,[edx-4]
push edx
@@loop:
mov bx,[edx]
cmp bx,$2020
je @@space
mov [eax],bl
inc eax
@@space:
inc edx
dec ecx
jne @@loop
mov [eax],cl
sub eax,edx
pop edx
add eax,[edx-4]
mov [edx-4],eax
end;
end;
end;

← →
Sha (2003-01-31 12:52) [99]

Решил поучаствовать и в конкурсе Inplace-функций:
function Sha3Inplace(p: pchar): pchar; var q: pchar; ch: char; label rt; begin; Result:=p; if (p<>nil) and (p^<>#0) then begin; q:=p-1; while true do begin; repeat; ch:=p^; inc(p); until ch<>" "; if ch=#0 then goto rt; inc(q); repeat; q^:=ch; ch:=p^; inc(q); if ch=#0 then goto rt; inc(p); until ch=" "; q^:=ch; end; rt: if q<Result then inc(q); q^:=ch; end; end;

← →
Sha (2003-01-31 15:31) [100]

2 Secety (30.01.03 02:45)
Кажется, будут проблемы с пустыми строками и последним пробелом.

← →
Sha (2003-02-01 15:45) [101]

Паскальные процедуры/функции для удаления пробелов и управляющих символов, работающие почти также эффективно, как Q_String:
function Sha4(const s: string): string; var p, q: pchar; ch: char; label rt; begin; p:=pointer(s); if p<>nil then begin; SetLength(Result,Length(s)); q:=pchar(pointer(Result))-1; repeat; repeat; ch:=p^; inc(p); if ch=#0 then goto rt; until ch>" "; inc(q); repeat; q^:=ch; ch:=p^; inc(q); inc(p); until ch<=" "; q^:=" "; until ch=#0; rt: SetLength(Result,(q-pointer(Result))); //SetLength(,-1)=SetLength(,0) end else Result:=""; end; procedure Sha4Var(var s: string); var p, q: pchar; ch: char; label rt; begin; UniqueString(s); p:=pointer(s); if p<>nil then begin; q:=p-1; repeat; repeat; ch:=p^; inc(p); if ch=#0 then goto rt; until ch>" "; inc(q); repeat; q^:=ch; ch:=p^; inc(q); inc(p); until ch<=" "; q^:=" "; until ch=#0; rt: SetLength(s,(q-pointer(s))); //SetLength(,-1)=SetLength(,0) end; end; function Sha4Inplace(p: pchar): pchar; var q: pchar; ch: char; label rt; begin; Result:=p; if (p<>nil) and (p^<>#0) then begin; q:=p-1; repeat; repeat; ch:=p^; inc(p); if ch=#0 then goto rt; until ch>" "; inc(q); repeat; q^:=ch; ch:=p^; inc(q); inc(p); until ch<=" "; q^:=" "; until ch=#0; rt: if q<Result then inc(q); q^:=#0; end; end;

← →
Sha (2003-02-01 15:50) [102]

Топ-лист на 15:00 01.02.2003.
В тесте участвовали программы, возврашающие за приемлемое время правильный результат. Результат считался правильным если из строки были удалены все пробелы, или все пробелы, кроме последнего, или все пробелы и все символы меньшие пробела (соответствующие настройки были сделаны в процедурах InitTBL и Sha).
Все программы были разбиты на 3 категории:
- функции, возращающие String значение,
- процедуры, изменяющие на месте String значение,
- процедуры, изменяющие на месте PChar значение.
Разделение Asm/PurePascal не проводилось.
Для оценки скорости работы программ использовался тест, предложенный Mystic © (29.01.03 21:24) с небольшими изменениями.
Чтобы получить наиболее достоверные результаты тест прогонялся 10 раз по исходным текстам Delphi6 и выбирался наилучший результат. Время выполнения измерялось в тиках процессора. Использовался процессор AMD K6-2+ 500 MHz.
Результаты: //String func //St:=Sha4(St); // 227 + //St:=Q_SpaceCompress(St); // 239 + //St:=Sha3(St); // 261 //St:=Danilka(St); // 354 - //St:=Sha(St); // 358 //St:=Romkin(St); // 542 - //String proc //Sha4Var(St); // 137 + //Q_SpaceCompressInplace(St); // 147 + //Mystic(St); // 278 + //Pchar proc //Sha4Inplace(PChar(St)); // 134 + //SecteyAsm(PChar(St)); // 163 - //Sha3Inplace(PChar(St)); // 165 //Sectey(PChar(St)); // 191 - //Digitman(PChar(St)); // 272
Примечания.
1. цифры справа - время в миллионах тиков CPU,
2. + означает, что удаляются все символы, меньшие или равные пробелу,
3. - означает, что последний пробел не удаляется,

Как видно из результатов теста, используя Pascal, можно писать весьма эффективные небольшие программы.

Заменя пробелов Найти похожие ветки