paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 20:29:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Initial implementation of graph unit on ptc

Browse Source 
git-svn-id: trunk@6929 -
This commit is contained in:
daniel 2007-03-18 22:07:37 +00:00
parent 6db1d803fa
commit dd4d377504
2 changed files with 538 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -797,6 +797,7 @@ packages/base/graph/inc/gtext.inc svneol=native#text/plain
packages/base/graph/inc/makefile.inc svneol=native#text/plain packages/base/graph/inc/makefile.inc svneol=native#text/plain
packages/base/graph/inc/modes.inc svneol=native#text/plain packages/base/graph/inc/modes.inc svneol=native#text/plain
packages/base/graph/inc/palette.inc svneol=native#text/plain packages/base/graph/inc/palette.inc svneol=native#text/plain
packages/base/graph/ptcgraph.pp svneol=native#text/x-pascal
packages/base/graph/unix/ggigraph.pp svneol=native#text/plain packages/base/graph/unix/ggigraph.pp svneol=native#text/plain
packages/base/graph/unix/graph.pp svneol=native#text/plain packages/base/graph/unix/graph.pp svneol=native#text/plain
packages/base/graph/unix/graph16.inc svneol=native#text/plain packages/base/graph/unix/graph16.inc svneol=native#text/plain

537
packages/base/graph/ptcgraph.pp Normal file
View File

@ -0,0 +1,537 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Daniel Mantione
member of the Free Pascal development team
This file implements the PTC support for the graph unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit ptcgraph;
{$define logging}
{******************************************************************************}
interface
{******************************************************************************}
{$i graphh.inc}
{Driver number for PTC.}
const PTC=22;
{******************************************************************************}
implementation
{******************************************************************************}
uses
termio,x86,ptc;
const
InternalDriverName = 'PTCPas';
{$i graph.inc}
type
PByte = ^Byte;
PLongInt = ^LongInt;
PByteArray = ^TByteArray;
TByteArray = array [0..MAXINT - 1] of Byte;
{ ---------------------------------------------------------------------
SVGA bindings.
---------------------------------------------------------------------}
Const
{ Text }
WRITEMODE_OVERWRITE = 0;
WRITEMODE_MASKED = 1;
FONT_EXPANDED = 0;
FONT_COMPRESSED = 2;
{ Types }
type
pvga_modeinfo = ^vga_modeinfo;
vga_modeinfo = record
width,
height,
bytesperpixel,
colors,
linewidth, { scanline width in bytes }
maxlogicalwidth, { maximum logical scanline width }
startaddressrange, { changeable bits set }
maxpixels, { video memory / bytesperpixel }
haveblit, { mask of blit functions available }
flags: Longint; { other flags }
{ Extended fields: }
chiptype, { Chiptype detected }
memory, { videomemory in KB }
linewidth_unit: Longint; { Use only a multiple of this as parameter for set_displaystart }
linear_aperture: PChar; { points to mmap secondary mem aperture of card }
aperture_size: Longint; { size of aperture in KB if size>=videomemory.}
set_aperture_page: procedure (page: Longint);
{ if aperture_size<videomemory select a memory page }
extensions: Pointer; { points to copy of eeprom for mach32 }
{ depends from actual driver/chiptype.. etc. }
end;
PGraphicsContext = ^TGraphicsContext;
TGraphicsContext = record
ModeType: Byte;
ModeFlags: Byte;
Dummy: Byte;
FlipPage: Byte;
Width: LongInt;
Height: LongInt;
BytesPerPixel: LongInt;
Colors: LongInt;
BitsPerPixel: LongInt;
ByteWidth: LongInt;
VBuf: pointer;
Clip: LongInt;
ClipX1: LongInt;
ClipY1: LongInt;
ClipX2: LongInt;
ClipY2: LongInt;
ff: pointer;
end;
var
OldIO : TermIos;
ptcconsole:TPTCconsole;
ptcsurface:TPTCSurface;
ptcformat:TPTCFormat;
Procedure SetRawMode(b:boolean);
Var
Tio : Termios;
Begin
if b then
begin
TCGetAttr(1,Tio);
OldIO:=Tio;
CFMakeRaw(Tio);
end
else
Tio:=OldIO;
TCSetAttr(1,TCSANOW,Tio);
End;
{ ---------------------------------------------------------------------
Required procedures
---------------------------------------------------------------------}
var
LastColor: smallint; {Cache the last set color to improve speed}
procedure ptc_savevideostate;
begin
end;
procedure ptc_restorevideostate;
begin
{ vga_setmode(0);}
end;
{
const
BgiColors: array[0..15] of LongInt
= ($000000, $000020, $002000, $002020,
$200000, $200020, $202000, $303030,
$202020, $00003F, $003F00, $003F3F,
$3F0000, $3F003F, $3F3F00, $3F3F3F);
}
procedure InitColors(nrColors: longint);
var
i: smallint;
begin
{ for i:=0 to nrColors do
vga_setpalette(I,DefaultColors[i].red shr 2,
DefaultColors[i].green shr 2,DefaultColors[i].blue shr 2)}
end;
procedure ptc_initmodeproc;
begin
writeln('Initializing mode');
{ create format }
ptcformat:=TPTCFormat.Create(16,$f800,$07e0,$001f);
{ open the console }
ptcconsole.open(paramstr(0),ptcformat);
{ create surface matching console dimensions }
ptcsurface:=TPTCSurface.Create(ptcconsole.width,ptcconsole.height,ptcformat);
end;
Function ClipCoords (Var X,Y : smallint) : Boolean;
{ Adapt to viewport, return TRUE if still in viewport,
false if outside viewport}
begin
X:= X + StartXViewPort;
Y:= Y + StartYViewPort;
ClipCoords:=Not ClipPixels;
if ClipPixels then
Begin
ClipCoords:=(X < StartXViewPort) or (X > (StartXViewPort + ViewWidth));
ClipCoords:=ClipCoords or
((Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)));
ClipCoords:=Not ClipCoords;
end;
end;
procedure ptc_directpixelproc_16bpp(X,Y: smallint);
var color:word;
pixels:Pword;
begin
case CurrentWriteMode of
XORPut:
begin
{ getpixel wants local/relative coordinates }
Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
Color := CurrentColor Xor Color;
end;
OrPut:
begin
{ getpixel wants local/relative coordinates }
Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
Color := CurrentColor Or Color;
end;
AndPut:
begin
{ getpixel wants local/relative coordinates }
Color := GetPixel(x-StartXViewPort,y-StartYViewPort);
Color := CurrentColor And Color;
end;
NotPut:
begin
Color := Not Color;
end
else
Color:=CurrentColor;
end;
pixels:=ptcsurface.lock;
{Plot the pixel on the surface.}
pixels[x+y*ptcsurface.width]:=color;
ptcsurface.unlock;
{ copy to console }
ptcsurface.copy(ptcconsole);
{ update console }
ptcconsole.update;
end;
procedure ptc_putpixelproc_16bpp(X,Y:smallint;Color:Word);
var pixels:Pword;
begin
if clipcoords(X,Y) then
begin
pixels:=ptcsurface.lock;
{ pixels:=ptcconsole.lock;}
{Plot the pixel on the surface.}
pixels[x+y*ptcsurface.width]:=color;
ptcsurface.unlock;
{ copy to console }
ptcsurface.copy(ptcconsole);
{ update console }
ptcconsole.update;
end;
end;
function ptc_getpixelproc_16bpp(X,Y: smallint):word;
var pixels:Pword;
begin
if clipcoords(X,Y) then
begin
pixels:=ptcsurface.lock;
{Get the pixel from the surface.}
ptc_getpixelproc_16bpp:=pixels[x+y*ptcsurface.width];
ptcsurface.unlock;
end;
end;
{ Bitmap utilities }
{type
PBitmap = ^TBitmap;
TBitmap = record
Width, Height: smallint;
Data: record end;
end;
}
procedure ptc_putimageproc (X,Y: smallint; var Bitmap; BitBlt: Word);
begin
end;
procedure ptc_getimageproc (X1,Y1,X2,Y2: smallint; Var Bitmap);
begin
end;
function ptc_imagesizeproc (X1,Y1,X2,Y2: smallint): longint;
begin
end;
procedure ptc_hlineproc_16bpp(x, x2,y : smallint);
var pixels:Pword;
i:word;
begin
{Clip.}
if (y<0) or (y>viewheight) then
exit;
if x<0 then
x:=0;
if x>viewwidth then
x:=viewwidth;
if x2<0 then
x2:=0;
if x>viewwidth then
x2:=viewwidth;
pixels:=ptcsurface.lock;
inc(x,StartXViewPort);
inc(x2,StartXViewPort);
inc(y,StartXViewPort);
{Plot the pixel on the surface.}
for i:=x to x2 do
pixels[i+y*ptcsurface.width]:=$ffff;
ptcsurface.unlock;
{ copy to console }
ptcsurface.copy(ptcconsole);
{ update console }
ptcconsole.update;
end;
procedure ptc_vlineproc (x,y,y2: smallint);
begin
end;
procedure ptc_clrviewproc_16bpp;
Var I,Xmax : longint;
begin
Xmax:=StartXViewPort+ViewWidth-1;
For i:=StartYViewPort to StartYViewPort+ViewHeight-1 do
ptc_hlineproc_16bpp(0,viewwidth,i);
{ reset coordinates }
CurrentX := 0;
CurrentY := 0;
end;
procedure ptc_patternlineproc (x1,x2,y: smallint);
begin
end;
procedure ptc_ellipseproc (X,Y: smallint;XRadius: word;
YRadius:word; stAngle,EndAngle: word; fp: PatternLineProc);
begin
end;
procedure ptc_lineproc (X1, Y1, X2, Y2 : smallint);
begin
end;
procedure ptc_getscanlineproc (X1,X2,Y : smallint; var data);
begin
end;
procedure ptc_setactivepageproc (page: word);
begin
end;
procedure ptc_setvisualpageproc (page: word);
begin
end;
procedure ptc_savestateproc;
begin
end;
procedure ptc_restorestateproc;
begin
end;
procedure ptc_setrgbpaletteproc(ColorNum, RedValue, GreenValue, BlueValue: smallint);
begin
{ vga_setpalette(ColorNum,RedValue shr 2,GreenValue shr 2,BlueValue shr 2);}
end;
procedure ptc_getrgbpaletteproc (ColorNum: smallint;
var RedValue, GreenValue, BlueValue: smallint);
Var R,G,B : longint;
begin
{ vga_getpalette(ColorNum,R,G,B);}
RedValue:=R * 255 div 63;
GreenValue:=G * 255 div 63;
BlueValue:=B * 255 div 63;
end;
{************************************************************************}
{* General routines *}
{************************************************************************}
procedure CloseGraph;
Begin
If not isgraphmode then
begin
_graphresult := grnoinitgraph;
exit
end;
SetRawMode(False);
RestoreVideoState;
isgraphmode := false;
end;
function QueryAdapterInfo:PModeInfo;
{ This routine returns the head pointer to the list }
{ of supported graphics modes. }
{ Returns nil if no graphics mode supported. }
{ This list is READ ONLY! }
var
graphmode:Tmodeinfo;
ptcmode: PPTCmode;
d,i : longint;
ws,hs:string[5];
const depths:array[0..3] of byte=(8,16,24,32);
colours:array[0..3] of longint=(256,65536,16777216,16777216);
depth_names:array[0..3] of string[5]=('256','64K','16M','16M32');
begin
QueryAdapterInfo := ModeList;
{ If the mode listing already exists... }
{ simply return it, without changing }
{ anything... }
if assigned(ModeList) then
exit;
SaveVideoState:=@ptc_savevideostate;
RestoreVideoState:=@ptc_restorevideostate;
ptcconsole:=TPTCconsole.create;
ptcmode:=ptcconsole.modes;
i:=0;
initmode(graphmode);
with graphmode do
begin
modenumber:=0;
drivernumber:=ptcgraph.ptc;
maxx:=639;
maxy:=479;
modename:='PTC_640x480x64K';
maxcolor:=65536;
palettesize:=65536;
hardwarepages:=0;
InitMode := @ptc_InitModeProc;
DirectPutPixel := @ptc_DirectPixelProc_16bpp;
GetPixel := @ptc_GetPixelProc_16bpp;
PutPixel := @ptc_PutPixelProc_16bpp;
SetRGBPalette := @ptc_SetRGBPaletteProc;
GetRGBPalette := @ptc_GetRGBPaletteProc;
end;
addmode(graphmode);
(*
writeln('processing modes');
while ptcmode^.valid do
begin
for d:=low(depths) to high(depths) do
begin
InitMode(graphmode);
with graphmode do
begin
ModeNumber:=I;
DriverNumber:=ptcgraph.PTC;
{ MaxX is number of pixels in X direction - 1}
MaxX:=ptcmode^.width-1;
{ same for MaxY}
MaxY:=ptcmode^.height-1;
str(ptcmode^.width,ws);
str(ptcmode^.height,hs);
modename:='PTC_'+ws+'x'+hs+'x'+depth_names[d];
MaxColor := 1 shl ptcmode^.format.r * 1 shl ptcmode^.format.g *1 shl ptcmode^.format.b;
writeln('mode ',modename,' ',maxcolor,'kleuren');
PaletteSize := MaxColor;
HardwarePages := 0;
*)
{ necessary hooks ...}
(*
if (MaxColor = 16) and
(LongInt(ModeInfo.Width) * LongInt(ModeInfo.Height) < 65536*4*2) then
begin
{Use optimized graphics routines for 4 bit EGA/VGA modes.}
ScrWidth := ModeInfo.Width div 8;
DirectPutPixel := @DirectPutPixel16;
PutPixel := @PutPixel16;
GetPixel := @GetPixel16;
HLine := @HLine16;
VLine := @VLine16;
GetScanLine := @GetScanLine16;
end
else
*)
(*
begin
DirectPutPixel := @ptc_DirectPixelProc;
GetPixel := @ptc_GetPixelProc;
PutPixel := @ptc_PutPixelProc;
{ May be implemented later:
HLine := @libvga_HLineProc;
VLine := @libvga_VLineProc;
GetScanLine := @libvga_GetScanLineProc;}
ClearViewPort := @ptc_ClrViewProc;
end;
SetRGBPalette := @ptc_SetRGBPaletteProc;
GetRGBPalette := @ptc_GetRGBPaletteProc;
{ These are not really implemented yet:
PutImage := @libvga_PutImageProc;
GetImage := @libvga_GetImageProc;}
{ If you use the default getimage/putimage, you also need the default
imagesize! (JM)
ImageSize := @libvga_ImageSizeProc; }
{ Add later maybe ?
SetVisualPage := SetVisualPageProc;
SetActivePage := SetActivePageProc;
Line := @libvga_LineProc;
InternalEllipse:= @libvga_EllipseProc;
PatternLine := @libvga_PatternLineProc;
}
InitMode := @ptc_InitModeProc;
end;
AddMode(graphmode);
inc(i);
end;
end;
*)
end;
initialization
ptcconsole:=TPTCconsole.create;
InitializeGraph;
finalization
ptcconsole.destroy;
end.