search2.pl
1 #! perl -wl
2 # args word word dict
3 # Dodgsonian doublets
4 #
5
6 use MyCanon;
7 use strict;
8 # use vars qw[ $debug ]; ## Globals;
9 use Getopt::Long;
10 INIT {
11 our $is_reversed;
12 our $limit=20;
13 our $debug=$ENV{DEBUG}||0;
14 our $trace;
15
16
17 unless (GetOptions("--reversed" => \$is_reversed,
18 "--limit=i" => \$limit,
19 "--debug" => \$debug,
20 "--trace" => \$trace,
21 ))
22 {
23 die "flags --reversed --limit=$limit --debug";
24 }
25
26
27
28 my $word1=shift @ARGV;
29 my $word2=shift @ARGV;
30 our @Queue;
31
32
33 our $start=$word1;
34 our $target=$word2;
35 my $n= length $word1;
36 die "Not same length $word1 $word2"
37 unless length($word1)==length($word2);
38
39
40 my @Stops;
41 if (-r 'stopwords.txt') {
42 my $stop;
43 open $stop, '<', 'stopwords.txt' or die 'stopwords.txt failed';
44 @Stops= map {chomp; $_} <$stop>;
45
46 }
47 my %Stop= map { $_ => 1 } @Stops;
48
49 our @Words=grep {chomp;
50 length == $n
51 and ! $Stop{$_}
52 } <>;
53 warn "read @{[scalar @Words]} words";
54 }
55
56 ####################################
57
58
59 # From init
60 our ($start,$target, @Queue, @Words);
61 our ($is_reversed,$debug,$limit,$trace); # Flags
62
63
64 # Used here
65 our (%Predicessor);
66
67
68 sub pop_word;
69
70 sub pop_word {
71 print "POP OUT" and return if @Queue < 1; # recursion ends when done
72
73 my $word=pop @{$Queue[-1]->{next}};
74 print "popping ", $word||'*NULL*' if $debug>3;
75
76 if (defined $word and $word)
77 {
78 push @{$Queue[-1]->{seen}},$word; # remember it
79 }
80 else
81 {
82 print "no word for ",$Queue[-1]->{word},"\n" if $debug > 3;
83 pop @Queue;
84 return;
85 }
86 return $word;
87 }
88
89 sub report {
90 my ($first, $last)=@_;
91
92 join( ' ',
93 $first,
94 join( '=>',
95 map( { $_->{word} } @Queue)
96 ),
97
98 $last
99 );
100 }
101
102 sub level_n {
103 my $n = shift;
104 join (' ',
105 $Queue[$n]->{word},
106 '=>[',
107 @{$Queue[$n]->{next}},
108 '|',
109 @{$Queue[$n]->{seen}},
110 "]"
111 );
112 }
113
114 sub dumpit {
115 if ($debug>2)
116 {
117 print for map { level_n $_ } 0..$#Queue;
118 print "===========================\n";
119 }
120 else
121 {
122 my $n=$#Queue;
123 print q{ }x$n, $n, ' ', level_n($n);
124 }
125
126 }
127
128
129 sub seen {
130 my $x=shift;
131 for my $y (map { ( $_->{word},
132 @{$_->{next}},
133 @{$_->{seen}}
134 )}
135 @Queue )
136 {
137 return 1 if $x eq $y;
138 }
139 return;
140 }
141
142
143 sub adjacents {
144 my $word=shift;
145 my $pat=adjacent_pattern($word);
146 my @next=
147 grep {
148 /$pat/
149 and ! seen($_)
150 } @Words;
151 # print "adjacent($word)= /$pat/ [@next]" if $debug;
152 return @next;
153 }
154
155
156 sub push_word {
157 our $is_reversed;
158 my $word=shift;
159 return if @Queue >= $limit;
160 print "# push($word)" if $debug > 2;
161 push @Queue,
162 { word=>$word,
163 next=>[ $is_reversed ? reverse adjacents($word) : adjacents($word)],
164 seen=> [],
165 };
166
167 }
168
169 push_word($start);
170
171
172
173 warn report('[plan:', "==> $target ]");
174
175 dumpit() if $debug;
176
177 local $|=1;
178
179 while (@Queue)
180 {
181 printf "\015%5d %s", scalar @Queue, report('[',']')
182 if $trace;
183
184 my $word=pop_word();
185
186 print("# word=@{[$word||q{}]}") if $debug>2;
187
188 # level_n($#Queue);
189
190 if ($word and $word eq $target)
191 {
192 print " => $target ** FOUND ** " if $trace;
193 print report("\n*Found*", "=>$target\n" ) unless $trace;
194 }
195 elsif($word)
196 {
197 # next if seen($word);
198 push_word($word); # recurse depth first
199 # report('[',']');
200 }
201 # else, we popped a bracket, continue
202
203 dumpit() if $debug;
204
205
206
207 }
208