Bonjour,
Je suis en train de développer la nouvelle version de CiDess, en VB5 (le logiciel fête les 10 ans de sa sortie cette année). CiDess sert à dessiner des circuits imprimés, il est gratuit. (http://cidess.free.fr/index-fr.html)
Comme nouvelle fonctionnalité, il y aura le perçage du circuit imprimé avec fraiseuse à commande numérique. Une option permet d’optimiser la longueur des trajets de l'usinage ; pour ce faire, j’ai recours aux algorithmes génétiques pour résoudre ce qui n’est rien d’autre qu'une version du très célèbre problème du voyageur de commerce.
Je suis arrivé à mes fins, et ça fonctionne bien.
J’ai voulu optimiser la rapidité de mon code et je suis tombé sur une surprise.
Le code de départ avait recours à des objets et des collections ; le voici :
Je pensais que ce code serai plus rapide si je faisais les calculs en ayant recours à des tableaux. Voici donc une deuxième version :
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 Private Sub OptimiserOrdrePercages_Genetique1(out As OutilCNC) 'AVEC DES OBJETS Dim per As PercageCNC Dim MaxLong As Double Dim MinLong As Double Dim MinLongPrec As Double Dim MinLongConstantDepuis As Integer Dim ListeParcours As Collection Dim ListeParcours2 As Collection Dim TmpListe As Collection Dim p As ParcoursCNC Dim p1 As ParcoursCNC Dim p2 As ParcoursCNC Dim Debut As Single Dim NbPercages As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim m As Integer Dim c As Integer Dim ChiffreOK As Boolean Dim XP As Double, YP As Double Dim Stagnation As Boolean Dim NbGenerations As Long Dim Duree As Single 'Paramètres de l'algorithme : NbPercages = out.ListePercages.count Debut = Timer out.LongAvantOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongAvantOptim = out.LongAvantOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i 'Création de la première génération : Set ListeParcours = New Collection 'La liste originale : Set p = New ParcoursCNC Call p.Nouveau(NbPercages) For j = 1 To NbPercages Call p.EcrireTableau(j, j) Next j ListeParcours.Add p 'Les listes aléatoires : Set TmpListe = New Collection For i = 2 To ParOpti_NbIndividus Set p = New ParcoursCNC Call p.Nouveau(NbPercages) Set TmpListe = New Collection For j = 1 To NbPercages TmpListe.Add j Next j Randomize For j = 1 To NbPercages 'Int((upperbound - lowerbound + 1) * Rnd + lowerbound) k = Int(TmpListe.count * Rnd + 1) Call p.EcrireTableau(j, TmpListe.Item(k)) Call TmpListe.Remove(k) Next j ListeParcours.Add p Next i 'Calcul du critère de la 1ière génération : For i = 1 To ParOpti_NbIndividus Set p = ListeParcours.Item(i) p.Lg = 0 Set per = out.ListePercages.Item(p.LireTableau(1)) XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages Set per = out.ListePercages.Item(p.LireTableau(j)) 'Optimisation : la fonction Sqr est couteuse en temps de calcul et n'est pas nécessaire pour faire une comparaison : 'p.Lg = p.Lg + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) 'p.Lg = p.Lg + (XP - per.Xmachine) ^ 2 + (YP - per.Ymachine) * (YP - per.Ymachine) ^ 2 p.Lg = p.Lg + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) XP = per.Xmachine YP = per.Ymachine Next j Next i MinLongPrec = p.Lg MinLongConstantDepuis = 0 out.DebugInfo = "" 'Mesure de la performance : NbGenerations = 1 Do '-------------------------------------------------------------------------------------------------------------------------------------- Randomize 'Mesure de la performance : NbGenerations = NbGenerations + 1 'REPRODUCTION : For i = 1 To ParOpti_NbReproductions 'On choisi aléatoirement deux parents : k = Int(ParOpti_NbIndividus * Rnd + 1) m = Int(ParOpti_NbIndividus * Rnd + 1) 'Reproduction : If k <> m Then Set p1 = ListeParcours.Item(k) Set p2 = ListeParcours.Item(m) 'Choix aléatoire du point de croisement : 'k=1 => 1.23456789 'm=8 => 12345678.9 c = Int((NbPercages - 1) * Rnd + 1) 'Croisement : Set p = New ParcoursCNC Call p.Nouveau(NbPercages) For j = 1 To c Call p.EcrireTableau(j, p1.LireTableau(j)) Next j 'Pour p.tableau(c+1...NbPercages) il faut prendre les chiffres de p2.Tableau() dans l'ordre, 'à condition que ces chiffres ne soient pas déjà dans p.Tableau(1...k) j = 0 m = c Do j = j + 1 ChiffreOK = True For k = 1 To c If p.LireTableau(k) = p2.LireTableau(j) Then ChiffreOK = False Next k If ChiffreOK Then m = m + 1 Call p.EcrireTableau(m, p2.LireTableau(j)) End If Loop Until m = NbPercages Or j = NbPercages ListeParcours.Add p End If Next i 'MUTATION : For i = 1 To ParOpti_NbMutations 'Choix aléatoire des points de mutation : k = Int(NbPercages * Rnd + 1) c = Int(NbPercages * Rnd + 1) If c <> k Then 'Choix aléatoire de l'individu muté : m = Int(ParOpti_NbIndividus * Rnd + 1) Set p1 = ListeParcours.Item(m) Set p = New ParcoursCNC Call p.Nouveau(NbPercages) For j = 1 To NbPercages If j = c Then Call p.EcrireTableau(j, p1.LireTableau(k)) ElseIf j = k Then Call p.EcrireTableau(j, p1.LireTableau(c)) Else Call p.EcrireTableau(j, p1.LireTableau(j)) End If Next j ListeParcours.Add p End If Next i 'CALCUL DU CRITERE POUR TOUS LES INDIVIDUS : 'Optimisation : pas besoin de calculer à nouveau le critère pour les membres de la génération précédente : 'For Each p In ListeParcours 'ListeParcours.Count = ParOpti_NbIndividus + Nombre de reproductions + ParOpti_NbMutations > ParOpti_NbIndividus For i = ParOpti_NbIndividus + 1 To ListeParcours.count Set p = ListeParcours.Item(i) p.Lg = 0 Set per = out.ListePercages.Item(p.LireTableau(1)) XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages Set per = out.ListePercages.Item(p.LireTableau(j)) 'Optimisation : la fonction Sqr est couteuse en temps de calcul et n'est pas nécessaire pour faire une comparaison : 'p.Lg = p.Lg + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) 'p.Lg = p.Lg + (XP - per.Xmachine) ^ 2 + (YP - per.Ymachine) * (YP - per.Ymachine) ^ 2 p.Lg = p.Lg + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) XP = per.Xmachine YP = per.Ymachine Next j Next i 'Next p 'SELECTION : 'On supprime le parcours le plus long jusqu'à ce qu'il n'en reste que ParOpti_NbIndividus dans la liste : Do If ListeParcours.count <= ParOpti_NbIndividus Then Exit Do For j = 1 To ListeParcours.count Set p = ListeParcours.Item(j) If j = 1 Then MaxLong = p.Lg k = j Else If p.Lg > MaxLong Then MaxLong = p.Lg k = j End If End If Next j ListeParcours.Remove k Loop 'On détermine si on stagne ou pas : Stagnation = True 'For Each p In ListeParcours For j = 1 To ListeParcours.count Set p = ListeParcours.Item(j) If p.Lg < MinLongPrec Then Stagnation = False MinLongPrec = p.Lg End If Next j 'Next p If Stagnation Then MinLongConstantDepuis = MinLongConstantDepuis + 1 If MinLongConstantDepuis > ParOpti_MaxMinLongConstatDepuis Then Exit Do Else MinLongConstantDepuis = 0 End If If Timer - Debut > ParOpti_DureeMax Then Exit Do Loop '-------------------------------------------------------------------------------------------------------------------------------------- 'out.DebugInfo = out.DebugInfo + ";Temps de calcul : " + Format(Timer - Debut) + " secondes" 'Mesure de la performance : Duree = Timer - Debut 'out.DebugInfo = " Temps de calcul " + Format(Duree) + " secondes - Calcul de " + Format(NbGenerations / Duree, "0.0") + " générations par seconde." out.DebugInfo = "Durée " + Format(Duree, "0.000") + "s - " + Format(NbGenerations) + " générations - " + Format(NbGenerations / Duree, "0.0") + " générations par seconde." 'On sélectionne le parcours le plus court : 'Set p = ListeParcours.Item(K) For j = 1 To ListeParcours.count Set p = ListeParcours.Item(j) If j = 1 Then MinLong = p.Lg k = j Else If p.Lg < MinLong Then MinLong = p.Lg k = j End If End If Next j Set p = ListeParcours.Item(k) 'Contrôle de sécurité : ChiffreOK = True For i = 1 To out.ListePercages.count - 1 k = p.LireTableau(i) If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False For j = i + 1 To out.ListePercages.count m = p.LireTableau(j) If k = m Then ChiffreOK = False Next j Next i k = p.LireTableau(out.ListePercages.count) If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False 'Affectation : If ChiffreOK Then 'Affectation : Set TmpListe = New Collection For j = 1 To NbPercages Set per = out.ListePercages.Item(p.LireTableau(j)) TmpListe.Add per Next j Set out.ListePercages = TmpListe 'out.LongApresOptim = MinLong out.LongApresOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongApresOptim = out.LongApresOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i Else MsgBox "Contrôle de sécurité échoué" out.LongApresOptim = -1 End If End Sub Class ParcoursCNC Private Tabl() As Integer Public Lg As Double Public Sub Nouveau(NombreIndex As Integer) ReDim Tabl(1 To NombreIndex) End Sub Public Function LireTableau(i As Integer) As Integer LireTableau = Tabl(i) End Function Public Sub EcrireTableau(i As Integer, Valeur As Integer) Tabl(i) = Valeur End Sub End Class
Mais cette deuxième version est à ma grande surprise plus lente. Elle est deux à trois fois plus lente que la version avec les objets.
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 Private Sub OptimiserOrdrePercages_Genetique2(out) 'AVEC UN TABLEAU A DEUX DIMENSIONS Dim per As PercageCNC Dim MaxLong As Double Dim MinLong As Double Dim MinLongPrec As Double Dim MinLongConstantDepuis As Integer Dim TmpListe As Collection Dim Debut As Single Dim NbPercages As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim m As Integer Dim c As Integer Dim p1 As Integer Dim p2 As Integer Dim p As Integer Dim ChiffreOK As Boolean Dim XP As Double, YP As Double Dim Stagnation As Boolean Dim premier As Boolean Dim TaillePopulation As Integer Dim NbGenerations As Long Dim Duree As Single NbPercages = out.ListePercages.count TaillePopulation = ParOpti_NbIndividus + ParOpti_NbReproductions + ParOpti_NbMutations ReDim Matrice(NbPercages + 1, TaillePopulation + 1) As Integer ReDim Lg(TaillePopulation + 1) As Double ReDim Pointeur(TaillePopulation + 1) As Integer ReDim ColonneOK(TaillePopulation + 1) As Integer 'Pointeur(1...NbIndividus) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux parents 'Pointeur(NbIndividus+1...NbIndividus+ParOpti_NbReproductions) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux enfants 'Pointeur(NbIndividus+ParOpti_NbReproductions+1...NbIndividus+ParOpti_NbReproductions+ParOptiMutants) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux mutants 'Lg(i) contient la longeur du parcours de la colonne i (Matrice(.,i)) Debut = Timer out.LongAvantOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongAvantOptim = out.LongAvantOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i 'Création de la première génération : For i = 1 To TaillePopulation Pointeur(i) = i Next i 'La liste originale : For j = 1 To NbPercages Matrice(j, 1) = j Next j 'Les listes aléatoires : Set TmpListe = New Collection For i = 2 To ParOpti_NbIndividus For j = 1 To NbPercages TmpListe.Add j Next j Randomize For j = 1 To NbPercages 'Int((upperbound - lowerbound + 1) * Rnd + lowerbound) k = Int(TmpListe.count * Rnd + 1) Matrice(j, i) = TmpListe.Item(k) Call TmpListe.Remove(k) Next j Next i 'Calcul du critère de la 1ière génération : For i = 1 To ParOpti_NbIndividus Set per = out.ListePercages.Item(Matrice(1, i)) '1ier perçage de l'individu i XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages Set per = out.ListePercages.Item(Matrice(j, i)) 'Perçage j de l'individu i Lg(i) = Lg(i) + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) 'Longueur de l'individu i XP = per.Xmachine YP = per.Ymachine Next j Next i MinLongPrec = Lg(1) MinLongConstantDepuis = 0 out.DebugInfo = "" 'Mesure de la performance : NbGenerations = 1 Do '-------------------------------------------------------------------------------------------------------------------------------------- Randomize 'Mesure de la performance : NbGenerations = NbGenerations + 1 'REPRODUCTION : For i = 1 To ParOpti_NbReproductions p = Pointeur(i + ParOpti_NbIndividus) 'p = pointeur de l'enfant n°i, stocké dans Pointeur(ParOpti_NbIndividus+1...ParOpti_NbIndividus+1+ParOptiNbReproductions) ' 'On choisi aléatoirement deux parents : k = Int(ParOpti_NbIndividus * Rnd + 1) Do m = Int(ParOpti_NbIndividus * Rnd + 1) Loop Until k <> m 'On cherche les colonnes p1 et p2 correspondant aux parents k et m p1 = Pointeur(k) p2 = Pointeur(m) 'Choix aléatoire du point de croisement : 'k=1 => 1.23456789 'm=8 => 12345678.9 c = Int((NbPercages - 1) * Rnd + 1) 'Croisement : For j = 1 To c Matrice(j, p) = Matrice(j, p1) 'Le percage j de l'enfant = le percage j du parent 1 Next j 'Génome du parent 2 dans l'enfant : j = 0 m = c Do j = j + 1 ChiffreOK = True 'On doit choisir les perçages du parent 2 dans l'ordre, en 'sautant' les percages déjà présents dans l'enfant : For k = 1 To c If Matrice(k, p) = Matrice(j, p2) Then ChiffreOK = False Next k If ChiffreOK Then m = m + 1 Matrice(m, p) = Matrice(j, p2) End If Loop Until m = NbPercages Or j = NbPercages Next i 'MUTATION : For i = 1 To ParOpti_NbMutations p = Pointeur(i + ParOpti_NbIndividus + ParOpti_NbReproductions) 'p = pointeur du mutant n°i, stocké dans Pointeur(ParOpti_NbIndividus+ParOpti_NbReproductions+1...TaillePopulation) ' 'Choix aléatoire des deux perçages qui seront échangés : k = Int(NbPercages * Rnd + 1) Do c = Int(NbPercages * Rnd + 1) Loop Until k <> c ' 'Choix aléatoire du parent dont le clone sera muté : m = Int(ParOpti_NbIndividus * Rnd + 1) p1 = Pointeur(m) ' For j = 1 To NbPercages If j = c Then Matrice(j, p) = Matrice(k, p1) ElseIf j = k Then Matrice(j, p) = Matrice(c, p1) Else Matrice(j, p) = Matrice(j, p1) End If Next j Next i 'CALCUL DU CRITERE POUR TOUS LES INDIVIDUS : 'Optimisation : pas besoin de calculer à nouveau le critère pour les membres de la génération précédente : 'For Each p In ListeParcours 'ListeParcours.Count = ParOpti_NbIndividus + Nombre de reproductions + ParOpti_NbMutations > ParOpti_NbIndividus For i = ParOpti_NbIndividus + 1 To TaillePopulation p = Pointeur(i) 'p est le n° de la colonne de Matrice(,) et le numéro de Lg() Lg(p) = 0 Set per = out.ListePercages.Item(Matrice(1, p)) XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages Set per = out.ListePercages.Item(Matrice(j, p)) 'Optimisation : la fonction Sqr est couteuse en temps de calcul et p'est pas nécessaire pour faire une comparaison : 'p.Lg = p.Lg + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) 'p.Lg = p.Lg + (XP - per.Xmachine) ^ 2 + (YP - per.Ymachine) * (YP - per.Ymachine) ^ 2 Lg(p) = Lg(p) + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) XP = per.Xmachine YP = per.Ymachine Next j Next i 'Next p 'SELECTION : 'Ici on doit réaffecter les pointeurs 'Plus un parcours (une colonne de Matrice()) a une longeur élevé (mauvais critère), plus son pointeur est long : For i = 1 To TaillePopulation ColonneOK(i) = 0 Next i ' For p = 1 To ParOpti_NbIndividus 'Les pointeurs Pointeur(1...NbIndividus) correspondront aux meilleurs individus, c'est à dire aux NbIndividus colonnes les meilleures premier = True For j = 1 To TaillePopulation 'Pour chaque colonne 'i' If ColonneOK(j) = 0 Then 'Les colonnes qui n'ont pas encore un pointeur pointant sur elles If premier Then premier = False MinLong = Lg(j) k = j Else If Lg(j) < MinLong Then MinLong = Lg(j) k = j End If End If End If Next j 'Ici, K contient le n° de la colonne la plus courte parmis celles restant à trier Pointeur(p) = k ColonneOK(k) = 1 Next p 'Il faut tout de même renuméroter les colonnes 'mauvaises' car elles seront utilsées pour les enfants et les mutants de la génération suivante : p = ParOpti_NbIndividus For j = 1 To TaillePopulation If ColonneOK(j) = 0 Then 'Colonne n'ayant aucun pointeur pointant sur elle p = p + 1 Pointeur(p) = j 'ColonneOK(j) = 1 superflux End If Next j 'Pointeur(1...NbIndividus) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux parents 'Pointeur(NbIndividus+1...NbIndividus+ParOpti_NbReproductions) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux enfants 'Pointeur(NbIndividus+ParOpti_NbReproductions+1...NbIndividus+ParOpti_NbReproductions+ParOptiMutants) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux mutants 'Lg(i) contient la longeur du parcours de la colonne i (Matrice(.,i)) 'On détermine si on stagne ou pas : Stagnation = True For j = 1 To ParOpti_NbIndividus p = Pointeur(j) ' If Lg(p) < MinLongPrec Then Stagnation = False MinLongPrec = Lg(p) End If Next j If Stagnation Then MinLongConstantDepuis = MinLongConstantDepuis + 1 If MinLongConstantDepuis > ParOpti_MaxMinLongConstatDepuis Then Exit Do Else MinLongConstantDepuis = 0 End If If Timer - Debut > ParOpti_DureeMax Then Exit Do Loop '-------------------------------------------------------------------------------------------------------------------------------------- 'out.DebugInfo = out.DebugInfo + ";Temps de calcul : " + Format(Timer - Debut) + " secondes" 'Mesure de la performance : Duree = Timer - Debut out.DebugInfo = "Durée " + Format(Duree, "0.000") + "s - " + Format(NbGenerations) + " générations - " + Format(NbGenerations / Duree, "0.0") + " générations par seconde." 'On sélectionne le parcours le plus court : 'Set p = ListeParcours.Item(K) For j = 1 To ParOpti_NbIndividus p = Pointeur(j) ' If j = 1 Then MinLong = Lg(p) k = p Else If Lg(p) < MinLong Then MinLong = Lg(p) k = p End If End If Next j 'Contrôle de sécurité : ChiffreOK = True For i = 1 To out.ListePercages.count - 1 k = Matrice(i, p) 'Perçage i du meilleur parcours p If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False For j = i + 1 To out.ListePercages.count m = Matrice(j, p) 'Perçage j du meilleur parcours p If k = m Then ChiffreOK = False Next j Next i k = Matrice(out.ListePercages.count, p) 'dernier Perçage du meilleur parcours p If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False 'Affectation : If ChiffreOK Then 'Affectation : Set TmpListe = New Collection For j = 1 To NbPercages Set per = out.ListePercages.Item(Matrice(j, p)) 'Perçage j du meilleur parcours p TmpListe.Add per Next j Set out.ListePercages = TmpListe 'out.LongApresOptim = MinLong out.LongApresOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongApresOptim = out.LongApresOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i Else MsgBox "Contrôle de sécurité échoué" out.LongApresOptim = -1 End If End Sub
J’ai pensé que l’emploi d’un tableau à deux dimensions était la cause de cette lenteur. J’ai donc fait une troisième version qui n’utilise que des tableaux à une dimension :
Mais c’est juste très légèrement moins lent (quelques % de gagné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
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 Private Sub OptimiserOrdrePercages_Genetique3(out) 'AVEC UN TABLEAU A UNE DIMENSION Dim per As PercageCNC Dim MaxLong As Double Dim MinLong As Double Dim MinLongPrec As Double Dim MinLongConstantDepuis As Integer Dim TmpListe As Collection Dim Debut As Single Dim NbPercages As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim m As Integer Dim c As Integer Dim p1 As Integer Dim p2 As Integer Dim p As Integer Dim q As Integer Dim q1 As Integer Dim q2 As Integer Dim ChiffreOK As Boolean Dim XP As Double, YP As Double Dim Stagnation As Boolean Dim premier As Boolean Dim TaillePopulation As Integer Dim NbGenerations As Long Dim Duree As Single NbPercages = out.ListePercages.count TaillePopulation = ParOpti_NbIndividus + ParOpti_NbReproductions + ParOpti_NbMutations ReDim Matrice((NbPercages + 1) * (TaillePopulation + 1)) As Integer ReDim Lg(TaillePopulation + 1) As Double ReDim Pointeur(TaillePopulation + 1) As Integer ReDim IndicePointeur(TaillePopulation + 1) As Integer ReDim ColonneOK(TaillePopulation + 1) As Integer 'Pointeur(1...NbIndividus) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux parents 'Pointeur(NbIndividus+1...NbIndividus+ParOpti_NbReproductions) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux enfants 'Pointeur(NbIndividus+ParOpti_NbReproductions+1...NbIndividus+ParOpti_NbReproductions+ParOptiMutants) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux mutants 'Lg(i) contient la longeur du parcours de la colonne i (Matrice(.,i)) Debut = Timer out.LongAvantOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongAvantOptim = out.LongAvantOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i 'Création de la première génération : For i = 1 To TaillePopulation Pointeur(i) = i IndicePointeur(i) = (Pointeur(i) - 1) * NbPercages Next i 'La liste originale : For j = 1 To NbPercages 'Matrice(j, 1) = j Matrice(j) = j 'IndicePointeur(1) = 0 Next j 'Les listes aléatoires : Set TmpListe = New Collection For p = 2 To ParOpti_NbIndividus For j = 1 To NbPercages TmpListe.Add j Next j Randomize q = IndicePointeur(p) 'Remarque : ici Pointeur(p) = p car on est à la première génération For j = 1 To NbPercages 'Int((upperbound - lowerbound + 1) * Rnd + lowerbound) k = Int(TmpListe.count * Rnd + 1) 'Matrice(j, p) = TmpListe.Item(k) Matrice(j + q) = TmpListe.Item(k) Call TmpListe.Remove(k) Next j Next p 'Calcul du critère de la 1ière génération : For p = 1 To ParOpti_NbIndividus q = IndicePointeur(p) 'Remarque : ici Pointeur(p) = p car on est à la première génération 'Set per = out.ListePercages.Item(Matrice(1, p)) '1ier perçage de l'individu p Set per = out.ListePercages.Item(Matrice(1 + q)) '1ier perçage de l'individu p XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages 'Set per = out.ListePercages.Item(Matrice(j, p)) 'Perçage j de l'individu p Set per = out.ListePercages.Item(Matrice(j + q)) 'Perçage j de l'individu p Lg(p) = Lg(p) + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) 'Longueur de l'individu p XP = per.Xmachine YP = per.Ymachine Next j Next p MinLongPrec = Lg(1) MinLongConstantDepuis = 0 out.DebugInfo = "" 'Mesure de la performance : NbGenerations = 1 Do '-------------------------------------------------------------------------------------------------------------------------------------- Randomize 'Mesure de la performance : NbGenerations = NbGenerations + 1 'REPRODUCTION : For i = 1 To ParOpti_NbReproductions 'p = Pointeur(i + ParOpti_NbIndividus) 'p = pointeur de l'enfant n°i, stocké dans Pointeur(ParOpti_NbIndividus+1...ParOpti_NbIndividus+1+ParOptiNbReproductions) q = IndicePointeur(Pointeur(i + ParOpti_NbIndividus)) ' 'On choisi aléatoirement deux parents : k = Int(ParOpti_NbIndividus * Rnd + 1) Do m = Int(ParOpti_NbIndividus * Rnd + 1) Loop Until k <> m 'On cherche les colonnes p1 et p2 correspondant aux parents k et m 'p1 = Pointeur(k) 'p2 = Pointeur(m) q1 = IndicePointeur(Pointeur(k)) q2 = IndicePointeur(Pointeur(m)) 'Choix aléatoire du point de croisement : 'k=1 => 1.23456789 'm=8 => 12345678.9 c = Int((NbPercages - 1) * Rnd + 1) 'Croisement : For j = 1 To c 'Matrice(j, p) = Matrice(j, p1) 'Le percage j de l'enfant = le percage j du parent 1 Matrice(j + q) = Matrice(j + q1) 'Le percage j de l'enfant = le percage j du parent 1 Next j 'Génome du parent 2 dans l'enfant : j = 0 m = c Do j = j + 1 ChiffreOK = True 'On doit choisir les perçages du parent 2 dans l'ordre, en 'sautant' les percages déjà présents dans l'enfant : For k = 1 To c 'If Matrice(k, p) = Matrice(j, p2) Then ChiffreOK = False If Matrice(k + q) = Matrice(j + q2) Then ChiffreOK = False Next k If ChiffreOK Then m = m + 1 'Matrice(m, p) = Matrice(j, p2) Matrice(m + q) = Matrice(j + q2) End If Loop Until m = NbPercages Or j = NbPercages Next i 'MUTATION : For i = 1 To ParOpti_NbMutations 'p = Pointeur(i + ParOpti_NbIndividus + ParOpti_NbReproductions) q = IndicePointeur(Pointeur(i + ParOpti_NbIndividus + ParOpti_NbReproductions)) 'p = pointeur du mutant n°i, stocké dans Pointeur(ParOpti_NbIndividus+ParOpti_NbReproductions+1...TaillePopulation) ' 'Choix aléatoire des deux perçages qui seront échangés : k = Int(NbPercages * Rnd + 1) Do c = Int(NbPercages * Rnd + 1) Loop Until k <> c ' 'Choix aléatoire du parent dont le clone sera muté : m = Int(ParOpti_NbIndividus * Rnd + 1) 'p1 = Pointeur(m) q1 = IndicePointeur(Pointeur(m)) ' For j = 1 To NbPercages If j = c Then 'Matrice(j, p) = Matrice(k, p1) Matrice(j + q) = Matrice(k + q1) ElseIf j = k Then 'Matrice(j, p) = Matrice(c, p1) Matrice(j + q) = Matrice(c + q1) Else 'Matrice(j, p) = Matrice(j, p1) Matrice(j + q) = Matrice(j + q1) End If Next j Next i 'CALCUL DU CRITERE POUR TOUS LES INDIVIDUS : 'Optimisation : pas besoin de calculer à nouveau le critère pour les membres de la génération précédente : 'For Each p In ListeParcours 'ListeParcours.Count = ParOpti_NbIndividus + Nombre de reproductions + ParOpti_NbMutations > ParOpti_NbIndividus For i = ParOpti_NbIndividus + 1 To TaillePopulation p = Pointeur(i) q = IndicePointeur(p) 'p est le n° de la colonne de Matrice(,) et le numéro de Lg() Lg(p) = 0 'Set per = out.ListePercages.Item(Matrice(1, p)) Set per = out.ListePercages.Item(Matrice(1 + q)) XP = per.Xmachine YP = per.Ymachine For j = 2 To NbPercages 'Set per = out.ListePercages.Item(Matrice(j, p)) Set per = out.ListePercages.Item(Matrice(j + q)) 'Optimisation : la fonction Sqr est couteuse en temps de calcul et p'est pas nécessaire pour faire une comparaison : 'p.Lg = p.Lg + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) 'p.Lg = p.Lg + (XP - per.Xmachine) ^ 2 + (YP - per.Ymachine) * (YP - per.Ymachine) ^ 2 Lg(p) = Lg(p) + (XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine) XP = per.Xmachine YP = per.Ymachine Next j Next i 'Next p 'SELECTION : 'Ici on doit réaffecter les pointeurs 'Plus un parcours (une colonne de Matrice()) a une longeur élevé (mauvais critère), plus son pointeur est long : For i = 1 To TaillePopulation ColonneOK(i) = 0 Next i ' For p = 1 To ParOpti_NbIndividus 'Les pointeurs Pointeur(1...NbIndividus) correspondront aux meilleurs individus, c'est à dire aux NbIndividus colonnes les meilleures premier = True For j = 1 To TaillePopulation 'Pour chaque colonne 'i' If ColonneOK(j) = 0 Then 'Les colonnes qui n'ont pas encore un pointeur pointant sur elles If premier Then premier = False MinLong = Lg(j) k = j Else If Lg(j) < MinLong Then MinLong = Lg(j) k = j End If End If End If Next j 'Ici, K contient le n° de la colonne la plus courte parmis celles restant à trier Pointeur(p) = k IndicePointeur(k) = (k - 1) * NbPercages ColonneOK(k) = 1 Next p 'p = Pointeur(i) 'q = IndicePointeur(p) 'q = IndicePointeur(Pointeur(i)) 'Il faut tout de même renuméroter les colonnes 'mauvaises' car elles seront utilsées pour les enfants et les mutants de la génération suivante : p = ParOpti_NbIndividus For j = 1 To TaillePopulation If ColonneOK(j) = 0 Then 'Colonne n'ayant aucun pointeur pointant sur elle p = p + 1 Pointeur(p) = j IndicePointeur(j) = (j - 1) * NbPercages 'ColonneOK(j) = 1 superflux End If Next j 'Pointeur(1...NbIndividus) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux parents 'Pointeur(NbIndividus+1...NbIndividus+ParOpti_NbReproductions) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux enfants 'Pointeur(NbIndividus+ParOpti_NbReproductions+1...NbIndividus+ParOpti_NbReproductions+ParOptiMutants) contient les n° de colonne 'c' de Matrice(l,c) correspondants aux mutants 'Lg(i) contient la longeur du parcours de la colonne i (Matrice(.,i)) 'On détermine si on stagne ou pas : Stagnation = True For j = 1 To ParOpti_NbIndividus p = Pointeur(j) ' If Lg(p) < MinLongPrec Then Stagnation = False MinLongPrec = Lg(p) End If Next j If Stagnation Then MinLongConstantDepuis = MinLongConstantDepuis + 1 If MinLongConstantDepuis > ParOpti_MaxMinLongConstatDepuis Then Exit Do Else MinLongConstantDepuis = 0 End If If Timer - Debut > ParOpti_DureeMax Then Exit Do Loop '-------------------------------------------------------------------------------------------------------------------------------------- 'out.DebugInfo = out.DebugInfo + ";Temps de calcul : " + Format(Timer - Debut) + " secondes" 'Mesure de la performance : Duree = Timer - Debut out.DebugInfo = "Durée " + Format(Duree, "0.000") + "s - " + Format(NbGenerations) + " générations - " + Format(NbGenerations / Duree, "0.0") + " générations par seconde." 'On sélectionne le parcours le plus court : 'Set p = ListeParcours.Item(K) For j = 1 To ParOpti_NbIndividus p = Pointeur(j) ' If j = 1 Then MinLong = Lg(p) k = p Else If Lg(p) < MinLong Then MinLong = Lg(p) k = p End If End If Next j q = IndicePointeur(k) 'Contrôle de sécurité : ChiffreOK = True For i = 1 To out.ListePercages.count - 1 'k = Matrice(i, p) 'Perçage i du meilleur parcours p k = Matrice(i + q) 'Perçage i du meilleur parcours p If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False For j = i + 1 To out.ListePercages.count 'm = Matrice(j, p) 'Perçage j du meilleur parcours p m = Matrice(j + q) 'Perçage j du meilleur parcours p If k = m Then ChiffreOK = False Next j Next i 'k = Matrice(out.ListePercages.count, p) 'dernier Perçage du meilleur parcours p k = Matrice(out.ListePercages.count + q) 'dernier Perçage du meilleur parcours p If k < 1 Or k > out.ListePercages.count Then ChiffreOK = False 'Affectation : If ChiffreOK Then 'Affectation : Set TmpListe = New Collection For j = 1 To NbPercages 'Set per = out.ListePercages.Item(Matrice(j, p)) 'Perçage j du meilleur parcours p Set per = out.ListePercages.Item(Matrice(j + q)) 'Perçage j du meilleur parcours p TmpListe.Add per Next j Set out.ListePercages = TmpListe 'out.LongApresOptim = MinLong out.LongApresOptim = 0 Set per = out.ListePercages.Item(1) XP = per.Xmachine YP = per.Ymachine For i = 2 To NbPercages Set per = out.ListePercages.Item(i) out.LongApresOptim = out.LongApresOptim + Sqr((XP - per.Xmachine) * (XP - per.Xmachine) + (YP - per.Ymachine) * (YP - per.Ymachine)) XP = per.Xmachine YP = per.Ymachine Next i Else MsgBox "Contrôle de sécurité échoué" out.LongApresOptim = -1 End If End Sub
Donc soit la gestion des objets et des collections est très performante en VB5, soit la gestion des tableaux est très lente en VB5.
Si quelqu’un ici à une idée pour optimiser mon code qu’il n’hésite pas.
Ce post sera utile à ceux qui cherchent à utiliser les algorithmes génétiques, et à ceux qui souhaitent optimiser leur code.
NB : Cette page explique très bien le principe des algorithmes génétiques : http://fr.wikipedia.org/wiki/Algorit...A9n%C3%A9tique
A+
Partager