RabbitFarm

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

You are given a number $N >= 10. Write a script to split the given number such that the difference between two consecutive numbers is always 1, and it shouldn't have a leading 0. Print the given number if it impossible to split the number.

Solution

use strict;
use warnings;
use boolean;
use AI::Genetic;

use constant THRESHOLD => 0;
use constant NUMBERS   => "1234";

sub no_op{
    my($x) = @_;
    return (caller(0))[3] if !defined($x);
    return $x;
}

sub get_1{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 1);
}

sub get_2{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 2);
}

sub get_3{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 3);
}

sub get_4{
    my($s) = @_;
    return (caller(0))[3] if !defined($s);
    return substr($s, 0, 4);
}

sub fitness{
    my($genes) = @_;
    my $s = NUMBERS;
    my $fitness = -1 * (length($s) -1);
    my @operands;
    for my $gene (@{$genes}){
        if(my($i) = $gene->() =~ m/get_([1-4])/){
            push @operands, $gene->($s);
            return -1 * NUMBERS if length($s) < $i;
            $s = substr($s, $i) if length($s) >= $i;
        }
    }
    $s = NUMBERS;
    for(my $i = 0; $i < @operands - 1; $i++){
        if($operands[$i] == ($operands[$i + 1] - 1)){
            $fitness++;
            my $chars = length($operands[$i]);
            $s = substr($s, $chars);
        }
    }
    if($operands[@operands - 1] && $operands[@operands - 2]){
    if($operands[@operands - 1] == ($operands[@operands - 2] + 1)){
        my $chars = length($operands[@operands - 1]);
        $s = substr($s, $chars);
    }
    }
    $fitness *= length($s);
    return $fitness;
}

sub terminate{
    my($aig) = @_;
    my $top_individual = $aig->getFittest();
    if($top_individual->score == THRESHOLD){
        my $genes = $top_individual->genes();
        my $s = NUMBERS;
        my @operands;
        for my $gene (@{$genes}){
            if(my($i) = $gene->() =~ m/get_([1-4])/){
                push @operands, $gene->($s);
                $s = substr($s, $i);
            }
        }
        print join(",", @operands) . "\n";
        return true;
    }
    print NUMBERS . "\n";
    return true;
}

MAIN:{
    my $aig = new AI::Genetic(
        -fitness    => \&fitness,
        -type       => "listvector",
        -population => 50000,
        -crossover  => 0.9,
        -mutation   => 0.1,
        -terminate  => \&terminate,
    );
    my $genes = [];
    for (0 .. 7){
        push @{$genes}, [\&get_1, \&get_2, \&get_3, \&get_4, \&no_op],
    }
    $aig->init(
        $genes
    );
    $aig->evolve("tournamentUniform", 1000);
}

Sample Run

$ perl perl/ch-1.pl
1,2,3,4

Notes

Task #1 is slightly similar to the Only 100, please task from Challenge 044. In that previous task we are given a string of numbers and asked to split the string with only + or - operations to arrive at a value of 100. Here we must similarly split the string of numbers, but the criteria is different. Here we need to assemble the string into numbers that differ only by 1, if possible.

As done in that previous challenge we use a not so brutish, yet forceful, approach using AI::Genetic. In this way our program learns the best way to achieve our goal given a fitness function which allows it to evaluate different splitting patterns and smartly choose the next attempt.

While avoiding evaluating a great many possible combinations, I must admit to a certain brutishness here in that I did not spend much time tuning the parameters used. Also, the get_ functions will not scale very well for very long strings. It would be possible to generate these functions in a loop using a functional programming style currying approach dependent on the length of the input string. Imagine an input of 1 followed by 999 0s, then a 1 followed by 998 0s and final 1. This use of AI::Genetic would certainly work with such an input given proper get_ functions, very many of which would be quickly be lost in the evolutionary dust, so to speak.

The use of function references for the genes is not something I am aware of outside of my own usage. I like to call this a Functional Genome.

Part 2

You are given a number $N >= 10. Write a script to find out if the given number $N is such that sum of squares of all digits is a perfect square. Print 1 if it is otherwise 0.

Solution

use strict;
use warnings;
use POSIX;

sub sum_squares{
    my($n) = @_;
    my @digits = split(//, $n);
    my $sum = 0;
    map { $sum += ($_ ** 2) } @digits;
    return (ceil(sqrt($sum)) == floor(sqrt($sum)));
}

MAIN:{
    my($N);
    $N = 34;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
    $N = 50;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
    $N = 52;
    if(sum_squares($N)){
        print "1\n";
    }
    else{
        print "0\n";
    }
}

Sample Run

$ perl perl/ch-2.pl
1
1
0

Notes

This task is well suited for Perl. We can make quick work of what might be a heavier lift in other languages by split-ting the number into individual digits and then using a map to perform the summing of the squares. The POSIX module provides convenient ceil and floor functions for checking to see if the result is a perfect square.

References

Challenge 116

Challenge 044 | Only 100, please