#  Copyright (c) 1997-2004
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  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.
#----------------------------------------------------------------------------
#  $Project: polymake $$Id: Preference.pm,v 1.11.2.2 2004/12/17 14:07:36 gawrilow Exp $

use strict;
use namespaces;

####################################################################################

package Poly::Label;

use Struct (
   [ new => '$;$$$$' ],
   [ '$name' => '#1' ],
   [ '$parent' => '#2' ],	# Label higher in the hierarchy
   [ '$wildcard_name' => '#3 || "*"' ],
   '%children',			# Labels lower in the hierarchy
   '%controls',			# control list -> number of items in this list
   [ '$clock' => '#4' ],	# sequential number of the last 'prefer' command
   [ '$rank' => '#5' ],		# rank in this command
);

# Structure of a control list:
# for i=0..#{involved Labels}-1
#   [i*2]   -> stored item
#   [i*2+1] -> key(Label)
# [-1]  -> order count: number of leading items which are known to be ordered due to
#          the active preferences. The trailing items are in arbitrary order.
#          Thus, a control list without any active preferences applied has
#          the order count == 0.

####################################################################################
sub child {
   my ($self, $name)=@_;
   $self->children->{$name} ||=
      new Poly::Label( $name, weak($self), $self->wildcard_name.".$name", $self->clock, $self->rank );
}
####################################################################################
sub add_control {
   my ($self, $list, $item)=@_;
   ++($self->controls->{$list});
   if (@$list) {
      my $pos=-1;
      if (defined($self->clock)) {
	 if ($list->[-1]==0  or
	     (my $clock_diff=$list->[1]->clock - $self->clock) < 0) {
	    $pos=0;
	    $list->[-1]=2;
	 } elsif ($clock_diff==0) {
	    for ($pos=0;
		 $pos<$list->[-1] && $list->[$pos+1]->rank <= $self->rank;
		 $pos+=2) { }
	    $list->[-1]+=2;
	 }
      }
      splice @$list, $pos, 0, $item, $self;
   } else {
      @$list=($item, $self, defined($self->clock)*2);
   }
}
####################################################################################
sub register_copy {
   my ($new, $old)=@_;
   for (my $i=1; $i<$#$old; $i+=2) {
      ++($old->[$i]->controls->{$new});
   }
}
####################################################################################
sub dup_control {
   my ($list)=@_;
   my @new_list=@$list;
   register_copy(\@new_list, $list);
   \@new_list;
}
####################################################################################
sub copy_control {
   my ($new, $old)=@_;
   @$new=@$old;
   register_copy($new, $old);
   $new;
}
####################################################################################
sub merge_controls {
   my ($dst, $src)=@_;
   register_copy($dst, $src);

   if (!$src->[-1]  ||
       $dst->[-1] && $dst->[1]->clock > $src->[1]->clock) {
      # src unordered - attach to the tail
      splice @$dst, -1, 0, @$src[0..$#$src-1];

   } elsif (!$dst->[-1]  ||
	    $src->[-1] && $dst->[1]->clock < $src->[1]->clock) {
      # dst unordered - push the new items to the front
      splice @$dst, 0, 0, @$src[0..$#$src-1];
      $dst->[-1]=$src->[-1];

   } else {
      # both ordered: merge carefully
      my $dord=$dst->[-1];
      my ($s, $d);
      for (($s,$d)=(1,1);  $s<$src->[-1] && $d<$dord;  $d+=2) {
	 if ($dst->[$d]->rank > $src->[$s]->rank) {
	    splice @$dst, $d-1, 0, @$src[$s-1,$s];
	    $s+=2;
	    $dord+=2;
	 }
      }
      $dst->[-1]+=$src->[-1];
      # insert the unordered rest
      splice @$dst, $dord, 0, @$src[$s-1..$#$src-1];
   }
}
####################################################################################
sub forget_control {
   my $list=shift;
   for (my $i=1; $i<$#$list; $i+=2) {
      delete $list->[$i]->controls->{$list};
   }
}
####################################################################################
# return all items from a control list, removing duplicates
sub get_items {
   my $list=shift;
   my (%seen, @items);
   for (my $i=0; $i<$#$list; $i+=2) {
      push @items, $list->[$i] unless $seen{$list->[$i]}++;
   }
   @items;
}
####################################################################################
# return the items from a control list, sorted by rank
# each bag starts with the rank value
# the last bag always contains unordered items (and rank is undef)
sub get_items_by_rank {
   my $list=shift;
   my (%seen, @bags);
   my $i;
   for ($i=0; $i<$list->[-1]; $i+=2) {
      my $cur_rank=$list->[$i+1]->rank;
      if (!@bags) {
	 push @bags, [ $cur_rank ];
      } elsif (@{$bags[-1]}==0) {
	 $bags[-1]->[0]=$cur_rank;
      } elsif ($bags[-1]->[0]<$cur_rank) {
	 push @bags, [ $cur_rank ];
      }
      push @{$bags[-1]}, $list->[$i] unless $seen{$list->[$i]}++;
   }
   if ($i<$#$list) {
      if (!@bags || @{$bags[-1]}>1) {
	 push @bags, [ undef ];
      } else {
	 undef $bags[-1]->[0];
      }
      for (; $i<$#$list; $i+=2) {
	 push @{$bags[-1]}, $list->[$i] unless $seen{$list->[$i]}++;
      }
   }
   @bags;
}
####################################################################################
sub is_in_effect {
   my $self=shift;
   return 0 if !defined $self->clock;

   foreach my $list (keys %{$self->controls}) {
      return 1 if $list->[-1] && $list->[1]->clock == $self->clock;
   }

   foreach my $c (values %{$self->children}) {
      $c->is_in_effect  and  return 1;
   }
   0;
}
####################################################################################
# clock, rank =>
sub set_preferred {
   my $self=shift;
   if (defined ($self->clock) && $self->clock==$_[0]) {
      die $self->full_name, " multiply occurs in the preference list: at positions ", $self->rank, " and $_[1]\n";
   }
   ($self->clock, $self->rank)=@_;

 CONTROLS:
   while (my ($list, $cnt)=each %{$self->controls}) {
      if ($list->[-1]) {
	 if ($list->[1]->clock < $self->clock) {
	    # obsolete
	    $list->[-1]=0;
	 } elsif ($list->[1]==$self) {
	    # kept his position
	    $list->[-1]=2*$cnt;
	    next CONTROLS;
	 }
      }
      my $new_pos=$list->[-1]+1;
      $list->[-1]+=2*$cnt;
      for (my $pos=$new_pos; $pos < $#$list; $pos+=2) {
	 if ($list->[$pos] == $self) {
	    if ($pos != $new_pos) {
	       splice @$list, $new_pos-1, 0, splice @$list, $pos-1, 2;
	    }
	    next CONTROLS unless --$cnt;
	    $new_pos+=2;
	 }
      }
      confess( "corrupted control list for label ", $self->full_name );
   }

   foreach my $c (values %{$self->children}) {
      $c->set_preferred(@_);
   }
}
####################################################################################
sub set_temp_preferred {
   my ($self, $scope)=@_;
   while (my ($list, $cnt)=each %{$self->controls}) {
      next if $#$list == $cnt*2; 	# no competitors
      my @temp_list=@$list;
      $temp_list[-1]=0;
      for (my $i=1;  $i<$#temp_list;  $i+=2) {
	 if ($list->[$i] == $self) {
	    if ($i-1 != $temp_list[-1]) {
	       # put the controlled item in the first position
	       splice @temp_list, $temp_list[-1], 0, splice @temp_list, $i-1, 2;
	    }
	    $temp_list[-1]+=2;
	    last unless --$cnt;
	 }
      }
      if ($Switches::v>=2) {
	 dbg_print( $self->full_name, " temporarily preferred over ",
		    join(", ", map { $temp_list[$_*2+1]->full_name } $self->controls->{$list}..($#temp_list/2-1)) );
      }
      confess( "corrupted control list for label ", $self->full_name ) if $cnt;
      $scope->begin_locals;
      local_array($list, \@temp_list);
      local_scalar($self->rank, 0);
      $scope->end_locals;
   }

   foreach my $c (values %{$self->children}) {
      $c->set_temp_preferred($scope);
   }
}
####################################################################################
sub full_name {
   my $self=shift;
   my $n=$self->name;
   while (defined($self=$self->parent)) {
      $n=$self->name.".$n";
   }
   $n
}

sub parent_name {
   my ($self)=@_;
   $self=$self->parent while defined($self->parent);
   $self->name
}

####################################################################################

package Poly::PreferenceList;

# Constructor: new Preference(Label, ...);

my $clock=0;

sub new {
   my $class=shift;
   activate(bless [ @_ ], $class);
}

sub activate {
   my $rank=0;
   foreach my $label (@{$_[0]}) {
      $label->set_preferred($clock, $rank++);
   }
   ++$clock;
   $_[0];
}

sub is_in_effect {
   my $self=shift;
   foreach my $label (@$self) {
      $label->is_in_effect  and  return 1;
   }
   return 0;
}

sub compare {
   my ($p1, $p2)=@_;
   for (my ($i, $l)=(0, min($#$p1, $#$p2)); $i<=$l; ++$i) {
      return 2 if $p1->[$i] != $p2->[$i];
   }
   return $#$p1 <=> $#$p2;
}

sub toString {
   my $self=shift;
   if (@$self==1) {
      $self->[0]->full_name
   } else {
      $self->[0]->wildcard_name . " " . join(", ", map { $_->parent_name } @$self)
   }
}
####################################################################################

package Poly::Preference::perModule;

use Struct (
   '$handler',
   '%labels',
   '@prefs',
   '$n_default',
   '@saved_default',
   '@super',
);

####################################################################################
sub add_label {
   my ($self, $name)=@_;
   ( $self->labels->{$name} &&=
     die "label $name already defined\n" ) ||=
   new Poly::Label($name);
}
####################################################################################
sub find_label {
   my ($self, $name, $create)=@_;
   my @name=split /\./, $name;
   $name=shift @name;
   my $label=$self->labels->{$name};
   if (!$label) {
      foreach my $super (@{$self->super}) {
	 $label=$super->labels->{$name}  and  last;
      }
      return undef unless $label;
   }
   foreach $name (@name) {
      $label= $create ? $label->child($name) : $label->children->{$name}
      or return undef;
   }
   $label;
}
####################################################################################
# $compile_mode & 1 => allow to create new sublevels
# $compile_mode & 2 => 'prefer' command comes from the rules
sub add_preference {
   my ($self, $expr, $compile_mode)=@_;
   my (@err, @l);

   # parse the labels
   if ($expr =~ /^[\w.]+$/) {
      if (defined (my $l=$self->find_label($expr, $compile_mode & 1))) {
	 @l=($l);
      } else {
	 push @err, $expr;
      }
   } elsif ($expr =~ /^\*.([\w.]+)\s+/) {
      my $tail=$1;
      @l=map { $self->find_label("$_.$tail", $compile_mode & 1) ||
	       do { push @err, "$_.$tail"; () }
	 } split /(?:\s*,\s*|\s+)/, $';
   } else {
      die "syntax error in preference list\n";
   }

   if (!@err) {
      my $pref=new Poly::PreferenceList(@l);
      my $p=$self->prefs;
      if ($compile_mode & 2) {
         ++$self->n_default;
         push @{$self->saved_default}, $pref;
      } else {
         for (my $i=0; $i<=$#$p; ) {
	    if ($p->[$i]->compare($pref)>0 && $p->[$i]->is_in_effect) {
	       ++$i;
	    } else {
	       --$self->n_default if $i<$self->n_default;
	       splice @$p, $i, 1;
	    }
	 }
	 $self->handler->need_save=1;
      }
      push @$p, $pref;

   } elsif ($compile_mode & 1) {
      die "unknown label", @err>1 && "s", ": ", @err, "\n";
   } else {
      err_print( "unknown label", @err>1 && "s", ": ", @err );
   }
}
####################################################################################
sub end_compile_mode {
   my ($self, $module)=@_;
   my $key=do { ref($module) =~ /([^:]+)$/; lc($1) } . " " . $module->name;
   if (my $ph=$module->can("prefs_handler")) {
      $ph=$ph->();
      if (!$self->handler) {
	 $self->handler=weak($ph);
	 push @{$ph->modules}, $module;
      }

      if (my $text=delete $ph->orphans->{$key}) {
	 while ($text =~ s/^[ \t]* prefer \s+ (.*?) ;? (?= \s*$ )//xm) {
	    $self->add_preference($1,1);
	 }
	 if ($text =~ /^\s*[^\#\s]/m) {
	    package Poly::User;
	    local $application=$module;
	    eval $text;
	    if ($@) {
	       err_print( process_eval_errors($@) );
	    } else {
	       $text =~ s/^\s*\#.*\n//gm;
	       $text =~ s/\A (?: ^\s*\n)+ //xm;
	       $text =~ s/(?: ^\s*\n)+ \Z//xm;
	       $ph->user_commands->{$key}=$text;
	    }
	 }
      } else {
	 $ph->need_save ||= @{$self->prefs}>0;
      }

   }
   $self;
}
####################################################################################
sub reset {
   my ($self)=@_;
   $self->n_default=(@{$self->prefs}=@{$self->saved_default});
   $_->activate for @{$self->prefs};
}
####################################################################################
sub inherit {
   my $self=shift;
   foreach (@_) {
      push @{$self->super}, $_, @{$_->super};
   }
}
####################################################################################

package Poly::Preference;

use Struct (
   [ new => '$' ],
   [ '$file' => '#1' ],		# where to save preference lists
   '@modules',			# Module or Application
   '%orphans',			# package => file fragment
   '%user_commands',		# package => perl text
   '$need_save',		# boolean
);

my $sep_line="########################\n";

my $preface=<<'.';
#########################################################################
#
#  This file contains preference settings that were in effect
#  as you closed your last polymake session.
#
#  Initially it contains copies of "prefer" commands scattered over the
#  rule files.  They are commented out, since they are come into action
#  as soon as the rule files are loaded.
#
#  Later on, each interactive "prefer" command you type in the polymake
#  shell is also recorded here, in the chronological order.
#  Prior commands having lost any effect are wiped out from the file
#  automatically.
#
#  You can also edit this file manually, including or deleting "prefer"
#  commands, or even other commands recognized by the interactive shell.
#  But never edit it while polymake processes are running, otherwise
#  you risk to do it in vain, all your changes may be overwritten.
#
#  To revert to the default preferences later, comment out or delete
#  your changes, or execute the interactive command 'prefer reset'.
#
#  Please be aware that this file is interpreted by polymake after all
#  rule files, unlike "customize.pl".
#
# **********************************************************************
#  If you have written your own rule files and want them be included
#  each time you start polymake, put commands like this:
#     include 'my.rules';
#  or
#     include qw( my.rules other.rules );
#  in the appropriate section of this file - after the declaration of
#  the application these rules belong to.
#
#  Specify the rule files either as absolute paths or relatively to
#  one of directories stored in the variable @Poly::User::lookup_rules
#  defined below.
#########################################################################

# polymake should look for additional rules in the following directories:
# @Poly::User::lookup_rules=( "$ENV{HOME}/my_rule_dir" );

# polymake should look for applications in the following directories:
# @Poly::Application::lookup=( );

.
if (defined $main::Version) {
   $preface .= <<"." . $sep_line;
# The rule files are rescanned for new preference lists as soon as you
# run a polymake version newer than recorded here, or use an application
# for the first time.
# If you have inserted new "prefer" commands in the rules and want them
# to appear here right now, comment out the following line and rerun polymake.
\$version=v$main::Version;

.
}

sub import {
   if (@_!=2) {
      croak( "usage: use Preference \"filename\"" );
   }
   my $pkg=caller;
   {
      no strict 'refs';
      if (exists &{"$pkg\::prefs_handler"}) {
	 croak( "attempt to install multiple preference handlers in package \"$pkg\"" );
      }
   }
   my $handler=&_new;
   define_function($pkg, "prefs_handler", sub { $handler });
   eval "package $pkg; END { \$handler->save if \$handler->need_save }";
   if (-f $handler->file) {
      $handler->read_file;
   } else {
      $handler->need_save=1;
   }
}
#################################################################################
sub read_file {
   my ($self, $filename)=@_;
   $filename ||= $self->file;
   open my $pf, $filename
   or die "can't read preferences file \"$filename\": $!\n";
   local $_;
   my ($key, $body, $version)=("BEGIN", <<".");
package Poly::User;
#line 1 \"$filename\"
.
   while (<$pf>) {
      if (/^\s*(application|module)\s+(\w+);\s*$/) {
	 $self->orphans->{$key}=$body;
	 $key="$1 $2";
	 my $l=$.+1;
	 $body="#line $l \"$filename\"\n";
	 next;
      }
      $body.=$_;
   }
   $self->orphans->{$key}=$body;

   eval $self->orphans->{BEGIN};
   if ($@) {
      err_print( process_eval_errors($@) );
      return;
   }

   $self->need_save=defined $main::Version &&
                    (!defined($version)  ||  $version lt $main::VersionNumber);
}
#################################################################################
sub forget_module {
   my ($self, $module)=@_;
   my $i=0;
   foreach (@{$self->modules}) {
      if ($_ == $module) {
	 splice @{$self->modules}, $i, 1;
	 return;
      }
      ++$i;
   }
}
#################################################################################
sub save {
   my ($self)=@_;
   open my $pf, ">", $self->file
      or die "can't store preferences in ", $self->file, ": $!\n";
   print $pf $preface;
   my $text=$self->orphans->{BEGIN};
   $text =~ s/\A(?s:.*?)^[\s\#]*\$version.*\n\s*\#+\s*\n//mg;
   print $pf $text;

   foreach my $module (@{$self->modules}) {
      ref($module) =~ /([^:]+)$/;
      my $key=lc($1)." ".$module->name;
      print $pf "$key;\n\n";
      my $p=$module->prefs;
      my $def=$p->n_default;
      foreach my $pref (@{$p->prefs}) {
	 print $pf "# " if $def-- > 0;
	 print $pf "prefer ", $pref->toString, ";\n\n";
      }
      if (defined (my $commands=$self->user_commands->{$key})) {
	 print $pf $commands, "\n";
      }
      print $pf $sep_line;
   }

   while ((my $key, $text)=each %{$self->orphans}) {
      next if $key eq "BEGIN";
      $text =~ s/^\#line.*\n//mg;
      print $pf "$key;\n\n$text";
   }

   $self->need_save=0;
}

1

# Local Variables:
# c-basic-offset:3
# End:
