求比我写的这个POS函数更优化的函数(50分)

次数=10000 子串长=4 母串长=140887
System 位置: 140870 时间: 2532
BMH 位置: 140870 时间: 1921
FPos 位置: 140870 时间: 3813
kmp 位置: 140870 时间: 5813
PosN_PosEx 位置: 140870 时间: 3437
Quick 位置: 140870 时间: 2813
FastPos 位置: 140870 时间: 4359
BMHTextPOS 位置: 140870 时间: 2469
------------------------------------------------
次数=10000 子串长=16 母串长=140887
System 位置: 0 时间: 2547
BMH 位置: 0 时间: 750
FPos 位置: 1242528 时间: 3828
kmp 位置: 0 时间: 5578
PosN_PosEx 位置: -1 时间: 3438
Quick 位置: 0 时间: 2828
FastPos 位置: 0 时间: 4375
BMHTextPOS 位置: 140870 时间: 922
------------------------------------------------
次数=10000 子串长=64 母串长=140887
System 位置: 0 时间: 2531
BMH 位置: 0 时间: 594
FPos 位置: 1242528 时间: 4343
kmp 位置: 0 时间: 7157
PosN_PosEx 位置: -1 时间: 4000
Quick 位置: 0 时间: 3281
FastPos 位置: 0 时间: 4969
BMHTextPOS 位置: 0 时间: 734


可以看出:
1.大名鼎鼎的kmp在子串长度不超过64时,速度是最慢的.超过64速度怎么样?有时间可以测试一下,不过我对这个算法没什么兴趣.
2.Delphi自带的Pos经过汇编优化,已经很快了
3.BMH算法没有使用汇编指令,全部Delphi语句,但速度已经快的令人吃惊了
4.子串越长,BMH反而越快,说明这个算法相当优秀

给我 BMH 函数，好不？

关于几种算法的比较
http://security.riit.tsinghua.edu.cn/seminar/2006_4_27/RQS_V2.doc

{***************************************************************
StarPos是指定Source串的开始扫描位置，该参数如果为0，则默认是从第1位开始的。
lpSubStr指向要匹配的字符串
lpSource指向扫描字符串
call demo
var Source,SubStr:String;
begin
Source := 'Test BMH';
SubStr := 'BMH';
ShowMessage(IntToStr(BMH(Source,SubStr,0)));
end;
***************************************************************}
Function BMH(lpSource,lpSubStr:String
StartPos:Integer):Integer;
var i,index,ExitLen:Integer;
CharTable:array[0..255] of Char;
begin
if Length(lpSubStr) < 1 then
begin
Result := -2
// 子字符串长度不能小于1位
Exit;
end;
// 初始化CharTable
FillChar(CharTable,sizeof(CharTable),Char(Length(lpSubStr)));
for i := Length(lpSubStr) downto 1 do
CharTable[Ord(lpSubStr)] := Char(Length(lpSubStr) - i);
if StartPos < 1 then
i := StartPos
else
i := StartPos - 1;
ExitLen := Length(lpSource) - Length(lpSubStr);
while i <= ExitLen do
begin
for index := Length(lpSubStr) downto 1 do
begin
if lpSource[i + index] <> lpSubStr[index] then
break;
end;
if index < 1 then
begin
Result := i + 1;
Exit;
end
else if CharTable[Ord(lpSource[index + i])] = Char(Length(lpSubStr)) then
i := i + index;
inc(i);
end;
Result := -1
// 没有匹配的字符串
end;

[xiaopei]的函数返回结果经常是错的,速度也不快;
tseug链接的文档看过了,谢谢.文档结果和我测试结果一模一样,kmp是所有算法里最慢的.[]
对那个QS算法很感兴趣,正在研究.
这是我自己写的POS:

unit BMHPos;
interface
uses SysUtils,StrUtils;
type
UByteArray=array[0..0] of byte
QByte=^UByteArray;

TPos=class
public
constructor Create;
destructor Destroy;override;

function Pos(const substr,fastr:string
n:integer=1):integer;
function TextPos(const substr,fastr:string
n:integer=1):integer;overload;
function JoinStr(const ss:array of string):string;
function ReplaceStr(const Txt,OldPat,NewPat:string
mode:integer=0):string;
function ReplaceText(const Txt,OldPat,NewPat:string
mode:integer=0):string;
//mode=0只替换第一个,mode=1替换所有
private
function MemBMH(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
function MemTextBMH(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
end;

var
MyPos:TPos;

implementation

var
CharPos:array[0..255] of integer
//记录#0~#255在子串中倒数位置
UpChar:array[0..255] of byte;

constructor TPos.Create;
begin
inherited;
end;

destructor TPos.Destroy;
begin
inherited;
end;

procedure MyInit;
var c:char;
begin
for c:=#0 to #255 do UpChar[ord(c)]:=ord(UpCase(c));
MyPos:=TPos.Create();
end;

procedure MyDone;
begin
MyPos.Free();
end;

procedure MakeBinTable(srcointer
slen:integer);
var i:integer;
begin
for i:=0 to 255 do CharPos:=slen;
dec(slen);
for i:=0 to slen do CharPos[QByte(src)]:=slen-i;
end;

function BMH0(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
label aaaa,bbbb,xend;
var i,k:integer;
begin
if(SubLen=0)or(SubLen>fLen)then goto xend;
i:=0;
aaaa:
k:=i+SubLen-1
if k>=fLen then goto xend;
k:=CharPos[FaPt[k]];
if k>0 then begin inc(i,k)
goto aaaa
end;
for k:=SubLen-1 downto 0 do
if subpt[k]<>fapt[i+k] then goto bbbb;
dec
if n<>0 then begin inc(i,sublen)
goto aaaa
end;
result:=i
exit;
bbbb:
inc(i,CharPos[Fapt[i+SubLen]]+1)
goto aaaa;
xend:
result:=-1;
end;

function TPos.MemBMH(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
begin
MakeBinTable(subpt,sublen);
result:=BMH0(subpt,sublen,fapt,flen,n);
end;

procedure MakeTextTable(src:QByte
slen:integer
dest:QByte);
var i:integer
a:byte;
begin
for i:=0 to 255 do CharPos:=slen;
dec(slen);
for i:=0 to slen do
begin
a:=UpChar[src];
dest[0]:=a
inc(dest);
CharPos[a]:=slen-i;
end;
end;

var ust:string
ustp:QByte;

function TextBMH0(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
label aaaa,bbbb,xend;
var i,k:integer;
begin
if(SubLen=0)or(SubLen>fLen)then goto xend;
SetLength(ust,SubLen)
ustp:=@ust[1]
i:=0;
aaaa:
k:=i+SubLen-1
if k>=fLen then goto xend;
k:=CharPos[UpChar[FaPt[k]]];
if k>0 then begin inc(i,k)
goto aaaa
end;
for k:=SubLen-1 downto 0 do
if ord(ustp[k])<>UpChar[fapt[i+k]] then goto bbbb;
dec
if n<>0 then begin inc(i,sublen)
goto aaaa
end;
result:=i
exit;
bbbb:
inc(i,CharPos[UpChar[Fapt[i+SubLen]]]+1)
goto aaaa;
xend:
result:=-1;
end;

function TPos.MemTextBMH(subpt:QByte
SubLen:integer
fapt:QByte
fLen:integer
n:integer=1):integer;
begin
SetLength(ust,SubLen)
ustp:=@ust[1];
MakeTextTable(subpt,sublen,pointer(ustp));
Result:=TextBMH0(subpt,sublen,fapt,flen,n);
ust:='';
end;

function TPos.Pos(const substr, fastr: string
n: integer=1): integer;
begin
result:=MemBMH(@substr[1],Length(substr),@fastr[1],Length(fastr),n)+1;
end;

function TPos.TextPos(const substr, fastr: string
n: integer): integer;
begin
result:=MemTextBMH(@substr[1],Length(substr),@fastr[1],Length(fastr),n)+1;
end;

function TPos.JoinStr(const ss: array of string): string;
var i,a:integer
p:QByte;
begin
a:=0
for i:=low(ss) to high(ss) do inc(a,Length(ss));
SetLength(result,a)
p:=@result[1];
for i:=low(ss) to high(ss) do
begin
a:=Length(ss);
Move(ss[1],p^,a);
inc(p,a);
end;
end;
//------------------------------字符串替换-----------------------------
procedure ReplaceStr0(OldPtr:QByte
OldLen:integer
NewPtr:QByte
NewLen:integer;
TxtPtr:QByte
TxtLen:integer
var dest:string
mode:integer=0);
label aaaa,bbbb;
var DestMaxLen:integer
Ti,Matchi,pdest,tend,dp:QByte;
k:integer;
begin
if OldLen>=NewLen then DestMaxLen:=TxtLen
else DestMaxLen:=TxtLen div OldLen * NewLen;
SetLength(dest,DestMaxLen)
MakeBinTable(oldptr,oldlen);
Ti:=TxtPtr
pdest:=@dest[1]
dp:=pdest;
tend:=QByte(integer(TxtPtr)+TxtLen);
bbbb:
k:=BMH0(OldPtr,OldLen,Ti,integer(tend)-integer(Ti));
if k<0 then goto aaaa;
Matchi:=QByte(integer(Ti)+k)
k:=integer(Matchi)-integer(ti);
if k<>0 then begin Move(ti[0],dp[0],k)
inc(dp,k)
end;
Move(NewPtr[0],dp[0],NewLen)
inc(dp,NewLen);
Ti:=QByte(integer(Matchi)+OldLen);
if mode=1 then goto bbbb;
aaaa:
k:=integer(tend)-integer(ti);
if k<>0 then begin Move(Ti[0],dp[0],k)
inc(dp,k)
end;
k:=integer(dp)-integer(pdest);
if k<>Length(dest) then
SetLength(dest,k);
end;

function TPos.ReplaceStr(const Txt, OldPat, NewPat: string
mode:integer=0): string;
begin
ReplaceStr0(@OldPat[1],Length(OldPat),@NewPat[1],Length(NewPat),@Txt[1],Length(Txt),Result,mode);
end;

procedure ReplaceText0(OldPtr:QByte
OldLen:integer
NewPtr:QByte
NewLen:integer;
TxtPtr:QByte
TxtLen:integer
var dest:string
mode:integer=0);
label aaaa,bbbb;
var DestMaxLen:integer
Ti,Matchi,pdest,tend,dp:QByte;
k:integer;
begin
if OldLen>=NewLen then DestMaxLen:=TxtLen
else DestMaxLen:=TxtLen div OldLen * NewLen;
SetLength(dest,DestMaxLen);
SetLength(ust,OldLen)
ustp:=@ust[1]
MakeTextTable(oldptr,oldlen,ustp);
Ti:=TxtPtr
pdest:=@dest[1]
dp:=pdest;
tend:=QByte(integer(TxtPtr)+TxtLen);
bbbb:
k:=TextBMH0(OldPtr,OldLen,Ti,integer(tend)-integer(Ti));
if k<0 then goto aaaa;
Matchi:=QByte(integer(Ti)+k)
k:=integer(Matchi)-integer(ti);
if k<>0 then begin Move(ti[0],dp[0],k)
inc(dp,k)
end;
Move(NewPtr[0],dp[0],NewLen)
inc(dp,NewLen);
Ti:=QByte(integer(Matchi)+OldLen);
if mode=1 then goto bbbb;
aaaa:
k:=integer(tend)-integer(ti);
if k<>0 then begin Move(Ti[0],dp[0],k)
inc(dp,k)
end;
k:=integer(dp)-integer(pdest);
if k<>Length(dest) then
SetLength(dest,k);
ust:='';
end;

function TPos.ReplaceText(const Txt, OldPat, NewPat: string
mode:integer=0): string;
begin
Replacetext0(@OldPat[1],Length(OldPat),@NewPat[1],Length(NewPat),@Txt[1],Length(Txt),Result,mode);
end;

initialization
MyInit();
finalization
MyDone();
end.

没上机测试，有一个地方写错了。
Function BMH(lpSource,lpSubStr:String
StartPos:Integer):Integer;
var i,index,ExitLen:Integer;
CharTable:array[0..255] of Char;
begin
if Length(lpSubStr) < 1 then
begin
Result := -2
// 子字符串长度不能小于1位
Exit;
end;
// 初始化CharTable
FillChar(CharTable,sizeof(CharTable),Char(Length(lpSubStr)));
for i := Length(lpSubStr) downto 1 do
CharTable[Ord(lpSubStr)] := Char(Length(lpSubStr) - i);
if StartPos < 1 then
i := StartPos
else
i := StartPos - 1;
ExitLen := Length(lpSource) - Length(lpSubStr);
while i <= ExitLen do
begin
for index := Length(lpSubStr) downto 1 do
begin
if lpSource[i + index] <> lpSubStr[index] then
break;
end;
if index < 1 then
begin
Result := i + 1;
Exit;
end
else if CharTable[Ord(lpSource[index + i])] = Char(Length(lpSubStr)) then
i := i + index - 1;
inc(i);
end;
Result := -1
// 没有匹配的字符串
end;

测试了一下，有些字符测试还是有错，看来对这个算法的理解的还不是很清楚。

经过实测，在我的软件中
DELPHI的POS函数平均用时240多点
我的第一个二重循环FPOS和我优化后的函数一样都是平均270
在高级语言比汇编慢的范围内，由于DELPHI的内部编译智能优化
对于二重循环，其实没有必要用KENNING的那种方法了。直接写成
最易读的方式就可以了。其它朋友的函数就没有时间去试了。

我还写了一个一重循环的只能子串不大于5字节的
function F5Pos(Head, Source: string): Integer;
var
I, LenHead, LenSource: Integer;
Head1, Head2, Head3, Head4, Head5, Head6, Head7, Head8, Head9, Head10: char;
begin
LenSource := Length(Source);
LenHead := Length(Head);
if LenSource = 0 then
begin
Result := 0
Exit;
end;
case LenHead of
0:
begin
Result := 0
Exit;
end;
1:
begin
Head1 := Head[1];
for I := 1 to LenSource do
if (Source = Head1) then
begin
Result := I
Exit;
end;
end;
2:
begin
Head1 := Head[1];
Head2 := Head[2];
for I := 1 to LenSource-1 do
if (Source = Head1) and
(Source[I+1] = Head2)
then
begin
Result := I
Exit;
end;
end;
3:
begin
Head1 := Head[1];
Head2 := Head[2];
Head3 := Head[3];
for I := 1 to LenSource-2 do
if (Source = Head1) and
(Source[I+1] = Head2) and
(Source[I+2] = Head3)
then
begin
Result := I
Exit;
end;
end;
4:
begin
Head1 := Head[1];
Head2 := Head[2];
Head3 := Head[3];
Head4 := Head[4];
for I := 1 to LenSource-3 do
if (Source = Head1) and
(Source[I+1] = Head2) and
(Source[I+2] = Head3) and
(Source[I+3] = Head4)
then
begin
Result := I
Exit;
end;
end;
5:
begin
Head1 := Head[1];
Head2 := Head[2];
Head3 := Head[3];
Head4 := Head[4];
Head5 := Head[5];
for I := 1 to LenSource-4 do
if (Source = Head1) and
(Source[I+1] = Head2) and
(Source[I+3] = Head4) and
(Source[I+2] = Head3) and
(Source[I+4] = Head5)
then
begin
Result := I
Exit;
end;
end;
else
begin
Result := 0
Exit;
end;
end;
end;
测试结果还是270左右，所以二重循环比条件语句并不慢，在编译优化后。

hook 只会发生一次，在你应用程序初始化时自动根据当前 CPU 的类型选择最优的 Pos 函数实现，把 delphi 原始的 pos 函数实现替换掉了。所以在你以后调用 pos 都是针对你当前 cpu 用汇编充分优化过的实现代码。
Fastcode 这个开源项目就是一个“竞赛”项目，把大家贡献最优的呈现出来。
现在 delphi 2007 之类的 N 多 rtl 函数都是引用 fastcode 的！比如 Delphi 2007 中 CompareStr 的实现：

(* ***** BEGIN LICENSE BLOCK *****
*
* The function CompareStr is licensed under the CodeGear license terms.
*
* The initial developer of the original code is Fastcode
*
* Portions created by the initial developer are Copyright (C) 2002-2007
* the initial developer. All Rights Reserved.
*
* Contributor(s): Pierre le Riche
*
* ***** END LICENSE BLOCK ***** *)
function CompareStr(const S1, S2: string): Integer;
asm
{On entry:
eax = @S1[1]
edx = @S2[1]
On exit:
Result in eax:
0 if S1 = S2,
> 0 if S1 > S2,
< 0 if S1 < S2
Code size:
101 bytes}
cmp eax, edx
je @SameString
{Is either of the strings perhaps nil?}
test eax, edx
jz @PossibleNilString
{Compare the first four characters (there has to be a trailing #0). In random
string compares this can save a lot of CPU time.}
@BothNonNil:
{Compare the first character}
movzx ecx, byte ptr [edx]
cmp cl, [eax]
je @FirstCharacterSame
{First character differs}
movzx eax, byte ptr [eax]
sub eax, ecx
ret
@FirstCharacterSame:
{Save ebx}
push ebx
{Set ebx = length(S1)}
mov ebx, [eax - 4]
xor ecx, ecx
{Set ebx = length(S1) - length(S2)}
sub ebx, [edx - 4]
{Save the length difference on the stack}
push ebx
{Set ecx = 0 if length(S1) < length(S2), $ffffffff otherwise}
adc ecx, -1
{Set ecx = - min(length(S1), length(S2))}
and ecx, ebx
sub ecx, [eax - 4]
{Adjust the pointers to be negative based}
sub eax, ecx
sub edx, ecx
@CompareLoop:
mov ebx, [eax + ecx]
xor ebx, [edx + ecx]
jnz @Mismatch
add ecx, 4
js @CompareLoop
{All characters match - return the difference in length}
@MatchUpToLength:
pop eax
pop ebx
ret
@Mismatch:
bsf ebx, ebx
shr ebx, 3
add ecx, ebx
jns @MatchUpToLength
movzx eax, byte ptr [eax + ecx]
movzx edx, byte ptr [edx + ecx]
sub eax, edx
pop ebx
pop ebx
ret
{It is the same string}
@SameString:
xor eax, eax
ret
{Good possibility that at least one of the strings are nil}
@PossibleNilString:
test eax, eax
jz @FirstStringNil
test edx, edx
jnz @BothNonNil
{Return first string length: second string is nil}
mov eax, [eax - 4]
ret
@FirstStringNil:
{Return 0 - length(S2): first string is nil}
sub eax, [edx - 4]
end;

再测了一下，上面的函数还要快一点点，平均不到265

再看 Delphi 2007 中的 PosEx 的实现：

(* ***** BEGIN LICENSE BLOCK *****
*
* The function PosEx is licensed under the CodeGear license terms.
*
* The initial developer of the original code is Fastcode
*
* Portions created by the initial developer are Copyright (C) 2002-2004
* the initial developer. All Rights Reserved.
*
* Contributor(s): Aleksandr Sharahov
*
* ***** END LICENSE BLOCK ***** *)
function PosEx(const SubStr, S: string
Offset: Integer = 1): Integer;
asm
test eax, eax
jz @Nil
test edx, edx
jz @Nil
dec ecx
jl @Nil

push esi
push ebx

mov esi, [edx-4] //Length(Str)
mov ebx, [eax-4] //Length(Substr)
sub esi, ecx //effective length of Str
add edx, ecx //addr of the first char at starting position
cmp esi, ebx
jl @Past //jump if EffectiveLength(Str)<Length(Substr)
test ebx, ebx
jle @Past //jump if Length(Substr)<=0

add esp, -12
add ebx, -1 //Length(Substr)-1
add esi, edx //addr of the terminator
add edx, ebx //addr of the last char at starting position
mov [esp+8], esi //save addr of the terminator
add eax, ebx //addr of the last char of Substr
sub ecx, edx //-@Str[Length(Substr)]
neg ebx //-(Length(Substr)-1)
mov [esp+4], ecx //save -@Str[Length(Substr)]
mov [esp], ebx //save -(Length(Substr)-1)
movzx ecx, byte ptr [eax] //the last char of Substr

@Loop:
cmp cl, [edx]
jz @Test0
@AfterTest0:
cmp cl, [edx+1]
jz @TestT
@AfterTestT:
add edx, 4
cmp edx, [esp+8]
jb @Continue
@EndLoop:
add edx, -2
cmp edx, [esp+8]
jb @Loop
@Exit:
add esp, 12
@Past:
pop ebx
pop esi
@Nil:
xor eax, eax
ret
@Continue:
cmp cl, [edx-2]
jz @Test2
cmp cl, [edx-1]
jnz @Loop
@Test1:
add edx, 1
@Test2:
add edx, -2
@Test0:
add edx, -1
@TestT:
mov esi, [esp]
test esi, esi
jz @Found
@String:
movzx ebx, word ptr [esi+eax]
cmp bx, word ptr [esi+edx+1]
jnz @AfterTestT
cmp esi, -2
jge @Found
movzx ebx, word ptr [esi+eax+2]
cmp bx, word ptr [esi+edx+3]
jnz @AfterTestT
add esi, 4
jl @String
@Found:
mov eax, [esp+4]
add edx, 2

cmp edx, [esp+8]
ja @Exit

add esp, 12
add eax, edx
pop ebx
pop esi
end;

同一段代码，在D2005/6/7的Vcl.win32和Vcl.net两种环境下都通过编译，但使用汇编
后，只有Vcl.win32支持，各位要想清楚，免得以后改的麻烦。

推崇FastCode的朋友不知道你们实测过没有?其实FastCode的速度并不快,大部分情况下还不如Delphi自带的Pos,这点连FastCode的站长都承认.
目前最快的就是BM和它的各种改进算法.

同意楼上，只不过BM算法的代码不好找。
而且FASTCODE要运行前换一次，感觉有点不直接。

BM？你说的是这个吧？


function FindPosBM(const ASource, ASub: string
AStartPos: Integer = 1): Integer;
const
MAX_CHAR = 256;
SizeInt = SizeOf(Integer);
type
PByteArr = ^TByteArr;
TByteArr = array [0..MaxInt - 1] of Byte;
var
Src, Sub: PByte;
I, J, CurrPos, SubLen, SrcLen: Integer;
Buffer: array [0..MAX_CHAR - 1] of Integer;
begin
Result := 0;
SubLen := Length(ASub);
SrcLen := Length(ASource);
if SubLen > SrcLen then Exit;

Sub := PByte(ASub);
Src := PByte(ASource);
for I := 0 to MAX_CHAR - 1 do
Buffer := SubLen;
for I := 0 to SubLen - 2 do
Buffer[PByteArr(Sub)^] := SubLen - I - 1;

CurrPos := SubLen + AStartPos - 2;
while CurrPos < SrcLen do
begin
I := CurrPos;
J := SubLen - 1;
while (J >= 0) and ((PByteArr(Src)^ = PByteArr(Sub)^[J])) do
begin
Dec(J);
Dec(I);
end;
if -1 = J then
begin
Result := CurrPos - SubLen + 1;
break;
end;
Inc(CurrPos, Buffer[PByteArr(Src)^[CurrPos]]);
end;
end;

在Vcl.net环境里面，像^这种符号，PByteArr = ^TByteArr这些不能编译，
大家要想清楚才用，万一程序要在Vcl.net里面编译，改起来麻烦。

to lxddd：
我确实没有听说过“其实FastCode的速度并不快,大部分情况下还不如Delphi自带的Pos,这点连FastCode的站长都承认”的说法，我只知道 Delphi 2006、2007 之后放弃了自己早期的实现转而使用 FastCode，难道 Borland/CodeGear 是在忽悠我们 ？ ;>
to 我爱PASCAL：
这是最方便的方式啊，你要做的就是 uses 一个单元，你无需动原有的任何代码，即可享受到 FastCode 带来的高效！难道你选好了 MyPosEx 然后 UltraEdit Replace PosEx ？？这个不是项目的做法。
“推崇FastCode的朋友不知道你们实测过没有”，呵呵，至少在我的项目中 FastCode 威力可不小。
不过直觉这和具体的应用场合可能非常相关，楼上的测试：子串长=xx 母串长=14xxxx 上百 k 的内容啊。我通常自在字段中查找，长度通常 < 1k。

发一个例子，具体的结果可能有偏差，不过这无关紧要，重要的是结合自己项目实际场景进行函数的选取，尺有所短寸有所长吗。
;>

unit MainFrm;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TPosEx = function (const SubStr, S: string
Offset: Integer = 1): Integer;

TMainForm = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Edit2: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FFunc: TPosEx;

procedure Test(const AMsg: string);
end;

var
MainForm: TMainForm;

implementation

{$R *.dfm}

uses
Math, StrUtils, FastcodePosExUnit, FastcodeCPUID;

function Delphi7PosEx(const SubStr, S: string
Offset: Integer = 1): Integer;
var
I,X: Integer;
Len, LenSubStr: Integer;
begin
if Offset = 1 then
Result := Pos(SubStr, S)
else
begin
I := Offset;
LenSubStr := Length(SubStr);
Len := Length(S) - LenSubStr + 1;
while I <= Len do
begin
if S = SubStr[1] then
begin
X := 1;
while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
Inc(X);
if (X = LenSubStr) then
begin
Result := I;
exit;
end;
end;
Inc(I);
end;
Result := 0;
end;
end;

function Delphi2007PosEx(const SubStr, S: string
Offset: Integer = 1): Integer;
asm
test eax, eax
jz @Nil
test edx, edx
jz @Nil
dec ecx
jl @Nil

push esi
push ebx

mov esi, [edx-4] //Length(Str)
mov ebx, [eax-4] //Length(Substr)
sub esi, ecx //effective length of Str
add edx, ecx //addr of the first char at starting position
cmp esi, ebx
jl @Past //jump if EffectiveLength(Str)<Length(Substr)
test ebx, ebx
jle @Past //jump if Length(Substr)<=0

add esp, -12
add ebx, -1 //Length(Substr)-1
add esi, edx //addr of the terminator
add edx, ebx //addr of the last char at starting position
mov [esp+8], esi //save addr of the terminator
add eax, ebx //addr of the last char of Substr
sub ecx, edx //-@Str[Length(Substr)]
neg ebx //-(Length(Substr)-1)
mov [esp+4], ecx //save -@Str[Length(Substr)]
mov [esp], ebx //save -(Length(Substr)-1)
movzx ecx, byte ptr [eax] //the last char of Substr

@Loop:
cmp cl, [edx]
jz @Test0
@AfterTest0:
cmp cl, [edx+1]
jz @TestT
@AfterTestT:
add edx, 4
cmp edx, [esp+8]
jb @Continue
@EndLoop:
add edx, -2
cmp edx, [esp+8]
jb @Loop
@Exit:
add esp, 12
@Past:
pop ebx
pop esi
@Nil:
xor eax, eax
ret
@Continue:
cmp cl, [edx-2]
jz @Test2
cmp cl, [edx-1]
jnz @Loop
@Test1:
add edx, 1
@Test2:
add edx, -2
@Test0:
add edx, -1
@TestT:
mov esi, [esp]
test esi, esi
jz @Found
@String:
movzx ebx, word ptr [esi+eax]
cmp bx, word ptr [esi+edx+1]
jnz @AfterTestT
cmp esi, -2
jge @Found
movzx ebx, word ptr [esi+eax+2]
cmp bx, word ptr [esi+edx+3]
jnz @AfterTestT
add esi, 4
jl @String
@Found:
mov eax, [esp+4]
add edx, 2

cmp edx, [esp+8]
ja @Exit

add esp, 12
add eax, edx
pop ebx
pop esi
end;

function Q_PosStr(const FindString, SourceString: string
Offset: Integer = 1): Integer;
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EDX
TEST EAX,EAX
JE @@qt
TEST EDX,EDX
JE @@qt0
MOV ESI,EAX
MOV EDI,EDX
MOV EAX,[EAX-4]
MOV EDX,[EDX-4]
DEC EAX
SUB EDX,EAX
DEC ECX
SUB EDX,ECX
JNG @@qt0
XCHG EAX,EDX
ADD EDI,ECX
MOV ECX,EAX
JMP @@nx
@@fr: INC EDI
DEC ECX
JE @@qt0
@@nx: MOV EBX,EDX
MOV AL,BYTE PTR [ESI]
@@lp1: CMP AL,BYTE PTR [EDI]
JE @@uu
INC EDI
DEC ECX
JE @@qt0
CMP AL,BYTE PTR [EDI]
JE @@uu
INC EDI
DEC ECX
JE @@qt0
CMP AL,BYTE PTR [EDI]
JE @@uu
INC EDI
DEC ECX
JE @@qt0
CMP AL,BYTE PTR [EDI]
JE @@uu
INC EDI
DEC ECX
JNE @@lp1
@@qt0: XOR EAX,EAX
@@qt: POP ECX
POP EBX
POP EDI
POP ESI
RET
@@uu: TEST EDX,EDX
JE @@fd
@@lp2: MOV AL,BYTE PTR [ESI+EBX]
CMP AL,BYTE PTR [EDI+EBX]
JNE @@fr
DEC EBX
JE @@fd
MOV AL,BYTE PTR [ESI+EBX]
CMP AL,BYTE PTR [EDI+EBX]
JNE @@fr
DEC EBX
JE @@fd
MOV AL,BYTE PTR [ESI+EBX]
CMP AL,BYTE PTR [EDI+EBX]
JNE @@fr
DEC EBX
JE @@fd
MOV AL,BYTE PTR [ESI+EBX]
CMP AL,BYTE PTR [EDI+EBX]
JNE @@fr
DEC EBX
JNE @@lp2
@@fd: LEA EAX,[EDI+1]
SUB EAX,[ESP]
POP ECX
POP EBX
POP EDI
POP ESI
ret
end;