Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[src/core/Cool-str.pm] new .trans algoritm

This one abstracts away the actual matching-and-replacing into a
helper class implementing a simple longest-token matching algorithm.
  • Loading branch information...
commit 9fe5972f60b9bf41aa73ac6e11893dbd185ee344 1 parent 731a832
Carl Mäsak authored November 20, 2010

Showing 1 changed file with 93 additions and 21 deletions. Show diff stats Hide diff stats

  1. 114  src/core/Cool-str.pm
114  src/core/Cool-str.pm
@@ -163,9 +163,79 @@ augment class Cool {
163 163
         ~pir::substr(self, $start, $len);
164 164
     }
165 165
 
166  
-    multi method trans(*@changes) {
167  
-        return self unless @changes;
  166
+    my $longest_substitution_matcher = class {
  167
+        has Cool $!source is readonly;
  168
+        has      @!substitutions;
  169
+
  170
+        has Int  $!index = 0;
  171
+        has Int  $!next_match;
  172
+        has      $!next_substitution;
  173
+        has      $!substitution_length;
  174
+
  175
+        has Str  $.unsubstituted_text;
  176
+        has Str  $.substituted_text;
  177
+
  178
+        method add_substitution($key, $value) {
  179
+            push @!substitutions, $key => $value;
  180
+        }
  181
+
  182
+        submethod compare_substitution($substitution, Int $pos, Int $length) {
  183
+            if $!next_match > $pos
  184
+               || $!next_match == $pos && $!substitution_length < $length {
  185
+
  186
+                $!next_match = $pos;
  187
+                $!substitution_length = $length;
  188
+                $!next_substitution = $substitution;
  189
+            }
  190
+        }
  191
+
  192
+        multi submethod triage_substitution($_ where { .key ~~ Regex }) {
  193
+            my $key = .key;
  194
+            return unless $!source.substr($!index) ~~ $key;
  195
+            self.compare_substitution($_, $!index + $/.from, $/.to - $/.from);
  196
+        }
  197
+
  198
+        multi submethod triage_substitution($_ where { .key ~~ Cool }) {
  199
+            return unless defined index($!source, .key, $!index);
  200
+            self.compare_substitution($_,
  201
+                                      index($!source, .key, $!index),
  202
+                                      .key.chars);
  203
+        }
  204
+
  205
+        multi submethod triage_substitution($_) {
  206
+            die "Don't know how to handle a {.WHAT} as a substitution key";
  207
+        }
  208
+
  209
+        multi submethod increment_index(Regex $s) {
  210
+            $!source.substr($!index) ~~ $s;
  211
+            $!index = $!next_match + $/.chars;
  212
+        }
168 213
 
  214
+        multi submethod increment_index(Str $s) {
  215
+            $!index = $!next_match + $s.chars;
  216
+        }
  217
+
  218
+        method next_substitution() {
  219
+            $!next_match = $!source.chars;
  220
+
  221
+            for @!substitutions {
  222
+                self.triage_substitution($_);
  223
+            }
  224
+
  225
+            $!unsubstituted_text
  226
+                = $!source.substr($!index, $!next_match - $!index);
  227
+            if defined $!next_substitution {
  228
+                my $result = $!next_substitution.value;
  229
+                $!substituted_text
  230
+                    = $result ~~ Callable ?? $result() !! $result;
  231
+                self.increment_index($!next_substitution.key);
  232
+            }
  233
+
  234
+            return $!next_match < $!source.chars;
  235
+        }
  236
+    }
  237
+
  238
+    multi method trans(*@changes) {
169 239
         my sub expand($s) {
170 240
             return $s.list if $s ~~ Iterable|Positional;
171 241
             gather for $s.comb(/ (\w) '..' (\w) | . /, :match) {
@@ -177,39 +247,41 @@ augment class Cool {
177 247
             }
178 248
         }
179 249
 
180  
-        my %c;
  250
+        my $ltm = $longest_substitution_matcher.new(:source(self));
181 251
         for (@changes) -> $p {
182 252
             die "$p.perl() is not a Pair" unless $p ~~ Pair;
183  
-            my @from = expand $p.key;
184  
-            my @to   = expand $p.value;
185  
-            if @to {
186  
-                @to = @to xx ceiling(@from / @to);
187  
-            } else {
188  
-                @to = '' xx @from;
  253
+            if $p.key ~~ Regex {
  254
+                $ltm.add_substitution($p.key, $p.value);
189 255
             }
190  
-            for @from Z @to -> $f, $t {
191  
-                if %c.exists($f) && %c{$f} ne $t {
  256
+            elsif $p.value ~~ Callable {
  257
+                my @from = expand $p.key;
  258
+                for @from -> $f {
  259
+                    $ltm.add_substitution($f, $p.value);
  260
+                }
  261
+            }
  262
+            else {
  263
+                my @from = expand $p.key;
  264
+                my @to   = expand $p.value;
  265
+                if @to {
  266
+                    @to = @to xx ceiling(@from / @to);
192 267
                 } else {
193  
-                    %c{$f} = $t;
  268
+                    @to = '' xx @from;
  269
+                }
  270
+                for @from Z @to -> $f, $t {
  271
+                    $ltm.add_substitution($f, $t);
194 272
                 }
195 273
             }
196 274
         }
197 275
 
198  
-        my $i = 0;
199 276
         my $r = "";
200  
-        my %h = %c.keys Z=> map { self.index($_) // Inf }, %c.keys;
201  
-        while ($_ = %h.pairs.sort({-.chars}).min: *.value).value < Inf {
202  
-            %h{.key} = self.index(.key, .value + 1) // Inf;
203  
-            next if .value < $i;
204  
-            $r ~= self.substr($i, .value - $i) ~ %c{.key};
205  
-            $i = .value + .key.chars;
  277
+        while $ltm.next_substitution {
  278
+            $r ~= $ltm.unsubstituted_text ~ $ltm.substituted_text;
206 279
         }
207  
-        $r ~= self.substr($i);
  280
+        $r ~= $ltm.unsubstituted_text;
208 281
 
209 282
         return $r;
210 283
     }
211 284
 
212  
-
213 285
     # S32/Str says that this should always return a StrPos object
214 286
     our Int multi method index($substring, $pos = 0) is export {
215 287
         if ($substring.chars == 0) {

0 notes on commit 9fe5972

Please sign in to comment.
Something went wrong with that request. Please try again.