Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/CONSULTP.ZIP/LIBRARY.PAS

Pascal/Delphi Source File | 1988-06-24 | 9.4 KB | 403 lines

Unit Library;

INTERFACE
{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}


{Library of Turbo Pascal Routines}
{Brian Corll November 27, 1987}



Uses
  Crt,
  Dos;

Type
  TextArrayType = Array[1..3000] of String[6];
  ParseType = String[6];
  ShortString = String[30];
  String80 = String[80];
  Regs =
             Record Case Boolean of
             True : (al,ah,bl,bh,cl,ch,dl,dh : Byte);
             False : (ax, bx, cx, dx, bp,si,di,ds,es,Flags : Registers);
                 end;
Procedure Off;
Procedure On;
procedure Beep(Tone,Duration : integer);
function UpperCase(InpStr: String80): String80;
function TrimL(InpStr: String80): String80;
function TrimR(InpStr: String80): String80;
function PadR(InpStr: String80; FieldLen: Integer): String80;
Procedure BlockCurs;
Function Words ( S : String ) : Integer;
Function OneWord  ( S : String; N : Integer ) : String;
Procedure FindWord(var TextArray : TextArrayType;LineCount,Position : Integer;
          TextKey : ParseType;var Result : Integer);

IMPLEMENTATION

Procedure On;
begin
  Inline($31/$C0/$8E/$C0/$26/$A1/$60/$04/$80/$E4/$DF/$89/$C1/$B4/$01/$CD/$10);
end;

Procedure Off;
begin
  Inline($31/$C0/$8E/$C0/$26/$A1/$60/$04/$80/$E4/$BF/$80/$CC/$20/$89/$C1/$B4/
    $01/$CD/$10);
end;

Function STRIP ( S : String80;
                 C : Char) : String80;
                 { Removes all leading and trailing
                   C characters from S }
begin
   InLine ( $1E/
            $8D/$7E/$07/
            $8A/$4E/$06/
            $30/$ED/
            $8C/$D0/
            $8E/$C0/
            $8B/$46/$04/
            $83/$F9/$01/
            $77/$0E/
            $8A/$5E/$07/
            $30/$FF/
            $39/$D8/
            $74/$35/
            $8B/$D7/
            $EB/$1D/$90/
            $FC/
            $F3/$AE/
            $E3/$2B/
            $4F/
            $8B/$D7/
            $8A/$4E/$06/
            $30/$ED/
            $8D/$7E/$07/
            $01/$CF/
            $4F/
            $FD/
            $F3/$AE/
            $47/
            $8B/$CF/
            $29/$D1/
            $41/
            $88/$8E/$06/$01/
            $8B/$F2/
            $8D/$BE/$07/$01/
            $8C/$D0/
            $8E/$D8/
            $FC/
            $F3/$A4/
            $EB/$07/$90/
            $C7/$86/$06/$01/$00/$00/
            $1F/$5D);
end;
procedure Beep(Tone,Duration : integer);
 begin
   Sound(Tone); Delay(Duration); NoSound;
 end;

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: String80): String80;
{ 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: String80): String80;
{ 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: String80): String80;
{ 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: String80): String80;
{ 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: String80; FieldLen: Integer): String80;
{ Pad String on left with spaces to fill to the desired field length }
Var  STemp : String80;
         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: String80; FieldLen: Integer): String80;
{ Pad String on right with spaces to fill to the desired field length }
Var  STemp : String80;
         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: String80; FieldLen: Integer): String80;
{ Left justify the String within the given field length }
Begin
   JustL := PadR(TrimL(InpStr),FieldLen)
End;

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



Function Isupper(var Atom : ShortString) : Boolean;
Begin
     If Atom[1] in ['A'..'Z'] then Isupper := TRUE
     else Isupper := FALSE;

end;

Function Islower(var Atom : ShortString) : Boolean;
Begin
     If Atom[1] in ['a'..'z'] then Islower := TRUE
     else Islower := FALSE;

end;

Function Isalpha(var Atom : Shortstring) : Boolean;
var
i : Integer;
Letter : Char;

Begin
     i := 1;
     For i := 1 to Length(Atom) do
     Letter := Atom[i];
     Letter := Upcase(Letter);
     If Letter in ['A'..'Z'] then Isalpha := TRUE
     else Isalpha := False;

end;

{ ---------------------------------------
  WORDS returns the number of words in S.
  --------------------------------------- }
Function Words ( S : String ) : Integer;
var
   NumWords,  CurrentAddress, Len
             : integer;

begin
   S := TrimL(TrimR(S));
   Len := Length(S);
   if Len = 0 then
      Words := 0
   else
   begin
      NumWords := 1;
      CurrentAddress := 1;
      for CurrentAddress := 1 to Len do
         if S[CurrentAddress] = #32 then
            NumWords := NumWords + 1;
      Words := NumWords;
   end;
end { Words };

{ ----------------------------
  WORDIND returns the position
  of WordNumber in S.
  ---------------------------- }
Function WordInd (          S : String80;
                   WordNumber : Integer ) : Integer;

{ Example: if S = 'I like Turbo Pascal' then
              WordInd ( S, 3 ) = 8.  }

var
   NumWords,  CurrentAddress, Len, Index
             : integer;
   NonBlank :  Boolean;

begin
   Len := Length(S);
   if Len = 0 then
      WordInd := 0
   else
   begin
      Index := 0;
      NumWords := 0;
      CurrentAddress := 0;
      NonBlank := false;
      repeat
         CurrentAddress := CurrentAddress + 1;
         if NonBlank then
         begin
            if S[CurrentAddress] = #32 then
               NonBlank := false;
         end
         else
         if S[CurrentAddress] <> #32 then
         begin
            NumWords := NumWords + 1;
            if NumWords = WordNumber then
               Index := CurrentAddress;
            NonBlank := true;
         end;
      until (CurrentAddress = Len) or (Index > 0);
      WordInd := Index;
   end;
end { WordInd };

Procedure BlockCurs;
Var
   Reg : Registers;

begin
     with Reg do
     begin
     ch := 01;
     cl := 12;
     ah := 1;
     Intr($10,Reg)
     end
end;

Function OneWord  ( S : String; N : Integer ) : String;

var
   NumWords, start, stop, CurrentAddress, len
             : integer;
   Ts
             : String80;
   BlankFound
             : Boolean;


begin
   if Length(S) = 0 then
      OneWord := ''
   else
   begin
      NumWords := 0;
      start := 1;
      len := length(S);
      stop := len;
      BlankFound := True;
      CurrentAddress := 0;

      repeat
         CurrentAddress := CurrentAddress + 1;
         if BlankFound then
         begin
            if S[CurrentAddress] <> #32 then
            begin
               BlankFound := false;
               NumWords := NumWords + 1;
               if NumWords = N then
                  start := CurrentAddress;
            end;
         end
         else
         if S[CurrentAddress] = #32 then
         begin
            BlankFound := true;
            if NumWords = N then
               stop := CurrentAddress;
         end;
      until (stop < len) or (CurrentAddress = len);

      if N > NumWords then
         OneWord := ''
      else
      begin
         if S[stop] <> #32 then
            stop := succ(stop);
         OneWord := copy ( S, start, stop - start );
      end;
   end;
end { OneWord };

Procedure FindWord(var TextArray : TextArrayType;LineCount,Position : Integer;
          TextKey : ParseType;var Result : Integer);


var
   Low,High,J,Width : Integer;

begin
   Result := -1;
   Width := Length(TextKey);
   if width <1 then exit;
   low := 1;
   high := LineCount;
   while high>=low do
   begin
        J := (low + high) div 2;
        if textkey<copy(textarray[J],Position,width) then
        high := j-1
        else
        if textkey>copy(textarray[J],position,width) then
        low := j+1
        else
        begin
        result :=j;
        exit
        end
        end
        end;
END.