Do you know of any free components/libraries, which allow to achieve a 3D flip effect?
Demo here: snorkl.tv
Here's an attempt using SetWorldTransform:
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
FFrontBmp, FBackBmp: TBitmap;
FBmps: array [Boolean] of TBitmap;
FXForm: TXForm;
FStep: Integer;
end;
var
Form1: TForm1;
implementation
uses
Math;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFrontBmp := TBitmap.Create;
FFrontBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '53.bmp');
FBackBmp := TBitmap.Create;
FBackBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + 'b1fv.bmp');
FBmps[True] := FFrontBmp;
FBmps[False] := FBackBmp;
FXForm.eM11 := 1;
FXForm.eM12 := 0;
FXForm.eM21 := 0;
FXForm.eM22 := 1;
FXForm.eDx := 0;
FXForm.eDy := 0;
Timer1.Enabled := False;
Timer1.Interval := 30;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FFrontBmp.Free;
FBackBmp.Free;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
SetGraphicsMode(PaintBox1.Canvas.Handle, GM_ADVANCED);
SetWorldTransform(PaintBox1.Canvas.Handle, FXForm);
PaintBox1.Canvas.Draw(0, 0, FBmps[FStep < 20]);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Bmp: TBitmap;
Sign: Integer;
begin
Inc(FStep);
Sign := math.Sign(FStep - 20);
FXForm.eM11 := FXForm.eM11 + 0.05 * Sign;
FXForm.eM21 := FXForm.eM21 - 0.005 * Sign;
FXForm.eDx := FXForm.eDx - 1 * Sign;
if FStep = 39 then begin
Timer1.Enabled := False;
PaintBox1.Refresh;
end else
PaintBox1.Invalidate;
if not Timer1.Enabled then begin
Bmp := FBmps[True];
FBmps[True] := FBmps[False];
FBmps[False] := Bmp;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := True;
FStep := 0;
end;
I'm not sure if this stood a chance of turning out to be anything beautiful in case I had some maths capability, but here's currently how it looks:
The images used:
Something like this might do the similar effect (just another attempt to show how this could be done, also not so precise, but it's just for fun since you've asked for a library or component). The principle is based on a rectnagle that is being resized and centered in the paint box where the card is being rendered with the StretchDraw function:
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, PNGImage;
type
TCardSide = (csBack, csFront);
TForm1 = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure PaintBox1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
FCardRect: TRect;
FCardSide: TCardSide;
FCardBack: TPNGImage;
FCardFront: TPNGImage;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FCardSide := csBack;
FCardRect := PaintBox1.ClientRect;
FCardBack := TPNGImage.Create;
FCardBack.LoadFromFile('tps2N.png');
FCardFront := TPNGImage.Create;
FCardFront.LoadFromFile('Ey3cv.png');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FCardBack.Free;
FCardFront.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if FCardRect.Right - FCardRect.Left > 0 then
begin
FCardRect.Left := FCardRect.Left + 3;
FCardRect.Right := FCardRect.Right - 3;
PaintBox1.Invalidate;
end
else
begin
Timer1.Enabled := False;
case FCardSide of
csBack: FCardSide := csFront;
csFront: FCardSide := csBack;
end;
Timer2.Enabled := True;
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if FCardRect.Right - FCardRect.Left < PaintBox1.ClientWidth then
begin
FCardRect.Left := FCardRect.Left - 3;
FCardRect.Right := FCardRect.Right + 3;
PaintBox1.Invalidate;
end
else
Timer2.Enabled := False;
end;
procedure TForm1.PaintBox1Click(Sender: TObject);
begin
Timer1.Enabled := False;
Timer2.Enabled := False;
FCardRect := PaintBox1.ClientRect;
Timer1.Enabled := True;
PaintBox1.Invalidate;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
case FCardSide of
csBack: PaintBox1.Canvas.StretchDraw(FCardRect, FCardBack);
csFront: PaintBox1.Canvas.StretchDraw(FCardRect, FCardFront);
end;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 203
ClientWidth = 173
Color = clBtnFace
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object PaintBox1: TPaintBox
Left = 48
Top = 40
Width = 77
Height = 121
OnClick = PaintBox1Click
OnPaint = PaintBox1Paint
end
object Timer1: TTimer
Enabled = False
Interval = 10
OnTimer = Timer1Timer
Left = 32
Top = 88
end
object Timer2: TTimer
Enabled = False
Interval = 10
OnTimer = Timer2Timer
Left = 88
Top = 88
end
end
Cards
Related
for (size_t i = 0; i < n; ++i) {
while (k >= 2 && cross(H[k-2], H[k-1], P[i]) <= 0) k--;
H[k++] = P[i];
for (size_t i = n-1, t = k+1; i > 0; --i) {
while (k >= t && cross(H[k-2], H[k-1], P[i-1]) <= 0) k--;
H[k++] = P[i-1];
I found the code for it on wikipedia but for some reasons I prefer to use doubly linked list as data structure The problem is in this first condition for while loop while(k>=2&&...) and while(k>=t && ...)
How can I rewrite these while loops on linked list
unit DoublyLinkedList;
interface
const NULL = NIL;
type TPoint = record
x,y:longint;
end;
PLink = ^TLink;
TLink = record
point:TPoint;
next:PLink;
prev:PLink;
end;
TList = record
first:PLink;
last:PLink;
end;
TFunc = function(A,B:TPoint):integer;
procedure ListInit(var L:TList);
function ListFind(L:TList;key:TPoint):PLink;
function ListIsEmpty(L:TList):boolean;
procedure ListInsertFirst(var L:TList;dd:TPoint);
procedure ListInsertLast(var L:TList;dd:TPoint);
procedure ListDeleteFirst(var L:TList);
procedure ListDeleteLast(var L:TList);
procedure ListInsert(var L:TList;dd:TPoint);
function ListInsertAfter(var L:TList;key,dd:TPoint):boolean;
procedure ListDeleteKey(var L:TList;key:TPoint);
procedure ListDisplayForward(L:TList);
procedure ListDisplayBackward(L:TList);
procedure BSTsort(var L:TList);
implementation
function equals(p1,p2:TPoint):boolean;
begin
equals:=(p1.x = p2.x) and (p1.y = p2.y);
end;
function compare(A,B:TPoint):integer;
var t:integer;
begin
t := 1;
if(A.x < B.x)or((A.x = B.x)and(A.y < B.y))then
t := -1;
if(A.x = B.x)and(A.y = B.y)then
t := 0;
compare := t;
end;
procedure BSTinsert(var root:PLink;x:PLink);
begin
if root = NULL then
begin
root := x;
x^.prev := NULL;
x^.next := NULL;
end
else if compare(root^.point,x^.point) = 0 then
BSTinsert(root^.prev,x)
else if compare(root^.point,x^.point) < 0 then
BSTinsert(root^.next,x)
else
BSTinsert(root^.prev,x);
end;
procedure BSTtoDLL(root:PLink;var L:TList);
begin
if root <> NULL then
begin
BSTtoDLL(root^.prev,L);
if ListIsEmpty(L) then
L.first := root
else
L.last^.next := root;
root^.prev := L.last;
L.last := root;
BSTtoDLL(root^.next,L);
end;
end;
procedure BSTsort(var L:TList);
var root,temp:PLink;
begin
root := NULL; (*This instruction was missing in the code *)
while not ListIsEmpty(L)do
begin
temp := L.first;
if L.first^.next = NULL then
L.last := NULL
else
L.first^.next^.prev := NULL;
L.first := L.first^.next;
BSTinsert(root,temp);
end;
BSTtoDLL(root,L);
end;
procedure ListInit(var L:TList);
begin
L.first := NULL;
L.last := NULL;
end;
function ListFind(L:TList;key:TPoint):PLink;
var p:PLink;
begin
p := L.first;
while(p <> NULL)and(not equals(key,p^.point))do
p := p^.next;
ListFind := p;
end;
function ListIsEmpty(L:TList):boolean;
begin
ListIsEmpty := L.first = NULL;
end;
procedure ListInsertFirst(var L:TList;dd:TPoint);
var newLink:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if ListIsEmpty(L) then
L.last := newLink
else
L.first^.prev := newLink;
newLink^.next := L.first;
L.first := newLink;
end;
procedure ListInsertLast(var L:TList;dd:TPoint);
var newLink:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if ListIsEmpty(L) then
L.first := newLink
else
begin
L.last^.next := newLink;
newLink^.prev := L.last;
end;
L.last := newLink;
end;
procedure ListDeleteFirst(var L:TList);
var temp:PLink;
begin
if not ListIsEmpty(L) then
begin
temp := L.first;
if L.first^.next = NULL then
L.last := NULL
else
L.first^.next^.prev := NULL;
L.first := L.first^.next;
dispose(temp);
end;
end;
procedure ListDeleteLast(var L:TList);
var temp:PLink;
begin
if not ListIsEmpty(L) then
begin
temp := L.last;
if L.first^.next = NULL then
L.first := NULL
else
L.last^.prev^.next := NULL;
L.last := L.last^.prev;
dispose(temp);
end;
end;
procedure ListInsert(var L:TList;dd:TPoint);
var newLink,current:PLink;
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
current := L.first;
while(current <> NULL)and(compare(newLink^.point,current^.point) > 0)do
current := current^.next;
if current = NULL then
begin
if ListIsEmpty(L)then
L.first := newLink
else
begin
L.last^.next := newLink;
newLink^.prev := L.last;
end;
L.last := newLink;
end
else if current^.prev = NULL then
begin
L.first := newLink;
newLink^.next := current;
current^.prev := newLink;
newLink^.prev := NULL;
current := newLink;
end
else
begin
current^.prev^.next := newLink;
newLink^.next := current;
newLink^.prev := current^.prev;
current^.prev := newLink;
end;
end;
function ListInsertAfter(var L:TList;key,dd:TPoint):boolean;
var newLink,current:PLink;
found:boolean;
begin
current := ListFind(L,key);
found := current <> NULL;
if found then
begin
new(newLink);
newLink^.point.x := dd.x;
newLink^.point.y := dd.y;
newLink^.next := NULL;
newLink^.prev := NULL;
if current^.next = NULL then
begin
newLink^.next := NULL;
L.last := newLink;
end
else
begin
newLink^.next := current^.next;
current^.next^.prev := newLink;
end;
newLink^.prev := current;
current^.next := newLink;
end;
ListInsertAfter:= found;
end;
procedure ListDeleteKey(var L:TList;key:TPoint);
var current:PLink;
begin
current := ListFind(L,key);
if current <> NULL then
begin
if current^.prev = NULL then
L.first := current^.next
else
current^.prev^.next := current^.next;
if current^.next = NULL then
L.last := current^.prev
else
current^.next^.prev := current^.prev;
dispose(current);
end;
end;
procedure ListDisplayForward(L:TList);
var current :PLink;
begin
write('List (first-->last): ');
current := L.first;
while current <> NIL do
begin
write('(',current^.point.x,',',current^.point.y,') -> ');
current := current^.next;
end;
writeln('NULL');
end;
procedure ListDisplayBackward(L:TList);
var current :PLink;
begin
write('List (last-->first): ');
current := L.last;
while current <> NIL do
begin
write('(',current^.point.x,',',current^.point.y,') -> ');
current := current^.prev;
end;
writeln('NULL');
end;
begin
end.
program MonotoneChain;
uses crt,doublylinkedlist;
function equals(a,b:TPoint):boolean;
begin
equals := (a.x = b.x) and (a.y = b.y)
end;
function vect(a1,a2,b1,b2:TPoint):longint;
begin
vect := (a2.x - a1.x) * (b2.y - b1.y) - (b2.x - b1.x) * (a2.y - a1.y)
end;
function dist2(a1,a2:TPoint):longint;
begin
dist2 := sqr(a2.x - a1.x) + sqr(a2.y-a1.y)
end;
procedure Solve(var A,B:TList);
var k,t:longint;
pt:PLink;
begin
ListInit(B);
if not ListIsEmpty(A)then
begin
k := 0;
pt := A.first;
while pt <> NULL do
begin
while(k >= 2)and(vect(B.last^.prev^.point,B.last^.point,B.last^.prev^.point,pt^.point) <= 0)do
begin
ListDeleteLast(B);
k := k - 1;
end;
ListInsertLast(B,pt^.point);
k := k + 1;
pt := pt^.next;
end;
t := k + 1;
pt := A.last;
while pt <> NULL do
begin
while(k >= t)and(vect(B.last^.prev^.point,B.last^.point,B.last^.prev^.point,pt^.point) <= 0)do
begin
ListDeleteLast(B);
k := k - 1;
end;
ListInsertLast(B,pt^.point);
k := k + 1;
pt := pt^.prev;
end;
ListDeleteLast(B);
end;
end;
procedure main;
var A,B:TList;
input:text;
p:TPoint;
path:string;
begin
ListInit(A);
writeln('Podaj sciezke do pliku z danymi do wczytania');
readln(path);
path := 'F:\fpc\3.0.4\bin\i386-win32\monotonechain\' + path;
assign(input,path);
{$I-}
reset(input);
{$I+}
if IOResult <> 0 then
writeln('Pliku nie udalo sie wczytac')
else
begin
while not eof(input) do
begin
while not eoln(input) do
begin
read(input,p.x,p.y);
ListInsertLast(A,p);
end;
readln(input);
writeln('List A');
ListDisplayForward(A);
ListDisplayBackward(A);
BSTsort(A);
Solve(A,B);
writeln('List A');
ListDisplayForward(A);
ListDisplayBackward(A);
writeln('List B');
ListDisplayForward(B);
ListDisplayBackward(B);
while not ListIsEmpty(A) do
ListDeleteFirst(A);
while not ListIsEmpty(B) do
ListDeleteFirst(B);
end;
close(input);
end;
readkey;
end;
BEGIN
main;
END.
Here is the code
Segmentation fault appears while I try to sort
the list using BST
Probably when I try to insert the node removed from head of the list to the BST
Segmentation fault appears only when I call it from procedure which finds the convex hull
When I call it from main block of code everything seem to be ok
One of the casese of segmentetion fault is dereferencing null pointer
but i dont know is this segmentation fault caused by dereferencing null pointer
It is strange for me that BSTsort called in main block of code works ok
but BSTsort called in Solve procedure causes segmentation fault
I think i know how to correct this sorting procedure
but I would like to know why segmentation fault occured and why only
in Solve procedure
did when pressing button select all the lines in dbgrid, can I select all the lines when ctrl + a is pressed?
function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.Datasource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm2.btn13Click(Sender: TObject);
begin
GridSelectAll(dbgrd1);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (ssCtrl in Shift) and (Key = $41) then
then GridSelectAll(dbgrd1); end;
I've been stressing out for the past few hours trying to get this working and I simply cannot figure it out. Basically it doesn't read anything from my .dat file and when I try to use options 2, 3 or 4 it just comes up with these
.
I've include the .dat file and pascal below. I'm desperate for help.
mytestfile.dat
1
Adele
Pop
2
Hello
ff
Remedy
dd
pascal
program MusicPlayer;
uses TerminalUserInput;
type
TrackRec = record
name: String;
location: String;
end;
// type TrackArray = array of TrackRec;
GenreType = (Pop, Rap, Rock, Classic);
AlbumRec = Record
name: String;
genre: GenreType;
// location: array of TrackRec;
tracks: array of TrackRec;
end;
type AlbumArray = array of AlbumRec;
function ReadGenre(): GenreType;
var
option: Integer;
begin
WriteLn('Press 1 for Pop');
WriteLn('Press 2 for Rap');
WriteLn('Press 3 for Rock');
WriteLn('Press 4 for Classic');
option := ReadInteger('');
while (option<1) or (option>5) do
begin
WriteLn('Please enter a number between 1-4');
option := ReadInteger('');
end;
case option of
1: result := Pop;
2: result := Rap;
3: result := Rock;
else
result := Classic;
end;
end;
procedure NewAlbum(var albums: AlbumArray; var myFile: TextFile);
var
number, i, tracks, y: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
ReWrite(myFile);
number := ReadInteger('How many albums do you want to make?: ');
WriteLn(myFile, number);
SetLength(albums, number);
for i := Low(albums) to High(albums) do
begin
albums[i].name := ReadString('Enter album name:');
WriteLn(myFile, albums[i].name);
albums[i].genre := ReadGenre();
WriteLn(myFile, albums[i].genre);
tracks := ReadIntegerRange('How many tracks do you want to enter? (max 15)', 0, 15);
WriteLn(myFile, tracks);
SetLength(albums[i].tracks, tracks);
for y := Low(albums[i].tracks) to tracks - 1 do
begin
albums[i].tracks[i].name := ReadString('Track name:');
WriteLn(myFile, albums[i].tracks[i].name);
albums[i].tracks[i].location := ReadString('Track Location:');
WriteLn(myFile, albums[i].tracks[i].location);
end;
end;
Close(myFile);
end;
procedure ReadTrack(count: Integer; var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadLn(myFile, i);
SetLength(albums[count].tracks, i);
for count := Low(albums[count].tracks) to High(albums[count].tracks) - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
procedure ReadAlbum(var albums: AlbumArray; var myFile: TextFile);
var
albumNumber, tracknumber, count, i: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
Reset(myFile);
ReadLn(myFile, albumNumber);
SetLength(albums, albumNumber);
for i := Low(albums) to High(albums) do
begin
ReadLn(myFile, albums[i].name);
ReadLn(myFile, albums[i].genre);
ReadLn(myFile, tracknumber);
SetLength(albums[i].tracks, tracknumber);
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
end;
procedure ReadAlbums(var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbum(albums, myFile);
WriteLn('Album is:');
for i := Low(albums) to High(albums) do
begin
WriteLn((i + 1),'.', albums[i].name);
WriteLn('.', albums[i].genre);
for number := Low(albums[i].tracks) to High(albums[i].tracks) do
begin
WriteLn((number + 1), '', albums[i].tracks[Low(albums[i].tracks)].name);
end;
end;
end;
procedure PlayAlbum (var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Please select an album: ');
i := i - 1;
number := ReadIntegerRange('Please select a song from album:', 1, 20);
number := number - 1;
WriteLn('Now playing');
WriteLn('Track selected: ', albums[i].tracks[number].name);
WriteLn('Album: ', albums[i].name);
end;
procedure Update(var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Select an album to update');
i := i - 1;
albums[i].name := ReadString('New Album Name:');
WriteLn('Album has now been updated');
end;
procedure Main();
var
i, count, select, change: Integer;
albums: AlbumArray;
myFile: TextFile;
begin
WriteLn('Please select an option: ');
WriteLn('-------------------------');
WriteLn('1. Read Albums');
WriteLn('2. Display Albums');
WriteLn('3. Select an Album');
WriteLn('4. Update an Album');
WriteLn('5. Exit');
WriteLn('-------------------------');
repeat
i := ReadInteger('Select option for menu:');
case i of
1: ReadAlbum(albums, myFile);
2: ReadAlbums(albums, myFile);
3: PlayAlbum(albums, myFile);
4: Update(albums, myFile);
end;
until i = 5;
end;
begin
Main();
end.
In the ReadAlbum() procedure you have two for loops, an outer one that loops through the albums and an inner one that loops through the tracks. In the latter you have messed up the indexes:
This is the erroneous code:
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
albums[] should use i as index and tracks[] should use count as index.
Until you get more used to arrays and indexes I suggest you name your variables with a clear meaning, for example:
`NumOfAlbums` in the meaning of how many albums you have
`AlbumIndex` as the index to the albums array
`NumOfTracks` as the number of tracks in an album
`TrackIndex` as the index to the tracks array
It may feel tiresome to write so long names, but you would probably not have made the mistake you did, with the more verbose names.
I Am trying to protect my Tidtcpserver from unknown commands
This is how my Verify commands function looks like
function TConnection.Verfieycmds(const CMSTOV: String): BOOLEAN;
var
CMDSTOVERFIYE : Tstringlist;
I : integer;
CommandFound : Boolean;
begin
Result := False;
CommandFound := False;
if Commandlist <> nil then
begin
CMDSTOVERFIYE := Commandlist.Lock;
try
for I := 0 to CMDSTOVERFIYE.Count - 1 do
begin
if CMSTOV = CMDSTOVERFIYE[I] then
begin
CommandFound := True;
end;
end;
CommandFound := True;
Result := CommandFound;
finally
Commandlist.Unlock;
end;
end;
end;
after adding this check on execute event and after few clients connect the server application freezed and need to be restarted and the exception log were empty
here is my server code
type
TConnection = class(TIdServerContext)
private
{Private}
public
{Public}
OutboundCache: TIdThreadSafeStringList;
Commandlist: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
Name: String;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure TcpServerConnect(AContext: TIdContext);
procedure TcpServerDisconnect(AContext: TIdContext);
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCloseQuery(Sender: TObject; var CanClose: BOOLEAN);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure TcpServerListenException(AThread: TIdListenerThread;
AException: Exception);
private
{ Private declarations }
LastUniqueID: Dword;
procedure HandleExceptions(Sender: TObject; E: Exception);
procedure UpdateBindings;
public
{ Public declarations }
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
Commandlist := TIdThreadSafeStringList.Create;
Commandlist.Add('Command1');
Commandlist.Add('Command2');
Commandlist.Add('Command3');
Commandlist.Add('Command4');
Commandlist.Add('Command5');
Commandlist.Add('Command6');
Commandlist.Add('Command7');
Commandlist.Add('Command8');
Commandlist.Add('Command9');
Commandlist.Add('Command10');
Commandlist.Add('Command11');
Commandlist.Add('Command12');
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
Commadcaches : TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
if Commandlist <> nil then
begin
Commadcaches := Commandlist.Lock;
try
for I := 0 to Commadcaches.Count - 1 do
Commadcaches.Objects[I].Free;
finally
Commandlist.Unlock;
end;
Commandlist.Free;
end;
inherited;
end;
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Startercommand : String;
Params: array [1 .. 200] of String;
Cache, OutboundCmds: TStringList;
ParamsCount, P: integer;
I: integer;
S: String;
DECODES : String;
UConnected : Boolean;
Len: Integer;
begin
Try
UConnected := AContext.Connection.Connected;
Except
UConnected := False;
End;
If Not UConnected Then
begin
AContext.Connection.Disconnect;
exit;
end;
Len := AContext.Connection.IOHandler.InputBuffer.Size;
If Len >= 200000 then
begin
AContext.Connection.Disconnect;
exit;
end;
Connection := AContext as TConnection;
// check for pending outbound commands...
OutboundCmds := nil;
try
Cache := Connection.OutboundCache.Lock;
try
if Cache.Count > 0 then
begin
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
end;
finally
Connection.OutboundCache.Unlock;
end;
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
AContext.Connection.IOHandler.Writeln(OutboundCmds.Strings[I],
IndyTextEncoding_UTF8);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
AContext.Connection.IOHandler.LargeStream := true;
AContext.Connection.IOHandler.Write(MS, 0, true);
end;
end;
Connection.LastSendRecv := Ticks64;
end;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
// check for a pending inbound command...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(Connection.LastSendRecv) >= 60000 then
AContext.Connection.Disconnect;
Exit;
end;
end;
Startercommand := Decode64(AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8), IndyTextEncoding_UTF8);
Command := Startercommand;
{HERE I START TO CHECK COMMAND LIST}
if (command <> 'ISACTIVE') then
begin
if Connection.Verfieycmds(Command) <> true then
begin
AContext.Connection.Disconnect;
Exit;
end;
end;
{HERE I START TO CHECK COMMAND LIST}
Connection.LastSendRecv := Ticks64;
if Command = '' then
begin
AContext.Connection.Disconnect;
Exit;
end;
ReceiveParams := False;
ReceiveStream := False;
if Command[1] = '1' then // command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
ReceiveStream := true;
end;
if ReceiveParams then // params is incomming
begin
S := AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8);
DECODES := Decode64(S, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (DECODES <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, DECODES);
if P = 0 then
Params[ParamsCount] := DECODES
else
begin
Params[ParamsCount] := Copy(DECODES, 1, P - 1);
Delete(DECODES, 1, P + 5);
end;
end;
end;
if Command = 'Broadcastanymessage' then
begin
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
end;
if i remove the Verfieycmds from the execute check the server running normally . what i am doing wrong ?
There is no reason to use a TIdThreadSafeStringList for the commands list. Only the thread that creates the list will ever be accessing it, so using a lock for it is unnecessary overhead.
And there is no reason to allocate a new list for each client, for that matter. That is just wasting memory.
Your commands are encoded in a manner that requires decoding before you can then validate them.
Try something more like this instead:
type
TConnection = class(TIdServerContext)
private
function HasInboundData: Boolean;
procedure SendOutboundCache;
public
OutboundCache: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
// ...
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
//...
procedure TcpServerConnect(AContext: TIdContext);
//...
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCreate(Sender: TObject);
//...
private
//...
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
LastSendRecv := Ticks64;
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
inherited;
end;
function TConnection.HasInboundData: Boolean;
begin
if Connection.IOHandler.InputBufferIsEmpty then
begin
Connection.IOHandler.CheckForDataOnSource(100);
Connection.IOHandler.CheckForDisconnect;
if Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(LastSendRecv) >= 60000 then
Connection.Disconnect;
Result := False;
Exit;
end;
end;
Result := True;
end;
procedure TConnection.SendOutboundCache;
var
Cache, OutboundCmds: TStringList;
MS: TMemoryStream;
I: integer;
begin
OutboundCmds := nil;
try
Cache := OutboundCache.Lock;
try
if Cache.Count = 0 then
Exit;
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
finally
OutboundCache.Unlock;
end;
for I := 0 to OutboundCmds.Count - 1 do
begin
Connection.IOHandler.WriteLn(OutboundCmds.Strings[I]);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
Connection.IOHandler.LargeStream := true;
Connection.IOHandler.Write(MS, 0, true);
end;
end;
LastSendRecv := Ticks64;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
end;
procedure TServobj.FormCreate(Sender: TObject);
begin
TcpServer.ContextClass := TConnection;
end;
procedure TServobj.TcpServerConnect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8
end;
const
ValidCmds: array[0..13] of String = (
'ISACTIVE',
'Broadcastanymessage',
'Command1',
'Command2',
'Command3',
'Command4',
'Command5',
'Command6',
'Command7',
'Command8',
'Command9',
'Command10',
'Command11',
'Command12'
);
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command, Decoded: String;
Params: array[1..200] of String;
ParamsCount, P, I, WhichCmd: integer;
begin
Connection := AContext as TConnection;
// check for pending outbound commands...
Connection.SendOutboundCache;
// check for a pending inbound command...
if not Connection.HasInboundData then
Exit;
Command := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ReceiveParams := False;
ReceiveStream := False;
if Command <> '' then
begin
if Command[1] = '1' then // command with params
begin
Delete(Command, 1, 1);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Delete(Command, 1, 1);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Delete(Command, 1, 1);
ReceiveParams := true;
ReceiveStream := true;
end;
end;
WhichCmd := PosInStrArray(Command, ValidCmds);
if WhichCmd = -1 then
begin
AContext.Connection.Disconnect;
Exit;
end;
if ReceiveParams then // params is incomming
begin
Decoded := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (Decoded <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, Decoded);
if P = 0 then
Params[ParamsCount] := Decoded
else
begin
Params[ParamsCount] := Copy(Decoded, 1, P - 1);
Delete(Decoded, 1, P + Length(Sep));
end;
end;
end;
Connection.LastSendRecv := Ticks64;
case WhichCmd of
// process commands as needed...
1: begin // Broadcastanymessage
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
// ...
end;
end;
I'm trying to make a combobox that selects first item back after change. My OS is Ubuntu 12.04. My code:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, Menus;
type
{ TForm1 }
TForm1 = class(TForm)
ComboBox1: TComboBox;
Edit1: TEdit;
Label1: TLabel;
Memo1: TMemo;
procedure ComboBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.ComboBox1Change(Sender: TObject);
var Text2:String;
begin
if (Combobox1.ItemIndex = 1) Then
begin
Text2 := Memo1.SelText;
Edit1.Text := Memo1.SelText;
Memo1.SelText := '[artist]' + Text2 + '[/artist]';
end;
if (Combobox1.ItemIndex = 2) Then
begin
if (Edit1.Text = '') Then
ShowMessage('Artist name is not defined') Else
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[album artist=' + Edit1.Text + ']' + Text2 + '[/album]';
end;
end;
if (ComboBox1.ItemIndex = 3) Then
begin
if (Edit1.Text = '') Then
ShowMessage('Artist name is not defined') Else
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[track artist=' + Edit1.Text + ']' + Text2 + '[/track]'
end;
end;
if (ComboBox1.ItemIndex = 4) Then
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[label]' + Text2 + '[/label]';
end;
if (ComboBox1.ItemIndex = 5) Then
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[tag]' + Text2 + '[/tag]';
end;
Combobox1.SelectFirst;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Text := 'Select an item';
end;
end.
This gives an error: unit1.pas(74,13) Error: identifier idents no member "SelectFirst"
How can I fix this?
the combobox haven't this procedure
if you want the first item select it by this way
ComboBox1.ItemIndex := 0