Utilisateur:Romainbehar/Programmation : anagrammes

Liste des anagrammes en français

Résultat (décembre 2016) :

• 503 000 groupes de lettres donnent plusieurs anagrammes sur les mots de 4 lettres ou plus ;
• 2 groupes de lettres donnent 34 anagrammes (reste à éliminer ceux qui ne varient que d’un accent ou d’un digramme) :
  • aeeinrst : aérisent, arénites, arétines, arsénite, artésien, astérien, enstérai, enterais, entiéras, éraniste, érastien, éreintas, éternisa, étraines, étrainés, rainètes, rainetés, ratinées, réentais, reniâtes, resatine, resatiné, résinate, retanise, retanisé, retenais, sènerait, seraient, sereinât, stéarine, stéariné, tanières, trainées, traînées
  • aeinrst : arétins, arisent, artiens, astiner, entrais, inertas, insérât, ranites, ratiens, ratines, ratinés, rentais, résinat, résinât, retsina, riantes, sartine, satiner, sentira, sériant, serinât, sirénât, taniser, tarines, tarsien, tisaner, traines, traînes, trainés, traînés, transie, trianes, tsarien, tsarine

Le programme peut facilement être modifié pour analyser une autre langue.

Programme

#!/usr/bin/perl -w

# trouver les anagrammes des mots français

use strict;
use utf8;
binmode STDOUT, ":utf8";

use MediaWiki::DumpFile::FastPages;
use Text::Unidecode;

my %anagrammes = ();

my $pages = MediaWiki::DumpFile::FastPages->new('frwiktionary-latest-pages-articles.xml');
my $titre;
my $texte;
while (($titre, $texte) = $pages->next) {
	# uniquement les pages qui ont une section {{langue|fr}}
	if ($texte =~ /\{\{langue\|fr\}\}/m) {
		# lettres sans accents (transforme aussi par exemple 'œ' en 'oe')
		my $sansaccents = unidecode($titre);
		# suppression de tout ce qui n'est pas des lettres
		$sansaccents =~ s/\W//g;
		# si moins de 3 lettres, on passe
		if (length($sansaccents) < 4) {
			next;
		}
		# tri des lettres (ordre alphabétique, conserve les doublons)
		my $tri = (join '', sort { $a cmp $b } split(//, $sansaccents));

		# stockage dans un tableau pour regouper les titres qui ont les mêmes lettres
		if (!exists $anagrammes{$tri}) {
			$anagrammes{$tri} = [];
		}
		push $anagrammes{$tri}, $titre;
	}
}

# affichage des groupes qui ont au moins deux mots
for my $a (keys %anagrammes) {
	my $total = scalar @{ $anagrammes{$a} };
	if($total < 2) {
		# si pour cette liste de lettres il n’y a qu’un seul mot, on passe
		next;
	}

	print "$total anagrammes avec les lettres $a :\n   ";
	for my $m (@{ $anagrammes{$a} }) {
		print $m, ",";
	}
	print "\n";
}