Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Re: Morphological Japh

by liverpole (Monsignor)
on Jun 02, 2006 at 15:00 UTC ( [id://553308]=note: print w/replies, xml ) Need Help??


in reply to Morphological Japh

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$..$/

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://553308]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (4)
As of 2024-03-29 08:05 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found