Task: Jaro similarity








VB: Option Explicit

Function JaroWinkler(text1 As String, text2 As String, Optional p As Double = 0.1) As Double
Dim dummyChar, match1, match2 As String
Dim i, f, t, j, m, l, s1, s2, limit As Integer

i = 1
Do
    dummyChar = Chr(i)
    i = i + 1
Loop Until InStr(1, text1 & text2, dummyChar, vbTextCompare) = 0

s1 = Len(text1)
s2 = Len(text2)
limit = WorksheetFunction.Max(0, Int(WorksheetFunction.Max(s1, s2) / 2) - 1)
match1 = String(s1, dummyChar)
match2 = String(s2, dummyChar)

For l = 1 To WorksheetFunction.Min(4, s1, s2)
    If Mid(text1, l, 1) <> Mid(text2, l, 1) Then Exit For
Next l
l = l - 1

For i = 1 To s1
    f = WorksheetFunction.Min(WorksheetFunction.Max(i - limit, 1), s2)
    t = WorksheetFunction.Min(WorksheetFunction.Max(i + limit, 1), s2)
    j = InStr(1, Mid(text2, f, t - f + 1), Mid(text1, i, 1), vbTextCompare)
    If j > 0 Then
        m = m + 1
        text2 = Mid(text2, 1, f + j - 2) & dummyChar & Mid(text2, f + j)
        match1 = Mid(match1, 1, i - 1) & Mid(text1, i, 1) & Mid(match1, i + 1)
        match2 = Mid(match2, 1, f + j - 2) & Mid(text1, i, 1) & Mid(match2, f + j)
    End If
Next i
match1 = Replace(match1, dummyChar, "", 1, -1, vbTextCompare)
match2 = Replace(match2, dummyChar, "", 1, -1, vbTextCompare)
t = 0
For i = 1 To m
    If Mid(match1, i, 1) <> Mid(match2, i, 1) Then t = t + 1
Next i

JaroWinkler = (m / s1 + m / s2 + (m - t / 2) / m) / 3
JaroWinkler = JaroWinkler + (1 - JaroWinkler) * l * WorksheetFunction.Min(0.25, p)
End Function




Ada: with Ada.Text_IO;

procedure Jaro_Distances is

   type Jaro_Measure is new Float;

   function Jaro_Distance (Left, Right : in String) return Jaro_Measure
   is
      Left_Matches   : array (Left'Range)  of Boolean := (others => False);
      Right_Matches  : array (Right'Range) of Boolean := (others => False);
      Matches        : Natural := 0;
      Transpositions : Natural := 0;
   begin
      if Left'Length = 0 and Right'Length = 0 then
         return 1.000;
      end if;

      declare
         Match_Distance : constant Natural := Natural'Max (Left'Length, Right'Length) / 2 - 1;
      begin
         for L in Left'Range loop
            declare
               First : constant Natural := Natural'Max (Right'First, Right'First + L - Left'First - Match_Distance);
               Last  : constant Natural := Natural'Min (L - Left'First + Match_Distance + Right'First, Right'Last);
            begin
               for R in First .. Last loop
                  if
                    not Right_Matches (R) and
                    Left (L) = Right (R)
                  then
                     Left_Matches (L)  := True;
                     Right_Matches (R) := True;
                     Matches := Matches + 1;
                     exit;
                  end if;
               end loop;
            end;
         end loop;
      end;

      if Matches = 0 then
         return 0.000;
      end if;

      declare
         R : Natural := Right'First;
      begin
         for L in Left'Range loop
            if Left_Matches (L) then
               while not Right_Matches (R) loop
                  R := R + 1;
               end loop;
               if Left (L) /= Right (R) then
                  Transpositions := Transpositions + 1;
               end if;
               R := R + 1;
            end if;
         end loop;
      end;

      declare
         Match  : constant Float := Float (Matches);
         Term_1 : constant Float := Match / Float (Left'Length);
         Term_2 : constant Float := Match / Float (Right'Length);
         Term_3 : constant Float := (Match - Float (Transpositions) / 2.0) / Match;
      begin
         return Jaro_Measure ((Term_1 + Term_2 + Term_3) / 3.0);
      end;
   end Jaro_Distance;

   procedure Show_Jaro (Left, Right :  in String)
   is
      package Jaro_IO is
         new Ada.Text_IO.Float_IO (Jaro_Measure);
      use Ada.Text_IO;

      Distance : constant Jaro_Measure := Jaro_Distance (Left, Right);
   begin
      Jaro_IO.Put (Distance, Fore => 1, Aft => 5, Exp => 0);
      Set_Col (10);  Put (Left);
      Set_Col (22);  Put (Right);
      New_Line;
   end Show_Jaro;

   S1 : constant String := "  MARTHA VS MARHTA  ";
begin
   Show_Jaro ("DWAYNE",    "DUANE");
   Show_Jaro ("DIXON",     "DICKSONX");
   Show_Jaro ("JELLYFISH", "SMELLYFISH");
   Show_Jaro (S1 (3 .. 8), S1 (13 .. 18));
end Jaro_Distances;