RabbitFarm

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

Part 1

Write a script to generate the first 19 Disarium Numbers.

Solution

use strict;
use warnings;
use POSIX;

sub disarium_n{
    my($n) = @_;
    my @disariums;
    map{
        return @disariums if @disariums == $n;
        my @digits = split(//, $_);
        my $digit_sum = 0;
        map{
            $digit_sum += $digits[$_] ** ($_ + 1);
        } 0 .. @digits - 1;
        push @disariums, $digit_sum if $digit_sum == $_;
    } 0 .. INT_MAX / 100;
}

MAIN:{
    print join(", ", disarium_n(19)) . "\n";
}

Sample Run

$ perl perl/ch-1.pl
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 89, 135, 175, 518, 598, 1306, 1676, 2427, 2646798

Notes

I gave myself a writing prompt for this exercise: only use map. This turned out to present a small issue and that is, how do we terminate out of a map early? This comes up because we do not need to examine all numbers in the large range of 0 .. INT_MAX / 100. Once we find the 19 numbers we require we should just stop looking. last will not work from within a map it turns out. In this case a return works well. But suppose we did not want to return out of the subroutine entirely? Well, I have tested it out and it turns out that goto will work fine from within a map block as well!

That code would look something like this, where the CONTINUE block would have some more code for doing whatever else was left to do.

sub disarium_n{
    my($n) = @_;
    my @disariums;
    map{
        goto CONTINUE if @disariums == $n;
        my @digits = split(//, $_);
        my $digit_sum = 0;
        map{
            $digit_sum += $digits[$_] ** ($_ + 1);
        } 0 .. @digits - 1;
        push @disariums, $digit_sum if $digit_sum == $_;
    } 0 .. INT_MAX / 100;
    CONTINUE:{
        ##
        # more to do before we return
        ##
    }
    return @disariums;
}

Part 2

You are given a list of integers with no duplicates, e.g. [0, 1, 2]. Write two functions, permutation2rank() which will take the list and determine its rank (starting at 0) in the set of possible permutations arranged in lexicographic order, and rank2permutation() which will take the list and a rank number and produce just that permutation.

Solution

use strict;
use warnings;
package PermutationRanking{
    use Mars::Class;
    use List::Permutor;

    attr q/list/;
    attr q/permutations/;
    attr q/permutations_sorted/;
    attr q/permutations_ranked/;

    sub BUILD{
        my $self = shift;
        my @permutations;
        my %permutations_ranked;
        my $permutor = new List::Permutor(@{$self->list()});
        while(my @set = $permutor->next()) {
            push @permutations, join(":", @set);
        }
        my @permutations_sorted = sort @permutations;
        my $rank = 0;
        for my $p (@permutations_sorted){
            $permutations_ranked{$p} = $rank;
            $rank++;
        }
        @permutations_sorted = map {[split(/:/, $_)]} @permutations_sorted;
        $self->permutations_sorted(\@permutations_sorted);
        $self->permutations_ranked(\%permutations_ranked);
    }

    sub permutation2rank{
        my($self, $list) = @_;
        return $self->permutations_ranked()->{join(":", @{$list})};
    }

    sub rank2permutation{
        my($self, $n) = @_;
        return "[" . join(", ", @{$self->permutations_sorted()->[$n]}) . "]";
    }
}

package main{
    my $ranker = new PermutationRanking(list => [0, 1, 2]);
    print "[1, 0, 2] has rank " . $ranker->permutation2rank([1, 0, 2]) . "\n";
    print "[" . join(", ", @{$ranker->list()}) . "]"  . " has permutation at rank 1 --> " . $ranker->rank2permutation(1) . "\n";
}

Sample Run

$ perl perl/ch-2.pl
[1, 0, 2] has rank 2
[0, 1, 2] has permutation at rank 1 --> [0, 2, 1]

Notes

I've been enjoying trying out Al Newkirk's Mars OOP framework. When it comes to Object Oriented code in Perl I've usually just gone with the default syntax or Class::Struct. I am far from a curmudgeon when it comes to OOP though, as I have a lot of experience using Java and C++. What I like about Mars is that it reminds me of the best parts of Class::Struct as well as the best parts of how Java does OOP. The code above, by its nature does not require all the features of Mars as here we don't need much in the way of Roles or Interfaces.

Perhaps guided by my desire to try out Mars more I have taken a definitively OOP approach to this problem. From the problem statement the intent may have been to have two independent functions. This code has two methods which depend on the constructor (defined within sub BUILD) to have populated the internal class variables needed.

There is a small trick here that the sorting is to be by lexicograohic order, which conveniently is the default for Perl's default sort. That doesn't really buy us any algorithmic improvement in performance, in fact it hurts it! Other approaches exist for this problem which avoid producing all permutations of the list.

References

Disarium Numbers

Mars

Challenge 174

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

Part 1

Write a script to generate the first 19 Disarium Numbers.

Solution

disariums(_) --> [].
disariums(Seen) --> [X], {disarium(X), \+ member(X, Seen)}, disariums([X|Seen]).

sum_power(Digits, Sum):-
    sum_power(Digits, 0, 0, Sum).
sum_power([], _, Sum, Sum).
sum_power([H|T], I, PartialSum, Sum):-   
    succ(I, N),
    number_chars(X, [H]),
    Partial is PartialSum + round(X ** N),
    sum_power(T, N, Partial, Sum).

disarium(X):-
    current_prolog_flag(max_integer, MAX_INTEGER),
    between(0, MAX_INTEGER, X),
    number_chars(X, Chars),
    sum_power(Chars, Sum),
    Sum == X.

n_disariums(N, Disariums):-
    length(Disariums, N), 
    phrase(disariums([]), Disariums). 

Sample Run

$ gprolog --consult-file prolog/ch-1.p 
| ?- n_disariums(19, Diariums).

Diariums = [0,1,2,3,4,5,6,7,8,9,89,135,175,518,598,1306,1676,2427,2646798] ? 

References

Challenge 174

Disarium Numbers