home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / QP_PAINT.ZIP / CTOOL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-05-22  |  22.6 KB  |  704 lines
  1. {$B-,F-,I+,R+}
  2.  
  3. unit CTool;
  4.  
  5. { Define TTool - a class for drawing tools }
  6.  
  7. { Copyright 1989
  8.   Scott Bussinger
  9.   110 South 131st Street
  10.   Tacoma, WA  98444
  11.   (206)531-8944
  12.   Compuserve 72247,2671 }
  13.  
  14. interface
  15.  
  16. uses CObject,CMouse,CWindow,CStyle,MSGraph,Crt;
  17.  
  18. type TToolPane = object(TPaneWindow)
  19.        procedure Anchor;                         { Set the anchor point for the tool }
  20.        procedure ClearAnchor;                    { The anchor should be broken }
  21.        procedure Draw;                           { Draw using the tool }
  22.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for this pane }
  23.        procedure Idle;                           { Let a text tool look at the keyboard }
  24.        function Select: boolean; override;       { Select this pane }
  25.        procedure SetCursor;                      { Set the mouse cursor for the tool }
  26.        procedure Track;                          { Track the mouse }
  27.        end;
  28.  
  29. type TEraserTool = object(TToolPane)
  30.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for an eraser }
  31.        function Select: boolean; override;       { Select an eraser }
  32.        end;
  33.  
  34. type TQuitTool = object(TToolPane)
  35.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for quitting }
  36.        function Select: boolean; override;       { Select to quit }
  37.        end;
  38.  
  39. type TModalToolPane = object(TToolPane)
  40.        fAnchored: boolean;
  41.        fAnchorPoint: _XYCoord;
  42.        fDrawAnchored: boolean;
  43.        fDrawPoint: _XYCoord;
  44.        fTrackPoint: _XYCoord;
  45.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a window }
  46.        procedure Anchor; override;               { Set the anchor point for the tool }
  47.        procedure ClearAnchor; override;          { The anchor should be broken }
  48.        procedure Draw; override;                 { Draw using the tool }
  49.        function Select: boolean; override;       { Select this pane }
  50.        procedure Track; override;                { Track the mouse }
  51.        end;
  52.  
  53. type TPenTool = object(TModalToolPane)
  54.        procedure Anchor; override;               { Set the anchor point for a pen }
  55.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a pen }
  56.        procedure Track; override;                { Track the mouse }
  57.        end;
  58.  
  59. type TPaintBucketTool = object(TModalToolPane)
  60.        procedure Draw; override;                 { Draw with a paint bucket }
  61.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a paint bucket }
  62.        procedure SetCursor; override;            { Set the mouse cursor for a paint bucket }
  63.        end;
  64.  
  65. type TRubberBandToolPane = object(TModalToolPane)
  66.        fRectangleTrack: boolean;
  67.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a rubberbanding tool }
  68.        procedure ClearAnchor; override;          { The anchor should be broken }
  69.        procedure Track; override;                { Track the mouse }
  70.        end;
  71.  
  72. type TRectangleRubberBandToolPane = object(TRubberBandToolPane)
  73.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a rectangular rubberband tool }
  74.        end;
  75.  
  76. type TLineTool = object(TRubberBandToolPane)
  77.        procedure Draw; override;                 { Draw using the line tool }
  78.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a line tool }
  79.        end;
  80.  
  81. type TBoxTool = object(TRectangleRubberBandToolPane)
  82.        procedure Draw; override;                 { Draw with a box }
  83.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a box tool }
  84.        end;
  85.  
  86. type TFilledBoxTool = object(TRectangleRubberBandToolPane)
  87.        procedure Draw; override;                 { Draw with a filled box }
  88.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a filled box tool }
  89.        end;
  90.  
  91. type TCircleTool = object(TRubberBandToolPane)
  92.        procedure Draw; override;                 { Draw with a circle }
  93.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a circle tool }
  94.        end;
  95.  
  96. type TFilledCircleTool = object(TRubberBandToolPane)
  97.        procedure Draw; override;                 { Draw with a filled circle }
  98.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a filled circle tool }
  99.        end;
  100.  
  101. type TEllipseTool = object(TRectangleRubberBandToolPane)
  102.        procedure Draw; override;                 { Draw with an ellipse }
  103.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for an ellipse tool }
  104.        end;
  105.  
  106. type TFilledEllipseTool = object(TRectangleRubberBandToolPane)
  107.        procedure Draw; override;                 { Draw with a filled ellipse }
  108.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a filled ellipse tool }
  109.        end;
  110.  
  111. type TTextTool = object(TRectangleRubberBandToolPane)
  112.        fEntryEnabled: boolean;
  113.        procedure Draw; override;                 { Draw with a text tool }
  114.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for a text tool }
  115.        procedure Idle; override;                 { Let the text tool look at the keyboard }
  116.        function Select: boolean; override;       { Select the text tool }
  117.        end;
  118.  
  119. type TToolWindow = object(TMultipanedWindow)
  120.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a tool selection window }
  121.        procedure ChangePane(Pane: integer); override; { Change to a new active pane }
  122.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new tool pane }
  123.        end;
  124.  
  125. implementation
  126.  
  127. var CurrentTrackLineStyle: word;
  128.  
  129. procedure TToolPane.Anchor;
  130.   { Set the anchor point for the tool }
  131.   begin
  132.   CurrentCanvas.Activate
  133.   end;
  134.  
  135. procedure TToolPane.ClearAnchor;
  136.   { The anchor should be broken }
  137.   begin
  138.   end;
  139.  
  140. procedure TToolPane.Draw;
  141.   { Draw using the tool }
  142.   begin
  143.   CurrentCanvas.Activate;
  144.   self.ClearAnchor
  145.   end;
  146.  
  147. procedure TToolPane.DrawIcon(Marked: boolean);
  148.   { Draw the icon for this tool }
  149.   begin
  150.   inherited self.DrawIcon(Marked);
  151.   if Marked                                      { Choose the background color for the icon }
  152.    then
  153.     _SetColor(SystemColor)
  154.    else
  155.     _SetColor(SystemBackground);
  156.   _Rectangle_w(_GFillInterior,0.00,0.00,1.00,1.00);
  157.   if Marked                                      { Choose the foreground color for the icon }
  158.    then
  159.     _SetColor(SystemBackground)
  160.    else
  161.     _SetColor(SystemColor)
  162.   end;
  163.  
  164. procedure TToolPane.Idle;
  165.   { Normally this does nothing }
  166.   begin
  167.   end;
  168.  
  169. function TToolPane.Select: boolean;
  170.   { Select this pane }
  171.   begin
  172.   Select := inherited self.Select;
  173.   Select := false;
  174.   self.ClearAnchor
  175.   end;
  176.  
  177. procedure TToolPane.SetCursor;
  178.   { Set the mouse cursor for the tool }
  179.   begin
  180.   Mouse.SetCursor(PenCursor)                     { The default tool cursor is a pen }
  181.   end;
  182.  
  183. procedure TToolPane.Track;
  184.   { Track the mouse }
  185.   begin
  186.   CurrentCanvas.Activate
  187.   end;
  188.  
  189. procedure TEraserTool.DrawIcon(Marked: boolean);
  190.   { Draw the icon for an eraser tool }
  191.   var DontCare: integer;
  192.   begin
  193.   inherited self.DrawIcon(Marked);
  194.   FitText(Roman,'C')
  195.   end;
  196.  
  197. function TEraserTool.Select: boolean;
  198.   { Clear the drawing window }
  199.   begin
  200.   Select := inherited self.Select;
  201.   Mouse.Hide;                                    { Keep the display clean }
  202.   _ClearScreen(_GViewport)
  203.   end;
  204.  
  205. procedure TQuitTool.DrawIcon(Marked: boolean);
  206.   { Draw the icon for the quitting tool }
  207.   var DontCare: integer;
  208.   begin
  209.   inherited self.DrawIcon(Marked);
  210.   FitText(Roman,'Q')
  211.   end;
  212.  
  213. function TQuitTool.Select: boolean;
  214.   { Quit the program }
  215.   begin
  216.   Select := inherited self.Select;
  217.   halt                                           { This one's easy -- just quit }
  218.   end;
  219.  
  220. procedure TModalToolPane.Init(Bordered: boolean;
  221.                               X1,Y1,X2,Y2: real);
  222.   { Initialize a window }
  223.   begin
  224.   inherited self.Init(Bordered,X1,Y1,X2,Y2);
  225.   self.ClearAnchor
  226.   end;
  227.  
  228. procedure TModalToolPane.Anchor;
  229.   { Set the anchor point for the tool }
  230.   begin
  231.   Mouse.DisableTextCursor;
  232.   Mouse.Hide;                                    { Keep the display clean }
  233.   inherited self.Anchor;
  234.   _GetViewCoord(Mouse.GetLocationX,Mouse.GetLocationY,self.fAnchorPoint);
  235.   self.fAnchored := true;
  236.   self.fTrackPoint := self.fAnchorPoint
  237.   end;
  238.  
  239. procedure TModalToolPane.ClearAnchor;
  240.   { The anchor should be broken }
  241.   begin
  242.   inherited self.ClearAnchor;
  243.   self.fAnchored := false
  244.   end;
  245.  
  246. procedure TModalToolPane.Draw;
  247.   { Draw using the tool }
  248.   begin
  249.   self.fDrawAnchored := self.fAnchored;
  250.   Mouse.Hide;                                    { Keep the display clean }
  251.   inherited self.Draw;
  252.   _GetViewCoord(Mouse.GetLocationX,Mouse.GetLocationY,self.fDrawPoint)
  253.   end;
  254.  
  255. function TModalToolPane.Select: boolean;
  256.   { Is this a modal tool? }
  257.   begin
  258.   Select := inherited self.Select;
  259.   Select := true;
  260.   Mouse.DisableTextCursor                        { Turn the text cursor off }
  261.   end;
  262.  
  263. procedure TModalToolPane.Track;
  264.   { Track the mouse }
  265.   begin
  266.   Mouse.Hide;                                    { Keep the display clean }
  267.   inherited self.Track;
  268.   _GetViewCoord(Mouse.GetLocationX,Mouse.GetLocationY,self.fTrackPoint)
  269.   end;
  270.  
  271. procedure TRubberBandToolPane.Init(Bordered: boolean;
  272.                                    X1,Y1,X2,Y2: real);
  273.   { Initialize a window }
  274.   begin
  275.   inherited self.Init(Bordered,X1,Y1,X2,Y2);
  276.   self.fRectangleTrack := false
  277.   end;
  278.  
  279. procedure XorRubberBand(Rectangular: boolean;
  280.                         var StartPoint,EndPoint: _XYCoord);
  281.   { Draw/Undraw a rubberband cursor }
  282.   var SaveStatus: GraphicsStatus;
  283.   begin
  284.   Mouse.Hide;                                    { Keep the display clean }
  285.   GetGraphicsStatus(SaveStatus);
  286.   _SetLineStyle(CurrentTrackLineStyle);
  287.   _SetWriteMode(_GXOR);                          { Temporarily switch to XOR mode }
  288.   _SetColor(SystemWhite);
  289.   if Rectangular                                 { Get rid of previous track }
  290.    then
  291.     _Rectangle(_GBorder,StartPoint.XCoord,StartPoint.YCoord,EndPoint.XCoord,EndPoint.YCoord)
  292.    else
  293.     begin
  294.     _MoveTo(StartPoint.XCoord,StartPoint.YCoord);
  295.     _LineTo(EndPoint.XCoord,EndPoint.YCoord)
  296.     end;
  297.   SetGraphicsStatus(SaveStatus)
  298.   end;
  299.  
  300. procedure TRubberBandToolPane.ClearAnchor;
  301.   { The anchor should be broken }
  302.   begin
  303.   if self.fAnchored then
  304.     XorRubberBand(self.fRectangleTrack,self.fAnchorPoint,self.fTrackPoint);
  305.   inherited self.ClearAnchor
  306.   end;
  307.  
  308. procedure TRubberBandToolPane.Track;
  309.   { Track the mouse }
  310.   var PreviousTrackPoint: _XYCoord;
  311.   begin
  312.   PreviousTrackPoint := self.fTrackPoint;
  313.   inherited self.Track;
  314.   if self.fAnchored and not CompareXYCoord(PreviousTrackPoint,self.fTrackPoint) then { Have we moved? }
  315.     begin
  316.     XorRubberBand(self.fRectangleTrack,self.fAnchorPoint,PreviousTrackPoint);
  317.     if not CompareXYCoord(self.fAnchorPoint,self.fTrackPoint) then
  318.       XorRubberBand(self.fRectangleTrack,self.fAnchorPoint,self.fTrackPoint)
  319.     end
  320.   end;
  321.  
  322. procedure TRectangleRubberBandToolPane.Init(Bordered: boolean;
  323.                                             X1,Y1,X2,Y2: real);
  324.   { Initialize a window }
  325.   begin
  326.   inherited self.Init(Bordered,X1,Y1,X2,Y2);
  327.   self.fRectangleTrack := true
  328.   end;
  329.  
  330. procedure TPenTool.Anchor;
  331.   { Move current position to mouse location }
  332.   begin
  333.   inherited self.Anchor;
  334.   _MoveTo(self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord)
  335.   end;
  336.  
  337. procedure TPenTool.DrawIcon(Marked: boolean);
  338.   { Draw the icon for the pen tool }
  339.   begin
  340.   inherited self.DrawIcon(Marked);
  341.   _MoveTo_w(0.13,0.87);
  342.   _LineTo_w(0.33,0.30);
  343.   _LineTo_w(0.48,0.30);
  344.   _LineTo_w(0.58,0.50);
  345.   _LineTo_w(0.63,0.50);
  346.   _LineTo_w(0.87,0.13)
  347.   end;
  348.  
  349. procedure TPenTool.Track;
  350.   { Leave a trail of dots by drawing a line to the current location }
  351.   begin
  352.   inherited self.Track;
  353.   if self.fAnchored then
  354.     _LineTo(self.fTrackPoint.XCoord,self.fTrackPoint.YCoord)
  355.   end;
  356.  
  357. procedure TPaintBucketTool.Draw;
  358.   { Start a Flood Fill at the current location }
  359.   begin
  360.   inherited self.Draw;
  361.   if self.fDrawAnchored then
  362.     _FloodFill(self.fDrawPoint.XCoord,self.fDrawPoint.YCoord,_GetColor)
  363.   end;
  364.  
  365. procedure TPaintBucketTool.DrawIcon(Marked: boolean);
  366.   { Draw the icon for a paint bucket }
  367.   begin
  368.   inherited self.DrawIcon(Marked);
  369.   _MoveTo_w(0.20,0.50);
  370.   _LineTo_w(0.70,0.20);
  371.   _LineTo_w(0.80,0.50);
  372.   _LineTo_w(0.30,0.80);
  373.   _LineTo_w(0.20,0.50);
  374.   _LineTo_w(0.80,0.50);
  375.   _LineTo_w(0.80,0.80);
  376.   _FloodFill_w(0.30,0.60,_GetColor)
  377.   end;
  378.  
  379. procedure TPaintBucketTool.SetCursor;
  380.   { Set a special cursor for a paint bucket tool }
  381.   begin
  382.   Mouse.SetCursor(BucketCursor)
  383.   end;
  384.  
  385. procedure TLineTool.Draw;
  386.   { Draw a straight line }
  387.   begin
  388.   inherited self.Draw;
  389.   if self.fDrawAnchored then
  390.     begin
  391.     _MoveTo(self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord);
  392.     _LineTo(self.fDrawPoint.XCoord,self.fDrawPoint.YCoord)
  393.     end
  394.   end;
  395.  
  396. procedure TLineTool.DrawIcon(Marked: boolean);
  397.   { Draw the icon for the line tool }
  398.   begin
  399.   inherited self.DrawIcon(Marked);
  400.   _MoveTo_w(0.20,0.80);
  401.   _LineTo_w(0.80,0.20);
  402.   _MoveTo_w(0.20,0.50);
  403.   _LineTo_w(0.80,0.50)
  404.   end;
  405.  
  406. procedure TBoxTool.Draw;
  407.   { Draw a rectangle }
  408.   begin
  409.   inherited self.Draw;
  410.   if self.fDrawAnchored then
  411.     _Rectangle(_GBorder,self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord,
  412.                         self.fDrawPoint.XCoord,self.fDrawPoint.YCoord)
  413.   end;
  414.  
  415. procedure TBoxTool.DrawIcon(Marked: boolean);
  416.   { Draw the icon for the box tool }
  417.   begin
  418.   inherited self.DrawIcon(Marked);
  419.   _Rectangle_w(_GBorder,0.20,0.20,0.80,0.80)
  420.   end;
  421.  
  422. procedure TFilledBoxTool.Draw;
  423.   { Draw a filled rectangle }
  424.   begin
  425.   inherited self.Draw;
  426.   if self.fDrawAnchored then
  427.     _Rectangle(_GFillInterior,self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord,
  428.                               self.fDrawPoint.XCoord,self.fDrawPoint.YCoord)
  429.   end;
  430.  
  431. procedure TFilledBoxTool.DrawIcon(Marked: boolean);
  432.   { Draw the icon for the filled box tool }
  433.   begin
  434.   inherited self.DrawIcon(Marked);
  435.   _Rectangle_w(_GFillInterior,0.20,0.20,0.80,0.80)
  436.   end;
  437.  
  438. procedure TCircleTool.Draw;
  439.   { Draw a circle }
  440.   var CenterX,CenterY: integer;
  441.       XRadius,YRadius: integer;
  442.   begin
  443.   inherited self.Draw;
  444.   if self.fDrawAnchored then
  445.     begin
  446.     CenterX := (self.fAnchorPoint.XCoord+self.fDrawPoint.XCoord) div 2;
  447.     CenterY := (self.fAnchorPoint.YCoord+self.fDrawPoint.YCoord) div 2;
  448.     XRadius := round(sqrt(sqr(longint(self.fAnchorPoint.XCoord-self.fDrawPoint.XCoord)) +
  449.                           sqr(AspectRatio*longint(self.fAnchorPoint.YCoord-self.fDrawPoint.YCoord))) / 2.0);
  450.     YRadius := round(XRadius * AspectRatio);
  451.     _Ellipse(_GBorder,CenterX-XRadius,CenterY-YRadius,CenterX+XRadius,CenterY+YRadius)
  452.     end
  453.  
  454.   (* this is code for specifying circles by center point and radius
  455.   XRadius := round(sqrt(sqr(self.fAnchorPoint.XCoord-self.fDrawPoint.XCoord) +
  456.                         sqr(AspectRatio*(self.fAnchorPoint.YCoord-self.fDrawPoint.YCoord))));
  457.   YRadius := round(XRadius * AspectRatio);
  458.   _Ellipse(_GBorder,self.fAnchorPoint.XCoord-XRadius,self.fAnchorPoint.YCoord-YRadius,
  459.                     self.fAnchorPoint.XCoord+XRadius,self.fAnchorPoint.YCoord+YRadius)
  460.   *)
  461.   end;
  462.  
  463. procedure TCircleTool.DrawIcon(Marked: boolean);
  464.   { Draw the icon for a circle tool }
  465.   const XRadius = 0.35;
  466.   var YRadius: real;
  467.   begin
  468.   inherited self.DrawIcon(Marked);
  469.   YRadius := XRadius * AspectRatioW;
  470.   _Ellipse_w(_GBorder,0.50-XRadius,0.50-YRadius,0.50+XRadius,0.50+YRadius)
  471.   end;
  472.  
  473. procedure TFilledCircleTool.Draw;
  474.   { Draw a filled circle }
  475.   var CenterX,CenterY: integer;
  476.       XRadius,YRadius: integer;
  477.   begin
  478.   inherited self.Draw;
  479.   if self.fDrawAnchored then
  480.     begin
  481.     CenterX := (self.fAnchorPoint.XCoord+self.fDrawPoint.XCoord) div 2;
  482.     CenterY := (self.fAnchorPoint.YCoord+self.fDrawPoint.YCoord) div 2;
  483.     XRadius := round(sqrt(sqr(longint(self.fAnchorPoint.XCoord-self.fDrawPoint.XCoord)) +
  484.                           sqr(AspectRatio*longint(self.fAnchorPoint.YCoord-self.fDrawPoint.YCoord))) / 2.0);
  485.     YRadius := round(XRadius * AspectRatio);
  486.     _Ellipse(_GFillInterior,CenterX-XRadius,CenterY-YRadius,CenterX+XRadius,CenterY+YRadius)
  487.     end
  488.  
  489.   (* this is code for specifying circles by center point and radius
  490.   XRadius := round(sqrt(sqr(self.fAnchorPoint.XCoord-self.fDrawPoint.XCoord) +
  491.                         sqr(AspectRatio*(self.fAnchorPoint.YCoord-self.fDrawPoint.YCoord))));
  492.   YRadius := round(XRadius * AspectRatio);
  493.   _Ellipse(_GFillInterior,self.fAnchorPoint.XCoord-XRadius,self.fAnchorPoint.YCoord-YRadius,
  494.                           self.fAnchorPoint.XCoord+XRadius,self.fAnchorPoint.YCoord+YRadius)
  495.   *)
  496.   end;
  497.  
  498. procedure TFilledCircleTool.DrawIcon(Marked: boolean);
  499.   { Draw the icon for a filled circle tool }
  500.   const XRadius = 0.35;
  501.   var YRadius: real;
  502.   begin
  503.   inherited self.DrawIcon(Marked);
  504.   YRadius := XRadius * AspectRatioW;
  505.   _Ellipse_w(_GFillInterior,0.50-XRadius,0.50-YRadius,0.50+XRadius,0.50+YRadius)
  506.   end;
  507.  
  508. procedure TEllipseTool.Draw;
  509.   { Draw an ellipse }
  510.   begin
  511.   inherited self.Draw;
  512.   if self.fDrawAnchored then
  513.     _Ellipse(_GBorder,self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord,
  514.                       self.fDrawPoint.XCoord,self.fDrawPoint.YCoord)
  515.   end;
  516.  
  517. procedure TEllipseTool.DrawIcon(Marked: boolean);
  518.   { Draw the icon for the ellipse tool }
  519.   begin
  520.   inherited self.DrawIcon(Marked);
  521.   _Ellipse_w(_GBorder,0.30,0.20,0.70,0.80)
  522.   end;
  523.  
  524. procedure TFilledEllipseTool.Draw;
  525.   { Draw a filled ellipse }
  526.   begin
  527.   inherited self.Draw;
  528.   if self.fDrawAnchored then
  529.     _Ellipse(_GFillInterior,self.fAnchorPoint.XCoord,self.fAnchorPoint.YCoord,
  530.                             self.fDrawPoint.XCoord,self.fDrawPoint.YCoord)
  531.   end;
  532.  
  533. procedure TFilledEllipseTool.DrawIcon(Marked: boolean);
  534.   { Draw the icon for a filled ellipse tool }
  535.   begin
  536.   inherited self.DrawIcon(Marked);
  537.   _Ellipse_w(_GFillInterior,0.30,0.20,0.70,0.80)
  538.   end;
  539.  
  540. procedure TTextTool.Draw;
  541.   { Setup for text entry }
  542.   var DontCare: integer;
  543.       Ch: char;
  544.       Height: integer;
  545.       Left: integer;
  546.       Top: integer;
  547.       Width: integer;
  548.   begin
  549.   inherited self.Draw;
  550.   if self.fDrawAnchored then
  551.     begin
  552.     Height := abs(self.fAnchorPoint.YCoord-self.fDrawPoint.YCoord);
  553.     if Height < 5 then                           { Always pick a minimum height }
  554.       Height := 5;
  555.     Width := abs(self.fAnchorPoint.XCoord-self.fDrawPoint.XCoord);
  556.     if Width < 5 then                            { Always pick a minimum width }
  557.       Width := 5;
  558.     SetFont(CurrentFont,Height,Width);
  559.     if self.fAnchorPoint.XCoord < self.fDrawPoint.XCoord
  560.      then
  561.       Left := self.fAnchorPoint.XCoord
  562.      else
  563.       Left := self.fDrawPoint.XCoord;
  564.     if self.fAnchorPoint.YCoord < self.fDrawPoint.YCoord
  565.      then
  566.       Top := self.fAnchorPoint.YCoord
  567.      else
  568.       Top := self.fDrawPoint.YCoord;
  569.     _MoveTo(Left,Top);                           { Move the current position to the top left corner }
  570.     Mouse.SetTextCursor(Height);                 { Turn on the text cursor }
  571.     Mouse.EnableTextCursor;
  572.     self.fEntryEnabled := true;                  { Allow text entry now }
  573.     while keypressed do                          { Clear the keyboard buffer }
  574.       Ch := ReadKey
  575.     end
  576.   end;
  577.  
  578. procedure TTextTool.DrawIcon(Marked: boolean);
  579.   { Draw the icon for the text tool }
  580.   begin
  581.   inherited self.DrawIcon(Marked);
  582.   FitText(Modern,'Abc');
  583.   end;
  584.  
  585. procedure TTextTool.Idle;
  586.   { Watch the keyboard }
  587.   var Ch: char;
  588.   begin
  589.   inherited self.Idle;
  590.   if self.fEntryEnabled then
  591.     Mouse.EnableTextCursor;
  592.   if keypressed then
  593.     begin
  594.     Ch := ReadKey;
  595.     if Ch = #0                                   { Clear function keys }
  596.      then
  597.       Ch := ReadKey
  598.      else
  599.       if (Ch>=' ') and self.fEntryEnabled then
  600.         begin
  601.         Mouse.Hide;
  602.         CurrentCanvas.Activate;
  603.         _OutGText(Ch)
  604.         end
  605.     end
  606.   end;
  607.  
  608. function TTextTool.Select: boolean;
  609.   { Turn off text entry until a size is selected }
  610.   begin
  611.   Select := inherited self.Select;
  612.   self.fEntryEnabled := false
  613.   end;
  614.  
  615. procedure TToolWindow.Init(Bordered: boolean;
  616.                            X1,Y1,X2,Y2: real);
  617.   { Initialize a tool selection window }
  618.   begin
  619.   inherited self.Init(false,X1,Y1,X2,Y2);
  620.   self.Partition(Bordered,X1,Y1,X2,Y2,2,6)
  621.   end;
  622.  
  623. procedure TToolWindow.ChangePane(Pane: integer);
  624.   { Change to a new active pane }
  625.   begin
  626.   self.fPane[self.fCurrentPane].DrawIcon(false); { Turn off the previous icon }
  627.   inherited self.ChangePane(Pane);               { Change the current pane }
  628.   self.fPane[self.fCurrentPane].DrawIcon(true)   { Turn on the new icon }
  629.   end;
  630.  
  631. function TToolWindow.CreatePane(Pane: integer): TPaneWindow;
  632.   { Create a new tool pane }
  633.   var Temp: record
  634.         case integer of
  635.           0: (PenTool: TPenTool);
  636.           1: (LineTool: TLineTool);
  637.           2: (BoxTool: TBoxTool);
  638.           3: (FilledBoxTool: TFilledBoxTool);
  639.           4: (CircleTool: TCircleTool);
  640.           5: (FilledCircleTool: TFilledCircleTool);
  641.           6: (EllipseTool: TEllipseTool);
  642.           7: (FilledEllipseTool: TFilledEllipseTool);
  643.           8: (TextTool: TTextTool);
  644.           9: (PaintBucketTool: TPaintBucketTool);
  645.           10: (EraserTool: TEraserTool);
  646.           11: (QuitTool: TQuitTool)
  647.         end;
  648.   begin
  649.   case Pane of
  650.     0: begin
  651.        new(Temp.PenTool);
  652.        CreatePane := Temp.PenTool
  653.        end;
  654.     1: begin
  655.        new(Temp.LineTool);
  656.        CreatePane := Temp.LineTool
  657.        end;
  658.     2: begin
  659.        new(Temp.BoxTool);
  660.        CreatePane := Temp.BoxTool
  661.        end;
  662.     3: begin
  663.        new(Temp.FilledBoxTool);
  664.        CreatePane := Temp.FilledBoxTool
  665.        end;
  666.     4: begin
  667.        new(Temp.CircleTool);
  668.        CreatePane := Temp.CircleTool
  669.        end;
  670.     5: begin
  671.        new(Temp.FilledCircleTool);
  672.        CreatePane := Temp.FilledCircleTool
  673.        end;
  674.     6: begin
  675.        new(Temp.EllipseTool);
  676.        CreatePane := Temp.EllipseTool
  677.        end;
  678.     7: begin
  679.        new(Temp.FilledEllipseTool);
  680.        CreatePane := Temp.FilledEllipseTool
  681.        end;
  682.     8: begin
  683.        new(Temp.TextTool);
  684.        CreatePane := Temp.TextTool
  685.        end;
  686.     9: begin
  687.        new(Temp.PaintBucketTool);
  688.        CreatePane := Temp.PaintBucketTool
  689.        end;
  690.     10: begin
  691.         new(Temp.EraserTool);
  692.         CreatePane := Temp.EraserTool
  693.         end;
  694.     11: begin
  695.         new(Temp.QuitTool);
  696.         CreatePane := Temp.QuitTool
  697.         end;
  698.     end
  699.   end;
  700.  
  701. begin
  702. CurrentTrackLineStyle := $6666
  703. end.
  704.