re-implementation of Str.samecase

samecase-bm

use SameCase;
use Benchmark;

my $s = "x" x 1000;
my $p1 = "Aa" x 50;
my $p2 = "Aa" x 500;
my $s-big = "x" x 10000;

my %r = timethese( 10000, {
    'samecase-strcat-p1'       => sub { my $x = $s.samecase-strcat($p1); },
    'samecase-strcat-p2'       => sub { my $x = $s.samecase-strcat($p2); },
    'samecase-array-p1'        => sub { my $x = $s.samecase-array($p1); },
    'samecase-array-p2'        => sub { my $x = $s.samecase-array($p2); },
    'samecase-strcat-big-p1'   => sub { my $x = $s-big.samecase-strcat($p1); },
    'samecase-strcat-big-p2'   => sub { my $x = $s-big.samecase-strcat($p2); },
    'samecase-array-big-p1'    => sub { my $x = $s-big.samecase-array($p1); },
    'samecase-array-big-p2'    => sub { my $x = $s-big.samecase-array($p2); },
});

say sprintf("%-25s: %s", "TEST NAME", "AVERAGE EXECUTION TIME");
for %r.kv -> $k, $v { say sprintf("%-25s: %.5f", $k,$v[3]); }

# Takes too long
my %r2 = timethese( 10, {
    'samecase-p1'              => sub { my $x = $s.samecase($p1); },
    'samecase-p2'              => sub { my $x = $s.samecase($p2); },
    'samecase-big-p1'          => sub { my $x = $s-big.samecase($p1); },
    'samecase-big-p2'          => sub { my $x = $s-big.samecase($p2); },
});

for %r2.kv -> $k, $v { say sprintf("%-25s: %.5f", $k,$v[3]); }

samecase-test

#!/usr/bin/env perl6

use SameCase;
use Test;

plan 6;

my $str = "x" x 10 ~ 'Z' x 10;
my $long-str = "x" x 10 ~ 'Z' x 10 ~ 'q' x 10;
my $pat = "AA  bbDDqq" x 2;
my $long-pat = "AA  bbDDqq" x 2 ~ 'qQQqq' x 2;

my $original =  $str.samecase($pat);
is $original, $str.samecase-strcat($pat), 'String concat is same as original';
is $original, $str.samecase-array($pat), 'Array is same as original';

my $original-long-str = $long-str.samecase($pat);
is $original-long-str, $long-str.samecase-strcat($pat), 'Longer string; String concat is same as original';
is $original-long-str, $long-str.samecase-array($pat), 'Longer string; Array is same as original';

my $original-long-pat =  $str.samecase($long-pat);
is $original-long-pat, $str.samecase-strcat($long-pat), 'Longer pattern; String concat is same as original';
is $original-long-pat, $str.samecase-array($long-pat), 'Longer pattern; Array is same as original';

SameCase.pm

use MONKEY_TYPING;

augment class Str {
    method samecase-strcat(Str:D: Str $pattern) {
        my str $str = nqp::unbox_s(self);
        my str $pat = nqp::unbox_s($pattern);
        my int $n = min(nqp::chars($str), nqp::chars($pattern));
        my int $i = 0;
        my int $j = 0;
        my str $ret = '';
        while $i < $n {

            $j = $j + 1 while !(nqp::iscclass(nqp::const::CCLASS_LOWERCASE, $pat, $j) ||
                                nqp::iscclass(nqp::const::CCLASS_UPPERCASE, $pat, $j) );
            $ret = $ret ~ nqp::substr($str,$i,$j - $i) if $i != $j;
            $i = $j;

            $j = $j + 1 while nqp::iscclass(nqp::const::CCLASS_LOWERCASE, $pat, $j);
            $ret = $ret ~ nqp::lc(nqp::substr($str,$i,$j - $i)) if $i != $j;
            $i = $j;

            $j = $j + 1 while nqp::iscclass(nqp::const::CCLASS_UPPERCASE, $pat, $j);
            $ret = $ret ~ nqp::uc(nqp::substr($str,$i,$j - $i)) if $i != $j;
            $i = $j;
        }
        $ret = $ret ~ nqp::substr($str,$i);
        $ret;
    }

    method samecase-array(Str:D: Str $pattern) {
        my str $str = nqp::unbox_s(self);
        my str $pat = nqp::unbox_s($pattern);
        my int $min = min(nqp::chars($str),nqp::chars($pattern));
        my int $i = 0;
        my int $j = 0;
        my int $case = 0;
        my int $last-case;
        my Mu $ret := nqp::list_s();
        while $i < $min {
            repeat {
                $last-case = $case;
                $case = nqp::iscclass(nqp::const::CCLASS_LOWERCASE, $pat, $j) +
                        nqp::iscclass(nqp::const::CCLASS_UPPERCASE, $pat, $j) * 2;
                last if $case != $last-case;
                $j = $j + 1;
            } while $j < $min;
            my $substr = nqp::substr($str, $i, $j - $i);
            my $rep = $last-case == 1 ?? nqp::lc($substr) !!
                      $last-case == 2 ?? nqp::uc($substr) !! $substr;
            nqp::push_s($ret, $rep);
            $i = $j
        }
        my $substr = nqp::substr($str,$i);
        my $rep = $case == 1 ?? nqp::lc($substr) !!
                  $case == 2 ?? nqp::uc($substr) !! $substr;
        nqp::push_s($ret, $rep);
        nqp::join("",$ret);
    }

}

timings

TEST NAME                : AVERAGE EXECUTION TIME
samecase-strcat-p1       : 0.00070
samecase-strcat-p2       : 0.00380
samecase-array-p1        : 0.00060
samecase-array-p2        : 0.00250
samecase-strcat-big-p1   : 0.00080
samecase-strcat-big-p2   : 0.00390
samecase-array-big-p1    : 0.00070
samecase-array-big-p2    : 0.00260
samecase-p1              : 0.60000
samecase-p2              : 0.90000
samecase-big-p1          : 5.40000
samecase-big-p2          : 5.70000