#!/usr/bin/perl
# Le script est après les commentaires. Script follows...

#Cet outil en perl recherche historiquement en 3 temps les noms propres identiques susceptibles d'apparaîtres différents du fait de  fautes/nuances typos.

# Premier temps. Exemples de nuances
# Frederic et Frédéric; Gonçalves et Goncalves, Nuñès et Nunès
# Jean-Marc, Jean Marc et Jean—Marc (tiret long ou moyen)
# Ausserbach et Außerbach, AEnigm et Aenigm

# Dans un second temps, on suppose des erreurs des types suivants:
# Inversion de deux lettres: conpsiration au lieu de conspiration 
# ou faute typo: arome au lieu d'atome (r et t proches sur le clavier).
# Dans ce contexte, le nombre de lettres est constant.

# Dans un 3e temps, ajout par erreur ou ambiguïté d'une lettre:
# indentité au lieu de identité, Raphaèle au lieu de Raphaëlle

# Dans ce script, la différence de longueur des mots comparés et normalisés) n'excède donc jamais 1

#On propose donc TROIS types d'alerte

# 1. mots avec même graphie sans diacritiques: cf. nuances
# 2. mots identiques à une inversion près (même nombre de lettres).
# 3. mots identiques à une lettre près (supplémentaire ou non).
# S'ajoutent des alertes mineures en d'autres situations, moins intéressantes.

# Démarche:
# 1. on réduit D'ABORD tous les mots en minuscules, sans accents, cédilles etc. avec la routine suppressiondiacritikandco. Celle-ci convertit aussi les ß et les doubles voyelles accolées (Æ), supprime espaces et insécables, simplifie tous les tirets. Ceci pour la majorité des langues occidentales. Des ajouts sont possible dans cette routine.

# 1. On lance une alerte si on trouve des mots simplifiés identiques. Succès.

# 2. On lance une alerte en cas d'*égalité* des longueurs des mots. 
# On utilise alors la routine debutdefragmentcommunadeuxmots, qui recherche le début commun à deux mots, APRES la routine précédente. La routine motmisalenvers fait ce qu'elle dit, elle sera utile pour trouver les fins communes à deux mots en utilisant debutdefragmentcommunadeuxmots.
#En fait, nos deux mots sont découpés en débutcommun (éventuellement vide), milieu de chaque, fin commune (éventuellement vide).

#Types d'alertes
# 2a. Si au moins 3 lettres consécutives distinguent les milieux de mots, on abandonne, supposant qu'ils sont vraiment différents. Abandon.
# 2b. Si les deux mots sans diacritiques sont identiques à une inversion près. Succès.
# 2c. les couples de lettres sont différents, même après inversion. Pas d'erreur typo, proposition d'abandon.
# 2d. Une seule lettre distingue les deux mots. Faire attention quand même.

# 3. Si les mots ont des longueurs différentes. On ne s'intéresse qu'au cas où un mot contient une lettre de plus que l'autre (ex.: indentique). On lance alors une alerte avec proposition de surveillance.

#####Debut pédago
#Pour comprendre le fonctionnement du script, on peut s'appuyer sur les exemples et commandes suivants (enlever les dièses au début des lignes)

# $nom1="cher"; # Außerbach";
# $nom2="chèr"; # Aussebrach";

#@liste=('Außerbach','Aussebrach','AuBerbach','identité', 'indentité','Raphaëlle','Raphaèle','École','ecolé','Ecoles','recole','ecolte','écolage','Eocle','Eole','Nunèçö','Ecolle', 'NUnec','Ecopli', 'Jean-Pierre', 'jean Pierre');

#print compamots($nom1,$nom2);
#print  compaliste(@liste);
#####Fin pédago

###Debut du script
my @liste, $fic,  $chemin, $ficsimple, $ficfinal, $i;
my $export=0;
if ($ARGV[0]=~/[-]+[ ]*help/ || $ARGV[0] eq "")
	{
	print "Cet outil recherche les mots très ressemblants (type Brzezinski ou Brezinski) susceptibles d'être mal saisis au clavier. Voici les options:

perl homonym.pl -help: lance cette documentation. Pour info, le début du code explique en détail le fonctionnement de ce script.

perl homonym.pl -f fichier (avec chemin d'accès si le fichier n'est pas dans le même dossier que ce programme): signale, pour tous les mots du fichier (séparés par un passage à la ligne ou RC), les très fortes ressemblances. Le résultat apparaît dans la fenêtre du terminal.

perl homonym.pl -g fichier: idem, mais produit le résultat dans un fichier analogue à l'initial, complété d'un .homonym (non garanti si le fichier d'origne contient des espaces ou des accents ni dans des univers Windows).

perl homonym.pl mot1 mot2 mot3 (etc.): signale, pour tous les mots de la liste (2 à 2), les très fortes ressemblances (erreurs typo, variations d'accents, de casse, interversion de 2 lettres, etc.).

NOTE: si le fichier est exécutable, on peut omettre la commande perl du début: ./homonym.pl etc.\n\n";
	}

elsif ($ARGV[0] eq "-f") 
	{
	$fic=$ARGV[1];
	open (F, "$fic") || die "fichier absent";
	while (<F>)
		{
		chomp;
		push (@liste,$_);	
		}
	close (F);
	
	}
elsif ($ARGV[0] eq "-g") 
	{
	$fic=$ARGV[1];
	open (F, "$fic");
	while (<F>)
		{
		chomp;
		push (@liste,$_);	
		}
	close (F);		
	#if ($fic =~/\//)	inutile (et le chdir aussi) si le chemin est complet ou si le fichier est dans le dossier du pgm homonym.pl
	#	{$chemin=$fic;
	#	($chemin, $ficsimple)= ($fic=~/(^.*\/)(.*$)/);
	$ficfinal=$fic.".homonym";
	open (G,">$ficfinal");
	$export=1;
	}
	
	else #2 ou plusieurs mots comme arguments, vont dans la liste
		{
		foreach $i (0..$#ARGV)
			{
			push (@liste,$ARGV[$i]);
			}
		}

if ($export)
	{
	print G compaliste(@liste);
	close (G);
	}
else 
	{
	print compaliste(@liste);
	}

### NE PAS ALTERER la suite, sauf en cas de grande assurance....

###ROUTINES
sub compaliste
	{
	my (@listeroutine)=@_;
	my $resu; my $i; my $j;
	foreach $i (0..$#listeroutine)
		{
		foreach $j ($i+1..$#listeroutine)
			{
			$resu.= compamots($listeroutine[$i],$listeroutine[$j]);	
			}
		}
	return $resu;	
	}

sub compamots #supposés minusc sans accents
	{
	my ($mot1,$mot2)=@_;
	my $alerte; my $debutcommun;my $fincommune;
	my $partieintermediaire1; my $partieintermediaire2;
	my $formesimple1=lc(suppressiondiacritikandco($mot1));
	my $formesimple2=lc(suppressiondiacritikandco($mot2));
	#On définit tout de suite les variables importantes pour la suite
	
	$debutcommun=debutdefragmentcommunadeuxmots ($formesimple1,$formesimple2);
	$fincommune= motmisalenvers(debutdefragmentcommunadeuxmots (motmisalenvers($formesimple1),motmisalenvers($formesimple2)));
	#A priori $debutcommun et $fincommune ne redonnent pas les mots entiers puisqu'on a des formes simplifiées différentes.
		
	$partieintermediaire1= $formesimple1;
	$partieintermediaire1=~s/^$debutcommun//;		$partieintermediaire1=~s/$fincommune$//;
	$partieintermediaire2= $formesimple2;
	$partieintermediaire2=~s/^$debutcommun//;
	$partieintermediaire2=~s/$fincommune$//;
	
#CAS 1
		if ($formesimple1 eq $formesimple2)
		{ $alerte="$mot1 et $mot2 ont les mêmes formes simplifiées\n";
		}
		#fonctionne bien

#CAS 2		
	elsif ( length($formesimple1) == length ($formesimple2))
		{
		#On cherche une inversion de lettres

#Précaution inutile				
		if (length ($partieintermediaire1) != length ($partieintermediaire2))
		#si jamais: inutile a priori
			{
			print "Un bug probable avec la routine compamots. La partie non commune aux mots $mot1 et $mot2 a une longueur variable: $partieintermediaire1 pour le 1er mot, $partieintermediaire2 pour le second.\n\n";
			}
			
		else #les long des parties intermédiaires sont bien identiques
			{
#CAS 2a
			if (length ($partieintermediaire1)>2)
				{
				$alerte= "";#ancien: plus de 2 lettres consécutives distinguent les mots $mot1 et $mot2; on abandonne, supposant que les mots sont vraiment différents\n"; #ok
				}
			else #1 à 2 lettres distinguent nos deux mots de même longueur. Si 2, on tentera une inversion. 
				{	
				if (length ($partieintermediaire1)==2)
					{
#CAS 2b				#on teste l'inversion
					my $testinterm2=motmisalenvers($partieintermediaire2);
					if ($testinterm2 eq $partieintermediaire1)
						{
						$alerte= "$mot1 et $mot2 sont identiques à une inversion près: $debutcommun".uc($partieintermediaire1)."$fincommune\n";
						} 		#fonctionne bien
					else
#CAS 2c.
						{
						$alerte=""; #ancien:les couples de lettres sont différents: $debutcommun".uc($partieintermediaire1)."$fincommune et $debutcommun".uc($partieintermediaire2)."$fincommune. Pas d'erreur typo, on oublie \n"; #ok
						}
					}
#CAS 2d.
				else #la différence est d'une lettre, est réelle
					{
					$alerte="Une lettre distingue $debutcommun".uc($partieintermediaire1)."$fincommune et $debutcommun".uc($partieintermediaire2)."$fincommune\n";
					}
				}		
			} #FIn des long des parties intermédiaires bien identiques
		} #fin du elsif même longueur
#CAS 3		
	else #longueurs différentes
		{
		my $echec=0; #le last ne fait pas ce que je veux

		$echec=1 if ((length($formesimple1) - length ($formesimple2))**2 >1);
		# on oubliera si la différence est de plus d'une lettre
		$echec=1 if (length($partieintermediaire1)*length($partieintermediaire2)!=0);
		#une des parties interm doit être nulle et l'autre valoir 1
		
		
# On ne recherche que les mots dont l'un a une lettre de plus que l'autre:
# Tzara ou Zara, Raphaelle ou Raphaele, indentation ou identation.
#Donc ces mots ont nécessairement beaucoup de choses en commun. 
#Les deux mots ont donc ou un début commun (le + petit, si la lettre supplémentaire est à la fin du gros), ou une fin commune (le + petit, si la lettre supp est au début du gros), et dans ces deux cas un milieu vide, 
#ou encore un début et une fin commune dont la concaténation fait le petit mot.
# Le piège est que  début.fin n'est pas toujours égal au mot le plus petit (cf. ecole/ecolle) ni au plus grand.

		my $motpetit=$formesimple1; 
		my $motgrand=$formesimple1;
		$motpetit=$formesimple2 if (length ($formesimple2) < length ($formesimple1));
		$motgrand=$formesimple2 if (length ($formesimple2) > length ($formesimple1));
		$concat=$debutcommun.$fincommune; #s'ils ont une intersection commune
		if (!$echec)
			{
			if ($fincommune eq $motpetit)
				{$alerte="$mot1 et $mot2 se ressemblent à l'initiale près, absente du plus petit mot\n";
				}
			elsif ($debutcommun  eq $motpetit)
				{$alerte="$mot1 et $mot2 se ressemblent à la lettre terminale près, absente du plus petit mot\n";
				}
			elsif ($concat eq $motgrand)
				{$alerte="$mot1 et $mot2 se ressemblent à une lettre doublée près, au milieu du grand mot et absente du plus petit mot\n";
				}
			else
				{
			$alerte="$mot1 et $mot2 se distinguent à un signe près: $debutcommun".uc($partieintermediaire1).uc($partieintermediaire2). "$fincommune\n";
			# concat des uc: car les parties interm sont ou vides ou composées d'une seule lettre: pas de risque donc
				}
			} 
			else # fin if non echec: si echec, on oublie
				{
				$alerte=""; #ancien: $mot1 et $mot2 ne se ressemblent pas du tout. Oubli\n";	
				}
		}	
	return $alerte;
	}

sub debutdefragmentcommunadeuxmots #marchera à l'envers avec reverse
	{
	my ($mot1,$mot2)=@_;
	my $fragmentdepartcommun;
	my @test1=split(//,$mot1); #@test1 va rétrécir au lavage
	my @savetest1= @test1;
	my @test2=split(//,$mot2);
	my @savetest2= @test2;
	my $indicelettresokalaperl=-1;

	while ( $#test1>-1||$#test2>-1)
		{
		my $debut1=shift (@test1);
		my $debut2=shift (@test2);
		if ($debut1 ne $debut2)
			{
			last;
			}
		$indicelettresokalaperl ++;
		}
	foreach $u (0..$indicelettresokalaperl)
		{
		$fragmentdepartcommun.=$savetest1[$u];
		}

	return $fragmentdepartcommun;
	}
	
sub motmisalenvers
	{my ($mot)=@_;
	my @test=split(//,$mot);
	my @inverse=reverse(@test);
	my $resu=join ("",@inverse);
	return $resu;
	}

sub suppressiondiacritikandco # travaille sur des mots, ne passe pas en minuscules. # faire une routine spéciale pour les ß et Æ des accents? 

	{
	my ($nom)=@_;
	$nom=~s/—/-/g; #tiret long
	$nom=~s/–/-/g; #tiret moyen
	$nom=~s/−/-/g; #signe moins
	$nom=~s/^ *//g;
	$nom=~s/ *$//g; 
	$nom=~s/ / /g; # insécables
	$nom=~s/ //g; #en fait on enlève tous les espaces (risque avec les tirets)
	$nom=~s/à/a/g;
	$nom=~s/ä/a/g;
	$nom=~s/å/a/g;
	$nom=~s/á/a/g;
	$nom=~s/æ/ae/g;

	$nom=~s/À/A/g;
	$nom=~s/Â/A/g;
	$nom=~s/Ä/A/g;
	$nom=~s/Å/A/g;
	$nom=~s/Á/A/g;
	$nom=~s/Æ/AE/g; #autre routine?

	$nom=~s/ß/ss/g;
	$nom=~s/ç/c/g;
	$nom=~s/Ç/C/g;
	$nom=~s/ð/d/g;
	$nom=~s/Ð/D/g;

$nom=~s/é/e/g;
$nom=~s/è/e/g;
$nom=~s/ê/e/g;
$nom=~s/ë/e/g;

$nom=~s/É/E/g;
$nom=~s/È/E/g;
$nom=~s/Ê/E/g;
$nom=~s/Ë/E/g;

$nom=~s/î/i/g;
$nom=~s/ï/i/g;
$nom=~s/ì/i/g;
$nom=~s/í/i/g;
$nom=~s/Î/I/g;$nom=~s/Ï/I/g;$nom=~s/Ì/I/g;$nom=~s/Í/I/g;

$nom=~s/ñ/n/g;$nom=~s/Ñ/N/g;
$nom=~s/ò/o/g;$nom=~s/ó/o/g;$nom=~s/ö/o/g;$nom=~s/ô/o/g;$nom=~s/ø/o/g;
$nom=~s/Ò/O/g;$nom=~s/Ó/O/g;$nom=~s/Ö/O/g;$nom=~s/Ô/O/g;$nom=~s/Ø/O/g;

$nom=~s/œ/oe/g;$nom=~s/Œ/OE/g;
$nom=~s/þ/p/g;$nom=~s/Þ/P/g;
$nom=~s/š/s/g;

$nom=~s/ú/u/g;$nom=~s/û/u/g;
$nom=~s/ü/u/g;$nom=~s/ù/u/g;
$nom=~s/Ú/U/g;$nom=~s/Û/U/g;$nom=~s/Ü/U/g;$nom=~s/Ù/U/g;

$nom=~s/ý/y/g;$nom=~s/Ý/Y/g;
$nom=~s/ÿ/y/g;$nom=~s/Ÿ/Y/g;
$nom=~s/ž/z/g;

#$nom=~s/;$nom=~s/;$nom=~s/;
return $nom;
	}