Sfida sui numeri palindromi

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

alexps81 ha scritto:

bisogna trovare tutti quei numeri che, arrivando fino a 10.000

Secondo la precisazione di Albatros, bisogna trovare i numeri PRIMI nell'intervallo considerato da 1 a 10000 escludendo 1, 3, 5, 7. Quindi 9 non va bene perchè non è primo anche se la sua rappresentazione in base due è palindroma (1001).

All'inizio pure io avevo frainteso la consegna.

[Seawolf Seawolf]

Mi sta piacendo questa partecipazione    

[albatros54Moderatore albatros54 Karma: 89 pts]

albatros54 ha scritto:

Forse non siamo stati chiari, vi prego di rileggere i vari interventi, il quesito chiede di trovare in un RANGE che va da 1 a 10000, i numeri primi(1230), una volta trovati questi numeri primi, convertirli in BINARIO e verificare se il  numero DECIMALE   corrispondente al BINARIO sono PALINDROMI

Come evidenziato, la sfida chiede di trovare , in un RANGE da 1 a 10000 , i NUMERI PRIMI, una volta trovati questi numeri primi(nel RANGE), per ogni NUMERO PRIMO trovato scrivere nella cella accanto il suo VALORE in formato BINARIO.

Quindi mi trovero ad avere , nella colonna"A" il valore decimale del numero PRIMO, nella colonna "B" il CORRISPONDENTE valore in BINARIO, a questo punto debbo verificare che il valore della colonna"A"(Decimale NUMERO PRIMO e il suo CORRISPONDENTE (Valore BINARIO) siano PALINDROMI.

Nel controllo debbono essere esclusi i NUMERI PRIMI 1- 3 -5 -7  .

Allego screenshot

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

[joke /on]

Sì però tu mi destabilizzi "lupo di mare", un po' accedi e un po' no, una volta sei nu utente registrato, un'altra volta no ma hai lo stesso avatar.
Io ho una certa età e con questi salti mentali faccio fatica   

[joke /off]

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac ha scritto:

Sì però tu mi destabilizzi "lupo di mare", un po' accedi e un po' no, una volta sei nu utente registrato, un'altra volta no ma hai lo stesso avatar. Io ho una certa età e con questi salti mentali faccio fatica

"seawolf" era da telefonino.  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao A tutti

Qui sottola mia Sub + Function Per trovare I numeri Palindromi tra i numeri primi minori di 10000 e maggiori di 7

Ho redatto la sub in modo che mi identifiche 

a) solo i numeri palindromi in base 10

b) solo i numeri palindromi in base 2

c) solo i numeri che sono palindromi sia in base 10 che in base 2

Option Explicit

Sub PalindromiPrimiDecEBin()
Dim VettoreNumeriPrimi()
Dim Numero As Integer
Dim Divisore As Integer
Dim NumeroPrimo As Boolean
Dim Index As Integer
Dim ContaDecPalin As Integer
Dim TextDecPalin As String
Dim ContaBinPalin As Integer
Dim TextBinPalin As String
Dim ContaDeBPalin As Integer
Dim TextDeBPalin As String
' Il Vettore VettoreNumeriPrimi ha 5 posizioni che sono
' VettoreNumeriPrimi(1, X) = il Numero Primo in notazione decimale
' VettoreNumeriPrimi(2, X) = il Numero Primo in notazione binaria
' VettoreNumeriPrimi(3, X) = Booleano= True se il Numero Primo in notazione decimale è palindromo
' VettoreNumeriPrimi(4, X) = Booleano= True se il Numero Primo in notazione binaria è palindromo
' VettoreNumeriPrimi(5, X) = Booleano= True se sia il numero in notazione decimale che in notazione binaria sono palindromo
ReDim VettoreNumeriPrimi(5, 1)
VettoreNumeriPrimi(1, 1) = 2
VettoreNumeriPrimi(2, 1) = "" & 10
VettoreNumeriPrimi(3, 1) = True
VettoreNumeriPrimi(4, 1) = False
VettoreNumeriPrimi(5, 1) = False
For Numero = 3 To 10000
NumeroPrimo = True
    For Divisore = 1 To UBound(VettoreNumeriPrimi, 2)
        If ((Numero Mod VettoreNumeriPrimi(1, Divisore)) = 0) Then
            NumeroPrimo = False
            Exit For
        End If
    Next Divisore
    If NumeroPrimo Then
        ReDim Preserve VettoreNumeriPrimi(5, UBound(VettoreNumeriPrimi, 2) + 1)
        VettoreNumeriPrimi(1, UBound(VettoreNumeriPrimi, 2)) = Numero
        VettoreNumeriPrimi(2, UBound(VettoreNumeriPrimi, 2)) = DecToBin(Numero)
        VettoreNumeriPrimi(3, UBound(VettoreNumeriPrimi, 2)) = (VettoreNumeriPrimi(1, UBound(VettoreNumeriPrimi, 2)) = StrReverse(VettoreNumeriPrimi(1, UBound(VettoreNumeriPrimi, 2))))
        VettoreNumeriPrimi(4, UBound(VettoreNumeriPrimi, 2)) = (VettoreNumeriPrimi(2, UBound(VettoreNumeriPrimi, 2)) = StrReverse(VettoreNumeriPrimi(2, UBound(VettoreNumeriPrimi, 2))))
        VettoreNumeriPrimi(5, UBound(VettoreNumeriPrimi, 2)) = VettoreNumeriPrimi(3, UBound(VettoreNumeriPrimi, 2)) And VettoreNumeriPrimi(4, UBound(VettoreNumeriPrimi, 2))
        'For Index = 1 To 5
        '    Cells(UBound(VettoreNumeriPrimi, 2), Index) = VettoreNumeriPrimi(Index, UBound(VettoreNumeriPrimi, 2))
        'Next Index
    End If
Next Numero
ContaDecPalin = 0
TextDecPalin = ""
ContaBinPalin = 0
TextBinPalin = ""
ContaDeBPalin = 0
TextDeBPalin = ""
For Index = 1 To UBound(VettoreNumeriPrimi, 2)
    If VettoreNumeriPrimi(1, Index) > 7 Then
        If VettoreNumeriPrimi(3, Index) Then
            ContaDecPalin = ContaDecPalin + 1
            TextDecPalin = TextDecPalin & vbCrLf & VettoreNumeriPrimi(1, Index)
        End If
        If VettoreNumeriPrimi(4, Index) Then
            ContaBinPalin = ContaBinPalin + 1
            TextBinPalin = TextBinPalin & vbCrLf & VettoreNumeriPrimi(2, Index) & " (" & VettoreNumeriPrimi(1, Index) & ")"
        End If
        If VettoreNumeriPrimi(5, Index) Then
            ContaDeBPalin = ContaDeBPalin + 1
            TextDeBPalin = TextDeBPalin & vbCrLf & VettoreNumeriPrimi(1, Index) & " | " & VettoreNumeriPrimi(2, Index)
        End If
    End If
Next Index
MsgBox "I numeri Palindromi tra i numero primi maggiori di 7 e minori di 10000" & vbCrLf & "in base 10 sono: " & vbCrLf & ContaDecPalin & vbCrLf & vbCrLf & "Ovvero: " & vbCrLf & TextDecPalin
MsgBox "I numeri Palindromi tra i numero primi maggiori di 7 e minori di 10000" & vbCrLf & "in base 2 sono: " & vbCrLf & ContaBinPalin & vbCrLf & vbCrLf & "Ovvero: " & vbCrLf & TextBinPalin
MsgBox "I numeri Palindromi tra i numero primi maggiori di 7 e minori di 10000 " & vbCrLf & "sia in base 10 che in base 2 sono: " & vbCrLf & ContaDeBPalin & vbCrLf & vbCrLf & "Ovvero: " & vbCrLf & TextDeBPalin
End Sub

Function DecToBin(NumeroDec) As String
Dim MioNumDec
Dim MioNumBIn
MioNumDec = NumeroDec
MioNumBIn = ""
Do
    MioNumBIn = (MioNumDec Mod 2) & MioNumBIn
    MioNumDec = MioNumDec \ 2
Loop Until MioNumDec = 0
DecToBin = MioNumBIn
End Function

 

 

 

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Caspita siete tutti formidabili   

Albatros avrà un bel daffare a giudicare quello che gli piace di più   

[albatros54Moderatore albatros54 Karma: 89 pts]

Bene, pero invece di MSGBOX vorrei vedere il risultato su di un foglio di EXCEL come screenshot del post #41761  

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[LucaSRPartecipante LucaSR Karma: 15 pts]

vi posto il risultato finale, sempre se non ho sbagliato qualcosa :

Option Explicit

Private Sub cmbEstraPalindromi_Click()
    'Dichiara le variabili/oggetti
    Dim rngCella As Range
    Dim Numero As Integer
    'Inizializza le variabili/oggetti
    Set rngCella = Calcolo.Range("A2")
    'Cicla da 9 a 10000
    For Numero = 11 To 10000
        'Verifica che sia un numero palindromo primo e palindromo binario
        If isPalindromo(CStr(Numero)) And isPrimo(Numero) And IsPalindromoBinario(Numero) Then
            rngCella.Value = Numero
            rngCella.Offset(0, 1).Value = ConvertiInBinario(Numero)
            'Sposta la cella di una riga in basso
            Set rngCella = rngCella.Offset(1)
        End If
    Next Numero
    'Libera la memoria
    Set rngCella = Nothing
End Sub

Private Function isPalindromo(ByVal NumeroStringa As String) As Boolean
        'Dichira le variabili/oggetti
        Dim Pos As Integer
        'Verifica che il numero sia almeno di 2 caratteri
        If Len(NumeroStringa) > 1 Then
            'Cicla il NumeroStringa dalla posizione 1 alla metà della lunghezza della stessa
            For Pos = 1 To CInt(Len(NumeroStringa) / 2)
                'Verifica che il numero sia palindromo
                If Mid(NumeroStringa, Pos, 1) <> Mid(NumeroStringa, Len(NumeroStringa) - Pos + 1, 1) Then
                    isPalindromo = False
                    Exit Function
                End If
            Next Pos
            isPalindromo = True
        Else
            isPalindromo = False
        End If
End Function

Private Function isPrimo(ByVal Numero As Integer) As Boolean
    'Dichiara le variabili/oggetti
    Dim Ciclo As Integer
    'Verifica che il numero sia Pari
    If Numero Mod 2 = 0 Then
        isPrimo = False
        Exit Function
    End If
    'Cicla i numeri dispari fino al numero interessato
    For Ciclo = 3 To Numero Step 2
        'Verifica che il numero sia Pari
        If Numero Mod Ciclo = 0 And Ciclo <> Numero Then
            isPrimo = False
            Exit Function
        End If
    Next Ciclo
    'Numero è primo
    isPrimo = True
End Function

Private Function ConvertiInBinario(ByVal Numero As Integer) As String
    'Dichiara le variabili/oggetti
    Dim Ciclo As Integer, Parziale As Integer, Totale As Integer
    Dim Binario As String
    'Inizializza le variabili/oggetti
    '********************************
    'lo so che non ci sarebbe bisogno di inizializzare le variabili in VBA,
    'ma è una vecchia tecnica di programmazione che mi porto dietro da tempo
    'che però mi permette di scrivere in qualsiasi linguaggio senza pensare se
    'quest'ulitmo inizializzi o meno le variabili
    '********************************
    Totale = 0
    Binario = ""
    'Ciclo dell'esponente
    For Ciclo = 13 To 0 Step -1
        Parziale = (2 ^ Ciclo) '- 1
        'Cerca il bit più significativo
        If Numero >= Parziale + Totale Then
            Binario = Binario & "1"
            Totale = Totale + Parziale
        Else
            Binario = Binario & "0"
        End If
    Next Ciclo
    'Ritorna la stringa del numero in binario
    ConvertiInBinario = Mid(Binario, InStr(1, Binario, 1))
End Function

Private Function IsPalindromoBinario(ByVal Numero As Integer) As Boolean
    IsPalindromoBinario = isPalindromo(ConvertiInBinario(Numero))
End Function

ho trovato una sola occorrenza che soddisfi le richieste, in attesa dell'arancina   

scusate ho dovuto ripostare perché avevo dimenticato una riga di codice di prova   

Allegati:

You must be logged in to view attached files.

[albatros54Moderatore albatros54 Karma: 89 pts]

albatros54 ha scritto:

Bene, pero invece di MSGBOX vorrei vedere il risultato su di un foglio di EXCEL come screenshot del post #41761

@ LucaSR  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[LucaSRPartecipante LucaSR Karma: 15 pts]

albatros54 ha scritto:

Bene, pero invece di MSGBOX vorrei vedere il risultato su di un foglio di EXCEL come screenshot del post #41761

penso di aver fatto ciò che hai chiesto, o sbaglio!?

[albatros54Moderatore albatros54 Karma: 89 pts]

LucaSR ha scritto:

penso di aver fatto ciò che hai chiesto, o sbaglio!?

ASSOLUTAMENTE SIIIII!! anzi, impegnati per completare la sfida, altrimenti vinci solo un'ARANCINO  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 ha scritto:

ASSOLUTAMENTE

Ma assolutamente sì o assolutamente no ?   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Comunque mi sto impegnando per mettere insieme altre sfide, visto il successo di pubblico   

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac ha scritto:

Albatros avrà un bel daffare a giudicare quello che gli piace di più

Per me hanno gia vinto tutti i partecipanti, anche se per ora siamo agli Albori , aspettando che scendano in campo i pezzi forti  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[LucaSRPartecipante LucaSR Karma: 15 pts]

vecchio frac ha scritto:

Ma assolutamente sì o assolutamente no ?      

Grazie grande capo, mi chiedevo la stessa cosa   

 

vecchio frac ha scritto:

Comunque mi sto impegnando per mettere insieme altre sfide, visto il successo di pubblico   

però non subito, ho un progetto da terminare       

[Luca73Partecipante Luca73 Karma: 58 pts]

Cancello il messaggio, sono talmente sbadato che l'avevo postato 2 volte

 

[scossaPartecipante scossa Karma: 37 pts]

Ciao, 

propongo la mia soluzione che scrive, per i  numeri naturali compresi tra 11 - preso sia come base 10 che come base 2 (quindi 3 in base 10) - a nMax (*), trova i numeri primi(*) palindromi in base 10 (colonna D), in base 2 (colonne E, F) e in entrambe le basi (colonne G, H).

Attenzione: ho corretto il codice per i palindromi "in entrambe le basi" 

(*) sub principale: numPalindromi(ByVal nMax As Long, Optional ByVal bIfPrimi As Boolean) dove nMax per default è 10.000;  bIfPrimi se True filtra solo i numeri primi, altrimenti li valuta tutti. Per comodità si può lanciare dalla sub lancia(). Ho provato con nMax 100.000 e li elabora in circa 80 (per tutti i numeri) 5 secondi (contro 11 centesimi di secondo per 10.000), non so con 1.000.000   

Allegato file.

Sub numPalindromi(ByVal nMax As Long, Optional ByVal bIfPrimi As Boolean)
  
  Dim j As Long, nRowDec As Long, nRowBin As Long, nRow As Long
  Dim cPrimi As Collection
  Dim sNum As String, nMin As Long
  Dim bPlnDec As Boolean, bPlnBin As Boolean
  Dim nStart As Double
  Dim nStop As Double
  
  nStart = MicroTimer
  
  Set cPrimi = New Collection
  Set cPrimi = uGeneraSequenza(nMax, bIfPrimi)
  Debug.Print Format(MicroTimer - nStart, "0.#####0")
  nRowDec = 3
  nRowBin = 3
  nRow = 3
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Range("D4:H" & 300003).ClearContents
  For j = 2 To cPrimi.Count
    sNum = cPrimi(j)(0)
    If sNum = StrReverse(sNum) Then
      If sNum > 10 Then
        bPlnDec = True
        nRowDec = nRowDec + 1
        Foglio1.Range("D" & nRowDec).Value = sNum
      End If
    End If
    sNum = cPrimi(j)(1)
    If sNum = StrReverse(sNum) Then
      bPlnBin = True
      nRowBin = nRowBin + 1
      Foglio1.Range("E" & nRowBin).Value = "'" & cPrimi(j)(0)
      Foglio1.Range("F" & nRowBin).Value = "'" & sNum
    End If
    If bPlnDec And bPlnBin Then
      nRow = nRow + 1
      Foglio1.Range("G" & nRow).Value = "'" & cPrimi(j)(0)
      Foglio1.Range("H" & nRow).Value = "'" & cPrimi(j)(1)
    End If
    bPlnDec = False
    bPlnBin = False
  Next j
  nStop = MicroTimer - nStart
  Debug.Print Format(nStop, "0.#####0")
  If nStop > 60 Then
    nMin = nStop / 60
    nStop = nStop - nMin * 60
  End If
  sNum = vbTab & nRowDec - 3 & " n.ri "
  If bIfPrimi Then sNum = sNum & "primi "
  sNum = sNum & "palindromi base 2" & vbCrLf
  sNum = sNum & vbTab & nRowBin - 3 & " n.ri "
  If bIfPrimi Then sNum = sNum & "primi "
  sNum = sNum & "palindromi base 10" & vbCrLf
  sNum = sNum & vbTab & nRow - 3 & " n.ri "
  If bIfPrimi Then sNum = sNum & "primi "
  sNum = sNum & "palindromi sia base 10 che base 2" & vbCrLf
  sNum = sNum & "sui numeri da 11 (dec e bin) a " & Format(nMax, "#,##0") & vbCrLf & vbCrLf
  sNum = sNum & "in " & nMin & " minuti e " & Format(nStop, "0.#####0") & " secondi"
  Set cPrimi = Nothing
  Foglio1.Range("D2").Value = "n.ri primi palindromi trovati sui primi " & Format(nMax, "#,##0") & " naturali" & vbCrLf & "in " & nMin & " minuti e " & Format(nStop, "0.#####0") & " secondi"
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "trovati" & sNum, vbInformation, "elaborazione terminata"
End Sub


Function uGeneraSequenza(ByVal nNums As Long, Optional ByVal bSoloPrimi As Boolean) As Collection
  Dim cRet As Collection, j As Long
  
  Set cRet = New Collection
  If bSoloPrimi Then
    For j = 1 To nNums
      If fPrimo(j) Then
        cRet.Add Array(j, fDecBin(j))
      End If
    Next j
  Else
    For j = 1 To nNums
      cRet.Add Array(j, fDecBin(j))
    Next j
  End If
  Set uGeneraSequenza = cRet
End Function

Public Function fDecBin(ByVal nDec As Long) As String
  Do While nDec <> 0
      fDecBin = Format(nDec - 2 * Int(nDec / 2)) & fDecBin
      nDec = Int(nDec / 2)
  Loop
End Function

Function fPrimo(ByVal nNum As Long) As Boolean
  Dim j As Long
  
  fPrimo = True
  If nNum Mod 2 = 0 Then
    fPrimo = False
  Else
    For j = 3 To nNum - 1 Step 2
        If nNum Mod j = 0 Then
          fPrimo = False
          Exit For
        End If
    Next j
  End If
End Function

 

Allegati:

You must be logged in to view attached files.

[LucaSRPartecipante LucaSR Karma: 15 pts]

Luca73 ha scritto:

Il quesito mi ricorda pezzi di vecchie sfide ma mischiate in maniera astuta e divertente....

Non ho partecipato a quelle precedenti, ma condordo con te, mi sto divertendo e mi sento stimolato nella creatività. Cose che non ho mai pensato mi servissero   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

propongo la mia soluzione

Naturalmente scossa spacca, però ero curioso di vedere la funzione MicroTimer che non trovo nel codice. E' un'API tua?

[scossaPartecipante scossa Karma: 37 pts]

vecchio frac ha scritto:

però ero curioso di vedere la funzione MicroTimer che non trovo nel codice. E' un'API tua?

No, è nel secondo modulo (mMicroTimer) del file.

`'MicroTimer function
'Found on the net
'
#If VBA7 Then

  Private Declare PtrSafe Function getFrequency _
              Lib "kernel32" _
              Alias "QueryPerformanceFrequency" ( _
              cyFrequency As Currency) _
              As Long
  
  
  Private Declare PtrSafe Function getTickCount _
              Lib "kernel32" _
              Alias "QueryPerformanceCounter" _
              (cyTickCount As Currency) _
              As Long
#Else
  Private Declare Function getFrequency _
              Lib "kernel32" _
              Alias "QueryPerformanceFrequency" ( _
              cyFrequency As Currency) _
              As Long
  
  
  Private Declare Function getTickCount _
              Lib "kernel32" _
              Alias "QueryPerformanceCounter" _
              (cyTickCount As Currency) _
              As Long
#End If


Public Function MicroTimer() As Double
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    MicroTimer = 0
    If cyFrequency = 0 Then getFrequency cyFrequency
    getTickCount cyTicks1
    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

`

scossa ha scritto:

non so con 1.000.000

ho provato, temevo peggio: 5 minuti e 20 secondi per trovare 874 palindromi base 10 (nessuno dopo 78487), 187 base 2 (nessuno dopo 524287), 6 entrambe (11, 55, 282, 808, 878, 7337).

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

ho provato, temevo peggio

Grazie scossa. Comunque interessante performance!

[scossaPartecipante scossa Karma: 37 pts]

vecchio frac ha scritto:

Comunque interessante performance!

considera che il mio è un pc vecchiotto:

[scossaPartecipante scossa Karma: 37 pts]

scossa ha scritto:

propongo la mia soluzione che scrive, per i  numeri naturali compresi tra 11 - preso sia come base 10 che come base 2 (quindi 3 in base 10) - a nMax (*), trova i numeri primi(*) palindromi in base 10 (colonna D), in base 2 (colonne E, F) e in entrambe le basi (colonne G, H). ......

Attenzione: sto rivedendo il codice perché nelle varie prove mi sono accorto che i valori per "entrambe le basi" sono errati!!

codice corretto e riallegato file nel post precedente.

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao

Mi permetto una nota a scossa:

Per verificare che i i numeri siano primi non serve dividere per tutti i numeri fino a n-1 si può velocizzare arrivando alla radicequadrata di n e per numeri alti dovrebbe fare la differenza.

 

[Autore]

Articoli