use Perl

I'm checking in what I've got of my trig tests / code update, which so far only tackles sin and cos. I thought it would be a good idea to get other people's eyes on it now, before I replicated the changes for all of the other trig functions. I'm up at my in-laws' cabin, had to drive into town to reach the Internet, so this seemed like the best way to pose my questions to the Perl 6 world.

1) Passing non-default $base value does not work for Num.sin / Num.cos or Complex.sin / Complex.cos. As far as I can tell the code is fine, and Num.sin("degrees") seems to work fine using p6eval, but the tests fail for me in trig.t. I thought it was some weird interaction with the fact sin is declared as an operator, but Rat.sin("degrees") works just fine in the tests. I'm stumped on this, if anyone else can offer some insight I'm all ears.

2) Equally weirdly, I've got working implementations of sin(Complex) and sin(Complex, $base). But they only work if defined trig.t, moving them to Complex.pm made those tests fail. Do they need "is export" added or something like that? What is "is export" for, anyway?

3) In general, I'd love it if a few people could look over the new tests for sine (cosine duplicates them). I'm not 100% comfortable with how repetitive they are. You could obviously change my little AngleAndResult to have a method which allows you to select the base and the numeric type to return, but I don't know how to make that cleanly work with the very much needed SKIP directives. (BTW, these changes I've made add over 1000 tests in trig.t, and they are only the tip of the iceberg.)

If you could e-mail comments to my user name here at gmail.com, that's probably the best way to reliably get my attention while I am away from the Internet this weekend. Any comments / suggestions would be deeply appreciated. In the meantime I'll play around with replacing "degrees", etc with a proper enum, as per the spec.

Loved PerlJam's Euler #52 post, but instantly wanted to try to optimize it. I think this version is about five times faster than his (not sure because I'm too lazy to run his full program on my system) while being more careful about what it checks.

use v6;

my $pass_start = 5;     # start at the first number divisible by three after this one
my $pass_end = 17;      # skip ahead when we get here
my $n;
loop ($n = 6; ; $n += 3)
{
    if $n > $pass_end
    {
        $pass_start *= 10;
        $pass_end *= 10;
        $n = $pass_start;
        $n -= $n % 3;
        next;
    }

    my $digits = (2*$n).comb.sort;
    next unless ($digits ~~ /0|5/);
    # say "$n ==> $digits";

    last if
        $digits eq (3*$n).comb.sort &&
        $digits eq (4*$n).comb.sort &&
        $digits eq (5*$n).comb.sort &&
        $digits eq (6*$n).comb.sort;
}
say $n;

New version handles my standard "trimmed_surface" becomes "TrimmedSurface" convention, and has a rather more elegant main loop.

#!/Users/colomon/tools/rakudo/perl6
my $search_word = @*ARGS.shift;
my $replacement = @*ARGS.shift;

sub UpperCaseEachWord($word)
{
    my @words = $word.split('_');
    my @uppered = map {$_.lc.ucfirst}, @words;
    return @uppered.join('');
}

my %substitutions;
%substitutions{$search_word.lc} = $replacement.lc;
%substitutions{$search_word.uc} = $replacement.uc;
%substitutions{UpperCaseEachWord($search_word)} = UpperCaseEachWord($replacement);

# for %substitutions.pairs -> $x
# {
#     say "{$x.key}, {$x.value}";
# }

for =$*IN -> $text is rw
{
    for %substitutions.pairs -> $sub
    {
        $text .= subst($sub.key, $sub.value, :g);
    }
    say $text;
}

I wanted to extend TextMate to do a case-aware search-and-replace. I decided to try it in Perl 6 because I wanted to use the :samecase modifier. Unfortunately, I was not able to get :samecase to work, but a simple modification made the script equally useful for me. I know this is mind-bogglingly simple, but it's now a practical part of my development environment for work.

#!/Users/colomon/tools/parrot-latest/languages/rakudo/perl6
my $search_word = @*ARGS.shift;
my $replacement = @*ARGS.shift;

for =$*IN -> $x
{
    my $y = $x.subst($search_word.lc, $replacement.lc, :g);
    my $z = $y.subst($search_word.uc, $replacement.uc, :g);
    say $z.subst($search_word.lc.ucfirst, $replacement.lc.ucfirst, :g);
}

I'll probably tweak this with some further improvements, including one that :samecase couldn't have handled anyway. But I just wanted to celebrate my first practical Perl 6 script!

The goal is to find the highest product of five consecutive digits in the huge "number". (Obviously made more sense to treat it as a string.) Besides forgetting that string concatenation is now ~ instead of ., there were only minor issues trying to find a version of the loop's body that worked in the compiler. [*] $num.substr($i,5).split('') didn't work, for instance. Probably the code is clearer as it is anyway.

my $num = "73167176531330624919225119674426574742355349194934"
        ~ "96983520312774506326239578318016984801869478851843"
        ~ "85861560789112949495459501737958331952853208805511"
        ~ "12540698747158523863050715693290963295227443043557"
        ~ "66896648950445244523161731856403098711121722383113"
        ~ "62229893423380308135336276614282806444486645238749"
        ~ "30358907296290491560440772390713810515859307960866"
        ~ "70172427121883998797908792274921901699720888093776"
        ~ "65727333001053367881220235421809751254540594752243"
        ~ "52584907711670556013604839586446706324415722155397"
        ~ "53697817977846174064955149290862569321978468622482"
        ~ "83972241375657056057490261407972968652414535100474"
        ~ "82166370484403199890008895243450658541227588666881"
        ~ "16427171479924442928230863465674813919123162824586"
        ~ "17866458359124566529476545682848912883142607690042"
        ~ "24219022671055626321111109370544217506941658960408"
        ~ "07198403850962455444362981230987879927244284909188"
        ~ "84580156166097919133875499200524063689912560717606"
        ~ "05886116467109405077541002256983155200055935729725"
        ~ "71636269561882670428252483600823257530420752963450";

my $max_value = 0;
my $i;
loop($i = 0; $i < $num.chars(); $i++)
{
    my @numbers = $num.substr($i,5).split('');
    my $value = [*] @numbers;
    $max_value = $value if ($value > $max_value);
}
say "$max_value";

Find all the primes to 200. Straightforward sieve implementation. Lacking some elegance, but when I attempted to use :by(2) it didn't work for me.

my @nonprime;

say 2;
for 3..200 -> $x, $y
{
    unless (@nonprime.exists($x))
    {
        say $x;
        my $i;
        loop ($i = $x; $i < 200; $i += 2 * $x)
        {
            @nonprime[$i] = 1;
        }
    }
}

After a couple of weeks' layoff from this project, I got back to work at 4am last night. I never successfully interpolated a variable in a regex like originally wanted to. Luckily, I realized a simple string equality test was all that was needed. After that, everything went very quickly, the only complications being the modified pattern matching syntax. This code doesn't strike me as wildly Perl6ish, but I suspect this is how I might do day-to-day programming in Perl 6 -- sort of a sturdy traditional Perl 5 structure with little dabs of convenient new stuff. This may be the first time I've ever really used grep -- I was never fully comfortable with the Perl 5 syntax for it for some reason -- and it makes me happy. This code isn't brilliant, but I like it.

my $wordfile = "wordlist.txt";

my @words = do
{
    my $words = open($wordfile) // die "Unable to open $wordfile: $!\n";
    =$words;
};

for (@*ARGS) -> $password
{
    say;
    say $password;

    my $score = 13;

    my %dictionary_checks;
    %dictionary_checks{$password.subst(/0/, "o").lc}
                    = "Password is word with ohs changed to zeroes.";
    %dictionary_checks{$password.subst(/1/, "l").lc}
                    = "Password is word with ells changed to ones.";
    %dictionary_checks{$password.lc}
                        = "Password is a word in the dictionary.";
    %dictionary_checks{$password.chop.lc}
                        = "Password minus last character is a word in the dictionary.";
    %dictionary_checks{$password.substr(1).lc}
                        = "Password minus first character is a word in the dictionary.";

    my @hits = grep { %dictionary_checks.exists($^a) }, @words;
    for @hits -> $trouble
    {
        $score--;
        say "{%dictionary_checks{$trouble}}";
    }

    if ($password.elems < 10 || $password.elems > 20)
    {
        $score--;
        say "Password should be 10-20 characters.";
    }

    unless ($password ~~ /\d/)
    {
        $score--;
        say "Password should have a digit in it.";
    }

    unless ($password ~~ /<[A..Z]>/)
    {
        $score--;
        say "Password should have an uppercase letter in it.";
    }

    unless ($password ~~ /<[a..z]>/)
    {
        $score--;
        say "Password should have a lowercase letter in it.";
    }

    unless ($password ~~ /\W/)
    {
        $score--;
        say "Password should have a non-alphanumeric character in it.";
    }

    if ($password ~~ /<[A..Z]>**4/)
    {
        $score--;
        say "Password has four uppercase letters in a row.";
    }

    if ($password ~~ /<[a..z]>**4/)
    {
        $score--;
        say "Password has four lowercase letters in a row.";
    }

    my %letter_freq;
    for $password.split('') -> $x
    {
        %letter_freq{$x}++;
    }
    if (%letter_freq.values.max > 1)
    {
        $score--;
        say "Password has duplicate characters.";
    }

    say "Score: $score";
}

That last test (the %letter_freq one) compiled and worked on the first try, probably my biggest "Perl 6 just works" moment so far. I'm a bit uncomfortable with all the repetition in there. I can imagine making the code more elegant by wrapping up the tests as closures and mapping them to the messages, but it seems like that would make it more obscure. Possibly a well-written function (macro of some sort?) to wrap the notion of test, failure message, and dock points?

Skipping the fourth script, since the proper Perl-y way to do it is just call "cal", and the longer way really wants some sort of CPAN module to do it properly.

With the fifth script, I may have hit a glitch, either in Raduko or in my understanding of Perl 6.

my $wordfile = "wordlist.txt";

my @words = do
{
    my $words = open($wordfile) // die "Unable to open $wordfile: $!\n";
    =$words;
}

for (@*ARGS) -> $password
{
    say $password;
}

fails with

Statement not terminated properly at line 9, near "-> $passwo"

current instr.: 'parrot;PGE;Util;die' pc 129 (runtime/parrot/library/PGE/Util.pir:83)
called from Sub 'parrot;Perl6;Grammar;eat_terminator' pc 28665 (src/gen_grammar.pir:3378)
called from Sub 'parrot;Perl6;Grammar;statementlist' pc 27321 (src/gen_grammar.pir:2845)
called from Sub 'parrot;Perl6;Grammar;statement_block' pc 24757 (src/gen_grammar.pir:1838)
called from Sub 'parrot;Perl6;Grammar;TOP' pc 20647 (src/gen_grammar.pir:207)
called from Sub 'parrot;PCT;HLLCompiler;parse' pc 634 (src/PCT/HLLCompiler.pir:388)
called from Sub 'parrot;PCT;HLLCompiler;compile' pc 428 (src/PCT/HLLCompiler.pir:301)
called from Sub 'parrot;PCT;HLLCompiler;eval' pc 862 (src/PCT/HLLCompiler.pir:500)
called from Sub 'parrot;PCT;HLLCompiler;evalfiles' pc 1217 (src/PCT/HLLCompiler.pir:669)
called from Sub 'parrot;PCT;HLLCompiler;command_line' pc 1398 (src/PCT/HLLCompiler.pir:759)
called from Sub 'parrot;Perl6;Compiler;main' pc 18987 (perl6.pir:162)

Switching it to

my $wordfile = "wordlist.txt";

my @words = do
{
    my $words = open($wordfile) // die "Unable to open $wordfile: $!\n";
    =$words;
};

for (@*ARGS) -> $password
{
    say $password;
}

makes it work perfectly.

Should the semicolon always be there after the do construct? If so, why does it work if you insert a "say;" before the for statement?

After a lot of really helpful suggestions from Aristotle, here is my second version of the third script. This version feels much more satisfyingly Perl6ish to me.

my $votes_file = "votes.txt";

sub EffectiveVote ( Str $vote, Hash %skip ) {
    return $vote.split( ',' ).first( { ! %skip{$_}.defined } )
        // die "No valid vote?!";
}

sub CountRound (Array @votes, Hash %skip)
{
    my %count;
    for @votes -> $vote
    {
        %count{EffectiveVote($vote, %skip)}++;
    }
    return %count;
}

my @votes = do
{
    my $votes = open($votes_file);
    =$votes;
}

my $count = 0;
my %skip;

loop
{
    say "\nRound {++$count}";
    my @ranking = CountRound(@votes, %skip).pairs.sort({.value}).reverse;

    say sprintf("%s: %s", .key, .value / @votes.elems)
        for @ranking;

    my $top_rank = @ranking[0];
    if ($top_rank.value > @votes.elems / 2)
    {
        say "\nThe winner is {$top_rank.key} with {$top_rank.value / @votes.elems * 100.0}% of the vote.";
        exit;
    }

    my $skip = @ranking.pop.key;
    %skip{$skip} = 1;
    say "Dropping $skip";
}

This is the instant runoff election task. I don't feel like I had terrible problems writing it, but I feel like it's a very satisfying piece of code, either.

my $votes_file = "votes.txt";

sub EffectiveVote (Str $vote, Hash %skip)
{
    my @vote = split ',', $vote;
    for @vote -> $choice
    {
        if (! %skip{$choice}.defined)
        {
            return $choice;
        }
    }
    die "No valid vote?!";
}

sub CountRound (Array @votes, Hash %skip)
{
    say "{@votes.elems} votes";

    my %count;
    my $total = 0;
    for @votes -> $vote
    {
        my $choice = EffectiveVote($vote, %skip);
        %count{$choice}++;
        $total++;
    }

    my %percentages;
    for %count.keys -> $choice
    {
        %percentages{$choice} = %count{$choice} / $total;
    }
    return %percentages;
}

my @votes;

my $votes = open($votes_file);
for (=$votes) -> $vote
{
    push @votes, $vote;
}

my $count = 0;
my %skip;
while (1)
{
    say;
    say "Round {++$count}";
    my %percentages = CountRound(@votes, %skip);
    my @ordered = sort { %percentages{$^b} <=> %percentages{$^a} }, %percentages.keys;
    for @ordered -> $vote
    {
        say "$vote: {%percentages{$vote}}";
    }

    if (%percentages{@ordered[0]} > 0.5)
    {
        say;
        say "The winner is {@ordered[0]} with {%percentages{@ordered[0]} * 100.0}% of the vote.";
        exit;
    }

    my $skip = @ordered.pop;
    %skip{$skip} = 1;
    say "Skipping $skip";
}

Two difficulties of note here. First, I initially tried making @votes an array of arrays. I couldn't figure out any obvious way to make this work in Perl 6. Second problem is

perl6(28102) malloc: *** error for object 0x2eb5a10: double free
*** set a breakpoint in malloc_error_break to debug
Segmentation fault

after the script properly finishes.