[VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Staple1600

XLDnaute Barbatruc
Bonjour à tous

Je cherche à réaliser sous VBA la chose suivante:

Lister les solutions possibles de ce jeu:
Ce lien n'existe plus
C'est à dire : avec les opérateurs de base +,-,*,/,(,) : trouver 24 avec 4 chiffres de( 1à 9 ) tiré au hasard

Un petit cadeau pour ceux qui sauront m'aider :)
(car malheureusement les maths et moi on a pas trop d'accointances ;) )
[flash]http://www.novelgames.com/flashgames/game.swf?id=73[/flash]
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re,

Avec la macro suivante, on récupère la combinaison 3388.

Le résultat est maintenant :
- 14063 formules
- 404 combinaisons.

L'erreur d'arrondi est inférieure à 10^-13.

Reste 2 questions, je pense ouvrir 2 autres fils :
- comment construire la fonction "classe" sans écrire tous les cas possibles
- comment se passer de la feuille de calcul pour les combinaisons.

Code:
Sub Opérateurs_Staple()
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim f1, f2, f3, f4, f5 As String, cl As Integer
Dim formule As New Collection, combinaison As New Collection
Range("A:A").ClearContents
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3

f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"

If IsError(Evaluate(f1)) Then GoTo 1
If [COLOR="Red"]Abs(Evaluate(f1) - 24) < 10 ^ -13[/COLOR] Then
formule.Add f1
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

1 If IsError(Evaluate(f2)) Then GoTo 2
If [COLOR="Red"]Abs(Evaluate(f2) - 24) < 10 ^ -13[/COLOR] Then
formule.Add f2
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

2 If IsError(Evaluate(f3)) Then GoTo 3
If [COLOR="Red"]Abs(Evaluate(f3) - 24) < 10 ^ -13[/COLOR] Then
formule.Add f3
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

3 If IsError(Evaluate(f4)) Then GoTo 4
If [COLOR="Red"]Abs(Evaluate(f4) - 24) < 10 ^ -13[/COLOR] Then
formule.Add f4
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

4 If IsError(Evaluate(f5)) Then GoTo 5
If [COLOR="Red"]Abs(Evaluate(f5) - 24) < 10 ^ -13[/COLOR] Then
formule.Add f5
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

5 Next
Next
Next
Next
Next
Next
Next
MsgBox "Formules " & formule.Count
MsgBox "Combinaisons " & combinaison.Count
End Sub

Function classe(x1, x2, x3, x4)
y1 = 1 * (x1 & x2 & x3 & x4)
y2 = 1 * (x1 & x2 & x4 & x3)
y3 = 1 * (x1 & x3 & x2 & x4)
y4 = 1 * (x1 & x3 & x4 & x2)
y5 = 1 * (x1 & x4 & x2 & x3)
y6 = 1 * (x1 & x4 & x3 & x2)
y7 = 1 * (x2 & x1 & x3 & x4)
y8 = 1 * (x2 & x1 & x4 & x3)
y9 = 1 * (x2 & x3 & x1 & x4)
y10 = 1 * (x2 & x3 & x4 & x1)
y11 = 1 * (x2 & x4 & x1 & x3)
y12 = 1 * (x2 & x4 & x3 & x1)
y13 = 1 * (x3 & x1 & x2 & x4)
y14 = 1 * (x3 & x1 & x4 & x2)
y15 = 1 * (x3 & x2 & x1 & x4)
y16 = 1 * (x3 & x2 & x4 & x1)
y17 = 1 * (x3 & x4 & x1 & x2)
y18 = 1 * (x3 & x4 & x2 & x1)
y19 = 1 * (x4 & x1 & x2 & x3)
y20 = 1 * (x4 & x1 & x3 & x2)
y21 = 1 * (x4 & x2 & x1 & x3)
y22 = 1 * (x4 & x2 & x3 & x1)
y23 = 1 * (x4 & x3 & x1 & x2)
y24 = 1 * (x4 & x3 & x2 & x1)
classe = Application.Min(y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15, y16, y17, y18, y19, y20, y21, y22, y23, y24)
End Function

A+
 

job75

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re,

Voilà une 1ère amélioration : la fonction "classe" a été remplacée par la fonction "mini" de pierrejean :

Code:
Sub Opérateurs_Staple()
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim f1, f2, f3, f4, f5 As String, cl As Integer
Dim formule As New Collection, combinaison As New Collection
Range("A:A").ClearContents
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3

f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"

If IsError(Evaluate(f1)) Then GoTo 1
If Abs(Evaluate(f1) - 24) < 10 ^ -13 Then
formule.Add f1
cl = mini(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

1 If IsError(Evaluate(f2)) Then GoTo 2
If Abs(Evaluate(f2) - 24) < 10 ^ -13 Then
formule.Add f2
cl = mini(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

2 If IsError(Evaluate(f3)) Then GoTo 3
If Abs(Evaluate(f3) - 24) < 10 ^ -13 Then
formule.Add f3
cl = mini(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

3 If IsError(Evaluate(f4)) Then GoTo 4
If Abs(Evaluate(f4) - 24) < 10 ^ -13 Then
formule.Add f4
cl = mini(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

4 If IsError(Evaluate(f5)) Then GoTo 5
If Abs(Evaluate(f5) - 24) < 10 ^ -13 Then
formule.Add f5
cl = mini(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If

5 Next
Next
Next
Next
Next
Next
Next
MsgBox "Formules " & formule.Count
MsgBox "Combinaisons " & combinaison.Count
End Sub

Function mini(x1, x2, x3, x4) 'créée par pierrejean le 23/10/08
tablo = Array(x1, x2, x3, x4)
For n = LBound(tablo) To UBound(tablo)
 For m = LBound(tablo) To UBound(tablo)
  If tablo(m) > tablo(n) Then
   temp = tablo(n)
   tablo(n) = tablo(m)
   tablo(m) = temp
  End If
 Next m
Next n
For n = LBound(tablo) To UBound(tablo)
  mini = mini & tablo(n)
Next n
End Function

A+
 

job75

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re,

Et voici la 2ème amélioration donnée par skoobi : il n'y a plus besoin de la feuille de calcul pour déterminer les combinaisons.

J'ai laissé dans la macro les lignes qui remplissent la feuille, mais on peut sans problème les retirer.

Code:
Sub Opérateurs_Staple()
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim f1, f2, f3, f4, f5 As String, cl As Integer
Dim formule As New Collection, combinaison As New Collection
Range("A:A").ClearContents
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3

f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"

If IsError(Evaluate(f1)) Then GoTo 1
If Abs(Evaluate(f1) - 24) < 10 ^ -13 Then
formule.Add f1
cl = mini(x1, x2, x3, x4)
On Error Resume Next
combinaison.Add cl, CStr(cl) 'méthode donnée par skoobi le 23/10/08
If Err = 0 Then Range("A" & combinaison.Count) = cl
On Error GoTo 0
End If

1 If IsError(Evaluate(f2)) Then GoTo 2
If Abs(Evaluate(f2) - 24) < 10 ^ -13 Then
formule.Add f2
cl = mini(x1, x2, x3, x4)
On Error Resume Next
combinaison.Add cl, CStr(cl)
If Err = 0 Then Range("A" & combinaison.Count) = cl
On Error GoTo 0
End If

2 If IsError(Evaluate(f3)) Then GoTo 3
If Abs(Evaluate(f3) - 24) < 10 ^ -13 Then
formule.Add f3
cl = mini(x1, x2, x3, x4)
On Error Resume Next
combinaison.Add cl, CStr(cl)
If Err = 0 Then Range("A" & combinaison.Count) = cl
On Error GoTo 0
End If

3 If IsError(Evaluate(f4)) Then GoTo 4
If Abs(Evaluate(f4) - 24) < 10 ^ -13 Then
formule.Add f4
cl = mini(x1, x2, x3, x4)
On Error Resume Next
combinaison.Add cl, CStr(cl)
If Err = 0 Then Range("A" & combinaison.Count) = cl
On Error GoTo 0
End If

4 If IsError(Evaluate(f5)) Then GoTo 5
If Abs(Evaluate(f5) - 24) < 10 ^ -13 Then
formule.Add f5
cl = mini(x1, x2, x3, x4)
On Error Resume Next
combinaison.Add cl, CStr(cl)
If Err = 0 Then Range("A" & combinaison.Count) = cl
On Error GoTo 0
End If

5 Next
Next
Next
Next
Next
Next
Next
MsgBox "Formules " & formule.Count
MsgBox "Combinaisons " & combinaison.Count
End Sub

Function mini(x1, x2, x3, x4) 'créée par pierrejean le 23/10/08
tablo = Array(x1, x2, x3, x4)
For n = LBound(tablo) To UBound(tablo)
 For m = LBound(tablo) To UBound(tablo)
  If tablo(m) > tablo(n) Then
   temp = tablo(n)
   tablo(n) = tablo(m)
   tablo(m) = temp
  End If
 Next m
Next n
For n = LBound(tablo) To UBound(tablo)
  mini = mini & tablo(n)
Next n
End Function

A+
 

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Bonsoir à tous



Job75: félicitations pour ta persévérance (même si tu as du te coucher tard)

Mais cela fait plaisir de voir le résultat d'un bataillon de neurones en découdre avec VBA.

Merci aussi à skoobi et pierrejean d'avoir adjoint vos neurones à ceux de job75.


Je m'en vais tester le dernier code de job75.



PS: job75: dans quel fil pierrejean a t'il posté sa fonction mini, j'ai eu beau lire ce fil et celui que tu as ouvert , je n'ai pas vu trace de pierrejean.
 

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re


Merci job75 pour les liens.


J'ajoute à mes remerciements la personne suivante

Wilfried42 (merci à toi).


Maintenant , il reste la partie Jeu

(Tirer 4 chiffres au hasard dans ceux qui solutionnent x1 x2 x3 x4 = 24
puis pouvoir comparer la réponse avec la bonne solution)

Je vais travailler un peu de mon côté.
 

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re



Le problème auquel je viens de me confronter

Avec ce code
MsgBox combinaison.Item(((Rnd * 404) + 1))

On tire un combinaison au hasard, mais à chaque fois, qu'on veut jouer à nouveau, il faut attendre environ 1m10

Dans ce cas, faut-il stocker dans un tableau les 404 combinaisons
(et dans un autre les 404 formules)

Un autre problème, c'est qu'il peut y avoir plusieurs solutions
(voir le classeur joint dans le message de 22h21)

Je m'en vais créer deux tableaux de ce pas.

A+ et bonne soirée à tous
 

job75

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re Staple

Re
Je m'en vais créer deux tableaux de ce pas.

Les "tableaux" sont déjà créés (les 2 collections). Pour qu'ils puissent être utilisés sans recalcul par d'autres macros, il suffit d'écrire (tu le sais bien...) en haut de la page de code :

Public formule As New Collection
Public combinaison As New Collection


Le problème c'est que je n'ai pas créé de correspondance entre les 2 collections. Je crois que c'est possible, mais il faudrait que je travaille la question. Tu sais peut-être comment faire ?

Maintenant, à part le tirage aléatoire, je n'ai pas compris en quoi consiste le jeu. Tu peux m'expliquer ?

A+
 

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re



Snif , snif


Job75: J'aurais du te lire avant , je viens de me coltiner à la mimine de créer deux tableaux (lol)

Bon bah je retourne modifier ma pièce jointe.

Tu peux néanmoins regarder comment j'envisage la feuille JEU

(PS: j'ai ajouté ton VBA (légèrement modifié)
 

Pièces jointes

  • 24job75v2.zip
    34.7 KB · Affichages: 48
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re


Le jeu: 4 chiffres s'affichent de manière aléatoire dans 4 cellules.

Le joueur doit trouver la formule qui aboutit à 24.

Un bouton [Vérifier l'expression] vérifie la validité mathématique de l'expression saisie par le joueur.


Un bouton Solution permet d'afficher la solution.



J'ai modifié ton code pour afficher les formules sur la même ligne que les combis
mais je ne sais pas comment lire la collection sans passer par le stockage sur la feuille pour le moment.

C'est pour cela que je partais sur l'idée de tableaux.



PS: Quel idiot je fais , j'étais content de ton algo et ca m'embetait
de ne pas l'utiliser.
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re

Je ne comprends pas le problème suivant

Je lance ta macro
Sub Opérateurs_Staple()


Puis celle-ci
Code:
Sub test_ii()
Dim hasard As Long
Dim chiffres
hasard = Int((Rnd * 404) + 1)
MsgBox combinaison.Item(Int((Rnd * 404) + 1))
'Cells(13, 6) = Mid(chiffres, 1, 1)
'Cells(14, 5) = Mid(chiffres, 2, 1)
'Cells(14, 7) = Mid(chiffres, 3, 1)
'Cells(17, 6) = Mid(chiffres, 4, 1)
''solution = tab_formules(hasard)
'V_solution = MsgBox("Voir la solution?", vbYesNo, "Afficher une solution")
'Debug.Print V_solution
'If V_solution = 6 Then
'MsgBox solution & " = 24"
'End If
End Sub
Cela fonctionne mais si je change en
MsgBox combinaison.Item(hasard)

Cela buggue

Et je remets ensuite
MsgBox combinaison.Item(Int((Rnd * 404) + 1))


Cela buggue aussi ??
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re


Apparemment cela na buggue plus


Voici la dernière version avec les collections déclarées en Public

(encore mes excuses job75)
 

Pièces jointes

  • 24job75v3.xls
    116.5 KB · Affichages: 83

job75

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re,

Bravo Staple, c'est du bon travail.

Mes remarques :

- Le temps de calcul pour l'établissement des tableaux (1m40s chez moi) est assez long, mais je ne vois pas comment l'éviter.

- Dans la mesure où ce calcul est fait à l'ouverture du fichier, pourquoi vouloir le refaire avec un bouton ? les collections seront toujours là. EDIT : en fait c'est probablement l'inverse que tu vas faire, la macro Open sera supprimée.

- Qu'il n'y ait qu'une solution donnée par combinaison n'est finalement pas gênant, il me semble. En plus comme elle est crée avec la combinaison, c'est normalement la plus simple.

- La collection "formule" était intéressante pour l'étude, mais il me semble que maintenant elle ne servira jamais à rien.

- Je suis content qu'il n'y ait pas de parenthèses imbriquées, c'est quand même plus propre...

Pour l'origine des bugs que tu as rencontrés, je n'ai pas non plus compris.

A+
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re



J'ai laissé le bouton (qui était là pour tester)

Une idée en l'air comme cela

(que j'essaie de tester mais qui buggue pour le moment)

Est-ce que de stocker la collection combi en hexadécimal (ou en binaire)
pourrait accélérer le code?


(Utiliser l'hexa aurait pour avantage de ne pas rendre directement visible
les combinaisons)

Pour ma gouverne je n'arrive pas à comprendre pourquoi ce test ne fonctionne pas.

Erreur 13 : Incompatibilité de type



J'ai déclaré cl en Double pourtant
Extrait de ton code modifié (sur toutes les etiquettes)
1 If IsError(Evaluate(f2)) Then GoTo 2
If Abs(Evaluate(f2) - 24) < 10 ^ -13 Then
formule.Add f2
cl = DecToHex(mini(x1, x2, x3, x4))
On Error Resume Next
combinaison.Add cl, CStr(cl)
Code:
Public Function DecToHex(DecVal As Double) As String
Dim a As Double, b As Double, c As String, d As Double
    a = DecVal
    For b = 1 To Int(Log(DecVal) / Log(16)) + 1
        d = CDbl(a Mod 16)
        Select Case d
            Case 0 To 9
                c = d
            Case Else
                c = Chr(55 + d)
        End Select
        DecToHex = c & DecToHex
        a = CDbl(Int(a / 16))
    Next b
End Function
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : [VBA] Maths -algorithm- "The 24 Game" aide demandée (combinaisons/permutations)

Re


Une petite question pour les formulistes du forum


Si certains parmi vous essaient de faire une version sans VBA , uniquement en formules, qu'ils se manisfestent ici et me disent s'ils veulent essayer par leurs propres moyens ou si
d'ores et déjà, je vous indique un lien vers un fichier Excel ne fonctionnant que par formule

(comme je l'avais promis dans mon post du 21/10 à 19h55)

cf. Lien supprimé
 
Dernière édition: