#  Copyright (c) 1997-2024
#  Ewgenij Gawrilow, Michael Joswig, and the polymake team
#  Technische Universität Berlin, Germany
#  https://polymake.org
#
#  This program 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 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program 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.
#-------------------------------------------------------------------------------

use strict;
use namespaces;
use warnings qw(FATAL void syntax misc);

package Polymake;

sub min($$) {  $_[0]<$_[1] ? $_[0] : $_[1]  }
sub max($$) {  $_[0]>$_[1] ? $_[0] : $_[1]  }
sub assign_min($$) { !defined($_[0]) || $_[0] > $_[1] and $_[0]=$_[1] }
sub assign_max($$) { !defined($_[0]) || $_[0] < $_[1] and $_[0]=$_[1] }
sub assign_min_max($$$) { !defined($_[0]) ? ($_[0]=$_[1]=$_[2]) : $_[0] > $_[2] ? ($_[0]=$_[2]) : $_[1] < $_[2] && ($_[1]=$_[2]) }

sub list_min {
   my $list = shift;
   my $ret;
   assign_min($ret, $_) for @$list;
   $ret;
}

sub list_max {
   my $list = shift;
   my $ret;
   assign_max($ret,$_) for @$list;
   $ret;
}
####################################################################################
sub list_index {     # \@list, numeric scalar or ref => position or -1
   my ($list, $item) = @_;
   my $i = 0;
   foreach my $elem (@$list) {
      return $i if $item == $elem;
      ++$i;
   }
   -1
}
####################################################################################
sub string_list_index {     # \@list, string => position or -1
   my ($list, $item) = @_;
   my $i = 0;
   foreach my $elem (@$list) {
      return $i if $item eq $elem;
      ++$i;
   }
   -1
}
####################################################################################
sub delete_from_list {  # \@list, numeric scalar or ref => true if deleted
   my ($list, $item) = @_;
   for (my $i = $#$list; $i >= 0; --$i) {
      if ($list->[$i] == $item) {
         splice @$list, $i, 1;
         return true;
      }
   }
   false
}
####################################################################################
sub delete_string_from_list {   # \@list, string scalar => true if deleted
   my ($list, $item) = @_;
   for (my $i = $#$list; $i >= 0; --$i) {
      if ($list->[$i] eq $item) {
         splice @$list, $i, 1;
         return true;
      }
   }
   false
}
####################################################################################
sub contains {          # \@list, numeric scalar or ref => bool
   my ($list, $item) = @_;
   foreach my $elem (@$list) {
      $elem == $item and return true;
   }
   return false;
}
####################################################################################
sub contains_string {           # \@list, scalar => bool
   my ($list, $item) = @_;
   foreach my $elem (@$list) {
      $elem eq $item and return true;
   }
   return false;
}
####################################################################################
# "string1", "string2" [, "delimiter" ]
# => -1 (s1==prefix(s2)) / 0 (s1==s2) / 1 (prefix(s1)==s2) / 2 (otherwise)
sub prefix_cmp($$;$) {
   my ($s1, $s2, $delim)=@_;
   my $l=min(length($s1), length($s2));
   if (substr($s1,0,$l) eq substr($s2,0,$l)) {
      my $cmpl=length($s1) <=> length($s2);
      if (defined($delim) && $cmpl) {
         return 2 if substr($cmpl>0 ? $s1 : $s2, $l, length($delim)) ne $delim;
      }
      $cmpl
   } else {
      2
   }
}
####################################################################################
sub uniq {
   my %seen;
   grep { !($seen{$_}++) } @_;
}
####################################################################################
sub sorted_uniq {
   my $i=-1;
   grep { ++$i == 0 || $_[$i-1] ne $_ } @_;
}
####################################################################################
sub num_sorted_uniq {
   my $i=-1;
   grep { ++$i == 0 || $_[$i-1] != $_ } @_;
}
####################################################################################
# \list1, \list2 => boolean
sub equal_lists {
   my ($l1, $l2) = @_;
   my $end = @$l1;
   return false if $end != @$l2;
   for (my $i = 0; $i < $end; ++$i) {
       return false if $l1->[$i] != $l2->[$i];
   }
   true
}

# \list1, start_index1, \list2, start_index2 => length of the equal sequence starting at given positions
sub equal_sublists {
   my ($l1, $i1, $l2, $i2) = @_;
   my $end = min(@$l1 - $i1, @$l2 - $i2) + $i1;
   for (; $i1 < $end; ++$i1, ++$i2) {
      last if $l1->[$i1] != $l2->[$i2];
   }
   $i1 - $_[1]
}

sub equal_string_sublists {
   my ($l1, $i1, $l2, $i2) = @_;
   my $end = min(@$l1 - $i1, @$l2 - $i2) + $i1;
   for (; $i1 < $end; ++$i1, ++$i2) {
      last if $l1->[$i1] ne $l2->[$i2];
   }
   $i1 - $_[1]
}

# \list1, \list2 => length of the common prefix
sub equal_list_prefixes {
   equal_sublists($_[0], 0, $_[1], 0);
}

sub equal_string_list_prefixes {
   equal_string_sublists($_[0], 0, $_[1], 0);
}

# \list1, \list2, ... => length of the common prefix of list1 and concatenated other lists
sub equal_list_prefixes2 {
   my $l1 = shift;
   my $ret = 0;
   foreach my $l2 (@_) {
      my $match = equal_sublists($l1, $ret, $l2, 0);
      $ret += $match;
      last if $ret == @$l1 || $match < @$l2;
   }
   $ret
}
####################################################################################
sub equal_nested_hashes {
   my ($h1, $h2) = @_;
   if (keys(%$h1) == keys(%$h2)) {
      while (my ($k, $v) = each %$h1) {
         unless (exists $h2->{$k} and equal_nested_elements($v, $h2->{$k})) {
            keys %$h1;
            return false;
         }
      }
      true;
   }
}

sub equal_nested_lists {
   my ($l1, $l2) = @_;
   my $end = @$l1;
   return false if $end != @$l2;
   for (my $i = 0; $i < $end; ++$i) {
       return false unless equal_nested_elements($l1->[$i], $l2->[$i]);
   }
   true
}

sub equal_nested_elements {
   my ($e1, $e2) = @_;
   if (is_object($e1)) {
      is_object($e2) && eval { $e1 == $e2 }
   } elsif (is_array($e1)) {
      is_array($e2) && equal_nested_lists($e1, $e2)
   } elsif (is_hash($e1)) {
      is_hash($e2) && equal_nested_hashes($e1, $e2)
   } elsif (is_boolean($e1)) {
      is_boolean($e2) && $e1 == $e2
   } elsif (is_numeric($e1)) {
      is_numeric($e2) && $e1 == $e2
   } elsif (defined($e1)) {
      defined($e2) && !is_object($e2) && $e1 eq $e2
   } else {
      !defined($e2)
   }
}
####################################################################################
sub deep_copy_hash {
   my ($src) = @_;
   my %result;
   while (my ($k, $v) = each %$src) {
      $result{$k} = deep_copy_element($v);
   }
   \%result
}

sub deep_copy_list {
   my ($src) = @_;
   [ map { deep_copy_element($_) } @$src ]
}

sub deep_copy_element {
   my ($src) = @_;
   if (is_hash($src)) {
      deep_copy_hash($src)
   } elsif (is_array($src)) {
      deep_copy_list($src)
   } else {
      $src
   }
}
####################################################################################
# HASH, "KEY", ... => value or undef; avoid creating intermediate empty hashes
sub descend_nested_hash {
   my $h = shift;
   foreach my $k (@_) {
      defined($h = $h->{$k}) or last;
   }
   $h
}
####################################################################################
sub enforce_nl($) {
   $_[0] .= "\n" if substr($_[0], -1) ne "\n";
   $_[0]
}
####################################################################################
declare $dbg_prefix="polymake: ";
declare $err_prefix="$dbg_prefix ERROR: ";
declare $warn_prefix="$dbg_prefix WARNING: ";

binmode STDIN, ":utf8";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
STDERR->autoflush;
declare $console=\*STDERR;

sub dbg_print {
   print STDERR $dbg_prefix, @_, substr($_[-1],-1) ne "\n" && "\n";
}
sub err_print {
   print $console $err_prefix, @_, substr($_[-1],-1) ne "\n" && "\n";
}
sub warn_print {
   print $console $warn_prefix, @_, substr($_[-1],-1) ne "\n" && "\n";
}
####################################################################################

sub croak {
   my ($pkg, $file, $line, $sub);
   my $i=0;
   if (is_object($INC[0]) && ref($INC[0]) eq "Polymake::Core::Application" && defined($INC[0]->compile_scope)) {
      do {
         ($pkg, $file, $line, $sub)=caller(++$i);
      } while ($pkg =~ /^Polymake(?:$|::Core::|::Overload\b|::Struct\b)/ || $sub =~ /::self$/ );

   } else {
      my ($app_file, $app_line);
      while ($pkg !~ /^Polymake::User\b/  or  $i==1 && $sub =~ /\bAUTOLOAD$/) {
         ($pkg, $file, $line, $sub)=caller(++$i);
         if (!defined $pkg || $pkg eq "main") {
            # not clear where we came from
            local $Carp::CarpLevel=1;
            &Carp::confess;
         }
         if ($file =~ m{/apps/$id_re/(?:rules|perllib|(testsuite))/}o) {
            if ($1 && $app_line) {
               ($file, $line)=($app_file, $app_line); last;
            } else {
               ($app_file, $app_line)=($file, $line);
            }
         }
         if ($file =~ m{/scripts/run_testcases(?:_oo)?$}) {
            undef $pkg;
         }
      }

      if ($file =~ m{^\(eval|/User.pm$} || $sub eq "(eval)") {
         # compatibility mode or command line script
         die @_, "\n";
      }
   }
   local $_=join("", @_);
   s/(?=\.?$)/ at $file line $line./s;
   die enforce_nl($_);
}

sub beautify_error {
   unless ($DebugLevel) {
      use re 'eval';
      $@ =~ s/ at \(eval \d+\)(?:\[.*?:\d+\])? line 1(\.)?/$1/g;
      $@ =~ s/, <\$?$id_re> line \d+\.//go;
      $@ =~ s/^(?:Compilation failed in require |BEGIN failed--|BEGIN not safe after errors--).*\n//mg;
      $@ =~ s/\A(?s:(.*?))(?<!\bcalled) at (\S+) (?(?{-f $2})(line \d+)|(?!.))(?:,( near .*))?\.?\n/"$2", $3: $1$4\n/mg;
      $@ =~ s/((".*?", line \d+:).*\n)(?:\2 syntax error near ".*?"\n)/$1/mg;
   }
   $@;
}
####################################################################################
sub sanitize_help {
   $_[0] =~ s/^\s*\#//gm;
   $_[0] =~ s/^\#+\n//gm;
   $_[0] =~ s/^(?:\s*\\|[ \t]+)$//gm;
   $_[0] =~ s/\n{3,}/\n\n/gs;
   $_[0] =~ s/^\s*\n//s;
   $_[0] =~ s/\n{2,}$/\n/s;
   mark_as_utf8string($_[0]);
}
####################################################################################
# this is a reduced version of Symbol::delete_package which does not delete the package itself
# used by Configure and Shell::Completion
sub wipe_package {
   my ($stash)=@_;
   foreach my $name (keys %$stash) {
      undef *{$stash->{$name}};
   }
   %$stash=();
}
####################################################################################

1

# Local Variables:
# cperl-indent-level:3
# indent-tabs-mode:nil
# End: