home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / pascal / qp_paint.arc / CWINDOW.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-22  |  13KB  |  414 lines
  1. {$B-,F-,I+,R+}
  2.  
  3. unit CWindow;
  4.  
  5. { Define TWindow - a class for windows on the screen }
  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,Dos,Crt,MSGraph;
  17.  
  18. type Font = (Courier,Helvetica,TimesRoman,Roman,Modern,Script);
  19.      GraphicsStatus = record
  20.        Color: integer;
  21.        F: Font;
  22.        FillMask: _FillMask;
  23.        Height: integer;
  24.        LineStyle: word;
  25.        Position: _XYCoord;
  26.        Width: integer;
  27.        WriteMode: integer
  28.        end;
  29.  
  30. type TWindow = object(TObject)
  31.        fSaveStatus: GraphicsStatus;
  32.        fUpperLeftX: integer;
  33.        fUpperLeftY: integer;
  34.        fLowerRightX: integer;
  35.        fLowerRightY: integer;
  36.        procedure Init(Bordered: boolean;X1,Y1,X2,Y2: real); { Initialize a window }
  37.        procedure Activate;                       { Activate a window }
  38.        procedure Deactivate;                     { Deactivate a window }
  39.        function CheckMouse: boolean;             { Check if the mouse is in this window }
  40.        procedure Clear;                          { Clear the window }
  41.        end;
  42.  
  43. type TDrawingWindow = object(TWindow)
  44.        procedure Activate; override;             { Activate a window }
  45.        end;
  46.  
  47. function AspectRatioW: real;
  48.   { Return the aspect ratio for the display in window }
  49.  
  50. function AspectRatio: real;
  51.   { Return the aspect ratio for the display in viewport }
  52.  
  53. function CompareXYCoord(var A,B: _XYCoord): boolean;
  54.   { Compare two _XYCoord pairs for equality }
  55.  
  56. procedure Error(ErrorMess: string);
  57.   { Wait for a key to acknowledge the error and quit }
  58.  
  59. procedure FitText(F: Font;
  60.                   S: string);
  61.   { Scale the font to fit string into current window }
  62.  
  63. procedure GetGraphicsStatus(var Status: GraphicsStatus);
  64.   { Get all of the graphics state }
  65.  
  66. function LongToStr(L: longint): string;
  67.   { Convert a longint to a string }
  68.  
  69. procedure SetFont(F: Font;Height: integer;Width: integer);
  70.   { Change to a new font }
  71.  
  72. procedure SetGraphicsStatus(var Status: GraphicsStatus);
  73.   { Restore all of the graphics states }
  74.  
  75. const MaxFillMasks = 16;
  76.       SolidFill = MaxFillMasks - 1;
  77.       FillMask: array[0..MaxFillMasks-1] of _FillMask =
  78.         (($80,$40,$20,$10,$08,$04,$02,$01),      { \ \  fill }
  79.          ($88,$44,$22,$11,$88,$44,$22,$11),      { \\\\ fill }
  80.          ($01,$02,$04,$08,$10,$20,$40,$80),      { / /  fill }
  81.          ($11,$22,$44,$88,$11,$22,$44,$88),      { //// fill }
  82.          ($80,$41,$22,$14,$08,$14,$22,$41),      { X X  fill }
  83.          ($55,$22,$55,$88,$55,$22,$55,$88),      { XXXX fill }
  84.          ($10,$10,$FF,$10,$10,$10,$10,$10),      { + +  fill }
  85.          ($22,$22,$FF,$22,$22,$22,$FF,$22),      { ++++ fill }
  86.  
  87.          ($E0,$70,$38,$1C,$0E,$07,$83,$C1),      { \\   fill }
  88.          ($07,$0E,$1C,$38,$70,$E0,$C1,$83),      { //   fill }
  89.          ($18,$18,$18,$FF,$FF,$18,$18,$18),      { ++   fill }
  90.  
  91.          ($00,$00,$00,$00,$00,$00,$00,$00),      { Empty fill }
  92.          ($88,$00,$22,$00,$88,$00,$22,$00),      { Light fill }
  93.          ($AA,$55,$AA,$55,$AA,$55,$AA,$55),      { 50% fill }
  94.          ($77,$FF,$DD,$FF,$77,$FF,$DD,$FF),      { Heavy fill }
  95.          ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF));     { Solid fill }
  96.  
  97. const MaxLineStyles = 12;
  98.       SolidLine = MaxLineStyles - 1;
  99.       LineStyle: array[0..MaxLineStyles-1] of word =
  100.         ($AAAA,          { * * * * * * * *  }    { * * * * * * * *  }
  101.          $9999,          { *  **  **  **  * }    { **  **  **  **   }
  102.          $DDDD,          { ** *** *** *** * }    { *** *** *** ***  }
  103.          $E633,          { ***  **   **  ** }    { *****  **   **   }
  104.          $F1C7,          { ****   ***   *** }    { *******   ***    }
  105.          $FC3F,          { ******    ****** }    { ************     }
  106.          $1010,          {    *       *     }    { *       *        }
  107.          $4444,          {  *   *   *   *   }    { *   *   *   *    }
  108.          $8181,          { *      **      * }    { **      **       }
  109.          $C3C3,          { **    ****    ** }    { ****    ****     }
  110.          $E7E7,          { ***  ******  *** }    { ******  ******   }
  111.          $FFFF);         { **************** }    { **************** }
  112.  
  113. const FontName: array[Font] of string[8] = ('courier','helv','tms rmn','roman','modern','script');
  114.  
  115. var CurrentCanvas: TDrawingWindow;
  116.     CurrentFont: Font;
  117.     CurrentHeight: integer;
  118.     CurrentWidth: integer;
  119.     CurrentWindow: TWindow;
  120.     SystemColor: integer;
  121.     SystemBackground: integer;
  122.     SystemWhite: integer;
  123.     VideoConfig: _VideoConfig;
  124.  
  125. implementation
  126.  
  127. var ExitSave: pointer;
  128.  
  129. function AspectRatioW: real;
  130.   { Return the aspect ratio for the display in window }
  131.   begin
  132.   AspectRatioW := VideoConfig.NumYPixels / VideoConfig.NumXPixels
  133.   end;
  134.  
  135. function AspectRatio: real;
  136.   { Return the aspect ratio for the display in viewport }
  137.   const ScreenRatio = 4 / 3;
  138.   begin
  139.   AspectRatio := AspectRatioW * ScreenRatio
  140.   end;
  141.  
  142. function CompareXYCoord(var A,B: _XYCoord): boolean;
  143.   { Compare two _XYCoord pairs for equality }
  144.   begin
  145.   CompareXYCoord := (A.XCoord=B.XCoord) and (A.YCoord=B.YCoord)
  146.   end;
  147.  
  148. procedure FitText(F: Font;
  149.                   S: string);
  150.   { Scale the font to fit string into current window }
  151.   var FontInfo: _FontInfo;
  152.       LowerRight: _XYCoord;
  153.       UpperLeft: _XYCoord;
  154.   begin
  155.   _GetViewCoord_W(0.10,0.10,UpperLeft);
  156.   _GetViewCoord_W(0.90,0.90,LowerRight);
  157.   SetFont(F,LowerRight.YCoord-UpperLeft.YCoord,(LowerRight.XCoord-UpperLeft.XCoord) div length(S));
  158.   _MoveTo((LowerRight.XCoord + UpperLeft.XCoord - _GetGTextExtent(S)) div 2,UpperLeft.YCoord);
  159.   _OutGText(S)
  160.   end;
  161.  
  162. procedure GetGraphicsStatus(var Status: GraphicsStatus);
  163.   { Get all of the graphics state }
  164.   var DontCare: boolean;
  165.   begin
  166.   with Status do
  167.     begin
  168.     Color := _GetColor;
  169.     F := CurrentFont;
  170.     DontCare := _GetFillMask(FillMask);
  171.     Height := CurrentHeight;
  172.     LineStyle := _GetLineStyle;
  173.     _GetCurrentPosition(Position);
  174.     Width := CurrentWidth;
  175.     WriteMode := _GetWriteMode
  176.     end
  177.   end;
  178.  
  179. function LongToStr(L: longint): string;
  180.   { Convert a longint to a string }
  181.   var Temp: string;
  182.   begin
  183.   str(L,Temp);
  184.   LongToStr := Temp
  185.   end;
  186.  
  187. procedure SetFont(F: Font;
  188.                   Height: integer;
  189.                   Width: integer);
  190.   { Change to a new font }
  191.   var DontCare: integer;
  192.   begin
  193.   if (CurrentFont<>F) or (CurrentHeight<>Height) or (CurrentWidth<>Width) then
  194.     begin
  195.     CurrentFont := F;                            { Keep track of these since MSGraph doesn't }
  196.     CurrentHeight := Height;
  197.     CurrentWidth := Width;
  198.     DontCare := _SetFont('t'''+FontName[F]+''''+
  199.                          'h' + LongToStr(Height) +
  200.                          'w' + LongToStr(Width) +
  201.                          'b')
  202.     end
  203.   end;
  204.  
  205. procedure SetGraphicsStatus(var Status: GraphicsStatus);
  206.   { Restore all of the graphics states }
  207.   begin
  208.   with Status do
  209.     begin
  210.     _SetColor(Color);
  211.     SetFont(F,Height,Width);
  212.     _SetFillMask(FillMask);
  213.     _SetLineStyle(LineStyle);
  214.     _MoveTo(Position.XCoord,Position.YCoord);
  215.     _SetWriteMode(WriteMode)
  216.     end
  217.   end;
  218.  
  219. procedure TWindow.Init(Bordered: boolean;
  220.                        X1,Y1,X2,Y2: real);
  221.   { Initialize a window }
  222.   var I: integer;
  223.  
  224.   procedure DrawBorder(SunColor,ShadowColor: integer;
  225.                        var X1,Y1,X2,Y2: integer);
  226.     { Draw a single row of border }
  227.     begin
  228.     _SetColor(SunColor);
  229.     _MoveTo(X1,Y2);
  230.     _LineTo(X1,Y1);
  231.     _LineTo(X2,Y1);
  232.     _SetColor(ShadowColor);
  233.     _LineTo(X2,Y2);
  234.     _LineTo(X1,Y2);
  235.     inc(X1);                                     { Move border in }
  236.     inc(Y1);
  237.     dec(X2);
  238.     dec(Y2)
  239.     end;
  240.  
  241.   begin
  242.   CurrentWindow := self;
  243.   _SetViewport(0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1); { Set to full screen coordinates }
  244.   _SetColor(SystemWhite);
  245.   SetFont(Roman,10,10);
  246.   _SetFillMask(FillMask[SolidFill]);
  247.   _SetLineStyle(LineStyle[SolidLine]);
  248.   _SetWriteMode(_GPSet);
  249.  
  250.   self.Deactivate;                               { Get the current defaults }
  251.   self.fUpperLeftX := round(X1*(VideoConfig.NumXPixels-1)); { Create window by percentage of screen }
  252.   self.fUpperLeftY := round(Y1*(VideoConfig.NumYPixels-1));
  253.   self.fLowerRightX := round(X2*(VideoConfig.NumXPixels-1));
  254.   self.fLowerRightY := round(Y2*(VideoConfig.NumYPixels-1));
  255.   if Bordered then
  256.     if VideoConfig.NumColors >= 16
  257.      then
  258.       begin
  259.       DrawBorder(0,0,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  260.       for I := 1 to 3 do
  261.         DrawBorder(11,0,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  262.       DrawBorder(15,15,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  263.       _SetColor(3);
  264.       _Rectangle(_GFillInterior,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY)
  265.       end
  266.      else
  267.       begin
  268.       _Rectangle(_GBorder,self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  269.       inc(self.fUpperLeftX);                     { Move window in }
  270.       inc(self.fUpperLeftY);
  271.       dec(self.fLowerRightX);
  272.       dec(self.fLowerRightY)
  273.       end;
  274.   _SetColor(SystemWhite);
  275.   self.Activate
  276.   end;
  277.  
  278. procedure TWindow.Activate;
  279.   { Activate a window and re-establish window drawing styles }
  280.   begin
  281.   CurrentWindow.Deactivate;
  282.   CurrentWindow := self;
  283.   SetGraphicsStatus(self.fSaveStatus);
  284.   _SetViewport(0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1); { Set to full screen coordinates }
  285.   end;
  286.  
  287. procedure TWindow.Deactivate;
  288.   { Deactivate a window and save window drawing styles }
  289.   var DontCare: boolean;
  290.   begin
  291.   GetGraphicsStatus(self.fSaveStatus)
  292.   end;
  293.  
  294. function TWindow.CheckMouse: boolean;
  295.   { Check if the mouse is in this window }
  296.   begin
  297.   if (Mouse.GetLocationX >= self.fUpperLeftX) and (Mouse.GetLocationX <= self.fLowerRightX) and
  298.      (Mouse.GetLocationY >= self.fUpperLeftY) and (Mouse.GetLocationY <= self.fLowerRightY)
  299.    then
  300.     begin
  301.     CheckMouse := true;
  302.     Self.Activate
  303.     end
  304.    else
  305.     CheckMouse := false
  306.   end;
  307.  
  308. procedure TWindow.Clear;
  309.   { Clear the window }
  310.   begin
  311.   self.Activate;
  312.   _ClearScreen(_GViewport)
  313.   end;
  314.  
  315. procedure TDrawingWindow.Activate;
  316.   { Activate a window and re-establish window drawing styles }
  317.   begin
  318.   inherited self.Activate;
  319.   _SetViewport(self.fUpperLeftX,self.fUpperLeftY,self.fLowerRightX,self.fLowerRightY);
  320.   _SetWindow(false,0.0,0.0,1.00,1.00)
  321.   end;
  322.  
  323. procedure Error(ErrorMess: string);
  324.   { Wait for a key to acknowledge the error and quit }
  325.   var DontCare: char;
  326.   begin
  327.   DontCare := char(_SetVideoMode(_DefaultMode));
  328.   writeln(ErrorMess);
  329.   writeln('Hit any key to continue.'^G);
  330.   repeat
  331.   until KeyPressed;
  332.   while KeyPressed do
  333.     DontCare := ReadKey;
  334.   halt(1)
  335.   end;
  336.  
  337. {$F+}
  338. procedure ExitHandler;
  339. {$F-}
  340.   { Restore the original screen mode on exit }
  341.   var DontCare: integer;
  342.   begin
  343.   ExitProc := ExitSave;
  344.   DontCare := _SetVideoMode(_DefaultMode)
  345.   end;
  346.  
  347. procedure InitializeScreen;
  348.   { Change to graphics mode }
  349.   var DontCare: integer;
  350.       FontDir: DirStr;
  351.       FontExt: ExtStr;
  352.       FontName: NameStr;
  353.       FontPath: PathStr;
  354.  
  355.   procedure RegisterFont(Font: PathStr);
  356.     { Register a font }
  357.     begin
  358.     if _RegisterFonts(FontDir+Font+'.FON') < 1 then
  359.       Error('Font file ('+Font+') not found.')
  360.     end;
  361.  
  362.   begin
  363.   ExitSave := ExitProc;
  364.   ExitProc := @ExitHandler;
  365.   _GetVideoConfig(VideoConfig);                  { Check what kind of hardware we have }
  366.   if VideoConfig.Adapter = _MDPA then
  367.     Error('Graphics display not available.');
  368.   DontCare := _SetVideoMode(_MaxResMode);        { This will pick either 2 or 16 color modes }
  369.   _GetVideoConfig(VideoConfig);                  { Get the information on the mode we selected }
  370.  
  371.   if VideoConfig.NumColors >= 16
  372.    then
  373.     begin
  374.     SystemColor := 0;
  375.     SystemBackground := 3;
  376.     SystemWhite := 15;
  377.     _SetColor(7);                                { Give screen an initial color }
  378.     _Rectangle(_GFillInterior,0,0,VideoConfig.NumXPixels-1,VideoConfig.NumYPixels-1)
  379.     end
  380.    else
  381.     begin
  382.     SystemColor := round(0.75*(VideoConfig.NumColors-1));
  383.     SystemBackground := round(0.25*(VideoConfig.NumColors-1));
  384.     SystemWhite := VideoConfig.NumColors - 1
  385.     end;
  386.  
  387.   FontPath := FSearch('MODERN.FON',GetEnv('PATH')); { Find the font files }
  388.   if FontPath = '' then
  389.     Error('Font files (*.FON) not found.');
  390.   FSplit(FExpand(FontPath),FontDir,FontName,FontExt);
  391.   RegisterFont('COURB');
  392.   RegisterFont('HELVB');
  393.   RegisterFont('TMSRB');
  394.   RegisterFont('ROMAN');
  395.   RegisterFont('MODERN');
  396.   RegisterFont('SCRIPT');
  397.   CurrentHeight := -1                            { Make sure the current font doesn't match }
  398.   end;
  399.  
  400. procedure CreateMouse;
  401.   { Create the mouse object }
  402.   begin
  403.   new(Mouse);
  404.   if not Mouse.Init then
  405.     Error('Mouse not found.'^G)
  406.   end;
  407.  
  408. begin
  409. CurrentCanvas := nil;
  410. CurrentWindow := nil;
  411. InitializeScreen;                                { Initialize the screen }
  412. CreateMouse                                      { Initialize the mouse }
  413. end.
  414.