(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext.

Local Open Scope zarith_ext_scope.

Module Type IntegralType.

Parameter t : eqType.
Parameter of_nat : nat -> t.
Axiom of_nat_inj : forall a b, of_nat a = of_nat b -> a = b.

Parameter add : t -> t -> t.
Axiom addA : forall a b c, add a (add b c) = add (add a b) c.
Axiom addC : forall n m, add n m = add m n.
Axiom add0 : forall a, add a (of_nat 0) = a.
Axiom add1 : forall a, add (of_nat 1) (of_nat a) = of_nat a.+1.

Parameter sub : t -> t -> t.
Parameter mul : t -> t -> t.
Parameter div : t -> t -> t.
Parameter rem : t -> t -> t.
Parameter abs : t -> t.

Parameter ge : t -> t -> Prop.
Parameter gt : t -> t -> Prop.
Parameter geb : t -> t -> bool.
Parameter gtb : t -> t -> bool.
Axiom geP : forall a b : t, geb a b <-> ge a b.
Axiom gtP : forall a b : t, gtb a b <-> gt a b.

Parameter eqb : t -> t -> bool.
Axiom eqP : Equality.axiom eqb.

Axiom ge_refl : forall a, ge a a.
Axiom gebNgt : forall a b, geb b a = (~~ gtb a b).
Axiom gtbE : forall a b, gtb a b = geb a b && (a != b).
Axiom gtW : forall a b, gt a b -> ge a b.
Axiom ge_trans : forall b a c, ge a b -> ge b c -> ge a c.
Axiom gt_add1 : forall n, gt (add (of_nat 1) n) n.

End IntegralType.

Module IntegralType_Prop (X : IntegralType).

Import X.

Lemma gt_trans a b c : gt a b -> gt b c -> gt a c.
Proof.
move=> /gtW a_b /gtP/negPn.
rewrite -gebNgt => c_b.
apply/gtP/negPn.
rewrite -gebNgt.
apply: contra c_b => c_a.
apply/geP/(ge_trans a) => //; exact/geP.
Qed.

Lemma ge_gt_dec a b : ge a b \/ gt b a.
Proof.
move H : (geb a b) => [|]; first by left; exact/geP.
right.
apply/gtP/negPn.
move/negbT : H.
apply contra.
by rewrite -gebNgt.
Qed.

Lemma geb_false a b : ~~ geb a b <-> ~ ge a b.
Proof. split; [by move/negP => H /geP | move=> H; exact/negP/geP]. Qed.

Lemma gtb_false a b : ~~ gtb a b <-> ~ gt a b.
Proof. split; [by move/negP => H /gtP | move=> H; exact/negP/gtP]. Qed.

Definition max (a b : t) := if geb a b then a else b.

Lemma ge_max_r a b : ge (max a b) b.
Proof. rewrite /max. move H : (geb _ _) => []; [exact/geP | exact/ge_refl]. Qed.

Lemma ge_max_l a b : ge (max b a) b.
Proof.
rewrite /max.
move H : (geb _ _) => []; first exact/ge_refl.
move/negbT : H; rewrite gebNgt => /negPn H; exact/gtW/gtP.
Qed.

Lemma maxA a b c : max a (max b c) = max (max a b) c.
Proof.
rewrite /max.
case/boolP : (geb b c) => b_c.
  case/boolP : (geb a b) => a_b //; last by rewrite b_c.
  case/boolP : (geb a c) => //.
  move/geP in b_c. move/geP in a_b.
  by move/geP: (ge_trans _ _ _ a_b b_c) => ->.
move a_c : (geb a c) => [|].
  move a_b : (geb a b) => [|]; first by rewrite a_c.
  move: b_c; rewrite gebNgt => /negPn c_b.
  move: a_b; rewrite gebNgt => /negPn b_a.
  have a_c2 : gtb c a.
    apply/gtP/(gt_trans _ b) => //; exact/gtP.
  by rewrite gebNgt a_c2 in a_c.
move a_b : (geb a b) => [|]; [by rewrite a_c | by rewrite (negbTE b_c)].
Qed.

Definition max_list l def := List.fold_left max l def.

Lemma ge_max_list_max : forall tl def x, ge (max_list tl (max def x)) x.
Proof.
elim => [def x /= | hd tl IH def x /=].
exact: ge_max_r.
case: (ge_gt_dec hd x) => X; first exact: (ge_trans hd).
rewrite -maxA.
apply (ge_trans (max x hd)) => //; exact/ge_max_l.
Qed.

Lemma my_max_list_prop : forall l def x, List.In x l -> ge (max_list l def) x.
Proof.
elim=> // hd tl IH def x /= [-> | H]; by [apply ge_max_list_max | apply IH].
Qed.

Lemma my_max_list_disj l : disj (add (of_nat 1) (max_list l (of_nat O)) :: List.nil) l.
Proof.
apply disj_cons_L; first by apply disj_nil_L.
move/(my_max_list_prop _ (of_nat O)).
move/geP.
rewrite gebNgt => /negP.
apply; exact/gtP/gt_add1.
Qed.

End IntegralType_Prop.

(*Inductive negpos : Set :=
| neg : positive -> negpos
| pos : positive -> negpos.

Definition of_negpos (x : negpos) : Z :=
  match x with neg p => Zneg p | pos p => Zpos p end.

Definition negpos_eqb a b :=
  match (a, b) with
    | (neg a', neg b') => Ndec.Peqb a' b'
    | (pos a', pos b') => Ndec.Peqb a' b'
    | _ => false
  end.

Lemma negpos_eqbP : Equality.axiom negpos_eqb.
Proof.
  move=> x y.
  apply: (iffP idP) => H.
  destruct x; destruct y => //.
  rewrite /negpos_eqb /= in H.
  move/positiveP:H => H.
  subst => //.
  rewrite /negpos_eqb /= in H.
  move/positiveP:H => H.
  subst => //.
  subst.
  destruct y; rewrite /negpos_eqb => /=.
  apply/positiveP => //.
  apply/positiveP => //.
Qed.

Canonical Structure negpos_eqMixin := EqMixin negpos_eqbP.
Canonical Structure negpos_eqType := Eval hnf in EqType _ negpos_eqMixin.

Lemma negposP : forall x, of_negpos x <> Z_of_nat 0.
Proof. case=> p //=. Qed.

Definition to_negpos (i : Z) (H : i == Z_of_nat O <> true) : negpos.
Proof.
case: i H => // p H; [exact (pos p) | exact (neg p)].
Defined.

Lemma to_negposK : forall z (H : z == Z_of_nat O <> true), of_negpos (to_negpos z H) = z.
Proof. by case. Qed.

Lemma negpos_inj : forall x y, of_negpos x = of_negpos y -> x = y.
Proof. case=> p; case=> p' //=; case=> -> //. Qed.*)

Module ZIT <: IntegralType.

Definition t : eqType := Z_eqType.
Definition of_nat : nat -> t := Z_of_nat.
Definition of_nat_inj a b : of_nat a = of_nat b -> a = b := Z_of_nat_inj a b.

Definition add : t -> t -> t := Zplus.
Definition addA : forall a b c, add a (add b c) = add (add a b) c := addZA.
Definition addC : forall n m, add n m = add m n := addZC.
Definition add0 a : add a (of_nat 0) = a := addZ0 a.
Lemma add1 a : add (of_nat 1) (of_nat a) = of_nat a.+1.
Proof. by rewrite /add /of_nat !Z_S [Z_of_nat 0]/= add0Z addZC. Qed.

Definition sub := Zminus.
Definition mul := Zmult.
Definition div := divZ.
Definition rem := Zmod.
Definition abs := Z.abs.

Definition ge := Z.ge.
Definition gt := Z.gt.
Definition geb := Zge_bool.
Definition gtb := Zgt_bool.

Lemma geP a b : geb a b <-> ge a b. Proof. split => *; exact/geZP. Qed.
Lemma gtP a b : gtb a b <-> gt a b. Proof. split => *; by apply/gtZP. Qed.

Definition eqb := @eq_op Z_eqType. (* so that we can use eqxx *)
Lemma eqP : Equality.axiom eqb. Proof. move=> *; exact: eqP. Qed.

Lemma ge_refl a : ge a a. Proof. exact/Z.le_ge/leZZ. Qed.

Lemma gebNgt a b : geb b a = (~~ gtb a b).
Proof. by rewrite /gtb Z.gtb_ltb ltZNge' negbK -Z.geb_leb. Qed.

Lemma gtbE a b : gtb a b = geb a b && (a != b).
Proof.
apply/gtZP; case: ifP => [|/negP X Y].
  case/andP => /geZP X /eqP Y; lia.
apply/X/andP; split; [apply/geZP; lia | apply/eqP; lia].
Qed.

Lemma gtW a b : gt a b -> ge a b. Proof. rewrite /gt /ge; lia. Qed.

Lemma ge_trans b a c : ge a b -> ge b c -> ge a c.
Proof. move=> *; exact: (Zge_trans _ b) . Qed.

Lemma gt_add1 n : gt (add (of_nat 1) n) n.
Proof. rewrite /gt /add /of_nat [Z_of_nat _]/=; lia. Qed.

End ZIT.

Module Import ZIT_prop_m := IntegralType_Prop ZIT.

(* turn the abstract (A.t_geb _ _) = true, (A.t_ge _ _ ), etc. hypotheses into their implementation,
   so as to be able to use third-party tactics to solve goals (e.g., lia) *)

Ltac open_integral_type_hyp :=
  match goal with
    | |- is_true (ZIT.gtb _ _) => apply (proj1 (ZIT.gtP _ _)); unfold ZIT.gt
    | H : is_true (ZIT.gtb _ _) |- _ =>
        move: {H}(proj1 (ZIT.gtP _ _) H) => H; unfold ZIT.gt in H
    | |- is_true (~~ ZIT.gtb _ _) => apply (proj1 (gtb_false _ _)); unfold ZIT.gt
    | H : is_true (~~ ZIT.gtb _ _) |- _ =>
        move: {H}((proj1 (gtb_false _ _)) H) => H; unfold ZIT.gt in H
    | |- is_true (~~ ZIT.geb _ _) => apply (proj1 (geb_false _ _)); unfold ZIT.ge
    | |- is_true (ZIT.geb _ _) => apply (proj1 (ZIT.geP _ _)); unfold ZIT.ge
    | H : is_true (ZIT.geb _ _) |- _ =>
        move: {H}(proj1 (ZIT.geP _ _) H) => H; unfold ZIT.ge in H
    | H : is_true (~~ ZIT.geb _ _) |- _ =>
        move: {H}((proj1 (geb_false _ _)) H) => H; unfold ZIT.ge in H
    | |- is_true (ZIT.eqb _ _) => apply/ZIT.eqP
    | H : is_true (ZIT.eqb _ _) |- _ => move/ZIT.tP : H => H

    | H : context [ZIT.add _ _] |- _ => unfold ZIT.add in H
    | H : context [ZIT.sub _ _] |- _ => unfold ZIT.sub in H
    | H : context [ZIT.mul _ _] |- _ => unfold ZIT.mul in H
    | H : context [ZIT.gt _ _] |- _ => unfold ZIT.gt in H
    | H : context [ZIT.ge _ _] |- _ => unfold ZIT.ge in H
    | H : context [ZIT.of_nat _] |- _ => unfold ZIT.of_nat in H
  end.

Ltac open_integral_type_goal :=
  match goal with
    | |- _ => unfold ZIT.add, ZIT.sub, ZIT.mul, ZIT.gt, ZIT.ge, ZIT.of_nat, ZIT.geb, ZIT.gtb, ZIT.eqb
  end.

Lemma ZIT_ring_theory : @ring_theory ZIT.t Z0 1%Z Zplus Zmult Zminus Z.opp (@eq _).
Proof.
constructor.
exact add0Z.
exact addZC.
exact addZA.
exact mul1Z.
exact mulZC.
exact mulZA.
exact mulZDl.
move=> x [] //.
move=> x.
exact: addZN.
Qed.

Add Ring ZIT_ring : ZIT_ring_theory.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This module proves the constructive description schema, which
infers the sigma-existence (i.e., [Set]-existence) of a witness to a
predicate from the regular existence (i.e., [Prop]-existence). One
requires that the underlying set is countable and that the predicate
is decidable. *)

(** Coq does not allow case analysis on sort [Prop] when the goal is in
[Set]. Therefore, one cannot eliminate [exists n, P n] in order to
show [{n : nat | P n}]. However, one can perform a recursion on an
inductive predicate in sort [Prop] so that the returning type of the
recursion is in [Set]. This trick is described in Coq'Art book, Sect.
14.2.3 and 15.4. In particular, this trick is used in the proof of
[Fix_F] in the module Coq.Init.Wf. There, recursion is done on an
inductive predicate [Acc] and the resulting type is in [Type].

To find a witness of [P] constructively, we program the well-known
linear search algorithm that tries P on all natural numbers starting
from 0 and going up.  Such an algorithm needs a suitable termination
certificate.  We offer two ways for providing this termination
certificate: a direct one, based on an ad-hoc predicate called
[before_witness], and another one based on the predicate [Acc].
For the first one we provide explicit and short proof terms. *)

(** Based on ideas from Benjamin Werner and Jean-François Monin *)

(** Contributed by Yevgeniy Makarov and Jean-François Monin *)

(* -------------------------------------------------------------------- *)

(* Direct version *)

Section ConstructiveIndefiniteDescription_Direct.

Variable P : nat -> Prop.

Hypothesis P_dec : forall n, {P n}+{~(P n)}.

(** The termination argument is [before_witness n], which says that
any number before any witness (not necessarily the [x] of [exists x :A, P x])
makes the search eventually stops. *)

Inductive before_witness : nat -> Prop :=
  | stop : forall n, P n -> before_witness n
  | next : forall n, before_witness (S n) -> before_witness n.

(* Computation of the initial termination certificate *)
Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 :=
  match n return (before_witness n -> before_witness 0) with
    | 0 => fun b => b
    | S n => fun b => O_witness n (next n b)
  end.

(* Inversion of [inv_before_witness n] in a way such that the result
is structurally smaller even in the [stop] case. *)
Definition inv_before_witness :
  forall n, before_witness n -> ~(P n) -> before_witness (S n) :=
  fun n b =>
    match b in before_witness n return ~ P n -> before_witness (S n) with
      | stop n p => fun not_p => match (not_p p) with end
      | next n b => fun _ => b
    end.

Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} :=
  match P_dec m with
    | left yes => exist (fun n => P n) m yes
    | right no => linear_search (S m) (inv_before_witness m b no)
  end.

Definition constructive_indefinite_description_nat :
  (exists n, P n) -> {n:nat | P n} :=
  fun e => linear_search O (let (n, p) := e in O_witness n (stop n p)).

End ConstructiveIndefiniteDescription_Direct.

(************************************************************************)

(* Version using the predicate [Acc] *)

Require Import Arith.

Section ConstructiveIndefiniteDescription_Acc.

Variable P : nat -> Prop.

Hypothesis P_decidable : forall n : nat, {P n} + {~ P n}.

(** The predicate [Acc] delineates elements that are accessible via a
given relation [R]. An element is accessible if there are no infinite
[R]-descending chains starting from it.

To use [Fix_F], we define a relation R and prove that if [exists n, P n]
then 0 is accessible with respect to R. Then, by induction on the
definition of [Acc R 0], we show [{n : nat | P n}].

The relation [R] describes the connection between the two successive
numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after
[x], i.e., [y = S x] and [P x] is false. Then the absence of an
infinite [R]-descending chain from 0 is equivalent to the termination
of our searching algorithm. *)

Let R (x y : nat) : Prop := x = S y /\ ~ P y.

Notation Local acc x := (Acc R x).

Lemma P_implies_acc : forall x : nat, P x -> acc x.
Proof.
intros x H. constructor.
intros y [_ not_Px]. absurd (P x); assumption.
Qed.

Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x.
Proof.
intros x n; generalize x; clear x; induction n as [|n IH]; simpl.
apply P_implies_acc.
intros x H. constructor. intros y [fxy _].
apply IH. rewrite fxy.
replace (n + S x) with (S (n + x)); auto with arith.
Defined.

Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0.
Proof.
intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x).
replace (x + 0) with x; auto with arith.
Defined.

(** In the following statement, we use the trick with recursion on
[Acc]. This is also where decidability of [P] is used. *)

Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}.
Proof.
intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption].
clear Acc_0; intros x IH.
destruct (P_decidable x) as [Px | not_Px].
exists x; simpl; assumption.
set (y := S x).
assert (Ryx : R y x). unfold R; split; auto.
destruct (IH y Ryx) as [n Hn].
exists n; assumption.
Defined.

Theorem constructive_indefinite_description_nat_Acc :
  (exists n : nat, P n) -> {n : nat | P n}.
Proof.
intros H; apply acc_implies_P_eventually.
apply P_eventually_implies_acc_ex; assumption.
Defined.

End ConstructiveIndefiniteDescription_Acc.

(************************************************************************)

Section ConstructiveEpsilon_nat.

Variable P : nat -> Prop.

Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}.

Definition constructive_epsilon_nat (E : exists n : nat, P n) : nat
  := proj1_sig (constructive_indefinite_description_nat P P_decidable E).

Definition constructive_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_epsilon_nat E)
  := proj2_sig (constructive_indefinite_description_nat P P_decidable E).

End ConstructiveEpsilon_nat.

(************************************************************************)

Section ConstructiveEpsilon.

(** For the current purpose, we say that a set [A] is countable if
there are functions [f : A -> nat] and [g : nat -> A] such that [g] is
a left inverse of [f]. *)

Variable A : Set.
Variable f : A -> nat.
Variable g : nat -> A.

Hypothesis gof_eq_id : forall x : A, g (f x) = x.

Variable P : A -> Prop.

Hypothesis P_decidable : forall x : A, {P x} + {~ P x}.

Definition P' (x : nat) : Prop := P (g x).

Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}.
Proof.
intro n; unfold P'; destruct (P_decidable (g n)); auto.
Defined.

Lemma constructive_indefinite_description : (exists x : A, P x) -> {x : A | P x}.
Proof.
intro H. assert (H1 : exists n : nat, P' n).
destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption.
apply (constructive_indefinite_description_nat P' P'_decidable)  in H1.
destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption.
Defined.

Lemma constructive_definite_description : (exists! x : A, P x) -> {x : A | P x}.
Proof.
  intros; apply constructive_indefinite_description; firstorder.
Defined.

Definition constructive_epsilon (E : exists x : A, P x) : A
  := proj1_sig (constructive_indefinite_description E).

Definition constructive_epsilon_spec (E : (exists x, P x)) : P (constructive_epsilon E)
  := proj2_sig (constructive_indefinite_description E).

End ConstructiveEpsilon.


(** * Complement and fix to SSRefect/MathComp *)
(******************************************************************************)
(*      Copyright (C) 2021      Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq ssrnat.
From mathcomp Require Import choice fintype finset fingroup bigop.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section ImsetFix.

Variables aT aT2 rT : finType.
Implicit Types (f g : aT -> rT) (D : {pred aT}) (R : {pred rT}).

Lemma eq_preimset f g R : f =1 g -> f @^-1: R = g @^-1: R.
Proof. by move=> eqfg; apply/setP => y; rewrite !inE eqfg. Qed.

Lemma eq_imset f g D : f =1 g -> f @: D = g @: D.
Proof.
move=> eqfg; apply/setP=> y.
by apply/imsetP/imsetP=> [] [x Dx ->]; exists x; rewrite ?eqfg.
Qed.

Lemma eq_in_imset f g D : {in D, f =1 g} -> f @: D = g @: D.
Proof.
move=> eqfg; apply/setP => y.
by apply/imsetP/imsetP=> [] [x Dx ->]; exists x; rewrite ?eqfg.
Qed.

Lemma eq_in_imset2 (f g : aT -> aT2 -> rT) (D : {pred aT}) (D2 : {pred aT2}) :
  {in D & D2, f =2 g} -> f @2: (D, D2) = g @2: (D, D2).
Proof.
move=> eqfg; apply/setP => y.
by apply/imset2P/imset2P=> [] [x x2 Dx Dx2 ->]; exists x x2; rewrite ?eqfg.
Qed.

End ImsetFix.

Section GroupCompl.

Import GroupScope.

Variables (gT : finGroupType).
Implicit Types (x y z : gT).

Lemma inv_sq1 x : x * x = 1 -> x^-1 = x.
Proof. by move=> /(congr1 (mulg^~ x^-1)); rewrite mulgK mul1g => {2}->. Qed.

Lemma conjgg x : x ^ x = x.
Proof. by rewrite conjgE mulKg. Qed.

Lemma eq_conjg x y z : (x == y ^ z) = (x ^ (z ^-1) == y).
Proof. by rewrite -(inj_eq (conjg_inj z ^-1)) -conjgM mulgV conjg1. Qed.

Lemma iter_mulg n x : iter n (mulg x) 1 = x ^+ n.
Proof. by rewrite /expgn /expgn_rec Monoid.iteropE /=. Qed.

Lemma prodgV I r (P : pred I) (F : I -> gT) :
  (\prod_(i <- r | P i) F i) ^-1 = \prod_(i <- rev r | P i) (F i)^-1.
Proof.
elim: r => [| r i IHr]; first by rewrite !big_nil invg1.
rewrite big_cons rev_cons -cats1 big_cat big_cons big_nil /= mulg1.
rewrite -{}IHr -{4}invg1 -fun_if -invMg.
by case: (P r); last by rewrite mul1g.
Qed.

End GroupCompl.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Set Firstorder Depth 5.

Require Import Coq.Setoids.Setoid.
Require Export CoRN.order.Lattice.

Local Open Scope po_scope.
(**
* Total Order
A total order is a lattice were x <= y or y <= x.
*)
Record TotalOrder : Type :=
{ L :> Lattice
; le_total : forall x y:L, {x <= y}+{y <= x}
}.

Section MinMax.

Variable X : TotalOrder.
(** meet x y is either x or y. *)
Definition meet_irred : forall x y : X, {meet x y == x} + {meet x y == y}.
Proof.
 intros.
 destruct (le_total _ x y) as [H|H].
  left.
  firstorder using le_meet_l.
 right.
 firstorder using le_meet_r.
Defined.

Section Monotone.

Variable f : X -> X.
Hypothesis Hf : monotone X f.

Add Morphism f with signature (@st_eq X) ==> (@st_eq X)  as monotone_compat.
Proof.
  revert Hf;rewrite -> monotone_def;intros Hf ??.
  do 2 rewrite -> equiv_le_def.
  firstorder.
Qed.

(** meet distributes over any monotone function. *)
Lemma monotone_meet_distr : forall x y : X, f (meet x y) == meet (f x) (f y).
Proof.
 set (Hf':=Hf). (* The section hypothesis is used in monotone_compat and hence cannot be changed. *)
 rewrite -> monotone_def in Hf'.
 assert (forall x y : X, x <= y -> f (meet x y) == meet (f x) (f y)).
  intros x y Hxy.
  assert (Hfxfy:=Hf' _ _ Hxy).
   rewrite -> le_meet_l in Hxy.
   rewrite -> le_meet_l in Hfxfy.
   rewrite -> Hfxfy.
   rewrite -> Hxy.
  reflexivity.
 intros.
 destruct (le_total _ x y).
  auto.
 rewrite -> (meet_comm X).
 rewrite -> (meet_comm _ (f x)).
 auto.
Qed.

End Monotone.

(** join distributes over meet *)
Lemma join_meet_distr_r : forall x y z:X, (join x (meet y z))==(meet (join x y) (join x z)).
Proof (fun a => monotone_meet_distr _ (join_monotone_r X a)).

Lemma join_meet_distr_l : forall x y z:X, (join (meet y z) x)==(meet (join y x) (join z x)).
Proof (fun a => monotone_meet_distr _ (join_monotone_l X a)).

Section Antitone.

Variable f : X -> X.
Hypothesis Hf : antitone X f.

(* begin hide *)
Add Parametric Morphism: f with signature (@st_eq X) ==> (@st_eq X) as antitone_compat.
Proof.
 revert Hf; rewrite -> antitone_def; intros.
 rewrite -> equiv_le_def in *.
 firstorder.
Qed.
(* end hide *)

(* meet transforms into join for antitone functions *)
Lemma antitone_meet_join_distr : forall x y : X, f (meet x y) == join (f x) (f y).
Proof.
 pose (Hf':=Hf).
 rewrite antitone_def in Hf'.
 assert (forall x y : X, x <= y -> f (meet x y) == join (f x) (f y)).
  intros x y Hxy.
  assert (Hfxfy:=Hf' _ _ Hxy).
  rewrite -> le_meet_l in Hxy.
  rewrite -> le_join_l in Hfxfy.
  rewrite -> Hfxfy. clear Hfxfy.
  apply antitone_compat. rewrite -> Hxy. reflexivity.
 intros.
 destruct (le_total _ x y).
  auto.
 rewrite -> (meet_comm X).
 rewrite -> (join_comm X).
 auto.
Qed.

End Antitone.

(** Lemmas of distributive lattices *)
Lemma join_meet_modular_r : forall x y z : X, join x (meet y (join x z)) == meet (join x y) (join x z).
Proof.
 intros.
 rewrite -> join_meet_distr_r.
 rewrite -> (join_assoc X).
 rewrite -> (join_idem X).
 reflexivity.
Qed.

Lemma join_meet_modular_l : forall x y z : X, join (meet (join x z) y) z == meet (join x z) (join y z).
Proof.
 intros.
 rewrite -> (join_comm X (meet (join x z) y) z).
 rewrite -> (meet_comm X (join x z) y).
 rewrite -> (meet_comm X (join x z) (join y z)).
 rewrite -> (join_comm X x z).
 rewrite -> (join_comm X y z).
 apply join_meet_modular_r.
Qed.

Lemma meet_join_disassoc : forall x y z : X, meet (join x y) z <= join x (meet y z).
Proof.
 intros.
 rewrite -> join_meet_distr_r.
 apply meet_le_compat.
  apply le_refl.
 apply join_ub_r.
Qed.

End MinMax.

Section MaxMin.

Variable X : TotalOrder.
(**
** Dual Total Order
The dual of a total order is a total order.
*)
Definition Dual : TotalOrder.
 eapply Build_TotalOrder with (L:= Dual X).
Proof.
 intros.
 destruct (le_total _ x y); auto.
Defined.
(** The duals of the previous lemmas hold. *)
Definition join_irred : forall x y : X, {join x y == x} + {join x y == y} :=
meet_irred Dual.

Lemma monotone_join_distr : forall f, monotone X f -> forall x y : X, f (join x y) == join (f x) (f y).
Proof monotone_meet_distr Dual.

Lemma meet_join_distr_r : forall x y z:X, (meet x (join y z))==(join (meet x y) (meet x z)).
Proof join_meet_distr_r Dual.

Lemma meet_join_distr_l : forall x y z:X, (meet (join y z) x)==(join (meet y x) (meet z x)).
Proof join_meet_distr_l Dual.

Lemma antitone_join_meet_distr : forall f, antitone X f -> forall x y : X, f (join x y) == meet (f x) (f y).
Proof antitone_meet_join_distr Dual.

Lemma meet_join_modular_r : forall x y z : X, meet x (join y (meet x z)) == join (meet x y) (meet x z).
Proof join_meet_modular_r Dual.

Lemma meet_join_modular_l : forall x y z : X, meet (join (meet x z) y) z == join (meet x z) (meet y z).
Proof join_meet_modular_l Dual.

End MaxMin.

Section TotalOrderMinDef.

Variable X : PartialOrder.
(** Given a total order, meet and join can be characterized in terms of
the order.*)
Variable min : X -> X -> X.
Hypothesis le_total : forall x y:X, {x <= y}+{y <= x}.
Hypothesis min_def1 : forall x y:X, x <= y -> min x y == x.
Hypothesis min_def2 : forall x y:X, y <= x -> min x y == y.

Lemma min_lb_l : forall x y:X, min x y <= x.
Proof.
 intros.
 destruct (le_total x y).
  rewrite -> min_def1; auto.
  apply le_refl.
 rewrite -> min_def2; auto.
Qed.

Lemma min_lb_r : forall x y:X, min x y <= y.
Proof.
 intros.
 destruct (le_total x y).
  rewrite -> min_def1; auto.
 rewrite -> min_def2; auto.
 apply le_refl.
Qed.

Lemma min_glb : forall x y z, z <= x -> z <= y -> z <= min x y.
Proof.
 intros.
 destruct (le_total x y).
  rewrite -> min_def1; assumption.
 rewrite -> min_def2; assumption.
Qed.

End TotalOrderMinDef.

(** With a total order has a new characterization. *)
Definition makeTotalOrder :
 forall (A : Type) (equiv : A -> A -> Prop) (le : A -> A -> Prop)
  (monotone antitone : (A -> A) -> Prop)
  (meet join : A -> A -> A),
  (forall x y : A, equiv x y <-> (le x y /\ le y x)) ->
  (forall x : A, le x x) ->
  (forall x y z : A, le x y -> le y z -> le x z) ->
  (forall x y : A, {le x y} + {le y x}) ->
  (forall f, monotone f <-> (forall x y, le x y -> le (f x) (f y))) ->
  (forall f, antitone f <-> (forall x y, le x y -> le (f y) (f x))) ->
  (forall x y : A, le x y -> equiv (meet x y) x) ->
  (forall x y : A, le y x -> equiv (meet x y) y) ->
  (forall x y : A, le y x -> equiv (join x y) x) ->
  (forall x y : A, le x y -> equiv (join x y) y) ->
  TotalOrder.
Proof.
 intros A0 eq0 le0 monotone0 antitone0 min max eq0_def refl trans total monotone0_def antitone0_def min_def1 min_def2 max_def1 max_def2.
 pose (PO:=makePartialOrder eq0 le0 monotone0 antitone0 eq0_def refl trans monotone0_def antitone0_def).
 pose (DPO := (PartialOrder.Dual PO)).
 pose (flip_total := fun x y => total y x).
 pose (L0:=makeLattice PO min max (min_lb_l PO min total min_def1 min_def2)
   (min_lb_r PO min total min_def1 min_def2) (min_glb PO min total min_def1 min_def2)
     (min_lb_l DPO max flip_total max_def1 max_def2) (min_lb_r DPO max flip_total max_def1 max_def2)
       (min_glb DPO max flip_total max_def1 max_def2)).
 exact (Build_TotalOrder L0 total).
Defined.

Module Default.
(**
** Default meet and join.
*)
Section MinDefault.
Variable A : Type.
Variable equiv: A -> A -> Prop.
Variable le : A -> A -> Prop.
Hypothesis equiv_le_def : forall x y : A, equiv x y <-> (le x y /\ le y x).
Hypothesis le_total : forall x y:A, {le x y}+{le y x}.

(** Given a total order, meet and join have a default implemenation. *)
Definition min (x y:A) :=
 if (le_total x y) then x else y.

Definition min_case x y (P:A -> Type) (Hx : le x y -> P x) (Hy : le y x -> P y) : P (min x y) :=
match (le_total x y) as s return P (if s then x else y) with
| left p => Hx p
| right p => Hy p
end.

Lemma min_def1 : forall x y, le x y -> equiv (min x y) x.
Proof.
 intros.
 apply min_case; firstorder auto.
Qed.

Lemma min_def2 : forall x y, le y x -> equiv (min x y) y.
Proof.
 intros.
 apply min_case; firstorder auto.
Qed.

End MinDefault.

Section MaxDefault.
Variable A : Type.
Variable equiv: A -> A -> Prop.
Variable le : A -> A -> Prop.
Hypothesis equiv_le_def : forall x y : A, equiv x y <-> (le x y /\ le y x).
Hypothesis le_total : forall x y:A, {le x y}+{le y x}.

Definition max (x y:A) :=
 if le_total y x then x else y.

Let flip_le x y := le y x.
Let flip_le_total x y := le_total y x.

Definition max_case :
 forall x y (P : A -> Type), (le y x -> P x) -> (le x y -> P y) -> P (max x y) :=
 min_case A flip_le flip_le_total.

Lemma max_def1 : forall x y, le y x -> equiv (max x y) x.
Proof.
 refine (min_def1 A equiv flip_le _ flip_le_total).
 firstorder auto.
Qed.

Lemma max_def2 : forall x y, le x y -> equiv (max x y) y.
Proof.
 refine (min_def2 A equiv flip_le _ flip_le_total).
 firstorder auto.
Qed.

End MaxDefault.

End Default.


Require Import Lia.
Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Sets.Ensembles.
From mathcomp Require Import all_ssreflect.

From Usuba Require Import usuba_AST.

Definition IntSize : Type := nat.
Definition IntSize_beq := Nat.eqb.

Definition IntSize_of_nat (n : nat) : option IntSize := Some n.

Inductive dir :=
    | DirH of IntSize
    | DirV of IntSize
    | DirB.
Scheme Equality for dir.

Inductive cst_or_int :=
    | CoIL : nat -> cst_or_int
    | CoIR : dir -> list nat -> option (list nat) -> cst_or_int.
Scheme Equality for option.
Scheme Equality for list.

Definition Value := list cst_or_int.

Record architecture : Type := {
    ARCH_ADD : dir -> option (nat -> nat -> nat);
    ARCH_SUB : dir -> option (nat -> nat -> nat);
    ARCH_DIV : dir -> option (nat -> nat -> nat);
    ARCH_MOD : dir -> option (nat -> nat -> nat);
    ARCH_MUL : dir -> option (nat -> nat -> nat);

    ARCH_NOT : dir -> option (nat -> nat);
    ARCH_AND : dir -> option (nat -> nat -> nat);
    ARCH_OR  : dir -> option (nat -> nat -> nat);
    ARCH_XOR : dir -> option (nat -> nat -> nat);
    ARCH_ANDN : dir -> option (nat -> nat -> nat);

    ARCH_LSHIFT : nat -> dir -> option (nat -> nat);
    ARCH_RSHIFT  : nat -> dir -> option (nat -> nat);
    ARCH_RASHIFT : nat -> dir -> option (nat -> nat);
    ARCH_LROTATE : nat -> dir -> option (nat -> nat);
    ARCH_RROTATE : nat -> dir -> option (nat -> nat);
}.

Definition context : Type := list (ident * cst_or_int).

Fixpoint find_val {A : Type} (ctxt : list (ident * A)) (i : ident) : option A :=
    match ctxt  with
        | nil => None
        | ((name, val)::tl) =>
            if String.eqb i name
            then Some val
            else find_val tl i
    end.

Fixpoint find_const (ctxt : context) (var : ident) : option nat :=
    match ctxt  with
        | nil => None
        | ((name, v)::tl) =>
            if String.eqb var name
            then match v with
                | CoIL i => Some i
                | _ => None
                end
            else find_const tl var
    end.

Fixpoint list_map2 {A B C : Type} (op : A -> B -> C) (l1 : list A) (l2 : list B) : option (list C) :=
    match l1, l2 with
    | nil, nil => Some nil
    | h1::t1, h2::t2 =>
        tl <- list_map2 op t1 t2;
        Some (op h1 h2::tl)
    | _, _ => None
    end.

Definition eval_binop_coi (binop : dir -> option (nat -> nat -> nat)) (v1 v2 : cst_or_int) : option cst_or_int :=
    match v1 with
    | CoIL i => None
    | CoIR d1 i1 l1 =>
        match v2 with
        | CoIL i2 => None
        | CoIR d2 i2 l2 =>
            if dir_beq d1 d2
            then
                op <- binop d1;
                l <- list_map2 op i1 i2;
                Some (CoIR d1 l None)
            else None
        end
    end.

Fixpoint eval_binop (binop : dir -> option (nat -> nat -> nat)) (l1 l2 : list cst_or_int) : option (list cst_or_int) :=
    match l1 with
    | nil => match l2 with
        | nil => Some nil
        | _::_ => None
        end
    | h1::tl1 => match l2 with
        | nil => None
        | h2::tl2 =>
            hd <- eval_binop_coi binop h1 h2;
            tl <- eval_binop binop tl1 tl2;
            Some (hd :: tl)
        end
    end.

Definition eval_monop_coi (monop : dir -> option (nat -> nat)) (v : cst_or_int) : option cst_or_int :=
    match v with
    | CoIL _ => None
    | CoIR d i l =>
        op <- monop d;
        Some (CoIR d (map op i) l)
    end.

Fixpoint eval_monop (monop : dir -> option (nat -> nat)) (v : list cst_or_int) : option (list cst_or_int) :=
    match v with
    | nil => Some nil
    | hd::tl =>
        hd' <- eval_monop_coi monop hd;
        tl' <- eval_monop monop tl;
        Some (hd' :: tl')
    end.

(* Fixpoint repeat_value (nb : nat) (zero : Value) : list_Value :=
    match nb with
    | 0 => lV_nil
    | S nb' => lV_cons zero (repeat_value nb' zero)
    end. *)

(* Function zero_from_val (v : Value) : Value :=
    match v with
    | VConst n => VConst 0
    | VInt d n l => VInt d (map (fun _ => 0) n) l
    | VTuple l => VTuple (zero_from_valL l)
    end
with zero_from_valL l :=
    match l with
    | lV_nil => lV_nil
    | lV_cons hd tl => lV_cons (zero_from_val hd) (zero_from_valL tl)
    end. *)

(* Definition zero_from (t : list_Value) : option Value :=
    match t with
    | lV_nil => None
    | lV_cons hd _ => Some (zero_from_val hd)
    end. *)

Fixpoint take_n {A : Type} (nb : nat) (l : list A) : option (list A * list A) :=
    match nb with
    | 0 => Some (nil, l)
    | S nb' => match l with
        | nil => None
        | hd :: tl =>
            (s, e) <- take_n nb' tl;
            Some (hd :: s, e)
        end
    end.

Definition eval_shift (op : shift_op) (arch : architecture) (v : list cst_or_int) (v2 : nat) : option (list cst_or_int) :=
    match v with
    | CoIR d (i::nil) len::nil =>
        f <- match op with
            | Lshift => ARCH_LSHIFT arch v2 d
            | Rshift => ARCH_RSHIFT arch v2 d
            | RAshift => ARCH_RASHIFT arch v2 d
            | Lrotate => ARCH_LROTATE arch v2 d
            | Rrotate => ARCH_RROTATE arch v2 d
            end;
        Some (CoIR d (f i::nil) len::nil)
    | CoIR d i len::nil => match op with
        | Lshift =>
            (hd, tl) <- take_n v2 i;
            Some (CoIR d (app tl (map (fun => 0) hd)) len::nil)
        | _ => None
        end
    | _ => None
    end.

Fixpoint eval_arith_expr (ctxt : context) (e : arith_expr) : option nat :=
    match e with
        | Const_e i => Some i
        | Var_e var => find_const ctxt var
        | Op_e op e1 e2 =>
            v1 <- eval_arith_expr ctxt e1;
            v2 <- eval_arith_expr ctxt e2;
            match op with
                | Add => Some (v1 + v2)
                | Mul => Some (v1 * v2)
                | Sub => Some (v1 - v2)
                | Mod => Some (v1 mod v2)
                | Div => some (v1 / v2)
            end
    end.

Inductive access : Type :=
    | AAll : access
    | ASlice : list nat -> access -> access.

Fixpoint split_into_segments {A : Type} (nb_segments segment_size : nat) (l : list A) : option (list (list A)) :=
    match nb_segments with
    | 0 => match l with
        | nil => Some nil
        | _ => None
        end
    | S nb_segments' =>
        (hd, tl) <- take_n segment_size l;
        tl' <- split_into_segments nb_segments' segment_size tl;
        Some (hd::tl')
    end.

(** We assert that `length values = prod_list dim` *)
Fixpoint get_access (values : list nat) (acc : access) (dim : list nat) : option (list nat) :=
    match dim with
    | nil =>
        match values with
        | n::nil =>
            match acc with
            | AAll => Some values
            | ASlice indices tl =>
                if forallb (fun x => x =? 0) indices
                then
                    l <- get_access values tl nil;
                    Some (flat_map (fun _ => l) indices)
                else
                    None
            end
        | _ => None (** Assertion not verified *)
        end
    | d::dim_tl =>
        if length values mod d =? 0
        then
            l' <- split_into_segments d (length values / d) values;
            match acc with
            | AAll => Some values
            | ASlice indices acc_tl =>
                fold_right (fun v l => l' <- l; v' <- v; v'' <- get_access v' acc_tl dim_tl; Some (v'' ++ l'))
                                (Some nil) (map (fun i => nth_error l' i) indices)
            end
        else None (** Assertion not verified *)
    end.

Fixpoint gen_range_incr (i1 i2 : nat) : list nat :=
    if i1 <? i2
    then nil
    else
        match i2 with
        | 0 => nil
        | S i2' => gen_range_incr i1 i2'
        end ++ i2::nil.

Fixpoint gen_range_decr (i1 i2 : nat) : list nat :=
    if i1 <? i2
    then nil
    else
        i1::match i1 with
        | 0 => nil
        | S i1' => gen_range_decr i1' i2
        end.

Definition gen_range (i1 i2 : nat) : list nat :=
    if i1 <=? i2
    then gen_range_incr i1 i2
    else gen_range_decr i1 i2.

Fixpoint eval_var (ctxt : context) (v : var) (acc : access) : option (list cst_or_int) :=
    match v with
    | Var v =>
        val <- find_val ctxt v;
        match val, acc with
        | CoIR _ _ None, _ => None
        | CoIL cst, _ =>
            iL' <- get_access (cst::nil) acc nil;
            Some (map CoIL iL')
        | CoIR dir iL (Some dim), _ =>
            iL' <- get_access iL acc dim;
            Some ((CoIR dir iL' None)::nil)
        end
    | Index v ae =>
        i <- eval_arith_expr ctxt ae;
        eval_var ctxt v (ASlice [:: i] acc)
    | Range v ae1 ae2 =>
        i1 <- eval_arith_expr ctxt ae1;
        i2 <- eval_arith_expr ctxt ae2;
        eval_var ctxt v (ASlice (gen_range i1 i2) acc)
    | Slice v ael =>
        il <- fold_right (fun ae l =>
            l' <- l; i <- eval_arith_expr ctxt ae; Some (i::l')) (Some nil) ael;
        eval_var ctxt v (ASlice il acc)
    end.

Function loop_rec (ctxt : context) (iter : context -> option context) i (s_i e_i : nat) : option context :=
    match e_i with
    | 0 => Some ctxt
    | S e_i' =>
        if (Nat.leb e_i s_i)
        then Some ctxt
        else
            ctxt' <- loop_rec ctxt iter i s_i e_i';
            iter ((i, CoIL e_i')::ctxt')
    end.

Fixpoint replace_id {A : Type} (i : nat) (l : list A) (v : A) : option (list A) :=
    match l with
    | nil => None
    | hd :: tl => match i with
        | 0 => Some (v :: tl)
        | S i' =>
            tl' <- replace_id i' tl v;
            Some (hd :: tl')
        end
    end.

Definition type_ctxt : Type := list (ident * typ).

Definition node_sem_type := option nat -> list cst_or_int -> option (list cst_or_int).
Definition prog_ctxt := list (ident * node_sem_type).

Fixpoint get_node (prog : prog_ctxt) (id : ident) : option node_sem_type :=
    match prog with
    | nil => None
    | (name, f) :: tl => if String.eqb name id
        then Some f
        else get_node tl id
    end.

Definition build_integer (typ : typ) (n : nat) : option (list cst_or_int) :=
    match typ with
    | Nat => Some (CoIL n::nil)
    | Uint Hslice (Mint size) 1 =>
        annot <- IntSize_of_nat size;
        Some (CoIR (DirH annot) (n::nil) (Some (1::nil))::nil)
    | Uint Vslice (Mint size) 1 =>
        annot <- IntSize_of_nat size;
        Some (CoIR (DirV annot) (n::nil) (Some (1::nil))::nil)
    | _ => None (* TODO *)
    end.

Function linearize_list_value (inL : list cst_or_int) (outL : list cst_or_int) : list cst_or_int :=
    match inL with
    | nil => outL
    | hd :: tl =>
        let outL := linearize_list_value tl outL in
        match hd with
        | CoIR d l a => match outL with
            | (CoIR d' l' a') :: tl =>
                if dir_beq d d'
                then (CoIR d (app l l') None) :: tl
                else hd :: outL
            | _ => hd :: outL
            end
        | CoIL n => (CoIL n) :: outL
        end
    end.

Fixpoint extract_ctxt (var_names : p) (ctxt : context) : option (list cst_or_int) :=
    match var_names with
    | nil => Some nil
    | v::tl =>
        val <- find_val ctxt (VD_ID v);
        tl <- extract_ctxt tl ctxt;
        Some (linearize_list_value (val::nil) tl)
    end.

Function eval_expr (arch : architecture) (prog : prog_ctxt) (ctxt : context) (e : expr) : option (list cst_or_int) :=
    match e with
        | Const n None => Some (CoIL n::nil)
        | Const n (Some typ) => build_integer typ n
        | ExpVar var => eval_var ctxt var AAll
        | Tuple el => eval_expr_list arch prog ctxt el
        | Not e =>
            v <- eval_expr arch prog ctxt e;
            eval_monop (ARCH_NOT arch) v
        | Log op e1 e2 =>
            v1 <- eval_expr arch prog ctxt e1;
            v2 <- eval_expr arch prog ctxt e2;
            f <- match op with
                | And | Masked And => Some (ARCH_AND arch)
                | Or | Masked Or => Some (ARCH_OR arch)
                | Xor | Masked Xor => Some (ARCH_XOR arch)
                | Andn | Masked Andn => Some (ARCH_ANDN arch)
                | Masked (Masked _) => None
            end;
            eval_binop f v1 v2
        | Arith op e1 e2 =>
            v1 <- eval_expr arch prog ctxt e1;
            v2 <- eval_expr arch prog ctxt e2;
            let f := match op with
                | Add => ARCH_ADD arch
                | Sub => ARCH_SUB arch
                | Div => ARCH_DIV arch
                | Mod => ARCH_MOD arch
                | Mul => ARCH_MUL arch
            end
            in eval_binop f v1 v2
        | Shift op e1 e2 =>
            v1 <- eval_expr arch prog ctxt e1;
            v2 <- eval_arith_expr ctxt e2;
            eval_shift op arch v1 v2
        | Shuffle v l => None
        | Bitmask e ae => None
        | Pack e1 e2 None => None
        | Pack e1 e2 (Some t) => None
        | Fun id el =>
            args <- eval_expr_list arch prog ctxt el;
            f <- find_val prog id;
            l_val <- f None args;
            Some (linearize_list_value l_val nil)
        | Fun_v id ie el =>
            args <- eval_expr_list arch prog ctxt el;
            i <- eval_arith_expr ctxt ie;
            f <- find_val prog id;
            l_val <- f (Some i) args;
            Some (linearize_list_value l_val nil)
    end
with eval_expr_list (arch : architecture) (prog : prog_ctxt) (ctxt : context) (el : expr_list) : option (list cst_or_int) :=
    match el with
    | Enil => Some nil
    | ECons e tl =>
        v <- eval_expr arch prog ctxt e;
        tl <- eval_expr_list arch prog ctxt tl;
        Some (linearize_list_value v tl)
    end.

Inductive int_or_list (A : Type) : Type :=
    | IoLL : nat -> int_or_list A
    | IoLR : list A -> int_or_list A.

Fixpoint try_take_n {A : Type} (nb : nat) (l : list A) : option ((list A) * int_or_list A) :=
    match nb with
    | 0 => Some (nil, IoLR A l)
    | S nb' => match l with
        | nil => Some (nil, IoLL A nb)
        | hd :: tl =>
            (s, e) <- try_take_n nb' tl;
            Some (hd :: s, e)
        end
    end.

Fixpoint build_ctxt_aux_take_n (nb : nat) (input : list cst_or_int) (d : dir) : option ((list nat) * list cst_or_int) :=
    match nb with
    | 0 => Some (nil, input)
    | S nb' => match input with
        | nil => None
        | (CoIL n)::in_tl =>
            (out, rest) <- build_ctxt_aux_take_n nb' in_tl d;
            Some (n::out, rest)
        | (CoIR d' iL _)::in_tl =>
            if dir_beq d d'
            then
                (hd, tl) <- try_take_n nb iL;
                match tl with
                | IoLR nil => Some (hd, in_tl)
                | IoLR tl => Some(hd, CoIR d' tl None::in_tl)
                | IoLL nb =>
                    (out, rest) <- build_ctxt_aux_take_n nb in_tl d;
                    Some (hd ++ out, rest)
                end
            else None
        end
    end.

Fixpoint prod_list (l : list nat) : nat :=
    match l with
    | nil => 1
    | hd::tl => hd * prod_list tl
    end.

Fixpoint build_ctxt_aux (typ : typ) (input : list cst_or_int) (l : list nat) : option (cst_or_int * list cst_or_int) :=
    match typ with
    | Nat => match input with
        | CoIL n :: input' => Some (CoIL n, input')
        | _ => None
        end
    | Uint d (Mint n) nb =>
        annot <- IntSize_of_nat n;
        d <- match d with
            | Hslice => Some (DirH annot)
            | Vslice => Some (DirV annot)
            | _ => None
        end;
        (valL, input') <- build_ctxt_aux_take_n (nb * prod_list l) input d;
        Some (CoIR d valL (Some (l ++ nb::nil)), input')
    | Uint _ Mnat nb => None
    | Uint _ (Mvar _) nb => None
    | Array typ len =>
        len <- eval_arith_expr nil len;
        build_ctxt_aux typ input (len::l)
    end.

Fixpoint build_ctxt (args : p) (input : list cst_or_int) : option context :=
    match args with
    | nil => match input with
        | nil => Some nil
        | _::_ => None
        end
    | var::tl =>
        (val, input') <- build_ctxt_aux (VD_TYP var) input nil;
        ctxt <- build_ctxt tl input';
        Some ((VD_ID var, val)::ctxt)
    end.

Fixpoint convert_type (typ : typ) (l : list nat) : option (dir * list nat) :=
    match typ with
    | Nat => None
    | Uint d (Mint n) nb =>
        annot <- IntSize_of_nat n;
        d <- match d with
            | Hslice => Some (DirH annot)
            | Vslice => Some (DirV annot)
            | _ => None
        end;
        Some (d, l ++ nb::nil)
    | Uint _ Mnat nb => None
    | Uint _ (Mvar _) nb => None
    | Array typ' len =>
        len' <- eval_arith_expr nil len;
        convert_type typ' (len'::l)
    end.

Fixpoint zeros (n : nat) : list nat :=
    match n with
    | 0 => nil
    | S n' => 0::zeros n'
    end.

Fixpoint update_ind {A : Type} (i : nat) (l : list A) (v : A) : option (list A) :=
    match l with
    | nil => None
    | hd::tl => match i with
        | 0 => Some (v::tl)
        | S i' =>
            tl' <- update_ind i' tl v;
            Some (hd::tl')
        end
    end.

(* We assert that `prod_list form = length val` *)
Fixpoint update (form : list nat) (val : list nat) (acc : access) (e : list cst_or_int) (dir : dir) : option (list nat * list cst_or_int) :=
    match form with
    | nil => match acc with
        | AAll =>
            build_ctxt_aux_take_n (length val) e dir
        | _ => None
        end
    | form_hd::form_tl =>
        if length val mod form_hd =? 0
        then
            val' <- split_into_segments form_hd (prod_list form_tl) val;
            match acc with
            | AAll => build_ctxt_aux_take_n (length val) e dir
            | ASlice iL acc_tl =>
                (val'', e') <- fold_left (fun state i =>
                                    (val', e) <- state;
                                    subl <- nth_error val' i;
                                    (subl', e') <- update form_tl subl acc_tl e dir;
                                    val'' <- update_ind i val' subl';
                                    Some (val'', e')) iL (Some (val', e));
                Some (concat val'', e')
            end
        else None
    end.

Fixpoint bind_aux (ctxt : context) (type_ctxt : type_ctxt) (v : var) (acc : access) (e : list cst_or_int) : option (context * list cst_or_int) :=
    match v with
    | Var v =>
        typ <- find_val type_ctxt v;
        (dir, form) <- convert_type typ nil;
        let val_init := match find_val ctxt v with
        | None => zeros (prod_list form)
        | Some (CoIL i) => i::nil
        | Some (CoIR _ iL _) => iL
        end in
        (val, e') <- update form val_init acc e dir;
        Some ((v, CoIR dir val (Some form))::ctxt, e')
    | Index v ae =>
        i <- eval_arith_expr ctxt ae;
        bind_aux ctxt type_ctxt v (ASlice [:: i] acc) e
    | Range v ae1 ae2 =>
        i1 <- eval_arith_expr ctxt ae1;
        i2 <- eval_arith_expr ctxt ae2;
        bind_aux ctxt type_ctxt v (ASlice (gen_range i1 i2) acc) e
    | Slice v ael =>
        il <- fold_right (fun ae l =>
        l' <- l; i <- eval_arith_expr ctxt ae; Some (i::l')) (Some nil) ael;
        bind_aux ctxt type_ctxt v (ASlice il acc) e
    end.

Fixpoint bind_aux_list ctxt type_ctxt (vl : list var) (el : list cst_or_int) : option (context * list cst_or_int) :=
    match vl with
    | nil => match el with
        | nil => Some (ctxt, el)
        | _ => None
        end
    | v :: vl' =>
        (ctxt', el') <- bind_aux ctxt type_ctxt v AAll el;
        bind_aux_list ctxt' type_ctxt vl' el'
    end.

Definition bind ctxt type_ctxt (vl : list var) (el : list cst_or_int) : option context :=
    match bind_aux_list ctxt type_ctxt vl el with
    | Some (ctxt', nil) => Some ctxt'
    | _ => None
    end.

Function eval_deq (arch : architecture) (prog : prog_ctxt) (type_ctxt : type_ctxt) (ctxt : context) (d : deq) : option context :=
    match d with
    | Eqn v e b =>
        e <- eval_expr arch prog ctxt e;
        bind ctxt type_ctxt v e
    | Loop i start_e end_e d2 opt =>
        start_i <- eval_arith_expr ctxt start_e;
        end_i <- eval_arith_expr ctxt end_e;
        ctxt' <- loop_rec ctxt (fun ctxt => eval_deq_list arch prog type_ctxt ctxt d2) i start_i end_i;
        match find_val ctxt i with
        | None => Some ctxt'
        | Some v => Some ((i, v)::ctxt')
        end
    end
with eval_deq_list (arch : architecture) (prog : prog_ctxt) (type_ctxt : type_ctxt) (ctxt : context) (dl : list_deq) : option context :=
    match dl with
    | Dnil => Some ctxt
    | Dcons d dl' =>
        ctxt' <- eval_deq arch prog type_ctxt ctxt d;
        eval_deq_list arch prog type_ctxt ctxt' dl'
    end.

Fixpoint build_type_ctxt (l : p) : type_ctxt :=
    match l with
    | nil => nil
    | hd::tl => (VD_ID hd, VD_TYP hd) :: build_type_ctxt tl
    end.

Fixpoint eval_node_inner (arch : architecture) (prog : prog_ctxt) (in_names out_names : p) (def : def_i) (i : option nat) (input : list cst_or_int) : option (list cst_or_int) :=
    match def, i with
    | Single temp_vars eqns, None =>
        ctxt <- build_ctxt in_names input;
        ctxt' <- eval_deq_list arch prog (build_type_ctxt (temp_vars ++ in_names ++ out_names)) ctxt eqns;
        extract_ctxt out_names ctxt'
    | Table l, None => match input with
        | (CoIL i)::nil | CoIR _ (i::nil) _::nil =>
            i' <- nth_error l i;
            Some (CoIL i'::nil)
        | _ => None
        end
    | Perm l, None => None
    | Multiple l, Some i =>
        eval_node_list arch prog in_names out_names l i input
    | _, _ => None
    end
with eval_node_list arch prog in_names out_names l i input :=
    match l with
    | LDnil => None
    | LDcons hd tl => match i with
        | 0 => eval_node_inner arch prog in_names out_names hd None input
        | S i' => eval_node_list arch prog in_names out_names tl i' input
        end
    end.

Definition eval_node (node : def) (arch : architecture) (prog : prog_ctxt) : node_sem_type :=
    fun opt input =>
        eval_node_inner arch prog (P_IN node) (P_OUT node) (NODE node) opt input.

Fixpoint eval_prog (arch : architecture) (fprog : prog) : prog_ctxt :=
    match fprog with
    | nil => nil
    | node::prog =>
        let tl := eval_prog arch prog in
        (ID node, eval_node node arch tl)::tl
    end.

(* Freevars *)

Fixpoint aexpr_freevars (e : arith_expr) : Ensemble ident :=
    match e with
    | Var_e i => Singleton ident i
    | Const_e _ => Empty_set ident
    | Op_e _ e1 e2 => Union ident (aexpr_freevars e1) (aexpr_freevars e2)
    end.

Fixpoint aexprl_freevars (e : list arith_expr) : Ensemble ident :=
    match e with
    | nil => Empty_set ident
    | h :: tl => Union ident (aexpr_freevars h) (aexprl_freevars tl)
    end.

Fixpoint typ_freevars (typ : typ) : Ensemble ident :=
    match typ with
    | Array typ' ae => Union ident (typ_freevars typ') (aexpr_freevars ae)
    | _ => Empty_set ident
    end.

Fixpoint var_freevars (v : var) : Ensemble ident :=
    match v with
    | Var var => Singleton ident var
    | Index v i => Union ident (var_freevars v) (aexpr_freevars i)
    | Range v s e => Union ident (var_freevars v) (Union ident (aexpr_freevars s) (aexpr_freevars e))
    | Slice v el => Union ident (var_freevars v) (aexprl_freevars el)
    end.

Fixpoint varl_freevars vl :=
    match vl with
    | nil => Empty_set ident
    | v :: tl => Union ident (var_freevars v) (varl_freevars tl)
    end.

Function expr_freevars (e : expr) : Ensemble ident :=
    match e with
    | Const _ _ => Empty_set ident
    | ExpVar v => var_freevars v
    | Tuple el => exprl_freevars el
    | Not e => expr_freevars e
    | Log _ e1 e2 | Arith _ e1 e2 => Union ident (expr_freevars e1) (expr_freevars e2)
    | Shift _ expr aexpr => Union ident (expr_freevars expr) (aexpr_freevars aexpr)
    | Shuffle v _ => var_freevars v
    | Bitmask expr aexpr => Union ident (expr_freevars expr) (aexpr_freevars aexpr)
    | Pack e1 e2 _ => Union ident (expr_freevars e1) (expr_freevars e2)
    | Fun f exprl => Union ident (Singleton ident f) (exprl_freevars exprl)
    | Fun_v f aexpr exprl => Union ident (Singleton ident f) (Union ident (aexpr_freevars aexpr) (exprl_freevars exprl))
    end
with exprl_freevars el :=
    match el with
    | Enil => Empty_set ident
    | ECons e el => Union ident (expr_freevars e) (exprl_freevars el)
    end.

Function deq_vars (d : deq) : Ensemble ident :=
    match d with
    | Eqn v e _ => Union ident (expr_freevars e) (varl_freevars v)
    | Loop i ae1 ae2 eqns _ =>
        Union ident (Singleton ident i)
            (Union ident (aexpr_freevars ae1)
                (Union ident (aexpr_freevars ae2) (deqs_vars eqns)))
    end
with deqs_vars (d : list_deq) : Ensemble ident :=
    match d with
    | Dnil => Empty_set ident
    | Dcons hd tl => Union ident (deq_vars hd) (deqs_vars tl)
    end.

Function deq_boundvars (d : deq) : Ensemble ident :=
    match d with
    | Eqn v e _ => (varl_freevars v)
    | Loop i _ _ eqns _ => Union ident (Singleton ident i) (deqs_boundvars eqns)
    end
with deqs_boundvars (d : list_deq) : Ensemble ident :=
    match d with
    | Dnil => Empty_set ident
    | Dcons hd tl => Union ident (deq_boundvars hd) (deqs_boundvars tl)
    end.


From TLTT Require Import MLTT2.Overture.
From TLTT Require Import MLTT2.Path_eq.

Definition isProp (A : TypeF) := forall (a b : A), a = b.

Lemma hProp_is_Set {A : TypeF} (f : isProp A)
  : isSet A.
Proof.
  intros a b.
  intros p q. pose (fun (y : A) => f a y) as g.
  assert (H : forall (y z : A) (p : y = z), p = (g y)^ @ (g z)).
  { intros. apply moveL_Vp. rewi transport_paths_r; apply apD. }
  subst g. simpl in H. rew H.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import Coq.NArith.BinNat.
Require Import Coq.Strings.String.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Import ListNotations.
Open Scope list_scope.

Notation ident := string.
Notation path := (list ident).

Definition Z_to_val (i: Z): ValueBase := ValBaseBit (P4Arith.to_lbool 32 i).

Definition counter_reg_repr (p : path) (counter : Z) : ext_pred :=
  ExtPred.and
    (ExtPred.singleton (p ++ ["reg_counter"])
       (Tofino.ObjRegister [Z_to_val counter]))
    (ExtPred.prop (0 <= counter)).

Program Definition counter_repr (p : path) (counter : Z) : ext_pred :=
  ExtPred.wrap [p] [counter_reg_repr p counter] _.
Next Obligation.
  unfold in_scope.
  rewrite <- (app_nil_r p) at 1.
  rewrite is_prefix_cancel. auto.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify Comparators Gates.

(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module Split.
Module B := Bitify.
Module D := DSL.
Module R := Repr.
Import R.

Import B.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Section _Split.
Context {n m: nat}.

(* // split a n + m bit input into two outputs
template Split(n, m) {
    assert(n <= 126);
    signal input in;
    signal output small;
    signal output big;

    small <-- in % (1 << n);
    big <-- in \ (1 << n);

    component n2b_small = Num2Bits(n);
    n2b_small.in <== small;
    component n2b_big = Num2Bits(m);
    n2b_big.in <== big;

    in === small + big * (1 << n);
} *)

Definition cons (_in: F) (small: F) (big: F) :=
  exists (n2b_small: @Num2Bits.t n) (n2b_big: @Num2Bits.t m),
  n2b_small.(Num2Bits._in) = small /\
  n2b_big.(Num2Bits._in) = big /\
  _in = small + big * 2^n.

Local Close Scope F_scope.

Record t := {
  _in: F;
  small: F;
  big: F;
  _cons: cons _in small big
}.

End _Split.
End Split.

Module SplitThree.
Module B := Bitify.
Module D := DSL.
Module R := Repr.
Import R.

Import B.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Section _SplitThree.
Context {n m k: nat}.

(* // split a n + m + k bit input into three outputs
template SplitThree(n, m, k) {
    assert(n <= 126);
    signal input in;
    signal output small;
    signal output medium;
    signal output big;

    small <-- in % (1 << n);
    medium <-- (in \ (1 << n)) % (1 << m);
    big <-- in \ (1 << n + m);

    component n2b_small = Num2Bits(n);
    n2b_small.in <== small;
    component n2b_medium = Num2Bits(m);
    n2b_medium.in <== medium;
    component n2b_big = Num2Bits(k);
    n2b_big.in <== big;

    in === small + medium * (1 << n) + big * (1 << n + m);
} *)

Definition cons (_in: F) (small: F) (medium: F) (big: F) :=
  exists (n2b_small: @Num2Bits.t n) (n2b_medium: @Num2Bits.t m) (n2b_big: @Num2Bits.t k),
  n2b_small.(Num2Bits._in) = small /\
  n2b_medium.(Num2Bits._in) = medium /\
  n2b_big.(Num2Bits._in) = big /\
  _in = small + medium * 2^n + big * 2^(n+m).

Local Close Scope F_scope.

Record t := {
  _in: F;
  small: F;
  medium: F;
  big: F;
  _cons: cons _in small medium big
}.

End _SplitThree.
End SplitThree.


From stdpp Require Import base countable.

Section hltl.

  Class hLTLSignature :=
    {
      var : Set;
      var_eqdec :> EqDecision var;
      var_countable :> Countable var;
      var_infinite :> Infinite var;
      AP : Set;
      AP_eqdec :> EqDecision AP
    }.

  Context {Σh : hLTLSignature}.

  Definition db_index := nat.

  Inductive Formula' :=
  | f_atomic_free (a : AP) (π : var)
  | f_atomic_bound (a : AP) (dbi : db_index)
  | f_neg (f : Formula')
  | f_and (f1 f2 : Formula')
  | f_next (f : Formula')
  | f_until (f1 f2 : Formula')
  .

  Inductive Formula :=
  | f_forall (f : Formula)
  | f_exists (f : Formula)
  | f_inj (f' : Formula')
  .

End hltl.


Require Import Setoid PArray Uint63.
From mathcomp Require Import all_ssreflect all_algebra.
Require Import PArith.BinPos PArith.BinPosDef.
Require Import NArith.BinNat NArith.BinNatDef.
From Bignums Require Import BigQ.
From Polyhedra Require Import extra_misc inner_product vector_order.
Require Import graph extra_array extra_int array_set rat_bigQ diameter img_graph refinement.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.Theory.
Import GRing.Theory Num.Theory.

(* Open Scope ring_scope. *)

(* --------------------------------------------------------------------------------------------------- *)

Module Common.

(* polyType is the type of the polytope *)
(* It is a pair of a matrix reprsented by lines and a vector b *)
Definition polyType := ((array (array bigQ)) * (array bigQ))%type.
 Definition m (Po : polyType) := length Po.1.
 Definition n (Po : polyType) := length Po.1.[0%uint63].

(* U is the type of perturbed "points" of the lex-graph*)
(* It is a matrix represented by columns *)
Definition U := array (array bigQ).
Definition lex_label := ((array Uint63.int) * U)%type.
Definition lex_mapping := array lex_label.

Definition bas (lbl : lex_mapping) (i : Uint63.int)  := lbl.[i].1.
Definition point (lbl : lex_mapping) (i : Uint63.int) := lbl.[i].2.
Definition compute_test (G : graph) := IFold.iall^~ (length G).

End Common.

Module Com := Common.

Section CommonEquiv.
Context (G : graph).

Definition compute_test := iall^~ (length G).

Lemma compute_testP f: compute_test f -> forall i, mem_vertex G i -> f i.
Proof.
move/allP=> compu i ig; apply/compu.
by rewrite mem_irangeE le0x.
Qed.

End CommonEquiv.

(* --------------------------------------------------------------------------------------------------- *)

Module FormatComputation.

(* Performs all format computation, i.e. correct length of arrays ... *)

Definition poly_format (Po : Com.polyType):=
  [&& (0 <? Com.m Po)%uint63, (0 <? Com.n Po)%uint63,
      (length Po.2 =?  Com.m Po)%uint63 &
      PArrayUtils.all (fun x=> (length x =? Com.n Po)%uint63) Po.1].

Definition basis_format (Po : Com.polyType) (x : array Uint63.int):=
  PC.pre_arr_set_computation (fun a b=> (a <? b)%uint63)
    (fun i=> (i <? Com.m Po)%uint63) x.

Definition point_format (Po : Com.polyType) (x : array (array bigQ)):=
  PC.pre_mx_computation x (Uint63.succ (Com.m Po)) (Com.n Po).

Definition lex_vert_format (Po : Com.polyType) (x : Com.lex_label):=
  basis_format Po x.1 && point_format Po x.2.

Definition lex_graph_format (Po : Com.polyType) (g : graph) (l : Com.lex_mapping):=
  PC.pre_graph_computation (fun x y=> PArrayUtils.lt_array_int x.1 y.1)
  (fun x=> lex_vert_format Po x) g l.

Definition lex_graph_n0 (g : graph):= (0 <? length g)%uint63.

Definition vert_graph_format (Po : Com.polyType)
  (g : graph) (l : array (array bigQ)):=
  PC.pre_graph_computation BigQUtils.BQltx_order
    (fun x=> (length x =? Com.n Po)%uint63) g l.

Definition bound_format (Po : Com.polyType) (a : array (array bigQ)):=
  PC.pre_mx_computation a (Com.n Po) (Com.m Po).

Definition inv_format (Po : Com.polyType) (a : array (array bigQ)):=
  PC.pre_mx_computation a (Com.n Po) (Com.n Po).

End FormatComputation.

Module FC := FormatComputation.

Section FormatEquiv.

Definition poly_format (Po : Com.polyType):=
  [&& (0 < Com.m Po)%O, (0 < Com.n Po)%O,
      (length Po.2 ==  Com.m Po) &
      arr_all (fun x=> (length x == Com.n Po)) Po.1].

Definition basis_format (Po : Com.polyType) (x : array Uint63.int):=
  pre_arr_set_computation (fun a b=> (a < b)%O)
    (fun i=> (i < Com.m Po)%O) x.

Definition point_format (Po : Com.polyType) (x : array (array bigQ)):=
  pre_mx_computation x (Uint63.succ (Com.m Po)) (Com.n Po).

Definition lex_vert_format (Po : Com.polyType) (x : Com.lex_label):=
  basis_format Po x.1 && point_format Po x.2.

Definition lex_graph_format (Po : Com.polyType) (g : graph) (l : Com.lex_mapping):=
  pre_graph_computation (fun x y=> lt_array_int x.1 y.1)
  (fun x=> lex_vert_format Po x) g l.

Definition lex_graph_n0 (g : graph) := (0 < length g)%O.

Definition vert_graph_format (Po : Com.polyType)
  (g : graph) (l : array (array bigQ)):=
  pre_graph_computation BQltx_order
    (fun x=> (length x == Com.n Po)) g l.

Definition bound_format (Po : Com.polyType) (a : array (array bigQ)):=
  pre_mx_computation a (Com.n Po) (Com.m Po).

Definition inv_format (Po : Com.polyType) (a : array (array bigQ)):=
  pre_mx_computation a (Com.n Po) (Com.n Po).

Lemma poly_formatE Po: FC.poly_format Po = poly_format Po.
Proof.
rewrite /FC.poly_format -!ltEint !eqEint arr_allE; repeat congr andb.
by apply/eq_all=> i; rewrite eqEint.
Qed.

Lemma lex_graph_formatE Po g l:
  FC.lex_graph_format Po g l = lex_graph_format Po g l.
Proof.
rewrite /FC.lex_graph_format pre_graph_computationE; repeat congr andb.
- by rewrite !rel_sortedP; apply/(sorted_rel_equiv)=> //;
  [move => ??; apply/erefl|move=> ???? -> ->; rewrite lt_array_intE].
- apply/eq_all=> ?; congr andb.
  + by rewrite /FC.basis_format pre_arr_set_computationE.
  + by rewrite /FC.point_format pre_mx_computationE.
Qed.

Lemma lex_graph_n0E g:
  FC.lex_graph_n0 g = lex_graph_n0 g.
Proof. by rewrite /FC.lex_graph_n0 -ltEint. Qed.

Lemma vert_graph_formatE Po g l:
  FC.vert_graph_format Po g l = vert_graph_format Po g l.
Proof.
rewrite /FC.vert_graph_format pre_graph_computationE; repeat congr andb.
- by rewrite !rel_sortedP; apply/(sorted_rel_equiv)=> //;
    [move=> ??; apply/erefl|move=> ???? -> ->; rewrite BQltx_orderE].
- by apply/eq_all=> ?; rewrite eqEint.
Qed.

Lemma bound_formatE Po y:
  FC.bound_format Po y = bound_format Po y.
Proof. by rewrite /FC.bound_format pre_mx_computationE. Qed.

Lemma inv_formatE Po y:
  FC.inv_format Po y = inv_format Po y.
Proof. by rewrite /FC.inv_format pre_mx_computationE. Qed.

End FormatEquiv.

(* --------------------------------------------------------------------------------------------------- *)

Module PolyBoundedComputation.

(* bounded_Po_test checks that every coordinate is bounded        *)
(* To do so, let y_pos y_neg : array (array bigQ), such that:  *)
(* -> forall i < n, y_pos.[i] *m A = (j == i)_(j < n)                   *)
(* -> forall i < n, y_neg.[i] *m A = - (j == i)_(j < n)                 *)
(* -> forall i < n, y.[i].1 and y.[i].2 are nonnegative               *)

Definition bound_certif_fold
  (Po: Com.polyType) (y : array (array bigQ)) (x : bigQ):=
  IFold.iall (fun i=>
    BigQUtils.eq_array_bigQ
          (BigQUtils.weighted_lines y.[i] Po.1)
          (BigQUtils.delta_line (Com.n Po) i x)
    && PArrayUtils.all BigQUtils.bigQ_ge0 y.[i]
  ) (length y).

Definition bounded_Po_test (Po : Com.polyType) (y_pos : array (array bigQ))
  (y_neg : array (array bigQ)) :=
    bound_certif_fold Po y_pos 1%bigQ &&
    bound_certif_fold Po y_neg (-1)%bigQ.

End PolyBoundedComputation.

Module PBC := PolyBoundedComputation.

Section PolyBoundedEquiv.

Context {Po : Com.polyType}.

Definition bound_certif_fold (y : array (array bigQ)) (x : bigQ):=
  iall (fun i=>
    eq_array_bigQ
      (weighted_lines y.[i] Po.1)
      (BigQUtils.delta_line (Com.n Po) i x)
    && arr_all BigQUtils.bigQ_ge0 y.[i]
  ) (length y).

Definition bounded_Po_test (y_pos y_neg : array (array bigQ)):=
  bound_certif_fold y_pos 1%bigQ && bound_certif_fold y_neg (-1)%bigQ.

Lemma bound_certif_foldE y x:
  PBC.bound_certif_fold Po y x = bound_certif_fold y x.
Proof.
rewrite /PBC.bound_certif_fold iallE; apply/eq_all=> i.
by rewrite eq_array_bigQE weighted_linesE arr_allE.
Qed.

Lemma bounded_Po_testE y_pos y_neg:
  PBC.bounded_Po_test Po y_pos y_neg = bounded_Po_test y_pos y_neg.
Proof. by congr andb; rewrite bound_certif_foldE. Qed.

End PolyBoundedEquiv.

(* --------------------------------------------------------------------------------------------------- *)

Module LexCertifComputation.

(*
  Verfify that a given graph g_lex : graph.graph and its labeling l_lex : Com.lex_mapping
  is the graph of lexicographic bases of a polyhedron Po : Com.polyType
*)

Section Defs.

Definition sat_ineq (m i : Uint63.int) (a : array bigQ) (b : bigQ) (x : Com.U):=
  if (PArrayUtils.fold_pair
      (fun bv xv acc=> if acc is Eq then (bv ?= (BigQUtils.bigQ_dot a xv))%bigQ else acc)
    (BigQUtils.perturbed_line m i b (-1)%bigQ) x Eq) is Gt
  then false else true.

Definition sat_eq (m i : Uint63.int) (a : array bigQ) (b : bigQ) (x : Com.U):=
  BigQUtils.eq_array_bigQ (BigQUtils.bigQ_mul_row_mx a x)
    (BigQUtils.perturbed_line m i b (-1)%bigQ).

Definition sat_Po (Po : Com.polyType) (x : Com.U) :=
  IFold.iall (fun i => sat_ineq (Com.m Po) i Po.1.[i] Po.2.[i] x) (Com.m Po).

Definition mask_eq (Po : Com.polyType) (m : array Uint63.int) (x : Com.U):=
  IFold.iall (fun i=> sat_eq (Com.m Po) m.[i] Po.1.[m.[i]] Po.2.[m.[i]] x) (length m).

End Defs.

Section Body.
Context (Po : Com.polyType) (G : graph) (lbl : Com.lex_mapping).

(* We test validity of each vertex label*)
Definition sat_test (i : Uint63.int) := sat_Po Po (Com.point lbl i).
Definition bas_eq_test (i : Uint63.int) := mask_eq Po (Com.bas lbl i) (Com.point lbl i).
Definition card_bas_test (i : Uint63.int) := (length (Com.bas lbl i) =? (Com.n Po))%uint63.
Definition vertex_test (i : Uint63.int) := [&& (card_bas_test i), (sat_test i) & (bas_eq_test i)].

Definition vertex_consistent := Com.compute_test G vertex_test.

(* We test the graph structure*)
Definition regularity_test (i : Uint63.int) := (GraphUtils.nb_neighbours G i =? (Com.n Po))%uint63.
Definition basI_test (i : Uint63.int) := GraphUtils.neighbour_all
  (fun j =>
    ((AIC.array_inter
      (fun i j=> (i <? j)%uint63) (Com.bas lbl i) (Com.bas lbl j)) =? Uint63.pred (Com.n Po))%uint63)
    G i.

Definition struct_consistent :=
  (Com.compute_test G (fun i => regularity_test i && basI_test i)).

Definition enum_algo := vertex_consistent && struct_consistent.

End Body.
End LexCertifComputation.

Module LCA := LexCertifComputation.

Section LexCertifEquiv.
Section Def.

Definition sat_ineq (m i : Uint63.int) (a : array bigQ) (b : bigQ) (x : Com.U):=
  let pert_b := BigQUtils.perturbed_line m i b (-1)%bigQ in
  let res := arr_fold_pair
    (fun bv xv acc=> if acc is Eq then (bv ?= (BigQUtils.bigQ_dot a xv))%bigQ else acc)
  pert_b x Eq in
  if res is Gt then false else true.

Definition sat_eq (m i : Uint63.int) (a : array bigQ) (b : bigQ) (x : Com.U):=
  let pert_b := BigQUtils.perturbed_line m i b (-1)%bigQ in
  eq_array_bigQ (bigQ_mul_row_mx a x) pert_b.

Definition sat_Po (Po : Com.polyType) (x : Com.U) :=
  iall (fun i => sat_ineq (Com.m Po) i Po.1.[i] Po.2.[i] x) (Com.m Po).

Definition mask_eq (Po : Com.polyType) (m : array Uint63.int) (x : Com.U):=
  iall (fun i=> sat_eq (Com.m Po) m.[i] Po.1.[m.[i]] Po.2.[m.[i]] x) (length m).

Context (Po : Com.polyType) (G : graph) (lbl : Com.lex_mapping).

Definition sat_test (i : Uint63.int) := sat_Po Po (Com.point lbl i).
Definition bas_eq_test (i : Uint63.int) := mask_eq Po (Com.bas lbl i) (Com.point lbl i).
Definition card_bas_test (i : Uint63.int) := (length (Com.bas lbl i) == (Com.n Po)).

Definition vertex_test (i : Uint63.int) := [&& (card_bas_test i), (sat_test i) & (bas_eq_test i)].

Definition vertex_consistent := compute_test G vertex_test.

Definition regularity_test (i : Uint63.int) := (nb_neighbours G i == (Com.n Po)).
Definition basI_test (i : Uint63.int) := neighbour_all
  (fun j =>
    ((array_inter
      (fun i j=> (i < j)%O) (Com.bas lbl i) (Com.bas lbl j)) == Uint63.pred (Com.n Po)))
    G i.

Definition struct_consistent :=
  (compute_test G (fun i => regularity_test i && basI_test i)).

Definition enum_algo := vertex_consistent && struct_consistent.

End Def.
Section Equiv.

Lemma vertex_consistentE Po g lbl:
  LCA.vertex_consistent Po g lbl = vertex_consistent Po g lbl.
Proof.
rewrite /LCA.vertex_consistent /Com.compute_test iallE.
apply/eq_all=> i; congr andb; rewrite /LCA.card_bas_test ?eqEint //.
congr andb.
- rewrite /LCA.sat_test /LCA.sat_Po.
  rewrite iallE; apply/eq_all=> k.
  rewrite /LCA.sat_ineq arr_fold_pairE.
  rewrite /sat_ineq /arr_fold_pair /Com.point.
  by elim: zip Eq.
- rewrite /LCA.bas_eq_test /LCA.mask_eq.
  rewrite iallE; apply/eq_all=> k.
  rewrite /LCA.sat_eq.
  by rewrite eq_array_bigQE; congr andb; rewrite ?bigQ_mul_row_mxE.
Qed.

Lemma struct_consistentE Po g lbl:
  LCA.struct_consistent Po g lbl = struct_consistent Po g lbl.
Proof.
rewrite /LCA.struct_consistent /Com.compute_test iallE; apply/eq_all=> i.
congr andb; first by rewrite /LCA.regularity_test eqEint.
rewrite /LCA.basI_test neighbour_allE; apply/eq_all=> j.
by rewrite array_interE eqEint.
Qed.

Lemma enum_algoE Po g lbl:
  LCA.enum_algo Po g lbl = enum_algo Po g lbl.
Proof. by congr andb; rewrite ?vertex_consistentE ?struct_consistentE //. Qed.

End Equiv.
End LexCertifEquiv.

Section LexCertifProofs.

Lemma sat_ineqP (m i : Uint63.int) (a : array bigQ) (b : bigQ) (u : Com.U) :
  length u = Uint63.succ m ->
  sat_ineq m i a b u =
  BQlex_order (BigQUtils.perturbed_line m i b (-1)%bigQ)
    (bigQ_mul_row_mx a u).
Proof.
move=> len_u.
rewrite /BQlex_order /bigQ_mul_row_mx.
rewrite /lex_array_rel /lex_array_rel_ /arr_fold_pair.
rewrite length_arr_map !length_set length_make -len_u leb_length eqxx /=.
rewrite rAS_map /sat_ineq /arr_fold_pair.
set F := (foldl _ _ _); set F' := (foldl _ _ _).
suff ->: F = F' by [].
rewrite /F /F'.
move/(congr1 int_to_nat): (len_u).
set pert_b := BigQUtils.perturbed_line _ _ _ _.
rewrite -(size_arr_to_seq u).
have <-: size (arr_to_seq pert_b) = Uint63.succ m by
  rewrite size_arr_to_seq !length_set !length_make -len_u leb_length.
elim/last_ind: (arr_to_seq pert_b) (arr_to_seq u)=> [|t h IH]; elim/last_ind=> [|t' h' _] //.
- by rewrite size_rcons.
- by rewrite size_rcons.
- rewrite !size_rcons => /succn_inj size_tt'.
  rewrite map_rcons !zip_rcons ?size_map // !foldl_rcons /=.
  by move: (IH t' size_tt')=> ->; rewrite !bigQ_dotE.
Qed.

Context {Po : Com.polyType} {g : graph} {lbl : Com.lex_mapping}.

Lemma lex_card_bas i: card_bas_test Po lbl i-> length (Com.bas lbl i) = (Com.n Po).
Proof. by move=> /eqP ->. Qed.

Lemma lex_basI i j:
  mem_vertex g i -> mem_vertex g j ->
  mem_edge g i j ->
  basI_test Po g lbl i ->
  array_inter (fun i j=> (i < j)%O)
    (Com.bas lbl i) (Com.bas lbl j) = Uint63.pred (Com.n Po).
Proof.
move=> ig jg ij_g /neighbour_allP.
move/(_ ig); move/neighboursP: ij_g=> /(_ ig jg) [k k_nei j_eq] /(_ k k_nei).
by rewrite j_eq /= => /(_ jg) /eqP ->.
Qed.

Lemma lex_regularity i: regularity_test Po g i -> nb_neighbours g i = (Com.n Po).
Proof. by move=> /eqP. Qed.

Lemma lex_sat_Po k i: (k < Com.m Po)%O ->
  sat_test Po lbl i ->
  sat_ineq (Com.m Po) k Po.1.[k] Po.2.[k] (Com.point lbl i).
Proof. by move=> k_Po /allP; apply; rewrite mem_irangeE le0x k_Po. Qed.

Lemma lex_mask_eq i j: (j < length (Com.bas lbl i))%O ->
  bas_eq_test Po lbl i ->
  sat_eq (Com.m Po) (Com.bas lbl i).[j]
    Po.1.[(Com.bas lbl i).[j]] Po.2.[(Com.bas lbl i).[j]]
    (Com.point lbl i).
Proof. by move=> j_bas /allP /(_ j); apply; rewrite mem_irangeE le0x j_bas. Qed.

End LexCertifProofs.

(* --------------------------------------------------------------- *)

Definition BQlex_label := Com.lex_label.
Definition BQlex_mapping := Com.lex_mapping.

Definition BQvert_label := (array bigQ)%type.
Definition BQvert_mapping := array (BQvert_label).

Module ImgGraphLexComputation.

(*
  Given two graphs g_lex and g_vert associated with their labels
  l_lex and l_simpl, img_lex_graph verifies the g_vert is the image graph
  of g_lex. It makes uses of three certificates
  (morph morph' : array int) (edge_inv : array (array (int * int)))
*)

Definition img_lex_graph morph morph' edge_inv
  g_lex l_lex g_vert l_vert :=
  ILGC.img_label_graph (fun x : BQlex_label => x.2.[0%uint63]) BigQUtils.eq_array_bigQ
  morph morph' edge_inv (g_lex, l_lex) (g_vert, l_vert).

End ImgGraphLexComputation.

Module IGLexC := ImgGraphLexComputation.

Section ImgGraphLexEquiv.

Definition img_lex_graph morph morph' edge_inv
  g_lex l_lex g_vert l_vert :=
  img_label_graph (fun x : BQlex_label => x.2.[0%uint63]) eq_array_bigQ
  morph morph' edge_inv (g_lex,l_lex) (g_vert,l_vert).

Lemma img_lex_graphE morph morph' edge_inv g_lex l_lex g_vert l_vert:
  IGLexC.img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert =
  img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert.
Proof.
rewrite /IGLexC.img_lex_graph img_label_graphE; congr andb.
by rewrite /img_label; apply/eq_all=> i /=; rewrite eq_array_bigQE.
Qed.

End ImgGraphLexEquiv.

(* -------------------------------------------------------------------- *)

Module DimensionFullComputation.

(* Given an array (lbl : BQvert_mapping) of Q^n points, dim_full_test
  verifies that given n points x_k and one origin x_0,
  the matrix \matrix_k (x_k - x_0)^T is invertible *)

Definition inverse_line_i (lbl : BQvert_mapping)
  (map_ : array Uint63.int) (origin : Uint63.int)
  (inv : array (array bigQ)) n i:=
  let: rV_i:=
    BigQUtils.bigQ_add_rV (lbl.[map_.[i]]) (BigQUtils.bigQ_scal_rV (-1)%bigQ lbl.[origin]) in
  BigQUtils.eq_array_bigQ (BigQUtils.bigQ_mul_row_mx rV_i inv) (BigQUtils.delta_line n i 1%bigQ).

Definition dim_full_test (lbl : BQvert_mapping)
  (map_ : array Uint63.int) (origin : Uint63.int) (inv : array (array bigQ))
  (Po : Com.polyType) :=
    [&&
      (length map_ =? Com.n Po)%uint63,
      PArrayUtils.all (fun x=> (x <? length lbl)%uint63) map_,
      (origin <? length lbl)%uint63 &
      IFold.iall
        (fun i=> inverse_line_i lbl map_ origin inv (Com.n Po) i)
      (length map_)
    ].

End DimensionFullComputation.

Module DFC := DimensionFullComputation.

Section DimensionFullEquiv.

Definition inverse_line_i (lbl : BQvert_mapping)
  (map_ : array Uint63.int) (origin : Uint63.int)
  (inv : array (array bigQ)) n i:=
  let: rV_i:=
    bigQ_add_rV (lbl.[map_.[i]]) (bigQ_scal_rV (-1)%bigQ lbl.[origin]) in
  eq_array_bigQ (bigQ_mul_row_mx rV_i inv) (BigQUtils.delta_line n i 1%bigQ).

(* Definition inv_format_test (inv : array (array bigQ))
  (Po : Com.polyType):=
  (length inv == (Com.n Po)) &&
  arr_all (fun line=> (length line == (Com.n Po))) inv.

Definition map_test (lbl : BQvert_mapping) (map_ : array Uint63.int) (Po : Com.polyType):=
  [&& (length map_ == (Uint63.succ (Com.n Po))),
      arr_all (fun x=> (x < length lbl)%O) map_ &
      is_lti_sorted map_]. *)

Definition dim_full_test (lbl : BQvert_mapping)
  (map_ : array Uint63.int) (origin : Uint63.int) (inv : array (array bigQ))
  (Po : Com.polyType) :=
  [&&
    (length map_ == Com.n Po),
    arr_all (fun x=> (x < length lbl)%O) map_,
    (origin < length lbl)%O &
    iall
      (fun i=> inverse_line_i lbl map_ origin inv (Com.n Po) i)
    (length map_)
  ].

Lemma dim_full_testE lbl map_ origin inv Po:
  DFC.dim_full_test lbl map_ origin inv Po =
  dim_full_test lbl map_ origin inv Po.
Proof.
repeat congr andb; rewrite ?eqEint //.
- by rewrite arr_allE; apply/eq_all=> ?; rewrite ltEint.
- rewrite /DFC.dim_full_test iallE; apply/eq_all=> i.
  rewrite /DFC.inverse_line_i /= eq_array_bigQE.
  by rewrite bigQ_mul_row_mxE bigQ_add_rVE bigQ_scal_rVE.
Qed.

End DimensionFullEquiv.

(* --------------------------------------------------------------- *)

Module HirschUtils.

(*
  Given a correct witness vertex,
  this function performs a BFS from this point
  to prove there is a path bigger than
  the bound defined by the Hirsch Conjecture
*)

Definition diameter_check g (Po : Com.polyType) x :=
  [&& ((Com.n Po) <? (Com.m Po))%uint63, GraphUtils.mem_vertex g x &
      ((Com.m Po) - (Com.n Po) <? nat_to_int (DC.BFS g x))%uint63].

Definition diameter_exact g (Po : Com.polyType) k :=
  (nat_to_int (DC.diameter_BFS g) =? k)%uint63.

End HirschUtils.

Section Hirsch.

Definition diameter_check g (Po : Com.polyType) x :=
  [&&
    ((Com.n Po) < (Com.m Po))%O, mem_vertex g x &
    (((Com.m Po) - (Com.n Po))%uint63 < nat_to_int (BFS g x))%O
  ].

Definition diameter_exact g (Po : Com.polyType) k :=
  (nat_to_int (diameter_BFS g) == k).

Section Equiv.

Lemma diameter_checkE g (Po : Com.polyType) x:
  HirschUtils.diameter_check g Po x = diameter_check g Po x.
Proof. by rewrite /HirschUtils.diameter_check BFSE mem_vertexE -!ltEint. Qed.

Lemma diameter_exactE g (Po : Com.polyType) k:
  HirschUtils.diameter_exact g Po k = diameter_exact g Po k.
Proof. by rewrite /HirschUtils.diameter_exact eqEint low_diameterE. Qed.

End Equiv.

End Hirsch.


Require Import
  Coq.FSets.FMapAVL
  Coq.FSets.FMapFacts
  Coq.Structures.OrderedTypeEx
  Coq.Logic.FunctionalExtensionality.

Module M := FMapAVL.Make Nat_as_OT.

Module P := WProperties_fun Nat_as_OT M.
Module F := P.F.

Inductive type: Set :=
  | Bool    :                 type
  | Nat     :                 type
  | Var     : nat  ->         type
  | Prod    : type -> type -> type
(*| List    : type         -> type*)
  | Lambda  : type -> type -> type
  | Forall  : nat  -> type -> type
  .

Definition update{V} k v (env: nat -> V) k': V :=
  if Nat.eqb k k' then v else env k'.

Fixpoint type2Type(t: type)(env: nat -> Type): Type :=
  match t with
  | Bool => bool
  | Nat => nat
  | Var v => env v
  | Prod t1 t2 => prod (type2Type t1 env) (type2Type t2 env)
(*| List t => list (type2Type t env) *)
  | Lambda t1 t2 => (type2Type t1 env) -> (type2Type t2 env)
  | Forall v t => forall (tt: Type), (type2Type t (update v tt env))
  end.

Definition x := type2Type (Prod Bool Nat) (fun _ => Empty_set).
Definition y: x := pair true 4.

Inductive Rel := Rel_ A A' (R: A -> A' -> Prop).

Definition p1 (env: nat -> Rel) n: Type := match env n with Rel_ T _ _ => T end.
Definition p2 (env: nat -> Rel) n: Type := match env n with Rel_ _ T _ => T end.
Definition rel(env: nat -> Rel) n: p1 env n -> p2 env n -> Prop :=
  match env n as R
    return match R with Rel_ A _ _ => A end -> match R with Rel_ _ A _ => A end -> Prop
    with Rel_ _ _ R => R end.

Lemma p1_update{A A'} k R env: update k A (p1 env) = p1 (update k (Rel_ A A' R) env).
Proof.
  unfold update, p1.
  extensionality k'.
  destruct (Nat.eqb k k'); reflexivity.
Qed.

Lemma p2_update{A A'} k R env: update k A' (p2 env) = p2 (update k (Rel_ A A' R) env).
Proof.
  unfold update, p2.
  extensionality k'.
  destruct (Nat.eqb k k'); reflexivity.
Qed.

Definition lift1{k t' A A' R env}(x: type2Type t' (update k A (p1 env))):
                                     type2Type t' (p1 (update k (Rel_ A A' R) env)).
  rewrite <- p1_update.
  assumption.
Defined.

Definition lift2{k t' A A' R env}(x: type2Type t' (update k A' (p2 env))):
                                     type2Type t' (p2 (update k (Rel_ A A' R) env)).
  rewrite <- p2_update.
  assumption.
Defined.

Fixpoint type2Rel(t: type)(env: nat -> Rel): type2Type t (p1 env) -> type2Type t (p2 env) -> Prop :=
  match t with
  | Bool => eq
  | Nat => eq
  | Var v => rel env v
  | Prod t1 t2 => fun v1 v2 =>
    match v1, v2 with
     (v1a, v1b), (v2a, v2b) => type2Rel _ env v1a v2a /\ type2Rel _ env v1b v2b
    end
(*| List t => fun v1 v2 => False*)
  | Lambda t1 t2 => fun f1 f2 =>
    forall v1 v2, type2Rel _ env v1 v2 -> type2Rel _ env (f1 v1) (f2 v2)
  | Forall X t' => fun g g' =>
      forall A A' (R: A -> A' -> Prop),
        type2Rel t' (update X (Rel_ _ _ R) env) (lift1 (g A)) (lift2 (g' A'))
  end.

Definition type2Type'(T: type): Type :=
  type2Type T (fun _ => Empty_set).

Definition type2Rel' (T: type): type2Type' T -> type2Type' T -> Prop :=
  type2Rel T (fun _ => Rel_ Empty_set Empty_set (fun _ _ => False)).

Theorem Parametricity: forall T (t: type2Type' T), type2Rel' T t t.
Proof.
  unfold type2Type', type2Rel'.
  induction T; simpl; try auto.
  intros [].
  intros [t1 t2]. auto.
  set (R1 := type2Rel T1 (fun _ : nat => Rel_ Empty_set Empty_set (fun _ _ : Empty_set => False))) in * |- *.
  set (R2 := type2Rel T2 (fun _ : nat => Rel_ Empty_set Empty_set (fun _ _ : Empty_set => False))) in * |- *.
  unfold p1, p2 in * |- *.
  set (TT1 := type2Type T1 (fun _ : nat => Empty_set)) in * |- *.
  set (TT2 := type2Type T2 (fun _ : nat => Empty_set)) in * |- *.
  intros f a1 a2 H.

Qed.

Definition I : type := Forall 0 (Lambda (Var 0) (Var 0)).
Definition It: Type := type2Type I (fun _ => Empty_set).
Definition Ir: It -> It -> Prop := type2Rel I (fun _ => Rel_ Empty_set Empty_set (fun _ _ => False)).

Definition i: It := fun X (x: X) => x.

Theorem foo: Ir i i.
Proof.
  unfold Ir.
  compute.
  intros A A' R a a' H.
  apply H.
  set (H3 := p1_update 0 R (fun _ : nat => Rel_ Empty_set Empty_set (fun _ _ : Empty_set => False))).
  set (H4 := p2_update 0 R (fun _ : nat => Rel_ Empty_set Empty_set (fun _ _ : Empty_set => False))).
  generalize H3.

 simpl.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Arith.
Require Import List.

(**** A few tests for the extraction mechanism ****)

(* Ideally, we should monitor the extracted output
   for changes, but this is painful. For the moment,
   we just check for failures of this script. *)

(*** STANDARD EXAMPLES *)

(** Functions. *)

Definition idnat (x:nat) := x.
Extraction idnat.
(* let idnat x = x *)

Definition id (X:Type) (x:X) := x.
Extraction id. (* let id x = x *)
Definition id' := id Set nat.
Extraction id'. (* type id' = nat *)

Definition test2 (f:nat -> nat) (x:nat) := f x.
Extraction test2.
(* let test2 f x = f x *)

Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat.
Extraction test3.
(* let test3 f x = f x __ *)

Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g.
Extraction test4.
(* let test4 f x g = f g *)

Definition test5 := (1, 0).
Extraction test5.
(* let test5 = Pair ((S O), O) *)

Definition cf (x:nat) (_:x <= 0) := S x.
Extraction NoInline cf.
Definition test6 := cf 0 (le_n 0).
Extraction test6.
(* let test6 = cf O *)

Definition test7 := (fun (X:Set) (x:X) => x) nat.
Extraction test7.
(* let test7 x = x *)

Definition d (X:Type) := X.
Extraction d. (* type 'x d = 'x *)
Definition d2 := d Set.
Extraction d2. (* type d2 = __ d *)
Definition d3 (x:d Set) := 0.
Extraction d3. (* let d3 _ = O *)
Definition d4 := d nat.
Extraction d4. (* type d4 = nat d *)
Definition d5 := (fun x:d Type => 0) Type.
Extraction d5.  (* let d5 = O *)
Definition d6 (x:d Type) := x.
Extraction d6.  (* type 'x d6 = 'x *)

Definition test8 := (fun (X:Type) (x:X) => x) Set nat.
Extraction test8. (* type test8 = nat *)

Definition test9 := let t := nat in id Set t.
Extraction test9.  (* type test9 = nat *)

Definition test10 := (fun (X:Type) (x:X) => 0) Type Type.
Extraction test10. (* let test10 = O *)

Definition test11 := let n := 0 in let p := S n in S p.
Extraction test11. (* let test11 = S (S O) *)

Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
Extraction test12.
(* type test12 = (__ -> __ -> __) -> __ *)

Definition test13 := match @left True True I with
                     | left x => 1
                     | right x => 0
                     end.
Extraction test13. (* let test13 = S O *)

(** example with more arguments that given by the type *)

Definition test19 :=
  nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0)
    (fun (n:nat) (f:nat -> nat) => f) 0 0.
Extraction test19.
(* let test19 =
  let rec f = function
    | O -> (fun n0 -> O)
    | S n0 -> f n0
  in f O O
*)

(** casts *)

Definition test20 := True:Type.
Extraction test20.
(* type test20 = __ *)

(** Simple inductive type and recursor. *)

Extraction nat.
(*
type nat =
  | O
  | S of nat
*)

Extraction sumbool_rect.
(*
let sumbool_rect f f0 = function
  |  Left -> f __
  | Right -> f0 __
*)

(** Less simple inductive type. *)

Inductive c (x:nat) : nat -> Set :=
  | refl : c x x
  | trans : forall y z:nat, c x y -> y <= z -> c x z.
Extraction c.
(*
type c =
  | Refl
  | Trans of nat * nat * c
*)

Definition Ensemble (U:Type) := U -> Prop.
Definition Empty_set (U:Type) (x:U) := False.
Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y.

Inductive Finite (U:Type) : Ensemble U -> Type :=
  | Empty_is_finite : Finite U (Empty_set U)
  | Union_is_finite :
      forall A:Ensemble U,
        Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x).
Extraction Finite.
(*
type 'u finite =
  | Empty_is_finite
  | Union_is_finite of 'u finite * 'u
*)

(** Mutual Inductive *)

Inductive tree : Set :=
    Node : nat -> forest -> tree
with forest : Set :=
  | Leaf : nat -> forest
  | Cons : tree -> forest -> forest.

Extraction tree.
(*
type tree =
  | Node of nat * forest
and forest =
  | Leaf of nat
  | Cons of tree * forest
*)

Fixpoint tree_size (t:tree) : nat :=
  match t with
  | Node a f => S (forest_size f)
  end

 with forest_size (f:forest) : nat :=
  match f with
  | Leaf b => 1
  | Cons t f' => tree_size t + forest_size f'
  end.

Extraction tree_size.
(*
let rec tree_size = function
  | Node (a, f) -> S (forest_size f)
and forest_size = function
  | Leaf b -> S O
  | Cons (t, f') -> plus (tree_size t) (forest_size f')
*)

(** Eta-expansions of inductive constructor *)

Inductive titi : Set :=
    tata : nat -> nat -> nat -> nat -> titi.
Definition test14 := tata 0.
Extraction test14.
(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
Definition test15 := tata 0 1.
Extraction test15.
(* let test15 x x0 = Tata (O, (S O), x, x0) *)

Inductive eta : Type :=
    eta_c : nat -> Prop -> nat -> Prop -> eta.
Extraction eta_c.
(*
type eta =
  | Eta_c of nat * nat
*)
Definition test16 := eta_c 0.
Extraction test16.
(* let test16 x = Eta_c (O, x) *)
Definition test17 := eta_c 0 True.
Extraction test17.
(* let test17 x = Eta_c (O, x) *)
Definition test18 := eta_c 0 True 0.
Extraction test18.
(* let test18 _ = Eta_c (O, O) *)

(** Example of singleton inductive type *)

Inductive bidon (A:Prop) (B:Type) : Type :=
    tb : forall (x:A) (y:B), bidon A B.
Definition fbidon (A B:Type) (f:A -> B -> bidon True nat)
  (x:A) (y:B) := f x y.
Extraction bidon.
(* type 'b bidon = 'b *)
Extraction tb.
(* tb : singleton inductive constructor *)
Extraction fbidon.
(* let fbidon f x y =
  f x y
*)

Definition fbidon2 := fbidon True nat (tb True nat).
Extraction fbidon2. (* let fbidon2 y = y *)
Extraction NoInline fbidon.
Extraction fbidon2.
(* let fbidon2 y = fbidon (fun _ x -> x) __ y *)

(* NB: first argument of fbidon2 has type [True], so it disappears. *)

(** mutual inductive on many sorts *)

Inductive test_0 : Prop :=
    ctest0 : test_0
with test_1 : Set :=
    ctest1 : test_0 -> test_1.
Extraction test_0.
(* test0 : logical inductive *)
Extraction test_1.
(*
type test1 =
  | Ctest1
*)

(** logical singleton *)

Extraction eq.
(* eq : logical inductive *)
Extraction eq_rect.
(* let eq_rect x f y =
  f
*)

(** No more propagation of type parameters. Obj.t instead. *)

Inductive tp1 : Type :=
    T : forall (C:Set) (c:C), tp2 -> tp1
with tp2 : Type :=
    T' : tp1 -> tp2.
Extraction tp1.
(*
type tp1 =
  | T of __ * tp2
and tp2 =
  | T' of tp1
*)

Inductive tp1bis : Type :=
    Tbis : tp2bis -> tp1bis
with tp2bis : Type :=
    T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
Extraction tp1bis.
(*
type tp1bis =
  | Tbis of tp2bis
and tp2bis =
  | T'bis of __ * tp1bis
*)

(** Strange inductive type. *)

Inductive Truc : Set -> Type :=
  | chose : forall A:Set, Truc A
  | machin : forall A:Set, A -> Truc bool -> Truc A.
Extraction Truc.
(*
type 'x truc =
  | Chose
  | Machin of 'x * bool truc
*)

(** Dependant type over Type *)

Definition test24 := sigT (fun a:Set => option a).
Extraction test24.
(* type test24 = (__, __ option) sigT *)

(** Coq term non strongly-normalizable after extraction *)

Require Import Gt.
Definition loop (Ax:Acc gt 0) :=
  (fix F (a:nat) (b:Acc gt a) {struct b} : nat :=
     F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax.
Extraction loop.
(* let loop _ =
  let rec f a =
    f (S a)
  in f O
*)

(*** EXAMPLES NEEDING OBJ.MAGIC *)

(** False conversion of type: *)

Lemma oups : forall H:nat = list nat, nat -> nat.
intros.
generalize H0; intros.
rewrite H in H1.
case H1.
exact H0.
intros.
exact n.
Qed.
Extraction oups.
(*
let oups h0 =
  match Obj.magic h0 with
    | Nil -> h0
    | Cons0 (n, l) -> n
*)

(** hybrids *)

Definition horibilis (b:bool) :=
  if b as b return (if b then Type else nat) then Set else 0.
Extraction horibilis.
(*
let horibilis = function
  | True -> Obj.magic __
  | False -> Obj.magic O
*)

Definition PropSet (b:bool) := if b then Prop else Set.
Extraction PropSet. (* type propSet = __ *)

Definition natbool (b:bool) := if b then nat else bool.
Extraction natbool. (* type natbool = __ *)

Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true.
Extraction zerotrue.
(*
let zerotrue = function
  | True -> Obj.magic O
  | False -> Obj.magic True
*)

Definition natProp (b:bool) := if b return Type then nat else Prop.

Definition natTrue (b:bool) := if b return Type then nat else True.

Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
Extraction zeroTrue.
(*
let zeroTrue = function
  | True -> Obj.magic O
  | False -> Obj.magic __
*)

Definition natTrue2 (b:bool) := if b return Type then nat else True.

Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
Extraction zeroprop.
(*
let zeroprop = function
  | True -> Obj.magic O
  | False -> Obj.magic __
*)

(** polymorphic f applied several times *)

Definition test21 := (id nat 0, id bool true).
Extraction test21.
(* let test21 = Pair ((id O), (id True)) *)

(** ok *)

Definition test22 :=
  (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
    (fun (X:Type) (x:X) => x).
Extraction test22.
(* let test22 =
  let f = fun x -> x in Pair ((f O), (f True)) *)

(* still ok via optim beta -> let *)

Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true).
Extraction test23.
(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *)

(* problem: fun f -> (f 0, f true) not legal in ocaml *)
(* solution: magic ... *)

(** Dummy constant __ can be applied.... *)

Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0).
Extraction f.
(* let f x y =
  y (x O)
*)

Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true).
Extraction NoInline f.
Extraction f_prop.
(* let f_prop =
  f (Obj.magic __) (fun _ -> True)
*)

Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true).
Extraction f_arity.
(* let f_arity =
  f (Obj.magic __) (fun _ -> True)
*)

Definition f_normal :=
  f nat (fun x => x) (fun x => match x with
                               | O => true
                               | _ => false
                               end).
Extraction f_normal.
(* let f_normal =
  f (fun x -> x) (fun x -> match x with
                             | O -> True
                             | S n -> False)
*)

(* inductive with magic needed *)

Inductive Boite : Set :=
    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite.
Extraction Boite.
(*
type boite =
  | Boite of bool * __
*)

Definition boite1 := boite true 0.
Extraction boite1.
(* let boite1 = Boite (True, (Obj.magic O)) *)

Definition boite2 := boite false (0, 0).
Extraction boite2.
(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)

Definition test_boite (B:Boite) :=
  match B return nat with
  | boite true n => n
  | boite false n => fst n + snd n
  end.
Extraction test_boite.
(*
let test_boite = function
  | Boite (b0, n) ->
      (match b0 with
         | True -> Obj.magic n
         | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n)))
*)

(* singleton inductive with magic needed *)

Inductive Box : Type :=
    box : forall A:Set, A -> Box.
Extraction Box.
(* type box = __ *)

Definition box1 := box nat 0.
Extraction box1. (* let box1 = Obj.magic O *)

(* applied constant, magic needed *)

Definition idzarb (b:bool) (x:if b then nat else bool) := x.
Definition zarb := idzarb true 0.
Extraction NoInline idzarb.
Extraction zarb.
(* let zarb = Obj.magic idzarb True (Obj.magic O) *)

(** function of variable arity. *)
(** Fun n = nat -> nat -> ... -> nat *)

Fixpoint Fun (n:nat) : Set :=
  match n with
  | O => nat
  | S n => nat -> Fun n
  end.

Fixpoint Const (k n:nat) {struct n} : Fun n :=
  match n as x return Fun x with
  | O => k
  | S n => fun p:nat => Const k n
  end.

Fixpoint proj (k n:nat) {struct n} : Fun n :=
  match n as x return Fun x with
  | O => 0 (* ou assert false ....*)
  | S n =>
      match k with
      | O => fun x => Const x n
      | S k => fun x => proj k n
      end
  end.

Definition test_proj := proj 2 4 0 1 2 3.

Eval compute in test_proj.

Recursive Extraction test_proj.

(*** TO SUM UP: ***)

(* Was previously producing a "test_extraction.ml" *)
Recursive Extraction
  idnat id id' test2 test3 test4 test5 test6 test7 d d2
  d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
  test13 test19 test20 nat sumbool_rect c Finite tree
  tree_size test14 test15 eta_c test16 test17 test18 bidon
  tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
  tp1bis Truc oups test24 loop horibilis PropSet natbool
  zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
  f_arity f_normal Boite boite1 boite2 test_boite Box box1
  zarb test_proj.

Extraction Language Haskell.
(* Was previously producing a "Test_extraction.hs" *)
Recursive Extraction
 idnat id id' test2 test3 test4 test5 test6 test7 d d2
 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
 test13 test19 test20 nat sumbool_rect c Finite tree
 tree_size test14 test15 eta_c test16 test17 test18 bidon
 tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
 tp1bis Truc oups test24 loop horibilis PropSet natbool
 zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
 f_arity f_normal Boite boite1 boite2 test_boite Box box1
 zarb test_proj.

Extraction Language Scheme.
(* Was previously producing a "test_extraction.scm" *)
Recursive Extraction
 idnat id id' test2 test3 test4 test5 test6 test7 d d2
 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
 test13 test19 test20 nat sumbool_rect c Finite tree
 tree_size test14 test15 eta_c test16 test17 test18 bidon
 tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
 tp1bis Truc oups test24 loop horibilis PropSet natbool
 zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
 f_arity f_normal Boite boite1 boite2 test_boite Box box1
 zarb test_proj.

(*** Finally, a test more focused on everyday's life situations ***)

Require Import ZArith.

Recursive Extraction two_or_two_plus_one Zdiv_eucl_exist.