File Coverage

blib/lib/Algorithm/Search.pm
Criterion Covered Total %
statement 314 353 88.9
branch 120 140 85.7
condition 13 19 68.4
subroutine 20 24 83.3
pod 0 19 0.0
total 467 555 84.1


line stmt bran cond sub pod time code
1             package Algorithm::Search;
2              
3             $VERSION = '0.04';
4              
5 12     12   265632 use 5.006;
  12         47  
  12         639  
6 12     12   89 use strict;
  12         18  
  12         489  
7 12     12   66 use Carp;
  12         28  
  12         1103  
8 12     12   73 use warnings;
  12         18  
  12         35544  
9              
10              
11             #Copyright 2008 Arthur S Goldstein
12              
13              
14             sub continue_search {
15 111     111 0 147 my $self = shift;
16 111         117 my $parameters = shift;
17 111 100       274 if (defined $parameters->{additional_steps}) {
18 8         20 $self->{max_steps} += $parameters->{additional_steps};
19 8         17 $self->{continue_search} = 1;
20             }
21 111         226 while ($self->{continue_search}) {
22             #print STDERR "Search step ".$self->{steps}."\n";
23 197867 100       517359 if ($self->{steps} == $self->{max_steps}) {
  197859 50       349152  
24 8         20 $self->{continue_search} = 0;
25 8         25 $self->{too_many_steps} = 1;
26             }
27             elsif (&{$self->{stop_search}}
28             ($self->{last_object}, $self->{steps}, $self->{last_path})) {
29 0         0 $self->{continue_search} = 0;
30             }
31             else {
32 197859         162339 &{$self->{search_step}}($self);
  197859         307496  
33             # $self->{steps}++;
34             }
35             }
36 111         426 return;
37             }
38              
39             sub solution_found {
40 61     61 0 300 my $self = shift;
41 61         131 return ($self->{solutions_found} > 0);
42             }
43              
44             sub solutions_found {
45 0     0 0 0 my $self = shift;
46 0         0 return $self->{solutions_found};
47             }
48              
49             sub solution {
50 0     0 0 0 my $self = shift;
51 0 0       0 if ($#{$self->{solutions}} == -1) {
  0         0  
52 0         0 return undef;
53             }
54 0         0 return $self->{solutions}->[0];
55             }
56              
57             sub solutions {
58 15     15 0 93 my $self = shift;
59 15         16 return @{$self->{solutions}};
  15         1629  
60             }
61              
62             sub search_trace {
63 4     4 0 2131 my $self = shift;
64 4         127 return $self->{trace};
65             }
66              
67             sub path {
68 4     4 0 16 my $self = shift;
69 4 50       4 if ($#{$self->{paths}} == -1) {
  4         18  
70 0         0 return undef;
71             }
72 4         168 return $self->{paths}->[0];
73             }
74              
75             sub paths {
76 55     55 0 252 my $self = shift;
77 55         59 return @{$self->{paths}};
  55         216  
78             }
79              
80             sub last_object {
81 15     15 0 101 my $self = shift;
82 15         84 return $self->{last_object};
83             }
84              
85             sub completed {
86 0     0 0 0 my $self = shift;
87 0         0 return $self->{search_completed};
88             }
89              
90             sub steps {
91 0     0 0 0 my $self = shift;
92 0         0 return $self->{steps};
93             }
94              
95             sub first_search_step {
96 89     89 0 113 my $self = shift;
97 89         130 my $initial_cost = $self->{initial_cost};
98             #why doesn't below line work?
99             #my $initial_position = $self->{last_object} = $self->{search_this}->copy;
100 89         259 my $x_position = $self->{last_object} = $self->{search_this}->copy;
101 89         2642 my $initial_position = $x_position;
102             #my $initial_position = $self->{last_object} = $self->{search_this};
103              
104 89 100       232 if ($self->{mark_solution}) {
105 88 50       214 if ($initial_position->is_solution) {
106 0         0 push @{$self->{paths}}, $self->{last_path} = [];
  0         0  
107 0         0 push @{$self->{solutions}}, $initial_position;
  0         0  
108 0 0       0 if (++$self->{solutions_found} == $self->{solutions_to_find}) {
109 0         0 $self->{search_completed} = 1;
110 0         0 $self->{continue_search} = 0;
111             }
112             }
113             }
114              
115 89         711 my %path_values;
116             my $value;
117 89 100       224 if ($self->{value_function}) {
118 47         138 $value = $initial_position->value;
119 47 100       255 if ($self->{do_not_repeat_values}) {
120 10         27 $self->{handled}->{$value} = 1;
121             }
122 47         85 $path_values{$value} = 1;
123             }
124              
125 89         92 my $initial_commit;
126 89 100       223 if ($self->{committing}) {
127 4         8 $initial_commit = $initial_position->commit_level;
128             }
129              
130 89 100       341 if ($self->{return_search_trace}) {
131 3         5 push @{$self->{trace}}, {
  3         21  
132             cost => $initial_cost,
133             commit => $initial_commit,
134             value_after => $value,
135             value_before => undef,
136             move => undef,
137             };
138             }
139              
140 89         164 $self->{queue} = [];
141             #print STDERR "tsize of queue is ".(scalar @{$self->{queue}})."\n";
142 89         1706 foreach my $move (reverse $initial_position->next_moves) {
143             #print STDERR "FAdded $move to queue\n";
144 338         787 push @{$self->{queue}},
  338         1020  
145             [$initial_position, $move, [], \%path_values, $initial_cost,
146             $initial_commit, $value];
147             }
148             #print STDERR "set up queu \n";
149             #print STDERR "rsize of queue is ".(scalar @{$self->{queue}})."\n";
150             }
151              
152             sub search_step {
153 197241     197241 0 188507 my $self = shift;
154              
155 197241 100       165897 if (!(scalar @{$self->{queue}})) {
  197241         393832  
156 61         87 $self->{search_completed} = 1;
157 61         75 $self->{continue_search} = 0;
158 61         165 return;
159             }
160              
161             #print STDERR "size of queue is ".(scalar @{$self->{queue}})."\n";
162 197180         529168 my ($position, $move, $path, $path_values, $cost, $commit, $previous_value) =
163 197180         172147 @{shift @{$self->{queue}}};
  197180         151144  
164 197180         245786 my $new_position;
165 197180         376382 $new_position = $position->copy;
166             #print STDERR "recovered from queue cost $cost\n";
167              
168 197180         8354864 my $new_cost = $new_position->move($move, $cost);
169 197180         5994287 $self->{steps}++;
170             #print STDERR "new cost is $new_cost\n";
171 197180 100       369594 if (!defined $new_cost) {
172 112658         678673 return;
173             };
174              
175 84522 100 100     183094 if ($self->{cost_cannot_increase} && ($new_cost > $cost) && (defined $cost))
      66        
176             {
177 63         257 return;
178             }
179              
180 84459         102860 $self->{last_object} = $new_position;
181 84459         157949 my $new_path;
182 84459         455640 $new_path = [@$path, $move];
183 84459         103424 $self->{last_path} = $new_path;
184              
185 84459         112253 my $new_path_values;
186             my $value;
187 84459 100       155318 if ($self->{value_function}) {
188 50933         110235 $value = $new_position->value;
189 50933 100       836200 if ($path_values->{$value}) {
190 17460         125214 return;
191             }
192 33473 100       64107 if ($self->{do_not_repeat_values}) {
193 33176 100       89284 if ($self->{handled}->{$value}) {
194 2096         13801 return;
195             }
196 31080         88485 $self->{handled}->{$value} = 1;
197             }
198 31377         697284 $new_path_values = {%$path_values};
199 31377         111623 $new_path_values->{$value} = 1;
200             }
201              
202 64903 100       116833 if ($self->{return_search_trace}) {
203 23         19 push @{$self->{trace}}, {
  23         80  
204             cost => $cost,
205             commit => $commit,
206             value_before => $previous_value,
207             value_after => $value,
208             move => $move,
209             };
210             }
211              
212 64903 100       116385 if ($self->{mark_solution}) {
213 62139 100       137474 if ($new_position->is_solution) {
214 303         1636 push @{$self->{paths}}, $new_path;
  303         616  
215 303         299 push @{$self->{solutions}}, $new_position;
  303         448  
216 303 100       726 if (++$self->{solutions_found} == $self->{solutions_to_find}) {
217 28         54 $self->{search_completed} = 1;
218 28         58 $self->{continue_search} = 0;
219             }
220             }
221             }
222              
223 64903 100       847088 if (scalar(@$new_path) == $self->{maximum_depth_minus_one}) {
224 227         729 return;
225             }
226              
227 64676         56951 my $new_commit;
228 64676 100       111244 if ($self->{committing}) {
229 31020         55705 $new_commit = $new_position->commit_level;
230 31020 100       745589 if ($new_commit < $commit) {
231 24         54 $self->{queue} = [];
232             }
233             }
234              
235 64676 100       344791 if ($self->{search_type} eq 'dfs') {
    100          
    50          
236 14115         24755 foreach my $move (reverse $new_position->next_moves) {
237 49462         108614 unshift @{$self->{queue}},
  49462         195184  
238             [$new_position, $move, $new_path, $new_path_values, $new_cost,
239             $new_commit, $value];
240             }
241             }
242             elsif ($self->{search_type} eq 'bfs') {
243 50267         94022 foreach my $move ($new_position->next_moves) {
244 187168         739676 push @{$self->{queue}},
  187168         809239  
245             [$new_position, $move, $new_path, $new_path_values, $new_cost,
246             $new_commit, $value];
247             }
248             }
249             elsif ($self->{search_type} eq 'cost') {
250 294         527 my @moves = $new_position->next_moves;
251 294 100       1802 if (scalar(@moves)) {
252 265         235 my ($l, $u) = (-1, scalar(@{$self->{queue}}));
  265         392  
253 265         290 my $m;
254 265         507 while ($u - $l > 1) {
255 960         1161 $m = $l + int (($u-$l)/2);
256             #print STDERR "m is $m and u is $u and nc is $new_cost cost is $cost ";
257             #print STDERR "4 is ";
258             #print STDERR $self->{queue}->[$m]->[4]."\n";
259 960 100       1598 if ($self->{queue}->[$m]->[4] > $new_cost) { #4 is cost
260 500         948 $u = $m;
261             }
262             else {
263 460         794 $l = $m;
264             }
265             }
266 265         355 foreach my $move (reverse @moves) {
267             #print STDERR "adding to queue nc $new_cost\n";
268 528         450 splice (@{$self->{queue}}, $u, 0,
  528         2491  
269             [$new_position, $move, $new_path, $new_path_values, $new_cost,
270             $new_commit, $value]);
271             }
272             }
273             }
274             else {
275 0         0 croak ("Unknown search type");
276             }
277             }
278              
279              
280             sub rdfs_first_search_step {
281 14     14 0 19 my $self = shift;
282 14         18 my $search_this = $self->{search_this};
283 14         17 $self->{last_object} = $search_this; #does not change
284 14         19 $self->{cost} = $self->{initial_cost};
285 14 50       30 if ($self->{committing}) {
286 0         0 $self->{commit} = $search_this->commit_level;
287             }
288 14 50       34 if ($search_this->is_solution) {
289 0         0 push @{$self->{paths}}, $self->{last_path} = [];
  0         0  
290 0 0       0 if ($self->{preserve_solutions}) {
291 0         0 push @{$self->{solutions}}, $search_this->copy;
  0         0  
292             }
293 0 0       0 if (++$self->{solutions_found} == $self->{solutions_to_find}) {
294 0         0 $self->{search_completed} = 1;
295 0         0 $self->{continue_search} = 0;
296             }
297             }
298 14         90 $self->{next_move} = $search_this->move_after_given();
299 14         178 my $value;
300 14 100       29 if (!defined $self->{next_move}) {
301 1         3 $self->{search_completed} = 1;
302 1         3 $self->{continue_search} = 0;
303             }
304             else {
305 13         18 $self->{moving_forward} = 1;
306 13         16 $self->{path} = [];
307 13         19 $self->{cost_list} = [];
308 13         16 $self->{commit_list} = [];
309 13 100       25 if ($self->{value_function}) {
310 12         22 $value = $search_this->value;
311 12         52 $self->{path_values} = {$value => 1};
312 12         29 $self->{value_list} = [$value];
313 12 100       28 if ($self->{do_not_repeat_values}) {
314 2         4 $self->{handled}->{$value} = 1;
315             }
316             }
317 13         12 push @{$self->{info}}, [$value, $self->{cost}, $self->{commit}];
  13         35  
318             }
319 14 100       36 if ($self->{return_search_trace}) {
320 1         3 push @{$self->{trace}}, {
  1         8  
321             cost => $self->{cost},
322             commit => $self->{commit},
323             value_before => undef,
324             value_after => $value,
325             move => undef,
326             };
327             }
328              
329             }
330              
331             sub forward_rdfs_search_step {
332 318     318 0 253 my $self = shift;
333 318         326 my $search_this = $self->{search_this};
334 318         288 my $next_move = $self->{next_move};
335             #print STDERR "frdfs next move is $next_move\n";
336 318         485 my $new_cost = $search_this->move($next_move);
337 318         1344 $self->{steps}++;
338 318 50       467 if (!defined $new_cost) {
339 0         0 $self->{moving_forward} = 0;
340 0         0 return;
341             }
342 318 100 100     612 if (($self->{cost_cannot_increase}) && ($new_cost > $self->{cost})) {
343             #print STDERR "cost increased was ".$self->{cost}." to be $new_cost\n";
344 10         17 $search_this->reverse_move($next_move);
345 10         86 $self->{moving_forward} = 0;
346 10         32 return;
347             }
348              
349 308         221 my $value;
350 308 100       458 if ($self->{value_function}) {
351 156         225 $value = $search_this->value;
352             #print STDERR "considering vf on $value\n";
353 156 100       538 if ($self->{do_not_repeat_values}) {
354 30 100       53 if ($self->{handled}->{$value}) {
355             #print STDERR "handled already\n";
356 14         46 $search_this->reverse_move($next_move);
357 14         40 $self->{moving_forward} = 0;
358 14         39 return;
359             }
360 16         55 $self->{handled}->{$value} = 1;
361             }
362 142 100       282 if ($self->{path_values}->{$value}) {
363             #print STDERR "repeating value\n";
364 35         59 $search_this->reverse_move($next_move);
365 35         121 $self->{moving_forward} = 0;
366 35         113 return;
367             }
368             }
369 259         183 my $new_commit;
370 259 50       359 if ($self->{committing}) {
371 0         0 $new_commit = $search_this->commit_level;
372             }
373              
374 259 100       381 if ($self->{return_search_trace}) {
375             #use Data::Dumper;
376             #print STDERR "si ".Dumper($self->{info})."\n";
377 7         7 push @{$self->{trace}}, {
  7         43  
378             cost => $new_cost,
379             commit => $new_commit,
380             value_after => $value,
381             value_before => $self->{info}->[-1]->[0],
382             move => $next_move,
383             };
384             }
385              
386 259 100       374 if ($search_this->is_solution) {
387 34         120 push @{$self->{paths}}, [@{$self->{path}}, $next_move];
  34         39  
  34         84  
388 34 50       89 if ($self->{preserve_solutions}) {
389 0         0 push @{$self->{solutions}}, $search_this->copy;
  0         0  
390             }
391 34 100       64 if (++$self->{solutions_found} == $self->{solutions_to_find}) {
392 3         5 $self->{search_completed} = 1;
393 3         5 $self->{continue_search} = 0;
394             }
395             # else {
396             # $self->{last_path} = $self->{path} = [@{$self->{path}}];
397             # }
398             }
399              
400              
401 259 100       954 if (scalar(@{$self->{path}}) == $self->{maximum_depth_minus_one}) {
  259         530  
402             #print STDERR "hit max depth ".$self->{maximum_depth}."\n";
403 75         153 $search_this->reverse_move($next_move);
404 75         183 $self->{moving_forward} = 0;
405 75         192 return;
406             }
407              
408 184         290 $self->{next_move} = $search_this->move_after_given();
409 184 100       1512 if (defined $self->{next_move}) {
410 151 100       288 if ($self->{value_function}) {
411 77         118 $self->{path_values}->{$value} = 1;
412             }
413 151         107 push @{$self->{path}}, $next_move;
  151         196  
414 151         175 push @{$self->{info}}, [$value, $new_cost, $new_commit];
  151         243  
415 151         214 $self->{cost} = $new_cost;
416 151         152 $self->{commit} = $new_commit;
417 151         540 return;
418             }
419             else {
420 33         32 $self->{next_move} = $next_move;
421 33         77 $search_this->reverse_move($next_move);
422 33         94 $self->{moving_forward} = 0;
423 33         138 return;
424             }
425             }
426              
427             sub backward_rdfs_search_step {
428 300     300 0 258 my $self = shift;
429 300         286 my $search_this = $self->{search_this};
430 300         564 my $next_move = $search_this->move_after_given($self->{next_move});
431 300 100       2548 if (defined $next_move) {
432             #print STDERR "back Have new move\n";
433 154         142 $self->{moving_forward} = 1;
434 154         142 $self->{next_move} = $next_move;
435 154         421 return;
436             }
437 146 100       107 if (scalar(@{$self->{path}}) == 0) {
  146         231  
438 10         16 $self->{search_completed} = 1;
439 10         13 $self->{continue_search} = 0;
440 10         31 return;
441             }
442             else {
443 136         230 my ($previous_value, $previous_cost, $previous_commit) =
444 136         102 @{pop @{$self->{info}}};
  136         103  
445 136 50 33     296 if ($self->{committing} && ($self->{commit} < $previous_commit)) {
446 0         0 $self->{search_completed} = 1;
447 0         0 $self->{continue_search} = 0;
448 0         0 return;
449             }
450 136         122 $self->{cost} = $previous_cost;
451 136         105 $self->{commit} = $previous_commit;
452 136 100       235 if ($self->{value_function}) {
453 62         75 $self->{path_values}->{$previous_value}--;
454             }
455 136         91 $self->{next_move} = pop @{$self->{path}};
  136         158  
456 136         246 $search_this->reverse_move($self->{next_move});
457             }
458             }
459              
460             sub rdfs_search_step {
461 618     618 0 486 my $self = shift;
462 618         636 my $search_this = $self->{search_this};
463 618         468 my $path_values = $self->{path_values};
464 618         515 my $direction = $self->{direction};
465              
466             #print STDERR "step ".$self->{steps}."\n";
467 618 100       744 if ($self->{moving_forward}) {
468 318         406 $self->forward_rdfs_search_step;
469             }
470             else {
471 300         492 $self->backward_rdfs_search_step;
472             }
473             }
474              
475             sub search {
476 103     103 0 52003 my $self = shift;
477 103         151 my $parameters = shift;
478 103         244 $self->{search_this} = $parameters->{search_this};
479 103   100     674 $self->{max_steps} = $parameters->{max_steps}
480             || $self->{default_max_steps} || 20000;
481 103         155 $self->{solutions_to_find} = 1;
482 103 50       268 if (defined $parameters->{solutions_to_find}) {
483 103         184 $self->{solutions_to_find} = $parameters->{solutions_to_find};
484             }
485             #print STDERR "Start search\n";
486 103         155 $self->{do_not_repeat_values} = $parameters->{do_not_repeat_values};
487 103         1067 $self->{maximum_depth} = $parameters->{maximum_depth};
488 103 100       1220 if (defined $parameters->{maximum_depth}) {
489 16         38 $self->{maximum_depth_minus_one} = $parameters->{maximum_depth} - 1;
490             }
491             else {
492 87         157 $self->{maximum_depth_minus_one} = -1;
493             }
494 103   50 197859   1419 $self->{stop_search} = $parameters->{stop_search} || sub {return 0};
  197859         329044  
495 103         350 $self->{return_search_trace} = $parameters->{return_search_trace};
496 103         140 my $no_value_function = $parameters->{no_value_function};
497 103         1075 $self->{initial_cost} = $parameters->{initial_cost};
498 103         659 $self->{cost_cannot_increase} = $parameters->{cost_cannot_increase};
499              
500             #copy might not be defined for rdfs, others it is required
501 103 100       486 if (UNIVERSAL::can($self->{search_this},"copy")) {
502 89         157 $self->{preserve_solutions} = 1;
503             }
504             else {
505 14         20 $self->{preserve_solutions} = 0;
506             }
507              
508 103 100       927 if (UNIVERSAL::can($self->{search_this},"is_solution")) {
509 102         166 $self->{mark_solution} = 1;
510             }
511             else {
512 1         3 $self->{mark_solution} = 0;
513             }
514              
515 103 100       349 if (UNIVERSAL::can($self->{search_this},"value")) {
516 74         120 $self->{value_function} = 1;
517             }
518             else {
519 29         55 $self->{value_function} = 0;
520             }
521 103 100       225 if ($no_value_function) {
522 36         58 $self->{value_function} = 0;
523             }
524              
525 103 100       348 if (UNIVERSAL::can($self->{search_this},"commit_level")) {
526 4         8 $self->{committing} = 1;
527             }
528             else {
529 99         192 $self->{committing} = 0;
530             }
531              
532 103 100       216 if (defined $parameters->{search_type}) {
533 86         156 $self->{search_type} = $parameters->{search_type};
534 86 100       349 if ($parameters->{search_type} eq 'dfs') {
    100          
    100          
    50          
535 16         48 $self->{first_search_step} = \&first_search_step;
536 16         67 $self->{search_step} = \&search_step;
537             }
538             elsif ($parameters->{search_type} eq 'bfs') {
539 43         100 $self->{first_search_step} = \&first_search_step;
540 43         111 $self->{search_step} = \&search_step;
541             }
542             elsif ($parameters->{search_type} eq 'cost') {
543 13         23 $self->{first_search_step} = \&first_search_step;
544 13         22 $self->{search_step} = \&search_step;
545             }
546             elsif ($parameters->{search_type} eq 'rdfs') {
547 14         28 $self->{first_search_step} = \&rdfs_first_search_step;
548 14         22 $self->{search_step} = \&rdfs_search_step;
549             }
550             else {
551 0         0 die "Unknown search type ".$parameters->{search_type};
552             }
553             }
554             else {
555 17         33 $self->{first_search_step} = $self->{default_first_search_step};
556 17         22 $self->{search_step} = $self->{default_search_step};
557 17         62 $self->{search_type} = $self->{default_search_type};
558             }
559 103         217 $self->{handled} = {};
560 103         267 $self->{move_list} = [undef];
561 103         187 $self->{moving_forward} = 1;
562 103         126 $self->{continue_search} = 1;
563 103         613 $self->{search_completed} = 0;
564 103         248 $self->{solutions_found} = 0;
565 103         179 $self->{solutions} = [];
566 103         359 $self->{paths} = [];
567 103         508 $self->{trace} = [];
568 103         152 &{$self->{first_search_step}}($self);
  103         255  
569 103         223 $self->{steps} = 1;
570 103         219 $self->continue_search;
571             }
572              
573             sub new {
574 13     13 0 3544 my $type = shift;
575 13   33     93 my $class = ref($type) || $type;
576 13         24 my $parameters = shift;
577 13         31 my $self = {};
578 13         49 $self->{default_first_search_step} = \&first_search_step;
579 13         29 $self->{default_search_type} = 'dfs';
580 13         48 $self->{default_search_step} = \&search_step;
581 13         35 bless $self, $class;
582 13         41 return $self;
583             }
584              
585              
586             1;
587              
588             __END__