home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / pascal / qp_paint.arc / CSTYLE.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-22  |  19KB  |  581 lines
  1. {$B-,F-,I+,R+}
  2.  
  3. unit CStyle;
  4.  
  5. { Define TStyle - a class for various drawing styles }
  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,MSGraph;
  17.  
  18. const MaxPanes = 16;
  19.  
  20. type TPaneWindow = object(TDrawingWindow)
  21.        procedure Define(Pane: integer);          { Define a new pane }
  22.        procedure DrawIcon(Marked: boolean);      { Draw the icon for this pane }
  23.        function Select: boolean;                 { Select this pane }
  24.        end;
  25.  
  26. type TMultipanedWindow = object(TWindow)
  27.        fCurrentPane: integer;
  28.        fNumPanes: integer;
  29.        fPane: array[0..MaxPanes-1] of TPaneWindow;
  30.        procedure Free; override;                 { Release a multipaned window }
  31.        procedure ChangePane(Pane: integer);      { Change to a new active pane }
  32.        function CheckMouse: boolean; override;   { Check if the mouse is in this window }
  33.        function CreatePane(Pane: integer): TPaneWindow; { Create a new window pane }
  34.        function CurrentPane: TPaneWindow;        { Get the current pane in window }
  35.        procedure Partition(Bordered: boolean;X1,Y1,X2,Y2: real;Across,Down: integer); { Partition a window with lots of panes }
  36.        procedure SetCursor;                      { Set the mouse cursor for the window }
  37.        end;
  38.  
  39. type TColorPane = object(TPaneWindow)
  40.        procedure Define(Pane: integer); override; { Define a new color pane }
  41.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for this color }
  42.        function Select: boolean; override;       { Select this color }
  43.        end;
  44.  
  45. type TColorWindow = object(TMultipanedWindow)
  46.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a color selection window }
  47.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new color pane }
  48.        end;
  49.  
  50. type TFillPane = object(TPaneWindow)
  51.        procedure Define(Pane: integer); override; { Define a new fill mask pane }
  52.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for this fill mask }
  53.        function Select: boolean; override;       { Select this fill mask }
  54.        end;
  55.  
  56. type TFillWindow = object(TMultipanedWindow)
  57.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a fill mask selection window }
  58.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new fill mask pane }
  59.        end;
  60.  
  61. type TLinePane = object(TPaneWindow)
  62.        procedure Define(Pane: integer); override; { Define a new line style pane }
  63.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for this line style }
  64.        function Select: boolean; override;       { Select this line style pane }
  65.        end;
  66.  
  67. type TLineWindow = object(TMultipanedWindow)
  68.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a line style selection window }
  69.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new line style pane }
  70.        end;
  71.  
  72. type TFontPane = object(TPaneWindow)
  73.        procedure Define(Pane: integer); override; { Define a new font pane }
  74.        procedure DrawIcon(Marked: boolean); override; { Draw the icon for this font }
  75.        function Select: boolean; override;       { Select this font }
  76.        end;
  77.  
  78. type TFontWindow = object(TMultipanedWindow)
  79.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a font selection window }
  80.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new font pane }
  81.        end;
  82.  
  83. type TColorStylePane = object(TPaneWindow)
  84.        procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the current color }
  85.        end;
  86.  
  87. type TFillStylePane = object(TPaneWindow)
  88.        procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the fill mask }
  89.        end;
  90.  
  91. type TLineStylePane = object(TPaneWindow)
  92.        procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the line style }
  93.        end;
  94.  
  95. type TFontStylePane = object(TPaneWindow)
  96.        procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the font }
  97.        end;
  98.  
  99. type TStyleWindow = object(TMultipanedWindow)
  100.        fCurrentWindow: TMultipanedWindow;
  101.        fCurrentWindowBordered: boolean;
  102.        fWX1: real;
  103.        fWX2: real;
  104.        fWY1: real;
  105.        fWY2: real;
  106.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a current style selection window }
  107.        procedure Free; override;                    { Release a current style window }
  108.        function CheckMouse: boolean; override;      { Check if the mouse is in this window }
  109.        function CreatePane(Pane: integer): TPaneWindow; override; { Create a new current style pane }
  110.        end;
  111.  
  112. implementation
  113.  
  114. procedure TMultipanedWindow.Free;
  115.   { Release a multipaned window }
  116.   var I: integer;
  117.   begin
  118.   for I := 0 to self.fNumPanes-1 do
  119.     self.fPane[I].Free;
  120.   inherited self.Free
  121.   end;
  122.  
  123. procedure TMultipanedWindow.ChangePane(Pane: integer);
  124.   { Change to a new active pane }
  125.   begin
  126.   self.fCurrentPane := Pane                      { Change the current pane }
  127.   end;
  128.  
  129. function TMultipanedWindow.CheckMouse: boolean;
  130.   { Check if the mouse is in this window }
  131.   var I: integer;
  132.   begin
  133.   CheckMouse := false;
  134.   if inherited self.CheckMouse then              { See if we're in this window at all }
  135.     begin
  136.     I := 0;                                      { Check a multipaned window by looking at each of the panes }
  137.     while (I<self.fNumPanes) and not (self.fPane[I].CheckMouse) do
  138.       inc(I);
  139.     if I < self.fNumPanes then
  140.       begin
  141.       CheckMouse := true;
  142.       self.SetCursor;                            { Change to the appropriate mouse cursor }
  143.       if (Mouse.GetButton(Left)=Released) and    { Was the button just released? }
  144.          self.fPane[I].Select then               { Does this pane cause a mode change? }
  145.         self.ChangePane(I)
  146.       end
  147.     end
  148.   end;
  149.  
  150. function TMultipanedWindow.CreatePane(Pane: integer): TPaneWindow;
  151.   { Create a new pane }
  152.   var Temp: TPaneWindow;
  153.   begin
  154.   new(Temp);
  155.   CreatePane := Temp
  156.   end;
  157.  
  158. function TMultipanedWindow.CurrentPane: TPaneWindow;
  159.   { Get the current pane }
  160.   begin
  161.   CurrentPane := self.fPane[self.fCurrentPane]
  162.   end;
  163.  
  164. procedure TMultipanedWindow.Partition(Bordered: boolean;
  165.                                       X1,Y1,X2,Y2: real;Across,Down: integer);
  166.   { Partition a window into an array of panes }
  167.   var I: integer;
  168.       R,C: integer;
  169.   begin
  170.   self.fNumPanes := Across * Down;
  171.   if self.fNumPanes > MaxPanes then
  172.     begin
  173.     self.fNumPanes := MaxPanes;
  174.     Across := MaxPanes div Down
  175.     end;
  176.   for I := 0 to self.fNumPanes-1 do
  177.     begin
  178.     R := I div Across;
  179.     C := I mod Across;
  180.     self.fPane[I] := self.CreatePane(I);
  181.     self.fPane[I].Init(Bordered,
  182.                          C  *(X2-X1)/Across + X1, { Initialize a drawing window in the small area }
  183.                          R  *(Y2-Y1)/Down + Y1,
  184.                        (C+1)*(X2-X1)/Across + X1,
  185.                        (R+1)*(Y2-Y1)/Down + Y1);
  186.     self.fPane[I].Define(I);
  187.     self.fPane[I].DrawIcon(false)
  188.     end;
  189.   self.fCurrentPane := 0;
  190.   self.ChangePane(self.fCurrentPane)
  191.   end;
  192.  
  193. procedure TMultipanedWindow.SetCursor;
  194.   { Set the mouse cursor for the window }
  195.   begin
  196.   Mouse.SetCursor(HandCursor)
  197.   end;
  198.  
  199. procedure TPaneWindow.Define(Pane: integer);
  200.   { Define a new pane }
  201.   begin
  202.   { Should be overridden in all subclasses }
  203.   end;
  204.  
  205. procedure TPaneWindow.DrawIcon(Marked: boolean);
  206.   { Draw the icon for this pane }
  207.   begin
  208.   Mouse.Hide;                                    { Keep the display clean }
  209.   self.Activate                                  { Switch to this window }
  210.   end;
  211.  
  212. function TPaneWindow.Select: boolean;
  213.   { Select this pane }
  214.   { Return true if selecting this pane should change the current pane or
  215.     false if the previous pane stays in effect. }
  216.   begin
  217.   Select := true;
  218.   CurrentCanvas.Activate
  219.   end;
  220.  
  221. procedure TColorPane.DrawIcon(Marked: boolean);
  222.   { Draw the icon for this color }
  223.   begin
  224.   inherited self.DrawIcon(Marked);
  225.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  226.   end;
  227.  
  228. procedure TColorPane.Define(Pane: integer);
  229.   { Define a new color pane }
  230.   begin
  231.   inherited self.Define(Pane);
  232.   _SetColor(Pane)
  233.   end;
  234.  
  235. function TColorPane.Select: boolean;
  236.   { Select this color }
  237.   var TempColor: integer;
  238.   begin
  239.   TempColor := _GetColor;
  240.   Select := inherited self.Select;
  241.   _SetColor(TempColor)
  242.   end;
  243.  
  244. procedure TColorWindow.Init(Bordered: boolean;
  245.                             X1,Y1,X2,Y2: real);
  246.   { Initialize a color selection window }
  247.   begin
  248.   inherited self.Init(false,X1,Y1,X2,Y2);
  249.   if VideoConfig.NumColors = 2                   { Watch for this special case, for a better looking display }
  250.    then
  251.     self.Partition(Bordered,X1,Y1,X2,Y2,2,1)
  252.    else
  253.     self.Partition(Bordered,X1,Y1,X2,Y2,VideoConfig.NumColors div 2,2);
  254.   self.ChangePane(self.fNumPanes-1)
  255.   end;
  256.  
  257. function TColorWindow.CreatePane(Pane: integer): TPaneWindow;
  258.   { Create a new color pane }
  259.   var Temp: TColorPane;
  260.   begin
  261.   new(Temp);
  262.   CreatePane := Temp
  263.   end;
  264.  
  265. procedure TFillPane.DrawIcon(Marked: boolean);
  266.   { Draw the icon for this fill mask }
  267.   var DontCare: boolean;
  268.       SaveFill: _FillMask;
  269.   begin
  270.   inherited self.DrawIcon(Marked);
  271.   DontCare := _GetFillMask(SaveFill);
  272.   _SetFillMask(FillMask[SolidFill]);
  273.   _SetColor(SystemBackground);
  274.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  275.   _SetFillMask(SaveFill);
  276.   _SetColor(SystemWhite);
  277.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  278.   end;
  279.  
  280. procedure TFillPane.Define(Pane: integer);
  281.   { Define a new fill mask pane }
  282.   begin
  283.   inherited self.Define(Pane);
  284.   _SetFillMask(FillMask[Pane])
  285.   end;
  286.  
  287. function TFillPane.Select: boolean;
  288.   { Select this fill mask }
  289.   var DontCare: boolean;
  290.       TempFillMask: _FillMask;
  291.   begin
  292.   DontCare := _GetFillMask(TempFillMask);
  293.   Select := inherited self.Select;
  294.   _SetFillMask(TempFillMask)
  295.   end;
  296.  
  297. procedure TFillWindow.Init(Bordered: Boolean;
  298.                            X1,Y1,X2,Y2: real);
  299.   { Initialize a fill mask selection window }
  300.   begin
  301.   inherited self.Init(false,X1,Y1,X2,Y2);
  302.   self.Partition(Bordered,X1,Y1,X2,Y2,MaxFillMasks div 2,2);
  303.   self.ChangePane(self.fNumPanes-1)
  304.   end;
  305.  
  306. function TFillWindow.CreatePane(Pane: integer): TPaneWindow;
  307.   { Create a new fill mask pane }
  308.   var Temp: TFillPane;
  309.   begin
  310.   new(Temp);
  311.   CreatePane := Temp
  312.   end;
  313.  
  314. procedure TLinePane.DrawIcon(Marked: boolean);
  315.   { Draw the icon for this line style }
  316.   begin
  317.   inherited self.DrawIcon(Marked);
  318.   _SetColor(SystemBackground);
  319.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  320.   _SetColor(SystemWhite);
  321.   _MoveTo_W(0.00,0.33);
  322.   _LineTo_W(1.00,0.33);
  323.   _MoveTo_W(0.00,0.66);
  324.   _LineTo_W(1.00,0.66)
  325.   end;
  326.  
  327. procedure TLinePane.Define(Pane: integer);
  328.   { Define a new line style pane }
  329.   begin
  330.   inherited self.Define(Pane);
  331.   _SetLineStyle(LineStyle[Pane])
  332.   end;
  333.  
  334. function TLinePane.Select: boolean;
  335.   { Select this line style }
  336.   var TempLineStyle: word;
  337.   begin
  338.   TempLineStyle := _GetLineStyle;
  339.   Select := inherited self.Select;
  340.   _SetLineStyle(TempLineStyle)
  341.   end;
  342.  
  343. procedure TLineWindow.Init(Bordered: boolean;
  344.                            X1,Y1,X2,Y2: real);
  345.   { Initialize a line style selection window }
  346.   begin
  347.   inherited self.Init(false,X1,Y1,X2,Y2);
  348.   self.Partition(Bordered,X1,Y1,X2,Y2,MaxLineStyles div 2,2);
  349.   self.ChangePane(self.fNumPanes-1)
  350.   end;
  351.  
  352. function TLineWindow.CreatePane(Pane: integer): TPaneWindow;
  353.   { Create a new line style window pane }
  354.   var Temp: TLinePane;
  355.   begin
  356.   new(Temp);
  357.   CreatePane := Temp
  358.   end;
  359.  
  360. procedure TFontPane.DrawIcon(Marked: boolean);
  361.   { Draw the icon for this font }
  362.   begin
  363.   inherited self.DrawIcon(Marked);
  364.   _SetColor(SystemBackground);
  365.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  366.   _SetColor(SystemWhite);
  367.   case CurrentFont of
  368.     Courier: FitText(Courier,'Courier (bit)');
  369.     Helvetica: FitText(Helvetica,'Helv (bit)');
  370.     TimesRoman: FitText(TimesRoman,'TmsRmn (bit)');
  371.     Roman: FitText(Roman,'Roman');
  372.     Modern: FitText(Modern,'Modern');
  373.     Script: FitText(Script,'Script')
  374.     end
  375.   end;
  376.  
  377. procedure TFontPane.Define(Pane: integer);
  378.   { Define a new font pane }
  379.   begin
  380.   inherited self.Define(Pane);
  381.   SetFont(Font(Pane),CurrentHeight,CurrentWidth)
  382.   end;
  383.  
  384. function TFontPane.Select: boolean;
  385.   { Select this font }
  386.   var TempFont: Font;
  387.   begin
  388.   TempFont := CurrentFont;
  389.   Select := inherited self.Select;
  390.   SetFont(TempFont,CurrentHeight,CurrentWidth)
  391.   end;
  392.  
  393. procedure TFontWindow.Init(Bordered: boolean;
  394.                            X1,Y1,X2,Y2: real);
  395.   { Initialize a font selection window }
  396.   begin
  397.   inherited self.Init(false,X1,Y1,X2,Y2);
  398.   self.Partition(Bordered,X1,Y1,X2,Y2,3,2);
  399.   self.ChangePane(ord(Roman))
  400.   end;
  401.  
  402. function TFontWindow.CreatePane(Pane: integer): TPaneWindow;
  403.   { Create a new font window pane }
  404.   var Temp: TFontPane;
  405.   begin
  406.   new(Temp);
  407.   CreatePane := Temp
  408.   end;
  409.  
  410. procedure TColorStylePane.DrawIcon(Marked: boolean);
  411.   { Draw the icon for the current color style }
  412.   var TempColor: integer;
  413.   begin
  414.   CurrentCanvas.Activate;
  415.   TempColor := _GetColor;
  416.   inherited self.DrawIcon(Marked);
  417.   _SetColor(TempColor);
  418.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  419.   end;
  420.  
  421. procedure TFillStylePane.DrawIcon(Marked: boolean);
  422.   { Draw the icon for the current fill mask }
  423.   var DontCare: boolean;
  424.       TempFillMask: _FillMask;
  425.   begin
  426.   CurrentCanvas.Activate;
  427.   DontCare := _GetFillMask(TempFillMask);
  428.   inherited self.DrawIcon(Marked);
  429.   _SetColor(SystemBackground);
  430.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  431.   _SetColor(SystemWhite);
  432.   _SetFillMask(TempFillMask);
  433.   _Rectangle_W(_GFillInterior,0.10,0.20,0.90,0.80)
  434.   end;
  435.  
  436. procedure TLineStylePane.DrawIcon(Marked: boolean);
  437.   { Draw the icon for the current line style }
  438.   var TempLineStyle: word;
  439.   begin
  440.   CurrentCanvas.Activate;
  441.   TempLineStyle := _GetLineStyle;
  442.   inherited self.DrawIcon(Marked);
  443.   _SetColor(SystemBackground);
  444.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  445.   _SetColor(SystemWhite);
  446.   _SetLineStyle(TempLineStyle);
  447.   _MoveTo_W(0.00,0.33);
  448.   _LineTo_W(1.00,0.33);
  449.   _MoveTo_W(0.00,0.66);
  450.   _LineTo_W(1.00,0.66)
  451.   end;
  452.  
  453. procedure TFontStylePane.DrawIcon(Marked: boolean);
  454.   { Draw the icon for the current font }
  455.   var TempFont: Font;
  456.   begin
  457.   CurrentCanvas.Activate;
  458.   TempFont := CurrentFont;
  459.   inherited self.DrawIcon(Marked);
  460.   _SetColor(SystemBackground);
  461.   _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  462.   _SetColor(SystemWhite);
  463.   case TempFont of
  464.     Courier: FitText(Courier,'Courier');
  465.     Helvetica: FitText(Helvetica,'Helv');
  466.     TimesRoman: FitText(TimesRoman,'TmsRmn');
  467.     Roman: FitText(Roman,'Roman');
  468.     Modern: FitText(Modern,'Modern');
  469.     Script: FitText(Script,'Script')
  470.     end
  471.   end;
  472.  
  473. procedure TStyleWindow.Init(Bordered: boolean;
  474.                             X1,Y1,X2,Y2: real);
  475.   { Initialize a style selection window }
  476.   var Temp: TColorWindow;
  477.   begin
  478.   inherited self.Init(false,X1,Y1,0.10*(X2-X1)+X1,Y2);
  479.   self.Partition(Bordered,X1,Y1,0.10*(X2-X1)+X1,Y2,1,4);
  480.   self.fWX1 := 0.11*(X2-X1)+X1;                  { Remember the window coordinates }
  481.   self.fWY1 := 0.50*(Y2-Y1)+Y1;                  { Choice window is only half as tall }
  482.   self.fWX2 := X2;
  483.   self.fWY2 := Y2;
  484.   new(Temp);
  485.   self.fCurrentWindowBordered := Bordered;
  486.   self.fCurrentWindow := Temp;
  487.   self.fCurrentWindow.Init(Bordered,self.fWX1,self.fWY1,self.fWX2,self.fWY2)
  488.   end;
  489.  
  490. procedure TStyleWindow.Free;
  491.   { Release a style selection window }
  492.   begin
  493.   self.fCurrentWindow.Free;
  494.   inherited self.Free
  495.   end;
  496.  
  497. function TStyleWindow.CheckMouse: boolean;
  498.   { Check if the mouse is in this window }
  499.   var PreviousActivePane: integer;
  500.       Temp: record
  501.         case integer of
  502.           0: (ColorWindow: TColorWindow);
  503.           1: (FillWindow: TFillWindow);
  504.           2: (LineWindow: TLineWindow);
  505.           3: (FontWindow: TFontWindow)
  506.         end;
  507.   begin
  508.   PreviousActivePane := self.fCurrentPane;
  509.   CheckMouse := true;
  510.   if inherited self.CheckMouse
  511.    then
  512.     begin
  513.     if (Mouse.GetButton(Left)=Released) and      { Was the button just released? }
  514.        (self.fCurrentPane<>PreviousActivePane) then { Was a new window selected? }
  515.       begin
  516.       self.fCurrentWindow.Free;                  { Release the old window }
  517.       case self.fCurrentPane of                  { Create the new window }
  518.         0: begin
  519.            new(Temp.ColorWindow);
  520.            self.fCurrentWindow := Temp.ColorWindow
  521.            end;
  522.         1: begin
  523.            new(Temp.FillWindow);
  524.            self.fCurrentWindow := Temp.FillWindow
  525.            end;
  526.         2: begin
  527.            new(Temp.LineWindow);
  528.            self.fCurrentWindow := Temp.LineWindow
  529.            end;
  530.         3: begin
  531.            new(Temp.FontWindow);
  532.            self.fCurrentWindow := Temp.FontWindow
  533.            end
  534.         end;
  535.       self.fCurrentWindow.Init(self.fCurrentWindowBordered,
  536.                                self.fWX1,self.fWY1,self.fWX2,self.fWY2)
  537.       end
  538.     end
  539.    else
  540.     if self.fCurrentWindow.CheckMouse
  541.      then
  542.       begin
  543.       if Mouse.GetButton(Left) = Released then   { Was the button just released? }
  544.         self.fPane[self.fCurrentPane].DrawIcon(false)
  545.       end
  546.      else
  547.       CheckMouse := false
  548.   end;
  549.  
  550. function TStyleWindow.CreatePane(Pane: integer): TPaneWindow;
  551.   { Create a new style selection window pane }
  552.   var Temp: record
  553.         case integer of
  554.           0: (ColorStylePane: TColorStylePane);
  555.           1: (FillStylePane: TFillStylePane);
  556.           2: (LineStylePane: TLineStylePane);
  557.           3: (FontStylePane: TFontStylePane)
  558.         end;
  559.   begin
  560.   case Pane of
  561.     0: begin
  562.        new(Temp.ColorStylePane);
  563.        CreatePane := Temp.ColorStylePane
  564.        end;
  565.     1: begin
  566.        new(Temp.FillStylePane);
  567.        CreatePane := Temp.FillStylePane
  568.        end;
  569.     2: begin
  570.        new(Temp.LineStylePane);
  571.        CreatePane := Temp.LineStylePane
  572.        end;
  573.     3: begin
  574.        new(Temp.FontStylePane);
  575.        CreatePane := Temp.FontStylePane
  576.        end
  577.     end
  578.   end;
  579.  
  580. end.
  581.