[SPOILER] Perl 'Hard' Quiz of the Week #2005-03-22

I don't know whether Pr. Fish intended his state labels (i.e., their
ret values) to be a hint, but they suggested each state encoding the
remainder of the input so far divided by $N.  That worked!  At first,
I was computing the transition function with a depth-first search,
so to improve performance, I went back and changed the code to use
breadth-first search.

Then I went back and read the spec and saw that the input arrived
LSB-first.  I tried the same approach on paper but got stuck when
I realized all powers of two would land in the same state, for
instance.  I even tried to think of a way to use the pumping lemma
to show that the reversed language isn't regular.

Somehow I noticed that reversing the directions of the transitions
seemed to accept the reversed language but lost the property of
tracking remainders.

Testing seems to show this to be a valid approach, and I wish I knew
why.  I need to look through the Linz book to see if this is a property
of regular languages.

For kicks, I wrote a class, in ModMachine.pm below, that converts the
transition function to a regular expression.  It's really fast for
small $N but starts to bog down when $N reaches thirty or forty.

Fun quiz!  (Then again, I'm a graph theory nerd.)

Enjoy,
Greg

-- gidfsm ------------------------------------------------------------

#! /usr/local/bin/perl

use warnings;
use strict;

sub draw_transitions;

sub gen_is_divisible_fsm {
    my $N = shift;

    die "\$N ($N) is even" unless $N & 1;

    my $delta = [ map { ret => $_, next_states => [] }, 0 .. $N-1 ];

    draw_transitions $delta;

    (0, $delta);
}

# Beginning with the start state, perform a breadth-first search to
# discover the state transitions.  For a state q, path p such that
# delta*(p) = q, and input bit b, the next state is (2*p+b) % $N.
#
# The input is in reverse, so we reverse the directions of the
# transitions.  I wish I knew why it works.
sub draw_transitions {
    my($delta) = @_;

    my @agenda = [ 0, 0 ];

    while (@agenda) {
        my($q,$p) = @{ shift @agenda };

        foreach my $b (0, 1) {
            my $next = (2*$p + $b) % @$delta;

            my $table = $delta->[$next]{next_states};

            unless (defined $table->[$b]) {
                $table->[$b] = $q;

                push @agenda => [ $next, $next ];
            }
        }
    }
}

sub feed {
    my($input,$q,$delta) = @_;

    $q = $delta->[$q]{next_states}[$_]
        for split //, reverse sprintf "%b", $input;

    $delta->[$q]{ret};
}

## main
my $N    = shift || 5;
my $upto = shift || 10_000;

my($q,$delta) = gen_is_divisible_fsm($N);

my $pass = 1;
foreach my $input (0 .. $upto) {
    my $accept = feed($input => $q, $delta) == 0;
    my $mod    = $input % $N;

    if ($accept && $mod) {
        print "$input: should not have accepted\n";
        $pass = 0;
    }
    elsif (!$accept && !$mod) {
        print "$input: should have accepted\n";
        $pass = 0;
    }
}

print $pass ? "PASS" : "FAIL", "\n";

-- ModMachine.pm -----------------------------------------------------

package ModMachine;

use warnings;
use strict;

sub new {
    my($class,$delta) = @_;

    my $self = {};
    bless $self => $class;

    $self->_init($delta);

    $self;
}

sub _init {
    my($self,$dorig) = @_;

    my $delta;
    foreach my $state (@$dorig) {
        my $copy = { %{ $state } };

        my $next = delete $copy->{next_states};

        foreach my $b (0, 1) {
            # this transition has label "$b"
            $copy->{label}{ $dorig->[ $next->[$b] ]{ret} } = $b;
        }

        push @$delta => $copy;
    }

    foreach my $state (@$delta) {
        $self->addstate($state);
    }
}

sub addstate {
    my($self,$state) = @_;

    $self->{state}{ $state->{ret} }{label} = $state->{label};
}

sub state {
    my($self,$label) = @_;

    $self->{state}{$label};
}

sub _rmstate {
    my($self,$label) = @_;

    delete $self->{state}{$label};
}

sub outbound {
    my($self,$label) = @_;

    return unless exists $self->{state}{$label};

    my $l = $self->{state}{$label}{label};

    my @out;
    foreach my $dst (keys %$l) {
        push @out => {
            to    => $dst,
            label => $l->{$dst},
        };
    }

    @out;
}

sub inbound {
    my($self,$label) = @_;

    my $state = $self->{state};

    my @in;
    foreach my $t (keys %$state) {
        next unless exists $state->{$t} &&
                    defined(my $l = $state->{$t}{label}{$label});

        push @in => { from => $t, label => $l };
    }

    @in;
}

sub _rmedge {
    my($self,$edge,$to) = @_;

    delete $self->{state}{ $edge->{from} }{label}{$to};
}

sub _addedge {
    my($self,$in,$out,$reflex) = @_;

    my $slot = \$self->{state}{$in->{from}}{label}{$out->{to}};

    $$slot .= "|" if defined $$slot;

    my($inlabel,$outlabel) = map /\|/ ? "($_)" : $_,
                             map $_->{label}, $in, $out;

    $$slot .= $inlabel . $reflex . $outlabel;
}

sub _eliminate {
    my($self,$label) = @_;

    my @in  = $self->inbound($label);
    my @out = $self->outbound($label);

    my @reflex = grep $_->{from} == $label, @in;
    my $reflex = @reflex
        ? "(" . join("|", map $_->{label}, @reflex) . ")*"
        : "";

    foreach my $in (@in) {
        next if $in->{from} eq $label;

        $self->_rmedge($in, $label);

        foreach my $out (@out) {
            next if $out->{to} eq $label;

            $self->_addedge($in, $out, $reflex);
        }
    }

    $self->_rmstate($label);
}

sub regex {
    my($self) = @_;

    $self->_eliminate($_) for grep $_ ne "0", keys %{ $self->{state} };

    (my $pat = $self->{state}{0}{label}{0}) =~ s/\(/(?:/g;
    qr/^(?:$pat)+$/;
}

1;