Algorithme de Dijkstra pour recherche de plus court chemin dans un graphe

**BeanzMaster** · 14/09/2020, 17h44

Envoyé par jurassic pork

EDIT : OK c'est bon maintenant en installant les paquets dt mais en voulant installer tous les paquets ensuite lazarus ne s'ouvre plus

Il faut faire attention à l'ordre d'installation des paquets, el mieux c'est d'abord de compiler les paquets "rt" dans l'ordre que je donne, puis installer un à un les paquets "dt"
d'abord "bzscene_tools_dt" puis "bzscene_image_dt"

si Lazarus ne s'ouvre plus c'est un des paquets "DT" qui coince. Je parierai sur "bzscene_audio_rt / bzscene_audio_dt" qui est capricieux, donc laisse tomber celui-ci pour le moment.

PS : Il faut également que tu installes les DLL surtout "FreeType" dans "c:\Windows\system32" pour les 64 bits et dans "c:\Windows\sysWOW64" pour les 32 bits
Si tu as voulu installer "bzscene_audio_rt" c'est surement qu'il faille copier la DLL de BASS (car celle-ci n'est pas chargée dynamiquement,. J'y travail)
Toutes les DLL requisent pour Windows sont présentes dans le dossier "Externals" de BZScene.

Pour Linux, il faudra installer les bibliothèques requises via ton gestionnaire de dépôt.

**jurassic pork** · 14/09/2020, 17h46

Ok maintenant je peux ouvrir le projet mais quand je veux compiler j'ai cette erreur :

unit1.pas(747,34) Error: identifier idents no member "InCircle"

**BeanzMaster** · 14/09/2020, 18h00

Envoyé par jurassic pork

Ok maintenant je peux ouvrir le projet mais quand je veux compiler j'ai cette erreur :

Décidement, désolé, pour les soucis,

(je ne pensais pas que vous alliez vouloir tester BZScene ) oups Effectivement cette méthode n'est pas présente , je l'ai rajouté pendant la game jam

Remplaces

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if (FMousePos.AsVector2f.InCircle(Node.Position.XY, 8)) then

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if PointInCircle(FMousePos.X; FMousePos.Y, Node.Position.X, Node.Position.Y, 8) then  // méthode présente dans l'unité BZGraphic

**JP CASSOU** · 14/09/2020, 18h07

Bjr à vous,

J'ai besoin de quelque chose de simple.

Mes noeuds sont structurés de la manière suivante, le graphe étant orienté:
TNumeroArc et TNumeroNoeud sont des integer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
type TGrapheNoeud = record
  IDStation: TIDStation; // il s'agit ici d'une étiquette représentant un nombre Int64
  X  : double;
  Y  : double;
  Z  : double;
  ListeArcsSortants    : array of TNumeroArc; 
  ListeArcsEntrants    : array of TNumeroArc;
end;

et mes arcs:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
type TGrapheArc = record
  IdxNoeudDepart  : TNumeroNoeud;
  IdxNoeudArrivee : TNumeroNoeud;
  Longueur        : double; // le poids, ici la longueur de l'arc
  Azimut          : double;
  Pente           : double;
end;

Mon objet TGraphe comporte deux tableaux dynamiques dont la taille est le nombre de noeuds:

FArrayDistancesMin: array of double; dont les éléments sont initialisés à +Infini
Cette liste est triée selon les étiquettes, elle comporte une fonction de recherche dicho:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
function TGraphe.FindNoeudByIDStation(const IDS: TIDStation; out ST: TGrapheNoeud; out IndexOf: TNumeroNoeud): boolean;
  function FindDepth(const I1, I2: TNumeroNoeud; const QIDX: TIDStation): TNumeroNoeud;
  var
    PVT: integer;
    C1 : TGrapheNoeud;
  begin
    Result := -1;
    // coupure en deux => calcul index médian
    PVT := (I2 + I1) div 2;
    // début > fin >> sortie directe avec erreur
    if (I1 > I2) then Exit(-1);
    C1 := GetNoeud(PVT); //GetBasePoint(PVT);
    // comparaison. Si vrai >> sortie avec numéro d'index
    if (C1.IDStation = QIDX) then Exit(PVT);
    // sinon, recherche en profondeur avec un niveau supplémentaire
    if (QIDX < C1.IDStation) then
    begin
      Result := FindDepth(I1, PVT-1, QIDX);
      Exit;
    end;
    Result := FindDepth(PVT+1, I2, QIDX);
  end;
begin
  Result := false;
  IndexOf := FindDepth(0, GetNbNoeuds() - 1, IDS);
  if (IndexOf >= 0) then
  begin
    ST     := GetNoeud(IndexOf);
    Exit(True);
  end;
end;

et le tableau
FArrayNoeudsVisites: array of boolean; dont les éléments sont initialisés à false

Au démarrage de ma recherche, je procède aux initialisations suivantes:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
  Result := false;
  FLeCheminTrouve.ClearListe();
  // sécurité: On met les distances minimales à +Inf et le statut Visité à False
  ResetTableauDistancesMin();
  ResetTableauNoeudsVisites();   
  // Recherche des noeuds de départ et d'arrivée
  Q1 := FindNoeudByIDStation(MakeTIDStation(Ser1, St1), QNoeudDepart, IdxNoeudDepart);
  if (Not Q1) then Exit(SetLastError(ERR_GRAPHE_NODE_NOT_FOUND, Format('Noeud "%d.%d" introuvable', [Ser1, St1])));
  Q1 := FindNoeudByIDStation(MakeTIDStation(Ser2, St2), QNoeudArrivee, IdxNoeudArrivee);
  if (Not Q1) then Exit(SetLastError(ERR_GRAPHE_NODE_NOT_FOUND, Format('Noeud "%d.%d" introuvable', [Ser2, St2])));
  FAfficherMessage(Format('%s.RechercherPlusCourtChemin(): %d: %d.%d -> %d: %d.%d', [ClassName, IdxNoeudDepart, Ser1, St1, IdxNoeudArrivee, Ser2, St2]));
  // Stations identiques -->[ ]
  Q1 := (Ser1 = Ser2) and (St1 = St2);
  if (Q1) then Exit(SetLastError(ERR_GRAPHE_SAME_START_END, '-- Les stations de départ et arrivée sont identiques'));
 
 
  // Le noeud courant est le noeud de départ
  QIdxNoeudCourant := IdxNoeudDepart;
  QNoeudCourant    := GetNoeud(QIdxNoeudCourant);
  // affichage de l'acquittement
  FAfficherMessage(Format('%s.RechercherPlusCourtChemin(): Acquittement %d: %d.%d -> %d: %d.%d', [ClassName, IdxNoeudDepart, Ser1, St1, IdxNoeudArrivee, Ser2, St2]));
  // La distance du noeud de départ est mise à 0.00
  FArrayDistancesMin[QIdxNoeudCourant] := 0.00;
  // Doit-on marquer 'Visité' le noeud de départ ici ?
  FArrayNoeudsVisites[IdxNoeudDepart] := True;
  // Pour contrôle
  ListerLesNoeuds('Après initialisation de la première itération', false);

Dans le while:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
 
while (Not NoeudsTousVisites()) do
  begin
    //FAfficherMessage(format('Passe %d - Noeud traité: %d ', []));
    if (NbPasses > 200) then break;  // Butée d'arrêt pour éviter les boucles infinis lors de la mise au point
    // Recherche le noeud non visité le plus proche
    QIdxNoeudCourant := RechercherIdxNearestNodeOf(QNoeudCourant, QDistanceMinNoeudVoisin);    // Noeud non visité de distance minimale
    // Sécurité: On quitte si le noeud n'est pas trouvé (ne devrait jamais se produire)
    if (QIdxNoeudCourant = -1) then
    begin
      exit(SetLastError(ERR_GRAPHE_NODE_NOT_FOUND, 'Noeud non trouvé'));
    end;
    // Si le nouveaud noeud est le noeud d'arrivée, on sort de la boucle
    if (QIdxNoeudCourant = IdxNoeudArrivee) then
    begin
      FAfficherMessage(Format('%d == %d', [QNoeudCourant.IDStation , QNoeudArrivee.IDStation]));
      FArrayNoeudsVisites[QIdxNoeudCourant] := True;
      break;
    end;
    // le noeud courant devient le plus proche qui a été trouvé
    QNoeudCourant := GetNoeud(QIdxNoeudCourant);
    FArrayNoeudsVisites[QIdxNoeudCourant] := True;
    // Pour les arcs sortants
    NbArcsSortants := Length(QNoeudCourant.ListeArcsSortants);
    if (NbArcsSortants > 0) then
    begin
      FAfficherMessage(Format('%d: %d arcs sortants', [QNoeudCourant.IDStation, NbArcsSortants]));
      for a := 0 to NbArcsSortants - 1 do
      begin
        qIdxArc   := QNoeudCourant.ListeArcsSortants[a];
        QArc      := GetArc(qIdxArc);
        // On attrappe le successeur
        QIdxNoeudSuccesseur := QArc.IdxNoeudArrivee;
        QST1                := GetNoeud(QIdxNoeudSuccesseur);
        QDistance1 := FArrayDistancesMin[QIdxNoeudCourant]    + QArc.Longueur;
        QDistance2 := FArrayDistancesMin[QIdxNoeudSuccesseur] + QArc.Longueur;
        if (QDistance2 < QDistance1) then
        begin
          FArrayDistancesMin[QIdxNoeudSuccesseur]  := QDistance1;
          FArrayNoeudsVisites[QIdxNoeudSuccesseur] := True;
          // mise à jour du prédécesseur
          QArc.IdxNoeudDepart := QIdxNoeudCourant;
          PutArc(a, QArc);
          FAfficherMessage(Format('Changement du noeud courant: %d devient %d', [QNoeudCourant.IDStation, QST1.IDStation]));
          QIdxNoeudCourant := QIdxNoeudSuccesseur;
          QNoeudCourant := GetNoeud(QIdxNoeudCourant);
          // on met à jour le tableau des distances
          FArrayDistancesMin[QIdxNoeudSuccesseur]  += QDistanceMinNoeudVoisin;
        end;
      end;
    end;
    Inc(NbPasses);
    // pour contrôle après la passe
    ListerLesNoeuds(Format('Passe %d', [NbPasses]));
    // Afficher le graphe
    FAfficherGraphe();
  end;

**BeanzMaster** · 14/09/2020, 18h29

Envoyé par JP CASSOU

Bjr à vous,

J'ai besoin de quelque chose de simple.

Mes noeuds sont structurés de la manière suivante, le graphe étant orienté:
TNumeroArc et TNumeroNoeud sont des integer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
type TGrapheNoeud = record
  IDStation: TIDStation; // il s'agit ici d'une étiquette représentant un nombre Int64
  X  : double;
  Y  : double;
  Z  : double;
  ListeArcsSortants    : array of TNumeroArc; 
  ListeArcsEntrants    : array of TNumeroArc;
end;

et mes arcs:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
type TGrapheArc = record
  IdxNoeudDepart  : TNumeroNoeud;
  IdxNoeudArrivee : TNumeroNoeud;
  Longueur        : double; // le poids, ici la longueur de l'arc
  Azimut          : double;
  Pente           : double;
end;

Avec le code que j'ai donné il n'y pas plus simple :
Il faut juste, faire quelques adaptions dans les classes de bases

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
 
  TNumeroNoeud = Integer;
  TArrayOfNumeroNoeud = Array of TNumeroNoeud 
  TNode = Class
  private
    FOwner : TGraphNode;
 
    FPosition : TBZVector;  // = X, Y, Z on peut remplacer aussi par Latitude, Longitude, Elevation
 
    FNodeLinkList : TNodeLinkList;
    FNodeIndex : Integer;
 
           FIDStation : Integer;
 
    procedure SetOwner(const AValue: TGraphNode);
    function geNodeLink(Index : Integer): TNodeLink;
 
    procedure seNodeLink(Index : Integer; const AValue: TNodeLink);
 
          function getArcsSortants : TArrayOfNumeroNoeud;
          function getArcEntrants : TArrayOfNumeroNoeud;
 
  public
    constructor Create(AOwner : TGraphNode; APosition : TBZVector);
    destructor Destroy; override;
 
    function AddNodeLink(anIndex : Integer) : TNodeLink; overload;
 
 
    property Owner : TGraphNode read FOwner write SetOwner;
    property Position : TBZVector read FPosition write FPosition;
    property NodeIndex : Integer read FNodeIndex write FNodeIndex;
    property LinkNode[Index : Integer] : TNodeLink read geNodeLink write seNodeLink;
    property NodeLinkList : TNodeLinkList read FNodeLinkList;
 
             property IDStation : Integer read FIDSTation write FIDStation;
 
             property ListeArcsSortants  :  TArrayOfNumeroNoeud read getArcsSortants ; // Ca correspond a "NodeLinkList"   ou a récupérer via "NodeLinkList" et la propriété "TargetIndex"
             property ListeArcsEntrants   : TArrayOfNumeroNoeud read getArcEntrants;   // A récupérer via "FOwner"pour chaque noeud, on va chercher les liens dans le "NodeLinkList", qui pointe "TargetIndex" vers ce noeud "NodeIndex"
  end;   
 
  { TNodeLink }
  TNodeLink = class
  private
    FOwner : TNodeLinkList;
    FTargetNodeIndex : Integer;
 
                    // FDistance : Single; // = Longueur On peut le garder mémoire
                   FAzimut          : double;
                   FPente           : double;
 
    procedure SetTargetNodeIndex(const AValue: Integer);
    procedure SetOwner(const AValue: TNodeLinkList);
    function getDistance: Single;
    function getNode: TNode;
    function getParentNode: TNode;
 
                function GetAzimut : Double;
                function GetPente : Double;
 
 
  public
    constructor Create(AOwner : TNodeLinkList; ATargetNodeIndex : Integer);
    destructor Destroy; override;
 
    property TargetNodeIndex : Integer read FTargetNodeIndex write SetTargetNodeIndex;
    property Owner : TNodeLinkList  read FOwner write setOwner;
 
             property Distance : Single read getDistance;   //FDistance = Longueur
 
    property Node : TNode read getNode;
    property ParentNode : TNode read getParentNode;
 
            property Azimut : Double read getAzimut;
            property Pente : Double read getPente;
  end;

Ensuite tu peux rajouter des méthodes globales, dans TGraphNode pour simplifier la gestion de tout ce petit monde

Pour ce qui est de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
  IdxNoeudDepart  : TNumeroNoeud;
  IdxNoeudArrivee : TNumeroNoeud;

Je ferai une simple liste répertoriant les stations

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Type
  TStation = record
    IDStation : Integer;
    IdxNoeudDepart  : TNumeroNoeud;  // je pas trop à quoi ca sert car la station est fixe
    IdxNoeudArrivee : TNumeroNoeud; 
  end;
 
  TListeStation = Array of TStation;

Ce qui permettrai d'appeler la methode de recherche (à modifier légerement pour rechercher le noeud en fonction de IDStation [c]GraphNode.Dijkstra(ListeStation['BoutDuMonde"].IDStation, ListeStation['BoutDuMonde"].IdxNoeudArrive[4]);

Du moins quelques chose dans le genre, et j'engloberai tout ca dans une classe "TGestionLignesMetro" avec des méthodes pour ajouter des lignes et des stations.

**JP CASSOU** · 14/09/2020, 18h36

Quand je dis 'simple', c'est sans utilisation de la librairie BZ, dans un premier temps

Envoyé par BeanzMaster

Avec le code que j'ai donné il n'y pas plus simple :
Il faut juste, faire quelques adaptions dans les classes de bases

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
 
  TNumeroNoeud = Integer;
  TArrayOfNumeroNoeud = Array of TNumeroNoeud 
  TNode = Class
  private
    FOwner : TGraphNode;
 
    FPosition : TBZVector;  // = X, Y, Z on peut remplacer aussi par Latitude, Longitude, Elevation
 
    FNodeLinkList : TNodeLinkList;
    FNodeIndex : Integer;
 
           FIDStation : Integer;
 
    procedure SetOwner(const AValue: TGraphNode);
    function geNodeLink(Index : Integer): TNodeLink;
 
    procedure seNodeLink(Index : Integer; const AValue: TNodeLink);
 
          function getArcsSortants : TArrayOfNumeroNoeud;
          function getArcEntrants : TArrayOfNumeroNoeud;
 
  public
    constructor Create(AOwner : TGraphNode; APosition : TBZVector);
    destructor Destroy; override;
 
    function AddNodeLink(anIndex : Integer) : TNodeLink; overload;
 
 
    property Owner : TGraphNode read FOwner write SetOwner;
    property Position : TBZVector read FPosition write FPosition;
    property NodeIndex : Integer read FNodeIndex write FNodeIndex;
    property LinkNode[Index : Integer] : TNodeLink read geNodeLink write seNodeLink;
    property NodeLinkList : TNodeLinkList read FNodeLinkList;
 
             property IDStation : Integer read FIDSTation write FIDStation;
 
             property ListeArcsSortants  :  TArrayOfNumeroNoeud read getArcsSortants ; // Ca correspond a "NodeLinkList"   ou a récupérer via "NodeLinkList" et la propriété "TargetIndex"
             property ListeArcsEntrants   : TArrayOfNumeroNoeud read getArcEntrants;   // A récupérer via "FOwner"pour chaque noeud, on va chercher les liens dans le "NodeLinkList", qui pointe "TargetIndex" vers ce noeud "NodeIndex"
  end;   
 
  { TNodeLink }
  TNodeLink = class
  private
    FOwner : TNodeLinkList;
    FTargetNodeIndex : Integer;
 
                    // FDistance : Single; // = Longueur On peut le garder mémoire
                   FAzimut          : double;
                   FPente           : double;
 
    procedure SetTargetNodeIndex(const AValue: Integer);
    procedure SetOwner(const AValue: TNodeLinkList);
    function getDistance: Single;
    function getNode: TNode;
    function getParentNode: TNode;
 
                function GetAzimut : Double;
                function GetPente : Double;
 
 
  public
    constructor Create(AOwner : TNodeLinkList; ATargetNodeIndex : Integer);
    destructor Destroy; override;
 
    property TargetNodeIndex : Integer read FTargetNodeIndex write SetTargetNodeIndex;
    property Owner : TNodeLinkList  read FOwner write setOwner;
 
             property Distance : Single read getDistance;   //FDistance = Longueur
 
    property Node : TNode read getNode;
    property ParentNode : TNode read getParentNode;
 
            property Azimut : Double read getAzimut;
            property Pente : Double read getPente;
  end;

Ensuite tu peux rajouter des méthodes globales, dans TGraphNode pour simplifier la gestion de tout ce petit monde

**BeanzMaster** · 14/09/2020, 18h46

Envoyé par JP CASSOU

Quand je dis 'simple', c'est sans utilisation de la librairie BZ, dans un premier temps

Tu n'est pas obligé, d'utiliser BZScene.
C'est sure il y a un peu de travail à faire pour l'adaptation.
Tu va quand même pas me dire que mon code est super dure à comprendre et à lire ? si ?

TNode = Class ça c'est du pascal pure et dure et pas besoin de BZScene

Tu utilises déja des listes générique type TListeSimple<T> = class(TFPList) dans ton code, il suffit juste d'adapter, non ?
Je pense que c'est à ta porté, de remplacer TNodeLinkList = class(specialize TBZBaseArray<TNodeLink>) par ta liste générique type TListeSimple<T> = class(TFPList) non ?
Je t'apporte déja une solution gratuitement, c'est déja pas mal non ?

Donc soit tu adaptes mon code a tes contraintes, soit tu adaptes l'aglo que je t'ai fournis à ton code. Tu as tous les éléments en main.

Après tu fais comme tu veux, c'est toi qui voit.

A+

Jérôme

**jurassic pork** · 14/09/2020, 21h50

hello,

Envoyé par BeanzMaster

Décidement, désolé, pour les soucis,

(je ne pensais pas que vous alliez vouloir tester BZScene ) oups Effectivement cette méthode n'est pas présente , je l'ai rajouté pendant la game jam

Remplaces

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if (FMousePos.AsVector2f.InCircle(Node.Position.XY, 8)) then

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if PointInCircle(FMousePos.X; FMousePos.Y, Node.Position.X, Node.Position.Y, 8) then  // méthode présente dans l'unité BZGraphic

Arf j'avais encore des erreurs de compilation sur le code de substitution :
il y avait un ; au lieu d'un , après le 1 er argument mais plus difficile Node.Position.X, Node.Position.Y sont des singles alors qu'on doit passer des Longint ( obligé de caster ) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
      if PointInCircle(FMousePos.X, FMousePos.Y,
                integer(Node.Position.X), integer(Node.Position.Y), 8) then

j'arrive enfin à compiler le programme mais quand je l'exécute j'ai directement un :

Execution stopped

ce qui explique pourquoi quand je lance l'exécutable du zip rien ne se passe.

comme antivirus j'ai windows defender qui n'a pas l'air de broncher.

EDIT : Bon finalement en mode debug j'ai un message d'erreur comme quoi il n'arrive pas à charger la dll freetype . Comme je suis en Lazarus 32 bits j'ai mis la dll 32 bits de externals dans SYSWOW64 et même dans le répertoire du projet mais toujours le message d'erreur avec après un execution stopped

EDIT2 : Bon j'ai été chercher la dll freetype sur le net ici et là ça fonctionne

donc elle est peut-être mauvaise dans ton zip.

EDIT3: Bon le cast en integer n'était pas une bonne idée car la fonction ne fonctionnait pas. Finalement dans BzGraphics j'ai créé une nouvelle fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

function PointInCircleSingle(const px,py,cx,cy: Single; const Radius:Integer): boolean; inline;

appelée comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
        if PointInCircleSingle(FMousePos.AsVector2f.X, FMousePos.AsVector2f.Y,
                  Node.Position.X, Node.Position.Y, 8) then

et là ça fonctionne

Ami calmant, J.P

**JP CASSOU** · 14/09/2020, 22h10

Envoyé par BeanzMaster

Tu n'est pas obligé, d'utiliser BZScene.
C'est sure il y a un peu de travail à faire pour l'adaptation.
Tu va quand même pas me dire que mon code est super dure à comprendre et à lire ? si ?

TNode = Class ça c'est du pascal pure et dure et pas besoin de BZScene

Tu utilises déja des listes générique type TListeSimple<T> = class(TFPList) dans ton code, il suffit juste d'adapter, non ?
Je pense que c'est à ta porté, de remplacer TNodeLinkList = class(specialize TBZBaseArray<TNodeLink>) par ta liste générique type TListeSimple<T> = class(TFPList) non ?
Je t'apporte déja une solution gratuitement, c'est déja pas mal non ?

Donc soit tu adaptes mon code a tes contraintes, soit tu adaptes l'aglo que je t'ai fournis à ton code. Tu as tous les éléments en main.

Après tu fais comme tu veux, c'est toi qui voit.

A+

Jérôme

Bsr,

J'ai cherché dans les sources de BZScene (https://github.com/jdelauney/BZScene...er/Source/Core) mais je ne trouve pas les unités concernant les graphes.
cdlt

**JP CASSOU** · 14/09/2020, 23h31

Bsr,

Je ne m'en sors toujours pas, et çà me gonfle. C'est du pénible +++

Je précise que je ne dois utiliser que les éléments suivants (çà m'est imposé)

- Une liste des noeuds
- Une liste des arcs
- Un tableau 0.. n-1 des distances
- Un tableau 0 .. n-1 des sommets visités

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
type TNumeroArc   = type Integer;
type TIDStation = type Int64;
type TGrapheNoeud = record
  IDStation: TIDStation;
  X  : double;
  Y  : double;
  Z  : double;
  ListeArcsSortants    : array of TNumeroArc;
  ListeArcsEntrants    : array of TNumeroArc;
end;
type TGrapheArc = record
  IdxNoeudDepart  : TNumeroNoeud;
  IdxNoeudArrivee : TNumeroNoeud;
  Longueur        : double;   // le poids, ici la longueur de l'arc
  Azimut          : double;   // pour la détermination du cap de la visée suivante
  Pente           : double;
end;

Je suis sur le sujet depuis plusieurs jours et je n'avance pas.
La sous-traitance est sérieusement envisagée. J'ai un concours interne (pas en info) demain.

La fonction RechercherPlusCourtChemin() modifiée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
 
function TGraphe.RechercherPlusCourtChemin(const Ser1, St1, Ser2, St2: integer): boolean;
var
  QDistanceMinNoeudVoisin: Double;  // distance du noeud le plus proche du noeud courant
  QNoeudDepart, QNoeudArrivee, QNoeudCourant, QST1: TGrapheNoeud;
  IdxNoeudDepart, IdxNoeudArrivee: TNumeroNoeud;
  //QIdxPredecesseur, QIdxNoeudSuccesseur: TNumeroNoeud;
 
  i, QIdxNoeudCourant, a, NbArcsSortants, NbPasses: integer;
  Q1: Boolean;
  QArc: TGrapheArc;
  qIdxArc: TNumeroArc;
  QDistance1, QDistance2: double;
begin
  Result := false;
  FLeCheminTrouve.ClearListe();
  // sécurité: On met les distances minimales à +Inf et le statut Visité à False
  ResetTableauDistancesMin();
  ResetTableauNoeudsVisites();
  SetLastError(0, '');
  // Recherche des noeuds de départ et d'arrivée
  Q1 := FindNoeudByIDStation(MakeTIDStation(Ser1, St1), QNoeudDepart, IdxNoeudDepart);
  if (Not Q1) then Exit(SetLastError(ERR_GRAPHE_NODE_NOT_FOUND, Format('Noeud "%d.%d" introuvable', [Ser1, St1])));
  Q1 := FindNoeudByIDStation(MakeTIDStation(Ser2, St2), QNoeudArrivee, IdxNoeudArrivee);
  if (Not Q1) then Exit(SetLastError(ERR_GRAPHE_NODE_NOT_FOUND, Format('Noeud "%d.%d" introuvable', [Ser2, St2])));
  FAfficherMessage(Format('%s.RechercherPlusCourtChemin(): %d: %d.%d -> %d: %d.%d', [ClassName, IdxNoeudDepart, Ser1, St1, IdxNoeudArrivee, Ser2, St2]));
  // Stations identiques -->[ ]
  Q1 := (Ser1 = Ser2) and (St1 = St2);
  if (Q1) then Exit(SetLastError(ERR_GRAPHE_SAME_START_END, '-- Les stations de départ et arrivée sont identiques'));
  // Le noeud courant est le noeud de départ
  QIdxNoeudCourant := IdxNoeudDepart;
  QNoeudCourant    := GetNoeud(QIdxNoeudCourant);
  FAfficherMessage(Format('%s.RechercherPlusCourtChemin(): Acquittement %d: %d.%d -> %d: %d.%d', [ClassName, IdxNoeudDepart, Ser1, St1, IdxNoeudArrivee, Ser2, St2]));
 
  FArrayDistancesMin[QIdxNoeudCourant] := 0.00;                    // La distance du noeud de départ est mise à 0.00
  FArrayNoeudsVisites[IdxNoeudDepart]  := True;                     // Doit-on marquer 'Visité' le noeud de départ ici ?
  // Pour contrôle
  ListerLesNoeuds('Après initialisation de la première itération', false);
 
  NbPasses := 0;
  FAfficherMessage(format('Juste avant le while: Station courante %d [%d]', [QIdxNoeudCourant, QNoeudCourant.IDStation]));
  while (Not NoeudsTousVisites()) do
  begin
    FAfficherMessage(format('Passe %d - Noeud traité: %d [QNoeudCourant%d]', [NbPasses, QIdxNoeudCourant, QNoeudCourant.IDStation]));
    FAfficherMessage('=======================');
    if (NbPasses > 20) then break;  // Butée d'arrêt pour éviter les boucles infinis lors de la mise au point
    // Pour les arcs sortants
    NbArcsSortants := Length(QNoeudCourant.ListeArcsSortants);
    if (NbArcsSortants > 0) then
    begin
      FAfficherMessage(Format('%d: %d arcs sortants', [QNoeudCourant.IDStation, NbArcsSortants]));
      QDistanceMinNoeudVoisin := Infinity;
      for a := 0 to NbArcsSortants - 1 do
      begin
        qIdxArc   := QNoeudCourant.ListeArcsSortants[a];
        QArc      := GetArc(qIdxArc);
          if (not FArrayNoeudsVisites[QArc.IdxNoeudArrivee]) then
          begin
            QDistanceMinNoeudVoisin := Min(QDistanceMinNoeudVoisin, QArc.Longueur);
            //QST1       := GetNoeud(QArc.IdxNoeudArrivee); //GetNoeud(QIdxNoeudSuccesseur);
            QDistance1 := FArrayDistancesMin[QIdxNoeudCourant]     + QArc.Longueur;
            QDistance2 := FArrayDistancesMin[QArc.IdxNoeudArrivee] + QArc.Longueur;
            if (QDistance1 < QDistance2) then
            begin
              QArc.IdxNoeudDepart := QIdxNoeudCourant;  // mise à jour du prédécesseur
              QIdxNoeudCourant := QArc.IdxNoeudArrivee; // MAJ du noeud suivant
              PutArc(qIdxArc, QArc);
              //FAfficherMessage(Format('Changement du noeud courant:  %d devient  %d', [QST1.IDStation, QNoeudCourant.IDStation]));
            end;
          end;
      end;
      FArrayDistancesMin[QIdxNoeudCourant]  += QDistanceMinNoeudVoisin;
      FArrayNoeudsVisites[QIdxNoeudCourant] := True;
      QNoeudCourant := GetNoeud(QIdxNoeudCourant);  // Si le nouveau noeud est le noeud d'arrivée, on sort de la boucle
      if (QIdxNoeudCourant = IdxNoeudArrivee) then
      begin
        FAfficherMessage(Format('%d == %d', [QNoeudCourant.IDStation , QNoeudArrivee.IDStation]));
        FArrayNoeudsVisites[QIdxNoeudCourant] := True;
        break;
      end;
    end;
 
 
    FAfficherMessage(Format('Noeud courant: %d %d', [QIdxNoeudCourant, QNoeudCourant.IDStation]));
    Inc(NbPasses);
    // pour contrôle après la passe
    //ListerLesNoeuds(Format('Passe %d', [NbPasses]));
    // Afficher le graphe
    FAfficherGraphe();
  end;
  FAfficherGraphe();
  FAfficherMessage(Format('%d passes', [NbPasses]));
  //****************************************************************************
  exit;
  FAfficherMessage('Parcours terminé');
  //*)
end;

La sortie :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 
Traitement du graphe
TGraphe.RechercherPlusCourtChemin(): 1: 1.1 -> 9: 2.2
TGraphe.RechercherPlusCourtChemin(): Acquittement 1: 1.1 -> 9: 2.2
 
Après initialisation de la première itération
15 noeuds (0,00, 0,00) -> 550,00, 350,00
 0: 100000: 1.0 0,00, 0,00: 1 arcs entrants, 1 arcs sortants, DistMini: +Inf, Visité: non
 1: 100001: 1.1 10,00, 10,00: 3 arcs entrants, 3 arcs sortants, DistMini: 0,00, Visité: OUI
 2: 100002: 1.2 100,00, 0,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 3: 100003: 1.3 200,00, 0,00: 3 arcs entrants, 3 arcs sortants, DistMini: +Inf, Visité: non
 4: 100004: 1.4 300,00, 0,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 5: 100005: 1.5 300,00, 100,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 6: 100006: 1.6 300,00, 200,00: 3 arcs entrants, 3 arcs sortants, DistMini: +Inf, Visité: non
 7: 100007: 1.7 550,00, 350,00: 1 arcs entrants, 1 arcs sortants, DistMini: +Inf, Visité: non
 8: 200001: 2.1 200,00, 101,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 9: 200002: 2.2 100,00, 100,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 10: 200003: 2.3 100,00, 200,00: 3 arcs entrants, 3 arcs sortants, DistMini: +Inf, Visité: non
 11: 200004: 2.4 26,00, 200,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 12: 300001: 3.1 0,00, 100,00: 2 arcs entrants, 2 arcs sortants, DistMini: +Inf, Visité: non
 13: 400001: 4.1 200,00, 200,00: 3 arcs entrants, 3 arcs sortants, DistMini: +Inf, Visité: non
 14: 400002: 4.2 200,00, 250,00: 1 arcs entrants, 1 arcs sortants, DistMini: +Inf, Visité: non
 
Juste avant le while: Station courante 1 [100001]
Passe 0 - Noeud traité: 1 [QNoeudCourant100001]
=======================
100001: 3 arcs sortants
Noeud courant: 2 100002
Passe 1 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 2 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 3 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 4 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 5 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 6 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 7 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 8 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 9 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 10 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 11 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 12 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 13 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 14 - Noeud traité: 2 [QNoeudCourant100002]
=======================
100002: 2 arcs sortants
Noeud courant: 2 100002
Passe 15 - Noeud traité: 2 [QNoeudCourant100002]

**BeanzMaster** · 15/09/2020, 09h05

Envoyé par JP CASSOU

Bsr,

J'ai cherché dans les sources de BZScene (https://github.com/jdelauney/BZScene...er/Source/Core) mais je ne trouve pas les unités concernant les graphes.
cdlt

Salut tout est dans le zip. Après concernant l'affichage c'est comme travailler avec un TBItmap native et le Canvas pen,.color, pen.Style, moveto, lineto...., sinon les unités utilisées pour le graphisme sont dan sources/core (bzcolors, bzprahic) et dans le dossier sources/images (bzbitmap)

**BeanzMaster** · 15/09/2020, 09h11

Envoyé par JP CASSOU

Bsr,

Je ne m'en sors toujours pas, et çà me gonfle. C'est du pénible +++

Je précise que je ne dois utiliser que les éléments suivants (çà m'est imposé)

- Une liste des noeuds
- Une liste des arcs
- Un tableau 0.. n-1 des distances
- Un tableau 0 .. n-1 des sommets visités

- Une liste des noeuds OK
- Une liste des arcs OK Ce sont bien des liaisons que l'on parle, c'est que le Noeud A pointe vers B, C, E, Z, Q etc.... ?
- Un tableau 0.. n-1 des distances OK
- Un tableau 0 .. n-1 des sommets visités : Ca correspond à quoi au chemin parcouru par ton metro, pour savoir si il est deja passé par une station ? ou c'est juste une obligation d'implementation pour l'algo ?

**BeanzMaster** · 15/09/2020, 09h26

Hello JP

Envoyé par jurassic pork

hello,

Arf j'avais encore des erreurs de compilation sur le code de substitution :
il y avait un ; au lieu d'un , après le 1 er argument mais plus difficile Node.Position.X, Node.Position.Y sont des singles alors qu'on doit passer des Longint ( obligé de caster ) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
      if PointInCircle(FMousePos.X, FMousePos.Y,
                integer(Node.Position.X), integer(Node.Position.Y), 8) then

Envoyé par jurassic pork

EDIT3: Bon le cast en integer n'était pas une bonne idée car la fonction ne fonctionnait pas. Finalement dans BzGraphics j'ai créé une nouvelle fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

function PointInCircleSingle(const px,py,cx,cy: Single; const Radius:Integer): boolean; inline;

appelée comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
if PointInCircleSingle(FMousePos.AsVector2f.X, FMousePos.AsVector2f.Y,  Node.Position.X, Node.Position.Y, 8) then

et là ça fonctionne

Ce n'est pas bien de caster, sur des type single, double ,

cela occasionne souvent des erreurs dans les nombres
le mieux c'est d'utiliser Round ou Trunc

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
var
 nb : TBZPoint; // ou TBZVector2i
 
  np := Node.Position.XY.Round;
  if PointInCircle(FMousePos.X, FMousePos.Y, np.X, np.Y, 8) then

Hum c'est bizarre que tu as du tout passer en single voici ma version actuelle de PointInCircle(j'ai peut être modifié depuis ma dernière mise à jour du dépot)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
function PointInCircle(const px,py,cx,cy: Integer; const Radius:Integer): boolean; inline;
var x,y: single;
begin
  x := cx - px;
  y := cy - py;
  result := (x * x + y * y) < (radius * radius);
end;

Envoyé par jurassic pork

EDIT : Bon finalement en mode debug j'ai un message d'erreur comme quoi il n'arrive pas à charger la dll freetype . Comme je suis en Lazarus 32 bits j'ai mis la dll 32 bits de externals dans SYSWOW64 et même dans le répertoire du projet mais toujours le message d'erreur avec après un execution stopped

EDIT2 : Bon j'ai été chercher la dll freetype sur le net ici et là ça fonctionne

donc elle est peut-être mauvaise dans ton zip.

Ami calmant, J.P

Non dans le zip il n'y avait pas la DLL, j'ai oublié de l'ajouter
Sinon toutes les DLLs nécessaires pour BZScene (à un moment ou un autre, suivant les fonctionnalités utilisées) pour Windows 32 et 64 sont dans le dossier \BZScene\Externals\Windows\ et x86 pour le 32 bit et x64 pour les 64bit

Par contre c'est vrai je n'ai pas beaucoup testé BZScene en 32 bits, n'hésites pas à me dire si tu as des erreurs. Si jamais tu as des exemples d'utilisations de BZScene ici et là

A+

Jérôme

**jurassic pork** · 15/09/2020, 09h46

hello Jérôme,

Envoyé par BeanzMaster

Non dans le zip il n'y avait pas la DLL, j'ai oublié de l'ajouter
Sinon toutes les DLLs nécessaires pour BZScene (à un moment ou un autre, suivant les fonctionnalités utilisées) pour Windows 32 et 64 sont dans le dossier \BZScene\Externals\Windows\ et x86 pour le 32 bit et x64 pour les 64bit

Par contre c'est vrai je n'ai pas beaucoup testé BZScene en 32 bits, n'hésites pas à me dire si tu as des erreurs. Si jamais tu as des exemples d'utilisations de BZScene ici et là

e

oops ce n'est pas dans le zip mais dans la librairie bzscene-master que j'avais pris la dll ( donc dll 32 bits à vérifier)

Ami calmant, J.P

**BeanzMaster** · 15/09/2020, 09h54

Envoyé par jurassic pork

hello Jérôme,

oops ce n'est pas dans le zip mais dans la librairie bzscene-master que j'avais pris la dll ( donc dll 32 bits à vérifier)

Ami calmant, J.P

Bizarre, bref j'ai essayé avec la version x64 du lien que tu fournis et elle ne fonctionne pas chez moi

Dans le doute voici un zip tout neuf avec ma DLL x64 et ta DLL x86

Merci

A+

Jérôme

**jurassic pork** · 15/09/2020, 10h24

je viens d'essayer le nouveau zip : il fonctionne

pour la dll peut être la version de vs utilisée pour la compilation :

pour celle de Kingdread

Compiled with MS Visual Studio 2013.

Ami calmant, J.P

**JP CASSOU** · 15/09/2020, 12h20

Bjr à tous,

J'ai choisi d'adapter les unités de graphes de BZ dans mon projet

Je rencontre une erreur pénible +++++ ici:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
bzgraphesclasses.pas(490,17) Error: Incompatible types: got "TClass" expected "TBZClassNode"

Les unités adaptées (le système d'envoi des PJ dans DVP, c'est de la merde

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
 
unit BZGraphesClasses;
 
{$mode delphi}{$H+}
 
 
 { Algo Dijkstra : https://ksvi.mff.cuni.cz/~dingle/2017/lecture_10.html }
 
interface
 
uses
  Classes, SysUtils, math,
  UnitGraphesTypes,
  BZArrayClasses;
 
 
type
  TBZGraphNode    = class;
  TBZNodeLink     = class;
  TBZNodeLinkList = class;
  //noeud
  TBZClassNode = Class
  private
    FOwner        : TBZGraphNode;
 
    FNodeLinkList : TBZNodeLinkList;
    FNodeIndex    : Integer;
    // data
    FIDStation    : TIDStation;
    FCoordNoeudX  : double;
    FCoordNoeudY  : double;
    FCoordNoeudZ  : double;
 
    procedure SetOwner(const AValue: TBZGraphNode);
    function  GetNodeLink(const Index : Integer): TBZNodeLink;
 
    procedure SetNodeLink(Index : Integer; const AValue: TBZNodeLink);
  public
    constructor Create(AOwner : TBZGraphNode; const QIDStation: TIDStation; const X, Y, Z: double);
    destructor  Destroy; override;
 
    function AddNodeLink(anIndex : Integer) : TBZNodeLink; overload;
    //function AddLinkNode(aNode : TNode) : TNodeLink; overload;
 
    property Owner : TBZGraphNode read FOwner write SetOwner;
 
    property IDStation     : TIDStation read FIDStation write FIDStation;
    property X  : double read FCoordNoeudX write FCoordNoeudX;
    property Y  : double read FCoordNoeudY write FCoordNoeudY;
    property Z  : double read FCoordNoeudZ write FCoordNoeudZ;
 
 
 
    property NodeIndex : Integer read FNodeIndex write FNodeIndex;
    property LinkNode[Index : Integer] : TBZNodeLink read GetNodeLink write SetNodeLink;
    property NodeLinkList : TBZNodeLinkList read FNodeLinkList;
  end;
// arc
  TBZNodeLink = class
  private
    FOwner : TBZNodeLinkList;
    FTargetNodeIndex : Integer;
   // FDistance : Single;
 
    procedure SetTargetNodeIndex(const AValue: Integer);
    procedure SetOwner(const AValue: TBZNodeLinkList);
    function  getDistance(): double;
    function  getNode(): TBZClassNode;
    function  getParentNode(): TBZClassNode;
 
  public
    constructor Create(AOwner : TBZNodeLinkList; ATargetNodeIndex : Integer);
    destructor Destroy; override;
 
    property TargetNodeIndex : Integer read FTargetNodeIndex write SetTargetNodeIndex;
    property Owner           : TBZNodeLinkList  read FOwner write setOwner;
    property Distance        : double read getDistance;   //FDistance;
    property Node            : TBZClassNode read getNode;
    property ParentNode      : TBZClassNode read getParentNode;
  end;
 
 
 
  { TGraphNode }
  TOnGraphNodeTravelNode = procedure (Sender : TObject; Node : TBZClassNode; ADistance : double) of object;
  TOnGraphNodeVerboseCall = procedure (Sender : TObject; msg : String) of object;
  //TBZGraphNode = class(specialize TBZBaseList<TClass>)
  TBZGraphNode = class(TBZBaseList<TClass>)
 
  private
 
    FOnGraphNodeTravelNode   : TOnGraphNodeTravelNode;
    FOnGraphNodeVerboseCall  : TOnGraphNodeVerboseCall;
 
    function getNode(Index : Integer): TBZClassNode;
    procedure setNode(Index : Integer; const AValue: TBZClassNode);
 
  protected
    //function CompareValue(Const elem1, elem2) : Integer;  override;
 
    procedure DoOnTravelNode(Sender : TObject; Anode : TBZClassNode; ADistance : double);
    procedure DoVerboseCall(const s :String);
  public
    constructor Create;
    destructor Destroy; override;
 
    function AddNode(ANode : TBZClassNode) : Integer; overload;
    function AddNode(const QIDStation: TIDStation; const QX, QY, QZ: double) : TBZClassNode; overload;
 
    function Dijkstra(FromIndex, ToIndex : Integer; out ShortestPath : TBZIntegerList) : Single;
 
    property Node[Index : Integer] : TBZClassNode read getNode write setNode;
 
    property OnTravelNode : TOnGraphNodeTravelNode read FOnGraphNodeTravelNode write FOnGraphNodeTravelNode;
    property OnVerboseCall  : TOnGraphNodeVerboseCall read FOnGraphNodeVerboseCall write FOnGraphNodeVerboseCall;
  end;
   // liste des arcs partant ou arrivant au noeud
  TBZNodeLinkList = class(TBZBaseList<TBZNodeLink>)
  private
    FOwner : TBZClassNode;
    procedure SetOwner(const AValue: TBZClassNode);
  protected
    function CompareValue(Const elem1, elem2: TBZNodeLink) : Integer;  override;
  public
    constructor Create(AOwner : TBZClassNode); overload;
    destructor Destroy; override;
 
    function NewNodeLink(ToIndex : Integer) : TBZNodeLink;
    function AddNodeLink(aNodeLink : TBZNodeLink) : Integer;
 
    property Owner : TBZClassNode read FOwner write SetOwner;
  end;
 
 
implementation
 
{$R *.lfm}
 
{%region=====[ TPriorityQueueHeap ]=============================================}
 
Const
  cNone = -MaxInt;
 
type
  TDynIntegerArray = Array of Integer;
  TDynSingleArray = Array of Single;
 
  { TPriorityQueueHeap }
 
  TPriorityQueueHeap = Class
  public
 
    Count: integer;
    Heap: TDynIntegerArray;      // binary heap holding values minimized by priority
    Priority: TDynSingleArray;  // each value's priority, or None if absent
    Position: TDynIntegerArray;  // each value's position in the heap array, or None if absent
 
    Constructor Create(n : Integer);
    Destructor Destroy; override;
 
    procedure Swap(var i, j: integer);
    function IsEmpty : Boolean;
    procedure MoveDown(Index: integer);
    procedure MoveUp(Index: integer);
    function InsertPriority(Index : Integer; APriorityValue : Single) : Integer;
    function RemoveSmallest(out APriorityValue : Single) : Integer;
    function IsExist(Index : Integer) : Boolean;
    function getPriority(Index : Integer) : Single;
    function DecreasePriority(Index : Integer; APriorityValue : Single) : Integer;
    function getParentIndex(Index : Integer) : Integer;
    function getLeftChildIndex(Index : Integer) : Integer;
    function getRightChildIndex(Index : Integer) : Integer;
 
  end;
 
 
Constructor TPriorityQueueHeap.Create(n: Integer);
var
  i: integer;
begin
  Self.Count := 0;
  setLength(Self.Heap, 1);
  setLength(Self.Priority, n);
  setLength(Self.Position, n);
  for i := 0 to n - 1 do
    begin
      Self.priority[i] := cNone;
      Self.position[i] := cNone;
    end;
end;
 
Destructor TPriorityQueueHeap.Destroy;
begin
  setLength(Self.Heap, 0);
  setLength(Self.Priority, 0);
  setLength(Self.Position, 0);
  Finalize(Self.Priority);
  Finalize(Self.Position);
  Finalize(Self.Heap);
  inherited Destroy;
end;
 
procedure TPriorityQueueHeap.Swap(var i, j: integer);
var
  k: integer;
begin
  k := i;
  i := j;
  j := k;
end;
 
function TPriorityQueueHeap.IsEmpty : Boolean;
begin
  Result := (Self.Count = 0);
end;
 
// Move the value at index i downward until its children are larger than it
procedure TPriorityQueueHeap.MoveDown(Index: integer);
var
  l, r, smallest: integer;
begin
  l := Self.getLeftChildIndex(Index);
  r := Self.getRightChildIndex(Index);
  smallest := Index;
 
  if (l < Self.Count) and (Self.Priority[Self.Heap[l]] < Self.Priority[Self.Heap[Index]]) then smallest := l;
  if (r < Self.Count)  and (Self.Priority[Self.Heap[r]] < Self.Priority[Self.Heap[smallest]]) then smallest := r;
 
  if smallest <> Index then  // some child is smaller
    begin
      Self.swap(Self.Heap[Index], Self.Heap[smallest]);
      Self.swap(Self.Position[Self.Heap[Index]], Self.Position[Self.Heap[smallest]]);
      Movedown(smallest);
    end;
end;
 
// Move the value at index i upward until its parent is smaller than it
procedure TPriorityQueueHeap.MoveUp(Index : integer);
var
  p: integer;
begin
  if Index = 0 then exit;
  p := Self.getParentIndex(Index);
  if (Self.Priority[Self.Heap[Index]] < Self.Priority[Self.Heap[p]]) then // smaller than parent
    begin
      Self.Swap(Self.Heap[Index], Self.Heap[p]);
      Self.Swap(Self.Position[Self.Heap[index]], Self.Position[Self.Heap[p]]);
      Self.MoveUp(p);
    end;
end;
 
function TPriorityQueueHeap.InsertPriority(Index: Integer; APriorityValue: Single) : Integer;
begin
  Result := 0;
  if (Self.Priority[Index] <> cNone) then
  begin
    Result := -1;
    Exit; // value is already in queue;
  end;
 
  if (Self.Count >= length(Self.Heap)) then  // array is full
  begin
    setLength(Self.Heap, length(Self.Heap) * 2);
  end;
  Self.Count := Self.Count + 1;
  Self.Heap[Self.Count - 1] := Index;
  Self.Position[Index] := Self.Count - 1;
  Self.Priority[Index] := APriorityValue;
  Self.MoveUp(Self.Count - 1);
end;
 
function TPriorityQueueHeap.RemoveSmallest(out APriorityValue : Single) : Integer;
var
  smallest: integer;
begin
  smallest := Self.Heap[0];
  Result := smallest;
  APriorityValue := Self.Priority[smallest];
  Self.Priority[smallest] := cNone;
  Self.Position[smallest] := cNone;
 
  Self.Heap[0] := Self.Heap[Self.Count - 1];
  Self.Position[Self.Heap[0]] := 0;
  Self.Count := Self.Count - 1;
  Self.MoveDown(0);
end;
 
function TPriorityQueueHeap.IsExist(Index : Integer) : Boolean;
begin
  Result := (Self.Priority[Index] <> cNone);
end;
 
function TPriorityQueueHeap.getPriority(Index : Integer) : Single;
begin
  Result := Self.Priority[Index];
end;
 
function TPriorityQueueHeap.DecreasePriority(Index : Integer; APriorityValue : Single) : Integer;
begin
  Result := 0;
  if Self.Priority[Index] = cNone then Result := - 1; // value is not in queue;
  if Self.Priority[Index] < APriorityValue then Result := -2; // existing priority is lower
 
  if (Result < 0) then Exit;
 
  Self.Priority[Index] := APriorityValue;
  MoveUp(Self.Position[Index]);
end;
 
function TPriorityQueueHeap.getParentIndex(Index : Integer) : Integer;
begin
  Result := (Index - 1) div 2;
end;
 
function TPriorityQueueHeap.getLeftChildIndex(Index : Integer) : Integer;
begin
  Result := 2 * Index + 1;
end;
 
function TPriorityQueueHeap.getRightChildIndex(Index : Integer) : Integer;
begin
  Result := 2 * Index + 2;
end;
 
{%endregion%}
 
{%region=====[ TNode ]==========================================================}
 
constructor TBZClassNode.Create(AOwner: TBZGraphNode; const QIDStation: TIDStation; const X, Y, Z: double);
begin
  FOwner := AOwner;
  FIDStation   := QIDStation;
  FCoordNoeudX := X;
  FCoordNoeudY := Y;
  FCoordNoeudZ := Z;
 
  FNodeLinkList := TBZNodeLinkList.Create(Self);
  FNodeIndex := -1;
  //if Assigned(FOwner) or (FOwner <> nil) then
  //begin
  //  Idx := FOwner.AddNode(Self);
  //  FNodeIndex := Idx;
  //end;
end;
 
destructor TBZClassNode.Destroy;
begin
  FreeAndNil(FNodeLinkList);
  inherited Destroy;
end;
 
function TBZClassNode.GetNodeLink(const Index : Integer): TBZNodeLink;
begin
  Result := FNodeLinkList.Items[Index];
end;
 
procedure TBZClassNode.SetNodeLink(Index : Integer; const AValue: TBZNodeLink);
begin
  Assert(((Index >= FNodeLinkList.Count)  or (Index < 0)), 'EdgeLIst : Index hors limite');
  AValue.Owner := FNodeLinkList;
  FNodeLinkList.Items[Index] := AValue;
end;
 
procedure TBZClassNode.SetOwner(const AValue: TBZGraphNode);
begin
  if FOwner = AValue then Exit;
  FOwner := AValue;
end;
 
function TBZClassNode.AddNodeLink(anIndex: Integer): TBZNodeLink;
Var
 aNodeLink : TBZNodeLink;
begin
  Assert(((anIndex >= FOwner.Count) or (anIndex < 0)), 'Node :  Edge Node Index hors limite');
  aNodeLink := TBZNodeLink.Create(FNodeLinkList, anIndex);
  FNodeLinkList.AddNodeLink(aNodeLink);
  Result := aNodeLink;
end;
 
 
{%endregion%}
 
{%region=====[ TNodeLink ]======================================================}
 
constructor TBZNodeLink.Create(AOwner: TBZNodeLinkList; ATargetNodeIndex: Integer);
begin
  FOwner := AOwner;
  FTargetNodeIndex := ATargetNodeIndex;
  //if FTargetNodeIndex = 0 then FDistance := 0
  //else FDistance := -1;
end;
 
destructor TBZNodeLink.Destroy;
begin
  inherited Destroy;
end;
 
procedure TBZNodeLink.SetOwner(const AValue: TBZNodeLinkList);
begin
  if FOwner = AValue then Exit;
  FOwner := AValue
end;
 
function TBZNodeLink.getDistance(): double;
var
  QParentNode, QCurrNode: TBZClassNode;
begin
  QParentNode := getParentNode();
  QCurrNode   := getNode();
  Result := sqrt((QCurrNode.X - QCurrNode.Y) ** 2 +
                 (QCurrNode.Y - QCurrNode.Y) ** 2 +
                 (QCurrNode.Z - QCurrNode.Z));
 
end;
 
function TBZNodeLink.getNode: TBZClassNode;
begin
  result :=FOwner.Owner.Owner.Node[FTargetNodeIndex];
end;
 
function TBZNodeLink.getParentNode: TBZClassNode;
begin
  Result := FOwner.Owner;
end;
 
procedure TBZNodeLink.SetTargetNodeIndex(const AValue: Integer);
begin
  if FTargetNodeIndex = AValue then Exit;
  FTargetNodeIndex := AValue;
end;
 
{%endregion%}
 
{%region=====[ TNodeLinkList ]==================================================}
 
constructor TBZNodeLinkList.Create(AOwner: TBZClassNode);
begin
  inherited Create(16);
  FOwner := AOwner;
end;
 
destructor TBZNodeLinkList.Destroy;
begin
  inherited Destroy;
end;
 
function TBZNodeLinkList.NewNodeLink(ToIndex: Integer): TBZNodeLink;
Var
  aNodeLink : TBZNodeLink;
begin
  aNodeLink := TBZNodeLink.Create(Self, ToIndex);
  Self.AddNodeLink(aNodeLink);
  Result := aNodeLink;
end;
 
function TBZNodeLinkList.AddNodeLink(aNodeLink: TBZNodeLink): Integer;
begin
  aNodeLink.Owner := Self;
  Result := Self.Add(aNodeLink);
end;
 
procedure TBZNodeLinkList.SetOwner(const AValue: TBZClassNode);
begin
  if FOwner = AValue then Exit;
  FOwner := AValue;
end;
 
function TBZNodeLinkList.CompareValue(Const elem1, elem2: TBZNodeLink): Integer;
begin
  if      elem1.TargetNodeIndex = elem2.TargetNodeIndex then Result :=  0
  else if elem1.TargetNodeIndex < elem2.TargetNodeIndex then Result := -1
  else                                                       Result :=  1;
end;
 
{%endregion%}
 
{%region=====[ TGraphNode ]=====================================================}
 
constructor TBZGraphNode.Create;
begin
  inherited Create(16);
end;
 
destructor TBZGraphNode.Destroy;
begin
  inherited Destroy;
end;
 
function TBZGraphNode.getNode(Index : Integer): TBZClassNode;
begin
  Result := Self.Items[Index];
end;
 
procedure TBZGraphNode.setNode(Index : Integer; const AValue: TBZClassNode);
begin
  Assert(((Index >= Self.Count) or (Index < 0)), 'GraphNode : Index hors limite');
  Self.Items[Index] := AValue;
end;
 
function TBZGraphNode.CompareValue(Const elem1, elem2): Integer;
begin
  Result := 0;
  (*
  if      elem1.NodeIndex = elem2.NodeIndex then Result :=  0
  else if elem1.NodeIndex < elem2.NodeIndex then Result := -1
  else                                           Result :=  1;
  //*)
end;
 
procedure TBZGraphNode.DoOnTravelNode(Sender : TObject; Anode: TBZClassNode; ADistance: double);
begin
  if Assigned(FOnGraphNodeTravelNode) then FOnGraphNodeTravelNode(Self, ANode, ADistance);
end;
 
procedure TBZGraphNode.DoVerboseCall(const s: String);
begin
  if Assigned(FOnGraphNodeVerboseCall) then FOnGraphNodeVerboseCall(Self, s);
end;
 
function TBZGraphNode.AddNode(const QIDStation: TIDStation; const QX, QY, QZ: double): TBZClassNode;
Var
  aNode : TBZClassNode;
  Idx : Integer;
begin
  aNode := TBZClassNode.Create(Self, QIDStation, QX, QY, QZ);
  aNode.IDStation := QIDStation;
  aNode.X := QX;
  aNode.Y := QY;
  aNode.Z := QZ;
 
  Idx := Self.AddNode(aNode);
  aNode.NodeIndex := Idx;
  Result := aNode;
end;
 
function TBZGraphNode.AddNode(ANode: TBZClassNode): Integer;
begin
  Result := Self.Add(aNode);
end;
 
function TBZGraphNode.Dijkstra(FromIndex, ToIndex: Integer; out ShortestPath: TBZIntegerList): Single;
var
  queue : TPriorityQueueHeap;
  pred : array of integer;
  i, j, cnt : integer;
  edge : TBZNodeLink;
  Dist, DMin : Single;
  DistTmp : Single;
begin
  ShortestPath := TBZIntegerList.Create(16);
  cnt := Self.Count;
  Queue := TPriorityQueueHeap.Create(cnt);
  Dist := 0;
  for i := 0 to (cnt - 1) do
  begin
    Queue.InsertPriority(i, MaxInt);
  end;
  setLength(pred{%H-}, cnt);
  Queue.DecreasePriority(FromIndex, 0);
  i := FromIndex;
 
  DoOnTravelNode(Self, Self.Items[i], Dist);
 
  // Première partie : recherche des chemins les plus court pour chaque noeud
  while not(Queue.isEmpty) do
  begin
    i := Queue.RemoveSmallest({ out } Dist);
    DoOnTravelNode(Self, Self.Items[i], Dist);
 
    if (i = ToIndex) then
    begin
      DoVerboseCall('===========================================================');
      DoVerboseCall('Level 4 - Tous chemins vers le noeud ' + i.ToString + ' ont été traités');
      break;
    end;
 
    if (Self.Items[i].NodeLinkList.Count > 0) then
    begin
      for j := 0 to (Self.Items[i].NodeLinkList.Count - 1) do
      begin
        Edge := Self.Items[i].LinkNode[j];
        DistTmp := Dist + Edge.Distance;
 
        DoVerboseCall('---------------------------------------------------------');
        DoVerboseCall('Level 1 - du noeud ' + i.ToString + ' vers noeud ' + Edge.TargetNodeIndex.ToString + ' --> Distance = ' + Edge.Distance.ToString);
 
        if (Queue.IsExist(Edge.TargetNodeIndex) and (DistTmp < Queue.getPriority(Edge.TargetNodeIndex))) then
        begin
          Queue.DecreasePriority(Edge.TargetNodeIndex, DistTmp);
          pred[Edge.TargetNodeIndex] := i;
          DMin := DistTmp;
          DoVerboseCall('Level 2 ---> C''est le chemin le plus court  du noeud ' + i.ToString + ' vers le noeud ' + Edge.TargetNodeIndex.ToString);
        end;
      end;
      if (i <> FromIndex) then
      begin
        DoverboseCall('[INFO] La distance  du noeud '+ FromIndex.ToString + ' vers le noeud ' + Edge.TargetNodeIndex.ToString + ' via le noeud '+ i.ToString +' est de : ' + DMin.ToString);
      end;
 
      DoVerboseCall('===========================================================');
      DoVerboseCall('Level 3 - Tous les chemins du noeud ' + i.ToString + ' ont été traités');
      DoVerboseCall('===========================================================');
    end;
  end;
 
  // Deuxieme partie : Extraction du chemin le plus court trouvé
  if (i = ToIndex) and (DistTmp < MaxInt) then
  begin
    Result := DistTmp;
    i := ToIndex;
    DoVerboseCall('Level 5 - Extraction du chemin le plus court du noeud ' + FromIndex.ToString + ' vers le noeud ' + ToIndex.ToString);
    While (pred[i] <> i) and (i <> FromIndex) do
    begin
      DoVerboseCall('Level 6 - Ajout du noeud ' + i.ToString);
      ShortestPath.Add(i);
      i := pred[i];
    end;
    DoVerboseCall('Level 6 - Ajout du noeud ' + FromIndex.ToString);
    ShortestPath.Add(FromIndex);
  end
  else result := -1;
 
  FreeAndNil(Queue);
end;
 
{%endregion%}
 
{ TMainForm }
 
procedure TMainForm.FormCreate(Sender: TObject);
begin
  FGraphNode := TGraphNode.Create;
  FGraphNode.OnTravelNode := @DoOnTavelNode;
  FGraphNode.OnVerboseCall := @DoOnVerboseCall;
  FDisplayBuffer := TBZBitmap.Create(PnlView.Width, pnlView.height);
  FSelectedNodeIndex := -1;
  FSelectedNodeLinkIndex := -1;
  FRenderShortestPath := False;
end;
 
procedure TMainForm.FormDestroy(Sender: TObject);
begin
  if Assigned(FShortestPath) then  FreeAndNil(FShortestPath);
  FreeAndNil(FDisplayBuffer);
  FreeAndNil(FGraphNode);
end;
 
procedure TMainForm.FormPaint(Sender: TObject);
begin
  RenderGraph;
  FDisplayBuffer.DrawToCanvas(pnlView.Canvas, pnlView.ClientRect);
end;
 
procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FMousePos.Create(x,y);
 
  if (ssLeft in Shift) then
  begin
    FMouseDown := True;
    if (ssShift in Shift) then
    begin
      if  (FSelectedNodeIndex <> -1) then FNodeAction := naAddLink
      else FNodeAction := naNone;
    end
    else
    begin
      if (FSelectedNodeIndex = -1) then
      begin
        FNodeAction := naAdd;
      end
      else FNodeAction := naNone;
    end;
  end
  else FNodeAction := naNone;
end;
 
procedure TMainForm.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Var
 NodePos : TBZVector;
 Node : TNode;
 NodeToLink : TNode;
begin
  if FMouseDown then
  begin
    if (FNodeAction = naAdd) then
    begin
      FMousePos.Create(x,y);
      NodePos.CreatePoint(x, y, 0);
      AddNode(NodePos);
    end
    else if (FNodeAction = naAddLink) then
    begin
      if (FSelectedNodeLinkIndex <> -1) then
      begin
        Node := FGraphNode.Node[FSelectedNodeIndex];
        NodeToLink := FGraphNode.Node[FSelectedNodeLinkIndex];
        LinkNode(Node, NodeToLink, False);
      end;
    end;
  end;
  FSelectedNodeIndex := -1;
  FSelectedNodeLinkIndex := -1;
  FNodeAction := naNone;
  FMouseDown := False;
  pnlView.Repaint;
end;
 
procedure TMainForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
Var
  idx : Integer;
  Node : TNode;
  np : TBZPoint;
begin
  FMousePos.Create(x,y);
  if FMouseDown then
  begin
    if ((Shift = [ssLeft, ssShift]) and (FNodeAction =  naAddLink)) then
    begin
      FSelectedNodeLinkIndex := -1;
      for idx := 0 to FGraphNode.Count-1 do
      begin
        Node := FGraphNode.Node[Idx];
        np := Node.Position.XY.Round;
        if PointInCircle(FMousePos.X, FMousePos.Y, np.X, np.Y, 8) then //(FMousePos.AsVector2f.InCircle(Node.Position.XY, 8)) then
        begin
          FSelectedNodeLinkIndex := Idx;
          Break;
        end;
      end;
    end;
  end
  else
  begin
    FSelectedNodeIndex := -1;
    for idx := 0 to FGraphNode.Count-1 do
    begin
      Node := FGraphNode.Node[Idx];
      np := Node.Position.XY.Round;
      if PointInCircle(FMousePos.X, FMousePos.Y, np.X, np.Y, 8) then //(FMousePos.AsVector2f.InCircle(Node.Position.XY, 8)) then
      begin
        FSelectedNodeIndex := Idx;
        Break;
      end;
    end;
  end;
  pnlView.Repaint;
end;
 
procedure TMainForm.btnFindShortestPathClick(Sender: TObject);
Var
  i, j : Integer;
  Node : TNode;
  NodeLink : TNodeLink;
  s : String;
  Dist : Single;
begin
  FRenderShortestPath := False;
  mmoDebug.clear;
  mmoDebug.Lines.Add('==========================================================');
  mmoDebug.Lines.Add('Graph construit avec ' + (FGraphNode.count.ToString) + ' noeuds');
  mmoDebug.Lines.Add('==========================================================');
  mmoDebug.Lines.Add('');
  for i := 0 to (FGraphNode.count - 1) do
  begin
    Node := FGraphNode.Items[i];
    mmoDebug.Lines.Add('Noeud ' + i.ToString);
    if (Node.NodeLinkList.Count > 0) then
    begin;
      for j := 0 to (Node.NodeLinkList.Count - 1) do
      begin
        mmoDebug.Lines.Add('----------------------------------------------------------');
        NodeLink := Node.LinkNode[j];
        mmoDebug.Lines.Add('   Lien ' + j.ToString);
        mmoDebug.Lines.Add('     -> vers le noeud : '+ NodeLink.TargetNodeIndex.ToString);
        mmoDebug.Lines.Add('             Distance : ' + NodeLink.Distance.ToString);
      end;
    end;
    mmoDebug.Lines.Add('==========================================================');
  end;
  mmoDebug.Lines.Add('');
  mmoDebug.Lines.Add('Début la recherche du chemin le plus court');
  mmoDebug.Lines.Add('==========================================================');
  Dist := FGraphNode.Dijkstra(speFromNodeIndex.Value, speToNodeIndex.Value, FShortestPath);
  mmoDebug.Lines.Add('Fin la recherche du chemin le plus court');
  mmoDebug.Lines.Add('==========================================================');
  if (Dist > 0) then
  begin
    mmoDebug.Lines.Add('Le plus court chemin du noeud ' + speFromNodeIndex.Value.ToString + ' vers le noeud ' + speToNodeIndex.Value.ToString);
    s := '';
    for i :=(FShortestPath.Count - 1) downto 0  do
    begin
      s := s + FShortestPath.Items[i].ToString;
      if (i > 0) then s := s + ', ';
    end;
    mmoDebug.Lines.Add('Passe par les noeuds : ' + s);
    mmoDebug.Lines.Add('La distance total est de : ' + Dist.ToString);
    FRenderShortestPath := True;
    pnlView.Repaint;
  end
  else
  begin
    mmoDebug.Lines.Add('Aucun chemin trouvé');
  end;
end;
 
procedure TMainForm.DoOnTavelNode(Sender: TObject; Node: TNode; ADistance: Single);
var
  s : String;
begin
  s:= '[INFO] Traitement du noeuds ' + Node.NodeIndex.ToString + ' - Distance par rapport au point de départ : ' + ADistance.ToString;
  mmoDebug.Append(s);
end;
 
procedure TMainForm.DoOnVerboseCall(Sender: TObject; msg: String);
begin
  mmoDebug.Append(msg);
end;
 
procedure TMainForm.BZThreadTimer1Timer(Sender: TObject);
begin
  //RenderGraph;
  pnlView.Repaint;
end;
 
procedure TMainForm.FormShow(Sender: TObject);
begin
  //BZThreadTimer1.Enabled := True;
end;
 
procedure TMainForm.AddNode(aPosition: TBZVector);
Var
 aNode : TNode;
begin
  aNode := FGraphNode.AddNode(aPosition);
  FSelectedNodeIndex := aNode.NodeIndex;
  Caption := 'Ajout d''un noeud à l''index : ' + FSelectedNodeIndex.ToString + '/' + FGraphNode.Count.ToString;
  speToNodeIndex.Value := FSelectedNodeIndex;
end;
 
procedure TMainForm.RemoveNode(Index: Integer);
begin
  FGraphNode.Delete(Index);
end;
 
procedure TMainForm.LinkNode(FromNode, ToNode: TNode; Const Bidi: Boolean);
begin
  FromNode.AddNodeLink(ToNode.NodeIndex);
  if Bidi then ToNode.AddNodeLink(FromNode.NodeIndex);
end;
 
procedure TMainForm.MoveNode(aNode: TNode; NewPosition: TBZVector);
begin
  FGraphNode.Node[aNode.NodeIndex].Position := NewPosition;
end;
 
function TMainForm.FindNodeFromPosition(aPosition: TBZVector): TNode;
Var
 aNode : TNode;
begin
  Result := Nil;
  FGraphNode.MoveFirst;
  aNode := FGraphNode.Current;
  While Not(FGraphNode.IsEndOfArray) do
  begin
    if (aNode.Position = aPosition) then
    begin
      Result := aNode;
      Break;
    end;
    FGraphNode.MoveNext;
    aNode := FGraphNode.Current;
  end;
end;
 
procedure TMainForm.RenderGraph;
Var
 idx : Integer;
 Node  : TNode;
 NodeLink : TNodeLink;
 
 pA, pB : TBZFloatPoint;
 
  procedure RenderNode(aNode : TNode; IsSelected : Boolean);
  begin
    with FDisplayBuffer.Canvas do
    begin
      Antialias := True;
      Pen.Style := ssSolid;
      if IsSelected then Pen.Color := clrAqua else Pen.Color := clrWhite;
      Brush.Style := bsSolid;
      if IsSelected then Brush.Color := clrYellow else Brush.Color := clrSilver;
      Circle(aNode.Position.XY, 8);
      Font.Color := clrBlack;
      Font.Size := 8;
      TextOut(Round(aNode.Position.XY.X - ((4 * aNode.NodeIndex.ToString.Length) - 2)), Round(aNode.Position.XY.Y + 4), aNode.NodeIndex.ToString);
    end;
  end;
 
  procedure RenderRubberLineLink;
  begin
    if (FNodeAction = naAddLink) then
    begin
      //(FSelectedNodeIndex <> -1) then
      begin
        Node := FGraphNode.Node[FSelectedNodeIndex];
        with FDisplayBuffer.Canvas do
        begin
          Pen.Style := ssSolid;
          Pen.Width := 3;
          Pen.Color := clrSkyBlue;
          pA := Node.Position.XY;
          pA.x := pA.x - 1;
          MoveTo(pA);
          pB := FMousePos.AsVector2f;
          LineTo(pB);
          //if (FSelectedNodeLinkIndex <> -1) then LineTo(NodeLink.Position.XY) else
        end;
      end;
    end;
  end;
 
  procedure RenderNodeLinks;
  Var
   i, j, k  : Integer;
   isBidi : Boolean;
  begin
    for i := 0 to (FGraphNode.Count - 1) do
    begin
      Node := FGraphNode.Node[i];
      if (Node.NodeLinkList.Count > 0) then
      begin
 
        for j := 0 to (Node.NodeLinkList.Count - 1) do
        begin
          NodeLink := Node.LinkNode[J];
          isBidi := false;
          if (NodeLink.Node.NodeLinkList.Count > 0) then
          begin
            for k := 0 to (NodeLink.Node.NodeLinkList.Count - 1) do
            begin
              if (NodeLink.Node.LinkNode[k].TargetNodeIndex = Node.NodeIndex) then
              begin
                isBidi := True;
                Break;
              end;
            end;
          end;
 
          with FDisplayBuffer.Canvas do
          begin
            Pen.Style := ssSolid;
            Pen.Width := 3;
            pA := Node.Position.XY;
            pB := NodeLink.Node.Position.XY;
            if not(IsBidi) then
            begin
              Pen.Color := clrOrange;
              MoveTo(pA);
              LineTo(pB);
            end
            else
            begin
              //Pen.Color := clrOrange;
              //pA := pA - 3;
              //pb := pB - 3;
              //MoveTo(pA);
              //LineTo(pB);
              Pen.Color := clrBlue;
              MoveTo(pA);
              LineTo(pB);
            end;
 
          end;
        end;
      end;
    end;
  end;
 
  procedure RenderShortestPath;
  var
    i : Integer;
  begin
 
    for i := 1 to (FShortestPath.Count - 1) do
    begin
      with FDisplayBuffer.Canvas do
      begin
         Pen.Style := ssSolid;
         Pen.Width := 3;
         pA := FGraphNode.Items[FShortestPath.Items[i - 1]].Position.XY;
         pB := FGraphNode.Items[FShortestPath.Items[i]].Position.XY;
         Pen.Color := clrLightMagenta;
         MoveTo(pA);
         LineTo(pB);
      end;
    end;
  end;
 
begin
  FDisplayBuffer.RenderFilter.DrawGrid(clrGray15, clrGray35, clrGray25, clrRed, clrGreen, 10);
 
  if FGraphNode.Count > 0 then
  begin
    RenderNodeLinks;
    RenderRubberLineLink;
    if FRenderShortestPath then RenderShortestPath;
    for idx := 0 to FGraphNode.Count-1 do
    begin
      Node := FGraphNode.Node[Idx];
      if (Idx = FSelectedNodeIndex) or (Idx = FSelectedNodeLinkIndex) then RenderNode(Node, True)
      else RenderNode(Node, False);
    end;
  end;
end;
 
 
{%endregion%}
 
end.

et

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
 
(*
  @abstract(Contient des classes génériques pour manipuler des
  tableaux "Array" a travers un pointeur.)
 
  Contient des classes pour manipuler des tableaux 1D de type Byte, Integer, Single et Double. @br
  Contient des classes pour manipuler des tableaux 2D de type Byte, Integer, Single et Double.
 
  -------------------------------------------------------------------------------------------------------------
 
  @created(24/02/2019)
  @author(J.Delauney (BeanzMaster))
  @bold(Historique) : @br
  @unorderedList(
    @item(Creation : 24/02/2019)
  )
 
  -------------------------------------------------------------------------------------------------------------
 
  @bold(Notes :)@br
 
  -------------------------------------------------------------------------------------------------------------
 
  @bold(Dependances) : BZSceneStrConsts, BZLogger si DEBUGLOG est activé @br
 
  -------------------------------------------------------------------------------------------------------------
 
   @bold(Credits :)@br
     @unorderedList(
       @item(J.Delauney (BeanzMaster))
     )
 
  -------------------------------------------------------------------------------------------------------------
 
  @bold(LICENCE) : MPL / LGPL @br
 
  ------------------------------------------------------------------------------------------------------------- *)
unit BZArrayClasses;
 
//==============================================================================
{$mode delphi}{$H+}
 
// Options de débogage pour que les logs soient fonctionnels, nous devons définir
// les options de compilations dans les unités des paquets. Car les options relatif à
// un projet ne sont pas propagé dans les unités d'un paquet.
{.$DEFINE DEBUG}
{.$DEFINE DEBUGLOG}
 
//==============================================================================
 
interface
 
uses
  Classes, SysUtils;
 
//==============================================================================
 
const
  { Granularité de croissance minimum d'un tableau }
  cDefaultListGrowthDelta = 16;
 
  { Lorsque la liste est plus petite que cInsertionSort_CutOff, nous utilisons InsertionSort au lieu d'appeler
   tout autre algorithme de tri, de manière récursive.
   8 et 64 semblent être les limites inférieures et supérieures où les performances se dégradent, donc
   quelque chose entre 16 et 48 donne probablement les meilleures performances
   D'après mes tests 42 est une bonne valeur médiane. }
  cInsertionSort_CutOff   = 42;
 
  { Lorsque la liste est plus petite que cQuickSort_CutOff, nous utilisons l'algorithme QuickSort au lieu de DualQuickSort }
  cQuickSort_CutOff       = 500;
 
type
  { Déclaration pour définir un tableau dynamique de single }
  TBZDynSingleArray = Array of Single;
  { Déclaration pour définir un tableau dynamique de single }
  TBZDynIntegerArray = Array of Integer;
  { Déclaration pour définir un tableau dynamique de single }
  TBZDynByteArray = Array of Byte;
 
  { Ordre de trie Ascendant ou descendant }
  TBZSortOrder = (soAscending, soDescending);
 
  { Classe de base générique pour gérer un tableau de n'importe quel type, tableau statique et pointeur.
****Fournis quelques fonctions utiles et communes  ajouter, supprimer, accès aux données.
    Prend également en charge l'accès en mode LIFO (Stack)  }
type TBZBaseList<T> = Class
  private
    FTagString : string;
    type
      PT = ^T;
      TArr = array of T;
    procedure SetCount(AValue : Int64);
 
  protected
    {$CODEALIGN RECORDMIN=16}
    FData: TArr;  //Le pointeur de liste de base (non typé)
    {$CODEALIGN RECORDMIN=4}
 
    FCapacity:Int64;
    FDataSize:Int64;
    FItemSize:Int64; // Doit être défini dans les sous-classes
    FGrowthDelta: Integer;
    FParentData: Pointer;
    FHandle: Int64;
 
    FRevision: LongWord;
    FCount: Int64;
 
    FPosition: Int64;
    FFirstDone: Boolean;
 
    Function GetData: Pointer; inline;
    Function GetDataArray: TArr; inline;
 
    function GetValue(const Position: Int64): T;
    procedure SetValue(const Position : Int64; const AValue : T);
 
    function GetMutable(const Position: Int64): PT;
    procedure IncreaseCapacity();
 
    procedure SetCapacity(const NewCapacity: Int64); virtual;
 
    function CompareValue(Const elem1, elem2: T) : Integer; virtual;
 
    procedure AnyQuickSort( idxL, idxH : Integer; Dir : TBZSortOrder); //CompareValue: TBZArraySortCompareValue); //var SwapBuf : pByte);
    procedure AnyInsertionSort(idxL, idxH : Integer; Dir : TBZSortOrder); //CompareValue: TBZArraySortCompareValue);
    procedure AnyDualPivotQuickSort(idxL, idxH : Integer; Dir : TBZSortOrder); // CompareValue : TBZArraySortCompareValue);
 
  public
    { Creation d'un nouveau tableau vide}
    constructor Create; overload;//override;
    { Creation d'un nouveau tableau de "Reserved" éléments }
    constructor Create(Reserved: Int64); overload;
    { Créer un nouveau tableau avec un nombre d'éléments Réservés et un propriétaire }
    constructor CreateParented(AParentData: Pointer; Reserved: Int64); overload;
    { Libère et détruit le tableau }
    destructor Destroy; override;
 
    { Renvoie la taille totale du tableau }
    function DataSize(): Int64; // size of the list
    { Renvoie la taille d'un élément }
    function ItemSize(): Longint;
 
    { Ajoute un nouvel élément }
    function Add(const Value: T):Int64;
    { Ajoute un nouvel élément si celui-ci n'es pas déja présent dans le tableau. Retourne -1 si l'élément n'est pas ajouté }
    function AddNoDup(const Value: T):Int64;
    { Insert un nouvel élément à la position "Position" }
    procedure Insert(Position: Int64; const Value: T);
    { Efface un  élément à la position "Position" }
    procedure Delete(Position : Int64);
    { Echange la posiotion des éléments "Index1" et "Index2" }
    procedure Exchange(index1, index2: Int64);
    { Inverse le tableau }
    procedure Reverse(); inline;
 
    //procedure AddNulls(nbVals: Cardinal); inline;
    //procedure InsertNulls(Position : Int64; nbVals: Cardinal); inline;
 
    { Vide la liste sans altérer la capacité. }
    procedure Flush();
    { Vide la liste et libère les éléments }
    procedure Clear();
    { Ajoute un nouvel élément en haut tableau }
    procedure Push(const Value: T);
    { Récupère l'élément en haut du tableau }
    function Pop: T;
    { Retourne le premier élément du tableau }
    function First: T;
    { Retourne le dernier élément du tableau }
    function Last(): T;
    { Renvoie l'élément suivant du tableau, relatif à la position actuelle }
    function Next(): T;
    { Renvoie l'élément précédent du tableau, relatif à la position actuelle }
    function Prev(): T;
    { Renvoie l'élément actuel du tableau, relatif à la position actuelle }
    function Current : T;
    { Déplacer la position actuelle dans le tableau à la prochaine }
    function MoveNext():Boolean;
    { Déplacer la position actuelle dans le tableau à la précédente }
    function MovePrev():Boolean;
    { Déplacer la position actuelle dans le tableau vers le premier élément }
    function MoveFirst():Boolean;
    { Déplacer la position actuelle dans le tableau vers le dernier élément }
    function MoveLast():Boolean;
    { Renvoie la position actuelle dans le tableau }
    function GetPosition() : Int64;
    { Se placer à la postion "Pos" en fonction de StartAt@br
      @param(Valeurs possible pour StartAt  :@br
      @unorderedlist(
        @item( 0 = Depuis le début (defaut) )
        @item( 1 = Depuis la position actuelle)
        @item( 2 = En partant de la fin)
      )}
    function Seek(const pos : Int64; const StartAt : Byte = 0) : boolean;
    { Se placer à n'importe quelle position dans le tableau (equivalent a seek(position, 0)}
    function MoveTo(const Position:Int64) : Boolean;
    { Vérifie si la fin du tableau est atteinte}
    function IsEndOfArray() : Boolean;
    { Retourne l'index de l'élément "SearchItem". Dans le cas ou celui n'existe pas retourne -1 }
    function IndexOf(const SearchItem : T): Integer;
    { Renvoie l'élélement suivant de l'élément "anItem", Si l'élément n'existe pas le premier élément du tableau est retourné }
    function GetNextFrom(const anItem : T) : T;
 
    // Array Rasterizer
    // function Scan(CallBack):Boolean;
    // function ScanNext(CallBack):Boolean;
    // function ScanPrev(CallBack):Boolean;
 
    // function ScanMany(nbItem,CallBack):Boolean;
    // function ScanTo(Position,CallBack):Boolean;
 
    // function ScanAll(CallBack):Boolean;
    // function ScanRange(From, To, CallBack):Boolean;
 
    // Array Utils
 
   // function CompareItems(Index1, index2, CompareValue): Integer; virtual;
 
    { Trie le tableaux par ordre croissant ou décroissant.
      L'algorithme de tri utilisé dépend du nombre d'éléments en fonction des constantes  cInsertion_CutOff et cQuickSort_CutOff. @br
      Si la liste à un nombre d'éléments inférieur à 42 le tri par insertion est utilisé. @br
      Si la liste à un nombre d'éléments inférieur ou égale à 500 le tri rapide "QuickSort" est utilisé. @br
      Si non, c'est le tri rapide à double pivot "DualPivotQuickSort" qui est utilisé. }
    procedure Sort(Const Direction : TBZSortOrder = soAscending);  virtual;
    { Trie le tableau avec l'algorithme de trie rapide "QuickSort" version "Stable" }
    procedure QuickSort(Const Direction : TBZSortOrder = soAscending); virtual;
    { Trie le tableau avec l'algorithme de trie rapide à double pivot version "Stable", c'est l'algorithme utilisé par défaut par la méthode Sort }
    procedure DualQuickSort(Const Direction : TBZSortOrder = soAscending); virtual;
    { Trie le tableau avec l'algorithme d'insertion }
    procedure InsertionSort(Const Direction : TBZSortOrder = soAscending); virtual;
 
    { Mélange les éléments du tableau aléatoirement. Il vous faudra appeler la méthode Randomize en premier }
    procedure Shuffle();
 
    // procedure Merge(AnotherArray: TBZBaseList<T>);
    // function Clone : TBZBaseList<T>;
    // function Extract(From, Nb : Int64): TBZBaseList<T>;
 
    // Extra funcs for management
    // function InsertItemsAt(Pos:Int64; AnArray : TBZBaseList<T>):Boolean;
    // function InsertItemsAtEnd
    // function InsertItemsAtFirst
    // procedure DeleteItems(Index: Int64r; nbVals: Cardinal); inline;
 
    { Nombre d'éléments dans la liste. Lors de l'attribution d'un nombre, les éléments ajoutés sont réinitialisés à zéro. }
    property Count: Int64 read FCount write SetCount;
    { Capacité du tableau actuel. Non persistant. }
    property Capacity: Int64 read FCapacity write SetCapacity;
    { Granularité de croissance. Pas persistant. }
    property GrowthDelta: Integer read FGrowthDelta write FGrowthDelta;
    { Augmenter de un après chaque changement de contenu. }
    property Revision: LongWord read FRevision write FRevision;
    { Renvoie le propriétaire s'il existe }
    property ParentData : Pointer read FParentData;
    { Renvoie le tableau sous forme de pointeur }
    property Data : Pointer read GetData;
    property DataArray : TArr read GetDataArray;
    { Renvoie le handle du tableau }
    property Handle : Int64 read FHandle;
 
    { Accès aux éléments du tableau }
    property Items[i : Int64]: T read getValue write SetValue;// default;
    { Accès à l'élément dans le tableau en tant que pointeur générique }
    property Mutable[i : Int64]: PT read getMutable;
    { Tag utilisateur }
    property TagString: string read FTagString write FTagString;
  end;
 
  {
  //generic TBZBaseListMap3D<T> = class(specialize TBZBaseList<T>)
  //private
  //  function GetValue3D(x, y, z : Int64): T;
  //  procedure SetValue3D(x, y, z : Int64; AValue: T);
  //published
  //public
  //  constructor Create(Rows, Cols, DCols : Int64); overload;
  //  constructor CreateParented(AParentData: Pointer; Rows, Cols, DCols: Int64); overload;
  //  property Items[x,y,z : Int64]: T read GetValue3D write SetValue3D;
  //end;
  //
  //generic TBZBaseListMap4D<T> = class(specialize TBZBaseList<T>)
  //private
  //  function GetValue4D(x, y, z, w : Int64): T;
  //  procedure SetValue4D(x, y, z, w : Int64; AValue: T);
  //published
  //public
  //  constructor Create(Rows, Cols, DCols, TCols: Int64); overload;
  //  constructor CreateParented(AParentData: Pointer; Rows, Cols, DCols, TCols: Int64); overload;
  //  property Items[x,y,z,w : Int64]: T read GetValue4D write SetValue4D;
  //end;
 
Type
  { Tableau générique de type Byte à une Dimension }
type TBZIntegerList = class(TBZBaseList<Integer>)
  private
  protected
    function CompareValue(Const elem1, elem2: integer) : Integer;  override;
  public
end;
type TBZDoubleList = class(TBZBaseList<double>)
  private
  protected
    function CompareValue(Const elem1, elem2: double) : Integer;  override;
  public
end;
implementation
 
//==============================================================================
 
{%region%=====[ TBZBaseList ]=================================================}
 
constructor TBZBaseList<T>.Create;
begin
  inherited Create;
  FCapacity:=0;
 // FItemSize:=Sizeof(T); // Must be defined in subclasses  ????
  FGrowthDelta:= cDefaultListGrowthDelta;
  FParentData:=nil;
  FHandle:=0;
  //FIsDirty:=false;
  FRevision:=0;
  FCount:=0;
  FPosition:=0;
  FFirstDone:=false;
end;
 
constructor TBZBaseList<T>.Create(Reserved : Int64);
begin
  Create;
  FDataSize:=Reserved;//*ItemSize;
  SetCapacity(Reserved);
  //SetCount(Reserved);
end;
 
constructor TBZBaseList<T>.CreateParented(AParentData : Pointer; Reserved : Int64);
begin
  Create(Reserved);
  FParentData := AParentData;
end;
 
destructor TBZBaseList<T>.Destroy;
begin
  {$IFDEF DEBUG}
    {$IFDEF DEBUGLOG}
      GlobalLogger.LogNotice('>>> TBZBaseList.Destroy');
    {$ENDIF}
  {$ENDIF}
  Clear;
  //SetLength(FData, 0);
  FData := nil;
  inherited Destroy;
end;
 
procedure TBZBaseList<T>.SetCount(AValue : Int64);
begin
  {$ifdef DEBUG}
    {$IFDEF DEBUGLOG}
      GlobalLogger.LogNotice('>>> TBZBaseList.SetCount');
      GlobalLogger.LogStatus('>>> AValue = ' + AValue.ToString);
    {$ENDIF}
    Assert(AValue >= 0);
  {$endif}
  if FCount = AValue then Exit;
  if AValue> FCapacity then SetCapacity(AValue);
  FCount := AValue;
  Inc(FRevision);
end;
 
Function TBZBaseList<T>.GetData : Pointer;
begin
  Result := @FData;
end;
 
Function TBZBaseList<T>.GetDataArray : TArr;
begin
  Result := FData;
end;
 
function TBZBaseList<T>.GetValue(const Position : Int64) : T;
begin
  Result := FData[Position];
end;
 
procedure TBZBaseList<T>.SetValue(const Position : Int64; const AValue : T);
begin
  if (Position >= FCapacity) then IncreaseCapacity;
  FData[Position] := AValue;
end;
 
function TBZBaseList<T>.GetMutable(const Position : Int64) : PT;
begin
  Result := @FData[Position];
end;
 
procedure TBZBaseList<T>.IncreaseCapacity();
begin
  if (FCapacity = 0) then SetCapacity(1)
  else
  begin
    if (FCount >= FCapacity) then SetCapacity(FCapacity + FGrowthDelta);
  end;
end;
 
procedure TBZBaseList<T>.SetCapacity(const NewCapacity : Int64);
begin
  if (FCapacity = newCapacity) then exit;
  FCapacity := newCapacity;
  SetLength(FData, FCapacity);
  Inc(FRevision);
end;
 
function TBZBaseList<T>.CompareValue(Const elem1, elem2: T) : Integer;
begin
  result := 0;
end;
 
function TBZBaseList<T>.DataSize() : Int64;
begin
  Result := FCount * ItemSize; //FDataSize;
end;
 
function TBZBaseList<T>.ItemSize() : Longint;
begin
  Result := Sizeof(T); //FItemSize;
end;
 
function TBZBaseList<T>.Add(const Value : T) : Int64;
begin
  Result := FCount;
  if (Result >= FCapacity) then self.IncreaseCapacity();
  FData[Result] := Value;
  Inc(FCount);
end;
 
function TBZBaseList<T>.AddNoDup(const Value : T) : Int64;
Var
  pos : Integer;
  isNew : Boolean;
begin
  Result := -1;
  pos := 0;
  isNew := True;
  while ((pos < FCount) and (isNew = true)) do
  begin
    if FData[pos] = Value then isNew := False;
    inc(pos);
  end;
  if IsNew then
  begin
    {$IFDEF DEBUG}
      {$IFDEF DEBUGLOG}
        GlobalLogger.LogHint('>>>> New value');
      {$ENDIF}
    {$ENDIF}
    Result := FCount;
    if (Result >= FCapacity) then IncreaseCapacity;
    FData[Result] := Value;
    Inc(FCount);
  end;
end;
 
procedure TBZBaseList<T>.Insert(Position : Int64; const Value : T);
begin
  if FCount = FCapacity then IncreaseCapacity;
  if Position < FCount then
    System.Move(FData[Position], FData[Position + 1], (FCount - Position) * ItemSize);
  FData[Position] := Value;
  Inc(FCount);
end;
 
procedure TBZBaseList<T>.Delete(Position : Int64);
begin
  if (Position < (FCount - 1)) then
  begin
    Dec(FCount);
    System.Move(FData[(Position + 1)], FData[Position], (FCount - Position) * ItemSize);
  end
  else Dec(FCount);
  Inc(FRevision);
end;
 
procedure TBZBaseList<T>.Exchange(index1, index2 : Int64);
var
  temp : T;
begin
  if Index1 = Index2 then Exit;
  temp := FData[index1];
  FData[index1] := FData[index2];
  FData[index2] := temp;
  Inc(FRevision);
end;
 
procedure TBZBaseList<T>.Reverse;
var
  s, e: Integer;
begin
  s := 0;
  e := FCount - 1;
  while s < e do
  begin
    Exchange(s, e);
    Inc(s);
    Dec(e);
  end;
  Inc(FRevision);
end;
 
//procedure TBZBaseList.AddNulls(nbVals : Cardinal);
//begin
//
//end;
//
//procedure TBZBaseList.InsertNulls(Position : Int64; nbVals : Cardinal);
//begin
//
//end;
 
procedure TBZBaseList<T>.Flush;
begin
  SetCount(0);
end;
 
procedure TBZBaseList<T>.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;
 
//procedure TBZBaseList.AdjustCapacityToAtLeast(const size: Integer);
//begin
//  if FCapacity < Size then SetCapacity(size);
//end;
 
procedure TBZBaseList<T>.Push(const Value : T);
begin
  self.Add(Value);
end;
 
function TBZBaseList<T>.Pop() : T;
begin
  Result := FData[FCount-1];
 Delete(FCount-1);
end;
 
function TBZBaseList<T>.First() : T;
begin
  Result := FData[0];
end;
 
function TBZBaseList<T>.Last() : T;
begin
  Result := Pop();
end;
 
function TBZBaseList<T>.Next() : T;
begin
  if (FPosition < FCount) then //Inc(FPosition);
    Result := FData[FPosition + 1]
  else Result := FData[FPosition];
end;
 
function TBZBaseList<T>.Prev() : T;
begin
  if (FPosition > 0) then  //Dec(FPosition);
   Result := FData[FPosition - 1]
  else Result := FData[FPosition];
end;
 
function TBZBaseList<T>.Current() : T;
begin
  Result := FData[FPosition];
end;
 
function TBZBaseList<T>.MoveNext() : Boolean;
begin
  Result := false;
  if (FPosition >= FCount-1) then exit;
  Result := True;
  Inc(FPosition);
end;
 
function TBZBaseList<T>.MovePrev() : Boolean;
begin
  Result := false;
  if (FPosition <= 0 ) then exit;
  Result := True;
  Dec(FPosition);
end;
 
function TBZBaseList<T>.MoveFirst() : Boolean;
begin
  result := true;
  FPosition := 0;
end;
 
function TBZBaseList<T>.MoveLast() : Boolean;
begin
  result := true;
  FPosition := FCount-1;
end;
 
function TBZBaseList<T>.GetPosition() : Int64;
begin
  Result := FPosition;
end;
 
function TBZBaseList<T>.Seek(const pos : Int64; const StartAt : Byte=0) : boolean;
var
  newpos : Int64;
begin
  result := true;
  Case StartAt of
    0: newpos := Pos; // From Beginning
    1:
    begin
      newpos := (FPosition-1) + Pos; // From Current positon
      if newpos >= FCount then
      begin
        //newpos := FCount-1;
        result := false;
      end;
    end;
    2:
    begin
      newpos := (FCount-1) - Pos; // From End;
      if newpos=0 then
      begin
        //newpos := 0;
        result := false;
      end;
    end;
    else newpos := pos;
  end;
  if result then FPosition := newpos;
end;
 
function TBZBaseList<T>.MoveTo(const Position:Int64) : Boolean;
begin
 
  result:= Self.Seek(Position, 0);
end;
 
function TBZBaseList<T>.IsEndOfArray() : Boolean;
begin
  result := (FPosition >= FCount);
end;
 
function TBZBaseList<T>.IndexOf(const SearchItem : T) : Integer;
var
  i: Integer;
begin
  if FCount <= 0 then Result := -1
  else
  begin
    Result := -1;
    for i  := 0 to FCount - 1 do
      if FData[i] = SearchItem then
      begin
        Result := i;
        Exit;
      end;
  end;
end;
 
function TBZBaseList<T>.GetNextFrom(const anItem : T) : T;
begin
  if FCount <= 0 then exit;
  Result := FData[((Self.indexOf(anItem) + 1) mod Self.Count)];
end;
 
{ Le "Dual Pivot QuickSort" est plus légèrement plus rapide que le QuickSort classique (dans la majorité des cas).
Sur la papier, le DualPivotQuickSort à 1.9nlnn+O(n) comparaisons, ce qui est 5% de moins que les comparaisons 2nlnn+O(n)  de l'algorithme Quicksort classique à pivot unique.
Cependant, il a besoin de 0.6nlnn+O(n) échanges de valeurs alors qu'avec le Quicksort classique il en faut 1/3nlnn+O(n).
Il existe une version en Java optimisée de cet algorithmequi donne de meilleurs résultats, mais celle-ci est complexe à mettre en place
cf : http://hg.openjdk.java.net/jdk8/jdk8/jdk/file/tip/src/share/classes/java/util/DualPivotQuicksort.java }
procedure TBZBaseList<T>.AnyDualPivotQuickSort(idxL, idxH : Integer; Dir : TBZSortOrder);
var
  idx, lpi, rpi : Integer;
  nb, li, hi  : Integer;
  SwapTemp, p, q, ak : T;
 
begin
 
  if (idxH <= idxL) then Exit;
  nb := idxH - idxL;
 
  if nb < cInsertionSort_CutOff then
  begin
    AnyInsertionSort(idxL, idxH, Dir);
    Exit;
  end;
  //else if nb <= cQuickSort_CutOff then
  //begin
  //  AnyQuickSort(idxL, idxH, Dir);
  //  Exit;
  //end;
 
  li := idxL;
  hi := idxH;
 
  // Debut de la partition
  if Dir = soAscending then
  begin
    if (CompareValue(FData[hi], FData[li]) < 0) then
    begin
      SwapTemp := FData[li];
      FData[li] := FData[hi];
      FData[hi] := SwapTemp;
    end;
  end
  else
  begin
    if (CompareValue(FData[hi], FData[li]) > 0) then
    begin
      SwapTemp := FData[li];
      FData[li] := FData[hi];
      FData[hi] := SwapTemp;
    end;
  end;
 
  p := FData[li];
  q := FData[hi];
 
  lpi := li + 1;
  rpi := hi - 1;
  idx := lpi;
 
  if Dir = soAscending then
  begin
    While (idx <= rpi) do
    begin
      ak := FData[idx];
      if (CompareValue(ak, p) < 0) then
      begin
        FData[idx] := FData[lpi];
        FData[lpi] := ak;
        inc(lpi);
      end
      else if (CompareValue(ak, q) >= 0) then
      begin
        While ((CompareValue(FData[rpi], q) > 0) and (idx < rpi)) do Dec(rpi);
        FData[idx] := FData[rpi];
        FData[rpi] := ak;
        dec(rpi);
        if (CompareValue(ak, p) < 0) then
        begin
          FData[idx] := FData[lpi];
          FData[lpi] := ak;
          inc(lpi);
        end;
      end;
      inc(idx);
    end;
  end
  else
  begin
    While (idx <= rpi) do
    begin
      ak := FData[idx];
      if (CompareValue(ak, p) > 0) then
      begin
        FData[idx] := FData[lpi];
        FData[lpi] := ak;
        inc(lpi);
      end
      else if (CompareValue(ak, q) <= 0) then
      begin
        While ((CompareValue(FData[rpi], q) < 0) and (idx < rpi)) do Dec(rpi);
        FData[idx] := FData[rpi];
        FData[rpi] := ak;
        dec(rpi);
        if (CompareValue(ak, p) > 0) then
        begin
          FData[idx] := FData[lpi];
          FData[lpi] := ak;
          inc(lpi);
        end;
      end;
      inc(idx);
    end;
  end;
 
  Dec(lpi);
  Inc(rpi);
 
  SwapTemp := FData[lpi];
  FData[lpi] := FData[li];
  FData[li] := SwapTemp;
 
  SwapTemp := FData[rpi];
  FData[rpi] := FData[hi];
  FData[hi] := SwapTemp;
  // Fin de la partition
 
  AnyDualPivotQuickSort(li,lpi - 1, Dir);
  if DIr = soAscending then
  begin
    if (CompareValue(FData[lpi], FData[rpi]) < 0) then AnyDualPivotQuickSort(lpi + 1, rpi - 1, Dir);
  end
  else
  begin
    if (CompareValue(FData[lpi], FData[rpi]) > 0) then AnyDualPivotQuickSort(lpi + 1, rpi - 1, Dir);
  end;
  AnyDualPivotQuickSort(rpi + 1, hi, Dir);
end;
 
procedure TBZBaseList<T>.AnyQuickSort(idxL, idxH : Integer; Dir : TBZSortOrder);
var
  li, hi : Integer;
  TP : Integer;
  mi    : Integer;
  SwapBuf : T;
begin
  if (idxL >= idxH) then exit;
  if (idxH - idxL) < cInsertionSort_CutOff then
  begin
    AnyInsertionSort(IdxL, idxH, Dir);//, CompareValue);
    Exit;
  end;
 
  if idxL<>0 then mi := (idxL + idxH) div 2
  else mi := (((idxL+1) + idxH) div 2) - 1;
  li := idxL;
  hi := idxH;
 
  SwapBuf := FData[li];
  FData[li] := FData[mi];
  FData[mi] := SwapBuf;
 
  TP := idxL;
  inc(li);
 
 
  if dir = soAscending then
  begin
    repeat
      if (CompareValue( FData[li], FData[idxL] ) < 0) then
      begin
        inc(TP);
        SwapBuf := FData[TP];
        FData[TP] := FData[li];
        FData[li] := SwapBuf;
      end;
      inc(li);
    until li>hi;
  end
  else
  begin
    repeat
      if (CompareValue( FData[li], FData[idxL] ) > 0) then
      begin
        inc(TP);
        SwapBuf := FData[TP];
        FData[TP] := FData[li];
        FData[li] := SwapBuf;
      end;
      inc(li);
    until li>hi;
  end;
 
  SwapBuf := FData[idxL];
  FData[idxL] := FData[TP];
  FData[TP] := SwapBuf;
 
  AnyQuickSort(idxL, TP-1, Dir);//, CompareValue);
  AnyQuickSort(TP+1, idxH, Dir);//, CompareValue);
end;
 
procedure TBZBaseList<T>.AnyInsertionSort(idxL, idxH : Integer; Dir : TBZSortOrder);
var
  ps, cs : Integer;
  li,hi : Integer;
  SwapBuf : T;
begin
 
  if FCount<2 then exit;
 
  if FCount = 2 then
  begin
    if (CompareValue(FData[1], FData[0]) < 0) then
    begin
      If Dir = soAscending then
      begin
        SwapBuf := FData[0];
        FData[0] := FData[1];
        FData[1] := SwapBuf;
        Exit;
      end
      else
      begin
        Exit;
      end;
    end;
  end;
 
  li :=idxL + 1;
  hi :=idxH;
 
  Repeat
   SwapBuf := FData[li]; //Move(pb[ls], SwapBuf^, Stride);
   ps := li;
   cs := ps - 1;
   If Dir = soAscending then
   begin
     While (ps >= 1) and  (CompareValue(SwapBuf, FData[cs]) < 0) do
     begin
       FData[ps] := FData[cs];
       dec(ps);
       dec(cs);
     end;
   end
   else
   begin
     While (ps >= 1) and  (CompareValue(SwapBuf, FData[cs]) > 0) do
     begin
       FData[ps] := FData[cs];
       dec(ps);
       dec(cs);
     end;
   end;
   FData[ps] := SwapBuf;
   inc(li);
  until li > hi;
 
end;
 
 
 
procedure TBZBaseList<T>.Sort(Const Direction : TBZSortOrder);
begin
  if FCount<2 then exit;
  if FCount < cInsertionSort_CutOff then AnyInsertionSort(0, FCount-1, Direction)
  else if FCount <= cQuickSort_CutOff then AnyQuickSort(0, FCount-1, Direction)
  else AnyDualPivotQuickSort(0, FCount-1, Direction);
end;
 
procedure TBZBaseList<T>.QuickSort(Const Direction : TBZSortOrder);
begin
  if FCount<2 then exit;
  AnyQuickSort(0, FCount-1, Direction);
end;
 
procedure TBZBaseList<T>.DualQuickSort(Const Direction : TBZSortOrder);
begin
  if FCount<2 then exit;
  AnyDualPivotQuickSort(0, FCount-1, Direction);
end;
 
procedure TBZBaseList<T>.InsertionSort(Const Direction : TBZSortOrder);
begin
  AnyInsertionSort(0, FCount-1, Direction);
end;
 
procedure TBZBaseList<T>.Shuffle();
Var
 SwapBuffer : T;
 I, K, RandIdx : Integer;
begin
  K := FCount - 1;
  for i := 1 to  K do
  begin
    RandIdx := random(K - I + 1) + I; // Distribution uniforme
    SwapBuffer := FData[RandIdx];
    FData[RandIdx] := FData[I];
    FData[I] := SwapBuffer;
  end;
end;
{%region%=====[ TBZDoubleList ]================================================}
 
function TBZIntegerList.CompareValue(Const elem1, elem2: integer) : Integer;
begin
  if      elem1 = elem2 then Result :=  0
  else if elem1 < elem2 then Result := -1
  else Result := 1;
end;
 
{%endregion%}
 
{%region%=====[ TBZSingleList ]================================================}
 
function TBZDoubleList.CompareValue(Const elem1, elem2: double) : Integer;
begin
  if      elem1 = elem2 then Result :=  0
  else if elem1 < elem2 then Result := -1
  else Result := 1;
end;
 
//==============================================================================
end.

**BeanzMaster** · 15/09/2020, 12h29

Envoyé par JP CASSOU

Bjr à tous,

J'ai choisi d'adapter les unités de graphes de BZ dans mon projet

Je rencontre une erreur pénible +++++ ici:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
bzgraphesclasses.pas(490,17) Error: Incompatible types: got "TClass" expected "TBZClassNode"

Ton erreur est ici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TBZGraphNode = class(TBZBaseList<TClass>)

Le Graph est une liste de Noeuds (Node) et non de "class" donc:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TBZGraphNode = class(TBZBaseList<TNode>)

Sinon voici qui va te faire gagner un peu de temps

Nom : 2020-09-15_121908.jpeg
Affichages : 182
Taille : 293,7 Ko

ps : fais gaffe avec {$mode Delphi} c'est la m... des fois, surtout avec des références sur des pointeurs

A+

Jérôme

**jurassic pork** · 15/09/2020, 13h41

J'ai testé ton nouveau projet Jérôme : Very Good job

Le seul souci que j'ai vu pour l'instant c'est quand on sélectionne une station les infos arc entrant et sortant n'on pas l'air bonnes.

Ami calmant, J.P

**jurassic pork** · 15/09/2020, 14h20

J'ai testé ton nouveau projet Jérôme : Very Good job

Le seul souci que j'ai vu pour l'instant c'est quand on sélectionne une station les infos arc entrant et sortant n'on pas l'air bonnes.

EDIT : correction possible :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 procedure ShowNodeInfo;  Var
    LArcsIn, LArcsOut : TBZIntegerList;
    aNode : TNode;
    i, arc : Integer;
  begin
    if (FCurrentSelectedNodeIndex =  -1)  or (FSelectedNode = nil) then exit;
    mmoInfos.Clear;
    mmoInfos.Lines.Add('Ligne         = ' + FSelectedNode.LineNUm.ToString);
    mmoInfos.Lines.Add('Station       = ' + FSelectedNode.StationNUm.ToString);
    mmoInfos.Lines.Add('ID Station    = ' + FSelectedNode.IDStation.ToString);
    if FSelectedNode.Visited then
      mmoInfos.Lines.Add('Visité        = ' + 'OUI')
    else
      mmoInfos.Lines.Add('Visité        = ' + 'NON');
    mmoInfos.Lines.Add('================================');
    LArcsIn := FSelectedNode.ArcsIn;
    mmoInfos.Lines.Add(' Arcs entrant : ');
    if (LArcsIn <> nil) then
    begin
      for i := 0 to (LArcsIn.Count - 1) do
      begin
        arc := LarcsIn.Items[i];
        mmoInfos.Lines.Add('---> Arc entrant : ' + arc.ToString);
        aNode := FGraphNode.Items[arc];
        mmoInfos.Lines.Add('     - Ligne      = ' + aNode.LineNUm.ToString);
        mmoInfos.Lines.Add('     - Station    = ' + aNode.StationNUm.ToString);
        mmoInfos.Lines.Add('     - ID Station = ' + aNode.IDStation.ToString);
        mmoInfos.Lines.Add('     - Distance   = ' + FSelectedNode.getDistanceTo(aNode).ToString);
        if aNode.Visited then
          mmoInfos.Lines.Add('     - Visité     = ' + 'OUI')
        else
          mmoInfos.Lines.Add('     - Visité     = ' + 'NON');
        mmoInfos.Lines.Add('--------------------------------');
        FreeAndNil(LArcsIn);
      end;
    end
    else
    begin
      mmoInfos.Lines.Add('---> Aucun arc entrant trouvé');
    end;
    mmoInfos.Lines.Add('================================');
    LArcsOut := FSelectedNode.ArcsOut;
    mmoInfos.Lines.Add(' Arcs sortant : ');
    if (LArcsOut <> nil) then
    begin
      for i := 0 to (LArcsOut.Count - 1) do
      begin
        arc := LarcSOut.Items[i];
        mmoInfos.Lines.Add('---> Arc sortant : ' + arc.ToString);
        aNode := FGraphNode.Items[arc];
        mmoInfos.Lines.Add('    - Ligne      = ' + aNode.LineNUm.ToString);
        mmoInfos.Lines.Add('    - Station    = ' + aNode.StationNUm.ToString);
        mmoInfos.Lines.Add('    - ID Station = ' + aNode.IDStation.ToString);
        mmoInfos.Lines.Add('    - Distance   = ' + FSelectedNode.getDistanceTo(aNode).ToString);
        if aNode.Visited then
          mmoInfos.Lines.Add('    - Visité     = ' + 'OUI')
        else
          mmoInfos.Lines.Add('    - Visité     = ' + 'NON');
        mmoInfos.Lines.Add('--------------------------------');
      end;
      FreeAndNil(LArcsOut);
    end
    else
    begin
      mmoInfos.Lines.Add('---> Aucun arc sortant trouvé');
    end;
  end;

Ami calmant, J.P

Algorithme de Dijkstra pour recherche de plus court chemin dans un graphe [Lazarus]

Lazarus Pascal

Discussions similaires

Partager

Partager