Follow along with the video below to see how to install our site as a web app on your home screen.
Nota: This feature may not be available in some browsers.
Option Explicit
Sub Main
Dim aColonne
Dim k , y , sBuf
Dim nClasse
ReDim aNumeri (10)
For k = 1 To 10
aNumeri (k) = k
Next
nClasse = 2
Scrivi "Senza ripetizioni"
Scrivi Permutazioni ( 10 ,nClasse)
aColonne = SviluppoPermutazioni ( aNumeri ,nClasse)
Call ScriviColonne ( aColonne , nClasse)
Scrivi
Scrivi "Con ripetizioni"
Scrivi Permutazioni ( 10 ,2,False)
aColonne = SviluppoPermutazioni ( aNumeri ,nClasse, False)
Call ScriviColonne ( aColonne , nClasse)
End Sub
Sub ScriviColonne (aColonne, nClasse)
Dim k , y , sbuf
For k = 1 To UBound(aColonne)
sbuf = FormattaStringa( k , "0000")& ") "
For y = 1 To nClasse
sbuf = sbuf & Format2(aColonne(k ,y)) & "."
Next
Call Scrivi ( RimuoviLastChr( sbuf , "."))
Next
End Sub
Beppignello;n1966676 ha scritto:
.
Cordiali saluti
Beppignello;n1966908 ha scritto:
GRAZIE
Option Explicit
Sub Main
Dim aNumeri , aCol , aSubCol
Dim clsSvil , clsSvil2
Dim nClasseSvil , nClasseSubSvil
Dim i , ii
Set clsSvil = GetMotoreSviluppoIntegrale
Set clsSvil2 = GetMotoreSviluppoIntegrale
nClasseSvil = 3
nClasseSubSvil = 2
aNumeri = GetANumeri
Call clsSvil.InitSviluppoIntegrale(aNumeri ,nClasseSvil)
Do While clsSvil.GetCombSviluppo(aCol)
i = i +1
Call Scrivi (FormattaStringa(i , "0000") & ") " & StringaNumeri (aCol ))
Call clsSvil2.InitSviluppoIntegrale(aCol ,nClasseSubSvil)
ii =0
Do While clsSvil2.GetCombSviluppo(aSubCol)
ii = ii +1
Call Scrivi (" ---> " & FormattaStringa(ii , "0000") & ") " & StringaNumeri (aSubCol ))
Loop
If i > 10 Then Exit Do
Loop
End SubOption Explicit
Sub Main
Dim aNumeri , aCol , aSubCol
Dim clsSvil , clsSvil2
Dim nClasseSvil , nClasseSubSvil
Dim i , ii
Set clsSvil = GetMotoreSviluppoIntegrale
Set clsSvil2 = GetMotoreSviluppoIntegrale
nClasseSvil = 3
nClasseSubSvil = 2
aNumeri = GetANumeri
Call clsSvil.InitSviluppoIntegrale(aNumeri ,nClasseSvil)
Do While clsSvil.GetCombSviluppoRid(aCol ,2)
i = i +1
Call Scrivi (FormattaStringa(i , "0000") & ") " & StringaNumeri (aCol ))
Call clsSvil2.InitSviluppoIntegrale(aCol ,nClasseSubSvil)
ii =0
Do While clsSvil2.GetCombSviluppo(aSubCol)
ii = ii +1
Call Scrivi (" ---> " & FormattaStringa(ii , "0000") & ") " & StringaNumeri (aSubCol ))
Loop
Loop
End SubOption Explicit
Class clsCombinazione
Private m_UltEstUscita
Private m_Key
Private m_aNum
Private m_Classe
Private m_Index
Private m_aBNum
Sub Class_Initialize
' codice
End Sub
Sub Class_Terminate
' codice
End Sub
Public Property Get Index
Index = m_Index
End Property
Public Property Let Index(NewValue)
m_Index = NewValue
End Property
Public Property Get Classe
Classe = m_Classe
End Property
Public Property Let Classe(NewValue)
m_Classe = NewValue
End Property
Public Property Get Key
Key = m_Key
End Property
Public Property Let Key(NewValue)
m_Key = NewValue
End Property
Public Property Get aNum
aNum = m_aNum
End Property
Public Property Let aNum(NewValue)
m_aNum = NewValue
End Property
Public Property Get UltEstUscita
UltEstUscita = m_UltEstUscita
End Property
Public Property Let UltEstUscita(NewValue)
m_UltEstUscita = NewValue
End Property
Function GetStringaNum
GetStringaNum = StringaNumeri(m_aNum,,True)
End Function
Function IsNumeroPresente(N)
IsNumeroPresente = m_aBNum(N)
End Function
Sub RefreshABnum
ReDim m_abnum(90)
Dim k
For k = 1 To 90
m_abnum(k) = False
Next
For k = 1 To UBound(m_aNum)
m_abnum(m_aNum(k)) = True
Next
End Sub
End Class
Sub Main
Dim collCombBase,CollLunghette,collLungTrov,nSorte,aRuote,Ini,fin,sMsg,nMoltip
Dim nCicloTeo,nRitMax,nClasseLunghetta,nRuoteSel,nLunghetteDaTrov,nCombBaseTrov
Dim clsComb,clsCombTmp,clsLunghette,TipoMetodo
Dim cItem,cItemNew,sKey,nTrovate
Dim i,nTrov,nIndexMax,bFound,k,nIniTmp
Dim TimeStart
TipoMetodo = 2
nTrov = 0
nSorte = ScegliEsito
nClasseLunghetta = ScegliClassseLunghetta
nRuoteSel = SelRuote(aRuote)
nLunghetteDaTrov = Int(InputBox("Lunghette da trovare","Quantità lunghette",1))
ReDim Preserve aRuote(nRuoteSel)
nCicloTeo = CicloTeorico(nClasseLunghetta,nSorte,UBound(aRuote))
nMoltip = 30
sMsg = "Inserire il ritardo massimo ipotizzato per la sorte voluta nella lunghetta" & vbCrLf
sMsg = sMsg & "Il valore mostrato è il CicloTeorico per la sorte di " & nSorte
sMsg = sMsg & " su " & nClasseLunghetta & " numeri su " & nRuoteSel & " ruote moltiplicato per " & nMoltip
nRitMax = Int(InputBox(sMsg,,nCicloTeo * nMoltip))
fin = EstrazioneFin
Ini = fin - nRitMax
If Ini <= 0 Then Ini = 1
TimeStart = Timer
Call Messaggio("Individua le combinazioni di classe " & nSorte & " uscite nel periodo")
Call AlimentaCollCombUscite(collCombBase,nSorte,aRuote,Ini,fin)
nCombBaseTrov = collCombBase.count
Call Messaggio("Ordinamento per ritardo delle combinazioni trovate " & nCombBaseTrov)
Call OrdinaItemCollection(collCombBase,"UltEstUscita","Key",,1)
Call Messaggio("Imposta posizioni classifica ritardi")
Call ImpostaPosizioni(collCombBase,nIndexMax)
sMsg = "Le combinazioni base di classe " & nSorte
sMsg = sMsg & " (uscite nel periodo analizzato di " & nRitMax & " estrazioni) "
sMsg = sMsg & " sono " & nCombBaseTrov
sMsg = sMsg & " sulle ruote " & StringaRuote(aRuote)
Call Scrivi(sMsg)
Call Scrivi
Set collLungTrov = GetNewCollection
i = 0
nTrovate = 0
For Each clsComb In collCombBase
i = i + 1
Call Messaggio("Radice " & clsComb.GetStringaNum & " Pos " & clsComb.Index & "/" & nIndexMax & " (" & i & "/" & nCombBaseTrov & ")")
If TipoMetodo = 1 Then
bFound = InitCercaLunghetta(collCombBase,clsComb,nSorte,nClasseLunghetta,CollLunghette,collLungTrov)
ElseIf TipoMetodo = 2 Then
bFound = InitCercaLunghetta2(collCombBase,clsComb,nSorte,nClasseLunghetta,CollLunghette,collLungTrov)
End If
If bFound Then nTrovate = nTrovate + 1
'If collLungTrov.count >= nLunghetteDaTrov Then Exit For
If nTrovate >= nLunghetteDaTrov Then Exit For
Call AvanzamentoElab(1,nCombBaseTrov,i)
If ScriptInterrotto Then Exit For
Next
For Each clsComb In collLungTrov
Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita & " - Rit " & RitardoCombinazioneTurbo(aRuote,clsComb.aNum,nSorte,fin))
Next
Call Scrivi("Tempo di elaborazione : " & FormattaSecondi(Timer - TimeStart))
End Sub
Function InitCercaLunghetta(collCombBase,cItemBase,nSorte,nClasseLunghetta,collLunghette,collLungTrov)
Dim nClasseTmp,nTrovate,nDaFare,nFatte,IndexBase
Dim aNumSvil,aCol,aColNew,N,sKey,cItem,cItemNew,cItemTmp,bValida,CollTmp
Set collLunghette = GetNewCollection
IndexBase = cItemBase.Index
nClasseTmp = nSorte + 1
For N = 1 To 90
aNumSvil = cItemBase.anum
'If PuntiSuArray(aNumSvil,aN) = 0 Then
If cItemBase.IsNumeroPresente(N) = False Then
bValida = True
Call InitSviluppoIntegrale(aNumSvil,nSorte - 1)
Do While GetCombSviluppo(aCol)
aColNew = aCol
ReDim Preserve aColNew(nSorte)
aColNew(nSorte) = N
Call OrdinaMatriceTurbo(aColNew,1)
sKey = "k" & StringaNumeri(aColNew,,True)
If GetItemCollection(collCombBase,sKey,cItem) Then
If cItem.Index > IndexBase Then
bValida = False
Exit Do
End If
End If
Loop
If bValida Then
ReDim Preserve aNumSvil(nClasseTmp)
aNumSvil(nClasseTmp) = N
Call OrdinaMatriceTurbo(aNumSvil,1)
Set cItem = New clsCombinazione
cItem.Index = IndexBase
cItem.aNum = aNumSvil
Call cItem.RefreshABnum
'collLunghette.Add cItem
sKey = "k" & StringaNumeri(aNumSvil,,True)
Call AddItemColl(collLunghette,cItem,sKey)
End If
End If
Next
Do While nClasseTmp < nClasseLunghetta
nClasseTmp = nClasseTmp + 1
Set CollTmp = GetNewCollection
nTrovate = 0
nDaFare = collLunghette.count
nFatte = 0
For Each cItem In collLunghette
For N = 1 To 90
aNumSvil = cItem.aNum
'If PuntiSuArray (aNumSvil , aN) = 0 Then
If cItem.IsNumeroPresente(N) = False Then
bValida = True
Call InitSviluppoIntegrale(aNumSvil,nSorte - 1)
Do While GetCombSviluppo(aCol)
aColNew = aCol
ReDim Preserve aColNew(nSorte)
aColNew(nSorte) = N
Call OrdinaMatriceTurbo(aColNew,1)
sKey = "k" & StringaNumeri(aColNew,,True)
If GetItemCollection(collCombBase,sKey,cItemTmp) Then
If cItemTmp.Index > IndexBase Then
bValida = False
Exit Do
End If
End If
Loop
If bValida Then
ReDim Preserve aNumSvil(nClasseTmp)
aNumSvil(nClasseTmp) = N
Call OrdinaMatriceTurbo(aNumSvil,1)
Set cItemNew = New clsCombinazione
cItemNew.Index = IndexBase
cItemNew.aNum = aNumSvil
Call cItemNew.RefreshABnum
sKey = "k" & StringaNumeri(aNumSvil,,True)
If AddItemColl(CollTmp,cItemNew,sKey) Then
nTrovate = nTrovate + 1
End If
End If
End If
Next
'nFatte = nFatte + 1
'Call AvanzamentoElab(1,nDaFare,nFatte)
If ScriptInterrotto Then Exit Do
Next
If nTrovate = 0 Then Exit Do
If ScriptInterrotto Then Exit Do
Set collLunghette = CollTmp
Loop
If nTrovate > 0 Then
For Each cItem In collLunghette
Set cItemNew = New clsCombinazione
cItemNew.aNum = cItem.aNum
cItemNew.Classe = cItem.Classe
cItemNew.Index = cItem.Index
cItemNew.UltEstUscita = cItem.UltEstUscita
collLungTrov.Add cItemNew
Next
InitCercaLunghetta = True
End If
End Function
Function InitCercaLunghetta2(collCombBase,cItemBase,nSorte,nClasseLunghetta,collLunghette,collLungTrov)
Dim cItemTmp,cItemTmp2,IndexBase,aNumBase,aNumTmp,aColNew
Dim CollTmp,cItemNew,cItem,sKey,nTrovate
Dim k,y,i
Dim nClasseTmp,collLunghetteTmp,aCol,bValida
Set collLunghette = GetNewCollection
collLunghette.Add cItemBase
IndexBase = cItemBase.Index
aNumBase = cItemBase.aNum
nTrovate = 0
nClasseTmp = nSorte
Do While nClasseTmp < nClasseLunghetta
nTrovate = 0
Set collLunghetteTmp = GetNewCollection
ReDim abLunghUsate(collCombBase.count)
For Each cItem In collLunghette
aNumBase = cItem.aNum
i = 0
For Each cItemTmp In collCombBase
i = i + 1
If Not abLunghUsate(i) Then
abLunghUsate(i) = True
If cItemTmp.Index <= IndexBase Then
aNumTmp = cItemTmp.aNum
If PuntiSuArray(aNumBase,aNumTmp) = nSorte - 1 Then
ReDim aB(90)
For k = 1 To nSorte
aB(aNumTmp(k)) = True
Next
For k = 1 To UBound(aNumBase)
aB(aNumBase(k)) = True
Next
Call ArrayBNumToArrayNum(aB,aColNew)
Call InitSviluppoIntegrale(aColNew,nSorte)
bValida = True
Do While GetCombSviluppo(aCol)
sKey = "k" & StringaNumeri(aCol,,True)
If GetItemCollection(collCombBase,sKey,cItemTmp2) Then
If cItemTmp2.Index > IndexBase Then
bValida = False
Exit Do
End If
End If
Loop
If bValida Then
'abLunghUsate ( i) = True
Set cItemNew = New clsCombinazione
cItemNew.Index = IndexBase
cItemNew.aNum = aColNew
Call cItemNew.RefreshABnum
sKey = "k" & StringaNumeri(aColNew,,True)
If AddItemColl(collLunghetteTmp,cItemNew,sKey) Then
nTrovate = nTrovate + 1
End If
End If
End If
Else
Exit For
End If
End If
Next
Next
If nTrovate > 0 Then
Set collLunghette = collLunghetteTmp
nClasseTmp = nClasseTmp + 1
Else
Exit Do
End If
Loop
If nClasseTmp = nClasseLunghetta Then
For Each cItem In collLunghette
Set cItemNew = New clsCombinazione
cItemNew.aNum = cItem.aNum
cItemNew.Classe = cItem.Classe
cItemNew.Index = cItem.Index
cItemNew.UltEstUscita = cItem.UltEstUscita
collLungTrov.Add cItemNew
Next
InitCercaLunghetta2 = True
End If
End Function
Sub ImpostaPosizioni(coll,nRetIndexMax)
Dim i,nLastEstUscita,clsComb
i = 0
nLastEstUscita = 0
For Each clsComb In coll
If clscomb.UltEstUscita <> nLastEstUscita Then
i = i + 1
End If
nLastEstUscita = clscomb.UltEstUscita
clsComb.Index = i
Next
nRetIndexMax = i
End Sub
Sub AlimentaCollCombUscite(coll,nSorteCerc,aRuote,Ini,Fin)
Dim idEstr,r,k,nCombSvil,sKey
Dim clsComb
ReDim aColonne(0)
ReDim aNum(0)
ReDim aCol(0)
nCombSvil = Combinazioni(5,nSorteCerc)
Set coll = GetNewCollection
For idEstr = Ini To Fin
For r = 1 To UBound(aRuote)
Call GetArrayNumeriRuota(idEstr,aRuote(r),aNum)
Call OrdinaMatrice(aNum,1)
Call InitSviluppoIntegrale(aNum,nSorteCerc)
Do While GetCombSviluppo(aCol)
sKey = "k" & StringaNumeri(aCol,,True)
Call GetClsComb(coll,sKey,clsComb,aCol,nSorteCerc)
clsComb.UltEstUscita = idEstr
Loop
Next
Call AvanzamentoElab(Ini,Fin,idEstr)
If ScriptInterrotto Then Exit For
Next
End Sub
Function GetClsComb(coll,sKey,clsComb,aCol,nClasse)
On Error Resume Next
Set clsComb = coll(sKey)
If Err <> 0 Then
Err.Clear
Set clsComb = New clsCombinazione
clsComb.Key = sKey
clsComb.aNum = aCol
clsComb.Classe = nClasse
clsComb.RefreshABnum
Call coll.Add(clsComb,sKey)
GetClsComb = False
Else
GetClsComb = True
End If
End Function
Function ScegliClassseLunghetta
Dim aVoci(30)
Dim k,i
For k = 2 To(2 - 1) + UBound(aVoci)
i = i + 1
aVoci(i) = k
Next
k = ScegliOpzioneMenu(aVoci,5,"Classe lunghetta")
ScegliClassseLunghetta = Int(aVoci(k))
End Function
Function SelRuote(aRuote)
Dim t,k,bTutte
bTutte = False
t = ScegliRuote(aRuote)
For k = 1 To t
If aRuote(k) = TT_ Then
bTutte = True
Exit For
End If
Next
If bTutte Then
ReDim aRuote(10)
For k = 1 To 10
aRuote(k) = k
Next
SelRuote = 10
Else
SelRuote = t
End If
End Function
Function FormattaSecondi(s)
'Questa Function trasforma il numero di secondi passato come parametro in una stringa
' passando i secondi si ottengono ore minuti e secondi in formato hh:mm:ss
' s ---> Numero di secondi da formattare
' ritorna una stringa il cui formato è hh:mm:ss (la function non funziona se in totale abbiamo piu di 99 ore )
Dim hh
Dim Mm
Dim Ss
Dim TimeStr
hh = s \ 3600
Mm =(s Mod 3600) \ 60
Ss = s -((hh * 3600) +(Mm * 60))
TimeStr = Format2(hh) & ":" & Format2(Mm) & ":" & Format2(Ss)
FormattaSecondi = TimeStr
End Function
