gistfile1.txt

use v6;

use Test;

use MONKEY_TYPING;

augment class Cool {
    
    # could build this up as a regex, use progressive matching
    # and a default Callable that grabs the mapped value and uses
    # the replacement
    multi method trans2(*@pairs, :d($delete), :s($squash), :c($complement)) {
        my %map;
        my @alternates;
        for @pairs -> $p {
            for $p.kv -> $match, $replace {
                my @matches;
                my @repl;
                given $replace {
                    when any(Seq, Iterable, Callable) {
                        # these are mapped as is, no range interpolation
                        @repl = $_;
                    }
                    when Str {
                        # TODO: simple strings can have ranges interpolated
                        # this is implemented directly in STD.pm, so we should probably fall back to that...
                        if (/\.\./) {
                            warn('Range interpolation of Str for transliteration NYI');
                        } 
                        @repl = $_.split('');
                    }
                    default {
                        die "Use of " ~ $_.WHAT ~ " not supported for transliteration replacement list"
                    }
                }
                given $match {
                    when any(Seq, Iterable, Regex) {
                        # these are mapped as is, no range interpolation
                        @matches = $_;
                    }
                    when Str {
                        # TODO: simple strings can have ranges interpolated
                        # this is implemented directly in STD.pm, so we should probably fall back to that...
                        if (/\.\./) {
                            warn('Range interpolation of Str for transliteration NYI');
                        } 
                        @matches = $_.split('');
                    }
                    default {
                        die "Use of " ~ $_.WHAT ~ " not supported for transliteration matching list"
                    }
                }
                my $last_repl;
                @alternates.push(@matches);
                for @matches -> $m {
                    my $r = @repl.shift;
                    $r //= $delete ?? '' !! $last_repl || ~$m;
                    %map{$m} = $r;
                    $last_repl = $r;
                }
            }
        }
        my @matches = self.match(/ <@alternates> /, :g);
        return self unless @matches || (@matches == 1 && !@matches[0].defined);
        my $result = '';
        my $prev_repl;
        for 0 .. @matches.end -> $i {
            my $m = @matches[$i];
            
            my $repl = %map{$m} ~~ Callable ?? %map{$m}($m) !! %map{$m};

            my $prev = $i == 0 ?? Mu !! @matches[$i - 1];
            my $prior = $prev.defined ?? self.substr($prev.to, $m.from - $prev.to) !! self.substr(0, $m.from);

            $result ~= $prior;
            # this may change dep. on how :s is defined
            $prev_repl = '' if ($prior.chars);
            # should use the name of the match here, not the match itself
            # otherwise regexes won't work
            
            if (!$squash) {
                $result ~= $repl;
            } else {
                $result ~= $repl unless $repl eq $prev_repl;
            }
            $prev_repl = $repl;
        }
        my $fence_post = @matches.pop;
        $result ~= self.substr($fence_post.to);
        $result;
    }
}

plan 51;

is("ABC".trans2( ('A'=>'a'), ('B'=>'b'), ('C'=>'c') ),
    "abc",
    "Each side can be individual characters");

is("XYZ".trans2( ('XYZ' => 'xyz') ),
    "xyz",
    "The two sides of the any pair can be strings interpreted as tr/// would multichar");

#is("ABC".trans2( ('A..C' => 'a..c') ),
#    "abc",
#    "The two sides of the any pair can be strings interpreted as tr/// would range");

is("ABCXYZ".trans2( (['A'..'C'] => ['a'..'c']), (<X Y Z> => <x y z>) ),
    "abcxyz",
    "The two sides of each pair may also be array references" );

#is("&nbsp;&lt;&gt;&amp;".trans2( (['&nbsp;', '&lt;', '&gt;', '&amp;'] =>
#    [' ',      '<',    '>',    '&'     ])),
#    " <>&","The array version can map one characters to one-or-more characters");
# 
#is(" <>&".trans2( ([' ',      '<',    '>',    '&'    ] => 
#                  ['&nbsp;', '&lt;', '&gt;', '&amp;' ])),
#                  "&nbsp;&lt;&gt;&amp;",
#    "The array version can map one-or-more characters to one-or-more characters");
#    
#is("&nbsp;&lt;&gt;&amp;".trans2( (['&nbsp;', '&nbsp;&lt;', '&lt;', '&gt;', '&amp;'] =>
#                                 [' ',      'AB',         '<',    '>',    '&'    ])),
#                                "AB>&",
#    "The array version can map one characters to one-or-more characters, using leftmost longest match");
    
is("Whfg nabgure Crey unpxre".trans2('a'..'z' => ['n'..'z','a'..'m'], 'A'..'Z' => ['N'..'Z','A'..'M']),
    "Just another Perl hacker",
    "Ranges can be grouped");

is('bookkeeper'.trans2(:d, 'ok' => ''), 'beeper',
    ':d flag (delete)');

is('bookkeeper'.trans2(:s, 'oke' => 'oke'), 'bokeper',
    ':s flag (squash)');
    
is('Good&Plenty'.trans2(:d, 'len' => 'x'), 'Good&Pxty','deletion');

is('Good&Plenty'.trans2(:s, 'len' => 'x'), 'Good&Pxty',
    'squashing depends on replacement repeat, not searchlist repeat');

is('Good&Plenty'.trans2(:s, 'len' => 't'), 'Good&Ptty',
    'squashing depends on replacement repeat, not searchlist repeat');

is('Good&Plenty'.trans2('len' => 'x'), 'Good&Pxxxty',
    'no flags');

my $x = 0;

is 'aXbXcXd'.trans2('X' => { ++$x }), 'a1b2c3d', 'Can use a closure on the RHS';
is $x, 3,                                       'Closure executed three times';

$x = 0;
my $y = 0;
my $s = 'aXbYcYdX';
my %matcher = (
    X   => { ++$x },
    Y   => { ++$y },
);

is $s.trans2(%matcher.pairs.sort),        'a1b1c2d2', 'Can use two closures in trans';
is $s,                              'aXbYcYdX', 'Source string unchanged';

is $s.trans2([<X Y>] => [{++$x},{++$y}]), 'a3b3c4d4', 'can use closures in pairs of arrays';
is $s,                              'aXbYcYdX', 'Source string unchanged';

$x = 0;
$y = 0;

my $s2 = 'ABC111DEF111GHI';

is $s2.trans2([<1 111>] => [{++$x},{++$y}]), 'ABC1DEF2GHI', 'can use closures in pairs of arrays';
is $s2,                              'ABC111DEF111GHI', 'Source string unchanged';
is $x, 0,                            'Closure not invoked (only longest match used)';
is $y, 2,                            'Closure invoked twice (once per replacement)';