paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 13:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added ptcgraph implementation of SetBkColor and GetBkColor in 640x480x2 (MCGAHi) mode

Browse Source 
git-svn-id: trunk@16115 -
This commit is contained in:
nickysn 2010-10-09 16:17:41 +00:00
parent 799b0368ac
commit 6310b37bd5
1 changed files with 61 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
packages/graph/src/ptcgraph/ptcgraph.pp
View File

@ -614,6 +614,32 @@ begin
CurrentCGABkColor := 0;
end;
procedure ptc_InitPaletteMCGA2;
var
PaletteData: PUint32;
I: Integer;
r, g, b: Uint32;
begin
VGAPalette := DefaultVGA16Palette;
FillChar(EGAPalette, SizeOf(EGAPalette), 0);
EGAPaletteEnabled := True;
for I := 1 to 15 do
EGAPalette[I] := 63;
PaletteData := ptc_palette_lock;
FillChar(PaletteData^, 256*4, 0);
for I := 0 to 1 do
begin
r := VGA6to8(VGAPalette[EGAPalette[I], 0]);
g := VGA6to8(VGAPalette[EGAPalette[I], 1]);
b := VGA6to8(VGAPalette[EGAPalette[I], 2]);
PaletteData[I] := (r shl 16) or (g shl 8) or b;
end;
ptc_palette_unlock;
CurrentCGABkColor := 0;
end;
procedure ptc_InternalOpen(const ATitle: string; AWidth, AHeight: Integer; AFormat: TPTCFormat; AVirtualPages: Integer);
var
ConsoleWidth, ConsoleHeight: Integer;
@ -717,6 +743,21 @@ begin
ColorMask := 1;
end;
procedure ptc_InitModeMCGA2(XResolution, YResolution, Pages: LongInt);
begin
{$IFDEF logging}
LogLn('Initializing mode ' + strf(XResolution) + ', ' + strf(YResolution) + ' 2 colours');
{$ENDIF logging}
{ open the console }
ptc_InternalOpen(ParamStr(0), XResolution, YResolution, PTCFormat8, Pages);
PTCWidth := XResolution;
PTCHeight := YResolution;
CurrentActivePage := 0;
{ create palette }
ptc_InitPaletteMCGA2;
ColorMask := 1;
end;
procedure ptc_InitMode32k(XResolution, YResolution, Pages: LongInt);
begin
{$IFDEF logging}
@ -801,7 +842,7 @@ end;
procedure ptc_Init640x480x2;
begin
ptc_InitModeCGA2(640, 480, 1);
ptc_InitModeMCGA2(640, 480, 1);
end;
procedure ptc_Init720x348x2;
@ -950,6 +991,22 @@ begin
GetBkColorCGA640 := CurrentCGABkColor;
end;
{ nickysn: VGA compatible implementation. I don't have a real MCGA to test
if there's any difference with VGA }
procedure SetBkColorMCGA640(ColorNum: Word);
begin
if ColorNum > 15 then
exit;
CurrentCGABkColor := ColorNum;
ptc_SetEGAPalette(0, ((ColorNum shl 1) and $10) or (ColorNum and $07));
end;
function GetBkColorMCGA640: Word;
begin
GetBkColorMCGA640 := CurrentCGABkColor;
end;
Function ClipCoords (Var X,Y : smallint) : Boolean;
{ Adapt to viewport, return TRUE if still in viewport,
false if outside viewport}
@ -1908,6 +1965,9 @@ end;
SetVisualPage := @ptc_SetVisualPage;
SetActivePage := @ptc_SetActivePage;
SetBkColor := @SetBkColorMCGA640;
GetBkColor := @GetBkColorMCGA640;
XAspect := 10000;
YAspect := 10000;
end;