home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GPMENU.ZIP / GXMENU.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-01  |  7.7 KB  |  240 lines
  1. {$S-,R-,I-,V-,B-}
  2.  
  3. {*********************************************************}
  4. {*                   GXMENU.PAS 4.03                     *}
  5. {*          Copyright (c) Michael Day 1988               *}
  6. {* Portions copyright (c) TurboPower Software 1987.      *}
  7. {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  8. {*     and used under license to TurboPower Software     *}
  9. {*                 All rights reserved.                  *}
  10. {*********************************************************}
  11.  
  12. unit GXMenu;
  13.   {-Pulldown Graphic Extended Menu routines}
  14.  
  15. interface
  16.  
  17. uses
  18.   tpcrt,
  19.   graph;
  20.  
  21. var GraphOn : boolean; {set to true when in graph mode}
  22.  
  23. {------------------------------------------------------------------}
  24. {draw a string on the screen}
  25. procedure GTWrite(S:string; row,col,attr:byte);
  26.  
  27. {------------------------------------------------------------------}
  28. {Restore screen contents and deallocate buffer space if requested}
  29. procedure GRestoreWindow(XL,YL,XH,YH:byte;
  30.                          Deallocate:Boolean;
  31.                          var Covers:Pointer);
  32.  
  33. {------------------------------------------------------------------}
  34. {Allocate buffer space if requested and save window contents}
  35. function GSaveWindow(XL,YL,XH,YH:byte;
  36.                      Allocate:Boolean;
  37.                      var Covers:Pointer):Boolean;
  38.  
  39. {------------------------------------------------------------------}
  40. {Clear a region with specified attribute}
  41. procedure GClearWindow(XL, YL, XH, YH, Attr : Byte);
  42.  
  43. {------------------------------------------------------------------}
  44. {Draws a frame around specified area}
  45. {--- get a copy of FrameWindow from TPCRT.PAS and rename ---}
  46. {---  all its FastWrite calls to GTWrite to create this  ---}
  47. {---     be sure to rename the procedure to GFWindow     ---}
  48. procedure GFWindow(LeftCol, TopRow, RightCol, BotRow, FAttr, HAttr : Byte;
  49.                    Header : String);
  50.  
  51.  
  52. {==========================================================================}
  53.  
  54. implementation
  55.  
  56. type adsImage = Pointer;
  57.      Rect = record
  58.                Xmin, Ymin, Xmax, Ymax : Integer;
  59.             end;
  60.  
  61. Var CoversP : adsImage;
  62.     BufBytes : LongInt;
  63.     R : Rect;
  64.  
  65. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  66. {Convert row/col numbers to a graphic rectangle used as backdrop for text}
  67. Procedure ConvertToRect(var R : Rect; XL, YL, XH, YH : integer);
  68. begin
  69.    With R do
  70.    begin
  71.      Xmin := pred(XL) * TextWidth('M');     {assumes row/col starts with 1,1}
  72.      Ymin := pred(YL) * TextHeight('M');
  73.      Xmax := pred( XH * TextWidth('M') );    {assumes row/col starts with 1,1}
  74.      Ymax := pred( YH * TextHeight('M') );
  75.    end;
  76. end;
  77.  
  78. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  79. {Convert row/col numbers to a graphic rectangle used to surround text}
  80. Procedure StringToRect(var R:Rect; S:String; col,row:Integer);
  81. begin
  82.    With R do
  83.    begin
  84.      Xmin := pred(col) * TextWidth('M');     {assumes row/col starts with 1,1}
  85.      Ymin := pred(row) * TextHeight('M');
  86.      Xmax := pred( Xmin + TextWidth(S) );
  87.      Ymax := pred( Ymin + TextHeight(S) );
  88.    end;
  89. end;
  90.  
  91. {*****************************************************************************}
  92. {display text string in graphics mode}
  93. procedure GTWrite(S:string; row,col,attr:byte);
  94. begin
  95.    if S <> '' then
  96.    begin
  97.      if GraphOn then   {graph screen write}
  98.      begin
  99.        StringToRect(R, S, col, row);
  100.        SetFillStyle(1,attr shr 4);
  101.        Bar(R.Xmin, R.Ymin, R.Xmax, R.Ymax);
  102.        SetColor(attr and $0f);
  103.        OutTextXY(R.Xmin, R.Ymin, S);
  104.      end
  105.      else
  106.        FastWrite(S, row, col, attr);    {text screen write}
  107.    end;
  108. end;
  109.  
  110. {*****************************************************************************}
  111. {Allocate buffer space if requested and save window contents}
  112. function GSaveWindow(XL, YL, XH, YH : byte;
  113.                      Allocate : Boolean;
  114.                      var Covers : Pointer) : Boolean;
  115.  
  116. begin
  117.    if GraphOn then   {graph screen save}
  118.    begin
  119.      GSaveWindow := True;   {assume success}
  120.      CoversP := Covers;
  121.      ConvertToRect(R, XL, YL, XH, YH); {convert to pixel data}
  122.  
  123.      if Allocate then   {compute bytes needed for screen buffer}
  124.      begin
  125.        BufBytes := ImageSize(R.Xmin, R.Ymin, R.Xmax, R.Ymax);
  126.        if MaxAvail < BufBytes then   {make sure enough memory is available}
  127.        begin
  128.          GSaveWindow := False;
  129.          Exit;
  130.        end
  131.        else
  132.        Begin
  133.          GetMem(CoversP, BufBytes);    {allocate the screen buffer}
  134.          Covers := CoversP;
  135.        End;
  136.      end;
  137.  
  138.      {save current contents to the screen buffer}
  139.      GetImage(R.Xmin, R.Ymin, R.Xmax, R.Ymax, CoversP^);
  140.    end
  141.  
  142.    else    {text screen save}
  143.      GSaveWindow := SaveWindow(XL, YL, XH, YH, Allocate, Covers);
  144. end;
  145.  
  146. {*****************************************************************************}
  147. {Restore screen contents and deallocate buffer space if requested}
  148. procedure GRestoreWindow(XL, YL, XH, YH : byte;
  149.                          Deallocate : Boolean;
  150.                          var Covers : Pointer);
  151. begin
  152.    if GraphOn then   {graph screen restore}
  153.    begin
  154.      CoversP := Covers;
  155.      ConvertToRect(R, XL, YL, XH, YH); {convert to pixel data}
  156.  
  157.      {Restore current contents to the screen buffer}
  158.      PutImage(R.Xmin,R.Ymin,CoversP^,NormalPut);
  159.  
  160.      if Deallocate then   {deallocate buffer space if requested}
  161.      begin
  162.        BufBytes := ImageSize(R.Xmin, R.Ymin, R.Xmax, R.Ymax);
  163.        FreeMem(CoversP, BufBytes);
  164.        Covers := nil;
  165.      end;
  166.    end
  167.    else
  168.      RestoreWindow(XL, YL, XH, YH, Deallocate, Covers); {text restore}
  169. end;
  170.  
  171. {*****************************************************************************}
  172. {Clear a region with specified attribute}
  173. procedure GClearWindow(XL, YL, XH, YH, Attr : Byte);
  174. var
  175.     WordsPerRow : Word;
  176.     Row : Word;
  177.     Span : string;
  178. begin
  179.    if GraphOn then  {graph mode clear}
  180.    begin
  181.      ConvertToRect(R, XL, YL, XH, YH); {convert to pixel data}
  182.      SetFillStyle(1,attr shr 4);
  183.      Bar(R.Xmin, R.Ymin, R.Xmax, R.Ymax);
  184.    end
  185.    else
  186.    begin  {text mode clear}
  187.      WordsPerRow := Succ(XH-XL);
  188.      Span[0] := Chr(WordsPerRow);
  189.      FillChar(Span[1], WordsPerRow, ' ');
  190.      for Row := YL to YH do
  191.        GTWrite(Span, Row, XL, Attr);
  192.    end;
  193. end;
  194. {$I MYSUBS.PAS}
  195. {*****************************************************************************}
  196. {Draws a frame around specified area}
  197. procedure GFWindow(LeftCol, TopRow, RightCol, BotRow, FAttr, HAttr : Byte;
  198.                    Header : String);
  199. var
  200.     HeaderLen : Byte absolute Header;
  201.     Row, Width, HeaderPos : Byte;
  202.     Span : String[80];
  203.     SpanLen : Byte absolute Span;
  204. begin
  205.    {calculate width of window and position of header}
  206.    SpanLen := Succ(RightCol-LeftCol);
  207.    Width := SpanLen-2;
  208.  
  209.    {construct the upper border and draw it}
  210.    FillChar(Span[2], Width, FrameChars[Horiz]);
  211.    Span[1] := FrameChars[ULeft];
  212.    Span[SpanLen] := FrameChars[URight];
  213.    GTWrite(Span, TopRow, LeftCol, FAttr);
  214.  
  215.    {draw the vertical bars}
  216.    for Row := Succ(TopRow) to Pred(BotRow) do begin
  217.      GTWrite(FrameChars[Vert], Row, LeftCol, FAttr);
  218.      GTWrite(FrameChars[Vert], Row, RightCol, FAttr);
  219.    end;
  220.  
  221.    {draw the bottom border}
  222.    Span[1] := FrameChars[LLeft];
  223.    Span[SpanLen] := FrameChars[LRight];
  224.    GTWrite(Span, BotRow, LeftCol, FAttr);
  225.  
  226.    if HeaderLen > 0 then begin
  227.      if HeaderLen > Width then
  228.        HeaderLen := Width;
  229.      HeaderPos := (SpanLen-HeaderLen) shr 1;
  230.      GTWrite(Header, TopRow, LeftCol+HeaderPos, HAttr);
  231.    end;
  232. end;
  233.  
  234. {******************************************************}
  235. {Initialization needed for the unit}
  236. begin
  237.   GraphOn := false;
  238. end.
  239.  
  240.