imported>Gfis: new

2017-09-10T17:27:21Z

new

New page

#!/usr/bin/perl

# Generate a meander sequence
# 2017-08-31, Georg Fischer
# Program in the public domain
# c.f. <http://www.teherba.org/index.php/OEIS/A220952>

use strict;
use integer; # avoid division problems with reals

my $debug = 0;
my $ansi = 0; # whether to use ANSI colors on console output
my $bfile = 0; # whether to print b-file
my $graph = 0; # whether to plot y,x behind the b-file entries
my $fail = 0;
my $sep = "/";
my $base = 5;
my $fbase = 10;
my $tbase = $base;
my $ident = "xx";
my $limit = 125;
my @path = (0,1,2,3,4,9,14,19,18,17,16,11,12,13,8,7,6,5,10,15,20,21,22,23,24);
# $bpath = "00/01/02/03/04/14/24/34/33/32/31/21/22/23/13/12/11/10/20/30/40/41/42/43/44/"; # defines the meander sequence
# print " 0 3 6 9 12 15 18 21 24 27 30 33 36 39 42 45 48 51 54 57 60 63 66 69 72\n" if $debug >= 1;

while (scalar(@ARGV) > 0 and ($ARGV[0] =~ m{\A\-})) { # start with hyphen
my $opt = shift(@ARGV);
if (0) {
} elsif ($opt eq "\-a") {
$ansi = 1;
} elsif ($opt eq "\-b") {
$bfile = 1;
} elsif ($opt eq "\-d") {
$debug = shift(@ARGV);
} elsif ($opt eq "\-g") {
$graph = 1;
} elsif ($opt eq "\-i") {
$ident = shift(@ARGV);
} elsif ($opt eq "\-l") {
$limit = shift(@ARGV);
} elsif ($opt eq "\-p") {
@path = split(/\,/, shift(@ARGV));
}
} # while opt

print "<!-================================-_>\n";
my $bpath = join("", map { my $bnum = &to_base($_); (length($bnum) < 2 ? "0$bnum" : $bnum) . $sep} @path);
print "<meander id=\"$ident\" path=\"" . join(",", @path) . "\"\n"
. " bpath=\"$bpath\"\n"
. " >\n";
my $ind = 1;

if (1) { # generate b-file
print "<b$base-file>\n";
$ind = 1;
my $ind_1 = $ind - 1;
my $bprev = "9";
my $bcurr = "0";
print "0 0\n";
while ($fail == 0 and $ind <= $limit) {
my $bnext = &get_successor($bprev, $bcurr);
if (length($bnext) > 8) {
$fail = 1;
} else { # not yet_failed
if ($bfile > 0) {
print "$ind $bnext\n";
} else {
if (length($bcurr) != length($bnext)) {
$ind_1 = $ind - 1;
print "$ind_1 $bcurr\n$ind $bnext\n";
}
}
} # not yet failed
$bprev = $bcurr;
$bcurr = $bnext;
$ind ++;
} # while $ind
print "</b$base-file>\n";
} # b-file

if ($fail == 0) { # success
&draw_path(@path);
if ($graph > 0) {
&draw_graph();
}
} # success
print "</meander>\n";
#--------
sub get_successor {
# get the successor node $bnext of a pair ($bprev, $bcurr)
our @cands = (); # candidates
#----
sub add_candidate {
# add a candidate
#----
sub adjust {
# make sure that both arguments start with "0" and have the same length
my ($bnum1, $bnum2) = @_;
while (length($bnum1) < length($bnum2)) {
$bnum1 = "0$bnum1";
}
while (length($bnum2) < length($bnum1)) {
$bnum2 = "0$bnum2";
}
if (substr($bnum1, 0, 1) != "0" or
substr($bnum2, 0, 1) != "0") {
$bnum1 = "0$bnum1";
$bnum2 = "0$bnum2";
}
return ($bnum1, $bnum2);
} # adjust
#----
sub is_adjacent {
# check whether 2 nodes are adjacent
my ($bprev, $bcurr) = @_;
($bprev, $bcurr) = &adjust($bprev, $bcurr);
# print "# is_adjacent(bprev=$bprev, bcurr=$bcurr) \n" if ($debug >= 2);
my $adjacent = 1;
my $width = length($bcurr);
my $j = $width - 1;
while ($adjacent == 1 and $j > 0) {
my $i = $j - 1;
while ($adjacent == 1 and $i >= 0) {
my $ppair = substr($bprev, $i, 1) . substr($bprev, $j, 1);
my $cpair = substr($bcurr, $i, 1) . substr($bcurr, $j, 1);
my $ppos = index($bpath, $ppair);
my $cpos = index($bpath, $cpair);
if ($ppair != $cpair and abs($cpos - $ppos) != 3) {
print "\n# is_adjacent($bprev,$bcurr): ppair=$ppair, cpair=$cpair, ppos=$ppos, cpos=$cpos\n" if $debug >= 2;
$adjacent = 0;
}
$i --;
} # while $i
$j --;
} # while $j
return $adjacent;
} # is_adjacent
#----
my ($npair, $bprev, $bcurr, $i, $j) = @_;
my $width = length($bcurr);
print "# add_candidate(npair=$npair, i=$i, j=$j)" if ($debug >= 1);
my $bcand = substr($bcurr, 0, $i) # before i
. substr($npair, 0, 1) # 1st digit -> [$i]
. substr($bcurr, $i + 1, $j - $i - 1) # between i and j
. substr($npair, 1, 1) # 2nd digit -> [$j]
. substr($bcurr, $j + 1, $width - 1 - $j) # behind j
;
if (0) {
} elsif (&is_adjacent($bcurr, $bcand) == 0) {
print "# $bcurr not adjacent to $bcand" if $debug >= 1;
} elsif ($bcand eq $bprev) {
print " $bcand=bprev" if $debug >= 1;
} else {
my $cpos = substr($bcurr, $i, 1) ne substr($bcand, $i, 1) ? $i : $j; # else change must be at j
my $icand = 0;
my $busy = 1;
while ($busy == 1 and $icand < scalar(@cands)) {
$busy = $cands[$icand] ne $bcand ? 1 : 0;
$icand ++;
} # while icand
if ($busy == 1) { # not yet stored
# $bcand =~ s{\A0}{};
push(@cands, $bcand);
} # not yet stored
print " -> bcand=$bcand" if $debug >= 1;
}
print "\n" if ($debug >= 1);
} # add_candidate
#----
my ($bprev, $bcurr) = @_;
($bprev, $bcurr) = &adjust($bprev, $bcurr);
print "# get_successor(bcurr=$bcurr)\n" if ($debug >= 1);
@cands = ();
my $width = length($bcurr);
my $j = $width - 1;
while ($j > 0) {
my $i = $j - 1;
while ($i >= 0) {
my $cpair = substr($bcurr, $i, 1) . substr($bcurr, $j, 1);
my $cpos = index($bpath, $cpair);
print "# cpair=$cpair -> cpos=$cpos\n" if ($debug >= 1);
if ($cpos >= 3) { # before
&add_candidate(substr($bpath, $cpos - 3, 2), $bprev, $bcurr, $i, $j);
} # before
if ($cpos < length($bpath) - 3) { # behind
&add_candidate(substr($bpath, $cpos + 3, 2), $bprev, $bcurr, $i, $j);
} # behind
$i --;
} # while $i
$j --;
} # while $j
my $cand = "";
print "# get_successor: " if ($debug >= 1);
my $lcand = scalar(@cands);
if (0) {
} elsif ($lcand > 1) {
print "# more than 1 candidate for $bcurr @ $ind" . ", cands=" . join(",", @cands) . "\n";
$fail = 1;
} elsif ($lcand < 1) {
print "# no candidate for $bcurr at $ind\n";
$fail = 1;
} else { # $lcand == 1
$cand = $cands[0];
$cand =~ s{\A0+}{};
if (length($cand) > 16) {
print "# $cand exploding @ $ind\n";
$fail = 1;
}
}
print "\n" if $debug >= 1;
return $cand;
} # get_successor
#--------
sub to_base {
# return a normal integer as number in base $tbase
my ($num) = @_;
my $result = "";
while ($num > 0) {
my $digit = $num % $tbase;
$result = $digit . $result;
$num /= $tbase;
} # while > 0
return $result eq "" ? "0" : $result;
} # to_base
#--------
sub from_base {
# return a number in base $fbase (string, maybe with letters) as normal integer
my ($num) = @_;
my $bpow = 1;
my $result = 0;
my $pos = length($num) - 1;
while ($pos >= 0) { # from backwards
my $digit = substr($num, $pos, 1);
if ($digit < 0) {
print STDERR "invalid digit in number $num\n";
}
$result += $digit * $bpow;
$bpow *= $fbase;
$pos --;
} # positive
return $result;
} # from_base
#--------
sub draw_graph {
print "<draw-graph>\n";
$ind = 1;
my $ind_1 = $ind - 1;
my $bprev = "9";
my $bcurr = "0";
print "0 0\n";
while ($fail == 0 and $ind <= $limit) {
my $bnext = &get_successor($bprev, $bcurr);
print sprintf("%-10s", "$ind $bnext")
. ($graph > 0 ? "|" . " " x (&from_base($bnext) + 1) . "@" : "")
. "\n";
$bprev = $bcurr;
$bcurr = $bnext;
$ind ++;
} # while $ind
print "</draw-graph>\n";
} # draw_graph
#--------
sub draw_path {
our $vert = "||"; if ($ansi == 1) { $vert = "\x1b[103m$vert\x1b[0m"; }
our $hori = "=="; if ($ansi == 1) { $hori = "\x1b[103m$hori\x1b[0m"; }
our @matrix = ();
our $blan = " ";
#----
sub get_matrix_pos {
my ($x, $y) = @_;
my $base2_1 = $base * 2 - 1; # 9 for base=5
return $x * 2 + ($base2_1 - 1) * $base2_1 - $y * 2 *$base2_1;
} # get_matrix_pos
#----
sub get_digit {
# return the value of a digit from a string in $base representation
# $base <= 10 for the moment, but hex is prepared
my ($num, $pos) = @_; # pos is 0 for last character
my $bum = &based0($num);
return substr($bum, length($bum) - 1 - $pos, 1);
} # get_digit
#----
sub based0 {
# return a number in base $base,
# filled to $maxexp - 1 with leading zeroes
my $maxexp = 2; # for drawing the start path only!
my ($num) = @_;
my $result = "";
my $ind = 0;
while ($ind < $maxexp) {
$result = ($num % $base) . $result;
$num /= $base;
$ind ++;
} # while $idig
return $result;
} # based0
#----
sub connect {
my ($pa0, $pa1) = @_;
if ($pa0 > $pa1) { # exchange, make p1 smaller
my $temp = $pa0;
$pa0 = $pa1;
$pa1 = $temp;
} # pa0 <= pa1
my $ba0 = &based0($pa0);
my $ba1 = &based0($pa1);
print "ba0=$ba0, ba1=$ba1" if $debug >= 2;
my $x0 = &get_digit($pa0, 1);
my $y0 = &get_digit($pa0, 0);
my $x1 = &get_digit($pa1, 1);
my $y1 = &get_digit($pa1, 0);
print ", x0=$x0, y0=$y0, x1=$x1, y1=$y1" if $debug >= 2;
my $mp0 = &get_matrix_pos($x0, $y0);
if ($x0 eq $x1) { # up
$matrix[$mp0 - ($base * 2 - 1)] = $vert; # up
print " $vert\n" if $debug >= 2;
} else {
$matrix[$mp0 + 1] = $hori; # right
print " $hori\n" if $debug >= 2;
}
} # connect
#----
# initialize the matrix
my $x = 0;
my $y = 0;
while ($x < $base) {
$y = 0;
while ($y < $base) {
my $mp = &get_matrix_pos($x, $y);
$matrix[$mp] = $ansi == 1 ? "\x1b[102m$x$y\x1b[0m" : "$x$y";
if ($x < $base - 1) {
$matrix[$mp + 1] = $blan; # " "; # right
}
if ($y > 0) {
$matrix[$mp + $base * 2 - 1] = $blan; # " "; # down
if ($x < $base - 1) {
$matrix[$mp + $base * 2 - 1 + 1] = $blan; # " "; # down
}
}
$y ++;
} # while y
$x ++;
} # while $x

my $ipa = 1;
while ($ipa < scalar(@path)) {
&connect($path[$ipa - 1], $path[$ipa]);
$ipa ++;
} # while $ipa
print "<draw-path>\n\n";
my $imp = 0;
while ($imp < scalar(@matrix)) { # print
print "$matrix[$imp]";
$imp ++;
if ($imp % ($base * 2 - 1) == 0) {
print "\n";
}
} # printing
print "\n</draw-path>\n";
} # draw_path
#--------
__DATA__

OEIS/gen meander.pl - Revision history

imported>Gfis: new