Быстрый линейный список, исключающий дубликаты - PullRequest
Новая
       15

Быстрый линейный список, исключающий дубликаты

1 голос
/ 15 июня 2011

У меня есть следующий код: 

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;

Выше приведен фрагмент кода тестовой программы, который вычисляет игру жизни Конвея .
Код должен быть максимально быстрым. И для этого я пробую разные подходы.

Он проходит через сетку активных ячеек, смотрит, какие ячейки активны, и помещает их в стеке.
Затем он обрабатывает элементы в стеке и видит, какие ячейки изменились.
Если ячейка изменилась, она обновляет изменения в сетке для следующего поколения.

Я храню ячейки в 32-битных кардиналах (4 бита Y, 8 бит X), а P (четные) поколения смещены на 1,1 пикселя относительно Q (нечетных) поколений, поэтому мне нужно только взять 3 соседей в аккаунт вместо 8.

Вопрос
Я хочу избавиться от сетки, я просто хочу иметь дело со стеком.
Как реализовать стек, который устраняет дубликаты?

Обратите внимание, что это должно быть как можно быстрее , и я не собираюсь использовать грязные уловки, чтобы получить это.

Ответы [ 5 ]

1 голос
/ 15 июня 2011

если я понял, что вы спросили, вы хотите, чтобы в стеке не было значений дублирования. я не Delphi человек, но если бы это был Java, я бы создал дерево хэш-карт / карт и добавил бы каждое значение на карту, а перед добавлением его в стек проверялось ли оно уже в хэше. Вы также можете добавить все значения для хэширования, но вы потеряете порядок хэша.

0 голосов
/ 17 июня 2011

В основном @Ken, полный исходный код для тестовой программы:

Обратите внимание, что 99,9% времени тратится на отображение, потому что я ничего не сделал для оптимизировать это.

Я создал новое приложение SDI-main и разместил в нем код, и, поскольку мне лень, я не потрудился переименовать или перекрасить какие-либо элементы управления.

Файл проекта: sdiapp.dpr 

program Sdiapp;

uses
  Forms,
  SDIMAIN in 'SDIMAIN.pas'; {Form1}

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Основная форма: 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 не позволяет мне публиковать файл формы из-за ограничения размера, но я надеюсь, что вы можете обойтись без.

0 голосов
/ 16 июня 2011

Я думал об этом и думаю, что у меня есть решение.

немного фона

Вот как данные располагаются в памяти 

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 --

Я не определился с размером строительного блока, но это общая идея.

Четные поколения называются P, нечетные поколения называются Q.

Они в шахматном порядке, как это 

 +----------------+<<<<<<<< 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 --

Таким образом, при генерации P -> Q мне нужно только смотреть на самого P и его соседей S, SE, E вместо всех 8 соседей, то же самое для Q -> P. Мне нужно только смотреть на сам Q и его N, NW и W соседи.
Также обратите внимание, что ошеломление экономит мне время при переводе результата поиска, потому что мне нужно меньше сдвигать биты, чтобы поставить результаты на место.

Когда я зацикливаюсь по сетке (Рисунок A) Я иду по клеткам (Рисунок B) в порядке, показанном на рисунке A. Всегда в строго возрастающем порядке в P -цикл и всегда в порядке убывания в Q-цикле.
На самом деле цикл Q работает в совершенно противоположном порядке по сравнению с циклом P, это ускоряет процесс за счет максимально возможного повторного использования кэша.

Я хочу свести к минимуму использование указателей в максимально возможной степени, потому что указатели не могут быть предсказаны и к ним нет доступа последовательно (они перепрыгивают повсюду) Поэтому я хочу использовать как можно больше массивов, стеков и очередей насколько это возможно.

Какие данные нужно сделать, чтобы отслеживать
Мне нужно отслеживать только те клетки, которые меняются. Если ячейка (то есть int32) не изменяется от одного поколения к следующему, я исключаю ее из рассмотрения.
Это то, что делает код в вопросе. Он использует сетку для отслеживания изменений, но я хочу использовать стек , а не сетку; и я только хочу иметь дело с активными клетками, которые я не хочу знать о стабильных или мертвых клетках.

Некоторые данные на фоне
Обратите внимание, что сама клетка всегда монотонно увеличивается. Как и его S-сосед, а также E и SE-сосед. Я могу использовать эту информацию, чтобы обмануть.

Решение
Я использую стек для отслеживания самой ячейки и ее соседа S и очередь для отслеживания ее соседей E и SE, и когда я закончу, я объединяю их.

Предположим, что в сетке следующие ячейки становятся активными после того, как я их вычислю: 

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}

И еще лучше
Мне не нужно фактически делать два стека и объединение как два отдельных шага, если я сделаю A стеком и B очередь, я могу сделать второй шаг, описанный в псевдокоде и построении два стека за один проход.

Примечание
Поскольку ячейка меняет свою границу S, E или SE, менять ее не нужно, но я могу проверить это, используя маски из таблицы C, и добавить в список только те ячейки, которые действительно нуждаются в проверке в следующем поколении.

Преимущества

  1. Используя эту схему, мне только нужно пройти через один стек с активными ячейками при расчете ячеек, поэтому я не трачу время на просмотр мертвых или неактивных ячеек.
  2. Я делаю только последовательный доступ к памяти, максимизируя использование кэша.
  3. Для построения стека с новыми изменениями для следующих поколений требуется только одна дополнительная временная очередь, которую я обрабатываю в строго последовательном порядке.
  4. Я не делаю сортировку и минимум сравнений.
  5. Мне не нужно отслеживать соседей каждой отдельной ячейки (int32), мне нужно только отслеживать соседей (S, E, SE, N, W, NW) из сетки, это сводит накладные расходы памяти к минимуму.
  6. Мне не нужно отслеживать статус ячеек, мне нужно только сосчитать мертвые клетки (Ячейка либо мертва, либо раньше, либо потому, что она изменила на мертвую. Все активные ячейки находятся в моем стеке TODO, это экономит время учета и память.
  7. Алгоритм работает за время o (n), где (n) - число активных ячеек, он исключает мертвые ячейки, стабильные ячейки и ячейки, которые колеблются с периодом 2.
  8. Я когда-либо имел дело только с 32-битными кардиналами, что намного быстрее, чем использование int16.
0 голосов
/ 15 июня 2011

Если ваша цель - скорость (и только скорость). Есть несколько трюков, которые могут ускорить многое. Моя собственная реализация игры жизни Конвея использует эти приемы, чтобы сделать это быстрее. Обратите внимание, что это ОЧЕНЬ дорого по памяти.

  1. Каждая клетка является объектом
  2. Каждый объект ячейки содержит свои координаты X / Y
  3. Каждый объект ячейки содержит «живые» счетчики количества живых соседей. (Когда ячейка включается / выключается, она уведомляет своего соседа, чтобы они обновили свои счетчики.
  4. Чтобы # 3 работал, при расчете следующего поколения ячейки сразу не включаются и не выключаются. Вместо этого они складываются в список, пока не будут вычислены все ячейки.
  5. В каждой ячейке есть счетчик, который указывает, на какое последнее поколение они перешли. Это позволяет избежать вычисления одной и той же ячейки дважды. (Моя альтернатива стеку, который устраняет дубликаты)
  6. Список # 5 повторно используется в следующем поколении, поскольку только соседние ячейки, которые изменились в предыдущем поколении, могут измениться в текущем.

Есть несколько приемов, которые я использую для ускорения генерации. Некоторые из перечисленных трюков принесут вам гораздо больше, чем многопоточность вашей реализации. Но использование как этих, так и многопоточности обеспечит максимально возможную производительность.

Что касается многопоточной темы, прочитайте запись Ву.

0 голосов
/ 15 июня 2011

Лично я бы выбрал совершенно другой подход. Во-первых, я не понимаю, как вам не нужно принимать во внимание всех соседей только из-за использования смещения 1,1, а затем я сомневаюсь, что уловки сдвига битов делают алгоритм намного быстрее (достаточно часто, это наоборот, но тогда это может будь ограничен в пропускной способности, в этом случае мы выиграем немного)

Так что я бы просто выбрал одну вещь, которая должна принести наибольший прирост производительности: создание многопоточного алгоритма. В нашем мире Quad / Hex / Octacores беспокойство о повышении производительности на несколько процентов при потере 300% и более кажется глупым. Так что, если бы мы игнорировали активные сетки и проверили все поля, алгоритм был бы тривиальным с некоторым большим масштабированием, тем более что можно легко векторизовать алгоритм, но тогда это не особенно эффективно, поэтому я бы попробовал несколько разных подходов к многопоточности алгоритм, учитывающий только активные ячейки.

Сначала вместо того, чтобы избавляться от сетки, я удваиваю ее: один src и один dest grid - которые меняются каждый раунд. Не требуется блокировка для доступа к сетке, не нужно беспокоиться при обновлении полей и нет устаревших записей (важно для многопоточности, мы хотим использовать кэш в конце концов).

Теперь самым простым решением было бы использовать некую параллельную структуру списка (без понятия о библиотеках delphi) для активных ячеек, и позволить каждому потоку украсть его и добавить новые активные ячейки в другой. С хорошей реализацией параллельной очереди без блокировки (в основном независимо от замены this в delphi) или чего-то подобного может быть довольно приятно и просто. Чтобы повысить производительность вместо добавления отдельных узлов в список, я бы подумал о добавлении в список целых чанков, скажем, в размере около 10-ти - больше работы с меньшими издержками, но если мы сделаем чанки слишком большими, мы потеряем параллелизм.

Я могу подумать о других решениях, таких как предоставление каждому потоку одного списка активных ячеек для обработки (или, точнее, одного списка для всех и разных смещений), но затем мы должны между каждым запуском собирать все новые записи (не слишком много накладных расходов на синхронизацию) но некоторые копирование) в список - стоит попробовать, я полагаю.

...