Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
1925 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Aide pour bug dans logiciel simulation cellules

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Aide pour bug dans logiciel simulation cellules

n°1955273
Profil sup​primé
Posté le 05-01-2010 à 19:59:26  answer
 

Bonjour,
 
Je suis en train de créer un programme basé sur le jeu de la vie qui simule la vie cellulaire. A partir d'un effectif de départ et d'une contrainte fixé par l'utilisateur, les cellules qui sont seules meurent. Celles qui sont entourés de la contrainte +1 meurent également. Dans le cas où il y a beaucoup de cellule initiale le programme fonctionne un certains temps avant d'atteindre un état d'équilibre. Mon programme atteint un équilibre beaucoup trop tôt. Il s'arrête alors même que des cellules devraient mourrire et d'autres générés en conséquence.
 
Merci de votre aide en espérant avoir été claire.  
 

'Déclaration des variables
Dim converge As Boolean
Dim virtueltab(1 To 100, 1 To 100) As Byte 'Tableau de transition
Dim vietab(1 To 100, 1 To 100) As Byte 'Tableau initial
Dim n As Integer 'Effectif de départ
Dim pauser As Boolean
Dim evol As Integer
Dim i As Integer 'Compteur des lignes du tableau initial
Dim j As Integer 'Compteur des colonnes du tableau initial
Dim l As Integer 'Compteur des lignes du tableau de transition
Dim m As Integer 'Compteur des colonnes du tableau de transition
Dim k As Integer 'Nombre de cellules voisines pour une cellule
Dim b As Integer 'Contrainte fixée par l'utilisateur
Dim popu As Integer
Dim reponse As VbMsgBoxResult
 
 
'Procédure initialisation
Sub initialisation(ByRef x() As Byte)
Dim i, j As Integer
'Remplissage du tableau avec des 0
For i = 1 To 100
    For j = 1 To 100
        x(i, j) = 0
    Next
Next
End Sub
 
'Procédure remplir
Sub remplir(ByVal n As Integer, ByRef x() As Byte)
Dim i, j, m As Integer
 
'Remplissage aléatoire du tableau: boucle répéter jusqu'à ce que les cases du tableau prennent la valeur 1, et ceci n fois
Randomize
For m = 1 To n
    Do
        i = Int(99 * Rnd) + 1
        j = Int(99 * Rnd) + 1
    Loop Until x(i, j) = 0
    x(i, j) = 1
Next
End Sub
         
'Fonction comptage
Function comptage(ByRef x() As Byte, ByVal i As Integer, ByVal j As Integer) As Integer
Dim l, c, n As Integer
Dim imin, imax, jmin, jmax As Integer
 
n = 0 'Initialisation du compteur
 
'Détermination des bornes du tableau dans un univers restreint
imin = i - 1
imax = i + 1
jmin = j - 1
jmax = j + 1
 
'Comptage dans les coins
If i = 1 Then
    imin = 1
Else
    If i = 100 Then
        imax = 100
    End If
End If
 
If j = 1 Then
    jmin = 1
Else
    If j = 100 Then
        jmax = 100
    End If
End If
 
'Comptage des futures cellules affichées
For l = imin To imax
    For c = jmin To jmax
        If x(l, c) = 1 Then
            n = n + 1
        End If
    Next
Next
 
If x(i, j) = 1 Then
    n = n - 1
End If
comptage = n
 
End Function
 
'Procédure dessiner
Sub dessiner(ByRef x() As Byte)
Dim l, c As Integer
For l = 1 To 100
    For c = 1 To 100
        If x(l, c) = 1 Then
            Picture1.FillStyle = 0 'Remplissage plein de la cellule vivante
            Picture1.FillColor = QBColor(4) 'Remplissage de couleur rouge de la cellule vivante
            Picture1.Circle (50 * l, 50 * c), 25, QBColor(4)
        Else
            Picture1.FillStyle = 0.01 'Remplissage plein de la cellule morte
            Picture1.FillColor = QBColor(15) 'Remplissage de couleur blanche de la cellule morte
            Picture1.Circle (50 * l, 50 * c), 25, QBColor(15) 'Couleur et forme de la cellule morte
        End If
         
        Picture1.AutoRedraw = True 'Rafraîchissement de l'image
         
    Next
Next
Refresh
End Sub
 
'Fonction evolution
Function evolution(ByRef x() As Byte, ByRef y() As Byte, ByVal i, j, b, k As Integer) As Integer
Dim c As Integer
c = 0
 
'k est le nombre de voisins autour de la cellule
If k = b + 1 Then
    If x(i, j) = 1 Then
        y(i, j) = 1
    Else
        y(i, j) = 1
        c = c + 1
    End If
End If
 
'Fonction de comptage des voisins en tenant compte des la contrainte b
If k = b Then
    If x(i, j) = 1 Then
        y(i, j) = 1
    Else
        y(i, j) = 0
    End If
End If
 
'Cas de la cellule seule ou entourée de plus de trois cellules: elle meurt dans virtueltab
If k < b Or k > b + 1 Then
    If x(i, j) = 1 Then
        y(i, j) = 0
        c = c + 1
    Else
        y(i, j) = 0
    End If
End If
 
'vietab reçoit les modifications effectuées dans virtueltab
x(i, j) = y(i, j)
evolution = c
End Function
 
'Fonction comptevol: comptage post évolution
Function comptevol(ByRef x() As Byte)
Dim i, j As Integer
Dim c As Integer
 
c = 0
For i = 1 To 100
    For j = 1 To 100
        If x(i, j) = 1 Then
            c = c + 1
        End If
    Next
Next
 
comptevol = c
End Function
 
Private Sub Bgo_Click()
 
'Algorithme principal
 
'Appel de la procédure de création du tableau
Call initialisation(vietab)
 
'On demande à l'utilisateur de définir un effectif de départ
If Teffectif.Text = "" Then
    n = InputBox("Effectif de départ?" )
    Teffectif.Text = n
Else
    n = Teffectif.Text
End If
 
'Choix de la contrainte
If Tcontrainte.Text = "" Then
    b = InputBox("Choix d'une contrainte entre 1 et 4" )
    Tcontrainte.Text = b
Else
    b = Tcontrainte.Text
End If
 
 
'Appel de la procédure de remplissage par randomisation
Call remplir(n, vietab)
 
'Appel de la procédure de dessin des cellules
Call dessiner(vietab)
 
evol = 0
For i = 1 To 100
    For j = 1 To 100
        'Appel de la fonction comptage, k reçoit sa valeur de sortie
        k = comptage(vietab, i, j)
        'Mise en correspondance des 2 tableaux
        c = evolution(vietab, virtueltab, i, j, b, k)
        evol = evol + c
    Next
Next
 
'La valeur de convergence est atteinte lorsqu'il n'y a plus d'écart entre les 2 tableaux
converge = evol = 0
 
'Somme des cellules vivantes
popu = comptevol(vietab)
 
'Dessin des valeurs contenues dans vietab
Call dessiner(vietab)
 
'Pause dans la boucle
Do
DoEvents
'Fin de la boucle si convergence au pause
Loop Until converge Or pauser
 
End Sub
 
 
 
 
 
 
 
 
 
Private Sub Bquitter_Click()
End
End Sub
 
 


Message édité par Profil supprimé le 05-01-2010 à 20:33:52
mood
Publicité
Posté le 05-01-2010 à 19:59:26  profilanswer
 

n°1955288
Profil sup​primé
Posté le 05-01-2010 à 21:00:56  answer
 

c'est un programme basique pourtant :D :lol:

n°1955564
seniorpapo​u
Posté le 06-01-2010 à 16:36:36  profilanswer
 

Bonjour,
que fait le DO juste avant DoEvents??
 
es-tu certain que:
 
'vietab reçoit les modifications effectuées dans virtueltab  
x(i, j) = y(i, j)  
 
 
n'est pas un peu prématuré à cet endroit?
 
Cordialement


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Aide pour bug dans logiciel simulation cellules

 

Sujets relatifs
[VBA]Copier certaines cellules dans un userform.[VBA] Graph : Selection d'une zone de cellules
Aide en schemeCréation d'un fichier config a l'aide de tableaux
Logiciel client SqlServer 2008Aide sur jointure externe complête
Aide pour projet informatiqueBesoin d'aide en php pour formulaire
[Excel VBA] Lister les noms de plages de cellules et leurs coordonnéesBesoin d'aide : recupérer des variables d'une page à l'autre
Plus de sujets relatifs à : Aide pour bug dans logiciel simulation cellules


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR