.
Math-PlanePath-129/tools/ 0002755 0001750 0001750 00000000000 14001441522 013041 5 ustar gg gg Math-PlanePath-129/tools/alternate-paper-dxdy.pl 0000644 0001750 0001750 00000004070 12022542003 017424 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see PlanePath Man Pages
Math-PlanePath Man Pages (including Math-PlanePath-Toothpick)
(back to Math-PlanePath home page )
HERE
my $count = 0;
my $total_bytes = 0;
my $join = "\n
";
my $prev_type = '';
foreach my $filename (@filenames) {
$filename =~ /(Math-.*?-(Base)?)?/;
my $type = $&;
if ($type ne $prev_type) {
print $out "$Entitize{$module}
Total $count modules.
This page Copyright $year $Entitize{$author} .
HERE
close $out or die;
my $old_content = File::Slurp::read_file($out_filename, {err_mode=>'quiet'})
// '';
my $new_content = File::Slurp::read_file($out->filename);
foreach ($old_content, $new_content) { # compare sans mod dates
s/^\d+) +level=(?\d+)|And for just a (?blob))/mg) {
if ($+{'blob'}) {
$type = 'blob,';
} else {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"${type}level=$level"} = $+{'id'};
}
}
ok ($type, 'blob,');
ok ($count, 15, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 15);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
foreach my $blob (0, 1) {
my $type = ($blob ? 'blob,' : '');
foreach my $level (($blob ? 4 : 0) .. 10) {
my $graph = make_graph($level, $blob);
last if $graph->vertices >= 256;
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "${type}level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
$others++;
if (MyGraphs::hog_grep($g6_str)) {
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
}
ok ($extras, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/0-Test-Synopsis.t 0000755 0001750 0001750 00000001764 11655356314 015453 0 ustar gg gg #!/usr/bin/perl -w
# 0-Test-Synopsis.t -- run Test::Synopsis if available
# Copyright 2009, 2010, 2011 Kevin Ryde
# 0-Test-Synopsis.t is shared by several distributions.
#
# 0-Test-Synopsis.t is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# 0-Test-Synopsis.t is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with this file. If not, see ) {
if (/^__END__/) {
last;
}
# only a DEBUG=> non-zero number is bad, so an expression can copy a
# debug from another package
if (/(DEBUG\s*=>\s*[1-9][0-9]*)/
|| /^[ \t]*((use|no) (Smart|Devel)::Comments)/
) {
print STDERR "\n$filename:$.: leftover: $_\n";
$good = 0;
}
# no "use lib ... devel", except in xt/*.t
unless ($filename =~ /\bxt\b/) {
if (/^[ \t]*(use lib\b.*devel.*)/) {
print STDERR "\n$filename:$.: leftover: $_\n";
$good = 0;
}
}
}
if (! close FH) {
&$diag ("Oops, error closing $filename: $!");
$good = 0;
next;
}
}
my @C_files = grep {m{
# toplevel or lib .c and .xs files
^[^/]*\.([ch]|xs)$
|^(lib|examples|x?t)/.*\.([ch]|xs)$
}x
} @files;
foreach $filename (@C_files) {
if ($options{'verbose'}) {
&$diag ("C/XS file ",$filename);
}
if (! open FH, "< $filename") {
&$diag ("Oops, cannot open $filename: $!");
$good = 0;
next;
}
while () {
# #define DEBUG 1
# #define MY_DEBUG 1
if (/^#\s*define\s+(MY_)DEBUG\s+[1-9]/
) {
print STDERR "\n$filename:$.: leftover: $_\n";
$good = 0;
}
}
if (! close FH) {
&$diag ("Oops, error closing $filename: $!");
$good = 0;
next;
}
}
&$diag ("checked ",scalar(@perl_files)," perl files, ",
scalar(@C_files)," C/XS files\n");
return $good;
}
Math-PlanePath-129/xt/TerdragonCurve-hog.t 0000644 0001750 0001750 00000006220 13570401563 016237 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2019 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see \d+) +level=(?\d+)/mg) {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"level=$level"} = $+{'id'};
}
ok ($count, 6, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 6);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
# 3^6 == 729
foreach my $level (0 .. 6) {
my $graph = make_graph($level);
last if $graph->vertices >= 256;
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
$others++;
if (MyGraphs::hog_grep($g6_str)) {
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
ok ($extras, 0);
ok ($others, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/AlternateTerdragon-hog.t 0000644 0001750 0001750 00000006234 13570402012 017065 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2019 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see \d+) +level=(?\d+)/mg) {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"level=$level"} = $+{'id'};
}
ok ($count, 6, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 6);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
# 3^6 == 729
foreach my $level (0 .. 6) {
my $graph = make_graph($level);
last if $graph->vertices >= 256;
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
$others++;
if (MyGraphs::hog_grep($g6_str)) {
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
ok ($extras, 0);
ok ($others, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/PeanoDiagonals-seq.t 0000644 0001750 0001750 00000003523 13731641652 016213 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2019, 2020 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see \d+) +level=(?\d+)/mg) {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"level=$level"} = $+{'id'};
}
ok ($count, 9, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 9);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
# 3^6 == 729
foreach my $level (0 .. 10) {
my $graph = make_graph($level);
last if $graph->vertices >= 256;
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
$others++;
if (MyGraphs::hog_grep($g6_str)) {
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
ok ($extras, 0);
ok ($others, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/bigrat.t 0000644 0001750 0001750 00000055020 13774320636 014013 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see }; # slurp
close FH or die;
### $content
{
$content =~ /=for my_pod see_also begin(.*)=for my_pod see_also end/s
or die "see_also not matched";
my $see_also = $1;
my @see_also;
while ($see_also =~ /L]+)>/g) {
push @see_also, $1;
}
@see_also = sort @see_also;
my $s = join(', ',@see_also);
my $l = join(', ',@lib_modules);
is ($s, $l, 'PlanePath.pm pod SEE ALSO');
my $j = "$s\n$l";
$j =~ /^(.*)(.*)\n\1(.*)/ or die;
my $sd = $2;
my $ld = $3;
if ($sd) {
diag "see also: ",$sd;
diag "library: ",$ld;
}
}
{
$content =~ /=for my_pod list begin(.*)=for my_pod list end/s
or die "class list not matched";
my $list = $1;
my @list;
while ($list =~ /^ (\S+)/mg) {
push @list, $1;
}
@list = sort @list;
my $s = join(', ',@list);
my $l = join(', ',@lib_modules);
is ($s, $l, 'PlanePath.pm pod class list');
my $j = "$s\n$l";
$j =~ /^(.*)(.*)\n\1(.*)/ or die;
my $sd = $2;
my $ld = $3;
if ($sd) {
diag "list: ",$sd;
diag "library: ",$ld;
}
}
{
$content =~ /=for my_pod step begin(.*)=for my_pod step end/s
or die "base list not matched";
my $list = $1;
$content =~ /=for my_pod base begin(.*)=for my_pod base end/s
or die "step list not matched";
$list .= $1;
# initialized to exceptions, no "step" in the pod
my @list = ('File',
'Hypot', 'HypotOctant',
'TriangularHypot', 'VogelFloret',
'PythagoreanTree', 'RationalsTree', 'FractionsTree', 'ChanTree',
'FactorRationals', 'GcdRationals', 'CfracDigits',
'WythoffPreliminaryTriangle');
my %seen;
while ($list =~ /([A-Z]\S+)/g) {
my $elem = $1;
next if $elem eq 'Base';
next if $elem eq 'Path';
next if $elem eq 'Step';
next if $elem eq 'Fibonacci';
next if $elem eq 'ToothpickSpiral'; # separate Math-PlanePath-Toothpick
$elem =~ s/,//;
next if $seen{$elem}++;
push @list, $elem;
}
@list = sort @list;
my $s = join(', ',@list);
my $l = join(', ',@lib_modules);
is ($s, $l, 'PlanePath.pm step/base pod lists');
my $j = "$s\n$l";
$j =~ /^(.*)(.*)\n\1(.*)/ or die;
my $sd = $2;
my $ld = $3;
if ($sd) {
diag "list: ",$sd;
diag "library: ",$ld;
}
}
}
#------------------------------------------------------------------------------
foreach my $tfile ('xt/PlanePath-subclasses.t',
'xt/slow/NumSeq-PlanePathCoord.t',
) {
open FH, $tfile or die "$tfile: $!";
my $content = do { local $/; }; # slurp
close FH or die;
### $content
{
$content =~ /# module list begin(.*)module list end/s
or die "module list not matched";
my $list = $1;
my @list;
my %seen;
while ($list =~ /'([A-Z][^',]+)/ig) {
next if $seen{$1}++;
push @list, $1;
}
@list = sort @list;
my $s = join(', ',@list);
my $l = join(', ',@lib_modules);
is ($s, $l, $tfile);
my $j = "$s\n$l";
$j =~ /^(.*)(.*)\n\1(.*)/ or die;
my $sd = $2;
my $ld = $3;
if ($sd) {
diag "t list: ",$sd;
diag "library: ",$ld;
}
}
if ($tfile eq 't/PlanePath-subclasses.t') {
$content =~ /# rect_to_n_range exact begin(.*)# rect_to_n_range exact /s
or die "rect_to_n_range exact not matched";
my $list = $1;
my %exact;
while ($list =~ /^\s*'Math::PlanePath::([A-Z][^']+)/img) {
$exact{$1} = 1;
}
my $good = 1;
foreach my $module (@lib_modules) {
next if $module eq 'Flowsnake'; # inherited
next if $module eq 'QuintetCurve'; # inherited
my $file = module_exact($module);
my $t = $exact{$module} || 0;
if ($file != $t) {
diag "Math::PlanePath::$module file $file t $t";
$good = 0;
}
}
ok ($good,
"$tfile rect exact matches file comments");
sub module_exact {
my ($module) = @_;
my $filename = "lib/Math/PlanePath/$module.pm";
open FH, $filename or die $!;
my $content = do { local $/; }; # slurp
close FH or die;
### $content
$content =~ /^# (not )?exact\n(sub rect_to_n_range |\*rect_to_n_range =)/m
or die "$filename no exact comment";
return $1 ? 0 : 1;
}
}
}
#------------------------------------------------------------------------------
# numbers.pl
{
open FH, 'examples/numbers.pl' or die $!;
my $content = do { local $/; }; # slurp
close FH or die;
### $content
{
$content =~ /my \@all_classes = \((.*)# expand arg "all"/s
or die "module list not matched";
my $list = $1;
my @list = ('File');
my %seen;
while ($list =~ /'([A-Z][^',]+)/ig) {
next if $seen{$1}++;
push @list, $1;
}
@list = sort @list;
my $s = join(', ',@list);
my $l = join(', ',@lib_modules);
is ($s, $l, 'numbers.pl all_classes');
my $j = "$s\n$l";
$j =~ /^(.*)(.*)\n\1(.*)/ or die;
my $sd = $2;
my $ld = $3;
if ($sd) {
diag "numbers.pl list: ",$sd;
diag "library: ",$ld;
}
}
}
exit 0;
Math-PlanePath-129/xt/HIndexing-more.t 0000644 0001750 0001750 00000005675 13475604735 015376 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2014, 2018, 2019 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see =1 || error();
# GP-DEFINE n--; my(m=sqrtint(n), k=ceil(m/2));
# GP-DEFINE n -= 4*k^2;
# GP-DEFINE if(n<0, if(n<-m, 3*k+n, k), if(n N
# GP-DEFINE \\ a couple of different ways
# GP-DEFINE XY_to_N0(x,y) = {
# GP-DEFINE if(x>abs(y), \\ right vertical
# GP-DEFINE (4*x-2)*x - (x-y),
# GP-DEFINE -x>abs(y), \\ left vertical
# GP-DEFINE (4*x-2)*x + (x-y),
# GP-DEFINE y>0,
# GP-DEFINE (4*y-2)*y - (x-y), \\ top horizontal
# GP-DEFINE (4*y-2)*y + (x-y)); \\ bottom horizontal
# GP-DEFINE }
# GP-DEFINE XY_to_N1(x,y) = XY_to_N0(x,y) + 1;
#
# GP-Test /* XY_to_N1() vs back again X() and Y() */ \
# GP-Test for(y=-1,20, \
# GP-Test for(x=-1,20, \
# GP-Test my(n=XY_to_N1(x,y), back_x=X(n),back_y=Y(n)); \
# GP-Test (x==back_x && y==back_y) \
# GP-Test || error("xy=",x,",",y," n="n" which is xy="back_x" "back_y))); \
# GP-Test 1
# GP-DEFINE check_XY_to_N0_func(func) = {
# GP-DEFINE if(0, \\ view
# GP-DEFINE forstep(y=4,-4,-1,
# GP-DEFINE for(x=-4,4,
# GP-DEFINE printf(" %4d", func(x,y)));
# GP-DEFINE print()));
# GP-DEFINE
# GP-DEFINE for(y=-20,20,
# GP-DEFINE for(x=-20,20,
# GP-DEFINE my(want=XY_to_N0(x,y),
# GP-DEFINE got=func(x,y));
# GP-DEFINE if(want!=got,
# GP-DEFINE error("xy=",x,",",y," want=",want," got=",got))));
# GP-DEFINE 1;
# GP-DEFINE }
# Per
# Ronald L. Graham, Donald E. Knuth, Oren Patashnik, "Concrete Mathematics",
# Addison-Wesley, 1989, chapter 3 "Integer Functions", exercise 40 page 99,
# answer page 498.
# They spiral clockwise so y negated as compared to the form here.
#
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test y = -y; \
# GP-Test my(k=max(abs(x),abs(y))); \
# GP-Test (2*k)^2 + if(x>y, -1, 1) * (2*k + x + y); \
# GP-Test )
# Using x-y diag as offset NW,SE, like Graham, Knuth, Patashnik.
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(r=2*max(abs(x),abs(y))); \
# GP-Test r^2 + if(x+y>0, -(x-y+r), x-y+r); \
# GP-Test )
# GP-Test /* transpose to go to x as radial distance */ \
# GP-Test /* then x-y diagonal as offset */ \
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(s = if(abs(x)>abs(y), -sign(x), [x,y]=[y,x];sign(x))); \
# GP-Test (4*x-2)*x + s*(x-y); \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(s = if(abs(x)>abs(y), -sign(x), [x,y]=[y,x];sign(x))); \
# GP-Test 4*x^2 - 2*x + s*x - s*y; \
# GP-Test )
#
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test if(abs(x)>abs(y), \
# GP-Test (4*x-2)*x - sign(x)*(x-y), \
# GP-Test (4*y-2)*y - sign(y)*(x-y)); \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test if(abs(x)>abs(y), \
# GP-Test 4*x*x - abs(x) + sign(x)*(y - 2*abs(x)), \
# GP-Test (4*y-2)*y - sign(y)*(x-y)); \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(s = if(abs(x)>abs(y), -sign(x), [x,y]=[y,x];sign(x))); \
# GP-Test my(t=x+y,d=x-y); \
# GP-Test t^2 + 2*d*t + d^2 - t - d + s*d; \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(swap=abs(x)>abs(y)); \
# GP-Test my(s); \
# GP-Test my(t=x+y); \
# GP-Test my(d=x-y); \
# GP-Test swap == (abs(t+d)>abs(t-d)) || error(); \
# GP-Test swap == (sign(t)*sign(d) > 0) || error(); \
# GP-Test /* d *= (-1)^!swap; */ \
# GP-Test d *= (-1)^(sign(t)*sign(d) <= 0); \
# GP-Test /* d = abs(d)*if(sign(t)>0,-1,1); */ \
# GP-Test if(swap, s=-sign(t+d), s=sign(t+d)); \
# GP-Test t^2 + 2*d*t + d^2 - t - d + s*d; \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(t=x+y); \
# GP-Test my(d=x-y); \
# GP-Test my(r=max(abs(x),abs(y))); \
# GP-Test if(t>0, 4*r^2 - 2*r - d, \
# GP-Test 4*r^2 + 2*r + d); \
# GP-Test )
# GP-Test check_XY_to_N0_func((x,y)-> \
# GP-Test my(t=x+y); \
# GP-Test my(d=x-y); \
# GP-Test my(r=2*max(abs(x),abs(y))); \
# GP-Test if(t>0, r^2 - (r+d), \
# GP-Test r^2 + (r+d)); \
# GP-Test )
# GP-DEFINE N1_to_left(n) = {
# GP-DEFINE my(x=X(n),y=Y(n),ret=0);
# GP-DEFINE for(d=0,3,
# GP-DEFINE my(dz=I^d, dx=real(dz), dy=imag(dz),
# GP-DEFINE left=XY_to_N1(x+dx,y+dy));
# GP-DEFINE if(left>=n-1,next);
# GP-DEFINE if(ret,error("n="n" dxdy="dx","dy" left="left" already ret="ret));
# GP-DEFINE ret=left);
# GP-DEFINE ret;
# GP-DEFINE }
# vector(30,n, N1_to_left(n))
# forstep(y=4,-4,-1, \
# for(x=-4,4, \
# printf(" %4d", XY_to_N0(x,y))); \
# print());
#------------------------------------------------------------------------------
# A180714 X+Y coordinate sum, OFFSET=0
MyOEIS::compare_values
(anum => 'A180714',
func => sub {
my ($count) = @_;
my $path = $path_n_start_0;
my @got;
for (my $n = 0; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
push @got, $x + $y;
}
return \@got;
});
# GP-DEFINE \\ coordinate sum X+Y, 0-based
# GP-DEFINE A180714(n) = {
# GP-DEFINE n>=0 || error();
# GP-DEFINE n++;
# GP-DEFINE X(n) + Y(n);
# GP-DEFINE }
# GP-Test /* compact */ \
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=ceil(sqrtint(4*n)/2)); \
# GP-Test (s^2 - (s%2) - n)*(-1)^s )
#
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=if(n,ceil(sqrtint(4*n-3)/2))); \
# GP-Test (s^2 - (s%2) - n)*(-1)^s )
#
# GP-Test /* round-to-nearest */ \
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=round(sqrt(n))); \
# GP-Test (s^2 - (s%2) - n)*(-1)^s )
# (7/2)^2 == 49/4
# integer n is never half way
#
# GP-Test /* sqrtint need to push half way */ \
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=sqrtint(n)); \
# GP-Test (abs(n-s*(s+1)) - s)*(-1)^s + (s%2) )
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=sqrtint(n),r=n-s*(s+1)); \
# GP-Test (abs(r)-s)*(-1)^s + (s%2) )
#
# GP-Test /* more or less the X,Y cases */ \
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(s=sqrtint(n),r=n-s*(s+1)); \
# GP-Test if(s%2==1, if(r<=0, -abs(r) +s, -abs(r) +s), \
# GP-Test if(r<=0, abs(r) -s, abs(r) -s) ) \
# GP-Test + (s%2) )
# GP-Test vector(1000,n,n--; A180714(n)) == \
# GP-Test vector(1000,n,n--; my(m=sqrtint(n),k=ceil(m/2)); \
# GP-Test n -= 4*k^2; \
# GP-Test if(n<-m, 4*k+n, \
# GP-Test n>=m, -(4*k-n), \
# GP-Test n<0 && n>=-m, -n, \
# GP-Test n>=0 && nA180714(n)==0,[1..300])
# select(n->n>=2 && A180714(n-1)==A180714(n+1),[1..300])
#
# 16-15-14-13-12 ...
# | | |
# 17 4--3--2 11 28 0-based
# | | | | | even squares X+Y=0
# 18 5 0--1 10 27
# | | | |
# 19 6--7--8--9 26
# | |
# 20-21-22-23-24-25
# A180714 increments mentioned in A180714
# vector(30,n,n--; A180714(n+1) - A180714(n))
# not in OEIS: 1, 1, -1, -1, -1, -1, 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1
# X+Y at corners, as mentioned in A180714
# Vec(-x*(1+x)/((x-1)*(x^2+1)^2) + O(x^20))
# not in OEIS: 1, 2, 0, -2, 1, 4, 0, -4, 1, 6, 0, -6, 1, 8, 0, -8, 1, 10, 0
#------------------------------------------------------------------------------
# A265400 left side neighbour, n_start=1
sub A265400 {
my ($n) = @_;
$n >= 1 or die "A265400 is for n>=1";
my ($x,$y) = $path->n_to_xy ($n);
$path->n_start == 1 or die;
return max(0, map { my $n2 = $path->xy_to_n($x + $dir4_to_dx[$_],
$y + $dir4_to_dy[$_]);
defined $n2 && $n2 < $n-1 ? ($n2) : () } 0 .. 3);
}
MyOEIS::compare_values
(anum => 'A265400',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
push @got, A265400($n);
}
return \@got;
});
{
# A265400() vs formula like the GP form below
my $bad = 0;
foreach my $n (1 .. 10000) {
my $want = A265400($n);
my $got;
if (issquare($n-1) || issquare(4*$n-3)) { $got = 0; }
else { $got = $n - 2*int(sqrt(4*$n - 3)) + 3; }
unless ($got == $want) {
$bad++;
}
}
ok ($bad, 0, 'A265400 formula vs path');
}
# cf Antti Karttunen Scheme code ~/OEIS/a260643.txt
#
# GP-DEFINE A265400(n) = {
# GP-DEFINE n>=1 || error("A265400() is for n>=1");
# GP-DEFINE \\ if(n>1, n - 2*sqrtint(4*n-1) - 3);
# GP-DEFINE \\ 2*sqrtint(4*n-1)-3;
# GP-DEFINE if(issquare(n-1) || issquare(4*n-3), 0, n+3 - 2*sqrtint(4*n-3));
# GP-DEFINE }
# forstep(y=5,-5,-1, \
# for(x=-5,5, \
# my(n=XY_to_N1(x,y)); \
# printf(" %4d/%-2d", n, A265400(n))); \
# print());
# my(v=OEIS_samples("A265400")); vector(#v,n, A265400(n)) == v /* OFFSET=1 */
# my(g=OEIS_bfile_gf("A265400")); g==x*Polrev(vector(poldegree(g),n, A265400(n)))
# poldegree(OEIS_bfile_gf("A265400"))
# vector(40,n, A265400(n))
# GP-DEFINE ceil_sqrt(n) = my(s); if(issquare(n,&s), s, sqrtint(n)+1);
# GP-Test vector(1000,n, my(s=ceil_sqrt(n)); (s-1)^2 < n && n <= s^2) == \
# GP-Test vector(1000,n, 1)
# GP-Test /* formula */ \
# GP-Test vector(1000,n, A265400(n)) == \
# GP-Test vector(1000,n, if(issquare(n-1) || issquare(4*n-3), 0, \
# GP-Test n+5 - 2*ceil_sqrt(4*n) ))
# runs of offset to the left cell
# vector(40,n, if(n_is_corner_1based(n),0, n - A265400(n)))
# not in OEIS: 3, 0, 5, 0, 7, 7, 0, 9, 9, 0, 11, 11, 11, 0, 13, 13, 13, 0, 15, 15, 15, 15, 0, 17, 17, 17, 17, 0, 19, 19, 19, 19, 19, 0, 21, 21, 21
#------------------------------------------------------------------------------
# A010052 - issquare() helper
sub issquare {
my ($n) = @_;
return int(sqrt($n))**2 == $n;
}
MyOEIS::compare_values
(anum => q{A010052}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, issquare($n) ? 1 : 0;
}
return \@got;
});
#------------------------------------------------------------------------------
# A267682 Y axis positive and negative, n_start=1, origin twice
MyOEIS::compare_values
(anum => 'A267682',
func => sub {
my ($count) = @_;
my @got;
my $y = 0;
for (;;) {
push @got, $path->xy_to_n(0, $y);
last unless @got < $count;
push @got, $path->xy_to_n(0, -$y);
last unless @got < $count;
$y++;
}
return \@got;
});
# A156859 Y axis positive and negative, n_start=0
MyOEIS::compare_values
(anum => 'A156859',
func => sub {
my ($count) = @_;
my $path = $path_n_start_0;
my @got = (0);
for (my $y = 1; @got < $count; $y++) {
push @got, $path->xy_to_n(0, $y);
last unless @got < $count;
push @got, $path->xy_to_n(0, -$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A059924 Write the numbers from 1 to n^2 in a spiralling square; a(n) is the
# total of the sums of the two diagonals.
MyOEIS::compare_values
(anum => q{A059924}, # not shown in pod
max_count => 1000,
func => sub {
my ($count) = @_;
my @got = (0);
for (my $n = 1; @got < $count; $n++) {
### A059924 ...
push @got, A059924($n);
}
return \@got;
});
# A059924 spirals inwards, use $square+1 - $t to reverse the path numbering
sub A059924 {
my ($n) = @_;
### A059924(): $n
my $square = $n*$n;
### $square
my $total = 0;
my ($x,$y) = $path->n_to_xy($square);
my $dx = ($x <= 0 ? 1 : -1);
my $dy = ($y <= 0 ? 1 : -1);
### diagonal: "$x,$y dir $dx,$dy"
for (;;) {
my $t = $path->xy_to_n($x,$y);
### $t
last if $t > $square;
$total += $square+1 - $t;
$x += $dx;
$y += $dy;
}
$x -= $dx;
$y -= $dy * $n;
$dx = - $dx;
### diagonal: "$x,$y dir $dx,$dy"
for (;;) {
my $t = $path->xy_to_n($x,$y);
### $t
last if $t > $square;
$total += $square+1 - $t;
$x += $dx;
$y += $dy;
}
### $total
return $total;
}
#------------------------------------------------------------------------------
# A027709 -- unit squares figure boundary
MyOEIS::compare_values
(anum => 'A027709',
func => sub {
my ($count) = @_;
my @got = (0);
for (my $n = $path->n_start; @got < $count; $n++) {
push @got, $path->_NOTDOCUMENTED_n_to_figure_boundary($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A078633 -- grid sticks
sub path_n_to_dsticks {
my ($path, $n) = @_;
my ($x,$y) = $path->n_to_xy($n);
my $dsticks = 4;
foreach my $i (0 .. $#dir4_to_dx) {
my $an = $path->xy_to_n($x+$dir4_to_dx[$i], $y+$dir4_to_dy[$i]);
$dsticks -= (defined $an && $an < $n);
}
return $dsticks;
}
MyOEIS::compare_values
(anum => 'A078633',
func => sub {
my ($count) = @_;
my @got;
my $boundary = 0;
for (my $n = $path->n_start; @got < $count; $n++) {
$boundary += path_n_to_dsticks($path,$n);
push @got, $boundary;
}
return \@got;
});
#------------------------------------------------------------------------------
# A094768 -- cumulative spiro-fibonacci total of 4 neighbours
MyOEIS::compare_values
(anum => q{A094768},
func => sub {
my ($count) = @_;
my $path = $path_n_start_0;
my $total = Math::BigInt->new(1);
my @got = ($total);
for (my $n = $path->n_start + 1; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n-1);
foreach my $i (0 .. $#dir4_to_dx) {
my $sn = $path->xy_to_n ($x+$dir4_to_dx[$i], $y+$dir4_to_dy[$i]);
if ($sn < $n) {
$total += $got[$sn];
}
}
$got[$n] = $total;
}
return \@got;
});
#------------------------------------------------------------------------------
# A094767 -- cumulative spiro-fibonacci total of 8 neighbours
MyOEIS::compare_values
(anum => q{A094767},
func => sub {
my ($count) = @_;
my $path = $path_n_start_0;
my $total = Math::BigInt->new(1);
my @got = ($total);
for (my $n = $path->n_start + 1; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n-1);
foreach my $i (0 .. $#dir8_to_dx) {
my $sn = $path->xy_to_n ($x+$dir8_to_dx[$i], $y+$dir8_to_dy[$i]);
if ($sn < $n) {
$total += $got[$sn];
}
}
$got[$n] = $total;
}
return \@got;
});
#------------------------------------------------------------------------------
# A094769 -- cumulative spiro-fibonacci total of 8 neighbours starting 0,1
MyOEIS::compare_values
(anum => q{A094769},
func => sub {
my ($count) = @_;
my $path = $path_n_start_0;
my $total = Math::BigInt->new(1);
my @got = (0, $total);
for (my $n = $path->n_start + 2; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n-1);
foreach my $i (0 .. $#dir8_to_dx) {
my $sn = $path->xy_to_n ($x+$dir8_to_dx[$i], $y+$dir8_to_dy[$i]);
if ($sn < $n) {
$total += $got[$sn];
}
}
$got[$n] = $total;
}
return \@got;
});
#------------------------------------------------------------------------------
# A078784 -- primes on any axis positive or negative
MyOEIS::compare_values
(anum => q{A078784}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
if ($x == 0 || $y == 0) {
push @got, $n;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A090925 -- permutation rotate +90
MyOEIS::compare_values
(anum => 'A090925',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
($x,$y) = (-$y,$x); # rotate +90
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A090928 -- permutation rotate +180
MyOEIS::compare_values
(anum => 'A090928',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
($x,$y) = (-$x,-$y); # rotate +180
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A090929 -- permutation rotate +270
MyOEIS::compare_values
(anum => 'A090929',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
($x,$y) = ($y,-$x); # rotate -90
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A090861 -- permutation rotate +180, opp direction
MyOEIS::compare_values
(anum => 'A090861',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
$y = -$y; # opp direction
($x,$y) = (-$x,-$y); # rotate 180
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A090915 -- permutation rotate +270, opp direction
MyOEIS::compare_values
(anum => 'A090915',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
$y = -$y; # opp direction
($x,$y) = ($y,-$x); # rotate -90
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A090930 -- permutation opp direction
MyOEIS::compare_values
(anum => 'A090930',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
$y = -$y; # opp direction
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
# A185413 -- rotate 180, offset X+1,Y
MyOEIS::compare_values
(anum => 'A185413',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
$x = 1 - $x;
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A078765 -- primes at integer radix sqrt(x^2+y^2), and not on axis
MyOEIS::compare_values
(anum => q{A078765}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
if ($x != 0 && $y != 0 && is_perfect_square($x*$x+$y*$y)) {
push @got, $n;
}
}
return \@got;
});
sub is_perfect_square {
my ($n) = @_;
my $sqrt = int(sqrt($n));
return ($sqrt*$sqrt == $n);
}
#------------------------------------------------------------------------------
# A200975 -- N on all four diagonals
MyOEIS::compare_values
(anum => 'A200975',
func => sub {
my ($count) = @_;
my @got = (1);
for (my $i = 1; @got < $count; $i++) {
push @got, $path->xy_to_n($i,$i);
last unless @got < $count;
push @got, $path->xy_to_n(-$i,$i);
last unless @got < $count;
push @got, $path->xy_to_n(-$i,-$i);
last unless @got < $count;
push @got, $path->xy_to_n($i,-$i);
last unless @got < $count;
}
return \@got;
});
# #------------------------------------------------------------------------------
# # A195060 -- N on axis or diagonal ???
# # vertices generalized pentagonal 0,1,2,5,7,12,15,22,...
# # union A001318, A032528, A045943
#
# MyOEIS::compare_values
# (anum => 'A195060',
# func => sub {
# my ($count) = @_;
# my @got = (0);
# for (my $n = $path->n_start; @got < $count; $n++) {
# my ($x,$y) = $path->n_to_xy ($n);
# if ($x == $y || $x == -$y || $x == 0 || $y == 0) {
# push @got, $n;
# }
# }
# return \@got;
# });
# #------------------------------------------------------------------------------
# # A137932 -- count points not on diagonals up to nxn
#
# MyOEIS::compare_values
# (anum => 'A137932',
# max_value => 1000,
# func => sub {
# my ($count) = @_;
# my @got;
# for (my $k = 0; @got < $count; $k++) {
# my $num = 0;
# my ($cx,$cy) = $path->n_to_xy ($k*$k);
# foreach my $n (1 .. $k*$k) {
# my ($x,$y) = $path->n_to_xy ($n);
# $num += (abs($x) != abs($y));
# }
# push @got, $num;
# }
# return \@got;
# });
#------------------------------------------------------------------------------
# A113688 -- isolated semi-primes
# cf
# A113689 Number of semiprimes in clumps of size >1 through n^2 in the semiprime spiral.
MyOEIS::compare_values
(anum => q{A113688}, # not shown in POD
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::AlmostPrimes->new;
my @got;
N: for (my $n = $path->n_start; @got < $count; $n++) {
next unless $seq->pred($n); # want n a semiprime
my ($x,$y) = $path->n_to_xy ($n);
foreach my $i (0 .. $#dir8_to_dx) {
my $sn = $path->xy_to_n ($x+$dir8_to_dx[$i], $y+$dir8_to_dy[$i]);
if ($seq->pred($sn)) {
next N; # has a semiprime neighbour, skip
}
}
push @got, $n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A215470 -- primes with >=4 prime neighbours in 8 surround
MyOEIS::compare_values
(anum => 'A215470',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
my $num = 0;
foreach my $i (0 .. $#dir8_to_dx) {
my $sn = $path->xy_to_n ($x+$dir8_to_dx[$i], $y+$dir8_to_dy[$i]);
if (is_prime($sn)) { $num++; }
}
if ($num >= 4) {
push @got, $n;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A137930 sum leading and anti diagonal of nxn square
MyOEIS::compare_values
(anum => q{A137930},
func => sub {
my ($count) = @_;
my @got;
for (my $k = 0; @got < $count; $k++) {
push @got, diagonals_total($path,$k);
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A137931}, # 2n x 2n
func => sub {
my ($count) = @_;
my @got;
for (my $k = 0; @got < $count; $k+=2) {
push @got, diagonals_total($path,$k);
}
return \@got;
});
# A114254 Sum of all terms on the two principal diagonals of a 2n+1 X 2n+1 square spiral.
MyOEIS::compare_values
(anum => q{A114254}, # 2n+1 x 2n+1
func => sub {
my ($count) = @_;
my @got;
for (my $k = 1; @got < $count; $k+=2) {
push @got, diagonals_total($path,$k);
}
return \@got;
});
sub diagonals_total {
my ($path, $k) = @_;
### diagonals_total(): $k
if ($k == 0) {
return 0;
}
my ($x,$y) = $path->n_to_xy ($k*$k); # corner
my $dx = ($x > 0 ? -1 : 1);
my $dy = ($y > 0 ? -1 : 1);
### corner: "$x,$y dx=$dx,dy=$dy"
my %n;
foreach my $i (0 .. $k-1) {
my $n = $path->xy_to_n($x,$y);
$n{$n} = 1;
$x += $dx;
$y += $dy;
}
$x -= $k*$dx;
$dy = -$dy;
$y += $dy;
### opposite: "$x,$y dx=$dx,dy=$dy"
foreach my $i (0 .. $k-1) {
my $n = $path->xy_to_n($x,$y);
$n{$n} = 1;
$x += $dx;
$y += $dy;
}
### n values: keys %n
return sum(keys %n);
}
#------------------------------------------------------------------------------
# A059428 -- Prime[N] for N=corner
MyOEIS::compare_values
(anum => q{A059428},
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath_object => $path,
turn_type => 'LSR');
my @got = (2);
while (@got < $count) {
my ($i,$value) = $seq->next;
if ($value) {
push @got, MyOEIS::ith_prime($i); # i=2 as first turn giving prime=3
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A123663 -- count total shared edges
MyOEIS::compare_values
(anum => q{A123663},
func => sub {
my ($count) = @_;
my @got;
my $edges = 0;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy ($n);
foreach my $sn ($path->xy_to_n($x+1,$y),
$path->xy_to_n($x-1,$y),
$path->xy_to_n($x,$y+1),
$path->xy_to_n($x,$y-1)) {
if ($sn < $n) {
$edges++;
}
}
push @got, $edges;
}
return \@got;
});
#------------------------------------------------------------------------------
# A172294 -- jewels, composite surrounded by 4 primes NSEW, n_start = 0
#
# Parity of loops mean n even has NSEW neighbours odd, and vice versa
MyOEIS::compare_values
(anum => q{A172294}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
my $path = $path_n_start_0;
for (my $n = $path->n_start; @got < $count; $n++) {
next if is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
if (is_prime ($path->xy_to_n($x+1,$y))
&& is_prime ($path->xy_to_n($x-1,$y))
&& is_prime ($path->xy_to_n($x,$y+1))
&& is_prime ($path->xy_to_n($x,$y-1))
) {
push @got, $n;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A115258 -- isolated primes, 8 neighbours
MyOEIS::compare_values
(anum => q{A115258}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
if (! is_prime ($path->xy_to_n($x+1,$y))
&& ! is_prime ($path->xy_to_n($x-1,$y))
&& ! is_prime ($path->xy_to_n($x,$y+1))
&& ! is_prime ($path->xy_to_n($x,$y-1))
&& ! is_prime ($path->xy_to_n($x+1,$y+1))
&& ! is_prime ($path->xy_to_n($x-1,$y-1))
&& ! is_prime ($path->xy_to_n($x-1,$y+1))
&& ! is_prime ($path->xy_to_n($x+1,$y-1))
) {
push @got, $n;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A214177 -- sum of 4 neighbours
MyOEIS::compare_values
(anum => q{A214177}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy ($n);
push @got, ($path->xy_to_n($x+1,$y)
+ $path->xy_to_n($x-1,$y)
+ $path->xy_to_n($x,$y+1)
+ $path->xy_to_n($x,$y-1)
);
}
return \@got;
});
#------------------------------------------------------------------------------
# A214176 -- sum of 8 neighbours
MyOEIS::compare_values
(anum => q{A214176}, # not shown in POD
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy ($n);
push @got, ($path->xy_to_n($x+1,$y)
+ $path->xy_to_n($x-1,$y)
+ $path->xy_to_n($x,$y+1)
+ $path->xy_to_n($x,$y-1)
+ $path->xy_to_n($x+1,$y+1)
+ $path->xy_to_n($x-1,$y-1)
+ $path->xy_to_n($x-1,$y+1)
+ $path->xy_to_n($x+1,$y-1)
);
}
return \@got;
});
#------------------------------------------------------------------------------
# A214664 -- X coord of prime N
MyOEIS::compare_values
(anum => 'A214664',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
push @got, $x;
}
return \@got;
});
# A214665 -- Y coord of prime N
MyOEIS::compare_values
(anum => 'A214665',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
push @got, $y;
}
return \@got;
});
# A214666 -- X coord of prime N, first to west
MyOEIS::compare_values
(anum => 'A214666',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
push @got, -$x;
}
return \@got;
});
# A214667 -- Y coord of prime N, first to west
MyOEIS::compare_values
(anum => 'A214667',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
next unless is_prime($n);
my ($x,$y) = $path->n_to_xy ($n);
push @got, -$y;
}
return \@got;
});
#------------------------------------------------------------------------------
# A143856 -- N values ENE slope=2
MyOEIS::compare_values
(anum => 'A143856',
func => sub {
my ($count) = @_;
my @got;
for (my $i = 0; @got < $count; $i++) {
push @got, $path->xy_to_n (2*$i, $i);
}
return \@got;
});
#------------------------------------------------------------------------------
# A143861 -- N values NNE slope=2
MyOEIS::compare_values
(anum => 'A143861',
func => sub {
my ($count) = @_;
my @got;
for (my $i = 0; @got < $count; $i++) {
push @got, $path->xy_to_n ($i, 2*$i);
}
return \@got;
});
#------------------------------------------------------------------------------
# A062410 -- a(n) is sum of existing numbers in row of a(n-1)
MyOEIS::compare_values
(anum => 'A062410',
func => sub {
my ($count) = @_;
my @got;
my %plotted;
$plotted{0,0} = Math::BigInt->new(1);
my $xmin = 0;
my $ymin = 0;
my $xmax = 0;
my $ymax = 0;
push @got, 1;
for (my $n = $path->n_start + 1; @got < $count; $n++) {
my ($prev_x, $prev_y) = $path->n_to_xy ($n-1);
my ($x, $y) = $path->n_to_xy ($n);
my $total = 0;
if ($y == $prev_y) {
### column: "$ymin .. $ymax at x=$prev_x"
foreach my $y ($ymin .. $ymax) {
$total += $plotted{$prev_x,$y} || 0;
}
} else {
### row: "$xmin .. $xmax at y=$prev_y"
foreach my $x ($xmin .. $xmax) {
$total += $plotted{$x,$prev_y} || 0;
}
}
### total: "$total"
$plotted{$x,$y} = $total;
$xmin = min($xmin,$x);
$xmax = max($xmax,$x);
$ymin = min($ymin,$y);
$ymax = max($ymax,$y);
push @got, $total;
}
return \@got;
});
#------------------------------------------------------------------------------
# A020703 -- permutation read clockwise, ie. transpose Y,X
# also permutation rotate +90, opp direction
MyOEIS::compare_values
(anum => 'A020703',
func => sub {
my ($count) = @_;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
push @got, $path->xy_to_n ($y, $x);
}
return \@got;
});
#------------------------------------------------------------------------------
# A121496 -- run lengths of consecutive N in A068225 N at X+1,Y
MyOEIS::compare_values
(anum => 'A121496',
func => sub {
my ($count) = @_;
my @got;
my $num = 0;
my $prev_right_n = A068225(1) - 1; # make first value look like a run
for (my $n = $path->n_start; @got < $count; $n++) {
my $right_n = A068225($n);
if ($right_n == $prev_right_n + 1) {
$num++;
} else {
push @got, $num;
$num = 1;
}
$prev_right_n = $right_n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A054551 -- plot Nth prime at each N, values are those primes on X axis
MyOEIS::compare_values
(anum => 'A054551',
func => sub {
my ($count) = @_;
my @got;
for (my $x = 0; @got < $count; $x++) {
my $n = $path->xy_to_n($x,0);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054553 -- plot Nth prime at each N, values are those primes on X=Y diagonal
MyOEIS::compare_values
(anum => 'A054553',
func => sub {
my ($count) = @_;
my @got;
for (my $x = 0; @got < $count; $x++) {
my $n = $path->xy_to_n($x,$x);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054555 -- plot Nth prime at each N, values are those primes on Y axis
MyOEIS::compare_values
(anum => 'A054555',
func => sub {
my ($count) = @_;
my @got;
for (my $y = 0; @got < $count; $y++) {
my $n = $path->xy_to_n(0,$y);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A053999 -- plot Nth prime at each N, values are those primes on South-East
MyOEIS::compare_values
(anum => 'A053999',
func => sub {
my ($count) = @_;
my @got;
for (my $x = 0; @got < $count; $x++) {
my $n = $path->xy_to_n($x,-$x);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054564 -- plot Nth prime at each N, values are those primes on North-West
MyOEIS::compare_values
(anum => 'A054564',
func => sub {
my ($count) = @_;
my @got;
for (my $x = 0; @got < $count; $x--) {
my $n = $path->xy_to_n($x,-$x);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054566 -- plot Nth prime at each N, values are those primes on negative X
MyOEIS::compare_values
(anum => 'A054566',
func => sub {
my ($count) = @_;
my @got;
for (my $x = 0; @got < $count; $x--) {
my $n = $path->xy_to_n($x,0);
push @got, MyOEIS::ith_prime($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A137928 -- N values on diagonal X=1-Y positive and negative
MyOEIS::compare_values
(anum => 'A137928',
func => sub {
my ($count) = @_;
my @got;
for (my $y = 0; @got < $count; $y++) {
push @got, $path->xy_to_n(1-$y,$y);
last unless @got < $count;
if ($y != 0) {
push @got, $path->xy_to_n(1-(-$y),-$y);
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A002061 -- central polygonal numbers, N values on diagonal X=Y pos and neg
MyOEIS::compare_values
(anum => 'A002061',
func => sub {
my ($count) = @_;
my @got;
for (my $y = 0; @got < $count; $y++) {
push @got, $path->xy_to_n($y,$y);
last unless @got < $count;
push @got, $path->xy_to_n(-$y,-$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A016814 -- N values (4n+1)^2 on SE diagonal every second square
MyOEIS::compare_values
(anum => 'A016814',
func => sub {
my ($count) = @_;
my @got;
for (my $i = 0; @got < $count; $i+=2) {
push @got, $path->xy_to_n($i,-$i);
}
return \@got;
});
#------------------------------------------------------------------------------
# A033952 -- AllDigits on negative Y axis
MyOEIS::compare_values
(anum => 'A033952',
func => sub {
my ($count) = @_;
my @got;
my $seq = Math::NumSeq::AllDigits->new;
for (my $y = 0; @got < $count; $y--) {
my $n = $path->xy_to_n (0, $y);
push @got, $seq->ith($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A033953 -- AllDigits starting 0, on negative Y axis
MyOEIS::compare_values
(anum => 'A033953',
func => sub {
my ($count) = @_;
my @got;
my $seq = Math::NumSeq::AllDigits->new;
for (my $y = 0; @got < $count; $y--) {
my $n = $path->xy_to_n (0, $y);
push @got, $seq->ith($n-1);
}
return \@got;
});
#------------------------------------------------------------------------------
# A033988 -- AllDigits starting 0, on negative X axis
MyOEIS::compare_values
(anum => 'A033988',
func => sub {
my ($count) = @_;
my @got;
my $seq = Math::NumSeq::AllDigits->new;
for (my $x = 0; @got < $count; $x--) {
my $n = $path->xy_to_n ($x, 0);
push @got, $seq->ith($n-1);
}
return \@got;
});
#------------------------------------------------------------------------------
# A033989 -- AllDigits starting 0, on positive Y axis
MyOEIS::compare_values
(anum => 'A033989',
func => sub {
my ($count) = @_;
my @got;
my $seq = Math::NumSeq::AllDigits->new;
for (my $y = 0; @got < $count; $y++) {
my $n = $path->xy_to_n (0, $y);
push @got, $seq->ith($n-1);
}
return \@got;
});
#------------------------------------------------------------------------------
# A033990 -- AllDigits starting 0, on positive X axis
MyOEIS::compare_values
(anum => 'A033990',
func => sub {
my ($count) = @_;
my @got;
my $seq = Math::NumSeq::AllDigits->new;
for (my $x = 0; @got < $count; $x++) {
my $n = $path->xy_to_n ($x, 0);
push @got, $seq->ith($n-1);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054556 -- N values on Y axis (but OFFSET=1)
MyOEIS::compare_values
(anum => 'A054556',
func => sub {
my ($count) = @_;
my @got;
for (my $y = 0; @got < $count; $y++) {
push @got, $path->xy_to_n(0,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054554 -- N values on X=Y diagonal
MyOEIS::compare_values
(anum => 'A054554',
func => sub {
my ($count) = @_;
my @got;
for (my $i = 0; @got < $count; $i++) {
push @got, $path->xy_to_n($i,$i);
}
return \@got;
});
#------------------------------------------------------------------------------
# A054569 -- N values on negative X=Y diagonal, but OFFSET=1
MyOEIS::compare_values
(anum => 'A054569',
func => sub {
my ($count) = @_;
my @got;
for (my $i = 0; @got < $count; $i++) {
push @got, $path->xy_to_n(-$i,-$i);
}
return \@got;
});
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/oeis/PeanoCurve-oeis.t 0000644 0001750 0001750 00000044421 13751363077 016512 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012, 2013, 2015, 2018, 2020 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see new (x_start=>1, y_start=>1);
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($i,$j) = $diag->n_to_xy($d); # by anti-diagonals
# if ($i > $j) { ($i,$j) = ($j,$i); }
my $ia = $path->xy_to_n(1,$i) or die;
my $ib = $path->xy_to_n(2,$i) or die;
my $ja = $path->xy_to_n(1,$j) or die;
my $jb = $path->xy_to_n(2,$j) or die;
($ia,$ib) = pair_left_justify($ia,$ib);
($ja,$jb) = pair_left_justify($ja,$jb);
push @got, path_find_row_with_pair($path, $ia+$ja, $ib+$jb);
}
return \@got;
});
#------------------------------------------------------------------------------
# A165357 - Left-justified Wythoff Array by diagonals
{
my $path = Math::PlanePath::WythoffArray->new;
sub left_justified_row_start {
my ($y) = @_;
return pair_left_justify($path->xy_to_n(0,$y),
$path->xy_to_n(1,$y));
}
sub left_justified_xy_to_n {
my ($x,$y) = @_;
my ($a,$b) = left_justified_row_start($y);
foreach (1 .. $x) {
($a,$b) = ($b,$a+$b);
}
return $a;
}
# foreach my $y (0 .. 5) {
# foreach my $x (0 .. 10) {
# printf "%3d ", left_justified_xy_to_n($x,$y);
# }
# print "\n";
# }
}
MyOEIS::compare_values
(anum => 'A165357',
func => sub {
my ($count) = @_;
my $diag = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, left_justified_xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A185737 -- accumulation array, by antidiagonals
# accumulation being total sum N in rectangle 0,0 to X,Y
MyOEIS::compare_values
(anum => 'A185737',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my $diag = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, path_rect_to_accumulation($path, 0,0, $x,$y);
}
return \@got;
});
sub path_rect_to_accumulation {
my ($path, $x1,$y1, $x2,$y2) = @_;
# $x1 = round_nearest ($x1);
# $y1 = round_nearest ($y1);
# $x2 = round_nearest ($x2);
# $y2 = round_nearest ($y2);
($x1,$x2) = ($x2,$x1) if $x1 > $x2;
($y1,$y2) = ($y2,$y1) if $y1 > $y2;
my $accumulation = 0;
foreach my $x ($x1 .. $x2) {
foreach my $y ($y1 .. $y2) {
$accumulation += $path->xy_to_n($x,$y);
}
}
return $accumulation;
}
#------------------------------------------------------------------------------
# A173028 -- row number which is x * row(y), by diagonals
# Return pair ($a,$b) which is in the $k'th coprime row of WythoffArray $path
# First pair at $k==1.
sub coprime_pair {
my ($path, $k) = @_;
my $x = $path->x_minimum;
for (my $y = $path->y_minimum; ; $y++) {
my $a = $path->xy_to_n($x, $y);
my $b = $path->xy_to_n($x+1,$y);
if (_coprime($a,$b)) {
$k--;
if ($k <= 0) {
return ($a,$b);
}
}
}
}
# Return the row number Y of WythoffArray $path which contains $multiple
# times the $k'th coprime row.
sub path_y_of_multiple {
my ($path, $multiple, $k) = @_;
### path_y_of_multiple: "$multiple,$k"
if ($multiple < 1) {
croak "path_y_of_multiple multiple=$multiple";
}
($a,$b) = coprime_pair($path,$k);
return path_find_row_with_pair($path, $a*$multiple, $b*$multiple);
}
# {
# my $path = Math::PlanePath::WythoffArray->new (x_start=>1, y_start=>1);
# foreach my $y (1 .. 5) {
# foreach my $x (1 .. 10) {
# printf "%3d ", path_y_of_multiple($path,$x,$y)//-1;
# }
# print "\n";
# }
# }
MyOEIS::compare_values
(anum => 'A173028',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new (x_start=>1, y_start=>1);
my $diag = Math::PlanePath::Diagonals->new (x_start => $path->x_minimum,
y_start => $path->y_minimum,
direction => 'up');
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, path_y_of_multiple($path,$x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A139764 -- lowest Zeckendorf term fibonacci value,
# is N on X axis for the column containing n
MyOEIS::compare_values
(anum => 'A139764',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
push @got, $path->xy_to_n($x,0); # down to axis
# Across to Y axis, not in OEIS
# push @got, $path->xy_to_n(0,$y); # across to axis
}
return \@got;
});
#------------------------------------------------------------------------------
# A220249 -- which row is n * Lucas numbers
MyOEIS::compare_values
(anum => 'A220249',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new (x_start=>1, y_start=>1);
my @got;
for (my $k = 1; @got < $count; $k++) {
# Lucas numbers starting 1, 3
push @got, path_find_row_with_pair($path, $k, $k*3);
}
return \@got;
});
#------------------------------------------------------------------------------
# A173027 -- which row is n * Fibonacci numbers
MyOEIS::compare_values
(anum => 'A173027',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new (x_start=>1, y_start=>1);
my @got;
for (my $k = 1; @got < $count; $k++) {
# Fibonacci numbers starting 1, 1
push @got, path_find_row_with_pair($path, $k, $k);
}
return \@got;
});
#------------------------------------------------------------------------------
# A035614 -- X coord, starting 0
# but is OFFSET=0 so start N=0
MyOEIS::compare_values
(anum => 'A035614',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
push @got, $x;
}
return \@got;
});
#------------------------------------------------------------------------------
# A188436 -- [3r]-[nr]-[3r-nr], where r=(1+sqrt(5))/2 and []=floor.
# positions of right turns
# Y axis turn right: 0 1 00 101 00 1 00 101
# Fibonacci word: 0 1 00 101 00 1 00 101
#
# N on Y axis
# 101010
# 101001
# 100101
# 100001
# 10101
# 10001
# 1001
# 101
# 1
# A188436: 00000 001000000010000100000001000000010000100000001000010000000100000
# path: 001000000010000100000001000000010000100000001000010000000100000
MyOEIS::compare_values
(anum => 'A188436',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'WythoffArray',
turn_type => 'Right');
my @got = (0,0,0,0,0);
while (@got < $count) {
my ($i,$value) = $seq->next;
push @got, $value;
}
return \@got;
});
use constant PHI => (1 + sqrt(5)) / 2;
use POSIX 'floor';
sub A188436_func {
my ($n) = @_;
floor(3*PHI) - floor($n*PHI)-floor(3*PHI-$n*PHI);
}
{
my $seq = Math::NumSeq::Fibbinary->new;
my $bad = 0;
foreach (1 .. 50000) {
my ($i,$seq_value) = $seq->next;
$seq_value = ($seq_value % 8 == 5 ? 1 : 0);
# if ($seq_value) { print "$i," }
my $func_value = A188436_func($i+4);
if ($func_value != $seq_value) {
print "$i fibbinary seq=$seq_value func=$func_value\n";
last if $bad++ > 20;
}
}
ok (0, $bad);
}
{
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'WythoffArray',
turn_type => 'Right');
my $bad = 0;
foreach (1 .. 50000) {
my ($i,$seq_value) = $seq->next;
my $func_value = A188436_func($i+4);
if ($func_value != $seq_value) {
print "$i turn seq=$seq_value func=$func_value\n";
last if $bad++ > 20;
}
}
ok (0, $bad);
}
# [3r]-[(n+4)r]-[3r-(n+4)r]
# = [3r]-[(n+4)r]-[3r-nr-4r]
# = [3r]-[nr+4r]-[-r-nr]
# some of Y axis 4,12,17,25,33,38,46
#------------------------------------------------------------------------------
# A003622 -- Y coordinate of right turns is "odd" Zeckendorf base
MyOEIS::compare_values
(anum => 'A003622',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath_object => $path,
turn_type => 'Right');
my @got;
while (@got < $count) {
my ($i,$value) = $seq->next;
if ($value) {
my ($x,$y) = $path->n_to_xy($i);
$x == 0 or die "oops, right turn supposed to be at X=0";
push @got, $y;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A134860 -- Wythoff AAB numbers
# N position of right turns, being Zeckendorf ending "...101"
MyOEIS::compare_values
(anum => 'A134860',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'WythoffArray',
turn_type => 'Right');
my @got;
while (@got < $count) {
my ($i,$value) = $seq->next;
if ($value) {
push @got, $i;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# Y axis 0=left,1=right is Fibonacci word
{
my $path = Math::PlanePath::WythoffArray->new;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath_object => $path,
turn_type => 'Right');
my $fw = Math::NumSeq::FibonacciWord->new;
my $bad = 0;
foreach my $y (1 .. 1000) {
my $n = $path->xy_to_n(0, Math::BigInt->new($y));
my $seq_value = $seq->ith($n);
my $fw_value = $fw->ith($y);
if ($fw_value != $seq_value) {
print "y=$y n=$n seq=$seq_value fw=$fw_value\n";
last if $bad++ > 20;
}
}
ok (0, $bad);
}
#------------------------------------------------------------------------------
# A080164 -- Wythoff difference array
# diff(x,y) = wythoff(2x+1,y) - wythoff(2x,y)
MyOEIS::compare_values
(anum => 'A080164',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my $diag = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, $path->xy_to_n(2*$x+1,$y) - $path->xy_to_n(2*$x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A143299 number of Zeckendorf 1-bits in row Y
# cf A007895 which is the fibbinary bit count Math::NumSeq::FibbinaryBitCount
MyOEIS::compare_values
(anum => 'A143299',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::FibbinaryBitCount->new;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
for (my $y = 0; @got < $count; $y++) {
my $n = $path->xy_to_n(0,$y);
push @got, $seq->ith($n);
}
return \@got;
});
#------------------------------------------------------------------------------
# A137707 secondary Wythoff array ???
# A137707 Secondary Wythoff Array read by antidiagonals.
# A137708 Secondary Lower Wythoff Sequence.
# A137709 Secondary Upper Wythoff Sequence.
# MyOEIS::compare_values
# (anum => 'A137707',
# func => sub {
# my ($count) = @_;
# my $path = Math::PlanePath::WythoffArray->new;
# my $diag = Math::PlanePath::Diagonals->new;
# my @got;
# for (my $d = $diag->n_start; @got < $count; $d++) {
# my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
# if ($y % 2) {
# push @got, $path->xy_to_n($x,$y-1) + 1;
# } else {
# push @got, $path->xy_to_n($x,$y);
# }
# }
# return \@got;
# });
#------------------------------------------------------------------------------
# A083398 -- anti-diagonals needed to cover numbers 1 to n
# maybe n_range_to_rect() ...
# max(X+Y) for 1 to n
MyOEIS::compare_values
(anum => 'A083398',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
my @diag;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x, $y) = $path->n_to_xy ($n);
$diag[$n] = $x+$y + 1; # +1 to count first diagonal as 1
push @got, max(@diag[1..$n]);
}
return \@got;
});
#------------------------------------------------------------------------------
# N in columns
foreach my $elem ([ 'A003622', 0 ], # N on Y axis, OFFSET=1
[ 'A035336', 1 ], # N in X=1 column OFFSET=1
[ 'A066097', 1 ], # N in X=1 column, duplicate OFFSET=0
# per list in A035513
[ 'A035337', 2 ], # OFFSET=0
[ 'A035338', 3 ], # OFFSET=0
[ 'A035339', 4 ], # OFFSET=0
[ 'A035340', 5 ], # OFFSET=0
) {
my ($anum, $x, %options) = @$elem;
MyOEIS::compare_values
(anum => $anum,
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = @{$options{'extra_initial'}||[]};
for (my $y = Math::BigInt->new(0); @got < $count; $y++) {
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
}
#------------------------------------------------------------------------------
# A160997 Antidiagonal sums of the Wythoff array A035513
MyOEIS::compare_values
(anum => 'A160997',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
for (my $d = 0; @got < $count; $d++) {
my $total = 0;
foreach my $x (0 .. $d) {
$total += $path->xy_to_n($x,$d-$x);
}
push @got, $total;
}
return \@got;
});
#------------------------------------------------------------------------------
# A005248 -- every second N on Y=1 row, every second Lucas number
MyOEIS::compare_values
(anum => q{A005248},
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = (2,3); # initial skipped
for (my $x = Math::BigInt->new(1); @got < $count; $x+=2) {
push @got, $path->xy_to_n ($x, 1);
}
return \@got;
});
#------------------------------------------------------------------------------
# N on rows
# per list in A035513
foreach my $elem ([ 'A000045', 0, extra_initial=>[0,1] ], # X axis Fibonaccis
[ 'A006355', 2, extra_initial=>[1,0,2,2,4] ],
[ 'A022086', 3, extra_initial=>[0,3,3,6] ],
[ 'A022087', 4, extra_initial=>[0,4,4,8] ],
[ 'A000285', 5, extra_initial=>[1,4,5,9] ],
[ 'A022095', 6, extra_initial=>[1,5,6,11] ],
# sum of Fibonacci and Lucas numbers
[ 'A013655', 7, extra_initial=>[3,2,5,7,12] ],
[ 'A022112', 8, extra_initial=>[2,6,8,14] ],
[ 'A022113', 9, extra_initial=>[2,7,9,16] ],
[ 'A022120', 10, extra_initial=>[3,7,10,17] ],
[ 'A022121', 11, extra_initial=>[3,8,11,19] ],
[ 'A022379', 12, extra_initial=>[3,9,12,21] ],
[ 'A022130', 13, extra_initial=>[4,9,13,22] ],
[ 'A022382', 14, extra_initial=>[4,10,14,24] ],
[ 'A022088', 15, extra_initial=>[0,5,5,10,15,25] ],
[ 'A022136', 16, extra_initial=>[5,11,16,27] ],
[ 'A022137', 17, extra_initial=>[5,12,17,29] ],
[ 'A022089', 18, extra_initial=>[0,6,6,12,18,30] ],
[ 'A022388', 19, extra_initial=>[6,13,19,32] ],
[ 'A022096', 20, extra_initial=>[1,6,7,13,20,33] ],
[ 'A022090', 21, extra_initial=>[0,7,7,14,21,35] ],
[ 'A022389', 22, extra_initial=>[7,15,22,37] ],
[ 'A022097', 23, extra_initial=>[1,7,8,15,23,38] ],
[ 'A022091', 24, extra_initial=>[0,8,8,16,24,40] ],
[ 'A022390', 25, extra_initial=>[8,17,25,42] ],
[ 'A022098', 26, extra_initial=>[1,8,9,17,26,43], ],
[ 'A022092', 27, extra_initial=>[0,9,9,18,27,45], ],
) {
my ($anum, $y, %options) = @$elem;
MyOEIS::compare_values
(anum => $anum,
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = @{$options{'extra_initial'}||[]};
for (my $x = Math::BigInt->new(0); @got < $count; $x++) {
push @got, $path->xy_to_n ($x, $y);
}
return \@got;
});
}
#------------------------------------------------------------------------------
# A064274 -- inverse perm of by diagonals up from X axis
MyOEIS::compare_values
(anum => 'A064274',
func => sub {
my ($count) = @_;
my $diagonals = Math::PlanePath::Diagonals->new (direction => 'up');
my $wythoff = Math::PlanePath::WythoffArray->new;
my @got = (0); # extra 0
for (my $n = $diagonals->n_start; @got < $count; $n++) {
my ($x, $y) = $wythoff->n_to_xy ($n);
$x = Math::BigInt->new($x);
$y = Math::BigInt->new($y);
push @got, $diagonals->xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A003849 -- Fibonacci word
MyOEIS::compare_values
(anum => 'A003849',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = (0);
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
push @got, ($x == 0 ? 1 : 0);
}
return \@got;
});
#------------------------------------------------------------------------------
# A000201 -- N+1 for N not on Y axis, spectrum of phi
MyOEIS::compare_values
(anum => 'A000201',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = (1);
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
if ($x != 0) {
push @got, $n+1;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A022342 -- N not on Y axis, even Zeckendorfs
MyOEIS::compare_values
(anum => 'A022342',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got = (0);
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
if ($x != 0) {
push @got, $n;
}
}
return \@got;
});
#------------------------------------------------------------------------------
# A001950 -- N+1 of the N's on Y axis, spectrum
MyOEIS::compare_values
(anum => 'A001950',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::WythoffArray->new;
my @got;
for (my $y = 0; @got < $count; $y++) {
my $n = $path->xy_to_n(0,$y);
push @got, $n+1;
}
return \@got;
});
#------------------------------------------------------------------------------
# A083412 -- by diagonals, down from Y axis
MyOEIS::compare_values
(anum => 'A083412',
func => sub {
my ($count) = @_;
my $diagonals = Math::PlanePath::Diagonals->new (direction => 'down');
my $wythoff = Math::PlanePath::WythoffArray->new;
my @got;
for (my $n = $diagonals->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonals->n_to_xy ($n);
push @got, $wythoff->xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A035513 -- by diagonals, up from X axis
MyOEIS::compare_values
(anum => 'A035513',
func => sub {
my ($count) = @_;
my $diagonals = Math::PlanePath::Diagonals->new (direction => 'up');
my $wythoff = Math::PlanePath::WythoffArray->new;
my @got;
for (my $n = $diagonals->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonals->n_to_xy ($n);
$x = Math::BigInt->new($x);
$y = Math::BigInt->new($y);
push @got, $wythoff->xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/oeis/TerdragonCurve-oeis.t 0000644 0001750 0001750 00000047356 13774702041 017400 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see 'A309952',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::GrayCode->new (apply_type => 'Ts');
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
push @got, $x;
}
return \@got;
});
#------------------------------------------------------------------------------
# A064706 - binary reflected Gray twice
#
# (n XOR n>>1) XOR (n XOR n>>1) >> 1
# = n XOR n>>1 XOR n>>1 XOR n>>2
# = n XOR n>>2
MyOEIS::compare_values
(anum => 'A064706',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, to_Gray_reflected(to_Gray_reflected($n,2),2);
}
return \@got;
});
# A064707 - binary reflected UnGray twice
MyOEIS::compare_values
(anum => 'A064707',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, from_Gray_reflected(from_Gray_reflected($n,2),2);
}
return \@got;
});
# GP-DEFINE \\ A003188
# GP-DEFINE binary_reflected_Gray(n) = bitxor(n,n>>1);
#
# GP-DEFINE \\ A006068
# GP-DEFINE binary_reflected_UnGray(g) = {
# GP-DEFINE my(v=binary(g),r=0);
# GP-DEFINE for(i=2,#v, \\ high to low
# GP-DEFINE v[i] = bitxor(v[i],v[i-1]));
# GP-DEFINE fromdigits(v,2);
# GP-DEFINE }
# my(v=OEIS_samples("A006068")); vector(#v,n,n--; binary_reflected_UnGray(n)) == v \\ OFFSET=0
# my(g=OEIS_bfile_gf("A006068")); g==Polrev(vector(poldegree(g)+1,n,n--;binary_reflected_UnGray(n)))
# poldegree(OEIS_bfile_gf("A006068"))
#
# GP-DEFINE \\ double binary Gray
# GP-DEFINE A064706(n) = binary_reflected_Gray(binary_reflected_Gray(n));
# my(v=OEIS_samples("A064706")); vector(#v,n,n--; A064706(n)) == v \\ OFFSET=0
# my(g=OEIS_bfile_gf("A064706")); g==Polrev(vector(poldegree(g)+1,n,n--;A064706(n)))
# poldegree(OEIS_bfile_gf("A064706"))
# GP-DEFINE \\ double binary UnGray
# GP-DEFINE A064707(n) = {
# GP-DEFINE my(v=binary(n));
# GP-DEFINE for(i=3,#v,v[i]=bitxor(v[i],v[i-2]));
# GP-DEFINE fromdigits(v,2);
# GP-DEFINE }
# my(v=OEIS_samples("A064707")); vector(#v,n,n--; A064707(n)) == v \\ OFFSET=0
# my(g=OEIS_bfile_gf("A064707")); g==Polrev(vector(poldegree(g)+1,n,n--;A064707(n)))
# poldegree(OEIS_bfile_gf("A064707"))
# GP-Test vector(2^14,n,n--; A064707(A064706(n))) == \
# GP-Test vector(2^14,n,n--; n)
# GP-Test vector(2^14,n,n--; A064706(A064707(n))) == \
# GP-Test vector(2^14,n,n--; n)
#
# GP-Test /* by shifts like Jorg and Paul D. Hanna in UnGray A006068 */ \
# GP-Test /* bit lengths of ops 1 + 2 + ... + 2^log(nlen) */ \
# GP-Test /* so linear in nlen rounded up to next power of 2 */ \
# GP-Test vector(2^14,n,n--; A064707(n)) == \
# GP-Test vector(2^14,n,n--; \
# GP-Test my(s=1,ns); while(ns=n>>(s<<=1), n=bitxor(n,ns)); n)
#
# GP-DEFINE extract_even_bits(n) = fromdigits(digits(n,4)%2,2);
# GP-DEFINE extract_odd_bits(n) = fromdigits(digits(n,4)>>1,2);
# GP-DEFINE spread_even_bits(n) = fromdigits(digits(n,2),4);
# GP-DEFINE spread_odd_bits(n) = fromdigits(digits(n,2)<<1,4);
# GP-Test /* double binary Gray as applied to evens and odds separately */ \
# GP-Test /* per Antti Karttunen formula in A064706 */ \
# GP-Test vector(2^14,n,n--; A064707(n)) == \
# GP-Test vector(2^14,n,n--; \
# GP-Test my(e=extract_even_bits(n)); \
# GP-Test my(o=extract_odd_bits(n)); \
# GP-Test e=binary_reflected_UnGray(e); \
# GP-Test o=binary_reflected_UnGray(o); \
# GP-Test spread_even_bits(e) + spread_odd_bits(o))
#------------------------------------------------------------------------------
# A098488 - decimal modular Gray
MyOEIS::compare_values
(anum => 'A098488',
func => sub {
my ($count) = @_;
my $radix = 10;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# A226134 - decimal modular UnGray
MyOEIS::compare_values
(anum => 'A226134',
func => sub {
my ($count) = @_;
my $radix = 10;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# GP-DEFINE A098488(n) = my(v=digits(n)); forstep(i=#v,2,-1, v[i]=(v[i]-v[i-1])%10); fromdigits(v);
#
# GP-Test /* Martin Cohn, example 4 Gray column */ \
# GP-Test my(want=[6764,6765,6766,6767,6768,6769,6760, \
# GP-Test 6860,6861,6862,6863,6864,6865], \
# GP-Test lo=6393, hi=6405); \
# GP-Test for(n=lo,hi, my(i=n-lo+1); \
# GP-Test A098488(n) == want[i] || error()); \
# GP-Test 1
# GP-Test /* Martin Cohn, example 4 matrix, for any 4-digit number */ \
# GP-Test my(m=[1,9,0,0; 0,1,9,0; 0,0,1,9; 0,0,0,1]); \
# GP-Test forvec(v=vector(4,i, [0,9]), \
# GP-Test A098488(fromdigits(v)) == fromdigits((v*m)%10) || error(v*m)); \
# GP-Test 1
# GP-DEFINE to_Gray(n,base) = {
# GP-DEFINE my(v=digits(n,base));
# GP-DEFINE forstep(i=#v,2,-1, v[i]=(v[i]-v[i-1])%base);
# GP-DEFINE fromdigits(v,base);
# GP-DEFINE }
# GP-Test vector(10^5,n,n--; A098488(n)) == \
# GP-Test vector(10^5,n,n--; to_Gray(n,10))
# vector(10^5,n,n--; to_Gray(n,10))
#------------------------------------------------------------------------------
# A007913 -- square free part of N
# mod 2 skip N even is Left turns
MyOEIS::compare_values
(anum => q{A007913}, # not xreffed in GrayCode.pm
fixup => sub {
my ($bvalues) = @_;
foreach (@$bvalues) { $_ %= 2; }
},
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'NotStraight');
my @got;
while (@got < $count) {
my ($n,$value) = $seq->next;
my ($n2,$value2) = $seq->next; # undouble
push @got, $value;
$value==$value2 || die "oops";
}
return \@got;
});
#------------------------------------------------------------------------------
# A065882 -- low base4 non-zero digit
# mod 2 is NotStraight
MyOEIS::compare_values
(anum => 'A065882',
fixup => sub {
my ($bvalues) = @_;
foreach (@$bvalues) { $_ %= 2; }
},
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'NotStraight');
my @got;
while (@got < $count) {
my ($n,$value) = $seq->next;
my ($n2,$value2) = $seq->next; # undouble
push @got, $value;
$value==$value2 || die "oops";
}
return \@got;
});
#------------------------------------------------------------------------------
# A003159 -- (N+1)/2 of positions of Left turns
MyOEIS::compare_values
(anum => 'A003159',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'NotStraight');
my @got;
while (@got < $count) {
my ($n,$value) = $seq->next;
my ($n2,$value2) = $seq->next; # undouble
if ($value) { push @got, ($n+1)/2; }
$value==$value2 || die "oops";
}
return \@got;
});
# A036554 -- (N+1)/2 of positions of Straight turns
MyOEIS::compare_values
(anum => 'A036554',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'Straight');
my @got;
while (@got < $count) {
my ($n,$value) = $seq->next; # undouble
my ($n2,$value2) = $seq->next;
$value==$value2 || die "oops";
if ($value) { push @got, ($n+1)/2; }
}
return \@got;
});
#------------------------------------------------------------------------------
# A039963 -- Left turns
MyOEIS::compare_values
(anum => 'A039963',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'Left');
my @got;
while (@got < $count) {
my ($i,$value) = $seq->next;
push @got, $value;
}
return \@got;
});
# A035263 -- Left turns undoubled, skip N even
MyOEIS::compare_values
(anum => 'A035263',
func => sub {
my ($count) = @_;
my $seq = Math::NumSeq::PlanePathTurn->new (planepath => 'GrayCode',
turn_type => 'Left');
my @got;
while (@got < $count) {
my ($i,$value) = $seq->next;
push @got, $value;
my ($i2,$value2) = $seq->next; # undouble
$value==$value2 || die "oops";
}
return \@got;
});
#------------------------------------------------------------------------------
# A003188 -- Gray code radix=2 is ZOrder X,Y -> Gray TsF
# and Gray FsT X,Y -> ZOrder
MyOEIS::compare_values
(anum => 'A003188',
func => sub {
my ($count) = @_;
require Math::PlanePath::ZOrderCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'TsF');
my $zorder_path = Math::PlanePath::ZOrderCurve->new;
my @got;
for (my $n = $zorder_path->n_start; @got < $count; $n++) {
my ($x, $y) = $zorder_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A003188},
func => sub {
my ($count) = @_;
require Math::PlanePath::ZOrderCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'FsT');
my $zorder_path = Math::PlanePath::ZOrderCurve->new;
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my ($x, $y) = $gray_path->n_to_xy ($n);
my $n = $zorder_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A006068 -- UnGray, inverse Gray TsT X,Y -> ZOrder N
# and ZOrder X,Y -> Gray FsF
MyOEIS::compare_values
(anum => q{A006068},
func => sub {
my ($count) = @_;
require Math::PlanePath::ZOrderCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'TsF');
my $zorder_path = Math::PlanePath::ZOrderCurve->new;
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my ($x, $y) = $gray_path->n_to_xy ($n);
my $n = $zorder_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
# A006068 -- UnGray, ZOrder X,Y -> Gray FsT N
MyOEIS::compare_values
(anum => q{A006068},
func => sub {
my ($count) = @_;
require Math::PlanePath::ZOrderCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'FsT');
my $zorder_path = Math::PlanePath::ZOrderCurve->new;
my @got;
for (my $n = $zorder_path->n_start; @got < $count; $n++) {
my ($x, $y) = $zorder_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A064707 -- permutation radix=2 TsF -> FsT
# inverse square of A003188 Gray code
# A064706 -- permutation radix=2 FsT -> TsF
# square of A003188 Gray code ZOrder->TsF
# not same as A100281,A100282
MyOEIS::compare_values
(anum => q{A064707},
func => sub {
my ($count) = @_;
my $TsF_path = Math::PlanePath::GrayCode->new (apply_type => 'TsF');
my $FsT_path = Math::PlanePath::GrayCode->new (apply_type => 'FsT');
my @got;
for (my $n = $TsF_path->n_start; @got < $count; $n++) {
my ($x, $y) = $TsF_path->n_to_xy ($n);
my $n = $FsT_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A064706},
func => sub {
my ($count) = @_;
my $TsF_path = Math::PlanePath::GrayCode->new (apply_type => 'TsF');
my $FsT_path = Math::PlanePath::GrayCode->new (apply_type => 'FsT');
my @got;
for (my $n = $FsT_path->n_start; @got < $count; $n++) {
my ($x, $y) = $FsT_path->n_to_xy ($n);
my $n = $TsF_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
# {
# my $seq = Math::NumSeq::OEIS->new(anum=>'A099896');
# sub A100281_by_twice {
# my ($i) = @_;
# $i = $seq->ith($i);
# if (defined $i) { $i = $seq->ith($i); }
# return $i;
# }
# }
# sub A100281_by_func {
# my ($i) = @_;
# $i = ($i ^ ($i>>1) ^ ($i>>2));
# $i = ($i ^ ($i>>1) ^ ($i>>2));
# return $i;
# }
#------------------------------------------------------------------------------
# A099896 -- permutation Peano radix=2 -> Gray sF, from N=1 onwards
# n XOR [n/2] XOR [n/4]
# 1, 3, 2, 7, 6, 4, 5, 14, 15, 13, 12, 9, 8, 10, 11, 28, 29, 31, 30, 27,
# to_gray = n xor n/2
# PeanoCurve radix=2
#
# 54--55 49--48 43--42 44--45 64--65 71--70 93--92 90--91 493-492
# | | | | | | | | |
# 53--52 50--51 40--41 47--46 67--66 68--69 94--95 89--88 494-495
#
# 56--57 63--62 37--36 34--35 78--79 73--72 83--82 84--85 483-482
# | | | | | | | | |
# 59--58 60--61 38--39 33--32 77--76 74--75 80--81 87--86 480-481
#
# 13--12 10--11 16--17 23--22 123-122 124-125 102-103 97--96 470-471
# | | | | | | | | |
# 14--15 9-- 8 19--18 20--21 120-121 127-126 101-100 98--99 469-468
#
# 3-- 2 4-- 5 30--31 25--24 117-116 114-115 104-105 111-110 472-473
# | | | | | | | | |
# 0-- 1 7-- 6 29--28 26--27 118-119 113-112 107-106 108-109 475-474
# apply_type => "sF"
#
# 7 | 32--33 37--36 52--53 49--48
# | / \ / \
# 6 | 34--35 39--38 54--55 51--50
# |
# 5 | 42--43 47--46 62--63 59--58
# | \ / \ /
# 4 | 40--41 45--44 60--61 57--56
# |
# 3 | 8-- 9 13--12 28--29 25--24
# | / \ / \
# 2 | 10--11 15--14 30--31 27--26
# |
# 1 | 2-- 3 7-- 6 22--23 19--18
# | \ / \ /
# Y=0 | 0-- 1 5-- 4 20--21 17--16
# |
# +---------------------------------
# X=0 1 2 3 4 5 6 7
MyOEIS::compare_values
(anum => 'A099896',
func => sub {
my ($count) = @_;
require Math::PlanePath::PeanoCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $peano_path = Math::PlanePath::PeanoCurve->new (radix => 2);
my @got;
for (my $n = 1; @got < $count; $n++) {
my ($x, $y) = $peano_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
# A100280 -- inverse
MyOEIS::compare_values
(anum => 'A100280',
func => sub {
my ($count) = @_;
require Math::PlanePath::PeanoCurve;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $peano_path = Math::PlanePath::PeanoCurve->new (radix => 2);
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my ($x, $y) = $gray_path->n_to_xy ($n);
my $n = $peano_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163233 -- permutation diagonals sF
MyOEIS::compare_values
(anum => 'A163233',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $n = $diagonal_path->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonal_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
# A163234 -- diagonals sF inverse
MyOEIS::compare_values
(anum => 'A163234',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'up',
n_start => 0);
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my ($x, $y) = $gray_path->n_to_xy ($n);
my $n = $diagonal_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163235 -- diagonals sF, opposite side start
MyOEIS::compare_values
(anum => 'A163235',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'down');
my @got;
for (my $n = $diagonal_path->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonal_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
push @got, $n;
}
return \@got;
});
# A163236 -- diagonals sF inverse, opposite side start
MyOEIS::compare_values
(anum => 'A163236',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'down');
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my ($x, $y) = $gray_path->n_to_xy ($n);
my $n = $diagonal_path->xy_to_n ($x, $y);
push @got, $n + $gray_path->n_start - $diagonal_path->n_start;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163237 -- diagonals sF, same side start, flip base-4 digits 2,3
sub flip_base4_23 {
my ($n) = @_;
my @digits = digit_split_lowtohigh($n,4);
foreach my $digit (@digits) {
if ($digit == 2) { $digit = 3; }
elsif ($digit == 3) { $digit = 2; }
}
return digit_join_lowtohigh(\@digits,4);
}
MyOEIS::compare_values
(anum => 'A163237',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $n = $diagonal_path->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonal_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
$n = flip_base4_23($n);
push @got, $n;
}
return \@got;
});
# A163238 -- inverse
MyOEIS::compare_values
(anum => 'A163238',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'up');
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my $n = flip_base4_23($n);
my ($x, $y) = $gray_path->n_to_xy ($n);
$n = $diagonal_path->xy_to_n ($x, $y);
push @got, $n + $gray_path->n_start - $diagonal_path->n_start;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163239 -- diagonals sF, opposite side start, flip base-4 digits 2,3
MyOEIS::compare_values
(anum => 'A163239',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'down');
my @got;
for (my $n = $diagonal_path->n_start; @got < $count; $n++) {
my ($x, $y) = $diagonal_path->n_to_xy ($n);
my $n = $gray_path->xy_to_n ($x, $y);
$n = flip_base4_23($n);
push @got, $n;
}
return \@got;
});
# A163240 -- inverse
MyOEIS::compare_values
(anum => 'A163240',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my $diagonal_path = Math::PlanePath::Diagonals->new (direction => 'down');
my @got;
for (my $n = $gray_path->n_start; @got < $count; $n++) {
my $n = flip_base4_23($n);
my ($x, $y) = $gray_path->n_to_xy ($n);
$n = $diagonal_path->xy_to_n ($x, $y);
push @got, $n + $gray_path->n_start - $diagonal_path->n_start;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163242 -- sF diagonal sums
MyOEIS::compare_values
(anum => 'A163242',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my @got;
for (my $y = 0; @got < $count; $y++) {
my $sum = 0;
foreach my $i (0 .. $y) {
$sum += $gray_path->xy_to_n ($i, $y-$i);
}
push @got, $sum;
}
return \@got;
});
#------------------------------------------------------------------------------
# A163478 -- sF diagonal sums, divided by 3
MyOEIS::compare_values
(anum => 'A163478',
func => sub {
my ($count) = @_;
my $gray_path = Math::PlanePath::GrayCode->new (apply_type => 'sF');
my @got;
for (my $y = 0; @got < $count; $y++) {
my $sum = 0;
foreach my $i (0 .. $y) {
$sum += $gray_path->xy_to_n ($i, $y-$i);
}
push @got, $sum / 3;
}
return \@got;
});
#------------------------------------------------------------------------------
# A003188 - binary reflected Gray
# modular and reflected same in binary
MyOEIS::compare_values
(anum => 'A003188',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, to_Gray_reflected($n,2);
}
return \@got;
});
MyOEIS::compare_values
(anum => 'A003188',
func => sub {
my ($count) = @_;
my $radix = 2;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# A014550 - binary Gray reflected, in binary
MyOEIS::compare_values
(anum => 'A014550',
func => sub {
my ($count) = @_;
my $radix = 2;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,10);
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A014550},
func => sub {
my ($count) = @_;
my $radix = 2;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,10);
}
return \@got;
});
# A006068 - binary Gray reflected inverse
MyOEIS::compare_values
(anum => q{A006068},
func => sub {
my ($count) = @_;
my $radix = 2;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A006068},
func => sub {
my ($count) = @_;
my $radix = 2;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# binary reflected Gray code increments
# lowest 1-bit of N, and negate if bit above it is a 1
MyOEIS::compare_values
(anum => 'A055975',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 1; @got < $count; $n++) {
push @got, to_Gray_reflected($n,2) - to_Gray_reflected($n-1,2);
}
return \@got;
});
# A119972 - signed n according as binary reflected Gray code increment negative
# dragon curve turn(n) * n
MyOEIS::compare_values
(anum => 'A119972',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 1; @got < $count; $n++) {
push @got,
to_Gray_reflected($n,2) > to_Gray_reflected($n-1,2)
? $n : -$n;
}
return \@got;
});
# A119974 - insert 0s into A119972 ...
# https://oeis.org/A119974/table
#
# A220466 - something bit wise crossreffed from increments A055975 ...
#------------------------------------------------------------------------------
# A105530 - ternary Gray modular
MyOEIS::compare_values
(anum => 'A105530',
func => sub {
my ($count) = @_;
my $radix = 3;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# A105529 - ternary Gray modular inverse
MyOEIS::compare_values
(anum => 'A105529',
func => sub {
my ($count) = @_;
my $radix = 3;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_modular($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# GP-DEFINE A105530(n) = my(v=digits(n,3)); forstep(i=#v,2,-1, v[i]=(v[i]-v[i-1])%3); fromdigits(v,3);
# my(v=OEIS_samples("A105530")); vector(#v,n,n--; A105530(n)) == v \\ OFFSET=0
# my(g=OEIS_bfile_gf("A105530")); g==Polrev(vector(poldegree(g)+1,n,n--;A105530(n)))
# poldegree(OEIS_bfile_gf("A105530"))
# GP-Test vector(3^5,n,n--; A105530(n)) == \
# GP-Test vector(3^5,n,n--; to_Gray(n,3))
# vector(20,n, to_Gray(n,4))
# vector(20,n, to_Gray(n,5))
# not in OEIS: 1, 2, 3, 7, 4, 5, 6, 10, 11, 8, 9, 13, 14, 15, 12, 28, 29, 30, 31, 19
# not in OEIS: 1, 2, 3, 4, 9, 5, 6, 7, 8, 13, 14, 10, 11, 12, 17, 18, 19, 15, 16, 21
#------------------------------------------------------------------------------
# A128173 - ternary Gray reflected
# odd radix to and from are the same
MyOEIS::compare_values
(anum => 'A128173',
func => sub {
my ($count) = @_;
my $radix = 3;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
MyOEIS::compare_values
(anum => q{A128173},
func => sub {
my ($count) = @_;
my $radix = 3;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# GP-DEFINE \\ mine in A128173
# GP-DEFINE ternary_reflected_Gray(n) = {
# GP-DEFINE my(v=digits(n,3),r=Mod(0,2));
# GP-DEFINE for(i=1,#v, if(r,v[i]=2-v[i]); r+=v[i]); fromdigits(v,3);
# GP-DEFINE }
# GP-DEFINE A128173 = ternary_reflected_Gray;
# GP-Test my(v=OEIS_samples("A128173")); /* OFFSET=0 */ \
# GP-Test vector(#v,n,n--; A128173(n)) == v
# my(g=OEIS_bfile_gf("A128173")); \
# g==Polrev(vector(poldegree(g)+1,n,n--; A128173(n)))
# poldegree(OEIS_bfile_gf("A128173"))
#------------------------------------------------------------------------------
# A003100 - decimal Gray reflected
MyOEIS::compare_values
(anum => 'A003100',
func => sub {
my ($count) = @_;
my $radix = 10;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_to_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
# A174025 - decimal Gray reflected inverse
MyOEIS::compare_values
(anum => 'A174025',
func => sub {
my ($count) = @_;
my $radix = 10;
my @got;
for (my $n = 0; @got < $count; $n++) {
my $digits = [ digit_split_lowtohigh($n,$radix) ];
Math::PlanePath::GrayCode::_digits_from_gray_reflected($digits,$radix);
push @got, digit_join_lowtohigh($digits,$radix);
}
return \@got;
});
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/oeis/SierpinskiCurve-oeis.t 0000644 0001750 0001750 00000005662 13474706343 017573 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012, 2013, 2018, 2019 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see }; # slurp
close FH or die "Error closing $filename: $!";
return scalar ($content =~ /F<\Q$example\E>
|F\s+directory
/xs);
}
sub raw_contains_example {
my ($filename, $example) = @_;
$example =~ s{^examples/}{};
open FH, "< $filename" or die "Cannot open $filename: $!";
my $ret = scalar (grep /\b\Q$example\E\b/, );
close FH or die "Error closing $filename: $!";
return $ret > 0;
}
plan tests => scalar(@example_files) + 1;
my $example;
foreach $example (@example_files) {
is (any_file_contains_example($example), 1,
"$example mentioned in some lib/ file");
}
ok(1);
exit 0;
Math-PlanePath-129/xt/PlanePath-subclasses.t 0000644 0001750 0001750 00000333754 13774317315 016601 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see \d+) +level=(?\d+)/mg) {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"level=$level"} = $+{'id'};
}
ok ($count, 4, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 4);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
# 5^4 == 625
foreach my $level (0 .. 4) {
my $graph = make_graph($level);
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
if (MyGraphs::hog_grep($g6_str)) {
$others++;
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
ok ($extras, 0);
ok ($others, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/AlternatePaper-hog.t 0000644 0001750 0001750 00000007214 13774712350 016225 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2019, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see \d+) +level=(?\d+)/mg) {
$count++;
my $id = $+{'id'};
my $level = $+{'level'};
$shown{"level=$level"} = $+{'id'};
}
ok ($count, 9, 'HOG ID number of lines');
}
ok (scalar(keys %shown), 9);
### %shown
my $extras = 0;
my $compared = 0;
my $others = 0;
my %seen;
foreach my $level (0 .. 9) {
my $graph = make_graph($level);
last if $graph->vertices >= 256;
my $g6_str = MyGraphs::Graph_to_graph6_str($graph);
$g6_str = MyGraphs::graph6_str_to_canonical($g6_str);
next if $seen{$g6_str}++;
my $key = "level=$level";
if (my $id = $shown{$key}) {
MyGraphs::hog_compare($id, $g6_str);
$compared++;
} else {
$others++;
if (MyGraphs::hog_grep($g6_str)) {
MyTestHelpers::diag ("HOG $key in HOG, not shown in POD");
my $name = $graph->get_graph_attribute('name');
MyTestHelpers::diag ($name);
MyTestHelpers::diag ($g6_str);
# MyGraphs::Graph_view($graph);
$extras++;
}
}
}
ok ($extras, 0);
ok ($others, 0);
MyTestHelpers::diag ("POD HOG $compared compares, $others others");
}
#------------------------------------------------------------------------------
# A086341 - Graph Diameter, k>=3
MyOEIS::compare_values
(anum => 'A086341',
max_count => 8,
func => sub {
my ($count) = @_;
my @got;
for (my $k = 0; @got < $count; $k++) {
my $graph = make_graph($k);
my $got= $graph->diameter;
if ($k==1) { $got == 2 or die; $got = 3; } # exceptions
if ($k==2) { $got == 4 or die; $got = 3; }
push @got, $got;
}
return \@got;
});
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/PixelRings-image.t 0000644 0001750 0001750 00000010613 12136177167 015706 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012, 2013 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see >1);
# GP-Test my(v=OEIS_samples("A003188")); \
# GP-Test v == vector(#v,n,n--; Gray(n)) /* OFFSET=0 */
# GP-DEFINE A099891(n,k) = my(B=0); for(i=0,k, if(binomial(k,i)%2, B=bitxor(B,Gray(n-i)))); B;
# GP-Test my(v=OEIS_samples("A099891"),l=List()); \
# GP-Test for(n=0,#v, for(k=0,n, if(#l>=#v,break(2)); listput(l,A099891(n,k)))); \
# GP-Test v == Vec(l)
#--
# second column k=1
# GP-Test /* my formula */ \
# GP-Test vector(256,n, A099891(n,1)) == \
# GP-Test vector(256,n, A006519(n))
# GP-Test vector(256,n, A099891(n,1)) == \
# GP-Test vector(256,n, bitxor(Gray(n),Gray(n-1)))
# GP-Test vector(256,n, A099891(n,1)) == \
# GP-Test vector(256,n, bitxor(bitxor(n,n-1), bitxor(n,n-1)>>1))
# GP-Test /* bitxor(n,n-1) changed bits by increment */ \
# GP-Test vector(256,n, bitxor(n,n-1)) == \
# GP-Test vector(256,n, 2*LowOneBit(n)-1)
# GP-Test vector(256,n, bitxor(n,n-1)>>1) == \
# GP-Test vector(256,n, LowOneBit(n)-1)
#
# GP-Test vector(256,n, A099891(n,1)) == \
# GP-Test vector(256,n, Gray(2*LowOneBit(n)-1))
#
# GP-Test my(v=OEIS_samples("A099892")); v == vector(#v,n,n--; A099891(n,n))
# Sierpinski triangle patterns of each bit, until 0s past column 2^k
#
# for(n=0,64, for(k=0,n, printf(" %2d",A099891(n,k))); print());
# for(n=0,20, for(k=0,n, printf(" %d",A099891(n,k)%2)); print());
# for(n=0,64, for(k=0,n, printf(" %s",if(bitand(A099891(n,k),8),8,"."))); print());
# vector(20,n,n++; A099891(n,n-1))
# not in OEIS: 2, 3, 6, 6, 0, 0, 12, 12, 0, 0, 0, 0, 0, 0, 24, 24, 0, 0, 0, 0
# vector(20,n,n++; A099891(n,2))
# not in OEIS: 3, 3, 5, 5, 3, 3, 9, 9, 3, 3, 5, 5, 3, 3, 17, 17, 3, 3, 5, 5
#------------------------------------------------------------------------------
# A064706 - binary Gray twice
# which is n XOR n>>2
MyOEIS::compare_values
(anum => 'A064706',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, to_binary_gray(to_binary_gray($n));
}
return \@got;
});
#------------------------------------------------------------------------------
# A055975 - binary Gray increments
MyOEIS::compare_values
(anum => 'A055975',
func => sub {
my ($count) = @_;
my @got;
for (my $n = 0; @got < $count; $n++) {
push @got, to_binary_gray($n+1) - to_binary_gray($n);
}
return \@got;
});
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/xt/DragonCurve-more.t 0000644 0001750 0001750 00000005334 13475604706 015726 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2012, 2013, 2018, 2019 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see ',
LICENSE => 'gpl_3',
SIGN => 1,
MIN_PERL_VERSION => '5.004',
META_MERGE =>
{ 'meta-spec' => { version => 2 },
resources =>
{ homepage => 'http://user42.tuxfamily.org/math-planepath/index.html',
license => 'http://www.gnu.org/licenses/gpl.html',
},
no_index => { directory=>['devel','xt'],
# these are in Math-PlanePath-Toothpick but added to by
# Math::NumSeq::PlanePathCoord here
package => [ 'Math::PlanePath::ToothpickTree',
'Math::PlanePath::ToothpickReplicate',
'Math::PlanePath::ToothpickUpist',
'Math::PlanePath::LCornerTree',
'Math::PlanePath::LCornerReplicate',
'Math::PlanePath::OneOfEight',
],
},
prereqs =>
{ test =>
{ suggests =>
{
# have "make test" do as much as possible
'Data::Float' => 0,
'Math::BigInt' => 0,
'Math::BigInt::Lite' => 0,
'Math::BigFloat' => '1.993',
'Math::BigRat' => 0,
'Number::Fraction' => 0,
},
},
},
},
);
Math-PlanePath-129/examples/ 0002755 0001750 0001750 00000000000 14001441522 013517 5 ustar gg gg Math-PlanePath-129/examples/knights-oeis.pl 0000755 0001750 0001750 00000003560 12041154023 016464 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see
Koch Snowflake level $level
HERE
# factor to make equilateral triangles from the integer Y out of KochSnowflakes
my $y_equilateral = sqrt(3);
my $path_width = 2 * 3**$level;
my $path_height = 2 * (2/3) * 3**$level * $y_equilateral;
my $scale = 0.9 * min ($width / $path_width,
$height / $path_height);
my $linewidth = 1/$level;
# N range for $level, per KochSnowflakes POD
my $n_lo = 4**$level;
my $n_hi = 4**($level+1) - 1;
my $points = '';
foreach my $n ($n_lo .. $n_hi) {
my ($x, $y) = $path->n_to_xy($n);
$x *= $scale;
$y *= $scale;
$y *= $y_equilateral;
$points .= "\n $x, $y";
}
print <<"HERE"
HERE
Math-PlanePath-129/examples/ulam-spiral-xpm.pl 0000755 0001750 0001750 00000006005 12041155744 017120 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see =0 && ((y+x)%2)==0 && ((y+x)&(y-x))==0 ? "*" : " ")
# Return a string which is row y of the triangle from character
# position x through to the right hand end x==y, inclusive.
row(x,y) = (x<=y ? char(x,y).row(x+1,y) : "\n")
# Return a string of stars, spaces and newlines which is the
# Sierpinski triangle rows from y to limit, inclusive.
# The first row is y=0.
triangle(y,limit) = (y <= limit ? row(-limit,y).triangle(y+1,limit) : "")
# Print rows 0 to 15, which is the order 4.
print triangle(0,15)
exit
Math-PlanePath-129/examples/other/dragon-curve.logo 0000755 0001750 0001750 00000005545 12335526416 020146 0 ustar gg gg #!/usr/bin/ucblogo
; Copyright 2012, 2013, 2014 Kevin Ryde
;
; This file is part of Math-PlanePath.
;
; Math-PlanePath is free software; you can redistribute it and/or modify it
; under the terms of the GNU General Public License as published by the Free
; Software Foundation; either version 3, or (at your option) any later
; version.
;
; Math-PlanePath is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
; for more details.
;
; You should have received a copy of the GNU General Public License along
; with Math-PlanePath. If not, see sub {
require MyFLAT;
require FLAT::Regex;
return FLAT::Regex->new ('((0|1|2)* 0 | []) 1(11)* | (0|1|2)* 2(11)*')->as_dfa
->MyFLAT::minimize
->MyFLAT::set_name("A189707_ternary0");
};
use constant::defer A189708_ternary_flat => sub {
require MyFLAT;
require FLAT::Regex;
return FLAT::Regex->new ('((0|1|2)* 0 | []) (11)* | (0|1|2)* 2 1(11)*')->as_dfa
->MyFLAT::minimize
->MyFLAT::set_name("A189708_ternary0");
};
use constant::defer ternary_any_flat => sub {
require MyFLAT;
require FLAT::Regex;
return FLAT::Regex->new ('(0|1|2)*')->as_dfa
->MyFLAT::minimize
->MyFLAT::set_name("ternary any");
};
A189707_ternary_flat()->union(A189708_ternary_flat())->as_dfa
->equals(ternary_any_flat()) or die;
# MyFLAT::FLAT_show_breadth(A189707_ternary_flat(),3);
# MyFLAT::FLAT_show_breadth(A189708_ternary_flat(),3);
# A189708_ternary_flat()->MyFLAT::reverse->MyFLAT::minimize->MyFLAT::view;
# left = even+even or odd+odd
my $f = FLAT::Regex->new ('(0|2)* (1 (0|2)* 1 (0|2)*)* (1|2) (00)*
| (0|2)* 1 (0|2)* (1 (0|2)* 1 (0|2)*)* (1|2) 0(00)*
')->as_dfa
->MyFLAT::minimize;
$f->MyFLAT::view;
$f->MyFLAT::reverse->MyFLAT::minimize->MyFLAT::view;
require Math::NumSeq::PlanePathTurn;
require Math::BaseCnv;
my $seq = Math::NumSeq::PlanePathTurn->new
(planepath => 'SierpinskiArrowhead',
turn_type => 'Left');
foreach (1 .. 400) {
my ($i, $value) = $seq->next;
my $i3 = Math::BaseCnv::cnv($i,10,3);
my $calc = $f->contains($i3) ? 1 : 0;
my $diff = ($value == $calc ? "" : " ***");
print "$i $i3 $value $calc$diff\n";
}
exit 0;
}
{
# turn sequence
require Math::NumSeq::PlanePathTurn;
require Math::BaseCnv;
my $seq = Math::NumSeq::PlanePathTurn->new
(planepath => 'SierpinskiArrowhead',
turn_type => 'Left');
foreach (1 .. 400) {
my ($i, $value) = $seq->next;
my $i3 = Math::BaseCnv::cnv($i,10,3);
# my $calc = calc_turnleft($i);
my $calc = WORKING__calc_turnleft($i);
my $diff = ($value == $calc ? "" : " ***");
print "$i $i3 $value $calc$diff\n";
}
sub calc_turnleft { # not working
my ($n) = @_;
my $ret = 1;
my $flip = 0;
while ($n && ($n % 9) == 0) {
$n = int($n/9);
}
if ($n) {
my $digit = $n % 9;
my $flip = ($digit == 0
|| $digit == 1 # 01
# || $digit == 3 # 10
|| $digit == 5 # 12
|| $digit == 6 # 20
|| $digit == 7 # 21
);
$ret ^= $flip;
$n = int($n/9);
}
while ($n) {
my $digit = $n % 9;
my $flip = ($digit == 1 # 01
|| $digit == 3 # 10
|| $digit == 5 # 12
|| $digit == 7 # 21
);
$ret ^= $flip;
$n = int($n/9);
}
return $ret;
}
# GP-DEFINE CountLowZeros(n) = valuation(n,3);
# vector(20,n, CountLowZeros(n))
# GP-DEFINE CountLowTwos(n) = my(ret=0); while(n%3==2, n\=3;ret++); ret;
# GP-DEFINE CountLowOnes(n) = my(ret=0); while(n%3==1, n\=3;ret++); ret;
# GP-DEFINE CountOnes(n) = vecsum(apply(d->d==1,digits(n,3)));
# vector(20,n,n--; CountOnes(n))
# GP-DEFINE LowestNonZero(n) = {
# GP-DEFINE if(n<1,error("LowestNonZero() is for n>=1")); \
# GP-DEFINE (n / 3^valuation(n,3)) % 3;
# GP-DEFINE }
# GP-DEFINE LowestNonOne(n) = while((n%3)==1,n=n\3); n%3;
# GP-DEFINE LowestNonTwo(n) = while((n%3)==2,n=n\3); n%3;
# GP-DEFINE CountOnesExceptLowestNonZero(n) = {
# GP-DEFINE while(n && n%3==0, n/=3);
# GP-DEFINE CountOnes(n\3);
# GP-DEFINE }
# vector(20,n,n--; CountOnes(n))
# GP-DEFINE turn_left(n) = ! turn_right(n);
# GP-DEFINE turn_right(n) = (CountOnes(n) + LowestNonZero(n) + CountLowZeros(n)) % 2;
# GP-DEFINE turn_right(n) = (CountOnesExceptLowestNonZero(n) + CountLowZeros(n)) % 2;
# vector(20,n, turn_left(n))
# vector(22,n, turn_right(n))
# vector(15,n, turn_left(n)-turn_right(n))
# not in OEIS: 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1
# not in OEIS: 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0,1,1
# not in OEIS: 1, 1, -1, -1, -1, -1, 1, 1, 1, -1, -1, 1, 1, 1, 1
# at odd and even positions
# vector(15,n, turn_left(2*n)-turn_right(2*n))
# vector(18,n, turn_left(2*n-1)-turn_right(2*n-1))
# not in OEIS: 1, -1, -1, 1, -1, 1, 1, -1, 1, 1, -1, -1, 1, -1, 1
# not in OEIS: 1, -1, -1, 1, 1, -1, 1, 1, -1, 1, -1, -1, 1, -1, -1, 1, 1, -1
# GP-Test vector(1000,m,m--; ((LowestNonOne(m)==0)+CountLowOnes(m))%2) == \
# GP-Test vector(1000,m, turn_left(2*m-1))
# GP-Test vector(1000,m,m--; ((LowestNonOne(m)==2)+CountLowOnes(m))%2) == \
# GP-Test vector(1000,m,m--; turn_right(2*m+1))
# GP-Test vector(1000,m,m--; ((LowestNonTwo(m)==0)+CountLowTwos(m))%2) == \
# GP-Test vector(1000,m, turn_left(2*m))
# GP-Test vector(1000,m,m--; (LowestNonTwo(m)+CountLowTwos(m))%2) == \
# GP-Test vector(1000,m, turn_right(2*m))
# GP-Test vector(1000,m, (LowestNonZero(m)+CountLowZeros(m))%2) == \
# GP-Test vector(1000,m, turn_left(2*m))
# GP-Test vector(1000,n, (n + LowestNonZero(n) + CountLowZeros(n))%2) == \
# GP-Test vector(1000,n, turn_right(n))
# vector(25,n, (1+LowestNonZero(n) + CountLowZeros(n))%2)
# is A189706 with index change low-2s -> low-0s
# ternary
# [ count 1 digits ] [1 or 2] [ count low 0 digits ]
# vector(10,k, (3^k)%2)
# vector(10,k, (2*3^k)%2)
sub WORKING__calc_turnleft { # works
my ($n) = @_;
my $ret = 1;
while ($n && ($n % 3) == 0) {
$ret ^= 1; # flip for trailing 0s
$n = int($n/3);
}
$n = int($n/3); # skip lowest non-0
while ($n) {
if (($n % 3) == 1) { # flip for all 1s
$ret ^= 1;
}
$n = int($n/3);
}
return $ret;
}
sub count_digits {
my ($n) = @_;
my $count = 0;
while ($n) {
$count++;
$n = int($n/3);
}
return $count;
}
sub count_1_digits {
my ($n) = @_;
my $count = 0;
while ($n) {
$count += (($n % 3) == 1);
$n = int($n/3);
}
return $count;
}
exit 0;
}
{
# direction sequence
# 9-17 = mirror image horizontally 3-dir
# 18-26 = dir+2
require Math::NumSeq::PlanePathDelta;
require Math::BaseCnv;
my $seq = Math::NumSeq::PlanePathDelta->new
(planepath => 'SierpinskiArrowhead',
delta_type => 'TDir6');
foreach (1 .. 3**4+1) {
my ($i, $value) = $seq->next;
# $value %= 6;
my $i3 = Math::BaseCnv::cnv($i,10,3);
my $calc = calc_dir6($i);
print "$i $i3 $value $calc\n";
}
sub calc_dir6 { # works
my ($n) = @_;
my $dir = 1;
while ($n) {
if (($n % 9) == 0) {
} elsif (($n % 9) == 1) {
$dir = 3 - $dir;
} elsif (($n % 9) == 2) {
$dir = $dir + 2;
} elsif (($n % 9) == 3) {
$dir = 3 - $dir;
} elsif (($n % 9) == 4) {
} elsif (($n % 9) == 5) {
$dir = 1 - $dir;
} elsif (($n % 9) == 6) {
$dir = $dir - 2;
} elsif (($n % 9) == 7) {
$dir = 1 - $dir;
} elsif (($n % 9) == 8) {
}
$n = int($n/9);
}
return $dir % 6;
}
sub Xcalc_dir6 { # works
my ($n) = @_;
my $dir = 1;
while ($n) {
if (($n % 3) == 0) {
}
if (($n % 3) == 1) {
# mirror
$dir = 3 - $dir;
}
if (($n % 3) == 2) {
$dir = $dir + 2;
}
$n = int($n/3);
if (($n % 3) == 0) {
}
if (($n % 3) == 1) {
# mirror
$dir = 3 - $dir;
}
if (($n % 3) == 2) {
$dir = $dir - 2;
}
$n = int($n/3);
}
return $dir % 6;
}
exit 0;
}
Math-PlanePath-129/devel/koch-squareflakes.pl 0000644 0001750 0001750 00000011740 12375744415 016771 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012, 2013, 2014 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see parse_from_string("TREE_a * (TREE_b / TREE_c)");
# my $pattern = Math::Symbolic::Custom::Pattern->new($formula);
use Math::Symbolic::Custom::Transformation;
my $trafo = Math::Symbolic::Custom::Transformation::Group->new
(',',
'TREE_a * (TREE_b / TREE_c)' => '(TREE_a * TREE_b) / TREE_c',
'TREE_a * (TREE_b + TREE_c)' => 'TREE_a * TREE_b + TREE_a * TREE_c',
'(TREE_b + TREE_c) * TREE_a' => 'TREE_b * TREE_a + TREE_c * TREE_a',
# '(TREE_a / TREE_b) / TREE_c' => 'TREE_a / (TREE_b * TREE_c)',
'(TREE_a / TREE_b) / (TREE_c / TREE_d)'
=> '(TREE_a * TREE_d) / (TREE_b * TREE_c)',
'1 - TREE_a / TREE_b' => '(TREE_b - TREE_a) / TREE_b',
'TREE_a / TREE_b + TREE_c' => '(TREE_a + TREE_b * TREE_c) / TREE_b',
'(TREE_a / TREE_b) * TREE_c' => '(TREE_a * TREE_c) / TREE_b',
'TREE_a - (TREE_b + TREE_c)' => 'TREE_a - TREE_b - TREE_c',
'(TREE_a - TREE_b) - TREE_c' => 'TREE_a - TREE_b - TREE_c',
);
sub simplify {
my $tree = shift;
### simplify(): "$tree"
### traf: ($trafo->apply_recursive($tree)//'').''
return $trafo->apply_recursive($tree) || $tree;
# if (my $m = $pattern->match($tree)) {
# $m = $m->{'trees'};
# ### trees: $m
# ### return: ($m->{'a'} * $m->{'b'}) / $m->{'c'}
# return ($m->{'a'} * $m->{'b'}) / $m->{'c'};
# } else {
# ### no match
# return $tree;
# }
}
__PACKAGE__->register();
}
require Math::Symbolic;
require Math::Symbolic::Derivative;
{
my $t = Math::Symbolic->parse_from_string('1/(x^2+1)');
$t = Math::Symbolic::Derivative::total_derivative($t, 'x');
$t = $t->simplify;
print "$t\n";
exit 0;
}
{
my $a = Math::Symbolic->parse_from_string(
'(x+y)/(1-x*y)'
);
my $z = Math::Symbolic->parse_from_string(
'z'
);
my $t = ($a + $z) / (1 - $a*$z);
$t = $t->simplify;
print $t;
exit 0;
}
}
{
my $path = Math::PlanePath::TheodorusSpiral->new;
my $prev_x = 0;
my $prev_y = 0;
#for (my $n = 10; $n < 100000000; $n = int($n * 1.2)) {
foreach my $n (2000, 2010, 2020, 2010, 2000, 2010, 2000, 2010) {
my ($x,$y) = $path->n_to_xy($n);
my $rsq = $x*$x+$y*$y;
my $dx = $x - $prev_x;
my $dy = $y - $prev_y;
my $dxy_dist = hypot($dx,$dy);
printf "%d %.2f,%.2f %.2f %.4f\n", $n, $x,$y, $rsq, $dxy_dist;
($prev_x, $prev_y) = ($x,$y);
}
exit 0;
}
sub integral {
my ($x) = @_;
print "log ", log(1+$x*$x), " at x=$x\n";
return $x * atan($x) - 0.5 * log (1 + $x*$x);
}
print "integral 0 = ", integral(0), "\n";
print "integral 1 = ", integral(1)/(2*pi()), "\n";
print "atan 1 = ", atan(1)/(2*pi()), "\n";
sub est {
my ($n) = @_;
my $k = $n-1;
if ($k == 0) { return 0; }
my $K = 2.1577829966;
my $root = sqrt($k);
my $a = 2*pi()*pi();
my $radians;
$radians = integral(1/$root); # - integral(0);
# $radians = ($k+1)*atan(1/$root) + $root - 1/($root*$k);
return $radians / (2*pi());
# $radians = 2*$root;
# return $radians / (2*pi());
#
# $radians = $root - atan($root) + $k*atan(1/$root);
# return $radians / (2*pi());
#
# return $k / $a; # revolutions
# return $k / pi();
#
# return 2*$root / $a;
# $radians = 2*sqrt($k+1) + $K + 1/(6*sqrt($k+1)); # plus O(n^(-3/2))
# return 0.5 * $a * ($k * sqrt(1+$k*$k) + log($k + sqrt(1+$k*$k))) / $k;
# return $root + ($k+1)*atan(1/$root);
}
print "est 1 = ", est(1), "\n";
print "est 2 = ", est(2), "\n";
{
require Math::Polynomial;
open OUT, '>', '/tmp/theodorus.data' or die;
my @n;
my @theta;
my $total = 0;
foreach my $n (2 .. 120) {
my $inc = Math::Trig::atan(1/sqrt($n-1)) / (2*pi()); # revs
$total += $inc;
my $est = est($n);
my $diff = $total - $est;
# $diff = 1/$diff;
if ($n > 50) {
push @n, $n-51;
push @theta, $diff;
print OUT "$n $diff\n";
}
print "$n $inc $total $est $diff\n";
}
print "\n";
Math::BigFloat->accuracy(500);
my $p = Math::Polynomial->new; # (Math::BigFloat->new(0));
$p = $p->interpolate(\@n, \@theta);
foreach my $i (0 .. $p->degree) {
print "$i ",$p->coeff($i),"\n";
}
# $p->string_config({ fold_sign => 1,
# variable => 'n' });
# print "theta = $p\n";
close OUT or die;
system "xterm -e 'gnuplot = $next) {
$next++;
my $diff = $n - $prev_n;
my $diff_diff = $diff - $prev_diff;
$total_diff_diff += $diff_diff;
$count_diff_diff++;
print "$n +$diff +$diff_diff $total\n";
if ($next >= 1000) {
last;
}
$prev_n = $n;
$prev_diff = $diff;
}
}
my $avg = $total_diff_diff / $count_diff_diff;
print "average $avg\n";
print "\n";
exit 0;
}
{
my $c2 = 2.15778;
my $t1 = 1.8600250;
my $t2 = 0.43916457;
my $z32 = 2.6123753486;
my $tn1 = 2*$t1 - 2*$t2 - $z32;
my $n = 1;
my $x = 1;
my $y = 0;
while ($n < 10000) {
my $r = sqrt($n); # before increment
($x, $y) = ($x - $y/$r, $y + $x/$r);
$n++;
$r = sqrt($n); # after increment
my $theta = atan2($y,$x);
if ($theta < 0) { $theta += 2*pi(); }
my $root;
$root = 2*sqrt($n) - $c2;
# $root += .01/$r;
# $root = -atan(sqrt($n)) + $n*atan(1/sqrt($n)) + sqrt($n);
# $root = atan(1/sqrt($n)) - pi()/2 + $n*atan(1/sqrt($n)) + sqrt($n);
$root = 2*sqrt($n)
+ 1/sqrt($n)
- $c2
# - 1/($n*sqrt($n))/3
# + 1/($n*$n*sqrt($n))/5
# - 1/($n*$n*sqrt($n))/7
# + 1/($n*$n*$n*sqrt($n))/9
;
# $root = -pi()/4 + Arctan($r);
# foreach my $k (2 .. 1000000) {
# $root += atan(1/sqrt($k)) - atan(1/sqrt($k + $r*$r - 1));
# # $root += atan( ($r*$r - 1) / ( ($k + $r*$r)*sqrt($k) + ($k+1)*sqrt($k+$r*$r-1)));
# }
# $root = -pi()/2 + Arctan($r) + $t1 *$r*$r/2 + ($tn1 - $t1)*$r**2/8;
$root = fmod ($root, 2*pi());
my $d = $root - $theta;
$d = fmod ($d + pi(), 2*pi()) - pi();
# printf "%10.6f %10.6f %23.20f\n", $theta, $root, $d;
printf "%23.20f\n", $d;
}
exit 0;
}
{
my $t1 = 0;
foreach my $k (1 .. 100) {
$t1 += 1 / (sqrt($k) * ($k+1));
printf "%10.6f\n", $t1;
}
exit 0;
}
sub Arctan {
my ($r) = @_;
return pi()/2 - atan(1/$r);
}
{
Math::BigFloat->accuracy(200);
my $bx = Math::BigFloat->new(1);
my $by = Math::BigFloat->new(0);
my $x = 1;
my $y = 0;
my $n = 1;
my @n = ($n);
my @x = ($x);
my @y = ($y);
my $count = 0;
my $prev_n = 0;
my $prev_d = 0;
my @dd;
while ($n++ < 10000000) {
my $r = hypot($x,$y);
my $py = $y;
($x, $y) = ($x - $y/$r, $y + $x/$r);
if ($py < 0 && $y >= 0) {
my $d = $n-$prev_n;
my $dd = $d-$prev_d;
push @dd, $dd;
printf "%5d +%4d +%3d %7.3f %10.6f %10.6f\n",
$n,
$d,
$dd,
# (sqrt($n)-1.07)/pi(),
sqrt($n),
$x, $y;
$prev_n = $n;
$prev_d = $d;
if (++$count >= 10) {
push @n, $n;
push @x, $x;
push @y, $y;
$count = 0;
}
}
}
print "average dd ", List::Util::sum(@dd)/scalar(@dd),"\n";
# require Data::Dumper;
# print Data::Dumper->new([\@n],['n'])->Indent(1)->Dump;
# print Data::Dumper->new([\@x],['x'])->Indent(1)->Dump;
# print Data::Dumper->new([\@y],['y'])->Indent(1)->Dump;
# require Math::Polynomial;
# my $p = Math::Polynomial->new(0);
# $p = $p->interpolate([ 1 .. @nc ], \@nc);
# $p->string_config({ fold_sign => 1,
# variable => 'd' });
# print "N = $p\n";
exit 0;
}
{
Math::BigFloat->accuracy(200);
my $bx = Math::BigFloat->new(1);
my $by = Math::BigFloat->new(0);
my $x = 1;
my $y = 0;
my $n = 1;
while ($n++ < 10000) {
my $r = hypot($x,$y);
($x, $y) = ($x - $y/$r, $y + $x/$r);
my $br = sqrt($bx*$bx + $by*$by);
($bx, $by) = ($bx - $by/$br, $by + $bx/$br);
}
my $ex = "$bx" + 0;
my $ey = "$by" + 0;
printf "%10.6f %10.6f %23.20f\n", $ex, $x, $ex - $x;
exit 0;
}
Math-PlanePath-129/devel/exe-atan2.c 0000644 0001750 0001750 00000003472 12005653477 014754 0 ustar gg gg /* Copyright 2011, 2012 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License along
with Math-PlanePath. If not, see
#include
#include
#include
void
dump (double d)
{
union { double d; unsigned char byte[8]; } u;
u.d = d;
printf ("%02X %02X %02X %02X %02X %02X %02X %02X\n",
u.byte[0], u.byte[1], u.byte[2], u.byte[3],
u.byte[4], u.byte[5], u.byte[6], u.byte[7]);
}
static const double double_ulong_max_plus_1
= ((double) ((ULONG_MAX >> 1)+1)) * 2.0;
static const double double_ull_max_plus_1
= ((double) ((ULLONG_MAX >> 1)+1)) * 2.0;
int
main (void)
{
volatile double zero = 0;
volatile double negzero = -zero;
dump (zero);
dump (negzero);
printf ("%la %la\n", zero,negzero);
printf ("%la\n", atan2(zero,zero));
printf ("%la\n", atan2(negzero,zero));
printf ("\n");
printf ("%la\n", atan2(zero,negzero));
printf ("%la\n", atan2(negzero,negzero));
printf ("\n");
printf ("ulong %la ", double_ulong_max_plus_1);
dump (double_ulong_max_plus_1);
printf (" %lf\n", double_ulong_max_plus_1);
printf ("ull %la ", double_ull_max_plus_1);
dump (double_ull_max_plus_1);
printf (" %lf\n", double_ull_max_plus_1);
exit (0);
}
Math-PlanePath-129/devel/sierpinski-triangle.gnuplot 0000644 0001750 0001750 00000006636 12041164262 020413 0 ustar gg gg #!/usr/bin/gnuplot
# Copyright 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see =1
# e = 1+sqrtint(4*n-7)
# vector(20,n, (1+sqrtint(4*n-3))\2)
# vector(20,n, my(d=(1+sqrtint(4*n-3))\2); n-d*(d-1))
exit 0;
}
{
require Math::Prime::XS;
my @primes = (0,
Math::Prime::XS::sieve_primes (1000));
my $path = Math::PlanePath::SquareSpiral->new;
foreach my $y (reverse -4 .. 4) {
foreach my $x (-4 .. 4) {
my $n = $path->xy_to_n($x,$y);
my $p = $primes[$n] // '';
printf " %4d", $p;
}
print "\n";
}
exit 0;
}
Math-PlanePath-129/devel/gosper-side.pl 0000644 0001750 0001750 00000005263 12402275640 015573 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2014 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see HOG id $num \n";
}
}
print $h <<"HERE";
$graph6_size bytes,
$num_vertices vertices,
$num_edges edges
$name$canonical$got
HERE
if ($num_vertices == 0) {
print $h "empty\n";
}
print $h <<"HERE";
HERE
if ($num_vertices <= 60) {
my $is_xy = $graph->isa('Graph')
&& ($graph->get_graph_attribute('vertex_name_type_xy')
|| $graph->get_graph_attribute('xy')
|| do {
my $type = $graph->get_graph_attribute('vertex_name_type');
defined $type && $type =~ /^xy/ }
|| do {
my ($v) = sort $graph->vertices;
defined $v && defined($graph->get_vertex_attribute($v,'x')) });
if ($is_xy || 1) {
### write with graphviz2 neato ...
my $graphviz2 = Graph_to_GraphViz2($graphs[$i]);
$graphviz2->run(format => 'png',
output_file=>$png_filename,
driver => 'neato');
### dot_input: $graphviz2->dot_input
} elsif (1) {
### write with graphviz2 dot ...
my $graphviz2 = Graph_to_GraphViz2($graphs[$i]);
$graphviz2->run(format => 'png',
output_file=>$png_filename);
} else {
my $easy = $graph;
if ($graph->isa('Graph')) {
### Graph num nodes ...
my $graph = $graph->copy;
foreach my $v ($graph->vertices) {
$graph->delete_vertex_attribute($v,'xy');
}
require Graph::Convert;
$easy = Graph::Convert->as_graph_easy($graph);
}
# Graph_Easy_blank_labels($easy);
foreach my $v (1,0) {
if (defined($easy->node($v))) {
$easy->set_attribute('root',$v); # for as_graphviz()
$easy->set_attribute('flow',$flow); # for as_graphviz()
}
}
### Graph-Easy num nodes: scalar($easy->nodes)
$easy->set_attribute('x-dot-start','1');
my $graphviz = $easy->as_graphviz;
# $graphviz =~ s/node \[/node [\n height=.08,\n width=.08,\n fixedsize=1,/;
# print $graphviz;
require IPC::Run;
IPC::Run::run(['dot','-Tpng',
],
'<',\$graphviz, '>',$png_filename);
# IPC::Run::run(['neato','-Tpng'], '<',\$graphviz, '>',$png_filename);
# IPC::Run::run(['fdp','-Tpng'], '<',\$graphviz, '>',$png_filename);
# print $easy->as_ascii;
}
require File::Slurp;
my $png = File::Slurp::read_file($png_filename);
require URI::data;
my $png_uri = URI->new("data:");
$png_uri->data($png);
$png_uri->media_type('image/png');
# my = URI::data->new($png,'image/png');
print $h qq{Upload
$name
HERE
close $h or die;
print "iceweasel file://$html_filename >/dev/null 2>&1 &\n";
}
# Return true of all arguments are different, as compared by "eq".
sub list_is_all_distinct_eq {
my %seen;
foreach (@_) {
if ($seen{$_}++) {
return 0;
}
}
return 1;
}
#------------------------------------------------------------------------------
# nauty bits
sub graph6_view {
my ($g6_str, %options) = @_;
my $graph = Graph_from_graph6_str($g6_str);
my $name = $options{'name'};
if (! defined $name || $name eq '') {
my $num_vertices = $graph->vertices;
my $num_edges = $graph->edges;
$graph->set_graph_attribute
(name => "$num_vertices vertices, $num_edges edges");
}
Graph_view($graph);
}
sub graph6_str_to_canonical {
my ($g6_str, %options) = @_;
### graph6_str_to_canonical(): $g6_str
# num_vertices == 0 is already canonical and nauty-labelg doesn't like to
# crunch that
if ($g6_str =~ /^\?/) {
return $g6_str;
}
unless ($g6_str =~ /\n$/) { $g6_str .= "\n"; }
if ($g6_str =~ /\n.*\n/s) { croak "multiple newlines in g6 string"; }
my $canonical;
my $err;
require IPC::Run;
if (! IPC::Run::run
(['nauty-labelg',
(($options{'format'}||'') eq 'sparse6' ? '-s'
: '-g'), # graph6 output
# '-i2',
],
'<',\$g6_str,
'>',\$canonical,
'2>',\$err)) {
die "nauty-labelg error: ",$canonical,$err;
}
return $canonical;
}
sub Graph_to_sparse6_str {
my ($graph) = @_;
require Graph::Writer::Sparse6;
my $writer = Graph::Writer::Sparse6->new;
open my $fh, '>', \my $str or die;
$writer->write_graph($graph, $fh);
return $str;
}
sub Graph_to_graph6_str {
my ($graph, %options) = @_;
require Graph::Writer::Graph6;
my $writer = Graph::Writer::Graph6->new
(format => ($options{'format'}||'graph6'));
open my $fh, '>', \my $str or die;
$writer->write_graph($graph, $fh);
return $str;
}
# $str is a graph6 or sparse6 string
sub Graph_from_graph6_str {
my ($str) = @_;
require Graph::Reader::Graph6;
my $reader = Graph::Reader::Graph6->new;
open my $fh, '<', \$str or die;
return $reader->read_graph($fh);
}
# $filename is a file containing graph6 or sparse6
sub Graph_from_graph6_filename {
my ($filename) = @_;
require Graph::Reader::Graph6;
my $reader = Graph::Reader::Graph6->new;
open my $fh, '<', $filename or die 'Cannot open ',$filename,': ',$!;
return $reader->read_graph($fh);
}
# return true if Graph.pm graphs $g1 and $g2 are isomorphic
sub Graph_is_isomorphic {
my ($g1, $g2) = @_;
my $g1_str = graph6_str_to_canonical(Graph_to_graph6_str($g1));
my $g2_str = graph6_str_to_canonical(Graph_to_graph6_str($g2));
return $g1_str eq $g2_str;
}
sub Graph_from_edge_aref {
my ($edge_aref, %options) = @_;
my $num_vertices = delete $options{'num_vertices'};
my $graph = Graph->new (undirected => 1);
$graph->add_vertices (0 .. ($num_vertices||0)-1);
foreach my $edge (@$edge_aref) {
scalar(@$edge) == 2 or die "bad edge_aref";
my ($from, $to) = @$edge;
($from =~ /^[0-9]+$/ && $to =~ /^[0-9]+$/) or die "bad edge_aref";
$graph->add_edge($from,$to);
}
return $graph;
}
sub Graph_from_vpar {
my ($vpar, @options) = @_;
require Graph;
my $graph = Graph->new (@options);
$graph->add_vertices(1 .. $#$vpar);
foreach my $v (1 .. $#$vpar) {
if ($vpar->[$v]) {
$graph->add_edge ($v, $vpar->[$v]);
} else {
$graph->set_graph_attribute('root',$v);
}
}
if ($graph->is_directed) {
$graph->set_graph_attribute('flow','north');
}
return $graph;
}
sub Graph_to_vpar {
my ($graph, $root) = @_;
$root //= Graph_tree_root($graph);
### Graph_to_vpar() ...
### $root
my @vertices = sort $graph->vertices;
my @vpar = (undef, (0) x scalar(@vertices));
unshift @vertices, undef;
### @vertices
my %vertex_to_v;
foreach my $v (1 .. $#vertices) { $vertex_to_v{$vertices[$v]} = $v; }
my %seen;
$vpar[$vertex_to_v{$root}] = 0;
$seen{$root} = 1;
my @pending = ($root);
while (@pending) {
my $vertex = pop @pending;
my $v = $vertex_to_v{$vertex};
### vertex: "$vertex v=$v"
my @neighbours = $graph->neighbours($vertex);
### @neighbours
my $p = 0;
$seen{$vertex} = 1;
$vpar[$v] = 0;
foreach my $neighbour (@neighbours) {
if ($seen{$neighbour}) {
$p = $vertex_to_v{$neighbour};
$vpar[$v] = $p;
### set: "$v parent $p"
} else {
push @pending, $neighbour;
}
}
}
### @vpar
return \@vpar;
}
sub Graph_vpar_str {
my ($graph) = @_;
my $vpar = Graph_to_vpar($graph);
my $str = "[";
foreach my $v (1 .. $#$vpar) {
$str .= ($vpar->[$v] // 'undef');
if ($v != $#$vpar) { $str .= ","; }
}
$str .= "]";
}
sub Graph_print_vpar {
my ($graph) = @_;
my $vpar = Graph_to_vpar($graph);
print "[";
foreach my $v (1 .. $#$vpar) {
print $vpar->[$v] // 'undef';
if ($v != $#$vpar) { print ","; }
}
print "]\n";
}
# synchronous => 1, wait for viewer to exit before returning.
sub vpar_view {
my ($vpar, %options) = @_;
### Graph_view(): %options
my $graphviz2 = vpar_to_GraphViz2($vpar, %options);
GraphViz2_view ($graphviz2, %options);
}
sub vpar_name {
my ($vpar) = @_;
my $str = 'N='.$#$vpar.' vpar';
my $sep = ' ';
foreach my $i (1..$#$vpar) {
$str .= $sep;
if (length($str) >= 45) {
$str .= '...';
return $str;
}
$str .= $vpar->[$i];
$sep = ',';
}
return $str;
}
sub vpar_to_GraphViz2 {
my ($vpar, %options) = @_;
### vpar_to_GraphViz2(): %options
require GraphViz2;
my $name = $options{'name'} // vpar_name($vpar);
my $flow = ($options{'flow'} // 'up');
my $graphviz2 = GraphViz2->new
(global => { directed => 1 },
graph => { label => $name,
rankdir => ($flow eq 'down' ? 'TB'
: $flow eq 'up' ? 'BT'
: $flow),
ordering => 'out',
},
node => { margin => 0, # cf default 0.11,0.055
},
);
foreach my $v (1 .. $#$vpar) {
$graphviz2->add_node(name => $v,
margin => '0.04,0.03', # cf default 0.11,0.055
height => '0.1', # inches, minimum
width => '0.1', # inches, minimum
);
}
foreach my $from (1 .. $#$vpar) {
if (my $to = $vpar->[$from]) {
$graphviz2->add_edge(from => $from, to => $to);
}
}
# roots in cluster at same rank so aligned horizontally
$graphviz2->push_subgraph (subgraph => {rank => 'same'});
foreach my $v (1 .. $#$vpar) {
unless ($vpar->[$v]) {
$graphviz2->add_node(name => $v);
}
}
$graphviz2->pop_subgraph;
return $graphviz2;
}
#------------------------------------------------------------------------------
# triangles
# ($a,$b,$c) are vertices of a triangle in $graph.
# a
# / \
# b---c
# Return true if this is an even triangle. For an even triangle every other
# vertex in the graph has an edge going to an even number of the vertices
# a,b,c. This means either no edges to them, or edges to exactly 2 of them.
#
sub Graph_triangle_is_even {
my ($graph, $a,$b,$c) = @_;
### Graph_triangle_is_even(): "$a $b $c"
foreach my $v ($graph->vertices) {
next if $v eq $a || $v eq $b || $v eq $c;
my $count = (($graph->has_edge($v,$a) ? 1 : 0)
+ ($graph->has_edge($v,$b) ? 1 : 0)
+ ($graph->has_edge($v,$c) ? 1 : 0));
### count: "$v is $count"
unless ($count == 0 || $count == 2) {
### triangle odd ...
return 0;
}
}
### triangle even ...
return 1;
}
# $graph is a Graph.pm.
# Call $stop = $callback->($a,$b,$c) for each triangle in $graph.
# If the return $stop is true then stop the search.
# The return is the $stop value, or undef at end of search.
#
# c
# / \
# a---b
#
# Triangles are found one way only, so if a,b,c then no calls also for
# permutations like b,a,c. It's unspecified exactly which vertices are the
# $a,$b,$c in the callback (though the current code has then in ascending
# alphabetical order).
#
sub Graph_triangle_search {
my ($graph, $callback) = @_;
foreach my $a ($graph->vertices) {
my @a_neighbours = sort $graph->neighbours($a);
foreach my $bi (0 .. $#a_neighbours-2) {
my $b = $a_neighbours[$bi];
next if $b lt $a;
foreach my $ci ($bi+1 .. $#a_neighbours-1) {
my $c = $a_neighbours[$ci];
if ($graph->has_edge($b,$c)) {
if (my $stop = $callback->($a,$b,$c)) {
return $stop;
}
}
}
}
}
return undef;
}
# $graph is a Graph.pm.
# ($a,$b,$c) = Graph_find_triangle($graph);
# Return a list of vertices which are a triangle within $graph.
# If no triangles then return an empty list;
# c
# / \
# a---b
sub Graph_find_triangle {
my ($graph) = @_;
my @ret;
Graph_triangle_search($graph, sub {@ret = @_});
return @ret;
}
# $graph is a Graph.pm.
# Return true if $graph contains a triangle.
sub Graph_has_triangle {
my ($graph) = @_;
return Graph_triangle_search($graph, sub {1});
}
# $graph is a Graph.pm.
# Return the number of triangles in $graph.
sub Graph_triangle_count {
my ($graph) = @_;
my $count = 0;
Graph_triangle_search($graph, sub { $count++; return 0});
return $count;
}
#------------------------------------------------------------------------------
# Claws
# $graph is a Graph.pm.
# Call $stop = $callback->($a,$b,$c,$d) for each claw in $graph.
# $a is the centre.
# If the return $stop is true then stop the search.
# The return is the $stop value, or undef at end of search.
# b
# /
# a--c
# \
# d
sub Graph_claw_search {
my ($graph, $callback) = @_;
foreach my $a ($graph->vertices) {
my @a_neighbours = $graph->neighbours($a);
foreach my $bi (0 .. $#a_neighbours-2) {
my $b = $a_neighbours[$bi];
foreach my $ci ($bi+1 .. $#a_neighbours-1) {
my $c = $a_neighbours[$ci];
next if $graph->has_edge($b,$c);
foreach my $di ($ci+1 .. $#a_neighbours) {
my $d = $a_neighbours[$di];
next if $graph->has_edge($b,$d) || $graph->has_edge($c,$d);
if (my $stop = $callback->($a,$b,$c,$d)) {
return $stop;
}
}
}
}
}
return undef;
}
# $graph is a Graph.pm.
# ($a,$b,$c,$d) = Graph_find_claw($graph);
# Return a list of vertices which are a claw (a 4-star) within $graph, as an
# induced subgraph. $a is the centre.
# If no claws then return an empty list;
# b
# /
# a--c
# \
# d
sub Graph_find_claw {
my ($graph) = @_;
my @ret;
Graph_claw_search($graph, sub {@ret = @_});
return @ret;
}
# $graph is a Graph.pm.
# Return true if $graph contains a claw (star-4) as an induced subgraph.
sub Graph_has_claw {
my ($graph) = @_;
return Graph_claw_search($graph, sub {1});
}
# $graph is a Graph.pm.
# Return the number of induced claws in $graph.
sub Graph_claw_count {
my ($graph) = @_;
my $count = 0;
Graph_claw_search($graph, sub { $count++; return 0});
return $count;
}
#------------------------------------------------------------------------------
# Return a list of how many vertices at depths 0 etc down from $root.
# The first width is depth=0 which is $root itself so width=1.
sub Graph_width_list {
my ($graph, $root) = @_;
my @widths;
my %seen;
my @pending = ($root);
while (@pending) {
push @widths, scalar(@pending);
my @new_pending;
foreach my $v (@pending) {
$seen{$v} = 1;
my @children = $graph->neighbours($v);
@children = grep {! $seen{$_}} @children;
push @new_pending, @children;
}
@pending = @new_pending;
}
return @widths;
}
# $graph is a Graph.pm.
# Return true if all vertices of $graph have same degree.
#
sub Graph_is_regular {
my ($graph) = @_;
my $degree;
foreach my $v ($graph->vertices) {
my $d = $graph->degree($v);
$degree //= $d;
if ($d != $degree) { return 0; }
}
return 1;
}
# $graph and $subgraph are Graph.pm objects.
# Return true if $subgraph is a subgraph of $graph.
# This is a check of graph structure. The vertex names in the two can be
# different.
#
sub Graph_is_subgraph {
my ($graph, $subgraph) = @_;
my $num_vertices = $graph->vertices;
my $subgraph_num_vertices = $subgraph->vertices;
edge_aref_is_subgraph(edge_aref_from_Graph($graph),
edge_aref_from_Graph($subgraph),
num_vertices => $num_vertices,
subgraph_num_vertices => $subgraph_num_vertices);
}
sub edge_aref_from_Graph {
my ($graph) = @_;
### edge_aref_from_Graph(): "$graph"
my @vertices = sort $graph->vertices;
my %vertices = map { $vertices[$_] => $_ } 0 .. $#vertices;
my @edges = $graph->edges;
return [ map { my ($from,$to) = @$_;
[ $vertices{$from},$vertices{$to} ]
} @edges ];
}
sub Graph_is_induced_subgraph {
my ($graph, $subgraph, %options) = @_;
my @graph_vertices = sort $graph->vertices;
my @subgraph_vertices = sort $subgraph->vertices;
### @graph_vertices
### @subgraph_vertices
my @ret;
my @used = (0) x (scalar(@graph_vertices) + 1);
my @map = (-1) x (scalar(@subgraph_vertices) + 1);
my $pos = 0;
OUTER: for (;;) {
$used[$map[$pos]] = 0;
### undo use: "used=".join(',',@used)
for (;;) {
my $m = ++$map[$pos];
### $m
if ($m > $#graph_vertices) {
$pos--;
### backtrack to pos: $pos
if ($pos < 0) {
last OUTER;
}
next OUTER;
}
if (! $used[$m]) {
$used[$m] = 1;
last;
}
### used ...
}
### incremented: "pos=$pos map=".join(',',@map)." used=".join(',',@used)
if ($graph->vertex_degree($graph_vertices[$map[$pos]])
< $subgraph->vertex_degree($subgraph_vertices[$pos])) {
### graph degree smaller than subgraph ...
next;
}
foreach my $p (0 .. $pos-1) {
### consider: "pos=$pos p=$p graph $graph_vertices[$map[$p]] to $graph_vertices[$map[$pos]] subgraph $subgraph_vertices[$p] to $subgraph_vertices[$pos]"
my $gedge = !! $graph->has_edge ($graph_vertices[$map[$p]],
$graph_vertices[$map[$pos]]);
my $sedge = !! $subgraph->has_edge($subgraph_vertices[$p],
$subgraph_vertices[$pos]);
if ($gedge != $sedge) {
next OUTER;
}
}
# good for this next vertex at $pos, descend
if (++$pos > $#subgraph_vertices) {
# print "found:\n";
# foreach my $p (0 .. $#subgraph_vertices) {
# print " $subgraph_vertices[$p] <-> $graph_vertices[$map[$p]]\n";
# }
if ($options{'all_maps'}) {
push @ret, { map {$subgraph_vertices[$_] => $graph_vertices[$map[$_]]}
0 .. $#subgraph_vertices};
### new map: $ret[-1]
$pos--;
} else {
return join(', ',
map {"$subgraph_vertices[$_]=$graph_vertices[$map[$_]]"}
0 .. $#subgraph_vertices);
}
}
$map[$pos] = -1;
}
if ($options{'all_maps'}) {
return @ret;
} else {
return 0;
}
}
sub edge_aref_is_induced_subgraph {
my ($edge_aref, $subgraph_edge_aref) = @_;
if (@$edge_aref < @$subgraph_edge_aref) {
return 0;
}
my @degree;
my @neighbour;
foreach my $edge (@$edge_aref) {
$neighbour[$edge->[0]][$edge->[1]] = 1;
$neighbour[$edge->[1]][$edge->[0]] = 1;
$degree[$edge->[0]]++;
$degree[$edge->[1]]++;
}
### @degree
my @subgraph_degree;
my @subgraph_neighbour;
foreach my $edge (@$subgraph_edge_aref) {
$subgraph_neighbour[$edge->[0]][$edge->[1]] = 1;
$subgraph_neighbour[$edge->[1]][$edge->[0]] = 1;
$subgraph_degree[$edge->[0]]++;
$subgraph_degree[$edge->[1]]++;
}
### @subgraph_degree
{
my @degree_sorted = sort {$b<=>$a} @degree; # descending
my @subgraph_degree_sorted = sort {$b<=>$a} @subgraph_degree;
foreach my $i (0 .. $#subgraph_degree_sorted) {
if ($subgraph_degree_sorted[$i] > $degree_sorted[$i]) {
return 0;
}
}
}
my $num_vertices = scalar(@neighbour);
my $subgraph_num_vertices = scalar(@subgraph_neighbour);
my @used = (0) x ($num_vertices + 1);
my @map = (-1) x ($subgraph_num_vertices + 1);
my $pos = 0;
OUTER: for (;;) {
$used[$map[$pos]] = 0;
### undo use: "used=".join(',',@used)
for (;;) {
my $m = ++$map[$pos];
### $m
if ($m >= $num_vertices) {
$pos--;
### backtrack to pos: $pos
if ($pos < 0) {
return 0;
}
next OUTER;
}
if (! $used[$m]) {
$used[$m] = 1;
last;
}
### used ...
}
### incremented: "pos=$pos map=".join(',',@map)." used=".join(',',@used)
if ($degree[$map[$pos]] < $subgraph_degree[$pos]) {
### graph degree smaller than subgraph ...
next;
}
foreach my $p (0 .. $pos-1) {
### consider: "pos=$pos p=$p graph $map[$p] to $map[$pos] subgraph $p to $pos"
my $has_edge = ! $neighbour[$map[$p]][$map[$pos]];
my $subgraph_has_edge = ! $subgraph_neighbour[$p][$pos];
if ($has_edge != $subgraph_has_edge) {
next OUTER;
}
}
# good for this next vertex at $pos, descend
if (++$pos >= $subgraph_num_vertices) {
# print "found:\n";
# foreach my $p (0 .. $subgraph_num_vertices-1) {
# print " $p <-> $map[$p]\n";
# }
return join(', ', map {"$_=$map[$_]"} 0 .. $subgraph_num_vertices-1);
# return 1;
}
$map[$pos] = -1;
}
}
sub edge_aref_is_subgraph {
my ($edge_aref, $subgraph_edge_aref, %option) = @_;
### edge_aref_is_subgraph() ...
### $edge_aref
### $subgraph_edge_aref
my @degree;
my @neighbour;
foreach my $edge (@$edge_aref) {
$neighbour[$edge->[0]][$edge->[1]] = 1;
$neighbour[$edge->[1]][$edge->[0]] = 1;
$degree[$edge->[0]]++;
$degree[$edge->[1]]++;
}
### @degree
my @subgraph_degree;
my @subgraph_neighbour;
foreach my $edge (@$subgraph_edge_aref) {
$subgraph_neighbour[$edge->[0]][$edge->[1]] = 1;
$subgraph_neighbour[$edge->[1]][$edge->[0]] = 1;
$subgraph_degree[$edge->[0]]++;
$subgraph_degree[$edge->[1]]++;
}
### @subgraph_degree
if (defined (my $num_vertices = $option{'num_vertices'})) {
$num_vertices >= @degree
or croak "num_vertices option too small";
$#degree = $num_vertices - 1;
$#neighbour = $num_vertices - 1;
}
if (defined (my $subgraph_num_vertices = $option{'subgraph_num_vertices'})) {
$subgraph_num_vertices >= @subgraph_degree
or croak "num_vertices option too small";
$#subgraph_degree = $subgraph_num_vertices - 1;
$#subgraph_neighbour = $subgraph_num_vertices - 1;
}
if (@degree < @subgraph_degree) {
### graph fewer vertices than subgraph ...
return 0;
}
my $num_vertices = scalar(@neighbour);
my $subgraph_num_vertices = scalar(@subgraph_neighbour);
foreach my $i (0 .. $num_vertices-1) {
$degree[$i] ||= 0;
}
foreach my $i (0 .. $subgraph_num_vertices-1) {
$subgraph_degree[$i] ||= 0;
}
my @used = (0) x ($num_vertices + 1);
my @map = (-1) x ($subgraph_num_vertices + 1);
my $pos = 0;
OUTER: for (;;) {
$used[$map[$pos]] = 0;
### undo use: "used=".join(',',@used)
for (;;) {
my $m = ++$map[$pos];
### $m
if ($m >= $num_vertices) {
$pos--;
### backtrack to pos: $pos
if ($pos < 0) {
return 0;
}
next OUTER;
}
if (! $used[$m]) {
$used[$m] = 1;
last;
}
### used ...
}
### incremented: "pos=$pos map=".join(',',@map)." used=".join(',',@used)
if (($degree[$map[$pos]]||0) < ($subgraph_degree[$pos]||0)) {
### graph degree smaller than subgraph ...
### degree: $degree[$map[$pos]]
### subgraph degree: $subgraph_degree[$pos]
next;
}
foreach my $p (0 .. $pos-1) {
### consider: "pos=$pos p=$p graph $map[$p] to $map[$pos] subgraph $p to $pos"
my $has_edge = $neighbour[$map[$p]][$map[$pos]];
my $subgraph_has_edge = $subgraph_neighbour[$p][$pos];
if ($subgraph_has_edge && ! $has_edge) {
next OUTER;
}
}
# good for this next vertex at $pos, descend
if (++$pos >= $subgraph_num_vertices) {
# print "found:\n";
# foreach my $p (0 .. $subgraph_num_vertices-1) {
# print " $p <-> $map[$p]\n";
# }
return join(', ', map {"$_=$map[$_]"} 0 .. $subgraph_num_vertices-1);
# return 1;
}
$map[$pos] = -1;
}
}
sub edge_aref_degrees_allow_subgraph {
my ($edge_aref, $subgraph_edge_aref) = @_;
if (@$edge_aref < @$subgraph_edge_aref) {
return 0;
}
my @degree;
foreach my $edge (@$edge_aref) {
$degree[$edge->[0]]++;
$degree[$edge->[1]]++;
}
### @degree
my @subgraph_degree;
foreach my $edge (@$subgraph_edge_aref) {
$subgraph_degree[$edge->[0]]++;
$subgraph_degree[$edge->[1]]++;
}
### @subgraph_degree
@degree = sort {$b<=>$a} @degree; # descending
@subgraph_degree = sort {$b<=>$a} @subgraph_degree;
foreach my $i (0 .. $#subgraph_degree) {
if ($subgraph_degree[$i] > $degree[$i]) {
return 0;
}
}
return 1;
}
sub edge_aref_eccentricity {
my ($edge_aref, $v) = @_;
### $v
my $eccentricity = 0;
my @edges = @$edge_aref;
my @pending = ($v);
while (@pending) {
### @edges
### @pending
$eccentricity++;
my @new_pending;
foreach my $v (@pending) {
@edges = grep {
my ($from,$to) = @$_;
my $keep = 1;
if ($from == $v) {
push @new_pending, $to;
$keep = 0;
} elsif ($to == $v) {
push @new_pending, $from;
$keep = 0;
}
$keep
} @edges;
}
@pending = @new_pending;
}
return $eccentricity;
}
# return true if all vertices of $graph have same degree
sub edge_aref_is_regular {
my ($edge_aref) = @_;
my @degrees = edge_aref_degrees($edge_aref);
### @degrees
foreach my $i (1 .. $#degrees) {
if ($degrees[$i] != $degrees[0]) {
return 0;
}
}
return 1;
}
#------------------------------------------------------------------------------
sub Graph_Wiener_part_at_vertex {
my ($graph,$vertex) = @_;
my $total = 0;
$graph->for_shortest_paths(sub {
my ($t, $u,$v, $n) = @_;
if ($u eq $vertex) {
$total += $t->path_length($u,$v);
}
});
return $total;
}
sub Graph_Wiener_index {
my ($graph) = @_;
my $total = 0;
$graph->for_shortest_paths(sub {
my ($t, $u,$v, $n) = @_;
$total += $t->path_length($u,$v);
});
return $total/2;
}
sub Graph_terminal_Wiener_index {
my ($graph) = @_;
my $total = 0;
my $for = $graph->for_shortest_paths
(sub {
my ($t, $u,$v, $n) = @_;
### u: $graph->vertex_degree($u)
### v: $graph->vertex_degree($v)
if ($graph->vertex_degree($u) == 1 && $graph->vertex_degree($v) == 1) {
$total += $t->path_length($u,$v);
}
});
return $total/2;
}
sub Graph_terminal_Wiener_part_at_vertex {
my ($graph, $vertex) = @_;
### Graph_terminal_Wiener_part_at_vertex(): $vertex
my $total = 0;
my $for = $graph->for_shortest_paths
(sub {
my ($t, $u,$v, $n) = @_;
# ### u: $graph->vertex_degree($u)
# ### v: $graph->vertex_degree($v)
### path: "$u to $v"
# can have $vertex not a leaf node
if ($u eq $vertex
&& $graph->vertex_degree($v) == 1) {
### length: $t->path_length($u,$v)
$total += $t->path_length($u,$v);
}
});
return $total;
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm.
# Return a new Graph.pm which is its line graph.
# Each vertex of the line graph is an edge of $graph and edges in the line
# graph are between those $graph edges with a vertex in common.
#
sub Graph_line_graph {
my ($graph) = @_;
my $line = Graph->new (undirected => $graph->is_undirected);
$line->set_graph_attribute
(name => join(', ',
($graph->get_graph_attribute('name') // ()),
'line graph'));
foreach my $from_edge ($graph->edges) {
my $from_edge_name = join(':', @$from_edge);
my ($from_vertex, $to_vertex) = @$from_edge;
foreach my $to_edge ($graph->edges_at($from_vertex),
$graph->edges_at($to_vertex)) {
my $to_edge_name = join(':', @$to_edge);
if ($from_edge_name ne $to_edge_name
&& ! $line->has_edge ($from_edge_name, $to_edge_name)
&& ! $line->has_edge ($to_edge_name, $from_edge_name)) {
$line->add_edge($from_edge_name, $to_edge_name);
}
}
}
return $line;
}
sub Graph_Easy_line_graph {
my ($easy) = @_;
my $line = Graph::Easy->new (undirected => $easy->is_undirected);
foreach my $from_edge ($easy->edges) {
my $from_name = $from_edge->name;
foreach my $to_edge ($from_edge->from->edges,
$from_edge->to->edges) {
my $to_name = $to_edge->name;
if ($from_name ne $to_name
&& ! $line->has_edge ($from_name, $to_name)
&& ! $line->has_edge ($to_name, $from_name)) {
$line->add_edge($from_name, $to_name);
}
}
}
return $line;
}
# Graph_Beineke_graphs() returns a list of Graph.pm graphs of Beineke G1 to G9.
use constant::defer Graph_Beineke_graphs => sub {
require Graph::Maker::Beineke;
map {
Graph::Maker->new('Beineke', G=>$_, undirected=>1)
} 1 .. 9;
};
# $graph is a Graph.pm.
# Return true if $graph is a line graph, by checking none of Beineke G1 to
# G9 are induced subgraphs.
#
sub Graph_is_line_graph_by_Beineke {
my ($graph) = @_;
### Graph_is_line_graph_by_Beineke() ...
foreach my $G (Graph_Beineke_graphs()) {
if (Graph_is_induced_subgraph($graph, $G)) {
### is induced subgraph, so not line graph ...
return 0;
}
### not subgraph ...
}
### final is line graph ...
return 1;
}
#------------------------------------------------------------------------------
# Graph Doubles
# $graph is a Graph.pm.
# Return a new graph which is the bipartite double of $graph.
# The new graph is two copies of the original vertices "$v.A" and $v.B".
# An edge $u to $v in $graph becomes edges $u.A to $v.B
# and $u.B to $v.A
#
sub Graph_bipartite_double {
my ($graph) = @_;
my $double = $graph->new; # same directed, countedged, etc
foreach my $v ($graph->vertices) {
$double->add_vertex("$v.A");
$double->add_vertex("$v.B");
}
foreach my $edge ($graph->edges) {
my ($from,$to) = @$edge;
### edge: "$from to $to"
$double->add_edge("$from.A","$to.B");
$double->add_edge("$from.B","$to.A");
}
return $double;
}
#------------------------------------------------------------------------------
# GraphViz2 conversions
# file:///usr/share/doc/graphviz/html/info/attrs.html
# $graph is a Graph.pm object.
# Return a GraphViz2 object.
#
sub Graph_to_GraphViz2 {
my ($graph, %options) = @_;
### Graph_to_GraphViz2: %options
require GraphViz2;
$options{'vertex_name_type'}
//= $graph->get_graph_attribute('vertex_name_type') // '';
my $is_xy = ($options{'is_xy'}
|| $options{'vertex_name_type'} =~ /^xy/
|| $graph->get_graph_attribute('vertex_name_type_xy')
|| $graph->get_graph_attribute('vertex_name_type_xy_triangular'));
my $is_xy_triangular
= ($graph->get_graph_attribute('is_xy_triangular')
|| $options{'vertex_name_type'} =~ /^xy-triangular/
|| $graph->get_graph_attribute('vertex_name_type_xy_triangular'));
### $is_xy
### $is_xy_triangular
my $name = $graph->get_graph_attribute('name');
my $flow = ($options{'flow'} // $graph->get_graph_attribute('flow') // 'down');
if ($flow eq 'north') { $flow = 'BT'; }
if ($flow eq 'east') { $flow = 'LR'; }
my $graphviz2 = GraphViz2->new
(global => { directed => $graph->is_directed },
graph => { (defined $name ? (label => $name) : ()),
(defined $flow ? (rankdir => $flow) : ()),
# ENHANCE-ME: take this in %options somehow
# Scale like "3" means input coordinates are tripled, so
# actual drawing is 1/3 of an inch steps.
inputscale => 3,
},
node => { margin => 0, # cf default 0.11,0.055
},
);
foreach my $v ($graph->vertices) {
my @attrs;
if (my ($x,$y) = Graph_vertex_xy($graph,$v)) {
if ($is_xy_triangular) {
$y = sprintf '%.5f', $y*sqrt(3);
}
if (defined $options{'scale'}) {
$x *= $options{'scale'};
$y *= $options{'scale'};
}
push @attrs, pin=>1, pos=>"$x,$y";
### @attrs
}
if (defined(my $name = $graph->get_vertex_attribute($v,'name'))) {
push @attrs, label => $name;
}
$graphviz2->add_node(name => $v,
margin => '0.03,0.02', # cf default 0.11,0.055
height => '0.1', # inches, minimum
width => '0.1', # inches, minimum
@attrs);
}
foreach my $edge ($graph->edges) {
my ($from, $to) = @$edge;
$graphviz2->add_edge(from => $from, to => $to);
}
return $graphviz2;
}
sub Graph_vertex_xy {
my ($graph, $v) = @_;
if (defined (my $xy = $graph->get_vertex_attribute($v,'xy'))) {
return split /,/, $xy;
}
if ($graph->get_graph_attribute('vertex_name_type_xy_triangular')) {
my ($x,$y) = split /,/, $v;
return ($x, $y*sqrt(3));
}
if ($graph->get_graph_attribute('vertex_name_type_xy')) {
return split /,/, $v;
}
if (defined(my $x = $graph->get_vertex_attribute($v,'x'))
&& defined(my $y = $graph->get_vertex_attribute($v,'y'))) {
return ($x,$y);
}
return ();
}
sub Graph_set_xy_points {
my $graph = shift;
while (@_) {
my $v = shift;
my $point = shift;
### $v
### $point
$graph->set_vertex_attribute($v, x => $point->[0]);
$graph->set_vertex_attribute($v, y => $point->[1]);
}
}
# $graphviz2 is a GraphViz2 object.
#
sub GraphViz2_view {
my ($graphviz2, %options) = @_;
require File::Temp;
my $ps = File::Temp->new (UNLINK => 0, SUFFIX => '.ps');
my $ps_filename = $ps->filename;
$graphviz2->run(format => 'ps',
output_file => $ps_filename,
($options{'driver'} ? (driver => $options{'driver'}) : ()),
);
postscript_view_file($ps_filename, %options);
# $graphviz2->run(format => 'xlib',
# driver => 'neato',
# );
}
sub parent_aref_view {
my ($aref) = @_;
Graph_Easy_view(parent_aref_to_Graph_Easy($aref));
}
#------------------------------------------------------------------------------
# $name is a vertex name.
# Return a form suitable for use as a PGF/Tikz node name.
# ENHANCE-ME: not quite right, would want to fixup most parens and more too.
#
sub vertex_name_to_tikz {
my ($name) = @_;
$name =~ s/[,:]/-/g;
return $name;
}
# $graph is an undirected Graph.pm.
# Print some PGF/Tikz TeX nodes and edges.
# The output is a bit rough, and usually must be massaged by hand.
#
sub Graph_print_tikz {
my ($graph) = @_;
my $is_xy = $graph->get_graph_attribute('vertex_name_type_xy');
my @vertices = sort $graph->vertices;
my $flow = 'east';
my $rows = int(sqrt(scalar(@vertices)));
my $r = 0;
my $c = 0;
my %seen_vn;
foreach my $v (@vertices) {
my $x = ($flow eq 'west' ? -$c : $c);
my $vn = vertex_name_to_tikz($v);
if (exists $seen_vn{$vn}) {
croak "Oops, duplicate tikz vertex name for \"$v\" and \"$seen_vn{$vn}\"";
}
$seen_vn{$vn} = $v;
my $at = ($is_xy ? $v : "$x,$r");
print " \\node ($vn) at ($at) [my box] {$v};\n";
$r++;
if ($r >= $rows) {
$c++;
$r = 0;
}
}
print "\n";
my $arrow = $graph->is_directed ? "->" : "";
foreach my $edge ($graph->unique_edges) {
my ($from,$to) = @$edge;
my $count = $graph->get_edge_count($from,$to);
my $node = ($count == 1 ? ''
: "node[pos=.5,auto=left] {$count} ");
$from = vertex_name_to_tikz($from);
$to = vertex_name_to_tikz($to);
if ($from eq $to) {
print " \\draw [$arrow,loop below] ($from) to $node();\n";
} else {
print " \\draw [$arrow] ($from) to $node($to);\n";
}
}
print "\n";
}
sub all_looks_like_consecutive_number {
all_looks_like_number(@_) or return 0;
my @a = sort {$a<=>$b} @_;
foreach my $i (1 .. $#a) {
$a[$i] == $a[$i-1] + 1 or return 0;
}
return 1;
}
sub all_looks_like_number {
foreach (@_) {
(Scalar::Util::looks_like_number($_)
&& $_ <= (1<<24))
or return 0;
}
return 1;
}
sub sort_num_or_alnum {
foreach (@_) {
unless (Scalar::Util::looks_like_number($_)) {
return sort @_;
}
}
return sort {$a<=>$b} @_;
}
sub Graph_print_dreadnaut {
my ($graph) = @_;
print Graph_dreadnaut_str($graph);
}
sub Graph_dreadnaut_str {
my ($graph, %options) = @_;
my @vertices = $graph->vertices;
my $base;
if (@vertices && all_looks_like_number(@vertices)) {
### numeric vertices ...
@vertices = sort {$a<=>$b} @vertices;
$base = $vertices[0];
} else {
### non-numeric vertices, sort ...
@vertices = sort @vertices;
$base = $options{'base'} || 0;
}
my %vertex_to_n;
@vertex_to_n{@vertices} = $base .. $base+$#vertices; # hash slice
### %vertex_to_n
my $str = '';
$str .= ($graph->is_directed ? 'd' : '-d')
. ' n='.scalar(@vertices)
. " \$=$base g";
my $comma = '';
my $prev_i = 0;
my @edges = sort {$vertex_to_n{$a->[0]} <=> $vertex_to_n{$b->[0]}
|| $vertex_to_n{$a->[1]} <=> $vertex_to_n{$b->[1]}}
$graph->edges;
### num edges: scalar(@edges)
my $prev_from = $base;
my $join = '';
foreach my $edge (@edges) {
### $edge
$str .= $comma;
my $from = $vertex_to_n{$edge->[0]};
my $to = $vertex_to_n{$edge->[1]};
### indices: "$from to $to"
if ($from != $prev_from) {
$str .= ($from == $prev_from + 1 ? ';'
: "$join$from:");
$join = '';
$prev_from = $from;
}
$str .= "$join$to";
$join = ' ';
}
### $str
return $str . ".";
}
sub Graph_run_dreadnaut {
my ($graph, %options) = @_;
require IPC::Run;
my $str = Graph_dreadnaut_str($graph,%options) . " a x\n";
if ($options{'verbose'}) {
print $str;
}
if (! IPC::Run::run(['dreadnaut'], '<',\$str)) {
die "dreadnaut: $!";
}
}
#------------------------------------------------------------------------------
# $graph is an undirected Graph.pm.
# Return the clique number of $graph.
# The clique number is the number of vertices in the maximum clique
# (complete graph) contained in $graph.
# Currently this is a brute force search, so quite slow and suitable only for
# small number of vertices.
#
sub Graph_clique_number {
my ($graph) = @_;
my @vertices = sort $graph->vertices;
my @clique = (-1);
my $maximum_clique_size = 0;
my $pos = 0;
OUTER: for (;;) {
### at: join(',',@clique[0..$pos])
if (++$clique[$pos] > $#vertices) {
# backtrack
if (--$pos < 0) {
last;
}
next;
}
my $v = $vertices[$clique[$pos]];
foreach my $i (0 .. $pos-1) {
if (! $graph->has_edge($v, $vertices[$clique[$i]])) {
next OUTER;
}
}
$pos++;
if ($pos > $maximum_clique_size) {
# print " new high $maximum_clique_size\n";
$maximum_clique_size = $pos;
}
if ($pos > $#vertices) {
# $graph is a complete-N
last;
}
$clique[$pos] = $clique[$pos-1];
}
return $maximum_clique_size;
}
# $graph is a Graph.pm and @vertices are vertex names in it.
# Return true if those vertices are a clique, meaning edge between all pairs.
sub Graph_is_clique {
my ($graph, @vertices) = @_;
foreach my $i (0 .. $#vertices) {
$graph->has_vertex($vertices[$i]) or die;
foreach my $j (0 .. $#vertices) {
next if $i == $j;
### has: "$vertices[$i] $vertices[$j] is ".($graph->has_edge($vertices[$i], $vertices[$j])||0)
$graph->has_edge($vertices[$i], $vertices[$j]) or return 0;
}
}
return 1;
}
#------------------------------------------------------------------------------
# $graph is a tree
# $v is a child node of $parent
# Return the depth of the subtree $v and deeper underneath $parent.
# If $v is a leaf then it is the entire subtree and the return is depth 1.
#
sub Graph_subtree_depth {
my ($graph, $parent, $v) = @_;
### $parent
### $v
$graph->has_edge($parent,$v) or die "oops, $parent and $v not adjacent";
my $depth = 0;
my %seen = ($parent => 1, $v => 1);
my @pending = ($v);
do {
@pending = map {$graph->neighbours($_)} @pending;
@pending = grep {! $seen{$_}++} @pending;
$depth++;
} while (@pending);
return $depth;
}
# $graph is a tree
# $v is a child node of $parent
# return the children of $v, being all neighbours except $parent
sub Graph_subtree_children {
my ($graph, $parent, $v) = @_;
return grep {$_ ne $parent} $graph->neighbours($v);
}
#------------------------------------------------------------------------------
# $edge_aref is an arrayref [ [from,to], [from,to], ... ]
# where each vertex is integer 0 upwards
# Return the number of vertices, which means the maximum + 1 of the vertex
# numbers in the elements.
#
sub edge_aref_num_vertices {
my ($edge_aref) = @_;
if (! @$edge_aref) { return 0; }
return max(map {@$_} @$edge_aref) + 1;
}
# $edge_aref is an arrayref [ [from,to], [from,to], ... ]
# where each vertex is integer 0 upwards forming a tree with root 0
# Return an arrayref of the parent of each vertex, so $a->[i] = parent of i
#
sub edge_aref_to_parent_aref {
my ($edge_aref) = @_;
### edge_aref_to_parent_aref() ...
my @neighbours;
foreach my $edge (@$edge_aref) {
my ($from, $to) = @$edge;
push @{$neighbours[$from]}, $to;
push @{$neighbours[$to]}, $from;
}
my @parent;
my @n_to_v = (0);
my @v_to_n = (0);
my $upto_v = 1;
for (my $v = 0; $v < $upto_v; $v++) {
### neighbours: "$v=n$v_to_n[$v] to n=".join(',',@{$neighbours[$v_to_n[$v]]})
foreach my $n (@{$neighbours[$v_to_n[$v]]}) {
if (! defined $n_to_v[$n]) {
$n_to_v[$n] = $upto_v;
$v_to_n[$upto_v] = $n;
$parent[$upto_v] = $v;
$upto_v++;
}
}
}
foreach my $edge (@$edge_aref) {
foreach my $n (@$edge) {
$n = $n_to_v[$n]; # mutate array
}
}
### @parent
### num_vertices: scalar(@parent)
return \@parent;
}
# $parent_aref is an arrayref where $a->[i] = parent of i
# vertices are integers 0 upwards
# Return an edge aref [ [from,to], [from,to], ... ]
#
sub parent_aref_to_edge_aref {
my ($parent_aref) = @_;
return [ map {[$parent_aref->[$_] => $_]} 1 .. $#$parent_aref ];
}
# $parent_aref is an arrayref where $a->[i] = parent of i
# vertices are integers 0 upwards
# Return a Graph::Easy
#
sub parent_aref_to_Graph_Easy {
my ($parent_aref) = @_;
require Graph::Easy;
my $graph = Graph::Easy->new(undirected => 1);
if (@$parent_aref) {
$graph->add_vertex(0);
foreach my $v (1 .. $#$parent_aref) {
$graph->add_edge($v,$parent_aref->[$v]);
}
}
return $graph;
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm.
# Modify $graph by changing the name of vertex $old_name to $new_name.
# If $old_name and $new_name are the same then do nothing.
# Otherwise $new_name should not exist already.
#
sub Graph_rename_vertex {
my ($graph, $old_name, $new_name) = @_;
### $old_name
### $new_name
return if $old_name eq $new_name;
if ($graph->has_vertex($new_name)) {
croak "Graph vertex \"$new_name\" exists already";
}
$graph->add_vertex($new_name);
$graph->set_vertex_attributes($new_name,
$graph->get_vertex_attributes($old_name));
foreach my $edge ($graph->edges_at($old_name)) {
my ($from,$to) = @$edge;
if ($from eq $old_name) { $from = $new_name; }
if ($to eq $old_name) { $to = $new_name; }
### $from
### $to
$graph->add_edge($from,$to);
}
$graph->delete_vertex($old_name);
}
# $graph is a Graph.pm.
# Return a new vertex name for $graph, one which does not otherwise occur in
# $graph.
#
sub Graph_new_vertex_name {
my ($graph, $prefix) = @_;
if (! defined $prefix) { $prefix = ''; }
my $upto = $graph->get_graph_attribute('Graph_new_vertex_name_upto') // 0;
$upto++;
$graph->set_graph_attribute('Graph_new_vertex_name_upto',$upto);
return "$prefix$upto";
}
# $graph is a Graph.pm.
# Add vertices to pad out existing vertices to all degree $N.
sub Graph_pad_degree {
my ($graph, $N) = @_;
my $upto = 1;
my @original_vertices = $graph->vertices;
foreach my $v (@original_vertices) {
while ($graph->vertex_degree($v) < $N) {
$graph->add_edge($v, Graph_new_vertex_name($graph));
$graph->set_graph_attribute('vertex_name_type',undef);
}
}
return $graph;
}
# $graph is a Graph.pm.
sub Graph_degree_sequence {
my ($graph) = @_;
return sort {$a<=>$b} map {$graph->vertex_degree($_)} $graph->vertices;
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm.
# Replace each vertex by a star of N vertices.
# Existing edges become edges between an arm of the new stars.
# All vertices must be degree <= N-1 (the arms of the stars)
#
# Key/value options are
#
# edges_between => $integer, default 1
# Number of edges in connections between new stars.
# Default 1 is replacing each edge by an edge between the stars.
# > 1 means extra vertices for those connections.
# 0 means the stars have a vertex in common for existing edges.
#
sub Graph_star_replacement {
my ($graph, $N, %options) = @_;
my $new_graph = $graph->new (undirected => $graph->is_undirected);
my $edges_between = $options{'edges_between'} // 1;
### $edges_between
my $upto = 1;
my %v_to_arms;
foreach my $v ($graph->vertices) {
my $centre = $upto++;
foreach my $i (2 .. $N) {
my $arm = $upto++;
$new_graph->add_edge($centre,$arm);
push @{$v_to_arms{$v}}, $arm;
}
}
foreach my $edge ($graph->edges) {
my ($u,$v) = @$edge;
$u = (pop @{$v_to_arms{$u}}) // croak "oops, degree > $N";
$v = (pop @{$v_to_arms{$v}}) // croak "oops, degree > $N";
if ($edges_between == 0) {
Graph_merge_vertices($new_graph, $u, $v);
} else {
my @between = map {my $b = $upto++; $b} 2 .. $edges_between;
$new_graph->add_path($u, @between, $v);
}
}
if (defined (my $name = $graph->get_graph_attribute('name'))) {
my $append = ", $N-star rep";
if ($name =~ /\Q$append\E$/) { $name .= ' 2'; }
elsif ($name =~ s{(\Q$append\E )(\d+)$}{$1.($2+1)}e) { }
else { $name .= $append; }
$graph->set_graph_attribute (name => $name);
### $name
}
return $new_graph;
}
sub _closest_xy_pair {
my ($aref, $bref) = @_;
if (@$aref == 0 || @$bref == 0) { return; }
my $min_a = 0;
my $min_b = 0;
my $min_norm;
foreach my $a (0 .. $#$aref) {
my ($ax,$ay) = split /,/, $aref->[$a];
foreach my $b (0 .. $#$bref) {
my ($bx,$by) = split /,/, $bref->[$b];
my $norm = ($ax-$bx)**2 + ($ay-$by)**2;
if (! defined $min_norm || $norm < $min_norm) {
$min_a = $a;
$min_b = $b;
$min_norm = $norm;
}
}
}
return (splice(@$aref, $min_a, 1),
splice(@$bref, $min_b, 1));
}
# Graph_merge_vertices($graph, $v, $v2, $v3, ...)
# $graph is a Graph.pm
# Modify $graph to merge all the given vertices into one.
# Edges going to any of them are moved to go to $v, and the rest deleted.
# Only for undirected graphs currently.
#
sub Graph_merge_vertices {
my $graph = shift;
$graph->expect_undirected;
my $v = shift;
foreach my $other (@_) {
### Graph_merge_vertices(): "$v, $other"
foreach my $neighbour ($graph->neighbours($other)) {
### $neighbour
unless ($neighbour eq $v) {
$graph->add_edge ($v, $neighbour);
}
}
$graph->delete_vertex($other);
}
}
# $graph is a Graph.pm.
# Replace each vertex by an N-cycle.
# Existing edges become edges between vertices of the cycles, consecutively
# around the cycle.
#
sub Graph_cycle_replacement {
my ($graph, $N, %options) = @_;
my $edges_between = $options{'edges_between'} // 1;
my $vertex_name_type = $graph->get_graph_attribute('vertex_name_type') // '';
my $xy = ($vertex_name_type =~ /^xy/) && $N==4;
### $vertex_name_type
### $xy
my $new_graph = $graph->new (undirected => $graph->is_undirected);
my $upto = 1;
my %v_to_arms;
foreach my $v ($graph->vertices) {
my @c;
if ($xy) {
my ($x,$y) = split /,/,$v;
$x *= $edges_between+4;
$y *= $edges_between+4;
@c = ( ($x+1).','.($y+1),
($x-1).','.($y+1),
($x-1).','.($y-1),
($x+1).','.($y-1) );
} else {
@c = map {my $c = $upto++; $c} 1 .. $N;
}
foreach my $c (@c) { die if $new_graph->has_vertex($c); }
$new_graph->add_cycle(@c);
$v_to_arms{$v} = \@c;
}
foreach my $edge ($graph->edges) {
my ($u,$v) = @$edge;
my @between;
if ($xy) {
($u,$v) = _closest_xy_pair($v_to_arms{$u},
$v_to_arms{$v})
or croak "oops, degree > $N";
# $u = (pop @{$v_to_arms{$u}}) // croak "oops, degree > $N";
# $v = (pop @{$v_to_arms{$v}}) // croak "oops, degree > $N";
my ($ux,$uy) = split /,/,$u;
my ($vx,$vy) = split /,/,$v;
@between = map { my $x = $ux + ($vx-$ux)/($edges_between+2);
my $y = $uy + ($vy-$uy)/($edges_between+2);
my $b = "$x,$y";
die if $new_graph->has_vertex($b);
$b;
} 1 .. $edges_between;
} else {
$u = (shift @{$v_to_arms{$u}}) // croak "oops, degree > $N";
$v = (shift @{$v_to_arms{$v}}) // croak "oops, degree > $N";
@between = map {my $b = $upto++; $b} 1 .. $edges_between;
}
if ($edges_between == 0) {
Graph_merge_vertices($new_graph, $u, $v);
} else {
$new_graph->add_path($u, @between, $v);
}
}
if (defined (my $name = $graph->get_graph_attribute('name'))) {
my $append = ", $N-star rep";
if ($name =~ /\Q$append\E$/) {
$name .= ' 2';
} elsif ($name =~ s{(\Q$append\E )(\d+)$}{$1.($2+1)}e) {
} else {
$name .= $append;
}
$new_graph->set_graph_attribute (name => $name);
}
$new_graph->set_graph_attribute('vertex_name_type', $vertex_name_type);
return $new_graph;
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm.
# Return a list of vertices which are a path achieving the eccentricity of $u.
#
# FIXME: is $graph->longest_path args ($u,$v) a documented feature?
sub Graph_eccentricity_path {
my ($graph, $u) = @_;
$graph->expect_undirected;
my $max = 0;
my $max_v;
for my $v ($graph->vertices) {
next if $u eq $v;
my $len = $graph->path_length($u, $v);
if (defined $len && (! defined $max || $len > $max)) {
$max = $len;
$max_v = $v;
}
}
return $graph->longest_path($u,$max_v);
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm undirected tree.
# Return ($eccentricity, $vertex,$vertex) which is the centre 1 or 2 vertex
# names and their eccentricity.
# Only tested on bicentral trees.
# FIXME: the return is not eccentricity but num vertices to reach maximum?
sub Graph_tree_centre_vertices {
my ($graph) = @_;
{
my $eccentricity = 0;
my %seen;
my %unseen = map {$_=>1} $graph->vertices;
my @prev_unseen;
for (;;) {
### seen: join(' ',keys %seen)
### unseen: join(' ',keys %unseen)
### $eccentricity
%unseen or last;
$eccentricity++;
@prev_unseen = keys %unseen;
my @leaves;
foreach my $v (@prev_unseen) {
my @neighbours = grep {! exists $seen{$_}} $graph->neighbours($v);
if (@neighbours <= 1) {
push @leaves, $v;
}
}
### @leaves
delete @unseen{@leaves}; # leaf nodes go from unseen to seen
@seen{@leaves} = ();
}
return ($eccentricity, @prev_unseen);
}
{
$graph = $graph->copy;
my @prev_vertices;
for (;;) {
my @vertices = $graph->vertices
or last;
@prev_vertices = @vertices;
my @leaves = grep {$graph->degree($_) <= 1} @vertices;
$graph->delete_vertices(@leaves);
}
return @prev_vertices;
}
}
# $graph is an undirected connected Graph.pm.
# Return a list of its leaf vertices.
#
sub Graph_leaf_vertices {
my ($graph) = @_;
return grep {$graph->vertex_degree($_)<=1} $graph->vertices;
}
# $graph is a Graph.pm undirected tree.
# Return a list of vertices which attain the diameter of tree $graph.
#
sub Graph_tree_diameter_path {
my ($graph) = @_;
if ($graph->vertices == 0) { return; }
my ($eccentricity, @centres) = Graph_tree_centre_vertices($graph);
### @centres
my @paths = ([ $centres[0] ]);
my @prev_paths = @paths;
for (;;) {
### paths: map {join(',',@$_)} @paths
my @new_paths;
foreach my $path (@paths) {
my $v = $path->[-1];
foreach my $neighbour ($graph->neighbours($v)) {
next if @$path>=2 && $neighbour eq $path->[-2];
push @new_paths, [@$path,$neighbour];
}
}
if (@new_paths) {
@prev_paths = @paths;
@paths = @new_paths;
} else {
last;
}
}
my $path = shift @paths;
### final path: join(',',@$path)
push @paths, @prev_paths;
if (@paths) {
foreach my $other_path (@paths) {
### final path: join(',',@$path)
### consider other: join(',',@$other_path)
if (@$other_path < 2 || $other_path->[1] ne $path->[1]) {
my @join = reverse @$path;
pop @join;
push @join, @$other_path;
### join to: join(',',@join)
$path = \@join;
last;
}
}
}
### $eccentricity
### path length: scalar(@$path)
scalar(@$path) == 2*$eccentricity - (@centres==1)
or die "oops";
return @$path;
}
# $graph is an undirected connected Graph.pm.
# Return the number of paths attaining the diameter of $graph.
# A path u--v is counted just once, not also v--u.
#
sub Graph_diameter_count {
my ($graph) = @_;
if ($graph->vertices <= 1) {
return 1;
}
my $diameter = 0;
my $count = 0;
$graph->for_shortest_paths(sub {
my ($t, $u,$v, $n) = @_;
my $len = $t->path_length($u,$v);
if ($len > $diameter) {
### new high path length: $len
$count = 0;
$diameter = $len;
}
if ($len == $diameter) {
$count++;
### equal high path length to count: $count
}
});
### $diameter
return ($graph->is_undirected ? $count/2 : $count);
}
# $graph is a Graph.pm.
# Insert $n new vertices into each of its edges.
# If $n omitted or undef then default 1 vertex in each edge.
sub Graph_subdivide {
my ($graph, $n) = @_;
if (! defined $n) { $n = 1; }
foreach my $edge ($graph->edges) {
$graph->delete_edge (@$edge);
my $prefix = "$edge->[0]-$edge->[1]-";
$graph->add_path ($edge->[0],
(map {Graph_new_vertex_name($graph,$prefix)} 1 .. $n),
$edge->[1]);
}
if ($n && $graph->edges
&& defined (my $name = $graph->get_graph_attribute('name'))) {
$graph->set_graph_attribute (name =>
"$name subdivision".($n > 1 ? " $n" : ""));
}
return $graph;
}
#------------------------------------------------------------------------------
# Independence Number
# $graph is a Graph.pm undirected tree or forest.
# Return its independence number.
#
sub Graph_tree_indnum {
my ($graph) = @_;
### Graph_tree_indnum: "num_vertices ".scalar($graph->vertices)
$graph->expect_acyclic;
$graph = $graph->copy;
my $indnum = 0;
my %exclude;
OUTER: while ($graph->vertices) {
foreach my $v ($graph->vertices) {
my $degree = $graph->vertex_degree($v);
next unless $degree <= 1;
my ($u) = $graph->neighbours($v);
### consider: "$v degree $degree neighbours ".($u//'undef')
if (delete $exclude{$v}) {
### exclude ...
} else {
### leaf include ...
$indnum++;
if (defined $u) { $exclude{$u} = 1; }
}
$graph->delete_vertex($v);
next OUTER;
}
die "oops, not a tree";
}
return $indnum;
}
sub Graph_make_most_indomsets {
my ($n) = @_;
my $graph = Graph->new (undirected=>1);
my $v = 0;
while ($n > 0) {
if ($v) { $graph->add_edge(0,$v) } # to x
my $u = $v;
my $size = 3 + (($n%3)!=0);
foreach my $i (0 .. $size-1) { # triangle or complete-4
foreach my $j (0 .. $i-1) {
$graph->add_edge($u+$i, $u+$j);
}
}
$n -= $size;
$v += $size;
}
return $graph;
}
sub Graph_is_indset {
my ($graph,$aref) = @_;
foreach my $from (@$aref) {
foreach my $to (@$aref) {
if ($graph->has_edge($from,$to)) {
return 0;
}
}
}
return 1;
}
sub Graph_indnum_and_count {
my ($graph) = @_;
require Algorithm::ChooseSubsets;
my @vertices = sort $graph->vertices;
my $it = Algorithm::ChooseSubsets->new(\@vertices);
my $indnum = 0;
my $count = 0;
while (my $aref = $it->next) {
if (Graph_is_indset($graph,$aref)) {
if (@$aref == $indnum) {
$count++;
} elsif (@$aref > $indnum) {
$indnum = @$aref;
$count = 1;
}
}
}
return ($indnum, $count);
}
#------------------------------------------------------------------------------
# Domination Number
# Cockayne, Goodman, Hedetniemi, "A Linear Algorithm for the Domination
# Number of a Tree", Information Processing Letters, volume 4, number 2,
# November 1975, pages 41-44.
# $graph is a Graph.pm undirected tree or forest.
# Return its domination number.
#
sub Graph_tree_domnum {
my ($graph) = @_;
### Graph_tree_domnum: "num_vertices ".scalar($graph->vertices)
$graph->expect_acyclic;
$graph = $graph->copy;
my $domnum = 0;
my %mtype = map {$_=>'bound'} $graph->vertices;
OUTER: while ($graph->vertices) {
foreach my $v ($graph->vertices) {
my $degree = $graph->vertex_degree($v);
next unless $degree <= 1;
### consider: $v
### $degree
my ($u) = $graph->neighbours($v);
if ($mtype{$v} eq 'free') {
### free, delete ...
} elsif ($mtype{$v} eq 'bound') {
### bound ...
if (defined $u) {
### set neighbour $u required ...
$mtype{$u} = 'required';
} else {
### no neighbour, domnum++ ...
$domnum++;
}
} elsif ($mtype{$v} eq 'required') {
### required, domnum++ ...
$domnum++;
if (defined $u && $mtype{$u} eq 'bound') {
### set neighbour $u free ...
$mtype{$u} = 'free';
}
} else {
die;
}
delete $mtype{$v};
$graph->delete_vertex($v);
next OUTER;
}
die "oops, not a tree";
}
return $domnum;
}
#------------------------------------------------------------------------------
# Dominating Sets Count
# with(n) = prod(child any) # sets including parent
# undom(n) = prod(child dom) # sets without parent and parent undominated
# dom(n) = prod(child with + dom) - prod(child dom)
# # sets without parent and parent dominated
# T(n) = with(n) + dom(n);
#
# with + dom = any - undom
#
# *
# / | \
# * * *
# /|\ /|\ /|\
# * * * * * * * * *
#
# path 1--2 2 with + 1 without = 3 any 0 without undom
# path 1--2--3 3 with + 2 without = 5 any 1 without undom
# 2 without dom
# cannot e,1,3
# $graph is a Graph.pm tree.
# Return the number of dominating sets in $graph.
#
sub Graph_tree_domsets_count {
my ($graph) = @_;
require Math::BigInt;
$graph = $graph->copy;
$graph->vertices || return 1; # empty graph
my %data;
my $one = Math::BigInt->new(1);
OUTER: for (;;) {
foreach my $v (sort $graph->vertices) {
my $degree = $graph->vertex_degree($v);
next unless $degree <= 1;
# with(n) = prod(c any)
# without(n) = prod(c with + dom = domsets)
# without_undom(n) = prod(c dom);
#
my $c_with = $data{$v}->{'with'} // $one;
my $c_without_undom = $data{$v}->{'without_undom'} // $one;
my $c_without = $data{$v}->{'without'} // $one;
my $c_without_dom = $c_without - $c_without_undom;
my $c_domsets = $c_with + $c_without_dom;
my $c_any = $c_with + $c_without;
### consider: "$v deg=$degree with $c_with, without $c_without, without_undom $c_without_undom"
### consider: " so without_dom=$c_without_dom domsets=$c_domsets any=$c_any"
if ($degree == 0) {
return $c_domsets;
}
my ($u) = $graph->neighbours($v);
$data{$u}->{'with'} //= $one;
$data{$u}->{'without'} //= $one;
$data{$u}->{'without_undom'} //= $one;
$data{$u}->{'with'} *= $c_any;
$data{$u}->{'without'} *= $c_domsets;
$data{$u}->{'without_undom'} *= $c_without_dom;
delete $data{$v};
$graph->delete_vertex($v);
next OUTER;
}
die "oops, not a tree $graph";
}
# OUTER: for (;;) {
# foreach my $v (sort $graph->vertices) {
# my $degree = $graph->vertex_degree($v);
# next unless $degree <= 1;
#
# $data{$v}->{'prod_c_any'} //= $one;
# $data{$v}->{'prod_c_dom'} //= $one;
# $data{$v}->{'prod_c_with_or_dom'} //= $one;
#
# # with(n) = prod(c any)
# # undom(n) = prod(c dom);
# # dom(n) = prod(c with + dom) - prod(c dom)
# #
# my $with = $data{$v}->{'prod_c_any'};
# my $undom = $data{$v}->{'prod_c_dom'};
# my $dom = $data{$v}->{'prod_c_with_or_dom'} - $undom;
# my $ret = $with + $dom;
# my $any = $ret + $undom;
#
# ### consider: "$v deg=$degree prods $data{$v}->{'prod_c_any'}, $data{$v}->{'prod_c_dom'}, $data{$v}->{'prod_c_with_or_dom'}"
# ### consider: " with $with dom $dom undom=$undom, ret $ret any $any"
#
# if ($degree == 0) {
# return $ret;
# }
#
# my ($u) = $graph->neighbours($v);
# $data{$u}->{'prod_c_any'} //= $one;
# $data{$u}->{'prod_c_dom'} //= $one;
# $data{$u}->{'prod_c_with_or_dom'} //= $one;
# $data{$u}->{'prod_c_any'} *= $any;
# $data{$u}->{'prod_c_dom'} *= $dom;
# $data{$u}->{'prod_c_with_or_dom'} *= $ret;
#
# delete $data{$v};
# $graph->delete_vertex($v);
# next OUTER;
# }
# die "oops, not a tree $graph";
# }
}
# 1 2 3 4 5
# path 1,1,2,2,4,4,7,9,13,18,25,36,49
# 1 with=1=1+0 without=0=0+1 domsets=1+0 = 1
# 2 with=1=1+0 without=1=1+0 domsets=1+1 = 2
# 3 with=2=1+1 without=2=1+1 domsets=1+1 = 2
# 4 with=2=1+1 without=3=2+1 domsets=2+2 = 4
# 5 with=4=1+3 without=4=2+2 domsets=4+2 = 6
#
# 1,3,4 without_dom
# 2,4 without_dom
# 1,3,5 with_unreq
# 2,5 with_req
# 1,3,4,5 not minimal
# 2,4,5 with_unreq but itself not minimal
#
# $graph is a Graph.pm tree.
# Return the number of minimal dominating sets in $graph.
#
sub Graph_tree_minimal_domsets_count {
my ($graph) = @_;
return tree_minimal_domsets_count_data_ret
(Graph_tree_minimal_domsets_count_data($graph));
}
# $graph is a Graph.pm tree.
# Return a hashref of data counting minimal dominating sets in $graph.
#
sub Graph_tree_minimal_domsets_count_data {
my ($graph) = @_;
require Math::BigInt;
$graph->vertices
|| return tree_minimal_domsets_count_data_initial(); # empty graph
$graph = $graph->copy;
my %data;
foreach my $v ($graph->vertices) {
$data{$v} = tree_minimal_domsets_count_data_initial();
}
OUTER: for (;;) {
foreach my $c (sort {$a cmp $b} $graph->vertices) {
my $degree = $graph->vertex_degree($c);
next unless $degree <= 1;
my ($v) = $graph->neighbours($c)
or return $data{$c}; # root
$data{$v} //= tree_minimal_domsets_count_data_initial();
tree_minimal_domsets_count_data_product_into
($data{$v},
delete($data{$c}) // tree_minimal_domsets_count_data_initial());
$graph->delete_vertex($c);
next OUTER;
}
die "oops, not a tree $graph";
}
}
sub tree_minimal_domsets_count_data_initial {
my $zero = Math::BigInt->new(0);
my $one = Math::BigInt->new(1);
$zero = 0;
$one = 1;
return { with => $one,
with_notreq => $one,
with_min_notreq => $one,
without_dom_sole => $zero,
without_notsole => $one,
without_undom => $one,
};
}
sub tree_minimal_domsets_count_data_ret {
my ($data) = @_;
return ($data ->{'with'}
- $data->{'with_notreq'}
+ $data->{'with_min_notreq'}
+ $data->{'without_dom_sole'}
+ $data->{'without_notsole'}
- $data->{'without_undom'});
}
# The args are 0 or more tree_minimal_domsets hashrefs.
# Return their product. This is a tree_minimal_domsets hashref for a
# vertex which has the given args as child vertices.
#
sub tree_minimal_domsets_count_data_product {
return tree_minimal_domsets_count_data_product_into
(tree_minimal_domsets_count_data_initial(), @_);
}
# $p is a tree_minimal_domsets hashref and zero or more further args likewise
# which are children of $p.
# Return their product for $p with those children.
#
sub tree_minimal_domsets_count_data_product_into {
### tree_minimal_domsets_count_data_product_into() ...
my $p = shift;
### $p
foreach my $v (@_) {
# ### $v
my $v_with_notmin_notreq = $v->{'with_notreq'} - $v->{'with_min_notreq'};
my $v_without_dom_notsole = $v->{'without_notsole'} - $v->{'without_undom'};
my $v_without_dom = $v->{'without_dom_sole'} + $v_without_dom_notsole;
my $v_mindom = ($v->{'with'} - $v_with_notmin_notreq # with_min
+ $v_without_dom);
my $v_with_req = $v->{'with'} - $v->{'with_notreq'};
$p->{'with'} *= $v_with_req + $v->{'without_notsole'};
$p->{'with_notreq'} *= $v_with_req + $v_without_dom_notsole;
$p->{'with_min_notreq'} *= $v_without_dom_notsole;
$p->{'without_dom_sole'} = ($p->{'without_dom_sole'} * $v_without_dom
+ $p->{'without_undom'} * $v_with_notmin_notreq);
$p->{'without_notsole'} *= $v_mindom;
$p->{'without_undom'} *= $v_without_dom;
}
return $p;
}
# $graph is a Graph.pm.
# $aref is an arrayref of vertex names.
# Return true if these vertices are a dominating set in $graph.
#
sub Graph_is_domset {
my ($graph, $aref) = @_;
my %vertices; @vertices{$graph->vertices} = ();
delete @vertices{@$aref,
map {$graph->neighbours($_)} @$aref};
return keys(%vertices) == 0;
}
# $graph is a Graph.pm.
# $aref is an arrayref of vertex names.
# Return true if these vertices are minimal for the amount of $graph they
# dominate, meaning any vertex removed would reduce the amount of $graph
# dominated.
#
sub Graph_domset_is_minimal {
my ($graph, $aref) = @_;
my %count;
foreach my $v (@$aref) {
foreach my $d ($v, $graph->neighbours($v)) {
$count{$d}++;
}
}
V: foreach my $v (@$aref) {
foreach my $d ($v, $graph->neighbours($v)) {
if ($count{$d} < 2) { next V; }
}
return 0; # $v and neighbours all count >=2
}
return 1;
}
# $graph is a Graph.pm.
# $aref is an arrayref of vertex names.
# Return true if these vertices are a minimal dominating set in $graph.
#
sub Graph_is_minimal_domset {
my ($graph, $aref) = @_;
return Graph_is_domset($graph,$aref) && Graph_domset_is_minimal($graph,$aref);
}
# Return the number of minimal dominating sets in $graph by iterating
# through all vertex sets and testing by the Graph_is_minimal_domset()
# predicate. This is quite slow so suitable only for small number of
# vertices.
#
sub Graph_minimal_domsets_count_by_pred {
my ($graph) = @_;
return Graph_sets_count_by_pred($graph, \&Graph_is_minimal_domset);
}
sub Graph_sets_count_by_pred {
my ($graph, $func) = @_;
require Algorithm::ChooseSubsets;
my $count = 0;
my @vertices = sort $graph->vertices;
my $it = Algorithm::ChooseSubsets->new(\@vertices);
while (my $aref = $it->next) {
if ($func->($graph,$aref)) {
$count++;
}
}
return $count;
}
sub Graph_sets_minimum_and_count_by_pred {
my ($graph, $func) = @_;
require Algorithm::ChooseSubsets;
my @count;
my $minsize = $graph->vertices;
my @vertices = sort $graph->vertices;
my $it = Algorithm::ChooseSubsets->new(\@vertices);
while (my $aref = $it->next) {
my $size = @$aref;
next if $size > $minsize;
if ($func->($graph,$aref)) {
$count[$size]++;
$minsize = min($minsize,$size);
}
}
return ($minsize, $count[$minsize]);
}
#------------------------------------------------------------------------------
# Total Dominating Sets
# $graph is a Graph.pm.
# $aref is an arrayref of vertex names.
# Return true if these vertices are a total dominating set in $graph.
# Every vertex must have one of $aref as a neighbour.
# Unlike a plain dominating set, $aref vertices to not dominate themselves,
# they must have a neighbour in the set.
#
sub Graph_is_total_domset {
my ($graph, $aref) = @_;
my %vertices; @vertices{$graph->vertices} = ();
delete @vertices{map {$graph->neighbours($_)} @$aref};
return keys(%vertices) == 0;
}
#------------------------------------------------------------------------------
# $graph is a Graph.pm and $sptg is its $graph->SPT_Dijkstra() tree.
# Set $sptg vertex attribute "count" on each vertex $v which gives the count
# of number of paths from SPT_Dijkstra_root to that $v.
#
sub Graph_SPT_counts {
my ($graph,$sptg, %options) = @_;
my $start = $sptg->get_graph_attribute('SPT_Dijkstra_root');
my $one = $options{'one'} || 1;
$sptg ->set_vertex_attribute ($start,'count',$one);
foreach my $from (sort {($sptg->get_vertex_attribute($a,'weight') || 0)
<=>
($sptg->get_vertex_attribute($b,'weight') || 0)}
$sptg->vertices) {
my $target_distance
= ($sptg->get_vertex_attribute($from,'weight') || 0) + 1;
my $from_count = $sptg ->get_vertex_attribute($from,'count');
### from: $from . ' weight ' .($sptg->get_vertex_attribute($from,'weight') || 0)
### $from_count
### $target_distance
foreach my $to ($graph->neighbours($from)) {
if (($sptg->get_vertex_attribute($to,'weight') || 0)
== $target_distance) {
### to: $to . ' weight ' .($sptg->get_vertex_attribute($to,'weight') || 0)
$sptg ->set_vertex_attribute
($to,'count',
$from_count + ($sptg ->get_vertex_attribute($to,'count') || 0));
} else {
### skip: $to . ' weight ' .($sptg->get_vertex_attribute($to,'weight') || 0)
}
}
}
}
#------------------------------------------------------------------------------
# Cycles
sub Graph_is_cycle {
my ($graph, $aref) = @_;
foreach my $i (0 .. $#$aref) {
$graph->has_edge($aref->[$i], $aref->[$i-1]) or return 0;
}
return 1;
}
# $graph is a Graph.pm. Find all cycles in it.
# The return is a list of arrayrefs, with each arrayref containing vertices
# which are a cycle.
# Each cycle appears just once, so just one direction around, not both ways.
#
# The order of vertices within each cycle and the order of cycles in the
# return are both unspecified. Within each cycle has a canonical order, but
# don't rely on that. The order of cycles is hash-random.
#
sub Graph_find_all_cycles {
my ($graph) = @_;
my @paths = map {[$_]} $graph->vertices;
my @cycles;
while (@paths) {
### num paths: scalar @paths
my @new_paths;
foreach my $path (@paths) {
NEIGHBOUR: foreach my $next ($graph->neighbours($path->[-1])) {
next if $next lt $path->[0]; # must have start smallest
if ($next eq $path->[0]) { # back to start, len=1 or >=3
Graph_is_cycle($graph, $path) or die;
if (@$path!=2
&& $path->[1] lt $path->[-1]) { # direction smaller second only
push @cycles, $path;
}
} else {
foreach my $i (1 .. $#$path) {
next NEIGHBOUR if $next eq $path->[$i]; # back to non-start
}
push @new_paths, [ @$path, $next ];
}
}
}
@paths = @new_paths;
}
return @cycles;
}
sub Graph_num_cycles {
my ($graph) = @_;
my @cycles = Graph_find_all_cycles($graph);
return scalar @cycles;
}
# Return true if $graph has a bi-cyclic component, meaning a connected
# component with 2 or more cycles in it.
sub Graph_has_bicyclic_component {
my ($graph) = @_;
my @components = $graph->connected_components;
foreach my $component (@components) {
my $subgraph = $graph->subgraph($component);
if (MyGraphs::Graph_num_cycles($subgraph) >= 2) {
return 1;
}
}
return 0;
}
# length of the smallest cycle in $graph
sub Graph_girth {
my ($graph) = @_;
### Graph_girth() ...
my $num_vertices = scalar $graph->vertices;
my $girth;
my $min = $graph->is_directed ? 1 : 3;
OUTER: foreach my $from ($graph->vertices) {
### $from
my %seen = ($from => 1);
my @pending = ($from);
foreach my $len (1 .. ($girth||$num_vertices)) {
### at: "len=$len pending=".join(' ',@pending)
my @new_pending;
foreach my $to (map {$graph->successors($_)} @pending) {
if ($len>=$min && $to eq $from) {
### cycle: "to=$to len=$len"
if (!defined $girth || $len < $girth) {
### is new low ...
$girth = $len;
}
next OUTER;
}
unless ($seen{$to}++) {
push @new_pending, $to;
}
}
@pending = @new_pending;
}
}
return $girth;
}
# $graph is an undirected Graph.pm.
# If $v is in a hanging cycle, other than the attachment point, then return
# an arrayref of the vertices of that cycle other than the attachment point
# (in an unspecified order).
# For example,
#
# 4---5
# \ /
# 1---2---3---6
#
# has hanging cycle 3,4,5. $v=4 or $v=5 gives return is [4,5].
# If $v is not in a hanging cycle then return undef.
#
sub Graph_is_hanging_cycle {
my ($graph, $v) = @_;
if ($graph->degree($v) != 2) { return undef; }
my %cycle = ($v => 1);
my @pending = $graph->neighbours($v);
my @end;
while (@pending) {
$v = pop @pending;
next if $cycle{$v};
if ($graph->degree($v) != 2) {
push @end, $v;
next;
}
$cycle{$v} = 1;
push @pending, $graph->neighbours($v);
}
if (@end == 0 || (@end==2 && $end[0] eq $end[1])) {
return [ keys %cycle ];
} else {
return undef;
}
}
# $graph is an undirected Graph.pm.
# Modify $graph to remove any hanging cycles.
# For example,
#
# 4---5
# \ /
# 1---2---3---6
#
# has hanging cycle 3,4,5. Vertices 4,5 are removed.
#
sub Graph_delete_hanging_cycles {
my ($graph) = @_;
my $count = 0;
MORE: for (;;) {
foreach my $v ($graph->vertices) {
if (my $aref = Graph_is_hanging_cycle($graph,$v)) {
$graph->delete_vertices(@$aref);
$count++;
next MORE;
}
}
last;
}
if ($count
&& defined(my $name = $graph->get_graph_attribute('name'))) {
$graph->set_graph_attribute (name => "$name, stripped hanging");
}
return $count;
}
# d-----c
# | |
# a-----b
sub Graph_find_all_4cycles {
my ($graph, %options) = @_;
### Graph_find_all_4cycles() ...
my $callback = $options{'callback'} || sub{};
my %seen;
foreach my $a (sort $graph->vertices) {
my @a_neighbours = $graph->neighbours($a);
### a: "$a to ".join(',',@a_neighbours)
foreach my $b (@a_neighbours) {
next if $b eq $a; # ignore self-loops
my @b_neighbours = $graph->neighbours($b);
if (! $graph->has_edge($a,$b)) {
print " a=$a\n";
foreach my $neighbour (@a_neighbours) {
print " $neighbour\n";
}
die "oops, no edge $a to $b";
}
foreach my $c (@b_neighbours) {
next if $c eq $a;
next if $c eq $b;
my @c_neighbours = $graph->neighbours($c);
if (! $graph->has_edge($b,$c)) {
die "oops";
}
foreach my $d (@c_neighbours) {
if (! $graph->has_edge($c,$d)) {
die "oops";
}
next if $d eq $a;
next if $d eq $b;
next if $d eq $c;
my @d_neighbours = $graph->neighbours($d);
### $d
### cycle: "$a $b $c $d goes ".join(',',@d_neighbours)
next unless $graph->has_edge($d,$a) || $graph->has_edge($a,$d);
next if $seen{$a,$b,$c,$d}++;
next if $seen{$b,$c,$d,$a}++;
next if $seen{$c,$d,$a,$b}++;
next if $seen{$d,$a,$b,$c}++;
next if $seen{$d,$c,$b,$a}++;
next if $seen{$c,$b,$a,$d}++;
next if $seen{$b,$a,$d,$c}++;
next if $seen{$a,$d,$c,$b}++;
# print "raw ",join(' -- ',($a,$b,$c,$d)),"\n";
# print " has_edge ",$graph->has_edge($a,$b),"\n";
# print " has_edge ",$graph->has_edge($b,$c),"\n";
# print " has_edge ",$graph->has_edge($c,$d),"\n";
# print " has_edge ad ",$graph->has_edge($d,$a),"\n";
# must not mutate the loop variables $a,$b,$c,$d, so @cycle
my @cycle = ($a,$b,$c,$d);
my $min = minstr(@cycle);
while ($cycle[0] ne $min) { # rotate to $cycle[0] the minimum
push @cycle, (shift @cycle);
}
$callback->(@cycle);
}
}
}
}
return;
}
#------------------------------------------------------------------------------
# Euler Cycle
# Return a list of vertices v1,v2,...,vn,v1 which is an Euler cycle, so
# traverse each edge exactly once.
#
sub Graph_Euler_cycle {
my ($graph, %options) = @_;
my $type = $options{'type'} || 'cycle';
### $type
my @vertices = $graph->vertices;
my $func = cmp_func(@vertices);
@vertices = sort $func @vertices;
my @edges = $graph->edges;
my $num_edges = scalar(@edges);
my @edge_keys = map {join(' to ',@$_)} @edges;
my %edge_keys = map { my $key = join(' to ',@$_);
($key => $key,
join(' to ',reverse @$_) => $key)
} @edges;
my %neighbours;
foreach my $v (@vertices) {
$neighbours{$v} = [ sort $func $graph->neighbours($v) ];
}
my @path = $vertices[0];
my $try;
$try = sub {
my ($visited) = @_;
if (scalar(keys %$visited) >= $num_edges) {
return 1;
}
my $v = $path[-1];
foreach my $to (@{$neighbours{$v}}) {
my $edge = $edge_keys{"$v to $to"};
next if $visited->{$edge};
push @path, $to;
if ($try->({ %$visited, $edge => 1 })) {
return 1;
}
pop @path;
}
return 0;
};
if ($try->({})) {
return @path;
} else {
return;
}
# my @path;
# my %visited;
# my $v = $vertices[0];
# my @nn = (-1);
# my $upto = 0;
# for (;;) {
# my $v = $path[$upto];
# my $n = ++$nn[$upto];
# my $to = $neighbours{$v}->[$n];
# ### at: join('--',@path) . " upto=$upto v=$v n=$n"
# ### $to
# ### assert: 0 <= $n && $n <= $#{$neighbours{$v}}+1
# if (! defined $to) {
# ### no more neighbours, backtrack ...
# $visited{$v} = 0;
# $upto--;
# last if $upto < 0;
# next;
# }
# if ($visited{$to}) {
# ### to is visited ...
# if ($upto == $num_vertices-1
# && ($type eq 'path'
# || $to eq $path[0])) {
# ### found path or cycle ...
# if ($options{'verbose'}) { print "found ",join(',',@path),"\n"; }
# if ($options{'found_coderef'}) { $options{'found_coderef'}->(@path); }
# if (! $options{'all'}) { return 1; }
# }
# next;
# }
#
# # extend path to $to
# $upto++;
# $path[$upto] = $to;
# $visited{$to} = 1;
# $nn[$upto] = -1;
# }
}
#------------------------------------------------------------------------------
# Hamiltonian Cycle
# $graph is a Graph.pm.
# Return true if it has a Hamiltonian cycle (a cycle visiting all vertices
# once each). Key/value options are
#
# type => "cycle" or "path" (default "cycle")
#
# type "path" means search for a Hamiltonian path (a path visiting all
# vertices once each).
#
# Currently this is a depth first search so quite slow and suitable only for
# a small number of vertices.
#
sub Graph_is_Hamiltonian {
my ($graph, %options) = @_;
my $type = $options{'type'} || 'cycle';
### $type
my @vertices = $graph->vertices;
my $num_vertices = scalar(@vertices);
my %neighbours;
foreach my $v (@vertices) {
$neighbours{$v} = [ $graph->neighbours($v) ];
}
foreach my $start (defined $options{'start'} ? $options{'start'}
: $type eq 'path' ? @vertices
: $vertices[0]) {
if ($options{'verbose'}) { print "try start $start\n"; }
my @path = ($start);
my %visited = ($path[0] => 1);
my @nn = (-1);
my $upto = 0;
for (;;) {
my $v = $path[$upto];
my $n = ++$nn[$upto];
my $to = $neighbours{$v}->[$n];
### at: join('--',@path) . " upto=$upto v=$v n=$n"
### $to
### assert: 0 <= $n && $n <= $#{$neighbours{$v}}+1
if (! defined $to) {
### no more neighbours, backtrack ...
$visited{$v} = 0;
$upto--;
last if $upto < 0;
next;
}
if ($visited{$to}) {
### to is visited ...
if ($upto == $num_vertices-1
&& ($type eq 'path'
|| $to eq $path[0])) {
### found path or cycle ...
if ($options{'verbose'}) { print "found ",join(',',@path),"\n"; }
if ($options{'found_coderef'}) { $options{'found_coderef'}->(@path); }
if (! $options{'all'}) { return 1; }
}
next;
}
# extend path to $to
$upto++;
$path[$upto] = $to;
$visited{$to} = 1;
$nn[$upto] = -1;
}
}
return 0;
}
#------------------------------------------------------------------------------
# Directed Graphs
# $graph is a directed Graph.pm.
# Return the number of maximal paths.
# A maximal path is from a predecessorless to a successorless.
# There might be multiple paths between a given predecessorless and
# successorless. All such paths are counted.
#
sub Graph_num_maximal_paths {
my ($graph) = @_;
### Graph_num_maximal_paths() ...
$graph->expect_directed;
my %indegree_remaining;
my %ways;
my %pending;
foreach my $v ($graph->vertices) {
$pending{$v} = 1;
if ($indegree_remaining{$v} = $graph->in_degree($v)) {
$ways{$v} = 0;
} else {
$ways{$v} = 1;
}
}
my $ret = 0;
while (%pending) {
### at pending: scalar(keys %pending)
my $progress;
foreach my $v (keys %pending) {
if ($indegree_remaining{$v}) {
### not ready: "$v indegree_remaining $indegree_remaining{$v}"
### assert: $indegree_remaining{$v} >= 0
next;
}
delete $pending{$v};
my @successors = $graph->successors($v);
if (@successors) {
foreach my $to (@successors) {
### edge: "$v to $to countedge ".$graph->get_edge_count($v,$to)
$pending{$to} or die "oops, to=$to not pending";
$ways{$to} += $ways{$v} * $graph->get_edge_count($v,$to);
$indegree_remaining{$to}--;
$progress = 1;
}
} else {
# successorless
$ret += $ways{$v};
}
}
if (%pending && !$progress) {
die "Graph_num_maximal_paths() oops, no progress, circular graph";
}
}
return $ret;
}
#------------------------------------------------------------------------------
# Lattices
# $graph is a directed Graph.pm.
# Return the number of pairs of comparable elements $u,$v, meaning pairs
# where there is a path from $u to $v. The count includes $u,$u empty path.
# For a lattice graph, this is the number of "intervals" in the lattice.
#
sub Graph_num_intervals {
my ($graph) = @_;
my $ret = 0;
foreach my $v ($graph->vertices) {
$ret += 1 + $graph->all_successors($v);
}
return $ret;
}
sub Graph_successors_matrix {
my ($graph, $vertices_aref, $vertex_to_index_href) = @_;
### $vertices_aref
### $vertex_to_index_href
my @ret;
foreach my $i_from (0 .. $#$vertices_aref) {
foreach my $to ($graph->successors($vertices_aref->[$i_from])) {
my $i_to = $vertex_to_index_href->{$to}
// die "oops, not found: $to";
$ret[$i_from]->[$i_to] = 1;
}
}
return \@ret;
}
sub Graph_reachable_matrix {
my ($graph, $vertices_aref, $vertex_to_index_href) = @_;
my $ret
= Graph_successors_matrix($graph,$vertices_aref,$vertex_to_index_href);
foreach my $i (0 .. $#$vertices_aref) {
$ret->[$i]->[$i] = 1;
}
my $more = 1;
while ($more) {
$more = 0;
foreach my $i (0 .. $#$vertices_aref) {
foreach my $j (0 .. $#$vertices_aref) {
foreach my $k (0 .. $#$vertices_aref) {
if ($ret->[$i]->[$j] && $ret->[$j]->[$k]
&& ! $ret->[$i]->[$k]) {
$ret->[$i]->[$k] = 1;
$more = 1;
}
}
}
}
}
return $ret;
}
# $graph is a directed Graph.pm which is a lattice.
# Return its "intervals lattice".
#
# An interval is a pair [$x,$y] with $y reachable from $x.
# Each vertex of the intervals lattice is such an interval, in the form of a
# string "$x-$y". Edges are from "$x-$y" to "$u-$v" where $x < $u and $y < $v,
# where < means $u reachable from $x, and $v reachable from $y.
#
sub Graph_make_intervals_lattice {
my ($graph, $covers) = @_;
$graph->expect_directed;
my $intervals = Graph->new;
my @vertices = $graph->vertices;
my %vertex_to_index;
@vertex_to_index{@vertices} = (0 .. $#vertices);
my $graph_reachable
= Graph_reachable_matrix($graph, \@vertices, \%vertex_to_index);
### $graph_reachable
sum(map{sum(map {$_||0} @$_)} @$graph_reachable) == Graph_num_intervals($graph) or die;
my %intervals;
foreach my $a (0 .. $#vertices) {
foreach my $b (0 .. $#vertices) {
next unless $graph_reachable->[$a]->[$b];
my $from = "$vertices[$a]-$vertices[$b]";
$intervals->add_vertex($from);
$intervals{$from} = [$a,$b];
}
}
foreach my $from (keys %intervals) {
my $from_aref = $intervals{$from};
foreach my $to (keys %intervals) {
next if $to eq $from;
my $to_aref = $intervals{$to};
next unless $graph_reachable->[$from_aref->[0]]->[$to_aref->[0]];
next unless $graph_reachable->[$from_aref->[1]]->[$to_aref->[1]];
### $from
### $to
# print "$a $b $c $d\n";
# next if $covers && defined $intervals->path_length($from,$to);
$intervals->add_edge($from, $to);
}
}
return $covers ? Graph_covers($intervals) : $intervals;
# $graph->expect_directed;
# my $intervals = Graph->new;
# foreach my $a ($graph->vertices) {
# foreach my $b ($graph->vertices) {
# next unless defined $graph->path_length($a,$b);
# my $from = "$a -- $b";
#
# foreach my $c ($graph->vertices) {
# next unless defined $graph->path_length($a,$c);
# foreach my $d ($graph->vertices) {
# next unless defined $graph->path_length($c,$d);
# next unless defined $graph->path_length($b,$d);
# my $to = "$c -- $d";
# next if $to eq $from;
# # print "$a $b $c $d\n";
# next if $covers && defined $intervals->path_length($from,$to);
# $intervals->add_edge($from, $to);
# }
# }
# }
# }
# return $covers ? Graph_covers($intervals) : $intervals;
}
# $graph is a directed Graph.pm which is expected to be acyclic.
# Delete edges to leave just its cover relations.
#
# At some from->to, if there is also from->mid->to then edge from->to is not
# a cover and is deleted.
#
sub Graph_covers {
my ($graph) = @_;
$graph->expect_acyclic;
my @vertices = $graph->vertices;
my %vertex_to_index;
@vertex_to_index{@vertices} = (0 .. $#vertices);
my $reachable
= Graph_reachable_matrix($graph, \@vertices, \%vertex_to_index);
foreach my $from (0 .. $#vertices) {
foreach my $mid (0 .. $#vertices) {
next if $from == $mid;
next unless $reachable->[$from]->[$mid];
foreach my $to (0 .. $#vertices) {
next if $mid == $to;
next unless $reachable->[$mid]->[$to];
$graph->delete_edge($vertices[$from],$vertices[$to]);
}
}
}
return $graph;
}
# $graph is a directed Graph.pm which is expected to be a lattice.
# Return its unique lowest element.
sub Graph_lattice_lowest {
my ($graph) = @_;
my @predecessorless = $graph->predecessorless_vertices;
@predecessorless==1
or die "Graph_lattice_lowest() oops, expected one predecessorless";
return $predecessorless[0];
}
# $graph is a directed Graph.pm which is expected to be a lattice.
# Return its unique highest element.
sub Graph_lattice_highest {
my ($graph) = @_;
my @successorless = $graph->successorless_vertices;
@successorless==1
or die "Graph_lattice_highest() oops, expected one successorless";
return $successorless[0];
}
# $graph is a directed Graph.pm which is expected to be a lattice.
# Return $href where
# $href->{'max'}->{$x}->{$y} is the lattice max($x,y)
# $href->{'min'}->{$x}->{$y} is the lattice min($x,y)
#
sub Graph_lattice_minmax_hash {
my ($graph) = @_;
my $verbose = 1;
my %hash;
my @vertices = $graph->vertices;
foreach my $elem (['all_successors','max'],
['all_predecessors','min']) {
my ($all_method, $key) = @$elem;
# $all_successors{$x}->{$y} = boolean, true x has y after it, false if not.
# x is a successor of itself ($graph->all_successors doesn't include x
# itself).
my %all_successors;
foreach my $x (@vertices) {
$all_successors{$x}->{$x} = 1;
foreach my $s ($graph->$all_method($x)) {
$all_successors{$x}->{$s} = 1;
}
}
# For each pair x,y look at the common successors and choose the smallest.
# Smallest in the sense the smaller has bigger among its successors.
foreach my $x (@vertices) {
my $xs_href = $all_successors{$x};
foreach my $y (@vertices) {
my $ys_href = $all_successors{$y};
my $m;
foreach my $xs (keys %$xs_href) {
if ($ys_href->{$xs}) { # common successor
if (!defined $m || $all_successors{$xs}->{$m}) {
$m = $xs; # which is before best $m so far
}
}
}
$hash{$key}->{$x}->{$y} = $m;
}
}
}
return \%hash;
# foreach my $v (@vertices) {
# $hash{'max'}->{$v}->{$v}
# = $hash{'min'}->{$v}->{$v} = $v;
# }
# foreach my $x (@vertices) {
# foreach my $y ($graph->all_successors($x)) {
# $hash{'max'}->{$x}->{$y}
# = $hash{'max'}->{$y}->{$x} = $y;
# if ($verbose) { print "successor $x max $y = $y\n"; }
# }
# foreach my $y ($graph->all_predecessors($x)) {
# $hash{'min'}->{$x}->{$y}
# = $hash{'min'}->{$y}->{$x} = $y;
# if ($verbose) { print "predecessor $x min $y = $y\n"; }
# }
# }
# my $more = 1;
# while ($more) {
# $more = 0;
# foreach my $M ('min','max') {
# foreach my $x (@vertices) {
# foreach my $y (@vertices) {
# if (defined(my $m $hash{$M}->{$x}->{$y})) {
# foreach my $z (@vertices) {
#
# if (defined(my $m = $hash{'max'}->{$y}->{$z})) {
# $more = 1;
# $hash{'max'}->{$x}->{$y}
# = $hash{'max'}->{$y}->{$x}
# = $m;
# if ($verbose) { print "chain $x max $y = $m from $z\n"; }
# }
# }
# }
# if (! defined $hash{'min'}->{$x}->{$y}) {
# foreach my $z ($graph->predecessors($y)) {
# if (defined(my $m = $hash{'min'}->{$x}->{$z})) {
# $more = 1;
# $hash{'min'}->{$x}->{$y}
# = $hash{'min'}->{$y}->{$x}
# = $m;
# if ($verbose) { print "chain $x min $y = $m from $z\n"; }
# }
# }
# }
# }
# }
# }
# my $more = 1;
# while ($more) {
# $more = 0;
# foreach my $x (@vertices) {
# foreach my $y (@vertices) {
# if (! defined $hash{'max'}->{$x}->{$y}) {
# foreach my $z ($graph->successors($y)) {
# if (defined(my $m = $hash{'max'}->{$x}->{$z})) {
# $more = 1;
# $hash{'max'}->{$x}->{$y}
# = $hash{'max'}->{$y}->{$x}
# = $m;
# if ($verbose) { print "chain $x max $y = $m from $z\n"; }
# }
# }
# }
# if (! defined $hash{'min'}->{$x}->{$y}) {
# foreach my $z ($graph->predecessors($y)) {
# if (defined(my $m = $hash{'min'}->{$x}->{$z})) {
# $more = 1;
# $hash{'min'}->{$x}->{$y}
# = $hash{'min'}->{$y}->{$x}
# = $m;
# if ($verbose) { print "chain $x min $y = $m from $z\n"; }
# }
# }
# }
# }
# }
# }
#
# return \%hash;
}
# $graph is a directed Graph.pm which is expected to be a lattice.
# $href is a hashref as returned by Graph_lattice_minmax_hash().
# Check that the relations in $href follow the lattice rules.
# die() if bad.
#
sub Graph_lattice_minmax_validate {
my ($graph, $href) = @_;
my $str = Graph_lattice_minmax_reason($graph,$href);
if ($str) {
die 'Graph_lattice_minmax_validate() ', $str;
}
}
# $graph is a directed Graph.pm which is expected to be a lattice.
# $href is a hashref as returned by Graph_lattice_minmax_hash().
# Check that the relations in $href follow the lattice rules.
# If good then return empty string ''.
# If bad then return a string describing the problem.
#
sub Graph_lattice_minmax_reason {
my ($graph, $href) = @_;
# defined
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
foreach my $M ('min','max') {
defined $href->{$M}->{$x}->{$y}
or return "missing $x $M $y";
}
}
}
# commutative
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
foreach my $M ('min','max') {
$href->{$M}->{$x}->{$y} eq $href->{$M}->{$y}->{$x}
or return "not commutative $x $M $y";
}
}
}
# idempotent
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
foreach my $M ('min','max') {
my $m = $href->{$M}->{$x}->{$y};
$href->{$M}->{$x}->{$m} eq $m
or return "not idempotent $x $M $y";
}
}
}
# absorptive a ^ (a v b) = a v (a ^ b) = a
# L H
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
my $min = $href->{'min'}->{$x}->{$y};
my $max = $href->{'max'}->{$x}->{$y};
my $a = $href->{'max'}->{$x}->{$min};
my $b = $href->{'min'}->{$x}->{$max};
($a eq $x && $b eq $x)
or return "not absorptive $x and $y min $min max $max got $a and $b";
}
}
# associative (xy)z = x(yz)
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
foreach my $z ($graph->vertices) {
foreach my $M ('min','max') {
my $a = $href->{$M}->{$href->{$M}->{$x}->{$y}}->{$z};
my $b = $href->{$M}->{$x}->{$href->{$M}->{$y}->{$z}};
$a eq $b
or return "not associative $x $M $y $M $z got $a and $b";
}
}
}
}
return '';
}
# $graph is a directed Graph.pm which is a lattice.
# $href is a hashref as returned by Graph_lattice_minmax_hash().
# Return true if $graph is semi-distributive.
#
sub lattice_minmax_is_semidistributive {
my ($graph, $href) = @_;
foreach my $x ($graph->vertices) {
foreach my $y ($graph->vertices) {
my $m = $href->{'min'}->{$x}->{$y};
my $M = $href->{'max'}->{$x}->{$y};
foreach my $z ($graph->vertices) {
if ($m eq $href->{'min'}->{$x}->{$z}) {
$href->{'min'}->{$x}->{$href->{'max'}->{$y}->{$z}} eq $m
or return 0;
}
if ($M eq $href->{'max'}->{$x}->{$z}) {
$href->{'max'}->{$x}->{$href->{'min'}->{$y}->{$z}} eq $M
or return 0;
}
}
}
}
}
# $graph is a directed Graph.pm which is a lattice.
# $href is a hashref as returned by Graph_lattice_minmax_hash().
# Return the number of complementary pairs in $graph.
# A complementary pair is vertices u,v where
# min(u,v) = global min and max(u,v) = global max
# so they neither meet nor join other than the global min,max.
#
# u = global min and v = global max is always a complementary pair.
# If the lattice is just 1 vertex then this includes u=v as a pair.
#
sub lattice_minmax_num_complementary_pairs {
my ($graph, $href) = @_;
my $lowest = MyGraphs::Graph_lattice_lowest($graph);
my $highest = MyGraphs::Graph_lattice_highest($graph);
my @vertices = $graph->vertices;
my $count_complementary = 0;
foreach my $i (0 .. $#vertices) {
my $u = $vertices[$i];
foreach my $j ($i .. $#vertices) {
my $v = $vertices[$j];
my $min = $href->{'min'}->{$u}->{$v};
my $max = $href->{'max'}->{$u}->{$v};
$count_complementary += ($min eq $lowest && $max eq $highest);
}
}
return $count_complementary;
}
# Think not efficient to check pair-by-pair.
#
# # Return true if $u and $v are complementary, meaning their min is the
# # bottom element and max is the top element.
# sub lattice_is_complementary {
# my ($graph, $u,$v) = @_;
# return lattice_min($graph, $u,$v) eq Graph_lattice_lowest($graph)
# && lattice_max($graph, $u,$v) eq Graph_lattice_highest($graph);
# }
# Is it efficient to search lattice min(x,y) or max(x,y), or better always
# build whole table?
#
# sub lattice_min {
# my ($graph, $u, $v) = @_;
# return lattice_min_or_max($graph,$u,$v, 'predecessors', 'all_predecessors');
# }
# sub lattice_max {
# my ($graph, $u, $v) = @_;
# return lattice_min_or_max($graph,$u,$v, 'successors', 'all_successors');
# }
# sub lattice_min_or_max {
# my ($graph, $u, $v, $immediate, $all) = @_;
#
# die "WRONG";
#
# my @verts = ($u,$v);
# my @verts_descendants;
# foreach my $i (0,1) {
# $verts_descendants[$i]->[0]->{$verts[$i]} = 1;
# }
# for (my $distance = 0; ; $distance++) {
# foreach my $i (0,1) {
# foreach my $from (keys %{$verts_descendants[$i]->[$distance]}) {
# foreach my $to_distance (0 .. $distance) {
# if ($verts_descendants[!$i]->[$to_distance]->{$from}) {
# return $from;
# }
# }
# }
# }
# foreach my $i (0,1) {
# $verts_descendants[$i]->[$distance+1]
# = graph_following_set_hashref($graph,$immediate,
# $verts_descendants[$i]->[$distance]);
# }
# if (! $verts_descendants[0]->[$distance+1]
# && ! $verts_descendants[1]->[$distance+1]) {
# die "lattice_min_or_max() not found";
# }
# }
#
# # my %v_successors; @v_successors{$v, $graph->$all($v)} = (); # hash slice
# # my %t = ($u => 1);
# # while (%t) {
# # foreach my $t (keys %t) {
# # if (exists $v_successors{$t}) {
# # return $t;
# # }
# # }
# # my %new_t;
# # foreach my $t (keys %t) {
# # @new_t{$graph->$immediate($t)} = (); # hash slice
# # }
# # %t = %new_t;
# # }
# # die "lattice_min_or_max() not found";
# }
# sub graph_following_set_hashref {
# my ($graph, $method, $href) = @_;
# my %ret;
# foreach my $v (keys %$href) {
# @ret{$graph->$method($v)} = (); # hash slice
# }
# return \%ret;
# }
#------------------------------------------------------------------------------
1;
__END__
Math-PlanePath-129/devel/lib/Math/ 0002755 0001750 0001750 00000000000 14001441522 014437 5 ustar gg gg Math-PlanePath-129/devel/lib/Math/SquareRadical.pm 0000644 0001750 0001750 00000011476 13734026652 017543 0 ustar gg gg # Copyright 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see 2> parameter can give a second copy of the spiral
rotated 180 degrees. With two arms all points of the plane are covered.
93--91 81--79--77--75 57--55 45--43--41--39 122-124 ..
| | | | | | | | | | |
95 89 83 69--71--73 59 53 47 33--35--37 120 126 132
| | | | | | | | | | |
97 87--85 67--65--63--61 51--49 31--29--27 118 128-130
| | |
99-101-103 22--20 10-- 8-- 6-- 4 13--15 25 116-114-112
| | | | | | | | |
109-107-105 24 18 12 1 0-- 2 11 17 23 106-108-110
| | | | | | | | |
111-113-115 26 16--14 3-- 5-- 7-- 9 19--21 104-102-100
| | |
129-127 117 28--30--32 50--52 62--64--66--68 86--88 98
| | | | | | | | | | |
131 125 119 38--36--34 48 54 60 74--72--70 84 90 96
| | | | | | | | | | |
.. 123-121 40--42--44--46 56--58 76--78--80--82 92--94
The first arm is the even numbers N=0,2,4,etc and the second arm is the odd
numbers N=1,3,5,etc.
=head2 Wunderlich Serpentine Curve
The way the ends join makes little "S" shapes similar to the PeanoCurve.
The first is at N=5 to N=13,
11-10 5
| | |
12 9 6
| | |
13 8--7
The wider parts then have these sections alternately horizontal or vertical
in the style of Walter Wunderlich's "serpentine" type 010 101 010 curve.
For example the 9x9 block N=41 to N=101,
61--62 67--68--69--70 115-116 121
| | | | | | |
60 63 66 73--72--71 114 117 120
| | | | | | |
59 64--65 74--75--76 113 118-119
| | |
58--57--56 83--82 77 112-111-110
| | | | |
53--54--55 84 81 78 107-108-109
| | | | |
52--51--50 85 80--79 106-105-104
| | |
43--44 49 86--87--88 97--98 103
| | | | | | |
42 45 48 91--90--89 96 99 102
| | | | | | |
41 46--47 92--93--94--95 100-101
The whole curve is in fact like the Wunderlich serpentine started from the
middle. This can be seen in the two arms picture above (in mirror image of
the usual PlanePath start direction for Wunderlich's curve).
=head1 FUNCTIONS
See L for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::MooreSpiral-Enew ()>
Create and return a new path object.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
=back
=head1 FORMULAS
=head2 X,Y to N
The correspondence to Wunderlich's 3x3 serpentine curve can be used to turn
X,Y coordinates in base 3 into an N. Reckoning the innermost 3x3 as level=1
then the smallest abs(X) or abs(Y) in a level is
Xlevelmin = (3^level + 1) / 2
eg. level=2 Xlevelmin=5
which can be reversed as
level = log3floor( max(abs(X),abs(Y)) * 2 - 1 )
eg. X=7 level=log3floor(2*7-1)=2
An offset can be applied to put X,Y in the range 0 to 3^level-1,
offset = (3^level-1)/2
eg. level=2 offset=4
Then a table can give the N base-9 digit corresponding to X,Y digits
Y=2 4 3 2 N digit
Y=1 -1 0 1
Y=0 -2 -3 -4
X=0 X=1 X=2
A current rotation maintains the "S" part directions and is updated by a
table
Y=2 0 +3 0 rotation when descending
Y=1 +1 +2 +1 into sub-part
Y=0 0 +3 0
X=0 X=1 X=2
The negative digits of N represent backing up a little in some higher part.
If N goes negative at any state then X,Y was off the main curve and instead
on the second arm. If the second arm is not of interest the calculation can
stop at that stage.
It no doubt would also work to take take X,Y as balanced ternary digits
1,0,-1, but it's not clear that would be any faster or easier to calculate.
=head1 SEE ALSO
L,
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see This path is the Wythoff preliminary triangle by Clark
Kimberling,
=cut
# math-image --path=WythoffLines --output=numbers --all --size=60x14
=pod
13 | 105 118 131 144 60 65 70 75 80 85 90 95 100
12 | 97 110 47 52 57 62 67 72 77 82 87 92
11 | 34 39 44 49 54 59 64 69 74 79 84
10 | 31 36 41 46 51 56 61 66 71 76
9 | 28 33 38 43 48 53 58 63 26
8 | 25 30 35 40 45 50 55 23
7 | 22 27 32 37 42 18 20
6 | 19 24 29 13 15 17
5 | 16 21 10 12 14
4 | 5 7 9 11
3 | 4 6 8
2 | 3 2
1 | 1
Y=0 |
+-----------------------------------------------------
X=0 1 2 3 4 5 6 7 8 9 10 11 12
A coordinate pair Y and X are the start of a Fibonacci style recurrence,
F[1]=Y, F[2]=X F[i+i] = F[i] + F[i-1]
Any such sequence eventually becomes a row of the Wythoff array
(L) after some number of initial iterations.
The N value at X,Y is the row number of the Wythoff array containing
sequence beginning Y and X. Rows are numbered starting from 1. Eg.
Y=4,X=1 sequence: 4, 1, 5, 6, 11, 17, 28, 45, ...
row 7 of WythoffArray: 17, 28, 45, ...
so N=7 at Y=4,X=1
Conversely a given N is positioned in the triangle according to where row
number N of the Wythoff array "precurses" by running the recurrence in
reverse,
F[i-1] = F[i+i] - F[i]
It can be shown that such a precurse always reaches a pair Y and X with
YE=1 and 0E=XEY, hence making the triangular X,Y arrangement
above.
N=7 WythoffArray row 7 is 17,28,45,73,...
go backwards from 17,28 by subtraction
11 = 28 - 17
6 = 17 - 11
5 = 11 - 6
1 = 6 - 5
4 = 5 - 1
stop on reaching 4,1 which is Y=4,X=1 satisfying Y>=1 and 0<=X=XEY
=cut
# (r-1 + floor(r*phi)) / (r-1 + 2*floor(r*phi))
# ~= (r-1+r*phi)/(r-1+2*r*phi)
# = (r*(phi+1) - 1) / (r*(2phi+1) - 1)
# -> r*(phi+1) / r*(2*phi+1)
# = (phi+1) / (2*phi+1)
# = 1/phi = 0.618
=pod
=head1 FUNCTIONS
See L for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::WythoffLines-Enew ()>
Create and return a new path object.
=back
=head1 OEIS
The Wythoff array is in Sloane's Online Encyclopedia of Integer Sequences
in various forms,
=over
L (etc)
=back
A165360 X
A165359 Y
A166309 N by rows
=head1 SEE ALSO
L,
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see 'A068076',
func => sub {
my ($count) = @_;
my $path = Math::PlanePath::BinaryTerms->new;
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
push @got, $x-1;
}
return \@got;
});
#------------------------------------------------------------------------------
# A067576 binary by anti-diagonals upwards
MyOEIS::compare_values
(anum => 'A067576',
func => sub {
my ($count) = @_;
require Math::PlanePath::Diagonals;
my $path = Math::PlanePath::BinaryTerms->new (radix => 2);
my $diag = Math::PlanePath::Diagonals->new (direction => 'up',
x_start=>1,y_start=>1);
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, $path->xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
# A066884 binary diagonals downwards
MyOEIS::compare_values
(anum => 'A066884',
func => sub {
my ($count) = @_;
require Math::PlanePath::Diagonals;
my $path = Math::PlanePath::BinaryTerms->new;
my $diag = Math::PlanePath::Diagonals->new (x_start=>1,y_start=>1);
my @got;
for (my $d = $diag->n_start; @got < $count; $d++) {
my ($x,$y) = $diag->n_to_xy($d); # by anti-diagonals
push @got, $path->xy_to_n($x,$y);
}
return \@got;
});
# A067587 inverse
MyOEIS::compare_values
(anum => 'A067587',
func => sub {
my ($count) = @_;
require Math::PlanePath::Diagonals;
my $path = Math::PlanePath::BinaryTerms->new;
my $diag = Math::PlanePath::Diagonals->new (x_start=>1,y_start=>1);
my @got;
for (my $n = $path->n_start; @got < $count; $n++) {
my ($x,$y) = $path->n_to_xy($n);
push @got, $diag->xy_to_n($x,$y);
}
return \@got;
});
#------------------------------------------------------------------------------
exit 0;
Math-PlanePath-129/devel/lib/Math/PlanePath/Godfrey.pm 0000644 0001750 0001750 00000007720 13734026652 020273 0 ustar gg gg # Copyright 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::QuintetSide-Enew ()>
Create and return a new path object.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
Fractional C<$n> gives a point on the straight line between surrounding
integer N.
=back
=head1 SEE ALSO
L,
L
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::PyramidReplicate-Enew ()>
Create and return a new path object.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
=back
=head1 SEE ALSO
L,
L,
L,
L,
L,
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see 2> parameter can give a second copy of the spiral
rotated 180 degrees. With two arms all points of the plane are covered.
93--91 81--79--77--75 57--55 45--43--41--39 122-124 ..
| | | | | | | | | | |
95 89 83 69--71--73 59 53 47 33--35--37 120 126 132
| | | | | | | | | | |
97 87--85 67--65--63--61 51--49 31--29--27 118 128-130
| | |
99-101-103 22--20 10-- 8-- 6-- 4 13--15 25 116-114-112
| | | | | | | | |
109-107-105 24 18 12 1 0-- 2 11 17 23 106-108-110
| | | | | | | | |
111-113-115 26 16--14 3-- 5-- 7-- 9 19--21 104-102-100
| | |
129-127 117 28--30--32 50--52 62--64--66--68 86--88 98
| | | | | | | | | | |
131 125 119 38--36--34 48 54 60 74--72--70 84 90 96
| | | | | | | | | | |
.. 123-121 40--42--44--46 56--58 76--78--80--82 92--94
The first arm is the even numbers N=0,2,4,etc and the second arm is the odd
numbers N=1,3,5,etc.
=head1 FUNCTIONS
See L for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::PeanoHalf-Enew ()>
Create and return a new path object.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
=back
=head1 FORMULAS
=head2 X,Y to N
The correspondence to Wunderlich's 3x3 serpentine curve can be used to turn
X,Y coordinates in base 3 into an N. Reckoning the innermost 3x3 as level=1
then the smallest abs(X) or abs(Y) in a level is
Xlevelmin = (3^level + 1) / 2
eg. level=2 Xlevelmin=5
which can be reversed as
level = log3floor( max(abs(X),abs(Y)) * 2 - 1 )
eg. X=7 level=log3floor(2*7-1)=2
An offset can be applied to put X,Y in the range 0 to 3^level-1,
offset = (3^level-1)/2
eg. level=2 offset=4
Then a table can give the N base-9 digit corresponding to X,Y digits
Y=2 4 3 2 N digit
Y=1 -1 0 1
Y=0 -2 -3 -4
X=0 X=1 X=2
A current rotation maintains the "S" part directions and is updated by a
table
Y=2 0 +3 0 rotation when descending
Y=1 +1 +2 +1 into sub-part
Y=0 0 +3 0
X=0 X=1 X=2
The negative digits of N represent backing up a little in some higher part.
If N goes negative at any state then X,Y was off the main curve and instead
on the second arm. If the second arm is not of interest the calculation can
stop at that stage.
It no doubt would also work to take take X,Y as balanced ternary digits
1,0,-1, but it's not clear that would be any faster or easier to calculate.
=head1 SEE ALSO
L,
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see c2 or h-1c2 or h<=c1
# # so does overlap if
# # l<=c2 and h>c1
# #
# my $radix_minus_1 = $radix - 1;
# my $overlap = sub {
# my ($c,$ck,$digit, $c1,$c2) = @_;
# if ($ck & 1) {
# $digit = $radix_minus_1 - $digit;
# }
# ### overlap consider: "inv".($ck&1)."digit=$digit ".($c+$digit*$power)."<=c<".($c+($digit+1)*$power)." cf $c1 to $c2 incl"
# return ($c + $digit*$power <= $c2
# && $c + ($digit+1)*$power > $c1);
# };
#
# while ($level-- >= 0) {
# ### $power
# ### $n_power
# ### $max_n
# ### $min_n
# {
# my $digit;
# for ($digit = $radix_minus_1; $digit > 0; $digit--) {
# last if &$overlap ($max_y,$max_yk,$digit, $y1,$y2);
# }
# $max_n += $n_power * $digit;
# $max_xk ^= $digit;
# if ($max_yk&1) { $digit = $radix_minus_1 - $digit; }
# $max_y += $power * $digit;
# ### max y digit (complemented): $digit
# ### $max_y
# ### $max_n
# }
# {
# my $digit;
# for ($digit = 0; $digit < $radix_minus_1; $digit++) {
# last if &$overlap ($min_y,$min_yk,$digit, $y1,$y2);
# }
# $min_n += $n_power * $digit;
# $min_xk ^= $digit;
# if ($min_yk&1) { $digit = $radix_minus_1 - $digit; }
# $min_y += $power * $digit;
# ### min y digit (complemented): $digit
# ### $min_y
# ### $min_n
# }
#
# $n_power = int($n_power/$radix);
# {
# my $digit;
# for ($digit = $radix_minus_1; $digit > 0; $digit--) {
# last if &$overlap ($max_x,$max_xk,$digit, $x1,$x2);
# }
# $max_n += $n_power * $digit;
# $max_yk ^= $digit;
# if ($max_xk&1) { $digit = $radix_minus_1 - $digit; }
# $max_x += $power * $digit;
# ### max x digit (complemented): $digit
# ### $max_x
# ### $max_n
# }
# {
# my $digit;
# for ($digit = 0; $digit < $radix_minus_1; $digit++) {
# last if &$overlap ($min_x,$min_xk,$digit, $x1,$x2);
# }
# $min_n += $n_power * $digit;
# $min_yk ^= $digit;
# if ($min_xk&1) { $digit = $radix_minus_1 - $digit; }
# $min_x += $power * $digit;
# ### min x digit (complemented): $digit
# ### $min_x
# ### $min_n
# }
#
# $power = int($power/$radix);
# $n_power = int($n_power/$radix);
# }
#
# ### is: "$min_n at $min_x,$min_y to $max_n at $max_x,$max_y"
# return ($min_n, $max_n);
}
1;
__END__
=for stopwords Giuseppe Peano Peano's eg Sur une courbe qui remplit toute aire Mathematische Annalen Ryde OEIS ZOrderCurve ie PeanoCurve Math-PlanePath versa Online Radix radix HilbertCurve
=head1 NAME
Math::PlanePath::PeanoRounded -- 3x3 self-similar quadrant traversal, with rounded corners
=head1 SYNOPSIS
use Math::PlanePath::PeanoRounded;
my $path = Math::PlanePath::PeanoRounded->new;
my ($x, $y) = $path->n_to_xy (123);
# or another radix digits ...
my $path5 = Math::PlanePath::PeanoRounded->new (radix => 5);
=head1 DESCRIPTION
This is a version of the PeanoCurve with rounded-off corners,
11 | 76-75 72-71 68-67
| / \ / \ / \
10 | 77 74-73 70-69 66
| | |
9 | 78 81-82 61-62 65
| \ / \ / \ /
8 | 79-80 83 60 63-64
| | |
7 | 88-87 84 59 56-55
| / \ / \ / \
6 | ...-89 86-85 58-57 54
| |
5 | 13-14 17-18 21-22 49-50 53
| / \ / \ / \ / \ /
4 | 12 15-16 19-20 23 48 51-52
| | | |
3 | 11 8--7 28-27 24 47 44-43
| \ / \ / \ / \ / \
2 | 10--9 6 29 26-25 46-45 42
| | | |
1 | 1--2 5 30 33-34 37-38 41
| / \ / \ / \ / \ /
Y=0 | 0 3--4 31-32 35-36 39-40
+------------------------------------------------------
X=0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
=head2 Radix
The C parameter can do the calculation in a base other than 3, using
the same kind of direction reversals. For example radix 5 gives 5x5 groups,
=cut
# math-image --path=PeanoRounded,radix=5 --all --output=numbers_dash
=pod
radix => 5
9 | 41-42 45-46 49-...
| / \ / \ /
8 | 40 43-44 47-48
| | radix=5
7 | 39 36-35 32-31
| \ / \ / \
6 | 38-37 34-33 30
| |
5 | 21-22 25-26 29
| / \ / \ /
4 | 20 23-24 27-28
| |
3 | 19 16-15 12-11
| \ / \ / \
2 | 18-17 14-13 10
| |
1 | 1--2 5--6 9
| / \ / \ /
Y=0 | 0 3--4 7--8
|
+---------------------------------
X=0 1 2 3 4 5 6 7 8 9
If the radix is even then the ends of each group don't join up. For example
in radix 4 N=31 isn't next to N=32.
=cut
# math-image --path=PeanoRounded,radix=4 --all --output=numbers_dash
=pod
7 | 30-29 26-25 32
| / \ / \ \
6 | 31 28-27 24 33--...
| |
5 | 17-18 21-22 |
| / \ / \ |
4 | 16 19-20 23
| |
3 | | 14-13 10--9
| | / \ / \
2 | 15 12-11 8
| |
1 | 1--2 5--6 |
| / \ / \ |
Y=0 | 0 3--4 7
+-----------------------------------------
X=0 1 2 4 5 6 7 8 9 10
=head1 FUNCTIONS
See L for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::PeanoRounded-Enew ()>
=item C<$path = Math::PlanePath::PeanoRounded-Enew (radix =E $r)>
Create and return a new path object.
The optional C parameter gives the base for digit splitting. The
default is ternary, C 3>.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
Fractional positions give an X,Y position along a straight line between the
integer positions.
=back
=head1 SEE ALSO
L,
L,
L
Giuseppe Peano, "Sur Une Courbe, Qui Remplit Toute Une Aire Plane",
Mathematische Annalen, volume 36, number 1, 1890, p157-160
=over
DOI 10.1007/BF01199438
http://www.springerlink.com/content/w232301n53960133/
=back
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::SquaRecurve-Enew ()>
=item C<$path = Math::PlanePath::SquaRecurve-Enew (radix =E $r)>
Create and return a new path object.
The optional C parameter gives the base for digit splitting. The
default is ternary, C 3>.
=item C<($x,$y) = $path-En_to_xy ($n)>
Return the X,Y coordinates of point number C<$n> on the path. Points begin
at 0 and if C<$n E 0> then the return is an empty list.
Fractional positions give an X,Y position along a straight line between the
integer positions.
=back
=head1 FORMULAS
=head2 N to Turn
The curve turns left or right 90 degrees at each point N E= 1. The turn
is 90 degrees
turn(N) = 90 degrees * (-1)^(N + number of low ternary 0s of N)
= -1,1,1,1,-1,-1,-1,1,-1,1,-1,-1,-1,1,1,1,-1,1
=cut
# GP-DEFINE turn(n) = (-1)^(n + valuation(n,3));
# GP-Test vector(18,n, turn(n)) == \
# GP-Test [-1,1, 1, 1,-1, -1, -1,1,-1,1,-1, -1, -1,1,1,1,-1,1]
# not in OEIS: -1,1,1,1,-1,-1,-1,1,-1,1,-1,-1,-1,1,1,1,-1,1
# not in OEIS: 1,-1,-1,-1,1,1,1,-1,1,-1,1,1,1,-1,-1,-1,1,-1 \\ negated
# not in OEIS: 0,1,1,1,0,0,0,1,0,1,0,0,0,1,1,1,0,1,0,1,1,1,0,0,0,1,1,1,0,0 \\ ones
# not in OEIS: 1,0,0,0,1,1,1,0,1,0,1,1,1,0,0,0,1,0 \\ zeros
# GP-Test vector(900,n, turn(3*n)) == \
# GP-Test vector(900,n, -turn(n))
# GP-Test vector(900,n, turn(3*n+1)) == \
# GP-Test vector(900,n, -(-1)^n)
# GP-Test vector(900,n, turn(3*n+2)) == \
# GP-Test vector(900,n, (-1)^n)
# vector(25,n, (-1)^valuation(n,3))
# not in OEIS: 1,1,-1,1,1,-1,1,1,1,1,1,-1,1,1,-1,1,1,1,1,1,-1,1,1,-1,1,1,-1,1
# vector(100,n, valuation(n,3)%2)
# A182581 num ternary low 0s mod 2
=pod
The power of -1 means left or right flip for each low ternary 0 of N, and
flip again if N is odd. Odd N is an odd number of ternary 1 digits.
This formula follows from the turns in a new low base-9 digit. The start
and end of the base figure are in the same directions so the turns at 9*N
are unchanged. Then 9*N+r goes as r in the base figure, but flipped
LE-ER when N odd since blocks are mirrored alternately.
turn(9N) = turn(N)
turn(9N+r) = turn(r)*(-1)^N for 1 <= r <= 8
=cut
# GP-Test vector(900,n, turn(9*n)) == \
# GP-Test vector(900,n, turn(n))
# GP-Test matrix(90,8,n,r, turn(9*n+r)) == \
# GP-Test matrix(90,8,n,r, turn(r)*(-1)^n)
=pod
Just in terms of base 3, a single new low ternary digit is a transpose of
what's above, and the base figure turns r=1,2 and LE-ER when N above
is odd again.
The same for any odd radix.
=head1 SEE ALSO
L,
L
=over
DOI 10.1007/BF01199438
http://www.springerlink.com/content/w232301n53960133/
=back
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2019, 2020 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see MyFLAT::get_non_accepting>
Return a list of all the non-accepting states in C<$fa>.
=back
=cut
sub get_non_accepting {
my ($fa) = @_;
return grep {! $fa->is_accepting($_)} $fa->get_states;
}
#------------------------------------------------------------------------------
=pod
=over
=item C<$count = num_accepting($fa)>
=item C<$count = num_non_accepting($fa)>
Return the number of accepting or non-accepting states in C<$fa>.
=back
=cut
sub num_accepting {
my ($fa) = @_;
my @states = $fa->get_accepting;
return scalar(@states);
}
sub num_non_accepting {
my ($fa) = @_;
my @states = $fa->MyFLAT::get_non_accepting;
return scalar(@states);
}
sub num_symbols {
my ($fa) = @_;
my @alphabet = $fa->alphabet;
return scalar(@alphabet);
}
#------------------------------------------------------------------------------
sub descendants {
my ($self, $state, $symb) = @_;
my %try;
@try{ref $state eq 'ARRAY' ? @$state : $state} = (); # hash slice
my %seen;
my %ret;
while (%try) {
foreach my $from (keys %try) {
delete $try{$from};
$seen{$from} = 1;
foreach my $to ($self->successors($from,$symb)) {
$ret{$to} = 1;
unless ($seen{$to}++) {
$try{$to} = undef;
}
}
}
}
return keys %ret;
}
#------------------------------------------------------------------------------
# Prefixes
=pod
=over
=item C<$new_lang = $lang-Eprefix>
=item C<$new_lang = $lang-Eprefix ($proper)>
Return a new regular language object for prefixes of C<$lang>. This means
all strings S for which there exists some T where S.T is in C<$lang>. For
example if "abc" is in C<$lang> then C<$new_lang> has all prefixes "", "a",
"ab", "abc".
The default is to allow T empty, so all strings of C<$lang> are included in
C<$new_lang>. Optional parameter C<$proper> true means T must be non-empty
so only proper prefixes S are accepted.
In both cases prefix S can be the empty string, if suitable T exists. For
C<$proper> false this means if C<$lang> accepts anything at all (Cis_empty>). For C<$proper> true it means if C<$lang> accepts
some non-empty string.
=back
=cut
sub prefix {
my ($self, $proper) = @_;
$self = $self->clone;
my @ancestors = $self->MyFLAT::ancestors([$self->get_accepting]);
if ($proper) {
$self->unset_accepting($self->get_accepting);
}
$self->set_accepting(@ancestors);
return $self;
}
sub ancestors {
my ($self, $state, $symb) = @_;
# "targets" are the states sought as successors. Initially given $state,
# then the immediate successors of those, successors of successors,
# etc.
# "ret" is those successors. It does not include the initial $state,
# unless a cycle comes back around to some of $state.
# "try" are states to look at for a successor target. Initially
# everything, then when a state is put in "ret" don't try it again.
my %targets;
@targets{ref $state eq 'ARRAY' ? @$state : $state} = (); # hash slice
my %try;
@try{$self->get_states} = (); # hash slice
my %ret;
my $more;
do {
$more = 0;
foreach my $from (keys %try) {
foreach my $to ($self->successors($from,$symb)) {
if (exists $targets{$to}) {
delete $try{$from};
$ret{$from} = 1;
$targets{$from} = 1;
$more = 1;
}
}
}
} while ($more);
return keys %ret;
}
# UNTESTED
# like successors, but the one-step preceding
sub predecessors {
my ($self, $state, $symb) = @_;
my %targets;
@targets{ref $state eq 'ARRAY' ? @$state : $state} = (); # hash slice
### %targets
my @ret;
foreach my $from ($self->get_states) {
foreach my $to ($self->successors($from,$symb)) {
if (exists $targets{$to}) {
push @ret, $from;
}
}
}
return @ret;
}
=pod
=over
=item C<@states = $fa-Eget_prefix_states ()>
=item C<@states = $fa-Eget_prefix_states ($proper)>
Return a list of those states which C would make accepting (and
all other states non-accepting).
This is all ancestor states of the accepting states in C<$fa>, so the
predecessors of accepting, the predecessors of them, etc. The default
C<$proper> false includes the original accepting states (so all original
strings of C<$fa>). For C<$proper> the original accepting states are not
included, unless they occur as ancestors. (If they do, and are reachable
from starting states, then it means there are already some prefixes accepted
by C<$fa>.)
No attention is paid to start states and what might be reached from them.
This allows prefixing to be found or manipulated before setting starts.
C<$fa> can be modified to accept also its prefixes like a non-copying form
of C<$fa-Eprefix()> by
$fa->set_accepting($fa->get_prefix_states);
=item C<@states = get_prefix_accepting($fa)>
=item C<$fa = prefix_accepting($fa)>
C returns states which are not accepting but which by
some sequence of symbols are able to reach accepting.
Some states of C<$fa> may be non-accepting, but able to reach an accepting
state by some sequence of symbols. C returns a list
of those states.
C returns a new FLAT which has these "prefix accepting"
states set as accepting. The effect is to accept all strings C<$fa> does,
and in addition accept all prefixes of strings accepted by C<$fa>, including
the empty string.
Prefix accepting states are the predecessors of accepting states, and
predecessors of those prefix states, etc. This usually extends back to
starting states, and includes those states. But no attention is paid to
starting-ness, the process just continues back by predecessors, irrespective
of what might be actually reachable from a starting state.
=back
=cut
# Return depth=>$depth,states=>$aref.
sub get_prefix_accepting_info {
my ($fa) = @_;
my $alphabet_aref = [ $fa->alphabet ];
my %non_accepting;
@non_accepting{$fa->MyFLAT::get_non_accepting} = (); # hash slice
my $depth = -1;
my %prefixes;
my $more;
do {
$depth++;
STATE: while (my ($state) = each %non_accepting) {
# if any successor is an accepting or accepting prefix then this state
# is an accepting prefix too
if (grep
{$prefixes{$_} || $fa->is_accepting($_)}
$fa->successors([$fa->epsilon_closure($state)], $alphabet_aref)) {
$prefixes{$state} = 1;
delete $non_accepting{$state};
$more = 1;
}
}
} while ($more--);
return (depth => $depth, states => [ keys %prefixes ]);
}
sub get_prefix_accepting {
my ($fa) = @_;
my %info = get_prefix_accepting_info($fa);
return @{$info{'states'}};
}
# Return a new FLAT (a clone) which accepts any initial prefix of the
# strings accepted by $fa.
# Each state is set to accepting if it has any accepting successor (some
# symbol leads to accepting), and repeating until no more such can be found.
#
sub prefix_accepting {
my ($fa, %options) = @_;
my %info = get_prefix_accepting_info($fa);
my $states = $info{'states'};
my $depth = $info{'depth'};
if ($options{'verbose'}) {
print $fa->{name}//'',
" accepting prefixes, count ",scalar(@$states)," more, depth=$depth\n";
}
$fa = $fa->clone;
$fa->set_accepting(@$states);
if (defined (my $name = $fa->{'name'})) {
if ($depth) { $name .= ' prefixes'; }
$fa->{'name'} = $name;
}
return $fa;
}
{
package FLAT::Regex;
sub MyFLAT_prefix {
my $self = shift;
$self->_from_op($self->op->MyFLAT_prefix(@_));
}
sub MyFLAT_suffix {
my $self = shift;
$self->_from_op($self->op->MyFLAT_suffix(@_));
}
}
{
package FLAT::Regex::Op::atomic;
sub MyFLAT_prefix {
my ($self, $proper) = @_;
my $member = $self->members;
return (! defined $member
? $self # null regex, unchanged
: $proper
# symbol becomes empty string, # empty string becomes null regexp
? (ref $self)->new(length($member) ? '' : undef)
: length($member)
# symbol, accept it and also empty string
? FLAT::Regex::Op::alt->new((ref $self)->new(''), $self)
# empty string, unchanged
: $self);
}
*MyFLAT_suffix = \&MyFLAT_prefix;
}
{
package FLAT::Regex::Op::star;
sub MyFLAT_prefix {
my ($self, $proper) = @_;
my $member = $self->members;
# M* -> M* properprefix(M)
# Can be proper prefix always since a itself covered by M*.
# But must check M has a non-empty string before doing that.
# Otherwise get (M* #) which doesn't match anything at all, but for
# $proper==0 want to match the empty string (unless M is_empty).
return ($member->has_nonempty_string
? FLAT::Regex::Op::concat->new($self, $member->MyFLAT_prefix(1))
: $proper ? FLAT::Regex::Op::atomic->new(undef)
: $member); # empty string or null regex remains so
}
sub MyFLAT_suffix {
my ($self, $proper) = @_;
my $member = $self->members;
# like prefix but reverse
return ($member->has_nonempty_string
? FLAT::Regex::Op::concat->new($member->MyFLAT_suffix(1), $self)
: $proper ? FLAT::Regex::Op::atomic->new(undef)
: $member); # empty string or null regex remains so
}
}
{
package FLAT::Regex::Op::concat;
sub MyFLAT_prefix {
my ($self,$proper) = @_;
# B C -> properprefix(B) | B prefix(C)
#
# If prefix(C) is not null then it includes the empty string and can go
# to properprefix(B) since whole B is covered by (B []).
#
# If C is the empty string and $proper==1 then prefix(C) is null so get
# (B #) which matches nothing and thus doesn't give whole C. This is as
# desired, since it is not a proper prefix in that case.
#
# For 3 or more concat members, nest like
# A B C -> properprefix(A) | A ( properprefix(B) | B prefix(C) )
#
# properprefix() is allowed for the earlier parts once a non-null prefix
# is seen.
#
# An empty $member means the whole concat matches nothing. Watch for
# that explicitly since B=# would give prefix(A) | (A #) which would
# wrongly accept prefix(A).
my $ret;
foreach my $member (CORE::reverse $self->members) {
if ($member->is_empty) { return $member; }
my $prefix = $member->MyFLAT_prefix($proper);
$ret = (defined $ret
? FLAT::Regex::Op::alt->new ($prefix,
__PACKAGE__->new($member, $ret))
: $prefix);
$proper ||= ! $prefix->is_empty;
}
return $ret;
}
sub MyFLAT_suffix {
my ($self,$proper) = @_;
# similar to prefix, working forwards through members for the nesting
# A B -> suffix(A) B | propersuffix(B)
# A B C -> ( suffix(A) B | propersuffix(B)) C ) | propersuffix(C)
my $ret;
foreach my $member ($self->members) {
if ($member->is_empty) { return $member; }
my $suffix = $member->MyFLAT_suffix($proper);
$ret = (defined $ret
? FLAT::Regex::Op::alt->new (__PACKAGE__->new($ret, $member),
$suffix)
: $suffix);
$proper ||= ! $suffix->is_empty;
}
return $ret;
}
}
{
package FLAT::Regex::Op;
# return new op of $self members transformed by $member->$method on each
sub MyFLAT__map_method {
my $self = shift;
my $method = shift;
return (ref $self)->new(map {$_->$method(@_)} $self->members);
}
}
{
package FLAT::Regex::Op::alt;
# prefix(X|Y) = prefix(X) | prefix(Y)
# suffix(X|Y) = suffix(X) | suffix(Y)
sub MyFLAT_prefix {
my $self = shift;
return $self->MyFLAT__map_method('MyFLAT_prefix',@_);
}
sub MyFLAT_suffix {
my $self = shift;
return $self->MyFLAT__map_method('MyFLAT_suffix',@_);
}
}
{
package FLAT::Regex::Op::shuffle;
*MyFLAT_prefix = \&FLAT::Regex::Op::alt::MyFLAT_prefix;
*MyFLAT_suffix = \&FLAT::Regex::Op::alt::MyFLAT_suffix;
}
#------------------------------------------------------------------------------
# Eventually Accepting
=pod
=over
=item C<@states = get_eventually_accepting($fa)>
=item C<$fa = eventually_accepting($fa)>
Some states of C<$fa> may be "eventually accepting" in the sense that after
more symbols they are certain to reach accepting, for all possible further
symbol values.
For example suppose alphabet a,b,c. If bba, bbb and bbc are all accepted by
C<$fa> then string "bb" is reckoned as eventually accepted since one further
symbol, any of a,b,c, goes to accepting.
C returns a list of states which are eventually
accepting. C returns a clone of C<$fa> which has
those states set as accepting.
Eventually accepting states are found first as any state with all symbols
going to accepting, then any state with all symbols going to either
accepting or eventually accepting, and so on until no more such further
states.
In an NFA, any epsilon transitions are crossed in the usual way, but there
should be just one starting state (or just one which ever leads to
accepting). If multiple starting states then the simple rule used will
sometimes fail to find all eventually accepting states and hence strings.
C will collapse multiple starts.
=back
=cut
# Return depth=>$depth,states=>$aref.
sub get_eventually_accepting_info {
my ($fa) = @_;
my $alphabet_aref = [ $fa->alphabet ];
my %non_accepting;
@non_accepting{$fa->MyFLAT::get_non_accepting} = (); # hash slice
my %eventually;
my $depth = -1;
my $more;
do {
$depth++;
my @new_eventually;
STATE: while (my ($state) = each %non_accepting) {
### $state
foreach my $to_state ($fa->successors([$fa->epsilon_closure($state)],
$alphabet_aref)) {
### $to_state
unless ($eventually{$to_state} || $fa->is_accepting($to_state)) {
next STATE;
}
}
push @new_eventually, $state;
}
foreach my $state (@new_eventually) {
$eventually{$state} = 1;
delete $non_accepting{$state};
$more = 1;
}
} while ($more--);
return (depth => $depth, states => [ keys %eventually ]);
}
sub get_eventually_accepting {
my ($fa) = @_;
my %info = get_eventually_accepting_info($fa);
return @{$info{'states'}};
}
# Return a new FLAT (a clone) which accepts strings eventually accepted by $fa.
sub eventually_accepting {
my ($fa, %options) = @_;
my %info = get_eventually_accepting_info($fa);
my $states = $info{'states'};
my $depth = $info{'depth'};
if ($options{'verbose'}) {
print $fa->{name}//'',
" eventually accepting, count ",scalar(@$states)," more, depth=$depth\n";
}
$fa = $fa->clone;
$fa->set_accepting(@$states);
if (defined (my $name = $fa->{'name'})) {
if ($depth) { $name .= ' eventually'; }
$fa->{'name'} = $name;
}
return $fa;
}
#------------------------------------------------------------------------------
=pod
=over
=item C<$fa = fraction_digits($num,$den, %options)>
Return a C which matches digits of fraction C<$num/$den>.
The DFA remains accepting as long as it is given successive digits of the
fraction, and goes non-accepting (and remains so) on a wrong digit.
The default is decimal digits, or optional key/value
radix => integer>=2
If C<$num/$den> is an exact fraction in C<$radix>, meaning C<$num/$den ==
n/$radix**k> for some integer n,k, then it has two different
representations. Firstly terminating digits followed by trailing 0s,
secondly C<$n-1> followed by trailing C<$radix-1> digits.
For example 42/100 is 420000... and 419999... Both digit sequences converge
to 42/100. For fractions not an exact power of C<$radix> there is just one
digit sequence which converges to C<$num/$den>.
C<$num == 0> gives a DFA matching 000..., or C<$num==$den> for fraction
C<$num/$den == 1> gives a DFA matching 9999... (or whatever C<$radix-1>).
In all cases the C<$fa-Ealphabet> is all the digits 0 to C<$radix-1>.
Those which are "wrong" digits at a given point go to a non-accepting sink
state. This is designed so that C<$fa-Ecomplement> gives all digit
strings except fraction C<$num/$den>.
MAYBE: Option to omit wrong digits in an NFA, so transitions only for the
accepted digits.
MAYBE: Currently the symbols for digits in a radix 11 or higher are decimal
strings, but that might change. Could have an option for hex or a table or
func. Decimal strings are easy to work with their values in Perl if a
further func might act on the resulting FLAT. C can always
change for final result if desired.
=back
=cut
sub fraction_digits {
my ($num, $den, %options) = @_;
### fraction_digits(): "$num / $den"
require FLAT::DFA;
my $f = FLAT::DFA->new;
my $radix = $options{'radix'} || 10;
### $radix
my $not_accept = $f->add_states(1);
$f->add_transition ($not_accept,$not_accept, 0..$radix-1);
unless ($num >=0 && $num <= $den) {
croak "fraction_digits() must have 0<=num<=den";
}
unless ($radix >= 2) {
croak "fraction_digits() must have radix>=2";
}
my %num_to_state;
my $prev_state = $f->add_states(1);
$f->set_starting ($prev_state);
$f->set_accepting ($prev_state);
$num_to_state{$num} = $prev_state;
my $prev_digit;
my $prev_prev_state;
if ($num == $den) {
# 1/1 match .9999...
$f->add_transition ($prev_state,$prev_state, $radix-1);
$f->add_transition ($prev_state,$not_accept, 0..$radix-2);
return $f;
}
for (;;) {
### $num
$num *= $radix;
my $digit = int($num / $den);
$num %= $den;
if ($digit >= 10) { $digit = chr(ord('A')+$digit-10); }
### $digit
my $cycle_state = $num_to_state{$num};
my $state = $cycle_state // $f->add_states(1);
$f->set_accepting ($state);
$f->add_transition ($prev_state,$state, $digit);
$f->add_transition ($prev_state,$not_accept,
grep {$_!=$digit} 0..$radix-1);
if (defined $cycle_state) {
if ($num == 0 && $prev_digit) {
$state = $f->add_states(1);
$f->set_accepting ($state);
$f->set_transition ($prev_prev_state, $not_accept,
grep {$_!=$prev_digit-1 && $_!=$prev_digit}
0..$radix-1);
$f->add_transition ($prev_prev_state,$state, $prev_digit-1);
$f->add_transition ($state,$state, $radix-1);
$f->add_transition ($state,$not_accept, 0..$radix-2);
}
return $f;
}
$num_to_state{$num} = $state;
$prev_digit = $digit;
$prev_prev_state = $prev_state;
$prev_state = $state;
}
}
# $radix ||= 10;
# unless ($num >=0 && $num < $den) {
# croak "fraction_digits() must have 0<=num$index of digits in @digits
# my $pos = 0;
# for (;;) {
# if (defined(my $rpos = $seen{$num})) {
# # this numerator is a repeat of what was at $rpos, so cycle back to there
# require FLAT::DFA;
# my $f = FLAT::DFA->new;
# my @states = $f->add_states($pos+1);
# $f->set_starting($states[0]);
# $f->set_accepting(@states[0..$pos-1]);
# foreach my $i (0 .. $pos) {
# foreach my $d (0 .. $radix-1) {
# my $to = ($i==$pos || $d != $digits[$i] ? $pos # not accept
# : $i == $pos-1 ? $rpos # cycle back
# : $i+1); # next
# $f->add_transition ($states[$i],$states[$to]);
# }
# }
# $f->{'name'} = "$num/$den radix $radix";
# return $f;
# }
#
# ### $num
# ### assert: $num >= 0
# ### assert: $num < $den
# $seen{$num} = $pos++;
# $num *= $radix;
# my $digit = int($num / $den);
# $num %= $den;
# if ($digit >= 10) { $digit = chr(ord('A')+$digit-10); }
# push @digits, $digit;
# }
#
# my $str;
# $str .= $digit;
# my $re = substr($str,0,$rpos) . "(".substr($str,$rpos) . ")*";
# ### $str
# ### $rpos
# ### $re
# my $f = FLAT::Regex->new($re)->as_dfa;
# $f->{'name'} = "$num/$den radix $radix";
# $f = prefix($f);
# return $f;
# $fa is a FLAT::DFA which matches fractions represented as strings of digits.
# Return a new FLAT::DFA which matches any terminating fraction like 10111
# also as its non-terminating equivalent 101101111...
# FIXME: currently only works for binary, and only when terminating
# fractions end with a 1, not with low 0s.
sub fraction_also_nines {
my ($fa, %options) = @_;
# FLAT::Regex->new ('(0|1)* 1 0*')->as_nfa;
my $binary_odd_flat = FLAT::Regex->new ('(0|1)* 1')->as_dfa;
return $fa->as_dfa
->intersect($binary_odd_flat)
->MyFLAT::skip_final
->MyFLAT::concat(FLAT::Regex->new ('01*')->as_dfa)
->union($fa)
->MyFLAT::set_name($fa->{'name'});
}
# $fa is a FLAT::NFA or FLAT::DFA accepting strings of digits.
# Those strings are interpreted as fractional numbers .ddddd...
# Return a new FLAT (same DFA or NFA) which accepts these same strings and
# also representations ending 999...
# For example if 321 is accepted then 3209999... is also accepted.
#
# The radix is taken from $fa->alphabet, or option radix=>$r can be given if
# $fa might not have all digits appearing.
#
# The digit strings read high to low by default. Option
# direction=>"lowtohigh" can interpret them low to high instead. Low to
# high will be more efficient since manipulations are at the low end
# (propagate a carry up through low "9"s), but both work.
#
# sub fraction_nines {
# my ($fa, %options) = @_;
# ### digits_increment() ...
#
# # starting state is flip
# # in flip 0-bit successor as a 1-bit, and thereafter unchanged
# # 1-bit successor as a 0-bit, continue flip
#
# my $direction = $options{'direction'} || 'hightolow';
# my $radix = $options{'radix'} || max($fa->alphabet)+1;
# my $nine = $radix-1;
#
# my $is_dfa = $fa->isa('FLAT::DFA');
# $fa = $fa->clone->MyFLAT::as_nfa;
# if ($direction eq 'hightolow') { $fa = $fa->reverse; }
#
# my %flipped_states;
# {
# # states reachable by runs of 9s from starting states
# my @pending = $fa->get_starting;
# while (defined (my $state = shift @pending)) {
# unless (exists $flipped_states{$state}) {
# my ($new_state) = $fa->add_states(1);
# ### add: "state=$state new=$new_state"
# $flipped_states{$state} = $new_state;
#
# if ($fa->is_starting($state)) {
# $fa->set_starting($new_state);
# $fa->unset_starting($state);
# }
# push @pending, $fa->successors($state, $nine);
# }
# }
# }
#
# while (my ($state, $flipped_state) = each %flipped_states) {
# ### setup: "$state nines becomes $flipped_state"
#
# foreach my $digit (0 .. $nine-1) {
# foreach my $successor ($fa->successors($state, $digit)) {
# ### digit: "digit=$digit $flipped_state -> $successor on 1"
# $fa->add_transition($flipped_state, $successor, $digit+1);
# }
# }
# if ($fa->is_accepting($state)) {
# # 99...99 accepting becomes 00..00 1 accepting, with a new state for
# # the additional 1-bit to go to
# my ($new_state) = $fa->add_states(1);
# $fa->set_accepting($new_state);
# $fa->add_transition($flipped_state, $new_state, 1);
# ### carry above accepting: $new_state
# }
#
# foreach my $successor ($fa->successors($state, $nine)) {
# ### nine: "$flipped_state -> $flipped_states{$successor} on 0"
# $fa->add_transition($flipped_state, $flipped_states{$successor}, 0);
# }
# }
#
# if (defined $fa->{'name'}) {
# $fa->{'name'} =~ s{\+(\d+)$}{'+'.($1+1)}e
# or $fa->{'name'} .= '+1';
# }
#
# if ($direction eq 'hightolow') { $fa = $fa->reverse; }
# if ($is_dfa) { $fa = $fa->as_dfa; }
# return $fa;
# }
#------------------------------------------------------------------------------
=pod
=over
=item C<$new_fa = $fa-EMyFLAT::separate_sinks>
Return a copy of C<$fa> which has separate sink states.
A sink state is where all out transitions loop back to itself. If two or
more states go to the same sink then the return has new states so that each
goes to its own such sink. The new sinks are the same accepting or not as
each original sink.
This does not change the strings accepted, but can help viewing a big
diagram where many long range transitions go to a single accepting and/or
non-accepting sink.
Only single sink states are sought. Multiple states cycling among
themselves all the same accepting or non-accepting are sinks, but they can
be merged by an C.
=item C<$bool = $fa-EMyFLAT::is_sink($state)>
Return true if C<$state> has all transitions go to itself.
=back
=cut
sub separate_sinks {
my ($fa) = @_;
$fa = $fa->clone;
my %sink_used;
my @alphabet = $fa->alphabet;
foreach my $from_state ($fa->get_states) {
foreach my $to_state ($fa->successors($from_state)) {
next unless $fa->MyFLAT::is_sink($to_state);
next if $from_state==$to_state;
next unless $sink_used{$to_state}++;
my $new_state = $fa->MyFLAT::copy_state($to_state);
my @labels = FLAT_get_transition_labels($fa,$from_state,$to_state);
### common sink: "$from_state to $to_state, new $new_state, labels ".join(' ',@labels)
# when $fa is an NFA add_transition() accumulates, so for it must
# remove old transitions
$fa->remove_transition($from_state,$to_state);
$fa->add_transition($from_state,$new_state,@labels);
}
}
return $fa;
}
# $fa is a FLAT::FA.
# FIXME: what about cycles of mutual transitions among accepting states?
sub is_sink {
my ($fa, $state) = @_;
my @next = $fa->successors($state);
return @next==1 && $next[0]==$state;
}
sub get_sink_states {
my ($fa) = @_;
return grep {$fa->MyFLAT::is_sink($_)} $fa->get_states;
}
sub is_accepting_sink {
my ($fa, $state) = @_;
$fa->MyFLAT::is_sink($state) && $fa->is_accepting($state);
}
sub get_accepting_sinks {
my ($fa) = @_;
return grep {$fa->MyFLAT::is_accepting_sink($_)} $fa->get_states;
}
sub num_accepting_sinks {
my ($fa) = @_;
# this depends on use of grep in get_accepting_sinks()
return scalar($fa->MyFLAT::get_accepting_sinks);
}
=pod
=over
=item C<$new_state = $fa-EMyFLAT::copy_state ($state)>
Add a state to C<$fa> which is a copy of C<$state>. Transitions out and
accepting-ness of C<$new_state> and the same as C<$state>. Return the new
state number.
=back
=cut
sub copy_state {
my ($fa, $state) = @_;
### copy_state(): $state
my ($new_state) = $fa->add_states(1);
if ($fa->is_accepting ($state)) {
$fa->set_accepting($new_state);
}
# ENHANCE-ME: transition can be copied more efficiently?
foreach my $symbol ($fa->alphabet) {
foreach my $next ($fa->successors($state, $symbol)) {
my $new_next = ($next == $state ? $new_state : $next);
$fa->add_transition($new_state,$new_next, $symbol);
}
}
return $new_state;
}
#------------------------------------------------------------------------------
# $fa is a FLAT::FA.
# Return a new FLAT with some of its states or symbols renamed.
#
# symbols_func => $coderef called $new_symbol = $coderef->($old_symbol)
# symbols_map => $hashref of $old_symbol => $new_symbol
# states_map => $hashref of $old_state => $new_state
# states_list => arrayref of existing states in order for the new
#
# Any states or symbols in $fa unmentioned in these mappings are unchanged,
# so some can be changed and the rest left alone.
#
# Symbols can be swapped or cycled by for example {'A'=>'B', 'B'=>'A'}.
# States similarly.
#
sub FLAT_rename {
my ($fa, %options) = @_;
my @alphabet = $fa->alphabet;
my $symbols_func = $options{'symbols_func'}
// do {
my $symbols_map = $options{'symbols_map'} // {};
sub {
my ($symbol) = @_;
return $symbols_map->{$symbol};
}
};
my $states_map = $options{'states_map'} // {};
if (defined(my $states_list = $options{'states_list'})) {
$states_map = { map {$_ => $states_list->[$_]} 0 .. $#$states_list };
}
my $new = (ref $fa)->new;
$new->add_states($fa->num_states);
foreach my $old_state ($fa->get_states) {
my $new_state = $states_map->{$old_state} // $old_state;
if ($fa->is_accepting($old_state)) { $new->set_accepting($new_state); }
if ($fa->is_starting ($old_state)) { $new->set_starting ($new_state); }
foreach my $symbol (@alphabet) {
my $new_symbol = $symbols_func->($symbol) // $symbol;
foreach my $old_next ($fa->successors($old_state, $symbol)) {
my $new_next = $states_map->{$old_next} // $old_next;
$new->add_transition($new_state, $new_next, $new_symbol);
}
}
}
$new->{'name'} = $fa->{'name'};
return $new;
}
# Return a new FLAT::FA of the same type as $fa but where any accepting
# states are numbered last.
sub rename_accepting_last {
my ($fa, %options) = @_;
return FLAT_rename($fa, states_list =>
[ $fa->MyFLAT::get_non_accepting, $fa->get_accepting ]);
}
sub _sort_sensibly {
if (grep {!looks_like_number($_)} @_) {
return sort @_;
} else {
return sort {$a<=>$b} @_;
}
}
sub alphabet_sorted {
my ($fa) = @_;
return _sort_sensibly($fa->alphabet);
}
sub states_breadth_first {
my ($fa) = @_;
my @ret;
my $upto = 0;
my @alphabet = $fa->MyFLAT::alphabet_sorted;
my @pending = sort {$a<=>$b} $fa->get_starting;
while (@pending) {
my $state = shift @pending;
next if defined $ret[$state];
$ret[$state] = $upto++;
foreach my $symbol (@alphabet) {
push @pending, sort {$a<=>$b} $fa->successors($state, $symbol);
}
}
return @ret;
}
sub rename_breadth_first {
my ($fa) = @_;
return FLAT_rename($fa, states_list => [$fa->MyFLAT::states_breadth_first]);
}
#------------------------------------------------------------------------------
# zero_digits_flat() returns a FLAT::DFA matching a run of 0 digits,
# possibly an empty run. This is regex "0*", but with alphabet 0 .. $radix-1.
sub zero_digits_flat {
my ($radix) = @_;
my $f = FLAT::DFA->new;
$f->add_states(2);
$f->set_starting(0);
$f->set_accepting(0);
$f->add_transition(0,0, 0); # state 0 accept 0s
$f->add_transition(0,1, 1 .. $radix-1);
$f->add_transition(1,1, 0 .. $radix-1); # state 1 non-accepting sink
return $f;
}
# one_bits_flat() returns a FLAT::DFA matching a run of 1 bits, possibly an
# empty run. This is regex "1*", but with alphabet 0,1.
use constant::defer one_bits_flat => sub {
require FLAT::DFA;
my $f = FLAT::DFA->new;
$f->add_states(2);
$f->set_starting(0);
$f->set_accepting(0);
$f->add_transition(0,0, 1);
$f->add_transition(0,1, 0);
$f->add_transition(1,1, 1);
$f->add_transition(1,1, 0);
return $f;
};
# Return a FLAT::DFA which matches bit strings which are an even number N.
# An empty string "" is reckoned as 0 and so is matched.
use constant::defer bits_N_even_flat => sub {
require FLAT::Regex;
my $f = FLAT::Regex->new('(0|1)* 0 | []')->as_dfa;
$f->{'name'} = 'even N';
return $f;
};
# Return a FLAT::DFA which matches bit strings which are an odd number N.
use constant::defer bits_N_odd_flat => sub {
require FLAT::Regex;
my $f = FLAT::Regex->new('(0|1)* 1')->as_dfa;
$f->{'name'} = 'odd N';
return $f;
};
# Return a FLAT::DFA which matches exactly $len many bits 0,1.
sub bits_of_length_flat {
my ($len) = @_;
my $f = FLAT::DFA->new;
if ($len < 0) { $len = -1; }
$f->add_states($len+2);
$f->set_starting(0);
if ($len >= 0) {
$f->set_accepting($len);
}
foreach my $state (0 .. $len) {
$f->add_transition($state,$state+1, 0);
$f->add_transition($state,$state+1, 1);
}
my $non = $len+1;
$f->add_transition($non,$non, 0);
$f->add_transition($non,$non, 1);
return $f->MyFLAT::set_name("$len bits");
# return FLAT::Regex->new('(0|1)' x $len)
# ->as_dfa
# ->MyFLAT::minimize
# ->MyFLAT::set_name("$len bits");
}
sub bits_of_length_or_more_flat {
my ($len) = @_;
require FLAT::Regex;
return FLAT::Regex->new(('(0|1)' x $len) . '(0|1)*')
->as_dfa
->MyFLAT::minimize
->MyFLAT::set_name(">=$len bits");
}
#------------------------------------------------------------------------------
# Return all the labels which transition $from_state to $to_state.
sub FLAT_get_transition_labels {
my ($fa, $from_state, $to_state) = @_;
### FLAT_get_transition_labels(): "$from_state to $to_state"
my @ret;
foreach my $symbol ($fa->alphabet) {
### $symbol
my $next;
if ((($next) = $fa->successors($from_state, $symbol))
&& $next==$to_state) {
push @ret, $symbol;
}
### $next
}
### @ret
return @ret;
}
#------------------------------------------------------------------------------
# printouts
sub FLAT_varname {
my ($fa) = @_;
my $name = $fa->{'name'};
if (defined $name) {
$name =~ tr/a-zA-Z0-9_/_/c;
}
return $name;
}
sub FLAT_print_perl_table {
my ($fa, $name) = @_;
$name //= FLAT_varname($fa);
my @alphabet = sort {$a<=>$b} $fa->alphabet;
print "# alphabet ",join(',',@alphabet),"\n";
require MyPrintwrap;
print "\@$name = (\n";
MyPrintwrap::printwrap_indent(" ");
my @states = $fa->get_states;
foreach my $state (@states) {
my @row = map { my $symbol = $_;
my @next = $fa->successors($state,$symbol);
if (@next != 1) {
croak "Not single next for $state symbol $symbol";
}
$next[0]
} @alphabet;
MyPrintwrap::printwrap(" [".join(',',@row)."]"
. ($state == $#states ? "" : ','));
}
print ");\n";
}
sub FLAT_print_perl_accepting {
my ($fa, $name) = @_;
$name //= FLAT_varname($fa);
my @accepting = $fa->get_accepting;
my $start = "\@$name = (";
my $end = ");\n";
my $line = $start . join(',',@accepting) . $end;
if (length $line < 79) {
print "$line\n";
return;
}
require MyPrintwrap;
MyPrintwrap::printwrap_indent(" ");
print $start,"\n";
foreach my $i (0 .. $#accepting) {
MyPrintwrap::printwrap("$accepting[$i]"
. ($i == $#accepting ? "" : ','));
}
MyPrintwrap::printwrap($end);
}
sub FLAT_print_gp_inline_table {
my ($fa, $name) = @_;
require MyPrintwrap;
MyPrintwrap::printwrap_indent("% GP-DEFINE ");
$MyPrintwrap::Printwrap = 0;
MyPrintwrap::printwrap("$name = {[");
$MyPrintwrap::Printwrap += 2;
my @alphabet = sort {$a<=>$b} $fa->alphabet;
my @states = $fa->get_states;
foreach my $state (@states) {
my @row = map { my @to = $fa->successors($state,$_);
@to<=1 or die "oops, not a DFA";
@to ? $to[0]+1 : "'none" } @alphabet;
MyPrintwrap::printwrap(join(',',@row)
. ($state == $#states ? '' : ';'));
}
MyPrintwrap::printwrap("]};\n");
}
sub FLAT_print_gp_inline_accepting {
my ($fa, $name) = @_;
require MyPrintwrap;
MyPrintwrap::printwrap_indent("% GP-DEFINE ");
$MyPrintwrap::Printwrap = 0;
MyPrintwrap::printwrap("$name = {[");
$MyPrintwrap::Printwrap += 2;
my $join = '';
my @accepting = $fa->get_accepting;
foreach my $i (0 .. $#accepting) {
MyPrintwrap::printwrap(($accepting[$i]+1) . ($i == $#accepting ? '' : ','));
}
MyPrintwrap::printwrap("]};\n");
}
sub FLAT_print_tikz {
my ($fa, %options) = @_;
my $node_prefix = $options{'node_prefix'} // 's';
my $flow = $options{'flow'} // $fa->{'flow'} // 'east';
my $state_labels = $options{'state_labels'};
print "% accepting ", join(',',$fa->get_accepting), "\n";
my @column_to_states;
my @state_to_column;
my $put_state = sub {
my ($state, $column) = @_;
$state_to_column[$state] = $column;
push @{$column_to_states[$column]}, $state;
};
foreach my $state ($fa->get_starting) {
$put_state->($state, 0);
}
for (my $c = 0; $c <= $#column_to_states; $c++) {
foreach my $from_state (@{$column_to_states[$c]}) {
next unless defined $state_to_column[$from_state];
my $to_column = $state_to_column[$from_state] + 1;
foreach my $to_state (sort $fa->successors($from_state)) {
next if defined $state_to_column[$to_state];
$put_state->($to_state, $to_column);
}
}
}
# unreached states at end
foreach my $state ($fa->get_states) {
next if defined $state_to_column[$state];
$put_state->($state, scalar(@column_to_states));
}
foreach my $column (0 .. $#column_to_states) {
my $states = $column_to_states[$column];
foreach my $i (0 .. $#$states) {
my $state = $states->[$i];
my $x = $column;
my $y = $i - int(scalar(@$states)/2);
if ($flow eq 'west') { $x = -$x; }
if ($flow eq 'north') { ($x,$y) = ($y,$x); }
if ($flow eq 'south') { ($x,$y) = ($y,-$x); }
my $state_name = "$node_prefix$state";
my $state_str = ($state_labels ? $state_labels->[$state] : $state);
print " \\node ($state_name) at ($x,$y) [my box] {$state_str};\n";
}
}
print "\n";
my @alphabet = sort {$a<=>$b} $fa->alphabet;
foreach my $from_state ($fa->get_states) {
my $from_state_name = "$node_prefix$from_state";
print " % $from_state_name\n";
require Tie::IxHash;
my %to_lists;
tie %to_lists, 'Tie::IxHash';
foreach my $symbol (@alphabet) {
if (my ($to_state) = $fa->successors($from_state, $symbol)) {
push @{$to_lists{$to_state}}, $symbol;
}
}
while (my ($to_state, $labels) = each %to_lists) {
my $to_state_name = "$node_prefix$to_state";
$labels = join(',', @$labels);
if ($from_state eq $to_state) {
print " \\draw [->,loop below] ($from_state_name) to node[pos=.12,auto=left] {$labels} ();\n";
} else {
my $bend = '';
my $pos = '.45';
if ($fa->get_transition($to_state,$from_state)) {
$bend = ',bend left=10';
$pos = '.5';
}
print " \\draw [->$bend] ($from_state_name) to node[pos=$pos,auto=left] {$labels} ($to_state_name);\n";
}
}
print "\n";
}
}
#------------------------------------------------------------------------------
# $aref is an arrayref of arrayrefs which is a state table.
# [ [1,2],
# [2,0],
# [0,1] ]
# States are numbered C<0> to C<$#$aref> inclusive.
# The table has C<$new_state = $aref-E[$state]-E[$digit]>.
# Return a FLAT::DFA of this state table.
#
# Optional further key/value arguments are
# starting => $state
# accepting => $state
# accepting_list => arrayref [ $state, $state, ... ]
# name => $string
#
# C is the starting state, or default 0.
#
# C or C are the state or states which are accepting.
# If both C and C are given then both their states
# specified are made accepting.
#
sub aref_to_FLAT_DFA {
my ($aref, %options) = @_;
require FLAT::DFA;
my $f = FLAT::DFA->new;
my @fstates = $f->add_states(scalar(@$aref));
my $starting = $options{'starting'} // 0;
$f->set_starting($fstates[$starting]);
### starting: "$starting (= $fstates[$starting])"
my @accepting = (@{$options{'accepting_list'} // []},
$options{'accepting'} // ());
if (! @accepting) { @accepting = $#$aref; }
$f->set_accepting(map {$fstates[$_]} @accepting);
my $width = @{$aref->[0]};
foreach my $state (0 .. $#$aref) {
my $row = $aref->[$state];
if (@$row != $width) {
croak "state row $state doesn't have $width entries";
}
foreach my $digit (0 .. $#$row) {
my $to_state = $row->[$digit]
// next; # croak "state $state digit $digit destination undef";
($to_state >= 0 && $to_state <= $#$aref)
or croak "state $state digit $digit destination $to_state out of range";
### transition: "$state(=$fstates[$state]) digit=$digit -> $to_state($fstates[$to_state])"
$f->add_transition($fstates[$state], $fstates[$to_state], $digit);
}
}
$f->{'name'} = $options{'name'};
return $f;
}
#------------------------------------------------------------------------------
# $fa is a FLAT::NFA or FLAT::DFA.
# Return a list of how many strings of length $len are accepted, for $len
# running 0 to $max_len inclusive.
# The counts can become large, especially when $fa has a lot of symbols.
# The numeric type of the return is inherited from $max_len, so for example
# if it is a Math::BigInt then that is used for the returns.
# In general, the counts are a linear recurrences with order at most the number
# of states in $fa. Such recurrences include constants (like one string of
# each length), and polynomials.
#
# MAYBE: length => $len count strings = $len accepted
# MAYBE: max_length => $len count strings <= $len accepted
# MAYBE: by_length_upto => $len counts of strings each length <= $len
#
# count_matrix($fa) = [],[] $array[$row]->[$col] with M*initcol = counts
# count_recurrence($fa)
#
sub FLAT_count_contains {
my ($fa, $max_len, %options) = @_;
my @states = $fa->get_states;
my @accepting = $fa->get_accepting;
my @alphabet = $fa->alphabet;
my $zero = $max_len*0; # inherit bignum from $max_len
my $ret_type = $options{'ret_type'} || 'accepting';
my @counts = map {$zero} 0 .. $#states;
### starting: $fa->get_starting
### @accepting
### @counts
foreach my $state ($fa->get_starting) {
$counts[$state]++;
}
my @ret;
if ($ret_type eq 'rows') {
@ret = map {[]} 0 .. $#counts;
}
foreach my $k (0 .. $max_len) {
### at: "k=$k ".join(',',map{$_//'_'}@counts)." total ".sum(0,map{$_//0}@counts)." accepting ".sum(0,map{$counts[$_]//0}@accepting)
{
my $accepting_count = $zero;
foreach my $state (@accepting) {
if ($counts[$state]) {
$accepting_count += $counts[$state];
}
}
if ($ret_type eq 'accepting') {
push @ret, $accepting_count;
} elsif ($ret_type eq 'columns') {
push @ret, \@counts;
} elsif ($ret_type eq 'rows') {
foreach my $i (0 .. $#counts) {
push @{$ret[$i]}, $counts[$i];
}
}
}
last if $k == $max_len;
my @new_counts = map {$zero} 0 .. $#states;
foreach my $from_state (@states) {
my $from_count = $counts[$from_state] || next;
foreach my $symbol (@alphabet) {
foreach my $to_state ($fa->successors($from_state, $symbol)) {
### add: "$from_count $from_state -> $to_state"
$new_counts[$to_state] += $from_count;
}
}
}
@counts = @new_counts;
}
return @ret;
}
sub counts_starting {
my ($fa, $zero) = @_;
if (! defined $zero) { $zero = 0; }
return [ map { $zero + ($fa->is_starting($_) ? 1 : 0) }
0 .. $fa->num_states-1 ];
}
sub counts_next {
my ($fa, $aref) = @_;
# ENHANCE-ME: This is a bit slow. What's the right way to iterate all
# transitions?
my $zero = $aref->[0] * 0;
my @new_counts = ($zero) x scalar(@$aref);
my @alphabet = $fa->alphabet;
foreach my $from_state ($fa->get_states) {
my $from_count = $aref->[$from_state] || next;
foreach my $symbol (@alphabet) {
foreach my $to_state ($fa->epsilon_closure
($fa->successors($from_state, $symbol))) {
$new_counts[$to_state] += $from_count;
}
}
}
return \@new_counts;
}
sub counts_accepting {
my ($fa, $aref) = @_;
my $ret = $aref->[0] * 0;
foreach my $state ($fa->get_accepting) {
$ret += $aref->[$state];
}
return $ret;
}
# FIXME: Not right for non-accepting cycles.
sub finite_max_length {
my ($fa) = @_;
### finite_max_length() ...
my @pending = $fa->get_starting;
my %seen = map {$_=>1} @pending;
my $ret = -1;
my $len = 0;
while (@pending) {
if (grep {$fa->is_accepting($_)} @pending) {
### accepting ...
$ret = $len;
}
$len++;
@pending = $fa->epsilon_closure($fa->successors(\@pending));
### to: @pending
@pending = grep {! $seen{$_}++} @pending;
}
### $ret
return $ret;
}
#------------------------------------------------------------------------------
# FLAT temporary
sub minimize {
my ($flat, %options) = @_;
my $name = eval { $flat->{'name'} };
if ($options{'verbose'}) {
print "minimize ",$flat->{'name'}//''," ",$flat->num_states," states ...";
}
$flat = $flat->as_dfa;
$flat = $flat->as_min_dfa;
if ($options{'verbose'}) {
print "done, num states ",$flat->num_states,"\n";
}
$flat->{'name'} = $name;
return $flat;
}
# workaround for FLAT::DFA ->as_nfa() leaving itself blessed down in FLAT::DFA
sub as_nfa {
my ($fa) = @_;
$fa = $fa->as_nfa;
if ($fa->isa('FLAT::DFA')) { bless $fa, 'FLAT::NFA'; }
return $fa;
}
# workaround for FLAT::DFA ->reverse() infinite recursion, can reverse in NFA
sub reverse {
my ($fa) = @_;
if ($fa->isa('FLAT::DFA')) {
$fa->MyFLAT::as_nfa($fa)->reverse->as_dfa;
} else {
$fa->reverse;
}
}
# workaround for FLAT::DFA ->concat() infinite recursion, can reverse in NFA
sub concat {
my $fa = shift @_;
my $want_dfa = $fa->isa('FLAT::DFA');
foreach my $f2 (@_) {
$fa = $fa->MyFLAT::as_nfa->concat($f2->MyFLAT::as_nfa);
}
if ($want_dfa) {
$fa = $fa->as_dfa;
}
return $fa;
}
# workaround for FLAT::DFA ->star() infinite recursion, can star in NFA
sub star {
my ($fa) = @_;
if ($fa->isa('FLAT::DFA')) {
$fa->MyFLAT::as_nfa($fa)->star->as_dfa;
} else {
$fa->star;
}
}
#------------------------------------------------------------------------------
sub view {
my ($fa) = @_;
require MyGraphs;
if ($fa->can('as_graphviz')) { # in FLAT::FA, not in FLAT::Regex
MyGraphs::graphviz_view($fa->as_graphviz);
} else {
print $fa->as_string;
}
}
sub FLAT_to_perl_re {
my ($fa) = @_;
my $str = $fa->as_perl_regex;
$str =~ s/\Q?://g;
return $str;
}
sub FLAT_check_is_equal {
my ($f1, $f2, %options) = @_;
my @names = ($f1->{'name'} // 'first',
$f2->{'name'} // 'second');
if ($f1->equals($f2)) {
print "$names[0] = $names[1], ok\n";
return;
}
{
my $a1 = join(',',sort $f1->alphabet);
my $a2 = join(',',sort $f2->alphabet);
unless ($a1 eq $a2) {
print "different alphabet: $a1\n";
print " alphabet: $a2\n";
}
}
my $radix = $options{'radix'}
// do { my @labels = $f1->alphabet; scalar(@labels) };
print "$names[0] not equal $names[1]\n";
foreach my $which (1, 2) {
my $extra = $f1->as_dfa->difference($f2->as_dfa);
print "extra in $names[0] over $names[1]\n";
if ($extra->is_empty) {
print " is_empty()\n";
} else {
if ($extra->is_finite) {
print " is_finite()\n";
}
require Math::BaseCnv;
if ($extra->contains('')) {
print " [] zero length string\n";
}
my $it = $extra->new_acyclic_string_generator;
# my $it = $extra->new_deepdft_string_generator(20);
my $count = 0;
while (my $str = $it->()) {
if (++$count > 20) {
print " ... and more\n";
last;
}
my $n = Math::BaseCnv::cnv($str,$radix,10);
print " $str N=$n\n";
}
}
@names = CORE::reverse @names;
($f1,$f2) = ($f2,$f1);
}
exit 1;
}
sub FLAT_check_is_subset {
my ($fsub, $fsuper) = @_;
if (! $fsub->as_dfa->is_subset_of($fsuper->as_dfa)) {
my $f = $fsub->as_dfa->difference($fsuper->as_dfa);
my $it = $f->new_acyclic_string_generator;
if (defined(my $sub_name = $fsub->{'name'})
&& defined(my $super_name = $fsuper->{'name'})) {
print "$sub_name not subset of $super_name, ";
}
print "extras in supposed subset\n";
my $count = 0;
while (my $str = $it->()) {
if (++$count > 20) {
print " ... and more\n";
last;
}
print " $str\n";
}
exit 1;
}
my $fsub_name = $fsub->{'name'} // 'subset';
my $fsuper_name = $fsuper->{'name'} // 'superset';
print "$fsub_name subset of $fsuper_name, ok\n";
}
sub FLAT_show_breadth {
my ($flat, $width, $direction) = @_;
$direction //= 'hightolow';
if (defined (my $name = $flat->{'name'})) {
print "$name ";
}
print "contains ($direction, by breadth)\n";
if ($flat->is_empty) {
print " is_empty()\n";
} elsif ($flat->is_finite) {
print " is_finite()\n";
}
my $count = 0;
my $total = 0;
my @alphabet = sort $flat->alphabet;
my $radix = @alphabet;
$total++;
if ($flat->contains('')) {
print " [empty string]\n";
$count++;
}
require Math::BaseCnv;
foreach my $k (1 .. $width) {
foreach my $n (0 .. $radix**$k-1) {
my $str = Math::BaseCnv::cnv($n,10,$radix);
$str = sprintf '%0*s', $k, $str;
if ($direction eq 'lowtohigh') { $str = CORE::reverse $str; }
$total++;
if ($flat->contains($str)) {
print " $str N=$n\n";
$count++;
}
}
}
print " count $count / $total\n";
}
sub FLAT_show_transitions {
my ($flat,$str) = @_;
my @str = split //, $str;
my $print_states = sub {
if (@_ == 0) {
print "(none)";
return;
}
my $join = '';
foreach my $state (@_) {
print $join, $state, $flat->is_accepting($state) ? "*" : '';
$join = ',';
}
};
foreach my $initial ($flat->get_starting) {
my $state = $initial;
$print_states->($state);
foreach my $char (@str) {
print " ($char)";
my @next = $flat->successors($state,$char);
if (! @next) {
last;
}
$state = $next[0];
print "-> ";
$print_states->(@next);
}
print "\n";
}
}
sub FLAT_check_accepting_remain_so {
my ($flat) = @_;
my @accepting = $flat->get_accepting;
my @alphabet = $flat->alphabet;
my $bad = 0;
my $name = $flat->{'name'} // '';
foreach my $state (@accepting) {
foreach my $char (@alphabet) {
my @next = $flat->successors($state,$char);
foreach my $to (@next) {
if (! $flat->is_accepting($to)) {
print "$name $state ($char) -> $to is no longer accepting\n";
$bad++;
}
}
}
}
if ($bad) { exit 1; }
print "$name accepting remain so, ok\n";
}
sub FLAT_show_acyclics {
my ($flat) = @_;
my $it = $flat->new_acyclic_string_generator;
if (defined (my $name = $flat->{'name'})) {
print "$name ";
}
print "acyclics\n";
if ($flat->is_empty) {
print " empty\n";
}
my $count = 0;
while (my $str = $it->()) {
if (++$count > 8) {
print " ... and more\n";
last;
}
print " $str\n";
}
}
sub FLAT_show_deep {
my ($flat, $depth) = @_;
my $it = $flat->new_deepdft_string_generator($depth // 5);
print "depth $depth\n";
my $count = 0;
while (my $str = $it->()) {
if (++$count > 8) {
print " ... and more\n";
last;
}
print " $str\n";
}
}
#------------------------------------------------------------------------------
sub set_name {
my ($flat, $name) = @_;
$flat->{'name'} = $name;
return $flat;
}
#------------------------------------------------------------------------------
=pod
=over
=item C<$new_fa = $fa-Edigits_increment (key =E value, ...)>
C<$fa> is a C or C accepting digit strings. Return a
new FLAT (same DFA or NFA) which accepts numbers +1, or +/- a given
increment. Key/value options are
add => integer, default 1
radix => integer>=2, default from alphabet
direction => "hightolow" (default) or "lowtohigh"
Option C $add> is the increment to apply (default 1). This can
be negative too.
Option C $radix> is the digit radix. The default is taken from
the digits appearing in C<$fa-Ealphabet> which is usually enough. The
option can be used if C<$fa> might not have all digits appearing in its
alphabet.
Digit strings are taken as high to low. Option C
"lowtohigh"> takes them low to high instead. Low to high is more efficient
here since manipulations are at the low end (add the increment and carry up
through low digits), but both work.
An increment can increase string length, for example 999 -E 1000. If
there are high 0s on a string then the carry propagates into them and does
not change the length, so 00999 -E 01000.
Negative increments do not decrease string length, so 1000 -> 0999. If
C<$add> reduces a number below 0 then that string is quietly dropped.
If the strings matched by C<$fa> represent a predicate, numbers with some
property, then the returned C<$new_fa> is those N for which N-add has the
property. This is since C<$new_fa> is +add from the originals. So to get a
predicate testing whether N+1 has the property, apply an C -1>.
An C of that and the original becomes a predicate for a pair N
and N+1 both with the property and longer runs can be made by further
intersects.
ENHANCE-ME: Maybe a width option to stay in given number of digits, discard
anything which would increment to bigger. Or a wraparound option to ignore
carry above width for modulo radix^width.
ENHANCE-ME: Maybe decrement should trim a high 0 digit. That would mean a
set of strings without high 0s remains so on decrement. But if say infinite
high 0s are present then wouldn't want to remove them. Perhaps when a
decrement goes to 0 it could be checked for an all-0s accepting state above,
and merge with it.
This function works by modifying the digits matched in C<$fa>, low to high.
For example if the starting state has a transition for low digit 4 then the
C<$new_fa> has starting state with transition for digit 5 instead. At a
given state there is a certain carry to propagate. At the starting states
this is C<$add>, and later it will be smaller. Existing states are reckoned
as carry 0. A new state is introduced for combinations of state and
non-zero carry reached. Transitions in those new states are based on the
originals. Where the original state has digit d the new state has (d+carry)
mod 10 and goes to the original successor and new_carry =
floor((4+carry)/10). If that new_carry is zero then this is the original
successor state since the increment is now fully applied. If new_carry is
non-zero then it's another new state for combination of state and carry. In
a C any epsilon transitions are stepped across to find what
digits in fact occur at the given state. In general an increment +1
propagates only up through digit 9s so that say 991 -> 002 (low to high).
Often C<$fa> might match only a few initial 9s and so only a few new states
introduced.
ENHANCE-ME: Could have some generality by reckoning the carry as an
arbitrary key or transform state, and go through $fa by a composition. Any
such transformation can be made with a finite set of possible keys.
=back
=cut
sub digits_increment {
my ($fa, %options) = @_;
### digits_increment() ...
# starting state is flip
# in flip 0-bit successor as a 1-bit, and thereafter unchanged
# 1-bit successor as a 0-bit, continue flip
my $direction = $options{'direction'} || 'hightolow';
my $radix = $options{'radix'} || max($fa->alphabet)+1;
my $nine = $radix-1;
my $add = $options{'add'} // 1;
### $radix
### $nine
my $is_dfa = $fa->isa('FLAT::DFA');
$fa = $fa->MyFLAT::as_nfa->clone;
if ($direction eq 'hightolow') { $fa = $fa->reverse; }
my %state_and_carry_to_new_state;
require Tie::IxHash;
tie %state_and_carry_to_new_state, 'Tie::IxHash';
{
# states reachable by runs of 9s from starting states
my @pending = map {[$_,$add]} $fa->get_starting;
while (my $elem = shift @pending) {
my ($state, $carry) = @$elem;
unless (exists $state_and_carry_to_new_state{"$state,$carry"}) {
my ($new_state) = $fa->add_states(1);
### reach: "state=$state new_state=$new_state carry=$carry"
$state_and_carry_to_new_state{"$state,$carry"} = $new_state;
if ($fa->is_starting($state) && $carry==$add) {
$fa->set_starting($new_state);
$fa->unset_starting($state);
}
foreach my $digit (0 .. $nine) {
my ($new_carry,$new_digit) = _divrem($digit+$carry, $radix);
if ($new_carry) {
push @pending, map {[$_,$new_carry]}
$fa->successors([$fa->epsilon_closure($state)],$digit);
}
}
}
}
}
### %state_and_carry_to_new_state
while (my ($state_and_carry, $new_state)
= each %state_and_carry_to_new_state) {
my ($state,$carry) = split /,/, $state_and_carry;
### setup: "state=$state carry=$carry new_state=$new_state"
foreach my $digit (0 .. $nine) {
my ($new_carry,$new_digit) = _divrem($digit+$carry, $radix);
foreach my $successor ($fa->successors([$fa->epsilon_closure($state)],
$digit)) {
my $new_successor
= ($new_carry
? $state_and_carry_to_new_state{"$successor,$new_carry"}
: $successor);
### digit: "state=$state carry=$carry digit=$digit successor $successor"
### new : " new state $new_state new_digit=$new_digit with new_carry=$new_carry new_successor=$new_successor"
$fa->add_transition ($new_state, $new_successor, $new_digit);
}
}
if ($carry > 0 && $fa->is_accepting($state)) {
# 99...99 accepting becomes 00..00 1 accepting, with a new state for
# the additional carry
### carry above accepting: "carry=$carry"
my $from_state;
while ($carry) {
$from_state = $new_state;
($new_state) = $fa->add_states(1);
($carry, my $digit) = _divrem($carry, $radix);
$fa->add_transition($from_state, $new_state, $digit);
### transition: "$from_state -> $new_state"
}
$fa->set_accepting($new_state);
### accepting: $new_state
}
}
if (defined $fa->{'name'}) {
$fa->{'name'} =~ s{\+(\d+)$}{'+'.($1+1)}e
or $fa->{'name'} .= '+1';
}
if ($direction eq 'hightolow') { $fa = $fa->reverse; }
if ($is_dfa) { $fa = $fa->as_dfa; }
return $fa;
}
# sub successors_through_epsilon {
# my ($fa, $state, $symbol) = @_;
# return $fa->epsilon_closure($fa->successors($state,$symbol));
# }
sub _divrem {
my ($n,$d) = @_;
my $r = $n % $d;
return (($n-$r)/$d, $r);
}
#------------------------------------------------------------------------------
=item C<$new_lang = $lang-Eskip_initial ()>
=item C<$new_lang = $lang-Eskip_final ()>
Return a new regular language object, of the same type as C<$lang>, which
matches the strings of C<$lang> with 1 initial or final symbol skipped.
A string of 1 symbol in C<$lang> becomes the empty string in C<$new_lang>.
The empty string in C<$lang> cannot have 1 symbol skipped so is ignored when
forming C<$new_lang>.
In a C, C works by changing the starting states to
the immediate successors of the current starting states. For a
C, if this results in multiple starts then they are converted to
a single start by the usual C. C works by changing
the accepting states to their immediate predecessors.
No minimization is performed. It's possible changed starts might leave some
states unreachable. It's possible changed accepting could leave various
states never reaching an accept.
ENHANCE-ME: maybe parameter $n to skip how many.
=back
=cut
sub skip_initial {
my ($fa) = @_;
### skip_initial(): $fa
my $name = $fa->{'name'};
my $is_dfa = $fa->isa('FLAT::DFA');
$fa = $fa->MyFLAT::as_nfa->clone; # need NFA for new multiple starts
my @states = $fa->get_starting;
$fa->unset_starting(@states);
### starting: @states
$fa->set_starting($fa->successors([$fa->epsilon_closure(@states)]));
### new starting: [ $fa->get_starting ]
if ($is_dfa) { $fa = $fa->as_dfa; }
if (defined $name) {
$name =~ s{ skip initial( (\d+))?$}{' skip initial '.(($2||0)+1)}e
or $name .= ' skip initial';
$fa->{'name'} = $name;
}
return $fa;
}
{
package FLAT::Regex;
sub MyFLAT_skip_initial {
my $self = shift;
$self->_from_op($self->op->MyFLAT_skip_initial(@_));
}
sub MyFLAT_skip_final {
my $self = shift;
$self->_from_op($self->op->MyFLAT_skip_final(@_));
}
}
{
package FLAT::Regex::Op::atomic;
sub MyFLAT_skip_initial {
my ($self) = @_;
### atomic MyFLAT_skip_initial: $self
my $member = $self->members;
return __PACKAGE__->new(defined $member && length($member)
? '' # symbol, becomes empty string
: undef); # empty str or null regex, becomes null
}
*MyFLAT_skip_final = \&MyFLAT_skip_initial;
# return a list of the initial symbols accepted
sub MyFLAT_initial_symbols {
my ($self) = @_;
my $member = $self->members;
return (defined $member && length($member) ? $member : ());
}
}
{
package FLAT::Regex::Op::star;
# skip_initial(X*) = skip_initial(X) X*
# skip_final(X*) = X* skip_final(X)
# or if X has no non-empty strings then return has no non-empty
sub MyFLAT_skip_initial {
my ($self) = @_;
my $member = $self->members;
return ($member->has_nonempty_string
? FLAT::Regex::Op::concat->new($member->MyFLAT_skip_initial, $self)
: $member);
}
sub MyFLAT_skip_final {
my ($self) = @_;
my $member = $self->members;
return ($member->has_nonempty_string
? FLAT::Regex::Op::concat->new($self, $member->MyFLAT_skip_final)
: $member);
}
# initial_symbols(X*) = initial_symbols(X)
sub MyFLAT_initial_symbols {
my ($self) = @_;
return $self->members->MyFLAT_initial_symbols;
}
}
{
package FLAT::Regex::Op::concat;
# skip_initial(X Y Z) = skip_initial(X) Y Z
# skip_final(X Y Z) = X Y skip_initial(Z)
# any X, or Z, without a non-empty string is skipped
sub MyFLAT_skip_initial {
my ($self) = @_;
my @members = $self->members;
# skip initial members which are the empty string and nothing else
while (@members >= 2
&& ! $members[0]->is_empty
&& ! $members[0]->has_nonempty_string) {
shift @members;
}
$members[0] = $members[0]->MyFLAT_skip_initial;
return (ref $self)->new(@members);
}
sub MyFLAT_skip_final {
my ($self) = @_;
my @members = $self->members;
# skip trailing members which are the empty string and nothing else
while (@members >= 2
&& ! $members[-1]->is_empty
&& ! $members[-1]->has_nonempty_string) {
pop @members;
}
$members[-1] = $members[-1]->MyFLAT_skip_final;
return (ref $self)->new(@members);
}
# initial_symbols(X Y Z) = initial_symbols(X)
# or whichever of X,Y,Z first has a non-empty string
sub MyFLAT_initial_symbols {
my $self = shift;
my @ret;
foreach my $member ($self->members) {
@ret = $member->MyFLAT_initial_symbols and last;
}
return @ret;
}
}
{
package FLAT::Regex::Op::alt;
# skip_initial(X | Y) = skip_initial(X) | skip_initial(Y)
# skip_final(X | Y) = skip_final(X) | skip_final(Y)
sub MyFLAT_skip_initial {
my $self = shift;
return $self->MyFLAT__map_method('MyFLAT_skip_initial',@_);
}
sub MyFLAT_skip_final {
my $self = shift;
return $self->MyFLAT__map_method('MyFLAT_skip_final',@_);
}
# initial_symbols(X|Y) = union(initial_symbols(X), initial_symbols(Y))
sub MyFLAT_initial_symbols {
my $self = shift;
my %ret;
foreach my $member ($self->members) {
foreach my $symbol ($member->MyFLAT_initial_symbols) {
$ret{$symbol} = 1;
}
}
return keys %ret;
}
}
{
package FLAT::Regex::Op::shuffle;
# can this be done better?
sub MyFLAT__map_skip {
my $self = shift;
my $method = shift;
my @members = $self->members;
my @alts;
foreach my $i (0 .. $#members) {
if ($members[$i]->has_nonempty_string) {
my @skip = @members;
$skip[$i] = $skip[$i]->MyFLAT_skip_initial(@_);
push @alts, __PACKAGE__->new(@skip);
}
}
return (@alts
? FLAT::Regex::Op::alt->new (@alts)
: FLAT::Regex::Op::atomic->new(undef));
}
sub MyFLAT_skip_initial {
my $self = shift;
return $self->MyFLAT__map_skip('MyFLAT_skip_final',@_);
}
sub MyFLAT_skip_final {
my $self = shift;
return $self->MyFLAT__map_skip('MyFLAT_skip_final',@_);
}
# wrong
# sub MyFLAT_skip_initial {
# my $self = shift;
# my %initial;
# my @members = $self->members;
# foreach $member (@members) {
# my @symbols = $members[$i]->MyFLAT_initial_symbols or next;
# @initial{@symbols} = (); # hash slice
# $member = $member->MyFLAT_skip_initial(@_); # mutate array
# }
# if (%initial) {
#
# return (%initial
# ? FLAT::Regex::Op::concat->new
# (FLAT::Regex::Op::alt->new
# (map {FLAT::Regex::Op::atomic->new($_)} keys %initial),
# __PACKAGE__->new(@members))
#
# : FLAT::Regex::Op::atomic->new(undef))
#
# return $self->MyFLAT__map_skip('MyFLAT_skip_final',@_);
# }
}
sub skip_final {
my ($fa, %options) = @_;
my $name = $fa->{'name'};
my $is_dfa = $fa->isa('FLAT::DFA');
$fa = $fa->MyFLAT::as_nfa
->MyFLAT::reverse
->MyFLAT::skip_initial(%options)
->MyFLAT::reverse;
if ($is_dfa) { $fa = $fa->as_dfa; }
if (defined $name) {
$name =~ s{ skip final( (\d+))?$}{' skip final '.(($1||0)+1)}e
or $name .= ' skip final';
$fa->{'name'} = $name;
}
return $fa;
}
# sub skip_initial_0s {
# my ($fa) = @_;
# my $s = $fa->MyFLAT::skip_initial;
# }
#------------------------------------------------------------------------------
# $fa is a FLAT::NFA or FLAT::DFA which matches strings of bits.
# Return a new FLAT (same DFA or NFA) which accepts the same in base-4.
#
# MAYBE: a general transform of list of symbols -> single symbol
#
# lowtohigh or hightolow only affects how a high 0-bit
#
sub binary_to_base4 {
my ($fa, %options) = @_;
my $direction = $options{'direction'} || 'hightolow';
### binary_to_base4(): $direction
my $name = $fa->{'name'};
my $is_dfa = $fa->isa('FLAT::DFA');
if ($direction eq 'hightolow') { $fa = $fa->reverse; }
my $new_fa = FLAT::DFA->new;
my @state_to_new_state;
my $state_to_new_state = sub {
my ($state) = @_;
my $new_state = $state_to_new_state[$state];
if (! defined $new_state) {
($new_state) = $new_fa->add_states(1);
### $new_state
$state_to_new_state[$state] = $new_state;
if ($fa->is_accepting($state)) {
$new_fa->set_accepting($new_state);
}
}
return $new_state;
};
my @pending = $fa->get_starting;
$new_fa->set_starting(map {$state_to_new_state->($_)}
$fa->epsilon_closure(@pending));
my @state_done;
while (@pending) {
my $state = pop @pending;
next if $state_done[$state]++;
my $new_state = $state_to_new_state->($state);
foreach my $bit0 (0,1) {
my @successors = $fa->successors([$fa->epsilon_closure($state)],
$bit0);
foreach my $bit1 (0,1) {
my @successors = $fa->successors([$fa->epsilon_closure(@successors)],
$bit1);
my $digit = $bit0 + 2*$bit1;
foreach my $successor (@successors) {
my $new_successor = $state_to_new_state->($successor);
### old: "bit0=$bit0 bit1=$bit1 $state to $successor"
### new: "digit=$digit $new_state to $new_successor"
$new_fa->add_transition($new_state, $new_successor, $digit);
push @pending, $successor;
}
}
}
}
if ($direction eq 'hightolow') { $new_fa = $new_fa->reverse; }
if ($is_dfa) { $new_fa = $new_fa->as_dfa; }
if (defined $name) {
$name =~ s{ skip final( (\d+))?$}{' skip final '.(($2||0)+1)}e
or $name .= ' base-4';
$new_fa->{'name'} = $name;
}
return $new_fa;
}
# $fa is a FLAT::NFA or FLAT::DFA.
# Return a new FLAT (same DFA or NFA) which accepts blocks of $n many symbols.
#
# New symbols are string concatenation of the existing, so for example
# symbols a,b,c in blocks of 2 would have symbols aa,ab,ba,bb,etc.
#
# ENHANCE-ME: A separator string, or mapper func for blocks to new symbol.
#
sub blocks {
my ($fa, $n, %options) = @_;
my @alphabet = $fa->alphabet;
my $num_symbols = scalar(@alphabet);
my $num_blocks = $num_symbols ** $n;
my @states = $fa->get_states;
# clone with no transitions
my $new_fa = (ref $fa)->new;
$new_fa->add_states($fa->num_states);
$new_fa->set_starting($fa->get_starting);
$new_fa->set_accepting($fa->get_accepting);
foreach my $state (@states) {
### $state
foreach my $i (0 .. $num_blocks-1) {
### $i
my $q = $i;
my $block_symbol = '';
my @successors = ($state);
foreach (1 .. $n) {
my $r = $q % $num_symbols;
$q = ($q-$r) / $num_symbols;
my $symbol = $alphabet[$r];
$block_symbol .= $symbol;
@successors = $fa->successors([$fa->epsilon_closure(@successors)],
$symbol);
}
foreach my $successor (@successors) {
### new transition: "$state -> $successor label $block_symbol"
$new_fa->add_transition($state, $successor, $block_symbol);
}
}
}
if (defined(my $name = $fa->{'name'})) {
$name .= " blocks $n";
$new_fa->{'name'} = $name;
}
return $new_fa;
}
#------------------------------------------------------------------------------
sub as_perl {
my ($fa, %options) = @_;
my $str = '';
my $varname = $options{'varname'} // 'fa';
$str .= "my \$$varname = " . ref($fa) . "->new;\n";
my @states = sort {$a<=>$b} $fa->get_states;
$str .= "\$$varname->add_states(" . scalar(@states) . ");\n";
$str .= "\$$varname->set_starting(" . join(',',$fa->get_starting) . ");\n";
$str .= "\$$varname->set_accepting(" . join(',',$fa->get_accepting) . ");\n";
foreach my $from (@states) {
foreach my $to (@states) {
my $t = $fa->get_transition($from,$to) // next;
my @symbols = map {"'$_'"} $t->alphabet;
$str .= "\$$varname->add_transition($from,$to,".join(',',@symbols).");\n";
}
}
}
sub print_perl {
my $fa = shift;
print $fa->MyFLAT::as_perl(@_);
}
# $re is a Perl regexp, usually a qr/.../ form.
# Return a string which is a FLAT style regexp.
# Each char matched by $re is matched by the flat.
# There's no scope for multi-char symbols in the flat.
# Whitespace chars should not be matched by $re.
# Regexp::Common::balanced used here probably needs new enough Perl.
#
sub perl_regexp_to_flat_regex {
my ($re) = @_;
my $str = "$re";
# (?opts:...)
# x = ignore whitespace and comments
# Assume for now that if present then it's whitespace everywhere,
# which is not quite right.
if ($str =~ s/\(\?\^([a-z]*):/(/) {
my $opts = $1;
if ($opts =~ /x/) {
$str =~ tr/ \t\r\n//d;
}
}
# ^ $ assumed always for now
# would need a good idea of the alphabet
$str =~ s/[\^\$]//g;
# [123] char classes
$str =~ s{\[([^\]]*)\]}{ '(' . join('|',split //, $1) . ')' }eg;
# (| or |) empty alternative
$str =~ s/\(\|/([]|/g;
$str =~ s/\|\)/|[])/g;
# X+ repeats, possibly nested
while ($str =~ s{($RE{'balanced'}{-parens=>'()'}|[^)])\+}{$1$1*}o) {}
# X? optional, possibly nested
while ($str =~ s{($RE{'balanced'}{-parens=>'()'}|[^)])\?}{($1|[])}o) {}
### $str
return $str;
}
sub flat_regex_to_perl_regexp {
my ($str) = @_;
$str =~ s/\[\]//g;
return qr/^$str$/x;
}
#------------------------------------------------------------------------------
# Read and Write AT&T FSM Format
#
# AT&T format is transitions in lines like (and in no particular order)
#
# FromState ToState InputSymbol OutputSymbol
#
# States are numbered 0 upwards. 0 is the starting state. The accepting
# states are one per line after the transition lines.
#
# The symbols are non-whitespace, and normally 0 means the "epsilon"
# transition of an NFA.
#
sub ensure_states {
my $fa = shift;
foreach my $state (@_) {
if ((my $more = ($state+1 - $fa->num_states)) > 0) {
$fa->add_states($more);
}
}
}
# $filename contains an "AT&T" format finite state machine or finite state
# transducer. Return a FLAT::NFA of it. Key/value options are
#
# epsilon_symbol => string, default 0
# no_epsilon_symbol => boolean, default false
#
# Symbol 0 in the file means an epsilon transition for the NFA and becomes
# the FLAT style empty symbol ''. Another symbol can be given with
# "epsilon_symbol", or no_epsilon_symbol => 1 for no epsilon.
#
sub read_att_file {
my ($class, $filename, %options) = @_;
open my $fh, '<', $filename
or croak "Cannot read $filename: $!";
my $fa = $class->MyFLAT::read_att_fh($fh, %options);
close $fh
or croak "Error reading $filename: $!";
return $fa;
}
sub read_att_fh {
my ($class, $fh, %options) = @_;
### $fh
my $fa = $class->new;
$fa->add_states(1);
$fa->set_starting(0);
my $epsilon_symbol = '0';
if (defined $options{'epsilon_symbol'}) {
$epsilon_symbol = $options{'epsilon_symbol'};
}
if ($options{'no_epsilon_symbol'}) {
$epsilon_symbol = undef;
}
while (defined(my $line = readline $fh)) {
chomp $line;
if (my ($from,$to,$symbol) = $line =~ /^(\d+)\s+(\d+)\s+(\S+)/) {
# next if $symbol eq '@_IDENTITY_SYMBOL_@';
$fa->MyFLAT::ensure_states($from, $to);
if (defined $epsilon_symbol && $symbol eq $epsilon_symbol) {
$symbol = ''; # FLAT epsilon transition
}
$symbol =~ s/\./_/g;
$symbol =~ s/@/flag/g;
### transition: "$from $to $symbol"
$fa->add_transition($from,$to,$symbol);
} elsif (my ($state) = $line =~ /^(\d+)$/) {
$fa->set_accepting($state);
} else {
croak "Unrecognised AT&T line: ",$line;
}
}
return $fa;
}
# $fa is a FLAT::NFA or FLAT::DFA.
# Write it in "AT&T" format finite state machine format to $filename.
#
# $fa must have a single starting state 0, since that is all the file format
# allows. Apply some renumbering if necessary before calling here. For an
# NFA, there's no need to convert entirely to a DFA, just renumber and make
# state 0 have epsilon transitions to the actual desired start states.
#
# The key/value options are
#
# epsilon_symbol => string, default 0
#
# Epsilon transitions are written to the file as symbol 0 in the usual way
# for the file format, by default. The epsilon_symbol option can write
# something else. If $fa is a DFA, or if it's an NFA without epsilons, then
# this has no effect.
#
sub write_att_file {
my ($fa, $filename, %options) = @_;
open my $fh, '>', $filename
or croak "Cannot write $filename: $!";
$fa->MyFLAT::write_att_fh ($fh, %options);
close $fh
or croak "Error writing $filename: $!";
return $fa;
}
sub write_att_fh {
my ($fa, $fh, %options) = @_;
my $epsilon_symbol = '0';
if (defined $options{'epsilon_symbol'}) {
$epsilon_symbol = $options{'epsilon_symbol'};
}
my @states = sort {$a<=>$b} $fa->get_states;
my @starting = $fa->get_starting;
unless (@starting==1 && $starting[0]==0) {
croak "AT&T format must be single starting state 0";
}
foreach my $from (@states) {
foreach my $symbol (sort $fa->alphabet, '') {
my $att_symbol = ($symbol eq '' ? $epsilon_symbol : $symbol);
foreach my $to (sort {$a<=>$b} $fa->successors($from,$symbol)) {
print $fh "$from\t$to\t$att_symbol\t$att_symbol\n";
}
}
}
foreach my $state (sort {$a<=>$b} $fa->get_accepting) {
print $fh $state,"\n";
}
}
#------------------------------------------------------------------------------
sub _DFA_to_Regex_union {
return join('|', grep {defined} @_);
}
sub _DFA_to_Regex_parens {
my ($re) = @_;
return ($re eq '' ? '' : "($re)");
}
sub _DFA_to_Regex_star {
my ($re) = @_;
return (defined $re && $re ne '' ? "($re)*" : '');
}
# FLAT::DFA
sub DFA_to_Regex {
my ($fa) = @_;
my @edges;
my @states = $fa->get_states;
my $starting = $states[-1]+1;
my $accepting = $states[-1]+2;
### $starting
### $accepting
foreach my $to ($fa->get_starting) {
$edges[$starting]->[$to] = '';
}
foreach my $from ($fa->get_accepting) {
$edges[$from]->[$accepting] = '';
}
foreach my $symbol ($fa->alphabet) {
foreach my $from (@states) {
foreach my $to ($fa->successors([$fa->epsilon_closure($from)],
$symbol)) {
$edges[$from]->[$to] = _DFA_to_Regex_union($edges[$from]->[$to],
$symbol);
}
}
}
unshift @states, $starting, $accepting;
### @states
### @edges
while (@states > 2) {
my $s = pop @states;
my $star = _DFA_to_Regex_star($edges[$s]->[$s]);
### $s
### $star
foreach my $pre_state (@states) {
my $pre_re = $edges[$pre_state]->[$s];
### $pre_state
### $pre_re
next unless defined $pre_re;
$pre_re = _DFA_to_Regex_parens($pre_re);
foreach my $post_state (@states) {
my $post_re = $edges[$s]->[$post_state];
### $post_state
### $post_re
next unless defined $post_re;
$post_re = _DFA_to_Regex_parens($post_re);
$edges[$pre_state]->[$post_state]
= _DFA_to_Regex_union($edges[$pre_state]->[$post_state],
"$pre_re $star $post_re");
### now: "$pre_state to $post_state is ".$edges[$pre_state]->[$post_state]
}
}
undef $edges[$s];
}
### stop ...
### @states
### return: $edges[$starting]->[$accepting]
my $ret = $edges[$starting]->[$accepting];
return (! defined $ret ? '#' : $ret);
}
sub FLAT_re_to_xfsm_re {
my ($str) = @_;
$str =~ tr/()0/[]z/;
return $str;
}
#------------------------------------------------------------------------------
sub FLAT_transition_split {
my ($fa, %options) = @_;
my @alphabet = $fa->alphabet;
my $symbols_func = $options{'symbols_func'}
// do {
my $symbols_map = $options{'symbols_map'} // {};
sub {
my ($symbol) = @_;
my $aref = $symbols_map->{$symbol};
return ($aref ? @$aref : ());
}
};
my $new = (ref $fa)->new;
$new->add_states($fa->num_states);
$new->{'name'} = $fa->{'name'};
$new->set_accepting($fa->get_accepting);
$new->set_starting($fa->get_starting);
foreach my $symbol (@alphabet) {
my @new_symbols = $symbols_func->($symbol);
if (! @new_symbols) {
@new_symbols = ($symbol); # unchanged
}
foreach my $state ($fa->get_states) {
foreach my $old_to ($fa->successors($state, $symbol)) {
### split: "$state to $old_to symbol $symbol becomes ".join(' ',@new_symbols)
my $from = $state;
foreach my $i (0 .. $#new_symbols - 1) {
my ($to) = $new->add_states(1);
if ($options{'new_accepting_to'} && $fa->is_accepting($old_to)) {
### new accepting: $to
$new->set_accepting($to);
}
$new->add_transition($from, $to, $new_symbols[$i]);
$from = $to;
}
$new->add_transition($from, $old_to, $new_symbols[-1]);
}
}
}
return $new;
}
#------------------------------------------------------------------------------
sub optional_leading_0s {
my ($f) = @_;
$f = $f->MyFLAT::as_nfa;
my $count = 0;
for (;;) {
my @starting = $f->get_starting;
### $count
### @starting
last if $count == scalar(@starting);
$count = scalar(@starting);
my @new_starting = $f->successors([$f->epsilon_closure(@starting)],'0');
### @new_starting
$f->set_starting(@new_starting);
}
return $f->as_dfa;
}
# func => $func called
# ($new_transmute,$new_symbol) = $func->($transmute,$symbol)
#
# $transmute is a string representing the current transmutation conditions.
#
sub transmute {
my ($fa, %options) = @_;
### transmute() ...
my $direction = $options{'direction'} || 'forward';
my $func = $options{'func'};
my $initial = $options{'initial'};
if (! defined $initial) { $initial = ''; }
my $is_dfa = $fa->isa('FLAT::DFA');
$fa = $fa->MyFLAT::as_nfa->clone;
if ($direction eq 'reverse') { $fa = $fa->reverse; }
my @alphabet = $fa->alphabet;
my $new_fa = (ref $fa)->new;
my @state_and_transmute_to_new_state;
my $find_new_state = sub {
my ($state, $transmute) = @_;
return ($state_and_transmute_to_new_state[$state]->{$transmute} //= do {
my ($new_state) = $new_fa->add_states(1);
if ($fa->is_starting($state) && $transmute eq $initial) {
$new_fa->set_starting($new_state);
}
if ($fa->is_accepting($state)) {
$new_fa->set_accepting($new_state);
}
$new_state;
});
};
my @state_and_transmute_done;
my @pending = map {[$_,$initial]} $fa->get_starting;
while (my $elem = shift @pending) {
my ($state,$transmute) = @$elem;
### elem: "state=$state transmute=$transmute"
if ($state_and_transmute_done[$state]->{$transmute}++) {
### already seen ...
next;
}
my $new_from = $find_new_state->($state,$transmute);
foreach my $symbol (@alphabet) {
my @to = $fa->successors([$fa->epsilon_closure($state)],$symbol) or next;
my ($new_transmute,$new_symbol) = $func->($transmute,$symbol) or next;
### for transition: "symbol=$symbol new_symbol=$new_symbol new_transmute=$new_transmute"
foreach my $to (@to) {
my $new_to = $find_new_state->($to,$new_transmute);
$new_fa->add_transition($new_from, $new_to, $new_symbol);
push @pending, [$to, $new_transmute];
### add new: "new_symbol=$new_symbol $new_from -> $new_to"
}
}
}
if ($direction eq 'reverse') { $new_fa = $new_fa->reverse; }
if ($is_dfa) { $new_fa = $new_fa->as_dfa; }
if (defined(my $name = $options{'name'})) {
$new_fa->MyFLAT::set_name($name);
}
return $new_fa;
}
# add => integer, default 1
# radix => integer>=2, default from alphabet
# direction => "hightolow" (default) or "lowtohigh"
sub digits_multiply {
my ($fa, %options) = @_;
my $direction = $options{'direction'} || 'hightolow';
my $radix = $options{'radix'} || max($fa->alphabet)+1;
my $mul = $options{'mul'} // 1;
my $carry = $options{'add'} // 0;
### $radix
### $mul
### $carry
return $fa->MyFLAT::transmute(initial => 0,
direction => ($direction eq 'lowtohigh'
? 'forward'
: 'reverse'),
func => sub {
my ($carry,$symbol) = @_;
### func: "carry=$carry symbol $symbol"
return _divrem ($symbol*$mul+$carry, $radix);
});
}
#------------------------------------------------------------------------------
1;
__END__
Math-PlanePath-129/devel/fractions-tree.pl 0000644 0001750 0001750 00000003200 11745170634 016272 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see
#include
#include
#include
typedef unsigned long my_unsigned;
typedef long long my_signed;
#define MY_SIGNED_ABS llabs
#define HYPOT_LIMIT 0x7FFFFFFF
char *
to_base (unsigned long long n, int radix)
{
static char str[256];
static char dstr[256];
int pos = sizeof(str)-1;
do {
int digit = n % radix;
n /= radix;
sprintf (dstr, "[%d]", digit);
int dlen = strlen(dstr);
pos -= dlen;
memcpy (str+pos, dstr, dlen);
} while (n);
return str+pos;
}
int
base_len (unsigned long long n, int radix)
{
int len = 0;
while (n) {
n /= radix;
len++;
}
return len;
}
int
main (void)
{
int realpart, level;
for (realpart = 3; realpart < 10; realpart++) {
int norm = realpart*realpart + 1;
int level_limit = 20;
if (realpart == 2) level_limit = 10;
if (realpart == 3) level_limit = 9;
if (realpart == 4) level_limit = 9;
for (level = 0; level < level_limit; level++) {
unsigned long long min_h = ~0ULL;
my_unsigned min_n = 0;
my_signed min_x = 0;
my_signed min_y = 0;
{
my_unsigned lo = pow(norm, level);
my_unsigned hi = lo * norm;
printf ("%2d lo=%lu hi=%lu\n", level, lo, hi);
my_unsigned n;
for (n = lo; n < hi; n++) {
my_signed x = 0;
my_signed y = 0;
my_signed bx = 1;
my_signed by = 0;
my_unsigned digits = n;
while (digits != 0) {
int digit = digits % norm;
digits /= norm;
x += digit * bx;
y += digit * by;
/* (bx,by) = (bx + i*by)*(i-$realpart) */
my_signed new_bx = bx*-realpart - by;
my_signed new_by = bx + by*-realpart;
bx = new_bx;
by = new_by;
}
unsigned long long abs_x = MY_SIGNED_ABS(x);
unsigned long long abs_y = MY_SIGNED_ABS(y);
if (abs_x > HYPOT_LIMIT
|| abs_y > HYPOT_LIMIT) {
continue;
}
unsigned long long h = abs_x*abs_x + abs_y*abs_y;
/* printf ("%2d %lu %Ld,%Ld %LX\n", level, n, x,y, h); */
if (h < min_h) {
min_h = h;
min_n = n;
min_x = abs_x;
min_y = abs_y;
}
}
}
/* printf ("%lX %Ld,%Ld %s\n", min_n, min_x,min_y, */
/* binary(min_h)); */
printf ("%2d", level);
printf (" %s [%d]", to_base(min_h,norm), base_len(min_h,norm));
printf ("\n");
/* printf ("\n"); */
}
}
return 0;
}
Math-PlanePath-129/devel/gcd-rationals-integer.pl 0000644 0001750 0001750 00000003250 11702424166 017527 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2012 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see
#include
#include
#include
typedef unsigned long my_unsigned;
typedef long long my_signed;
#define MY_SIGNED_ABS llabs
#define HYPOT_LIMIT 0x7FFFFFFF
char *
to_base (unsigned long long n, int radix)
{
static char str[256];
static char dstr[256];
int pos = sizeof(str)-1;
do {
int digit = n % radix;
n /= radix;
sprintf (dstr, "[%d]", digit);
int dlen = strlen(dstr);
pos -= dlen;
memcpy (str+pos, dstr, dlen);
} while (n);
return str+pos;
}
int
base_len (unsigned long long n, int radix)
{
int len = 0;
while (n) {
n /= radix;
len++;
}
return len;
}
int
main (void)
{
int realpart, level;
for (realpart = 3; realpart < 10; realpart++) {
int norm = realpart*realpart + 1;
int level_limit = 20;
if (realpart == 2) level_limit = 10;
if (realpart == 3) level_limit = 9;
if (realpart == 4) level_limit = 9;
for (level = 0; level < level_limit; level++) {
unsigned long long min_h = ~0ULL;
my_unsigned min_n = 0;
my_signed min_x = 0;
my_signed min_y = 0;
{
my_unsigned lo = pow(norm, level);
my_unsigned hi = lo * norm;
printf ("%2d lo=%lu hi=%lu\n", level, lo, hi);
my_unsigned n;
for (n = lo; n < hi; n++) {
my_signed x = 0;
my_signed y = 0;
my_signed bx = 1;
my_signed by = 0;
my_unsigned digits = n;
while (digits != 0) {
int digit = digits % norm;
digits /= norm;
x += digit * bx;
y += digit * by;
/* (bx,by) = (bx + i*by)*(i+$realpart) */
my_signed new_bx = bx*realpart - by;
my_signed new_by = bx + by*realpart;
bx = new_bx;
by = new_by;
}
unsigned long long abs_x = MY_SIGNED_ABS(x);
unsigned long long abs_y = MY_SIGNED_ABS(y);
if (abs_x > HYPOT_LIMIT
|| abs_y > HYPOT_LIMIT) {
continue;
}
unsigned long long h = abs_x*abs_x + abs_y*abs_y;
/* printf ("%2d %lu %Ld,%Ld %LX\n", level, n, x,y, h); */
if (h < min_h) {
min_h = h;
min_n = n;
min_x = abs_x;
min_y = abs_y;
}
}
}
/* printf ("%lX %Ld,%Ld %s\n", min_n, min_x,min_y, */
/* binary(min_h)); */
printf ("%2d", level);
printf (" %s [%d]", to_base(min_h,norm), base_len(min_h,norm));
printf ("\n");
/* printf ("\n"); */
}
}
return 0;
}
Math-PlanePath-129/devel/run.pl 0000644 0001750 0001750 00000046314 13773771520 014172 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see n_to_turn_LSR ($n)>
Return the turn at C<$n> in the form
1 left turn
0 straight or 180 reverse or no move at all
-1 right turn
undef no turn exists at $n
The path is taken to go in a line from C<$n-1> to C<$n> and the turn is then
whether C<$n+1> is left, right, or on that line. C<$n> can be fractional.
If there is no X,Y for any of the three points considered then the return is
C.
=item C<$lsr = $path-Eturn_LSR_minimum>
=item C<$lsr = $path-Eturn_LSR_maximum>
Return the minimum or maximum LSR value returned by
C<$path-En_to_turn_LSR($n)> for integer N values in the path. If there
are no turns at all then return C.
=back
Math-PlanePath-129/devel/squarecurve.pl 0000644 0001750 0001750 00000016704 13010525150 015707 0 ustar gg gg # Copyright 2016 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see
HERE
my $equilateral = sqrt(3);
my $xoffset = $width * .2;
my $yoffset = $height * .5;
my $xsize = $width * .3;
my $yscale = .3;
foreach my $level (4 .. 4) {
my $linewidth = 1/$level;
my $n_hi = 7**$level - 1;
my $n_e = 7**($level-1)*6-1;
my ($ex, $ey) = $path->n_to_xy($n_e);
$ey *= $equilateral;
my $angle = - atan2($ey,$ex);
my $hypot = hypot ($ex,$ey);
my $xfactor = $xsize / $hypot;
my $yfactor = $height * .8 * $yscale / $hypot;
my $s = sin($angle);
my $c = cos($angle);
my $points = '';
foreach my $n (0 .. $n_hi) {
my ($x, $y) = $path->n_to_xy($n);
$y *= $equilateral;
# my ($r, $theta) = cartesian_to_cylindrical($x, $y, 0);
# $r += $angle;
# ($x, $y) = cylindrical_to_cartesian($r, $theta, 0);
($x, $y) = ($x * $c - $y * $s,
$x * $s + $y * $c);
$x = $x * $xfactor + $xoffset;
$y = $y * $yfactor + $yoffset;
$points .= "$x,$y ";
}
print "";
}
print <<'HERE';
HERE
Math-PlanePath-129/devel/junk/ 0002755 0001750 0001750 00000000000 14001441522 013747 5 ustar gg gg Math-PlanePath-129/devel/junk/FibonacciSquareSpiral.pm 0000644 0001750 0001750 00000010430 12145611505 020521 0 ustar gg gg # Copyright 2012, 2013 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see for the behaviour common to all path
classes.
=over 4
=item C<$path = Math::PlanePath::FibonacciSquareSpiral-Enew ()>
Create and return a new path object.
=back
=head1 SEE ALSO
L,
L
=head1 HOME PAGE
http://user42.tuxfamily.org/math-planepath/index.html
=head1 LICENSE
Copyright 2012, 2013 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see but
#
# Nlevel = ((3L+2)*4^level - 5) / 3
# Nlevel = 4^level - 1 + ((3L+2)*4^level - 5) / 3 - 4^level + 1
# Nlevel = 4^level - 1 + ((3L+2)*4^level - 5 - 3*4^level + 3) / 3
# Nlevel = 4^level - 1 + ((3L-1)*4^level - 2) / 3
#
#
#
# For C = L and reckoning the first diagonal side N=0 to N=2L
# as level 0, a level extends out to a triangle
#
# Nlevel = ((6L+4)*4^level - 4) / 3
# Xlevel = (L+2)*2^level - 1
#
# For example level 2 in the default L=1 goes to N=((6*1+4)*4^2-4)/3=52 and
# Xlevel=(1+2)*2^2-1=11. Or in the L=4 sample above level 1 is
# N=((6*4+4)*4^1-4)/3=36 and Xlevel=(4+2)*2^1-1=11.
#
# The power-of-4 in Nlevel is per the plain C, with factor
# 2L+1 for the points making the diagonal stair. The "/3" arises from the
# extra points between replications. They become a power-of-4 series
#
# Nextras = 1+4+4^2+...+4^(level-1) = (4^level-1)/3
#
# For example level 1 is Nextras=(4^1-1)/3=1, being point N=6 in the default
# L=1. Or for level 2 Nextras=(4^2-1)/3=5 at N=6 and N=19,26,33,46.
{
# between two curves
# (13*4^k - 7)/3
# = 2 15 67 275 1107 4435 17747 70995 283987 1135955
# not in OEIS
# area=2 initial diamond is level=0
require Math::Geometry::Planar;
my $path = Math::PlanePath::SierpinskiCurve->new (arms => 2);
my @values;
foreach my $level (0 .. 8) {
my $n_hi = 4**($level+1) - 1;
my @points;
for (my $n = 0; $n <= $n_hi; $n+=2) {
my ($x,$y) = $path->n_to_xy($n);
push @points, [$x,$y];
}
for (my $n = $n_hi; $n >= 0; $n-=2) {
my ($x,$y) = $path->n_to_xy($n);
push @points, [$x,$y];
}
### @points
my $polygon = Math::Geometry::Planar->new;
$polygon->points(\@points);
my $area = $polygon->area;
my $length = $polygon->perimeter;
my $formula = two_area_by_formula($level);
print "$level $length area $area $formula\n";
push @values, $area;
}
shift @values;
require Math::OEIS::Grep;
Math::OEIS::Grep->search(array => \@values);
exit 0;
sub two_area_by_formula {
my ($k) = @_;
return (13*4**$k - 7) / 3;
$k++;
return (27*4**($k-1) - 18*2**($k-1) -14 * 4**($k-1) + 18 * 2**($k-1) - 4) / 3 - 1;
return 9*4**($k-1) - 6*2**($k-1) + (-14 * 4**($k-1) + 18 * 2**($k-1) - 4) / 3 - 1;
return 9*4**($k-1) - 6*2**($k-1) - (14 * 4**($k-1) - 18 * 2**($k-1) + 4) / 3 - 1;
return 9*2**(2*$k-2) - 2*3*2**($k-1) + 1 - (14 * 4**($k-1) - 18 * 2**($k-1) + 4) / 3 - 2;
return (3*2**($k-1) - 1)**2 - (14 * 4**($k-1) - 18 * 2**($k-1) + 4) / 3 - 2;
return (3*2**($k-1) - 1)**2 - 4*(7 * 4**($k-1) - 9 * 2**($k-1) + 2) / 6 - 2;
return (3*2**($k-1) - 2 + 1)**2 - 4*((7 * 4**($k-1) - 9 * 2**($k-1) + 2) / 6) - 2;
return (3*2**($k-1) - 2 + 1)**2 - 4*area_by_formula($k-1) - 2;
}
}
{
# area under the curve
# (7*4^k - 9*2^k + 2)/6
#
require Math::Geometry::Planar;
my $path = Math::PlanePath::SierpinskiCurve->new;
my @values;
foreach my $level (1 .. 10) {
my ($n_lo, $n_hi) = $path->level_to_n_range($level);
my @points;
foreach my $n ($n_lo .. $n_hi) {
my ($x,$y) = $path->n_to_xy($n);
push @points, [$x,$y];
}
my $polygon = Math::Geometry::Planar->new;
$polygon->points(\@points);
my $area = $polygon->area;
my $length = $polygon->perimeter;
my $formula = area_by_formula($level);
print "$level $length area $area $formula\n";
push @values, $area;
}
shift @values;
require Math::OEIS::Grep;
Math::OEIS::Grep->search(array => \@values);
exit 0;
sub area_by_formula {
my ($k) = @_;
if ($k == 0) { return 0; }
return (7 * 4**$k - 9 * 2**$k + 2) / 6;
return (28 * 4**($k-1) - 18 * 2**($k-1) + 2) / 6;
{
return (
4**($k-1) * 6
- 4**($k-1) + 1
+ 9*4**($k-1) - 9*2**($k-1)
)/3;
}
{
return (
(4**($k-1) * 6 - 4**($k-1) + 1)/3
+ 3*4**($k-1) - 3*2**($k-1));
}
{
return (4**($k-1) * 2
- (4**($k-1) - 1)/3
+ 3*2* (4**($k-1) - 2**($k-1))/(4-2));
}
{
# i=k-2
# = 2*4^(k-1) + 3*2 * sum 4^i * 2^(k-2-i) - (4^(k-1) - 1)/3
# i=0
# = 2*4^(k-1) + 3*2 * (4^(k-1) - 2^(k-1))/(4-2) - (4^(k-2) - 1)/3
if ($k == 1) { return 2; }
my $total = 4**($k-1) * 2;
$total -= (4**($k-1) - 1)/3;
$total += 3*2* (4**($k-1) - 2**($k-1))/(4-2);
return $total;
}
{
# i=k-2
# = 2*4^(k-1) + 3*2^2 * sum 4^i * 2^(k-3-i) - (4^(k-1) - 1)/3
# i=0
# = 2*4^(k-1) + 3*2^2 * (4^(k-1) - 2^(k-1))/(4-2) - (4^(k-2) - 1)/3
if ($k == 1) { return 2; }
my $total = 4**($k-1) * 2;
$total -= (4**($k-1) - 1)/3;
foreach my $i (0 .. $k-2) {
$total += 4**$i * (3 * 2**($k-1-$i));
}
return $total;
}
{
# A(2) = 4*A(1) + (3*2^(1) - 1)
# = (3*2^(k-1) - 1) 0 + k-1 = k-1
# + 4 *(3*2^(k-2) - 1) 1 + k-2 = k-1
# + 4^2*(3*2^(k-3) - 1) 2 + k-2 = k-1
# + ...
# + 4^(k-3)*(3*2^(2) - 1) Ytop(2) k-3 + 2 = k-1
# + 4^(k-2)*A(1)
# i=k-2
# = 2*4^(k-1) + sum 4^i * (3*2^(k-1-i) - 1)
# i=0
if ($k == 1) { return 2; }
my $total = 4**($k-1) * 2;
foreach my $i (0 .. $k-2) {
$total += 4**$i * (3 * 2**($k-1-$i) - 1);
}
return $total;
}
{
# A(k) = 4*A(k-1) + Ytop(k) + 1 k >= 2
# A(1) = 2
# A(0) = 0
# Ytop(k) = 3*2^(k-1) - 2
# A(k) = 4*A(k-1) + 3*2^(k-1) - 1
#
if ($k == 1) { return 2; }
return 4*area_by_formula($k-1) + 3 * 2**($k-1) - 1;
}
}
}
{
# Y coordinate sequence
require Math::NumSeq::PlanePathCoord;
my $seq = Math::NumSeq::PlanePathCoord->new (planepath => 'SierpinskiCurve',
coordinate_type => 'Sum');
my @values;
for (1 .. 500) {
my ($i,$value) = $seq->next;
push @values, $value-1;
}
unduplicate(\@values);
print "values: ", join(',', @values), "\n";
require Math::OEIS::Grep;
Math::OEIS::Grep->search(array => \@values, verbose => 1);
exit 0;
sub unduplicate {
my ($aref) = @_;
my $i = 1;
while ($i < $#$aref) {
if ($aref->[$i] == $aref->[$i-1]) {
splice @$aref, $i, 1;
} else {
$i++;
}
}
}
}
{
# dSumAbs
require Math::NumSeq::PlanePathDelta;
my $seq = Math::NumSeq::PlanePathDelta->new (planepath => 'SierpinskiCurveStair,arms=6',
delta_type => 'dSumAbs');
for (1 .. 300) {
my ($i,$value) = $seq->next;
print "$value,";
if ($i % 6 == 5) {
print "\n";
}
}
exit 0;
}
{
# A156595 Mephisto Waltz first diffs xor as turns
require Tk;
require Tk::CanvasLogo;
require Math::NumSeq::MephistoWaltz;
my $top = MainWindow->new;
my $width = 1200;
my $height = 800;
my $logo = $top->CanvasLogo(-width => $width, -height => $height)->pack;
my $turtle = $logo->NewTurtle('foo');
$turtle->LOGO_PU();
$turtle->LOGO_FD(- $height/2*.9);
$turtle->LOGO_PD();
my $step = 5;
$turtle->LOGO_FD($step);
my $seq = Math::NumSeq::MephistoWaltz->new;
my ($i,$prev) = $seq->next;
for (;;) {
my ($i,$value) = $seq->next;
my $turn = $value ^ $prev;
$prev = $value;
last if $i > 10000;
if ($turn) {
$turtle->LOGO_FD($step);
if ($i & 1) {
$turtle->LOGO_RT(120);
} else {
$turtle->LOGO_LT(120);
}
} else {
$turtle->LOGO_FD($step);
}
$logo->createArc($turtle->{x}+2, $turtle->{y}+2,
$turtle->{x}-2, $turtle->{y}-2);
}
Tk::MainLoop();
exit;
}
{
# dX,dY
require Math::PlanePath::SierpinskiCurve;
my $path = Math::PlanePath::SierpinskiCurve->new;
foreach my $n (0 .. 32) {
# my $n = $n + 1/256;
my ($x,$y) = $path->n_to_xy($n);
my ($x2,$y2) = $path->n_to_xy($n+1);
my $sx = $x2-$x;
my $sy = $y2-$y;
my $sdir = dxdy_to_dir8($sx,$sy);
my ($dx,$dy) = $path->_WORKING_BUT_HAIRY__n_to_dxdy($n);
my $ddir = dxdy_to_dir8($dx,$dy);
my $diff = ($dx != $sx || $dy != $sy ? ' ***' : '');
print "$n $x,$y $sx,$sy\[$sdir] $dx,$dy\[$ddir]$diff\n";
}
# return 0..7
sub dxdy_to_dir8 {
my ($dx, $dy) = @_;
return atan2($dy,$dx) / atan2(1,1);
if ($dx == 1) {
if ($dy == 1) { return 1; }
if ($dy == 0) { return 0; }
if ($dy == -1) { return 7; }
}
if ($dx == 0) {
if ($dy == 1) { return 2; }
if ($dy == -1) { return 6; }
}
if ($dx == -1) {
if ($dy == 1) { return 3; }
if ($dy == 0) { return 4; }
if ($dy == -1) { return 5; }
}
die 'oops';
}
exit 0;
}
{
# Mephisto Waltz 1/12 slice of plane
require Tk;
require Tk::CanvasLogo;
require Math::NumSeq::MephistoWaltz;
my $top = MainWindow->new;
my $width = 1000;
my $height = 800;
my $logo = $top->CanvasLogo(-width => $width, -height => $height)->pack;
my $turtle = $logo->NewTurtle('foo');
$turtle->LOGO_RT(45);
$turtle->LOGO_PU();
$turtle->LOGO_FD(- $height*sqrt(2)/2*.9);
$turtle->LOGO_PD();
$turtle->LOGO_RT(135);
$turtle->LOGO_LT(30);
my $step = 5;
$turtle->LOGO_FD($step);
my $seq = Math::NumSeq::MephistoWaltz->new;
for (;;) {
my ($i,$value) = $seq->next;
last if $i > 10000;
if ($value) {
$turtle->LOGO_RT(60);
$turtle->LOGO_FD($step);
} else {
$turtle->LOGO_LT(60);
$turtle->LOGO_FD($step);
}
}
Tk::MainLoop();
exit;
}
{
require Tk;
require Tk::CanvasLogo;
require Math::NumSeq::PlanePathTurn;
my $top = MainWindow->new();
my $logo = $top->CanvasLogo->pack;
my $turtle = $logo->NewTurtle('foo');
my $seq = Math::NumSeq::PlanePathTurn->new
(planepath => 'KochCurve',
turn_type => 'Left');
$turtle->LOGO_RT(45);
$turtle->LOGO_FD(10);
for (;;) {
my ($i,$value) = $seq->next;
last if $i > 64;
if ($value) {
$turtle->LOGO_RT(45);
$turtle->LOGO_FD(10);
$turtle->LOGO_RT(45);
$turtle->LOGO_FD(10);
} else {
$turtle->LOGO_LT(90);
$turtle->LOGO_FD(10);
$turtle->LOGO_LT(90);
$turtle->LOGO_FD(10);
}
}
Tk::MainLoop();
exit;
}
{
# filled fraction
require Math::PlanePath::SierpinskiCurve;
require Number::Fraction;
my $path = Math::PlanePath::SierpinskiCurve->new;
foreach my $level (1 .. 20) {
my $Ntop = 4**$level / 2 - 1;
my ($x,$y) = $path->n_to_xy($Ntop);
my $Xtop = 3*2**($level-1) - 1;
$x == $Xtop or die "x=$x Xtop=$Xtop";
my $frac = $Ntop / ($x*($x-1)/2);
print " $level $frac\n";
}
my $nf = Number::Fraction->new(4,9);
my $limit = $nf->to_num;
print " limit $nf = $limit\n";
exit 0;
}
{
# filled fraction
require Math::PlanePath::SierpinskiCurveStair;
require Number::Fraction;
foreach my $L (1 .. 5) {
print "L=$L\n";
my $path = Math::PlanePath::SierpinskiCurveStair->new (diagonal_length=>$L);
foreach my $level (1 .. 10) {
my $Nlevel = ((6*$L+4)*4**$level - 4) / 3;
my ($x,$y) = $path->n_to_xy($Nlevel);
my $Xlevel = ($L+2)*2**$level - 1;
$x == $Xlevel or die "x=$x Xlevel=$Xlevel";
my $frac = $Nlevel / ($x*($x-1)/2);
print " $level $frac\n";
}
my $nf = Number::Fraction->new((12*$L+8),(3*$L**2+12*$L+12));
my $limit = $nf->to_num;
print " limit $nf = $limit\n";
}
exit 0;
}
{
my $path = Math::PlanePath::SierpinskiCurve->new;
my @rows = ((' ' x 79) x 64);
foreach my $n (0 .. 3 * 3**4) {
my ($x, $y) = $path->n_to_xy ($n);
$x += 32;
substr ($rows[$y], $x,1, '*');
}
local $,="\n";
print reverse @rows;
exit 0;
}
{
my @rows = ((' ' x 64) x 32);
foreach my $p (0 .. 31) {
foreach my $q (0 .. 31) {
next if ($p & $q);
my $x = $p-$q;
my $y = $p+$q;
next if ($y >= @rows);
$x += 32;
substr ($rows[$y], $x,1, '*');
}
}
local $,="\n";
print reverse @rows;
exit 0;
}
Math-PlanePath-129/devel/hilbert-sides.pl 0000644 0001750 0001750 00000016673 13776741263 016135 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2015, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see new;
foreach my $k (0 .. 10) {
my ($n_lo,$n_hi) = $path->level_to_n_range($k);
my $x_max = 0;
my $n_max = 0;
foreach my $n ($n_lo .. $n_hi) {
my ($x,$y) = $path->n_to_xy($n);
if ($x > $x_max) {
$x_max = $x;
$n_max = $n;
}
}
my $n5 = cnv($n_max,10,5);
my $x5 = cnv($x_max,10,5);
print "k=$k $n_max $n5 $x_max $x5\n";
}
exit 0;
}
{
my $level = 6;
my $path = Math::PlanePath::QuintetReplicate->new;
my ($n_lo, $n_hi) = $path->level_to_n_range($level);
print "\\fill foreach \\p in {";
foreach my $n ($n_lo .. $n_hi) {
my ($x,$y) = $path->n_to_xy($n);
print "($x,$y),";
}
print "} ";
print "{ \\p rectangle +(1,1) };\n";
exit 0;
}
{
# min/max for level
require Math::BaseCnv;
require Math::PlanePath::QuintetReplicate;
my $path = Math::PlanePath::QuintetReplicate->new;
my $prev_min = 1;
my $prev_max = 1;
my @mins;
for (my $level = 0; $level < 20; $level++) {
my $n_start = 5**$level;
my $n_end = 5**($level+1) - 1;
my $min_hypot = 128*$n_end*$n_end;
my $min_x = 0;
my $min_y = 0;
my $min_pos = '';
my $max_hypot = 0;
my $max_x = 0;
my $max_y = 0;
my $max_pos = '';
print "level $level n=$n_start .. $n_end\n";
foreach my $n ($n_start .. $n_end) {
my ($x,$y) = $path->n_to_xy($n);
my $h = $x*$x + $y*$y;
# my $h = abs($x) + abs($y);
if ($h < $min_hypot) {
my $n5 = Math::BaseCnv::cnv($n,10,5) . '[5]';
$min_hypot = $h;
$min_pos = "$x,$y $n $n5";
}
if ($h > $max_hypot) {
my $n5 = Math::BaseCnv::cnv($n,10,5) . '[5]';
$max_hypot = $h;
$max_pos = "$x,$y $n $n5";
}
}
# print " min $min_hypot at $min_x,$min_y\n";
# print " max $max_hypot at $max_x,$max_y\n";
# {
# my $factor = $min_hypot / $prev_min;
# my $base5 = Math::BaseCnv::cnv($min_hypot,10,5) . '[5]';
# print " min $min_hypot $base5 at $min_pos factor $factor\n";
# }
{
my $factor = $max_hypot / $prev_max;
my $base5 = Math::BaseCnv::cnv($max_hypot,10,5) . '[5]';
print " max $max_hypot $base5 at $max_pos factor $factor\n";
}
$prev_min = $min_hypot;
$prev_max = $max_hypot;
push @mins, $min_hypot;
}
print join(',',@mins),"\n";
exit 0;
}
{
# Dir4 maximum
require Math::PlanePath::QuintetReplicate;
require Math::NumSeq::PlanePathDelta;
require Math::BigInt;
require Math::BaseCnv;
my $path = Math::PlanePath::QuintetReplicate->new;
my $seq = Math::NumSeq::PlanePathDelta->new (planepath_object => $path,
delta_type => 'Dir4');
my $dir4_max = 0;
foreach my $n (0 .. 600000) {
# my $n = Math::BigInt->new(2)**$level - 1;
my $dir4 = $seq->ith($n);
if ($dir4 > $dir4_max) {
$dir4_max = $dir4;
my ($dx,$dy) = $path->n_to_dxdy($n);
my $n5 = Math::BaseCnv::cnv($n,10,5);
printf "%7s %2b,\n %2b %8.6f\n", $n5, abs($dx),abs($dy), $dir4;
}
}
exit 0;
}
Math-PlanePath-129/devel/iterator.pl 0000644 0001750 0001750 00000017047 11604443335 015207 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2010, 2011 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see next()>
=item C<($n, $x, $y) = $path-Enext_nxy()>
=item C<($n, $x, $y) = $path-Epeek()>
=item C<$path-Erewind()>
=item C<$path-Eseek_to_n($n)>
=item C<$n = $path-Etell_n($n)>
=item C<($n,$x,$y) = $path-Etell_nxy($n)>
=back
=cut
use Math::PlanePath;
{
package Math::PlanePath;
no warnings 'redefine';
sub new {
my $class = shift;
my $self = bless { @_ }, $class;
$self->rewind;
return $self;
}
sub rewind {
my ($self) = @_;
$self->seek_to_n($self->n_start);
}
sub seek_to_n {
my ($self, $n) = @_;
$self->{'n'} = $n;
}
sub tell_n {
my ($self, $n) = @_;
return $self->{'n'};
}
sub next_nxy {
my ($self) = @_;
my $n = $self->{'n'}++;
return ($n, $self->n_to_xy($n));
}
sub peek_nxy {
my ($self) = @_;
my $n = $self->{'n'};
return ($n, $self->n_to_xy($n));
}
}
{
use Math::PlanePath::ZOrderCurve;
package Math::PlanePath::ZOrderCurve;
# sub seek_to_n {
# my ($self, $n) = @_;
# ($self->{'x'},$self->{'y'}) = $self->n_to_xy($self->{'n'} = $n);
# $self->{'bx'} = $x;
# $self->{'by'} = $y;
# $self->{'a'} = [ \$self->{'x'}, \$self->{'y'} ];
# $self->{'i'} = 1;
# ### ZOrderCurve seek_to_n(): $self
# }
# sub next_nxy {
# my ($self) = @_;
# $self->{'a'}->[($self->{'i'} ^= 1)]++;
# return (++$self->{'n'}, $self->{'x'}, $self->{'y'});
# }
# sub peek_nxy {
# my ($self) = @_;
# return ($self->{'n'} + 1,
# $self->{'x'} + !$self->{'i'},
# $self->{'y'} + $self->{'i'});
# }
}
{
use Math::PlanePath::Rows;
package Math::PlanePath::Rows;
sub seek_to_n {
my ($self, $n) = @_;
$self->{'n'} = --$n;
my $width = $self->{'width'};
$self->{'px'} = ($n % $width) - 1;
$self->{'py'} = int ($n / $width);
### seek_to_n: $self
}
sub next_nxy {
my ($self) = @_;
my $x = ++$self->{'px'};
if ($x >= $self->{'width'}) {
$x = $self->{'px'} = 0;
$self->{'py'}++;
}
return (++$self->{'n'}, $x, $self->{'py'});
}
sub peek_nxy {
my ($self) = @_;
if ((my $x = $self->{'px'} + 1) < $self->{'width'}) {
return ($self->{'n'}+1, $x, $self->{'py'});
} else {
return ($self->{'n'}+1, 0, $self->{'py'}+1);
}
}
}
{
use Math::PlanePath::Diagonals;
package Math::PlanePath::Diagonals;
# N = (1/2 d^2 + 1/2 d + 1)
# = (1/2*$d**2 + 1/2*$d + 1)
# = ((0.5*$d + 0.5)*$d + 1)
# d = -1/2 + sqrt(2 * $n + -7/4)
sub seek_to_n {
my ($self, $n) = @_;
$self->{'n'} = $n;
my $d = $self->{'d'} = int (-.5 + sqrt(2*$n - 1.75));
$n -= $d*($d+1)/2 + 1;
$self->{'px'} = $n - 1;
$self->{'py'} = $d - $n + 1;
### Diagonals seek_to_n(): $self
}
sub next_nxy {
my ($self) = @_;
my $x = ++$self->{'px'};
my $y = --$self->{'py'};
if ($y < 0) {
$x = $self->{'px'} = 0;
$y = $self->{'py'} = ++$self->{'d'};
}
return ($self->{'n'}++, $x, $y);
}
sub peek_nxy {
my ($self) = @_;
if (my $y = $self->{'py'}) {
return ($self->{'n'}, $self->{'px'}+1, $y-1);
} else {
return ($self->{'n'}, 0, $self->{'d'}+1);
}
}
}
{
use Math::PlanePath::SquareSpiral;
package Math::PlanePath::SquareSpiral;
sub next_nxy {
my ($self) = @_;
### next(): $self
my $x = ($self->{'x'} += $self->{'dx'});
my $y = ($self->{'y'} += $self->{'dy'});
unless ($self->{'side'}--) {
### turn
($self->{'dx'},$self->{'dy'}) = (-$self->{'dy'},$self->{'dx'}); # left
$self->{'side'} = (($self->{'d'} += ($self->{'grow'} ^= 1)) - 1)
+ ($self->{'dx'} && $self->{'wider'});
### grow applied: $self->{'grow'}
### d now: $self->{'d'}
### side now: $self->{'side'}
### dx,dy now: "$self->{'dx'},$self->{'dy'}"
}
### return: 'n='.$self->{'n'}.' '.($self->{'x'} + $self->{'dx'}).','.($self->{'y'} + $self->{'dy'})
return ($self->{'n'}++, $x, $y);
}
sub peek_nxy {
my ($self) = @_;
# ### peek(): $self
return ($self->{'n'},
$self->{'x'} + $self->{'dx'},
$self->{'y'} + $self->{'dy'});
}
# N = (1/2 d^2 + 1/2 d + 1)
# = (1/2*$d**2 + 1/2*$d + 1)
# = ((0.5*$d + 0.5)*$d + 1)
# d = -1/2 + sqrt(2 * $n + -7/4)
sub seek_to_n {
my ($self, $n) = @_;
### SquareSpiral seek_to_n: $n
$self->{'n'} = $n;
my $d = $self->{'d'} = int (1/2 + sqrt(1 * $n + -3/4));
$n -= (($d - 1)*$d + 1);
### $d
### half d: int($d/2)
### remainder: $n
my $dx;
my $dy;
my $y = - int($d/2);
my $x = $y + $n;
if ($self->{'grow'} = ($n < $d)) {
### horizontal
$dx = 1;
$dy = 0;
} else {
### vertical
$n -= $d;
$dx = 0;
$dy = 1;
($x, $y) = ($y + $d,
$x - $d);
}
if ($d & 1) {
} else {
### negate for even d from: "$x,$y"
$dx = - $dx;
$dy = - $dy;
$x = -$x;
$y = -$y;
}
$self->{'side'} = $d - $n;
$self->{'dx'} = $dx;
$self->{'dy'} = $dy;
$self->{'x'} = $x - $dx;
$self->{'y'} = $y - $dy;
# if ($n == 3) {
# $self->{'side'} = 2;
# $self->{'grow'} = 1;
# $self->{'d'} = 2;
# $self->{'dx'} = -1;
# $self->{'dy'} = 0;
# $self->{'x'} = 2;
# $self->{'y'} = 1;
# return;
# }
#
# $self->{'n'} = $n;
# $self->{'side'} = 1;
# $self->{'grow'} = 0;
# $self->{'d'} = 0;
# $self->{'dx'} = 1;
# $self->{'dy'} = 0;
# $self->{'x'} = -1;
# $self->{'y'} = 0;
### SquareSpiral seek_to_n(): $self
}
}
use Smart::Comments;
foreach my $class ('Math::PlanePath::SquareSpiral',
'Math::PlanePath::Diagonals',
'Math::PlanePath::Rows',
) {
my $path = $class->new (width => 5);
foreach my $n_start_offset (0 .. 30) {
my $want_n = $path->n_start;
if ($n_start_offset) {
$want_n += $n_start_offset;
$path->seek_to_n ($want_n);
}
### $class
### $n_start_offset
foreach my $i (0 .. 100) {
my ($peek_n, $peek_x, $peek_y) = $path->peek;
my ($got_n, $got_x, $got_y) = $path->next;
my ($want_x, $want_y) = $path->n_to_xy($want_n);
if ($want_n != $got_n) {
### $want_n
### $got_n
die "x";
}
if ($want_x != $got_x) {
### $want_n
### $want_x
### $got_x
die "x";
}
if ($want_y != $got_y) {
### $want_n
### $want_y
### $got_y
die "x";
}
if ($peek_n != $want_n) {
### $peek_n
### $want_n
die "x";
}
if ($peek_x != $want_x) {
### $want_n
### $peek_x
### $want_x
die "x";
}
if ($peek_y != $want_y) {
### $want_n
### $peek_y
### $want_y
die "x";
}
$want_n++;
}
}
}
Math-PlanePath-129/devel/misc.pl 0000644 0001750 0001750 00000002164 12400452234 014274 0 ustar gg gg #!/usr/bin/perl -w
# Copyright 2011, 2012, 2013, 2014 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see
#include
#include
#include
typedef unsigned long my_unsigned;
typedef long long my_signed;
#define MY_SIGNED_ABS llabs
#define HYPOT_LIMIT 0x7FFFFFFF
char *
binary (unsigned long long n)
{
static char str[sizeof(n)*8+1];
int pos = sizeof(str)-1;
do {
str[pos] = (n&1)+'0';
n >>= 1;
pos--;
} while (n);
return str+pos+1;
}
int
main (void)
{
int level;
for (level = 0; level < 8*sizeof(my_unsigned)-1; level++) {
unsigned long long min_h = ~0ULL;
my_unsigned min_n = 0;
my_signed min_x = 0;
my_signed min_y = 0;
{
my_unsigned lo = (my_unsigned)1 << level;
my_unsigned hi = (my_unsigned)1 << (level+1);
/* printf ("%2d lo=%lu hi=%lu\n", level, lo, hi); */
my_unsigned n;
for (n = lo; n < hi; n++) {
my_signed x = 0;
my_signed y = 0;
my_signed bx = 1;
my_signed by = 0;
my_unsigned bits;
for (bits = n; bits != 0; bits >>= 1) {
if (bits & 1) {
x += bx;
y += by;
/* (bx,by) * i, rotate +90 */
my_signed new_bx = -by;
my_signed new_by = bx;
bx = new_bx;
by = new_by;
}
/* (bx,by) * (i+1) */
my_signed new_bx = bx-by;
my_signed new_by = bx+by;
bx = new_bx;
by = new_by;
}
unsigned long long abs_x = MY_SIGNED_ABS(x);
unsigned long long abs_y = MY_SIGNED_ABS(y);
if (abs_x > HYPOT_LIMIT
|| abs_y > HYPOT_LIMIT) {
continue;
}
unsigned long long h = abs_x*abs_x + abs_y*abs_y;
/* printf ("%2d %lu %Ld,%Ld %LX\n", level, n, x,y, h); */
if (h < min_h) {
min_h = h;
min_n = n;
min_x = abs_x;
min_y = abs_y;
}
}
}
/* printf ("%lX %Ld,%Ld %s\n", min_n, min_x,min_y, */
/* binary(min_h)); */
printf ("%2d", level);
char *binary_str = binary(min_h);
int binary_len = strlen(binary_str);
printf (" %s [%d]", binary(min_h), binary_len);
printf ("\n");
/* printf ("\n"); */
}
return 0;
}
Math-PlanePath-129/lib/ 0002755 0001750 0001750 00000000000 14001441521 012446 5 ustar gg gg Math-PlanePath-129/lib/Math/ 0002755 0001750 0001750 00000000000 14001441522 013340 5 ustar gg gg Math-PlanePath-129/lib/Math/NumSeq/ 0002755 0001750 0001750 00000000000 14001441522 014550 5 ustar gg gg Math-PlanePath-129/lib/Math/NumSeq/PlanePathDelta.pm 0000644 0001750 0001750 00000456504 13774433072 017771 0 ustar gg gg # Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Kevin Ryde
# This file is part of Math-PlanePath.
#
# Math-PlanePath is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-PlanePath is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-PlanePath. If not, see module in the form of a NumSeq sequence.
The C choices are
"dX" change in X coordinate
"dY" change in Y coordinate
"AbsdX" abs(dX)
"AbsdY" abs(dY)
"dSum" change in X+Y, equals dX+dY
"dSumAbs" change in abs(X)+abs(Y)
"dDiffXY" change in X-Y, equals dX-dY
"dDiffYX" change in Y-X, equals dY-dX
"dAbsDiff" change in abs(X-Y)
"dRadius" change in Radius sqrt(X^2+Y^2)
"dRSquared" change in RSquared X^2+Y^2
"Dir4" direction 0=East, 1=North, 2=West, 3=South
"TDir6" triangular 0=E, 1=NE, 2=NW, 3=W, 4=SW, 5=SE
In each case the value at i is per C<$path-En_to_dxdy($i)>, being the
change from N=i to N=i+1, or from N=i to N=i+arms for paths with multiple
"arms" (thus following the arm). i values start from the usual
C<$path-En_start()>.
=head2 AbsdX,AbsdY
If a path always steps NSEW by 1 then AbsdX and AbsdY behave as a boolean
indicating horizontal or vertical step,
NSEW steps by 1 gives
AbsdX = 0 vertical AbsdY = 0 horizontal
1 horizontal 1 vertical
If a path includes diagonal steps by 1 then those diagonals are a non-zero
delta, so the indication is then
NSEW and diagonals steps by 1 gives
AbsdX = 0 vertical AbsdY = 0 horizontal
1 non-vertical 1 non-horizontal
ie. horiz or diag ie. vert or diag
=head2 dSum
"dSum" is the change in X+Y and is also simply dX+dY since
dSum = (Xnext+Ynext) - (X+Y)
= (Xnext-X) + (Ynext-Y)
= dX + dY
The sum X+Y counts anti-diagonals, as described in
L. dSum is therefore a move between
diagonals, or 0 if a step stays within the same diagonal.
\
\ ^ dSum > 0 dSum = step dist to North-East
\/
/\
dSum < 0 v \
\
=head2 dSumAbs
"dSumAbs" is the change in the abs(X)+abs(Y) sum,
dSumAbs = (abs(Xnext)+abs(Ynext)) - (abs(X)+abs(Y))
As described in L, SumAbs is a
"Manhattan" or "taxi-cab" distance from the origin, or equivalently a move
between diamond-shaped rings.
For example C follows a diamond shape ring around and so has
dSumAbs=0 until stepping out to each next diamond with dSumAbs=1.
A path might make a big X,Y jump which is only a small change in SumAbs.
For example C in its default step=2 from the end of one row to
the start of the next has dSumAbs=2.
=head2 dDiffXY and dDiffYX
"dDiffXY" is the change in DiffXY = X-Y, which is also simply dX-dY since
dDiffXY = (Xnext-Ynext) - (X-Y)
= (Xnext-X) - (Ynext-Y)
= dX - dY
The difference X-Y counts diagonals downwards to the south-east as described
in L. dDiffXY is therefore
movement between those diagonals, or 0 if a step stays within the same
diagonal.
dDiffXY < 0 /
\ / dDiffXY = step dist to South-East
\/
/\
/ v
/ dDiffXY > 0
"dDiffYX" is the negative of dDiffXY. Whether X-Y or Y-X is desired depends
on which way you want to measure diagonals, or which way around to have the
sign for the changes. dDiffYX is based on Y-X and so counts diagonals
upwards to the North-West.
=head2 dAbsDiff
"dAbsDiff" is the change in AbsDiff = abs(X-Y). AbsDiff can be interpreted
geometrically as distance from the leading diagonal, as described in
L. dAbsDiff is therefore movement
closer to or further away from that leading diagonal, measuring
perpendicular to it.
/ X=Y line
/
/ ^
/ \
/ * dAbsDiff move towards or away from X=Y line
|/ \
--o-- v
/|
/
When an X,Y jumps from one side of the diagonal to the other dAbsDiff is
still the change in distance from the diagonal. So for example if X,Y is
followed by the mirror point Y,X then dAbsDiff=0. That sort of thing
happens for example in the C path when jumping from the end of
one run to the start of the next. In the C case it's a move just
1 further away from the X=Y centre line even though it's a big jump in
overall distance.
=head2 dRadius, dRSquared
"dRadius" and "dRSquared" are the change in the Radius and RSquared as
described in L.
dRadius = next_Radius - Radius
dRSquared = next_RSquared - RSquared
dRadius can be interpreted geometrically as movement towards (negative
values) or away from (positive values) the origin, ignoring direction.
Notice that dRadius is not sqrt(dRSquared), since sqrt(n^2-t^2) != n-t
unless n or t is zero. Here would mean a step either going to or coming
from the origin 0,0.
=head2 Dir4
"Dir4" is the curve step direction as an angle in the range 0 E= Dir4
E 4. The cardinal directions E,N,W,S are 0,1,2,3. Angles in between
are a fraction.
Dir4 = atan2(dY,dX) scaled as range 0 <= Dir4 < 4
1.5 1 0.5
\ | /
\|/
2 ----o---- 0
/|\
/ | \
2.5 3 3.5
If a row such as Y=-1,XE0 just below the X axis is visited then the Dir4
approaches 4, without ever reaching it. The C<$seq-Evalue_maximum()> is
4 in this case, as a supremum.
=head2 TDir6
"TDir6" is the curve step direction 0 E= TDir6 E 6 taken in the
triangular style of L. So dX=1,dY=1 is
taken to be 60 degrees which is TDir6=1.
2 1.5 1 TDir6
\ | /
\|/
3 ---o--- 0
/|\
/ | \
4 4.5 5
Angles in between the six cardinal directions are fractions. North is 1.5
and South is 4.5.
The direction angle is calculated as if dY was scaled by a factor sqrt(3) to
make the lattice into equilateral triangles, or equivalently as a circle
stretched vertically by sqrt(3) to become an ellipse.
TDir6 = atan2(dY*sqrt(3), dX) in range 0 <= TDir6 < 6
Notice that angles on the axes dX=0 or dY=0 are not changed by the sqrt(3)
factor. So TDir6 has ENWS 0, 1.5, 3, 4.5 which is steps of 1.5. Verticals
North and South normally don't occur in the triangular lattice paths which
go by unit steps, but TDir6 can be applied on any path.
The sqrt(3) factor increases angles in the middle of the quadrants. For
example dX=1,dY=1 becomes TDir6=1 whereas a plain angle would be only
45/360*6=0.75 in the same 0 to 6 scale. The sqrt(3) is a continuous
scaling, so a plain angle and a TDir6 are a one-to-one mapping. As the
direction progresses through the quadrant TDir6 grows first faster and then
slower than the plain angle.
=cut
# TDir6 = atan2(dY*sqrt(3), dX)
# Dir6 = atan2(dY, dX)
# TDir6 = Dir6 * atan2(dY*sqrt(3), dX)/atan2(dY, dX)
=pod
=head1 FUNCTIONS
See L for behaviour common to all sequence classes.
=over 4
=item C<$seq = Math::NumSeq::PlanePathDelta-Enew (key=Evalue,...)>
Create and return a new sequence object. The options are
planepath string, name of a PlanePath module
planepath_object PlanePath object
delta_type string, as described above
C can be either the module part such as "SquareSpiral" or a
full class name "Math::PlanePath::SquareSpiral".
=item C<$value = $seq-Eith($i)>
Return the change at N=$i in the PlanePath.
=item C<$i = $seq-Ei_start()>
Return the first index C<$i> in the sequence. This is the position
C<$seq-Erewind()> returns to.
This is C<$path-En_start()> from the PlanePath.
=back
=head1 BUGS
Some path sequences don't have C and are not available through
L entry due to the path C not matching
the OEIS "offset". Paths with an C parameter have suitable
adjustments applied, but those without are omitted from the
L mechanism presently.
=head1 SEE ALSO
L,
L,
L,
L
L
=head1 HOME PAGE
L
=head1 LICENSE
Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Kevin Ryde
This file is part of Math-PlanePath.
Math-PlanePath is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
Math-PlanePath is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
Math-PlanePath. If not, see as a sequence. The
default is the X axis, or the C parameter (a string) can choose
among
"X_axis" X axis (positive part)
"Y_axis" Y axis (positive part)
"X_neg" X negative axis
"Y_neg" Y negative axis
"Diagonal" leading diagonal X=i, Y=i
"Diagonal_NW" north-west diagonal X=-i, Y=i
"Diagonal_SW" south-west diagonal X=-i, Y=-i
"Diagonal_SE" south-east diagonal X=i, Y=-i
"Depth_start" first N at depth=i
"Depth_end" last N at depth=i
For example the C X axis starts i=0 with values 1, 2, 11, 28,
53, 86, etc.
"X_neg", "Y_neg", "Diagonal_NW", etc, on paths which don't traverse negative
X or Y have just a single value from X=0,Y=0.
The behaviour on paths which visit only some of the points on the respective
axis is unspecified as yet, as is behaviour on paths with repeat points,
such as the C.
=head1 FUNCTIONS
See L for behaviour common to all sequence classes.
=over 4
=item C<$seq = Math::NumSeq::PlanePathN-Enew (key=Evalue,...)>
Create and return a new sequence object. The options are
planepath string, name of a PlanePath module
planepath_object PlanePath object
line_type string, as described above
C