home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chestnut's Multimedia Mania
/
MM_MANIA.ISO
/
graphics
/
paintoop
/
cwindow.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-11-19
|
15KB
|
499 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
(206)531-8944
Compuserve 72247,2671 }
interface
uses Crt,Graph,Dos,CObject,CMouse;
type Font = (Triplex,Small,SansSerif,Gothic,Bold,Simplex,TriplexScript,Script,EuroStyle,Complex);
GraphicsStatus = record
Color: integer;
F: Font;
FillPattern: FillPatternType;
Height: integer;
LineStyle: word;
Viewport: ViewportType;
Width: integer;
WriteMode: integer;
XCoord: integer;
YCoord: integer
end;
type TWindowPtr = ^TWindow;
TWindow = object(TObject)
fSaveStatus: GraphicsStatus;
fUpperLeftX: integer;
fUpperLeftY: integer;
fLowerRightX: integer;
fLowerRightY: integer;
constructor Init(Bordered: boolean;X1,Y1,X2,Y2: real); { Initialize a window }
procedure Activate; virtual; { Activate a window }
procedure Deactivate; virtual; { Deactivate a window }
function CheckMouse: boolean; virtual; { Check if the mouse is in this window }
procedure Clear; virtual; { Clear the window }
end;
type TDrawingWindowPtr = ^TDrawingWindow;
TDrawingWindow = object(TWindow)
constructor Init(Bordered: boolean;X1,Y1,X2,Y2: real);
end;
function AspectRatio: real;
{ Return the aspect ratio for the display in viewport }
procedure ChangeColor(Color: word);
{ Change the current color }
procedure ChangeFill(var FillPattern: FillPatternType;
Color: word);
{ Change the fill pattern }
procedure ChangeWriteMode(Mode: integer);
{ Change the display write mode }
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 }
procedure GraphCheck;
{ Check for a graphics error and quit if something goes wrong }
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 MaxFillPatterns = 16;
SolidFill = MaxFillPatterns - 1;
FillPattern: array[0..MaxFillPatterns-1] of FillPatternType =
(($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); { **************** } { **************** }
var CurrentCanvas: TDrawingWindowPtr;
CurrentFont: Font;
CurrentHeight: integer;
CurrentWidth: integer;
CurrentWindow: TWindowPtr;
CurrentWriteMode: integer;
GraphDriver: integer;
GraphMode: integer;
SystemColor: integer;
SystemBackground: integer;
SystemWhite: integer;
implementation
var BiosCrtMode: byte absolute $0040:$0049; { Where the BIOS stores the video mode }
ExitSave: pointer;
FontTable: array[Font] of integer;
SaveBiosCrtMode: byte;
function AspectRatio: real;
{ Return the aspect ratio for the display in window }
var X: word;
Y: word;
begin
GetAspectRatio(X,Y);
AspectRatio := Y / X
end;
procedure ChangeColor(Color: word);
{ Change the current color }
var FillPattern: FillPatternType;
begin
SetColor(Color);
GetFillPattern(FillPattern); { Change both colors at same time }
ChangeFill(FillPattern,Color)
end;
procedure ChangeFill(var FillPattern: FillPatternType;
Color: word);
{ Change the fill pattern }
begin
if (GraphDriver=HercMono) and (Color=0) { Work around strange bug in Hercules driver }
then
SetFillStyle(Graph.SolidFill,Black)
else
SetFillPattern(FillPattern,Color)
end;
procedure ChangeWriteMode(Mode: integer);
{ Change the display write mode }
begin
CurrentWriteMode := Mode; { Keep track of write mode since Graph doesn't }
SetWriteMode(Mode)
end;
procedure FitText(F: Font;
S: string);
{ Scale the font to fit string into current window }
var TextSettings: TextSettingsType;
Viewport: ViewportType;
begin
GetViewSettings(Viewport);
with Viewport do
begin
SetFont(F,trunc(0.9*(Y2-Y1)),trunc(0.9*(X2-X1)) div length(S));
GetTextSettings(TextSettings);
SetTextJustify(CenterText,CenterText);
OutTextXY((X2-X1) div 2,(Y2-Y1) div 2,S);
SetTextJustify(TextSettings.Horiz,TextSettings.Vert)
end
end;
procedure GetGraphicsStatus(var Status: GraphicsStatus);
{ Get all of the graphics state }
var LineSettings: LineSettingsType;
begin
with Status do
begin
GetViewSettings(Viewport);
Color := GetColor;
F := CurrentFont;
GetFillPattern(FillPattern);
Height := CurrentHeight;
GetLineSettings(LineSettings);
LineStyle := LineSettings.Pattern;
XCoord := GetX;
YCoord := GetY;
Width := CurrentWidth;
WriteMode := CurrentWriteMode
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 RatioX: word;
RatioY: word;
begin
if (CurrentFont<>F) or (CurrentHeight<>Height) or (CurrentWidth<>Width) then
begin
CurrentFont := F; { Keep track of these since Graph doesn't }
CurrentHeight := Height;
CurrentWidth := Width;
SetTextStyle(FontTable[CurrentFont],HorizDir,UserCharSize);
GraphCheck;
SetTextJustify(LeftText,TopText);
GraphCheck;
SetUserCharSize(1,1,1,1);
RatioY := round(10.0 * Height / TextHeight('Q'));
RatioX := round(10.0 * Width / TextWidth('Q'));
SetUserCharSize(RatioX,10,RatioY,10);
GraphCheck
end
end;
procedure SetGraphicsStatus(var Status: GraphicsStatus);
{ Restore all of the graphics states }
begin
with Status do
begin
with Viewport do
SetViewport(X1,Y1,X2,Y2,Clip);
SetColor(Color);
SetFont(F,Height,Width);
ChangeFill(FillPattern,Color);
SetLineStyle(UserBitLn,LineStyle,NormWidth);
MoveTo(XCoord,YCoord);
ChangeWriteMode(WriteMode)
end
end;
constructor 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
ChangeColor(SunColor);
MoveTo(X1,Y2);
LineTo(X1,Y1);
LineTo(X2,Y1);
ChangeColor(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,GetMaxX,GetMaxY,ClipOn); { Set to full screen coordinates }
ChangeColor(SystemWhite);
SetFont(Triplex,10,10);
ChangeFill(FillPattern[SolidFill],SystemWhite);
SetLineStyle(UserBitLn,LineStyle[SolidLine],NormWidth);
ChangeWriteMode(CopyPut);
Deactivate; { Get the current defaults }
fUpperLeftX := round(X1*GetMaxX); { Create window by percentage of screen }
fUpperLeftY := round(Y1*GetMaxY);
fLowerRightX := round(X2*GetMaxX);
fLowerRightY := round(Y2*GetMaxY);
if Bordered then
if GetMaxColor >= 15
then
begin
DrawBorder(0,0,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
for I := 1 to 3 do
DrawBorder(11,0,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
DrawBorder(15,15,fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
ChangeColor(3);
Bar(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY)
end
else
begin
Rectangle(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY);
inc(fUpperLeftX); { Move window in }
inc(fUpperLeftY);
dec(fLowerRightX);
dec(fLowerRightY)
end;
ChangeColor(SystemWhite);
SetViewport(fUpperLeftX,fUpperLeftY,fLowerRightX,fLowerRightY,ClipOn);
Activate
end;
procedure TWindow.Activate;
{ Activate a window and re-establish window drawing styles }
begin
CurrentWindow^.Deactivate;
CurrentWindow := @self;
SetGraphicsStatus(fSaveStatus)
end;
procedure TWindow.Deactivate;
{ Deactivate a window and save window drawing styles }
begin
GetGraphicsStatus(fSaveStatus)
end;
function TWindow.CheckMouse: boolean;
{ Check if the mouse is in this window }
begin
if (Mouse.GetLocationX >= fUpperLeftX) and (Mouse.GetLocationX <= fLowerRightX) and
(Mouse.GetLocationY >= fUpperLeftY) and (Mouse.GetLocationY <= fLowerRightY)
then
begin
CheckMouse := true;
Activate
end
else
CheckMouse := false
end;
procedure TWindow.Clear;
{ Clear the window }
begin
Activate;
ClearViewport
end;
constructor TDrawingWindow.Init(Bordered: boolean;
X1,Y1,X2,Y2: real);
{ Initialize a window }
begin
TWindow.Init(Bordered,X1,Y1,X2,Y2)
end;
procedure Error(ErrorMess: string);
{ Wait for a key to acknowledge the error and quit }
var DontCare: char;
begin
CloseGraph;
writeln(ErrorMess);
writeln('Hit any key to continue.'^G);
repeat
until KeyPressed;
while KeyPressed do
DontCare := ReadKey;
halt(1)
end;
procedure GraphCheck;
{ Check for a graphics error and quit if something goes wrong }
var ErrorCode: integer;
begin
ErrorCode := GraphResult;
if ErrorCode <> grOk then
Error('Graphics error: ' + GraphErrorMsg(ErrorCode))
end;
{$F+}
procedure ExitHandler;
{$F-}
{ Restore the original screen mode on exit }
var DontCare: integer;
begin
ExitProc := ExitSave;
BiosCrtMode := SaveBiosCrtMode; { Restore the BIOS information in case we fiddled with it earlier }
CloseGraph
end;
{$L TRIP.OBJ}
procedure TriplexFont; external;
{$L LITT.OBJ}
procedure SmallFont; external;
{$L SANS.OBJ}
procedure SansSerifFont; external;
{$L GOTH.OBJ}
procedure GothicFont; external;
{$L BOLD}
procedure BoldFontData; external;
{$L SIMP}
procedure SimplexFontData; external;
{$L TSCR}
procedure TriplexScriptFontData; external;
{$L SCRI}
procedure ScriptFontData; external;
{$L EURO}
procedure EuroStyleFontData; external;
{$L LCOM}
procedure ComplexFontData; external;
procedure InitializeScreen;
{ Change to graphics mode }
var DontCare: integer;
begin
ExitSave := ExitProc;
ExitProc := @ExitHandler;
SaveBiosCrtMode := BiosCrtMode;
FontTable[Triplex] := RegisterBGIFont(@TriplexFont);
FontTable[Small] := RegisterBGIFont(@SmallFont);
FontTable[SansSerif] := RegisterBGIFont(@SansSerifFont);
FontTable[Gothic] := RegisterBGIFont(@GothicFont);
FontTable[Bold] := InstallUserFont('BOLD');
FontTable[Bold] := RegisterBGIFont(@BoldFontData);
FontTable[Simplex] := RegisterBGIFont(@SimplexFontData);
FontTable[TriplexScript] := RegisterBGIFont(@TriplexScriptFontData);
FontTable[Script] := RegisterBGIFont(@ScriptFontData);
FontTable[EuroStyle] := RegisterBGIFont(@EuroStyleFontData);
FontTable[Complex] := RegisterBGIFont(@ComplexFontData);
GraphCheck;
GraphDriver := Detect;
DetectGraph(GraphDriver,GraphMode);
GraphCheck;
case GraphDriver of { Pick more colorful modes }
CGA,MCGA,ATT400: GraphMode := CGAC1
else
end;
InitGraph(GraphDriver,GraphMode,'');
GraphCheck;
case GraphDriver of
HercMono: BiosCrtMode := 6 { Inform the mouse driver that we're using a Hercules display }
else
end;
if GetMaxColor >= 15
then
begin
SystemColor := 0;
SystemBackground := 3;
SystemWhite := 15;
ChangeColor(7); { Give screen an initial color }
Bar(0,0,GetMaxX,GetMaxY)
end
else
begin
SystemColor := round(0.75*GetMaxColor);
SystemBackground := round(0.25*GetMaxColor);
SystemWhite := GetMaxColor
end;
CurrentHeight := -1; { Make sure the current font doesn't match }
ChangeWriteMode(CopyPut)
end;
procedure CreateMouse;
{ Create the mouse object }
begin
Mouse.Init;
if not Mouse.Present then
Error('Mouse not found.'^G)
end;
begin
CurrentCanvas := nil;
CurrentWindow := nil;
InitializeScreen; { Initialize the screen }
CreateMouse { Initialize the mouse }
end.