{$X+}
program DEL_TIMR ;

{ Inject and Remove are faster alternatives to BP7's Insert and Delete
  READ conditional compilation directives and set accordingly !
  N.B. Read the "** acceptable range **" statement below.
  Program Concat work as a sub-case of Inject. }

{$IFDEF WINDOWS} uses WinCrt ; {$ENDIF}

(* Derived from a post by Joe Merten <joe@jme.de>, JME Engineering Berlin :
  If your reason to replace the KeyPressed function is only
  that you don't want to use the Crt unit, try: *)
function KeyPressed : boolean ; assembler ;
asm  mov AH,$01 ; int $16
    mov AL,TRUE ; JNZ @Ende ; mov AL,FALSE ; @Ende: end ;


const

job =
  {$IFDEF INS} 'INS' {$ENDIF}
  {$IFDEF DEL} 'DEL' {$ENDIF}
  {$IFDEF CAT} 'CAT' {$ENDIF}
  ;
user =

  {$IFDEF JRS} 'JRS' ;

procedure Remove(var S : string ; Index, Count : Integer) ;
{ JRS's faster replacement for Sys.DELETE }
var Tmp : integer ;
begin
  if (Count<=0) or (Index<=0) or (Index>Length(S)) then EXIT ;
  Tmp := Length(S)-Index+1 { Maximum Removable } ;
  if Count>=Tmp then Count := Tmp else
    Move(S[Index+Count], S[Index], Tmp-Count) ;
  Dec(S[0], Count) end {Remove} ;

procedure Inject(Source : string ; var S : string ; Index : integer) ;
{ JRS's faster replacement for Sys.INSERT }
var New, Old, All, Was : integer ;
begin New := Length(Source) ; if New=0 then EXIT ;
  Was := Length(S) ;
  if Index<1 then Index := 1 else
    if Index>Succ(Was) then Index := Succ(Was) ;
  All := Was+New ;
  if All<=255
    then     begin S[0] := char(All) ; Old := Was-Index+1 ;
    end else begin S[0] := char(255) ; Old := 256-Index-New ;
    if Old<0 then begin Old := 0 ; New := 256-Index end ; end ;
  if Old>0 then Move(S[Index], S[Index+New], Old) ;
  if New>0 then Move(Source[1], S[Index], New) ;
  end {Inject} ;

{$IFDEF ADJ1}{$DEFINE ADJ}{$ENDIF}
{$IFDEF ADJ2}{$DEFINE ADJ}{$ENDIF}
{$IFDEF ADJ1}
function Adjoin(const S1, S2 : string) : string ;
{ JRS's ? not-faster ? replacement for Sys.CONCAT(S1, S2) }
var New : byte ; S : string ;
begin S := S1 ;
  if Length(S2)>0 then begin
    if Length(S1)+Length(S2)<=255 then New := Length(S2)
      else New := 255-Length(S1) ;
    if New>0 then begin
      Move(S2[1], S[Succ(Length(S))], New) ; Inc(S[0], New) end ;
    end ;
  Adjoin := S end {Adjoin} ;
{$ENDIF ADJ1}

{$IFDEF ADJ2}
function Adjoin(const S1, S2 : string) : string ;
{ JRS's ? not-faster ? replacement for Sys.CONCAT(S1, S2) }
var P : ^string ; New : byte ;
begin asm
      les di, @Result ; mov word ptr P,di ; mov word ptr P+2,es end {FP/OR} ;
  P^ := S1 ;
  if Length(S2)>0 then begin
    if Length(S1)+Length(S2)<=255 then New := Length(S2)
      else New := 255-Length(S1) ;
    if New>0 then begin
      Move(S2[1], P^[Succ(Length(P^))], New) ; Inc(P^[0], New) end ;
    end ;
  end {Adjoin} ;
{$ENDIF ADJ2}

procedure AddStr(var S0 : openstring ; const S1, S2 : string) ;
{ JRS's faster replacement for S0 := Sys.CONCAT(S1, S2) }
var New : integer ;
begin S0 := S1 ;
  if Length(S2)>0 then begin New := integer(High(S0))-Length(S0) ;
    if Length(S2)<=New then New := Length(S2) ;
    if New>0 then begin
      Move(S2[1], S0[Succ(Length(S0))], New) ; Inc(S0[0], New) end ;
    end end {AddStr} ;

procedure AppStr(var S0 : openstring ; const S2 : string) ;
{ JRS's faster replacement for S0 := Sys.CONCAT(S0, S2) }
var New : byte ;
begin
  if Length(S2)>0 then begin New := High(S0)-Length(S0) ;
    if Length(S2)<=New then New := Length(S2) ;
    if New>0 then begin
      Move(S2[1], S0[Succ(Length(S0))], New) ; Inc(S0[0], New) end ;
    end end {AppStr} ;

{$ENDIF JRS}


{$IFDEF PEDT} 'PEDT' ;
(* after Pedt Scragg <postmaster@pedt.demon.co.uk> (re-laid by JRS) : *)
procedure Remove(var s : String ; index, count : byte) ;
begin
  if index > length(s) then exit else
    if index + count > succ(length(s)) then s[0] := chr(index) else
    begin
    Move(s[Index + count], s[Index], succ(length(s)) - index - count) ;
    Dec(s[0], Count) ;
    end ;
  end ;
{$ENDIF PEDT}


{$IFDEF MIKE} 'MIKE' ;
(* In article <34717177.6538@short.net> of Tue, 18 Nov 1997 02:44:07
  in comp.lang.pascal.misc, Mike <internal@short.net> wrote:
  Here's mine! (re-laid by JRS) *)
procedure Remove(var st : string ; ix, count : byte) ;
var
gv    : word {got to handle strings of 255 char} ;
StLen : byte absolute st;
begin  gv := ix + count ;
  if StLen>=gv then begin
    Move(st[gv], st[ix], StLen + 1 - gv) ;
    Dec(StLen, count) ;
    end else StLen := ix - 1 ;
  end ;
{$ENDIF MIKE}


type float = {$IFOPT N+} extended {$ELSE} real {$ENDIF} ;

var Goes : longint ; SumRat : float ;


function Compare(Len : byte ; Ix, Ct : integer) : boolean ;
const Tiks : longint = {$IFDEF DEBUG} 0 {$ELSE} 1 {$ENDIF} ;
SL = 255 {alter this to test } ;
var SysT, OurT, L, Base, NLoops, T0 : longint ;
ChkA : char ; SysS : string [SL] ;
ChkB : char ; OurS : string [SL] ; ChkC : char ;
Rat : float ; Q : byte ;
AddS, VarS : string ;
Tkr : longint absolute $40:$6C ;
begin Compare := true ;
  VarS[0] := char(Len) ;
  for Q := 1 to 255 {<-stet} do VarS[Q] := char(Q+64) ;

  AddS[0] := char(Ct) ; Ct := Length(AddS) ;
  for Q := 1 to 255 {<-stet} do AddS[Q] := char(123-Q) ;

  ChkA := 'A' ; ChkB := 'B' ; ChkC := 'C' ;

  Write(Len:4, Ix:4, Ct:4, ';') ;

  T0 := Tkr ; repeat until T0<>Tkr ; T0 := Tkr+Tiks ; NLoops := 0 ;
  repeat SysS := VarS ;
    Inc(NLoops) until Tkr>=T0 ;
  Base := NLoops ; Write(' Base:', Base:6, ',') ;

  T0 := Tkr ; repeat until T0<>Tkr ; T0 := Tkr+Tiks ; NLoops := 0 ;
  repeat SysS := VarS ;
    {$IFDEF INS} Insert(AddS, SysS, Ix) ; {$ENDIF}
    {$IFDEF DEL} Delete(SysS, Ix, Ct) ; {$ENDIF}
    {$IFDEF CAT} SysS := Concat(AddS, VarS) ; {$ENDIF}
    Inc(NLoops) until Tkr>=T0 ;
  SysT := NLoops ; Write(' SysS:', SysT:6, Ord(SysS[0]):4, ',') ;


  if { ** acceptable range ** }
    {$IFDEF JRS} false {$ENDIF}
    {$IFDEF PEDT}
    (Ct<0) or (Ix<0) or (Ct>Succ(Len-Ix)) or (Ix+Ct>255) or (Len=255)
    {$ENDIF}
    {$IFDEF MIKE}
    (Ct<0) or (Ix<=0) or (Ct>Succ(Len-Ix)) or (Ix+Ct>255)
    {$ENDIF}
    then begin Writeln('Skip') ; Compare := false ; EXIT end ;

  T0 := Tkr ; repeat until T0<>Tkr ; T0 := Tkr+Tiks ; NLoops := 0 ;
  repeat OurS :=
      {$IFDEF CAT}{$IFDEF APP}AddS{$ELSE}VarS{$ENDIF}{$ELSE}VarS{$ENDIF} ;
    {$IFDEF INS} Inject(AddS, OurS, Ix) ; {$ENDIF}
    {$IFDEF DEL} Remove(OurS, Ix, Ct) ; {$ENDIF}
    {$IFDEF CAT}
    {$IFDEF ADJ} OurS := Adjoin(AddS, VarS) ; {$ENDIF}
    {$IFDEF ADD} AddStr(OurS, AddS, VarS) ; {$ENDIF}
    {$IFDEF APP} AppStr(OurS, VarS) ; {$ENDIF}
    {$ENDIF}
    Inc(NLoops) until Tkr>=T0 ;
  OurT := NLoops ; Write(' OurS:', OurT:6, Ord(OurS[0]):4, ';') ;

  {$IFNDEF DEBUG}
  if (SysT>0) and (OurT>0) then begin
    Rat := (1.0/OurT - 1.0/Base)/(1.0/SysT - 1.0/Base) ; Write(Rat:6:3) ;
    SumRat := SumRat + Rat ; Inc(Goes) ;
    end else Write ('':6) ;
  {$ENDIF}

  Write(' :', SysS=OurS:5) ;
  if Goes>0 then Write(SumRat/Goes:6:3) ;
  Writeln ;
  if (SysS<>OurS) or (ChkA<>'A') or (ChkB<>'B') or (ChkC<>'C') then begin
    Writeln(Length(SysS):5, ^M^J, '  SysStr "', SysS, '"') ;
    Writeln(Length(OurS):5, ^M^J, '  OurStr "', OurS, '"') ;
    Writeln('ChkA ', ChkA, ChkA='A':6,
      {} '   ChkB ', ChkB, ChkB='B':6,
      {} '   ChkC ', ChkC, ChkC='C':6) ;
    Readln ; EXIT end ;
  if KeyPressed then EXIT ;
  Compare := false end {Compare} ;


procedure Cap ;
begin Writeln ;
  Writeln('DEL_TIMR - www.merlyn.demon.co.uk >= 1998/06/26  - "',
    {$IFDEF INS} 'Inject' {$ENDIF}
    {$IFDEF DEL} 'Remove' {$ENDIF}
    {$IFDEF CAT}
    {$IFDEF ADJ} 'Adjoin' {$ENDIF}
    {$IFDEF ADD} 'AddStr' {$ENDIF}
    {$IFDEF APP} 'AppStr' {$ENDIF}
    {$ENDIF}
    , '" by ', user) ;
  end {Cap} ;

var Slen : byte ; Ndx, Cnt : integer ; St1, St2 : string ;


BEGIN Cap ;
{Randomize ;}

Writeln('Functioning : ') ;
St1 := '123456789' ;
{$IFDEF INS} Insert('uvwx', St1, 6) ; {$ENDIF}
{$IFDEF DEL} Delete(St1, 3, 4) ; {$ENDIF}
{$IFDEF CAT} St1 := Concat('uvwx', 'UVWX') ; {$ENDIF}
Writeln('  System.:', St1) ;
St2 := '123456789' ;
{$IFDEF INS} Inject('uvwx', St2, 6) ; {$ENDIF}
{$IFDEF DEL} Remove(St2, 3, 4) ; {$ENDIF}
{$IFDEF CAT}
{$IFDEF ADJ} St2 := Adjoin('uvwx', 'UVWX') ; {$ENDIF}
{$IFDEF ADD} AddStr(St2, 'uvwx', 'UVWX') ; {$ENDIF}
{$IFDEF APP} St2 := 'uvwx' ; AppStr(St2, 'UVWX') ; {$ENDIF}
{$ENDIF}
Writeln('  Program:', St2) ;
if St1=St2 then begin

  Writeln(^M^J'Now counts repeats over one clock tick of 55ms :'^M^J) ;

  Goes := 0 ; SumRat := 0.0 ; Cnt := Random(256) ; Cnt := Random(256) ;
  Writeln('Slen Ndx Cnt; Base  Loops, SysS  Loops   L, OurS  Loops   L;',
    {$IFDEF DEBUG} ' :Match' {$ELSE} ' Ratio :Match AvRat' {$ENDIF} ) ;
  Writeln('Bad Params :-') ;
  Compare( 20, -10,   4) ;
  Compare( 20,  10,  -4) ;
  Compare( 20,  10, 999) ;
  Compare( 20, 999,   4) ;
  Writeln('Off String :-') ;
  Compare( 20, 110,   4) ;
  Compare( 20,  10,  44) ;
  Writeln('Borderline :-') ;
  Compare(  0,   0,   5) ;
  Writeln('Systematic :-') ;
  Compare( 20,  10,   4) ;
  Compare(250,  10,   4) ;
  Compare(250, 240,   4) ;
  Compare(255,   2, 253) ;
  for Cnt := 9 to 13 do Compare( 20, 10, Cnt) ;
  {$IFDEF ALL}
  for Slen := 0 to 255 do
    for Ndx := -2 to Slen+2 do
    for Cnt := -2 to 257 do Compare(Slen, Ndx, Cnt) ; {$ENDIF}
  Writeln('Randomised :-') ;
  repeat
    Slen := Random(256) ;
    Ndx  := Random(Slen    +10) - integer(5) ;
    Cnt  := Random(Slen-Ndx+10) - integer(5) ;
    until Compare(Slen, Ndx, Cnt) ;
  end ;
Cap ; Readln ;
END.

Tkr access can err hourly; Do NOT run across midnight.

Consider also using PChar