#  Copyright (c) 1997-2010
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.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: lattice.rules 9582 2010-03-17 10:38:31Z herr $


# Polytope all of whose vertex coordinates are integral

declare object LatticePolytope : Polytope<Rational>;

INCLUDE
  lattice_properties.rules
  lattice_visual.rules
  _4ti2.rules
  latte.rules
  normaliz2.rules
  normaliz.rules

object Polytope<Rational> {

    auto_cast : LatticePolytope;
    precondition : LATTICE;
    precondition : BOUNDED;

    rule N_LATTICE_POINTS : LATTICE_POINTS {
        $this->N_LATTICE_POINTS = $this->LATTICE_POINTS->rows;
    }
    weight 0.10;
    
    rule BOUNDARY_LATTICE_POINTS : LATTICE_POINTS , FACETS {
        my $lattice_points = $this->LATTICE_POINTS;
        my $facets = $this->FACETS;

        my @blp = ();
        foreach my $l (@$lattice_points) {
            foreach (@$facets) {
                if ( $_*$l  == 0) {
                    push @blp, new Vector<Integer>($l);
                    last;
                }
            }
        }
        $this->BOUNDARY_LATTICE_POINTS=\@blp; 
    }
    weight 2.10;
    
    rule N_BOUNDARY_LATTICE_POINTS : N_LATTICE_POINTS , N_INTERIOR_LATTICE_POINTS {
        $this->N_BOUNDARY_LATTICE_POINTS = $this->N_LATTICE_POINTS - $this->N_INTERIOR_LATTICE_POINTS;
    }
    weight 0.10;
    
    rule N_BOUNDARY_LATTICE_POINTS : BOUNDARY_LATTICE_POINTS {
        $this->N_BOUNDARY_LATTICE_POINTS = $this->BOUNDARY_LATTICE_POINTS->rows;
    }
    weight 0.10;
    
    rule INTERIOR_LATTICE_POINTS : LATTICE_POINTS , FACETS {
        my $lattice_points = $this->LATTICE_POINTS;
        my $facets = $this->FACETS;

        my @ilp = ();
        foreach my $l (@$lattice_points) {
            my $b = 1;
            foreach (@$facets) {
                if ( $_*$l  == 0) {
                    $b = 0;
                    last;
                }
            }
            if($b==1) {
                push @ilp, new Vector<Integer>($l);
            }       
        }  
        $this->INTERIOR_LATTICE_POINTS=\@ilp;
    }
    weight 2.10;
    
    rule N_INTERIOR_LATTICE_POINTS : INTERIOR_LATTICE_POINTS {
        $this->N_INTERIOR_LATTICE_POINTS = $this->INTERIOR_LATTICE_POINTS->rows;
    }
    weight 0.10;
    
    rule N_INTERIOR_LATTICE_POINTS : N_LATTICE_POINTS , N_BOUNDARY_LATTICE_POINTS {
        $this->N_INTERIOR_LATTICE_POINTS = $this->N_LATTICE_POINTS - $this->N_BOUNDARY_LATTICE_POINTS;
    }
    weight 0.10;

    rule LATTICE_POINTS : HILBERT_BASIS {
        my $hilb = $this->HILBERT_BASIS;
        my @points = ();
        foreach (@$hilb) {
            if ($_->[0] == 1) {
                push @points, $_;
            }
        }
        $this->LATTICE_POINTS = \@points;
    }
    precondition : BOUNDED;
    weight 1.10;
    
    rule N_LATTICE_POINTS : HILBERT_BASIS {
        my $hilb = $this->HILBERT_BASIS;
        my $count = 0;
        foreach (@$hilb) {
            if ($_->[0] == 1) {
                $count++;
            }
        }
        $this->N_LATTICE_POINTS = $count;
    }
    precondition : BOUNDED;
    weight 1.10;
    
    rule N_HILBERT_BASIS : HILBERT_BASIS {
        $this->N_HILBERT_BASIS = $this->HILBERT_BASIS->rows;
    }
    weight 0.10;


label projection

    rule projection.points: LATTICE_POINTS : FACETS , AFFINE_HULL , VERTICES_IN_FACETS , AMBIENT_DIM , DIM {
        $this->LATTICE_POINTS = lp_projection($this,0);
    }
    precondition : BOUNDED;
    weight 5.05;
}


object LatticePolytope {


    rule N_LATTICE_POINTS : EHRHART_POLYNOMIAL_COEFF {
        my $e = $this->EHRHART_POLYNOMIAL_COEFF;
        my $dim = $#$e;
        my $num = new Rational(0);
        for (my $i = 0; $i <= $dim; $i++) {
            $num += $e->[$i];
        }
        $this->N_LATTICE_POINTS=new Int($num);
    }
    weight 0.10;
    
    rule N_LATTICE_POINTS : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $dim = new Integer("$#$h");
        $this->N_LATTICE_POINTS = $this->H_STAR_VECTOR->[1] + $dim + 1;
    }
    precondition : DIM { $this->DIM > 0; }
    weight 0.10;
    
    
    # @category Lattice polytopes
    # The number of [[LATTICE_POINTS]] in the //n//-th dilation of the polytope
    # @param Int n dilation factor
    user_method N_LATTICE_POINTS_IN_DILATION {
        my $p=shift;
        my $n=shift;
     
        my $ev = $p->EHRHART_POLYNOMIAL_COEFF;
        my $dim = $#$ev;
        my $n_lp = 0;
        for (my $i = 0; $i <= $dim; $i++) {
            $n_lp += $ev->[$i] * ($n ** $i);
        }
        if ($dim % 2 && $n < 0) {
            return -$n_lp;
        } else {
            return $n_lp; 
        }
    }
        
    rule N_INTERIOR_LATTICE_POINTS : EHRHART_POLYNOMIAL_COEFF {
        my $e = $this->EHRHART_POLYNOMIAL_COEFF;
        my $dim = $#$e;
        my $num = new Rational(0);
        for (my $i = 0; $i <= $dim; $i++) {
            if ($i%2==0) {
                $num += $e->[$i];
            } else {
                $num -= $e->[$i];
            }
        }
        $this->N_INTERIOR_LATTICE_POINTS=new Int(abs($num));
    }
    weight 0.10;
    
    rule N_INTERIOR_LATTICE_POINTS : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $dim = $#$h;
        $this->N_INTERIOR_LATTICE_POINTS = $h->[$dim];
    }
    weight 0.10;
    
    # Check, whether the polar dual is also a lattice polytope.
    rule REFLEXIVE : FACETS {
        my $n_int = $this->lookup("N_INTERIOR_LATTICE_POINTS");
        if (defined($n_int) && $n_int != 1) {
            $this->REFLEXIVE = 0;
            return;
        }
        my $fac = eliminate_denominators($this->FACETS);
        foreach (@$fac) {
            my $a = $_->[0];
            for(my $i=1; $i<scalar(@$_); $i++) {
                if (($_->[$i])%$a != 0) {
                    $this->REFLEXIVE = 0;
                    return;
                }
            } 
        }
        $this->REFLEXIVE = 1;
    }
    precondition : CENTERED;
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM }
    weight 1.10;
    
    rule REFLEXIVE : GORENSTEIN , GORENSTEIN_INDEX {
        if ($this->GORENSTEIN) {
            if ($this->GORENSTEIN_INDEX == 1) {
                $this->REFLEXIVE = 1;
            } else {
                $this->REFLEXIVE = 0;
            }
        } else {
            $this->REFLEXIVE = 0;
        }
    }
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM; }
    weight 0.10;
    
    rule REFLEXIVE : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $dim = $#$h;
        my $i = 0;
        if ($this->H_STAR_VECTOR->[$dim] == 0) {
            $this->REFLEXIVE = 0;
            return;
        }
        while ($i < $dim-$i) {
            if($this->H_STAR_VECTOR->[$i] != $this->H_STAR_VECTOR->[$dim-$i]) {
                $this->REFLEXIVE = 0;
                return;
            }
            $i++;
        }
        $this->REFLEXIVE = 1;
    }
    weight 0.10;
    
    rule GORENSTEIN , GORENSTEIN_INDEX : {
        $this->GORENSTEIN = 1;
        $this->GORENSTEIN_INDEX = 1;
    }
    precondition : REFLEXIVE;
    weight 0.10;
    
    rule GORENSTEIN : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $max = $#$h;
        while ($this->H_STAR_VECTOR->[$max] == 0) {
            $max--;
        }
        my $i = 0;
        while ($i < $max-$i) {
            if($this->H_STAR_VECTOR->[$i] != $this->H_STAR_VECTOR->[$max-$i]) {
                $this->GORENSTEIN = 0;
                return;
            }
            $i++;
        }
        $this->GORENSTEIN = 1;
    }
    weight 0.10;
    
    #Read FACETS f1, . . . , fk (in lattice minimal form) and check whether there is a lattice minimal x ??? L such that hx, fii = 1 for all 1 . i . k. If so, then P is Gorenstein, and the first coordinate r of x of is the Gorenstein index of P. x is the unique inner lattice point of rP
    rule GORENSTEIN , GORENSTEIN_INDEX , GORENSTEIN_VECTOR : FACETS , AMBIENT_DIM {
        my $fac = eliminate_denominators($this->FACETS);
        my @vert = map { new Vector<Rational>(1, @{ div_exact($_,gcd($_)) }) } @$fac;
        my $p = new Polytope<Rational>(POINTS=>\@vert);
        if ($p->DIM <= $this->AMBIENT_DIM) {
            my $x = dehomogenize($p->AFFINE_HULL->row(0));
            if (is_integral($x)) {
                $this->GORENSTEIN = 1;
                my $lx = new Vector<Integer>($x->[0]>0 ? $x : -$x);
                $lx->div_exact(gcd($lx));
                $this->GORENSTEIN_INDEX = abs($lx->[0]);
		$lx->[0]=1;
                $this->GORENSTEIN_VECTOR = $lx;
                return;
            }
        }
        $this->GORENSTEIN = 0;
    }
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM; }
    weight 3.10;
    
    rule GORENSTEIN_VECTOR : INTERIOR_LATTICE_POINTS {
        $this->GORENSTEIN_VECTOR = $this->INTERIOR_LATTICE_POINTS->row(0);
    }
    precondition : REFLEXIVE;
    weight 0.10;
    
    rule CANONICAL : N_INTERIOR_LATTICE_POINTS {
        $this->CANONICAL = ($this->N_INTERIOR_LATTICE_POINTS == 1);
    }
    weight 0.10;
    
    rule TERMINAL : CANONICAL , N_LATTICE_POINTS , N_VERTICES {
        $this->TERMINAL = ($this->CANONICAL && ($this->N_LATTICE_POINTS == $this->N_VERTICES + 1));
    }
    weight 0.10;
    
    rule LATTICE_EMPTY : N_LATTICE_POINTS , N_VERTICES {
        if ($this->N_LATTICE_POINTS == $this->N_VERTICES) {
            $this->LATTICE_EMPTY = 1;
        } else {
            $this->LATTICE_EMPTY = 0;
        }
    }
    weight 0.10;   
    
    rule LATTICE_VOLUME : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $dim = $#$h;
        my $vol = new Integer(0);
        for (my $i = 0; $i <= $dim; $i++) {
            $vol += $this->H_STAR_VECTOR->[$i];
        }
        $this->LATTICE_VOLUME = $vol;
    }
    weight 0.10;    
    
    rule LATTICE_VOLUME : VOLUME , DIM {
        $this->LATTICE_VOLUME = $this->VOLUME * fac($this->DIM);
    }
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM; }
    weight 0.10;
    
    rule VOLUME : LATTICE_VOLUME , DIM {
        my $vol = new Rational($this->LATTICE_VOLUME);
        $this->VOLUME = $vol / fac($this->DIM);
    }
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM; }
    weight 0.10;

    rule LATTICE_VOLUME : EHRHART_POLYNOMIAL_COEFF , DIM {
        $this->LATTICE_VOLUME = $this->EHRHART_POLYNOMIAL_COEFF->[$this->DIM] * fac($this->DIM);
    } 
    weight 0.10;
    
    rule LATTICE_DEGREE : LATTICE_CODEGREE , DIM {
        $this->LATTICE_DEGREE = $this->DIM + 1 - $this->LATTICE_CODEGREE;
    }
    weight 0.10;
    
    rule LATTICE_DEGREE : H_STAR_VECTOR {
        my $h = $this->H_STAR_VECTOR;
        my $i = $#$h;
        while ($h->[$i] == 0) {
            $i--;
        }
        $this->LATTICE_DEGREE = $i;
    }
    weight 0.10;
    
    rule LATTICE_CODEGREE : GORENSTEIN_INDEX {
        my $index = $this->GORENSTEIN_INDEX;
        if($index > 0) {
            $this->LATTICE_CODEGREE = $index;
        }
    }
    precondition : GORENSTEIN;
    weight 0.10;
    
    rule LATTICE_CODEGREE : LATTICE_DEGREE , DIM {
        $this->LATTICE_CODEGREE = $this->DIM + 1 - $this->LATTICE_DEGREE;
    }
    weight 0.10;

    rule EHRHART_POLYNOMIAL_COEFF : H_STAR_VECTOR {
        $this->EHRHART_POLYNOMIAL_COEFF = binomial_to_power_basis(new Vector<Rational>($this->H_STAR_VECTOR));
    }
    weight 0.10;

    rule H_STAR_VECTOR : EHRHART_POLYNOMIAL_COEFF {
        $this->H_STAR_VECTOR = power_to_binomial_basis($this->EHRHART_POLYNOMIAL_COEFF);
    }
    weight 0.10;
    
    rule NORMAL : HILBERT_BASIS {
        my $hilb = $this->HILBERT_BASIS;
        foreach (@$hilb) {
            if (@$_->[0] != 1) {
                $this->NORMAL = 0;
                return;
            }
        }
        $this->NORMAL = 1;
    }
    weight 1.10;
    
    rule FACET_WIDTH : FACET_WIDTHS {
        $this->FACET_WIDTH = maximum($this->FACET_WIDTHS);
    }
    weight 0.10;

  rule FACET_VERTEX_LATTICE_DISTANCES : VERTICES, FACETS {
   my $m = eliminate_denominators($this->FACETS);
   my $vert = new Matrix<Integer>($this->VERTICES);
   foreach (@{$m}) { $_ = div_exact($_,gcd($_)); }

   $this->FACET_VERTEX_LATTICE_DISTANCES = $m * transpose($vert);
  } 
  precondition : DIM, AMBIENT_DIM { $this->AMBIENT_DIM == $this->DIM; }

  
  # @category Lattice polytopes
  # Vector containing the distances of a given point //v// from all facets
  # @param Vector<Rational> v point in the ambient space of the polytope
  # @return Vector<Integer>
  user_method FACET_POINT_LATTICE_DISTANCES {
   my $p = shift;
   ($p->AMBIENT_DIM == $p->DIM) or die "polytope must be full dimensional\n";

   my $v = new Vector<Rational>(shift);
   $v->dim == $p->DIM or die "polytope - point dimension mismatch\n";  
   $v = (1|$v);

   my $m = eliminate_denominators($p->FACETS);

   my @d = map { (new Vector<Rational>( @{ div_exact($_,gcd($_)) })) * $v } @$m;

   return new Vector<Integer>(\@d);
  }
    
    rule FACET_WIDTHS : VERTICES , FACETS , AMBIENT_DIM {
        $this->FACET_WIDTHS = [
            map {
                my $f=$_;
                $f->div_exact(gcd($f));
                my $max;
                assign_max($max, $f * $_) for @{$this->VERTICES};
                $max;
            } @{ eliminate_denominators($this->FACETS) }
        ];
    }
    precondition : AMBIENT_DIM , DIM { $this->AMBIENT_DIM == $this->DIM }
    weight 3.10;

    rule COMPRESSED : FACET_WIDTH {
        $this->COMPRESSED=($this->FACET_WIDTH==1);
    }
    weight 0.10;

    rule SMOOTH : N_VERTICES, GRAPH.ADJACENCY, GRAPH.EDGE_DIRECTIONS, SIMPLE {

        if ( !$this->SIMPLE ) { $this->SMOOTH = 0; return; }

        for ( my $v=0; $v < $this->N_VERTICES; ++$v ) {
            my $m=new Matrix<Integer>; 
            for ( my $e=entire($this->GRAPH->ADJACENCY->out_edges($v)); $e; ++$e ) { 
                my $w= eliminate_denominators($this->GRAPH->EDGE_DIRECTIONS->[$$e]); 
                $m /= div_exact($w,gcd($w)); 
            }

            my $g = 0;
            foreach (all_subsets_of_k($m->rows,1..$m->cols-1)) {
                $g = gcd($g,abs(det($m->minor(All,$_))));
                last if ($g == 1);
            }
        
            if ($g != 1) { $this->SMOOTH = 0; return; }
        }

        $this->SMOOTH = 1;
    }
    weight 3.10;
  
    rule VERY_AMPLE : GRAPH.ADJACENCY, GRAPH.EDGE_DIRECTIONS, N_VERTICES, VERTICES, FACETS | INEQUALITIES {
        my $sched;
        for ( my $v=0; $v < $this->N_VERTICES; ++$v ) {
            my @dirs = ();
            push @dirs, unit_vector<Rational>($this->VERTICES->cols, 0);
            for (my $e = entire($this->GRAPH->ADJACENCY->out_edges($v)); $e; ++$e) {
                push @dirs, ($e->to_node > $e->from_node) ? -$this->GRAPH->EDGE_DIRECTIONS->[$$e] : $this->GRAPH->EDGE_DIRECTIONS->[$$e];
            }
            my $p = new LatticePolytope(POINTS=>\@dirs);
	    $sched ||= $p->get_schedule("HILBERT_BASIS")
		   || die "don't know how to compute HILBERT_BASIS: please install 4ti2, normaliz, or latte\n";
	    $sched->apply($p);
            foreach my $h (@{$p->HILBERT_BASIS}) {
                next if ($h->[0]==1);
                foreach (@{$this->FACETS|INEQUALITIES}) {
                    if ($_*($h+$this->VERTICES->[$v]) < 0) {
                        $this->VERY_AMPLE=0;
                        return;
                    }
                }
                if (defined (my $AH = $this->lookup("AFFINE_HULL | EQUATIONS"))) {
                    foreach (@$AH) {
                        if ($_*($h+$this->VERTICES->[$v]) != 0) {
                            $this->VERY_AMPLE=0;
                            return;
                        }
                    }
                }
            }
        }
        $this->VERY_AMPLE=1;
    }
    weight 5.50;

    rule VERY_AMPLE : { $this->VERY_AMPLE = 1; }
    precondition : SMOOTH | NORMAL;
    weight 0.10;

}


# Local Variables:
# mode: perl
# c-basic-offset:4
# End:
