Fiumi di parole...

Stampa
( 0 Votes ) 
Valutazione attuale:  / 0
ScarsoOttimo 
Categoria: Informatica
Data pubblicazione
Scritto da Magellano Visite: 2662

Fiumi di parole...

Questo programma in VBA per Excel ricava TUTTI gli anagrammi, i palindromi, i bifronti e gli antipodi possibili a partire da un file 'vocabolario'
Innanzi tutto devo ringraziare Fragger per avermi messo a disposizione il suo vocabolario, con oltre 130 mila vocaboli comprendendo le declinazioni dei sostantivi, frutto di un lavoro monumentale, che mi ha permesso di estrarre tutti gli anagrammi, i bifronti, gli antipodi possibili, relativamente a tale dizionario. Prima di allora,la vecchia versione del programma era in grado di 'apprendere' le parole e creare un vocabolario facendogli leggere più file di testo (articoli, romanzi, saggi, ecc.) scaricati da internet o presi da cd-rom, ma ero arrivato a 'solo' diecimila vocaboli.

Dal suddetto vocabolario ho estratto un file di testo in cui vi sono solo le parole, in maiuscolo, non ordinate alfabeticamente, una per ogni riga di testo, cioè separate da un carattere di return. La routine di caricamento legge quindi il file senza alcuna difficoltà.

Vocabolario: Vocaboli.zip

Il problema della ricerca degli anagrammi di una parola si dovrebbe ricondurre alla ricerca di tutte le possibili permutazioni delle lettere di quella parola. Se le lettere sono 6, si hanno 6! (si legge sei fattoriale o fattoriale di 6) = 1*2*3*4*5*6 = 720 combinazioni. Il fattoriale cresce molto in fretta, come è facile verificare: ad es. 10! = 3.628.800.

 E' facile capire quindi che un computer anche veloce impiega molto tempo per cercare la presenza di eventuali parole nel dizionario che siano anagrammi della parola data.

Nonostante questo, già trent'anni fa si vedeva in TV un programma, Paroliamo, presentato da un giovanissimo Fabrizio Frizzi, in cui si estraevano delle lettere ed occorreva trovare le parole più lunghe componibili con tali lettere; il computer, non certo veloce come quelli di oggi, le trovava in un batter d'occhio. Come mai?

In sostanza esso cercava gli anagrammi costruibili con gruppi delle lettere estratte. In realtà si usava un trucco che aggirava il problema degli anagrammi:

si ricavava la 'radice' della parola da anagrammare, che era una stringa di caratteri ottenuta dalla parola data riordinando alfabeticamente le sue lettere; questa stringa ha la proprietà di coincidere con le radici degli anagrammi della parola data. Queste radici sono le chiavi univoche di un archivio che le collega a quei gruppi di parole ottenibili una dall'altra per anagramma. Basta allora costruire preventivamente un vocabolario ordinato per chiavi, alle quali sono associate le parole, ed il gioco è fatto.

 

Il programma ricava:

 

- i palindromi (es. anilina): basta controllare per ogni parola se la stringa ottenuta invertendo l'ordine delle lettere coincide con la parola data;

- gli anagrammi: basta ordinare le parole in base alle loro radici, come detto innanzi;

- i bifronti (es. acetone, enoteca): si cercano tra i gruppi di anagrammi di una stessa parola;

- gli antipodi: possono essere di vari tipi e si cercano ancora tra i gruppi di anagrammi:

1. antipodo bifronte diretto (battello, bolletta), si porta in fondo la prima lettera e si legge al contrario

2. antipodo bifronte inverso (torace, carota), si porta in cima l'ultima lettera e si legge al contrario

3. antipodo palindromo diretto (banana), si porta in fondo la prima lettera e si legge al contrario

4. antipodo palindromo inverso (ananas), si porta in cima l'ultima lettera e si legge al contrario

 

Poiché i bifronti e gli antipodi sono anche degli anagrammi, essi vengono ricavati successivamente dalla tabella dei gruppi di anagrammi che viene ricavata.

Perciò il programma esegue le seguenti routine, nell'ordine:

 

- cancellazione e creazione di fogli distinti per lunghezza dei vocaboli (non ci starebbero in un unico foglio)

- caricamento dei dati sui fogli, estrazieone delle radici, ricerca dei palindromi

- ordinamento alfabetico per radice
- ricerca degli anagrammi per ciascuna radice
- ricerca dei bifronti
-ricerca degli antipodi

 

Altri giochi di enigmistica, come le zeppe, gli scarti, i cambi, i lucchetti, le cerniere,le sciarade, ecc., richiedono algoritmi più complessi ed un tempo di elaborazione più lungo; la loro ricerca non è stata perciò affrontata.

 

ATTENZIONE: poichè non è prevista l'apertura di una finestra di dialogo per la ricerca del percorso del file vocabolario.txt, questo dovrà risiedere nella stessa cartella di Windows del file di Excel che avete aperto.

Create perciò una cartella di Windows, metteteci dentro il file del vocabolario, create al suo interno una cartella di lavoro di Excel. Aprite Strumenti/Macro/Visual Basic Editor, copiate il codice seguente nello spazio del VBA all'interno della finestra di codice di ThisWorkbook, come già fatto in altre lezioni.

Per lanciare l'esecuzione del programma posizionate il cursore all'interno della routine Main e premete F5 o cliccate sul pulsante di esecuzione delle routine; alla richiesta del nome del file del dizionario, rispondete scrivendo "vocabolario.txt".

 

Per rendere il lavoro più professionale, inseriamo invece un pulsante di avvio personalizzato:

Sulla finestra di Excel (non del VBA) andate su Visualizza/Barra degli strumenti/Personalizza…

Nella finestra di dialogo Personalizza che si apre, sulla scheda Comandi si scelga Macro, si trascini il pulsante personalizzato (la faccina sorridente) posizionandolo su una barra dei pulsanti.

Prima di chiudere la finestra Personalizza, cliccare col destro sul pulsante e, se volete, potete cambiare icona o addirittura modificarla ridisegnandola. Assegnate al pulsante la routine Main andando su Assegna Macro… e scegliendo dall’elenco la routine ThisWorkbook.Main.

 

Per non allungare troppo questo articolo e per evitare di inserire molti commenti tra le istruzioni, si rinvia la spiegazione dettagliata del funzionamento di ciascuna routine ad una prossima lezione.

Buon divertimento!

 

 


   

Option Explicit
Const LMin As Integer = 5
Const LMax As Integer = 25
'lunghezze min e max delle parole cercate
Dim Percorso As String, NomeFile As String

 

Sub Main()
Application.DisplayAlerts = False
EliminaFogli 'elimina i fogli tranne uno

Application.DisplayAlerts = True

CreaFogli 'crea i fogli su cui mettere le parole

Sheets("ANAGRAMMI").Select 'seleziona ANAGRAMMI per visualizzare il contatore

Percorso = Path & "\"

NomeFile = InputBox("Nome del file (*.txt)?", "NOME DEL FILE") 'legge il nome del vocabolario

CaricaParole 'legge i vocaboli e li mette su fogli distinti in base alla lunghezza

OrdinaRadici 'riordina alfabeticamente tutte le tabelle in base alle radici

TrovaAnagrammi 'trova le parole che hanno la stessa radice

TrovaBifronti

TrovaAntipodi
Beep
MsgBox "FINE"

End Sub

 

Sub EliminaFogli()
'elimina i fogli tranne uno

Dim N As Integer
For N = Sheets.Count To 2 Step -1
    Sheets(N).Delete

Next N
End Sub

 

Sub CreaFogli()
'crea i fogli di raccolta di anagrammi, palindromi, bifronti

Dim N As Integer
Sheets(1).Name = "ANAGRAMMI" 'crea il foglio Main

Sheets.Add
ActiveSheet.Name = "PALINDROMI"
Sheets.Add
ActiveSheet.Name = "BIFRONTI"
Sheets.Add
ActiveSheet.Name = "ANTIPODI"
'crea i fogli contenenti le parole, distinte per lunghezza

For N = LMin To LMax
    Sheets.Add
    ActiveSheet.Name = Str(N)

Next N
End Sub

 

Sub CaricaParole()
'legge i vocaboli, ricava le radici e trova i palindromi

Dim N As Long, Riga As Integer, Z As Integer
Dim Parola As String, L As Integer
Open Percorso & NomeFile For Input As #1
With Sheets("PALINDROMI")
    .Select
    Do While Not EOF(1)

        Input #1, Parola
        L = Len(Parola)
        N = N + 1
        .Cells(1, 2) = N
        If L > LMin - 1 And L < LMax + 1 Then

            Riga = Sheets(Str(L)).Cells(1, 1) + 1

            Sheets(Str(L)).Cells(Riga + 1, 2) = Parola

            Sheets(Str(L)).Cells(Riga + 1, 1) = Radice(Parola)

            Sheets(Str(L)).Cells(1, 1) = Riga

            If Bifronte(Parola) = Parola Then
                Z = .Cells(1, 1)
                .Cells(Z + 2, 1) = Parola

                .Cells(1, 1) = Z + 1

            End If

        End If
        DoEvents 'serve per poter interrompere l'esecuzione

    Loop
End With
Close 1
End Sub

 

Sub OrdinaRadici()
'riordina alfabeticamente per radici i fogli del vocabolario

Dim L As Integer
For L = LMin To LMax
    Worksheets(Str(L)).Select

    Worksheets(Str(L)).Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _

        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Next L
End Sub

 

Sub TrovaAnagrammi()
'ricerca gli anagrammi in base alla coincidenza delle chiavi

Dim L As Integer, N As Integer, k As Integer, h, Z As Integer

With Sheets("ANAGRAMMI")
    .Select
    .Cells(1, 1) = 0

    For L = LMin To LMax

        N = Sheets(Str(L)).Cells(1, 1)

        For k = 2 To N + 1

            If Sheets(Str(L)).Cells(k, 1) = Sheets(Str(L)).Cells(k + 1, 1) Then

                Z = .Cells(1, 1)

                .Cells(Z + 2, 1).Select

                h = 0

                Do While Sheets(Str(L)).Cells(k, 1) = Sheets(Str(L)).Cells(k + h + 1, 1)

                    If h = 0 Then

                        .Cells(Z + 2, 1) = 1
                        .Cells(Z + 2, 2) = Sheets(Str(L)).Cells(k, 2)

                    End If

                    .Cells(Z + 2, 1) = .Cells(Z + 2, 1) + 1

                    .Cells(Z + 2, h + 3) = Sheets(Str(L)).Cells(k + h + 1, 2)

                    h = h + 1

                Loop

                k = k + h

                .Cells(1, 1) = Z + 1

                DoEvents

            End If

        Next k
    Next L
End With
End Sub

 

Function Radice(Parola As String) As String
'ricava la radice di una parola riordinando le lettere di ciascuna in ordine alfabetico

Dim Vett(25) As Integer
Dim L As Integer, i As Integer, j As Integer, k As Integer

Dim c As String
L = Len(Parola)
For k = 1 To L
    c = Mid(Parola, k, 1)

    Vett(k) = Asc(c)
Next k
For i = 1 To L - 1
    For j = i + 1 To L

        If Vett(i) > Vett(j) Then

            k = Vett(i)
            Vett(i) = Vett(j)
            Vett(j) = k
        End If
    Next j
Next i
Radice= ""
    For k = 1 To L

Radice= Radice+ Chr(Vett(k))

Next k
End Function

 

 

Sub TrovaBifronti()

'trova i bifronti tra i gruppi di anagrammi

Dim L As Integer, N As Integer, M As Integer
Dim k As Integer, i As Integer, j As Integer, Z As Integer

Dim Parola1 As String, Parola2 As String
With Sheets("BIFRONTI")
    .Select
    .Cells(1, 1) = 0

    N = Sheets("ANAGRAMMI").Cells(1, 1)

    For k = 1 To N

        M = Sheets("ANAGRAMMI").Cells(k + 1, 1)

        For i = 1 To M - 1

            For j = i + 1 To M

                Parola1 = Sheets("ANAGRAMMI").Cells(k + 1, i + 1)

                Parola2 = Sheets("ANAGRAMMI").Cells(k + 1, j + 1)

                If Parola2 = Bifronte(Parola1) Then

                    Z = .Cells(1, 1)
                    .Cells(1, 1) = Z + 1

                    .Cells(Z + 2, 1).Select
                    .Cells(Z + 2, 1) = Parola1

                    .Cells(Z + 2, 2) = Parola2

                End If

            Next j

        Next i
        .Cells(1, 3) = k
        DoEvents 'serve per poter interrompere l'esecuzione

    Next k
End With
End Sub

 

Sub TrovaAntipodi()
'trova gli antipodi, tra i gruppi di anagrammi, indicando a fianco il tipo di antipodo

Dim L As Integer, N As Integer, M As Integer
Dim k As Integer, i As Integer, j As Integer, Z As Integer

Dim Parola1 As String, Parola2 As String
With Sheets("ANTIPODI")
    .Select
    .Cells(1, 1) = 0

    N = Sheets("ANAGRAMMI").Cells(1, 1)

    For k = 1 To N

        M = Sheets("ANAGRAMMI").Cells(k + 1, 1)

        For i = 1 To M

            For j = i To M

                Parola1 = Sheets("ANAGRAMMI").Cells(k + 1, i + 1)

                Parola2 = Sheets("ANAGRAMMI").Cells(k + 1, j + 1)

                If Parola2 = Left(Parola1, 1) & Bifronte(Right(Parola1, Len(Parola1) - 1)) Then

                    Z = .Cells(1, 1)

                    .Cells(1, 1) = Z + 1
                    .Cells(Z + 2, 1).Select

                    .Cells(Z + 2, 1) = Parola1

                    .Cells(Z + 2, 2) = Parola2

                    If i = j Then .Cells(Z + 2, 3) = "antipodo PALINDR. DIR" Else .Cells(Z + 2, 3) = "antipodo BIFR. DIR"

                End If

                If Parola2 = Bifronte(Left(Parola1, Len(Parola1) - 1)) & Right(Parola1, 1) Then

                    Z = .Cells(1, 1)

                    .Cells(1, 1) = Z + 1

                    .Cells(Z + 2, 1).Select
                    .Cells(Z + 2, 1) = Parola1

                    .Cells(Z + 2, 2) = Parola2

                    If i = j Then .Cells(Z + 2, 3) = "antipodo PALINDR. INV" Else .Cells(Z + 2, 3) = "antipodo BIFR. INV"

                End If
            Next j

        Next i
        .Cells(1, 3) = k

        DoEvents 'serve per poter interrompere l'esecuzione

    Next k
End With
End Sub

 

Function Bifronte(Parola As String) As String
'ricava il bifronte di una parola, cioè la parola scritta al contrario

Dim L As Integer, k As Integer
L = Len(Parola)
Bifronte = ""
For k = 1 To L
    Bifronte = Mid(Parola, k, 1) & Bifronte
Next k
End Function
 
Joomla 1.7 Templates designed by College Jacke