RabbitFarm
2021-06-13
Evolving a Sequence with a Functional Genome: The Weekly Challenge 116
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
posted at: 21:17 by: Adam Russell | path: /perl | permanent link to this entry