[Sources] Jeu des chiffres et des lettres

[philben]

salut Vodiem,

cela dit après zieutage je ne décèle pas de différence de temps entre la requête que tu as choisi et celle que j'ai choisi.

Voilà ce que c'est d'avoir un ordi de course...
Pour ma part avec ma vieille casserole, j'obtiens un gain global d'un facteur 10 soit un passage de plus d'une seconde à 115 ms d'après GetTickCount.
Cette différence s'explique essentiellement par l'utilisation de l'index.

je reste perplexe sur le gain de la récursivité du générateur

Globalement cette partie du code n'a pas ou peu d'impact sur le temps total. Toujours sur ma casserole, je note un gain d'un facteur entre 1,5 et 2.

Ceci n'enlève rien à la qualité de ton code et du principe que tu as élaboré.
Je serai heureux de voir le joli Puissance4 que tu vas créer

Encore Bravo Vodiem et remerciement à Random pour son idée ingénieuse de motif avec lettres ordonnées.

A+

Philippe

[vodiem]

après mon cambriolage j'ai dû ressouder une ancienne carte mère l'opération à durée 1/2 journée et je lui ai greffé un peu de ram. après l'opération Frankenstein overclocké est reconnu par windows comme: sempron 2500+, 576 ram avec ses 10Go de HDD.

facteur 10? +d'1s à qq ms...
il faut que je regarde cela de plus près, je n'observe pas une différence aussi importante. il serait temps que je porte mes lunettes, râaa... zut: ca aussi ils me l'ont piqué!. y aurait il des différences aussi importante selon le matériel?

Envoyé par philben

Je serai heureux de voir le joli Puissance4 que tu vas créer

joli peut être, soigné surement, fonctionnelle c'est autre chose...
pour ce qui est du jeu, c'est comme le mot le plus long: j'ai du mal à aligner plus de trois lettres alors 4...
j'ai hâte de voir jusqu'où tu as mis la barre, toi qui a déjà fait un tétris...

merci pour la requete, je suis un peu surpris ce n'est pas la première fois qu'access me fait des tours de cochon et me laisse croire à certain aprioris.
merci philben de les remettre en cause.

merci aussi à random, initiateur du débat.

on attend le feedback User.

[User]

Désolé pour le retard,

Bravo philben pour cette optimisation, que dis-je a ce niveau j'ai l'impression d'avoir une Ferrari entre les mains

philben
Crée une requête séparée "compilée" RqMots, éliminer les "mots" < 2 lettres
remplire directement la table combinaison...
et j'en passe tout cela semble bien améliorer les choses..

(le tri de vodiem semblait toute fois intéressant)

Tout ceci ne fait que confirmer la valeur de la méthode de vodiem que vous trouverez toujours en version n°2

Ta version philben est en n°3

J'ai supprimée la version n°1

Merci encore à vous deux !

[philben]

Bonjour,

Comme la BAL de User est pleine, je me permet d'envoyer mon message ici :

bonjour User,

je tenais à m'excuser pour le boulot supplémentaire que je t'ai occasionné, mais j'aime bien chamailler mon ami Vodiem

Je suis aussi très heureux de ton retour sur le forum.

Encore Bravo pour ton application

Amicalement,

Philippe

[User]

Une nouvelle version avec le sql

where motif In (l_motifs)

ca evite la table combinaison et l'ajout des combinaison dans cette table et donc la base reste fixe et la vitesse est comparable

création de la liste des motifs a partir du tirage:

Function genCombinaison(chaine As String) As String  'renvoie une liste de motifs
Dim str As String
Dim i As Long
Dim j As Long
Dim s As String
Dim n As Integer, mx As Integer
 
n = Len(chaine)
m = 2 ^ n
chaine = creerMotif(chaine)
 
str = vbNullString
 
For i = 1 To m
    mx = n - 1    'max pour éviter des décalages inutiles il faudrait: log base 2 +1
    For j = 0 To mx
        s = s + Mid(chaine, j + 1, SHR(i, j) And 1)
    Next j
    If Len(s) > 1 Then
       str = str & Chr(39) & s & Chr(39) & ","
    end if
    s = vbNullString
Next i
genCombinaison = str
End Function
 
 

et la procedure principale:

Public Function generer_resultats2(ByVal Tirage As String)
   Dim oDb As DAO.Database, oRs As DAO.Recordset
   Dim i As Integer, j As Integer, l_motifs As String, sql_mots As String
   Dim tb_str(2 To 9) As String, s As String
 
   DoCmd.Hourglass True
 
   Set oDb = CurrentDb
   
   l_motifs = genCombinaison(Tirage)
      
   l_motifs = Left(l_motifs, Len(l_motifs) - 1)
   
   sql_mots = "SELECT mot " & _
   "FROM dico " & _
   "WHERE motif In (" & l_motifs & ");"
   
   Set oRs = oDb.OpenRecordset(sql_mots, dbOpenForwardOnly)
   Do Until oRs.EOF
      tb_str(Len(oRs!mot)) = tb_str(Len(oRs!mot)) & oRs!mot & " "
      oRs.MoveNext
   Loop
 
   j = 1
 
   For i = 9 To 2 Step -1
      If tb_str(i) <> vbNullString Then
         s = s & "Mots de " & i & " lettres:" & vbCrLf
         s = s & tb_str(i) & vbCrLf & vbCrLf
         j = j + 1
         If j > 3 Then Exit For
      End If
   Next i
 
   Forms!Mot_plus_long!Solutions = s
 
   Set oRs = Nothing
   Set oDb = Nothing
 
   DoCmd.Hourglass False
 
End Function
 
 
 

version n°4


merci Philben pour ton accueil

[philben]

bonjour User,

Une nouvelle version avec le sql

Ta nouvelle solution fonctionne bien, de mon côté, je me suis amusé à programmer une méthode sans la colonne <mot> de la table pour gagner 1,5Mo, ça fonctionne mais c'est pour le fun !

Je me suis aussi amusé à programmer le Compte est bon avec une fonction récursive qui semble fonctionner pas mal.
Le style est un peu crade mais en une heure c'était dans le sac.

La fonction :

 
'v1.01 :
'-> optimisation et nettoyage du code
'-> correction d'un bug avec la division (autorise / maintenant si l1 = l2)
Private Sub ChercheCEB(ByRef alNombres() As Long, ByVal lResultat As Long, _
                       ByVal byProf As Byte, tCEB As tCompteEstBon)
   Dim fDiv As Single
   Dim l1 As Long, l2 As Long, lSaveBest As Long, lSaveValeur As Long
   Dim i As Byte, j As Byte, k As Byte
   Dim bCalc As Boolean
 
   For i = 0 To 5
      If alNombres(i) > 0 Then
         l1 = alNombres(i)
         alNombres(i) = 0
         For j = i + 1 To 5
            If alNombres(j) > 0 Then
               l2 = alNombres(j)
               alNombres(j) = 0
               For k = 0 To 3
                  Select Case k
                  Case 0   '+
                     alNombres(i) = l1 + l2
                     bCalc = True
                  Case 1   '-
                     If l1 <> l2 Then
                        alNombres(i) = Abs(l1 - l2)
                        bCalc = True
                     End If
                  Case 2   'x
                     If l1 < 10 ^ 4 And l2 < 10 ^ 4 Then
                        alNombres(i) = l1 * l2
                        bCalc = True
                     End If
                  Case Else   '/
                     If l1 >= l2 Then
                        fDiv = l1 / l2
                        If fDiv = Int(fDiv) Then
                           alNombres(i) = fDiv
                           bCalc = True
                        End If
                     End If
                  End Select
                  If bCalc Then
                     tCEB.lCount = tCEB.lCount + 1
                     If alNombres(i) = lResultat Or _
                        Abs(alNombres(i) - lResultat) < Abs(tCEB.lBest - lResultat) Then
                        tCEB.byLastProf = byProf
                        tCEB.lBest = alNombres(i)
                        SetOperation k, byProf, l1, l2, alNombres(i), tCEB
                        If alNombres(i) = lResultat Then Exit Sub
                     End If
                     If byProf - 1 > 0 Then
                        lSaveValeur = alNombres(i)
                        lSaveBest = tCEB.lBest
                        ChercheCEB alNombres, lResultat, byProf - 1, tCEB
                        If tCEB.lBest = lResultat Or _
                           Abs(tCEB.lBest - lResultat) < Abs(lSaveBest - lResultat) Then
                           SetOperation k, byProf, l1, l2, lSaveValeur, tCEB
                           If tCEB.lBest = lResultat Then Exit Sub
                        End If
                     End If
                     bCalc = False
                  End If
               Next k
               alNombres(j) = l2
            End If
         Next j
         alNombres(i) = l1
      End If
   Next i
End Sub
 
Private Sub SetOperation(ByVal byOper As Byte, ByVal byProf As Byte, ByVal l1 As Long, _
                         ByVal l2 As Long, ByVal lValeur As Long, ByRef tCEB As tCompteEstBon)
   Select Case byOper
   Case 0
      tCEB.asOperations(byProf) = l1 & " + " & l2 & " = " & lValeur
   Case 1
      If l1 > l2 Then
         tCEB.asOperations(byProf) = l1 & " - " & l2 & " = " & lValeur
      Else
         tCEB.asOperations(byProf) = l2 & " - " & l1 & " = " & lValeur
      End If
   Case 2
      tCEB.asOperations(byProf) = l1 & " x " & l2 & " = " & lValeur
   Case Else
      tCEB.asOperations(byProf) = l1 & " / " & l2 & " = " & lValeur
   End Select
End Sub

le type utilisé :

 
Private Type tCompteEstBon
   asOperations(1 To 5) As String
   lBest As Long
   lCount As Long
   byLastProf As Byte
End Type
 

la fonction appelante :

 
'modifiée
Public Function CEB(ByRef alNombres() As Long, ByVal lResultat As Long)
   Dim tCEB As tCompteEstBon
   Dim lTmp As Long
   Dim i As Integer, j As Byte
   Dim s As String
   
   DoCmd.Hourglass True
   
   Randomize
   For i = 5 To 2 Step -1
      j = Int(i * Rnd())
      lTmp = alNombres(i)
      alNombres(i) = alNombres(j)
      alNombres(j) = lTmp
   Next i
   
   ChercheCEB alNombres, lResultat, 5, tCEB
   
   If tCEB.lBest = lResultat Then
      s = "Solution trouvée : "
   Else
      s = "Compte Approché : "
   End If
   s = s & tCEB.lBest & vbCrLf & "en " & tCEB.lCount & " essais"
   j = 1
   For i = 5 To tCEB.byLastProf Step -1
      If tCEB.asOperations(i) <> vbNullString Then
         s = s & vbCrLf & j & ") " & tCEB.asOperations(i)
         j = j + 1
      End If
   Next i
   
   Forms!Compte_est_bon!Solutions = Forms!Compte_est_bon!Solutions & s & vbCrLf
   DoCmd.Hourglass False
End Function
 

Et le code du bouton appelant :

 
Private Sub Commande76_Click()
Dim t1(0 To 5) As Long
Dim i As Integer
Dim res As Integer
Dim s As String
Dim t0 As Long
 
 
Me!ProgressBar.Value = 0
Me.TimerInterval = 0
 
res = CInt(Me!Resultat.Caption)
 
For i = 0 To 5
t1(i) = CInt(Me("Nombre" & (i + 1)).Caption)
Next i
 
 
'Me!Solutions = ""
't0 = GetTickCount()
ceb t1, res
'MsgBox GetTickCount() - t0
End Sub
 

Amicalement,

Philippe

[vodiem]

c'est un peu limite à la discution mais je voudrais revenir sur le gain que tu parles philben.

j'ai comparé 4 requetes équivalentes provenant de synthaxe différente:
SQL1: INNER JOIN
SQL2: EXISTS
SQL3: LEFT JOIN (evidemment +long)
SQL4: IN
Une requete du type "WHERE ([motif]='...') OR ..." étant beaucoup plus long.

code de test:

Option Compare Database
 
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Function tempsEcoule(sql As Variant) As Long
Dim rs As DAO.Recordset
debut = GetTickCount()
Set rs = CurrentDb.OpenRecordset(sql)
fin = GetTickCount()
rs.Close
tempsEcoule = fin - debut
End Function
 
Private Sub Commande1_Click()
 
SQL1 = "SELECT DISTINCT D.mot " & _
       "FROM combinaison AS C INNER JOIN dico AS D ON C.motif=D.motif;"
 
SQL2 = "SELECT t1.mot " & _
       "FROM dico AS t1 " & _
       "WHERE EXISTS (select t2.motif from combinaison t2 where t2.motif=t1.motif)"
        
SQL3 = "SELECT DISTINCT t2.mot " & _
       "FROM combinaison AS t1 LEFT JOIN dico AS t2 ON t1.motif = t2.motif " & _
       "WHERE not (t2.motif is null)"
 
SQL4 = "SELECT mot FROM dico " & _
       "WHERE motif IN (select motif from combinaison)"
 
Debug.Print "SQL4: " & tempsEcoule(SQL4)
Debug.Print "SQL3: " & tempsEcoule(SQL3)
Debug.Print "SQL2: " & tempsEcoule(SQL2)
Debug.Print "SQL1: " & tempsEcoule(SQL1)
 
End Sub

résultat:
après 1er ouverture de la base:
SQL1: 687
SQL2: 78
SQL3: 1969
SQL4: 31

2eme exécution
SQL1: 266
SQL2: 31
SQL3: 1375
SQL4: 15

3eme
SQL1: 250
SQL2: 15
SQL3: 1375
SQL4: 31

inversement (des fois que...)
SQL4: 15
SQL3: 1406
SQL2: 32
SQL1: 250

on peut donc noter que l'INNER JOIN est moins rapide qu'un EXISTS et qu'un IN.

et voici une discution sur la comparaison entre l'EXISTS et IN: ici

je vais donc garder mes aprioris.

User tu as bien fait de modifier le code du genCombinaison car cela devait être avec mon code:

s = s + Mid(chaine, j + 1, SHR(i + 1, j) And 1)

et tu as tout à fait raison: une fois la combinaison crée, toutes les formes sont déjà présent donc la génération du motif alourdi de traitement.

bravo philben pour la suite: "le compte est bon"
je n'aurait pas le temps là dessus de chipoter avec toi.

[philben]

salut vodiem,

peux-tu ajouter la boucle sur les enregistrements dans ton temps car ouvrir un recordset n'est pas parcourir le jeu...

 
Set oRs = oDb.OpenRecordset(sql_mots, dbOpenForwardOnly)
   Do Until oRs.EOF
      tb_str(Len(oRs!mot)) = tb_str(Len(oRs!mot)) & oRs!mot & " "
      oRs.MoveNext
   Loop
 

A+

Philippe

[User]

Salut à tous les deux

Philben:
Concernant le compte est bon j'ai testé ta fonction récursive qui fonctionne très bien (ca ouvre de nouvelles possibilités...)

juste 2 petits problèmes à rectifier quand tu en auras le temps (restons zen),

eviter les opérations du style
10*1=10
10/1=10

et dans de très rares cas, des résultats intermédiaire qui ne sont pas utilisés du style:

compte a trouver 110
1) 50 +5 =55
2) 100+20 = 120
3) 55*2 = 110

l'operation 2) 100+20=120 n'est pas utilisé...


je precise qu'il s'agit de cas rares

--------------------------------------------

Sinon Bravo ca apporte un plus indéniable

Bonne soirée à tous

Denis

[vodiem]

salut à tous,

philben>

après 1er ouverture de la base:
SQL1: 297
SQL2: 265
SQL3: 2453
SQL4: 266

2eme exec:
SQL1: 266
SQL2: 266
SQL3: 1406
SQL4: 266

3eme:
SQL1: 265
SQL2: 282
SQL3: 1390
SQL4: 266

après qq manip:
SQL1: 266
SQL2: 265
SQL3: 1391
SQL4: 281

c'est une question intéressante. on va pas trop chipoter on peut dire que dans ce contexte cela se vaut.
je ne dirais pas que l'INNER JOIN est équivalent mais que l'utilisation des recordsets inhibe les performances du EXISTS/IN.

[philben]

bonjour Denis,

Sinon Bravo ca apporte un plus indéniable

Ce n'était pas mon objectif car ton système fonctionne très bien, mais seulement de pouvoir enfin battre ce jeu !

Merci à toi User

Philippe

[philben]

bonjour Denis,

J'ai essayé de tenir compte de tes observations et j'espère avoir résolu la majorité des problèmes (reste parfois des opérations non nécessaires) avec ce nouveau code :

 
Option Compare Database
Option Explicit
 
'Algo récursif pour le "Compte Est Bon" - v1.05 - Philben
 
'Constantes pour alOperations
Private Const gcbyl1 As Byte = 0
Private Const gcbyOper As Byte = 1
Private Const gcbyl2 As Byte = 2
Private Const gcbyValeur As Byte = 3
 
'Profondeur de recherche (aucune intérêt de rechercher plus en profondeur)
Private Const gcbyMinProf As Byte = 1
Private Const gcbyMaxProf As Byte = 5
 
Private Const gcbyMaxNombres As Byte = 6
Private Const gcbyMaxTab As Byte = gcbyMaxNombres + gcbyMaxProf - 1
 
Private Type tCompteEstBon
   alOperations(gcbyMinProf To gcbyMaxProf, gcbyl1 To gcbyValeur) As Long
   lMinEcart As Long
   lCount As Long
   byLastProf As Byte
End Type
 
'Fonction principale - Passage d'un tableau de nombre (1 to 6)
Public Function CEB(ByRef alNombres() As Long, ByVal lResultat As Long) As String
   Dim tCEB As tCompteEstBon
   Dim lTmp As Long, alValeurs(1 To gcbyMaxTab) As Long
   Dim i As Integer, j As Byte
   Dim sResultat As String
 
   Randomize
   For i = 1 To gcbyMaxNombres
      alValeurs(i) = alNombres(i)
   Next i
 
   'randomise l'ordre des nombres pour résultat aléatoire
   For i = gcbyMaxNombres - 1 To 2 Step -1
      j = Int(i * Rnd()) + 1
      lTmp = alNombres(i + 1)
      alNombres(i + 1) = alNombres(j)
      alNombres(j) = lTmp
   Next i
 
   tCEB.lMinEcart = 10 ^ 5
   
   'Algo principal de recherche de la solution
   ChercheCEB alNombres, lResultat, 1, tCEB
 
   'Préparation pour affichage
   With tCEB
      For i = gcbyMaxNombres + 1 To gcbyMaxNombres + .byLastProf - 1
         alValeurs(i) = .alOperations(i - gcbyMaxNombres, gcbyValeur)
      Next i
 
      If .lMinEcart = 0 Then
         sResultat = "Solution trouvée !"
      Else
         sResultat = "Compte Approché : " & .alOperations(.byLastProf, gcbyValeur)
      End If
      sResultat = sResultat & vbCrLf & "en " & .lCount & " essais"
      sResultat = sResultat & GetValideOperations(alValeurs, tCEB)
   End With
   CEB = sResultat
End Function
 
'Algo récursif v1.05 :
'-> optimisation vitesse
Private Sub ChercheCEB(ByRef alNombres() As Long, ByVal lResultat As Long, _
                       ByVal byProf As Byte, tCEB As tCompteEstBon)
   Dim fDiv As Single
   Dim l1 As Long, l2 As Long, lSaveEcart As Long, lSaveValeur As Long
   Dim i As Byte, j As Byte, k As Byte
 
   For i = 1 To gcbyMaxNombres
      If alNombres(i) > 0 Then
         l1 = alNombres(i)
         alNombres(i) = 0
         For j = i + 1 To gcbyMaxNombres
            If alNombres(j) > 0 Then
               l2 = alNombres(j)
               alNombres(j) = 0
               For k = 0 To 3
                  Select Case k
                  Case 0   '+
                     alNombres(i) = l1 + l2
                  Case 1   'x
                     If l1 > 1 And l2 > 1 And l1 < 10 ^ 4 And l2 < 10 ^ 4 Then
                        alNombres(i) = l1 * l2
                     End If
                  Case 2   '-
                     If l1 <> l2 Then alNombres(i) = Abs(l1 - l2)
                  Case Else   '/
                     If l1 > 1 And l2 > 1 Then
                        If l1 >= l2 Then
                           fDiv = l1 / l2
                        Else
                           fDiv = l2 / l1
                        End If
                        If fDiv = Int(fDiv) Then alNombres(i) = fDiv
                     End If
                  End Select
                  If alNombres(i) > 0 Then
                     tCEB.lCount = tCEB.lCount + 1
                     If Abs(alNombres(i) - lResultat) < tCEB.lMinEcart Then
                        tCEB.byLastProf = byProf
                        tCEB.lMinEcart = Abs(alNombres(i) - lResultat)
                        tCEB.alOperations(byProf, gcbyl1) = l1
                        tCEB.alOperations(byProf, gcbyOper) = k
                        tCEB.alOperations(byProf, gcbyl2) = l2
                        tCEB.alOperations(byProf, gcbyValeur) = alNombres(i)
                        If tCEB.lMinEcart = 0 Then Exit Sub
                     End If
                     If byProf < gcbyMaxProf Then
                        lSaveValeur = alNombres(i)
                        lSaveEcart = tCEB.lMinEcart
                        ChercheCEB alNombres, lResultat, byProf + 1, tCEB
                        If tCEB.lMinEcart < lSaveEcart Then
                           tCEB.alOperations(byProf, gcbyl1) = l1
                           tCEB.alOperations(byProf, gcbyOper) = k
                           tCEB.alOperations(byProf, gcbyl2) = l2
                           tCEB.alOperations(byProf, gcbyValeur) = lSaveValeur
                           If tCEB.lMinEcart = 0 Then Exit Sub
                        End If
                     End If
                     alNombres(i) = 0
                  End If
               Next k
               alNombres(j) = l2
            End If
         Next j
         alNombres(i) = l1
      End If
   Next i
End Sub
 
'Nettoyage des opérations (enlever celles qui ne sont pas utilisés, etc...)
Private Function GetValideOperations(ByRef alValeurs() As Long, ByRef tCEB As tCompteEstBon) As String
   Dim l As Long
   Dim j As Integer
   Dim i As Byte, k As Byte, byLastValeur As Byte, byCurValeur As Byte
   Dim sOpers As String
 
   With tCEB
      'Annule les nombres puis les opérations utilisés
      byLastValeur = gcbyMaxNombres + .byL