RosettaCodeData/Task/Increment-a-numerical-string/Free-Pascal-Lazarus/increment-a-numerical-string.pas

program StrInc;
//increments a positive numerical string in different bases.
//the string must be preset with a value, length >0 ;
{$IFDEF WINDOWS}
  {$APPTYPE CONSOLE}
{$ENDIF}
{$IFDEF FPC}
  {$Mode Delphi} {$Optimization ON,ALL}{$Align 32}
  uses
    sysutils;
{$ELSE}
  uses
    system.SysUtils;
{$ENDIF}
type
  tMyNumString = Ansistring; //string[31];//

function IncLoop(ps: pChar;le,Base: NativeInt):NativeInt;inline;
//Add 1 and correct carry
//returns 0, if no overflow, else 1
var
  dgt: nativeInt;
Begin
  //convert base to the highest char in base  2 > '1' ;10 -> '9'
  base += Ord('0')-1;
  dec(le);//ps is 0-based

  result := 0;
  repeat
    dgt := ord(ps[le]);
    IF dgt < base then
    begin
      ps[le] := chr(dgt+1);
      EXIT;
    end;
    ps[le] := '0';
    dec(le);
  until (le<0);
  result:= 1;
end;

procedure IncIntStr(base:NativeInt;var s:tMyNumString);
var
  le: NativeInt;
begin
  le := length(s);
  //overflow -> prepend a '1' to string
  if (IncLoop(pChar(@s[1]),le,base) <>0) then
  Begin
//    s := '1'+s;
    setlength(s,le+1);
    move(s[1],s[2],le);
    s[1] := '1';
  end;
end;

procedure IncMyString(var NumString: tMyNumString);
var
	i: integer;
	f_code: word;
begin
  // string to num
  val(Numstring,i,f_code);
  //num to string
  if f_code= 0 then
    str(i+1,NumString);
end;

procedure IncMyStringOrg(var NumString: tMyNumString);
var
  i: integer;
begin
  readStr(NumString, i);
  writeStr(NumString, succ(i));
end;

const
  strLen = 26;
  MAX = 1 shl strLen -1;

var
  s  : tMyNumString;
  i,base : nativeInt;
  T0: TDateTime;
Begin
  writeln(MAX,' increments in base');
  For base := 2 to 10 do
  Begin
    //s := '0' doesn't work
    setlength(s,1);
    s[1]:= '0';
{   //Zero pad string
    setlength(s,strLen);fillchar(s[1],strLen,'0');
}
    T0 := time;
    For i := 1 to MAX do
      IncIntStr(Base,s);
    T0 := (time-T0)*86400;
    if base = 10 then
      writeln(' IncAnsiString '); ;
    writeln(s:strLen,' base ',base:2,T0:8:3,' s');
  end;

  writeln(' val -> str ');
  setlength(s,1);
  s[1]:= '0';
  T0 := time;
  For i := 1 to MAX do
    IncMyString(s);
  T0 := (time-T0)*86400;
  writeln(s:strLen,' base ',10:2,T0:8:3,' s');

  writeln(' readstr -> writestring ');
  setlength(s,1);
  s[1]:= '0';
  T0 := time;
  For i := 1 to MAX do
    IncMyStringOrg(s);
  T0 := (time-T0)*86400;
  writeln(s:strLen,' base ',10:2,T0:8:3,' s');

  s:='';
 {$IFDEF WINDOWS}
    readln;
  {$ENDIF}
end.