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

Pascal/Delphi Source File | 1989-05-22 | 13.1 KB | 414 lines

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

unit CWindow;

{ Define TWindow - a class for windows on the screen }

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

interface

uses CObject,CMouse,Dos,Crt,MSGraph;

type Font = (Courier,Helvetica,TimesRoman,Roman,Modern,Script);
     GraphicsStatus = record
       Color: integer;
       F: Font;
       FillMask: _FillMask;
       Height: integer;
       LineStyle: word;
       Position: _XYCoord;
       Width: integer;
       WriteMode: integer
       end;

type TWindow = object(TObject)
       fSaveStatus: GraphicsStatus;
       fUpperLeftX: integer;
       fUpperLeftY: integer;
       fLowerRightX: integer;
       fLowerRightY: integer;
       procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); { Initialize a window }
       procedure Activate;                       { Activate a window }
       procedure Deactivate;                     { Deactivate a window }
       function CheckMouse: boolean;             { Check if the mouse is in this window }
       procedure Clear;                          { Clear the window }
       end;

type TDrawingWindow = object(TWindow)
       procedure Activate; override;             { Activate a window }
       end;

function AspectRatioW: real;
  { Return the aspect ratio for the display in window }

function AspectRatio: real;
  { Return the aspect ratio for the display in viewport }

function CompareXYCoord(var A,B: _XYCoord): boolean;
  { Compare two _XYCoord pairs for equality }

procedure Error(ErrorMess: string);
  { Wait for a key to acknowledge the error and quit }

procedure FitText(F: Font;
                  S: string);
  { Scale the font to fit string into current window }

procedure GetGraphicsStatus(var Status: GraphicsStatus);
  { Get all of the graphics state }

function LongToStr(L: longint): string;
  { Convert a longint to a string }

procedure SetFont(F: Font;Height: integer;Width: integer);
  { Change to a new font }

procedure SetGraphicsStatus(var Status: GraphicsStatus);
  { Restore all of the graphics states }

const MaxFillMasks = 16;
      SolidFill = MaxFillMasks - 1;
      FillMask: array[0..MaxFillMasks-1] of _FillMask =
        (($80,$40,$20,$10,$08,$04,$02,$01),      { \ \  fill }
         ($88,$44,$22,$11,$88,$44,$22,$11),      { \\\\ fill }
         ($01,$02,$04,$08,$10,$20,$40,$80),      { / /  fill }
         ($11,$22,$44,$88,$11,$22,$44,$88),      { //// fill }
         ($80,$41,$22,$14,$08,$14,$22,$41),      { X X  fill }
         ($55,$22,$55,$88,$55,$22,$55,$88),      { XXXX fill }
         ($10,$10,$FF,$10,$10,$10,$10,$10),      { + +  fill }
         ($22,$22,$FF,$22,$22,$22,$FF,$22),      { ++++ fill }

         ($E0,$70,$38,$1C,$0E,$07,$83,$C1),      { \\   fill }
         ($07,$0E,$1C,$38,$70,$E0,$C1,$83),      { //   fill }
         ($18,$18,$18,$FF,$FF,$18,$18,$18),      { ++   fill }

         ($00,$00,$00,$00,$00,$00,$00,$00),      { Empty fill }
         ($88,$00,$22,$00,$88,$00,$22,$00),      { Light fill }
         ($AA,$55,$AA,$55,$AA,$55,$AA,$55),      { 50% fill }
         ($77,$FF,$DD,$FF,$77,$FF,$DD,$FF),      { Heavy fill }
         ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF));     { Solid fill }

const MaxLineStyles = 12;
      SolidLine = MaxLineStyles - 1;
      LineStyle: array[0..MaxLineStyles-1] of word =
        ($AAAA,          { * * * * * * * *  }    { * * * * * * * *  }
         $9999,          { *  **  **  **  * }    { **  **  **  **   }
         $DDDD,          { ** *** *** *** * }    { *** *** *** ***  }
         $E633,          { ***  **   **  ** }    { *****  **   **   }
         $F1C7,          { ****   ***   *** }    { *******   ***    }
         $FC3F,          { ******    ****** }    { ************     }
         $1010,          {    *       *     }    { *       *        }
         $4444,          {  *   *   *   *   }    { *   *   *   *    }
         $8181,          { *      **      * }    { **      **       }
         $C3C3,          { **    ****    ** }    { ****    ****     }
         $E7E7,          { ***  ******  *** }    { ******  ******   }
         $FFFF);         { **************** }    { **************** }

const FontName: array[Font] of string[8] = ('courier','helv','tms rmn','roman','modern','script');

var CurrentCanvas: TDrawingWindow;
    CurrentFont: Font;
    CurrentHeight: integer;
    CurrentWidth: integer;
    CurrentWindow: TWindow;
    SystemColor: integer;
    SystemBackground: integer;
    SystemWhite: integer;
    VideoConfig: _VideoConfig;

implementation

var ExitSave: pointer;

function AspectRatioW: real;
  { Return the aspect ratio for the display in window }
  begin
  AspectRatioW := VideoConfig.NumYPixels / VideoConfig.NumXPixels
  end;

function AspectRatio: real;
  { Return the aspect ratio for the display in viewport }
  const ScreenRatio = 4 / 3;
  begin
  AspectRatio := AspectRatioW * ScreenRatio
  end;

function CompareXYCoord(var A,B: _XYCoord): boolean;
  { Compare two _XYCoord pairs for equality }
  begin
  CompareXYCoord := (A.XCoord=B.XCoord) and (A.YCoord=B.YCoord)
  end;

procedure FitText(F: Font;
                  S: string);
  { Scale the font to fit string into current window }
  var FontInfo: _FontInfo;
      LowerRight: _XYCoord;
      UpperLeft: _XYCoord;
  begin
  _GetViewCoord_W(0.10,0.10,UpperLeft);
  _GetViewCoord_W(0.90,0.90,LowerRight);
  SetFont(F,LowerRight.YCoord-UpperLeft.YCoord,(LowerRight.XCoord-UpperLeft.XCoord) div length(S));
  _MoveTo((LowerRight.XCoord + UpperLeft.XCoord - _GetGTextExtent(S)) div 2,UpperLeft.YCoord);
  _OutGText(S)
  end;

procedure GetGraphicsStatus(var Status: GraphicsStatus);
  { Get all of the graphics state }
  var DontCare: boolean;
  begin
  with Status do
    begin
    Color := _GetColor;
    F := CurrentFont;
    DontCare := _GetFillMask(FillMask);
    Height := CurrentHeight;
    LineStyle := _GetLineStyle;
    _GetCurrentPosition(Position);
    Width := CurrentWidth;
    WriteMode := _GetWriteMode
    end
  end;

function LongToStr(L: longint): string;
  { Convert a longint to a string }
  var Temp: string;
  begin
  str(L,Temp);
  LongToStr := Temp
  end;

procedure SetFont(F: Font;
                  Height: integer;
                  Width: integer);
  { Change to a new font }
  var DontCare: integer;
  begin
  if (CurrentFont<>F) or (CurrentHeight<>Height) or (CurrentWidth<>Width) then
    begin
    CurrentFont := F;                            { Keep track of these since MSGraph doesn't }
    CurrentHeight := Height;
    CurrentWidth := Width;
    DontCare := _SetFont('t'''+FontName[F]+''''+
                         'h' + LongToStr(Height) +
                         'w' + LongToStr(Width) +
                         'b')
    end
  end;

procedure SetGraphicsStatus(var Status: GraphicsStatus);
  { Restore all of the graphics states }
  begin
  with Status do
    begin
    _SetColor(Color);
    SetFont(F,Height,Width);
    _SetFillMask(FillMask);
    _SetLineStyle(LineStyle);
    _MoveTo(Position.XCoord,Position.YCoord);
    _SetWriteMode(WriteMode)
    end
  end;

procedure TWindow.Init(Bordered: boolean;
                       X1,Y1,X2,Y2: real);
  { Initialize a window }
  var I: integer;

  procedure DrawBorder(SunColor,ShadowColor: integer;
                       var X1,Y1,X2,Y2: integer);
    { Draw a single row of border }
    begin
    _SetColor(SunColor);
    _MoveTo(X1,Y2);
    _LineTo(X1,Y1);
    _LineTo(X2,Y1);
    _SetColor(ShadowColor);
    _LineTo(X2,Y2);
    _LineTo(X1,Y2);
    inc(X1);                                     { Move border in }
    inc(Y1);
    dec(X2);
    dec(Y2)
    end;

  begin
  CurrentWindow := self;
  _SetViewport(0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1); { Set to full screen coordinates }
  _SetColor(SystemWhite);
  SetFont(Roman,10,10);
  _SetFillMask(FillMask[SolidFill]);
  _SetLineStyle(LineStyle[SolidLine]);
  _SetWriteMode(_GPSet);

  self.Deactivate;                               { Get the current defaults }
  self.fUpperLeftX := round(X1*(VideoConfig.NumXPixels-1)); { Create window by percentage of screen }
  self.fUpperLeftY := round(Y1*(VideoConfig.NumYPixels-1));
  self.fLowerRightX := round(X2*(VideoConfig.NumXPixels-1));
  self.fLowerRightY := round(Y2*(VideoConfig.NumYPixels-1));
  if Bordered then
    if VideoConfig.NumColors >= 16
     then
      begin
      DrawBorder(0,0,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
      for I := 1 to 3 do
        DrawBorder(11,0,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
      DrawBorder(15,15,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
      _SetColor(3);
      _Rectangle(_GFillInterior,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY)
      end
     else
      begin
      _Rectangle(_GBorder,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
      inc(self.fUpperLeftX);                     { Move window in }
      inc(self.fUpperLeftY);
      dec(self.fLowerRightX);
      dec(self.fLowerRightY)
      end;
  _SetColor(SystemWhite);
  self.Activate
  end;

procedure TWindow.Activate;
  { Activate a window and re-establish window drawing styles }
  begin
  CurrentWindow.Deactivate;
  CurrentWindow := self;
  SetGraphicsStatus(self.fSaveStatus);
  _SetViewport(0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1); { Set to full screen coordinates }
  end;

procedure TWindow.Deactivate;
  { Deactivate a window and save window drawing styles }
  var DontCare: boolean;
  begin
  GetGraphicsStatus(self.fSaveStatus)
  end;

function TWindow.CheckMouse: boolean;
  { Check if the mouse is in this window }
  begin
  if (Mouse.GetLocationX >= self.fUpperLeftX) and (Mouse.GetLocationX <= self.fLowerRightX) and
     (Mouse.GetLocationY >= self.fUpperLeftY) and (Mouse.GetLocationY <= self.fLowerRightY)
   then
    begin
    CheckMouse := true;
    Self.Activate
    end
   else
    CheckMouse := false
  end;

procedure TWindow.Clear;
  { Clear the window }
  begin
  self.Activate;
  _ClearScreen(_GViewport)
  end;

procedure TDrawingWindow.Activate;
  { Activate a window and re-establish window drawing styles }
  begin
  inherited self.Activate;
  _SetViewport(self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  _SetWindow(false,0.0,0.0,1.00,1.00)
  end;

procedure Error(ErrorMess: string);
  { Wait for a key to acknowledge the error and quit }
  var DontCare: char;
  begin
  DontCare := char(_SetVideoMode(_DefaultMode));
  writeln(ErrorMess);
  writeln('Hit any key to continue.'^G);
  repeat
  until KeyPressed;
  while KeyPressed do
    DontCare := ReadKey;
  halt(1)
  end;

{$F+}
procedure ExitHandler;
{$F-}
  { Restore the original screen mode on exit }
  var DontCare: integer;
  begin
  ExitProc := ExitSave;
  DontCare := _SetVideoMode(_DefaultMode)
  end;

procedure InitializeScreen;
  { Change to graphics mode }
  var DontCare: integer;
      FontDir: DirStr;
      FontExt: ExtStr;
      FontName: NameStr;
      FontPath: PathStr;

  procedure RegisterFont(Font: PathStr);
    { Register a font }
    begin
    if _RegisterFonts(FontDir+Font+'.FON') < 1 then
      Error('Font file ('+Font+') not found.')
    end;

  begin
  ExitSave := ExitProc;
  ExitProc := @ExitHandler;
  _GetVideoConfig(VideoConfig);                  { Check what kind of hardware we have }
  if VideoConfig.Adapter = _MDPA then
    Error('Graphics display not available.');
  DontCare := _SetVideoMode(_MaxResMode);        { This will pick either 2 or 16 color modes }
  _GetVideoConfig(VideoConfig);                  { Get the information on the mode we selected }

  if VideoConfig.NumColors >= 16
   then
    begin
    SystemColor := 0;
    SystemBackground := 3;
    SystemWhite := 15;
    _SetColor(7);                                { Give screen an initial color }
    _Rectangle(_GFillInterior,0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1)
    end
   else
    begin
    SystemColor := round(0.75*(VideoConfig.NumColors-1));
    SystemBackground := round(0.25*(VideoConfig.NumColors-1));
    SystemWhite := VideoConfig.NumColors - 1
    end;

  FontPath := FSearch('MODERN.FON',GetEnv('PATH')); { Find the font files }
  if FontPath = '' then
    Error('Font files (*.FON) not found.');
  FSplit(FExpand(FontPath),FontDir,FontName,FontExt);
  RegisterFont('COURB');
  RegisterFont('HELVB');
  RegisterFont('TMSRB');
  RegisterFont('ROMAN');
  RegisterFont('MODERN');
  RegisterFont('SCRIPT');
  CurrentHeight := -1                            { Make sure the current font doesn't match }
  end;

procedure CreateMouse;
  { Create the mouse object }
  begin
  new(Mouse);
  if not Mouse.Init then
    Error('Mouse not found.'^G)
  end;

begin
CurrentCanvas := nil;
CurrentWindow := nil;
InitializeScreen;                                { Initialize the screen }
CreateMouse                                      { Initialize the mouse }
end.