File Coverage

blib/lib/Math/PlanePath/DekkingCurve.pm

Criterion	Covered	Total	%
statement	137	154	88.9
branch	25	44	56.8
condition	28	45	62.2
subroutine	26	26	100.0
pod	10	10	100.0
total	226	279	81.0

# Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 .


package Math::PlanePath::DekkingCurve;
use 5.004;
use strict;
#use List::Util 'max';
*max = \&Math::PlanePath::_max;

use vars '$VERSION', '@ISA';
$VERSION = 127;
use Math::PlanePath;
use Math::PlanePath::Base::NSEW;
@ISA = ('Math::PlanePath::Base::NSEW',
        'Math::PlanePath');
*_divrem = \&Math::PlanePath::_divrem;
*_divrem_mutate = \&Math::PlanePath::_divrem_mutate;

use Math::PlanePath::Base::Generic
  'is_infinite',
  'round_nearest';
use Math::PlanePath::Base::Digits
  'round_up_pow',
  'round_down_pow',
  'digit_split_lowtohigh',
  'digit_join_lowtohigh';

# uncomment this to run the ### lines
# use Smart::Comments;


use constant n_start => 0;
use constant class_x_negative => 1;
use constant class_y_negative => 1;

use constant parameter_info_array => [ { name      => 'arms',
                                         share_key => 'arms_4',
                                         display   => 'Arms',
                                         type      => 'integer',
                                         minimum   => 1,
                                         maximum   => 4,
                                         default   => 1,
                                         width     => 1,
                                         description => 'Arms',
                                       } ];


#------------------------------------------------------------------------------

sub x_negative {
  my ($self) = @_;
  return $self->{'arms'} > 1;
}
{
  my @x_negative_at_n = (undef, undef, 5, 2, 2);
  sub x_negative_at_n {
    my ($self) = @_;
    return $x_negative_at_n[$self->{'arms'}];
  }
}

sub y_negative {
  my ($self) = @_;
  return $self->{'arms'} > 2;
}
{
  my @y_negative_at_n = (undef, undef, undef, 8, 3);
  sub y_negative_at_n {
    my ($self) = @_;
    return $y_negative_at_n[$self->{'arms'}];
  }
}

#------------------------------------------------------------------------------

use Math::PlanePath::DekkingCentres;
use vars '@_next_state','@_digit_to_x','@_digit_to_y','@_yx_to_digit';
BEGIN {
  *_next_state = \@Math::PlanePath::DekkingCentres::_next_state;
  *_digit_to_x = \@Math::PlanePath::DekkingCentres::_digit_to_x;
  *_digit_to_y = \@Math::PlanePath::DekkingCentres::_digit_to_y;
  *_yx_to_digit = \@Math::PlanePath::DekkingCentres::_yx_to_digit;
}

sub new {
  my $self = shift->SUPER::new(@_);
  $self->{'arms'} ||= 1;
  return $self;
}

# tables generated by tools/dekking-curve-table.pl
#
my @edge_dx = (0,0,0,1,1, 0,0,1,1,0, 0,0,0,1,0, 0,0,1,0,1, 0,1,0,1,1,
               1,1,1,1,1, 1,1,1,0,1, 1,1,0,1,0, 0,0,1,0,0, 0,1,1,0,0,
               1,1,1,0,0, 1,1,0,0,1, 1,1,1,0,1, 1,1,0,1,0, 1,0,1,0,0,
               0,0,0,0,0, 0,0,0,1,0, 0,0,1,0,1, 1,1,0,1,1, 1,0,0,1,1,
               1,1,1,1,1, 1,0,0,0,0, 1,1,1,1,1, 0,0,0,0,1, 1,0,0,1,1,
               1,1,1,0,0, 1,1,1,1,1, 0,0,0,1,1, 0,0,1,0,1, 0,1,0,1,1,
               0,0,0,0,0, 0,1,1,1,1, 0,0,0,0,0, 1,1,1,1,0, 0,1,1,0,0,
               0,0,0,1,1, 0,0,0,0,0, 1,1,1,0,0, 1,1,0,1,0, 1,0,1,0,0);
my @edge_dy = (0,0,0,0,0, 0,0,0,1,0, 0,0,1,0,1, 1,1,0,1,1, 1,0,0,1,1,
               0,0,0,1,1, 0,0,1,1,0, 0,0,0,1,0, 0,0,1,0,1, 0,1,0,1,1,
               1,1,1,1,1, 1,1,1,0,1, 1,1,0,1,0, 0,0,1,0,0, 0,1,1,0,0,
               1,1,1,0,0, 1,1,0,0,1, 1,1,1,0,1, 1,1,0,1,0, 1,0,1,0,0,
               0,0,0,1,1, 0,0,0,0,0, 1,1,1,0,0, 1,1,0,1,0, 1,0,1,0,0,
               1,1,1,1,1, 1,0,0,0,0, 1,1,1,1,1, 0,0,0,0,1, 1,0,0,1,1,
               1,1,1,0,0, 1,1,1,1,1, 0,0,0,1,1, 0,0,1,0,1, 0,1,0,1,1,
               0,0,0,0,0, 0,1,1,1,1, 0,0,0,0,0, 1,1,1,1,0, 0,1,1,0,0);

sub n_to_xy {
  my ($self, $n) = @_;
  ### DekkingCurve n_to_xy(): $n

  if ($n < 0) { return; }
  if (is_infinite($n)) { return ($n,$n); }

  my $int = int($n);
  $n -= $int;  # fraction part

  my $arms = $self->{'arms'};
  my $arm = _divrem_mutate ($int, $arms);
  if ($arm) { $int += 1; }
  my @digits = digit_split_lowtohigh($int,25);
  my $state = 0;
  my @x;
  my @y;
  foreach my $i (reverse 0 .. $#digits) {
    $state += $digits[$i];
    $x[$i] = $_digit_to_x[$state];
    $y[$i] = $_digit_to_y[$state];
    $state = $_next_state[$state];
  }

  ### @x
  ### @y
  ### $state
  ### dx: $_digit_to_x[$state+24] - $_digit_to_x[$state]
  ### dy: $_digit_to_y[$state+24] - $_digit_to_y[$state]

  my $zero = $int * 0;
  my $x = ($n * (($_digit_to_x[$state+24] - $_digit_to_x[$state])/4)
           + digit_join_lowtohigh(\@x, 5, $zero)
           + $edge_dx[$state]);
  my $y = ($n * (($_digit_to_y[$state+24] - $_digit_to_y[$state])/4)
           + digit_join_lowtohigh(\@y, 5, $zero)
           + $edge_dy[$state]);

  if ($arm < 2) {
    if ($arm < 1) { return ($x,$y); }  # arm==0
    return (-$y,$x);                   # arm==1  rotate +90
  }
  if ($arm < 3) { return (-$x,-$y); }  # arm==2
  return ($y,-$x);                     # arm==3  rotate -90
}

sub xy_to_n {
  my ($self, $x, $y) = @_;
  ### DekkingCurve xy_to_n(): "$x, $y"

  $x = round_nearest ($x);
  $y = round_nearest ($y);
  if (is_infinite($x)) {
    return $x;
  }
  if (is_infinite($y)) {
    return $y;
  }

  my $arms = $self->{'arms'};
  if (($arms < 2 && $x < 0) || ($arms < 3 && $y < 0)) {
    ### X or Y negative, no N value ...
    return undef;
  }

  foreach my $arm (0 .. $arms-1) {
    foreach my $xoffset (0,-1) {
      foreach my $yoffset (0,-1) {

        my @x = digit_split_lowtohigh($x+$xoffset,5);
        my @y = digit_split_lowtohigh($y+$yoffset,5);
        my $state = 0;
        my @n;
        foreach my $i (reverse 0 .. max($#x,$#y)) {
          my $digit = $n[$i] = $_yx_to_digit[$state + 5*($y[$i]||0) + ($x[$i]||0)];
          $state = $_next_state[$state+$digit];
        }
        my $zero = $x*0*$y;
        my $n = digit_join_lowtohigh(\@n, 25, $zero);
        $n = $n*$arms;
        if (my ($nx,$ny) = $self->n_to_xy($n)) {
          if ($nx == $x && $ny == $y) {
            return $n + ($arm ? $arm-$arms : $arm);
          }
        }
      }
    }
    ($x,$y) = ($y,-$x); # rotate -90
    ### rotate to: "$x, $y"
  }
  return undef;
}

# not exact
sub rect_to_n_range {
  my ($self, $x1,$y1, $x2,$y2) = @_;
  ### DekkingCurve rect_to_n_range(): "$x1,$y1, $x2,$y2"

  $x1 = round_nearest ($x1);
  $x2 = round_nearest ($x2);
  $y1 = round_nearest ($y1);
  $y2 = round_nearest ($y2);

  if ($x1 > $x2) { ($x1,$x2) = ($x2,$x1); }
  if ($y1 > $y2) { ($y1,$y2) = ($y2,$y1); }

  my $arms = $self->{'arms'};
  if (($arms < 2 && $x2 < 0) || ($arms < 3 && $y2 < 0)) {
    ### rectangle all negative, no N values ...
    return (1, 0);
  }

  my ($pow) = round_down_pow (max(abs($x1),abs($y1),$x2,$y2) + 1, 5);
  ### $pow
  return (0, 25*$pow*$pow*$arms - 1);
}

#------------------------------------------------------------------------------

sub level_to_n_range {
  my ($self, $level) = @_;
  return (0,  25**$level * $self->{'arms'});
}
sub n_to_level {
  my ($self, $n) = @_;
  ### n_to_level(): $n
  if ($n < 0) { return undef; }
  if (is_infinite($n)) { return $n; }
  $n = round_nearest($n);
  $n += $self->{'arms'}-1;  # division rounding up
  _divrem_mutate ($n, $self->{'arms'});
  my ($pow, $exp) = round_up_pow ($n, 25);
  return $exp;
}

#------------------------------------------------------------------------------
# Not taking into account multiple arms ...

# Return true if X axis segment $x to $x+1 is traversed
sub _UNDOCUMENTED__xseg_is_traversed {
  my ($self, $x) = @_;
  if ($x < 0 || is_infinite($x)) { return 0; }
  if ($x == 0) { return 1; }
  my $digit = _divrem_mutate($x, 5);
  if ($digit) {
    return ($digit == 1);
  }
  # find lowest non-zero
  while ($x && ! ($digit = _divrem_mutate($x, 5))) { }
  return ($digit == 1 || $digit == 2);
}

# Return true if Y axis segment $y to $y+1 is traversed
sub _UNDOCUMENTED__yseg_is_traversed {
  my ($self, $y) = @_;
  if ($y < 0 || is_infinite($y)) { return 0; }
  my $digit = _divrem_mutate($y, 5);
  if ($digit != 4) {
    return ($digit == 3);
  }
  # find lowest non-4
  while ($y && ($digit = _divrem_mutate($y, 5)) == 4) { }
  return ($digit == 2 || $digit == 3);
}

#------------------------------------------------------------------------------
1;
__END__