freepascal
/
utils
1
0
Fork 0
Code Issues 0 Pull-Requests 0 Releases 0 Wiki Aktivität
Quellcode durchsuchen

* implemented uutlAlgorithm

master
Bergmann89 vor 9 Jahren
Ursprung
835a257870
Commit
f5850af740
6 geänderte Dateien mit 610 neuen und 616 gelöschten Zeilen
Geteilte Ansicht
Diff-Optionen
Statistiken anzeigen Patch-Datei herunterladen Vergleichs-Datei herunterladen
  1. +132
    -0
      uutlAlgorithm.pas
  2. +1
    -1
      uutlEvent.pas
  3. +284
    -449
      uutlEventManager.pas
  4. +2
    -165
      uutlGenerics.pas
  5. +190
    -0
      uutlInterfaces.pas
  6. +1
    -1
      uutlObservableGenerics.pas

+ 132
- 0
uutlAlgorithm.pas Datei anzeigen

@@ -0,0 +1,132 @@
unit uutlAlgorithm;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils,
uutlInterfaces;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic TutlQuickSort<T> = class(TObject)
public type
IList = specialize IutlList<T>;
IComparer = specialize IutlComparer<T>;

private
class procedure DoSort(
aList: IList;
aComparer: IComparer;
aLow: Integer;
aHigh: Integer);

public
class procedure Sort(
aList: IList;
aComparer: IComparer);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic TutlBinarySearch<T> = class(TObject)
public type
IList = specialize IutlReadOnlyList<T>;
IComparer = specialize IutlComparer<T>;

private
class function DoSearch(
aList: IList;
aComparer: IComparer;
const aMin: Integer;
const aMax: Integer;
constref aItem: T;
out aIndex: Integer): Boolean;

public
class function Search(
aList: IList;
aComparer: IComparer;
constref aItem: T;
out aIndex: Integer): Boolean;
end;

implementation

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlQuickSort//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlQuickSort.DoSort(aList: IList; aComparer: IComparer; aLow: Integer; aHigh: Integer);
var
lo, hi: Integer;
p, tmp: T;
begin
repeat
lo := aLow;
hi := aHigh;
p := aList.GetItem((aLow + aHigh) div 2);
repeat
while (aComparer.Compare(p, aList.GetItem(lo)) > 0) do
lo := lo + 1;
while (aComparer.Compare(p, aList.GetItem(hi)) < 0) do
hi := hi - 1;
if (lo <= hi) then begin
tmp := aList.GetItem(lo);
aList.SetItem(lo, aList.GetItem(hi));
aList.SetItem(hi, tmp);
lo := lo + 1;
hi := hi - 1;
end;
until (lo > hi);

if (hi - aLow < aHigh - lo) then begin
if (aLow < hi) then
DoSort(aList, aComparer, aLow, hi);
aLow := lo;
end else begin
if (lo < aHigh) then
DoSort(aList, aComparer, lo, aHigh);
aHigh := hi;
end;
until (aLow >= aHigh);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlQuickSort.Sort(aList: IList; aComparer: IComparer);
begin
DoSort(aList, aComparer, 0, aList.GetCount-1);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlBinarySearch///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlBinarySearch.DoSearch(aList: IList; aComparer: IComparer; const aMin: Integer; const aMax: Integer;
constref aItem: T; out aIndex: Integer): Boolean;
var
i, cmp: Integer;
begin
if (aMin <= aMax) then begin
i := aMin + Trunc((aMax - aMin) / 2);
cmp := aComparer.Compare(aItem, aList.GetItem(i));
if (cmp = 0) then begin
result := true;
aIndex := i;
end else if (cmp < 0) then
result := DoSearch(aList, aComparer, aMin, i-1, aItem, aIndex)
else if (cmp > 0) then
result := DoSearch(aList, aComparer, i+1, aMax, aItem, aIndex);
end else begin
result := false;
aIndex := aMin;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlBinarySearch.Search(aList: IList; aComparer: IComparer; constref aItem: T;
out aIndex: Integer): Boolean;
begin
result := DoSearch(aList, aComparer, 0, aList.GetCount-1, aItem, aIndex);
end;

end.


+ 1
- 1
uutlEvent.pas Datei anzeigen

@@ -54,7 +54,7 @@ type
public
property Empty: Boolean read GetEmpty;

procedure DispatchEvent(const aEvent: IutlEvent);
procedure DispatchEvent(const aEvent: IutlEvent); virtual;

function RegisterListener(const aListener: IutlEventListener): Boolean;
function UnregisterListener(const aListener: IutlEventListener): Boolean;


+ 284
- 449
uutlEventManager.pas Datei anzeigen

@@ -9,170 +9,162 @@ unit uutlEventManager;
interface

uses
Classes, SysUtils, syncobjs, Controls,
uutlGenerics;
Classes, SysUtils, Controls,
uutlEvent;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlEventManager = class(TObject)
public type
TEventType = 0..63;
TEventTypeMask = UInt64;

////////////////////////////////////////////////////////////////////////////
TEvent = class
public
EventType: TEventType;
Timestamp: QWord;

function Clone: TEvent;
procedure Assign(const aEvent: TEvent); virtual;
constructor Create; virtual;
end;
TEventClass = class of TEvent;
TEventList = specialize TutlList<TEvent>;

////////////////////////////////////////////////////////////////////////////
TEventListener = class(TObject)
public
function DispatchEvent(const aEvent: TEvent): Boolean; virtual;
end;
TEventListenerSet = specialize TutlHashSet<TEventListener>;

////////////////////////////////////////////////////////////////////////////
TEventHandlerCallback = procedure(aSender: TObject; aEvent: TEvent) of object;
TCallbackEventListener = class(TEventListener)
public
Callback: TEventHandlerCallback;
Filter: TEventTypeMask;
function DispatchEvent(const aEvent: TEvent): Boolean; override;
end;

TutlMouseButtons = set of TMouseButton;
TutlWinControlEvent = class(TutlEvent)
private
fEventQueue: TEventList;
fEventQueueLock: TCriticalSection;
fEventListener: TEventListenerSet;

procedure DispatchEvent(const aEvent: TEvent);
protected
procedure PushEvent(const aEvent: TEvent); virtual;
procedure RecordEvent(const aEvent: TEvent); virtual;
fSender: TControl;
public
procedure RegisterListener(const aEventMask: TEventTypeMask; const aCallback: TEventHandlerCallback);
procedure RegisterListener(const aListener: TEventListener);
property Sender: TControl read fSender;
constructor Create(
const aEventType: TutlEventType;
const aSender: TControl);
end;

procedure UnregisterListener(const aHandler: TEventHandlerCallback);
procedure UnregisterListener(const aListener: TEventListener);
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlMouseEvent = class(TutlWinControlEvent)
private
fButtons: TutlMouseButtons;
fClientPos: TPoint;
fScreenPos: TPoint;

procedure DispatchEvents;
public
property Buttons: TutlMouseButtons read fButtons;
property ClientPos: TPoint read fClientPos;
property ScreenPos: TPoint read fScreenPos;

constructor Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aButtons: TutlMouseButtons;
const aClientPos: TPoint);
end;

constructor Create;
destructor Destroy; override;
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlMouseWheelEvent = class(TutlWinControlEvent)
private
fWheelDelta: Integer;
fClientPos: TPoint;
fScreenPos: TPoint;

public
class function MakeMask (const aTypes: array of TEventType): TEventTypeMask;
class function CombineMasks(const aMasks: array of TEventTypeMask): TEventTypeMask;
class function MaskHasType (const aMask: TEventTypeMask; const aType: TEventType): Boolean; inline;
property WheelDelta: Integer read fWheelDelta;
property ClientPos: TPoint read fClientPos;
property ScreenPos: TPoint read fScreenPos;

constructor Create(
const aSender: TControl;
const aWheelDelta: Integer;
const aClientPos: TPoint);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlWinControlEventManager = class(TutlEventManager)
public type
////////////////////////////////////////////////////////////////////////////
TMouseEvent = class(TEvent)
public
Button: TMouseButton;
ClientPos: TPoint;
ScreenPos: TPoint;
procedure Assign(const aEvent: TEvent); override;
end;
TutlKeyEvent = class(TutlWinControlEvent)
private
fCharCode: WideChar;
fKeyCode: Word;

////////////////////////////////////////////////////////////////////////////
TMouseWheelEvent = class(TEvent)
public
WheelDelta: Integer;
ClientPos: TPoint;
ScreenPos: TPoint;
procedure Assign(const aEvent: TEvent); override;
end;
public
property CharCode: WideChar read fCharCode;
property KeyCode: Word read fKeyCode;

constructor Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aCharCode: WideChar;
const aKeyCode: Word);
end;

////////////////////////////////////////////////////////////////////////////
TKeyEvent = class(TEvent)
public
CharCode: WideChar;
KeyCode: Word;
procedure Assign(const aEvent: TEvent); override;
end;
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlWindowEvent = class(TutlWinControlEvent)
private
fScreenRect: TRect;
fClientWidth: Cardinal;
fClientHeight: Cardinal;

////////////////////////////////////////////////////////////////////////////
TWindowEvent = class(TEvent)
public
ScreenRect: TRect;
ClientWidth: Cardinal;
ClientHeight: Cardinal;
procedure Assign(const aEvent: TEvent); override;
end;
public
property ScreenRect: TRect read fScreenRect;
property ClientWidth: Cardinal read fClientWidth;
property ClientHeight: Cardinal read fClientHeight;

constructor Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aScreenRect: TRect;
const aClientWidth: Cardinal;
const aClientHeight: Cardinal);
end;

////////////////////////////////////////////////////////////////////////////
TMouseButtons = set of TMouseButton;
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlWinControlEventManager = class(TutlEventListenerSet)
public const
EVENT_MOUSE_DOWN = 0;
EVENT_MOUSE_UP = 1;
EVENT_MOUSE_WHEEL_UP = 2;
EVENT_MOUSE_WHEEL_DOWN = 3;
EVENT_MOUSE_MOVE = 4;
EVENT_MOUSE_ENTER = 5;
EVENT_MOUSE_LEAVE = 6;
EVENT_MOUSE_CLICK = 7;
EVENT_MOUSE_DBL_CLICK = 8;

EVENT_KEY_DOWN = 10;
EVENT_KEY_REPEAT = 11;
EVENT_KEY_UP = 12;

EVENT_WINDOW_RESIZE = 15;
EVENT_WINDOW_ACTIVATE = 16;
EVENT_WINDOW_DEACTIVATE = 17;

EVENTS_MOUSE: TutlEventTypes = [
EVENT_MOUSE_DOWN,
EVENT_MOUSE_UP,
EVENT_MOUSE_WHEEL_UP,
EVENT_MOUSE_WHEEL_DOWN,
EVENT_MOUSE_MOVE,
EVENT_MOUSE_ENTER,
EVENT_MOUSE_LEAVE,
EVENT_MOUSE_CLICK,
EVENT_MOUSE_DBL_CLICK
];
EVENTS_KEYBOARD: TutlEventTypes = [
EVENT_KEY_DOWN,
EVENT_KEY_REPEAT,
EVENT_KEY_UP
];
EVENTS_WINDOW: TutlEventTypes = [
EVENT_WINDOW_RESIZE,
EVENT_WINDOW_ACTIVATE,
EVENT_WINDOW_DEACTIVATE
];

private type
TKeyboardState = record
Modifiers: TShiftState;
KeyState: array[Byte] of Boolean;
end;

TMouseState = record
ScreenPos, ClientPos: TPoint;
Buttons: TMouseButtons;
ScreenPos: TPoint;
ClientPos: TPoint;
Buttons: TutlMouseButtons;
end;

TWindowState = record
Active: boolean;
Active: Boolean;
ScreenRect: TRect;
ClientWidth: Integer;
ClientHeight: Integer;
end;

public const
MOUSE_DOWN = 0;
MOUSE_UP = 1;
MOUSE_WHEEL_UP = 2;
MOUSE_WHEEL_DOWN = 3;
MOUSE_MOVE = 4;
MOUSE_ENTER = 5;
MOUSE_LEAVE = 6;
MOUSE_CLICK = 7;
MOUSE_DBL_CLICK = 8;

KEY_DOWN = 10;
KEY_REPEAT = 11;
KEY_UP = 12;

WINDOW_RESIZE = 15;
WINDOW_ACTIVATE = 16;
WINDOW_DEACTIVATE = 17;

EVENTS_MOUSE: TEventTypeMask =
(1 shl MOUSE_DOWN) or
(1 shl MOUSE_UP) or
(1 shl MOUSE_WHEEL_UP) or
(1 shl MOUSE_WHEEL_DOWN) or
(1 shl MOUSE_MOVE) or
(1 shl MOUSE_ENTER) or
(1 shl MOUSE_LEAVE) or
(1 shl MOUSE_CLICK) or
(1 shl MOUSE_DBL_CLICK);
EVENTS_KEYBOARD: TEventTypeMask =
(1 shl KEY_DOWN) or
(1 shl KEY_REPEAT) or
(1 shl KEY_UP);
EVENTS_WINDOW: TEventTypeMask =
(1 shl WINDOW_RESIZE) or
(1 shl WINDOW_ACTIVATE) or
(1 shl WINDOW_DEACTIVATE);
private
fKeyboard: TKeyboardState;
fMouse: TMouseState;
fWindow: TWindowState;

private
procedure HandlerMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure HandlerMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure HandlerMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer);
@@ -190,27 +182,41 @@ type
procedure HandlerDeactivate (Sender: TObject);

protected
procedure RecordEvent(const aEvent: TEvent); override;
procedure RecordEvent(const aEvent: IutlEvent); virtual;

protected
function CreateMouseEvent (aEvent: TMouseEvent; aType: TEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint): TMouseEvent; virtual;
function CreateMouseWheelEvent(aEvent: TMouseWheelEvent; aSender: TWinControl; aDelta: Integer; aClientPos: TPoint): TMouseWheelEvent; virtual;
function CreateKeyEvent (aEvent: TKeyEvent; aType: TEventType; aKey: Word): TKeyEvent; virtual;
function CreateWindowEvent (aEvent: TWindowEvent; aType: TEventType; aSender: TControl): TWindowEvent; virtual;
function CreateMouseEvent(
aSender: TObject;
aType: TutlEventType;
aButtons: TutlMouseButtons;
aClientPos: TPoint): TutlMouseEvent; virtual;

function CreateMouseWheelEvent(
aSender: TObject;
aDelta: Integer;
aClientPos: TPoint): TutlMouseWheelEvent; virtual;

function CreateKeyEvent(
aSender: TObject; aType: TutlEventType;
aKey: Word): TutlKeyEvent; virtual;

function CreateWindowEvent(
aSender: TObject;
aType: TutlEventType): TutlWindowEvent; virtual;

public
property Keyboard: TKeyboardState read fKeyboard;
property Mouse: TMouseState read fMouse;
property Window: TWindowState read fWindow;

procedure AttachEvents(const aControl: TWinControl; const aMask: TEventTypeMask);
procedure DispatchEvent(const aEvent: IutlEvent); override;
procedure AttachEvents(const aControl: TWinControl; const aTypes: TutlEventTypes);
end;

implementation

uses
LCLIntf, Forms,
uutlTiming, uutlConversion, uutlKeyCodes;
uutlKeyCodes;

type
TWinControlVisibilityClass = class(TWinControl)
@@ -232,339 +238,167 @@ type
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TEvent.Clone: TEvent;
begin
result := TEventClass(ClassType).Create;
result.Assign(self);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.TEvent.Assign(const aEvent: TEvent);
begin
Timestamp := aEvent.Timestamp;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventManager.TEvent.Create;
begin
inherited Create;
Timestamp := GetMicroTime;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TEventListener////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TEventListener.DispatchEvent(const aEvent: TEvent): Boolean;
begin
result := false;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager.TCallbackEventListener////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventManager.TCallbackEventListener.DispatchEvent(const aEvent: TEvent): Boolean;
begin
result := inherited DispatchEvent(aEvent);
if TutlEventManager.MaskHasType(Filter, aEvent.EventType) then
Callback(self, aEvent);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventManager///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.DispatchEvent(const aEvent: TEvent);
var
l: TEventListener;
begin
for l in fEventListener do begin
if l.DispatchEvent(aEvent) then
break;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.PushEvent(const aEvent: TEvent);
begin
fEventQueueLock.Enter;
try
if Assigned(fEventQueue) then
fEventQueue.Add(aEvent)
else if Assigned(aEvent) then
aEvent.Free;
finally
fEventQueueLock.Leave;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RecordEvent(const aEvent: TEvent);
begin
// DUMMY
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RegisterListener(const aEventMask: TEventTypeMask; const aCallback: TEventHandlerCallback);
var
l: TCallbackEventListener;
begin
UnregisterListener(aCallback);
l := TCallbackEventListener.Create;
try
l.Filter := aEventMask;
l.Callback := aCallback;
RegisterListener(l);
except
FreeAndNil(l);
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.RegisterListener(const aListener: TEventListener);
begin
fEventListener.Add(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.UnregisterListener(const aHandler: TEventHandlerCallback);
var
i: Integer;
m1, m2: TMethod;
cel: TCallbackEventListener;
begin
m1 := TMethod(aHandler);
for i := fEventListener.Count-1 downto 0 do
if Supports(fEventListener[i], TCallbackEventListener, cel) then begin
m2 := TMethod(cel.Callback);
if (m1.Data = m2.Data) and
(m1.Code = m2.Code) then
fEventListener.Delete(i);
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.UnregisterListener(const aListener: TEventListener);
begin
fEventListener.Remove(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventManager.DispatchEvents;
var
e: TEvent;
begin
fEventQueueLock.Acquire;
try
if Assigned(fEventQueue) then begin
for e in fEventQueue do begin
DispatchEvent(e);
RecordEvent(e);
end;
fEventQueue.Clear;
end;
finally
fEventQueueLock.Release;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventManager.Create;
begin
inherited Create;
fEventListener := TEventListenerSet.Create(true);
fEventQueue := TEventList.Create(true);
fEventQueueLock := TCriticalSection.Create;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlEventManager.Destroy;
begin
fEventQueueLock.Enter;
try
FreeAndNil(fEventQueue);
finally
fEventQueueLock.Leave;
end;
FreeAndNil(fEventQueueLock);
FreeAndNil(fEventListener);
inherited Destroy;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.MakeMask(const aTypes: array of TEventType): TEventTypeMask;
var
e: TEventType;
begin
result := 0;
for e in aTypes do
result := result or (1 shl e);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.CombineMasks(const aMasks: array of TEventTypeMask): TEventTypeMask;
var
m: TEventTypeMask;
begin
result := 0;
for m in aMasks do
result := result or m;
end;

//TutlWinControlEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEventManager.MaskHasType(const aMask: TEventTypeMask; const aType: TEventType): Boolean;
constructor TutlWinControlEvent.Create(const aEventType: TutlEventType; const aSender: TControl);
begin
result := ((aMask and (1 shl aType)) <> 0);
inherited Create(aEventType);
fSender := aSender;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TMouseEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlMouseEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TMouseEvent.Assign(const aEvent: TEvent);
var
me: TMouseEvent;
constructor TutlMouseEvent.Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aButtons: TutlMouseButtons;
const aClientPos: TPoint);
begin
inherited Assign(aEvent);
if Supports(aEvent, TMouseEvent, me) then begin
Button := me.Button;
ClientPos := me.ClientPos;
ScreenPos := me.ScreenPos;
end;
inherited Create(aEventType, aSender);
fButtons := aButtons;
fClientPos := aClientPos;
fScreenPos := fSender.ClientToScreen(fClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TMouseWheelEvent////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlMouseWheelEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TMouseWheelEvent.Assign(const aEvent: TEvent);
var
mwe: TMouseWheelEvent;
constructor TutlMouseWheelEvent.Create(
const aSender: TControl;
const aWheelDelta: Integer;
const aClientPos: TPoint);
begin
inherited Assign(aEvent);
if Supports(aEvent, TMouseWheelEvent, mwe) then begin
WheelDelta := mwe.WheelDelta;
ClientPos := mwe.ClientPos;
ScreenPos := mwe.ScreenPos;
end;
if (aWheelDelta < 0)
then inherited Create(TutlWinControlEventManager.EVENT_MOUSE_WHEEL_DOWN, aSender)
else inherited Create(TutlWinControlEventManager.EVENT_MOUSE_WHEEL_UP, aSender);
fWheelDelta := aWheelDelta;
fClientPos := aClientPos;
fScreenPos := fSender.ClientToScreen(fClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TKeyEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlKeyEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TKeyEvent.Assign(const aEvent: TEvent);
var
ke: TKeyEvent;
constructor TutlKeyEvent.Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aCharCode: WideChar;
const aKeyCode: Word);
begin
inherited Assign(aEvent);
if Supports(aEvent, TKeyEvent, ke) then begin
CharCode := ke.CharCode;
KeyCode := ke.KeyCode;
end;
inherited Create(aEventType, aSender);
fCharCode := aCharCode;
fKeyCode := aKeyCode;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager.TWindowEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWindowEvent////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.TWindowEvent.Assign(const aEvent: TEvent);
var
we: TWindowEvent;
constructor TutlWindowEvent.Create(
const aEventType: TutlEventType;
const aSender: TControl;
const aScreenRect: TRect;
const aClientWidth: Cardinal;
const aClientHeight: Cardinal);
begin
inherited Assign(aEvent);
if Supports(aEvent, TWindowEvent, we) then begin
ScreenRect := we.ScreenRect;
ClientWidth := we.ClientWidth;
ClientHeight := we.ClientHeight;
end;
inherited Create(aEventType, aSender);
fScreenRect := aScreenRect;
fClientWidth := aClientWidth;
fClientHeight := aClientHeight;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlWinControlEventManager/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure TutlWinControlEventManager.HandlerMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_DOWN, Button, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_DOWN, [ Button ], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure TutlWinControlEventManager.HandlerMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_UP, Button, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_UP, [Button], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_MOVE, mbLeft, Point(X, Y), TWinControl(Sender).ClientToScreen(Point(X, Y))));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_MOVE, [], Point(X, Y)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseEnter(Sender: TObject);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_ENTER, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_ENTER, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseLeave(Sender: TObject);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_LEAVE, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_LEAVE, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerClick(Sender: TObject);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_CLICK, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_CLICK, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDblClick(Sender: TObject);
begin
PushEvent(CreateMouseEvent(nil, MOUSE_DBL_CLICK, mbLeft, TWinControl(Sender).ScreenToClient(Controls.Mouse.CursorPos), Controls.Mouse.CursorPos));
DispatchEvent(CreateMouseEvent(Sender, EVENT_MOUSE_DBL_CLICK, [], TControl(Sender).ScreenToClient(Controls.Mouse.CursorPos)));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure TutlWinControlEventManager.HandlerMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
PushEvent(CreateMouseWheelEvent(nil, TWinControl(Sender), WheelDelta, MousePos));
DispatchEvent(CreateMouseWheelEvent(Sender, WheelDelta, MousePos));
Handled := false;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
PushEvent(CreateKeyEvent(nil, KEY_DOWN, Key));
DispatchEvent(CreateKeyEvent(Sender, EVENT_KEY_DOWN, Key));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
PushEvent(CreateKeyEvent(nil, KEY_UP, Key));
DispatchEvent(CreateKeyEvent(Sender, EVENT_KEY_UP, Key));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerResize(Sender: TObject);
begin
PushEvent(CreateWindowEvent(nil, WINDOW_RESIZE, TControl(Sender)));
DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_RESIZE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerActivate(Sender: TObject);
begin
PushEvent(CreateWindowEvent(nil, WINDOW_ACTIVATE, TControl(Sender)));
DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_ACTIVATE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.HandlerDeactivate(Sender: TObject);
begin
PushEvent(CreateWindowEvent(nil, WINDOW_DEACTIVATE, TControl(Sender)));
DispatchEvent(CreateWindowEvent(Sender, EVENT_WINDOW_DEACTIVATE));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.RecordEvent(const aEvent: TEvent);
procedure TutlWinControlEventManager.RecordEvent(const aEvent: IutlEvent);
var
me: TMouseEvent;
ke: TKeyEvent;
we: TWindowEvent;
me: TutlMouseEvent;
ke: TutlKeyEvent;
we: TutlWindowEvent;

function GetPressedButtons: TMouseButtons;
function GetPressedButtons: TutlMouseButtons;
begin
result := [];
if (GetKeyState(VK_LBUTTON) < 0) then
@@ -580,26 +414,24 @@ var
end;

begin
inherited RecordEvent(aEvent);

if Supports(aEvent, TMouseEvent, me) then begin
if Supports(aEvent, TutlMouseEvent, me) then begin
fMouse.ClientPos := me.ClientPos;
fMouse.ScreenPos := me.ScreenPos;
case me.EventType of
MOUSE_DOWN:
Include(fMouse.Buttons, me.Button);
MOUSE_UP:
Exclude(fMouse.Buttons, me.Button);
MOUSE_LEAVE:
EVENT_MOUSE_DOWN:
fMouse.Buttons := fMouse.Buttons + me.Buttons;
EVENT_MOUSE_UP:
fMouse.Buttons := fMouse.Buttons - me.Buttons;
EVENT_MOUSE_LEAVE:
fMouse.Buttons := [];
MOUSE_ENTER:
EVENT_MOUSE_ENTER:
fMouse.Buttons := GetPressedButtons;
end;

end else if Supports(aEvent, TKeyEvent, ke) then begin
end else if Supports(aEvent, TutlKeyEvent, ke) then begin
case ke.EventType of
KEY_DOWN,
KEY_REPEAT: begin
EVENT_KEY_DOWN,
EVENT_KEY_REPEAT: begin
fKeyboard.KeyState[ke.KeyCode and $FF] := true;
case ke.KeyCode of
VK_SHIFT: Include(fKeyboard.Modifiers, ssShift);
@@ -607,7 +439,7 @@ begin
VK_CONTROL: Include(fKeyboard.Modifiers, ssCtrl);
end;
end;
KEY_UP: begin
EVENT_KEY_UP: begin
fKeyboard.KeyState[ke.KeyCode and $FF] := false;
case ke.KeyCode of
VK_SHIFT: Exclude(fKeyboard.Modifiers, ssShift);
@@ -620,13 +452,13 @@ begin
then include(fKeyboard.Modifiers, ssAltGr)
else exclude(fKeyboard.Modifiers, ssAltGr);

end else if Supports(aEvent, TWindowEvent, we) then begin
end else if Supports(aEvent, TutlWindowEvent, we) then begin
case we.EventType of
WINDOW_ACTIVATE:
EVENT_WINDOW_ACTIVATE:
fWindow.Active := true;
WINDOW_DEACTIVATE:
EVENT_WINDOW_DEACTIVATE:
fWindow.Active := false;
WINDOW_RESIZE: begin
EVENT_WINDOW_RESIZE: begin
fWindow.ScreenRect := we.ScreenRect;
fWindow.ClientWidth := we.ClientWidth;
fWindow.ClientHeight := we.ClientHeight;
@@ -636,61 +468,64 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseEvent(aEvent: TMouseEvent; aType: TEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint): TMouseEvent;
function TutlWinControlEventManager.CreateMouseEvent(aSender: TObject; aType: TutlEventType;
aButtons: TutlMouseButtons; aClientPos: TPoint): TutlMouseEvent;
begin
result := aEvent;
if not Assigned(result) then
result := TMouseEvent.Create;
result.EventType := aType;
result.Button := aButton;
result.ClientPos := aClientPos;
result.ScreenPos := aScreenPos;
result := TutlMouseEvent.Create(
aType,
(aSender as TControl),
aButtons,
aClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseWheelEvent(aEvent: TMouseWheelEvent; aSender: TWinControl; aDelta: Integer; aClientPos: TPoint): TMouseWheelEvent;
function TutlWinControlEventManager.CreateMouseWheelEvent(aSender: TObject; aDelta: Integer;
aClientPos: TPoint): TutlMouseWheelEvent;
begin
result := aEvent;
if not Assigned(result) then
result := TMouseWheelEvent.Create;
result.ClientPos := aClientPos;
result.ScreenPos := aSender.ClientToScreen(aClientPos);
result.WheelDelta := aDelta;
if (aDelta < 0)
then result.EventType := MOUSE_WHEEL_DOWN
else result.EventType := MOUSE_WHEEL_UP;
result := TutlMouseWheelEvent.Create(
(aSender as TControl),
aDelta,
aClientPos);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateKeyEvent(aEvent: TKeyEvent; aType: TEventType; aKey: Word): TKeyEvent;
function TutlWinControlEventManager.CreateKeyEvent(aSender: TObject; aType: TutlEventType; aKey: Word): TutlKeyEvent;
begin
result := aEvent;
if not Assigned(result) then
result := TKeyEvent.Create;
result.EventType := aType;
if (aType = KEY_DOWN) and fKeyboard.KeyState[aKey and $FF] then
result.EventType := KEY_REPEAT;
result.KeyCode := aKey;
result.CharCode := VKCodeToCharCode(aKey, fKeyboard.Modifiers);
if (aType = EVENT_KEY_DOWN) and fKeyboard.KeyState[aKey and $FF] then
aType := EVENT_KEY_REPEAT;
result := TutlKeyEvent.Create(
aType,
(aSender as TControl),
VKCodeToCharCode(aKey, fKeyboard.Modifiers),
aKey);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateWindowEvent(aEvent: TWindowEvent; aType: TEventType; aSender: TControl): TWindowEvent;
function TutlWinControlEventManager.CreateWindowEvent(aSender: TObject; aType: TutlEventType): TutlWindowEvent;
var
p: TPoint;
p0, p1: TPoint;
begin
with TControl(aSender) do begin
p0 := ClientToScreen(Point(0, 0));
p1 := ClientToScreen(Point(Width, Height));
end;
result := TutlWindowEvent.Create(
aType,
(aSender as TControl),
Rect(p0.x, p0.y, p1.x, p1.y),
(aSender as TWinControl).ClientWidth,
(aSender as TWinControl).ClientHeight);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.DispatchEvent(const aEvent: IutlEvent);
begin
p := aSender.ScreenToClient(Point(0, 0));
result := aEvent;
if not Assigned(result) then
result := TWindowEvent.Create;
result.EventType := aType;
result.ClientWidth := aSender.ClientWidth;
result.ClientHeight := aSender.ClientHeight;
result.ScreenRect := Rect(p.x, p.y, p.x + result.ClientWidth, p.y + result.ClientHeight);
RecordEvent(aEvent);
inherited DispatchEvent(aEvent);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.AttachEvents(const aControl: TWinControl; const aMask: TEventTypeMask);
procedure TutlWinControlEventManager.AttachEvents(const aControl: TWinControl; const aTypes: TutlEventTypes);
var
ctl: TWinControlVisibilityClass;
frm: TCustomFormVisibilityClass;
@@ -698,22 +533,22 @@ begin
ctl := TWinControlVisibilityClass(aControl);

// mouse events
if MaskHasType(aMask, MOUSE_DOWN) then ctl.OnMouseDown := @HandlerMouseDown;
if MaskHasType(aMask, MOUSE_UP) then ctl.OnMouseUp := @HandlerMouseUp;
if MaskHasType(aMask, MOUSE_MOVE) then ctl.OnMouseMove := @HandlerMouseMove;
if MaskHasType(aMask, MOUSE_ENTER) then ctl.OnMouseEnter := @HandlerMouseEnter;
if MaskHasType(aMask, MOUSE_LEAVE) then ctl.OnMouseLeave := @HandlerMouseLeave;
if MaskHasType(aMask, MOUSE_CLICK) then ctl.OnClick := @HandlerClick;
if MaskHasType(aMask, MOUSE_DBL_CLICK) then ctl.OnDblClick := @HandlerDblClick;
if MaskHasType(aMask, MOUSE_WHEEL_DOWN) or
MaskHasType(aMask, MOUSE_WHEEL_UP) then ctl.OnMouseWheel := @HandlerMouseWheel;
if (EVENT_MOUSE_DOWN in aTypes) then ctl.OnMouseDown := @HandlerMouseDown;
if (EVENT_MOUSE_UP in aTypes) then ctl.OnMouseUp := @HandlerMouseUp;
if (EVENT_MOUSE_MOVE in aTypes) then ctl.OnMouseMove := @HandlerMouseMove;
if (EVENT_MOUSE_ENTER in aTypes) then ctl.OnMouseEnter := @HandlerMouseEnter;
if (EVENT_MOUSE_LEAVE in aTypes) then ctl.OnMouseLeave := @HandlerMouseLeave;
if (EVENT_MOUSE_CLICK in aTypes) then ctl.OnClick := @HandlerClick;
if (EVENT_MOUSE_DBL_CLICK in aTypes) then ctl.OnDblClick := @HandlerDblClick;
if (EVENT_MOUSE_WHEEL_DOWN in aTypes) or
(EVENT_MOUSE_WHEEL_UP in aTypes) then ctl.OnMouseWheel := @HandlerMouseWheel;

// key events
if MaskHasType(aMask, KEY_DOWN) then ctl.OnKeyDown := @HandlerKeyDown;
if MaskHasType(aMask, KEY_UP) then ctl.OnKeyUp := @HandlerKeyUp;
if (EVENT_KEY_DOWN in aTypes) then ctl.OnKeyDown := @HandlerKeyDown;
if (EVENT_KEY_UP in aTypes) then ctl.OnKeyUp := @HandlerKeyUp;

// window events
if MaskHasType(aMask, WINDOW_RESIZE) then begin
if (EVENT_WINDOW_RESIZE in aTypes) then begin
ctl.OnResize := @HandlerResize;
fWindow.ClientWidth := ctl.ClientWidth;
fWindow.ClientHeight := ctl.ClientHeight;
@@ -721,8 +556,8 @@ begin
if (aControl is TCustomForm) then begin
frm := TCustomFormVisibilityClass(aControl);
frm.KeyPreview := true;
if MaskHasType(aMask, WINDOW_ACTIVATE) then frm.OnActivate := @HandlerActivate;
if MaskHasType(aMask, WINDOW_DEACTIVATE) then frm.OnDeactivate := @HandlerDeactivate;
if (EVENT_WINDOW_ACTIVATE in aTypes) then frm.OnActivate := @HandlerActivate;
if (EVENT_WINDOW_DEACTIVATE in aTypes) then frm.OnDeactivate := @HandlerDeactivate;
end;
end;



+ 2
- 165
uutlGenerics.pas Datei anzeigen

@@ -10,69 +10,10 @@ unit uutlGenerics;
interface

uses
Classes, SysUtils, typinfo, uutlSyncObjs;
Classes, SysUtils, typinfo,
uutlSyncObjs, uutlInterfaces;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlEqualityComparer<T> = interface
function EqualityCompare(const i1, i2: T): Boolean;
end;

generic TutlEqualityComparer<T> = class(TInterfacedObject, specialize IutlEqualityComparer<T>)
public
function EqualityCompare(const i1, i2: T): Boolean;
end;

generic TutlEventEqualityComparer<T> = class(TInterfacedObject, specialize IutlEqualityComparer<T>)
public type
TEqualityEvent = function(const i1, i2: T): Boolean;
TEqualityEventO = function(const i1, i2: T): Boolean of object;
TEqualityEventN = function(const i1, i2: T): Boolean is nested;
private type
TEqualityEventType = (eetNormal, eetObject, eetNested);
private
fEvent: TEqualityEvent;
fEventO: TEqualityEventO;
fEventN: TEqualityEventN;
fEventType: TEqualityEventType;
public
function EqualityCompare(const i1, i2: T): Boolean;
constructor Create(const aEvent: TEqualityEvent); overload;
constructor Create(const aEvent: TEqualityEventO); overload;
constructor Create(const aEvent: TEqualityEventN); overload;
{ HINT: you need to activate "$modeswitch nestedprocvars" when you want to use nested callbacks }
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlComparer<T> = interface
function Compare(const i1, i2: T): Integer;
end;

generic TutlComparer<T> = class(TInterfacedObject, specialize IutlComparer<T>)
public
function Compare(const i1, i2: T): Integer;
end;

generic TutlEventComparer<T> = class(TInterfacedObject, specialize IutlComparer<T>)
public type
TEvent = function(const i1, i2: T): Integer;
TEventO = function(const i1, i2: T): Integer of object;
TEventN = function(const i1, i2: T): Integer is nested;
private type
TEventType = (etNormal, etObject, etNested);
private
fEvent: TEvent;
fEventO: TEventO;
fEventN: TEventN;
fEventType: TEventType;
public
function Compare(const i1, i2: T): Integer;
constructor Create(const aEvent: TEvent); overload;
constructor Create(const aEvent: TEventO); overload;
constructor Create(const aEvent: TEventN); overload;
{ HINT: you need to activate "$modeswitch nestedprocvars" when you want to use nested callbacks }
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic TutlListBase<T> = class(TObject)
private type
@@ -584,9 +525,6 @@ type

function utlFreeOrFinalize(var obj; const aTypeInfo: PTypeInfo; const aFreeObj: Boolean = true): Boolean;

operator < (const i1, i2: TObject): Boolean; inline;
operator > (const i1, i2: TObject): Boolean; inline;

implementation

uses
@@ -594,18 +532,6 @@ uses

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Helper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator < (const i1, i2: TObject): Boolean;
begin
result := Pointer(i1) < Pointer(i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator > (const i1, i2: TObject): Boolean;
begin
result := Pointer(i1) > Pointer(i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlFreeOrFinalize(var obj; const aTypeInfo: PTypeInfo; const aFreeObj: Boolean = true): Boolean;
var
@@ -679,95 +605,6 @@ begin
inherited Create('key already exists');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEqualityComparer//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEqualityComparer.EqualityCompare(const i1, i2: T): Boolean;
begin
result := (i1 = i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventEqualityComparer.EqualityCompare(const i1, i2: T): Boolean;
begin
case fEventType of
eetNormal: result := fEvent(i1, i2);
eetObject: result := fEventO(i1, i2);
eetNested: result := fEventN(i1, i2);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEvent);
begin
inherited Create;
fEvent := aEvent;
fEventType := eetNormal;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEventO);
begin
inherited Create;
fEventO := aEvent;
fEventType := eetObject;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEventN);
begin
inherited Create;
fEventN := aEvent;
fEventType := eetNested;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlComparer//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlComparer.Compare(const i1, i2: T): Integer;
begin
if (i1 < i2) then
result := -1
else if (i1 > i2) then
result := 1
else
result := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventComparer.Compare(const i1, i2: T): Integer;
begin
case fEventType of
etNormal: result := fEvent(i1, i2);
etObject: result := fEventO(i1, i2);
etNested: result := fEventN(i1, i2);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEvent);
begin
inherited Create;
fEvent := aEvent;
fEventType := etNormal;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEventO);
begin
inherited Create;
fEventO := aEvent;
fEventType := etObject;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEventN);
begin
inherited Create;
fEventN := aEvent;
fEventType := etNested;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlListBase//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


+ 190
- 0
uutlInterfaces.pas Datei anzeigen

@@ -0,0 +1,190 @@
unit uutlInterfaces;

{$mode objfpc}{$H+}
{$modeswitch nestedprocvars}

interface

uses
Classes, SysUtils;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlEqualityComparer<T> = interface
function EqualityCompare(const i1, i2: T): Boolean;
end;

generic TutlEqualityComparer<T> = class(TInterfacedObject, specialize IutlEqualityComparer<T>)
public
function EqualityCompare(const i1, i2: T): Boolean;
end;

generic TutlEventEqualityComparer<T> = class(TInterfacedObject, specialize IutlEqualityComparer<T>)
public type
TEqualityEvent = function(const i1, i2: T): Boolean;
TEqualityEventO = function(const i1, i2: T): Boolean of object;
TEqualityEventN = function(const i1, i2: T): Boolean is nested;
private type
TEqualityEventType = (eetNormal, eetObject, eetNested);
private
fEvent: TEqualityEvent;
fEventO: TEqualityEventO;
fEventN: TEqualityEventN;
fEventType: TEqualityEventType;
public
function EqualityCompare(const i1, i2: T): Boolean;
constructor Create(const aEvent: TEqualityEvent); overload;
constructor Create(const aEvent: TEqualityEventO); overload;
constructor Create(const aEvent: TEqualityEventN); overload;
{ HINT: you need to activate "$modeswitch nestedprocvars" when you want to use nested callbacks }
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlComparer<T> = interface
function Compare(const i1, i2: T): Integer;
end;

generic TutlComparer<T> = class(TInterfacedObject, specialize IutlComparer<T>)
public
function Compare(const i1, i2: T): Integer;
end;

generic TutlEventComparer<T> = class(TInterfacedObject, specialize IutlComparer<T>)
public type
TEvent = function(const i1, i2: T): Integer;
TEventO = function(const i1, i2: T): Integer of object;
TEventN = function(const i1, i2: T): Integer is nested;
private type
TEventType = (etNormal, etObject, etNested);
private
fEvent: TEvent;
fEventO: TEventO;
fEventN: TEventN;
fEventType: TEventType;
public
function Compare(const i1, i2: T): Integer;
constructor Create(const aEvent: TEvent); overload;
constructor Create(const aEvent: TEventO); overload;
constructor Create(const aEvent: TEventN); overload;
{ HINT: you need to activate "$modeswitch nestedprocvars" when you want to use nested callbacks }
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlReadOnlyList<T> = interface(IUnknown)
function GetCount: Integer;
function GetItem(const aIndex: Integer): T;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic IutlList<T> = interface(specialize IutlReadOnlyList<T>)
procedure SetItem(const aIndex: Integer; const aItem: T);
end;

operator < (const i1, i2: TObject): Boolean; inline;
operator > (const i1, i2: TObject): Boolean; inline;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator < (const i1, i2: TObject): Boolean;
begin
result := Pointer(i1) < Pointer(i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator > (const i1, i2: TObject): Boolean;
begin
result := Pointer(i1) > Pointer(i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEqualityComparer//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEqualityComparer.EqualityCompare(const i1, i2: T): Boolean;
begin
result := (i1 = i2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventEqualityComparer.EqualityCompare(const i1, i2: T): Boolean;
begin
case fEventType of
eetNormal: result := fEvent(i1, i2);
eetObject: result := fEventO(i1, i2);
eetNested: result := fEventN(i1, i2);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEvent);
begin
inherited Create;
fEvent := aEvent;
fEventType := eetNormal;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEventO);
begin
inherited Create;
fEventO := aEvent;
fEventType := eetObject;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventEqualityComparer.Create(const aEvent: TEqualityEventN);
begin
inherited Create;
fEventN := aEvent;
fEventType := eetNested;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlComparer//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlComparer.Compare(const i1, i2: T): Integer;
begin
if (i1 < i2) then
result := -1
else if (i1 > i2) then
result := 1
else
result := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventComparer.Compare(const i1, i2: T): Integer;
begin
case fEventType of
etNormal: result := fEvent(i1, i2);
etObject: result := fEventO(i1, i2);
etNested: result := fEventN(i1, i2);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEvent);
begin
inherited Create;
fEvent := aEvent;
fEventType := etNormal;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEventO);
begin
inherited Create;
fEventO := aEvent;
fEventType := etObject;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventComparer.Create(const aEvent: TEventN);
begin
inherited Create;
fEventN := aEvent;
fEventType := etNested;
end;

end.


+ 1
- 1
uutlObservableGenerics.pas Datei anzeigen

@@ -6,7 +6,7 @@ interface

uses
Classes, SysUtils,
uutlGenerics;
uutlGenerics, uutlInterfaces;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


Verfassen Vorschau
Laden…
Abbrechen
Speichern