Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
Several people have asked me for the source code, so I'm posting it here.  This is the original code, which both creates the "multiple-layer" image, and the final compressed image, and then uncompresses and "peels" each layer off to provide individual the individual image frames which are morphed in progression.

You can make any changes to the array @layers, and it will create the corresponding frames in the output "morph".

#!/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', $ima +ge)") # 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 multip +le # 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 scatt +er # # Inputs: $1 ... A pointer to hash of coordinates # $2 ... A pointer to the "scatter" hash # $3 ... A pointer to the array of progressively entropic im +ages # $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)); }

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

In reply to Re: Morphological Japh by liverpole
in thread Morphological Japh by liverpole

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others examining the Monastery: (4)
    As of 2014-09-22 03:06 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (177 votes), past polls