#!/usr/bin/perl -w
use Time::HiRes;

sub min_chunks {
        my($x, $y) = @_;
        my $start_time = Time::HiRes::time();
        my $lenx = length($x);
        if ($lenx != length($y)) {
                print "LENGTH MISMATCH: '$x' '$y'\n" if $DEBUG > 0;
                return 0;
        }
        if (join("", sort split //, $x) ne join("", sort split //, $y)) {
                print "CHARS DIFFER: '$x' '$y'\n" if $DEBUG > 0;
                return 0;
        }
        if ($x eq $y) {
                print "IDENTICAL INPUT: '$x'\n" if $DEBUG > 0;
                return 1;
        }

        # Outer loop.  Start by trying to divide $x into two chunks
        # and seeing whether the chunks can be rearranged into $y.
        # If not, try again with three chunks, then four, and so on
        # up to length($x) chunks.

        my @chunks = ( );
        my %chunk_appears = ( );
        study($y);
        OUTER: for (my $check = 2; $check < $lenx; ++$check) {
                my @poslist = ( 1 .. $check-1 );
                my $final;

                # Inner loop.  @poslist is our list of breakpoints
                # for the chunks.  If length($x) is 10, and we're
                # on the three-break pass through the outer list,
                # we start by checking whether breaking $x at
                # positions 1, 2 and 3 can be rearranged to form $y,
                # then 1,2,4, then 1,2,5 and so on up to 7,8,9.
                # The helper method _get_chunks splits $x into the
                # strings defined by @poslist;  _can_chunk runs the
                # tedious process of trying to rearrange those
                # strings into $y, and _increment_poslist bumps
                # @poslist from 1,2,4 to 1,2,5.

                INNER: while (1) {
                        @chunks = _get_chunks($x, \@poslist);
                        my $first_missing_chunk = _first_missing_chunk($y, \@chunks);
                        if ($first_missing_chunk) {
                                # At least one chunk appears nowhere in $y.
                                # Knowing this lets us skip testing some
                                # chunks and increment poslist much more
                                # efficiently.
                                _increment_poslist($lenx, \@poslist, $first_missing_chunk);
                                last INNER if !defined($poslist[0]);
                        } else {
                                # Test this list of chunks.
                                last OUTER if _can_chunk($y, \@chunks);
                                # Nope, it didn't work;  keep looking.
                                _increment_poslist($lenx, \@poslist);
                                last INNER if !defined($poslist[0]);
                        } 
                }
                @chunks = ( ); # no solution found yet, keep trying
        }

        if (!@chunks) {
                # We got all the way to the max number of chunks;
                # that means $x and $y have the same number of all
                # their letters but there is no way to chunk one
                # into the other without using each individual
                # letter as a chunk.  No need to do the tedious
                # testing on this one!  We already know the answer.
                @chunks = split //, $x;
        }

        printf("%2d chunks (%7.3f secs) $x $y @chunks\n",
                scalar(@chunks),
                Time::HiRes::time-$start_time)
                if $DEBUG > 0;
        return wantarray ? @chunks : scalar(@chunks);
}


############################################################


# _get_chunks
#
# _get_chunks is relatively simple, just divide $x up into substrings.
# I've chosen perhaps a dumbassed one-based way of numbering the
# breaks between characters, where 1, the first possible break, means
# to break between substr($x,0,1) and substr($x,1,1), i.e. *before*
# the zero-based character number 1.  This means the range of
# possible breaks goes from 1 to length($x)-1.  That made a tiny bit
# more sense to me than making it zero-based and sending it from
# 0 to length($x)-2.

sub _get_chunks {
        my($x, $poslist_ar) = @_;
        my @poslist = (0, @$poslist_ar, length($x));
        my @lenlist = map { $poslist[$_+1] - $poslist[$_] } 0..$#poslist-1;
        my @chunks = ( );
        for my $i (0..$#lenlist) {
                push @chunks, substr($x, $poslist[$i], $lenlist[$i]);
        }
        return @chunks;
}

# _increment_poslist
#
# Walk our way through the poslist, the list of positions at which to
# attempt to break the first word into chunks.  For a word of length 6,
# for example, the list of 4-chunk poslists is, in order:
# 1,2,3    1,2,4    1,2,5    1,3,4    1,3,5    1,4,5
# 2,3,4    2,3,5    2,4,5    3,4,5
# (Since 1 means break just after the first char, and 5 means break
# just after the last char.)  This routine increments from each entry
# to the next by checking for the rightmost number that needs
# incrementing, incrementing it, and then if there are more numbers
# to its right, setting them in numeric order.  Once the "rightmost
# number that needs incrementing" is none of them, i.e. is past the
# left edge, we're done.  This takes advantage of perl's nice feature
# that $foo[-1] is the last entry in @foo, which makes some of the
# math nice and simple.
# Note that once again, Pascal's Triangle plays a role in a QOTW.
# The number of poslists of length k for a word with length n is
# n choose k.
# Trickily, we can pass in a hint about whether we can skip much of
# the incrementing process.  This takes a factor of n out of this
# algorithm's big-O notation for pathological cases, changing a time
# of 265 seconds (for "abcdefghijklmnopqrst" and its reverse) to 2 ms!
# If first_missing_chunk is 0, we assume all the chunks actually
# appear at some point in the target string so we just increment to
# the next list normally.  If > 0, we assume that chunk (numbered
# one-based from the left) does not appear in the target string so we
# can skip changing all chunks to its right.

sub _increment_poslist {
        my($len, $poslist_ar, $first_missing_chunk) = @_;
        my $size = scalar(@$poslist_ar);
        $first_missing_chunk ||= $size+1;
        my $n;
        $n = -$size-1+$first_missing_chunk;
        INNER1: while (--$n >= -$size) {
                last INNER1 if $poslist_ar->[$n] < $len+$n;
        }
        if ($n < -$size) {
                @$poslist_ar = ( undef );
                return;
        }
        my $v = $poslist_ar->[$n] + 1;
        INNER2: while ($n <= -1) {
                $poslist_ar->[$n++] = $v++;
        }
}

sub _first_missing_chunk {
        my($y, $chunks_ar) = @_;
        for my $i (0..$#$chunks_ar) {
                return $i+1 if $y !~ /$chunks_ar->[$i]/;
        }
        return 0;
}

# _can_chunk
#
# Can the text substrings in @chunks be rearranged to form $y?
#
# The easy way to do this would be to feed them into List::Permutor
# or Algorithm::Permute and interate over all possible permutations
# until either we run out or a hit is found.  But we can optimize
# dramatically by doing some unfortunately rather complicated
# tests and then running an algorithm that substantially limits
# the number of possibilities.  This is still the time-consuming
# part of the inner loop.  I've also done it in a way that's
# perhaps needlessly complicated (I didn't try the simpler way,
# hey, maybe Algorithm::Permute is actually faster).
#
# What I do is create the array @try, which has one item for each
# character position in $y.  Each item in @try is an arrayref
# which has one item for each chunk in @$chunks_ar which could
# *possibly* match starting at the given position in $y.  Let's
# do an example.  For $y eq 'abcab', $chunks_ar->[0] eq 'ab',
# and $chunks_ar->[1] eq 'abc'.  The @try array has 5 items, one
# for each letter in 'abcab'.  The first item, corresponding to
# chunks which can match starting at the first letter, will start
# out as an arrayref with both chunks (since both match).  The
# second and third items will be empty, since no chunks match at
# the beginning of 'bcab' or 'cab'.  The fourth item will start
# out with just the first chunk, since 'ab' matches
# substr($y,3,2) but 'abc' does not match substr($y,3,3).  So to
# start with, @try = ( [0,1], [], [], [0], [] ).  Then there is
# an optimization pass which eliminates chunks which do not have
# a length which would allow the formation of a complete string:
# in our example, we have seen that either of the two chunks
# will match substrings at the first position, but now we see
# that only the second chunk 'abc' has a length that will get us
# to another @try entry that has any hope of succeeding.  The
# first chunk 'ab' is too short, it would take us to an empty
# arrayref which must fail.  So we eliminate the second chunk
# from the start of the string, leaving us with the @try array
# ( [1], [], [], [0], [] ).  In this example there is only one
# way to attempt to assemble this into a string:  first chunk 1,
# three chars long, then chunk 0, two chars long (and happily,
# it is successful).

sub _can_chunk {
        my($y, $chunks_ar) = @_;

        # Split up $y into its constituent characters.  For each char
        # position, create an arrayref of chunks which might fit it.
        # The aim is to then iterate from left to right across $y,
        # through all possibilities of chunks which might fit, like
        # stepping stones.

        my $might_succeed = 0;
        my @y = split //, $y;
        my @try = ( );
        for my $i (0..$#y) {
                push @try, [ ];
                for my $chunknum (0..$#$chunks_ar) {
                        if (substr($y, $i, length($chunks_ar->[$chunknum]))
                                eq $chunks_ar->[$chunknum]) {
                                push @{$try[$i]}, $chunknum;
                                $might_succeed = 1;
                        }
                }
        }
        if (!$might_succeed) {
                return 0;
        }

        # OK, there's a chance this chunking can succeed.  First, go
        # through and eliminate chunks which aren't of a length that
        # allows us to land on another stepping stone.  This
        # optimization may vastly increase speed in some pathological
        # cases.

        for my $i (0..$#try) {
                my @new = ( );
                for my $chunknum (@{$try[$i]}) {
                        my $nextchunk = $i+length($chunks_ar->[$chunknum]);
                        next if $nextchunk > scalar(@try);
                        if ($nextchunk == scalar(@try) || @{$try[$nextchunk]}) {
                                push @new, $chunknum;
                        }
                }
                @{$try[$i]} = @new;
        }
        # If that left us without a starting chunk, it can't succeed.
        if (!@{$try[0]}) {
                return 0;
        }

        # This might succeed.  Walk through all possible combinations.
        # Note that @chunklist is a list of indexes into the list of
        # lists @try.  Bear with me;  the first chunk we try is
        # $chunks[ $try[0][$chunklist[0]] ], the second is
        # $chunks[ $try[1][$chunklist[1]] ], and so on through $#try.
        # Since any given index into @$chunks_ar may appear in both
        # @{$try[$foo]} and @{$try[$bar]}, we may get duplicates,
        # which _try_works knows to skip.
        my @chunklist = (0) x scalar(@try);
        TRYCHUNKING: while (1) {
                return 1 if _try_works($y, $chunks_ar, \@try, \@chunklist);
                _increment_chunklist(\@chunklist, \@try);
                last TRYCHUNKING if !defined($chunklist[0]);
        }

        return 0;
}

# _try_works
#
# Given the target string, the list of chunks, the master @try array,
# and a combination of indexes into that array, see if those indexes
# successfully build up the target from the chunks.

sub _try_works {
        my($y, $chunks_ar, $try_ar, $chunklist_ar) = @_;
        my $leny = length($y);
        my $chunkword = "";
        my $i = 0;
        my %used = ( );
        while ($i < $leny) {
                my $chunk_num = $try_ar->[$i][$chunklist_ar->[$i]];
                if (!defined($chunk_num)) {
                        # If there is no stepping stone at this position,
                        # there's no way to continue, so this try can't
                        # work.
                        return 0;
                }
                if (exists $used{$chunk_num}) {
                        # Already used this chunk earlier in the string,
                        # so this try can't work.
                        return 0;
                }
                my $chunk = $chunks_ar->[$chunk_num];
                $chunkword .= $chunk;
                $i += length($chunk);
                $used{$chunk_num} = 1;
        }
        my $success = ($y eq $chunkword) ? 1 : 0;
        return $success;
}

# _increment_chunklist
#
# Given a list of indexes into @try's subarrays, go to the next
# possible list of indexes.  I'm not going to try to explain this
# in English;  this is way too complicated, sorry, just read the
# perl :)

sub _increment_chunklist {
        my($chunklist_ar, $try_ar) = @_;
        # Any given entry in the chunklist maxxes out at the number of
        # entries in the try list.
        my $size = scalar(@$chunklist_ar);
        my $n = 0;
        while (--$n >= -$size) {
                last if $chunklist_ar->[$n] < $#{$try_ar->[$n]};
        }
        if ($n < -$size) {
                @$chunklist_ar = ( undef );
                return;
        }
        ++$chunklist_ar->[$n];
        # Now, if we had to move left at all, the entries to the right
        # all go to 0.
        while (++$n <= -1) {
                $chunklist_ar->[$n] = 0;
        }
}

my $z = min_chunks('xylinid', 'xylidin');
print "$z\n";
