Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TP_ADV.ZIP/LIST0907.PAS

Pascal/Delphi Source File | 1989-11-17 | 8.8 KB | 287 lines

Unit WindTool;

Interface

Uses
  CRT,
  DOS;

Type
  BorderType = Byte;

Var
  { The width of the screen in the current video mode }
  VidWidth : Word;

  { The base offset of display memory of the current display }
  BaseAddr : Word;

  { To control the sound on or off based on TRUE or FALSE }
  SoundOn  : Boolean;

Procedure OpenWindow ( X1, Y1, X2, Y2 : Byte; Border : BorderType;
                       BorderColor : Word; Title : String );

Procedure CloseWindow;

Procedure MoveNoSnow (  Count : Word; FromAddr, ToAddr : Pointer );

Procedure MoveFast ( Count : Word; FromAddr, ToAddr : Pointer );

Procedure MovWindow ( ToScreen : Boolean; X1, Y1, X2, Y2 : Word;
                      Buff : Pointer );

Procedure DoBorder ( X1, Y1, X2, Y2 : Byte; Border : BorderType;
                     BorderColor : Word; Title : String );

Procedure DefineBorder ( Num : Byte; UpLeft, UpRight, BtmLeft, BtmRight,
                         HorizLine, VertLine, BegTitle, EndTitle : Char );

Procedure WindowSound ( Open : Boolean );

Procedure GetVideoAddress;

Function GetWindowSize ( X1, Y1, X2, Y2 : Word ) : Word;

Implementation

Const
  MaxStack = 1000;  { Largest size for window stack }
  MaxBorders = 4;

Type
  BorderRec    = Record
                   UL, UR, BL, BR,
                   HL, VL,
                   BT, ET : Char;
                 End;
  BorderArray  = Array [ 1..MaxBorders ] of BorderRec;
  StackElement = Record
                   sX1, sY1,
                   sX2, sY2 : Byte;
                   sBuff : Pointer;
                 End;
  StackType    = Array [0..MaxStack] of StackElement;

Var
  BArr      : BorderArray;
  Stack     : StackType;
  StackPtr  : Word;

{$L WindTool.obj}

{$F+}
Procedure MoveNoSnow; External;

Procedure MoveFast; External;

Procedure MovWindow; External;
{$F-}

Procedure ReportError ( s : String );
{ Brut force error checking. If an error occurs, clear the screen and  }
{ report problem, then terminate program. This is more for development }
{ error reporting then a shipping error generater.                     }
Begin
  ClrScr;
  WriteLn ( s );
  Halt ( 1 );
End;

Function GetWindowSize;
{ Calculate the total amount of memory needed to store the window, }
{ character and attribute.                                         }
Begin
  GetWindowSize := ( X2 - X1 + 1 ) * ( Y2 - Y1 + 1 ) * 2;
End;

Procedure PushWindow ( pX1,pY1,pX2,pY2 : Byte );
{ Allocate memory on the internal window stack for the window, then }
{ save the memory in that area.                                     }
Begin
  If ( StackPtr = 0 ) Then      { Special case. If it is the first window   }
  Begin                         { opened, get the current windowcoordinates.}
    With Stack [ StackPtr ] Do
    Begin
      sX1 := Lo ( WindMin ) + 1;
      sY1 := Hi ( WindMin ) + 1;
      sX2 := Lo ( WindMax ) + 1;
      sY2 := Hi ( WindMax ) + 1;
    End;
  End;
  Inc ( StackPtr );             { Increment the stack pointer }
  With Stack [ StackPtr ] Do    { Store the X,Y coordinates }
  Begin
    sX1 := pX1;
    sY1 := pY1;
    sX2 := pX2;
    sY2 := pY2;
                               { Allocate storage for window }
    GetMem ( sBuff, GetWindowSize ( sX1, sY1, sX2, sY2 ) );
    If ( sBuff = NIL ) Then
      ReportError ( 'No heap left for window allocation.' );
                               { Move window into storage area }
    MovWindow ( FALSE, sX1, sY1, sX2, sY2, sBuff );
  End;
End;

Procedure PopWindow;
Begin
  With WindTool.Stack [ WindTool.StackPtr ] Do
  Begin
                               { Resore the window information }
    MovWindow ( TRUE, sX1, sY1, sX2, sY2, sBuff );
                               { Release heap storage }
    FreeMem ( sBuff, GetWindowSize ( sX1, sY1, sX2, sY2 ) );
  End;
  Dec ( StackPtr );            { Decrement the stack pointer }
End;

Procedure DoBorder;
Var
  i : Integer;
  s : String;
  tmp : Word;
Begin
  tmp := TextAttr;                          { Save the current screencolors }
  TextColor ( Lo ( BorderColor ) );         { Set color for border }
  TextBackground ( Hi ( BorderColor ) );    { " }
  Window ( 1, 1, 80, 25 );                  { Set window to entire screen }
  If ( Border > MaxBorders ) OR ( Border < 0 ) Then
    Border := 1;
  s := BArr [ Border ].UL;              { Build top line of window border }
  For i := 1 to ( X2 - X1 - 1 ) Do      { " }
    s := s + BArr [ Border ].HL;        { " }
  s := s + BArr [ Border ].UR;          { " }
  GotoXY ( X1, Y1 );                    { Print top line of window border }
  Write ( s );
  i := Length ( s );
  s [ 1 ] := BArr [ Border ].BL;        { Build bottom line of windowborder }
  s [ i ] := BArr [ Border ].BR;        { " }
  GotoXY ( X1, Y2 );                    { Print bottom line of border }
  Write ( s );
  FillChar ( s, i, ' ' );               { Build center of window }
  s [ 0 ] := Chr ( i );                 { " }
  s [ 1 ] := BArr [ Border ].VL;        { " }
  s [ Length ( s ) ] := BArr [ Border ].VL; { " }
  For i := ( Y1 + 1 ) to ( Y2 - 1 ) Do
  Begin
    GotoXY ( X1, i );                   { Loop and print center of window }
    Write ( s );
  End;

  { Build Title string }
  If ( Length ( Title ) > 0 ) Then      { If title string is not zero, }
  Begin                                 { dont draw a title string.    }
    If ( Length ( Title ) > ( X2 - X1 - 3 ) ) Then  { If string larger than}
      Title [0] := Chr ( X2 - X1 - 3 );             { window, shorten it.  }
    Insert ( BArr [ Border ].BT, Title, 1 ); { Add start Title character }
    Title := Title + BArr [ Border ].ET;     { Add end Title character   }
    i := X1 + ((X2 - X1 + 1) div 2 ) - ( Length (Title) Div 2);
    GotoXY ( X1 + ( ( X2 - X1 + 1 ) Div 2 ) - ( Length ( Title ) Div 2 ),Y1 );
    Write ( Title );                         { Write the title to thewindow }
  End;

  Window ( X1 + 1, Y1 + 1, X2 - 1, Y2 - 1 );  { Make Turbo aware of window }
  TextAttr := tmp;                            { Restore orig. screen colors}
  ClrScr;
End;

Procedure DefineBorder;
{ Define a border for the DoBorder procedure }
Begin
  With BArr [ Num ] Do
  Begin
    UL := UpLeft;
    UR := UpRight;
    BL := BtmLeft;
    BR := BtmRight;
    HL := HorizLine;
    VL := VertLine;
    BT := BegTitle;
    ET := EndTitle;
  End;
End;

Procedure WindowSound;
{ Based on value of the SoundOn boolean variable, make a sound for }
{ opening or closing a window.                                     }
Begin
  If ( SoundOn ) Then
  Begin
    If Open Then
    Begin
      Sound ( 100 );  { Open a window sound }
      Delay ( 50 );
      Sound ( 200 );
      Delay ( 50 );
      Sound ( 300 );
      Delay ( 50 );
      NoSound;
    End
    Else
    Begin
      Sound ( 300 );  { Close a window sound }
      Delay ( 50 );
      Sound ( 200 );
      Delay ( 50 );
      Sound ( 100 );
      Delay ( 50 );
      NoSound;
    End;
  End;
End;

Procedure GetVideoAddress;
{ Based on the current video mode, set the width of the screen and }
{ the base address of the video screen.                            }
Var
  reg : Registers;
Begin
  reg.AH := $0F;
  Intr ( $10, reg );  { BIOS interrupt to get current video mode }
  VidWidth := reg.AH;
  Case ( reg.AL ) Of
       0..3 : BaseAddr := $B800;  { Color display }
       7    : BaseAddr := $B000;  { Monochrome display }
       Else
       Begin          { Must be in a graphics mode, halt program }
         ReportError ( 'Not in a text mode!' );
       End;
  End;
End;

Procedure OpenWindow;
{ Perform all the work required to open a window on the screen, draw the }
{ border, make the sound, ...                                            }
Begin
  WindowSound ( TRUE );
  PushWindow ( X1, Y1, X2, Y2 );
  DoBorder ( X1, Y1, X2, Y2, Border, BorderColor, Title );
End;

Procedure CloseWindow;
{ Perform all the work required to close a window and make the sound. }
Begin
  WindowSound ( FALSE );
  PopWindow;
  With Stack [ StackPtr ] Do
  Begin
    If ( StackPtr = 0 ) Then
      Window ( sX1, sY1, sX2, sY2 )    { Main window }
    Else
      Window ( sX1 + 1, sY1 + 1, sX2 - 1, sY2 - 1 );
  End;
End;

Begin
  GetVideoAddress;                        { Get current video information  }
  FillChar ( Stack, SizeOf (Stack), 0 );  { Initialize window stack        }
  StackPtr := 0;                          { Initialize window stack pointer}
  SoundOn := TRUE;                        { Default sound to be on         }
  DefineBorder ( 1, ' ',' ',' ',' ',' ',' ',' ',' ' ); { Set predefined }
  DefineBorder ( 2, '┌','┐','└','┘','─','│','┤','├' ); { border types.  }
  DefineBorder ( 3, '╔','╗','╚','╝','═','║','╡','╞' );
  DefineBorder ( 4, ' ',' ',' ',' ',' ',' ',' ',' ' );
End.