RabbitFarm

Part 1

You are given 2 strings, $A and $B. Write a script to find out common base strings in $A and $B.

Solution

use strict;
use warnings;
##
# You are given 2 strings, $A and $B.
# Write a script to find out common base strings in $A and $B.
## 
use boolean;

sub contains{
    my($s0) = @_;
    return sub{
        my($s) = @_;
        return [true, $s0] if($s =~ m/^($s0)+$/g);
        return [false, $s0];
    }
}

sub make_checks{
    my($s) = @_;
    my @letters = split(//, $s);
    my @checks;
    for my $i (0 .. (int(@letters/2 - 1))){
        push @checks, contains(join("", @letters[0 .. $i]));
    }
    return @checks;
}

MAIN:{
    my($A, $B);
    #$A = "aaaaaaa";
    #$B = "aaaaaaaaaaaaaaaaaa";
    $A = "abcdabcd";
    $B = "abcdabcdabcdabcd";
    my @checks = make_checks($A);
    for my $check (@checks){
        if($check->($A)->[0] && $check->($B)->[0]){
            print $check->($A)->[1] . "\n";
            exit;
        }
    }
}

Sample Run

$ perl perl/ch-1.pl
abcdabcd, abcdabcdabcdabcd --> (abcd abcdabcd)
aaa, aa --> (a)

Notes

I used a similar technique to what I used in Challenge 003 and Challenge 004 where I create an array of anonymous functions which each check different substrings. The functions are created using what is called currying whereby we pass in a parameter (or multiple parameters if we needed to!) to a function which creates a closure around those parameters and returns a new function. This is, I admit, not all that necessary! I repeat the method though out of a sense of nostalgia. We are now on Challenge 081!

Part 2

You are given file named input. Write a script to find the frequency of all the words. It should print the result as first column of each line should be the frequency of the word followed by all the words of that frequency arranged in lexicographical order. Also sort the words in the ascending order of frequency.

use strict;
use warnings;
##
# You are given file named input.
# Write a script to find the frequency of all the words.
# It should print the result as first column of each line should be the frequency of the 
# word followed by all the words of that frequency arranged in lexicographical order. Also 
# sort the words in the ascending order of frequency.
##
MAIN:{
    my %counts;
    my %count_words;
    my $s;
    {    local $/;
         $s = ;
    }
    $s =~ s/'s//g;
    $s =~ tr/."(),//d;
    $s =~ tr/-/ /;
    my @words = split(/\s+/, $s);
    for my $word (@words){
        $counts{$word}++;
    }
    for my $k (keys %counts){
        my $count = $counts{$k};
        push @{$count_words{$count}}, $k;
    }
    for my $k (sort keys %count_words){
        print $k . "\t" . join(" ",  sort {$a cmp $b} @{$count_words{$k}}) . "\n";
    }
}


__DATA__ 
West Side Story

The award-winning adaptation of the classic romantic tragedy "Romeo and
Juliet". The feuding families become two warring New York City gangs,
the white Jets led by Riff and the Latino Sharks, led by Bernardo. Their
hatred escalates to a point where neither can coexist with any form of
understanding. But when Riff's best friend (and former Jet) Tony and
Bernardo's younger sister Maria meet at a dance, no one can do anything
to stop their love. Maria and Tony begin meeting in secret, planning to
run away. Then the Sharks and Jets plan a rumble under the
highway--whoever wins gains control of the streets. Maria sends Tony to
stop it, hoping it can end the violence. It goes terribly wrong, and
before the lovers know what's happened, tragedy strikes and doesn't stop
until the climactic and heartbreaking ending.

Sample Run

$ perl perl/ch-2.pl
1   But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award away become before begin best classic climactic coexist control dance do doesn't end ending escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white whoever winning wins with wrong younger
2   Bernardo Jets Riff Sharks The by it led tragedy
3   Maria Tony a can of stop
4   to
9   and the

Notes

I have to admit that sometimes, even after many years of using Perl, that if I don’t use a certain feature often enough that I end up getting a little surprised. The surprise here is that Perl is clever enough to know that if I am trying a push onto a hash value which is undef, such as when I first do a push @{$count_words{$count}}, $k; for a new value of $k, that a new array is created. No need to check for undef and create a new one manually. This is called autovivification and while a very common thing in Perl for whatever reason it managed to catch me a little by surprise this time around. Probably due to my working a lot in other languages recently that don;t have this feature! Gabor has a nice writeup on autovivification for anyone interested in reading more.