paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-03 06:50:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

* updated PTCPas to version 0.99.14

Browse Source 
git-svn-id: trunk@25771 -
This commit is contained in:
nickysn 2013-10-13 22:34:01 +00:00
parent 74af6d0dab
commit 014a4e4653
44 changed files with 970 additions and 440 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -6199,6 +6199,8 @@ packages/ptc/src/core/cleard.inc svneol=native#text/plain
packages/ptc/src/core/cleari.inc svneol=native#text/plain
packages/ptc/src/core/clipperd.inc svneol=native#text/plain
packages/ptc/src/core/clipperi.inc svneol=native#text/plain
packages/ptc/src/core/closeeventd.inc svneol=native#text/plain
packages/ptc/src/core/closeeventi.inc svneol=native#text/plain
packages/ptc/src/core/colord.inc svneol=native#text/plain
packages/ptc/src/core/colori.inc svneol=native#text/plain
packages/ptc/src/core/consoled.inc svneol=native#text/plain
@ -6224,6 +6226,8 @@ packages/ptc/src/core/openglattributesd.inc svneol=native#text/plain
packages/ptc/src/core/openglattributesi.inc svneol=native#text/plain
packages/ptc/src/core/paletted.inc svneol=native#text/plain
packages/ptc/src/core/palettei.inc svneol=native#text/plain
packages/ptc/src/core/resizeeventd.inc svneol=native#text/plain
packages/ptc/src/core/resizeeventi.inc svneol=native#text/plain
packages/ptc/src/core/surfaced.inc svneol=native#text/plain
packages/ptc/src/core/surfacei.inc svneol=native#text/plain
packages/ptc/src/core/timerd.inc svneol=native#text/plain
@ -6268,6 +6272,8 @@ packages/ptc/src/win32/base/win32monitor.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32monitord.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32moused.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32mousei.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32resized.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32resizei.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32window.inc svneol=native#text/plain
packages/ptc/src/win32/base/win32windowd.inc svneol=native#text/plain
packages/ptc/src/win32/base/windows.ico -text

228
packages/graph/src/ptcgraph/ptccrt.pp
View File

@ -1,6 +1,6 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2010, 2011 by Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (c) 2010, 2011, 2013 by Nikolay Nikolov (nickysn@users.sourceforge.net)
This file implements keyboard input support for ptcgraph
@ -114,44 +114,198 @@ var
KeyEv: IPTCKeyEvent;
begin
repeat
PTCWrapperObject.NextEvent(ev, False, [PTCKeyEvent]);
PTCWrapperObject.NextEvent(ev, False, [PTCKeyEvent, PTCCloseEvent]);
if ev <> nil then
begin
KeyEv := ev as IPTCKeyEvent;
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;
case ev.EventType of
PTCCloseEvent:
begin
{ emulate Ctrl-C/Ctrl-Break, when the user
presses the [X] button to close the window }
KeyBufAdd(#3);
end;
PTCKeyEvent:
begin
KeyEv := ev as IPTCKeyEvent;
if KeyEv.Press then
begin
if KeyEv.Alt then
begin
case KeyEv.Code of
PTCKEY_F1: KeyBufAdd(#0#104);
PTCKEY_F2: KeyBufAdd(#0#105);
PTCKEY_F3: KeyBufAdd(#0#106);
PTCKEY_F4: KeyBufAdd(#0#107);
PTCKEY_F5: KeyBufAdd(#0#108);
PTCKEY_F6: KeyBufAdd(#0#109);
PTCKEY_F7: KeyBufAdd(#0#110);
PTCKEY_F8: KeyBufAdd(#0#111);
PTCKEY_F9: KeyBufAdd(#0#112);
PTCKEY_F10: KeyBufAdd(#0#113);
PTCKEY_ONE: KeyBufAdd(#0#120);
PTCKEY_TWO: KeyBufAdd(#0#121);
PTCKEY_THREE: KeyBufAdd(#0#122);
PTCKEY_FOUR: KeyBufAdd(#0#123);
PTCKEY_FIVE: KeyBufAdd(#0#124);
PTCKEY_SIX: KeyBufAdd(#0#125);
PTCKEY_SEVEN: KeyBufAdd(#0#126);
PTCKEY_EIGHT: KeyBufAdd(#0#127);
PTCKEY_NINE: KeyBufAdd(#0#128);
PTCKEY_ZERO: KeyBufAdd(#0#129);
PTCKEY_MINUS: KeyBufAdd(#0#130);
PTCKEY_EQUALS: KeyBufAdd(#0#131);
PTCKEY_Q: KeyBufAdd(#0#16);
PTCKEY_W: KeyBufAdd(#0#17);
PTCKEY_E: KeyBufAdd(#0#18);
PTCKEY_R: KeyBufAdd(#0#19);
PTCKEY_T: KeyBufAdd(#0#20);
PTCKEY_Y: KeyBufAdd(#0#21);
PTCKEY_U: KeyBufAdd(#0#22);
PTCKEY_I: KeyBufAdd(#0#23);
PTCKEY_O: KeyBufAdd(#0#24);
PTCKEY_P: KeyBufAdd(#0#25);
PTCKEY_A: KeyBufAdd(#0#30);
PTCKEY_S: KeyBufAdd(#0#31);
PTCKEY_D: KeyBufAdd(#0#32);
PTCKEY_F: KeyBufAdd(#0#33);
PTCKEY_G: KeyBufAdd(#0#34);
PTCKEY_H: KeyBufAdd(#0#35);
PTCKEY_J: KeyBufAdd(#0#36);
PTCKEY_K: KeyBufAdd(#0#37);
PTCKEY_L: KeyBufAdd(#0#38);
PTCKEY_Z: KeyBufAdd(#0#44);
PTCKEY_X: KeyBufAdd(#0#45);
PTCKEY_C: KeyBufAdd(#0#46);
PTCKEY_V: KeyBufAdd(#0#47);
PTCKEY_B: KeyBufAdd(#0#48);
PTCKEY_N: KeyBufAdd(#0#49);
PTCKEY_M: KeyBufAdd(#0#50);
end;
end
else
if KeyEv.Control then
begin
case KeyEv.Code of
PTCKEY_ESCAPE: KeyBufAdd(#27);
PTCKEY_F1: KeyBufAdd(#0#94);
PTCKEY_F2: KeyBufAdd(#0#95);
PTCKEY_F3: KeyBufAdd(#0#96);
PTCKEY_F4: KeyBufAdd(#0#97);
PTCKEY_F5: KeyBufAdd(#0#98);
PTCKEY_F6: KeyBufAdd(#0#99);
PTCKEY_F7: KeyBufAdd(#0#100);
PTCKEY_F8: KeyBufAdd(#0#101);
PTCKEY_F9: KeyBufAdd(#0#102);
PTCKEY_F10: KeyBufAdd(#0#103);
PTCKEY_TWO: KeyBufAdd(#0#3);
PTCKEY_BACKSPACE: KeyBufAdd(#127);
PTCKEY_A: KeyBufAdd(#1);
PTCKEY_B: KeyBufAdd(#2);
PTCKEY_C: KeyBufAdd(#3);
PTCKEY_D: KeyBufAdd(#4);
PTCKEY_E: KeyBufAdd(#5);
PTCKEY_F: KeyBufAdd(#6);
PTCKEY_G: KeyBufAdd(#7);
PTCKEY_H: KeyBufAdd(#8);
PTCKEY_I: KeyBufAdd(#9);
PTCKEY_J: KeyBufAdd(#10);
PTCKEY_K: KeyBufAdd(#11);
PTCKEY_L: KeyBufAdd(#12);
PTCKEY_M: KeyBufAdd(#13);
PTCKEY_N: KeyBufAdd(#14);
PTCKEY_O: KeyBufAdd(#15);
PTCKEY_P: KeyBufAdd(#16);
PTCKEY_Q: KeyBufAdd(#17);
PTCKEY_R: KeyBufAdd(#18);
PTCKEY_S: KeyBufAdd(#19);
PTCKEY_T: KeyBufAdd(#20);
PTCKEY_U: KeyBufAdd(#21);
PTCKEY_V: KeyBufAdd(#22);
PTCKEY_W: KeyBufAdd(#23);
PTCKEY_X: KeyBufAdd(#24);
PTCKEY_Y: KeyBufAdd(#25);
PTCKEY_Z: KeyBufAdd(#26);
PTCKEY_OPENBRACKET: KeyBufAdd(#27);
PTCKEY_BACKSLASH: KeyBufAdd(#28);
PTCKEY_CLOSEBRACKET: KeyBufAdd(#29);
PTCKEY_SIX: KeyBufAdd(#30);
PTCKEY_MINUS: KeyBufAdd(#31);
PTCKEY_ENTER: KeyBufAdd(#10);
PTCKEY_LEFT: KeyBufAdd(#0#115);
PTCKEY_RIGHT: KeyBufAdd(#0#116);
PTCKEY_HOME: KeyBufAdd(#0#119);
PTCKEY_END: KeyBufAdd(#0#117);
PTCKEY_PAGEUP: KeyBufAdd(#0#132);
PTCKEY_PAGEDOWN: KeyBufAdd(#0#118);
end;
end
else
if KeyEv.Shift then
begin
case KeyEv.Code of
PTCKEY_ESCAPE: KeyBufAdd(#27);
PTCKEY_F1: KeyBufAdd(#0#84);
PTCKEY_F2: KeyBufAdd(#0#85);
PTCKEY_F3: KeyBufAdd(#0#86);
PTCKEY_F4: KeyBufAdd(#0#87);
PTCKEY_F5: KeyBufAdd(#0#88);
PTCKEY_F6: KeyBufAdd(#0#89);
PTCKEY_F7: KeyBufAdd(#0#90);
PTCKEY_F8: KeyBufAdd(#0#91);
PTCKEY_F9: KeyBufAdd(#0#92);
PTCKEY_F10: KeyBufAdd(#0#93);
PTCKEY_BACKSPACE: KeyBufAdd(#8);
PTCKEY_TAB: KeyBufAdd(#0#15);
PTCKEY_ENTER: KeyBufAdd(#13);
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);
else
if (KeyEv.Unicode >= 32) and (KeyEv.Unicode <= 127) then
KeyBufAdd(Chr(KeyEv.Unicode));
end;
end
else
begin
case KeyEv.Code of
PTCKEY_ESCAPE: KeyBufAdd(#27);
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);
PTCKEY_BACKSPACE: KeyBufAdd(#8);
PTCKEY_TAB: KeyBufAdd(#9);
PTCKEY_ENTER: KeyBufAdd(#13);
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);
else
if (KeyEv.Unicode >= 32) and (KeyEv.Unicode <= 127) then
KeyBufAdd(Chr(KeyEv.Unicode));
end;
end;
end;
end;
end;
end;
until ev = nil;

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

@ -16,7 +16,7 @@
**********************************************************************}
unit ptcgraph;
{$define logging}
{//$define logging}
{******************************************************************************}
interface
@ -25,6 +25,11 @@ unit ptcgraph;
uses
ptc, ptcwrapper;
{$ifdef VER2_6}
type
CodePointer = Pointer;
{$endif}
{$i graphh.inc}
{Driver number for PTC.}
@ -121,9 +126,6 @@ var
implementation
{******************************************************************************}
//uses
// termio{,x86};
const
InternalDriverName = 'PTCPas';
@ -285,12 +287,6 @@ const
end;
var
// OldIO: TermIos;
{ ptcconsole: TPTCConsole = nil;
ptcsurface: TPTCSurface = nil;
ptcpalette: TPTCPalette = nil;
ptcformat: TPTCFormat = nil;}
PTCWidth: Integer;
PTCHeight: Integer;
PTCFormat8: IPTCFormat;
@ -351,36 +347,12 @@ end;
procedure ptc_update;
begin
{ copy to console }
// ptcsurface.copy(ptcconsole);
{ update console }
// ptcconsole.update;
end;
{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;
@ -391,39 +363,6 @@ begin
PTCWrapperObject.Close;
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 }
{ FreeAndNil(PTCFormat);
PTCFormat:=TPTCFormatFactory.CreateNew(16,$f800,$07e0,$001f);}
{ open the console }
{ ptcconsole.open(paramstr(0),ptcformat);}
{ create surface matching console dimensions }
{ FreeAndNil(PTCSurface);
PTCSurface:=TPTCSurface.Create(ptcconsole.width,ptcconsole.height,ptcformat);}
end;
function VGA6to8(dac6: Uint32): Uint32;
begin
VGA6to8 := dac6 shl 2;
@ -509,7 +448,6 @@ end;
procedure ptc_SetVGAPalette(ColorNum, ARed, AGreen, ABlue: Integer);
var
PaletteData: PUint32;
r, g, b: Uint32;
I: Integer;
begin
if (VGAPalette[ColorNum, 0] <> ARed) or
@ -1025,10 +963,8 @@ begin
end;
procedure ptc_DirectPixelProc_16bpp(X,Y: smallint);
var color:word;
pixels:Pword;
var
pixels:Pword;
begin
// Writeln('ptc_DirectPixelProc_16bpp(', X, ', ', Y, ')');
pixels := ptc_surface_lock;
@ -1057,10 +993,8 @@ begin
end;
procedure ptc_DirectPixelProc_8bpp(X,Y: smallint);
var color:word;
pixels:PByte;
var
pixels:PByte;
begin
// Writeln('ptc_DirectPixelProc_8bpp(', X, ', ', Y, ')');
pixels := ptc_surface_lock;
@ -1149,28 +1083,6 @@ begin
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;
@ -1399,60 +1311,6 @@ begin
ptc_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_SetRGBAllPaletteProc(const Palette: PaletteType);
begin
{...}
@ -1492,7 +1350,6 @@ end;
_graphresult := grnoinitgraph;
exit
end;
// SetRawMode(False);
RestoreVideoState;
isgraphmode := false;
end;
@ -1554,13 +1411,6 @@ end;
var
graphmode:Tmodeinfo;
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... }
@ -1576,31 +1426,6 @@ end;
SaveVideoState:=@ptc_savevideostate;
RestoreVideoState:=@ptc_restorevideostate;
{ if PTCConsole = nil then
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;
HLine := @ptc_HLineProc_16bpp;
end;
addmode(graphmode);}
InitMode(graphmode);
with graphmode do
@ -2742,81 +2567,6 @@ end;
end;
AddMode(graphmode);
end;
(*
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

19
packages/hermes/src/x86_64/x86_64_i8.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal version of the Hermes pixel conversion library.
Copyright (C) 2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2012, 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -39,7 +39,7 @@
procedure ConvertX86_64_index8_32(iface: PHermesConverterInterface); cdecl;
label
loop_start, loop_pre_remainder, loop_remainder, done;
preloop_start, preloop_skip, loop_start, loop_pre_remainder, loop_remainder, done;
var
i: Integer;
s_pixel: Uint8;
@ -67,6 +67,21 @@ begin
mov rdi, [dest]
mov rbx, [lookup]
mov rcx, [s_width]
preloop_start:
test rdi, 15
jz preloop_skip
movzx rax, byte [rsi]
mov edx, dword [rbx + rax * 4]
movnti [rdi], edx
inc rsi
add rdi, 4
sub rcx, 1
jz done
jmp preloop_start
preloop_skip:
mov r8, rcx
and r8, 3
shr rcx, 2

31
packages/ptc/docs/CHANGES.txt
View File

@ -1,12 +1,31 @@
0.99.14
- support for resizable windows extended. Your application now receives
a new event IPTCResizeEvent and is allowed to call a new method called
InternalResize, which adjusts the console's width and height according to
the new window size. The previous behaviour where your application's image
is scaled, without it realizing that the resolution is changed still works
if you don't call InternalResize (or when you use ptcgraph for that matter)
- added support for intercepting the windows close events. When using unit ptc
directly, this is enabled by sending the option 'intercept window close' to
the console and then handling the newly introduced IPTCCloseEvent event.
When using ptcgraph and ptccrt, closing the window emulates pressing Ctrl-C,
in other words, your application will receive the #3 key code via ReadKey.
- fixed crash in hermes (the pixel conversion library, used internally by
PTCPas), encountered when converting from indexed 8bpp to 32bpp on amd64,
when the surface width is not multiple of 8
- even more X11 keyboard fixes
- removed the debug log (grlog.txt) written by programs that use ptcgraph
0.99.13
- added support for OpenGL under X11 and Windows. You can now use PTCPas to initialize
OpenGL and handle events for you in a multiplatform way (similar to GLUT or SDL). See
ptcgl.pp and ptcgl2.pp in the example directory.
- added support for OpenGL under X11 and Windows. You can now use PTCPas to
initialize OpenGL and handle events for you in a multiplatform way (similar
to GLUT or SDL). See ptcgl.pp and ptcgl2.pp in the example directory.
- X11 keyboard handling improvements:
- added support for the numpad keys
- typematic repeat (i.e. when you press a key and hold it down) now sends only
repeating key press events, instead of repeating pairs of key release + key press.
This makes it possible to detect auto-repeat and is also the way that Windows behaves.
- typematic repeat (i.e. when you press a key and hold it down) now sends
only repeating key press events, instead of repeating pairs of key
release + key press. This makes it possible to detect auto-repeat and is
also the way that Windows behaves.
0.99.12
- pressing Alt or F10 under Windows no longer pauses the application.

6
packages/ptc/docs/INSTALL.txt
View File

@ -1,13 +1,13 @@
The supported platforms are Linux, FreeBSD, Windows, Windows Mobile and DOS.
Generally you need the latest stable version of the Free Pascal Compiler, which
currently means version 2.4.2. Generally FPC 2.2.4 should also work fine.
currently means version 2.6.2.
- Compiling the library:
Before starting make sure the FPCDIR environment variable is set correctly.
For example: (windows, fpc version 2.4.2, default install dir)
For example: (windows, fpc version 2.6.2, default install dir)
set FPCDIR=c:\fpc\2.4.2
set FPCDIR=c:\fpc\2.6.2
To compile the library type:

3
packages/ptc/docs/README.txt
View File

@ -30,8 +30,7 @@ Supported consoles:
compatible.)
X11 (on linux and other unix-like OSes, supports XRandR, XF86VidMode, XShm
and xf86dga extensions)
Vesa 1.0+ (DOS. Supports LFB and banked video memory access. Video pages not
yet supported)
Vesa 1.0+ (DOS. Supports LFB and banked video memory access)
VGA (DOS, fakemodes, mode13h, etc...)
CGA (DOS, added by me just for fun ... and maybe some day I'll even add
EGA :-) )

1
packages/ptc/docs/TODO.txt
View File

@ -1,3 +1,4 @@
- Mac OS X support
- mouse grab support
- add more event types (expose, focus in, focus out, etc.)
- mouse support for the x11 dga console

6
packages/ptc/fpmake.pp
View File

@ -77,6 +77,8 @@ begin
AddInclude('cleari.inc');
AddInclude('clipperd.inc');
AddInclude('clipperi.inc');
AddInclude('closeeventd.inc');
AddInclude('closeeventi.inc');
AddInclude('colord.inc');
AddInclude('colori.inc');
AddInclude('consoled.inc');
@ -102,6 +104,8 @@ begin
AddInclude('openglattributesi.inc');
AddInclude('paletted.inc');
AddInclude('palettei.inc');
AddInclude('resizeeventd.inc');
AddInclude('resizeeventi.inc');
AddInclude('surfaced.inc');
AddInclude('surfacei.inc');
AddInclude('timerd.inc');
@ -140,6 +144,8 @@ begin
AddInclude('win32monitord.inc', [win32, win64]);
AddInclude('win32moused.inc', [win32, win64]);
AddInclude('win32mousei.inc', [win32, win64]);
AddInclude('win32resized.inc', [win32, win64]);
AddInclude('win32resizei.inc', [win32, win64]);
AddInclude('win32window.inc', [win32, win64]);
AddInclude('win32windowd.inc', [win32, win64]);
AddInclude('win32directxcheck.inc', [win32, win64]);

3
packages/ptc/src/core/baseconsoled.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -51,6 +51,7 @@ type
procedure Open(const ATitle: string; AMode: IPTCMode;
APages: Integer = 0); overload;
procedure Close;
procedure InternalResize(AWidth, AHeight: Integer);
procedure Flush;
procedure Finish;
procedure Update;

8
packages/ptc/src/core/baseconsolei.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -100,6 +100,7 @@ type
procedure Open(const ATitle: string; AMode: IPTCMode;
APages: Integer = 0); overload; virtual; abstract;
procedure Close; virtual; abstract;
procedure InternalResize(AWidth, AHeight: Integer); virtual;
procedure Flush; virtual; abstract;
procedure Finish; virtual; abstract;
procedure Update; virtual; abstract;
@ -149,6 +150,11 @@ begin
FOpenGLAttributes := TPTCOpenGLAttributes.Create;
end;
procedure TPTCBaseConsole.InternalResize(AWidth, AHeight: Integer);
begin
raise TPTCError.Create('Console does not support internal resize');
end;
function TPTCBaseConsole.GetOpenGL_Attributes: IPTCOpenGLAttributes;
begin
Result := FOpenGLAttributes;

40
packages/ptc/src/core/closeeventd.inc Normal file
View File

@ -0,0 +1,40 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
type
IPTCCloseEvent = interface(IPTCEvent)
['{C1FC36CA-F3D3-498A-98DC-D56E72158F45}']
end;
TPTCCloseEventFactory = class
public
class function CreateNew: IPTCCloseEvent;
end;

46
packages/ptc/src/core/closeeventi.inc Normal file
View File

@ -0,0 +1,46 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
type
TPTCCloseEvent = class(TPTCEvent, IPTCCloseEvent)
protected
function GetEventType: TPTCEventType; override;
end;
class function TPTCCloseEventFactory.CreateNew: IPTCCloseEvent;
begin
Result := TPTCCloseEvent.Create;
end;
function TPTCCloseEvent.GetEventType: TPTCEventType;
begin
Result := PTCCloseEvent;
end;

9
packages/ptc/src/core/consolei.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -66,6 +66,7 @@ type
APages: Integer = 0); overload; override;
procedure Close; override;
procedure InternalResize(AWidth, AHeight: Integer); override;
procedure Flush; override;
procedure Finish; override;
procedure Update; override;
@ -868,3 +869,9 @@ begin
Check;
Result := FConsole.OpenGL_GetSwapInterval;
end;
procedure TPTCConsole.InternalResize(AWidth, AHeight: Integer);
begin
Check;
FConsole.InternalResize(AWidth, AHeight);
end;

2
packages/ptc/src/core/coreimplementation.inc
View File

@ -5,6 +5,8 @@
{$INCLUDE eventi.inc}
{$INCLUDE keyeventi.inc}
{$INCLUDE mouseeventi.inc}
{$INCLUDE closeeventi.inc}
{$INCLUDE resizeeventi.inc}
{$INCLUDE modei.inc}
{$INCLUDE palettei.inc}
{$INCLUDE cleari.inc}

2
packages/ptc/src/core/coreinterface.inc
View File

@ -4,6 +4,8 @@
{$INCLUDE eventd.inc}
{$INCLUDE keyeventd.inc}
{$INCLUDE mouseeventd.inc}
{$INCLUDE closeeventd.inc}
{$INCLUDE resizeeventd.inc}
{$INCLUDE moded.inc}
{$INCLUDE paletted.inc}
{$INCLUDE cleard.inc}

8
packages/ptc/src/core/eventd.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2011 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -31,7 +31,8 @@
}
type
TPTCEventType = (PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent});
TPTCEventType =
(PTCKeyEvent, PTCMouseEvent, PTCCloseEvent, PTCResizeEvent);
TPTCEventMask = set of TPTCEventType;
IPTCEvent = interface
['{1D5A6831-6648-47B6-83D5-10E65FDB72AD}']
@ -40,4 +41,5 @@ type
end;
const
PTCAnyEvent: TPTCEventMask = [PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent}];
PTCAnyEvent: TPTCEventMask =
[PTCKeyEvent, PTCMouseEvent, PTCCloseEvent, PTCResizeEvent];

45
packages/ptc/src/core/resizeeventd.inc Normal file
View File

@ -0,0 +1,45 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
type
IPTCResizeEvent = interface(IPTCEvent)
['{91AB0B40-7565-444B-935A-4B333F92AE31}']
function GetWidth: Integer;
function GetHeight: Integer;
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
end;
TPTCResizeEventFactory = class
public
class function CreateNew(AWidth, AHeight: Integer): IPTCResizeEvent;
end;

70
packages/ptc/src/core/resizeeventi.inc Normal file
View File

@ -0,0 +1,70 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
type
TPTCResizeEvent = class(TPTCEvent, IPTCResizeEvent)
private
FWidth: Integer;
FHeight: Integer;
function GetWidth: Integer;
function GetHeight: Integer;
protected
function GetEventType: TPTCEventType; override;
public
constructor Create(AWidth, AHeight: Integer);
end;
class function TPTCResizeEventFactory.CreateNew(AWidth, AHeight: Integer): IPTCResizeEvent;
begin
Result := TPTCResizeEvent.Create(AWidth, AHeight);
end;
constructor TPTCResizeEvent.Create(AWidth, AHeight: Integer);
begin
FWidth := AWidth;
FHeight := AHeight;
end;
function TPTCResizeEvent.GetEventType: TPTCEventType;
begin
Result := PTCResizeEvent;
end;
function TPTCResizeEvent.GetWidth: Integer;
begin
Result := FWidth;
end;
function TPTCResizeEvent.GetHeight: Integer;
begin
Result := FHeight;
end;

4
packages/ptc/src/ptc.pp
View File

@ -60,7 +60,7 @@ uses
{$ENDIF FPDOC}
const
PTCPAS_VERSION = 'PTCPas 0.99.13';
PTCPAS_VERSION = 'PTCPas 0.99.14';
type
PUint8 = ^Uint8;
@ -195,6 +195,7 @@ end;
{$INCLUDE win32/base/win32hookd.inc}
{$INCLUDE win32/base/win32kbdd.inc}
{$INCLUDE win32/base/win32moused.inc}
{$INCLUDE win32/base/win32resized.inc}
{$INCLUDE win32/directx/win32directxhookd.inc}
{$INCLUDE win32/directx/win32directxlibraryd.inc}
{$INCLUDE win32/directx/win32directxdisplayd.inc}
@ -213,6 +214,7 @@ end;
{$INCLUDE win32/base/win32hook.inc}
{$INCLUDE win32/base/win32kbd.inc}
{$INCLUDE win32/base/win32mousei.inc}
{$INCLUDE win32/base/win32resizei.inc}
{$INCLUDE win32/directx/win32directxcheck.inc}
{$INCLUDE win32/directx/win32directxtranslate.inc}
{$INCLUDE win32/directx/win32directxhook.inc}

3
packages/ptc/src/ptcwrapper/ptcwrapper.pp
View File

@ -1,6 +1,6 @@
{
Free Pascal PTCPas framebuffer library threaded wrapper
Copyright (C) 2010, 2011, 2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2010, 2011, 2012, 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -262,6 +262,7 @@ procedure TPTCWrapperThread.Execute;
begin
try
FConsole := TPTCConsoleFactory.CreateNew;
FConsole.Option('intercept window close');
FEventQueue := TEventQueue.Create;
FPalette := TPTCPaletteFactory.CreateNew;

3
packages/ptc/src/win32/base/win32moused.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2007, 2009, 2010 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2007, 2009, 2010, 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -61,6 +61,7 @@ type
AFullScreen: Boolean; AConsoleWidth, AConsoleHeight: Integer);
procedure SetWindowArea(AWindowX1, AWindowY1, AWindowX2, AWindowY2: Integer);
procedure SetConsoleSize(AConsoleWidth, AConsoleHeight: Integer);
{ control }
procedure Enable;

8
packages/ptc/src/win32/base/win32mousei.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2007, 2009, 2010 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2007, 2009, 2010, 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -55,6 +55,12 @@ begin
FWindowY2 := AWindowY2;
end;
procedure TWin32Mouse.SetConsoleSize(AConsoleWidth, AConsoleHeight: Integer);
begin
FConsoleWidth := AConsoleWidth;
FConsoleHeight := AConsoleHeight;
end;
procedure TWin32Mouse.Enable;
begin
{ enable buffering }

40
packages/ptc/src/win32/base/win32resized.inc Normal file
View File

@ -0,0 +1,40 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
type
TWin32Resize = class(TWin32Hook)
private
FEventQueue: TEventQueue;
function WndProc(hWnd: HWND; message: DWord; wParam: WPARAM; lParam: LPARAM): LRESULT; override;
public
constructor Create(AWindow: HWND; AThread: DWord; AEventQueue: TEventQueue);
end;

54
packages/ptc/src/win32/base/win32resizei.inc Normal file
View File

@ -0,0 +1,54 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
constructor TWin32Resize.Create(AWindow: HWND; AThread: DWord; AEventQueue: TEventQueue);
begin
inherited Create(AWindow, AThread);
FEventQueue := AEventQueue;
end;
function TWin32Resize.WndProc(hWnd: HWND; message: DWord; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
Width, Height: Integer;
begin
Result := 0;
if message = WM_SIZE then
begin
Width := lParam and $FFFF;
Height := (lParam shr 16) and $FFFF;
//Writeln(wParam, ' ', Width, ' ', Height);
if wParam <> SIZE_MINIMIZED then
begin
FEventQueue.AddEvent(TPTCResizeEvent.Create(Width, Height));
end;
end;
end;

12
packages/ptc/src/win32/base/win32window.inc
View File

@ -48,7 +48,7 @@ function WndProcMultiThreaded(hWnd: HWND; message: UINT; wParam: WPARAM; lParam:
constructor TWin32Window.Create(const AWndClass, ATitle: string; AExtra, AStyle, AClassStyle: DWord;
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded,
ACursor: Boolean);
ACursor, AInterceptClose: Boolean);
var
program_instance{, library_instance}: DWord;
rectangle: RECT;
@ -59,6 +59,7 @@ begin
Defaults;
FMultithreaded := AMultithreaded;
try
FInterceptClose := AInterceptClose;
program_instance := GetModuleHandle(nil);
{ library_instance := program_instance;}
wc.cbSize := SizeOf(WNDCLASSEX);
@ -275,7 +276,11 @@ begin
end;
WM_CLOSE: begin
LOG('TWin32Window WM_CLOSE');
Halt(0);
WindowObject := TWin32Window(GetWindowLongPtr(hWnd, GWLP_USERDATA));
if WindowObject.InterceptClose then
Result := 0
else
Halt(0);
end;
else
Result := DefWindowProcA(hWnd, message, wParam, lParam);
@ -334,6 +339,7 @@ begin
FHeight := 0;
FManaged := True;
FMultithreaded := False;
FInterceptClose := False;
end;
procedure TWin32Window.Close;
@ -379,7 +385,7 @@ var
begin
with AOwner do
begin
FWindow := CreateWindowExA(FExtra, PChar(FName), PChar(FTitle), FStyle, FX, FY, FWidth, FHeight, 0, 0, 0, nil);
FWindow := CreateWindowEx(FExtra, PChar(FName), PChar(FTitle), FStyle, FX, FY, FWidth, FHeight, 0, 0, 0, nil);
if IsWindow(FWindow) then
begin
ShowWindow(FWindow, FShow);

4
packages/ptc/src/win32/base/win32windowd.inc
View File

@ -47,6 +47,7 @@ type
FManaged: Boolean;
FMultithreaded: Boolean;
FCursorConfineInEffect: Boolean;
FInterceptClose: Boolean;
{ class function WndProcSingleThreaded(hWnd: HWND; message: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
class function WndProcMultiThreaded(hWnd: HWND; message: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;}
@ -61,7 +62,7 @@ type
public
constructor Create(window: HWND);
constructor Create(const AWndClass, ATitle: string; AExtra, AStyle, AClassStyle: DWord;
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded, ACursor: Boolean);
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded, ACursor, AInterceptClose: Boolean);
destructor Destroy; override;
procedure Cursor(AFlag: Boolean);
procedure ConfineCursor(AFlag: Boolean);
@ -71,4 +72,5 @@ type
property Thread: DWord read GetThread;
property Managed: Boolean read FManaged;
property Multithreaded: Boolean read FMultithreaded;
property InterceptClose: Boolean read FInterceptClose write FInterceptClose;
end;

8
packages/ptc/src/win32/directx/win32directxconsoled.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -59,6 +59,7 @@ type
FNearestMode: (NEAREST_DEFAULT, NEAREST_CENTERING, NEAREST_STRETCHING); {Nearest}
FCursorMode: TWin32CursorMode; {Cursor}
FFullscreen: Boolean;
FInterceptClose: Boolean;
{ objects }
FCopy: TPTCCopy;
@ -68,6 +69,7 @@ type
FWindow: TWin32Window;
FKeyboard: TWin32Keyboard;
FMouse: TWin32Mouse;
FResize: TWin32Resize;
FWin32Cursor: TWin32Cursor;
{ DirectX objects }
@ -114,6 +116,9 @@ type
{ cursor state }
procedure UpdateCursor;
procedure SetInterceptClose(AInterceptClose: Boolean);
property InterceptClose: Boolean read FInterceptClose write SetInterceptClose;
public
constructor Create; override;
destructor Destroy; override;
@ -128,6 +133,7 @@ type
procedure Open(const ATitle: string; AMode: IPTCMode;
APages: Integer = 0); overload; override;
procedure Close; override;
procedure InternalResize(AWidth, AHeight: Integer); override;
procedure Flush; override;
procedure Finish; override;
procedure Update; override;

62
packages/ptc/src/win32/directx/win32directxconsolei.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -45,25 +45,6 @@
{$DEFINE CHECK_LOCK:=//}
{$ENDIF}
//const
{Output}
// DEFAULT = 0;
// WINDOWED = 1;
// FULLSCREEN = 2;
{Window}
// RESIZABLE = 0;
// FIXED = 1;
{Primary}
// DIRECT = 0;
// SECONDARY = 1;
{Nearest}
// NEAREST_DEFAULT = 0;
// NEAREST_CENTERING = 1;
// NEAREST_STRETCHING = 2;
function PChar2String(Q: PChar): string;
var
I: Integer;
@ -125,6 +106,7 @@ begin
Close;
FHook.Free;
FResize.Free;
FMouse.Free;
FKeyboard.Free;
FWindow.Free;
@ -361,6 +343,12 @@ begin
FPrimary.blocking(False);
exit;
end;
if AOption = 'intercept window close' then
begin
InterceptClose := True;
Result := True;
exit;
end;
if AOption = 'enable logging' then
begin
LOG_enabled := True;
@ -425,6 +413,22 @@ begin
FWin32Cursor.Show;
end;
procedure TDirectXConsole.InternalResize(AWidth, AHeight: Integer);
begin
CHECK_OPEN('TDirectXConsole.InternalResize');
CHECK_LOCK('TDirectXConsole.InternalResize');
if FFullscreen then
raise TPTCError.Create('TDirectXConsole.InternalResize only works in windowed mode');
if FWindowMode <> RESIZABLE then
raise TPTCError.Create('TDirectXConsole.InternalResize only works in resizable window mode');
FPrimary.InternalResize(AWidth, AHeight);
if FPrimaryModeWindowed = SECONDARY then
FPrimary.secondary(AWidth, AHeight);
FMouse.SetConsoleSize(AWidth, AHeight);
end;
procedure TDirectXConsole.Flush;
begin
CHECK_OPEN('TDirectXConsole.Flush');
@ -939,6 +943,7 @@ end;
procedure TDirectXConsole.internal_close;
begin
FOpen := False;
FreeAndNil(FResize);
FreeAndNil(FMouse);
FreeAndNil(FKeyboard);
FreeAndNil(FHook);
@ -978,6 +983,7 @@ end;
procedure TDirectXConsole.internal_open_finish;
begin
FreeAndNil(FResize);
FreeAndNil(FMouse);
FreeAndNil(FKeyboard);
FreeAndNil(FEventQueue);
@ -986,12 +992,15 @@ begin
FMouse := TWin32Mouse.Create(FWindow.handle, FWindow.thread, False, FEventQueue, FPrimary.Fullscreen, FPrimary.width, FPrimary.height);
if FPrimary.Fullscreen then
FMouse.SetWindowArea(0, 0, FDisplay.Mode.Width, FDisplay.Mode.Height);
if not FPrimary.Fullscreen then
FResize := TWin32Resize.Create(FWindow.handle, FWindow.thread, FEventQueue);
FWindow.update;
FOpen := True;
end;
procedure TDirectXConsole.internal_open_reset;
begin
FreeAndNil(FResize);
FreeAndNil(FMouse);
FreeAndNil(FKeyboard);
FreeAndNil(FHook);
@ -1029,7 +1038,7 @@ begin
0, 0,
GetSystemMetrics(SM_CXSCREEN),
GetSystemMetrics(SM_CYSCREEN),
False, False, FCursor)
False, False, FCursor, InterceptClose)
else
FWindow := TWin32Window.Create(window);
@ -1141,9 +1150,9 @@ begin
extended := WS_EX_TOPMOST;
case FWindowMode of
RESIZABLE: FWindow := TWin32Window.Create('PTC_DIRECTX_WINDOWED_RESIZABLE', FTitle,
extended, WS_OVERLAPPEDWINDOW or WS_VISIBLE, CS_VREDRAW or CS_HREDRAW, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, FCenterWindow, False, FCursor);
extended, WS_OVERLAPPEDWINDOW or WS_VISIBLE, CS_VREDRAW or CS_HREDRAW, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, FCenterWindow, False, FCursor, InterceptClose);
FIXED: FWindow := TWin32Window.Create('PTC_DIRECTX_WINDOWED_FIXED', FTitle,
extended, WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX, CS_VREDRAW or CS_HREDRAW, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, FCenterWindow, False, FCursor);
extended, WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX, CS_VREDRAW or CS_HREDRAW, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, FCenterWindow, False, FCursor, InterceptClose);
end;
end;
FDisplay.cooperative(FWindow.handle, False);
@ -1227,6 +1236,13 @@ begin
FWin32Cursor.Hide;
end;
procedure TDirectXConsole.SetInterceptClose(AInterceptClose: Boolean);
begin
FInterceptClose := AInterceptClose;
if Assigned(FWindow) then
FWindow.InterceptClose := AInterceptClose;
end;
{$IFDEF DEBUG}
procedure TDirectXConsole.CHECK_OPEN(AMsg: String);
begin

25
packages/ptc/src/win32/directx/win32directxhook.inc
View File

@ -160,18 +160,27 @@ begin
if FManaged then
begin
console := FConsole;
if FConsole.InterceptClose then
begin
FConsole.FEventQueue.AddEvent(TPTCCloseEvent.Create);
Result := 0;
exit;
end
else
begin
console := FConsole;
{ close console }
console.Close;
{ close console }
console.Close;
{ note: at this point the hook object has been destroyed by the console! }
{ note: at this point the hook object has been destroyed by the console! }
{ internal console shutdown }
console.internal_shutdown;
{ internal console shutdown }
console.internal_shutdown;
{ halt }
Halt(0);
{ halt }
Halt(0);
end;
end;
{ handled }

27
packages/ptc/src/win32/directx/win32directxprimary.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -214,7 +214,6 @@ begin
begin
if FDDSPrimary <> nil then
begin
// FDDSPrimary^.lpVtbl^.Release(FDDSPrimary);
FDDSPrimary := nil;
end;
raise TPTCError.Create('could not create primary surface', error);
@ -232,6 +231,18 @@ begin
LOG('creating secondary surface');
LOG('width', AWidth);
LOG('height', AHeight);
if FDDC <> nil then
begin
LOG('releasing clipper');
FDDC := nil;
end;
if FDDSSecondary <> nil then
begin
LOG('releasing secondary surface');
FDDSSecondary := nil;
end;
FillChar(descriptor, SizeOf(descriptor), 0);
descriptor.dwSize := SizeOf(descriptor);
descriptor.dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
@ -351,27 +362,23 @@ begin
if FDDC <> nil then
begin
LOG('releasing clipper');
// FDDC^.lpVtbl^.Release(FDDC);
FDDC := nil;
end;
if FDDSSecondary <> nil then
begin
LOG('releasing secondary surface');
// FDDSSecondary^.lpVtbl^.Release(FDDSSecondary);
FDDSSecondary := nil;
end;
i := 0;
while FDDSPrimaryPage[i] <> nil do
begin
LOG('releasing attached primary surface page');
// FDDSPrimaryPage[i]^.lpVtbl^.Release(FDDSPrimaryPage[i]);
FDDSPrimaryPage[i] := nil;
Inc(i);
end;
if FDDSPrimary <> nil then
begin
LOG('releasing primary surface');
// FDDSPrimary^.lpVtbl^.Release(FDDSPrimary);
FDDSPrimary := nil;
end;
end;
@ -806,3 +813,11 @@ function TDirectXPrimary.Clip: IPTCArea;
begin
Result := FClip;
end;
procedure TDirectXPrimary.InternalResize(AWidth, AHeight: Integer);
begin
FWidth := AWidth;
FHeight := AHeight;
FArea := TPTCArea.Create(0, 0, FWidth, FHeight);
FClip := TPTCArea.Create(FArea);
end;

4
packages/ptc/src/win32/directx/win32directxprimaryd.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003, 2006, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2003, 2006, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Glenn Fiedler (ptc@gaffer.org)
This library is free software; you can redistribute it and/or
@ -87,6 +87,8 @@ type
procedure Centering(ACenter: Boolean);
procedure Close;
procedure InternalResize(AWidth, AHeight: Integer);
procedure Update;
function Lock: Pointer;

11
packages/ptc/src/win32/gdi/win32gdiconsoled.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -36,6 +36,7 @@ type
FWin32DIB: TWin32DIB;
FKeyboard: TWin32Keyboard;
FMouse: TWin32Mouse;
FResize: TWin32Resize;
FWin32Cursor: TWin32Cursor;
FHook: TGDIHook;
@ -48,6 +49,7 @@ type
FModes: array of IPTCMode;
FFullscreen: Boolean;
FResizable: Boolean;
FModeSetter: TWin32ModeSetter;
FGrabMouse: Boolean;
@ -65,6 +67,8 @@ type
FDefaultHeight: Integer;
FDefaultFormat: IPTCFormat;
FInterceptClose: Boolean;
FUseOpenGL: Boolean;
procedure UpdateCursor;
@ -84,6 +88,9 @@ type
procedure CheckOpen(const AMessage: string);
procedure CheckUnlocked(const AMessage: string);
procedure SetInterceptClose(AInterceptClose: Boolean);
property InterceptClose: Boolean read FInterceptClose write SetInterceptClose;
public
constructor Create; override;
destructor Destroy; override;
@ -97,6 +104,8 @@ type
APages: Integer = 0); overload; override;
procedure Close; override;
procedure InternalResize(AWidth, AHeight: Integer); override;
procedure Copy(ASurface: IPTCSurface); override;
procedure Copy(ASurface: IPTCSurface;
ASource, ADestination: IPTCArea); override;

151
packages/ptc/src/win32/gdi/win32gdiconsolei.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2007, 2009-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2007, 2009-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -50,6 +50,7 @@ begin
FWin32Cursor := TWin32Cursor.Create;
FFullscreen := True;
FResizable := False;
FModeSetter := TWin32ModeSetter.Create;
@ -122,28 +123,6 @@ begin
FModeSetter.Open(AWidth, AHeight, AFormat);
end;
(* FWindow := TWin32Window.Create('PTC_GDI_FULLSCREEN',
ATitle,
WS_EX_TOPMOST,
DWord(WS_POPUP or WS_SYSMENU or WS_VISIBLE), // fpc windows RTL bug - WS_POPUP should be a DWord!!!
CS_HREDRAW or CS_VREDRAW,
SW_NORMAL,
0, 0,
GetSystemMetrics(SM_CXSCREEN),
GetSystemMetrics(SM_CYSCREEN),
False, False);*)
(* FWindow := TWin32Window.Create('PTC_GDI_WINDOWED_RESIZABLE',
ATitle,
0,
WS_OVERLAPPEDWINDOW or WS_VISIBLE,
CS_HREDRAW or CS_VREDRAW,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False);*)
if FFullscreen then
begin
if FUseOpenGL then
@ -158,6 +137,7 @@ begin
{m_center_window}False,
False,
FCursor,
InterceptClose,
FOpenGLAttributes)
else
FWindow := TWin32Window.Create('PTC_GDI_FULLSCREEN',
@ -170,41 +150,74 @@ begin
AWidth, AHeight,
{m_center_window}False,
False,
FCursor);
FCursor,
InterceptClose);
end
else
begin
if FUseOpenGL then
FWindow := TWin32OpenGLWindow.Create('PTC_OPENGL_WINDOWED_FIXED',
ATitle,
0,
WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX or WS_CLIPSIBLINGS or WS_CLIPCHILDREN,
CS_HREDRAW or CS_VREDRAW or CS_OWNDC,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor,
FOpenGLAttributes)
if FResizable then
FWindow := TWin32OpenGLWindow.Create('PTC_OPENGL_WINDOWED_RESIZABLE',
ATitle,
0,
WS_OVERLAPPEDWINDOW or WS_VISIBLE or WS_CLIPSIBLINGS or WS_CLIPCHILDREN,
CS_HREDRAW or CS_VREDRAW or CS_OWNDC,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor,
InterceptClose,
FOpenGLAttributes)
else
FWindow := TWin32OpenGLWindow.Create('PTC_OPENGL_WINDOWED_FIXED',
ATitle,
0,
WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX or WS_CLIPSIBLINGS or WS_CLIPCHILDREN,
CS_HREDRAW or CS_VREDRAW or CS_OWNDC,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor,
InterceptClose,
FOpenGLAttributes)
else
FWindow := TWin32Window.Create('PTC_GDI_WINDOWED_FIXED',
ATitle,
0,
WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX,
CS_HREDRAW or CS_VREDRAW,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor);
if FResizable then
FWindow := TWin32Window.Create('PTC_GDI_WINDOWED_RESIZABLE',
ATitle,
0,
WS_OVERLAPPEDWINDOW or WS_VISIBLE,
CS_HREDRAW or CS_VREDRAW,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor,
InterceptClose)
else
FWindow := TWin32Window.Create('PTC_GDI_WINDOWED_FIXED',
ATitle,
0,
WS_VISIBLE or WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX,
CS_HREDRAW or CS_VREDRAW,
SW_NORMAL,
CW_USEDEFAULT, CW_USEDEFAULT,
AWidth, AHeight,
{m_center_window}False,
False,
FCursor,
InterceptClose);
end;
FWin32DIB := TWin32DIB.Create(AWidth, AHeight);
FreeAndNil(FKeyboard);
FreeAndNil(FMouse);
FreeAndNil(FResize);
FreeAndNil(FHook);
FreeAndNil(FEventQueue);
FEventQueue := TEventQueue.Create;
@ -213,6 +226,8 @@ begin
FMouse := TWin32Mouse.Create(FWindow.Handle, FWindow.Thread, False, FEventQueue, FFullScreen, AWidth, AHeight);
if FFullscreen then
FMouse.SetWindowArea(0, 0, AWidth, AHeight);
if not FFullscreen and FResizable then
FResize := TWin32Resize.Create(FWindow.Handle, FWindow.Thread, FEventQueue);
tmpArea := TPTCArea.Create(0, 0, AWidth, AHeight);
FArea := tmpArea;
@ -248,6 +263,7 @@ begin
FreeAndNil(FKeyboard);
FreeAndNil(FMouse);
FreeAndNil(FResize);
FreeAndNil(FHook);
FreeAndNil(FWin32DIB);
@ -260,6 +276,24 @@ begin
FOpen := False;
end;
procedure TGDIConsole.InternalResize(AWidth, AHeight: Integer);
begin
CheckOpen( 'TGDIConsole.InternalResize');
CheckUnlocked('TGDIConsole.InternalResize');
if FFullscreen then
raise TPTCError.Create('TGDIConsole.InternalResize only works in windowed mode');
if not FResizable then
raise TPTCError.Create('TGDIConsole.InternalResize only works in resizable window mode');
FreeAndNil(FWin32DIB);
FWin32DIB := TWin32DIB.Create(AWidth, AHeight);
FArea := TPTCAreaFactory.CreateNew(0, 0, AWidth, AHeight);
FClip := FArea;
FMouse.SetConsoleSize(AWidth, AHeight);
end;
procedure TGDIConsole.Copy(ASurface: IPTCSurface);
begin
// todo...
@ -443,6 +477,16 @@ begin
FFullscreen := True;
exit;
end;
if AOption = 'resizable window' then
begin
FResizable := True;
exit;
end;
if AOption = 'fixed window' then
begin
FResizable := False;
exit;
end;
if AOption = 'default cursor' then
begin
FCursorMode := CURSOR_DEFAULT;
@ -475,6 +519,12 @@ begin
FGrabMouse := False;
exit;
end;
if AOption = 'intercept window close' then
begin
InterceptClose := True;
Result := True;
exit;
end;
Result := FCopy.Option(AOption);
end;
@ -704,6 +754,13 @@ begin
end;
end;
procedure TGDIConsole.SetInterceptClose(AInterceptClose: Boolean);
begin
FInterceptClose := AInterceptClose;
if Assigned(FWindow) then
FWindow.InterceptClose := AInterceptClose;
end;
procedure TGDIConsole.CheckOpen(const AMessage: String);
begin
if not FOpen then

25
packages/ptc/src/win32/gdi/win32gdihooki.inc
View File

@ -140,18 +140,27 @@ begin
if FManaged then
begin
console := FConsole;
if FConsole.InterceptClose then
begin
FConsole.FEventQueue.AddEvent(TPTCCloseEvent.Create);
Result := 0;
exit;
end
else
begin
console := FConsole;
{ close console }
console.Close;
{ close console }
console.Close;
{ note: at this point the hook object has been destroyed by the console! }
{ note: at this point the hook object has been destroyed by the console! }
{ internal console shutdown }
//console.internal_shutdown;
{ internal console shutdown }
//console.internal_shutdown;
{ halt }
Halt(0);
{ halt }
Halt(0);
end;
end;
{ handled }

14
packages/ptc/src/win32/gdi/win32modesetteri.inc
View File

@ -29,6 +29,20 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
{$ifdef VER2_6}
{ constants moved to the windows unit in fpc trunk }
const
DISP_CHANGE_BADPARAM = -5;
DISP_CHANGE_BADDUALVIEW = -6;
DM_POSITION = $00000020;
DM_NUP = $00000040;
DM_PANNINGWIDTH = $08000000;
DM_PANNINGHEIGHT = $10000000;
DMDFO_DEFAULT = 0;
DMDFO_STRETCH = 1;
DMDFO_CENTER = 2;
{$endif VER2_6}
constructor TWin32ModeSetter.Create;
begin
SetupModeList;

2
packages/ptc/src/win32/gdi/win32openglwindowd.inc
View File

@ -45,5 +45,5 @@ type
public
constructor Create(const AWndClass, ATitle: string; AExtra, AStyle, AClassStyle: DWord;
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded,
ACursor: Boolean; const AOpenGLAttributes: IPTCOpenGLAttributes);
ACursor, AInterceptClose: Boolean; const AOpenGLAttributes: IPTCOpenGLAttributes);
end;

4
packages/ptc/src/win32/gdi/win32openglwindowi.inc
View File

@ -35,12 +35,12 @@ const
PFD_SUPPORT_COMPOSITION = $00008000;
constructor TWin32OpenGLWindow.Create(const AWndClass, ATitle: string; AExtra, AStyle, AClassStyle: DWord;
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded, ACursor: Boolean;
AShow, AX, AY, AWidth, AHeight: Integer; ACenter, AMultithreaded, ACursor, AInterceptClose: Boolean;
const AOpenGLAttributes: IPTCOpenGLAttributes);
begin
SetOpenGLAttributes(AOpenGLAttributes);
inherited Create(AWndClass, ATitle, AExtra, AStyle, AClassStyle,
AShow, AX, AY, AWidth, AHeight, ACenter, AMultithreaded, ACursor);
AShow, AX, AY, AWidth, AHeight, ACenter, AMultithreaded, ACursor, AInterceptClose);
end;
function TWin32OpenGLWindow.WMCreate(

4
packages/ptc/src/x11/x11consoled.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -67,6 +67,8 @@ type
APages: Integer = 0); overload; override;
procedure Close; override;
procedure InternalResize(AWidth, AHeight: Integer); override;
procedure Copy(ASurface: IPTCSurface); override;
procedure Copy(ASurface: IPTCSurface;
ASource, ADestination: IPTCArea); override;

24
packages/ptc/src/x11/x11consolei.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -200,6 +200,23 @@ begin
UpdateMouseGrab;
exit;
end;
if AOption = 'intercept window close' then
begin
FFlags := FFlags + [PTC_X11_INTERCEPT_WINDOW_CLOSE];
if Assigned(FX11Display) then
FX11Display.InterceptClose := True;
exit;
end;
if AOption = 'resizable window' then
begin
FFlags := FFlags + [PTC_X11_RESIZABLE_WINDOW];
exit;
end;
if AOption = 'fixed window' then
begin
FFlags := FFlags - [PTC_X11_RESIZABLE_WINDOW];
exit;
end;
if AOption = 'enable logging' then
begin
LOG_enabled := True;
@ -328,6 +345,11 @@ begin
FreeAndNil(FX11Display);
end;
procedure TX11Console.InternalResize(AWidth, AHeight: Integer);
begin
FX11Display.InternalResize(AWidth, AHeight);
end;
procedure TX11Console.Flush;
begin
Update;

10
packages/ptc/src/x11/x11displayd.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -43,6 +43,8 @@ type
PTC_X11_FULLSCREEN_CURSOR_VISIBLE,
PTC_X11_WINDOWED_CURSOR_INVISIBLE,
PTC_X11_GRAB_MOUSE,
PTC_X11_INTERCEPT_WINDOW_CLOSE,
PTC_X11_RESIZABLE_WINDOW,
PTC_X11_USE_OPENGL);
TX11Flags = set of TX11FlagsEnum;
@ -72,6 +74,9 @@ type
FFunctionKeys: PInteger;
FNormalKeys: PInteger;
function GetInterceptClose: Boolean;
procedure SetInterceptClose(AInterceptClose: Boolean);
function NextEvent(out AEvent: IPTCEvent; AWait: Boolean; const AEventMask: TPTCEventMask): Boolean; virtual; abstract;
function PeekEvent(AWait: Boolean; const AEventMask: TPTCEventMask): IPTCEvent; virtual; abstract;
@ -90,6 +95,7 @@ type
function GetFormat: IPTCFormat;
function GetArea: IPTCArea;
procedure HandleKeyEvent(const e: TXKeyEvent);
property InterceptClose: Boolean read GetInterceptClose write SetInterceptClose;
public
constructor Create(ADisplay: PDisplay; AScreen: Integer; const AFlags: TX11Flags); virtual;
destructor Destroy; override;
@ -103,6 +109,8 @@ type
procedure Close; virtual; abstract;
procedure InternalResize(AWidth, AHeight: Integer); virtual;
procedure Update; virtual; abstract;
procedure Update(AArea: IPTCArea); virtual; abstract;

20
packages/ptc/src/x11/x11displayi.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -497,6 +497,24 @@ begin
FEventQueue.AddEvent(key);
end;
function TX11Display.GetInterceptClose: Boolean;
begin
Result := PTC_X11_INTERCEPT_WINDOW_CLOSE in FFlags;
end;
procedure TX11Display.SetInterceptClose(AInterceptClose: Boolean);
begin
if AInterceptClose then
FFlags := FFlags + [PTC_X11_INTERCEPT_WINDOW_CLOSE]
else
FFlags := FFlags - [PTC_X11_INTERCEPT_WINDOW_CLOSE];
end;
procedure TX11Display.InternalResize(AWidth, AHeight: Integer);
begin
raise TPTCError.Create('Console not in windowed mode');
end;
procedure TX11Display.OpenGL_SwapBuffers;
begin
raise TPTCError.Create('Not in OpenGL mode');

6
packages/ptc/src/x11/x11windowdisplayd.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -47,6 +47,7 @@ type
FX11InvisibleCursor: TCursor; { Blank cursor }
FFullScreen: Boolean; { Keeps a snapshot of the PTC_X11_FULLSCREEN option
taken at the time 'open' was called }
FResizable: Boolean;
FFocus: Boolean;
FModeSwitcher: TX11Modes;
@ -55,6 +56,8 @@ type
FPreviousMousePositionSaved: Boolean; { true, if FPreviousMouseX,
FPreviousMouseY and FPreviousMouseButtonState contain valid values }
FPreviousWidth, FPreviousHeight: Integer;
{$IFDEF ENABLE_X11_EXTENSION_GLX}
FGLXFBConfig: TX11GLXFBConfig;
{$ENDIF ENABLE_X11_EXTENSION_GLX}
@ -82,6 +85,7 @@ type
procedure Open(AWindow: TWindow; AFormat: IPTCFormat); override;
procedure Open(AWindow: TWindow; AFormat: IPTCFormat; AX, AY, AWidth, AHeight: Integer); override;
procedure Close; override;
procedure InternalResize(AWidth, AHeight: Integer); override;
procedure Update; override;
procedure Update(AArea: IPTCArea); override;
function Lock: Pointer; override;

82
packages/ptc/src/x11/x11windowdisplayi.inc
View File

@ -1,6 +1,6 @@
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2012 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Original C++ version by Christian Nentwich (c.nentwich@cs.ucl.ac.uk)
This library is free software; you can redistribute it and/or
@ -65,10 +65,13 @@ var
begin
FHeight := AHeight;
FWidth := AWidth;
FPreviousWidth := FWidth;
FPreviousHeight := FHeight;
FDestX := 0;
FDestY := 0;
FFullScreen := PTC_X11_FULLSCREEN In FFlags;
FFullScreen := PTC_X11_FULLSCREEN in FFlags;
FResizable := (PTC_X11_RESIZABLE_WINDOW in FFlags) and not FFullScreen;
FFocus := True;
@ -149,22 +152,33 @@ begin
{ Set normal hints }
size_hints := XAllocSizeHints;
try
size_hints^.flags := PMinSize or PBaseSize;
size_hints^.min_width := AWidth;
size_hints^.min_height := AHeight;
size_hints^.flags := PBaseSize;
size_hints^.base_width := AWidth;
size_hints^.base_height := AHeight;
if FFullScreen then
begin
size_hints^.flags := size_hints^.flags or PWinGravity;
size_hints^.flags := size_hints^.flags or PMinSize or PWinGravity;
size_hints^.min_width := AWidth;
size_hints^.min_height := AHeight;
size_hints^.win_gravity := StaticGravity;
end
else
begin
{ not fullscreen - add maxsize limit=minsize, i.e. make window not resizable }
size_hints^.flags := size_hints^.flags or PMaxSize;
size_hints^.max_width := AWidth;
size_hints^.max_height := AHeight;
if FResizable then
begin
size_hints^.flags := size_hints^.flags or PMinSize;
size_hints^.min_width := 0;
size_hints^.min_height := 0;
end
else
begin
{ not fullscreen and not resizable: maxsize=minsize=basesize }
size_hints^.flags := size_hints^.flags or PMinSize or PMaxSize;
size_hints^.min_width := AWidth;
size_hints^.min_height := AHeight;
size_hints^.max_width := AWidth;
size_hints^.max_height := AHeight;
end;
end;
XSetWMNormalHints(FDisplay, FWindow, size_hints);
XFlush(FDisplay);
@ -287,6 +301,32 @@ begin
end;
end;
procedure TX11WindowDisplay.InternalResize(AWidth, AHeight: Integer);
begin
if FFullScreen then
raise TPTCError.Create('Internal resize not supported in fullscreen mode');
if not FResizable then
raise TPTCError.Create('Internal resize cannot be used on a non-resizable window');
if not (PTC_X11_USE_OPENGL in FFlags) then
begin
{ destroy previous XImage }
FreeAndNil(FPrimary);
end;
FWidth := AWidth;
FHeight := AHeight;
if not (PTC_X11_USE_OPENGL in FFlags) then
begin
{ Create XImage using factory method }
FPrimary := CreateImage(FDisplay, FScreen, FWidth, FHeight, FFormat);
end;
{ Set clipping area }
FClip := TPTCArea.Create(0, 0, FWidth, FHeight);
end;
procedure TX11WindowDisplay.internal_ShowCursor(AVisible: Boolean);
var
attr: TXSetWindowAttributes;
@ -529,6 +569,18 @@ var
end;
end;
procedure HandleConfigureNotifyEvent;
begin
if FFullScreen or not FResizable then
exit;
if (FPreviousWidth <> e.xconfigure.width) or (FPreviousHeight <> e.xconfigure.height) then
FEventQueue.AddEvent(TPTCResizeEvent.Create(e.xconfigure.width, e.xconfigure.height));
FPreviousWidth := e.xconfigure.width;
FPreviousHeight := e.xconfigure.height;
end;
begin
NewFocusSpecified := False;
while UsefulEventsPending do
@ -545,12 +597,16 @@ begin
end;
ClientMessage: begin
if (e.xclient.format = 32) and (TAtom(e.xclient.data.l[0]) = FAtomClose) then
Halt(0);
if InterceptClose then
FEventQueue.AddEvent(TPTCCloseEvent.Create)
else
Halt(0);
end;
Expose: begin
if e.xexpose.count = 0 then
Draw;
end;
ConfigureNotify: HandleConfigureNotifyEvent;
KeyPress, KeyRelease: HandleKeyEvent(e.xkey);
ButtonPress, ButtonRelease, MotionNotify: HandleMouseEvent;
end;
@ -698,7 +754,7 @@ end;
function TX11WindowDisplay.CreateModeSwitcher: TX11Modes;
begin
{$IFDEF ENABLE_X11_EXTENSION_XRANDR}
if PTC_X11_TRY_XRANDR In FFlags then
if PTC_X11_TRY_XRANDR in FFlags then
try
LOG('trying to initialize the Xrandr mode switcher');
Result := TX11ModesXrandr.Create(FDisplay, FScreen);
@ -709,7 +765,7 @@ begin
{$ENDIF ENABLE_X11_EXTENSION_XRANDR}
{$IFDEF ENABLE_X11_EXTENSION_XF86VIDMODE}
if PTC_X11_TRY_XF86VIDMODE In FFlags then
if PTC_X11_TRY_XF86VIDMODE in FFlags then
try
LOG('trying to initialize the XF86VidMode mode switcher');
Result := TX11ModesXF86VidMode.Create(FDisplay, FScreen);