Option Explicit
Dim aPuntaRighe
Dim aPuntaPosEstr
Dim aNumeriEstr
Dim nQEstrazioni
Dim nPuntatore
Dim collComb
Sub Main
Dim idEstr,Ruota
Dim Inizio,Fine
ReDim aRuote(0)
ReDim aBRuote(0)
Dim nQRuoteSel
Dim k,j
Dim nClasse
Dim sRuoteInteressate,nQRuoteInteressate
Dim nComb
Dim nPassoMax
Dim sMsg
Dim bStesoPasso
Dim bOk
Set collComb = GetNewCollection
Fine = EstrazioneFin
nQEstrazioni = Int(InputBox("Quante estrazioni a partire dall'ultima","Estrazioni da analizzare",18))
nClasse = Int(InputBox("Quanti numeri da cercare ","Quantita numeri",3))
nPassoMax = Int(InputBox("Quante estrazioni di distanza massima tra un numero e il successivo ","Quantita numeri",1))
bStesoPasso = ScegliStessoPasso
nQRuoteSel = ScegliRuote(aRuote,aBRuote)
Call DoEventsEx
If nQRuoteSel >= 2 And nQEstrazioni >= nClasse And nClasse >= 3 And aBRuote(TU_) = False And nPassoMax > 0 Then
Call AlimentaEstrazioniDaAnalizzare
'\\\\\ TEST
' Call InitPuntatori(nClasse)
' ReDim aRetIdEstrInteressateA(nClasse)
'
' ReDim aRetNum(0)
' Do While GetCombinazione(aRetNum,nClasse,1 ,aRetIdEstrInteressateA)
' Call Scrivi(StringaNumeri(aRetNum))
' If ScriptInterrotto Then Exit Do
'
' Loop
' Exit Sub
'
For k = 1 To nQRuoteSel - 1
Call InitPuntatori(nClasse)
ReDim aRetNum(0)
nComb = 0
ReDim aRetIdEstrInteressateA(nClasse)
ReDim aRetIdEstrInteressateB(nClasse)
Do While GetCombinazione(aRetNum,nClasse,aRuote(k),aRetIdEstrInteressateA ,nPassoMax)
nComb = nComb + 1
If contaNumeriDiversi(aRetNum) = nClasse Then
If VerificaPasso (aRetIdEstrInteressateA , nPassoMax )Then
sRuoteInteressate = SiglaRuota(aRuote(k)) & " " & GetInfoEstrInteressate(aRetIdEstrInteressateA)
nQRuoteInteressate = 1
For j = k + 1 To nQRuoteSel
If SequenzaPresente(aRetNum,aRuote(j),nClasse,aRetIdEstrInteressateB) Then
If VerificaPasso (aRetIdEstrInteressateB , nPassoMax ) Then
bOk = True
If bStesoPasso Then
bOk = VerificaStessoPasso (aRetIdEstrInteressateA ,aRetIdEstrInteressateB )
End If
If bOk Then
sRuoteInteressate = sRuoteInteressate & " " & SiglaRuota(aRuote(j)) & " " & GetInfoEstrInteressate(aRetIdEstrInteressateB)
nQRuoteInteressate = nQRuoteInteressate + 1
End If
End If
End If
Next
If nQRuoteInteressate > 1 Then
If AddItemInColl (SiglaRuota(aRuote(k)) & StringaNumeri (aRetNum)) Then
Call Scrivi("Sequenza " & StringaNumeri(aRetNum,,True) & " presente su " & sRuoteInteressate)
End If
End If
End If
End If
If ScriptInterrotto Then Exit Do
If nComb Mod 100 = 0 Then
Call Messaggio(nComb)
End If
Loop
If ScriptInterrotto Then Exit For
Call AvanzamentoElab(1,nQRuoteSel - 1,k)
Next
Else
sMsg = "Parametri non corretti" & vbCrLf
sMsg = sMsg & "Selezionare almeno due ruote" & vbCrLf
sMsg = sMsg & "Cercare almeno tre numeri" & vbCrLf
sMsg = sMsg & "Il valore distanza in estrazioni tra un numero e il successivo deve essere maggiore di 0" & vbCrLf
sMsg = sMsg & "Non selezionare la ruota Tutte"
MsgBox sMsg ,vbCritical
End If
End Sub
Function AddItemInColl (sKey)
On Error Resume Next
collComb.Add sKey ,sKey
If Err =0 Then
AddItemInColl = True
Else
Err.Clear
End If
End Function
Function SequenzaPresente(aNum,nRuota,nClasse,aRetIdEstrInteressate)
Dim idEstr,e,p,bFound
Dim nPuntaNum,nLastEstr
p = 0
nLastEstr = 0
ReDim aRetIdEstrInteressate(nClasse)
For nPuntaNum = 1 To nClasse
For idEstr = nLastEstr + 1 To nQEstrazioni
bFound = False
For e = 1 To 5
If aNumeriEstr(idEstr,nRuota,e) = aNum(nPuntaNum) Then
p = p + 1
bFound = True
Exit For
End If
Next
If bFound Then
aRetIdEstrInteressate(nPuntaNum) = idEstr
nLastEstr = idEstr
Exit For
End If
Next
Next
If p = nClasse Then
SequenzaPresente = True
Else
SequenzaPresente = False
End If
End Function
Sub AlimentaEstrazioniDaAnalizzare()
Dim idEstr,nInizio,nFine,e,r,n
ReDim aNumeriEstr(nQEstrazioni,12,5)
nFine = EstrazioneFin
nInizio =(nFine - nQEstrazioni) + 1
For idEstr = nInizio To nFine
n = n + 1
aNumeriEstr(n,0,0) = idEstr
For r = 1 To 12
If r <> 11 Then
For e = 1 To 5
aNumeriEstr(n,r,e) = Estratto(idEstr,r,e)
Next
End If
Next
Next
End Sub
Sub InitPuntatori(nClasse)
Dim K
ReDim aPuntaRighe(nClasse)
ReDim aPuntaPosEstr(nClasse)
For K = 1 To UBound(aPuntaRighe) - 1
aPuntaRighe(K) = K
aPuntaPosEstr(K) = 1
Next
aPuntaRighe(K) = K
aPuntaPosEstr(K) = 0
nPuntatore = UBound(aPuntaRighe)
End Sub
Function IncrementaPuntatori(nClasse , nPassoMax )
Dim nNewPos,nNewRiga
Dim k,j
Dim bRet
Do
For k = nClasse To 1 Step - 1
nNewPos = aPuntaPosEstr(k) + 1
If nNewPos <= 5 Then
aPuntaPosEstr(k) = nNewPos
nNewRiga = aPuntaRighe(k)
For j = k + 1 To nClasse
aPuntaPosEstr(j) = 1
nNewRiga = nNewRiga + 1
aPuntaRighe(j) = nNewRiga
Next
'IncrementaPuntatori = True
'Exit Function
bRet = True
Exit For
Else
nNewRiga = aPuntaRighe(k) + 1
If(nNewRiga +(nClasse - k)) <= nQEstrazioni Then
For j = k To nClasse
aPuntaRighe(j) = nNewRiga
nNewRiga = nNewRiga + 1
aPuntaPosEstr(j) = 1
Next
' IncrementaPuntatori = True
' Exit Function
bRet = True
Exit For
End If
End If
Next
If bRet Then
If VerificaPasso (aPuntaRighe , nPassoMax) Then
Exit Do
Else
bRet = False
End If
Else
Exit Do
End If
Loop
IncrementaPuntatori = bRet
End Function
Function GetCombinazione(aNum,nClasse,nRuota,aRetIdEstrInteressate, nPassoMax)
Dim k,nRiga,nPos,s
ReDim aNum(nClasse)
ReDim aRetIdEstrInteressate(nClasse)
If IncrementaPuntatori(nClasse ,nPassoMax) Then
For k = 1 To nClasse
nRiga = aPuntaRighe(k)
nPos = aPuntaPosEstr(k)
aNum(k) = aNumeriEstr(nRiga,nRuota,nPos)
aRetIdEstrInteressate(k) = nRiga
Next
GetCombinazione = True
Else
GetCombinazione = False
End If
End Function
Function contaNumeriDiversi(aNum)
ReDim aB(90)
Dim k,p
p = 0
For k = 1 To UBound(aNum)
If Not aB(aNum(k)) Then
aB(aNum(k)) = True
p = p + 1
End If
Next
contaNumeriDiversi = p
End Function
Function GetInfoEstrInteressate(aIdEstr)
Dim s,k
s = "("
For k = 1 To UBound(aIdEstr)
s = s & aNumeriEstr(aIdEstr(k),0,0) & " - "
Next
s = RimuoviLastChr(s," - ") & ")"
GetInfoEstrInteressate = s
End Function
Function VerificaPasso (aIdEstr , nPassoMax )
Dim k
Dim bRet
bRet = True
For k = UBound(aIdEstr) To 2 Step -1
If aIdEstr (k) - aIdEstr (k-1) >nPassoMax Then
bRet = False
Exit For
End If
Next
VerificaPasso = bRet
End Function
Function VerificaStessoPasso (aIdA ,aIdB )
Dim k
Dim bRet
bRet = True
For k = UBound(aIdA) To 2 Step -1
If aIdA (k) - aIdA (k-1) <> aIdB (k) - aIdB (k-1)Then
bRet = False
Exit For
End If
Next
VerificaStessoPasso = bRet
End Function
Function ScegliStessoPasso
ReDim aVoci (1)
Dim i
aVoci(0) = "Sequenze con stesso passo"
aVoci(1) = "Sequenze qualsiasi"
i= ScegliOpzioneMenu( aVoci ,0)
If i = 0 Then
ScegliStessoPasso = True
Else
ScegliStessoPasso = False
End If
End Function
