Sfida numero 2: numeri palindromi

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Per questa sfida (proposta da Luca73) si tratta di giocare con i numeri palindromi.
Abbiamo già in passato affrontato un esercizio per verificare se un numero è palindromo oppure no.
Ecco quindi la sfida: "Scrivere una routine VBA che, dato un numero intero e positivo di n cifre, restituisca il numero palindromo più vicino che sia superiore al numero dato".
Si possono usare tutte le tecniche note.

Esempi:

784351 ---> 784487
80123  ---> 80208
6532   ---> 6556

Le proposte verranno accettate solo fra cinque giorni da adesso: quindi potrete pubblicare i vostri post da domenica 3 marzo 2019 a partire dalle ore 12. Questa discussione viene chiusa da ora e riaperta al momento giusto.

Eventuali richieste di chiarimento potranno essere fatte in chat o direttamente alla mail della Redazione.

Il vincitore verrà stabilito mediante sondaggio aperto a tutta la comunità: il sondaggio durerà qualche giorno (verrà stabilito al momento della chiusura della sfida). Solo le risposte che arriveranno in questa discussione verranno prese in considerazione.
In caso di parità si terrà conto del criterio cronologico. Ognuno può pubblicare tutte le soluzioni che vuole, ma solo l'ultima postata verrà tenuta in considerazione in caso di parità di voti ottenuti.

Il vincitore avrà la soddisfazione di aver partecipato e di aver illustrato qualche tecnica magari nuova o interessante. Inoltre avrà l'onore di proporre la sfida successiva!

Quindi pronti? ...via! cominciate a pensarci, ci rivediamo qui a partire da domenica prossima!

[patelModeratore patel Karma: 51 pts]

propongo questa UDF

Option Explicit

Function palindromo(cella As Double) As Double
Dim L As Integer, L2 As Integer, s1 As String, pal As String, s As String
s = LTrim(Str(cella))
L = Len(s)
L2 = L / 2 + 0.1
s1 = Left(s, L2)
If L Mod 2 = 1 Then
  pal = s1 & StrReverse(Left(s1, Len(s1) - 1))
Else
  pal = s1 & StrReverse(s1)
End If
If Val(pal) <= Val(s) Then
  s1 = Str(Val(s1) + 1)
  If L Mod 2 = 1 Then
    pal = s1 & StrReverse(Left(s1, Len(s1) - 1))
  Else
    pal = s1 & StrReverse(s1)
  End If
End If
palindromo = Val(pal)
End Function

[albatros54Moderatore albatros54 Karma: 89 pts]

For Dummies:

Sub palindromo1()
    Dim a As String
    Dim somma As Variant

    a = CDbl(InputBox("dammi il valore"))
    somma = a
    Do
        somma = somma + 1 ' segno - per palindromo inferiore
    Loop Until somma = StrReverse(somma)
    MsgBox "Il numero palindromo superiore a " & a & " è " & somma
End Sub

altra senza "StrReverse"

Sub palindromo2()

    Dim lngCont As Integer, lngpalindromo As Integer, lngb As String
    '
    Dim stra As String
    Dim lnglun As Long
    '
    Dim strEstr As String, strFinl As String
    '

    lngCont = 1
    stra = InputBox("dammi il valore")
    lnglun = Len(stra)
    lngb = CDbl(stra)
    Do Until lngCont >= lnglun
        strEstr = Mid(lngb, lngCont, 1)
        strFinl = Mid(lngb, lnglun + 1 - lngCont, 1)
        If strEstr = strFinl Then
            lngCont = lngCont + 1
        Else

            lngb = lngb + 1
            lnglun = Len(lngb)
            If strEstr <> strFinl Then
                lngCont = 1
            End If
        End If

    Loop

    MsgBox "Il numero palindromo superiore a " & stra & " è " & lngb

End Sub

Funzione, da inserire in cella:

Public Function palindromo3(ByVal stra As Variant)
    Dim lngCont As Integer, lngpalindromo As Integer, lngb As String
    Dim lnglun As Long
    Dim strEstr As String, strFinl As String
    

    lngCont = 1
    lnglun = Len(stra)
    lngb = stra
    Do Until lngCont >= lnglun
        strEstr = CDbl(Mid(lngb, lngCont, 1))
        strFinl = CDbl(Mid(lngb, lnglun + 1 - lngCont, 1))
        If strEstr = strFinl Then
            lngCont = lngCont + 1
        Else

            lngb = lngb + 1
            lnglun = Len(lngb)
            If strEstr <> strFinl Then
                lngCont = 1
            End If
        End If

    Loop
    palindromo3 = lngb

End Function

Allego file con tutte le routine

 

Edit by VF: ho aggiustato un pochino il format di questo post che si era un po' sballato 🙂

 

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.

[patelModeratore patel Karma: 51 pts]

Albatros, i miei complimenti per la prima  come ho fatto a non pensarci ?  

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Mi associo a patel, è bellissima  

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Chiusura della sfida con accettazione delle proposte: martedì 5 marzo ore 16! Poi via col televoto 😀

[patelModeratore patel Karma: 51 pts]

Aggiungo la UDF derivata dalla prima di albatros

Function fpalindromo(cella As Long) As Long
    Dim somma As Long
    somma = cella
    Do
        somma = somma + 1 ' segno - per palindromo inferiore
    Loop Until somma = StrReverse(somma)
    fpalindromo = somma
End Function

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Albatros esagerato, vuoi stravincere?     

@patel, la tua soluzione non restituisce il palindromo superiore corretto in caso di numeri a due cifre come per esempio 55 (deve essere 66), dacci un'occhiata; inoltre trattando con numeri Long restituisce errore di Overflow quando ne superi i limiti (prova con 12345678901).

@albatros, le soluzioni numero 2 e 3 non restituiscono il palindromo superiore corretto per numeri come 66 o 88. 

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac ha scritto:

, le soluzioni numero 2 e 3 non restituiscono il palindromo superiore corretto per numeri come 66 o 88.

basta aggiungere 1 alla variabile lngb, sia nella prima che nella seconda

lngb = CDbl(stra) + 1

 

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 )

[scossaPartecipante scossa Karma: 37 pts]

Ciao,

arrivo in ritardo (tanto per cambaiare); avevo scritto una prima soluzione con la stessa logica di Albatros (la più intuitiva, basat sul valore numerico):

Function fPalin(ByVal sVal As String, Optional ByVal bSelf As Boolean = True) As Long
  
  If sVal = StrReverse(sVal) And bSelf Then sVal = sVal + 1 'doppia conversione implicita
  Do While sVal <> StrReverse(sVal)
    sVal = CStr(CLng(sVal) + 1)
  Loop
  
  fPalin = StrReverse(sVal)

End Function

ma le prestazioni decadono all'aumentare della lunghezza della stringa (si possono superare le migliaia di loop)

quindi ho pensato di lavorare sulla stringa, evitando i loop :

Function fPalindro(ByVal sVal As String) As Long
 
  Dim sLeft As String, sRight As String, sLeftPal As String
  Dim nLen As Long, nLenL As Long
  
  If sVal = StrReverse(sVal) Then sVal = CStr(CLng(sVal + 1))
  nLen = Int(Len(sVal) / 2 + 0.5)
  nLenL = IIf(Len(sVal) Mod 2, nLen - 1, nLen)
  sLeft = Left(sVal, nLen)
  sRight = Right(sVal, nLen)
  sLeftPal = StrReverse(sLeft)
  If --sLeftPal < --sRight Then
    sLeft = CStr(--sLeft + 1)
  End If
  sLeftPal = StrReverse(Left(sLeft, nLenL))
  fPalindro = --(sLeft & sLeftPal)
  
End Function

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Che bello! abbiamo qui anche scossa, grazie     

[TextombPartecipante Textomb]

Anche se mi pare di rifriggere una frittata...

Sub N_Palindromi()

    Dim myN As Long
    
    myN = Application.InputBox("Inserisci un numero intero, positivo", Type:=1)
    
    If myN < 0 Then Exit Sub
    
        If myN < 9 Then
            myN = myN + 1
        ElseIf myN < 11 Then
            myN = 11
        Else
            F_Palindromo myN
        End If
    
    MsgBox Format(myN, "#,#")
    
End Sub

Function F_Palindromo(nVal As Long) As Long
    
    Dim nPal As Long
    Dim nChr As Long
    Dim Pvt As Long
    Dim halfN As Long
    Dim halfNpvt As Long
    Dim Bln_Odd As Boolean
    
    nChr = Len(CStr(nVal))
    
    Bln_Odd = Application.IsOdd(nChr)
    
    If Bln_Odd Then ' Se nChr è dispari estraggo il suo mediano Pvt
        Pvt = Mid(CStr(nVal), ((nChr / 2) + 0.5), 1)
        halfN = Left(CStr(nVal), (nChr / 2) - 0.5)
        nPal = CLng(halfN & Pvt & StrReverse(halfN))
    Else
        ' Il numero di caratteri è pari.
        halfN = Left(CStr(nVal), nChr / 2)
        nPal = CLng(halfN & StrReverse(halfN))
    End If
    
    
    ' Verifico la condizione iniziale
    ' Se è così, termino la funzione...
    If nPal > nVal Then
        nVal = nPal
        Exit Function
    End If
    
        ' Se sono qui vuol dire che il palindromo è inferiore al numero iniziale.
        ' Aggiungo 1 e faccio un altro giro...
        If Bln_Odd Then ' Si tratta di un numero dispari...
            halfNpvt = CLng(halfN & Pvt) + 1
            nVal = halfNpvt & Application.Rept("0", (nChr / 2 - 0.5))
        Else ' Si tratta di un numero pari...
            halfN = halfN + 1
            nVal = halfN & Application.Rept("0", nChr / 2)
        End If
        
        F_Palindromo nVal
        
End Function

[patelModeratore patel Karma: 51 pts]

vecchio frac ha scritto:

@patel, la tua soluzione non restituisce il palindromo superiore corretto in caso di numeri a due cifre come per esempio 55 (deve essere 66), dacci un'occhiata; inoltre trattando con numeri Long restituisce errore di Overflow quando ne superi i limiti (prova con 12345678901).

ho corretto

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao

Ecco le mie

la prima trova solo il palindrono superiore

Sub PalLTSup()
Dim MioNumero As Long
Dim NumPalMax As Long
Dim NumPari As Boolean
Dim VettoreParti(1 To 3)
Const Alto = 1
Const Medio = 2
Const Basso = 3
Dim LungMioNum

MioNumero = Range("C3")
If MioNumero = StrReverse(MioNumero) Then
    NumPalMax = MioNumero
Else
    LungMioNum = Len(Format(MioNumero, "0"))
    NumPari = Int(LungMioNum / 2) = LungMioNum / 2
    VettoreParti(Alto) = MioNumero \ (10 ^ (Int(LungMioNum / 2 + 0.5)))
    If Not NumPari Then
        VettoreParti(Medio) = (MioNumero \ (10 ^ (Int(LungMioNum / 2 - 0.5)))) Mod 10
    Else
        VettoreParti(Medio) = ""
    End If
    VettoreParti(Basso) = MioNumero Mod (10 ^ (Int(LungMioNum / 2)))
    If CLng(StrReverse(VettoreParti(Alto))) > VettoreParti(Basso) Then
        NumPalMax = CLng(VettoreParti(Alto) & VettoreParti(Medio) & StrReverse(VettoreParti(Alto)))
    Else
        NumPalMax = CLng(CLng(VettoreParti(Alto) & VettoreParti(Medio)) + 1) & StrReverse(Left((CLng(VettoreParti(Alto) & VettoreParti(Medio)) + 1), Int(LungMioNum / 2)))
    End If

End If
Range("E5") = NumPalMax
End Sub

La seconda trova sia il superiore chel'inferiore

Sub PalLT01()
Dim MioNumero As Long
Dim NumPalMin As Long
Dim NumPalMax As Long
Dim NumPari As Boolean
Dim VettoreParti(1 To 3)
Const Alto = 1
Const Medio = 2
Const Basso = 3
Dim LungMioNum

MioNumero = Range("C3")
If MioNumero < 10 Then
    NumPalMax = MioNumero
    NumPalMin = MioNumero
ElseIf MioNumero = 10 Then
    NumPalMax = 11
    NumPalMin = 9
ElseIf MioNumero = StrReverse(MioNumero) Then
    NumPalMax = MioNumero
    NumPalMin = MioNumero
Else
    LungMioNum = Len(Format(MioNumero, "0"))
    NumPari = Int(LungMioNum / 2) = LungMioNum / 2
    
    VettoreParti(Alto) = MioNumero \ (10 ^ (Int(LungMioNum / 2 + 1.5) - 1))
    If Not NumPari Then
        VettoreParti(Medio) = (MioNumero \ (10 ^ (Int(LungMioNum / 2 + 1.5) - 2))) Mod 10
    Else
        VettoreParti(Medio) = 0
    End If
    VettoreParti(Basso) = MioNumero Mod (10 ^ (Int(LungMioNum / 2)))
    If NumPari Then
        If CLng(StrReverse(VettoreParti(Alto))) > VettoreParti(Basso) Then
            NumPalMax = CLng(VettoreParti(Alto) & StrReverse(VettoreParti(Alto)))
            If VettoreParti(Alto) = 10 ^ (LungMioNum / 2 - 1) Then
                NumPalMin = CLng(String(LungMioNum - 1, "9"))
            Else
                NumPalMin = CLng((VettoreParti(Alto) - 1) & StrReverse((VettoreParti(Alto) - 1)))
            End If
        Else
            NumPalMax = CLng((VettoreParti(Alto) + 1) & StrReverse((VettoreParti(Alto) + 1)))
            NumPalMin = CLng(VettoreParti(Alto) & StrReverse(VettoreParti(Alto)))
        End If
    Else
        If CLng(StrReverse(VettoreParti(Alto))) > VettoreParti(Basso) Then
            NumPalMax = CLng(VettoreParti(Alto) & VettoreParti(Medio) & StrReverse(VettoreParti(Alto)))
            If CLng(VettoreParti(Alto) & VettoreParti(Medio)) = 10 ^ (LungMioNum / 2 - 0.5) Then
                NumPalMin = CLng(String(LungMioNum - 1, "9"))
            Else
                NumPalMin = CLng(CLng(VettoreParti(Alto) & VettoreParti(Medio)) - 1) & StrReverse((CLng(VettoreParti(Alto) & VettoreParti(Medio)) - 1) \ 10)
            End If
        Else
            NumPalMax = CLng(CLng(VettoreParti(Alto) & VettoreParti(Medio)) + 1) & StrReverse((CLng(VettoreParti(Alto) & VettoreParti(Medio)) + 1) \ 10)
            NumPalMin = CLng(VettoreParti(Alto) & VettoreParti(Medio) & StrReverse(VettoreParti(Alto)))
        End If
    End If

End If
Range("C5") = NumPalMax
Range("C6") = NumPalMin
End Sub

 

[Luca73Partecipante Luca73 Karma: 58 pts]

Giusto per dettagliare.

Io nelle mie macro ho considerato il "superiore" come "uguale o superiore" pertanto il palindromo superiore di 55 è 55 stessso.

Così pure per l'inferiore. Pertanto quando in partenza avevo un numero singolo o già palindromo ho considerato se stesso.

Ciao a tutti

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

patel ha scritto:

ho corretto

Grazie a tutti ragazzi! Viste le numerose proposte, e poichè molte giocano sulle performances, sto preparando un piccolo test per il benchmark, così possiamo misurare i millisecondi. Inoltre sto valutando se pubblicare anche la mia soluzione, non vorrei però fare la solita figura   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Textomb ha scritto:

Anche se mi pare di rifriggere una frittata...

Grazie mille textomb! Ti si rivede !    

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Luca73 ha scritto:

Giusto per dettagliare.

Grazie Luca! il proponente della sfida 😀

Luca73 ha scritto:

nelle mie macro ho considerato il "superiore" come "uguale o superiore"

Quando mi avevi proposto la sfida non lo avevi precisato, ed è per questo che ho fatto la precisazione a patel. Pertanto a questo punto possiamo accettare e considerare valide le proposte che restituiscono lo stesso numero come "uguale o superiore" se è già palindromo (5555 = 5555).

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

@textomb controlla la tua seconda proposta, non mi dà risultati corretti.

?f_palindromo(5670)
 0 

Cosa sbaglio?

[TextombPartecipante Textomb]

Si tratta di una funziona ricorsiva... Viene richiamata dalla Sub N_Palindromi()...

Se la fai viaggiare in assenza della sub chiamante non da i risultati attesi.

Fai sapere...

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Ah ecco, non sono stato attento    scusami   

[patelModeratore patel Karma: 51 pts]

vecchio frac ha scritto:

Grazie a tutti ragazzi! Viste le numerose proposte, e poichè molte giocano sulle performances, sto preparando un piccolo test per il benchmark, così possiamo misurare i millisecondi.....

In un caso del genere secondo me le performances non sono prioritarie, conta l'idea più brillante e che utilizza meno righe di codice

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Certamente! Conterebbe anche l'idea più originale, o quella più ricercata, o quella più inusuale... poichè si lascia la scelta al giudizio popolare, ognuno può adottare il metro che ritiene più idoneo. Secondo me anche le performances possono essere rilevanti, almeno a livello statistico   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

In effetti in questa prova le differenze di performances non sono significative. I millisecondi impiegati sono decisamente trascurabili (da zero a 16 nei casi peggiori). Ho testato ogni routine con cento numeri da "palindromizzare" (uguali per tutti) e l'unica osservazione rilevante è che in generale fra tutte solo le ultime due routines di Albatros soffrono qualche rallentamento nell'elaborare alcune conversioni (in circa il sei-otto per cento dei casi e comunque entro i 16 ms).

[scossaPartecipante scossa Karma: 37 pts]

vecchio frac ha scritto:

In effetti in questa prova le differenze di performances non sono significative. I millisecondi impiegati sono decisamente trascurabili ....

Avevo fatto anch'io un test, con circa 34000 righe: sul mio pc (non troppo performante) le routine con il ciclo impiegano mediamente 10 sec. (Do .. Until ... Loop), o 9 sec. (Do .. While .. Loop), mentre l'altra mia proposta impiega poco più di 5 secondi ... direi che in assoluto la differenza c'è, nell'uso pratico invece dipende da quanti numeri devi elaborare.

 

[Autore]

Articoli