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 + .byLastProf - 1 byCurValeur = gcbyl1 For i = 1 To 2 For j = .byLastProf To 1 Step -1 l = .alOperations(j, byCurValeur) For k = 1 To byLastValeur If l = alValeurs(k) Then alValeurs(k) = 0 Exit For End If Next k Next j byCurValeur = gcbyl2 Next i 'Création des opérations valides For i = 1 To .byLastProf - 1 If alValeurs(i + gcbyMaxNombres) = 0 Then sOpers = sOpers & vbCrLf & GetOperation(i, tCEB) Next i GetValideOperations = sOpers & vbCrLf & GetOperation(i, tCEB) End With End Function 'Création de l'opération Private Function GetOperation(ByVal byProf As Byte, ByRef tCEB As tCompteEstBon) As String Dim sOp As String Dim lTmp As Long With tCEB Select Case .alOperations(byProf, gcbyOper) Case 0 sOp = " + " Case 1 sOp = " x " Case 2 sOp = " - " If .alOperations(byProf, gcbyl2) > .alOperations(byProf, gcbyl1) Then lTmp = .alOperations(byProf, gcbyl2) .alOperations(byProf, gcbyl2) = .alOperations(byProf, gcbyl1) .alOperations(byProf, gcbyl1) = lTmp End If Case Else sOp = " / " If .alOperations(byProf, gcbyl2) > .alOperations(byProf, gcbyl1) Then lTmp = .alOperations(byProf, gcbyl2) .alOperations(byProf, gcbyl2) = .alOperations(byProf, gcbyl1) .alOperations(byProf, gcbyl1) = lTmp End If End Select GetOperation = .alOperations(byProf, gcbyl1) & sOp & .alOperations(byProf, gcbyl2) & _ " = " & .alOperations(byProf, gcbyValeur) End With End Function