Option Explicit
'Si può fare di meglio? di fillotto
'https://forum.lottoced.com/forum/lottoced/area-download/2133073-si-pu%C3%B2-fare-di-meglio
'messaggio #39
Dim clsHSS
Class clsCombinazione
Private aNum
Private aBNum
Private mFrequenze
Private mPresenze
Private mClasse
Private mKey
Private aIdEstr
Private nTrov
Private Sub Class_Initialize()
mFrequenze = 00
mPresenze = 00
ReDim aBnum(90)
End Sub
Public Property Get Classe
Classe = mClasse
End Property
Public Property Let Classe(v)
mClasse = v
End Property
Public Property Get ArrayNum
ArrayNum = aNum
End Property
Public Property Get Key
Key = mKey
End Property
Public Property Let Key(v)
mKey = v
End Property
Public Property Get Presenze
Presenze = mPresenze
End Property
Public Property Get Frequenze
Frequenze = mFrequenze
End Property
Public Property Get Combinazione
Combinazione = StringaNumeri(aNum,,True)
End Property
Sub IncrementaFrequenze
mFrequenze = mFrequenze + 01
End Sub
Sub SetNumeri(aNumTmp)
Dim k
aNum = aNumTmp
For k = 01 To UBound(aNum)
aBNum(aNum(k)) = True
Next
End Sub
Sub CalcolaFrequenza(aRuote,nSorte,nIni,nFin)
'mFrequenze = SerieFreqTurbo(nIni,nFin,aNum,aRuote,nSorte)
mFrequenze = clsHSS.SerieFreq(nIni,nFin,aNum,aRuote,nSorte)
End Sub
Sub CalcolaPresenze(aRuote,nSorte,Inizio,Fine)
Dim k,r,e,nPunti,aNumRuota,nPresenze
Dim aB
nPresenze = 00
For k = Inizio To Fine
For r = 01 To UBound(aRuote)
Call GetArrayNumeriRuota(k,aRuote(r),aNumRuota)
nPunti = 00
For e = 01 To 05
If aBNum(aNumRuota(e)) Then
nPunti = nPunti + 01
End If
Next
If nPunti >= nSorte Then
nPresenze = nPresenze + 01
End If
Next
Next
mPresenze = nPresenze
End Sub
Sub AddIdEstr(v)
nTrov = nTrov + 01
ReDim Preserve aIdEstr(nTrov)
aIdEstr(nTrov) = v
End Sub
End Class
Private aEstrattiBool
Sub Main
Dim sFileBd
sFileBd = GetDirectoryAppData & "BaseDati.dat"
Set clsHSS = CreateObject("HSS.ClsHighSpeedStat")
Call clsHSS.Init(sFileBd,01)
'
Dim nEstrDaUSare,nClasse,nSorte,CollLunghette,nIni,nFin,k
nEstrDaUSare = 18
'
nClasse = ScegliClasse()' 7'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
nSorte = ScegliSorte()' 2'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ReDim aRuote(10)
' For k = 01 To 10
' aRuote (k) = k
' Next
ReDim aRuote(01)
aRuote(01) = SelRuote(aRuote)' FI_''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
nIni =(EstrazioneFin - nEstrDaUSare) + 01
nFin = EstrazioneFin
Set CollLunghette = GetCollLunghettaMigliori(nIni,nFin,nClasse,nSorte,aRuote,nEstrDaUSare)
Call AlimentaTabOutput(CollLunghette,aRuote,nClasse,nSorte)
Set clsHSS = Nothing : Call MsgBox(TempoTrascorso)
End Sub
Sub AlimentaTabOutput(CollLunghette,aRuote,nClasse,nSorte)
Dim av,cLung
Call Scrivi("Ruote : " & StringaRuote(aRuote))
Call Scrivi("Classe : " & nClasse)
Call Scrivi("Sorte : " & nSorte)
Call Scrivi("Tempo Trascorso : " & TempoTrascorso)
av = Array("","Lunghetta","Frequenza","Presenza")
Call InitTabella(av)
For Each cLung In CollLunghette
av(01) = cLung.Combinazione
av(02) = cLung.Frequenze
av(03) = cLung.Presenze
Call AddRigaTabella(av)
Next
Call ScegliTipoTabella()
End Sub
Function GetCollLunghettaMigliori(Inizio,Fine,nClasse,nSorte,aRuote,nEstrUsate)
Dim CollComb,cComb
Dim CollLung,cLung
Dim k,j,e
Dim nFatte,nDaFare
Dim nRetFrequenze
Dim sKey
ReDim aCol(nSorte)
ReDim abNumValidi(90)
ReDim aEstrattiBool(nEstrUsate,12,90)
Call AlimentaArrayEstrattiBool(aEstrattiBool,Inizio,Fine,aRuote)
Set CollComb = GetNewCollection
Set CollLung = GetNewCollection
' alimento una collection con tutte le combinazioni di classe <nSorte> che si
' formano con le cinquine comprese nel range interessato
' di ogni singola combinazione si calcolano le frequenze
For k = Inizio To Fine
For j = 01 To UBound(aRuote)
ReDim aNum(00)
Call GetArrayNumeriRuota(k,aRuote(j),aNum)
For e = 01 To 05
abNumValidi(aNum(e)) = True
Next
Call OrdinaMatriceTurbo(aNum,01)
Call InitSviluppoIntegrale(aNum,nSorte)
Do While GetCombSviluppo(aCol)
sKey = "k" & StringaNumeri(aCol,,True)
If GetItemCollection(CollComb,sKey,cComb) Then
cComb.IncrementaFrequenze
Else
Set cComb = New clsCombinazione
cComb.Classe = nSorte
cComb.SetNumeri(aCol)
cComb.key = sKey
cComb.IncrementaFrequenze
Call AddItemColl(CollComb,cComb,sKey)
End If
Loop
Next
Call AvanzamentoElab(Inizio,Fine,k)
Next
Call AvanzamentoElab(Inizio,Fine,Inizio)
' ordino la collection contenente tutte le combinazioni di classe <nSorte> per il valore frequenza
Call OrdinaItemCollection(CollComb,"Frequenze","Key")
' da ognuna delle combinazioni base scasturirà una lunghetta quindi ciclo su tutte
' le combinazioni base presenti nella collection e per ciascuna costruirò una lunghetta
nDaFare = CollComb.count
nFatte = 00
For Each cComb In CollComb
ReDim aRetCol(nClasse)
' ottiene la lunghetta "migliore" che contiene la combinazione base
If GetLung(cComb,aRetCol,nRetFrequenze,CollComb,Inizio,Fine,aRuote,nSorte,nClasse,abNumValidi,nEstrUsate) Then
' aggiungo la lunghetta trovata in una nuova collection
Set cLung = New clsCombinazione
cLung.Classe = nClasse
Call OrdinaMatriceTurbo(aRetCol,01)
cLung.SetNumeri(aRetCol)
sKey = "k" & StringaNumeri(aRetCol,,True)
Call cLung.CalcolaFrequenza(aRuote,nSorte,Inizio,Fine)
Call cLung.CalcolaPresenze(aRuote,nSorte,Inizio,Fine)
Call AddItemInColl(cLung,sKey,CollLung)
End If
nFatte = nFatte + 01
If nFatte Mod 10 = 00 Then
Call Messaggio(nFatte)
Call AvanzamentoElab(1,nDaFare,nFatte)
If ScriptInterrotto Then Exit For
Call DoEventsEx()
End If
Next
' ordino la collection delle lunghette trovate per poi mostrarle in output
Call OrdinaItemCollection(CollLung,"Presenze")
Set GetCollLunghettaMigliori = CollLung
End Function
Sub AlimentaArrayEstrattiBool(aEstrattiBool,Inizio,Fine,aRuote)
Dim idEstr,i,r,e
ReDim aNum(05)
For idEstr = Inizio To Fine
i = i + 01
For r = 01 To UBound(aRuote)
Call GetArrayNumeriRuota(idEstr,aRuote(r),aNum)
For e = 01 To 05
aEstrattiBool(i,aRuote(r),aNum(e)) = True
Next
Next
Next
End Sub
Sub AddItemInColl(cItem,sKey,Coll)
On Error Resume Next
Coll.Add cItem,sKey
If Err <> 00 Then Err.Clear
End Sub
Function GetLung(cComb,aRetCol,nRetPres,collComb,Inizio,Fine,aRuote,nSorte,nClasse,abNumValidi,nQtEstrUsate)
' a partire dalla combinazione base costruisce la lunghetta migliore (piu prolifica per presenze)
Dim nPos,n,nPresMax,nNum,nPresTmp,k,aNumBase
Dim aNumDaSvil,nQtNumDaSvil,aColDaPrendere,bFound
ReDim aBUsati(90)
Dim objSvil
Dim sKey
Dim cCombTmp
Dim nClasseSvilTmp
' inizializzo un nuovo motore di sviluppo
Set objSvil = GetMotoreSviluppoIntegrale
' leggo i numeri della combinazione base
aNumBase = cComb.ArrayNum
For k = 01 To cComb.Classe
aRetCol(k) = aNumBase(k)
aBUsati(aRetCol(k)) = True
Next
' faccio in clclo che dura fino a quando la lunghetta non arriva a contenere la quantità
' di numeri voluta
' la lunghetta parte con i numeri della combinazione base
' i numeri vengono aggiunti sviluppandoli con combinazioni di classe <nSorte>
' al termine del ciclo do sia avrà la combinazione migliore da aggiungere
' alla lunghetta base
' il giro continua finche la lunghetta non raggiunge la quantita di numeri voluti
nPos = cComb.Classe
Do While nPos < nClasse
' calcolo la classe per sviluppare le combinazioni da testare insieme ai numeri gia presenti
' nella lunghetta
' se possibile la classe di sviluppo è pari a <nSorte> senno viene calcolata e assume un valore inferiore
If nClasse - nPos >= nSorte Then
nClasseSvilTmp = nSorte
Else
nClasseSvilTmp = nClasse - nPos
End If
' predispongo la lunghetta per accogliere i numeri che otterremo dallo sviluppo
ReDim Preserve aRetCol(nPos + nClasseSvilTmp)
' individuo i numeri da sviluppare i quali devono avere la c aratteristica sia di essere usciti
' nelle estrazioni coinvolte dal range sia di non essere gia presenti nella lunghetta stessa
ReDim aNumDaSvil(90)
nQtNumDaSvil = 00
For n = 01 To 90
If Not(aBUsati(n)) Then
If abNumValidi(n) Then
nQtNumDaSvil = nQtNumDaSvil + 01
aNumDaSvil(nQtNumDaSvil) = n
End If
End If
Next
ReDim Preserve aNumDaSvil(nQtNumDaSvil)
' inizio a sviluppare le combinazioni da testare insieme ai numeri della lunghetta
ReDim aCol(nClasseSvilTmp)
bFound = False
Call objSvil.InitSviluppoIntegrale(aNumDaSvil,nClasseSvilTmp)
Do While objSvil.GetCombSviluppo(aCol)
' nelle opportune posizioni dell'array della lunghetta pongo i numeri della combinazione sviluppata
For k = 01 To nClasseSvilTmp
aRetCol(nPos + k) = aCol(k)
Next
' calcolo le presenze della lunghetta
'
'nPresTmp = Presenze(aRetCol,nQtEstrUsate,UBound(aRetCol),aRuote,nSorte)''''''''''''''''''''''''''''''''''
nPresTmp = clsHSS.SeriePres(Inizio,Fine,aRetCol,aRuote,nSorte)''''''''''''''''''''''''''''''''''''''''''''
'
' se le presenze calcolate sono >= a quelle gia inidviduate allora
' devo tenere traccia della combinazione da prendere per inserirla
' nella lunghetta all'uscita del ciclo
If nPresTmp >= nPresMax Then
aColDaPrendere = aCol
nPresMax = nPresTmp
bFound = True
End If
Loop
' se ho trovato una combinazione da poter inserire nella lunghetta
' procedo ad inserirla e tengo traccia della nuova dimensione (quantita dei numeri)
' della lunghetta
' se non ho trovato niente è inutile continuare esce
If bFound Then
For k = 01 To nClasseSvilTmp
aRetCol(nPos + k) = aColDaPrendere(k)
aBUsati(aColDaPrendere(k)) = True
Next
nPos = nPos + nClasseSvilTmp
Else
Exit Do
End If
Loop
' se la lunghetta ha raggiunto la dimesnione prevista la funzione torna true
If nPos = nClasse Then
GetLung = True
Else
GetLung = False
End If
End Function
Sub AlimentaNumValidi(aCol,Inizio,Fine,aRuote,abNumValidi)
' funzione usata per test non nello script
ReDim abNumValidi(90)
ReDim aNumRuota(05)
Dim idEstr,e,r
For idEstr = Inizio To Fine
For r = 01 To UBound(aRuote)
Call GetArrayNumeriRuota(idEstr,aRuote(r),aNumRuota)
If PuntiSuArray(aNumRuota,aCol) > 01 Then
For e = 01 To 05
abNumValidi(aNumRuota(e)) = True
Next
End If
Next
Next
End Sub
Function Presenze(aColDaSvilTmp,nQtEstrUsate,nClasseLunghetta,aRuote,Sorte)
' calcola le presenze di una lunghetta
Dim k,r,e,nPunti,aNumRuota,nPresenze
' Dim aB
nPresenze = 00
' aB = ArrayNumeriToBool(aColDaSvilTmp)
For k = 01 To nQtEstrUsate
For r = 01 To UBound(aRuote)
' Call GetArrayNumeriRuota(k,aRuote(r),aNumRuota)
nPunti = 00
For e = 01 To nClasseLunghetta
If aEstrattiBool(k,aRuote(r),aColDaSvilTmp(e)) Then
nPunti = nPunti + 01
End If
Next
If nPunti >= Sorte Then
nPresenze = nPresenze + 01
End If
Next
Next
Presenze = nPresenze
End Function
Function ScegliClasse()
Dim k,i,aVoci(10) : For k = 01 To(01 - 01) + UBound(aVoci) : i = i + 01 : aVoci(i) = k : Next
k = ScegliOpzioneMenu(aVoci,07,"Selezionare Classe Sviluppo Lunghetta")
ScegliClasse = Int(aVoci(k))
End Function
Function ScegliSorte()
Dim i,aVoci(05) : For i = 01 To 05 : aVoci(i) = NomeSorte(i) : Next
ScegliSorte = ScegliOpzioneMenu(aVoci,02,"Selezionare Sorte da Analizzare")
End Function
Function SelRuote(aRuote)
Dim t,k,bTutte : bTutte = False : t = ScegliRuote(aRuote)
For k = 01 To t : If aRuote(k) = TT_ Then : bTutte = True : Exit For: End If : Next
If bTutte Then
ReDim aRuote(10) : For k = 01 To 10 : aRuote(k) = k : Next : SelRuote = 10
Else : SelRuote = t : End If
End Function
Function ScegliTipoTabella()
Dim aVoci : aVoci = Array(aVoci,"Tabella Normale","Tabella Ordinabile")
ScegliTipoTabella = ScegliOpzioneMenu(aVoci,02,"Selezionare Tipo Tabella")
If ScegliTipoTabella = 01 Then : Call CreaTabella() : Else : Call CreaTabellaOrdinabile() : End If
End Function
