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

* updated ptcgraph and added ptccrt

Browse Source 
git-svn-id: trunk@16019 -
This commit is contained in:
nickysn 2010-09-19 22:44:57 +00:00
parent b1ffb01b42
commit 7bbb0817d3
4 changed files with 3051 additions and 538 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2623,7 +2623,8 @@ packages/graph/src/inc/makefile.inc svneol=native#text/plain
packages/graph/src/inc/modes.inc svneol=native#text/plain
packages/graph/src/inc/palette.inc svneol=native#text/plain
packages/graph/src/macosx/graph.pp svneol=native#text/plain
packages/graph/src/ptcgraph.pp svneol=native#text/x-pascal
packages/graph/src/ptcgraph/ptccrt.pp svneol=native#text/plain
packages/graph/src/ptcgraph/ptcgraph.pp svneol=native#text/x-pascal
packages/graph/src/sdlgraph/sdlgraph.pp svneol=native#text/plain
packages/graph/src/unix/ggigraph.pp svneol=native#text/plain
packages/graph/src/unix/graph.pp svneol=native#text/plain

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

@ -1,537 +0,0 @@
{
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.

266
packages/graph/src/ptcgraph/ptccrt.pp Normal file
View File

@ -0,0 +1,266 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2010 by Nikolay Nikolov (nickysn@users.sourceforge.net)
This file implements keyboard input support for ptcgraph
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 ptccrt;
{$MODE objfpc}
{$DEFINE HasCRT}
{$IFDEF WinCE}
{$UNDEF HasCRT}
{$ENDIF WinCE}
interface
{$IFDEF HasCRT}
uses
crt;
{$ENDIF HasCRT}
type
{$IFDEF HasCRT}
tcrtcoord = crt.tcrtcoord;
{$ELSE HasCRT}
tcrtcoord = 1..255;
{$ENDIF HasCRT}
var
DirectVideo: Boolean {$IFDEF HasCRT}absolute crt.DirectVideo{$ENDIF HasCRT};
TextAttr: Byte {$IFDEF HasCRT}absolute crt.TextAttr{$ENDIF HasCRT};
function KeyPressed: Boolean;
function ReadKey: Char;
procedure ClrScr;
procedure ClrEol;
procedure GotoXY(X, Y: tcrtcoord);
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure Delay(MS: Word);
procedure Sound(HZ: Word);
procedure NoSound;
implementation
uses
ptcgraph, ptc, ptcwrapper
{$IFDEF UNIX}
, baseunix
{$ENDIF UNIX}
{$IF defined(Win32) or defined(Win64) or defined(WinCE)}
, windows
{$ENDIF defined(Win32) or defined(Win64) or defined(WinCE)}
;
function InGraphMode: Boolean;
begin
Result := (PTCWrapperObject <> nil) and (PTCWrapperObject.IsOpen);
end;
var
KeyBuffer: array[0..64] of Char;
KeyBufHead, KeyBufTail: Integer;
function KeyBufEmpty: Boolean;
begin
Result := KeyBufHead = KeyBufTail;
end;
procedure KeyBufAdd(Ch: Char);
begin
{todo: overflow checking}
KeyBuffer[KeyBufTail] := Ch;
Inc(KeyBufTail);
if KeyBufTail > High(KeyBuffer) then
KeyBufTail := Low(KeyBuffer);
end;
procedure KeyBufAdd(S: String);
var
I: Integer;
begin
for I := 1 to Length(S) do
KeyBufAdd(S[I]);
end;
function KeyBufGet: Char;
begin
if KeyBufHead <> KeyBufTail then
begin
Result := KeyBuffer[KeyBufHead];
Inc(KeyBufHead);
if KeyBufHead > High(KeyBuffer) then
KeyBufHead := Low(KeyBuffer);
end;
end;
procedure GetKeyEvents;
var
ev: TPTCEvent;
KeyEv: TPTCKeyEvent;
begin
ev := nil;
try
repeat
PTCWrapperObject.NextEvent(ev, False, [PTCKeyEvent]);
if ev <> nil then
begin
KeyEv := TPTCKeyEvent(ev);
if KeyEv.Press then
begin
case KeyEv.Code of
PTCKEY_BACKSPACE:
if KeyEv.Control then
KeyBufAdd(#127)
else
KeyBufAdd(#8);
PTCKEY_ENTER: KeyBufAdd(#13);
PTCKEY_ESCAPE: KeyBufAdd(#27);
PTCKEY_INSERT: KeyBufAdd(#0#82);
PTCKEY_DELETE: KeyBufAdd(#0#83);
PTCKEY_LEFT: KeyBufAdd(#0#75);
PTCKEY_UP: KeyBufAdd(#0#72);
PTCKEY_RIGHT: KeyBufAdd(#0#77);
PTCKEY_DOWN: KeyBufAdd(#0#80);
PTCKEY_HOME: KeyBufAdd(#0#71);
PTCKEY_END: KeyBufAdd(#0#79);
PTCKEY_PAGEUP: KeyBufAdd(#0#73);
PTCKEY_PAGEDOWN: KeyBufAdd(#0#81);
PTCKEY_F1: KeyBufAdd(#0#59);
PTCKEY_F2: KeyBufAdd(#0#60);
PTCKEY_F3: KeyBufAdd(#0#61);
PTCKEY_F4: KeyBufAdd(#0#62);
PTCKEY_F5: KeyBufAdd(#0#63);
PTCKEY_F6: KeyBufAdd(#0#64);
PTCKEY_F7: KeyBufAdd(#0#65);
PTCKEY_F8: KeyBufAdd(#0#66);
PTCKEY_F9: KeyBufAdd(#0#67);
PTCKEY_F10: KeyBufAdd(#0#68);
else
if (KeyEv.Unicode >= 32) and (KeyEv.Unicode <= 127) then
KeyBufAdd(Chr(KeyEv.Unicode));
end;
end;
end;
until ev = nil;
finally
ev.Free;
end;
end;
function KeyPressed: Boolean;
begin
if not InGraphMode then
begin
{$IFDEF HasCRT}
Result := crt.KeyPressed
{$ELSE HasCRT}
Result := False;
{$ENDIF HasCRT}
end
else
begin
GetKeyEvents;
Result := not KeyBufEmpty;
end;
end;
function ReadKey: Char;
{$IFDEF UNIX}
var
req, rem: TTimeSpec;
{$ENDIF UNIX}
begin
if not InGraphMode then
begin
{$IFDEF HasCRT}
Result := crt.ReadKey;
{$ELSE HasCRT}
Result := #0;
{$ENDIF HasCRT}
end
else
begin
while not KeyPressed do
begin
{$IFDEF UNIX}
req.tv_sec := 0;
req.tv_nsec := 1000000;
fpnanosleep(@req, @rem);
{$ENDIF UNIX}
{$IF defined(Win32) or defined(Win64) or defined(WinCE)}
Sleep(1);
{$ENDIF defined(Win32) or defined(Win64) or defined(WinCE)}
end;
Result := KeyBufGet;
end;
end;
procedure ClrScr;
begin
{$IFDEF HasCRT}
crt.ClrScr;
{$ENDIF HasCRT}
end;
procedure ClrEol;
begin
{$IFDEF HasCRT}
crt.ClrEol;
{$ENDIF HasCRT}
end;
procedure GotoXY(X, Y: tcrtcoord);
begin
{$IFDEF HasCRT}
crt.GotoXY(X, Y);
{$ENDIF HasCRT}
end;
procedure TextColor(Color: Byte);
begin
{$IFDEF HasCRT}
crt.TextColor(Color);
{$ENDIF HasCRT}
end;
procedure TextBackground(Color: Byte);
begin
{$IFDEF HasCRT}
crt.TextBackground(Color);
{$ENDIF HasCRT}
end;
procedure Delay(MS: Word);
begin
{$IFDEF HasCRT}
crt.Delay(MS);
{$ENDIF HasCRT}
end;
procedure Sound(HZ: Word);
begin
{$IFDEF HasCRT}
crt.Sound(HZ);
{$ENDIF HasCRT}
end;
procedure NoSound;
begin
{$IFDEF HasCRT}
crt.NoSound;
{$ENDIF HasCRT}
end;
end.

2783
packages/graph/src/ptcgraph/ptcgraph.pp Normal file
View File

File diff suppressed because it is too large Load Diff