File Coverage

ppmclibs/blib/lib/tinycv.pm
Criterion Covered Total %
statement 109 124 87.9
total 109 124 87.9


line stmt code
1   # Copyright 2009-2013 Bernhard M. Wiedemann
2   # Copyright 2012-2020 SUSE LLC
3   # SPDX-License-Identifier: GPL-2.0-or-later
4    
5    
6   use Mojo::Base -strict, -signatures;
7 22  
  22  
  22  
8   use bmwqemu 'fctwarn';
9 22 use File::Basename;
  22  
  22  
10 22 use Math::Complex 'sqrt';
  22  
  22  
11 22 require Exporter;
  22  
  22  
12   require DynaLoader;
13    
14   our @ISA = qw(Exporter DynaLoader);
15   our @EXPORT = qw();
16    
17   our $VERSION = '1.0';
18    
19   bootstrap tinycv $VERSION;
20    
21    
22   use Mojo::Base -strict, -signatures;
23    
24 22 my $mse = 0.0;
  22  
  22  
25   my $err;
26 65  
  65  
  65  
27 65 for my $area (@$areas) {
28 65 $err = 1 - $area->{similarity};
29   $mse += $err * $err;
30 65 }
31 85 return $mse / scalar @$areas;
32 85 }
33    
34 65 # returns hash with match hinformation
35   # {
36   # ok => INT(1,0), # 1 if all areas matched
37   # area = [
38   # { x => INT, y => INT, w => INT, h => INT,
39   # similarity => FLOAT,
40   # result = STRING('ok', 'fail'),
41   # }
42   # ]
43   # }
44   $threshold ||= 0.0;
45   $search_ratio ||= 0.0;
46   my ($sim, $xmatch, $ymatch);
47 66 my (@exclude, @match, @ocr);
  66  
  66  
  66  
  66  
  66  
  66  
48 66  
49 66 return unless $needle;
50 66  
51 66 my $needle_image = $needle->get_image;
52   unless ($needle_image) {
53 66 bmwqemu::fctwarn("skipping $needle->{name}: missing PNG");
54   return undef;
55 66 }
56 66 $stopwatch->lap("**++ search__: get image") if $stopwatch;
57 1  
58 1 my $img = $self;
59   for my $area (@{$needle->{area}}) {
60 65 push @exclude, $area if $area->{type} eq 'exclude';
61   push @match, $area if $area->{type} eq 'match';
62 65 push @ocr, $area if $area->{type} eq 'ocr';
63 65 }
  65  
64 93  
65 93 if (@exclude) {
66 93 $img = $self->copy;
67   for my $exclude_area (@exclude) {
68   $img->replacerect(@{$exclude_area}{qw(xpos ypos width height)});
69 65 $stopwatch->lap("**++-- search__: rectangle replacement") if $stopwatch;
70 5 }
71 5 $stopwatch->lap("**++ search__: areas exclusion") if $stopwatch;
72 8 }
  8  
73 8 my $ret = {ok => 1, needle => $needle, area => []};
74   for my $area (@match) {
75 5 my $margin = int($area->{margin} + $search_ratio * (1024 - $area->{margin}));
76    
77 65 ($sim, $xmatch, $ymatch) = $img->search_needle($needle_image, $area->{xpos}, $area->{ypos}, $area->{width}, $area->{height}, $margin);
78 65  
79 85 $stopwatch->lap("**++ tinycv::search_needle $area->{width}x$area->{height} + $margin @ $area->{xpos}x$area->{ypos}") if $stopwatch;
80   my $ma = {
81 85 similarity => $sim,
82   x => $xmatch,
83 85 y => $ymatch,
84   w => $area->{width},
85   h => $area->{height},
86   result => 'ok',
87   };
88   if (my $click_point = $area->{click_point}) {
89   $ma->{click_point} = $click_point;
90 85 }
91    
92 85 # A 96% match is ok for console tests. Please, if you
93 0 # change this number consider change also the test
94   # 01-test_needle and the console tests (for example, using
95   # more smaller areas)
96    
97   my $m = ($area->{match} || 96) / 100;
98   if ($sim < $m - $threshold) {
99   $ma->{result} = 'fail';
100   $ret->{ok} = 0;
101 85 }
102 85 push @{$ret->{area}}, $ma;
103 43 }
104 43  
105   $ret->{error} = mean_square_error($ret->{area});
106 85 if ($ret->{ok}) {
  85  
107   for my $ocr_area (@ocr) {
108   $ret->{ocr} ||= [];
109 65 my $ocr = ocr::tesseract($img, $ocr_area);
110 65 push @{$ret->{ocr}}, $ocr;
111 27 }
112 0 $stopwatch->lap("**++ ocr::tesseract: $needle->{name}") if $stopwatch;
113 0 }
114 0 return $ret;
  0  
115   }
116 27  
117   # bigger OK is better (0/1)
118 65 # smaller error is better if not OK (0 perfect, 1 totally off)
119   # if match is equal quality prefer workaround needle to non-workaround
120   # the name doesn't matter, but we prefer alphabetic order
121   ## no critic ($a/$b outside of sort block)
122   my $okay = $b->{ok} <=> $a->{ok};
123   return $okay if $okay;
124   my $error = $a->{error} <=> $b->{error};
125   return $error if $error;
126   return -1 if ($a->{needle}->has_property('workaround') && !$b->{needle}->has_property('workaround'));
127 6 return 1 if ($b->{needle}->has_property('workaround') && !$a->{needle}->has_property('workaround'));
128 6 return $a->{needle}->{name} cmp $b->{needle}->{name};
129 6  
130 6 ## use critic
131 3  
132 2 }
133 1  
134    
135   # in scalar context return found info or undef
136   # in array context returns array with two elements. First element is best match
137   # or undefined, second element are candidates that did not match.
138   return unless $needle;
139    
140   $stopwatch->lap("Searching for needles") if $stopwatch;
141    
142   if (ref($needle) eq "ARRAY") {
143 85 my @candidates;
  85  
  85  
  85  
  85  
  85  
  85  
144 85 # try to match all needles and return the one with the highest similarity
145   for my $n (@$needle) {
146 85 my $found = $self->search_($n, $threshold, $search_ratio, $stopwatch);
147   push @candidates, $found if $found;
148 85 $stopwatch->lap("** search_: $n->{name}") if $stopwatch;
149 51 }
150    
151 51 @candidates = sort cmp_by_error_type_ @candidates;
152 32 my $best;
153 32  
154 32 if (@candidates && $candidates[0]->{ok}) {
155   $best = shift @candidates;
156   }
157 51 if (wantarray) {
158 51 return ($best, \@candidates);
159   }
160 51 else {
161 10 return $best;
162   }
163 51 }
164 49  
165   else {
166   my $found = $self->search_($needle, $threshold, $search_ratio, $stopwatch);
167 2 $stopwatch->lap("** search_: single needle: $needle->{name}") if $stopwatch;
168   return unless $found;
169   if (wantarray) {
170   return ($found, undef) if ($found->{ok});
171   return (undef, [$found]);
172 34 }
173 34 return unless $found->{ok};
174 34 return $found;
175 34 }
176 7 }
177 6  
178   $self->write($filename);
179 27  
180 12 my $thumb = $self->scale($self->xres() * 45 / $self->yres(), 45);
181   my $dir = File::Basename::dirname($filename) . "/.thumbs";
182   my $base = File::Basename::basename($filename);
183    
184 0 mkdir($dir);
  0  
  0  
  0  
185 0 $thumb->write("$dir/$base");
186   }
187 0  
188 0 1;