home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / paintoop / cwindow.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-11-19  |  14.7 KB  |  499 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 Crt,Graph,Dos,CObject,CMouse;
  17.  
  18. type Font = (Triplex,Small,SansSerif,Gothic,Bold,Simplex,TriplexScript,Script,EuroStyle,Complex);
  19.      GraphicsStatus = record
  20.        Color: integer;
  21.        F: Font;
  22.        FillPattern: FillPatternType;
  23.        Height: integer;
  24.        LineStyle: word;
  25.        Viewport: ViewportType;
  26.        Width: integer;
  27.        WriteMode: integer;
  28.        XCoord: integer;
  29.        YCoord: integer
  30.        end;
  31.  
  32. type TWindowPtr = ^TWindow;
  33.      TWindow = object(TObject)
  34.        fSaveStatus: GraphicsStatus;
  35.        fUpperLeftX: integer;
  36.        fUpperLeftY: integer;
  37.        fLowerRightX: integer;
  38.        fLowerRightY: integer;
  39.        constructor Init(Bordered: boolean;X1,Y1,X2,Y2: real); { Initialize a window }
  40.        procedure Activate; virtual;              { Activate a window }
  41.        procedure Deactivate; virtual;            { Deactivate a window }
  42.        function CheckMouse: boolean; virtual;    { Check if the mouse is in this window }
  43.        procedure Clear; virtual;                 { Clear the window }
  44.        end;
  45.  
  46. type TDrawingWindowPtr = ^TDrawingWindow;
  47.      TDrawingWindow = object(TWindow)
  48.        constructor Init(Bordered: boolean;X1,Y1,X2,Y2: real);
  49.        end;
  50.  
  51. function AspectRatio: real;
  52.   { Return the aspect ratio for the display in viewport }
  53.  
  54. procedure ChangeColor(Color: word);
  55.   { Change the current color }
  56.  
  57. procedure ChangeFill(var FillPattern: FillPatternType;
  58.                          Color: word);
  59.   { Change the fill pattern }
  60.  
  61. procedure ChangeWriteMode(Mode: integer);
  62.   { Change the display write mode }
  63.  
  64. procedure Error(ErrorMess: string);
  65.   { Wait for a key to acknowledge the error and quit }
  66.  
  67. procedure FitText(F: Font;
  68.                   S: string);
  69.   { Scale the font to fit string into current window }
  70.  
  71. procedure GetGraphicsStatus(var Status: GraphicsStatus);
  72.   { Get all of the graphics state }
  73.  
  74. procedure GraphCheck;
  75.   { Check for a graphics error and quit if something goes wrong }
  76.  
  77. function LongToStr(L: longint): string;
  78.   { Convert a longint to a string }
  79.  
  80. procedure SetFont(F: Font;Height: integer;Width: integer);
  81.   { Change to a new font }
  82.  
  83. procedure SetGraphicsStatus(var Status: GraphicsStatus);
  84.   { Restore all of the graphics states }
  85.  
  86. const MaxFillPatterns = 16;
  87.       SolidFill = MaxFillPatterns - 1;
  88.       FillPattern: array[0..MaxFillPatterns-1] of FillPatternType =
  89.         (($80,$40,$20,$10,$08,$04,$02,$01),      { \ \  fill }
  90.          ($88,$44,$22,$11,$88,$44,$22,$11),      { \\\\ fill }
  91.          ($01,$02,$04,$08,$10,$20,$40,$80),      { / /  fill }
  92.          ($11,$22,$44,$88,$11,$22,$44,$88),      { //// fill }
  93.          ($80,$41,$22,$14,$08,$14,$22,$41),      { X X  fill }
  94.          ($55,$22,$55,$88,$55,$22,$55,$88),      { XXXX fill }
  95.          ($10,$10,$FF,$10,$10,$10,$10,$10),      { + +  fill }
  96.          ($22,$22,$FF,$22,$22,$22,$FF,$22),      { ++++ fill }
  97.  
  98.          ($E0,$70,$38,$1C,$0E,$07,$83,$C1),      { \\   fill }
  99.          ($07,$0E,$1C,$38,$70,$E0,$C1,$83),      { //   fill }
  100.          ($18,$18,$18,$FF,$FF,$18,$18,$18),      { ++   fill }
  101.  
  102.          ($00,$00,$00,$00,$00,$00,$00,$00),      { Empty fill }
  103.          ($88,$00,$22,$00,$88,$00,$22,$00),      { Light fill }
  104.          ($AA,$55,$AA,$55,$AA,$55,$AA,$55),      { 50% fill }
  105.          ($77,$FF,$DD,$FF,$77,$FF,$DD,$FF),      { Heavy fill }
  106.          ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF));     { Solid fill }
  107.  
  108. const MaxLineStyles = 12;
  109.       SolidLine = MaxLineStyles - 1;
  110.       LineStyle: array[0..MaxLineStyles-1] of word =
  111.         ($AAAA,          { * * * * * * * *  }    { * * * * * * * *  }
  112.          $9999,          { *  **  **  **  * }    { **  **  **  **   }
  113.          $DDDD,          { ** *** *** *** * }    { *** *** *** ***  }
  114.          $E633,          { ***  **   **  ** }    { *****  **   **   }
  115.          $F1C7,          { ****   ***   *** }    { *******   ***    }
  116.          $FC3F,          { ******    ****** }    { ************     }
  117.          $1010,          {    *       *     }    { *       *        }
  118.          $4444,          {  *   *   *   *   }    { *   *   *   *    }
  119.          $8181,          { *      **      * }    { **      **       }
  120.          $C3C3,          { **    ****    ** }    { ****    ****     }
  121.          $E7E7,          { ***  ******  *** }    { ******  ******   }
  122.          $FFFF);         { **************** }    { **************** }
  123.  
  124. var CurrentCanvas: TDrawingWindowPtr;
  125.     CurrentFont: Font;
  126.     CurrentHeight: integer;
  127.     CurrentWidth: integer;
  128.     CurrentWindow: TWindowPtr;
  129.     CurrentWriteMode: integer;
  130.     GraphDriver: integer;
  131.     GraphMode: integer;
  132.     SystemColor: integer;
  133.     SystemBackground: integer;
  134.     SystemWhite: integer;
  135.  
  136. implementation
  137.  
  138. var BiosCrtMode: byte absolute $0040:$0049;      { Where the BIOS stores the video mode }
  139.     ExitSave: pointer;
  140.     FontTable: array[Font] of integer;
  141.     SaveBiosCrtMode: byte;
  142.  
  143. function AspectRatio: real;
  144.   { Return the aspect ratio for the display in window }
  145.   var X: word;
  146.       Y: word;
  147.   begin
  148.   GetAspectRatio(X,Y);
  149.   AspectRatio := Y / X
  150.   end;
  151.  
  152. procedure ChangeColor(Color: word);
  153.   { Change the current color }
  154.   var FillPattern: FillPatternType;
  155.   begin
  156.   SetColor(Color);
  157.   GetFillPattern(FillPattern);                   { Change both colors at same time }
  158.   ChangeFill(FillPattern,Color)
  159.   end;
  160.  
  161. procedure ChangeFill(var FillPattern: FillPatternType;
  162.                          Color: word);
  163.   { Change the fill pattern }
  164.   begin
  165.   if (GraphDriver=HercMono) and (Color=0)        { Work around strange bug in Hercules driver }
  166.    then
  167.     SetFillStyle(Graph.SolidFill,Black)
  168.    else
  169.     SetFillPattern(FillPattern,Color)
  170.   end;
  171.  
  172. procedure ChangeWriteMode(Mode: integer);
  173.   { Change the display write mode }
  174.   begin
  175.   CurrentWriteMode := Mode;                      { Keep track of write mode since Graph doesn't }
  176.   SetWriteMode(Mode)
  177.   end;
  178.  
  179. procedure FitText(F: Font;
  180.                   S: string);
  181.   { Scale the font to fit string into current window }
  182.   var TextSettings: TextSettingsType;
  183.       Viewport: ViewportType;
  184.   begin
  185.   GetViewSettings(Viewport);
  186.   with Viewport do
  187.     begin
  188.     SetFont(F,trunc(0.9*(Y2-Y1)),trunc(0.9*(X2-X1)) div length(S));
  189.     GetTextSettings(TextSettings);
  190.     SetTextJustify(CenterText,CenterText);
  191.     OutTextXY((X2-X1) div 2,(Y2-Y1) div 2,S);
  192.     SetTextJustify(TextSettings.Horiz,TextSettings.Vert)
  193.     end
  194.   end;
  195.  
  196. procedure GetGraphicsStatus(var Status: GraphicsStatus);
  197.   { Get all of the graphics state }
  198.   var LineSettings: LineSettingsType;
  199.   begin
  200.   with Status do
  201.     begin
  202.     GetViewSettings(Viewport);
  203.     Color := GetColor;
  204.     F := CurrentFont;
  205.     GetFillPattern(FillPattern);
  206.     Height := CurrentHeight;
  207.     GetLineSettings(LineSettings);
  208.     LineStyle := LineSettings.Pattern;
  209.     XCoord := GetX;
  210.     YCoord := GetY;
  211.     Width := CurrentWidth;
  212.     WriteMode := CurrentWriteMode
  213.     end
  214.   end;
  215.  
  216. function LongToStr(L: longint): string;
  217.   { Convert a longint to a string }
  218.   var Temp: string;
  219.   begin
  220.   str(L,Temp);
  221.   LongToStr := Temp
  222.   end;
  223.  
  224. procedure SetFont(F: Font;
  225.                   Height: integer;
  226.                   Width: integer);
  227.   { Change to a new font }
  228.   var RatioX: word;
  229.       RatioY: word;
  230.   begin
  231.   if (CurrentFont<>F) or (CurrentHeight<>Height) or (CurrentWidth<>Width) then
  232.     begin
  233.     CurrentFont := F;                            { Keep track of these since Graph doesn't }
  234.     CurrentHeight := Height;
  235.     CurrentWidth := Width;
  236.     SetTextStyle(FontTable[CurrentFont],HorizDir,UserCharSize);
  237.     GraphCheck;
  238.     SetTextJustify(LeftText,TopText);
  239.     GraphCheck;
  240.     SetUserCharSize(1,1,1,1);
  241.     RatioY := round(10.0 * Height / TextHeight('Q'));
  242.     RatioX := round(10.0 * Width / TextWidth('Q'));
  243.     SetUserCharSize(RatioX,10,RatioY,10);
  244.     GraphCheck
  245.     end
  246.   end;
  247.  
  248. procedure SetGraphicsStatus(var Status: GraphicsStatus);
  249.   { Restore all of the graphics states }
  250.   begin
  251.   with Status do
  252.     begin
  253.     with Viewport do
  254.       SetViewport(X1,Y1,X2,Y2,Clip);
  255.     SetColor(Color);
  256.     SetFont(F,Height,Width);
  257.     ChangeFill(FillPattern,Color);
  258.     SetLineStyle(UserBitLn,LineStyle,NormWidth);
  259.     MoveTo(XCoord,YCoord);
  260.     ChangeWriteMode(WriteMode)
  261.     end
  262.   end;
  263.  
  264. constructor TWindow.Init(Bordered: boolean;
  265.                        X1,Y1,X2,Y2: real);
  266.   { Initialize a window }
  267.   var I: integer;
  268.  
  269.   procedure DrawBorder(SunColor,ShadowColor: integer;
  270.                        var X1,Y1,X2,Y2: integer);
  271.     { Draw a single row of border }
  272.     begin
  273.     ChangeColor(SunColor);
  274.     MoveTo(X1,Y2);
  275.     LineTo(X1,Y1);
  276.     LineTo(X2,Y1);
  277.     ChangeColor(ShadowColor);
  278.     LineTo(X2,Y2);
  279.     LineTo(X1,Y2);
  280.     inc(X1);                                     { Move border in }
  281.     inc(Y1);
  282.     dec(X2);
  283.     dec(Y2)
  284.     end;
  285.  
  286.   begin
  287.   CurrentWindow := @self;
  288.   SetViewport(0,0,GetMaxX,GetMaxY,ClipOn);       { Set to full screen coordinates }
  289.   ChangeColor(SystemWhite);
  290.   SetFont(Triplex,10,10);
  291.   ChangeFill(FillPattern[SolidFill],SystemWhite);
  292.   SetLineStyle(UserBitLn,LineStyle[SolidLine],NormWidth);
  293.   ChangeWriteMode(CopyPut);
  294.  
  295.   Deactivate;                                    { Get the current defaults }
  296.   fUpperLeftX := round(X1*GetMaxX);              { Create window by percentage of screen }
  297.   fUpperLeftY := round(Y1*GetMaxY);
  298.   fLowerRightX := round(X2*GetMaxX);
  299.   fLowerRightY := round(Y2*GetMaxY);
  300.   if Bordered then
  301.     if GetMaxColor >= 15
  302.      then
  303.       begin
  304.       DrawBorder(0,0,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
  305.       for I := 1 to 3 do
  306.         DrawBorder(11,0,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
  307.       DrawBorder(15,15,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
  308.       ChangeColor(3);
  309.       Bar(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY)
  310.       end
  311.      else
  312.       begin
  313.       Rectangle(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
  314.       inc(fUpperLeftX);                          { Move window in }
  315.       inc(fUpperLeftY);
  316.       dec(fLowerRightX);
  317.       dec(fLowerRightY)
  318.       end;
  319.   ChangeColor(SystemWhite);
  320.   SetViewport(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY,ClipOn);
  321.   Activate
  322.   end;
  323.  
  324. procedure TWindow.Activate;
  325.   { Activate a window and re-establish window drawing styles }
  326.   begin
  327.   CurrentWindow^.Deactivate;
  328.   CurrentWindow := @self;
  329.   SetGraphicsStatus(fSaveStatus)
  330.   end;
  331.  
  332. procedure TWindow.Deactivate;
  333.   { Deactivate a window and save window drawing styles }
  334.   begin
  335.   GetGraphicsStatus(fSaveStatus)
  336.   end;
  337.  
  338. function TWindow.CheckMouse: boolean;
  339.   { Check if the mouse is in this window }
  340.   begin
  341.   if (Mouse.GetLocationX >= fUpperLeftX) and (Mouse.GetLocationX <= fLowerRightX) and
  342.      (Mouse.GetLocationY >= fUpperLeftY) and (Mouse.GetLocationY <= fLowerRightY)
  343.    then
  344.     begin
  345.     CheckMouse := true;
  346.     Activate
  347.     end
  348.    else
  349.     CheckMouse := false
  350.   end;
  351.  
  352. procedure TWindow.Clear;
  353.   { Clear the window }
  354.   begin
  355.   Activate;
  356.   ClearViewport
  357.   end;
  358.  
  359. constructor TDrawingWindow.Init(Bordered: boolean;
  360.                        X1,Y1,X2,Y2: real);
  361.   { Initialize a window }
  362.   begin
  363.   TWindow.Init(Bordered,X1,Y1,X2,Y2)
  364.   end;
  365.  
  366. procedure Error(ErrorMess: string);
  367.   { Wait for a key to acknowledge the error and quit }
  368.   var DontCare: char;
  369.   begin
  370.   CloseGraph;
  371.   writeln(ErrorMess);
  372.   writeln('Hit any key to continue.'^G);
  373.   repeat
  374.   until KeyPressed;
  375.   while KeyPressed do
  376.     DontCare := ReadKey;
  377.   halt(1)
  378.   end;
  379.  
  380. procedure GraphCheck;
  381.   { Check for a graphics error and quit if something goes wrong }
  382.   var ErrorCode: integer;
  383.   begin
  384.   ErrorCode := GraphResult;
  385.   if ErrorCode <> grOk then
  386.     Error('Graphics error: ' + GraphErrorMsg(ErrorCode))
  387.   end;
  388.  
  389. {$F+}
  390. procedure ExitHandler;
  391. {$F-}
  392.   { Restore the original screen mode on exit }
  393.   var DontCare: integer;
  394.   begin
  395.   ExitProc := ExitSave;
  396.   BiosCrtMode := SaveBiosCrtMode;                { Restore the BIOS information in case we fiddled with it earlier }
  397.   CloseGraph
  398.   end;
  399.  
  400. {$L TRIP.OBJ}
  401. procedure TriplexFont; external;
  402.  
  403. {$L LITT.OBJ}
  404. procedure SmallFont; external;
  405.  
  406. {$L SANS.OBJ}
  407. procedure SansSerifFont; external;
  408.  
  409. {$L GOTH.OBJ}
  410. procedure GothicFont; external;
  411.  
  412. {$L BOLD}
  413. procedure BoldFontData; external;
  414.  
  415. {$L SIMP}
  416. procedure SimplexFontData; external;
  417.  
  418. {$L TSCR}
  419. procedure TriplexScriptFontData; external;
  420.  
  421. {$L SCRI}
  422. procedure ScriptFontData; external;
  423.  
  424. {$L EURO}
  425. procedure EuroStyleFontData; external;
  426.  
  427. {$L LCOM}
  428. procedure ComplexFontData; external;
  429.  
  430. procedure InitializeScreen;
  431.   { Change to graphics mode }
  432.   var DontCare: integer;
  433.   begin
  434.   ExitSave := ExitProc;
  435.   ExitProc := @ExitHandler;
  436.   SaveBiosCrtMode := BiosCrtMode;
  437.  
  438.   FontTable[Triplex] := RegisterBGIFont(@TriplexFont);
  439.   FontTable[Small] := RegisterBGIFont(@SmallFont);
  440.   FontTable[SansSerif] := RegisterBGIFont(@SansSerifFont);
  441.   FontTable[Gothic] := RegisterBGIFont(@GothicFont);
  442.   FontTable[Bold] := InstallUserFont('BOLD');
  443.   FontTable[Bold] := RegisterBGIFont(@BoldFontData);
  444.   FontTable[Simplex] := RegisterBGIFont(@SimplexFontData);
  445.   FontTable[TriplexScript] := RegisterBGIFont(@TriplexScriptFontData);
  446.   FontTable[Script] := RegisterBGIFont(@ScriptFontData);
  447.   FontTable[EuroStyle] := RegisterBGIFont(@EuroStyleFontData);
  448.   FontTable[Complex] := RegisterBGIFont(@ComplexFontData);
  449.   GraphCheck;
  450.  
  451.   GraphDriver := Detect;
  452.   DetectGraph(GraphDriver,GraphMode);
  453.   GraphCheck;
  454.   case GraphDriver of                            { Pick more colorful modes }
  455.     CGA,MCGA,ATT400: GraphMode := CGAC1
  456.     else
  457.     end;
  458.   InitGraph(GraphDriver,GraphMode,'');
  459.   GraphCheck;
  460.   case GraphDriver of
  461.     HercMono: BiosCrtMode := 6                   { Inform the mouse driver that we're using a Hercules display }
  462.     else
  463.     end;
  464.  
  465.   if GetMaxColor >= 15
  466.    then
  467.     begin
  468.     SystemColor := 0;
  469.     SystemBackground := 3;
  470.     SystemWhite := 15;
  471.     ChangeColor(7);                              { Give screen an initial color }
  472.     Bar(0,0,GetMaxX,GetMaxY)
  473.     end
  474.    else
  475.     begin
  476.     SystemColor := round(0.75*GetMaxColor);
  477.     SystemBackground := round(0.25*GetMaxColor);
  478.     SystemWhite := GetMaxColor
  479.     end;
  480.  
  481.   CurrentHeight := -1;                           { Make sure the current font doesn't match }
  482.   ChangeWriteMode(CopyPut)
  483.   end;
  484.  
  485. procedure CreateMouse;
  486.   { Create the mouse object }
  487.   begin
  488.   Mouse.Init;
  489.   if not Mouse.Present then
  490.     Error('Mouse not found.'^G)
  491.   end;
  492.  
  493. begin
  494. CurrentCanvas := nil;
  495. CurrentWindow := nil;
  496. InitializeScreen;                                { Initialize the screen }
  497. CreateMouse                                      { Initialize the mouse }
  498. end.
  499.