home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / OOTP_4.ZIP / CHAP7.LST / MYWINDOW.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-04-16  |  12.0 KB  |  454 lines
  1. unit Mywindow;  { Listing 7-4 }
  2. {$A+,B-,D+,E+,F+,I+,L+,N-,O-,R-,S+,V+}
  3. {$M 16384,0,655360}
  4.  
  5. interface
  6.  
  7. uses Graph, ListObj, Crt, Mouse, Dos;
  8.  
  9. const
  10.      PathToDriver : string = 'C:\TP';
  11.  
  12. type
  13.  
  14. ScreenPtr = ^Screen;
  15. GWindowPtr = ^GWindow;
  16.  
  17.  
  18. Proc = procedure;
  19. ProcPtr = ^Proc;
  20.  
  21. VPort = object
  22.         Value : ViewPortType;
  23.         procedure Init( Left, Top, Right, Bottom : integer;
  24.                             ClipQ, SetQ : boolean );
  25.         procedure SetValue;
  26.         procedure GetValue( var AValue : ViewPortType );
  27.         end;
  28.  
  29. Screen = object(List)
  30.          SViewPort : VPort;
  31.          SColor    : integer;
  32.          SFill     : integer;
  33.          SLine     : integer;
  34.          MouseToken : GWindowPtr;
  35.          MouseX     : integer;
  36.          MouseY     : integer;
  37.          CloseHead  : boolean;
  38.          procedure Init( L,T,R,B,Color,Fill,Line : integer;
  39.                                               Clip : boolean );
  40.          procedure RestoreVP;
  41.          procedure UpdateMouse;
  42.          procedure DefaultMouseAction;
  43.          end;
  44.  
  45. GWindow = object(Node)
  46.           GWViewPort  : VPort;
  47.           WindName    : string;
  48.           BelowGWArea : pointer;
  49.           BelowGWSize : word;
  50.           GWFillS     : integer;
  51.           GWFillC     : integer;
  52.           GWColor1    : integer;
  53.           ParentScr   : ScreenPtr;
  54.           constructor Init( FillStyle, FillColor, BColor1 : integer;
  55.                             PScreen : ScreenPtr; WLabel : string );
  56.           destructor Done;
  57.           procedure PrependToList( var AList : List );
  58.           function InboundMouse : boolean;
  59.           procedure MouseAction;
  60.           procedure LocalMouseCoords( var  x, y : integer );
  61.           end;
  62.  
  63. procedure mstart;
  64. procedure EntryPoint;
  65. procedure SetMouseHandler( mask : integer );
  66.  
  67. var
  68.    S,T : Screen;
  69.    GraphDriver, Graphmode : integer;
  70.  
  71. implementation
  72.  
  73. var
  74.    xpos, ypos : integer;
  75.    ConMask : integer;
  76.    index : integer;
  77.  
  78. function FindAll( pNode : pointer ) : boolean;
  79. begin
  80.      FindAll := true;
  81. end;
  82.  
  83. function FindMouse( ANode : pointer ) : boolean;
  84. var pGW : GWindowPtr;
  85. begin
  86.      pGW := ANode;
  87.      if pGW^.InBoundMouse = true then
  88.         begin
  89.         pGW^.ParentScr^.MouseToken := pGW;
  90.         FindMouse := true;
  91.         end
  92.      else
  93.         FindMouse := false;
  94. end;
  95.  
  96. {$L MTEST5.OBJ}
  97. {$F-}
  98. procedure mstart; external;
  99. {$F+}
  100.  
  101. procedure SetMouseHandler( mask : integer );
  102. var R : registers;
  103. begin
  104.      R.AX := $C;
  105.      R.BX := $0;
  106.      R.CX := mask;
  107.      R.DX := Ofs(mstart);
  108.      R.ES := Seg(mstart);
  109.      Intr( $33, R );
  110. end;
  111.  
  112.  
  113. procedure Screen.Init( L,T,R,B,Color,Fill,Line : integer;
  114.                                               Clip : boolean );
  115. var
  116.    UMP : array[0..3] of byte;
  117.    a,c : word;
  118.    UMPDest : pointer;
  119.    i : integer;
  120. begin
  121.      List.Init;  {Initialize the list part of the Screen object }
  122.      { Initialize the mouse and set the mouse handler with all bits in }
  123.      { the condition mask set }
  124.      FindObjectDemon := FindMouse;
  125.      { The mouse shall look like an arrow. }
  126.      {MouseArrowCursor;}
  127.      SViewPort.Init( L, T, R, B, Clip, true );
  128.      if MouseInit = true then  SetMouseHandler( 30 );
  129.      { should be 30 if you don't want to track movement; 31 if you do }
  130.  
  131.      SColor := Color;
  132.      SFill  := Fill;
  133.      SLine  := Line;
  134.      CloseHead := false;
  135.      SetFillStyle( Fill, Color );
  136.      SetLineStyle( Line, 0, white );
  137.      bar( L, T, R, B );
  138.      MouseToken := nil;
  139.      MouseShow;
  140. end;
  141.  
  142. procedure Screen.DefaultMouseAction;
  143. var
  144.    pNewWindow : GWindowPtr;
  145. begin
  146.    SetMouseHandler(0);
  147.    if MouseRPressed = true then
  148.       begin
  149.       sound(300);delay(40);nosound;
  150.       New(pNewWindow,
  151.           Init( solidfill, blue, white, @S, 'Window #'));
  152.       end;
  153.    SetMouseHandler(30);
  154. end;
  155.  
  156. procedure Screen.RestoreVP;  {restores the screen's viewport }
  157. begin
  158.      SViewPort.SetValue;
  159. end;
  160.  
  161. { The handler set in Screen.Init calls this function.   Anytime the
  162.   mouse moves or if any buttons are pushed, this routine gets called. }
  163. procedure Screen.UpdateMouse;
  164. var
  165.    VP :ViewPortType;
  166. begin
  167. if FindObject = true then
  168.    begin
  169.    GetViewSettings(VP);
  170.    MouseToken := GetCursor;
  171.    MouseToken^.GWViewPort.SetValue;
  172.    MouseToken^.MouseAction;
  173.    with VP do
  174.         SetViewPort( x1, y1, x2, y2, true );
  175.    if CloseHead = true then  { if top window requests closing }
  176.       begin
  177.       MouseToken := PopFirst;
  178.       Dispose(MouseToken,Done);            { Close the window }
  179.       CloseHead := false;    { reset request flag }
  180.       end;
  181.    end
  182. else
  183.    DefaultMouseAction;
  184. end;
  185.  
  186. procedure GetGWCoords( var x1, y1, x2, y2 : integer);
  187. var t, a1, a2, b1, b2 : integer;
  188.     color : word;
  189.     P : array[0..4] of pointer;
  190.     LS : LineSettingsType;
  191.  
  192.     function Max( x, y : integer ): integer;
  193.     begin
  194.          if x > y then Max := x else Max := y;
  195.     end;
  196.  
  197.     function Min( x, y : integer) : integer;
  198.     begin
  199.          if x < y then Min := x else Min := y;
  200.     end;
  201.  
  202.     procedure Shadow( x1, y1, x2, y2 : integer );
  203.     begin
  204.          Mark(P[0]);
  205.          GetMem( P[1], ImageSize( x1, y1, x2, y1) );
  206.          GetImage( x1, y1, x2, y1, P[1]^ ); { top }
  207.          GetMem( P[2], ImageSize( x2, y2, x2, y1) );
  208.          GetImage( x2, y2, x2, y1, P[2]^ ); {right}
  209.          GetMem( P[3], ImageSize( x1, y1, x1, y2) );
  210.          GetImage( x1, y1, x1, y2, P[3]^ ); { left }
  211.          GetMem( P[4], ImageSize( x1, y2, x2, y2) );
  212.          GetImage( x1, y2, x2, y2, P[4]^ ); {bottom }
  213.          Rectangle( x1, y1, x2, y2 );
  214.          PutImage( Min(x1, x2), y1, P[1]^, NormalPut );
  215.          PutImage( x2, Min( y1, y2 ), P[2]^, NormalPut );
  216.          PutImage( x1, Min( y1, y2), P[3]^, NormalPut );
  217.          PutImage( Min(x1,x2), y2, P[4]^, NormalPut );
  218.          Release(P[0]);
  219.     end;
  220.  
  221. begin
  222.      MouseCoords( x1, y1);  {grab the x,y coordinates!}
  223.      repeat
  224.      until MouseLPressed = true;
  225.      MouseHide;
  226.      repeat
  227.            MouseCoords(x2,y2);
  228.            Shadow(x1, y1, x2, y2);
  229.      until MouseLReleased = true;
  230.      if x1 > x2 then begin
  231.         t := x1;
  232.         x1 := x2;
  233.         x2 := t;
  234.         end;
  235.      if y1 > y2 then begin
  236.         t := y1;
  237.         y1 := y2;
  238.         y2 := t;
  239.         end;
  240. end;
  241.  
  242. constructor GWindow.Init( FillStyle, FillColor,
  243.                                 BColor1 : integer;
  244.                                 PScreen : ScreenPtr; WLabel : string );
  245. var OldVPort : VPort;
  246.     OldColor : integer;
  247.     OldFill  : FillSettingsType;
  248.     L, T, R, B : integer;
  249.     srg : string;
  250.  
  251.     function SaveArea( L, T, R, B : integer ) : boolean;
  252.     begin
  253.          BelowGWSize := ImageSize( L, T, R, B);
  254.          GetMem( BelowGWArea, BelowGWSize );
  255.          if (BelowGWArea = nil) or (BelowGWSize < 255) then
  256.             SaveArea := false
  257.          else begin
  258.             GetImage( L, T, R, B, BelowGWArea^ );
  259.             SaveArea := true;
  260.             end;
  261.     end;
  262.  
  263.     procedure AdrToHexStr( Adr : pointer; var s : string );
  264.     var
  265.        r : array[1..9] of byte;
  266.        tmp : word;
  267.        i   : integer;
  268.     begin
  269.          tmp := Seg( Adr^ );
  270.          r[4] := (tmp and $F);
  271.          r[3] := (tmp and $F0) shr 4;
  272.          r[2] := (tmp and $F00) shr 8;
  273.          r[1] := (tmp and $F000) shr 12;
  274.          tmp := Ofs( Adr^ );
  275.          r[9] := (tmp and $F);
  276.          r[8] := (tmp and $F0) shr 4;
  277.          r[7] := (tmp and $F00) shr 8;
  278.          r[6] := (tmp and $F000) shr 12;
  279.          r[5] := 0;
  280.          for i := 1 to 9 do
  281.              if r[i] < 10 then
  282.                 s[i] := Chr($30 + r[i])
  283.              else
  284.                 s[i] := Chr($37 + r[i]);
  285.          s[5] := ':';
  286.          s[0] := Chr(9);
  287.     end;
  288.  
  289.  
  290.  
  291. begin
  292.      Node.Init( SizeOf( Self ) );
  293.      GetFillSettings( OldFill );
  294.  
  295.      GWFillS  := FillStyle;     { Save fill style }
  296.      GWFillC  := FillColor;
  297.      GWColor1 := BColor1;       { Save primary fill color }
  298.      Str( index, srg );
  299.      Windname := WLabel+srg;
  300.      Inc(index);
  301.      OldColor := GetColor;
  302.      ParentScr := PScreen;      { Save pointer to parent screen }
  303.      GetViewSettings(OldVPort.Value);
  304.      ParentScr^.RestoreVP;      { Restore parent screen viewport }
  305.      GetGWCoords( L, T, R, B );
  306.      if not SaveArea( L, T, R, B ) then
  307.         begin
  308.         sound(600);delay(100);nosound;
  309.         OldVPort.SetValue;
  310.         MoveTo( 0,0 );
  311.         GWindow.Done;
  312.         MouseShow;
  313.         fail;
  314.         end
  315.      else
  316.         begin
  317.         SetColor(GWColor1);                { set window's color }
  318.         SetFillStyle(GWFillS,GWFillC);     { set window's fill data }
  319.         SetLineStyle(Solidln,0,NormWidth); { set generic line style }
  320.         Bar3D( L, T, R, B, 0, false );  { draw window }
  321.         Line( L, T+(2*TextHeight(WindName)), R, T+(2*TextHeight(WindName)) );
  322.         GWViewPort.Init( L, T, R, B, true, true );  { store & set }
  323.         SetTextJustify( CenterText, CenterText );
  324.         OutTextXY( Round((R-L)/2), TextHeight(WindName), WindName);
  325.         AdrToHexStr(HeapPtr, srg);
  326.         OutTextXY( Round((R-L)/2), Round((B-T)/2), srg );
  327.         Str(BelowGWSize, srg);
  328.         OutTextXY( 40, 40, srg );
  329.         PrependToList( ParentScr^ ); { add this window to screen's tally }
  330.         SetColor( OldColor );               { restore old color... }
  331.         SetFillStyle( OldFill.Pattern, OldFill.Color );    { ...and fill }
  332.         end;
  333.      {MouseArrowCursor;}
  334.      MouseShow;
  335. end;
  336.  
  337. destructor GWindow.Done;
  338. begin
  339.      GWViewPort.SetValue;
  340.      MouseHide;
  341.      if BelowGWArea <> nil then
  342.         begin
  343.         PutImage(0,0,BelowGWArea^,CopyPut);
  344.         FreeMem( BelowGWArea, BelowGWSize );
  345.         end;
  346.      MouseShow;
  347. end;
  348.  
  349. function GWindow.InboundMouse : boolean;
  350. begin
  351.      if (GWViewPort.Value.x1 <= ParentScr^.MouseX) and
  352.         (GWViewPort.Value.x2 >= ParentScr^.MouseX) and
  353.         (GWViewPort.Value.y1 <= ParentScr^.MouseY) and
  354.         (GWViewPort.Value.y2 >= ParentScr^.MouseY) then
  355.              InboundMouse := true
  356.         else
  357.              InboundMouse := false;
  358. end;
  359.  
  360.  
  361. procedure GWindow.PrependToList( var AList : List );
  362. begin
  363.      Node.PrependToList( AList );
  364.      MouseShow;
  365. end;
  366.  
  367. procedure GWindow.LocalMouseCoords( var x, y : integer );
  368. var
  369.    VP :ViewPortType;
  370. begin
  371.      GWViewPort.GetValue(VP);
  372.      MouseCoords( x, y );
  373.      ParentScr^.MouseX := x;
  374.      ParentScr^.MouseY := y;
  375.      with VP do
  376.           begin
  377.           x := x - x1;
  378.           y := y - y1;
  379.           end;
  380. end;
  381.  
  382. procedure GWindow.MouseAction;
  383. var
  384.    x,y :integer;
  385.    str : string;
  386. begin
  387.      while MouseLPressed = true do
  388.         begin
  389.         LocalMouseCoords(x,y);
  390.         MouseHide;
  391.         if (ParentScr^.FindObject = true) then
  392.            begin
  393.            if @Self = ParentScr^.MouseToken then
  394.               begin
  395.               PutPixel(x,y,white);
  396.               end;
  397.            end;
  398.         MouseShow;
  399.         end;
  400.      while MouseRPressed = true do
  401.            begin
  402.            sound(400);delay(100); nosound;
  403.            if @Self = ParentScr^.Head then
  404.               ParentScr^.CloseHead := true;
  405.            end;
  406. end;
  407.  
  408. procedure VPort.Init( Left, Top, Right, Bottom : integer;
  409.                             ClipQ, SetQ : boolean );
  410. begin
  411.      Value.x1 := Left;
  412.      Value.y1 := Top;
  413.      Value.x2 := Right;
  414.      Value.y2 := Bottom;
  415.      Value.Clip := ClipQ;
  416.      if SetQ = true then
  417.         SetValue;
  418. end;
  419.  
  420. procedure VPort.SetValue;
  421. begin
  422.      SetViewPort( Value.x1, Value.y1, Value.x2, Value.y2, Value.Clip );
  423. end;
  424.  
  425. procedure VPort.GetValue( var AValue : ViewPortType );
  426. begin
  427.      GetViewSettings( AValue );
  428. end;
  429. {$F+}
  430. procedure EntryPoint;
  431. {$F-}
  432. begin
  433.      S.MouseX := xpos;
  434.      S.MouseY := ypos;
  435.      S.UpdateMouse;
  436. end;
  437.  
  438. {$F+}
  439. function HeapFunc( size : word ) : integer;
  440. {$F-}
  441. begin
  442.      HeapFunc := 1;
  443. end;
  444.  
  445. begin
  446.      HeapError := @HeapFunc;
  447.      index := 1;
  448.      GraphDriver := Detect;  { Detect the graphics driver }
  449.      InitGraph( GraphDriver, GraphMode, PathToDriver ); { Initialize graphics }
  450.      S.Init( 0, 0, GetMaxX, GetMaxY, cyan, solidfill, solidln, true );
  451. end.
  452.  
  453.  
  454.