OCR matching regex

[choeppner]

I am trying to solve an problem where I am searching for a string within a string using regex. More accurately I am searching for the longest string within a string, allowing for missing or extra characters.

I have been around and around this problem and now I think that it is not possible with regex. So I thought I would ask the monks for enlightenment.

So here is the real world situation, equipment marked with both painted id letters and RFID tags are being verified. An image of the equipment is run through a OCR process and a string of characters is returned. Sometimes there are extra characters included before, inside or after the actual part number, caused by noisy image. From a separate process, the equipment's RFID tag is read.

This seems straight forward enough, but I need to allow for extra characters in the string being searched, and allow for missing characters from the string being searched for.

The simple example is find "ABC" in "DFGABCKBG".

The example where I fail to find a solution is, find "ABC" in "DFGAXBHCY" as "AXBHC", or "ABC" in "DFGAXBHY" as "AXB".

p.s.

I'm not yelling, the OCR text is all upper case.

[tybalt89]

#!/usr/bin/perl -l

# http://perlmonks.org/?node_id=1178025

use strict;
use warnings;

while(<DATA>)
  {
  my ($want, $in) = split;
  my $pat = $want =~ s/\B/?.?/gr . '?';
  #print $pat;
  my (@answers, %found);
  $in =~ /$pat(?{$found{$&}++ or $answers[length $&] .= "$& "})(*FAIL)
+/;
  print "$want in $in is ", @answers ? $answers[-1] : 'not found';
  }

__DATA__
ABC DFGABCKBG
ABC DFGAXBHCY
ABC DFGAXBHY

Many more test cases are needed :)

Also an explanation of why ABC DFGAXBHY should be AXB instead of AXBH

Also what should be done if there is more than one "longest".

Also, can there be more than one extra character between wanted chars, and if so, how many?

[kcott]

G'day choeppner,

In my opinion, a regex is not the right tool for this job. The string-related functions length, index and substr can provide all the functionality you need. I'd also expect them to be much faster than any regex solution (Benchmark against any you receive).

Here's my test code (with some additional test data):

#!/usr/bin/env perl

use strict;
use warnings;

use Test::More;

my @tests = (
    [qw{ABC DFGABCKBG ABC}], 
    [qw{ABC DFGAXBHCY AXBHC}],
    [qw{ABC DFGAXBHY AXB}],
    [qw{ABC DFGCBAKBG AKB}],
    [qw{ABC DFGCBAKbG A}],
    ['', 'DFGCBAKbG', ''],
    ['ABC', '', ''],
    [qw{ABC AXBHCY AXBHC}],
    [qw{ABC DFGAXBHC AXBHC}],
    [qw{abc DFGABCKBG}, ''],
);

plan tests => scalar @tests;

for my $test (@tests) {
    my ($start, $end) = (-1, -1),
    my ($rfid, $ocr, $exp) = @$test;

    for (0 .. length($rfid) - 1) {
        my $pos = index $ocr, substr($rfid, $_, 1), $end + 1;
        next if $pos == -1;
        $start = $pos if $start == -1;
        $end = $pos;
    }

    my $got = $start == -1 ? '' : substr $ocr, $start, $end - $start +
+ 1;

    is($got, $exp, "Find '$rfid' in '$ocr' as '$exp'");
}

Output:

1..10
ok 1 - Find 'ABC' in 'DFGABCKBG' as 'ABC'
ok 2 - Find 'ABC' in 'DFGAXBHCY' as 'AXBHC'
ok 3 - Find 'ABC' in 'DFGAXBHY' as 'AXB'
ok 4 - Find 'ABC' in 'DFGCBAKBG' as 'AKB'
ok 5 - Find 'ABC' in 'DFGCBAKbG' as 'A'
ok 6 - Find '' in 'DFGCBAKbG' as ''
ok 7 - Find 'ABC' in '' as ''
ok 8 - Find 'ABC' in 'AXBHCY' as 'AXBHC'
ok 9 - Find 'ABC' in 'DFGAXBHC' as 'AXBHC'
ok 10 - Find 'abc' in 'DFGABCKBG' as ''

See also: Test::More

[LanX]

These are fuzzy requirements

My first guess is you are looking for Levenshtein_distance .

My second guess is you have problems to phrase a clear heuristic and rather need a learning algorithm which can be trained with encountered problems. °

In any case we˛ need to see some real data in order to help.

footnotes

°) Something like calculating frequencies of false character sequences to calculate the probability of ambiguous solutions

˛) like all learning algorithms ;)

[tybalt89]

#!/usr/bin/perl -l

# http://perlmonks.org/?node_id=1178025

use strict;
use warnings;
use Algorithm::Diff qw(traverse_sequences);

while(<DATA>)
  {
  my ($want, $in) = split;
  my @from = split //, $in;
  my @to = split //, $want;
  my $answer = '';

  traverse_sequences( \@from, \@to,
    {
    MATCH     => sub {$answer .= $from[shift()]},
    DISCARD_A => sub {$answer .= "-$from[shift()]"},
    DISCARD_B => sub {$answer .= "+$to[pop()]"},
    } );
  $answer =~ s/^(?:[+-]\w)+ | (?:[+-]\w)+$//gx; # strip outer
  $answer =~ tr/+-//d; # clean up inner
  $answer ||= 'not found';
  print "$want in $in is $answer";
  }

__DATA__
ABC DFGABCKBG
ABC DFGAXBHCY
ABC DFGAXBHY
ABC DEFGHI