#ifndef STRING_INC_PAS
#define STRING_INC_PAS

{  -------   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..maxlen :strIndex] of char) : strIndex;
{@@ __attribute__ ((const)) @@} inline;
begin
   strmax := maxlen;
end; { strmax }

{: return actual length of a string }
function strLen(s : packed array[one..maxlen :strIndex] of char)
     : integer  {@@ __attribute__ ((const)) @@};
var i : strIndex;
begin
   i := 1;
   while (i <= maxlen) 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..maxlen :strIndex] of char;
                        n : integer); inline;
begin
   if n < maxlen then
      s[n+1] := chr(0);
end; { setstrlen }

{: return upper case char}
function toupper(c : char): char; {@@ __attribute__ ((const)) @@} inline;
begin
   if c in ['a'..'z'] then
      Toupper := chr(ord(c) - ord('a') + ord('A'))
   else
      Toupper := c
end; { Toupper }

{: return lowper case char}
function tolower(c : char): char; {@@ __attribute__ ((const)) @@} inline;
begin
   if c in ['A'..'Z'] then
      tolower := chr(ord(c) - ord('A') + ord('a'))
   else
      tolower := c
end; { tolower }

{: 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..maxlen :strIndex] of char);
var i,j : integer;
begin
   if count  < 0 then begin
      writeln('str(): negative count');
      halt;
   end
   else if count  > maxlen 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..maxlen :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..maxlen :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..maxlen :strIndex] of char;
                         pos   : strIndex;
                         count : integer);
var i,j,l : integer;
begin
   if pos + count > maxlen 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..maxlen :strIndex] of char);
var i,j : strIndex;
begin
   i := 1;
   while (i <= maxlen) and (s[i] <= ' ') do
      i := i+1;

   {s[i] is first non-blank char}
   j := 1;
   while i <= maxlen 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..maxlen :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..maxlen :strIndex] of char)
              : integer {@@ __attribute__ ((const)) @@};
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..maxlen :strIndex] of char;
                        pos :strIndex );
var i, ls, ld : integer;
begin
   ld := strLen(dst);
   ls := strLen(str);
   if ld + ls > maxlen then begin
      writeln('string too 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 }


{: Compare s1 and s2.  s1 ands2 may have different max lengths.
if s1 and s2 are the same type, it's better to use 'if s1 = s2 then ...'
   return 1 iff s1 > s2
          0 iff s1 = s2
         -1 iff s1 < s2 }
function strCompare(s1 : packed array [lo1 .. hi1 : strIndex] of char;
                    s2 : packed array [lo2 .. hi2 : strIndex] of char
                    ) : integer {@@ __attribute__ ((pure)) @@};
var
   result  : integer;
   d       : integer;
   i,m1,m2 : integer;
begin

   m1 := strLen(s1);
   m2 := strLen(s2);
   if m1 > m2 then
      d := m2
   else
      d := m1;
   { d := min(m1, m2) }

   i := 1;
   result := 99;
   while result = 99 do begin
      if s1[i] < s2[i] then
         result := -1
      else if s1[i] > s2[i] then
         result := +1
      else if i < d then
         i := i+1
      else  begin
         d := m1 - m2;
         if d > 0 then
            result := 1
         else if d < 0 then
            result := -1
         else
            result := 0
      end
   end;
   strCompare := result;
end; { strCompare }


{: 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 }


{: find value of real number from string
   str where the number is
   pos look here for the number
   OK true iff x is a valid number }
procedure strval( str : packed array[one..shi : integer] of char;
                  pos : strIndex;
               var x  : real;
               var ok : boolean );
var
   number, fracPart : real;
   pwr10, scale     : real;
   exp              : integer;
   i                : strIndex;
   neg, eneg        : boolean;

begin

   ok := false;
   if pos  > shi then begin
      writeln('strval(): pos outside range of string');
      halt;
   end;
   i := pos;
   neg := false;

   while (i <= shi) and (str[i] <= ' ') do begin    {skip leading white space}
      i := i+1;
   end;

   if (i <= shi) and (str[i] in ['+','-']) then begin
      if str[i] = '-' then
         neg := true;
      i := i+1;
   end;

   number := 0;
   while (i <= shi) and (str[i] in ['0'..'9']) do begin
      {TODO: check for overflow}
      number := number*10 + ord(str[i]) - ord('0');
      i := i+1;
      ok := true; {we have a valid number}
   end;

   if (i <= shi) and (str[i] = '.') then begin
      {found a fractional part}
      i := i+1;
      fracPart := 0;
      scale := 1;
      while (i <= shi) and (str[i] in ['0'..'9']) do begin
         {TODO: check for overflow}
         fracPart := fracPart*10 + ord(str[i]) - ord('0');
         scale := scale*10;
         i := i+1;
         ok := true; {we have a valid number}
      end;
      number := number + fracPart / scale;
   end;

   if (i <= shi) and (str[i] in ['e','E']) then begin
      {found exponent}
      exp := 0;
      i := i+1;
      eneg := false;
      if (i <= shi) and (str[i] in ['+','-']) then begin
         if str[i] = '-' then
            eneg := true;
         i := i+1;
      end;
      while (i <= shi) and (str[i] in ['0'..'9']) do begin
         {TODO: check for overflow}
         exp := exp*10 + ord(str[i]) - ord('0');
         i := i+1;
      end;
      scale := 1;
      pwr10 := 10;
      while exp <> 0 do begin
         if odd(exp) then
            scale := scale * pwr10;
         pwr10 := sqr(pwr10);
         exp := exp div 2;
      end;
      if eneg then
         number := number / scale
      else
         number := number * scale;
   end;

   if neg then
      x := -number
   else
      x := number;

end; { strval }


{: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 ------- }

#endif // STRING_INC_PAS
