{  -------   string.inc.pas -------

                string functions for p5x

A set of functions to manipulate strings in pascal.


Here, a string is part of a packed array of characters, but null terminated
except the null termination is not used when the string has maximum length.

eg,

var
   // STRING is defined in the c preprocessor, so must be CAPITALISED
   myStr : STRING(6);
begin
   myStr := 'hello';       // myStr = ['h', 'e', 'l', 'l', 'o', 0]
   writeln(myStr);         // prints 'hello'
   strAppend(myStr, '!');  // myStr = ['h', 'e', 'l', 'l', 'o', '!']
   writeln(myStr);         // prints 'hello!'
   setstrlen(myStr, 2);    // myStr = ['h', 'e', 0, ...]
   writeln(myStr);         // prints 'he'

}

#define STRING(a) packed array[1 .. a] of char

type
   strIndex =  1..maxint;

{: return maximum length of a string }
function strmax(s : packed array[one..len :strIndex] of char) : strIndex;
begin
   strmax := len;
end; { strmax }

{: return actual length of a string }
{@@ static int  strPos_1(const strIndex_1, const strIndex_1 , void *const, const strIndex_1, const strIndex_1, void *const)  __attribute__ ((pure)); @@}
function strlen(s : packed array[one..len :strIndex] of char) : integer;
var i : integer;
begin
   i := 1;
   while (i <= len) and (s[i] <> chr(0)) do
      i := i+1;
   strlen := i-1;
end; { strlen }

{: set actual length of a string }
procedure setstrlen(var s : packed array[one..len :strIndex] of char;
                        n : integer);
begin
   if n < len then
      s[n+1] := chr(0);
end; { setstrlen }

{: extract substring from src, result in dst, starting from pos, count chars}
procedure str(    src   : packed array[lo..hi :strIndex] of char;
                  pos   : strIndex;
                  count : integer;
              var dst   : packed array[one..len :strIndex] of char);
var i,j : integer;
begin
   if count  < 0 then begin
      writeln('str(): negative count');
      halt;
   end
   else if count  > len then begin
      writeln('str(): destination string too short');
      halt;
   end;
   if pos + count - 1 > strlen(src) then begin
      writeln('str(): pos too large');
      halt;
   end;
   j := 1;
   i := pos;
   while j <= count do begin
      dst[j] := src[i];
      j := j+1;
      i := i+1;
   end; {while}
   setstrlen(dst, count);
end; { str }

{: assign str2 to str1}
procedure strAssign(var str1 : packed array[lo..hi :strIndex] of char;
                        str2 : packed array[one..len :strIndex] of char);
var i : integer;
begin
   for i := 1 to strlen(str2) do begin
      if i > hi then begin
         writeln('strassign too long');
         halt;
      end;
      str1[i] := str2[i];
   end;
   setstrlen(str1, i);
end; { strassign }

{: append str2 onto end of str1}
procedure strAppend(var str1 : packed array[lo..hi :strIndex] of char;
                        str2 : packed array[one..len :strIndex] of char);
var i,j : integer;
begin
   i := strlen(str1);
   for j := 1 to strlen(str2) do begin
      i := i+1;
      if i > hi then begin
         writeln('strappend too long');
         halt;
      end;
      str1[i] := str2[j];
   end;
   setstrlen(str1, i);
end; { strappend }

{: delete substring from s, starting from pos, count chars}
procedure strDelete( var s : packed array[one..len :strIndex] of char;
                         pos   : strIndex;
                         count : integer);
var i,j,l : integer;
begin
   if pos + count > len then begin
      writeln('error in strdelete()');
      halt;
   end;
   j := pos;
   i := pos+count;
   l := strlen(s);
   while i <= l do begin
      s[j] := s[i];
      j := j+1;
      i := i+1;
   end; {while}
   setstrlen(s, j-1);
end; { strdelete }

{: strip leading blanks from string}
procedure strltrim(var s : packed array[one..len :strIndex] of char);
var i,j : strIndex;
begin
   i := 1;
   while (i <= len) and (s[i] <= ' ') do
      i := i+1;

   {s[i] is first non-blank char}
   j := 1;
   while i <= len do begin
      s[j] := s[i];
      i := i+1;
      j := j+1;
   end;
   setstrlen(s, j-1);
end; { strltrim }

{: strip trailing blanks from string}
procedure strrtrim(var s : packed array[one..len :strIndex] of char);
var i : integer;
begin
   i := strlen(s);
   while (i >= 1) and (s[i] = ' ') do
      i := i-1;

   {s[i] is last non-blank char}
   setstrlen(s, i);
end; { strrtrim }

{: find position of str2 in str1,
   return 0 if not found}
function strPos(str1 : packed array[lo..hi :strIndex] of char;
                str2 : packed array[one..len :strIndex] of char) : integer;
var i,j,l    : integer;
    foundPos : integer;
begin
   foundPos := 0;
   l := strlen(str2);
   i := 1;
   while (i <= strlen(str1) - l + 1) and (foundPos = 0) do begin
      j := 1;
      while (j <= l) and (str1[i+j-1] = str2[j]) do
         j := j+1;
      if j > l then
         foundPos := i;
      i := i+1;
   end; {while}
   strPos := foundPos;
end; { strPos }

{: insert str into str at position pos}
procedure strInsert(    str : packed array[lo..hi :strIndex] of char;
                    var dst : packed array[one..len :strIndex] of char;
                        pos :strIndex );
var i, ls, ld : integer;
begin
   ld := strlen(dst);
   ls := strlen(str);
   if ld + ls > len then begin
      writeln('string to long to insert');
      halt;
   end;
   if pos > ld+1 then begin
      writeln('strInsert pos too large');
      halt;
   end;
   for i := ld downto pos do
      dst[i+ls] := dst[i];
   for i := 1 to ls do
      dst[pos+i-1] := str[i];
   setstrlen(dst, ld+ls);
end; { strInsert }

{: write real number to string, overwrite existing contents
   x    real number to write
   str  string
   pos  start position
   wid  field width, -ve for left justified

You must ensure that the number fits within the field width.
When the number needs more space than is available it will be replaced
by '#' characters, but this feature should not be relied on.
}
procedure strwrnum(    x   : real;
                   var str : packed array [one .. max : strIndex] of char;
                       pos : strIndex; wid : integer );
var
   n,len : integer;
begin
   if pos+abs(wid)-1 > max then begin
      writeln('strwrnum: number width too big');
      halt;
   end;

   len := strlen(str);

   {output is n.nn or n.nne+nn, whichever has more sig digits}
   {@@ {}
      const int aw = abs(wid_2);
      char s[aw+1]; // need terminating null
      const double ax = fabs(x_2);

      // find largest number that fits in wid spaces,
      // including sign, decimal point and first decimal digit
      const double xlim = (ax>=1 && aw>=3)? __builtin_powi(10, aw-3): 0;

      // least significant digit that fits in wid spaces,
      // after sign, decimal point and leading zero
      const double xlsd = (ax<1 && aw>3)? __builtin_powi(10, 3-aw): 0;


      // sig digits, after space for sign & decimal point
      int sig = aw - 2;
      if( ax+xlsd/2 < 1.0) sig--; // lose one for leading zero
      if( ax+xlsd/2 < 0.1) sig--;
      if( ax+xlsd/2 < 0.01) sig--;
      if( ax == 0) sig=1;

      if(ax >= 0.5
         && ((aw == 2 && ax < 9.5)
             || ax<100*xlim - 0.5 && (ax>=xlim || ceil(x_2)==x_2) )
          ) {
         // format nnn
         //printf("use fixed notation, without decimal point\n");
         n_2 = snprintf(s, aw+1, "% *.0f", wid_2, round(x_2) );
      }
      else if( (ax >= 1 && ax < xlim)
         || (ax >= 0.001 && ax < 1 && sig >= 1)
         || (x_2 == 0 && aw >= 2)
        ) {
         // format nn.nnn
         //printf("use fixed notation\n");
          n_2 = snprintf(s, aw+1, "% *.*g", wid_2, sig, x_2 );
      }
      else if( aw==6 || aw==7) {
         // format ne+00
         //printf("use minimum exp notation\n");
         n_2 = snprintf(s, aw+1, "% *.0e", wid_2, x_2);
      }
      else if( aw>7 ) {
         // format n.ne+00
         //printf("use exp notation\n");
         n_2 = snprintf(s, aw+1, "% *.*g", wid_2, aw-6, x_2);
      }
      else {
         // x cannot fit into allocated space
         //printf("too big\n");
         for(n_2=0; n_2<aw; n_2++) s[n_2] = '#';
      }

      if( n_2 > aw )
         for(n_2=0; n_2<aw; n_2++) s[n_2] = '#';

      strncpy((char*)str_2c+pos_2-1, s, aw);
   @@}

   {if n <> abs(wid) then
      writeln('n is ', n, ', wid is ', wid, ', x is ', x );}

   if pos+abs(wid) > len then
      setstrlen(str, pos+abs(wid)-1);
end; { strwrnum }

{:read string str from text file f, up to end of line
  skip leading blanks}
procedure readString(var f   : text;
                     var str : packed array [one .. max : strIndex] of char);
var
   c    : char;
   i    : integer;
begin
   i := 0;
   while not eof(f) and not eoln(f) and (i < max) do begin
      read(f, c);
      if (c > ' ') or (i<>0) then begin
         i := i+1;
         str[i] := c;
      end;
   end;
   setstrlen(str, i);
   if not eof(f) then
      readln(f);
end; { readString }

{  ------- end of string.inc.pas ------- }
