home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / STAYRESP.ZIP / STAYWNDO.341 < prev    next >
Encoding:
Text File  |  1986-06-07  |  15.7 KB  |  376 lines
  1. {**********************************************************************}
  2. {                         W I N D O . I N C                            }
  3. {                     "...but I dont do floors !"                      }
  4. {**********************************************************************}
  5. {                 Kloned and Kludged by Lane Ferris                    }
  6. {                     -- The Hunters Helper --                         }
  7. {               Original Copyright 1984 by Michael A. Covington        }
  8. {               Modifications by Lynn Canning 9/25/85                  }
  9. {                 1) Foreground and Background colors added.           }
  10. {                    Monochrome monitors are automatically set         }
  11. {                    to white on black.                                }
  12. {                 2) Multiple borders added.                           }
  13. {                 3) TimeDelay procedure added.                        }
  14. {               Requirements: IBM PC or close compatible.              }
  15. {----------------------------------------------------------------------}
  16. { To make a window on the screen, call the procedure                   }
  17. {      MkWin(x1,y1,x2,y2,FG,BG,BD);                                    }
  18. {   The x and y coordinates define the window placement and are the    }
  19. {   same as the Turbo Pascal Window coordinates.                       }
  20. {   The border parameters (BD) are 0 = No border                       }
  21. {                                  1 = Single line border              }
  22. {                                  2 = Double line border              }
  23. {                                  3 = Double Top/Bottom Single sides  }
  24. {   The foreground (FG) and background (BG) parameters are the same    }
  25. {   values as the corresponding Turbo Pascal values.                   }
  26. {                                                                      }
  27. { The maximum number of windows open at one time is set at five        }
  28. { (see MaxWin=5).  This may be set to greater values if necessary.     }
  29. {                                                                      }
  30. { After the window is made, you must write the text desired from the   }
  31. { calling program.  Note that the usable text area is actually 1       }
  32. { position smaller than the window coordinates to allow for the border.}
  33. { Hence, a window defined as 1,1,80,25 would actually be 2,2,79,24     }
  34. { after the border is created.  When writing to the window in your     }
  35. { calling program, the textcolor and backgroundcolor may be changed as }
  36. { desired by using the standard Turbo Pascal commands.                 }
  37. {                                                                      }
  38. { To return to the previous screen or window, call the procedure       }
  39. {      RmWin;                                                          }
  40. {                                                                      }
  41. { The TimeDelay procedure is invoked from your calling program.  It    }
  42. { is similar to the Turbo Pascal DELAY except DELAY is based on clock  }
  43. { speed whereas TimeDelay is based on the actual clock.  This means    }
  44. { that the delay will be the same duration on all systems no matter    }
  45. { what the clock speed.                                                }
  46. { The procedure could be used for an error condition as follows:       }
  47. {     MkWin          - make an error message window                    }
  48. {     Writeln        - write error message to window                   }
  49. {     TimeDelay(5)   - leave window on screen 5 seconds                }
  50. {     RmWin          - remove error window                             }
  51. {     cont processing                                                  }
  52. {----------------------------------------------------------------------}
  53.  
  54. Const
  55.  
  56.       InitDone :boolean = false ;      { Initialization switch   }
  57.  
  58.       On     = True ;
  59.       Off    = False ;
  60.       VideoEnable = $08;               { Video Signal Enable Bit }
  61.       Bright = 8;                      { Bright Text bit}
  62.       Mono   = 7;                      {MonoChrome Mode}
  63.  
  64. Type
  65.      Imagetype  = array [1..4000] of char;  { Screen Image in the heap    }
  66.      WinDimtype = record
  67.                     x1,y1,x2,y2: integer
  68.                   end;
  69.  
  70.      Screens    = record              { Save Screen Information     }
  71.                    Image: Imagetype;  { Saved screen Image }
  72.                    Dim:   WinDimtype; { Saved Window Dimensions }
  73.                    x,y:   integer;    { Saved cursor position }
  74.                   end;
  75.  
  76.  
  77.  Var
  78.  
  79.   Win:                                { Global variable package }
  80.     record
  81.       Dim:    WinDimtype;             { Current Window Dimensions }
  82.       Depth:  integer;
  83.                    { MaxWin should be included in your program }
  84.                    { and it should be the number of windows saved }
  85.                    { at one time }
  86.                    { It should be in the const section of your program }
  87.       Stack:  array[1..MaxWin] of ^Screens;
  88.  
  89.     end;
  90.  
  91.   Crtmode     :byte      absolute $0040:$0049; {Crt Mode,Mono,Color,B&W..}
  92.   Crtwidth    :byte      absolute $0040:$004A; {Crt Mode Width, 40:80 .. }
  93.   Monobuffer  :Imagetype absolute $B000:$0000; {Monochrome Adapter Memory}
  94.   Colorbuffer :Imagetype absolute $B800:$0000; {Color Adapter Memory     }
  95.   CrtAdapter  :integer   absolute $0040:$0063; { Current Display Adapter }
  96.   VideoMode   :byte      absolute $0040:$0065; { Video Port Mode byte    }
  97.   TurboCrtMode: byte     absolute  Dseg:6;     {Turbo's Crt Mode byte    }
  98.   Video_Buffer:integer;                        { Record the current Video}
  99.   Delta,
  100.   x,y         :integer;
  101.  
  102. {------------------------------------------------------------------}
  103. {                     Delay for  X seconds                         }
  104. {------------------------------------------------------------------}
  105.  
  106. procedure TimeDelay (hold : integer);
  107. type
  108.   RegRec =                                { The data to pass to DOS }
  109.     record
  110.       AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
  111.     end;
  112. var
  113.   regs:regrec;
  114.   ah, al, ch, cl, dh:byte;
  115.   sec               :string[2];
  116.   result, secn, error, secn2, diff :integer;
  117.  
  118. begin
  119.   ah := $2c;                       {Get Time-Of-Day from DOS}
  120.   with regs do                     {Will give back Ch:hours }
  121.                                    {Cl:minutes,Dh:seconds   }
  122.     ax := ah shl 8 + al;           {Dl:hundreds             }
  123.   intr($21,regs);
  124.  
  125.   with regs do
  126.     str(dx shr 8:2, sec);          {Get seconds      }
  127.                                    {with leading null}
  128.   if (sec[1] = ' ') then
  129.     sec[1]:= '0';
  130.   val(sec, secn, error);           {Conver seconds to integer}
  131.   repeat                           { stay in this loop until the time }
  132.      ah := $2c;                    { has expired }
  133.      with regs do
  134.         ax := ah shl 8 + al;
  135.      intr($21,regs);               {Get current time-of-day}
  136.  
  137.      with regs do                  {Normalize to Char}
  138.         str(dx shr 8:2, sec);
  139.      if (sec[1] = ' ') then
  140.         sec[1]:= '0';
  141.      val(sec, secn2, error);       {Convert seconds to integer}
  142.      diff := secn2 - secn;         {Number of elapsed seconds}
  143.      if diff < 0 then            { we just went over the minute }
  144.         diff := diff + 60;       { so add 60 seconds }
  145.   until diff > hold;             { has our time expired yet }
  146. end; { procedure TimeDelay }
  147.  
  148. {------------------------------------------------------------------}
  149. {          Get Absolute postion of Cursor into parameters x,y      }
  150. {------------------------------------------------------------------}
  151. Procedure Get_Abs_Cursor (var x,y :integer);
  152.   Var
  153.       Active_Page  : byte absolute $0040:$0062;  { Current Video Page Index}
  154.       Crt_Pages    : array[0..7] of integer absolute $0040:$0050 ;
  155.  
  156.    Begin
  157.  
  158.       X := Crt_Pages[active_page];     { Get Cursor Position       }
  159.       Y := Hi(X)+1;                    { Y get Row                 }
  160.       X := Lo(X)+1;                    { X gets Col position       }
  161.    End;
  162. {------------------------------------------------------------------}
  163. {          Turn the Video On/Off to avoid Read/Write snow          }
  164. {------------------------------------------------------------------}
  165. Procedure Video (Switch:boolean);
  166.    Begin
  167.       If (Switch = Off) then
  168.       Port[CrtAdapter+4] := (VideoMode - VideoEnable)
  169.       else Port[CrtAdapter+4] := (VideoMode or VideoEnable);
  170.    End;
  171. {------------------------------------------------------------------}
  172. {     InitWin Saves the Current (whole) Screen                     }
  173. {------------------------------------------------------------------}
  174. Procedure InitWin;
  175.   { Records Initial Window Dimensions }
  176.    Begin
  177.  
  178.      with Win.Dim do
  179.        begin x1:=1; y1:=1; x2:=crtwidth; y2:=25 end;
  180.      Win.Depth:=0;
  181.      InitDone := True ;                    { Show initialization Done }
  182. end;
  183. {------------------------------------------------------------------}
  184. {       BoxWin Draws a Box around the current Window               }
  185. {------------------------------------------------------------------}
  186. procedure BoxWin(x1,y1,x2,y2, BD, FG, BG :integer);
  187.  
  188.   { Draws a box, fills it with blanks, and makes it the current }
  189.   { Window.  Dimensions given are for the box; actual Window is }
  190.   { one unit smaller in each direction.                         }
  191.  
  192. var
  193.     I,
  194.     TB,SID,TLC,TRC,BLC,BRC   :integer;
  195.  
  196. begin
  197.   if Crtmode = Mono then begin
  198.     FG := 7;
  199.     BG := 0;
  200.     end;
  201.  
  202.   Window(x1,y1,x2,y2);              {Make the Window}
  203.   TextColor(FG) ;                   {Set the colors}
  204.   TextBackground(BG);
  205.  
  206.  
  207.   Case BD of                        {Make Border characters}
  208.     0:;                             {No border option}
  209.     1:begin                         {Single line border option}
  210.       TB  := 196;                     {Top Border}
  211.       SID := 179;                     {Side Border}
  212.       TLC := 218;                     {Top Left Corner}
  213.       TRC := 191;                     {Top Right Corner}
  214.       BLC := 192;                     {Bottom Left Corner}
  215.       BRC := 217;                     {Bottom Right Corner}
  216.       end;
  217.     2:begin                         {Double line border option}
  218.       TB  := 205;
  219.       SID := 186;
  220.       TLC := 201; TRC := 187;
  221.       BLC := 200; BRC := 188;
  222.       end;
  223.     3:begin                         {Double Top/Bottom with single sides}
  224.       TB  := 205;                   {"deary and dont spare the lace"}
  225.       SID := 179;
  226.       TLC := 213; TRC := 184;
  227.       BLC := 212; BRC := 190;
  228.       end;
  229.     End;{Case}
  230.  
  231.   IF BD > 0 then begin                  { User want a border? }
  232.   { Top }
  233.      gotoxy(1,1);                       { Window Origin       }
  234.      Write( chr(TLC) );                 { Top Left Corner     }
  235.      For I:=2 to x2-x1   do             { Top Bar             }
  236.         Write( chr(TB));
  237.      Write( chr(TRC) );                 { Top Right Corner
  238.  
  239.   { Sides  }
  240.      for I:=2 to y2-y1 do
  241.        begin
  242.          gotoxy(1,I);                   { Left Side Bar       }
  243.          write( chr(SID) );
  244.          gotoxy(x2-x1+1,I) ;            { Right Side Bar      }
  245.          write( chr(SID) );
  246.        end;
  247.  
  248.   { Bottom }
  249.      gotoxy(1,y2-y1+1);                   { Bottom Left Corner }
  250.      write( chr(BLC) );
  251.      for I:=2 to x2-x1   do               { Bottom Bar         }
  252.         write( chr(TB) );
  253.  
  254.   { Make it the current Window }
  255.      Window(x1+1,y1+1,x2-1,y2-1);
  256.      write( chr(BRC) );                 { Bottom Right Corner }
  257.    end; {If BD > 0};
  258.  
  259.    gotoxy(1,1) ;
  260.    TextColor( FG) ;                { Take Low nibble 0..15  }
  261.    TextBackground (BG);            { Take High nibble  0..9 }
  262.    ClrScr;
  263.  end;
  264. {------------------------------------------------------------------}
  265. {       MkWin   Make a Window                                      }
  266. {------------------------------------------------------------------}
  267. procedure MkWin(x1,y1,x2,y2, FG, BG, BD :integer);
  268.   { Create a removable Window }
  269.  
  270. begin
  271.  
  272.   If (InitDone = false) then              { Initialize if not done yet }
  273.       InitWin;
  274.  
  275.   TurboCrtMode := CrtMode;                  {Set Textmode w/o ClrScr}
  276.   If CrtMode = 7 then Video_Buffer := $B000 {Set Ptr to Monobuffer      }
  277.   else  Video_Buffer := $B800;              {or Color Buffer            }
  278.  
  279.  
  280.   with Win do Depth:=Depth+1;              { Increment Stack pointer }
  281.   if Win.Depth>maxWin then
  282.     begin
  283.       writeln(^G,' Windows nested too deep ');
  284.       halt
  285.     end;
  286.                 {-------------------------------------}
  287.                 {       Save contents of screen       }
  288.                 {-------------------------------------}
  289.   With Win do
  290.     Begin
  291.     New(Stack[Depth]);                  { Allocate Current Screen to Heap }
  292.     Video( Off);
  293.  
  294.     If CrtMode = 7 then
  295.     Stack[Depth]^.Image := monobuffer   { set pointer to it      }
  296.     else
  297.     Stack[Depth]^.Image := colorbuffer ;
  298.  
  299.     Video( On);
  300.    End ;
  301.  
  302.  
  303.   With Win do
  304.      Begin                                { Save Screen Dimentions        }
  305.      Stack[Depth]^.Dim := Dim;
  306.      Stack[Win.Depth]^.x  := wherex;      { Save Cursor Position          }
  307.      Stack[Win.Depth]^.y  := wherey;
  308.      End ;
  309.  
  310.                                           { Validate the Window Placement}
  311.   If (X2 > 80) then                       { If off right of screen       }
  312.           begin
  313.           Delta := (X2 - 80);             { Overflow off right margin    }
  314.           If X1 > Delta then
  315.              X1 := X1 - Delta ;           { Move Left window edge        }
  316.           X2 := X2 - Delta ;              { Move Right edge on 80        }
  317.           end;
  318.   If (Y2 > 25) then                       { If off bottom   screen       }
  319.           begin
  320.           Delta := Y2 - 25;               { Overflow off right margin    }
  321.           If Y1 > Delta then
  322.              Y1 := Y1 - Delta ;           { Move Top edge up             }
  323.           Y2 := Y2 - Delta ;              { Move Bottom  24              }
  324.           end;
  325.                                           { Create the New Window  }
  326.  
  327.   BoxWin(x1,y1,x2,y2,BD,FG,BG);
  328.   If BD >0 then begin                     {Shrink window within borders}
  329.      Win.Dim.x1 := x1+1;
  330.      Win.Dim.y1 := y1+1;                     { Allow for margins }
  331.      Win.Dim.x2 := x2-1;
  332.      Win.Dim.y2 := y2-1;
  333.      end;
  334.  
  335. end;
  336. {------------------------------------------------------------------}
  337. {                          Remove Window                           }
  338. {------------------------------------------------------------------}
  339.         { Remove the most recently created removable Window }
  340.         { Restore screen contents, Window Dimensions, and   }
  341.         { position of cursor.  }
  342. Procedure RmWin;
  343.   Var
  344.     Tempbyte : byte;
  345.  
  346.    Begin
  347.    Video(Off);
  348.  
  349.    With Win do
  350.       Begin                                { Restore next Screen       }
  351.       If crtmode = 7 then
  352.       monobuffer := Stack[Depth]^.Image
  353.       else
  354.       colorbuffer := Stack[Depth]^.Image;
  355.       Dispose(Stack[Depth]);                { Remove Screen from Heap   }
  356.  
  357.    Video(On);
  358.  
  359.    With Win do                              { Re-instate the Sub-Window }
  360.     Begin                                   { Position the old cursor   }
  361.       Dim := Stack[Depth]^.Dim;
  362.       Window(Dim.x1,Dim.y1,Dim.x2,Dim.y2);
  363.       gotoxy(Stack[Depth]^.x,Stack[Depth]^.y);
  364.     end;
  365.  
  366.       Get_Abs_Cursor(x,y) ;          { New Cursor Position       }
  367.       Tempbyte :=                    { Get old Cursor attributes }
  368.            Mem[ Video_Buffer:((x-1 + (y-1) * 80 ) * 2)+1 ];
  369.  
  370.       TextColor( Tempbyte And $0F );        { Take Low nibble  0..15}
  371.       TextBackground ( Tempbyte Div 16);   { Take High nibble  0..9 }
  372.       Depth := Depth - 1
  373.     end ;
  374. end;
  375. {------------------------------------------------------------------}
  376.