################################################################################
#
#  kPerl Logics/Mathematics Library Group
#  Object Library for Numerical Range
#
#  copyright (c)
#    Fritz Lipmann Institute Jena, Genome Analysis Group, 2005
#    Institute of Molecular Biotechnology Jena, Dept. Genome Analysis, 2001-2002, 2004
#  author
#    Karol Szafranski, karol.szafranski@leibniz-fli.de
#
################################################################################
#
#  DESCRIPTION
#
# - purpose
#   range object that is represented by lower and upper boundary. Boundaries
#   may be undefined, meaning that the range extends to infinity on the
#   respective side.
#
# - switches are always set library-wide, i.e. all active objects are affected.
#   The way to set switches is just an assignment to the library switch hash,
#   like:
#     $Math::Range::LibGlob{switch}{-debug} = 1;
#
# - value range for boundaries
#   is of float type. If the class is used with integer type boundary values
#   this means that they are defined in a computational sense. E.g. a range
#   1..1 has zero length. The all-day thinking often differs, attributing
#   length one to such a case.
#
# - individual description of functions at the beginning of the code blocks
#
################################################################################
#
#  OBJECT OPERATORS
#
# - data type conversion
#   bool         always TRUE
#   @{}          ( $lower, $upper )
#                this is implicitly implemented cause it is the physical structure
#   %{}          ( '-1'=>$lower, '1'=>$upper )
#
# - calculation
#   x            do crossing between range $a and range $b (method cross())
#
#
#  OBJECT METHODS  for external access
#
# - housekeeping
#   new          return:
#                - from library/object with 1 arg:
#                  - class::$arg1
#                  - $arg1 = [$arg1a,$arg1b]
#                - from library/object with 2 args: $arg1..$arg2
#   new_parsed   new with plain argument like 'lower..upper'
#                This method is much lika a reversal of string()
#   clone        clone object
#   is_sharp     boolean for sharply defined borders
#   lower        set/read lower boundary of range
#   left         alias to lower(), deprecated
#   upper        set/read upper boundary of range
#   right        alias to upper(), deprecated
#   length       length from lower() to upper()
#   string       sprint in compact form
#
# - calculations
#   covers       test if a point is lying inside the range
#   swallow      "swallow" another range
#   overlaps     test if a ranges overlap
#   includes     test if a range (base object) includes the argument range
#   cross        do crossing between range $a and range $b
#
#
#  OBJECT DATA STRUCTURE
#
# - array: ($lower,$upper)
#   see method ini for valid syntaxes
#
################################################################################
#
#  FUNCTIONS, DATA
#
#   @ISA
#   overload
#   %LibGlob
#
# - housekeeping
#   $LibGlob{switch}
#   &new  see MainLib::DefaultObjArray.pm
#   &ini
#   &new_parsed
#   &is_sharp
#   &lower
#   &left
#   &upper
#   &right
#   &length
#   &string
#
# - calculations
#   &covers
#   &swallow
#   &overlaps
#   &includes
#   &cross
#
################################################################################
#
#  DEBUG, CHANGES, ADDITIONS
#
# - If the constructor is used to check for validity of initialization arguments
#   it would be nice to wrap the constructor call into an eval. Otherwise, the
#   constructor will throw errors that are out of context of what's actually
#   been tried. Cmp. bug archive 20040910*.
#   See Math::Geomet2dPoint->new_rotate() for a solution.
#
# - look also for notes in the header of each function block
#
################################################################################

package Math::Range;

# includes
use strict; #use warnings;  # OK 20040810
use Math::kCalc qw(&Min &Max);
use MainLib::DefaultObjArray;
# we cannot import &MainLib::Data::DataPrint - it would cause a name clash
#   with method DataPrint()

# inheritance
our @ISA;
push @ISA, qw(MainLib::DefaultObjArray);

# overloading
use overload
'""'   => # make the stringify operator work like for non-overloaded object references
          sub { \@{$_[0]} },
'bool' => sub { 1; },
#'0+'   => "Numify",
#'@{}'  => # no explicit overload required
'%{}'  => sub { return { '-1'=>$_[0][0], '1'=>$_[0][1] }; },
#'x'    => sub { print "Math::Range::x. arguments:\n";
#                map { printf "  %s\n", $_ } @_ },
;

# package-wide constants and variables
our (%LibGlob);


################################################################################
# housekeeping
################################################################################


# shouldn't we use %LibGlob instead?
$LibGlob{switch} = {};


# parametric initialization
#
# INTERFACE
# - argument 1+: either:
#                - with 1 arg:
#                  - class::$arg1
#                  - $arg1 = [$arg1a,$arg1b]
#                - with 2 args: $arg1..$arg2
#
# - library options:
#   -debug      STD
#
# - return val: - object reference
#               - undef if an error occurs
#
# DESCRIPTION
# - this function will be called by method new()
# - either range argument may be undef => 'border not defined'
#
sub ini {
  my ($this,@DataArg) = @_;
  my $class = ref($this);
  my $debug = $LibGlob{switch}{-debug};

  # enter submitted argument(s)
  if (@DataArg) {

    # convert refs to array:
    # this object, ARRAY reference
    if (@DataArg == 1) {
      if (ref($DataArg[0]) eq 'ARRAY' and int(@{$DataArg[0]})==2) {
        @DataArg = @{$DataArg[0]};
      } elsif (ref($DataArg[0]) eq $class) {
        @DataArg = @{$DataArg[0]};
      } else {
        printf STDERR "%s. ERROR: unable to interpret data argument %s\n", (caller(0))[3], $DataArg[0]||"''";
        return undef;
      }
    }

    # assign from array of points
    # check consistency of boundaries, needed in $this->cross()
    if (@DataArg == 2) {
      $debug and printf STDERR "%s. assigning from arguments: (%s..%s)\n", (caller(0))[3], @DataArg;
      if (! int (grep { ! defined $_ } @DataArg) and $DataArg[0] > $DataArg[1]) {
        printf STDERR "%s. ERROR: conflicting arguments: (%s..%s)\n", (caller(0))[3], @DataArg;
        return undef;
      } else {
        @$this = @DataArg;
      }
    }

    # arg number error
    else {
      printf STDERR "%s. ERROR: too many data arguments %d\n", (caller(0))[3], int @DataArg;
      return undef;
    }
  }

  # no args
  else {
    printf STDERR "%s. ERROR: cannot do initialization without args\n", (caller(0))[3];
    return undef;
  }

  # exit SUB
  return $this;
}


# parse object from string argument
#
# INTERFACE
# - argument 1: range string
# - return val: object reference
#
sub new_parsed {
  my ($this, $ArgRange) = @_;
  my (@range);

  # refine argument string
  $ArgRange =~ s/\s+//g;

  # default for minimal argument, only lower bound given
  if ($ArgRange !~ m/\.\./) {
    $ArgRange .= '..';
  }

  # format
  @range = (split /\.\./,$ArgRange)[0..1];
  @range = map { ($_ eq '') ? undef : $_ } @range;

  # exit SUB
  return $this->new(\@range);
}


# clone object
sub clone { bless [ @{$_[0]} ] }


# return flag for sharpness of border definitions
sub is_sharp {
  return (! grep{ !defined($_) } @{$_[0]});
}


# set/return lower border of range
sub lower {
  my ($this,$val) = @_;
  if (int(@_) > 1) { $this->[0] = $val }
  return $this->[0];
}

sub left { $_[0]->lower(@_) }

# set/return upper border of range
sub upper {
  my ($this,$val) = @_;
  if (int(@_) > 1) { $this->[1] = $val }
  return $this->[1];
}

sub right { $_[0]->upper(@_) }


# length of range
#
# DESCRIPTION
# - see notes on "value range for boundaries" in the header of the module.
#   Boundary values are defined in a computational sense.
#
sub length {
  my $this=shift;
  if ($this->is_sharp()) { return $this->[1]-$this->[0] }
  else { return undef }
}


# string representation object
#
# INTERFACE
# - return val: stringified object
# - options:
#   -ref        parenthesize values and precede by object label
#
sub string {
  my ($this,%opt) = @_;
  my $s = sprintf ('%s..%s', map{ defined($_)?"$_":'undef' } @$this);
  if($opt{-ref}){ $s = sprintf('%s(%s)',ref($this),$s) }
  return $s;
}


################################################################################
# calculations
################################################################################


# test if a point is lying inside the range
#
# INTERFACE
# - argument 1: point to test (float)
# - return val: boolean
#
sub covers {
  my ($this,$pt) = @_;
  return ( (!defined($this->[0]) or $pt>=$this->[0]) and
           (!defined($this->[1]) or $pt<=$this->[1]) );
}


# "swallow" another range
#
# INTERFACE
# - argument 1: reference to 2nd range
#
sub swallow {
  my ($this,@DataArg) = @_;
  my $pRangeArg = $this->new(@DataArg) or return undef;
  $this->lower( (grep{ !defined($_) }$this->lower(),$pRangeArg->lower()),
    &Min($this->lower(),$pRangeArg->lower()) );
  $this->upper( (grep{ !defined($_) }$this->upper(),$pRangeArg->upper()),
    &Max($this->upper(),$pRangeArg->upper()) );
}


# test if range overlaps another range
#
# INTERFACE
# - argument 1: reference to 2nd range
# - return val: test result (boolean)
#
sub overlaps {
  my ($this,@DataArg) = @_;
  my $pRangeArg = $this->new(@DataArg) or return undef;
  if (!defined($pRangeArg->lower())) {
    $pRangeArg->lower(&Min($pRangeArg->upper()-1,$this->lower()));
  }
  if (!defined($pRangeArg->upper())) {
    $pRangeArg->upper(&Max($pRangeArg->lower()+1,$this->upper()));
  }

  # test on non-overlap
  my $bNonOlap=0;
  $bNonOlap ||= int (defined($this->lower()) and $this->lower()>$pRangeArg->upper());
  $bNonOlap ||= int (defined($this->upper()) and $this->upper()<$pRangeArg->lower());

  return !$bNonOlap;
}


# test if range includes another range
#
# INTERFACE
# - argument 1: reference to 2nd range
# - return val: test result (boolean)
#
sub includes {
  my ($this,@DataArg) = @_;
  my $pRangeArg = $this->new(@DataArg) or return undef;

  # determine borders of crossed range
  my $bIncl=1;
  $bIncl &&= int (!defined($this->lower()) or
    (defined($pRangeArg->lower()) and $this->lower()<=$pRangeArg->lower()) );
  $bIncl &&= int (!defined($this->upper()) or
    (defined($pRangeArg->upper()) and $this->upper()>=$pRangeArg->upper()) );

  return $bIncl;
}


# do crossing between range and 2nd range
#
# INTERFACE
# - argument 1: reference to 2nd range
# - return val: cross range, undef for no crossing
#
sub cross {
  my ($this,@DataArg) = @_;
  my $pRangeArg = $this->new(@DataArg) or return undef;

  # determine borders of crossed range
  my @bound;
  $bound[0] = (sort { defined($b)<=>defined($a) or $b<=>$a; }
    ($$this[0], $$pRangeArg[0]))[0];
  $bound[1] = (sort { defined($b)<=>defined($a) or $a<=>$b; }
    ($$this[1], $$pRangeArg[1]))[0];

  # return crossed range
  return $this->new(@bound);
}


1;
# $Id: Range.pm,v 1.18 2018/06/05 18:02:56 szafrans Exp $
