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

Staple1600

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

Re


Job75: il faudrait trouver un moyen de faire comprendre à VBA les lois de la distributivité (si mes souvenirs sont bon) :D


Ou alors arriver à formater la chaine sol par tranche de 5 lignes pour
les formules s'affichent sur 5 lignes dans la msgbox (chaque "tronçon de formule" étant séparé par un vTab
 
Dernière édition:

job75

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

Re,

Pour les parenthèses, on peut peut-être revoir la question, en utilisant des parenthèses imbriquées (travail que tu as fait au début, mais il te manque le 5ème cas).

Pour les permutations de chiffres, comment les éviter puisque l'addition et la multiplication sont commutatives ?

A+

Edit : avec les parenthèses imbriquées, on obtenait 14754 formules, donc ce n'est pas ce qui résoudra le problème. Comment les auteurs du jeu l'on résolu, là est la question.
 
Dernière édition:

Staple1600

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

Re



Je suis parti sur l'idée de laisser toutes les solutions mais en formatant la msgbox sur plusieurs colonnes.

(Je coince pour le moment -> j'ai ouvert une nouvelle discussion à ce sujet)



Autrement pour le reste, il n'y a pas moyen de "trier" les solutions équivalentes et d'en prendre qu'une (peu importe laquelle) comme solution ?
 

Staple1600

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

Re

Désolé de vous laisser .

Je pars en week-end

J'espère que les formulistes se seront manifestés d'ici là.

Bon week-end à tous et grand merci encore à Job75 , sans oublier Lii et tous ceux qui s'intéressent à ce fil.
 

ROGER2327

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

Bonsoir à tous.

J'ai attaqué le problème avec un marteau pilon :
  1. Recensement des tirages possibles, sans tenir compte de l'ordre.
  2. Une boucle dans laquelle je place aléatoirement les quatre nombres et j'essaie aléatoirement encore les opérateurs +, -, *, /.
    Sortie de la boucle si un calcul donne 24, ou si le nombre d'itérations atteint 10 000.

On obtient des choses...

Mode d'emploi du classeur :

Les macros sont associées à la feuille 'Feuil1'.
  1. La macro 'données' place les opérandes possibles dans les colonnes A à D.
  2. La macro 'vq' teste chaque quartet d'opérandes et propose éventuellement une réponse dans la colonne F.
  3. La macro 'test' répète 12 fois 'vq' et place les résultats dans les colonnes F à Q.(Environ 90 secondes.)
Les résultats sont écrits en notation polonaise inverse, i.e.
9 6 - 3 5 + *
signifie
(9 - 6)*(3 + 5)

Evidemment, on n'est jamais certain de ne pas laisser échapper une solution...

Enjoy !
 

Pièces jointes

  • Vingt-quatre.zip
    43.3 KB · Affichages: 84

job75

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

Bonjour Roger, le forum,

J'avais pensé à une solution de ce genre au tout début, mais je ne l'ai pas appliquée car en effet on n'est jamais sûr d'avoir trouvé toutes les solutions.

Le temps de calcul est du même ordre, c'est bon à savoir.

Merci pour ce travail.

A+
 

Staple1600

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

Bonjour à tous


Merci à Roger de rejoindre le fil.

Je testerai ton classeur dès mon retour.

Ravi de voir une autre approche du problème.


J'espère toujours que les formulistes finiront pas se manifester.


Bon week-end à tous
 

ROGER2327

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

Rapide, spécialement à l'attention de job75 et Staple1600 :

Ne perdez pas de temps avec mon classeur : CE N'EST PAS LE BON.

J'enverrai un classeur correct demain.

Avec mes excuses...
 

ROGER2327

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

Rapidement, spécialement pour job75 & Staple1600

Ne perdez pas de temps avec mon classeur : ce n'est pas le bon.

J'enverrai quelque chose de correct demain.

Mille excuses...
 

ROGER2327

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

Rapidement, spécialement pour job75 & Staple1600 :

Ne perdez pas de temps avec mon classeur : CE N'EST PAS LE BON.

J'enverrai une version correcte demain.

Mille excuses...
 

job75

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

Bonsoir Staple, le forum,

Un rappel : le problème posé par Staple est quasiment résolu. Toutes les combinaisons et toutes les formules-solutions ont été trouvées.

Restait le problème que pour le jeu, il y a trop de formules-solutions.

J'ai donc construit une fonction Epur qui :
- supprime les parenthèses inutiles
- supprime les permutations les plus évidentes, i.e. pour les cas suivants :

x1+x2+x3+x4
x1*x2*x3*x4
x1+(x2°x3°x4) ou (x1°x2°x3)+x4 ==> Edit : tests supprimés car aucun cas
x1*(x2°x3°x4) ou (x1°x2°x3)*x4


On trouvera ci-dessous la macro et la fonction permettant de déterminer le nombre de formules-solutions : il est maintenant de 6065 (au lieu de 14033 précédemment). Le temps de calcul, du fait de la fonction Epur, passe chez moi de 1m30s à 3m40s...

Pour la partie jeu, j'ai bien entendu modifié le fichier de Staple (ci-joint). L'augmentation du temps de calcul n'est pas trop perceptible. En moyenne il y a 6065/404 = 15 solutions par tirage.

Bonne fin de soirée.

NOTES POUR STAPLE : il faut :
- On Error Resume Next en début de macro
- méthode skoobi pour la collection solution
- fonction mini de pierrejean

Code:
Public x1, x2, x3, x4 As Byte

Sub Opérateurs_Staple()
Dim op() As Variant
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 = Epur("(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4)
f2 = Epur(x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4)
f3 = Epur("(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")")
f4 = Epur("(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4)
f5 = Epur(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
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
formule.Add f1, f1
On Error GoTo 0
End If

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

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

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

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

Function Epur(f$)
'suppression des parenthèses inutiles
For i = 1 To 7 Step 2
If Mid(f, i, 1) = "(" Then
j = Application.Find(")", f, i)
x = Mid(f, i + 1, j - 1 - i)
If IsError(Application.Find("+", x)) And IsError(Application.Find("-", x)) _
Or Mid(f, IIf(i > 1, i - 1, 1), 1) = "+" _
Or IIf(j = 7, Mid(f, 8, 1), 0) = "+" Or IIf(j = 7, Mid(f, 8, 1), 0) = "-" _
Then f = Replace(f, "(" & x & ")", x)
End If
Next
'classement si + ou *
If f Like "?+?+?+?" Then
f = mini(x1, x2, x3, x4)
f = Mid(f, 1, 1) & "+" & Mid(f, 2, 1) & "+" & Mid(f, 3, 1) & "+" & Mid(f, 4, 1)
End If
If f Like "?[*]?[*]?[*]?" Then
f = mini(x1, x2, x3, x4)
f = Mid(f, 1, 1) & "*" & Mid(f, 2, 1) & "*" & Mid(f, 3, 1) & "*" & Mid(f, 4, 1)
End If
If f Like "(?????)[*]?" And Mid(f, 9, 1) <= Mid(f, 2, 1) Then f = Mid(f, 9, 1) & "*" & Mid(f, 1, 7)
If f Like "?[*](?????)" And Mid(f, 1, 1) > Mid(f, 4, 1) Then f = Mid(f, 3, 7) & "*" & Mid(f, 1, 1)
Epur = f
End Function
 

Pièces jointes

  • 24job75v5.zip
    38.9 KB · Affichages: 91
  • 24job75v5.zip
    38.9 KB · Affichages: 89
  • 24job75v5.zip
    38.9 KB · Affichages: 87
Dernière édition:

job75

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

Bonjour Staple, le forum,

Je viens de découvrir une chose bien extraordinaire, Staple. La 2ème formule (ex f2) :

x1°(x2°x3)°x4

n'est pas nécessaire pour obtenir les 404 combinaisons ! Il n'y en a que 4 à étudier :

(x1°x2)°x3°x4
(x1°x2)°(x3°x4)
(x1°x2°x3)°x4
x1°(x2°x3°x4)


Du coup les macros sont simplifiées et le temps de calcul diminué de 20% (1m15s sans la fonction Epur, 3m avec Epur).

Le nombre de formules-solutions est 11750 sans Epur et 5656 avec Epur (soit 5656/404 = 14 par tirage pour le jeu).

Ci-joint la macro avec Epur pour le comptage, et le fichier du jeu.

A+

EDITION pour le jeu, Staple :

- pour la macro Afficher_solution, Solution.Add f1, f1 est mieux, mettre le signe = quand tu définis sol

- pour Epur, la fonction mini de pierrejean n'est pas nécessaire puisque les valeurs x1 x2 x3 x4 sont déjà dans l'ordre. Pour la différencier de la précédente, je l'ai renommée Epur1.

Code:
Public x1, x2, x3, x4 As Byte

Sub Opérateurs_Staple()
Dim op() As Variant
Dim f1, f2, f3, f4 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 = Epur("(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4)
f2 = Epur("(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")")
f3 = Epur("(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4)
f4 = Epur(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
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
formule.Add f1, f1
On Error GoTo 0
End If

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

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

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

4 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

Function Epur(f$)
'suppression des parenthèses inutiles
For i = 1 To 7 Step 2
If Mid(f, i, 1) = "(" Then
j = Application.Find(")", f, i)
x = Mid(f, i + 1, j - 1 - i)
If IsError(Application.Find("+", x)) And IsError(Application.Find("-", x)) _
Or Mid(f, IIf(i > 1, i - 1, 1), 1) = "+" _
Or IIf(j = 7, Mid(f, 8, 1), 0) = "+" Or IIf(j = 7, Mid(f, 8, 1), 0) = "-" _
Then f = Replace(f, "(" & x & ")", x)
End If
Next
'classement si + ou *
If f Like "?+?+?+?" Then
f = mini(x1, x2, x3, x4)
f = Mid(f, 1, 1) & "+" & Mid(f, 2, 1) & "+" & Mid(f, 3, 1) & "+" & Mid(f, 4, 1)
End If
If f Like "?[*]?[*]?[*]?" Then
f = mini(x1, x2, x3, x4)
f = Mid(f, 1, 1) & "*" & Mid(f, 2, 1) & "*" & Mid(f, 3, 1) & "*" & Mid(f, 4, 1)
End If
If f Like "(?????)[*]?" And Mid(f, 9, 1) <= Mid(f, 2, 1) Then f = Mid(f, 9, 1) & "*" & Mid(f, 1, 7)
If f Like "?[*](?????)" And Mid(f, 1, 1) > Mid(f, 4, 1) Then f = Mid(f, 3, 7) & "*" & Mid(f, 1, 1)
Epur = f
End Function
 

Pièces jointes

  • 24job75v5.zip
    41.3 KB · Affichages: 131
  • 24job75v5.zip
    41.3 KB · Affichages: 151
  • 24job75v5.zip
    41.3 KB · Affichages: 148
Dernière édition:

Staple1600

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

Bonjour job75, Roger, le fil, le forum


Job75
Un bref passage matinal d'abord pour te remercier

de ta persévérance, de ton code VBA.

J'ai testé ton fichier (d'avant ton dernier post) --> tip top

Maintenant, dès lundi, j'essaierai de m'atteler à la vérification de la saisie du joueur (avec RegExp ou l' opérateur Like)

Merci encore de ton implication, Job75.

(J'essaierai de tester avant la fin de la journée, de tester ton dernier classeur post de 11h03)


Roger
Une petit demande de confort (pour ma pomme ;) )
Déjà que je dois consommer un grand nombre de neurones pour revenir vers les maths si tu te mets à employer la notation polonaise inverse, tu vas m'achever :D

Pourrais-tu stp noter les solutions de manière classique ?

Merci
 
Dernière édition:

Staple1600

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

Re


Avant de vous laisser, pour cause de réunion de famille

et pour vous laisser de quoi vous amuser avec VBA et les maths

Voici dans la même veine (pour ceux que cela intéresse)

Le four four's game:
(plus d'infos ici:
http://en.wikipedia.org/wiki/Four_fours )
Trouver les solutions de 1 à 100, en utilisant uniquement 4 fois le chiffre 4
(on peut utiliser !, ^ et , en plus des 4 opérations classiques)

Exemple
1 = 4/4*4/4

Bon amusement et bon week-end à tous

PS: pour les impatients
http://www.drb.insel.de/~heiner/Puzzles/Year/R4444
 
Dernière édition:

job75

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

Re,

Staple, prends bien la dernière Edition dans mon post précédent...

Bon appétit et A+

Edit 1 : il est bon d'initialiser les nombres aléatoires avec Randomize

Edit 2 : dans l'un de tes posts tu te demandais combien d'éléments peut contenir une matrice définissant un nom. A mon avis, la seule limite est celle de la mémoire.

En VBA je ne sais pas faire, mais avec une macro Excel 4.0 voici :

- les données sont en Feuil1!A1:A10000

- tu crées une feuille macro Excel 4.0 et tu entres la formule suivante sous forme matricielle :

=RETOUR(DEFINIR.NOM("toto";""&Feuil1!$A$1:$A$10000))

- si tu veux masquer le nom, toujours en matricielle :

=RETOUR(DEFINIR.NOM("toto";""&Feuil1!$A$1:$A$10000;;;VRAI))

- tu exécutes la macro

- si tu veux stocker des nombres, tu utilises DEREF(Feuil1!$A$1:$A$10000) mais généralement ça occupe plus de place mémoire.

Dans ton jeu, tu peux utiliser cette méthode pour mémoriser les combinaisons.
 
Dernière édition:

Statistiques des forums

Discussions
311 722
Messages
2 081 930
Membres
101 843
dernier inscrit
Thaly