I have more respect for OCR software now.

Recently, trying to practice memorizing simple visual substitution ciphers; wrote a subimage replacement script that as input, takes

and outputs

My script, has a few features that aren't strictly necessary for plain OCR of monospaced text in a known font at a known initial starting offset.

And, what gives me much more respect for OCR software now, than before I started; is that the initial pixel stepping scan mode; prior to finding the first ten characters; is very slow.

This code probably won't be useful to anyone else, because

It's also, sorta unclear and hard to read, due to misleading comments, and overuse of the comment-blocks-for-version-control design antipattern. Anyway,

#!/usr/bin/perl -w
use strict;
use Getopt::Long;
use Imager;

my $in_path = "test_load.png";
my $out_path = "test_substitute.png";

unless(GetOptions("in-path=s" => \$in_path,
                  "in_path=s" => \$in_path,
                  "out-path=s" => \$out_path,
                  "out_path=s" => \$out_path)){ #will add stuff later
    print("Warning: Failed to parse options.\n");
    exit(1);
}

#Try to replace known characters in a screenshot of an xterm,
#with squished morse replacements. We might take a slightly roundabout
+ route.

my $in_dir = "screenshots/toshiba/";
my $repl_dir = "screenshots/toshiba/";
my $in_prefix = "toshiba ";
my $repl_prefix = "auto 8x20 char ";

my $known_chars = "etoanETOANirshIRSH" . "bcdfgjklmBCDFGJKLM" . "pquvw
+xyzPQUVWXYZ";
                  #Sigh . . . not much of a golfer. join("","a".."z",A
+..Z) would work.
                  # So would                        join "",map {$_.lc
+} join"",A..Z
                  # Or                              $"="";$t="@{[A..Z]
+}";$t.lc$t
my @known_longchars = qw(e@b t@b o@b a@b n@b i@b r@b s@b h@b 
                         E@b T@b O@b A@b N@b I@b R@b S@b H@b
                         b@b c@b d@b f@b g@b j@b k@b l@b m@b 
                         B@b C@b D@b F@b G@b J@b K@b L@b M@b 
                         p@b q@b u@b v@b w@b x@b y@b z@b 
                         P@b Q@b U@b V@b W@b X@b Y@b Z@b    );
#                         e@u t@u o@u a@u n@u i@u r@u s@u h@u 
#                         E@u T@u O@u A@u N@u I@u R@u S@u H@u   
#                         b@u c@u d@u f@u g@u j@u k@u l@u m@u 
#                         B@u C@u D@u F@u G@u J@u K@u L@u M@u 
#                         p@u q@u u@u v@u w@u x@u y@u z@u 
#                         P@u Q@u U@u V@u W@u X@u Y@u Z@u     );
   #for example, Ccircumflex or parenleft
   # . . . and the first dozen are for mundane boring stuff of trying
   # to make the bold characters in the emacs status bar, of the test 
+file,
   # translate ? 
my @known_chars = (split(//, $known_chars), @known_longchars);

my $in_char_x = 6;
my $in_char_y = 13;

my $out_char_x = 8;   #that the replacement is larger than the origina
+l,
my $out_char_y = 20;  #makes my life considerably harder.

my @fav_colors = ("~" x 3, "#" x 3, "A" x 3);
#White-ish, black-ish, and gray-ish
#limiting myself to printable ascii values . . . so stupid. 
#(Should be "\xFF\" x 3, "\x00" x 3, "\x80" x 3 if it were to be displ
+ayed directly.)

#Load the input image
my $in_img = Imager->new(file => $in_path);
unless($in_img){
    print("Warning: Failed to load \"$in_path\": " . Imager->errstr . 
+"\n");
    exit(1);
}

#In the design notes I had said to map to 2-color or 3-color images
#for storage. And expected to use 1 to 8 bits per pixel to store this.
#But, due to simplicity, it looks like 24 bits per pixel is the easies
+t
#to handle. 12x wasteful.
my %bitmapper_mapper = ();
my %bitmapper_mapper_imgs = (); #only until the reverse of flatten_img
+ is written.

my %bitmapper_names = ();
my %names_bitmapper = (); #reverse

my $num_added = 0;
my $num_skipped = 0;
#Load and parse the dictionary.
for my $charname (@known_chars){
    my $src_path = $in_dir . ($in_dir ne "" && $in_dir !~ /\/$/ ? "/" 
+: "") . 
                      $in_prefix . $charname . ".png";
    my $repl_path = $repl_dir . ($repl_dir ne "" && $repl_dir !~ /\/$/
+ ? "/" : "") .
                      $repl_prefix . $charname . ".png";
    my $src_img = Imager->new(file => $src_path);
    unless($src_img){
        print("Warning: Failed to load \"$src_path\": " . Imager->errs
+tr . "\n");
        $num_skipped++;
        next;
    }
    my $repl_img = Imager->new(file => $repl_path);
    unless($repl_img){
        print("Warning: Failed to load \"$repl_path\": " . Imager->err
+str . "\n");
        $num_skipped++;
        next;
    }
    #find colors, convert to bicolor, map to known colors, save as raw
+.
    my $src_simple = flatten_img($src_img, "");
    #print( "Input path \"$src_path\" => image \"$src_simple\"\n\n");

    my $repl_simple = flatten_img($repl_img, "");
    #print("Input path \"$repl_path\" => image \"$repl_simple\"\n\n");
  
    #add it to the dicionary.
    $bitmapper_mapper{$src_simple} = $repl_simple;
    $bitmapper_mapper_imgs{$src_simple} = $repl_img;

    $bitmapper_names{$src_simple} = $charname;
    $names_bitmapper{$charname} = $repl_simple;
    $num_added++;
}
my $num_duplicates = $num_added - scalar(keys(%bitmapper_mapper));
printf("Error loading %d characters.\n", $num_skipped) if $num_skipped
+;
printf("Loaded %d characters, with %d duplicates.\n", $num_added, $num
+_duplicates);

#Begin.

$in_img = drop_alpha($in_img, "");
printf("Source image (\"$in_path\") is %dx%d pixels.\n", 
       $in_img->getwidth(), $in_img->getheight());

#FIXME
#Scan through the image, looking for known characters.
my $start_y = 0;
my $start_x = 0;
my $use_stepping_y = 0;
my $base_x = 0;
my $use_base_x = 0;

my @char_queue = (); #format is a list of hash refs; each containing
                     # initial x, initial y,
                     # original character -- we'll figure out what it 
+is
                     #                       later, by calling flatten
+_img() a second time ?
                     #                       Too messy to figure out h
+ow to store the colors
                     #                       and character separately.
                     # name -- maybe.
while($start_y + $in_char_y <= $in_img->getheight()){
    #last if $start_y > 50; #abort early . . . performance is crap, an
+d testing will
                           #be faster if I don't have to wait for it t
+o slog through the 
                           #middle and bottom of the image before seei
+ng if the top is
                           #correct.

    #Characters exist on a grid, and they don't overlap.
    #However, we aren't given the grid starting offsets, so until 5 to
+ 10 characters
    #are found, check everything.
    $start_x = 0;
    
    if( ! $use_base_x ){
      my %count_tmp = ();
      my @count_tmp_char_queue = ();
      for my $tmp_base_x (0 .. $in_char_x - 1){
          $start_x = $tmp_base_x;
          while($start_x + $in_char_x <= $in_img->getwidth()){
              my $test_rect = $in_img->crop(left => $start_x, top => $
+start_y,
                                            width => $in_char_x, heigh
+t => $in_char_y);
              my $test_rect_simple = flatten_img($test_rect, "");
              if(defined($bitmapper_mapper{$test_rect_simple})){
                  #match.
                  $count_tmp{$tmp_base_x}++;
                  push(@{$count_tmp_char_queue[$tmp_base_x]}, 
                       { "orig_x" => $start_x,
                         "orig_y" => $start_y,
                         "orig_image" => $test_rect,
                         "orig_name" => $bitmapper_names{$test_rect_si
+mple}
                       } );
              }
              $start_x += $in_char_x;
          }
      }
      my @best_offsets = sort( { $count_tmp{$b} <=> $count_tmp{$a} } k
+eys(%count_tmp) );

      printf("INFO: line y %3d; %d valid x initial offsets found. ", 
           $start_y, scalar(keys(%count_tmp)));
      if(scalar(keys(%count_tmp))){
          print("(" . join(", ", map({ "off $_ => $count_tmp{$_} match
+es" } @best_offsets)) . 
                ")\n");
      }else{
          print("\n");
      }
      #How many times should we skip forward ? 
      if($#best_offsets > -1){
          my $second_best = $#best_offsets > 0 ? $count_tmp{$best_offs
+ets[1]} : 0;
          
          $use_stepping_y += $count_tmp{$best_offsets[0]} - $second_be
+st >= 10 ? 
              ($in_img->getheight() - $start_y) / $in_char_y + 5   :  
+1;
          
          $use_base_x += $count_tmp{$best_offsets[0]} - $second_best >
+= 10 ? 
              ($in_img->getheight() - $start_y) / $in_char_y + 5   :  
+1;

          $base_x = $best_offsets[0];
          #More than ten characters; assume true forever; fewer then t
+en characters;
          #assume true for one line.

          #fold in what was found so far.
          push(@char_queue, @{$count_tmp_char_queue[$best_offsets[0]]}
+);
          
      }
    }else{
        #Reusing found offset.
        $start_x = $base_x;

        my $count_curline = 0;
        while($start_x + $in_char_x < $in_img->getwidth()){
            my $test_rect = $in_img->crop(left => $start_x, top => $st
+art_y,
                                          width => $in_char_x, height 
+=> $in_char_y);
            my $test_rect_simple = flatten_img($test_rect, "");
            if(defined($bitmapper_mapper{$test_rect_simple})){
                #match.
                $count_curline++;
                push(@char_queue, 
                     { "orig_x" => $start_x,
                       "orig_y" => $start_y,
                       "orig_image" => $test_rect,
                       "orig_name" => $bitmapper_names{$test_rect_simp
+le}
                     } );
            }
            $start_x += $in_char_x;
        }
        printf("INFO: line y %3d; reusing x initial offset %d.", $star
+t_y, $base_x);
        printf(" Found %d matches.", $count_curline) if $count_curline
+;
        printf("\n");
        $use_base_x--;
        $use_base_x = 0 if $use_base_x < 0;
    }

    $start_y += $use_stepping_y-- ?  $in_char_y : 1;
    $use_stepping_y = 0 if $use_stepping_y < 0;
}

#Suggested plan.
#generate a list of x-offsets with chars to replace
#generate a list of y-offsets with chars to replace

print("Beginning substitution.\n");
my $str = join(",", map( { $$_{"orig_name"} } @char_queue));
printf("During scan, found %d characters.\n", $#char_queue + 1);
printf("Found (%s)\n", $str);

my %found_xs = ();
my %found_ys = ();
for(@char_queue){
    $found_xs{$$_{"orig_x"}} = 1;
    $found_ys{$$_{"orig_y"}} = 1;
}
printf("Found %d unique y offsets and %d unique x offsets.\n",
       scalar(keys(%found_ys)), scalar(keys(%found_xs)));
my $grow_x = scalar(keys(%found_xs)) * ($out_char_x - $in_char_x);
my $grow_y = scalar(keys(%found_ys)) * ($out_char_y - $in_char_y);

#Enlarge the image horizontally first.
#Copy stripe by stripe, and insert padding where necesary.
my $tmp_img = Imager->new(xsize => $in_img->getwidth() + $grow_x,
                          ysize => $in_img->getheight() + 0,
                          channels => 3);
my $leftpad = int( ($out_char_x - $in_char_x) / 2);
my $rightpad = $out_char_x - $in_char_x - $leftpad;

my @found_xs = sort({ $a <=> $b } keys(%found_xs));
if( $#found_xs > -1){
    #Copy up to the first insertation.
    $tmp_img->paste(src => $in_img,
                    width => $found_xs[0]);
    my $pad_color = Imager::Color->new("#ff00ff");
    for(my $nth = 0; $nth <= $#found_xs; $nth++){
        #Left pad.
        #$tmp_img->box(xmin => $found_xs[$nth] + $nth * ($leftpad + $r
+ightpad),
        #              xmax => $found_xs[$nth] + $nth * ($leftpad + $r
+ightpad) + $leftpad - 1,
        #              ymin => 0,
        #              ymax => $in_img->getheight() - 1,
        #              filled => 1, color => $pad_color);

        #Stretch colors from existing background, instead of using pad
+_color.

        # crop, scaleX, paste
        $tmp_img->paste(left => $found_xs[$nth] + $nth * ($leftpad + $
+rightpad),
           src => $in_img->crop(left => $found_xs[$nth], width => 1)->
+scaleX(pixels => $leftpad) );

        #Original.
        $tmp_img->paste(left => $found_xs[$nth] + $nth * ($leftpad + $
+rightpad) + $leftpad,
                        src => $in_img,
                        src_minx => $found_xs[$nth],
                        width => $in_char_x);
        #right pad.
        #$tmp_img->box(xmin => $found_xs[$nth] + $nth * ($leftpad + $r
+ightpad) + $leftpad + $in_char_x,
        #              xmax => $found_xs[$nth] + $nth * ($leftpad + $r
+ightpad) + $out_char_x - 1,
        #              ymin => 0,
        #              ymax => $in_img->getheight() - 1,
        #              filled => 1, color => $pad_color);
        
        #crop, scaleX, paste,
        $tmp_img->paste(left => $found_xs[$nth] + $nth * ($leftpad + $
+rightpad) + $leftpad + $in_char_x,
           src => $in_img->crop(left => $found_xs[$nth] + $in_char_x -
+ 1, width => 1)
                        ->scaleX(pixels => $rightpad) );

        if($nth < $#found_xs){
            #original to the next cutpoint.
            $tmp_img->paste(left => $found_xs[$nth] + $nth * ($leftpad
+ + $rightpad) + $out_char_x,
                        src => $in_img,
                        src_minx => $found_xs[$nth] + $in_char_x,
                        width => $found_xs[$nth + 1] - $found_xs[$nth]
+ - $in_char_x);
        }
    }
    #Copy after the last insertation.
    $tmp_img->paste( left => $found_xs[$#found_xs] + $in_char_x + $gro
+w_x,
                     src => $in_img,
                     src_minx => $found_xs[$#found_xs] + $in_char_x);
}else{
    #nothing to do.
    $tmp_img->paste(src => $in_img);
}

#Enlarge the image vertically next. Same as above, just rotated.
my $out_img = Imager->new(xsize => $in_img->getwidth() + $grow_x, 
                          ysize => $in_img->getheight() + $grow_y,
                          channels => 3);

my $toppad = int( ($out_char_y - $in_char_y) / 2);
my $botpad = $out_char_y - $in_char_y - $toppad;

my @found_ys = sort({ $a <=> $b } keys(%found_ys));
if( $#found_ys > -1){
    #Copy up to the first insertation.
    $out_img->paste(src => $tmp_img,
                    height => $found_ys[0]);
    my $pad_color = Imager::Color->new("#ff00ff");
    for(my $nth = 0; $nth <= $#found_ys; $nth++){
        #Top pad.
        #$out_img->box(xmin => 0,
        #              xmax => $tmp_img->getwidth() -1,
        #              ymin => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad),
        #              ymax => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad) + $toppad - 1,
        #               filled => 1, color => $pad_color);
        #Stretch colors from existing background, instead of using pad
+_color.

        # crop, scaleY, paste
        $out_img->paste(top => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad),
           src =>  $tmp_img->crop(top => $found_ys[$nth], height => 1)
+->scaleY(pixels => $toppad));

        ##Original.
        $out_img->paste(top => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad) + $toppad,
                        src => $tmp_img,
                        src_miny => $found_ys[$nth],
                        height => $in_char_y);
        #bottom pad.
        #$out_img->box(xmin => 0,
        #              xmax => $tmp_img->getwidth() -1 ,
        #              ymin => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad) + $toppad + $in_char_y,
        #              ymax => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad) + $out_char_y - 1,
        #              filled => 1, color => $pad_color);

        #crop, scaleY, paste
        $out_img->paste(top => $found_ys[$nth] + $nth * ($toppad + $bo
+tpad) + $toppad + $in_char_y,
          src =>$tmp_img->crop(top =>$found_ys[$nth] +$in_char_y -1, h
+eight =>1)->scaleY(pixels =>$botpad));

        if($nth < $#found_ys){
            ##original to the next cutpoint.
            $out_img->paste(top => $found_ys[$nth] + $nth * ($toppad +
+ $botpad) + $out_char_y,
                            src => $tmp_img,
                            src_miny => $found_ys[$nth] + $in_char_y,
                            height => $found_ys[$nth + 1] - $found_ys[
+$nth] - $in_char_y);
        }
    }
    #Copy after the last insertation.
    $out_img->paste( top => $found_ys[$#found_ys] + $in_char_y + $grow
+_y,
                     src => $tmp_img,
                     src_miny => $found_ys[$#found_ys] + $in_char_y);
}else{
    #nothing to do.
    $out_img->paste(src => $tmp_img);
}

#Patch up offsets.
my %adjust_xs = ();
my %adjust_ys = ();

for(my $nth = 0; $nth <= $#found_xs; $nth++){
    $adjust_xs{$found_xs[$nth]} = $found_xs[$nth] + $nth * ($out_char_
+x - $in_char_x);
}

for(my $nth = 0; $nth <= $#found_ys; $nth++){
    $adjust_ys{$found_ys[$nth]} = $found_ys[$nth] + $nth * ($out_char_
+y - $in_char_y);
}
#Insert characters.
for(@char_queue){
    my $new_x = $adjust_xs{$$_{"orig_x"}};
    my $new_y = $adjust_ys{$$_{"orig_y"}};
    my $orig_img = $$_{"orig_image"};
    my $name = $$_{"orig_name"};

    #plain copy now, get the colors shifted later.
    $out_img->paste(left => $new_x, top => $new_y,
      src => 
        unflatten_img(
           remap_colors($orig_img, $bitmapper_mapper{flatten_img($orig
+_img, "")}, ""), 
              $out_char_x, $out_char_y, ""));

                        #remap_colors($orig_img, $bitmapper_mapper{fla
+tten_img($orig_img, "")}), 
                        #$out_char_x, $out_char_y, "" ));
    
    printf("INFO: Char \"%s\" at offsets (%3d,%3d)\n", $name, $new_x, 
+$new_y);
}

print("Saving to \"$out_path\" . . . ");
if($out_img->write(file => $out_path, type => "png")){
    print("done.\n");
}else{
    print("failed: " . $out_img->errstr . "\n");
}



#Needs a more precise name.
sub flatten_img { 
    (my $img, my $errmode) = @_;
    my $out_str;
    my $logmsg = "";

    #Drop alpha channel.
    $img = drop_alpha($img);
    
    $img->write(data => \$out_str, type => "raw", raw_interleave => 0)
+;

    #count number of colors.
    my $expected_count = $img->getwidth() * $img->getheight();
    my $orig_colors = $img->getcolorusagehash(maxcolors => 4); #conven
+ient.
    my $total_px = 0;
    for(keys(%$orig_colors)){
        $total_px += $$orig_colors{$_};
    }
    if($total_px != $expected_count || scalar(keys(%$orig_colors)) > 3
+){
        if($errmode eq "print"){
            print("Warning: too many colors.\n");
        }elsif($errmode eq "list"){
            $logmsg .= "Warning: too many colors.\n";
        }
    }

    #sort by popularity.
    my @orig_colors_list = sort( { $$orig_colors{$b} <=> $$orig_colors
+{$a} }
                                   keys(%$orig_colors));

    my %tmp_map = ();
    for my $idx (0..2){
        $tmp_map{$orig_colors_list[$idx]} = $fav_colors[$idx] if defin
+ed($orig_colors_list[$idx]);
    }
    
    my $errpx = 0;
    $out_str =~ s/(...)/defined($tmp_map{$1}) ? $tmp_map{$1} : scalar(
+ $errpx++, $1 )/eg;

    if($errpx){
        #switch depending on errmode
        if($errmode eq "print"){
            print("Warning: found $errpx unexpected pixels.\n");
        }elsif($errmode eq "list"){
            $logmsg .= "Warning: found $errpx unexpected pixels.\n";
        }
    }
    if($errmode eq "list"){
        return ($out_str, $logmsg);
    }elsif($errmode eq "undef"){
        return $errpx ? undef : $out_str;
    }elsif($errmode eq "ignore" || 1 ){
        return $out_str;
    }

}

sub unflatten_img {
    (my $flatimg, my $x, my $y, my $errmode) = @_;
    my $img = Imager->new(channels => 3);
    my $res = $img->read(data => $flatimg, type => "raw", xsize => $x,
+ ysize => $y,
                      raw_interleave => 0, datachannels => 3, storecha
+nnels => 3);
    if( ! $res){
        print("Failed to unflatten img: " . $img->errstr() . "\n");
    }
    return $img;
}

sub remap_colors {
    (my $src, my $flatimg, my $errmode) = @_;
    my $orig_colors = $src->getcolorusagehash(maxcolors => 3); 
    #sort by popularity.
    my @orig_colors_list = sort( { $$orig_colors{$b} <=> $$orig_colors
+{$a} }
                                   keys(%$orig_colors));
    my $msgstr = "";

    my %tmp_map = ();
    for my $idx (0..2){
        $tmp_map{$fav_colors[$idx]} = $orig_colors_list[$idx] if defin
+ed($orig_colors_list[$idx]);
    }
    $flatimg =~ s/(...)/defined($tmp_map{$1}) ? $tmp_map{$1} : $1/eg;
    return $flatimg;
}

sub drop_alpha {
    (my $img, my $errmode) = @_;
    if($img->getchannels() == 4){
        my $tmp = Imager->new(xsize => $img->getwidth(), 
                              ysize => $img->getheight(),
                              channels => 3);
        $tmp->paste(left => 0, top => 0, src => $img);
        return $tmp;
    }else{
        return $img;
    }
}

[download]

See also, soylentnews journal post #1, soylentnews journal post #2

Replies are listed 'Best First'.
Re: Subimage replacement script
by SuicideJunkie (Vicar) on Nov 16, 2015 at 23:02 UTC

    When I was trying to OCR screenshots a few years ago, I collected a directory full of snippets of the possible characters, and then wrote a helper script to find which pixels to sample to eliminate the most possibilities at each step and save the results into a HoHoHo...H search tree/dictionary (each leaf node being the character found, and other nodes containing pixel coordinates to check and a pair of hashrefs to follow depending on the pixel color).

    That way the characters could be determined from 5-10 samples instead of a full comparison, and variable width characters were supported. Sampling a pixel further right than a potential character's size could not eliminate it as a possibility; the tree would eventually prefer a pixel that could eliminate the narrower characters.

    All my images were downsampled to 1-bit per pixel to keep it simple, and the start position was known relative to the window coordinates, so that helped a bunch.

    Perhaps you could try doing a search for a known character and then scan outwards from that? Something vaguely like /01110.{$img_width_minus5}10001.{$img_width_minus5}10001.{$img_width_minus5}01110/ to search for an 'o' shape anywhere in the image. Once you've found one character, then you've found the grid.

[reply]
[d/l]

Back to Cool Uses for Perl