Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TPROUTN.ZIP/STRNGLIB.INC

Text File | 1985-05-17 | 8.3 KB | 308 lines

{ Suplementry String functions and procedures For Turbo Pascal  }
Type
  LString = String[80];

function LoCase(InChar: Char): Char;
{ convert a Character to lower case }
Begin
   If InChar IN ['A'..'Z'] then
      LoCase := Chr(Ord(InChar)+32)
   Else
      LoCase := InChar
End;

function LowerCase(InpStr: LString): LString;
{ convert a String to lower case Characters }
Var i : Integer;
Begin
   For i := 1 to Length(InpStr) do
       LowerCase[i] := LoCase(InpStr[i]);
   LowerCase[0] := InpStr[0]
End;

function UpperCase(InpStr: LString): LString;
{ convert a String to upper case Characters }
Var i : Integer;
Begin
   For i := 1 to Length(InpStr) do
       UpperCase[i] := UpCase(InpStr[i]);
   UpperCase[0] := InpStr[0]
End;

function TrimL(InpStr: LString): LString;
{ strip leading spaces from a String }
Var i,len : Integer;
Begin
   len := length(InpStr);
   i := 1;
   While (i <= len) and (InpStr[i] = ' ') do
      i := i + 1;
   TrimL := Copy(InpStr,i,len-i+1)
End;

function TrimR(InpStr: LString): LString;
{ strip trailing spaces from a String }
Var i : Integer;
Begin
   i := length(InpStr);
   While (i >= 1) and (InpStr[i] = ' ') do
      i := i - 1;
   TrimR := Copy(InpStr,1,i)
End;

function PadL(InpStr: LString; FieldLen: Integer): LString;
{ Pad String on left with spaces to fill to the desired field length }
Var  STemp : LString;
         i : Integer;
Begin
   If FieldLen >= SizeOF(InpStr) then
      FieldLen := SizeOf(InpStr)-1;
   If length(InpStr) > FieldLen then
      PadL := Copy(InpStr,1,FieldLen)
   Else
      Begin
        STemp := InpStr;
        For i := Length(STemp)+1 to FieldLen do
           Insert(' ',STemp,1);
        PadL := STemp
      End
End;

function PadR(InpStr: LString; FieldLen: Integer): LString;
{ Pad String on right with spaces to fill to the desired field length }
Var  STemp : LString;
         i : Integer;
Begin
   If FieldLen >= SizeOF(InpStr) then
      FieldLen := SizeOf(InpStr)-1;
   If length(InpStr) > FieldLen then
      PadR := Copy(InpStr,1,FieldLen)
   Else
      Begin
        STemp := InpStr;
        For i := Length(STemp)+1 to FieldLen do
           STemp := STemp + ' ';
        PadR := STemp
      End
End;

function JustL(InpStr: LString; FieldLen: Integer): LString;
{ Left justify the String within the given field length }
Begin
   JustL := PadR(TrimL(InpStr),FieldLen)
End;

function JustR(InpStr: LString; FieldLen: Integer): LString;
{ Right justify the String within the given field length }
Begin
   JustR := PadL(TrimR(InpStr),FieldLen)
End;

function Center(InpStr: LString; FieldLen: Integer): LString;
{ Center a String within a specified field length;  the String
  is padded on both sides with spaces }
Var LeadSpaces : Integer;
        STemp : LString;
Begin
   { strip leading and trailing spaces; determine the
     Number of spaces needed to center the String }
   STemp := TrimR(TrimL(InpStr));
   LeadSpaces := (FieldLen - Length(STemp) + 1) div 2;
   { insert leading spaces then trailing spaces }
   Center := PadR(PadL(STemp,FieldLen-LeadSpaces),FieldLen)
End;

procedure GString(InpStr, DelStr: LString; span: boolean;
                  Var cpos, dpos: Integer; Var OutStr: LString);
{ Return a String containing all Characters starting at position, cpos,
 of the source String up to the first first occurence of any of several
 delimiters.  The position of the found delimiter is returned as well
 as which delimiter.
}
Var done : boolean;
Begin
   OutStr := ''; dpos := 0;
   If cpos > 0 then
      Begin
        done := false;
        While (cpos <= Length(InpStr)) and not done do
           Begin
             dpos := pos(InpStr[cpos],DelStr);
             If span xor (dpos = 0) then
                Begin
                  OutStr := OutStr + InpStr[cpos];
                  cpos := cpos + 1
                End
             Else
               done := true
           End;
      If (span xor (dpos = 0)) or (cpos > length(InpStr)) then cpos := 0
    End
End;

function GetStr(InpStr: LString; Delim: Char): LString;
{ Return a String containing all Characters starting at the
  first position of the source String up to the first delimiter.
}
Var i : Integer;
Begin
   i := Pos(Delim,InpStr);
   If i = 0 then
      Begin
        GetStr := InpStr;
        InpStr := ''
      End
   Else
      Begin
        GetStr := Copy(InpStr,1,i-1);
        Delete(InpStr,1,i)
      End
End;

function Break(InpStr: LString; DelStr: LString): LString;
{ Emulate SNOBOL BREAK function }
Var cp, dp : Integer;
    OutStr : LString;
Begin
   cp := 1;
   GString(InpStr,DelStr,false,cp,dp,OutStr);
   Break := OutStr;
   If cp = 0 then
      InpStr := ''
   Else
      Delete(InpStr,1,cp-1)
End;

function Span(InpStr: LString; DelStr: LString): LString;
{ Emulate SNOBOL SPAN function }
Var cp, dp : Integer;
    OutStr : LString;
Begin
   cp := 1;
   GString(InpStr,DelStr,true,cp,dp,OutStr);
   Span := OutStr;
   If cp = 0 then
      InpStr := ''
   Else
      Delete(InpStr,1,cp-1)
End;

Procedure RealStr(Valu: Real; Base, Trail: Integer;
                  Var OutStr: LString);
{ Convert a real value to a String }
Var
   i, digit, MaxLen : Integer;
   IntValu, FracValu : real;
   Sign : boolean;

function NewDigit(num:Integer): Char;
Begin
   If num < 10 then
      NewDigit := chr(num + ord('0'))
   Else
      NewDigit := chr(num + ord('A') - 10)
End;

Begin
   MaxLen := SizeOf(OutStr);
   If Valu < 0 then
      Begin
        Valu := - Valu;
        Sign := true
      End
   Else
      Sign := false;
   IntValu := Int(Valu);
   FracValu := Frac(Valu);
   If Valu < 1 then
      OutStr := '0'
   Else
      Begin
      { convert Leading digits to a String }
        OutStr := '';
        While (IntValu >= 1) and (Length(OutStr) < MaxLen) do
           Begin
             Valu := IntValu / Base;
             Digit := Trunc(Round(Frac(Valu)*Base));
             IntValu := Int(Valu);
             Insert(NewDigit(digit),OutStr,1);
           End
      End;
   If (Trail > 0) and ( length(OutStr) < MaxLen) then
      Begin
      { convert trialing digits }
        OutStr := OutStr + '.';
        i := 1;
        While (Length(OutStr) < MaxLen) and (i <= Trail) do
           Begin
             Valu := FracValu * Base;
             Digit := Trunc(Valu);
             FracValu := Frac(Valu);
             OutStr := OutStr + NewDigit(Digit);
             i := i + 1
           End
      End;
    If sign then Insert('-',OutStr,1);
End;

Procedure RealVal(InpStr: LString; Base: Integer;
                  Var Err: Integer; Var Valu: real);
{ convert a String to a real value }
Var
  i, digit : Integer;
  GotRadixPoint,GotDigit,Negate : boolean;
  InChar : Char;
  InvBase : real;
Begin
   Valu := 0;
   Err := 0;
   negate := false;
   i := 0;
   InvBase := 1;
   GotRadixPoint := false;
   While (i < length(InpStr)) and (err = 0) do
     Begin
        i := i + 1;
        GotDigit := false;
        InChar := UpCase(InpStr[i]);
        case InChar of
          '0'..'9':
             Begin
               digit := ord(InpStr[i]) - ord('0');
               GotDigit := true
             End;
          'A'..'Z':
             Begin
               digit := ord(InChar) - ord('A') + 10;
               GotDigit := true
             End;
          '-' :
             Begin
               If negate then
                 err := i
               Else
                 negate := true
             End;
          '+' : If negate then err := i;
          '.' : If GotRadixPoint then
                      err := i
                   Else
                      GotRadixPoint := true;
         Else    err := i
         End  {case} ;
      If GotDigit then
         If digit >= base then
            err := i
         Else
            If GotRadixPoint then
               Begin
                 InvBase := InvBase / base;
                 Valu := Valu + InvBase * digit
               End
            Else
               Valu := Valu * base + digit
      End; { While }
   If negate then
      valu := - valu;
End;