I have a procedure to auto-resize a column in a grid to accommodate for the largest string in that column. However when there's over 2,000 records in the grid, it takes a little too much time. Any tips on speeding this up?
//lstSKU = grid
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M: Integer;
X: Integer;
S: String;
R: TRect;
begin
M:= 20;
lstSKU.Canvas.Font.Assign(lstSKU.Font);
for X:= 1 to lstSKU.RowCount - 1 do begin
S:= lstSKU.Cells[ACol, X];
R:= Rect(0, 0, 20, 20);
DrawText(lstSKU.Canvas.Handle, PChar(S), Length(S), R,
DT_LEFT or DT_VCENTER or DT_CALCRECT);
if R.Right > M then
M:= R.Right;
end;
M:= M + 15;
lstSKU.ColWidths[ACol]:= M;
end;
Is this a standard TStringGrid/TDrawGrid?
You can iterate through using Canvas.TextWidth(S) instead to measure the content width of each cell, save the largest, add any padding, and then set the Grid.ColWidths[Col] := M;. This will trigger a single redraw if needed. (Basically what you're doing, without repeating the drawing operation 2001 times.)
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M, T: Integer;
X: Integer;
S: String;
begin
M := 20;
for X := 1 to lstSKU.RowCount - 1 do
begin
S:= lstSKU.Cells[ACol, X];
T := lstSKU.Canvas.TextWidth(S);
if T > M then
M := T;
end;
M := M + 15;
lstSKU.ColWidths[ACol] := M;
end;
If you want to set both width and height of the cell to accomodate larger fonts or something, use TextExtent instead of TextWidth; TextExtent returns a TSize, from which you can read Width and Height.
Although already answered, I'm posting the final code, which you can use with any string grid (TStringGrid). It resized 3,000 records with 27 columns in 2.3 seconds, as opposed to the prior 6.4 average.
//AGrid = Grid containing column to be resized
//ACol = Column index of grid to be resized
//AMin = Minimum column width
procedure ResizeCol(AGrid: TStringGrid; const ACol, AMin: Integer);
var
M, T: Integer; //M=Maximum Width; T=Current Text
X: Integer; //X=Loop Counter
begin
M:= AMin; //Begin with minimum width
AGrid.Canvas.Font.Assign(AGrid.Font);
for X:= 1 to AGrid.RowCount - 1 do begin
T:= AGrid.Canvas.TextWidth(AGrid.Cells[ACol, X]);
if T > M then M:= T;
end;
AGrid.ColWidths[ACol]:= M + AMin;
end;
Related
You play a game with 100 opponents. The game has k rounds. Every round you can eliminate some opponents (always atleast 1). You are rewarded for eliminating them.
The reward is: 100.000 * '# of eliminated opponents' / '# of opponents' <= in integers (rounded down)
I want to eliminate the opponents in a way, that gets me the largest amount of money possible.
Example game:
number of rounds = 3
first round we eliminate 50 opponents, so we get 100.000 * 50 / 100 = +50.000
second round we eliminate 30, so we get 100.000 * 30 / 50 = +60.000
last round we eliminate last 20 opponents, so we get 100.000 * 20 / 20 = +100.000
so the total winnings are: 210.000
I tried to write up something, but I don't think it's the most effective way to do it?
Program EliminationGame;
var
selectedHistory : array [1..10] of integer;
opponentCount,roundCount : integer;
maxOpponents,numberSelected : integer;
totalMoney : integer;
i : integer;
begin
totalMoney := 0;
maxOpponents := 100;
opponentCount := maxOpponents;
roundCount := 3; {test value}
for i:=1 to roundCount do begin
if (i = roundCount) then begin
numberSelected := opponentCount;
end else begin
numberSelected := floor(opponentCount / roundCount);
end;
selectedHistory[i] := numberSelected;
totalMoney := floor(totalMoney + (numberSelected / opponentCount * 100000));
opponentCount := opponentCount - numberSelected;
end;
writeln('Total money won:');
writeln(totalMoney);
writeln('Amount selected in rounds:');
for i:= 0 to Length(selectedHistory) do
write(selectedHistory[i],' ');
end.
Also it seems that floor function does not exist in pascal?
It seems the question has a maths answer that can be calculated in advance. As #Anton said it was obvious that the number of points given during the third round did not depend upon the number of eliminated enemies. So the third round should eliminate 1 enemy.
So We get the following function for a thre-round game.
f(x)=100000x/100+100000(99-x)/(100-x)+100000*1/1, where x- the number
of enemies eleminated at first round.
if we find the extrema (local maximum of the function) it appears equal to 90. That means the decision is the following: the first round eliminates 90 the second - 9, the third - 1 enemy.
Of course, for consideration: 90=100-sqrt(100).
In other words: the Pascal decision of the task is to loop a variable from 1 to 99 and see the maximum of this function. X-will be the answer.
program Project1;
var
x, xmax: byte;
MaxRes, tmp: real;
begin
xmax := 0;
MaxRes := 0;
for x := 1 to 99 do
begin
tmp := 100000 * x / 100 + 100000*(99 - x) / (100 - x) + 100000 * 1 / 1;
if tmp > MaxRes then
begin
MaxRes := tmp;
xmax := x;
end;
end;
writeln(xmax);
readln;
end.
The general decision for other number of enemies and rounds (using recursion) is the following (Delphi dialect):
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
Uses System.SysUtils;
var
s: string;
function Part(RemainingEnemies: byte; Depth: byte;
var OutputString: string): real;
var
i: byte;
tmp, MaxRes: real;
imax: byte;
DaughterString: string;
begin
OutputString := '';
if Depth = 0 then
exit(0);
imax := 0;
MaxRes := 0;
for i := 1 to RemainingEnemies - Depth + 1 do
begin
tmp := i / RemainingEnemies * 100000 + Part(RemainingEnemies - i, Depth - 1,
DaughterString);
if tmp > MaxRes then
begin
MaxRes := tmp;
imax := i;
OutputString := inttostr(imax) + ' ' + DaughterString;
end;
end;
result := MaxRes;
end;
begin
writeln(Part(100, 3, s):10:1);//first parameter-Enemies count,
//2-Number of rounds,
//3-output for eliminated enemies counter
writeln(s);
readln;
end.
This problem can be solved with a dynamic approach.
F(round,number_of_opponents_remained):
res = 0
opp // number_of_opponents_remained
for i in [1 opp]
res = max(res, opp/100 + F(round-1,opp - i) )
return res
I should say this not the complete solution and you add some details about it, and I am just giving you an idea. You should add some details such as base case and checking if opp>0 and some other details. The complexity of this algorithm is O(100*k).
I am trying to change a bit-map's pixel color if it's white. I wrote following code. But it's awfully slow!. i want to check if a pixel's color is white or not, and if it is white, change the color to black.
Can anybody suggest a better approach?
procedure TForm1.Button1Click(Sender: TObject);
var
BitMap1 : TBitmap;
X, Y, Size : Integer;
P: Cardinal;
begin
BitMap1 := TBitmap.Create;
bitMap1.LoadFromFile('image1.bmp');
for Y := 0 to Bitmap1.Height - 1 do
begin
for X := 0 to Bitmap1.width * size - 1 do
begin
p := BitMap1.Canvas.Pixels[X,Y];
if p = 255 then
BitMap1.Canvas.Pixels[X,Y] := 0;
end;
end;
Image1.Picture.Assign(BitMap1);
end;
For sure use the ScanLine property to access bitmap pixels since you're working with a large array of pixels where the Pixels access is slow. For replacing colors of your choice with support for 24-bit and 32-bit bitmaps, I would use something like this:
procedure ReplaceColor(ABitmap: TBitmap; ASource, ATarget: TColor);
type
TRGBBytes = array[0..2] of Byte;
var
I: Integer;
X: Integer;
Y: Integer;
Size: Integer;
Pixels: PByteArray;
SourceColor: TRGBBytes;
TargetColor: TRGBBytes;
const
TripleSize = SizeOf(TRGBBytes);
begin
case ABitmap.PixelFormat of
pf24bit: Size := TripleSize;
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('Bitmap must be 24-bit or 32-bit format!');
end;
for I := 0 to TripleSize - 1 do
begin
// fill the array of bytes with color channel values in BGR order,
// the same would do for the SourceColor from ASource parameter:
// SourceColor[0] := GetBValue(ASource);
// SourceColor[1] := GetGValue(ASource);
// SourceColor[2] := GetRValue(ASource);
// but this is (just badly readable) one liner
SourceColor[I] := Byte(ASource shr (16 - (I * 8)));
// the same do for the TargetColor array from the ATarget parameter
TargetColor[I] := Byte(ATarget shr (16 - (I * 8)));
end;
for Y := 0 to ABitmap.Height - 1 do
begin
// get a pointer to the currently iterated row pixel byte array
Pixels := ABitmap.ScanLine[Y];
// iterate the row horizontally pixel by pixel
for X := 0 to ABitmap.Width - 1 do
begin
// now imagine, that you have an array of bytes in which the groups of
// bytes represent a single pixel - e.g. the used Pixels array for the
// first 2 pixels might look like this for 24-bit and 32-bit bitmaps:
// Pixels [0][1][2] [3][4][5]
// 24-bit B G R B G R
// Pixels [0][1][2][3] [4][5][6][7]
// 32-bit B G R A B G R A
// from the above you can see that you'll need to multiply the current
// pixel iterator by the count of color channels to point to the first
// (blue) color channel in that array; and that's what that (X * Size)
// is for here; X is a pixel iterator, Size is size of a single pixel:
// X * 3 (0 * 3) (1 * 3)
// ⇓ ⇓
// Pixels [0][1][2] [3][4][5]
// 24-bit B G R B G R
// X * 4 (0 * 4) (1 * 4)
// ⇓ ⇓
// Pixels [0][1][2][3] [4][5][6][7]
// 32-bit B G R A B G R A
// so let's compare a BGR value starting at the (X * Size) position of
// the Pixels array with the SourceColor array and if it matches we've
// found the same colored pixel, if so then...
if CompareMem(#Pixels[(X * Size)], #SourceColor, TripleSize) then
// copy the TargetColor color byte array values to that BGR position
// (in other words, replace the color channel bytes there)
Move(TargetColor, Pixels[(X * Size)], TripleSize);
end;
end;
end;
And the usage:
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('d:\Image.bmp');
ReplaceColor(Bitmap, clWhite, clBlack);
Image1.Picture.Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
For pure GDI and bitmaps having at most 256 colors you might use the CreateMappedBmp function.
You should use scanlines for this. Example:
procedure ChangeWhiteToBlack(var Bitmap: TBitmap);
var
scanline: PRGBTriple;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbtBlue = 255) and (rgbtGreen = 255) and (rgbtRed = 255) then
FillChar(scanline^, sizeof(TRGBTriple), 0);
end;
inc(scanline);
end;
end;
end;
To try this:
procedure TForm5.FormCreate(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Desktop\test.bmp');
ChangeWhiteToBlack(bm);
bm.SaveToFile('C:\Users\Andreas Rejbrand\Desktop\test2.bmp');
finally
bm.Free;
end;
end;
Update: You need only a very minor modification of the code to make it work on 32-bit bitmaps instead:
procedure ChangeWhiteToBlack32(var Bitmap: TBitmap);
var
scanline: PRGBQuad;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf32bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbBlue = 255) and (rgbGreen = 255) and (rgbRed = 255) then
FillChar(scanline^, sizeof(TRGBQuad), 0);
end;
inc(scanline);
end;
end;
end;
In fact, you could do
procedure ChangeWhiteToBlack24(var Bitmap: TBitmap);
var
scanline: PRGBTriple;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbtBlue = 255) and (rgbtGreen = 255) and (rgbtRed = 255) then
FillChar(scanline^, sizeof(TRGBTriple), 0);
end;
inc(scanline);
end;
end;
end;
procedure ChangeWhiteToBlack32(var Bitmap: TBitmap);
var
scanline: PRGBQuad;
y: Integer;
x: Integer;
begin
Assert(Bitmap.PixelFormat = pf32bit);
for y := 0 to Bitmap.Height - 1 do
begin
scanline := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with scanline^ do
begin
if (rgbBlue = 255) and (rgbGreen = 255) and (rgbRed = 255) then
FillChar(scanline^, sizeof(TRGBQuad), 0);
end;
inc(scanline);
end;
end;
end;
procedure ChangeWhiteToBlack(var Bitmap: TBitmap);
begin
case Bitmap.PixelFormat of
pf24bit: ChangeWhiteToBlack24(Bitmap);
pf32bit: ChangeWhiteToBlack32(Bitmap);
else
raise Exception.Create('Pixel format must be pf24bit or pf32bit.');
end;
end;
if you don't want to make a single procedure that works with both 24-bit and 32-bit bitmaps, as TLama did. [One benefit of having two separate procedures is that these short procedures are easier to read (and maintain).]
procedure TForm1.Button1Click(Sender: TObject);
var
BitMap1,
BitMap2 : TBitmap;
X, Y, Size : Integer;
P: Cardinal;
begin
BitMap1 := TBitmap.Create;
BitMap1.LoadFromFile('image1.bmp');
BitMap1.Transparent := true;
BitMap1.TransparentColor := clWhite; // old color
BitMap2 := TBitMap.Create;
BitMap2.Height := BitMap1.Height;
BitMap2.Width := BitMap1.Width;
BitMap2.Canvas.Brush.Color := clBlack; // new color
BitMap2.Canvas.FillRect(
Rect(
0,
0,
BitMap2.Width,
BitMap2.Height
)
);
BitMap2.Canvas.Draw(BitMap1);
Image1.Picture.Assign(BitMap2);
BitMap1.Free;
BitMap2.Freel
end;
private void btnLoad2_Click(object sender, System.EventArgs e)
{
Bitmap myBitmap= new Bitmap(openFileDialog1.FileName);
Bitmap myBitmap1 = new Bitmap("C:\\Documents and Settings\\Lalji\\Desktop\\image.png");
for (int x = 0; x < myBitmap.Width; x++)
{
for (int y = 0; y < myBitmap.Height; y++)
{
// Get the color of a pixel within myBitmap.
Color pixelColor = myBitmap.GetPixel(x, y);
string pixelColorStringValue =
pixelColor.R.ToString("D3") + " " +
pixelColor.G.ToString("D3") + " " +
pixelColor.B.ToString("D3") + ", ";
if (pixelColor.R.Equals(0) && pixelColor.G.Equals(0) && pixelColor.B.Equals(0))
{
//MessageBox.Show("black pixel");
}
else if (pixelColor.R.Equals(255) && pixelColor.G.Equals(255) && pixelColor.B.Equals(255))
{
//MessageBox.Show("white pixel");
myBitmap1.SetPixel(x, y, Color.White);
}
//switch (pixelColorStringValue)
//{
// case "255 255 255":
// {
// // white pixel
// MessageBox.Show("white pixel");
// break;
// }
// case "000 000 000,":
// {
// // black pixel
// MessageBox.Show("black pixel");
// break;
// }
//}
}
}
myBitmap1.Save("C:\\Documents and Settings\\Lalji\\Desktop\\image1.png");
MessageBox.Show("Process done");
}
It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 9 years ago.
I am trying to convert an image (lets say black and white) to a Matrix (where 0 = black and 1 = white)
i tried with this code :
procedure TForm1.Button1Click(Sender: TObject);
type
tab = array[1..1000,1..1000] of byte;
var i,j: integer;
s : string;
image : TBitmap;
t : tab;
begin
image := TBitmap.Create;
image.LoadFromFile('c:\image.bmp');
s := '';
for i := 0 to image.Height do
begin
for j := 0 to image.Width do
begin
if image.Canvas.Pixels[i,j] = clWhite then
t[i,j] := 0
else
t[i,j] := 1;
end;
end;
for i := 0 to image.Height do
begin
for j := 0 to image.Width do
begin
s:=s + IntToStr(t[i,j]);
end;
Memo1.Lines.Add(s);
s:='';
end;
end;
But it gave me wrong results.
Any Idea?
There are five bugs and two other issues in your code!
First,
for i := 0 to image.Height do
must be replaced by
for i := 0 to image.Height - 1 do
(why?) and similarly,
for j := 0 to image.Width do
must be replaced by
for j := 0 to image.Width - 1 do
Second, the Pixels array takes arguments [x, y], not [y, x]. Hence, you need to replace
image.Canvas.Pixels[i,j]
by
image.Canvas.Pixels[j,i]
Third, you wrote "0 = black and 1 = white" but obviously you do the opposite!
Fourth, you try to access t[0, 0], even though your matrix starts indexing at 1. Use array[0..1000,0..1000] of byte; to fix that.
Fifth, you have a memory leak (image isn't freed -- use try..finally).
Also, it is better to use dynamic arrays:
type
TByteMatrix = array of array of byte;
var
mat: TByteMatrix;
and you begin with
SetLength(mat, image.Height - 1, image.Width - 1);
if you want it to index [y, x], and opposite otherwise.
Finally, you should not use the Pixels property at all in this case, since it is terribly slow. Instead, use the Scanline property. See this or that or something else for more information.
Also, you will gain a lot of speed simply by adding Memo1.Lines.BeginUpdate before and Memo1.Lines.EndUpdate after the update of the memo control.
The following procedure converts the input ABitmap bitmap to a multidimensional AMatrix array of bytes, which represents pixels and where 0 value means white pixel and 1 means any other color:
type
TPixelMatrix = array of array of Byte;
procedure BitmapToMatrix(ABitmap: TBitmap; var AMatrix: TPixelMatrix);
type
TRGBBytes = array[0..2] of Byte;
var
I: Integer;
X: Integer;
Y: Integer;
Size: Integer;
Pixels: PByteArray;
SourceColor: TRGBBytes;
const
TripleSize = SizeOf(TRGBBytes);
begin
case ABitmap.PixelFormat of
pf24bit: Size := SizeOf(TRGBTriple);
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('ABitmap must be 24-bit or 32-bit format!');
end;
SetLength(AMatrix, ABitmap.Height, ABitmap.Width);
for I := 0 to TripleSize - 1 do
SourceColor[I] := Byte(clWhite shr (16 - (I * 8)));
for Y := 0 to ABitmap.Height - 1 do
begin
Pixels := ABitmap.ScanLine[Y];
for X := 0 to ABitmap.Width - 1 do
begin
if CompareMem(#Pixels[(X * Size)], #SourceColor, TripleSize) then
AMatrix[Y, X] := 0
else
AMatrix[Y, X] := 1;
end;
end;
end;
This procedure prints out the multidimensional AMatrix array of bytes to the AMemo memo box:
procedure ShowPixelMatrix(AMemo: TMemo; const AMatrix: TPixelMatrix);
var
S: string;
X: Integer;
Y: Integer;
begin
AMemo.Clear;
AMemo.Lines.BeginUpdate;
try
AMemo.Lines.Add('Matrix size: ' + IntToStr(Length(AMatrix[0])) + 'x' +
IntToStr(Length(AMatrix)));
AMemo.Lines.Add('');
for Y := 0 to High(AMatrix) do
begin
S := '';
for X := 0 to High(AMatrix[Y]) - 1 do
begin
S := S + IntToStr(AMatrix[Y, X]);
end;
AMemo.Lines.Add(S);
end;
finally
AMemo.Lines.EndUpdate;
end;
end;
And the usage of the above procedures:
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
PixelMatrix: TPixelMatrix;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('d:\Image.bmp');
BitmapToMatrix(Bitmap, PixelMatrix);
finally
Bitmap.Free;
end;
ShowPixelMatrix(Memo1, PixelMatrix);
end;
This extension of the above BitmapToMatrix procedure allows you to specify at which luminance level given by the AMinIntensity parameter will be pixels taken as non-white.
The more the AMinIntensity value is closer to 0, the more lighter pixels are treated as non-white. This allows you to work with a color intensity tolerance (e.g. to better recognize antialiased text):
procedure BitmapToMatrixEx(ABitmap: TBitmap; var AMatrix: TPixelMatrix;
AMinIntensity: Byte);
type
TRGBBytes = array[0..2] of Byte;
var
X: Integer;
Y: Integer;
Gray: Byte;
Size: Integer;
Pixels: PByteArray;
begin
case ABitmap.PixelFormat of
pf24bit: Size := SizeOf(TRGBTriple);
pf32bit: Size := SizeOf(TRGBQuad);
else
raise Exception.Create('ABitmap must be 24-bit or 32-bit format!');
end;
SetLength(AMatrix, ABitmap.Height, ABitmap.Width);
for Y := 0 to ABitmap.Height - 1 do
begin
Pixels := ABitmap.ScanLine[Y];
for X := 0 to ABitmap.Width - 1 do
begin
Gray := 255 - Round((0.299 * Pixels[(X * Size) + 2]) +
(0.587 * Pixels[(X * Size) + 1]) + (0.114 * Pixels[(X * Size)]));
if Gray < AMinIntensity then
AMatrix[Y, X] := 0
else
AMatrix[Y, X] := 1;
end;
end;
end;
Memo lines position is decline, but your looping image.height first its will be result reverse in memo, to that try this code
procedure TForm1.Button1Click(Sender: TObject);
var i,j: integer;
s : string;
image : TBitmap;
begin
image := TBitmap.Create;
image.LoadFromFile('c:\image.bmp');
s := '';
for i := 0 to image.width-1 do
begin
for j := 0 to image.Height-1 do
begin
if image.Canvas.Pixels[i,j] = clWhite then
s := s+'0'
else
s := s+'1';
end;
memo1.Lines.Add(s);
s:='';
end;
end;
I'm trying to implement A* path finding algorithm (now it's Dijkstra's algorithm i.e without heuristic) using this article Link. But I can't figure out what's wrong in my code (it finds incorrect path).
instead of the empty begin ... end; it should be this step:
If it is on the open list already, check to see if this path to that
square is better, using G cost as the measure. A lower G cost means
that this is a better path. If so, change the parent of the square to
the current square, and recalculate the G and F scores of the square.
but I think it is not important because there is no diagonal movement.
uses
crt;
const
MAXX = 20;
MAXY = 25;
type
TArr = array [0..MAXY, 0..MAXX] of integer;
TCell = record
x: integer;
y: integer;
end;
TListCell = record
x: integer;
y: integer;
G: integer;
parent: TCell;
end;
TListArr = array [1..10000] of TListCell;
TList = record
arr: TListArr;
len: integer;
end;
var
i, j, minind, ind, c: integer;
start, finish: TCell;
current: TListCell;
field: TArr;
opened, closed: TList;
procedure ShowField;
var
i, j: integer;
begin
textcolor(15);
for i := 0 to MAXX do
begin
for j := 0 to MAXY do
begin
case field[j, i] of
99: textcolor(8); // not walkable
71: textcolor(14); // walkable
11: textcolor(10); // start
21: textcolor(12); // finish
15: textcolor(2); // path
14: textcolor(5);
16: textcolor(6);
end;
write(field[j, i], ' ');
end;
writeln;
end;
textcolor(15);
end;
procedure AddClosed(a: TListCell);
begin
closed.arr[closed.len + 1] := a;
inc(closed.len);
end;
procedure AddOpened(x, y, G: integer);
begin
opened.arr[opened.len + 1].x := x;
opened.arr[opened.len + 1].y := y;
opened.arr[opened.len + 1].G := G;
inc(opened.len);
end;
procedure DelOpened(n: integer);
var
i: integer;
begin
AddClosed(opened.arr[n]);
for i := n to opened.len - 1 do
opened.arr[i] := opened.arr[i + 1];
dec(opened.len);
end;
procedure SetParent(var a: TListCell; parx, pary: integer);
begin
a.parent.x := parx;
a.parent.y := pary;
end;
function GetMin(var a: TList): integer;
var
i, min, mini: integer;
begin
min := MaxInt;
mini := 0;
for i := 1 to a.len do
if a.arr[i].G < min then
begin
min := a.arr[i].G;
mini := i;
end;
GetMin := mini;
end;
function FindCell(a: TList; x, y: integer): integer;
var
i: integer;
begin
FindCell := 0;
for i := 1 to a.len do
if (a.arr[i].x = x) and (a.arr[i].y = y) then
begin
FindCell := i;
break;
end;
end;
procedure ProcessNeighbourCell(x, y: integer);
begin
if (field[current.x + x, current.y + y] <> 99) then // if walkable
if (FindCell(closed, current.x + x, current.y + y) <= 0) then // and not visited before
if (FindCell(opened, current.x + x, current.y + y) <= 0) then // and not added to list already
begin
AddOpened(current.x + x, current.y + y, current.G + 10);
SetParent(opened.arr[opened.len], current.x, current.y);
// field[opened.arr[opened.len].x, opened.arr[opened.len].y]:=16;
end
else
begin
end;
end;
begin
randomize;
for i := 0 to MAXX do
for j := 0 to MAXY do
field[j, i] := 99;
for i := 1 to MAXX - 1 do
for j := 1 to MAXY - 1 do
if random(5) mod 5 = 0 then
field[j, i] := 99
else field[j, i] := 71;
// start and finish positions coordinates
start.x := 5;
start.y := 3;
finish.x := 19;
finish.y := 16;
field[start.x, start.y] := 11;
field[finish.x, finish.y] := 21;
ShowField;
writeln;
opened.len := 0;
closed.len := 0;
AddOpened(start.x, start.y, 0);
SetParent(opened.arr[opened.len], -1, -1);
current.x := start.x;
current.y := start.y;
repeat
minind := GetMin(opened);
current.x := opened.arr[minind].x;
current.y := opened.arr[minind].y;
current.G := opened.arr[minind].G;
DelOpened(minind);
ProcessNeighbourCell(1, 0); // look at the cell to the right
ProcessNeighbourCell(-1, 0); // look at the cell to the left
ProcessNeighbourCell(0, 1); // look at the cell above
ProcessNeighbourCell(0, -1); // look at the cell below
if (FindCell(opened, finish.x, finish.y) > 0) then
break;
until opened.len = 0;
// count and mark path
c := 0;
while ((current.x <> start.x) or (current.y <> start.y)) do
begin
field[current.x, current.y] := 15;
ind := FindCell(closed, current.x, current.y);
current.x := closed.arr[ind].parent.x;
current.y := closed.arr[ind].parent.y;
inc(c);
end;
ShowField;
writeln(c);
readln;
end.
Edit Feb 1 '12: updated code, also fixed path marking (there should be or instead and), looks like it works now :)
You should rewrite the program to use a loop instead of cut-and-paste to visit each neighbor. If you do that you will avoid bugs like the following:
if (field[current.x, current.y - 1] <> 99) then
if (FindCell(closed, current.x, current.y - 1) <= 0) then
if (FindCell(opened, current.x + 1, current.y) <= 0) then
(See the inconsistent current.x + 1, current.y in the last line.)
With respect to the loop, I was thinking of something like this (pseudo-Python):
neighbor_offsets = [(0, 1), (0, -1), (1, 0), (-1, 0)]
for offset in neighbor_offsets:
neighbor = current + offset
if is_walkable(neighbor) and not is_visited(neighbor):
# Open 'neighbor' with 'current' as parent:
open(neighbor, current)
# Perhaps check if the goal is reached:
if neighbor == finish:
goal_reached = True
break
If you don't write a loop but just refactor to
ProcessCell(x+1, y);
ProcessCell(x-1, y);
ProcessCell(x, y-1);
ProcessCell(x, y-1);
then that's a great improvement too.
Youre posting quite a lot of code, have you tried narrow it down where it fails?
Have you compared your code with the pseudocode on wikipedia?
Also remember that dijkstra is just A* with a heuristic of 0.
Edit:
The article you linked (which I now realize is the very same I used to learn the A*, funny) contains illustrated steps. I would suggest that you recreate that map/grid and run your implementation on it. Then step through the images:
Are the eight initial neighbors added to the open list? Do they have the correct parent?
Is the correct open node picked as next to be scanned according to the heuristic?
Is the list of closed nodes correct?
And so on...
In DelphiXE, I'm using a tFileOpenDialog to select a folder and then listing all the *.jpg files in that folder in a tListBox. I'm allowing the list items to be dragged and dropped within the list for custom sorting so that I can display them in order later.
I'd like to be able to draw a thumbnail of the image beside the filename so that the display is similar to Windows Explorer when looking at files in List view where you have the associated icon just left of the file name on the same row.
I've found a couple of old examples that lead me to believe this is possible using tListBox.onDrawItem, but I've been unable to get one to work.
What is the best approach to take to accomplish this goal using a tListBox, or by some other means?
Thanks for your help.
Update: I've been working to use tListView instead, as suggested.
I've attempted to convert the examples from Ken and Andreas to use actual images instead of dynamically created sample bitmaps. I was able to get the basics working, but without resizing, I get only the top left of the image 64*64. I'm only working with JPGs at this point. imagecount is just the count of my list of filenames in my listbox, I haven't moved the initial list creation into the listview at this point.
That is done with this code:
procedure TfrmMain.CreateThumbnails;
var
i: Integer;
FJpeg: TJpegImage;
R: TRect;
begin
for i := 0 to imageCount - 1 do
begin
FJpeg := TJpegImage.Create;
thumbs[i] := TBitmap.Create;
FJpeg.LoadFromFile(Concat(imgFolderlabel.caption,
photoList.Items.Strings[i]));
thumbs[i].Assign(FJpeg);
thumbs[i].SetSize(64, 64);
end;
imgListView.LargeImages := ImageList1;
FJpeg.Free;
end;
In order to also resize and stretch the image properly within the thumbnail, I'm trying to implement some code from here: http://delphi.about.com/od/graphics/a/resize_image.htm
The new code looks like:
procedure TfrmMain.CreateThumbnails;
var
i: Integer;
FJpeg: TJpegImage;
R: TRect;
begin
for i := 0 to imageCount - 1 do
begin
FJpeg := TJpegImage.Create;
thumbs[i] := TBitmap.Create;
FJpeg.LoadFromFile(Concat(imgFolderlabel.caption,
photoList.Items.Strings[i]));
thumbs[i].Assign(FJpeg);
//resize code
R.Left := 0;
R.Top := 0;
// proportional resize
if thumbs[i].Width > thumbs[i].Height then
begin
R.Right := 64;
R.Bottom := (64 * thumbs[i].Height) div thumbs[i].Width;
end
else
begin
R.Bottom := 64;
R.Right := (64 * thumbs[i].Width) div thumbs[i].Height;
end;
thumbs[i].Canvas.StretchDraw(R, thumbs[i]);
// resize image
//thumbs[i].Width := R.Right;
//thumbs[i].Height := R.Bottom;
thumbs[i].SetSize(64, 64); //all images must be same size for listview
end;
imgListView.LargeImages := ImageList1;
FJpeg.Free;
end;
This gives me a collage of image thumbnails with their filenames and works good.
Thank you.
Not an answer, but an alternative (using Andreas' code for creating the image array as a starting point). Drop a TListView and a TImageList on a new form, cut all the code from the editor from the interface to just above the final end. with this:
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ComCtrls;
type
TForm1 = class(TForm)
ImageList1: TImageList;
ListView1: TListView;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
procedure CreateListItems;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
N = 50;
THUMB_WIDTH = 32;
THUMB_HEIGHT = 32;
THUMB_PADDING = 4;
var
thumbs: array[0..N-1] of TBitmap;
procedure CreateThumbnails;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
thumbs[i] := TBitmap.Create;
thumbs[i].SetSize(THUMB_WIDTH, THUMB_HEIGHT);
thumbs[i].Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
thumbs[i].Canvas.FillRect(Rect(0, 0, THUMB_WIDTH, THUMB_HEIGHT));
end;
end;
procedure TForm1.CreateListItems;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
with ListView1.Items.Add do
begin
Caption := 'Item ' + IntToStr(i);
ImageIndex := i;
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
var
i: Integer;
begin
CreateThumbnails;
for i := 0 to N - 1 do
ImageList1.Add(thumbs[i], nil);
ListView1.LargeImages := ImageList1;
CreateListItems;
end;
OnDrawItem is a good way to go.
Simple example:
const
N = 50;
THUMB_WIDTH = 64;
THUMB_HEIGHT = 64;
THUMB_PADDING = 4;
var
thumbs: array[0..N-1] of TBitmap;
procedure CreateThumbnails;
var
i: Integer;
begin
for i := 0 to N - 1 do
begin
thumbs[i] := TBitmap.Create;
thumbs[i].SetSize(THUMB_WIDTH, THUMB_HEIGHT);
thumbs[i].Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
thumbs[i].Canvas.FillRect(Rect(0, 0, THUMB_WIDTH, THUMB_HEIGHT));
end;
end;
procedure TForm4.FormCreate(Sender: TObject);
var
i: integer;
begin
with ListBox1.Items do
begin
BeginUpdate;
for i := 0 to N - 1 do
Add(Format('This is item %d.', [i]));
EndUpdate;
end;
ListBox1.ItemHeight := 2*THUMB_PADDING + THUMB_HEIGHT;
CreateThumbnails;
end;
procedure TForm4.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
dc: HDC;
s: string;
r: TRect;
begin
dc := TListBox(Control).Canvas.Handle;
s := TListBox(Control).Items[Index];
FillRect(dc, Rect, GetStockObject(WHITE_BRUSH));
BitBlt(dc,
Rect.Left + THUMB_PADDING,
Rect.Top + THUMB_PADDING,
THUMB_WIDTH,
THUMB_HEIGHT,
thumbs[Index].Canvas.Handle,
0,
0,
SRCCOPY);
r := Rect;
r.Left := Rect.Left + 2*THUMB_PADDING + THUMB_WIDTH;
DrawText(dc,
PChar(s),
length(s),
r,
DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);
end;
In a real-world scenario, the thumbs array would contain the actual image thumbs. In this example, however, the "thumbnails" consist of single-colour squares.