Rapide liste linéaire qui exclut les doublons

StackOverflow https://stackoverflow.com/questions/6350547

Question

Je le code suivant: 

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;

Le ci-dessus est un extrait de code d'un programme de test qui calcule le jeu de vie .
Le code doit être aussi rapide que possible. Et à cette fin, je suis en train d'approches différentes.

Il marche bien une grille de cellules actives, semble voir quelles cellules sont actives et met ces sur une pile.
Ensuite, il traite les éléments de la pile et voit les cellules qui ont changé.
Si une cellule a changé il met à jour les modifications dans la grille pour la prochaine génération.

je stocke des cellules dans des cardinaux 32 bits (4 bits Y, 8 bits X) et P (pair) sont décalées les générations 1,1 pixel par rapport à la génération Q (impair), de cette façon me suffit de prendre 3 voisins dans compte au lieu de 8.

Question Je veux me débarrasser de la grille, je veux juste faire face à la pile.
Comment puis-je mettre une pile qui élimine les doublons?

Notez qu'il doit être aussi vite que possible et je ne suis pas au-dessus en utilisant des astuces sales pour obtenir cela.

Était-ce utile?

La solution 4

J'ai réfléchi à ce sujet et je pense avoir une solution.

des renseignements généraux

Voici comment les données sont Laid en mémoire 

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

Je ne l'ai pas décidé de la taille du bloc de construction, mais c'est l'idée générale.

Même les générations sont appelées P, les générations impaires sont appelées Q.

Ils sont décalés comme celui-ci 

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

De cette façon, lors de la génération P -> Q, je ne ai besoin de regarder P lui-même et ses S, SE, E voisins, au lieu des 8 voisins, idem pour Q -> P. lorsque je regarde à Q lui-même et son N, NW et ses voisins W.
Notez également que le décalage me fait gagner du temps à traduire le résultat de la recherche, parce que je dois faire moins peu de décalage pour mettre les résultats en place.

Quand je boucle si une grille (figure A) Je marche si les cellules (figure B) dans l'ordre indiqué sur le schéma A. Toujours dans l'ordre croissant dans strictement un cycle P et toujours par ordre décroissant dans un cycle Q.
En fait, le cycle Q fonctionne exactement l'ordre opposé du cycle P, ce qui accélère les choses en réutilisant le cache autant que possible.

Je veux minimiser l'utilisation de pointeurs, autant que possible, parce que les pointeurs ne peuvent pas être prédits et ne sont pas accessibles de façon séquentielle (ils sautent dans tous les sens) Je veux utiliser des tableaux, des piles et des files d'attente autant que possible.

Quelles données à besoin de garder une trace de Je dois garder une trace des seules les cellules qui changent. Si une cellule (qui est un int32) ne change pas d'une génération à l'autre je le supprimer de la considération.
Voilà ce que fait le code dans la question. Il utilise une grille pour garder une trace des changements, mais je veux utiliser un, pas une grille pile ; et I uniquement veulent traiter avec des cellules actives Je ne veux pas savoir sur stable ou les cellules mortes.

Un peu d'histoire sur les données Remarquez comment est toujours la cellule augmente de façon monotone elle-même. Comme il est le S voisin, ainsi que l'E et SE voisin. Je peux utiliser cette information pour tricher.

La solution J'utilise une pile de garder une trace de la cellule elle-même et son voisin S et une file d'attente de garder une trace de son E et SE voisin et quand je suis fait, je fusionner les deux.

Supposons que dans la grille les cellules suivantes sortent aussi actif après que je les ai calculé: 

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}

Et mieux encore Je ne suis pas réellement faire les deux piles et la fusion en deux étapes séparées, si je fais A une pile et B une file d'attente, je peux faire la deuxième étape décrite dans le pseudo-code et la construction des deux piles en une passer.

Remarque En tant que cellule change de S, E ou frontière SE n'a pas besoin nécessaire de changer, mais je peux tester en utilisant les masques que dans le tableau C, et d'ajouter que les cellules qui ont vraiment besoin de vérifier dans la prochaine génération à la liste.

Avantages

  1. L'utilisation de ce système, je n'ai jamais marcher à travers un pile avec des cellules actives dans le calcul de cellules, donc je ne perds pas de temps à regarder les cellules mortes ou inactives.
  2. Je ne fais que les accès mémoire séquentielle, ce qui maximise l'utilisation du cache.
  3. Construire la pile avec de nouveaux changements pour les prochaines générations ne nécessite qu'une seule file d'attente temporaire supplémentaire, que je processus en ordre strictement séquentiel.
  4. Je ne le tri pas et le minimum de comparaisons.
  5. Je n'ai pas de garder une trace des voisins de chaque cellule individuelle (int32), je ne ai besoin de garder une trace des voisins (S, E, SE, N, W, NW) des grilles, ce qui maintient la surcharge de mémoire au minimum.
  6. Je ne suis pas besoin de garder une trace d'un état des cellules, je ne dois compter les cellules mortes (une cellule est soit mort, parce qu'il était mort avant, ou parce qu'il changé en morts. Toutles cellules actives sont dans ma pile TODO, un gain de temps de tenue de livres et de l'espace mémoire.
  7. Les courses de l'algorithme dans o (n) où (n) est le nombre de cellules actives , il exclut les cellules mortes, les cellules stables et des cellules qui oscillent avec une période 2.
  8. Je ne jamais traiter avec 32 cardinaux de bits, ce qui est le plus rapide que d'utiliser Int16 de.

Autres conseils

si je compris ce que vous avez demandé que vous voulez la pile d'avoir aucune valeur de duplication. Je ne suis pas une personne delphi mais si elle était java je voudrais créé un arbre hashmap / carte et ajouter chaque valeur à la carte et avant de l'ajouter à la vérification de la pile si elle est déjà dans le hachage. vous pouvez également ajouter toutes les valeurs e le hachage itérer, mais vous perdrez l'ordre du hachage.

Personnellement, je prendrais une approche complètement différente. D'abord, je ne vois pas comment vous n'avez pas à prendre tous les voisins en compte seulement en raison de l'utilisation d'un 1,1 décalage et je doute que des tours opérateurs de bits font l'algorithme beaucoup plus rapide (assez souvent il est au contraire, mais il pourrait être mem bande passante contrainte auquel cas nous allions gagner un peu)

Alors que je venais de passer pour une chose qui devrait apporter de loin le plus grand gain de performance: Faire l'algorithme multithread. Dans notre monde de se soucier Quad / Hex / Octacores de quelques pour cent de performance augmente tout en gaspillant 300% ou plus semble stupide. Donc, si nous avions ignorer les grilles actives et vérifier tous les domaines de l'algorithme serait trivial avec une grande échelle, d'autant plus que l'on pourrait facilement vectoriser l'algorithme, mais que ce je ne fonctionne pas particulièrement efficace alors essayez quelques approches différentes vers un multithreading algorithme qui ne prend que les cellules actives en compte.

Tout d'abord au lieu de se débarrasser de la grille je doublerai: Un src et une grille dest - qui a troqué chaque tour. Aucun verrouillage pour accéder au réseau nécessaire, ne pas à vous soucier de la mise à jour lorsque les champs et aucune entrée rassis (important pour le multithreading nous voulons utiliser le cache après tout).

Maintenant, la solution la plus simple serait d'utiliser une sorte de structure de liste concurrente (aucune idée sur les bibliothèques delphi) pour les cellules actives et laisser chaque fil voler de celui-ci et ajouter de nouvelles cellules actives à l'autre. Avec une bonne mise en œuvre sans blocage d'une file d'attente concurrente (essentiellement quel que soit le remplacement de cette est delphi) ou quelque chose de semblable pourrait être tout à fait agréable et simple. Pour une meilleure performance au lieu d'ajouter des nœuds simples à la liste, je pense à ajouter des morceaux entiers à la liste, par exemple dans des tailles de 10 ou si - plus de travail avec moins de frais généraux, mais si nous faisons les morceaux trop gros, nous parallélisme lose.

Je ne peux penser à d'autres solutions comme donner à chaque fil une liste des cellules actives au travail à travers (ou plus exactement une liste pour tous et décalages différents) mais nous devons entre chaque série de recueillir toutes les nouvelles entrées (pas de frais généraux de synchronisation mais certains copie) dans une liste -. la peine d'essayer, je suppose

Si votre objectif est la vitesse (et seulement la vitesse). Il y a quelques trucs qui peuvent accélérer les choses beaucoup. Ma propre implémentation de Game of Life utiliser ces astuces de Conway pour le rendre plus rapide. Notez qu'il est très cher sur la mémoire.

  1. Chaque cellules sont un objet
  2. Chaque objet de cellule contient ses coordonnées X / Y
  3. Chaque objet cellule contient un compteurs « live » du nombre de voisins vivants. (Quand un tour de cellule On / Off, il lui notifient son voisin afin qu'ils mettent à jour leurs compteurs.
  4. Pour faire # 3 œuvres, quand on calcule la prochaine génération, les cellules ne sont pas activés / désactivés tout de suite. Ils sont plutôt empilés dans une liste jusqu'à ce que toutes les cellules sont calculées.
  5. Chaque cellule a un compteur qui indique ce qui est de la dernière génération, ils ont changé sur. Qui permettent d'éviter le calcul de la même deux fois la cellule. (Mon alternative à la pile qui élimine les doublons)
  6. La liste des # 5 est réutilisée sur la prochaine génération, car seuls les voisins d'une cellule qui a changé sur la génération précédente peut changer sur l'actuel.

Il y a quelques-uns des trucs que j'utiliser pour accélérer la génération. Certains des trucs listés ici vous obtiendrez beaucoup plus que votre mise en œuvre multithreading. Mais en utilisant à la fois ceux-ci et multithread obtiendra les meilleures performances possibles.

En ce qui concerne le sujet multithread, lisez l'entrée de Voo.

La plupart du temps @Ken, le code source complet pour le programme de test:

Notez que 99.9% du temps est de passer dans l'affichage, parce que je n'ai pas fait quoi que ce soit à optimiser cela.

J'ai créé une nouvelle application SDI-principal et le code posté cela et parce que je suis paresseux, je ne l'ai pas pris la peine de renommer ou de repeindre tous les contrôles.

Fichier projet: sdiapp.dpr 

program Sdiapp;

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

{$R *.RES}

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

forme principale: 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 ne me permet pas d'afficher le fichier de formulaire en raison d'une limite de taille, mais j'espère que vous pouvez gérer sans.

Licencié sous: CC-BY-SA avec attribution
Non affilié à StackOverflow
scroll top