World of Shareware - Software Farm 2/wosw_2.zip/wosw_2/PASCAL/PSSTR102.ZIP/STRINGS.PAS

Pascal/Delphi Source File | 1993-01-01 | 18KB | 831 lines

{

                                                      ╔══════════════════╗
                                                      ║ String, Variable ║
                                                      ║   and Keyboard   ║
                                                      ║    Utilities     ║
                                                      ║    Rev. 1.02     ║
                                                      ╚══════════════════╝

}

{$F-} {$O-} {$A+} {$G-}
{$V-} {$B-} {$X-} {$N+} {$E+}

{$I FINAL.PAS}

{$IFDEF FINAL}
  {$I-} {$R-}
  {$D-} {$L-} {$S-}
{$ENDIF}

Unit Strings;

Interface

Uses CRT,DOS;

Const
  MaxXYSaves        =    5;                  {Max Number of Cursor Saves}
  LeftText          =    0;
  CentreText        =    1;
  RightText         =    2;
  OutSideText       =    3;

Type
  TextFormats       = LeftText..RightText;
  JustifyFormats    = LeftText..OutSideText;
  XYType            = (CursorX,CursorY);
  XYPosData         = Array[1..MaxXYSaves] of
                        Array [XYType] of Byte;
  KeyBufferFunction = (Clear,Save,Restore);


Procedure SpacesToZeros (StIn:String;Var StOut:String);
Function  PosFrom       (SubS:String;StIn:String;FarIn:Byte):Byte;
Function  RevPosFrom    (SubS:String;StIn:String;FarIn:Byte):Byte;
Procedure UpperCase     (StIn:String;Var StOut:String);
Procedure PadVar        (StIn:String;Var StOut:String;Count:Byte);
Procedure PadVarWith    (StIn:String;Var StOut:String;Count:Byte;
                                                      WithMe:Char);
Procedure FormatVar     (StIn:String;Var StOut:String;
                         Size:Byte;Format:TextFormats);
Procedure UnPadVar      (StIn:String;Var StOut:String);
Procedure UnPadVarRight (StIn:String;Var StOut:String);
Procedure UnPadVarLeft  (StIn:String;Var StOut:String);
Procedure RightJustify  (StIn:String;Var StOut:String;
                         Margin:Byte;JType:JustifyFormats);
Procedure PadFileName   (StIn:String;Var StOut:String);

Function  AdjustMeter   (StartMeter1,EndMeter1,ValueMeter1,
                         StartMeter2,EndMeter2:LongInt):LongInt;

Function  MemoryCount   (P:Pointer):LongInt;
Procedure GetLowestOfs  (P:Pointer;Var S,O:Word);
Procedure AdjustPtr     (Var P:Pointer;Amount:LongInt);

Procedure SaveCursorSize(Var Data:Word);
Procedure RestCursorSize(Data:Word);
Procedure SaveXYPos     (Var Position:XYPosData);
Procedure RestXYPos     (Var Position:XYPosData);
Procedure CursorSize    (UpLim,DownLim:Byte);

Procedure PushCursorSize;
Procedure PopCursorSize;
Procedure PushXYPos;
Procedure PopXYPos;
Procedure PushTextColor;
Procedure PopTextColor;

Procedure KeyBuffer     (Option:KeyBufferFunction);

Procedure SwapBytes     (Var A,B:Byte);
Procedure SwapIntegers  (Var A,B:Integer);
Procedure SwapWords     (Var A,B:Word);
Procedure SwapLongInts  (Var A,B:LongInt);
Procedure SwapReals     (Var A,B:Real);
Procedure SwapSingles   (Var A,B:Single);
Procedure SwapDoubles   (Var A,B:Double);
Procedure SwapExtendeds (Var A,B:Extended);
Procedure SwapStrings   (Var A,B:String);

Implementation

Var
  PushPopCursorSize:Array[1..MaxXYSaves] of Word;
  PushPopTextColor :Array[1..MaxXYSaves] of Word;
  PushPopCursorPos :XYPosData;

Procedure SpacesToZeros(StIn:String;Var StOut:String); Assembler;

Asm
  push  ds
  cld
  lds   si,StIn
  les   di,StOut
  lodsb
  stosb
  xor   ah,ah
  xchg  ax,cx
  jcxz  @Section3

@Section1:

  lodsb
  cmp   al,' '
  jne   @Section2
  mov   al,'0'

@Section2:

  stosb
  loop  @Section1

@Section3:

  pop   ds

End;

Function PosFrom(SubS:String;StIn:String;FarIn:Byte):Byte;

Var
  NewPos:Byte;

Begin
  Delete(StIn,1,FarIn-1);
  NewPos:=Pos(SubS,StIn);
  If NewPos=0 Then
    PosFrom:=0
  Else
    PosFrom:=NewPos+FarIn-1;
End;

Function RevPosFrom(SubS:String;StIn:String;FarIn:Byte):Byte;

Var
  Mark  :Byte;
  Temp  :Byte;
  Chk   :String;

Begin
  If Length(SubS)>Length(StIn) Then
  Begin
    RevPosFrom:=0;
    Exit;
  End;

  Mark:=Length(StIn)-Length(SubS)+1;
  If Mark>FarIn Then Mark:=FarIn;
  Temp:=0;

  While (Mark>=1) And (Temp=0) do
  Begin
    Chk:=Copy(StIn,Mark,Length(SubS));
    If Chk=SubS Then
      Temp:=Mark
    Else
      Dec(Mark);
  End;
  RevPosFrom:=Temp;
End;

Procedure UpperCase(StIn:String;Var StOut:String); Assembler;

Asm
  push  ds
  cld
  lds   si,StIn
  les   di,StOut
  lodsb
  stosb
  xor   ah,ah
  xchg  ax,cx
  jcxz  @Section3

@Section1:

  lodsb
  cmp   al,'a'
  jb    @Section2
  cmp   al,'z'
  ja    @Section2
  sub   al,20h

@Section2:

  stosb
  loop  @Section1

@Section3:

  pop   ds

End;

Procedure PadVar(StIn:String;Var StOut:String;Count:Byte);

Var
   J:Byte;

Begin
  StOut:=StIn;
  For J:=1 to Count do
    StOut:=StOut+' ';
End;

Procedure PadVarWith(StIn:String;Var StOut:String;Count:Byte;WithMe:Char);

Var
   J:Byte;

Begin
  StOut:=StIn;
  For J:=1 to Count do
    StOut:=StOut+WithMe;
End;

Procedure FormatVar(StIn:String;Var StOut:String;
                    Size:Byte;Format:TextFormats);
Begin
  StOut:=StIn;

  If Format=LeftText Then
    While Length(StOut)<Size do
      StOut:=StOut+' '
  Else
    If Format=CentreText Then
    Begin
      While Length(StOut)<Size-1 do
        StOut:=' '+StOut+' ';
      Format:=RightText;
    End;

  If Format=RightText Then
    While Length(StOut)<Size do
      StOut:=' '+StOut;
End;

Procedure UnPadVar(StIn:String;Var StOut:String);
Begin
  StOut:=StIn;
  While (Length(StOut)>0) And (StOut[1]=' ') do
    Delete(StOut,1,1);
  While (Length(StOut)>0) And (StOut[Length(StOut)]=' ') do
    Delete(StOut,Length(StOut),1);
End;

Procedure UnPadVarRight(StIn:String;Var StOut:String);
Begin
  StOut:=StIn;
  While (Length(StOut)>0) And (StOut[Length(StOut)]=' ') do
    Delete(StOut,Length(StOut),1);
End;

Procedure UnPadVarLeft(StIn:String;Var StOut:String);
Begin
  StOut:=StIn;
  While (Length(StOut)>0) And (StOut[1]=' ') do
    Delete(StOut,1,1);
End;

Procedure RightJustify(StIn:String;Var StOut:String;
                       Margin:Byte;JType:JustifyFormats);

  Procedure RightJustifyLeft;

  Var
    EndLoop  :Boolean;
    Marker,
    SpPos    :Byte;

  Begin
    EndLoop:=False;
    While (Length(StOut)<Margin) And (Not EndLoop) do
    Begin
      Marker:=1;
      Repeat
        SpPos:=PosFrom(' ',StOut,Marker);
        If (SpPos=0) Or (SpPos=Length(StOut)) Then
        Begin
          If Marker=1 Then EndLoop:=True;
          Marker:=255
        End
        Else
        Begin
          Insert(' ',StOut,SpPos);
          Marker:=SpPos+2;
          While (StOut[Marker]=' ') And (Marker<Margin) do
            Inc(Marker);
        End;
      Until (Length(StOut)>=Margin) Or (Marker>Length(StOut)) Or EndLoop;
    End;
  End;

  Procedure RightJustifyRight;

  Var
    EndLoop  :Boolean;
    Marker,
    SpPos    :Byte;

  Begin
    EndLoop:=False;
    While (Length(StOut)<Margin) And (Not EndLoop) do
    Begin
      Marker:=Length(StOut);
      Repeat
        SpPos:=RevPosFrom(' ',StOut,Marker);
        If (SpPos=0) Or (SpPos=1) Then
        Begin
          If Marker=Length(StOut) Then EndLoop:=True;
          Marker:=0;
        End
        Else
        Begin
          Insert(' ',StOut,SpPos);
          Marker:=SpPos-1;
          While (StOut[Marker]=' ') And (Marker>1) do
            Dec(Marker);
        End;
      Until (Length(StOut)>=Margin) Or (Marker=0) Or EndLoop;
    End;
  End;

  Procedure RightJustifyCentre;

  Var
    EndLoop1,
    EndLoop2 :Boolean;
    Marker1,
    Marker2,
    SpPos    :Byte;

  Begin
    EndLoop1:=False;
    EndLoop2:=False;

    While (Length(StOut)<Margin) And (Not EndLoop1) And (Not EndLoop2) do
    Begin
      Marker1:=Length(StOut) Div 2;
      Marker2:=Marker1;
      If StOut[Marker1]=' ' Then Inc(Marker1);

      Repeat
        If Not ((Length(StOut)>=Margin) Or (Marker1>Length(StOut)) Or EndLoop1) Then
        Begin
          SpPos:=PosFrom(' ',StOut,Marker1);
          If (SpPos=0) Or (SpPos=Length(StOut)) Then
          Begin
            If Marker1=Length(StOut) Div 2 Then EndLoop1:=True;
            Marker1:=255
          End
          Else
          Begin
            Insert(' ',StOut,SpPos);
            Marker1:=SpPos+2;
            While (StOut[Marker1]=' ') And (Marker1<Margin) do
              Inc(Marker1);
          End;
        End;

        If Not ((Length(StOut)>=Margin) Or (Marker2=0) Or EndLoop2) Then
        Begin
          SpPos:=RevPosFrom(' ',StOut,Marker2);
          If (SpPos<=1) Then
          Begin
            If Marker2=Length(StOut) Div 2 Then EndLoop2:=True;
            Marker2:=0;
          End
          Else
          Begin
            Insert(' ',StOut,SpPos);
            If Marker1 <> 255 Then
              Inc(Marker1);               {Pushes Marker 1 Up 1 Space}
            Marker2:=SpPos-1;
            While (StOut[Marker2]=' ') And (Marker2>1) do
              Dec(Marker2);
          End;
        End;
      Until ((Length(StOut)>=Margin) Or (Marker1>Length(StOut)) Or EndLoop1) And
            ((Length(StOut)>=Margin) Or (Marker2=0) Or EndLoop2);
    End;
  End;

  Procedure RightJustifyOutSide;

  Var
    EndLoop1,
    EndLoop2 :Boolean;
    Marker1,
    Marker2,
    SpPos    :Byte;

  Begin
    EndLoop1:=False;
    EndLoop2:=False;

    While (Length(StOut)<Margin) And (Not EndLoop1) And (Not EndLoop2) do
    Begin
      Marker1:=1;
      Marker2:=Length(StOut);

      Repeat
        If Not ((Length(StOut)>=Margin) Or (Marker1>Length(StOut) Div 2) Or EndLoop1) Then
        Begin
          SpPos:=PosFrom(' ',StOut,Marker1);
          If (SpPos=0) Or (SpPos>Length(StOut) Div 2) Then
          Begin
            If Marker1=1 Then EndLoop1:=True;
            Marker1:=255
          End
          Else
          Begin
            Insert(' ',StOut,SpPos);
            Marker1:=SpPos+2;
            While (StOut[Marker1]=' ') And (Marker1<Length(StOut) Div 2) do
              Inc(Marker1);
          End;
        End;

        If Not ((Length(StOut)>=Margin) Or (Marker2<Length(StOut) Div 2) Or EndLoop2) Then
        Begin
          SpPos:=RevPosFrom(' ',StOut,Marker2);
          If (SpPos<=1) Then
          Begin
            If Marker2<=Length(StOut) Div 2 Then EndLoop2:=True;
            Marker2:=0;
          End
          Else
          Begin
            Insert(' ',StOut,SpPos);
            If Marker1 <> 255 Then
              Inc(Marker1);               {Pushes Marker 1 Up 1 Space}
            Marker2:=SpPos-1;
            While (StOut[Marker2]=' ') And (Marker2>=Length(StOut) Div 2) do
              Dec(Marker2);
          End;
        End;
      Until ((Length(StOut)>=Margin) Or (Marker1>Length(StOut) Div 2) Or EndLoop1) And
            ((Length(StOut)>=Margin) Or (Marker2<=Length(StOut) Div 2) Or EndLoop2);
    End;
  End;

Begin
  StOut:=StIn;
  Case JType Of
    LeftText    :RightJustifyLeft;
    RightText   :RightJustifyRight;
    CentreText  :RightJustifyCentre;
    OutSideText :RightJustifyOutSide;
  End;
End;

Procedure PadFileName(StIn:String;Var StOut:String);

{ ╔════════════════════════════════════════════════════════════════════════╗ }
{ ║  Pads the file name to 12 characters.                                  ║ }
{ ╚════════════════════════════════════════════════════════════════════════╝ }

Var
  T1 :DirStr;
  T2 :NameStr;
  T3 :ExtStr;
  Dot:Char;

Begin
  If StIn='.' Then
  Begin
    PadVar(StIn,StOut,11);
    Exit;
  End;

  If StIn='..' Then
  Begin
    PadVar(StIn,StOut,10);
    Exit;
  End;

  FSplit(StIn,T1,T2,T3);
  PadVar(T2,T2,8-Length(T2));
  Delete(T3,1,1);
  PadVar(T3,T3,3-Length(T3));
  If T3='   ' Then Dot:=' ' Else Dot:='.';
  StOut:=T1+T2+Dot+T3;
End;

Function AdjustMeter(StartMeter1,EndMeter1,ValueMeter1,
                     StartMeter2,EndMeter2:LongInt):LongInt;
Begin
  AdjustMeter:=(((EndMeter2-StartMeter2)*(ValueMeter1-StartMeter1)) Div
               (EndMeter1-StartMeter1))+StartMeter2;
End;

Function MemoryCount(P:Pointer):LongInt;
Begin
  MemoryCount:=LongInt(Seg(P^)) * 16 + Ofs(P^);
End;

Procedure GetLowestOfs(P:Pointer;Var S,O:Word);
Begin
  O:=Ofs(P^);
  S:=Seg(P^);
  If O<16 Then Exit;
  Inc(S,O Div 16);
  O:=O Mod 16;
End;

Procedure AdjustPtr(Var P:Pointer;Amount:LongInt);

Var
  X,
  Segt,
  Ofst  :Word;

Begin
  Segt:=Seg(P^);
  Ofst:=Ofs(P^);
  If Amount<0 Then
  Begin
    X:=$FFFF-Ofst;      {Want to Make Ofst as Big as Possible}
    X:=X - (X Mod 16);  {Round It to the Nearest 16}
    Dec(Segt,X Div 16); {Take it from the Segment}
    Inc(Ofst,X);        {Add it to the Offset}
  End
  Else
  Begin
    X:=Ofst - (Ofst Mod 16);    {Want to make Ofst as Small as Possible}
    Inc(Segt,X Div 16);         {Add it to the Segment}
    Dec(Ofst,X);                {Take it from the Offset}
  End;
  P:=Ptr(Segt,Ofst+Amount);
End;

Procedure SaveCursorSize(Var Data:Word); Assembler;
Asm
  mov  ah,3
  int  10h
  les  di,Data
  mov  es:[di],cx
End;

Procedure RestCursorSize(Data:Word); Assembler;
Asm
  mov  ah,1
  mov  cx,Data
  int  10h
End;

Procedure SaveXYPos(Var Position:XYPosData);
{This saves the current cursor position and can store up to the last five}
{cursor positions}
{Number 'MaxXYSaves' is the lastest save}

Var
  X:Byte;   {Loop}

Begin
  For X:=1 to MaxXYSaves-1 do                    {Shift Cursor Saves up}
  Begin
      Position[X,CursorX]:=Position[X+1,CursorX];
      Position[X,CursorY]:=Position[X+1,CursorY];
  End;   {For X Loop}
  Position[5,CursorX]:=WhereX;      {Insert New Cursor Save Position}
  Position[5,CursorY]:=WhereY;
End;  {SaveXYPos}

Procedure RestXYPos(Var Position:XYPosData);
{This will restore up to five previously saved cursor positions}
{Number 'MaxXYSaves' is the position to be restored}

Var
  X:Byte;       {Loop}

Begin
  GotoXY(Position[MaxXYSaves,CursorX],Position[MaxXYSaves,CursorY]); {Goto Old Position}
  For X:=MaxXYSaves downto 2 do    {Shift up the cursor positions for the next restore}
  Begin
      Position[X,CursorX]:=Position[X-1,CursorX];
      Position[X,CursorY]:=Position[X-1,CursorY];
  End;  {For X Loop}
End;  {RestXYPos}

Procedure CursorSize(UpLim,DownLim:Byte); Assembler;
{Set the cursor size.  Send $20,$20 for no cursor}
Asm
  mov  ah,1
  mov  ch,UpLim
  mov  cl,DownLim
  int  10h
End;

Procedure PushCursorSize;

Var
  X:Word;

Begin
  For X:=1 to MaxXYSaves-1 do
    PushPopCursorSize[X]:=PushPopCursorSize[X+1];

  Asm
    mov  ah,3
    int  10h
    mov  X,cx
  End;

  PushPopCursorSize[MaxXYSaves]:=X;
End;

Procedure PopCursorSize;

Var
  X:Word;

Begin
  X:=PushPopCursorSize[MaxXYSaves];

  Asm
    mov  ah,1
    mov  cx,X
    int  10h
  End;

  For X:=MaxXYSaves DownTo 2 do
    PushPopCursorSize[X]:=PushPopCursorSize[X-1];
End;

Procedure PushXYPos;

Var
  X:Byte;

Begin
  For X:=1 to MaxXYSaves-1 do
    PushPopCursorPos[X]:=PushPopCursorPos[X+1];

  PushPopCursorPos[MaxXYSaves,CursorX]:=WhereX;
  PushPopCursorPos[MaxXYSaves,CursorY]:=WhereY;
End;

Procedure PopXYPos;

Var
  X:Byte;

Begin
  GotoXY(PushPopCursorPos[MaxXYSaves,CursorX],
         PushPopCursorPos[MaxXYSaves,CursorY]);

  For X:=MaxXYSaves DownTo 2 do
    PushPopCursorPos[X]:=PushPopCursorPos[X-1];
End;

Procedure PushTextColor;

Var
  X:Byte;

Begin
  For X:=1 to MaxXYSaves-1 do
    PushPopTextColor[X]:=PushPopTextColor[X+1];

  PushPopTextColor[MaxXYSaves]:=TextAttr;
End;

Procedure PopTextColor;

Var
  X:Word;

Begin
  TextAttr:=PushPopTextColor[MaxXYSaves];

  For X:=MaxXYSaves DownTo 2 do
    PushPopTextColor[X]:=PushPopTextColor[X-1];
End;

Procedure KeyBuffer(Option:KeyBufferFunction);

Type
  KeyBufType=Record
               Head:Word;
               Tail:Word;
               Data:Array[1..16] Of Word;
             End;

Const
  KeyBuf:KeyBufType=(Head:0;Tail:0;Data:(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0));
  P     :Pointer   =Ptr(0,$41A);

Begin
  Case Option Of
    Clear   :MemW[0:$41A]:=MemW[0:$41C];
    Save    :Move(P^,KeyBuf,SizeOf(KeyBuf));
    Restore :Move(KeyBuf,P^,SizeOf(KeyBuf));
  End;
End;

Procedure SwapBytes(Var A,B:Byte); Assembler;
Asm
  push  ds
  les   di,A
  lds   si,B
  mov   al,es:[di]
  mov   bl,al             {A into BX}
  mov   al,ds:[si]        {B into AX}
  mov   es:[di],al
  mov   al,bl
  mov   ds:[si],al
  pop   ds
End;

Procedure SwapIntegers(Var A,B:Integer); Assembler;
Asm
  push  ds
  les   di,A
  lds   si,B
  mov   ax,es:[di]
  mov   bx,ax             {A into BX}
  mov   ax,ds:[si]        {B into AX}
  mov   es:[di],ax
  mov   ax,bx
  mov   ds:[si],ax
  pop   ds
End;

Procedure SwapWords(Var A,B:Word); Assembler;
Asm
  push  ds
  les   di,A
  lds   si,B
  mov   ax,es:[di]
  mov   bx,ax             {A into BX}
  mov   ax,ds:[si]        {B into AX}
  mov   es:[di],ax
  mov   ax,bx
  mov   ds:[si],ax
  pop   ds
End;

Procedure SwapLongInts(Var A,B:LongInt);

Var
  C:LongInt;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapReals(Var A,B:Real);

Var
  C:Real;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapSingles(Var A,B:Single);

Var
  C:Single;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapDoubles(Var A,B:Double);

Var
  C:Double;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapExtendeds(Var A,B:Extended);

Var
  C:Extended;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapComps(Var A,B:Comp);

Var
  C:Comp;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

Procedure SwapStrings(Var A,B:String);

Var
  C:String;

Begin
  C:=A;
  A:=B;
  B:=C;
End;

End.

{ Copyright 1993, Michael Gallias }