Delphi> Vertical scanline? (Get columns instead of rows?) - delphi

I'm trying to write an algorithm that will detect the space between 'RF' and 'WOOLF in the image below.
I need something like Scanline for COLUMNS not rows.
My algorithm will be scanning each column for the presence of black pixels, if it finds any it will store '1', else it will store '0', so for example the image above might be:
000001111111111111111111100000000000000000000000011111111111111111111111111111111111111111111111111
so I will know that the space starts on pixel 30.

Why can't you just access the pixels through Scanline?
for i := 0 to (column count)-1 do begin //enumerate columns
black_pixels:=false
for j := 0 to (row count)-1 do //enumerate scanlines
if PByte(integer(Scanline[j]) + i)^=0 then begin
//black pixels in column i
black_pixels:=true;
break;
end;
end;
(just an example, I don't remember the specifics of using scanline)
Even if you're concerned with locality, you can just setup an array of size (column count), and update it while scanning through j, i:
for j := 0 to (row count)-1 do
for i := 0 to (column count)-1 do
if PByte(integer(Scanline[j]) + i)^=0 then
blackpixels[i] := true;
For 1-bit images the data is stored in scanline by bits, though (see this document). To access bit k of BYTE_VALUE (counting from 0), use:
((BYTE_VALUE shr k) and 1)
As requested, additional explanations on how this works.
"Shl" and "shr" are "shift left" and "shift right" operations. What they do is shift the bits inside of the byte to the left (highest bit side) and to the right (lowest bit side). For instance:
01101101 shr 0 = 01101101
01101101 shr 1 = 00110110
01101101 shr 2 = 00011011
01101101 shr 3 = 00001101
In the same way
01101101 shl 0 = 01101101
01101101 shl 1 = 11011010
01101101 shl 2 = 10110100
01101101 shl 3 = 01101000
Binary AND ("C := A and B") is an operation which for every bit, takes it's values from A and from B and sets it's value in C to 1 only when A and B have 1's at the same place.
For instance:
01101101 and
00000000 =
00000000 (B has no 1's at all)
01101101 and
11111111 =
01101101 (B has all 1's, so every 1 from A is transferred to C)
01101101 and
11001100 =
01001100
Therefore what ((BYTE_VALUE shr (i-1)) and 1) does is:
First, shifts BYTE_VALUE (i-1) bits to the right, thus making it's i-th bit the rightmost. But the new BYTE_VALUE can still have unrelated bits to the left of it.
Then, zeroes out all the bits except for the new rightmost.
For instance, if we want to know the 5th rightmost bit of 01101101, we shr it by 4:
01101101 shr 4 = 00000110
But although the rightmost bit is zero, the whole value is still not zero. We AND it with 1 == 00000001:
00000110 and 00000001 = 00000000 = 0
Back to the topic. When your columns are packed by bits, this is how you enumerate them:
setLength(blackpixels, ColumnCount);
for i := 0 to ColumnCount - 1 do
blackpixels[i] := false;
for j := 0 to RowCount-1 do
for i := 0 to ColumnCount div 8-1 do begin
byte_value := PByte(integer(Bitmap.Scanline[j]) + i)^; //read the byte which contains 8 columns
for k := 0 to 7 do
if ((byte_value shr (7-k)) and 1)=0 then
blackpixels[i*8+k] := true;
end;
Here's the working example, just in case:
//Assuming img is declared as img: TImage;
//mm is declared as mm: TMemo;
var blackpixels: array of boolean;
i, j, k: integer;
byte_value: byte;
RowCount, ColumnCount: integer;
Bitmap: TBitmap;
s: string;
begin
RowCount := img.Picture.Bitmap.Height;
ColumnCount := img.Picture.Bitmap.Width;
Bitmap := img.Picture.Bitmap;
setLength(blackpixels, ColumnCount);
for i := 0 to ColumnCount - 1 do
blackpixels[i] := false;
if Bitmap.PixelFormat=pf1Bit then begin
for j := 0 to RowCount-1 do
for i := 0 to ColumnCount div 8-1 do begin
byte_value := PByte(integer(Bitmap.Scanline[j]) + i)^; //read the byte which contains 8 columns
for k := 0 to 7 do
if ((byte_value shr (7-k)) and 1)=0 then //(7-k) because pixels seems to be stored inside of the byte "left-to-right" (highest to lowest)
blackpixels[i*8+k] := true;
end;
end else
raise Exception.Create('Invalid pixel format');
//Print array
if ColumnCount > 0 then
s := BoolToStr(blackpixels[0], false)
else s := '';
for i := 1 to ColumnCount - 1 do
s := s + ', ' + BoolToStr(blackpixels[i], false);
s := '(' + s + ')';
mm.Lines.Add(s);

Related

Byte array to Signed integer in Delphi

source array(4 bytes)
[$80,$80,$80,$80] =integer 0
[$80,$80,$80,$81] = 1
[$80,$80,$80,$FF] = 127
[$80,$80,$81,$01] = 128
need to convert this to integer.
below is my code and its working at the moment.
function convert(b: array of Byte): Integer;
var
i, st, p: Integer;
Negative: Boolean;
begin
result := 0;
st := -1;
for i := 0 to High(b) do
begin
if b[i] = $80 then Continue // skip leading 80
else
begin
st := i;
Negative := b[i] < $80;
b[i] := abs(b[i] - $80);
Break;
end;
end;
if st = -1 then exit;
for i := st to High(b) do
begin
p := round(Power(254, High(b) - i));
result := result + b[i] * p;
result := result - (p div 2);
end;
if Negative then result := -1 * result
end;
i'm looking for a better function?
Update:
file link
https://drive.google.com/file/d/0ByBA4QF-YOggZUdzcXpmOS1aam8/view?usp=sharing
in uploaded file ID field offset is from 5 to 9
NEW:
Now i got into new problem which is decoding date field
Date field hex [$80,$8F,$21,$C1] -> possible date 1995-12-15
* in uploaded file date field offset is from 199 to 203
Just an example of some improvements as outlined by David.
The array is passed by reference as a const.
The array is fixed in size.
The use of floating point calculations are converted directly into a constant array.
Const
MaxRange = 3;
Type
TMySpecial = array[0..MaxRange] of Byte;
function Convert(const b: TMySpecial): Integer;
var
i, j: Integer;
Negative: Boolean;
Const
// Pwr[i] = Round(Power(254,MaxRange-i));
Pwr: array[0..MaxRange] of Cardinal = (16387064,64516,254,1);
begin
for i := 0 to MaxRange do begin
if (b[i] <> $80) then begin
Negative := b[i] < $80;
Result := Abs(b[i] - $80)*Pwr[i] - (Pwr[i] shr 1);
for j := i+1 to MaxRange do
Result := Result + b[j]*Pwr[j] - (Pwr[j] shr 1);
if Negative then
Result := -Result;
Exit;
end;
end;
Result := 0;
end;
Note that less code lines is not always a sign of good performance.
Always measure performance before optimizing the code in order to find real bottlenecks.
Often code readability is better than optimizing over the top.
And for future references, please tell us what the algorithm is supposed to do.
Code for testing:
const
X : array[0..3] of TMySpecial =
(($80,$80,$80,$80), // =integer 0
($80,$80,$80,$81), // = 1
($80,$80,$80,$FF), // = 127
($80,$80,$81,$01)); // = 128
var
i,j: Integer;
sw: TStopWatch;
begin
sw := TStopWatch.StartNew;
for i := 1 to 100000000 do
for j := 0 to 3 do
Convert(X[j]);
WriteLn(sw.ElapsedMilliseconds);
ReadLn;
end.

Lift UInt64 limits with strings in Delphi

I'm reaching my limit with UInt64 and I was wondering if there are functions which do simple operating options such as +/- , etc. with just strings because they can store just as much RAM as you have... (theoretically)
For example I would like to calculate
24758800785707605497982484480 + 363463464326426 and get the result as a string.
I kinda know how to solve this problems with strings using the number system 0123456789 and kinda do digit by digit and overflow the next position - which would cost a lot more power, but I wouldn't mind this issue...
I would like to have this ability to do such calculations until my RAM just blows up (which would be the real limit...)
Are there such functions which already do that?
Arbitrarily large integers are not supported at the language level in Delphi, but a bit of Googling turns up http://www.delphiforfun.org/programs/Library/big_integers.htm, which can support them as alibrary.
On super computers, its called BCD math (Binary Coded Decimals) and each half-byte of RAM represents a decimal digit [0..9] - not an efficient use of RAM, but huge computations take minimal time (i.e. about 3 mSecs to multiply 2 million digit numbers. A BCD Emulator on a fast PC takes 5 or 6 minutes.
I never need to add big numbers, but I do multiply. Actually I call this routine iteratively to compute for example, 1000000 factorial (a 5,565,709 million digit answer. Str6Product refers to how it chops up a pair of string numbers. s1 and s2 have a practical length limit of about 2^31. The function is limited by what a "string can hold". Whatever that limit is, I've never gotten there.
//==============================================================================
function Str6Product(s1: string; s2: string): string; // 6-13 5:15 PM
var
so,snxt6 : string;
z1,z3, i, j, k : Cardinal; // Cardinal is 32-bit unsigned
x1,x3,xm : Cardinal;
countr : Cardinal;
a1, a2, a3 : array of Int64;
inum, icarry : uInt64; // uInt64 is 64-bit signed
begin
s1 := '00000'+s1;
s2 := '00000'+s2;
z1 := length(s1); // set size of Cardinal arrays
z3 := z1 div 6;
x1 := length(s2); // set size of Cardinal arrays
x3 := x1 div 6;
xm := max(x3,z3);
SetLength(a1,xm+1);
SetLength(a2,xm+1);
// try to keep s1 and s2 about the
// same length for best performance
for i := 1 to xm do begin // from rt 2 lft - fill arrays
// with 4-byte integers
if i <= z3 then a1[i] := StrToInt(copy (s1, z1-i*6+1, 6));
if i <= x3 then a2[i] := StrToInt(copy (s2, x1-i*6+1, 6));
if i > z3 then a1[i] := 0;
if i > x3 then a2[i] := 0;
end;
k := max(xm-x3, xm-z3); // k prevents leading zeroes
SetLength(a3,xm+xm+1);
icarry := 0; countr := 0;
icMax := 0; inMax := 0;
for i := 1 to xm do begin // begin 33 lines of "string mult" engine
inum := 0;
for j := 1 to i do
inum := inum + (a1[i-j+1] * a2[j]);
icarry := icarry + inum;
if icMax < icarry then icMax := icarry;
if inMax < inum then inMax := inum;
inum := icarry mod 1000000;
icarry := icarry div 1000000;
countr := countr + 1;
a3[countr] := inum;
end;
if xm > 1 then begin
for i := xm downto k+1 do begin // k or 2
inum := 0;
for j := 2 to i do
inum := inum + (a1[xm+j-i] * a2[xm-j+2]);
icarry := icarry + inum;
if icMax < icarry then icMax := icarry;
if inMax < inum then inMax := inum;
inum := icarry mod 1000000;
icarry := icarry div 1000000;
countr := countr + 1;
a3[countr] := inum;
end;
end;
if icarry >= 1 then begin
countr := countr + 1;
a3[countr] := icarry;
end;
so := IntToStr(a3[countr]);
for i := countr-1 downto 1 do begin
snxt6 := IntToStr(a3[i]+1000000);
so := so+ snxt6[2]+ snxt6[3]+ snxt6[4]+ snxt6[5]+ snxt6[6]+ snxt6[7];
end;
while so[1] = '0' do // leading zeroes may exist
so := copy(so,2,length(so));
result := so;
end;
//==============================================================================
Test call:
StrText := Str6Product ('742136061320987817587158718975871','623450632948509826743508972875');
I should have added that you should be able to add large numbers using the same methodology - From right to left, fragment the strings into 16 byte chunks then convert those chunks to uInt64 variables. Add the least significant digits first and if it produces a 17th byte, carry that over to the 2nd least significant chunk, add those two PLUS any carry over etc. When otherwise done, convert each 16-byte chunk back to string and concatenate accordingly.
The conversions to and from integer to string and vice-versa is a pain, but necessary for big number arithmetic.

Fast linear list that excludes duplicates

I have the following code:
procedure TCellBlock.GeneratePtoQ;
var
x,y: integer;
i: integer;
Change: cardinal;
begin
i:= 0;
//Walk the grid of changed (alive) cells
for x:= GridMaxX downto 1 do begin
for y:= GridMaxY downto 1 do begin
if Active[cIndexP][x, y] then begin
Active[cIndexP][x,y]:= false;
//Put active items on the stack.
ToDo[i]:= x shl 16 or y;
Inc(i);
end; {if}
end; {for y}
end; {for x}
while i > 0 do begin
Dec(i);
y:= ToDo[i] and $FFFF;
x:= ToDo[i] shr 16;
//Calculate the cell, Change = (oldval XOR newval)
Change:= Grid[x,y].GeneratePtoQ;
//Mark the cells in the grid that need to be recalculated next generation.
Active[cIndexQ][x,y]:= Active[cIndexQ][x,y] or (Change <> 0);
Active[cIndexQ][x+1,y+1]:= Active[cIndexQ][x+1,y+1] or ((Change and $cc000000) <> 0);
Active[cIndexQ][x+1,y]:= Active[cIndexQ][x+1,y] or ((Change and $ff000000) <> 0);
Active[cIndexQ][x,y+1]:= Active[cIndexQ][x,y+1] or ((Change and $cccccccc) <> 0);
end; {while}
end;
The above is a code snippet of a test program that calculates conway's game of life.
The code needs to be as fast as possible. And for this purpose I'm trying different approaches.
It walks though a grid of active cells, looks to see which cells are active and puts those
on a stack.
Next it processes the items on the stack and sees which cells have changed.
If a cell has changed it updates the changes into the grid for the next generation.
I store cells in 32bit cardinals (4 bits Y, 8 bits X) and the P (even) generations are offset 1,1 pixel relative to the Q (odd) generations, this way I only have to take 3 neighbors into account instead of 8.
Question
I want to get rid of the grid, I just want to deal with the stack.
How do I implement a stack that eliminates duplicates?
Note that it needs to be as fast as possible and I'm not above using dirty tricks to get that.
if i understood what you asked you want the stack to have no duplication values. i'm not a delphi person but if it was java i would created a hashmap/ map tree and add each value to the map and before adding it to the stack check if it's already in the hash. you can also add all the values th the hash iterate it but you will loose the order of the hash.
Personally I'd take a completely different approach. First I don't see how you don't have to take all neighbours into account just because of using a 1,1 offset and then I doubt that bitshifting tricks make the algorithm much faster (often enough it's the contrary, but then it could be mem bandwidth constrained in which case we'd win a bit)
So I'd just go for the one thing that should bring by far the largest performance gain: Making the algorithm multithreaded. In our world of Quad/Hex/Octacores worrying about a few percent performance increases while wasting 300% or more seems silly. So if we'd ignore the active grids and check all fields the algorithm would be trivial with some great scaling, especially since one could easily vectorize the algorithm, but then that's not especially work efficient so I'd try some different approaches towards multithreading an algorithm that only takes the active cells in account.
First instead of getting rid of the grid I'd double it: One src and one dest grid - that are swapped each round. No locking to access the grid necessary, don't have to worry about when updating the fields and no stale entries (important for multithreading we want to use the cache after all).
Now the simplest solution would be to use some kind of concurrent list structure (no idea about delphi libraries) for the active cells and let each thread steal from it and add new active cells to another. With a good lock-free implementation of a concurrent queue (basically whatever the replacement of this is in delphi) or something similar could be quite nice and simple. For a better performance instead of adding single nodes to the list, I'd think about adding whole chunks to the list, say in sizes of 10 or so - more work with less overhead but if we make the chunks too large we lose parallelism.
I can think of other solutions like giving every thread one list of active cells to work through (or more exactly one list for all and different offsets) but then we have to between each run gather all new entries (not much synchronization overhead but some copying) into a list - worth a try I assume.
If your goal is speed (and only speed). There is a few tricks that can speed things up a LOT. My own implementation of the Conway's Game of Life use those tricks to make it faster. Note that it is VERY expensive on memory.
Each cells are an object
Each cell object contains its X/Y coordinates
Each cell object contains a "live" counters of the number of Alive neighbors. (When a cell turns On/Off, it notify it's neighbor so they update their counters.
To make #3 works, when the next generation is calculated, cells are not turned On/Off right away. They are instead stacked into a list until all cells are calculated.
Each cell has a counter which indicate which is the last generation they changed on. That avoid calculating the same cell twice. (My alternative to the stack that eliminates duplicates)
The list of #5 is reused on the next generation, as only the neighbors of a cell that changed on the previous generation can change on the current one.
There are some of the tricks I use to speed up the generation. Some of the tricks listed here will get you a lot more than multithreading your implementation. But using both those and multithread will get the most performance possible.
As for the multithread subject, read Voo's entry.
I've been thinking about it and I think I have a solution.
some background
Here's how the data is in laid out in memory
00 A 08 B 10 18 The bits of Individual int32's are layout like this:
01 | 09 | 11 19 00 04 08 0C 10 14 18 1C // N-Mask: $33333333
02 | 0A | 12 1A 01 05 09 0D 11 15 19 1D // S-Mask: $cccccccc
03 | 0B | 13 1B 02 06 0A 0E 12 16 1A 1E // W-Mask: $000000ff
04 | 0C | 14 1C 03 07 0B 0F 13 17 1B 1F // E-Mask: $ff000000
05 | 0D | 15 1D //SE-Mask: $cc000000
06 | 0E | 16 1E //NW-Mask: $00000033
07 V 0F V 17 1F I can mask of different portions if need be.
-- Figure A: Grid -- -- Figure B: cell -- -- Table C: masks --
I haven't decided on the size of the building block, but this is the general idea.
Even generations are called P, odd generations are called Q.
They are staggered like this
+----------------+<<<<<<<< P 00 04 08 0C //I use a 64K lookup
|+---------------|+ 01 05* 09* 0D //table to lookup
|| || 02 06* 0A* 0E //the inner* 2x2 bits from
|| || 03 07 0B 0F //a 4x4 grid.
+----------------+| //I need to do 8 lookups for a 32 bit cell
+----------------+<<<<<<<< Q
- Figure D: Cells are staggered - -- Figure E: lookup --
This way when generating P -> Q, I only need to look at P itself and its S, SE, E neighbors, instead of all 8 neighbors, ditto for Q -> P. I need only look at Q itself and its N, NW and W neighbors.
Also notice that the staggering saves me time in translating the result of the lookup, because I have to do less bit shifting to put the results in place.
When I loop though a grid (Figure A) I walk though the cells (Figure B) in the order shown in figure A. Always in strictly increasing order in a P-cycle and always in decreasing order in a Q-cycle.
In fact the Q cycle works in exactly the opposite order from the P-cycle, this speeds things up by reusing the cache as much as possible.
I want to minimize using pointers as much as possible, because pointers cannot be predicted and are not accessed sequentially (they jump all over the place) So I want to use arrays, stacks and queues as much as possible.
What data do to need to keep track of
I need to keep track of only the cells that change. If a cell (that is an int32) does not change from one generation to the next I remove it from consideration.
This is what the code in the question does. It uses a grid to keep track of the changes, but I want to use a stack, not a grid; and I only want to deal with active cells I don't want to know about stable or dead cells.
Some background on the data
Notice how the cell itself is always monotonically increasing. As is its S-neighbor, as well as the E and SE-neighbor. I can use this info to cheat.
The solution
I use a stack to keep track of the cell itself and its S neighbor and a queue to keep track of its E and SE neighbor and when I'm done I merge the two.
Suppose in the Grid the following cells come out as active after I've calculated them:
00, 01, 08 and 15
I make the following two stacks:
stack A stack B
00 08 a) -A: Cell 00 itself in stack A and its E-neighbor in B
01 09 a) Cell 00's S neighbor in stack A and its SE-n'bor in B
02 0A b) -B: Cell 01 is already in the stack, we only add S/SE
08 10 c) -C: Cell 08 goes into the stack as normal
09 11 c) We'll sort out the merge later.
15 1D d) -D: Cell 15 and neighbors go on as usual.
16 1E d)
Now I push members from stack A and B onto a new stack C so that stack C has
no duplicates and it strictly increasing:
Here's the pseudo code to process the two queues:
a:= 0; b:= 0; c:=0;
while not done do begin
if stack[a] <= stack[b] then begin
stack[c]:= stack[a]; inc(a); inc(c);
if stack[a] = stack[b] then inc(b);
end
else begin
stack[c]:= stack[b]; inc(b); inc(c);
end;
end; {while}
And even better
I don't have to actually do the two stacks and the merging as two separate steps, if I make A a stack and B a queue, I can do the second step described in the pseudo code and the building of the two stacks in one pass.
Note
As a cell changes its S, E or SE border does not necessary need to change, but I can test for that using the masks in table C, and only add the cells that really need checking in the next generation to the list.
Benefits
Using this scheme, I only ever have to walk through one stack with active cells when calculating cells, so I don't waste time looking at dead or inactive cells.
I only do sequential memory accesses, maximizing cache usage.
Building the stack with new changes for the next generations only requires one extra temporary queue, which I process in strictly sequential order.
I do no sorting and the minimum of comparisons.
I don't have to keep track of the neighbors of each individual cells (int32), I only need to keep track of the neighbors (S,E,SE, N,W,NW) of the grids, this keeps the memory overhead to a minimum.
I don't need to keep track of a cells status, I only need to count dead cells (A cell is either dead, because it was dead before, or because it changed into dead. All the active cells are in my TODO stack, this saves bookkeeping time and memory space.
The algorithm runs in o(n) time where (n) is the number of active cells, it excludes dead cells, stable cells and cells that oscillate with period 2.
I only ever deal with 32 bit cardinals, which is the much faster than using int16's.
Mostly #Ken, the complete sourcecode for the test program:
Note that 99,9% of the time is spend in displaying, because I haven't done anything to
optimize that.
I've created a new SDI-main app and posted the code in that and because I'm lazy I haven't bothered to rename or repaint any controls.
Project file: sdiapp.dpr
program Sdiapp;
uses
Forms,
SDIMAIN in 'SDIMAIN.pas'; {Form1}
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Main form: sdimain.pas
unit SDIMAIN;
interface
uses Windows, Classes, Graphics, Forms, Controls, Menus,
Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, ImgList, StdActns,
ActnList, ToolWin;
{--------------------------------------------
p and q are bit arrays of 16x16 bits, grouped
as in 8 int32's as follows
P00 P04 P08 P0c P10 P14 P18 P1c
P01 P05 P09 P0d P11 P15 P19 P1d
P02 P06 P0a P0e P12 P16 P1a P1e
P03 P07 P0b P0f P13 P17 P1b P1f
|
+----> The bits per int32 are grouped as follows
The int32's are grouped as follows
P0 P1
P2 P3
P4 P5
P6 P7
P and Q are staggered as follows:
+---------------------------------+ <---- P
| +-------------------------------|-+ <----Q
| | | |
| | | |
... ...
| | | |
+-|-------------------------------+ |
+---------------------------------+
Generations start counting from 0,
all even generations are stored in P.
all odd generations are stored in Q.
When generating P->Q, the S, SE and E neighbors are checked.
When generating Q->P, the N, NW and W neighbors are checked.
The westernmost P edge in a grid is stored inside that grid.
Ditto for all easternmost Q edges.
--------------------------------------------}
const
cClearQState = $fffffff0;
cClearPState = $fffff0ff;
cIndexQ = 1;
cIndexP = 0;
ChangeSelf = 0;
ChangeNW = 1;
ChangeW = 2;
ChangeN = 3;
ChangeSE = 1;
ChangeE = 2;
ChangeS = 3;
const
//A Grid is 128 x 128 pixels.
GridSizeX = 512 div 8; //should be 128/8, 1024 for testing.
GridSizeY = GridSizeX * 2; //32 totaal: 16x32x4bytes = 2048 x 2 (p+q) = 4k per block.
GridMaxX = GridSizeX - 1;
GridMaxY = GridSizeY - 1;
NumberOfCells = GridSizeX * GridSizeY;
CellSizeX = 8;
CellSizeY = 4;
CellMaxX = CellSizeX - 1;
CellMaxY = CellSizeY - 1;
type
TUnit = Cardinal;
TBytes = array[0..3] of byte;
TChange = array[0..3] of boolean;
type
TCellBlock = class;
TFlags = record
case boolean of
true: (whole: cardinal);
false: (part: array[0..3] of byte);
end;
//TActiveList = array[0..GridMaxX, 0..GridMaxY] of boolean;
//TActive = array[0..1] of TActiveList;
TToDoList = array[-1..NumberOfCells] of cardinal; //Padding on both sides.
TNewRow = TFlags;
PCell = ^TCell;
TCell = record
public
p: TUnit;
q: TUnit;
procedure SetPixel(x,y: integer; InP: Boolean = true);
function GeneratePtoQ: cardinal; inline;
function GenerateQtoP: cardinal; inline;
end;
//A grid contains pointers to an other grid, a unit or nil.
//A grid can contain grids (and nils) or units (and nils), but not both.
PGrid = ^TGrid;
TGrid = array[0..GridMaxX,0..GridMaxY] of TCell;
TCellBlock = class(TPersistent)
private
FHasCells: boolean;
FLevel: integer;
FGrid: TGrid;
ToDoP: TToDoList;
ToDoQ: TToDoList;
PCount: integer;
QCount: integer;
FParent: TCellBlock;
FMyX,FMyY: integer;
N,W,NW: TCellBlock;
S,E,SE: TCellBlock;
procedure GeneratePtoQ; virtual;
procedure GenerateQtoP; virtual;
procedure UpdateFlagsPtoQ; virtual;
procedure UpdateFlagsQtoP; virtual;
procedure Generate; virtual;
procedure Display(ACanvas: TCanvas); virtual;
procedure SetPixel(x,y: integer);
property Grid: TGrid read FGrid write FGrid;
public
constructor Create(AParent: TCellBlock);
destructor Destroy; override;
property Parent: TCellBlock read FParent;
property HasCells: boolean read FHasCells;
property Level: integer read FLevel;
property MyX: integer read FMyX;
property MyY: integer read FMyY;
end;
TCellParent = class(TCellBlock)
private
procedure GeneratePtoQ; override;
procedure GenerateQtoP; override;
//procedure Display(Startx,StartY: integer; ACanvas: TCanvas); override;
public
constructor CreateFromChild(AChild: TCellBlock; ChildX, ChildY: integer);
constructor CreateFromParent(AParent: TCellParent);
destructor Destroy; override;
end;
type
TForm1 = class(TForm)
ToolBar1: TToolBar;
ToolButton9: TToolButton;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ActionList1: TActionList;
FileNew1: TAction;
FileOpen1: TAction;
FileSave1: TAction;
FileSaveAs1: TAction;
FileExit1: TAction;
EditCut1: TEditCut;
EditCopy1: TEditCopy;
EditPaste1: TEditPaste;
HelpAbout1: TAction;
StatusBar: TStatusBar;
ImageList1: TImageList;
Image1: TImage;
Timer1: TTimer;
Label1: TLabel;
procedure FileNew1Execute(Sender: TObject);
procedure FileSave1Execute(Sender: TObject);
procedure FileExit1Execute(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FileOpen1Execute(Sender: TObject);
procedure ToolButton4Click(Sender: TObject);
private
MyBlock: TCellBlock;
MyBitmap: TBitmap;
BitmapData: array[0..1024,0..(1024 div 32)] of integer;
procedure InitLookupTable;
procedure RestartScreen;
public
{ Public declarations }
end;
var
Form1: TForm1;
const
cLiveCell = $88888888;
cLiveVerticalP = $40404040;
cLiveVerticalQ = $04040404;
cLiveTop = $00000088;
cLiveBottom = $88000000;
cLivePCorner = $00000040;
cLiveQCorner = $04000000;
cUnstableCell = $22222222;
cUnstableVerticalP = $10101010;
cUnstableVerticalQ = $01010101;
cUnstableTop = $00000022;
cUnstableBottom = $22000000;
cUnstablePCorner = $00000010;
cUnstableQCorner = $01000000;
cAllDead = $00000000;
cAllLive = $ffffffff;
cLiveRow = $8;
cLive2x2 = $4;
cUnstableRow = $2;
cUnstable8x4 = $22;
cUnstable2x2 = $1;
cUnstable2x4 = $11;
cStateMask: array [0..7] of cardinal =
($fffffff0, $ffffff0f, $fffff0ff, $ffff0fff, $fff0ffff, $ff0fffff, $f0ffffff, $0fffffff);
var
LookupTable: array[0..$FFFF] of byte;
Generation: int64;
implementation
uses about, sysutils, clipbrd, Math;
{$R *.dfm}
type
bool = longbool;
procedure getCPUticks(var i : int64);
begin
asm
mov ECX,i;
RDTSC; //cpu clock in EAX,EDX
mov [ECX],EAX;
mov [ECX+4],EDX;
end;
end;
function IntToBin(AInt: integer): string;
var
i: integer;
begin
i:= SizeOf(AInt)*8;
Result:= StringOfChar('0',i);
while (i > 0) do begin
if Odd(AInt) then Result[i]:= '1';
AInt:= AInt shr 1;
Dec(i);
end; {while}
end;
constructor TCellBlock.Create(AParent: TCellBlock);
begin
inherited Create;
FParent:= AParent;
ToDoQ[-1]:= $ffffffff;
ToDoP[-1]:= $ffffffff;
end;
destructor TCellBlock.Destroy;
begin
inherited Destroy;
end;
procedure TCell.SetPixel(x: Integer; y: Integer; InP: Boolean = true);
var
Mask: cardinal;
Offset: Integer;
begin
//0,0 is the topleft pixel, no correction for p,q fase.
x:= x mod 8;
y:= y mod 4;
Offset:= x * 4 + y;
Mask:= 1 shl Offset;
if (InP) then p:= p or Mask else q:= q or Mask;
end;
procedure TCellBlock.SetPixel(x: Integer; y: Integer);
var
GridX, GridY: integer;
x1,y1: integer;
i: integer;
begin
x:= x + (GridSizeX div 2) * CellSizeX;
y:= y + (GridSizeY div 2) * CellSizeY;
if Odd(Generation) then begin
Dec(x); Dec(y);
QCount:= 0;
end
else PCount:= 0;
GridX:= x div CellSizeX;
GridY:= y div CellSizeY;
if (GridX in [0..GridMaxX]) and (GridY in [0..GridMaxY]) then begin
Grid[GridX,GridY].SetPixel(x,y);
i:= 0;
for x1:= 1 to GridMaxX-1 do begin
for y1:= 1 to GridMaxY-1 do begin
case Odd(Generation) of
false: begin
ToDoP[i]:= (x1 shl 16 or y1);
Inc(PCount);
end;
true: begin
ToDoQ[i]:= (x1 shl 16 or y1);
Inc(QCount);
end;
end; {case}
Inc(i);
end; {for y}
end; {for x}
end; {if}
end;
//GeneratePtoQ
//This procedure generates the Q data and QState-flags
//using the P-data and PState-flags.
procedure TCellBlock.Generate;
begin
if Odd(Generation) then GenerateQtoP
else GeneratePtoQ;
Inc(Generation);
end;
const
MaskS = $cccccccc;
MaskE = $ff000000;
MaskSE = $cc000000;
procedure TCellBlock.GeneratePtoQ;
var
x,y: integer;
i: integer;
Change: cardinal;
ToDoA: TToDoList;
ToDoB: TToDoList;
A, B: integer;
done: boolean;
Address: cardinal;
begin
i:= 0;
A:= 0; B:= 0;
ToDoA[-1]:= $ffffffff;
ToDoB[-1]:= $ffffffff;
while (i < PCount) do begin
y:= ToDoP[i] and $FFFF;
x:= ToDoP[i] shr 16;
Inc(i);
if (x = GridMaxX) or (y = GridMaxY) then continue; //Skip the loop.
Change:= Grid[x,y].GeneratePtoQ;
if (Change <> 0) then begin
Address:= (x shl 16 or y);
if ToDoA[A-1] <> Address then begin
ToDoA[A]:= Address; Inc(A);
end;
if (Change and MaskS) <> 0 then begin
ToDoA[A]:= Address + 1;
Inc(A);
end; {if S changed}
if ((Change and MaskE) <> 0) then begin
Address:= Address + (1 shl 16);
if ToDoB[B-1] <> Address then begin
ToDoB[B]:= Address;
Inc(B);
end;
if ((Change and MaskSE) <> 0) then begin
ToDoB[B]:= Address + 1;
Inc(B);
end; {if SE changed}
end; {if E changed}
end; {if whole cell changed}
end; {while}
ToDoA[A]:= $ffffffff;
ToDoB[B]:= $ffffffff;
ToDoB[B+1]:= $ffffffff;
a:= 0; b:= 0; QCount:= 0;
Done:= (ToDoA[a] = $ffffffff) and (ToDoB[b] = $ffffffff);
while not done do begin
if ToDoA[a] <= ToDoB[b] then begin
ToDoQ[QCount]:= ToDoA[a]; inc(a); inc(QCount);
if ToDoA[a] = ToDoB[b] then inc(b);
end
else begin
ToDoQ[QCount]:= ToDoB[b]; inc(b); inc(QCount);
end;
Done:= (ToDoA[a] = $ffffffff) and (ToDoB[b] = $ffffffff);
end; {while}
end;
const
MaskN = $33333333;
MaskW = $000000ff;
MaskNW = $00000033;
procedure TCellBlock.GenerateQtoP;
var
x,y: integer;
i: integer;
Change: cardinal;
ToDoA: TToDoList;
ToDoB: TToDoList;
A, B: integer;
done: boolean;
Address: cardinal;
begin
i:= 0;
A:= 0; B:= 0;
ToDoA[-1]:= $ffffffff;
ToDoB[-1]:= $ffffffff;
while (i < QCount) do begin
y:= ToDoQ[i] and $FFFF;
x:= ToDoQ[i] shr 16;
Inc(i);
if (x = 0) or (y = 0) then Continue; //Skip the rest of the loop.
Change:= Grid[x,y].GenerateQtoP;
if (Change <> 0) then begin
Address:= (x shl 16 or y);
if ToDoA[A-1] <> Address then begin
ToDoA[A]:= Address; Inc(A);
end;
if (Change and MaskN) <> 0 then begin
ToDoA[A]:= Address - 1;
Inc(A);
end; {if N changed}
if ((Change and MaskW) <> 0) then begin
Address:= Address - (1 shl 16);
if ToDoB[B-1] <> Address then begin
ToDoB[B]:= Address;
Inc(B);
end;
if ((Change and MaskNW) <> 0) then begin
ToDoB[B]:= Address - 1;
Inc(B);
end; {if NW changed}
end; {if W changed}
end; {if whole cell changed}
end; {while}
ToDoA[A]:= $ffffffff;
ToDoB[B]:= $ffffffff;
ToDoB[B+1]:= $ffffffff;
a:= 0; b:= 0; PCount:= 0;
Done:= (ToDoA[a] = $ffffffff) and (ToDoB[b] = $ffffffff);
while not done do begin
if ToDoA[a] <= ToDoB[b] then begin
ToDoP[PCount]:= ToDoA[a]; inc(a); inc(PCount);
if ToDoA[a] = ToDoB[b] then inc(b);
end
else begin
ToDoP[PCount]:= ToDoB[b]; inc(b); inc(PCount);
end;
Done:= (ToDoA[a] = $ffffffff) and (ToDoB[b] = $ffffffff);
end; {while}
end;
(*
procedure TCellBlock.GenerateQtoP;
var
x,y: integer;
i: integer;
Change: cardinal;
begin
i:= 0;
for x:= 0 to GridMaxX - 1 do begin
for y:= 0 to GridMaxY -1 do begin
if Active[cIndexQ][x, y] then begin
Active[cIndexQ][x, y]:= false;
ToDo[i]:= x shl 16 or y;
Inc(i);
end; {if}
end; {for y}
end; {for x}
while i > 0 do begin
Dec(i);
y:= ToDo[i] and $FFFF;
x:= ToDo[i] shr 16;
Change:= Grid[x,y].GenerateQtoP;
Active[cIndexP][x,y]:= Active[cIndexP][x,y] or (Change <> 0);
Active[cIndexP][x-1,y-1]:= Active[cIndexP][x-1,y-1] or ((Change and $00000033) <> 0);
Active[cIndexP][x-1,y]:= Active[cIndexP][x-1,y] or ((Change and $000000ff) <> 0);
Active[cIndexP][x,y-1]:= Active[cIndexP][x,y-1] or ((Change and $33333333) <> 0);
end; {while}
end; (**)
procedure TCellBlock.UpdateFlagsPtoQ;
begin
//nog in te vullen.
end;
procedure TCellBlock.UpdateFlagsQtoP;
begin
//nog in te vullen
end;
function TCell.GeneratePtoQ: cardinal;
var
NewQ: cardinal;
Change: cardinal;
const
Mask1 = $f;
Mask2 = $ff;
Mask4 = $ffff;
Row1Mask = $33333333; //0011-0011-0011-0011-0011-0011-0011-0011
Row2Mask = $cccccccc; //1100-1100-1100-1100-1100-1100-1100-1100
function MakeNewBrick(p0,p1,p2,p3: cardinal): cardinal; inline;
var
Row1, Row2: cardinal;
begin
//Generate new Brick using a 2x2 grid of bricks ordered like:
//p0 p1
//p2 p3
//First row inside P0
if (p0 <> 0) then Row1:=
LookupTable[p0 and $ffff] or
LookupTable[(p0 shr 8) and $ffff] shl 8 or
LookupTable[(p0 shr 16)] shl 16 or
LookupTable[(p0 shr 24) or (p1 and $ff) shl 8] shl 24
else Row1:= LookupTable[(p1 and $ff) shl 8] shl 24;
(**)
p0:= ((p0 and $cccccccc)) or ((p2 and $33333333));
p1:= ((p1 and $cc)) or ((p3 and $33));
if (p0 <> 0) then Row2:=
LookupTable[p0 and $ffff] or
LookupTable[(p0 shr 8) and $ffff] shl 8 or
LookupTable[(p0 shr 16)] shl 16 or
LookupTable[(p0 shr 24) or ((p1 and $ff) shl 8)] shl 24
else Row2:= LookupTable[(p1 and $ff) shl 8] shl 24;
Result:= (Row1 and Row1Mask) or (Row2 and Row2Mask);
end;
begin
NewQ:= MakeNewBrick(Self.p, PGrid(#Self)^[1,0].p, PGrid(#Self)^[0,1].p, PGrid(#Self)^[1,1].p);
Result:= NewQ xor q;
q:= NewQ;
end;
function TCell.GenerateQtoP: cardinal;
var
Offset: integer;
NewP: cardinal;
Change: cardinal;
const
Row1Mask = $33333333; //0011-0011-0011-0011-0011-0011-0011-0011
Row2Mask = $cccccccc; //1100-1100-1100-1100-1100-1100-1100-1100
function MakeNewBrick(q0,q1,q2,q3: cardinal): cardinal; inline;
var
Row1, Row2: cardinal;
begin
//Generate new Brick using a 2x2 grid of bricks ordered like:
//q3 q2
//q1 q0
if (q0 <> 0) then Row1:=
LookupTable[(q0 shr 16)] shl 26 or
LookupTable[(q0 shr 8 ) and $ffff] shl 18 or
LookupTable[(q0 ) and $ffff] shl 10 or
LookupTable[((q0 and $ff) shl 8) or (q1 shr 24)] shl 2
else Row1:= LookupTable[(q1 shr 24)] shl 2;
(*
q0:= ((q0 and $33333333) shl 2) or ((q2 and $cccccccc) shr 2);
q1:= ((q1 and $33000000) shl 2) or ((q3 and $cc000000) shr 2);
if (q0 <> 0) then Row2:=
LookupTable[(q0 shr 16) and $ffff] shl 24 or
LookupTable[(q0 shr 8) and $ffff] shl 16 or
LookupTable[(q0 ) and $ffff] shl 8 or
LookupTable[((q0 and $ff) shl 8) or (q1 shr 24)]
else Row2:= LookupTable[(q1 shr 24)];
(**)
q0:= ((q0 and $33333333)) or ((q2 and $cccccccc));
q1:= ((q1 and $33000000)) or ((q3 and $cc000000));
if (q0 <> 0) then Row2:=
LookupTable[(q0 shr 16)] shl 22 or
LookupTable[(q0 shr 8) and $ffff] shl 14 or
LookupTable[(q0 ) and $ffff] shl 6 or
LookupTable[((q0 and $ff) shl 8) or (q1 shr 24)] shr 2
else Row2:= LookupTable[(q1 shr 24)] shr 2;
Result:= (Row1 and Row2Mask) or (Row2 and Row1Mask);
end;
begin
Offset:= -1;
NewP:= MakeNewBrick(Self.q, PGrid(#Self)^[Offset,0].q, PGrid(#Self)^[0,Offset].q, PGrid(#Self)^[Offset, Offset].q);
Result:= NewP xor P;
P:= NewP;
end;
procedure TCellBlock.Display(ACanvas: TCanvas);
var
GridX,GridY: integer;
//Offset: integer;
procedure DisplayCell(ACell: TCell);
var
x,y,x1,y1: integer;
Row, Mask: integer;
DoPixel: boolean;
Offset: integer;
DrawOffset: integer;
InP: boolean;
begin
DrawOffset:= (Generation and 1);
InP:= not(Odd(Generation));
for y:= 0 to CellMaxY do begin
for x:= 0 to CellMaxX do begin
//if (x = 0) or (y = 0) then ACanvas.Pixels[GridX*16+x+Offset,GridY*16+y+Offset]:= clBtnFace;
//0,0 is the topleft pixel, no correction for p,q fase.
x1:= x mod 8;
y1:= y mod 4;
Offset:= x1 * 4 + y1;
Mask:= 1 shl Offset;
if (InP) then DoPixel:= (ACell.p and Mask) <> 0
else DoPixel:= (ACell.q and Mask) <> 0;
if DoPixel then ACanvas.Pixels[GridX*CellSizeX+x+DrawOffset, GridY*CellSizeY+y+DrawOffset]:= clBlack;
end; {for x}
end; {for y}
end; (**)
begin
ACanvas.Rectangle(-1,-1,1000,1000);
FillChar(Form1.BitmapData, SizeOf(Form1.BitmapData), #0);
for GridY:= 0 to GridMaxY do begin
for GridX:= 0 to GridMaxX do begin
if Int64(Grid[GridX, GridY]) <> 0 then begin
DisplayCell(Grid[GridX,GridY]);
end;
end;
end;
end;
//--------------------------------------
//A Parent is every layer above the ground level
//the tree grows from the bottom up.
//A new parent is placed on top of the last one and
//always has one and only one child to start with, from there
//the tree grows down again.
constructor TCellParent.CreateFromChild(AChild: TCellBlock; ChildX: Integer; ChildY: Integer);
begin
inherited Create(nil);
end;
constructor TCellParent.CreateFromParent(AParent: TCellParent);
begin
inherited Create(AParent);
end;
destructor TCellParent.Destroy;
begin
inherited Destroy;
end;
procedure TCellParent.GeneratePtoQ;
begin
end;
procedure TCellParent.GenerateQtoP;
begin
end;
//The bitmap for the lookup table is as follows:
// 0 2 4 6
// +----+
// 1 |3 5| 7
// 8 |A C| E
// +----+
// 9 B D F
// The inner 2x2 cells are looked up.
// so 0241358AC make up bit 3 etc.
procedure TForm1.InitLookupTable;
const
//Masks for normal order.
MaskNW = $0757; //0000-0111-0101-0111
MaskSW = $0EAE; //0000-1110-1010-1110
MaskNE = $7570; //0111-0101-0111-0000
MaskSE = $EAE0; //1110-1010-1110-0000
//Bitlocations for normal order
BitNW = $0020; //0000-0000-0010-0000
BitSW = $0040; //0000-0000-0100-0000
BitNE = $0200; //0000-0020-0000-0000
BitSE = $0400; //0000-0100-0000-0000
//Lookup table also has a shifted order. here the bottom half of the N word
//and the top half of the south word combine.
//Like so:
// 2 6 A E
// 3 7 B F
// 0 4 8 C
// 1 5 9 D
//Mask for split order.
Mask2NW = $0D5D; // 0000-1101-0101-1101
Mask2SW = $0BAB; // 0000-1011-1010-1011
Mask2NE = $D5D0; // 1101-0101-1101-0000
Mask2SE = $BAB0; // 1011-1010-1011-0000
//Bitlocations for split order
Bit2NW = $0080; // 0000-0000-1000-0000
Bit2SW = $0010; // 0000-0000-0001-0000
Bit2NE = $0800; // 0000-1000-0000-0000
Bit2SE = $0100; // 0000-0001-0000-0000
ResultNW = $01;
ResultSW = $02;
ResultNE = $10;
ResultSE = $20;
Result2NW = $04;
Result2SW = $08;
Result2NE = $40;
Result2SE = $80;
var
i: integer;
iNW, iNE, iSW, iSE: cardinal;
Count: integer;
ResultByte: byte;
function GetCount(a: integer): integer;
var
c: integer;
begin
Result:= 0;
for c:= 0 to 15 do begin
if Odd(a shr c) then Inc(Result);
end; {for c}
end; {GetCount}
begin
//Fill the normal lookup.
for i:= 0 to $ffff do begin
ResultByte:= 0;
iNW:= i and MaskNW;
Count:= GetCount(iNW);
case Count of //count excluding bit itself
3: ResultByte:= ResultNW;
2: if ((i and BitNW) <> 0) then ResultByte:= ResultNW;
end;
iSW:= i and MaskSW;
Count:= GetCount(iSW);
case Count of
3: ResultByte:= ResultByte or ResultSW;
2: if ((i and BitSW) <> 0) then ResultByte:= ResultByte or ResultSW;
end;
iNE:= i and MaskNE;
Count:= GetCount(iNE);
case Count of
3: ResultByte:= ResultByte or ResultNE;
2: if ((i and BitNE) <> 0) then ResultByte:= ResultByte or ResultNE;
end;
iSE:= i and MaskSE;
Count:= GetCount(iSE);
case Count of
3: ResultByte:= ResultByte or ResultSE;
2: if ((i and BitSE) <> 0) then ResultByte:= ResultByte or ResultSE;
end;
LookupTable[i]:= ResultByte;
end; {for i}
//Fill the shifted lookup.
for i:= 0 to $ffff do begin
ResultByte:= 0;
iNW:= i and Mask2NW;
Count:= GetCount(iNW);
case Count of //count excluding bit itself
3: ResultByte:= Result2NW;
2: if ((i and Bit2NW) <> 0) then ResultByte:= Result2NW;
end;
iSW:= i and Mask2SW;
Count:= GetCount(iSW);
case Count of
3: ResultByte:= ResultByte or Result2SW;
2: if ((i and Bit2SW) <> 0) then ResultByte:= ResultByte or Result2SW;
end;
iNE:= i and Mask2NE;
Count:= GetCount(iNE);
case Count of
3: ResultByte:= ResultByte or Result2NE;
2: if ((i and Bit2NE) <> 0) then ResultByte:= ResultByte or Result2NE;
end;
iSE:= i and Mask2SE;
Count:= GetCount(iSE);
case Count of
3: ResultByte:= ResultByte or Result2SE;
2: if ((i and Bit2SE) <> 0) then ResultByte:= ResultByte or Result2SE;
end;
LookupTable[i]:= LookupTable[i] or ResultByte;
end; {for i} (**)
end;
procedure TForm1.RestartScreen;
begin
MyBlock.Free;
MyBlock:= TCellBlock.Create(nil);
//MyBlock.SetPixel(5,7);
//MyBlock.SetPixel(6,7);
//MyBlock.SetPixel(7,7);
//MyBlock.SetPixel(7,6);
//MyBlock.SetPixel(6,5);
MyBlock.SetPixel(10,0);
MyBlock.SetPixel(11,0);
MyBlock.SetPixel(9,1);
MyBlock.SetPixel(10,1);
MyBlock.SetPixel(10,2);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Assigned(MyBlock) then begin
MyBlock.Generate;
MyBlock.Display(Image1.Canvas);
end;
end;
procedure TForm1.ToolButton4Click(Sender: TObject);
begin
if Assigned(MyBlock) then begin
MyBlock.Generate;
MyBlock.Display(Image1.Canvas);
end;
end;
procedure TForm1.FileNew1Execute(Sender: TObject);
begin
InitLookupTable;
FillChar(BitmapData, SizeOf(BitmapData), #0);
MyBitmap:= TBitmap.Create;
MyBitmap.SetSize(1024,1024);
MyBitmap.PixelFormat:= pf1bit;
MyBitmap.Monochrome:= true;
//MyBitmap.Handle:= CreateBitmap(1000,1000,1,2,nil);
Generation:= 0;
RestartScreen;
MyBlock.Display(Image1.Canvas);
//if (Sender = FileNew1) then Timer1.Enabled:= not(Timer1.Enabled);
end;
procedure TForm1.FileOpen1Execute(Sender: TObject);
var
i,a: integer;
start, eind: int64;
Diff: double;
LowDiff: double;
begin
LowDiff:= MaxInt;
for a:= 0 to 10 do begin
FileNew1Execute(Sender);
GetCPUTicks(start);
for i:= 0 to 1000 do begin
MyBlock.Generate;
end;
GetCPUTicks(eind);
//Label1.Caption:= IntToStr(Eind - Start);
Diff:= Eind - start;
LowDiff:= Min(Diff, LowDiff);
Label1.Caption:= Format('%10.0n',[lowdiff]) + ' CPU cycles per 1,000 generations';
Clipboard.AsText:= Label1.Caption;
end; {for a}
MyBlock.Display(Image1.Canvas);
end;
procedure TForm1.FileSave1Execute(Sender: TObject);
begin
Timer1.Enabled:= not(Timer1.Enabled);
end;
procedure TForm1.FileExit1Execute(Sender: TObject);
begin
Close;
end;
initialization
Generation:= 0;
end.
Stackoverflow does not allow me to post the form file due to a size limit, but I hope you can manage without.

Connect 4: Check for winner

In Delphi, I have a Connect 4 board representation (7 columns x 6 lines) in form of an array:
TBoard = Array[1..7, 1..6] of SmallInt;
Board: TBoard; // instance ob TBoard
Each element can have three different states:
1 = player 1's pieces
0 = empty
-1 = player 2's pieces
Now I need a function which checks if there's a winner or a draw:
function CheckForWinner(): SmallInt;
... where 1 is player 1's win, 0 is a draw, -1 is player 2's win and "nil" is for a game which has not ended yet.
My draft is as follows - split into two single functions:
function CheckForWinner(): SmallInt;
var playerToCheck: ShortInt;
s, z: Byte;
draw: Boolean;
begin
draw := TRUE;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := FALSE; // if there are empty fields then it is no draw
end;
end;
if draw then begin
result := 0;
end
else begin
playerToCheck := Board[lastPieceX, lastPieceY]; // only for last-moving player
if searchRow(playerToCheck, +1, 0, lastPieceX, lastPieceY) then // search right/left
result := playerToCheck
else if searchRow(playerToCheck, 0, +1, lastPieceX, lastPieceY) then // search up/down
result := playerToCheck
else if searchRow(playerToCheck, +1, +1, lastPieceX, lastPieceY) then // search right-down/left-up
result := playerToCheck
else if searchRow(playerToCheck, +1, -1, lastPieceX, lastPieceY) then // search right-up/left-down
result := playerToCheck;
else
result := nil;
end;
end;
end;
function searchRow(player: SmallInt; sChange, zChange: ShortInt; startS, startZ: Byte): Boolean;
var inRow, s, z: SmallInt;
begin
inRow := 0;
s := startS;
z := startZ;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s+sChange;
z := z+zChange;
inRow := inRow+1;
end;
s := startS-sChange;
z := startZ-zChange;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s-sChange;
z := z-zChange;
inRow := inRow+1;
end;
if inRow = 4 then
result := TRUE
else
result := FALSE;
end;
What do you think of this approach? Do you have a better (faster / shorter) solution?
Thank you very much!
I didn't read your code. I just elected to write some myself with a blank slate.
Here's my version:
const
RowCount = 6;
ColCount = 7;
type
TState = (stNone, stA, stB);
TBoard = array [1..RowCount] of array [1..ColCount] of TState;
function ValidLocation(Row, Col: Integer): Boolean;
begin
Result := InRange(Row, 1, RowCount) and InRange(Col, 1, ColCount);
end;
procedure Check(
const Board: TBoard;
const StartRow, StartCol: Integer;
const RowDelta, ColDelta: Integer;
out Winner: TState
);
var
Row, Col, Count: Integer;
State: TState;
begin
Winner := stNone;
Row := StartRow;
Col := StartCol;
State := Board[Row, Col];
if State=stNone then
exit;
Count := 0;
while ValidLocation(Row, Col) and (Board[Row, Col]=State) do begin
inc(Count);
if Count=4 then begin
Winner := State;
exit;
end;
inc(Row, RowDelta);
inc(Col, ColDelta);
end;
end;
function Winner(const Board: TBoard): TState;
var
Row, Col: Integer;
begin
for Row := 1 to RowCount do begin
for Col := 1 to ColCount do begin
Check(Board, Row, Col, 0, 1, Result);//check row
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 0, Result);//check column
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 1, Result);//check diagonal
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, -1, Result);//check other diagonal
if Result<>stNone then
exit;
end;
end;
Result := stNone;
end;
Big long pile of code. Uses brute force approach, not that performance matters for Connect 4. Don't like the four identical if Result<>stNone then exit; lines, but you can surely think of a cleaner way. Code has not been run. It might not even work!! Just the way my brain attempted to solve the problem.
Checking for a winner in very much the same way as you do, only with a little less code.
I think you wouldn't need to check all fields to determine if the game is done. Just increase a counter when you drop a piece in the game. The game is a draw if the counter reaches 42 and there is no winner yet.
function CheckRow(x, y, xd, yd: Integer): Boolean;
var
c: Integer;
function RowLength(x, y, xd, yd: Integer): Integer;
begin
Result := 0;
repeat
Inc(Result);
Inc(x, xd);
Inc(y, yd);
until not ((x in [1..7]) and (y in [1..6]) and (Board[x, y] = c));
end;
begin
c := Board[x, y];
Result := 4 <= RowLength(x, y, xd, yd) + RowLength(x, y, xd*-1, yd*-1) - 1;
end;
function CheckForWinner(x, y: Integer): Integer;
begin
Result := 0;
if CheckRow(x, y, 0, 1) or CheckRow(x, y, 1, 1) or
CheckRow(x, y, 1, 0) or CheckRow(x, y, 1, -1) then
Result := Board[x,y];
end;
Disclaimer: I haven't studied the algorithm in detail. The comments below are merely my first reactions after staring at the code for less than ten seconds.
I have some very quick remarks. First, I think
TCellState = (csUnoccupied, csPlayerA, csPlayerB)
TBoard = Array[1..7, 1..6] of TCellState;
is nicer. Of course, you can save compatibility with your old code by doing
TCellState = (csUnoccupied = 0, csPlayerA = 1, csPlayerB = -1)
Second,
draw := true;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := false;
end;
end;
You don't need the begin and end parts:
draw := TRUE;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
draw := false;
More importantly, as a gain in performance, you should break the loops as soon as you have set drawn to false:
draw := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
begin
draw := false;
break;
end;
This will, however, only break the z loop. To break both loops, the nicest way is to put the entire block above in a local function. Let's call it CheckDraw:
function CheckDraw: boolean;
begin
result := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(false);
end;
Alternatively, you can use label and goto to break out of both loops at once.
Update
I see now that you can just do
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(0);
and you don't even need to introduce the draw local variable!
End update
Furthermore,
if inRow = 4 then
result := TRUE
else
result := FALSE;
is bad. You should do just
result := inRow = 4;
Finally, In my taste
s := s+sChange;
should be written
inc(s, sChange);
and
inRow := inRow+1
should be
inc(inRow);
Oh, and nil is a pointer, not an integer.
The source code from the Fhourstones Benchmark from John Tromp uses a fascinating algorithm for testing a connect four game for a win. The algorithm uses following bitboard representation of the game:
. . . . . . . TOP
5 12 19 26 33 40 47
4 11 18 25 32 39 46
3 10 17 24 31 38 45
2 9 16 23 30 37 44
1 8 15 22 29 36 43
0 7 14 21 28 35 42 BOTTOM
There is one bitboard for the red player and one for the yellow player. 0 represents a empty cell, 1 represents a filled cell. The bitboard is stored in an unsigned 64 bit integer variable. The bits 6, 13, 20, 27, 34, 41, >= 48 have to be 0.
The algorithm is:
// return whether 'board' includes a win
bool haswon(unsigned __int64 board)
{
unsigned __int64 y = board & (board >> 6);
if (y & (y >> 2 * 6)) // check \ diagonal
return true;
y = board & (board >> 7);
if (y & (y >> 2 * 7)) // check horizontal
return true;
y = board & (board >> 8);
if (y & (y >> 2 * 8)) // check / diagonal
return true;
y = board & (board >> 1);
if (y & (y >> 2)) // check vertical
return true;
return false;
}
You have to call the function for the bitboard of the player who did the last move

How to speed up algorithm (Binarization, integral image)

I wrote this procedure based on integral image algorithm described at this url
http://people.scs.carleton.ca/~roth/iit-publications-iti/docs/gerh-50002.pdf
Is there any way to do this code faster?
Pointers are much faster as dynamic arrays?
procedure TForm1.bBinarizationClick(Sender: TObject);
var
iX1, iY1,
iX2, iY2,
ii, jj,
s, s2,
iSum, iCount, index,
iHeight, iWidth : Integer;
iSize: Integer;
row : ^TRGBTriple;
black : TRGBTriple;
aIntegralIm: array of Integer;
aGrays : array of Byte;
startTime : Cardinal;
begin
iWidth := bBitmap.Width;
iHeight := bBitmap.Height;
iSize := iWidth * iHeight;
SetLength(aGrays, iSize);
SetLength(aIntegralIm, iSize);
black.rgbtRed := (clBlack and $0000FF);
black.rgbtGreen := (clBlack and $00FF00) shr 8;
black.rgbtBlue := (clBlack and $FF0000) shr 16;
bBitmap2.Canvas.Brush.Color := clWhite;
bBitmap2.Canvas.FillRect(Rect(0, 0, bBitmap2.Width, bBitmap2.Height));
s := Round(iWidth / TrackBar2.Position);
s2 := Round(s / 2);
startTime := GetTickCount();
index := 0;
for ii := 0 to iHeight - 1 do begin
row := bBitmap.ScanLine[ii];
for jj := 0 to iWidth - 1 do begin
aGrays[index] := ((row.rgbtRed * 77 + row.rgbtGreen * 150 + row.rgbtBlue * 29) shr 8);
inc(index);
inc(row);
end;
end;
for ii := 0 to iWidth - 1 do begin
iSum := 0;
for jj := 0 to iHeight - 1 do begin
index := jj*iWidth+ii;
iSum := iSum + aGrays[index];
if ii = 0 then aIntegralIm[index] := iSum
else aIntegralIm[index] := aIntegralIm[index - 1] + iSum;
end;
end;
for jj := 0 to iHeight - 1 do begin
row := bBitmap2.ScanLine[jj];
for ii := 0 to iWidth - 1 do begin
index := jj*iWidth+ii;
iX1 := ii-s2;
iX2 := ii+s2;
iY1 := jj-s2;
iY2 := jj+s2;
if (iX1 < 0) then iX1 := 0;
if (iX2 >= iWidth) then iX2 := iWidth-1;
if (iY1 < 0) then iY1 := 0;
if (iY2 >= iHeight) then iY2 := iHeight-1;
iCount := (iX2 - iX1) * (iY2 - iY1);
iSum := aIntegralIm[iY2*iWidth+iX2]
- aIntegralIm[iY1*iWidth+iX2]
- aIntegralIm[iY2*iWidth+iX1]
+ aIntegralIm[iY1*iWidth+iX1];
if (aGrays[index] * iCount) < (iSum * (100 - TrackBar1.Position) / 100) then row^ := black;
inc(row);
end;
end;
ePath.Text := 'Time: ' + inttostr(GetTickCount() - startTime) + ' ms';
imgOryginal.Picture.Bitmap.Assign(bBitmap2);
end;
You can at least do a few simple things:
precalculate (100 - TrackBar1.Position) into a variable
Instead of division: / 100 use * 100 on the other side. You might not need any floating point values.
Use lookup tables for the following (care to explain the identation btw?):
Code:
if (iX1 < 0) then iX1 := 0;
if (iX2 >= iWidth) then iX2 := iWidth-1;
if (iY1 < 0) then iY1 := 0;
if (iY2 >= iHeight) then iY2 := iHeight-1;
Try to keep the index and icremnet, decrement istead of multiplication: index := jj*iWidth+ii;
My guess is that the second loop is the slow bit.
The trick would be to avoid to recalculate everything in the second loop all the time
If S is constant (relative to the loop I mean, not absolute)
iy1,iy2 only change with the main(jj) loop and so do iy1*width (and iy2*width).
Precalculate them, or optimize them away in the same way you do with row. (precalculate once per line, increment inbetween)
change the ii loop into three loops:
the first bit where ix1=0
the second where ix1=ii-s ix2=ii+s;
the third where ix1=ii-s and ix2=iwidth-1
this removes a lot of checks out of the loops, to be done only once.
make a dedicated loop for the condition if (aGrays[index] * iCount) < (iSum * (100 - TrackBar1.Position) / 100) then row^ := black; so that it isn't evaluated for each pixel, since you can precalculate the area's where this happens ?
introduce pointers into the gray calculating loop so that you don't have to recalculate the index each pixel (but e.g. only for the row loop, incrementing a ptr per pixel)
If you are hardy, you can also precalculate the jump between lines. Keep in mind that abs(scanline[j]-scanline[i])-width is a metric for the number of alignment bytes per row.
Even more advanced is optimizing for cache effects on the level of your algorithm. See
rotating bitmaps. In code
to get an idea how this works. Some pointer tricks are demonstrated there too (but only for 8-bit elements)
I would first use a profiler to find out the CPU usage repartition, to figure out the smallest part(s) of code that would benefit the most from optimisation.
Then I would adapt the effort according to the results. If some code represents 90% of the CPU load and is executed zillions of times, even extreme measures (recoding a few sequences using inline assembly language) might make sense.
Use the excellent and free SamplingProfiler to find out the bottleneck in your code. Then optimize and run the profiler again to find the next bottleneck. This approach is much better than guessing what's need to be optimized because even experts are often wrong about that.

Resources