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

+ UPgrade PTCPas to latest svn revision

Browse Source 
git-svn-id: trunk@6912 -
This commit is contained in:
daniel 2007-03-18 10:51:23 +00:00
parent 2639d8f83a
commit aa0b2b4e71
36 changed files with 1568 additions and 608 deletions

66
.gitattributes vendored
View File

@ -3160,11 +3160,15 @@ packages/extra/pcap/fpmake.pp svneol=native#text/plain
packages/extra/pcap/pcap.pp svneol=native#text/plain
packages/extra/ptc/Makefile -text
packages/extra/ptc/Makefile.fpc -text
packages/extra/ptc/aread.inc -text
packages/extra/ptc/areai.inc -text
packages/extra/ptc/aread.inc svneol=native#text/x-pascal
packages/extra/ptc/areai.inc svneol=native#text/x-pascal
packages/extra/ptc/basecond.inc -text
packages/extra/ptc/baseconi.inc -text
packages/extra/ptc/baseconsoled.inc svneol=native#text/x-pascal
packages/extra/ptc/baseconsolei.inc svneol=native#text/x-pascal
packages/extra/ptc/basesurd.inc -text
packages/extra/ptc/basesurface.inc svneol=native#text/x-pascal
packages/extra/ptc/basesurfaced.inc svneol=native#text/x-pascal
packages/extra/ptc/basesuri.inc -text
packages/extra/ptc/c_api/area.inc -text
packages/extra/ptc/c_api/aread.inc -text
@ -3195,16 +3199,18 @@ packages/extra/ptc/c_api/surface.inc -text
packages/extra/ptc/c_api/surfaced.inc -text
packages/extra/ptc/c_api/timer.inc -text
packages/extra/ptc/c_api/timerd.inc -text
packages/extra/ptc/cleard.inc -text
packages/extra/ptc/cleari.inc -text
packages/extra/ptc/clipperd.inc -text
packages/extra/ptc/clipperi.inc -text
packages/extra/ptc/colord.inc -text
packages/extra/ptc/colori.inc -text
packages/extra/ptc/consoled.inc -text
packages/extra/ptc/consolei.inc -text
packages/extra/ptc/copyd.inc -text
packages/extra/ptc/copyi.inc -text
packages/extra/ptc/cleard.inc svneol=native#text/x-pascal
packages/extra/ptc/cleari.inc svneol=native#text/x-pascal
packages/extra/ptc/clipperd.inc svneol=native#text/x-pascal
packages/extra/ptc/clipperi.inc svneol=native#text/x-pascal
packages/extra/ptc/colord.inc svneol=native#text/x-pascal
packages/extra/ptc/colori.inc svneol=native#text/x-pascal
packages/extra/ptc/consoled.inc svneol=native#text/x-pascal
packages/extra/ptc/consolei.inc svneol=native#text/x-pascal
packages/extra/ptc/copyd.inc svneol=native#text/x-pascal
packages/extra/ptc/copyi.inc svneol=native#text/x-pascal
packages/extra/ptc/coreimplementation.inc svneol=native#text/x-pascal
packages/extra/ptc/coreinterface.inc svneol=native#text/x-pascal
packages/extra/ptc/demos/Makefile -text
packages/extra/ptc/demos/Makefile.fpc -text
packages/extra/ptc/demos/fire.pp -text
@ -3239,8 +3245,10 @@ packages/extra/ptc/dos/timeunit/timeunit.pp -text
packages/extra/ptc/dos/vesa/console.inc -text
packages/extra/ptc/dos/vesa/consoled.inc -text
packages/extra/ptc/dos/vesa/vesa.pp -text
packages/extra/ptc/errord.inc -text
packages/extra/ptc/errori.inc -text
packages/extra/ptc/errord.inc svneol=native#text/x-pascal
packages/extra/ptc/errori.inc svneol=native#text/x-pascal
packages/extra/ptc/eventd.inc svneol=native#text/x-pascal
packages/extra/ptc/eventi.inc svneol=native#text/x-pascal
packages/extra/ptc/examples/Makefile -text
packages/extra/ptc/examples/Makefile.fpc -text
packages/extra/ptc/examples/area.pp -text
@ -3262,24 +3270,28 @@ packages/extra/ptc/examples/save.pp -text
packages/extra/ptc/examples/stretch.pp -text
packages/extra/ptc/examples/stretch.tga -text
packages/extra/ptc/examples/timer.pp -text
packages/extra/ptc/formatd.inc -text
packages/extra/ptc/formati.inc -text
packages/extra/ptc/keyd.inc -text
packages/extra/ptc/keyi.inc -text
packages/extra/ptc/log.inc -text
packages/extra/ptc/moded.inc -text
packages/extra/ptc/modei.inc -text
packages/extra/ptc/paletted.inc -text
packages/extra/ptc/palettei.inc -text
packages/extra/ptc/formatd.inc svneol=native#text/x-pascal
packages/extra/ptc/formati.inc svneol=native#text/x-pascal
packages/extra/ptc/keyd.inc svneol=native#text/x-pascal
packages/extra/ptc/keyeventd.inc svneol=native#text/x-pascal
packages/extra/ptc/keyeventi.inc svneol=native#text/x-pascal
packages/extra/ptc/keyi.inc svneol=native#text/x-pascal
packages/extra/ptc/log.inc svneol=native#text/x-pascal
packages/extra/ptc/moded.inc svneol=native#text/x-pascal
packages/extra/ptc/modei.inc svneol=native#text/x-pascal
packages/extra/ptc/mouseeventd.inc svneol=native#text/x-pascal
packages/extra/ptc/mouseeventi.inc svneol=native#text/x-pascal
packages/extra/ptc/paletted.inc svneol=native#text/x-pascal
packages/extra/ptc/palettei.inc svneol=native#text/x-pascal
packages/extra/ptc/ptc.cfg -text
packages/extra/ptc/ptc.pp -text
packages/extra/ptc/surfaced.inc -text
packages/extra/ptc/surfacei.inc -text
packages/extra/ptc/surfaced.inc svneol=native#text/x-pascal
packages/extra/ptc/surfacei.inc svneol=native#text/x-pascal
packages/extra/ptc/test/convtest.pas -text
packages/extra/ptc/test/endian.pas -text
packages/extra/ptc/test/view.pp -text
packages/extra/ptc/timerd.inc -text
packages/extra/ptc/timeri.inc -text
packages/extra/ptc/timerd.inc svneol=native#text/x-pascal
packages/extra/ptc/timeri.inc svneol=native#text/x-pascal
packages/extra/ptc/tinyptc/tinyptc.pp -text
packages/extra/ptc/win32/base/cursor.inc -text
packages/extra/ptc/win32/base/event.inc -text

27
packages/extra/ptc/aread.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -21,18 +21,19 @@
Type
TPTCArea=Class(TObject)
Private
Fleft, Ftop, Fright, Fbottom : Integer;
FLeft, FTop, FRight, FBottom : Integer;
Function GetWidth : Integer;
Function GetHeight : Integer;
Public
Constructor Create;
Constructor Create(_left, _top, _right, _bottom : Integer);
Constructor Create(Const Area : TPTCArea);
Destructor Destroy; Override;
Function width : Integer;
Function height : Integer;
Procedure Assign(Const area : TPTCArea);
Function Equals(Const area : TPTCArea) : Boolean;
Property left : Integer read Fleft;
Property top : Integer read Ftop;
Property right : Integer read Fright;
Property bottom : Integer read Fbottom;
Constructor Create(ALeft, ATop, ARight, ABottom : Integer);
Constructor Create(Const AArea : TPTCArea);
Procedure Assign(Const AArea : TPTCArea);
Function Equals(Const AArea : TPTCArea) : Boolean;
Property Left : Integer Read FLeft;
Property Top : Integer Read FTop;
Property Right : Integer Read FRight;
Property Bottom : Integer Read FBottom;
Property Width : Integer Read GetWidth;
Property Height : Integer Read GetHeight;
End;

75
packages/extra/ptc/areai.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -18,80 +18,75 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
Constructor TPTCArea.Create(_left, _top, _right, _bottom : Integer);
Constructor TPTCArea.Create(ALeft, ATop, ARight, ABottom : Integer);
Begin
If _left < _right Then
If ALeft < ARight Then
Begin
Fleft := _left;
Fright := _right;
FLeft := ALeft;
FRight := ARight;
End
Else
Begin
Fleft := _right;
Fright := _left;
FLeft := ARight;
FRight := ALeft;
End;
If _top < _bottom Then
If ATop < ABottom Then
Begin
Ftop := _top;
Fbottom := _bottom;
FTop := ATop;
FBottom := ABottom;
End
Else
Begin
Ftop := _bottom;
Fbottom := _top;
FTop := ABottom;
FBottom := ATop;
End;
End;
Constructor TPTCArea.Create;
Begin
Fleft := 0;
Fright := 0;
Ftop := 0;
Fbottom := 0;
FLeft := 0;
FRight := 0;
FTop := 0;
FBottom := 0;
End;
Constructor TPTCArea.Create(Const area : TPTCArea);
Constructor TPTCArea.Create(Const AArea : TPTCArea);
Begin
ASSign(area);
FLeft := AArea.FLeft;
FTop := AArea.FTop;
FRight := AArea.FRight;
FBottom := AArea.FBottom;
End;
Destructor TPTCArea.Destroy;
Procedure TPTCArea.Assign(Const AArea : TPTCArea);
Begin
Inherited Destroy;
FLeft := AArea.FLeft;
FTop := AArea.FTop;
FRight := AArea.FRight;
FBottom := AArea.FBottom;
End;
Procedure TPTCArea.Assign(Const area : TPTCArea);
Function TPTCArea.Equals(Const AArea : TPTCArea) : Boolean;
Begin
If Self = area Then
Raise TPTCError.Create('self assignment is not allowed');
Fleft := area.Fleft;
Ftop := area.Ftop;
Fright := area.Fright;
Fbottom := area.Fbottom;
Result := (FLeft = AArea.FLeft) And
(FTop = AArea.FTop) And
(FRight = AArea.FRight) And
(FBottom = AArea.FBottom);
End;
Function TPTCArea.Equals(Const area : TPTCArea) : Boolean;
Function TPTCArea.GetWidth : Integer;
Begin
Equals := (Fleft = area.Fleft) And
(Ftop = area.Ftop) And
(Fright = area.Fright) And
(Fbottom = area.Fbottom);
Result := FRight - FLeft;
End;
Function TPTCArea.width : Integer;
Function TPTCArea.GetHeight : Integer;
Begin
width := Fright - Fleft;
End;
Function TPTCArea.height : Integer;
Begin
height := Fbottom - Ftop;
Result := FBottom - FTop;
End;

57
packages/extra/ptc/baseconsoled.inc Normal file
View File

@ -0,0 +1,57 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
TPTCBaseConsole=Class(TPTCBaseSurface)
Private
FReleaseEnabled : Boolean;
Public
Constructor Create;
Procedure configure(Const _file : String); Virtual; Abstract;
Function modes : PPTCMode; Virtual; Abstract;
Procedure open(Const _title : String; _pages : Integer = 0); Overload; Virtual; Abstract;
Procedure open(Const _title : String; Const _format : TPTCFormat;
_pages : Integer = 0); Overload; Virtual; Abstract;
Procedure open(Const _title : String; _width, _height : Integer;
Const _format : TPTCFormat; _pages : Integer = 0); Overload; Virtual; Abstract;
Procedure open(Const _title : String; Const _mode : TPTCMode;
_pages : Integer = 0); Overload; Virtual; Abstract;
Procedure close; Virtual; Abstract;
Procedure flush; Virtual; Abstract;
Procedure finish; Virtual; Abstract;
Procedure update; Virtual; Abstract;
Procedure update(Const _area : TPTCArea); Virtual; Abstract;
{ event handling }
Function NextEvent(Var event : TPTCEvent; wait : Boolean; Const EventMask : TPTCEventMask) : Boolean; Virtual; Abstract;
Function PeekEvent(wait : Boolean; Const EventMask : TPTCEventMask) : TPTCEvent; Virtual; Abstract;
{ key handling }
Function KeyPressed : Boolean;
Function PeekKey(Var k : TPTCKeyEvent) : Boolean;
Procedure ReadKey(Var k : TPTCKeyEvent);
Procedure ReadKey;
Property KeyReleaseEnabled : Boolean Read FReleaseEnabled Write FReleaseEnabled;
Function pages : Integer; Virtual; Abstract;
Function name : String; Virtual; Abstract;
Function title : String; Virtual; Abstract;
Function information : String; Virtual; Abstract;
End;

88
packages/extra/ptc/baseconsolei.inc Normal file
View File

@ -0,0 +1,88 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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 TPTCBaseConsole.Create;
Begin
FReleaseEnabled := False;
End;
Function TPTCBaseConsole.KeyPressed : Boolean;
Var
k, kpeek : TPTCEvent;
Begin
k := Nil;
Try
Repeat
kpeek := PeekEvent(False, [PTCKeyEvent]);
If kpeek = Nil Then
Exit(False);
If FReleaseEnabled Or (kpeek As TPTCKeyEvent).Press Then
Exit(True);
NextEvent(k, False, [PTCKeyEvent]);
Until False;
Finally
k.Free;
End;
End;
Procedure TPTCBaseConsole.ReadKey(Var k : TPTCKeyEvent);
Var
ev : TPTCEvent;
Begin
ev := k;
Try
Repeat
NextEvent(ev, True, [PTCKeyEvent]);
Until FReleaseEnabled Or (ev As TPTCKeyEvent).Press;
Finally
k := ev As TPTCKeyEvent;
End;
End;
Function TPTCBaseConsole.PeekKey(Var k : TPTCKeyEvent) : Boolean;
Begin
If KeyPressed Then
Begin
ReadKey(k);
Result := True;
End
Else
Result := False;
End;
Procedure TPTCBaseConsole.ReadKey;
Var
k : TPTCKeyEvent;
Begin
k := TPTCKeyEvent.Create;
Try
ReadKey(k);
Finally
k.Free;
End;
End;

31
packages/extra/ptc/basesurface.inc Normal file
View File

@ -0,0 +1,31 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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 TPTCBaseSurface.Create;
Begin
End;
}
{Destructor TPTCBaseSurface.Destroy;
Begin
Inherited Destroy;
End;
}

63
packages/extra/ptc/basesurfaced.inc Normal file
View File

@ -0,0 +1,63 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
TPTCBaseSurface=Class(TObject)
Public
{ Constructor Create;}
{ Destructor Destroy; Override;}
Procedure copy(Var surface : TPTCBaseSurface); Virtual; Abstract;
Procedure copy(Var surface : TPTCBaseSurface;
Const source, destination : TPTCArea); Virtual; Abstract;
Function lock : Pointer; Virtual; Abstract;
Procedure unlock; Virtual; Abstract;
Procedure load(Const pixels : Pointer;
_width, _height, _pitch : Integer;
Const _format : TPTCFormat;
Const _palette : TPTCPalette); Virtual; Abstract;
Procedure load(Const pixels : Pointer;
_width, _height, _pitch : Integer;
Const _format : TPTCFormat;
Const _palette : TPTCPalette;
Const source, destination : TPTCArea); Virtual; Abstract;
Procedure save(pixels : Pointer;
_width, _height, _pitch : Integer;
Const _format : TPTCFormat;
Const _palette : TPTCPalette); Virtual; Abstract;
Procedure save(pixels : Pointer;
_width, _height, _pitch : Integer;
Const _format : TPTCFormat;
Const _palette : TPTCPalette;
Const source, destination : TPTCArea); Virtual; Abstract;
Procedure clear; Virtual; Abstract;
Procedure clear(Const color : TPTCColor); Virtual; Abstract;
Procedure clear(Const color : TPTCColor;
Const _area : TPTCArea); Virtual; Abstract;
Procedure palette(Const _palette : TPTCPalette); Virtual; Abstract;
Function palette : TPTCPalette; Virtual; Abstract;
Procedure clip(Const _area : TPTCArea); Virtual; Abstract;
Function width : Integer; Virtual; Abstract;
Function height : Integer; Virtual; Abstract;
Function pitch : Integer; Virtual; Abstract;
Function area : TPTCArea; Virtual; Abstract;
Function clip : TPTCArea; Virtual; Abstract;
Function format : TPTCFormat; Virtual; Abstract;
Function option(Const _option : String) : Boolean; Virtual; Abstract;
End;

10
packages/extra/ptc/cleard.inc
View File

@ -21,11 +21,13 @@
Type
TPTCClear=Class(TObject)
Private
Fhandle : THermesHandle;
Fformat : TPTCFormat;
FHandle : THermesHandle;
FFormat : TPTCFormat;
Public
Constructor Create;
Destructor Destroy; Override;
Procedure request(Const format : TPTCFormat);
Procedure clear(pixels : Pointer; x, y, width, height, pitch : Integer; Const color : TPTCColor);
Procedure Request(Const AFormat : TPTCFormat);
Procedure Clear(APixels : Pointer;
AX, AY, AWidth, AHeight, APitch : Integer;
Const AColor : TPTCColor);
End;

62
packages/extra/ptc/cleari.inc
View File

@ -21,17 +21,17 @@
Constructor TPTCClear.Create;
Begin
Fformat := Nil;
FFormat := Nil;
{ initialize hermes }
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
{ default current format }
Fformat := TPTCFormat.Create;
FFormat := TPTCFormat.Create;
{ create hermes clearer instance }
Fhandle := Hermes_ClearerInstance;
FHandle := Hermes_ClearerInstance;
{ check hermes clearer instance }
If Fhandle = 0 Then
If FHandle = 0 Then
Raise TPTCError.Create('could not create hermes clearer instance');
End;
@ -39,64 +39,52 @@ Destructor TPTCClear.Destroy;
Begin
{ return the clearer instance }
Hermes_ClearerReturn(Fhandle);
Fformat.Free;
Hermes_ClearerReturn(FHandle);
FFormat.Free;
{ free hermes }
Hermes_Done;
Inherited Destroy;
End;
Procedure TPTCClear.request(Const format : TPTCFormat);
Procedure TPTCClear.Request(Const AFormat : TPTCFormat);
Var
hermes_format : PHermesFormat;
Begin
hermes_format := @format.Fformat;
hermes_format := @AFormat.FFormat;
{ request surface clear for this format }
If Not Hermes_ClearerRequest(Fhandle, hermes_format) Then
If Not Hermes_ClearerRequest(FHandle, hermes_format) Then
Raise TPTCError.Create('unsupported clear format');
{ update current format }
Fformat.Assign(format);
FFormat.Assign(AFormat);
End;
Procedure TPTCClear.clear(pixels : Pointer; x, y, width, height, pitch : Integer; Const color : TPTCColor);
Procedure TPTCClear.Clear(APixels : Pointer; AX, AY, AWidth, AHeight, APitch : Integer; Const AColor : TPTCColor);
Var
r, g, b, a : LongInt;
index : LongInt;
Begin
{$IFDEF DEBUG}
{
This checking is performed only when DEBUG is defined,
and can be used to track down errors early caused by passing
nil pointers to the clear function.
Even though technically clear should never receive a nil
pointer, we provide a check here to assist in debugging
just in case it ever does!
}
If pixels = Nil Then
If APixels = Nil Then
Raise TPTCError.Create('nil pixels pointer in clear');
{$ELSE}
{ In release build no checking is performed for the sake of efficiency. }
{$ENDIF}
{ check format type }
If Fformat.direct Then
If FFormat.direct Then
Begin
{ check color type }
If Not color.direct Then
If Not AColor.direct Then
Raise TPTCError.Create('direct pixel formats can only be cleared with direct color');
{ setup clear color }
r := Trunc(color.r * 255);
g := Trunc(color.g * 255);
b := Trunc(color.b * 255);
a := Trunc(color.a * 255);
r := Trunc(AColor.R * 255);
g := Trunc(AColor.G * 255);
b := Trunc(AColor.B * 255);
a := Trunc(AColor.A * 255);
{ clamp red }
If r > 255 Then
@ -127,16 +115,17 @@ Begin
a := 0;
{ perform the clearing }
Hermes_ClearerClear(Fhandle,pixels,x,y,width,height,pitch,r,g,b,a);
Hermes_ClearerClear(FHandle, APixels, AX, AY, AWidth, AHeight, APitch,
r, g, b, a);
End
Else
Begin
{ check color type }
If Not color.indexed Then
If Not AColor.indexed Then
Raise TPTCError.Create('indexed pixel formats can only be cleared with indexed color');
{ setup clear index }
index := color.index;
index := AColor.index;
{ clamp color index }
If index > 255 Then
@ -146,6 +135,7 @@ Begin
index := 0;
{ perform the clearing }
Hermes_ClearerClear(Fhandle,pixels,x,y,width,height,pitch,0,0,0,index);
Hermes_ClearerClear(FHandle, APixels, AX, AY, AWidth, AHeight, APitch,
0, 0, 0, index);
End;
End;

9
packages/extra/ptc/clipperd.inc
View File

@ -18,14 +18,13 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
{ $INLINE ON}
Type
TPTCClipper=Class(TObject)
Public
{ clip a single area against clip area }
Function clip(Const _area, _clip : TPTCArea) : TPTCArea;
Class Function Clip(Const AArea, AClip : TPTCArea) : TPTCArea;
{ clip source and destination areas against source and destination clip areas }
Procedure clip(Const source, clip_source, clipped_source,
destination, clip_destination,
clipped_destination : TPTCArea);
Class Procedure Clip(Const ASource, AClipSource, AClippedSource,
ADestination, AClipDestination,
AClippedDestination : TPTCArea);
End;

95
packages/extra/ptc/clipperi.inc
View File

@ -18,9 +18,9 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
{ $INLINE ON}
{$INLINE ON}
Class Function TPTCClipper.clip(Const _area, _clip : TPTCArea) : TPTCArea;
Class Function TPTCClipper.Clip(Const AArea, AClip : TPTCArea) : TPTCArea;
Var
left, top, right, bottom : Integer;
@ -28,41 +28,47 @@ Var
Begin
{ get in coordinates }
left := _area.left;
top := _area.top;
right := _area.right;
bottom := _area.bottom;
left := AArea.Left;
top := AArea.Top;
right := AArea.Right;
bottom := AArea.Bottom;
{ get clip coordinates }
clip_left := _clip.left;
clip_top := _clip.top;
clip_right := _clip.right;
clip_bottom := _clip.bottom;
clip_left := AClip.Left;
clip_top := AClip.Top;
clip_right := AClip.Right;
clip_bottom := AClip.Bottom;
{ clip left }
If left < clip_left Then
left := clip_left;
If left > clip_right Then
left := clip_right;
{ clip top }
If top < clip_top Then
top := clip_top;
If top > clip_bottom Then
top := clip_bottom;
{ clip right }
If right < clip_left Then
right := clip_left;
If right > clip_right Then
right := clip_right;
{ clip bottom }
If bottom < clip_top Then
bottom := clip_top;
If bottom > clip_bottom Then
bottom := clip_bottom;
clip := TPTCArea.Create(left, top, right, bottom);
Result := TPTCArea.Create(Left, Top, Right, Bottom);
End;
{ clip floating point area against a floating point clip area }
Procedure TPTCClipper_clip(Var left, top, right, bottom : Real;
clip_left, clip_top, clip_right, clip_bottom : Real);{ Inline;}
clip_left, clip_top, clip_right, clip_bottom : Real); Inline;
Begin
{ clip left }
@ -88,7 +94,7 @@ Begin
End;
{ clip floating point area against clip area }
Procedure TPTCClipper_clip(Var left, top, right, bottom : Real; Const _clip : TPTCArea);{ Inline;}
Procedure TPTCClipper_clip(Var left, top, right, bottom : Real; Const _clip : TPTCArea); Inline;
Var
clip_left, clip_top, clip_right, clip_bottom : Real;
@ -104,7 +110,7 @@ Begin
End;
{ snap a floating point area to integer coordinates }
Procedure TPTCClipper_round(Var left, top, right, bottom : Real);{ Inline;}
Procedure TPTCClipper_round(Var left, top, right, bottom : Real); Inline;
Begin
left := Round(left);
@ -113,9 +119,9 @@ Begin
bottom := Round(bottom);
End;
Class Procedure TPTCClipper.clip(Const source, clip_source, clipped_source,
destination, clip_destination,
clipped_destination : TPTCArea);
Class Procedure TPTCClipper.Clip(Const ASource, AClipSource, AClippedSource,
ADestination, AClipDestination,
AClippedDestination : TPTCArea);
Var
tmp1, tmp2 : TPTCArea;
@ -143,88 +149,103 @@ Begin
tmp2 := Nil;
Try
{ expand source area to floating point }
source_left := source.left;
source_top := source.top;
source_right := source.right;
source_bottom := source.bottom;
source_left := ASource.Left;
source_top := ASource.Top;
source_right := ASource.Right;
source_bottom := ASource.Bottom;
{ setup clipped source area }
clipped_source_left := source_left;
clipped_source_top := source_top;
clipped_source_right := source_right;
clipped_source_bottom := source_bottom;
{ perform clipping on floating point source area }
TPTCClipper_clip(clipped_source_left, clipped_source_top, clipped_source_right,
clipped_source_bottom, clip_source);
clipped_source_bottom, AClipSource);
{ check for early source area clipping exit }
If (clipped_source_left = clipped_source_right) Or
(clipped_source_top = clipped_source_bottom) Then
Begin
{ clipped area is zero }
tmp1 := TPTCArea.Create(0, 0, 0, 0);
clipped_source.ASSign(tmp1);
clipped_destination.ASSign(tmp1);
AClippedSource.Assign(tmp1);
AClippedDestination.Assign(tmp1);
Exit;
End;
{ calculate deltas in source clip }
source_delta_left := clipped_source_left - source_left;
source_delta_top := clipped_source_top - source_top;
source_delta_right := clipped_source_right - source_right;
source_delta_bottom := clipped_source_bottom - source_bottom;
{ calculate ratio of source area to destination area }
source_to_destination_x := destination.width / source.width;
source_to_destination_y := destination.height / source.height;
source_to_destination_x := ADestination.Width / ASource.Width;
source_to_destination_y := ADestination.Height / ASource.Height;
{ expand destination area to floating point }
destination_left := destination.left;
destination_top := destination.top;
destination_right := destination.right;
destination_bottom := destination.bottom;
destination_left := ADestination.Left;
destination_top := ADestination.Top;
destination_right := ADestination.Right;
destination_bottom := ADestination.Bottom;
{ calculate adjusted destination area }
adjusted_destination_left := destination_left + source_delta_left * source_to_destination_x;
adjusted_destination_top := destination_top + source_delta_top * source_to_destination_y;
adjusted_destination_right := destination_right + source_delta_right * source_to_destination_x;
adjusted_destination_bottom := destination_bottom + source_delta_bottom * source_to_destination_y;
{ setup clipped destination area }
clipped_destination_left := adjusted_destination_left;
clipped_destination_top := adjusted_destination_top;
clipped_destination_right := adjusted_destination_right;
clipped_destination_bottom := adjusted_destination_bottom;
{ perform clipping on floating point destination area }
TPTCClipper_clip(clipped_destination_left, clipped_destination_top,
clipped_destination_right, clipped_destination_bottom, clip_destination);
clipped_destination_right, clipped_destination_bottom, AClipDestination);
{ check for early destination area clipping exit }
If (clipped_destination_left = clipped_destination_right) Or
(clipped_destination_top = clipped_destination_bottom)
Then
(clipped_destination_top = clipped_destination_bottom) Then
Begin
{ clipped area is zero }
tmp1 := TPTCArea.Create(0, 0, 0, 0);
clipped_source.ASSign(tmp1);
clipped_destination.ASSign(tmp1);
AClippedSource.Assign(tmp1);
AClippedDestination.Assign(tmp1);
Exit;
End;
{ calculate deltas in destination clip }
destination_delta_left := clipped_destination_left - adjusted_destination_left;
destination_delta_top := clipped_destination_top - adjusted_destination_top;
destination_delta_right := clipped_destination_right - adjusted_destination_right;
destination_delta_bottom := clipped_destination_bottom - adjusted_destination_bottom;
{ calculate ratio of destination area to source area }
destination_to_source_x := 1 / source_to_destination_x;
destination_to_source_y := 1 / source_to_destination_y;
{ calculate adjusted source area }
adjusted_source_left := clipped_source_left + destination_delta_left * destination_to_source_x;
adjusted_source_top := clipped_source_top + destination_delta_top * destination_to_source_y;
adjusted_source_right := clipped_source_right + destination_delta_right * destination_to_source_x;
adjusted_source_bottom := clipped_source_bottom + destination_delta_bottom * destination_to_source_y;
{ assign adjusted source to clipped source }
clipped_source_left := adjusted_source_left;
clipped_source_top := adjusted_source_top;
clipped_source_right := adjusted_source_right;
clipped_source_bottom := adjusted_source_bottom;
{ round clipped areas to integer coordinates }
TPTCClipper_round(clipped_source_left, clipped_source_top,
clipped_source_right, clipped_source_bottom);
TPTCClipper_round(clipped_destination_left, clipped_destination_top,
clipped_destination_right, clipped_destination_bottom);
{ construct clipped area rectangles from rounded floating point areas }
tmp1 := TPTCArea.Create(Trunc(clipped_source_left),
Trunc(clipped_source_top),
@ -234,8 +255,8 @@ Begin
Trunc(clipped_destination_top),
Trunc(clipped_destination_right),
Trunc(clipped_destination_bottom));
clipped_source.ASSign(tmp1);
clipped_destination.ASSign(tmp2);
AClippedSource.Assign(tmp1);
AClippedDestination.Assign(tmp2);
Finally
tmp1.Free;
tmp2.Free;

36
packages/extra/ptc/colord.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -21,24 +21,22 @@
Type
TPTCColor=Class(TObject)
Private
m_index : Integer;
m_r, m_g, m_b, m_a : Single;
m_direct : Boolean;
m_indexed : Boolean;
FIndex : Integer;
FRed, FGreen, FBlue, FAlpha : Single;
FDirect : Boolean;
FIndexed : Boolean;
Public
Constructor Create;
Constructor Create(_index : Integer);
Constructor Create(_r, _g, _b, _a : Real);
Constructor Create(_r, _g, _b : Real);
Constructor Create(Const color : TPTCColor);
Destructor Destroy; Override;
Procedure Assign(Const color : TPTCColor);
Function Equals(Const color : TPTCColor) : Boolean;
Property index : Integer read m_index;
Property r : Single read m_r;
Property g : Single read m_g;
Property b : Single read m_b;
Property a : Single read m_a;
Property direct : Boolean read m_direct;
Property indexed : Boolean read m_indexed;
Constructor Create(AIndex : Integer);
Constructor Create(ARed, AGreen, ABlue : Single; AAlpha : Single = 1);
Constructor Create(Const AColor : TPTCColor);
Procedure Assign(Const AColor : TPTCColor);
Function Equals(Const AColor : TPTCColor) : Boolean;
Property Index : Integer Read FIndex;
Property R : Single Read FRed;
Property G : Single Read FGreen;
Property B : Single Read FBlue;
Property A : Single Read FAlpha;
Property Direct : Boolean Read FDirect;
Property Indexed : Boolean Read FIndexed;
End;

114
packages/extra/ptc/colori.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -21,89 +21,71 @@
Constructor TPTCColor.Create;
Begin
m_indexed := False;
m_direct := False;
m_index := 0;
m_r := 0;
m_g := 0;
m_b := 0;
m_a := 1;
FIndexed := False;
FDirect := False;
FIndex := 0;
FRed := 0;
FGreen := 0;
FBlue := 0;
FAlpha := 1;
End;
Constructor TPTCColor.Create(_index : Integer);
Constructor TPTCColor.Create(AIndex : Integer);
Begin
m_indexed := True;
m_direct := False;
m_index := _index;
m_r := 0;
m_g := 0;
m_b := 0;
m_a := 1;
FIndexed := True;
FDirect := False;
FIndex := AIndex;
FRed := 0;
FGreen := 0;
FBlue := 0;
FAlpha := 1;
End;
Constructor TPTCColor.Create(_r, _g, _b, _a : Real);
Constructor TPTCColor.Create(ARed, AGreen, ABlue : Single; AAlpha : Single = 1);
Begin
m_indexed := False;
m_direct := True;
m_index := 0;
m_r := _r;
m_g := _g;
m_b := _b;
m_a := _a;
FIndexed := False;
FDirect := True;
FIndex := 0;
FRed := ARed;
FGreen := AGreen;
FBlue := ABlue;
FAlpha := AAlpha;
End;
Constructor TPTCColor.Create(_r, _g, _b : Real);
Constructor TPTCColor.Create(Const AColor : TPTCColor);
Begin
m_indexed := False;
m_direct := True;
m_index := 0;
m_r := _r;
m_g := _g;
m_b := _b;
m_a := 1;
FIndex := AColor.FIndex;
FRed := AColor.FRed;
FGreen := AColor.FGreen;
FBlue := AColor.FBlue;
FAlpha := AColor.FAlpha;
FDirect := AColor.FDirect;
FIndexed := AColor.FIndexed;
End;
Constructor TPTCColor.Create(Const color : TPTCColor);
Procedure TPTCColor.Assign(Const AColor : TPTCColor);
Begin
ASSign(color);
FIndex := AColor.FIndex;
FRed := AColor.FRed;
FGreen := AColor.FGreen;
FBlue := AColor.FBlue;
FAlpha := AColor.FAlpha;
FDirect := AColor.FDirect;
FIndexed := AColor.FIndexed;
End;
Destructor TPTCColor.Destroy;
Function TPTCColor.Equals(Const AColor : TPTCColor) : Boolean;
Begin
Inherited Destroy;
End;
Procedure TPTCColor.Assign(Const color : TPTCColor);
Begin
If Self = color Then
Raise TPTCError.Create('self assignment is not allowed');
m_index := color.index;
m_r := color.r;
m_g := color.g;
m_b := color.b;
m_a := color.a;
m_direct := color.direct;
m_indexed := color.indexed;
End;
Function TPTCColor.Equals(Const color : TPTCColor) : Boolean;
Begin
If m_direct And color.m_direct Then
If (m_r = color.m_r) And (m_g = color.m_g) And
(m_b = color.m_b) And (m_a = color.m_a) Then
Equals := True
Else
Equals := False
Else
If m_index = color.m_index Then
Equals := True
Else
Equals := False;
Result := (FIndexed = AColor.FIndexed) And
(FDirect = AColor.FDirect) And
(FIndex = AColor.FIndex) And
(FRed = AColor.FRed) And
(FGreen = AColor.FGreen) And
(FBlue = AColor.FBlue) And
(FAlpha = AColor.FAlpha);
End;

28
packages/extra/ptc/consoled.inc
View File

@ -22,13 +22,13 @@ Type
TPTCConsole=Class(TPTCBaseConsole)
Private
Function ConsoleCreate(index : Integer) : TPTCBaseConsole;
Function ConsoleCreate(Const _name : String) : TPTCBaseConsole;
Function ConsoleCreate(Const AName : String) : TPTCBaseConsole;
Procedure check;
console : TPTCBaseConsole;
m_modes : Array[0..1023] Of TPTCMode;
hacky_option_console_flag : Boolean;
Public
Constructor Create;
Constructor Create; Override;
Destructor Destroy; Override;
Procedure configure(Const _file : String); Override;
Function option(Const _option : String) : Boolean; Override;
@ -74,18 +74,18 @@ Type
Procedure clear(Const color : TPTCColor;
Const _area : TPTCArea); Override;
Procedure palette(Const _palette : TPTCPalette); Override;
Function palette : TPTCPalette; Override;
Procedure clip(Const _area : TPTCArea); Override;
Function width : Integer; Override;
Function height : Integer; Override;
Function pitch : Integer; Override;
Function pages : Integer; Override;
Function area : TPTCArea; Override;
Function clip : TPTCArea; Override;
Function format : TPTCFormat; Override;
Function name : String; Override;
Function title : String; Override;
Function information : String; Override;
Function Palette : TPTCPalette; Override;
Procedure Clip(Const _area : TPTCArea); Override;
Function GetWidth : Integer; Override;
Function GetHeight : Integer; Override;
Function GetPitch : Integer; Override;
Function GetPages : Integer; Override;
Function GetArea : TPTCArea; Override;
Function Clip : TPTCArea; Override;
Function GetFormat : TPTCFormat; Override;
Function GetName : String; Override;
Function GetTitle : String; Override;
Function GetInformation : String; Override;
Function NextEvent(Var event : TPTCEvent; wait : Boolean; Const EventMask : TPTCEventMask) : Boolean; Override;
Function PeekEvent(wait : Boolean; Const EventMask : TPTCEventMask) : TPTCEvent; Override;
End;

217
packages/extra/ptc/consolei.inc
View File

@ -18,6 +18,47 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
Const
{$IFDEF GO32V2}
ConsoleTypesNumber = 4;
{$ENDIF GO32V2}
{$IFDEF Win32}
ConsoleTypesNumber = 2;
{$ENDIF Win32}
{$IFDEF WinCE}
ConsoleTypesNumber = 2;
{$ENDIF WinCE}
{$IFDEF UNIX}
ConsoleTypesNumber = 1;
{$ENDIF UNIX}
ConsoleTypes : Array[0..ConsoleTypesNumber - 1] Of
Record
ConsoleClass : Class Of TPTCBaseConsole;
Names : Array[1..2] Of String;
End =
(
{$IFDEF GO32V2}
(ConsoleClass : TVESAConsole; Names : ('VESA', '')),
(ConsoleClass : TVGAConsole; Names : ('VGA', 'Fakemode')),
(ConsoleClass : TCGAConsole; Names : ('CGA', '')),
(ConsoleClass : TTEXTFX2Console; Names : ('TEXTFX2', 'Text'))
{$ENDIF GO32V2}
{$IFDEF Win32}
(ConsoleClass : TDirectXConsole; Names : ('DirectX', '')),
(ConsoleClass : TGDIConsole; Names : ('GDI', ''))
{$ENDIF Win32}
{$IFDEF WinCE}
(ConsoleClass : TWinCEGAPIConsole; Names : ('GAPI', '')),
(ConsoleClass : TWinCEGDIConsole; Names : ('GDI', ''))
{$ENDIF WinCE}
{$IFDEF UNIX}
(ConsoleClass : TX11Console; Names : ('X11', ''))
{$ENDIF UNIX}
);
Constructor TPTCConsole.Create;
Var
@ -33,18 +74,29 @@ Begin
FillChar(m_modes, SizeOf(m_modes), 0);
For I := Low(m_modes) To High(m_modes) Do
m_modes[I] := TPTCMode.Create;
{$IFDEF UNIX}
configure('/usr/share/ptcpas/ptcpas.conf');
s := fpgetenv('HOME');
If s = '' Then
s := '/';
If s[Length(s)] <> '/' Then
s := s + '/';
s := s + '.ptcpas.conf';
configure(s);
{$ELSE UNIX}
configure('ptcpas.cfg');
configure('/usr/share/ptcpas/ptcpas.conf');
s := fpgetenv('HOME');
If s = '' Then
s := '/';
If s[Length(s)] <> '/' Then
s := s + '/';
s := s + '.ptcpas.conf';
configure(s);
{$ENDIF UNIX}
{$IFDEF Win32}
configure('ptcpas.cfg');
{$ENDIF Win32}
{$IFDEF GO32V2}
configure('ptcpas.cfg');
{$ENDIF GO32V2}
{$IFDEF WinCE}
{todo: configure WinCE}
{$ENDIF WinCE}
End;
Destructor TPTCConsole.Destroy;
@ -67,7 +119,7 @@ Var
S : String;
Begin
ASSignFile(F, _file);
AssignFile(F, _file);
{$I-}
Reset(F);
{$I+}
@ -88,7 +140,6 @@ End;
Function TPTCConsole.option(Const _option : String) : Boolean;
Begin
{$IFDEF PTC_LOGGING}
If _option = 'enable logging' Then
Begin
LOG_enabled := True;
@ -101,7 +152,6 @@ Begin
option := True;
Exit;
End;
{$ENDIF PTC_LOGGING}
If Assigned(console) Then
option := console.option(_option)
@ -152,7 +202,7 @@ Begin
local := 0;
While _modes[local].valid Do
Begin
m_modes[mode].ASSign(_modes[local]);
m_modes[mode].Assign(_modes[local]);
Inc(local);
Inc(mode);
End;
@ -164,7 +214,7 @@ Begin
{ todo: strip duplicate modes from list? }
tmp := TPTCMode.Create;
Try
m_modes[mode].ASSign(tmp);
m_modes[mode].Assign(tmp);
Finally
tmp.Free;
End;
@ -213,7 +263,7 @@ Begin
On error : TPTCError Do Begin
tmp := TPTCError.Create(error.message, composite);
Try
composite.ASSign(tmp);
composite.Assign(tmp);
Finally
tmp.Free;
End;
@ -273,7 +323,7 @@ Begin
On error : TPTCError Do Begin
tmp := TPTCError.Create(error.message, composite);
Try
composite.ASSign(tmp);
composite.Assign(tmp);
Finally
tmp.Free;
End;
@ -333,7 +383,7 @@ Begin
On error : TPTCError Do Begin
tmp := TPTCError.Create(error.message, composite);
Try
composite.ASSign(tmp);
composite.Assign(tmp);
Finally
tmp.Free;
End;
@ -393,7 +443,7 @@ Begin
On error : TPTCError Do Begin
tmp := TPTCError.Create(error.message, composite);
Try
composite.ASSign(tmp);
composite.Assign(tmp);
Finally
tmp.Free;
End;
@ -549,99 +599,99 @@ Begin
console.palette(_palette);
End;
Function TPTCConsole.palette : TPTCPalette;
Function TPTCConsole.Palette : TPTCPalette;
Begin
check;
palette := console.palette;
Result := console.Palette;
End;
Procedure TPTCConsole.clip(Const _area : TPTCArea);
Procedure TPTCConsole.Clip(Const _area : TPTCArea);
Begin
check;
console.clip(_area);
End;
Function TPTCConsole.width : Integer;
Function TPTCConsole.GetWidth : Integer;
Begin
check;
width := console.width;
Result := console.GetWidth;
End;
Function TPTCConsole.height : Integer;
Function TPTCConsole.GetHeight : Integer;
Begin
check;
height := console.height;
Result := console.GetHeight;
End;
Function TPTCConsole.pitch : Integer;
Function TPTCConsole.GetPitch : Integer;
Begin
check;
pitch := console.pitch;
Result := console.GetPitch;
End;
Function TPTCConsole.pages : Integer;
Function TPTCConsole.GetPages : Integer;
Begin
check;
pages := console.pages;
Result := console.GetPages;
End;
Function TPTCConsole.area : TPTCArea;
Function TPTCConsole.GetArea : TPTCArea;
Begin
check;
area := console.area;
Result := console.GetArea;
End;
Function TPTCConsole.clip : TPTCArea;
Function TPTCConsole.Clip : TPTCArea;
Begin
check;
clip := console.clip;
Result := console.Clip;
End;
Function TPTCConsole.format : TPTCFormat;
Function TPTCConsole.GetFormat : TPTCFormat;
Begin
check;
format := console.format;
Result := console.GetFormat;
End;
Function TPTCConsole.name : String;
Function TPTCConsole.GetName : String;
Begin
name := '';
Result := '';
If Assigned(console) Then
name := console.name
Result := console.GetName
Else
{$IFDEF GO32V2}
name := 'DOS';
Result := 'DOS';
{$ENDIF GO32V2}
{$IFDEF WIN32}
name := 'Win32';
Result := 'Win32';
{$ENDIF WIN32}
{$IFDEF LINUX}
name := 'Linux';
Result := 'Linux';
{$ENDIF LINUX}
End;
Function TPTCConsole.title : String;
Function TPTCConsole.GetTitle : String;
Begin
check;
title := console.title;
Result := console.GetTitle;
End;
Function TPTCConsole.information : String;
Function TPTCConsole.GetInformation : String;
Begin
check;
information := console.information;
Result := console.GetInformation;
End;
Function TPTCConsole.NextEvent(Var event : TPTCEvent; wait : Boolean; Const EventMask : TPTCEventMask) : Boolean;
@ -661,58 +711,37 @@ End;
Function TPTCConsole.ConsoleCreate(index : Integer) : TPTCBaseConsole;
Begin
{$IFDEF GO32V2}
Case index Of
0 : ConsoleCreate := VESAConsole.Create;
1 : ConsoleCreate := VGAConsole.Create;
2 : ConsoleCreate := CGAConsole.Create;
3 : ConsoleCreate := TEXTFX2Console.Create;
Else
ConsoleCreate := Nil;
End;
{$ENDIF GO32V2}
{$IFDEF WIN32}
Case index Of
0 : ConsoleCreate := TDirectXConsole.Create;
Else
ConsoleCreate := Nil;
End;
{$ENDIF WIN32}
{$IFDEF UNIX}
Case index Of
0 : ConsoleCreate := TX11Console.Create;
Else
ConsoleCreate := Nil;
End;
{$ENDIF UNIX}
If ConsoleCreate <> Nil Then
ConsoleCreate.KeyReleaseEnabled := KeyReleaseEnabled;
Result := Nil;
If (index >= Low(ConsoleTypes)) And (index <= High(ConsoleTypes)) Then
Result := ConsoleTypes[index].ConsoleClass.Create;
If Result <> Nil Then
Result.KeyReleaseEnabled := KeyReleaseEnabled;
End;
Function TPTCConsole.ConsoleCreate(Const _name : String) : TPTCBaseConsole;
Function TPTCConsole.ConsoleCreate(Const AName : String) : TPTCBaseConsole;
Var
I, J : Integer;
Begin
ConsoleCreate := Nil;
{$IFDEF GO32V2}
If _name = 'VESA' Then
ConsoleCreate := VESAConsole.Create;
If (_name = 'VGA') Or (_name = 'Fakemode') Then
ConsoleCreate := VGAConsole.Create;
If (_name = 'TEXTFX2') Or (_name = 'Text') Then
ConsoleCreate := TEXTFX2Console.Create;
If _name = 'CGA' Then
ConsoleCreate := CGAConsole.Create;
{$ENDIF GO32V2}
{$IFDEF WIN32}
If _name = 'DirectX' Then
ConsoleCreate := TDirectXConsole.Create;
{$ENDIF WIN32}
{$IFDEF UNIX}
If _name = 'X11' Then
ConsoleCreate := TX11Console.Create;
{$ENDIF UNIX}
If ConsoleCreate <> Nil Then
ConsoleCreate.KeyReleaseEnabled := KeyReleaseEnabled;
Result := Nil;
If AName = '' Then
Exit;
For I := Low(ConsoleTypes) To High(ConsoleTypes) Do
For J := Low(ConsoleTypes[I].Names) To High(ConsoleTypes[I].Names) Do
If AName = ConsoleTypes[I].Names[J] Then
Begin
Result := ConsoleTypes[I].ConsoleClass.Create;
If Result <> Nil Then
Begin
Result.KeyReleaseEnabled := KeyReleaseEnabled;
Exit;
End;
End;
End;
Procedure TPTCConsole.check;

20
packages/extra/ptc/copyd.inc
View File

@ -21,17 +21,17 @@
Type
TPTCCopy=Class(TObject)
Private
Procedure update;
m_handle : THermesHandle;
m_flags : LongInt;
Procedure Update;
FHandle : THermesHandle;
FFlags : LongInt;
Public
Constructor Create;
Destructor Destroy; Override;
Procedure request(Const source, destination : TPTCFormat);
Procedure palette(Const source, destination : TPTCPalette);
Procedure copy(Const source_pixels : Pointer; source_x, source_y,
source_width, source_height, source_pitch : Integer;
destination_pixels : Pointer; destination_x, destination_y,
destination_width, destination_height, destination_pitch : Integer);
Function option(Const _option : String) : Boolean;
Procedure Request(Const ASource, ADestination : TPTCFormat);
Procedure Palette(Const ASource, ADestination : TPTCPalette);
Procedure Copy(Const ASourcePixels : Pointer; ASourceX, ASourceY,
ASourceWidth, ASourceHeight, ASourcePitch : Integer;
ADestinationPixels : Pointer; ADestinationX, ADestinationY,
ADestinationWidth, ADestinationHeight, ADestinationPitch : Integer);
Function Option(Const AOption : String) : Boolean;
End;

76
packages/extra/ptc/copyi.inc
View File

@ -23,48 +23,45 @@ Constructor TPTCCopy.Create;
Begin
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
m_flags := HERMES_CONVERT_NORMAL;
m_handle := Hermes_ConverterInstance(m_flags);
If m_handle = 0 Then
FFlags := HERMES_CONVERT_NORMAL;
FHandle := Hermes_ConverterInstance(FFlags);
If FHandle = 0 Then
Raise TPTCError.Create('could not create hermes converter instance');
End;
Destructor TPTCCopy.Destroy;
Begin
Hermes_ConverterReturn(m_handle);
Hermes_ConverterReturn(FHandle);
Hermes_Done;
Inherited Destroy;
End;
Procedure TPTCCopy.request(Const source, destination : TPTCFormat);
Procedure TPTCCopy.Request(Const ASource, ADestination : TPTCFormat);
Var
hermes_source_format, hermes_destination_format : PHermesFormat;
Begin
hermes_source_format := @source.Fformat;
hermes_destination_format := @destination.Fformat;
If Not Hermes_ConverterRequest(m_handle, hermes_source_format,
hermes_source_format := @ASource.FFormat;
hermes_destination_format := @ADestination.FFormat;
If Not Hermes_ConverterRequest(FHandle, hermes_source_format,
hermes_destination_format) Then
Raise TPTCError.Create('unsupported hermes pixel format conversion');
End;
Procedure TPTCCopy.palette(Const source, destination : TPTCPalette);
Procedure TPTCCopy.Palette(Const ASource, ADestination : TPTCPalette);
Begin
If Not Hermes_ConverterPalette(m_handle, source.m_handle,
destination.m_handle) Then
If Not Hermes_ConverterPalette(FHandle, ASource.m_handle,
ADestination.m_handle) Then
Raise TPTCError.Create('could not set hermes conversion palettes');
End;
Procedure TPTCCopy.copy(Const source_pixels : Pointer; source_x, source_y,
source_width, source_height, source_pitch : Integer;
destination_pixels : Pointer; destination_x, destination_y,
destination_width, destination_height, destination_pitch : Integer);
Var
source : Pointer;
Procedure TPTCCopy.copy(Const ASourcePixels : Pointer; ASourceX, ASourceY,
ASourceWidth, ASourceHeight, ASourcePitch : Integer;
ADestinationPixels : Pointer; ADestinationX, ADestinationY,
ADestinationWidth, ADestinationHeight, ADestinationPitch : Integer);
Begin
{$IFDEF DEBUG}
@ -84,48 +81,47 @@ Begin
this operation is undefined if the source and destination memory
areas overlap.
}
If source_pixels = Nil Then
If ASourcePixels = Nil Then
Raise TPTCError.Create('nil source pointer in copy');
If destination_pixels = Nil Then
If ADestinationPixels = Nil Then
Raise TPTCError.Create('nil destination pointer in copy');
If source_pixels = destination_pixels Then
If ASourcePixels = ADestinationPixels Then
Raise TPTCError.Create('identical source and destination pointers in copy');
{$ELSE DEBUG}
{ in release build no checking is performed for the sake of efficiency. }
{$ENDIF DEBUG}
source := source_pixels;
If Not Hermes_ConverterCopy(m_handle, source, source_x, source_y,
source_width, source_height, source_pitch, destination_pixels,
destination_x, destination_y, destination_width, destination_height,
destination_pitch) Then
If Not Hermes_ConverterCopy(FHandle, ASourcePixels, ASourceX, ASourceY,
ASourceWidth, ASourceHeight, ASourcePitch, ADestinationPixels,
ADestinationX, ADestinationY, ADestinationWidth, ADestinationHeight,
ADestinationPitch) Then
Raise TPTCError.Create('hermes conversion failure');
End;
Function TPTCCopy.option(Const _option : String) : Boolean;
Function TPTCCopy.Option(Const AOption : String) : Boolean;
Begin
If (_option = 'attempt dithering') And ((m_flags And HERMES_CONVERT_DITHER) = 0) Then
If (AOption = 'attempt dithering') And ((FFlags And HERMES_CONVERT_DITHER) = 0) Then
Begin
m_flags := m_flags Or HERMES_CONVERT_DITHER;
update;
option := True;
FFlags := FFlags Or HERMES_CONVERT_DITHER;
Update;
Result := True;
Exit;
End;
If (_option = 'disable dithering') And ((m_flags And HERMES_CONVERT_DITHER) <> 0) Then
If (AOption = 'disable dithering') And ((FFlags And HERMES_CONVERT_DITHER) <> 0) Then
Begin
m_flags := m_flags And (Not HERMES_CONVERT_DITHER);
update;
option := True;
FFlags := FFlags And (Not HERMES_CONVERT_DITHER);
Update;
Result := True;
Exit;
End;
option := False;
Result := False;
End;
Procedure TPTCCopy.update;
Procedure TPTCCopy.Update;
Begin
Hermes_ConverterReturn(m_handle);
m_handle := Hermes_ConverterInstance(m_flags);
If m_handle = 0 Then
Hermes_ConverterReturn(FHandle);
FHandle := Hermes_ConverterInstance(FFlags);
If FHandle = 0 Then
Raise TPTCError.Create('could not update hermes converter instance');
End;

16
packages/extra/ptc/coreimplementation.inc Normal file
View File

@ -0,0 +1,16 @@
{$INCLUDE errori.inc}
{$INCLUDE areai.inc}
{$INCLUDE colori.inc}
{$INCLUDE formati.inc}
{$INCLUDE eventi.inc}
{$INCLUDE keyeventi.inc}
{$INCLUDE mouseeventi.inc}
{$INCLUDE modei.inc}
{$INCLUDE palettei.inc}
{$INCLUDE cleari.inc}
{$INCLUDE copyi.inc}
{$INCLUDE clipperi.inc}
{$INCLUDE basesurfacei.inc}
{$INCLUDE baseconsolei.inc}
{$INCLUDE surfacei.inc}
{$INCLUDE timeri.inc}

17
packages/extra/ptc/coreinterface.inc Normal file
View File

@ -0,0 +1,17 @@
{$INCLUDE aread.inc}
{$INCLUDE colord.inc}
{$INCLUDE formatd.inc}
{$INCLUDE eventd.inc}
{$INCLUDE keyeventd.inc}
{$INCLUDE mouseeventd.inc}
{$INCLUDE moded.inc}
{$INCLUDE paletted.inc}
{$INCLUDE cleard.inc}
{$INCLUDE copyd.inc}
{$INCLUDE clipperd.inc}
{$INCLUDE basesurfaced.inc}
{$INCLUDE surfaced.inc}
{$INCLUDE baseconsoled.inc}
{$INCLUDE consoled.inc}
{$INCLUDE errord.inc}
{$INCLUDE timerd.inc}

19
packages/extra/ptc/errord.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -21,16 +21,15 @@
Type
TPTCError=Class(TObject)
Private
Procedure defaults;
Fmessage : String;
FMessage : String;
Public
Constructor Create;
Constructor Create(Const _message : String);
Constructor Create(Const _message : String; Const error : TPTCError);
Constructor Create(Const error : TPTCError);
Constructor Create(Const AMessage : String);
Constructor Create(Const AMessage : String; Const AError : TPTCError);
Constructor Create(Const AError : TPTCError);
Destructor Destroy; Override;
Procedure Assign(Const error : TPTCError);
Function Equals(Const error : TPTCError) : Boolean;
Procedure report;
Function message : String;
Procedure Assign(Const AError : TPTCError);
Function Equals(Const AError : TPTCError) : Boolean;
Procedure Report;
Property Message : String read FMessage;
End;

69
packages/extra/ptc/errori.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -18,37 +18,30 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
Procedure TPTCError.defaults;
Begin
Fmessage := '';
End;
Constructor TPTCError.Create;
Begin
defaults;
FMessage := '';
End;
Constructor TPTCError.Create(Const _message : String);
Constructor TPTCError.Create(Const AMessage : String);
Begin
Fmessage := _message;
FMessage := AMessage;
LOG('error', Self);
End;
Constructor TPTCError.Create(Const _message : String; Const error : TPTCError);
Constructor TPTCError.Create(Const AMessage : String; Const AError : TPTCError);
Begin
Fmessage := _message + #13 + #10 + error.Fmessage;
FMessage := AMessage + #10 + AError.FMessage;
LOG('composite error', Self);
End;
Constructor TPTCError.Create(Const error : TPTCError);
Constructor TPTCError.Create(Const AError : TPTCError);
Begin
defaults;
ASSign(error);
FMessage := AError.FMessage;
End;
Destructor TPTCError.Destroy;
@ -57,49 +50,51 @@ Begin
Inherited Destroy;
End;
Procedure TPTCError.Assign(Const error : TPTCError);
Procedure TPTCError.Assign(Const AError : TPTCError);
Begin
If Self = error Then
Raise TPTCError.Create('self assignment is not allowed');
Fmessage := error.Fmessage;
FMessage := AError.FMessage;
End;
Function TPTCError.Equals(Const error : TPTCError) : Boolean;
Function TPTCError.Equals(Const AError : TPTCError) : Boolean;
Begin
Equals := (Fmessage = error.Fmessage);
Equals := (FMessage = AError.FMessage);
End;
Procedure TPTCError.report;
Procedure TPTCError.Report;
{$IFDEF WIN32}
{$IFDEF Win32}
Var
txt : ShortString;
{$ENDIF WIN32}
txt : AnsiString;
{$ENDIF Win32}
{$IFDEF WinCE}
Var
txt : WideString;
{$ENDIF WinCE}
Begin
LOG('error report', Self);
{$IFDEF GO32V2}
RestoreTextMode;
Writeln(stderr, Fmessage);
Writeln(stderr, 'error: ', FMessage);
{$ENDIF GO32V2}
{$IFDEF WIN32}
{$IFDEF Win32}
Win32Cursor_resurrect;
txt := Fmessage + #0;
MessageBox(0, @txt[1], 'Error', MB_OK Or MB_ICONERROR Or MB_SETFOREGROUND Or MB_TOPMOST);
{$ENDIF WIN32}
txt := FMessage;
MessageBox(0, PChar(txt), 'Error', MB_OK Or MB_ICONERROR Or MB_SETFOREGROUND Or MB_TOPMOST);
{$ENDIF Win32}
{$IFDEF WinCE}
txt := FMessage;
MessageBox(0, PWideChar(txt), 'Error', MB_OK Or MB_ICONERROR Or MB_SETFOREGROUND Or MB_TOPMOST);
{$ENDIF WinCE}
{$IFDEF UNIX}
Writeln(stderr, 'error: ', Fmessage);
Writeln(stderr, 'error: ', FMessage);
{$ENDIF UNIX}
Halt(1);
End;
Function TPTCError.message : String;
Begin
message := Fmessage;
End;

38
packages/extra/ptc/eventd.inc Normal file
View File

@ -0,0 +1,38 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
TPTCEventType = (PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent});
TPTCEventMask = Set Of TPTCEventType;
TPTCEvent = Class(TObject)
Protected
Function GetType : TPTCEventType; Virtual; Abstract;
Public
Property EventType : TPTCEventType Read GetType;
End;
Const
PTCAnyEvent : TPTCEventMask = [PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent}];
{Type
TPTCExposeEvent = Class(TPTCEvent)
Protected
Function GetType : TPTCEventType; Override;
End;}

141
packages/extra/ptc/eventi.inc Normal file
View File

@ -0,0 +1,141 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
}
{Function TPTCExposeEvent.GetType : TPTCEventType;
Begin
Result := PTCExposeEvent;
End;}
Type
PEventLinkedList = ^TEventLinkedList;
TEventLinkedList = Record
Event : TPTCEvent;
Next : PEventLinkedList;
End;
TEventQueue = Class(TObject)
Private
FHead, FTail : PEventLinkedList;
Public
Constructor Create;
Destructor Destroy; Override;
Procedure AddEvent(event : TPTCEvent);
Function PeekEvent(Const EventMask : TPTCEventMask) : TPTCEvent;
Function NextEvent(Const EventMask : TPTCEventMask) : TPTCEvent;
End;
Constructor TEventQueue.Create;
Begin
FHead := Nil;
FTail := Nil;
End;
Destructor TEventQueue.Destroy;
Var
p, pnext : PEventLinkedList;
Begin
p := FHead;
While p <> Nil Do
Begin
FreeAndNil(p^.Event);
pnext := p^.Next;
Dispose(p);
p := pnext;
End;
Inherited Destroy;
End;
Procedure TEventQueue.AddEvent(event : TPTCEvent);
Var
tmp : PEventLinkedList;
Begin
New(tmp);
FillChar(tmp^, SizeOf(tmp^), 0);
tmp^.Next := Nil;
tmp^.Event := event;
If FTail <> Nil Then
Begin
FTail^.Next := tmp;
FTail := tmp;
End
Else
Begin { FTail = Nil }
FHead := tmp;
FTail := tmp;
End;
End;
Function TEventQueue.PeekEvent(Const EventMask : TPTCEventMask) : TPTCEvent;
Var
p : PEventLinkedList;
Begin
p := FHead;
While p <> Nil Do
Begin
If p^.Event.EventType In EventMask Then
Begin
Result := p^.Event;
Exit;
End;
p := p^.Next;
End;
Result := Nil;
End;
Function TEventQueue.NextEvent(Const EventMask : TPTCEventMask) : TPTCEvent;
Var
prev, p : PEventLinkedList;
Begin
prev := Nil;
p := FHead;
While p <> Nil Do
Begin
If p^.Event.EventType In EventMask Then
Begin
Result := p^.Event;
{ delete the element from the linked list }
If prev <> Nil Then
prev^.Next := p^.Next
Else
FHead := p^.Next;
If p^.Next = Nil Then
FTail := prev;
Dispose(p);
Exit;
End;
prev := p;
p := p^.Next;
End;
Result := Nil;
End;

29
packages/extra/ptc/formatd.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -21,22 +21,25 @@
Type
TPTCFormat=Class(TObject)
Private
Fformat : THermesFormat;
FFormat : THermesFormat;
Function GetDirect : Boolean;
Function GetBytes : Integer;
Public
Constructor Create;
Constructor Create(_bits : Integer);
Constructor Create(_bits : Integer; _r, _g, _b : int32);
Constructor Create(_bits : Integer; _r, _g, _b, _a : int32);
Constructor Create(ABits : Integer);
Constructor Create(ABits : Integer;
ARedMask, AGreenMask, ABlueMask : Uint32;
AAlphaMask : Uint32 = 0);
Constructor Create(Const format : TPTCFormat);
Destructor Destroy; Override;
Procedure Assign(Const format : TPTCFormat);
Function Equals(Const format : TPTCFormat) : Boolean;
Property r : int32 read Fformat.r;
Property g : int32 read Fformat.g;
Property b : int32 read Fformat.b;
Property a : int32 read Fformat.a;
Property bits : Integer read Fformat.bits;
Property indexed : Boolean read Fformat.indexed;
Function direct : Boolean;
Function bytes : Integer;
Property R : Uint32 read FFormat.r;
Property G : Uint32 read FFormat.g;
Property B : Uint32 read FFormat.b;
Property A : Uint32 read FFormat.a;
Property Bits : Integer read FFormat.bits;
Property Indexed : Boolean read FFormat.indexed;
Property Direct : Boolean read GetDirect;
Property Bytes : Integer read GetBytes;
End;

85
packages/extra/ptc/formati.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -22,72 +22,54 @@ Constructor TPTCFormat.Create;
Begin
{ defaults }
Fformat.r := 0;
Fformat.g := 0;
Fformat.b := 0;
Fformat.a := 0;
Fformat.bits := 0;
Fformat.indexed := False;
FFormat.r := 0;
FFormat.g := 0;
FFormat.b := 0;
FFormat.a := 0;
FFormat.bits := 0;
FFormat.indexed := False;
{ initialize hermes }
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
End;
Constructor TPTCFormat.Create(_bits : Integer);
Constructor TPTCFormat.Create(ABits : Integer);
Begin
{ check bits per pixel }
If _bits <> 8 Then
If ABits <> 8 Then
Raise TPTCError.Create('unsupported bits per pixel');
{ indexed color }
Fformat.r := 0;
Fformat.g := 0;
Fformat.b := 0;
Fformat.a := 0;
Fformat.bits := _bits;
Fformat.indexed := True;
FFormat.r := 0;
FFormat.g := 0;
FFormat.b := 0;
FFormat.a := 0;
FFormat.bits := ABits;
FFormat.indexed := True;
{ initialize hermes }
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
End;
Constructor TPTCFormat.Create(_bits : Integer; _r, _g, _b, _a : int32);
Constructor TPTCFormat.Create(ABits : Integer;
ARedMask, AGreenMask, ABlueMask : Uint32;
AAlphaMask : Uint32 = 0);
Begin
{ check bits per pixel }
If ((_bits And 7) <> 0) Or (_bits <= 0) Or (_bits > 32) Then
If ((ABits And 7) <> 0) Or (ABits <= 0) Or (ABits > 32) Then
Raise TPTCError.Create('unsupported bits per pixel');
{ direct color }
Fformat.r := _r;
Fformat.g := _g;
Fformat.b := _b;
Fformat.a := _a;
Fformat.bits := _bits;
Fformat.indexed := False;
{ initialize hermes }
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
End;
Constructor TPTCFormat.Create(_bits : Integer; _r, _g, _b : int32);
Begin
{ check bits per pixel }
If ((_bits And 7) <> 0) Or (_bits <= 0) Or (_bits > 32) Then
Raise TPTCError.Create('unsupported bits per pixel');
{ direct color }
Fformat.r := _r;
Fformat.g := _g;
Fformat.b := _b;
Fformat.a := 0;
Fformat.bits := _bits;
Fformat.indexed := False;
FFormat.r := ARedMask;
FFormat.g := AGreenMask;
FFormat.b := ABlueMask;
FFormat.a := AAlphaMask;
FFormat.bits := ABits;
FFormat.indexed := False;
{ initialize hermes }
If Not Hermes_Init Then
@ -101,9 +83,10 @@ Begin
If Not Hermes_Init Then
Raise TPTCError.Create('could not initialize hermes');
Hermes_FormatCopy(@format.Fformat, @Fformat)
Hermes_FormatCopy(@format.FFormat, @FFormat)
End;
{$INFO TODO: check what happens if Hermes_Init blows up in the constructor...}
Destructor TPTCFormat.Destroy;
Begin
@ -115,24 +98,24 @@ Procedure TPTCFormat.Assign(Const format : TPTCFormat);
Begin
If Self = format Then
Raise TPTCError.Create('self assignment is not allowed');
Hermes_FormatCopy(@format.Fformat, @Fformat)
Exit;
Hermes_FormatCopy(@format.Fformat, @Fformat);
End;
Function TPTCFormat.Equals(Const format : TPTCFormat) : Boolean;
Begin
Equals := Hermes_FormatEquals(@format.Fformat, @Fformat);
Result := Hermes_FormatEquals(@format.FFormat, @FFormat);
End;
Function TPTCFormat.direct : Boolean;
Function TPTCFormat.GetDirect : Boolean;
Begin
direct := Not Fformat.indexed;
Result := Not FFormat.indexed;
End;
Function TPTCFormat.bytes : Integer;
Function TPTCFormat.GetBytes : Integer;
Begin
bytes := Fformat.bits Shr 3;
Result := FFormat.bits Shr 3;
End;

166
packages/extra/ptc/keyeventd.inc Normal file
View File

@ -0,0 +1,166 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
TPTCKeyEvent=Class(TPTCEvent)
Private
FCode : Integer;
FUnicode : Integer;
FAlt : Boolean;
FShift : Boolean;
FControl : Boolean;
FPress : Boolean;
Function GetRelease : Boolean;
Protected
Function GetType : TPTCEventType; Override;
Public
Constructor Create;
Constructor Create(ACode : Integer);
Constructor Create(ACode, AUnicode : Integer);
Constructor Create(ACode, AUnicode : Integer; APress : Boolean);
Constructor Create(ACode : Integer; AAlt, AShift, AControl : Boolean);
Constructor Create(ACode : Integer; AAlt, AShift, AControl, APress : Boolean);
Constructor Create(ACode, AUnicode : Integer;
AAlt, AShift, AControl : Boolean);
Constructor Create(ACode, AUnicode : Integer;
AAlt, AShift, AControl, APress : Boolean);
Constructor Create(Const AKey : TPTCKeyEvent);
Procedure Assign(Const AKey : TPTCKeyEvent);
Function Equals(Const AKey : TPTCKeyEvent) : Boolean;
Property Code : Integer read FCode;
Property Unicode : Integer read FUnicode;
Property Alt : Boolean read FAlt;
Property Shift : Boolean read FShift;
Property Control : Boolean read FControl;
Property Press : Boolean read FPress;
Property Release : Boolean read GetRelease;
End;
Const
PTCKEY_UNDEFINED = $00;
PTCKEY_CANCEL = $03;
PTCKEY_BACKSPACE = $08; {'\b'}
PTCKEY_TAB = $09; {'\t'}
PTCKEY_ENTER = $0A; {'\n'}
PTCKEY_CLEAR = $0C;
PTCKEY_SHIFT = $10;
PTCKEY_CONTROL = $11;
PTCKEY_ALT = $12;
PTCKEY_PAUSE = $13;
PTCKEY_CAPSLOCK = $14;
PTCKEY_KANA = $15;
PTCKEY_FINAL = $18;
PTCKEY_KANJI = $19;
PTCKEY_ESCAPE = $1B;
PTCKEY_CONVERT = $1C;
PTCKEY_NONCONVERT = $1D;
PTCKEY_ACCEPT = $1E;
PTCKEY_MODECHANGE = $1F;
PTCKEY_SPACE = $20;
PTCKEY_PAGEUP = $21;
PTCKEY_PAGEDOWN = $22;
PTCKEY_END = $23;
PTCKEY_HOME = $24;
PTCKEY_LEFT = $25;
PTCKEY_UP = $26;
PTCKEY_RIGHT = $27;
PTCKEY_DOWN = $28;
PTCKEY_COMMA = $2C; {','}
PTCKEY_PERIOD = $2E; {'.'}
PTCKEY_SLASH = $2F; {'/'}
PTCKEY_ZERO = $30;
PTCKEY_ONE = $31;
PTCKEY_TWO = $32;
PTCKEY_THREE = $33;
PTCKEY_FOUR = $34;
PTCKEY_FIVE = $35;
PTCKEY_SIX = $36;
PTCKEY_SEVEN = $37;
PTCKEY_EIGHT = $38;
PTCKEY_NINE = $39;
PTCKEY_SEMICOLON = $3B; {';'}
PTCKEY_EQUALS = $3D; {'='}
PTCKEY_A = $41;
PTCKEY_B = $42;
PTCKEY_C = $43;
PTCKEY_D = $44;
PTCKEY_E = $45;
PTCKEY_F = $46;
PTCKEY_G = $47;
PTCKEY_H = $48;
PTCKEY_I = $49;
PTCKEY_J = $4A;
PTCKEY_K = $4B;
PTCKEY_L = $4C;
PTCKEY_M = $4D;
PTCKEY_N = $4E;
PTCKEY_O = $4F;
PTCKEY_P = $50;
PTCKEY_Q = $51;
PTCKEY_R = $52;
PTCKEY_S = $53;
PTCKEY_T = $54;
PTCKEY_U = $55;
PTCKEY_V = $56;
PTCKEY_W = $57;
PTCKEY_X = $58;
PTCKEY_Y = $59;
PTCKEY_Z = $5A;
PTCKEY_OPENBRACKET = $5B; {'['}
PTCKEY_BACKSLASH = $5C; {'\'}
PTCKEY_CLOSEBRACKET = $5D; {']'}
PTCKEY_NUMPAD0 = $60;
PTCKEY_NUMPAD1 = $61;
PTCKEY_NUMPAD2 = $62;
PTCKEY_NUMPAD3 = $63;
PTCKEY_NUMPAD4 = $64;
PTCKEY_NUMPAD5 = $65;
PTCKEY_NUMPAD6 = $66;
PTCKEY_NUMPAD7 = $67;
PTCKEY_NUMPAD8 = $68;
PTCKEY_NUMPAD9 = $69;
PTCKEY_MULTIPLY = $6A; {numpad '*'}
PTCKEY_ADD = $6B; {numpad '+'}
PTCKEY_SEPARATOR = $6C;
PTCKEY_SUBTRACT = $6D; {numpad '-'}
PTCKEY_DECIMAL = $6E; {numpad '.'}
PTCKEY_DIVIDE = $6F; {numpad '/'}
PTCKEY_F1 = $70;
PTCKEY_F2 = $71;
PTCKEY_F3 = $72;
PTCKEY_F4 = $73;
PTCKEY_F5 = $74;
PTCKEY_F6 = $75;
PTCKEY_F7 = $76;
PTCKEY_F8 = $77;
PTCKEY_F9 = $78;
PTCKEY_F10 = $79;
PTCKEY_F11 = $7A;
PTCKEY_F12 = $7B;
PTCKEY_DELETE = $7F;
PTCKEY_NUMLOCK = $90;
PTCKEY_SCROLLLOCK = $91;
PTCKEY_PRINTSCREEN = $9A;
PTCKEY_INSERT = $9B;
PTCKEY_HELP = $9C;
PTCKEY_META = $9D;
PTCKEY_BACKQUOTE = $C0;
PTCKEY_QUOTE = $DE;

153
packages/extra/ptc/keyeventi.inc Normal file
View File

@ -0,0 +1,153 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 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
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.
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
}
Function TPTCKeyEvent.GetType : TPTCEventType;
Begin
Result := PTCKeyEvent;
End;
Constructor TPTCKeyEvent.Create;
Begin
FCode := Integer(PTCKEY_UNDEFINED);
FUnicode := -1;
FAlt := False;
FShift := False;
FControl := False;
FPress := True;
End;
Constructor TPTCKeyEvent.Create(ACode : Integer);
Begin
FCode := ACode;
FUnicode := -1;
FAlt := False;
FShift := False;
FControl := False;
FPress := True;
End;
Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer);
Begin
FCode := ACode;
FUnicode := AUnicode;
FAlt := False;
FShift := False;
FControl := False;
FPress := True;
End;
Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer; APress : Boolean);
Begin
FCode := ACode;
FUnicode := AUnicode;
FAlt := False;
FShift := False;
FControl := False;
FPress := APress;
End;
Constructor TPTCKeyEvent.Create(ACode : Integer; AAlt, AShift, AControl : Boolean);
Begin
FCode := ACode;
FUnicode := -1;
FAlt := AAlt;
FShift := AShift;
FControl := AControl;
FPress := True;
End;
Constructor TPTCKeyEvent.Create(ACode : Integer; AAlt, AShift, AControl, APress : Boolean);
Begin
FCode := ACode;
FUnicode := -1;
FAlt := AAlt;
FShift := AShift;
FControl := AControl;
FPress := APress;
End;
Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer; AAlt, AShift, AControl : Boolean);
Begin
FCode := ACode;
FUnicode := AUnicode;
FAlt := AAlt;
FShift := AShift;
FControl := AControl;
FPress := True;
End;
Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer;
AAlt, AShift, AControl, APress : Boolean);
Begin
FCode := ACode;
FUnicode := AUnicode;
FAlt := AAlt;
FShift := AShift;
FControl := AControl;
FPress := APress;
End;
Constructor TPTCKeyEvent.Create(Const AKey : TPTCKeyEvent);
Begin
FCode := AKey.Code;
FUnicode := AKey.Unicode;
FAlt := AKey.Alt;
FShift := AKey.Shift;
FControl := AKey.Control;
FPress := AKey.Press;
End;
Procedure TPTCKeyEvent.Assign(Const AKey : TPTCKeyEvent);
Begin
FCode := AKey.Code;
FUnicode := AKey.Unicode;
FAlt := AKey.Alt;
FShift := AKey.Shift;
FControl := AKey.Control;
FPress := AKey.Press;
End;
Function TPTCKeyEvent.Equals(Const AKey : TPTCKeyEvent) : Boolean;
Begin
Result := (FCode = AKey.FCode) And
(FUnicode = AKey.FUnicode) And
(FAlt = AKey.FAlt) And
(FShift = AKey.FShift) And
(FControl = AKey.FControl) And
(FPress = AKey.FPress);
End;
Function TPTCKeyEvent.GetRelease : Boolean;
Begin
Result := Not FPress;
End;

107
packages/extra/ptc/log.inc
View File

@ -18,24 +18,53 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
{$IFDEF PTC_LOGGING}
{$IFNDEF WinCE}
Const
LOG_create : Boolean = True;
LOG_enabled : Boolean =
{$IFDEF DEBUG}
True;
{$ELSE DEBUG}
False;
{$ENDIF DEBUG}
LOG_filename = 'ptcpas.log';
{$ELSE WinCE}
Function LOG_filename : WideString;
Var
RequiredBufferLength : DWord;
ReturnedPathLength : DWord;
TempPathBuf : PWideChar;
dummy : Byte;
Begin
RequiredBufferLength := GetTempPathW(0, @dummy);
TempPathBuf := GetMem(RequiredBufferLength * SizeOf(WideChar));
Try
ReturnedPathLength := GetTempPathW(RequiredBufferLength, TempPathBuf);
If ReturnedPathLength > RequiredBufferLength Then
Begin
{ The temp path length increased between 2 consecutive calls to GetTempPath?! }
Result := '';
Exit;
End;
Result := TempPathBuf;
Result := Result + 'ptcpas.log';
Finally
FreeMem(TempPathBuf);
End;
End;
{$ENDIF WinCE}
Var
LOG_create : Boolean = True;
LOG_enabled : Boolean =
{$IFDEF DEBUG}
True;
{$ELSE DEBUG}
False;
{$ENDIF DEBUG}
LOG_file : Text;
Procedure LOG_open;
Begin
ASSignFile(LOG_file, 'ptc.log');
AssignFile(LOG_file, LOG_filename);
If LOG_create Then
Begin
Rewrite(LOG_file);
@ -52,7 +81,7 @@ Begin
CloseFile(LOG_file);
End;
Procedure LOG(message : String);
Procedure LOG(Const message : String);
Begin
If Not LOG_enabled Then
@ -62,7 +91,7 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : Boolean);
Procedure LOG(Const message : String; data : Boolean);
Begin
If Not LOG_enabled Then
@ -76,7 +105,7 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : Integer);
Procedure LOG(Const message : String; data : Integer);
Begin
If Not LOG_enabled Then
@ -86,7 +115,7 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : Double);
Procedure LOG(Const message : String; data : DWord);
Begin
If Not LOG_enabled Then
@ -96,7 +125,7 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : String);
Procedure LOG(Const message : String; data : Int64);
Begin
If Not LOG_enabled Then
@ -106,7 +135,47 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : TPTCFormat);
Procedure LOG(Const message : String; data : QWord);
Begin
If Not LOG_enabled Then
Exit;
LOG_open;
Writeln(LOG_file, message, ' = ', data);
LOG_close;
End;
Procedure LOG(Const message : String; data : Single);
Begin
If Not LOG_enabled Then
Exit;
LOG_open;
Writeln(LOG_file, message, ' = ', data);
LOG_close;
End;
Procedure LOG(Const message : String; data : Double);
Begin
If Not LOG_enabled Then
Exit;
LOG_open;
Writeln(LOG_file, message, ' = ', data);
LOG_close;
End;
Procedure LOG(Const message : String; Const data : String);
Begin
If Not LOG_enabled Then
Exit;
LOG_open;
Writeln(LOG_file, message, ' = ', data);
LOG_close;
End;
Procedure LOG(Const message : String; data : TPTCFormat);
Begin
If Not LOG_enabled Then
@ -129,7 +198,7 @@ Begin
LOG_close;
End;
Procedure LOG(message : String; data : TPTCError);
Procedure LOG(Const message : String; data : TPTCError);
Begin
If Not LOG_enabled Then
@ -138,7 +207,3 @@ Begin
Writeln(LOG_file, message, ': ', data.message);
LOG_close;
End;
{$ELSE PTC_LOGGING}
{$DEFINE LOG:=//}
{$ENDIF PTC_LOGGING}

20
packages/extra/ptc/moded.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -22,19 +22,19 @@ Type
PPTCMode=^TPTCMode;
TPTCMode=Class(TObject)
Private
m_valid : Boolean;
m_width : Integer;
m_height : Integer;
m_format : TPTCFormat;
FValid : Boolean;
FWidth : Integer;
FHeight : Integer;
FFormat : TPTCFormat;
Public
Constructor Create;
Constructor Create(_width, _height : Integer; Const _format : TPTCFormat);
Constructor Create(AWidth, AHeight : Integer; Const AFormat : TPTCFormat);
Constructor Create(Const mode : TPTCMode);
Destructor Destroy; Override;
Procedure Assign(Const mode : TPTCMode);
Function Equals(Const mode : TPTCMode) : Boolean;
Property valid : Boolean read m_valid;
Property width : Integer read m_width;
Property height : Integer read m_height;
Property format : TPTCFormat read m_format;
Property Valid : Boolean read FValid;
Property Width : Integer read FWidth;
Property Height : Integer read FHeight;
Property Format : TPTCFormat read FFormat;
End;

52
packages/extra/ptc/modei.inc
View File

@ -1,6 +1,6 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2001-2006 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
@ -18,57 +18,57 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
Type
TPTCModeDynArray = Array Of TPTCMode;
Constructor TPTCMode.Create;
Begin
m_format := Nil;
m_format := TPTCFormat.Create;
m_valid := False;
m_width := 0;
m_height := 0;
FFormat := TPTCFormat.Create;
FWidth := 0;
FHeight := 0;
FValid := False;
End;
Constructor TPTCMode.Create(_width, _height : Integer; Const _format : TPTCFormat);
Constructor TPTCMode.Create(AWidth, AHeight : Integer; Const AFormat : TPTCFormat);
Begin
m_format := Nil;
m_valid := True;
m_width := _width;
m_height := _height;
m_format := TPTCFormat.Create(_format);
FFormat := TPTCFormat.Create(AFormat);
FWidth := AWidth;
FHeight := AHeight;
FValid := True;
End;
Constructor TPTCMode.Create(Const mode : TPTCMode);
Begin
m_format := Nil;
m_format := TPTCFormat.Create;
ASSign(mode);
FFormat := TPTCFormat.Create(mode.FFormat);
FWidth := mode.FWidth;
FHeight := mode.FHeight;
FValid := mode.FValid;
End;
Destructor TPTCMode.Destroy;
Begin
m_format.Free;
FFormat.Free;
Inherited Destroy;
End;
Procedure TPTCMode.Assign(Const mode : TPTCMode);
Begin
If Self = mode Then
Raise TPTCError.Create('self assignment is not allowed');
m_valid := mode.valid;
m_width := mode.width;
m_height := mode.height;
m_format.ASSign(mode.format);
FFormat.Assign(mode.FFormat);
FWidth := mode.FWidth;
FHeight := mode.FHeight;
FValid := mode.FValid;
End;
Function TPTCMode.Equals(Const mode : TPTCMode) : Boolean;
Begin
Equals := (m_valid = mode.m_valid) And
(m_width = mode.m_width) And
(m_height = mode.m_height) And
m_format.Equals(mode.m_format);
Result := (FValid = mode.FValid) And
(FWidth = mode.FWidth) And
(FHeight = mode.FHeight) And
FFormat.Equals(mode.FFormat);
End;

56
packages/extra/ptc/mouseeventd.inc Normal file
View File

@ -0,0 +1,56 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2006 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
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.
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
{todo TPTCMouseCursor = (PTCMouseCursorDefault,
PTCMouseCursorAlwaysVisible,
PTCMouseCursorAlwaysInvisible);}
TPTCMouseButton = (PTCMouseButton1, { left mouse button }
PTCMouseButton2, { right mouse button }
PTCMouseButton3, { middle mouse button }
PTCMouseButton4,
PTCMouseButton5);
TPTCMouseButtonState = Set Of TPTCMouseButton;
TPTCMouseEvent = Class(TPTCEvent)
Private
FX, FY : Integer;
FDeltaX, FDeltaY : Integer;
FButtonState : TPTCMouseButtonState;
Protected
Function GetType : TPTCEventType; Override;
Public
Constructor Create(AX, AY, ADeltaX, ADeltaY : Integer; AButtonState : TPTCMouseButtonState);
Property X : Integer Read FX;
Property Y : Integer Read FY;
Property DeltaX : Integer Read FDeltaX;
Property DeltaY : Integer Read FDeltaY;
Property ButtonState : TPTCMouseButtonState Read FButtonState;
End;
TPTCMouseButtonEvent = Class(TPTCMouseEvent)
Private
FPress : Boolean;
FButton : TPTCMouseButton;
Function GetRelease : Boolean;
Public
Constructor Create(AX, AY, ADeltaX, ADeltaY : Integer; AButtonState : TPTCMouseButtonState; APress : Boolean; AButton : TPTCMouseButton);
Property Press : Boolean Read FPress;
Property Release : Boolean Read GetRelease;
Property Button : TPTCMouseButton Read FButton;
End;

53
packages/extra/ptc/mouseeventi.inc Normal file
View File

@ -0,0 +1,53 @@
{
Free Pascal port of the OpenPTC C++ library.
Copyright (C) 2001-2006 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
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.
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
}
Function TPTCMouseEvent.GetType : TPTCEventType;
Begin
Result := PTCMouseEvent;
End;
Constructor TPTCMouseEvent.Create(AX, AY, ADeltaX, ADeltaY : Integer; AButtonState : TPTCMouseButtonState);
Begin
FX := AX;
FY := AY;
FDeltaX := ADeltaX;
FDeltaY := ADeltaY;
FButtonState := AButtonState;
End;
Constructor TPTCMouseButtonEvent.Create(AX, AY, ADeltaX, ADeltaY : Integer; AButtonState : TPTCMouseButtonState; APress : Boolean; AButton : TPTCMouseButton);
Begin
If APress Xor (AButton In AButtonState) Then
Raise TPTCError.Create('Invalid ButtonState');
Inherited Create(AX, AY, ADeltaX, ADeltaY, AButtonState);
FPress := APress;
FButton := AButton;
End;
Function TPTCMouseButtonEvent.GetRelease : Boolean;
Begin
Result := Not FPress;
End;

2
packages/extra/ptc/palettei.inc
View File

@ -55,7 +55,7 @@ Begin
m_handle := Hermes_PaletteInstance;
If m_handle = 0 Then
Raise TPTCError.Create('could not create hermes palette instance');
ASSign(palette);
Assign(palette);
End;
Destructor TPTCPalette.Destroy;

14
packages/extra/ptc/surfaced.inc
View File

@ -64,13 +64,13 @@ Type
Procedure clear(Const color : TPTCColor); Override;
Procedure clear(Const color : TPTCColor; Const _area : TPTCArea); Override;
Procedure palette(Const _palette : TPTCPalette); Override;
Function palette : TPTCPalette; Override;
Function Palette : TPTCPalette; Override;
Procedure clip(Const _area : TPTCArea); Override;
Function width : Integer; Override;
Function height : Integer; Override;
Function pitch : Integer; Override;
Function area : TPTCArea; Override;
Function clip : TPTCArea; Override;
Function format : TPTCFormat; Override;
Function GetWidth : Integer; Override;
Function GetHeight : Integer; Override;
Function GetPitch : Integer; Override;
Function GetArea : TPTCArea; Override;
Function Clip : TPTCArea; Override;
Function GetFormat : TPTCFormat; Override;
Function option(Const _option : String) : Boolean; Override;
End;

32
packages/extra/ptc/surfacei.inc
View File

@ -266,10 +266,10 @@ Begin
m_palette.load(_palette.data^);
End;
Function TPTCSurface.palette : TPTCPalette;
Function TPTCSurface.Palette : TPTCPalette;
Begin
palette := m_palette;
Result := m_palette;
End;
Procedure TPTCSurface.clip(Const _area : TPTCArea);
@ -280,50 +280,50 @@ Var
Begin
tmp := TPTCClipper.clip(_area, m_area);
Try
m_clip.ASSign(tmp);
m_clip.Assign(tmp);
Finally
tmp.Free;
End;
End;
Function TPTCSurface.width : Integer;
Function TPTCSurface.GetWidth : Integer;
Begin
width := m_width;
Result := m_width;
End;
Function TPTCSurface.height : Integer;
Function TPTCSurface.GetHeight : Integer;
Begin
height := m_height;
Result := m_height;
End;
Function TPTCSurface.pitch : Integer;
Function TPTCSurface.GetPitch : Integer;
Begin
pitch := m_pitch;
Result := m_pitch;
End;
Function TPTCSurface.area : TPTCArea;
Function TPTCSurface.GetArea : TPTCArea;
Begin
area := m_area;
Result := m_area;
End;
Function TPTCSurface.clip : TPTCArea;
Function TPTCSurface.Clip : TPTCArea;
Begin
clip := m_clip;
Result := m_clip;
End;
Function TPTCSurface.format : TPTCFormat;
Function TPTCSurface.GetFormat : TPTCFormat;
Begin
format := m_format;
Result := m_format;
End;
Function TPTCSurface.option(Const _option : String) : Boolean;
Begin
option := m_copy.option(_option);
Result := m_copy.option(_option);
End;

33
packages/extra/ptc/timeri.inc
View File

@ -47,7 +47,7 @@ Constructor TPTCTimer.Create(Const timer : TPTCTimer);
Begin
internal_init_timer;
ASSign(timer);
Assign(timer);
End;
Destructor TPTCTimer.Destroy;
@ -74,8 +74,8 @@ Function TPTCTimer.Equals(Const timer : TPTCTimer) : Boolean;
Begin
Equals := (m_old = timer.m_old) And (m_time = timer.m_time) And
(m_start = timer.m_start) And (m_current = timer.m_current) And
(m_running = timer.m_running);
(m_start = timer.m_start) And (m_current = timer.m_current) And
(m_running = timer.m_running);
End;
Procedure TPTCTimer.settime(_time : Double);
@ -144,14 +144,17 @@ Function TPTCTimer.resolution : Double;
Begin
{$IFDEF GO32V2}
resolution := TimerResolution;
Result := TimerResolution;
{$ENDIF GO32V2}
{$IFDEF WIN32}
resolution := 1 / m_frequency;
{ resolution := 1 / 1000;}
{$ENDIF WIN32}
{$IFDEF Win32}
Result := 1 / m_frequency;
{ Result := 1 / 1000;}
{$ENDIF Win32}
{$IFDEF WinCE}
Result := 1 / 1000;
{$ENDIF WinCE}
{$IFDEF UNIX}
resolution := 1 / 1000000;
Result := 1 / 1000000;
{$ENDIF UNIX}
End;
@ -177,7 +180,7 @@ Begin
End;
{$ENDIF GO32V2}
{$IFDEF WIN32}
{$IFDEF Win32}
Function TPTCTimer.clock : Double;
Var
@ -188,7 +191,15 @@ Begin
clock := _time / m_frequency;
{ clock := timeGetTime / 1000;}
End;
{$ENDIF WIN32}
{$ENDIF Win32}
{$IFDEF WinCE}
Function TPTCTimer.clock : Double;
Begin
Result := GetTickCount / 1000;
End;
{$ENDIF WinCE}
{$IFDEF UNIX}
Function TPTCTimer.clock : Double;