Spaziometria o uno script possono rilevare la 10ina + in ritardo x A su tutte?

LuigiB · 19 Marzo 2016

anche io ho fatto delle modifiche se possibile fare altre prove..ciao a tutti
..

Codice:

Option Explicit
Class clsCombinazione
    Private m_UltEstUscita
    Private m_Key
    Private m_aNum
    Private m_Classe
    Private m_Index
    Private m_aNumComplementari
    Private m_QNumComplementari
    Sub Class_Initialize
        ' codice
    End Sub
    Sub Class_Terminate
        ' codice
    End Sub
    Public Property Get QNumComplementari
        QNumComplementari = m_QNumComplementari
    End Property
    Public Property Let QNumComplementari(NewValue)
        m_QNumComplementari = NewValue
    End Property
    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 aNumComplementari
        aNumComplementari = m_aNumComplementari
    End Property
    Public Property Let aNumComplementari(NewValue)
        m_aNumComplementari = 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 AlimentaCollLunghetta(CollLunghette,CollCombBase,nClasseLung)
        Dim abNum,nClasseTmp
        Dim n
        ReDim aCol(0)
        Dim sKey,cItem
        Dim bFound,bNonAdatta
        Dim aNum
        Dim nNumIni,nNumAggiunto
        Dim sRadice
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        nNumIni = 0
        sRadice = StringaNumeri(m_aNum,,True)
        Do While nNumIni < 90
            nNumIni = nNumIni + 1
            Do While nClasseTmp < nClasseLung
                bFound = False
                Call Messaggio("Analisi radice " & sRadice)
                bNonAdatta = True
                For n = nNumIni To 90
                    If abNum(n) = False Then
                        nNumAggiunto = n
                        abNum(n) = True
                        nClasseTmp = nClasseTmp + 1
                        'ReDim aNum(nClasseTmp)
                        Call ArrayBNumToArrayNum(abNum,aNum)
                        Call InitSviluppoIntegrale(aNum,m_Classe)
                        bNonAdatta = False
                        Do While GetCombSviluppo(aCol)
                            sKey = "k" & StringaNumeri(aCol,,True)
                            If GetItemCollection(CollCombBase,sKey,cItem) Then
                                If cItem.Index > m_Index Then
                                    bNonAdatta = True
                                    abNum(n) = False
                                    nClasseTmp = nClasseTmp - 1
                                    Exit Do
                                End If
                            End If
                        Loop
                        If bNonAdatta = False Then Exit For
                    End If
                Next
                If bNonAdatta Then Exit Do
            Loop
            If nClasseTmp = nClasseLung Then
                Dim clsL
                Set clsL = New clsCombinazione
                clsL.aNum = aNum
                clsL.Classe = nClasseLung
                clsL.UltEstUscita = m_UltEstUscita
                sKey = "k" & StringaNumeri(aNum,,True)
                On Error Resume Next
                Call AddItemColl(CollLunghette,clsL,sKey)
                nNumIni = nNumAggiunto
                abNum(nNumAggiunto) = False
                nClasseTmp = nClasseTmp - 1
            Else
                nNumIni = 90
            End If
        Loop
    End Function
    Function AlimentaNumComplementari(CollCombBase)
        Dim aNum,abNum,nClasseTmp
        Dim n,nNumAggiunto,bNonAdatta
        ReDim aCol(0)
        Dim sKey,cItem
        Dim nQNumAggiunti,aNumAggiunti
        Dim sRadice
        
        nQNumAggiunti = 0
        'ReDim m_aNumComplementari (0)
        ReDim aNumAggiunti(nQNumAggiunti)
        nQNumAggiunti = 0
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        
        For n = 1 To 90
            If abNum(n) = False Then
                nNumAggiunto = n
                abNum(n) = True
                Call ArrayBNumToArrayNum(abNum,aNum)
                Call InitSviluppoIntegrale(aNum,m_Classe)
                bNonAdatta = False
                Do While GetCombSviluppo(aCol)
                    sKey = "k" & StringaNumeri(aCol,,True)
                    If GetItemCollection(CollCombBase,sKey,cItem) Then
                        If cItem.Index > m_Index Then
                            bNonAdatta = True
                            abNum(n) = False
                            Exit Do
                        End If
                    End If
                Loop
                If bNonAdatta = False Then
                    nQNumAggiunti = nQNumAggiunti + 1
                    ReDim Preserve aNumAggiunti(nQNumAggiunti)
                    aNumAggiunti(nQNumAggiunti) = nNumAggiunto
                    If VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti) = False Then
                        aNumAggiunti(nQNumAggiunti) = 0
                        nQNumAggiunti = nQNumAggiunti - 1
                    End If
                End If
                abNum(nNumAggiunto) = False
            End If
        Next
        ReDim Preserve aNumAggiunti(nQNumAggiunti)
        m_QNumComplementari = nQNumAggiunti
        m_aNumComplementari = aNumAggiunti
    End Function
    Function VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti)
        ReDim aCol(0)
        Dim cItem
        Dim bNonAdatta,sKey
        Dim aColonne,k,y,i
        Dim aNumDaSvil
        ReDim aNumDaSvil(nQNumAggiunti + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNumDaSvil(i) = m_aNum(k)
        Next
        For k = 1 To nQNumAggiunti
            i = i + 1
            aNumDaSvil(i) = aNumAggiunti(k)
        Next
        Call OrdinaMatrice(aNumDaSvil, 1)
        aColonne = SviluppoIntegrale(aNumDaSvil,m_Classe)
        bNonAdatta = False
        For k = 1 To UBound(aColonne)
            sKey = "k"
            For y = 1 To m_Classe
                sKey = sKey & Format2(aColonne(k,y)) & "."
            Next
            sKey = RimuoviLastChr(sKey,".")
            If GetItemCollection(CollCombBase,sKey,cItem) Then
                If cItem.Index > m_Index Then
                    bNonAdatta = True
                    Exit For
                End If
            End If
        Next
        VerificaNumAggiunti = Not bNonAdatta
    End Function
    Function GetNumeriDaSviluppare
        Dim k,i
        Dim aNum
        ReDim aNum(m_QNumComplementari + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNum(i) = m_aNum(k)
        Next
        For k = 1 To m_QNumComplementari
            i = i + 1
            aNum(i) = m_aNumComplementari(k)
        Next
        Call OrdinaMatrice(aNum,1)
        GetNumeriDaSviluppare = aNum
    End Function
End Class
Sub Main
    Dim collCombBase,CollLunghette,nSorte,aRuote,Ini,fin,sMsg,nMoltip
    Dim nCicloTeo,nRitMax,nClasseLunghetta,nRuoteSel,nCombBaseTrov,nLunghetteDaTrov
    Dim clsComb
    Dim i , nTrov , nIndexMax
    
    nTrov =0
    nSorte = ScegliEsito
    nClasseLunghetta = ScegliClassseLunghetta
    nRuoteSel = SelRuote(aRuote)
    nLunghetteDaTrov = 3
    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
    Call AlimentaCollCombUscite(collCombBase,nSorte,aRuote,Ini,fin)
    Call OrdinaItemCollection(collCombBase,"UltEstUscita","Key",,1)
    Call ImpostaPosizioni(collCombBase , nIndexMax )
    nCombBaseTrov = collCombBase.count
    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 CollLunghette = GetNewCollection
    i = 0
    Dim nTipoMetodo
    nTipoMetodo = 2
    For Each clsComb In collCombBase
        Select Case nTipoMetodo
        Case 1
            Call clsComb.AlimentaCollLunghetta(CollLunghette,collCombBase,nClasseLunghetta)
            'Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita)
            If CollLunghette.count >= nLunghetteDaTrov Then Exit For
        Case 2
            
            Call Messaggio ("Metodo 2 radice " & clsComb.GetStringaNum  & " Pos " & CLSCOMB.Index & "/" & nIndexMax )
            Call clsComb.AlimentaNumComplementari(collCombBase)
            If clsComb.QNumComplementari + nSorte >= nClasseLunghetta Then
                Call Scrivi("I migliori numeri da sviluppare in classe " & nClasseLunghetta & " per " & NomeSorte(nSorte) & " sono i seguenti")
                Call Scrivi(StringaNumeri(clsComb.GetNumeriDaSviluppare))
                sMsg = "Il ritardo per " & NomeSorte(nSorte) & " dell'intera sequenza "
                sMsg = sMsg & "(composta  da " & clsComb.QNumComplementari + nSorte & "  numeri)"
                sMsg = sMsg & " è di " & RitardoCombinazioneTurbo(aRuote,clsComb.GetNumeriDaSviluppare,nSorte,fin)
                Call Scrivi(sMsg)
                Call Scrivi
                nTrov = nTrov +1
                If nTrov >= nLunghetteDaTrov Then Exit For
            End If
        End Select
        i = i + 1
        Call AvanzamentoElab(1,nCombBaseTrov,i)
        If ScriptInterrotto Then Exit For
    Next
    For Each clsComb In CollLunghette
        Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita & " - Rit " & RitardoCombinazioneTurbo(aRuote,clsComb.aNum,nSorte,fin))
    Next
End Sub
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
        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 GetItemCollection(Coll,sKey,cItem)
    On Error Resume Next
    Set cItem = Coll(sKey)
    If Err <> 0 Then
        Err.Clear
        GetItemCollection = False
    Else
        GetItemCollection = True
    End If
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

i legend · 19 Marzo 2016

ciao luigi Buon Week end

mancano ancora delle formazioni.
ho fatto un piccolo e spartano script per racchiudere in un array le formazioni con il ritardo minimo voluto.(magari dipende che non trova tutti gli ambi.)
infatti gli ambi che hanno un ritardo minore di quello che noi vogliamo non ci servono.
Riposto dopo

Beppignello · 19 Marzo 2016

per LuigiB

io ottengo questo elenco

0082 / 0082 1307 8.14.33.49.77
0067 / 0067 1353 48.60.76.82.88
0067 / 0067 1223 1.30.32.55.64
0066 / 0066 1356 7.48.76.82.88
0066 / 0066 1296 2.29.34.58.87
0065 / 0065 1226 14.16.49.60.67

Totale Combinazioni....6

alcune sono uguale anche con il tuo, ma si ferma a ritardo 67

I migliori numeri da sviluppare in classe 5 per Ambo sono i seguenti
1.30.32.55.64
Il ritardo per Ambo dell'intera sequenza (composta da 5 numeri) è di 67

I migliori numeri da sviluppare in classe 5 per Ambo sono i seguenti
2.29.34.58.87
Il ritardo per Ambo dell'intera sequenza (composta da 5 numeri) è di 66

I migliori numeri da sviluppare in classe 5 per Ambo sono i seguenti
6.53.75.83.87
Il ritardo per Ambo dell'intera sequenza (composta da 5 numeri) è di 64

per I Legend,

il limite è imposto dallo sviluppo sistema

oltre alla classe 4, diventa impossibile, "Memoria esaurita"

un presupposto troppo importante, a mio avviso.

i legend · 19 Marzo 2016

ciao Beppignello lo script deve servire per trovare gli ambi con ritardo minimo da noi richiesto.
non deve trovare terzine quartine od altro quello lo deve fare la routine per costruire le lunghette.
Buttalo pure quello come avevo scritto era da controllare.
grazie per averlo fatto

per i terni in lunghetta diventa molto piu complicato credo.
sentiamo il prof

Codice:

Option Explicit
' test per trovare i ritardi attuali
' Salvo errori ed eventuali bugs
' controllare e verificare i risultati anche da altre fonti
' Non
Class ClsRitardo
    Private mSorte
    Private mRit
    Private mIni
    Private mFin
    Private mRitMinCercato
    Private aRuote
    Public Property Get RitTro
        RitTro = mRit
    End Property
    Sub Init(aNum,VetRuote,RngIni,RngFin,SorteGioco)
        aRuote = VetRuote
        mIni = RngIni
        mFin = RngFin
        mSorte = SorteGioco
        mSorte = SorteGioco
        mRit = RitardoCombinazioneTurbo(aRuote,aNum,mSorte,mFin,,,mIni)
    End Sub
    Function IsCondTrue(RitMinCer)
        mRitMinCercato = RitMinCer
        IsCondTrue =(mRit >= mRitMinCercato)
    End Function
End Class
Sub Main
    ReDim aNum(90)
    ReDim aRu(0) :ScegliRuote(aRu)
    Dim nClasse :nClasse = 2
    Dim Sorte :Sorte = 2
    
    Dim RitMin :RitMin = 300
    Dim nCol
    Dim clsR
    Dim k,Id
    For k = 1 To 90
        aNum(k) = k
    Next
    nCol = InitSviluppoIntegrale(aNum,nClasse)
    ReDim aRit(nCol,2)
    k = 0
    Id = 0
    Do While GetCombSviluppo(aNum)
        Id = Id + 1
        Set clsR = New ClsRitardo
        Call clsR.Init(aNum,aRu,3950,EstrazioneFin,Sorte)
        If clsR.IsCondTrue(RitMin) Then
            k = k + 1
            aRit(k,1) = StringaNumeri(aNum,"-",True)
            aRit(k,2) = clsR.ritTro
        End If
        If Id Mod 100 = 0 Then
            Call AvanzamentoElab(1,nCol,Id)
            Call Messaggio(StringaNumeri(aNum,,True))
        End If
        If ScriptInterrotto Then Exit Do
    Loop
    If ScriptInterrotto Then Exit Sub
    Call OrdinaMatriceTurbo(aRit,- 1,2)
    ScriviMatrice(aRit)
End Sub

Joe91 · 19 Marzo 2016

Secondo me la spiegazione è diversa.

E' come riempire una vasca ... ove c'è gravità

(Luigi ha usato l' espressione "Bottom")

iniziando dal basso.

Fissando un foro d'uscita ad una altezza minima ... è logico ...

che l'acqua esca da quell'altezza e non dai fori

... eventualmente effettuati anche ... più in alto.

Semplicemente trova dei minimi, pur di valore elevato.

Beppignello · 19 Marzo 2016

ho provato il tuo script analizzando, non solo 142 estrazioni precedenti, come rmax di una cinquina
ma ho provato anche le 5185 estrazioni prec. estrazionefin-3950, ma la lista rimane uguale.

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

Beppignello · 19 Marzo 2016

1) calcolo i ritardi degli ambi
2) prendo i più alti di un minimo richiesto
3) accoppio gli ambi che stanno sopra come ritardo (in questo caso quartine) oppure sviluppo in terzine e trovo le terzine più in ritardo
4) salgo in continuo con la classe di sviluppo che richiedo.

5) escludo tutte quelle con ritardo minore del minimo
6) stampo elenco

però:

le classi dispari devo elaborare 90 interazioni, per ogni ambo
le classi dispari devo elaborare x n.ambi che stanno sopra al ritardo che richiedo

chissà, se può andare questa idea.

LuigiB · 19 Marzo 2016

ragazzi scusate , per orasono concentratosulla mia idea e non ho visto lo script di leggend e non mi sono concentrato sull'idea di Beppignello , invece Joe mi ha fatto pensare e ho fatto una nuova modifica allo script.
Beppignello , legend potete fare un 'altra prova con questo nuovo script ?

Codice:

Option Explicit
Class clsCombinazione
    Private m_UltEstUscita
    Private m_Key
    Private m_aNum
    Private m_Classe
    Private m_Index
    Private m_aNumComplementari
    Private m_QNumComplementari
    Sub Class_Initialize
        ' codice
    End Sub
    Sub Class_Terminate
        ' codice
    End Sub
    Public Property Get QNumComplementari
        QNumComplementari = m_QNumComplementari
    End Property
    Public Property Let QNumComplementari(NewValue)
        m_QNumComplementari = NewValue
    End Property
    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 aNumComplementari
        aNumComplementari = m_aNumComplementari
    End Property
    Public Property Let aNumComplementari(NewValue)
        m_aNumComplementari = 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 AlimentaCollLunghetta(CollLunghette,CollCombBase,nClasseLung)
        Dim abNum,nClasseTmp
        Dim n
        ReDim aCol(0)
        Dim sKey,cItem
        Dim bFound,bNonAdatta
        Dim aNum
        Dim nNumIni,nNumAggiunto
        Dim sRadice
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        nNumIni = 0
        sRadice = StringaNumeri(m_aNum,,True)
        Do While nNumIni < 90
            nNumIni = nNumIni + 1
            Do While nClasseTmp < nClasseLung
                bFound = False
                Call Messaggio("Analisi radice " & sRadice)
                bNonAdatta = True
                For n = nNumIni To 90
                    If abNum(n) = False Then
                        nNumAggiunto = n
                        abNum(n) = True
                        nClasseTmp = nClasseTmp + 1
                        'ReDim aNum(nClasseTmp)
                        Call ArrayBNumToArrayNum(abNum,aNum)
                        Call InitSviluppoIntegrale(aNum,m_Classe)
                        bNonAdatta = False
                        Do While GetCombSviluppo(aCol)
                            sKey = "k" & StringaNumeri(aCol,,True)
                            If GetItemCollection(CollCombBase,sKey,cItem) Then
                                If cItem.Index > m_Index Then
                                    bNonAdatta = True
                                    abNum(n) = False
                                    nClasseTmp = nClasseTmp - 1
                                    Exit Do
                                End If
                            End If
                        Loop
                        If bNonAdatta = False Then Exit For
                    End If
                Next
                If bNonAdatta Then Exit Do
            Loop
            If nClasseTmp = nClasseLung Then
                Dim clsL
                Set clsL = New clsCombinazione
                clsL.aNum = aNum
                clsL.Classe = nClasseLung
                clsL.UltEstUscita = m_UltEstUscita
                sKey = "k" & StringaNumeri(aNum,,True)
                On Error Resume Next
                Call AddItemColl(CollLunghette,clsL,sKey)
                nNumIni = nNumAggiunto
                abNum(nNumAggiunto) = False
                nClasseTmp = nClasseTmp - 1
            Else
                nNumIni = 90
            End If
        Loop
    End Function
    Function AlimentaNumComplementari(CollCombBase)
        Dim aNum,abNum,nClasseTmp
        Dim n,nNumAggiunto,bNonAdatta
        ReDim aCol(0)
        Dim sKey,cItem
        Dim nQNumAggiunti,aNumAggiunti
        Dim sRadice
        
        nQNumAggiunti = 0
        'ReDim m_aNumComplementari (0)
        ReDim aNumAggiunti(nQNumAggiunti)
        nQNumAggiunti = 0
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        
        For n = 1 To 90
            If abNum(n) = False Then
                nNumAggiunto = n
                abNum(n) = True
                Call ArrayBNumToArrayNum(abNum,aNum)
                Call InitSviluppoIntegrale(aNum,m_Classe)
                bNonAdatta = False
                Do While GetCombSviluppo(aCol)
                    sKey = "k" & StringaNumeri(aCol,,True)
                    If GetItemCollection(CollCombBase,sKey,cItem) Then
                        If cItem.Index > m_Index Then
                            bNonAdatta = True
                            abNum(n) = False
                            Exit Do
                        End If
                    End If
                Loop
                If bNonAdatta = False Then
                    nQNumAggiunti = nQNumAggiunti + 1
                    ReDim Preserve aNumAggiunti(nQNumAggiunti)
                    aNumAggiunti(nQNumAggiunti) = nNumAggiunto
                    'If VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti) = False Then
                    '    aNumAggiunti(nQNumAggiunti) = 0
                    '    nQNumAggiunti = nQNumAggiunti - 1
                    'End If
                End If
                abNum(nNumAggiunto) = False
            End If
        Next
        ReDim Preserve aNumAggiunti(nQNumAggiunti)
        m_QNumComplementari = nQNumAggiunti
        m_aNumComplementari = aNumAggiunti
    End Function
    Function VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti)
        ReDim aCol(0)
        Dim cItem
        Dim bNonAdatta,sKey
        Dim aColonne,k,y,i
        Dim aNumDaSvil
        ReDim aNumDaSvil(nQNumAggiunti + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNumDaSvil(i) = m_aNum(k)
        Next
        For k = 1 To nQNumAggiunti
            i = i + 1
            aNumDaSvil(i) = aNumAggiunti(k)
        Next
        Call OrdinaMatrice(aNumDaSvil,1)
        aColonne = SviluppoIntegrale(aNumDaSvil,m_Classe)
        bNonAdatta = False
        For k = 1 To UBound(aColonne)
            sKey = "k"
            For y = 1 To m_Classe
                sKey = sKey & Format2(aColonne(k,y)) & "."
            Next
            sKey = RimuoviLastChr(sKey,".")
            If GetItemCollection(CollCombBase,sKey,cItem) Then
                If cItem.Index > m_Index Then
                    bNonAdatta = True
                    Exit For
                End If
            End If
        Next
        VerificaNumAggiunti = Not bNonAdatta
    End Function
    Function GetNumeriDaSviluppare
        Dim k,i
        Dim aNum
        ReDim aNum(m_QNumComplementari + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNum(i) = m_aNum(k)
        Next
        For k = 1 To m_QNumComplementari
            i = i + 1
            aNum(i) = m_aNumComplementari(k)
        Next
        Call OrdinaMatrice(aNum,1)
        GetNumeriDaSviluppare = aNum
    End Function
End Class
Sub Main
    Dim collCombBase,CollLunghette,nSorte,aRuote,Ini,fin,sMsg,nMoltip
    Dim nCicloTeo,nRitMax,nClasseLunghetta,nRuoteSel,nCombBaseTrov,nLunghetteDaTrov
    Dim clsComb
    Dim i,nTrov,nIndexMax
    
    nTrov = 0
    nSorte = ScegliEsito
    nClasseLunghetta = ScegliClassseLunghetta
    nRuoteSel = SelRuote(aRuote)
    nLunghetteDaTrov = 3
    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
    Call AlimentaCollCombUscite(collCombBase,nSorte,aRuote,Ini,fin)
    Call OrdinaItemCollection(collCombBase,"UltEstUscita","Key",,1)
    Call ImpostaPosizioni(collCombBase,nIndexMax)
    nCombBaseTrov = collCombBase.count
    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 CollLunghette = GetNewCollection
    i = 0
    Dim nTipoMetodo
    nTipoMetodo = 2
    For Each clsComb In collCombBase
        Select Case nTipoMetodo
        Case 1
            Call clsComb.AlimentaCollLunghetta(CollLunghette,collCombBase,nClasseLunghetta)
            'Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita)
            If CollLunghette.count >= nLunghetteDaTrov Then Exit For
        Case 2
            
            Call Messaggio("Metodo 2 radice " & clsComb.GetStringaNum & " Pos " & CLSCOMB.Index & "/" & nIndexMax)
            Call clsComb.AlimentaNumComplementari(collCombBase)
            If clsComb.QNumComplementari + nSorte >= nClasseLunghetta Then
                Call AlimentaCollLunghetta (CollLunghette,collCombBase, clsComb.GetNumeriDaSviluppare ,nClasseLunghetta , nSorte ,clsComb.Index )
                If CollLunghette.count >= nLunghetteDaTrov Then Exit For

                'Call Scrivi("I migliori numeri da sviluppare in classe " & nClasseLunghetta & " per " & NomeSorte(nSorte) & " sono i seguenti")
'                Call Scrivi(StringaNumeri(clsComb.GetNumeriDaSviluppare))
'                sMsg = "Il ritardo per " & NomeSorte(nSorte) & " dell'intera sequenza "
'                sMsg = sMsg & "(composta  da " & clsComb.QNumComplementari + nSorte & "  numeri)"
'                sMsg = sMsg & " è di " & RitardoCombinazioneTurbo(aRuote,clsComb.GetNumeriDaSviluppare,nSorte,fin)
'                Call Scrivi(sMsg)
'                Call Scrivi
'                nTrov = nTrov + 1
'                If nTrov >= nLunghetteDaTrov Then Exit For
            End If
        End Select
        i = i + 1
        Call AvanzamentoElab(1,nCombBaseTrov,i)
        If ScriptInterrotto Then Exit For
    Next
    For Each clsComb In CollLunghette
        Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita & " - Rit " & RitardoCombinazioneTurbo(aRuote,clsComb.aNum,nSorte,fin))
    Next
End Sub

Sub AlimentaCollLunghetta (CollLunghette,CollCombBase,aNumDaSvil ,nClasseLunghetta , nSorte , IndexCur)

    Dim aCol
    ReDim aCol (0)
    Dim aColonne , k , y
    Dim sKey
    Dim cItem
    Dim bValida
    
    Call InitSviluppoIntegrale( aNumDaSvil , nClasseLunghetta)
    Do While GetCombSviluppo(aCol)
        bValida = True
        aColonne = SviluppoIntegrale (aCol ,nSorte )
        For k = 1 To UBound(aColonne)
            sKey = "k"
            For y = 1 To nSorte-1
                sKey = sKey & Format2(aColonne(k,y)) & "."
            Next
            sKey = sKey & Format2(aColonne(k,y))
            If GetItemCollection( CollCombBase ,sKey , cItem) Then
                If cItem.Index > IndexCur Then
                    bValida = False
                    Exit For
                End If
            End If
        Next    
        If bValida Then
            Set cItem = New clsCombinazione
            cItem.Index =IndexCur
            cItem.aNum  = aCol
            sKey = "k" & StringaNumeri(aCol)
            Call AddItemColl(CollLunghette , cItem , sKey)
        End If
        
    Loop
End Sub
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
        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 GetItemCollection(Coll,sKey,cItem)
    On Error Resume Next
    Set cItem = Coll(sKey)
    If Err <> 0 Then
        Err.Clear
        GetItemCollection = False
    Else
        GetItemCollection = True
    End If
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

i legend · 19 Marzo 2016

Ciao luigi scusa non posso provera lo script.
Non si accende più il PC. Da non crederci.
Vedrò in settimana ma penso sia andato in pensione.
Vi seguo.

Beppignello · 19 Marzo 2016

08.14.33.49.77 -- - Rit 82
01.30.32.55.64 -- - Rit 67
48.60.76.82.88 -- - Rit 67

Tempo impiegato...7:31:43 PM : 7:32:01 PM

ci siamo, okey è giusto

0082 / 0082 1307 8.14.33.49.77
0067 / 0067 1353 48.60.76.82.88
0067 / 0067 1223 1.30.32.55.64
0066 / 0066 1356 7.48.76.82.88
0066 / 0066 1296 2.29.34.58.87
0065 / 0065 1226 14.16.49.60.67

Tempo elaborazione..7:32:53 PM : 7:32:55 PM

il tempo impiegato è abbastanza buono

LuigiB · 19 Marzo 2016

ho in mente altre modifiche .,,

Beppignello · 19 Marzo 2016

LuigiB, secondo te, un parere, visto che molte lunghette hanno in comune molti numeri, con la rotazione integrale o semintegrale,

è fattibile escluderne un po, applicando una sorte di riduzione
esempio

01 02 03 04 05
....01 02 03 04 06
....01 02 03 04 90

01 02 03 05 06
....01 02 03 05 90

01 02 03 06 07

che riduzione si potrebbe applicare?

una ripetizione della cinquina precedente, che abbiamo <= 3 numeri, oppure 4 numeri

che diavoleria si potrebbe impostare per scartare molte combinazioni fin da subito?

LuigiB · 20 Marzo 2016

ciao Beppignello , ma lo scopo è saltare combinazioni per rendere piu veloce l'agoritmo o semplicemente ridurre ?
Nel primo caso purtroppo la faccenda è complessa perche bisogna vedere cosa si sta scartando perche se si scarta la disposizione di numeri sbaglaita poi non si trova piu la combinazione col ritardo massimo asoluto , in pratica il problema che stiamo affrontando ora ..
nel secondo caso invece se lo scopo è solo ridurre è molto piu veloce usare le matrici per fare le riduzioni matematiche

Beppignello · 20 Marzo 2016

ciao
mi riferisco ad una combinazione che ha il ritardo superiore al minimo richiesto, ma questo dato lo sappiamo dopo la ricerca del ritardo attuale,

supponiamo di cercare una cinquina per sorte ambo
di precaricare all'inizio il ritardo di tutti gli ambi

1) ci impiegherà di più l'istruzione ritardocombinazioneturbo x trovare il ritardo attuale della combinazione che stiamo cercando
oppure
facendo un loop di 10 ambi che compongono la cinquina (arrays ambi/ritardo già caricata all'inizio,per comodità)(4005ambi)
per vedere se vi è anche solo 1 ambo minore del minimo richiesto, scartare da subito la combinazione???

LuigiB · 20 Marzo 2016

Ciao , è chiaro che è molto piu veloce sfruttare un valore precalcolato piuttosto che ricalcolarlo.
Nel mio script non a caso ho fatto uso di una collection , come ho spiegato piu volte le collection sono contenitori dove si possono inserire oggetti , gli oggetti sono dati dalle classi.
In una collection l'oggetto puo essere inserito tramite una chiave e nella fase di estrazione dell'oggetto
dalla collection la chiave rende veloce l'operazione.Se ivalori precalcolati li inserisci in un array invece o ti inventi una formula che dati i nunmeri della combinazione ti fa tornare l'indice dell'array per leggere il valore precalcolato di quelal combinazione o invece ti devi scorrere tutto l'array il che lo rende molto meno veloce piuttosto che usare le collection.

Ho fatto nuove modifiche allo script , dovrebbe essere piu veloce .. se puoi provarlo e farmi sapere ...

Codice:

Option Explicit
Class clsCombinazione
    Private m_UltEstUscita
    Private m_Key
    Private m_aNum
    Private m_Classe
    Private m_Index
    Private m_aNumComplementari
    Private m_QNumComplementari
    Sub Class_Initialize
        ' codice
    End Sub
    Sub Class_Terminate
        ' codice
    End Sub
    Public Property Get QNumComplementari
        QNumComplementari = m_QNumComplementari
    End Property
    Public Property Let QNumComplementari(NewValue)
        m_QNumComplementari = NewValue
    End Property
    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 aNumComplementari
        aNumComplementari = m_aNumComplementari
    End Property
    Public Property Let aNumComplementari(NewValue)
        m_aNumComplementari = 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 AlimentaCollLunghetta(CollLunghette,CollCombBase,nClasseLung)
        Dim abNum,nClasseTmp
        Dim n
        ReDim aCol(0)
        Dim sKey,cItem
        Dim bFound,bNonAdatta
        Dim aNum
        Dim nNumIni,nNumAggiunto
        Dim sRadice
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        nNumIni = 0
        sRadice = StringaNumeri(m_aNum,,True)
        Do While nNumIni < 90
            nNumIni = nNumIni + 1
            Do While nClasseTmp < nClasseLung
                bFound = False
                Call Messaggio("Analisi radice " & sRadice)
                bNonAdatta = True
                For n = nNumIni To 90
                    If abNum(n) = False Then
                        nNumAggiunto = n
                        abNum(n) = True
                        nClasseTmp = nClasseTmp + 1
                        'ReDim aNum(nClasseTmp)
                        Call ArrayBNumToArrayNum(abNum,aNum)
                        Call InitSviluppoIntegrale(aNum,m_Classe)
                        bNonAdatta = False
                        Do While GetCombSviluppo(aCol)
                            sKey = "k" & StringaNumeri(aCol,,True)
                            If GetItemCollection(CollCombBase,sKey,cItem) Then
                                If cItem.Index > m_Index Then
                                    bNonAdatta = True
                                    abNum(n) = False
                                    nClasseTmp = nClasseTmp - 1
                                    Exit Do
                                End If
                            End If
                        Loop
                        If bNonAdatta = False Then Exit For
                    End If
                Next
                If bNonAdatta Then Exit Do
            Loop
            If nClasseTmp = nClasseLung Then
                Dim clsL
                Set clsL = New clsCombinazione
                clsL.aNum = aNum
                clsL.Classe = nClasseLung
                clsL.UltEstUscita = m_UltEstUscita
                sKey = "k" & StringaNumeri(aNum,,True)
                On Error Resume Next
                Call AddItemColl(CollLunghette,clsL,sKey)
                nNumIni = nNumAggiunto
                abNum(nNumAggiunto) = False
                nClasseTmp = nClasseTmp - 1
            Else
                nNumIni = 90
            End If
        Loop
    End Function
    Function AlimentaNumComplementari(CollCombBase)
        Dim aNum,abNum,nClasseTmp
        Dim n,nNumAggiunto,bNonAdatta
        ReDim aCol(0)
        Dim sKey,cItem
        Dim nQNumAggiunti,aNumAggiunti
        Dim sRadice
        
        nQNumAggiunti = 0
        'ReDim m_aNumComplementari (0)
        ReDim aNumAggiunti(nQNumAggiunti)
        nQNumAggiunti = 0
        nClasseTmp = m_Classe
        abNum = ArrayNumeriToBool(m_aNum)
        
        For n = 1 To 90
            If abNum(n) = False Then
                nNumAggiunto = n
                abNum(n) = True
                Call ArrayBNumToArrayNum(abNum,aNum)
                Call InitSviluppoIntegrale(aNum,m_Classe)
                bNonAdatta = False
                Do While GetCombSviluppo(aCol)
                    sKey = "k" & StringaNumeri(aCol,,True)
                    If GetItemCollection(CollCombBase,sKey,cItem) Then
                        If cItem.Index > m_Index Then
                            bNonAdatta = True
                            abNum(n) = False
                            Exit Do
                        End If
                    End If
                Loop
                If bNonAdatta = False Then
                    nQNumAggiunti = nQNumAggiunti + 1
                    ReDim Preserve aNumAggiunti(nQNumAggiunti)
                    aNumAggiunti(nQNumAggiunti) = nNumAggiunto
                    'If VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti) = False Then
                    '    aNumAggiunti(nQNumAggiunti) = 0
                    '    nQNumAggiunti = nQNumAggiunti - 1
                    'End If
                End If
                abNum(nNumAggiunto) = False
            End If
        Next
        ReDim Preserve aNumAggiunti(nQNumAggiunti)
        m_QNumComplementari = nQNumAggiunti
        m_aNumComplementari = aNumAggiunti
    End Function
    Function VerificaNumAggiunti(CollCombBase,aNumAggiunti,nQNumAggiunti)
        ReDim aCol(0)
        Dim cItem
        Dim bNonAdatta,sKey
        Dim aColonne,k,y,i
        Dim aNumDaSvil
        ReDim aNumDaSvil(nQNumAggiunti + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNumDaSvil(i) = m_aNum(k)
        Next
        For k = 1 To nQNumAggiunti
            i = i + 1
            aNumDaSvil(i) = aNumAggiunti(k)
        Next
        Call OrdinaMatrice(aNumDaSvil,1)
        aColonne = SviluppoIntegrale(aNumDaSvil,m_Classe)
        bNonAdatta = False
        For k = 1 To UBound(aColonne)
            sKey = "k"
            For y = 1 To m_Classe
                sKey = sKey & Format2(aColonne(k,y)) & "."
            Next
            sKey = RimuoviLastChr(sKey,".")
            If GetItemCollection(CollCombBase,sKey,cItem) Then
                If cItem.Index > m_Index Then
                    bNonAdatta = True
                    Exit For
                End If
            End If
        Next
        VerificaNumAggiunti = Not bNonAdatta
    End Function
    Function GetNumeriDaSviluppare
        Dim k,i
        Dim aNum
        ReDim aNum(m_QNumComplementari + m_Classe)
        i = 0
        For k = 1 To m_Classe
            i = i + 1
            aNum(i) = m_aNum(k)
        Next
        For k = 1 To m_QNumComplementari
            i = i + 1
            aNum(i) = m_aNumComplementari(k)
        Next
        Call OrdinaMatrice(aNum,1)
        GetNumeriDaSviluppare = aNum
    End Function
End Class
Sub Main
    Dim collCombBase,CollLunghette,nSorte,aRuote,Ini,fin,sMsg,nMoltip
    Dim nCicloTeo,nRitMax,nClasseLunghetta,nRuoteSel,nCombBaseTrov,nLunghetteDaTrov
    Dim clsComb
    Dim i,nTrov,nIndexMax
    Dim TimeStart
    
    nTrov = 0
    nSorte = ScegliEsito
    nClasseLunghetta = ScegliClassseLunghetta
    nRuoteSel = SelRuote(aRuote)
    nLunghetteDaTrov = 3
    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 AlimentaCollCombUscite(collCombBase,nSorte,aRuote,Ini,fin)
    Call OrdinaItemCollection(collCombBase,"UltEstUscita","Key",,1)
    Call ImpostaPosizioni(collCombBase,nIndexMax)
    nCombBaseTrov = collCombBase.count
    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 CollLunghette = GetNewCollection
    i = 0
    Dim nTipoMetodo
    nTipoMetodo = 2
    For Each clsComb In collCombBase
        Select Case nTipoMetodo
        Case 1
            Call clsComb.AlimentaCollLunghetta(CollLunghette,collCombBase,nClasseLunghetta)
            'Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita)
            If CollLunghette.count >= nLunghetteDaTrov Then Exit For
        Case 2
            
            Call Messaggio("Metodo 2 radice " & clsComb.GetStringaNum & " Pos " & CLSCOMB.Index & "/" & nIndexMax)
            Call clsComb.AlimentaNumComplementari(collCombBase)
            If clsComb.QNumComplementari + nSorte >= nClasseLunghetta Then
                Call AlimentaCollLunghetta(CollLunghette,collCombBase,clsComb.aNum,clsComb.aNumComplementari,nClasseLunghetta,nSorte,clsComb.Index)
                If CollLunghette.count >= nLunghetteDaTrov Then Exit For

                'Call Scrivi("I migliori numeri da sviluppare in classe " & nClasseLunghetta & " per " & NomeSorte(nSorte) & " sono i seguenti")
'                Call Scrivi(StringaNumeri(clsComb.GetNumeriDaSviluppare))
'                sMsg = "Il ritardo per " & NomeSorte(nSorte) & " dell'intera sequenza "
'                sMsg = sMsg & "(composta  da " & clsComb.QNumComplementari + nSorte & "  numeri)"
'                sMsg = sMsg & " è di " & RitardoCombinazioneTurbo(aRuote,clsComb.GetNumeriDaSviluppare,nSorte,fin)
'                Call Scrivi(sMsg)
'                Call Scrivi
'                nTrov = nTrov + 1
'                If nTrov >= nLunghetteDaTrov Then Exit For
            End If
        End Select
        i = i + 1
        Call AvanzamentoElab(1,nCombBaseTrov,i)
        If ScriptInterrotto Then Exit For
    Next
    For Each clsComb In CollLunghette
        Call Scrivi(clsComb.GetStringaNum & " -- " & clsComb.UltEstUscita & " - Rit " & RitardoCombinazioneTurbo(aRuote,clsComb.aNum,nSorte,fin))
    Next
    
    Call Scrivi ("Tempo di elaborazione : " & FormattaSecondi( Timer - TimeStart ))
End Sub

Sub AlimentaCollLunghetta(CollLunghette,CollCombBase,aNumBase,aNumDaSvil,nClasseLunghetta,nSorte,IndexCur)

    Dim aCol
    ReDim aCol(0)
    Dim aColonne,k,y
    Dim sKey
    Dim cItem
    Dim bValida
    Dim nNumToFound
    Dim nClasseSvilCompl
    
    nClasseSvilCompl = nClasseLunghetta - nSorte
    
    Call InitSviluppoIntegrale(aNumDaSvil,nClasseSvilCompl)
    Do While GetCombSviluppo(aCol)
        bValida = True
        'ReDim Preserve aCol(nClasseLunghetta)
'        For k = 1 To UBound(aNumBase)
'            aCol(nClasseLunghetta -(k - 1)) = aNumBase(k)
'        Next
'        Call OrdinaMatrice(aCol,1)
'        
        aColonne = SviluppoIntegrale(aCol,nSorte)
        For k = 1 To UBound(aColonne)
            sKey = "k"
            For y = 1 To nSorte - 1
                sKey = sKey & Format2(aColonne(k,y)) & "."
            Next
            sKey = sKey & Format2(aColonne(k,y))
            If GetItemCollection(CollCombBase,sKey,cItem) Then
                If cItem.Index > IndexCur Then
                    nNumToFound = aColonne(k,nSorte )
                    bValida = False
                    Exit For
                End If
            End If
        Next    
        If bValida Then
            ReDim Preserve aCol(nClasseLunghetta)
            For k = 1 To UBound(aNumBase)
                aCol(nClasseLunghetta -(k - 1)) = aNumBase(k)
            Next
            Call OrdinaMatrice(aCol,1)

            Set cItem = New clsCombinazione
            cItem.Index = IndexCur
            cItem.aNum = aCol
            sKey = "k" & StringaNumeri(aCol)
            Call AddItemColl(CollLunghette,cItem,sKey)
        Else
            For k  = nClasseSvilCompl To 1 Step -1
                If aCol(k)= nNumToFound Then
                    Call ForzaIncrementoPuntatoreSvilSisInt (k)
                    Exit For
                End If
            Next
        End If
        
    Loop
End Sub
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
        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 GetItemCollection(Coll,sKey,cItem)
    On Error Resume Next
    Set cItem = Coll(sKey)
    If Err <> 0 Then
        Err.Clear
        GetItemCollection = False
    Else
        GetItemCollection = True
    End If
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

Beppignello · 20 Marzo 2016

08.14.33.49.77 -- - Rit 82
01.30.32.55.64 -- - Rit 67
48.60.76.82.88 -- - Rit 67
Tempo di elaborazione : 00:00:04
9:58:57 AM : 9:59:13 AM

16 secondi esatti per trovare le cinquine più in ritardo per ambo a Tutte le ruote

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

38.43.48.53.60.70.73.82.83.88 -- - Rit 28
07.12.38.39.41.43.48.50.53.88 -- - Rit 27
38.41.43.48.50.53.60.70.83.88 -- - Rit 27
38.41.43.48.53.60.70.73.82.83 -- - Rit 27
38.41.43.48.53.60.70.73.82.88 -- - Rit 27
38.41.43.48.53.60.70.73.83.88 -- - Rit 27
38.41.43.48.53.60.70.82.83.88 -- - Rit 27
38.41.43.48.53.60.73.82.83.88 -- - Rit 27
38.41.43.48.53.70.73.82.83.88 -- - Rit 27
38.41.43.48.60.70.73.82.83.88 -- - Rit 27
38.41.48.53.60.70.73.82.83.88 -- - Rit 27
41.43.48.53.60.70.73.82.83.88 -- - Rit 27
Tempo di elaborazione : 00:00:54
10:00:48 AM : 10:01:54 AM

1 minuto e 6 secondi per trovare le migliori decine per ambo a Tutte

mi sembra ottimo

LuigiB · 20 Marzo 2016

ciao Bep , mi sa che nel tuo calcolo del tempo includi anche il tempo impiegato dall'utente a dare i vari input , nel mio script il tempo lo calcola dal momento in cui l'utente ha finito di inserire gli input al momento in cui finisce. C'è qualche secondo di differenza era solo da notare .. sul mio pc le cinquine a tutte per ambo le fa in 3 secondi.
Purtroppo sviluppare classi maggiori della decina rimane sempre piu lento per forza di cose ...

Beppignello · 20 Marzo 2016

si ho messo velocemente il time, prima dell'inserimento e delle scelte, poco importa per il tempo effettivo, siamo nell'ordine
di pochi secondi.

piuttosto
ho elaborato lo script per una undicina per ambo, mi da errore, dopo l'elaborazione prima di emettere l'output.

il mio invece ottiene quanto segue:

Ritardo Freq. Combinazione Lunghetta
0027 / 0027 7295 38.41.43.48.53.60.70.73.82.83.88
0023 / 0023 7108 1.7.18.19.38.41.43.54.82.88.89

Totale Combinazioni....2
Tempo elaborazione..10:21:07 AM : 10:22:11 AM

1 minuti e qualche secondo

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

Beppignello · 20 Marzo 2016

come cercavo di dirti prima, chiedendoti un parere, questa specie di routine potrebbe servire a qualcosa per velocizzare
soprattutto nelle lunghette con diversi numeri e lunghezze, prima di utilizzare e ricalcolare il ritardo

se per esempio abbiamo una decina da elaborare, basta un solo ambo con ritardo minore per essere esclusa
lo fa solo calcolandone 9 e non 45 come fosse l'integrale.
se può servire:
AmbiRitardovalido = 0
For jk = 1 To(n - 1)
ritardoattuale = minim(numeri(jk),numeri(n))
If Int(ritardoattuale) < Int(maxmax(numericercati)) Then
Exit For
Else
AmbiRitardovalido = AmbiRitardovalido + 1
End If
Next

LuigiB · 20 Marzo 2016

stavo cercando di capire l'errore che dicevi ma a me ha funzionato .. ci ha messo un quarto d'ora ..

free image hosting

Spaziometria o uno script possono rilevare la 10ina + in ritardo x A su tutte?

LuigiB

Guest

i legend

Premium Member

Beppignello

Guest

i legend

Premium Member

Joe91

Advanced Member >PLATINUM PLUS<

Beppignello

Guest

Beppignello

Guest

LuigiB

Guest

i legend

Premium Member

Beppignello

Guest

LuigiB

Guest

Beppignello

Guest

LuigiB

Guest

Beppignello

Guest

LuigiB

Guest

Beppignello

Guest

LuigiB

Guest

Beppignello

Guest

Beppignello

Guest

LuigiB

Guest

Ultima estrazione Lotto

Ultimi Messaggi