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