ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/QP_PAINT.ZIP/CSTYLE.PAS

Pascal/Delphi Source File | 1989-05-22 | 18.2 KB | 581 lines

{$B-,F-,I+,R+}

unit CStyle;

{ Define TStyle - a class for various drawing styles }

{ Copyright 1989
  Scott Bussinger
  110 South 131st Street
  Tacoma, WA  98444
  [phone]
  Compuserve 72247,2671 }

interface

uses CObject,CMouse,CWindow,MSGraph;

const MaxPanes = 16;

type TPaneWindow = object(TDrawingWindow)
       procedure Define(Pane: integer);          { Define a new pane }
       procedure DrawIcon(Marked: boolean);      { Draw the icon for this pane }
       function Select: boolean;                 { Select this pane }
       end;

type TMultipanedWindow = object(TWindow)
       fCurrentPane: integer;
       fNumPanes: integer;
       fPane: array[0..MaxPanes-1] of TPaneWindow;
       procedure Free; override;                 { Release a multipaned window }
       procedure ChangePane(Pane: integer);      { Change to a new active pane }
       function CheckMouse: boolean; override;   { Check if the mouse is in this window }
       function CreatePane(Pane: integer): TPaneWindow; { Create a new window pane }
       function CurrentPane: TPaneWindow;        { Get the current pane in window }
       procedure Partition(Bordered: boolean;X1,Y1,X2,Y2: real;Across,Down: integer); { Partition a window with lots of panes }
       procedure SetCursor;                      { Set the mouse cursor for the window }
       end;

type TColorPane = object(TPaneWindow)
       procedure Define(Pane: integer); override; { Define a new color pane }
       procedure DrawIcon(Marked: boolean); override; { Draw the icon for this color }
       function Select: boolean; override;       { Select this color }
       end;

type TColorWindow = object(TMultipanedWindow)
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a color selection window }
       function CreatePane(Pane: integer): TPaneWindow; override; { Create a new color pane }
       end;

type TFillPane = object(TPaneWindow)
       procedure Define(Pane: integer); override; { Define a new fill mask pane }
       procedure DrawIcon(Marked: boolean); override; { Draw the icon for this fill mask }
       function Select: boolean; override;       { Select this fill mask }
       end;

type TFillWindow = object(TMultipanedWindow)
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a fill mask selection window }
       function CreatePane(Pane: integer): TPaneWindow; override; { Create a new fill mask pane }
       end;

type TLinePane = object(TPaneWindow)
       procedure Define(Pane: integer); override; { Define a new line style pane }
       procedure DrawIcon(Marked: boolean); override; { Draw the icon for this line style }
       function Select: boolean; override;       { Select this line style pane }
       end;

type TLineWindow = object(TMultipanedWindow)
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a line style selection window }
       function CreatePane(Pane: integer): TPaneWindow; override; { Create a new line style pane }
       end;

type TFontPane = object(TPaneWindow)
       procedure Define(Pane: integer); override; { Define a new font pane }
       procedure DrawIcon(Marked: boolean); override; { Draw the icon for this font }
       function Select: boolean; override;       { Select this font }
       end;

type TFontWindow = object(TMultipanedWindow)
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a font selection window }
       function CreatePane(Pane: integer): TPaneWindow; override; { Create a new font pane }
       end;

type TColorStylePane = object(TPaneWindow)
       procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the current color }
       end;

type TFillStylePane = object(TPaneWindow)
       procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the fill mask }
       end;

type TLineStylePane = object(TPaneWindow)
       procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the line style }
       end;

type TFontStylePane = object(TPaneWindow)
       procedure DrawIcon(Marked: boolean); override; { Draw the icon showing the font }
       end;

type TStyleWindow = object(TMultipanedWindow)
       fCurrentWindow: TMultipanedWindow;
       fCurrentWindowBordered: boolean;
       fWX1: real;
       fWX2: real;
       fWY1: real;
       fWY2: real;
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); override; { Initialize a current style selection window }
       procedure Free; override;                    { Release a current style window }
       function CheckMouse: boolean; override;      { Check if the mouse is in this window }
       function CreatePane(Pane: integer): TPaneWindow; override; { Create a new current style pane }
       end;

implementation

procedure TMultipanedWindow.Free;
  { Release a multipaned window }
  var I: integer;
  begin
  for I := 0 to self.fNumPanes-1 do
    self.fPane[I].Free;
  inherited self.Free
  end;

procedure TMultipanedWindow.ChangePane(Pane: integer);
  { Change to a new active pane }
  begin
  self.fCurrentPane := Pane                      { Change the current pane }
  end;

function TMultipanedWindow.CheckMouse: boolean;
  { Check if the mouse is in this window }
  var I: integer;
  begin
  CheckMouse := false;
  if inherited self.CheckMouse then              { See if we're in this window at all }
    begin
    I := 0;                                      { Check a multipaned window by looking at each of the panes }
    while (I<self.fNumPanes) and not (self.fPane[I].CheckMouse) do
      inc(I);
    if I < self.fNumPanes then
      begin
      CheckMouse := true;
      self.SetCursor;                            { Change to the appropriate mouse cursor }
      if (Mouse.GetButton(Left)=Released) and    { Was the button just released? }
         self.fPane[I].Select then               { Does this pane cause a mode change? }
        self.ChangePane(I)
      end
    end
  end;

function TMultipanedWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new pane }
  var Temp: TPaneWindow;
  begin
  new(Temp);
  CreatePane := Temp
  end;

function TMultipanedWindow.CurrentPane: TPaneWindow;
  { Get the current pane }
  begin
  CurrentPane := self.fPane[self.fCurrentPane]
  end;

procedure TMultipanedWindow.Partition(Bordered: boolean;
                                      X1,Y1,X2,Y2: real;Across,Down: integer);
  { Partition a window into an array of panes }
  var I: integer;
      R,C: integer;
  begin
  self.fNumPanes := Across * Down;
  if self.fNumPanes > MaxPanes then
    begin
    self.fNumPanes := MaxPanes;
    Across := MaxPanes div Down
    end;
  for I := 0 to self.fNumPanes-1 do
    begin
    R := I div Across;
    C := I mod Across;
    self.fPane[I] := self.CreatePane(I);
    self.fPane[I].Init(Bordered,
                         C  *(X2-X1)/Across + X1, { Initialize a drawing window in the small area }
                         R  *(Y2-Y1)/Down + Y1,
                       (C+1)*(X2-X1)/Across + X1,
                       (R+1)*(Y2-Y1)/Down + Y1);
    self.fPane[I].Define(I);
    self.fPane[I].DrawIcon(false)
    end;
  self.fCurrentPane := 0;
  self.ChangePane(self.fCurrentPane)
  end;

procedure TMultipanedWindow.SetCursor;
  { Set the mouse cursor for the window }
  begin
  Mouse.SetCursor(HandCursor)
  end;

procedure TPaneWindow.Define(Pane: integer);
  { Define a new pane }
  begin
  { Should be overridden in all subclasses }
  end;

procedure TPaneWindow.DrawIcon(Marked: boolean);
  { Draw the icon for this pane }
  begin
  Mouse.Hide;                                    { Keep the display clean }
  self.Activate                                  { Switch to this window }
  end;

function TPaneWindow.Select: boolean;
  { Select this pane }
  { Return true if selecting this pane should change the current pane or
    false if the previous pane stays in effect. }
  begin
  Select := true;
  CurrentCanvas.Activate
  end;

procedure TColorPane.DrawIcon(Marked: boolean);
  { Draw the icon for this color }
  begin
  inherited self.DrawIcon(Marked);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  end;

procedure TColorPane.Define(Pane: integer);
  { Define a new color pane }
  begin
  inherited self.Define(Pane);
  _SetColor(Pane)
  end;

function TColorPane.Select: boolean;
  { Select this color }
  var TempColor: integer;
  begin
  TempColor := _GetColor;
  Select := inherited self.Select;
  _SetColor(TempColor)
  end;

procedure TColorWindow.Init(Bordered: boolean;
                            X1,Y1,X2,Y2: real);
  { Initialize a color selection window }
  begin
  inherited self.Init(false,X1,Y1,X2,Y2);
  if VideoConfig.NumColors = 2                   { Watch for this special case, for a better looking display }
   then
    self.Partition(Bordered,X1,Y1,X2,Y2,2,1)
   else
    self.Partition(Bordered,X1,Y1,X2,Y2,VideoConfig.NumColors div 2,2);
  self.ChangePane(self.fNumPanes-1)
  end;

function TColorWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new color pane }
  var Temp: TColorPane;
  begin
  new(Temp);
  CreatePane := Temp
  end;

procedure TFillPane.DrawIcon(Marked: boolean);
  { Draw the icon for this fill mask }
  var DontCare: boolean;
      SaveFill: _FillMask;
  begin
  inherited self.DrawIcon(Marked);
  DontCare := _GetFillMask(SaveFill);
  _SetFillMask(FillMask[SolidFill]);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetFillMask(SaveFill);
  _SetColor(SystemWhite);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  end;

procedure TFillPane.Define(Pane: integer);
  { Define a new fill mask pane }
  begin
  inherited self.Define(Pane);
  _SetFillMask(FillMask[Pane])
  end;

function TFillPane.Select: boolean;
  { Select this fill mask }
  var DontCare: boolean;
      TempFillMask: _FillMask;
  begin
  DontCare := _GetFillMask(TempFillMask);
  Select := inherited self.Select;
  _SetFillMask(TempFillMask)
  end;

procedure TFillWindow.Init(Bordered: Boolean;
                           X1,Y1,X2,Y2: real);
  { Initialize a fill mask selection window }
  begin
  inherited self.Init(false,X1,Y1,X2,Y2);
  self.Partition(Bordered,X1,Y1,X2,Y2,MaxFillMasks div 2,2);
  self.ChangePane(self.fNumPanes-1)
  end;

function TFillWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new fill mask pane }
  var Temp: TFillPane;
  begin
  new(Temp);
  CreatePane := Temp
  end;

procedure TLinePane.DrawIcon(Marked: boolean);
  { Draw the icon for this line style }
  begin
  inherited self.DrawIcon(Marked);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetColor(SystemWhite);
  _MoveTo_W(0.00,0.33);
  _LineTo_W(1.00,0.33);
  _MoveTo_W(0.00,0.66);
  _LineTo_W(1.00,0.66)
  end;

procedure TLinePane.Define(Pane: integer);
  { Define a new line style pane }
  begin
  inherited self.Define(Pane);
  _SetLineStyle(LineStyle[Pane])
  end;

function TLinePane.Select: boolean;
  { Select this line style }
  var TempLineStyle: word;
  begin
  TempLineStyle := _GetLineStyle;
  Select := inherited self.Select;
  _SetLineStyle(TempLineStyle)
  end;

procedure TLineWindow.Init(Bordered: boolean;
                           X1,Y1,X2,Y2: real);
  { Initialize a line style selection window }
  begin
  inherited self.Init(false,X1,Y1,X2,Y2);
  self.Partition(Bordered,X1,Y1,X2,Y2,MaxLineStyles div 2,2);
  self.ChangePane(self.fNumPanes-1)
  end;

function TLineWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new line style window pane }
  var Temp: TLinePane;
  begin
  new(Temp);
  CreatePane := Temp
  end;

procedure TFontPane.DrawIcon(Marked: boolean);
  { Draw the icon for this font }
  begin
  inherited self.DrawIcon(Marked);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetColor(SystemWhite);
  case CurrentFont of
    Courier: FitText(Courier,'Courier (bit)');
    Helvetica: FitText(Helvetica,'Helv (bit)');
    TimesRoman: FitText(TimesRoman,'TmsRmn (bit)');
    Roman: FitText(Roman,'Roman');
    Modern: FitText(Modern,'Modern');
    Script: FitText(Script,'Script')
    end
  end;

procedure TFontPane.Define(Pane: integer);
  { Define a new font pane }
  begin
  inherited self.Define(Pane);
  SetFont(Font(Pane),CurrentHeight,CurrentWidth)
  end;

function TFontPane.Select: boolean;
  { Select this font }
  var TempFont: Font;
  begin
  TempFont := CurrentFont;
  Select := inherited self.Select;
  SetFont(TempFont,CurrentHeight,CurrentWidth)
  end;

procedure TFontWindow.Init(Bordered: boolean;
                           X1,Y1,X2,Y2: real);
  { Initialize a font selection window }
  begin
  inherited self.Init(false,X1,Y1,X2,Y2);
  self.Partition(Bordered,X1,Y1,X2,Y2,3,2);
  self.ChangePane(ord(Roman))
  end;

function TFontWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new font window pane }
  var Temp: TFontPane;
  begin
  new(Temp);
  CreatePane := Temp
  end;

procedure TColorStylePane.DrawIcon(Marked: boolean);
  { Draw the icon for the current color style }
  var TempColor: integer;
  begin
  CurrentCanvas.Activate;
  TempColor := _GetColor;
  inherited self.DrawIcon(Marked);
  _SetColor(TempColor);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00)
  end;

procedure TFillStylePane.DrawIcon(Marked: boolean);
  { Draw the icon for the current fill mask }
  var DontCare: boolean;
      TempFillMask: _FillMask;
  begin
  CurrentCanvas.Activate;
  DontCare := _GetFillMask(TempFillMask);
  inherited self.DrawIcon(Marked);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetColor(SystemWhite);
  _SetFillMask(TempFillMask);
  _Rectangle_W(_GFillInterior,0.10,0.20,0.90,0.80)
  end;

procedure TLineStylePane.DrawIcon(Marked: boolean);
  { Draw the icon for the current line style }
  var TempLineStyle: word;
  begin
  CurrentCanvas.Activate;
  TempLineStyle := _GetLineStyle;
  inherited self.DrawIcon(Marked);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetColor(SystemWhite);
  _SetLineStyle(TempLineStyle);
  _MoveTo_W(0.00,0.33);
  _LineTo_W(1.00,0.33);
  _MoveTo_W(0.00,0.66);
  _LineTo_W(1.00,0.66)
  end;

procedure TFontStylePane.DrawIcon(Marked: boolean);
  { Draw the icon for the current font }
  var TempFont: Font;
  begin
  CurrentCanvas.Activate;
  TempFont := CurrentFont;
  inherited self.DrawIcon(Marked);
  _SetColor(SystemBackground);
  _Rectangle_W(_GFillInterior,0.00,0.00,1.00,1.00);
  _SetColor(SystemWhite);
  case TempFont of
    Courier: FitText(Courier,'Courier');
    Helvetica: FitText(Helvetica,'Helv');
    TimesRoman: FitText(TimesRoman,'TmsRmn');
    Roman: FitText(Roman,'Roman');
    Modern: FitText(Modern,'Modern');
    Script: FitText(Script,'Script')
    end
  end;

procedure TStyleWindow.Init(Bordered: boolean;
                            X1,Y1,X2,Y2: real);
  { Initialize a style selection window }
  var Temp: TColorWindow;
  begin
  inherited self.Init(false,X1,Y1,0.10*(X2-X1)+X1,Y2);
  self.Partition(Bordered,X1,Y1,0.10*(X2-X1)+X1,Y2,1,4);
  self.fWX1 := 0.11*(X2-X1)+X1;                  { Remember the window coordinates }
  self.fWY1 := 0.50*(Y2-Y1)+Y1;                  { Choice window is only half as tall }
  self.fWX2 := X2;
  self.fWY2 := Y2;
  new(Temp);
  self.fCurrentWindowBordered := Bordered;
  self.fCurrentWindow := Temp;
  self.fCurrentWindow.Init(Bordered,self.fWX1,self.fWY1,self.fWX2,self.fWY2)
  end;

procedure TStyleWindow.Free;
  { Release a style selection window }
  begin
  self.fCurrentWindow.Free;
  inherited self.Free
  end;

function TStyleWindow.CheckMouse: boolean;
  { Check if the mouse is in this window }
  var PreviousActivePane: integer;
      Temp: record
        case integer of
          0: (ColorWindow: TColorWindow);
          1: (FillWindow: TFillWindow);
          2: (LineWindow: TLineWindow);
          3: (FontWindow: TFontWindow)
        end;
  begin
  PreviousActivePane := self.fCurrentPane;
  CheckMouse := true;
  if inherited self.CheckMouse
   then
    begin
    if (Mouse.GetButton(Left)=Released) and      { Was the button just released? }
       (self.fCurrentPane<>PreviousActivePane) then { Was a new window selected? }
      begin
      self.fCurrentWindow.Free;                  { Release the old window }
      case self.fCurrentPane of                  { Create the new window }
        0: begin
           new(Temp.ColorWindow);
           self.fCurrentWindow := Temp.ColorWindow
           end;
        1: begin
           new(Temp.FillWindow);
           self.fCurrentWindow := Temp.FillWindow
           end;
        2: begin
           new(Temp.LineWindow);
           self.fCurrentWindow := Temp.LineWindow
           end;
        3: begin
           new(Temp.FontWindow);
           self.fCurrentWindow := Temp.FontWindow
           end
        end;
      self.fCurrentWindow.Init(self.fCurrentWindowBordered,
                               self.fWX1,self.fWY1,self.fWX2,self.fWY2)
      end
    end
   else
    if self.fCurrentWindow.CheckMouse
     then
      begin
      if Mouse.GetButton(Left) = Released then   { Was the button just released? }
        self.fPane[self.fCurrentPane].DrawIcon(false)
      end
     else
      CheckMouse := false
  end;

function TStyleWindow.CreatePane(Pane: integer): TPaneWindow;
  { Create a new style selection window pane }
  var Temp: record
        case integer of
          0: (ColorStylePane: TColorStylePane);
          1: (FillStylePane: TFillStylePane);
          2: (LineStylePane: TLineStylePane);
          3: (FontStylePane: TFontStylePane)
        end;
  begin
  case Pane of
    0: begin
       new(Temp.ColorStylePane);
       CreatePane := Temp.ColorStylePane
       end;
    1: begin
       new(Temp.FillStylePane);
       CreatePane := Temp.FillStylePane
       end;
    2: begin
       new(Temp.LineStylePane);
       CreatePane := Temp.LineStylePane
       end;
    3: begin
       new(Temp.FontStylePane);
       CreatePane := Temp.FontStylePane
       end
    end
  end;

end.