#!/usr/bin/perl -w
#
#  Creates a "morph" of words.
#
#  May 2006 by liverpole
#

##############
### Strict ###
##############
use strict;
use warnings;


#################
### Libraries ###
#################
eval { require Win32::Console::ANSI };
use Data::Dumper;
use File::Basename;


####################
### User-defined ###
####################
my $maxlayer = 6;           # Maximum allowable combined layers
my $maxrow   = 17;          # Maximum number of rows in any layer
my $startsym = 63;          # The starting symbol (represents bitmask zero)
my $countsym = 33;          # The starting symbol (represents a count of 3)
my $joinchar = '>';         # What character used to join lines?
my $regchar  = '=';         # The character to split the regex on
my $trunc    = 70;          # If nonzero, # of chars to truncate image to
my $maxx     = 78;          # Limit of x
my $maxy     = 21;          # Limit of y
my $blank    = " " x 79;    # 1 blank line

my $is_win   = ($^O =~ /win/i);     # Are we running on Windows?
my $cbase    = $is_win? 31: 101;    # The base color value

# The largest encodable 'count' value, used during final compression
# of the merged image layers.
#
my $maxcount = $startsym - $countsym + 1;


#############################################################
### Layers (up to 6 allowed with current symbol mappings) ###
#############################################################
my @layers = (
'

                ######                                    ###
                ######                                    ###
                   ###                                    ###
                   ###       ###   ###        #####     #######
                   ###       ###   ###       #######    #######
                   ###       ###   ###      ###    #      ###
                   ###       ###   ###      ####          ###
                   ###       ###   ###      #######       ###
                   ###       ###   ###       #######      ###
                   ###       ###   ###          ####      ###
                  ####       #########      #    ###      ###
              #######        #########      #######       ######
              ######          #### ###       #####         #####
',
'

         ####                          ###    ###
         ####                          ###    ###
        ######                         ###    ###
        ######    ### ####     ####   ####### ### ####    ######   ###  ##
        ######    #########  ######## ####### #########  ########  #######
       ###  ###   #########  ###  ###  ###    ######### ####  #### #######
       ###  ###   ###   ### ###    ### ###    ###   ### ###    ### ###
       ###  ###   ###   ### ###    ### ###    ###   ### ########## ###
       ########   ###   ### ###    ### ###    ###   ### ########## ###
      ##########  ###   ### ###    ### ###    ###   ### ###        ###
      ###    ###  ###   ###  ###  ###  ###    ###   ### ####     # ###
      ###    ###  ###   ###  ########  ###### ###   ###  ######### ###
     ###      ### ###   ###    ####     ##### ###   ###   #######  ###
',
'

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




',
'

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

',                                                                     
'

 ###                                                            ###
 ###                                                            ###
 ###   ###                                                      ###
 ###   ### ###    ###   ######   ###  ## ########       ####    ###    ######
 ###       ###    ###  ########  ####### ##########   ########  ###   ########
 ###   ### ###    ### ####  #### ####### ###     ###  ###  ###  ###  ####  ####
 ###   ### ###    ### ###    ### ###     ###     ### ###    ### ###  ###    ###
 ###   ### ###    ### ########## ###     ###     ### ###    ### ###  ##########
 ###   ### ###    ### ########## ###     ###     ### ###    ### ###  ##########
 ###   ###  ###  ###  ###        ###     ##########  ###    ### ###  ###
 ###   ###   ######   ####     # ###     #########    ###  ###  ###  ####     #
  ###  ###    ####     ######### ###     ###          ########   ###  #########
   ### ###     ##       #######  ###     ###            ####      ###  #######
                                         ###
       ###############################   ###   ##############################
       ###############################   ###   ##############################
                                         ###
',
'

                                               ######
                  #######               #################
          ######## #######           #####################
         ###################      #########################
                ###########    ###############################
              ############# ####################################
             #####################################################
              ######################################################
               ######################################################
                 ############################################### ####
                    ###########################################   ###
                           ######### ##################  ######  ###
                           ########  #########  ######    ######
                            ######   ########    #####      #####
                            #####    #####       #####       ####
                             ####     #####    #####         ####
                             ####        ########            ###
                            ####          #########         ####
                           ####        ####### ####        ######
                         ######                           #######
',
);


###############
### Globals ###
###############
my $iam   = basename $0;
my $image = "";         # The merge of all image layers


####################
### Command-line ###
####################
my $delay          = shift || 0;
my $entropy_radius = shift || 240;


####################
### Main program ###
####################
my $nlayers = @layers;
($nlayers > $maxlayer) and die "$iam:  max of $maxlayer exceeded!\n";

# Merge the image to a single layer
for (my $mask = 1, my $i = 0; $i < $nlayers; $i++, $mask <<= 1) {
    my $layer = $layers[$i];
    $image = merge($image, $layer, $mask);
}
# show("Image after merge", $image);


# Compress the single layer image
$image = compress($image);
# show("Image after compression", $image);


#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# HALF-WAY
#
# Display the image at this point (with "show('Compressed image', $image)")
# to see what the encoded part of "Morphological Japh" looks like.
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


# Decompress the single layer image
$image = decompress($image);
# show("Image after decompression", $image);


# Morph forever
my $idx = 0;
my @layer = map { peel_golf(1<<$_, $image) } (0 .. $nlayers-1);
my $color = 0;
print "\e[2J\n";
while (1) {
    my $from = $layer[$idx];
    my $to   = $layer[($idx+1)%$nlayers];
    $idx = ($idx + 1) % $nlayers;
    morph($from, $to, $color++);
    $color %= $nlayers;
}


###################
### Subroutines ###
###################

#
#  show():  (debugging routine) displays the current image;
#           waits for user to hit <RETURN>.
#
sub show {
    my ($msg, $pimg) = @_;
    print "=" x 79, "\n";
    print " $msg\n";
    print "=" x 79, "\n";
    print "\e[${cbase}m";
    my $ref = ref $pimg;
    if ($ref eq "") {
        print "$pimg\n";
    } elsif ($ref eq "ARRAY") {
        for (my $i = 0; $i < @$pimg; $i++) {
            my $p = $pimg->[$i];
            $ref = ref $p;
            if ($ref eq "") {
                print "$p\n";
            } else {
                map { print "$_\n" } @$p;
                print "-" x 79, "\n";
            }
        }
    } else {
        die "$iam:  Unknown reference '$ref'\n";
    }
    print "\e[m\e[K";
    <STDIN>;
}


#
#  merge():  merges all layers (up to 6) into a single layer, using
#            a different bitmask for each layer.
#
sub merge {
    my ($image, $layer, $mask) = @_;
    $layer =~ s/^\n//s;
    my @image = split("\n", $image);
    my @layer = split("\n", $layer);
    map { s/\s+$// } @layer;
    my @result;
    while (@image || @layer) {
        my $merge = shift @image || "";
        my $line  = shift @layer || "";
        my @vals = split(//, $merge);
        my @next = split(//, $line);
        my $result = "";
        while (@vals || @next) {
            my $char = shift @vals || chr($startsym);
            my $next = shift @next || " ";
            my $val = ord($char) - $startsym;
            my $new = ($next eq '#')? $mask: 0;
            my $c = chr($startsym + $val + $new);
            $result .= $c;
        }
        push @result, $result;
    }
    my $merge = join("\n", @result);
    return $merge;
}


#
#  peel():  the inverse of merge()
#
sub peel {
    my ($mask, $img) = @_;
    my @lines = split("\n", $img);
    my $text = "\n";
    foreach my $line (@lines) {
        my @chars = split(//, $line);
        foreach my $char (@chars) {
            my $val = ord($char) - $startsym;
            $text .= ($val & $mask)? '@': ' ';
        }
        $text .= "\n";
    }
    return $text;
}


#
#  peel_golf():  a "golfed" version of peel()
#
sub peel_golf {
    no warnings;
    no strict;

    $; = "";
    map {
        $_ .= '?' x (79 - length $_);
        map{
            $; .= $_[0] & (-63+ord$_)? '@':' '
        } split//;
        $;.=$/;
    } split$/, pop;
    $/.$;
}


#
#  compress():  further compress the 'merged' image, by finding multiple
#               occurrences of a character, and replacing them with an
#               encoded version of <count><character>.
#
sub compress {
    my ($image) = @_;
    my @lines = split(/\n/, $image);
    my $count = $maxcount;
    while ($count-- > 2) {
        foreach my $line (@lines) {
            while ($line =~ /((.)\2{$count})/) {
                my $char = $2;
                my $str = $char x ($count + 1);
                my $cnt = chr($countsym + $count - 2);
                $line =~ s/\Q$str\E/$cnt$char/g;
            }
        }
    }
    my $img = join($joinchar, @lines);
    if ($trunc) {
        my $cnt = $trunc - 3;
        $img =~ s/(.{$cnt})(.+)/$1\n$2/;
        $img =~ s/(.{$trunc})/$1\n/g;
    }
    return $img;
}


#
#  decompress():  the inverse of compress()
#
sub decompress {
    my ($img) = @_;
    my $endsym = $startsym + (2 ** $maxlayer) - 1;
    $img =~ s/\n//gs;
    $img =~ s/\Q$joinchar\E/\n/g;

    foreach my $count (3..$maxcount) {
        my $cnt = chr($countsym + $count - 3);
        foreach my $val ($startsym..$endsym) {
            my $sym = chr($val);
            my $str = $sym x $count;
            $img =~ s/\Q${cnt}${sym}\E/$str/g;
        }
    }

    return $img;
}


#
#  coordinates():  breaks up an image into its (X,Y) coordinates.
#
sub coordinates {
    my ($img) = @_;
    my $pcoor = { };
    my @lines = split("\n", $img);
    my $idx = 0;
    for (my $y = 0; $y < @lines; $y++) {
        my $line = $lines[$y];
        my @points = split(//, $line);
        for (my $x = 0; $x < @points; $x++) {
            ($points[$x] eq " ") or $pcoor->{$idx++} = [ $x, $y ];
        }
    }
    $pcoor->{'count'} = $idx;
    return $pcoor;
}


#
#  scatter():  creates a random entropic 'scatter', towards which each
#              image will morph individually.
#
sub scatter {
    my ($count, $xcenter, $ycenter, $radius) = @_;
    $radius ||= 1;
    my $ppoints = { };
    for (my $i = 0; $i < $count; $i++) {
        while (1) {
            my $x = int rand $maxx;
            my $y = int rand $maxy;
            if ((($x - $xcenter)**2 + ($y - $ycenter)**2) <= $radius) {
                $ppoints->{$i} = [$x, $y];
                last;
            }
        }
    }
    $ppoints->{'count'} = $count;
    return $ppoints;
}


sub colorize {
    my ($img, $color) = @_;
    $color += $cbase;
    my $cstr = $is_win? "\e[4;7;${color}m": "\e[${color}m";
    $img =~ s/( +)/\e[m$1$cstr/g;
    return $img;
}


#
#  randchar():  generate a random character
#
sub randchar { chr 33 + int(rand 93) }


#
#  migrate():  migrate all points 1 step towards the destination scatter
#
#  Inputs:  $1 ... A pointer to hash of coordinates
#           $2 ... A pointer to the "scatter" hash
#           $3 ... A pointer to the array of progressively entropic images
#           $4 ... The color escape sequence
#
sub migrate {
    my ($pxy, $psc, $parray, $color) = @_;

    my $count0 = $pxy->{'count'};
    my $count1 = $psc->{'count'};

    my @lines = ($blank) x ($maxy + 1);
    my $b_moved = 0;

    for (my $i = 0; $i < $count0; $i++) {
        my $p1 = $pxy->{$i % $count0};
        my $p2 = $psc->{$i % $count1};
        my ($x1, $y1) = (@$p1);
        my ($x2, $y2) = (@$p2);
        if ($x1 != $x2 || $y1 != $y2) {
            $x1 = ($p1->[0] -= ($x1 <=> $x2));
            $y1 = ($p1->[1] -= ($y1 <=> $y2));
            ++$b_moved;
        }
        substr($lines[$y1], $x1, 1, randchar)
    }

    push @$parray, colorize(join($/,@lines), $color);
    return $b_moved;
}


#
#  output():  Display a single image
#
sub output {
    print "\e[H", $_[0];
    $delay and select(undef, undef, undef, $delay);
}


#
#  morph():  Performs a "morph" from one image into another.
#
sub morph {
    my ($from, $to, $color) = @_;

    my $pfr = coordinates($from);
    my $pto = coordinates($to);

    my @from = ( );
    my @to   = ( );

    my $psc = scatter($pto->{'count'}, 40, 10, $entropy_radius);

    my $m1 = my $m2 = 1;
    while ($m1 || $m2) {
        $m1 &&= migrate($pfr, $psc, \@from, $color);
        $m2 &&= migrate($pto, $psc, \@to, ($color+1) % $nlayers);
    }

    output(colorize($from, $color));
    map { output $_ } (@from, reverse @to);
    output(colorize($to, ($color+1) % $nlayers));
}