(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008-2009                                       *)
(***************************************************************************)

Require Export area_coords_constructions.

(* Those lemma are not proved as they are used only
in a optimisation of the method. *)

Lemma elim_py_a_ratio_right : forall Y O U V A B ro ru rv,
 a_ratio Y O U V ro ru rv ->
 Py A B Y = ro * Py A B O + ru * Py A B U + rv * Py A B V.
Proof.
Admitted.

Lemma elim_signed_area_a_ratio : forall Y O U V A B ro ru rv,
 a_ratio Y O U V ro ru rv ->
 S A B Y = ro * S A B O + ru * S A B U + rv * S A B V.
Proof.
intros.
Admitted.

Lemma elim_py_a_ratio_middle : forall Y O U V A B ro ru rv,
 a_ratio Y O U V ro ru rv ->
 Py A Y B = ro * Py A O B + ru * Py A U B + rv * Py A V B
     - ro*ru*Py O U O - ro*ru*Py O V O - ru*rv * Py U V U.
Proof.
intros.
Admitted.

Lemma elim_py_a_ratio_left_right : forall Y O U V A ro ru rv,
 a_ratio Y O U V ro ru rv ->
 Py Y A Y = ro * (ro * Py O A O + ru * Py O A U + rv * Py O A V) +
                   ru * (ro * Py U A O + ru * Py U A U + rv * Py U A V) +
                   rv * (ro * Py V A O + ru * Py V A U + rv * Py V A V).
Proof.
intros.
rewrite (elim_py_a_ratio_right  Y O U V Y A ro ru rv H).
replace (Py Y A O) with (Py O A Y) by auto with Geom.
replace (Py Y A U) with (Py U A Y) by auto with Geom.
replace (Py Y A V) with (Py V A Y) by auto with Geom.
rewrite (elim_py_a_ratio_right  Y O U V O A ro ru rv H).
rewrite (elim_py_a_ratio_right  Y O U V U A ro ru rv H).
rewrite (elim_py_a_ratio_right  Y O U V V A ro ru rv H).
auto.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Nth.
Require option.Option.
Require list.NthLength.
Require list.Append.
Require list.NthLengthAppend.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Definition pal {a:Type} {a_WT:WhyType a} (x:(list a)) (n:Z): Prop :=
  forall (i:Z), ((0%Z <= i)%Z /\ (i < n)%Z) -> ((list.Nth.nth i
  x) = (list.Nth.nth ((n - 1%Z)%Z - i)%Z x)).

(* Why3 goal *)
Theorem WP_parameter_palindrome_rec : forall {a:Type} {a_WT:WhyType a},
  forall (x:(list a)) (y:(list a)),
  ((list.Length.length y) <= (list.Length.length x))%Z -> forall (x1:a)
  (x2:(list a)), (y = (Init.Datatypes.cons x1 x2)) -> forall (x3:a)
  (x4:(list a)), (x2 = (Init.Datatypes.cons x3 x4)) -> forall (x5:a)
  (x6:(list a)), (x = (Init.Datatypes.cons x5 x6)) ->
  (((list.Length.length x4) <= (list.Length.length x6))%Z -> ((exists i:Z,
  ((0%Z <= i)%Z /\ (i < (list.Length.length x4))%Z) /\ ~ ((list.Nth.nth i
  x6) = (list.Nth.nth (((list.Length.length x4) - 1%Z)%Z - i)%Z x6))) ->
  exists i:Z, ((0%Z <= i)%Z /\ (i < (list.Length.length y))%Z) /\
  ~ ((list.Nth.nth i
  x) = (list.Nth.nth (((list.Length.length y) - 1%Z)%Z - i)%Z x)))).
(* Why3 intros a a_WT x y h1 x1 x2 h2 x3 x4 h3 x5 x6 h4 h5 (i,((h6,h7),h8)). *)
intros a a_WT x y h1 x1 x2 h2 x3 x4 h3 x5 x6 h4 hl (i,(hi1,hi2)).
subst.
exists (i+1)%Z; intuition.
unfold Length.length. fold Length.length.
omega.
unfold Length.length in *. fold Length.length in *.
assert (Nth.nth (i+1) (x5 :: x6) = Nth.nth i x6).
  unfold Nth.nth; fold Nth.nth.
  generalize (Zeq_bool_eq (i+1) 0).
  destruct (Zeq_bool (i+1) 0).
  intuition.
  elimtype False.
  omega.
  intuition.
  replace (i+1-1)%Z with i by omega. auto.
replace (1 + (1 + Length.length x4) - 1 - (i + 1))%Z
         with (1 + Length.length x4 - 1 - i)%Z
  in H1 by omega.
assert (Nth.nth (1 + Length.length x4 - 1 - i) (x5 :: x6) =
        Nth.nth (Length.length x4 - 1 - i) x6).
    unfold Nth.nth; fold Nth.nth.
  generalize (Zeq_bool_eq (1 + Length.length x4 - 1 - i) 0).
    destruct (Zeq_bool (1 + Length.length x4 - 1 - i) 0).
  intuition; elimtype False; omega.
  intuition.
  replace (1 + Length.length x4 - 1 - i - 1)%Z with (Length.length x4 - 1 - i)%Z
  by omega; auto.
congruence.
Qed.


(** * Coq Proof Environment : Example *)

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = (negb x)) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H [].
  - rewrite -> H; rewrite -> H. reflexivity.
  - rewrite -> H; rewrite -> H. reflexivity. Qed.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Loops.
Require Import Rupicola.Lib.ControlFlow.DownTo.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Arithmetic.FLia.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Field.Interface.Compilation2.
Require Import Crypto.Algebra.Hierarchy.
Require Import Numbers.DecimalString.

Local Open Scope Z_scope.

Section Utils.

    Lemma Nat_iter_plus_one :
      forall A f k (x : A), Nat.iter k f (f x) = Nat.iter (S k) f x.
    Proof.
      intros.
      induction k.
      - reflexivity.
      - simpl.
        rewrite IHk.
        f_equal.
    Qed.

End Utils.

Section FElems.

  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Section Impl.
    Context (m : positive).
    Fixpoint exp_by_squaring (x : F m) (n : positive) : F m :=
      match n with
      | 1    => x
      | n'~0 => let/n res := exp_by_squaring x n' in
                let/n res := F.pow res 2 in
                res
      | n'~1 => let/n res := exp_by_squaring x n' in
                let/n res := F.pow res 2 in
                let/n res := F.mul x res in
                res
      end%positive.

    Fixpoint run_length_encoding (n : positive) : list (bool * nat) :=
      match n with
      | xH => [(true, 0)]
      | xO n' =>
        match (run_length_encoding n') with
        | (false, k) :: t => (false, k + 1) :: t
        | t => (false, 0) :: t
        end
      | xI n' =>
        match (run_length_encoding n') with
        | (true, k) :: t => (true, k + 1) :: t
        | t => (true, 0) :: t
        end
      end%nat.

    Definition exp_square_and_multiply (x : F m) (x' : F m) :=
      let/n res := F.pow x' 2 in
      let/n res := F.mul res x in
      res.

    Definition exp_square (x' : F m) :=
      let/n res := F.pow x' 2 in
      res.

    Fixpoint exp_from_encoding_simple (x : F m) (n : list (bool * nat)) : F m :=
      match n with
      | [] =>
        1
      (* can add more cases for small k to be faster *)
      | (true, 0%nat) :: t =>
        let/n res := exp_from_encoding_simple x t in
        let/n res := F.pow res 2 in
        let/n res := F.mul x res in
        res
      | (true, k) :: t =>
        let/n res := exp_from_encoding_simple x t in
        let/n res := Nat.iter (S k) (exp_square_and_multiply x) res in
        res
      | (false, 0%nat) :: t =>
        let/n res := exp_from_encoding_simple x t in
        let/n res := F.pow res 2 in
        res
      | (false, k) :: t =>
        let/n res := exp_from_encoding_simple x t in
        let/n res := Nat.iter (S k) (exp_square) res in
        res
      end.

    Fixpoint exp_from_encoding (x : F m) (n : list (bool * nat)) : F m :=
      match n with
      | [] =>
        1
      | [(true, 0%nat)] =>
        x
      | [(true, 1%nat)] =>
        let/n res := F.pow x 2 in
        let/n res := F.mul x res in
        res
      | [(true, (S k))] =>
        let/n res := F.pow x 2 in
        let/n res := F.mul x res in
        let/n res := Nat.iter k (exp_square_and_multiply x) res in
        res
      | [(false, 0%nat); (true, 0%nat)] =>
        let/n res := F.pow x 2 in
        res
      | [(false, k); (true, 0%nat)] =>
        let/n res := F.pow x 2 in
        let/n res := Nat.iter k (exp_square) res in
        res
      | (true, 0%nat) :: t =>
        let/n res := exp_from_encoding x t in
        let/n res := F.pow res 2 in
        let/n res := F.mul x res in
        res
      | (true, k) :: t =>
        let/n res := exp_from_encoding x t in
        let/n res := Nat.iter (S k) (exp_square_and_multiply x) res in
        res
      | (false, 0%nat) :: t =>
        let/n res := exp_from_encoding x t in
        let/n res := F.pow res 2 in
        res
      | (false, k) :: t =>
        let/n res := exp_from_encoding x t in
        let/n res := Nat.iter (S k) (exp_square) res in
        res
      end.

    Definition exp_by_squaring_encoded_simple (x : F m) (n : positive) : F m :=
      exp_from_encoding_simple x (run_length_encoding n).

    Definition exp_by_squaring_encoded (x : F m) (n : positive) : F m :=
      exp_from_encoding x (run_length_encoding n).
  End Impl.

  Section Proofs.
    Context (m : positive).

    Lemma F_mul_1_r : forall x : F m,
        (x * 1)%F = x.
    Proof.
      intros.
      F_lia.
    Qed.

    Lemma F_mul_1_l : forall x : F m,
        (1 * x)%F = x.
    Proof.
      intros.
      F_lia.
    Qed.

    Create HintDb F_pow.
    Hint Rewrite @F.pow_2_r : F_pow.
    Hint Rewrite @F.pow_add_r : F_pow.
    Hint Rewrite @F.pow_mul_l : F_pow.
    Hint Rewrite <- @F.pow_pow_l : F_pow.
    Hint Rewrite @F.pow_1_r : F_pow.
    Hint Rewrite @F.pow_3_r : F_pow.

    Ltac simplify_F :=
      unfold nlet;
      autorewrite with F_pow;
      repeat rewrite F_mul_1_r;
      repeat rewrite F_mul_1_l;
      try reflexivity;
      try F_lia.

    Definition Pos2N_pos_xI n : N.pos n~1 = (2 * N.pos n + 1)%N := eq_refl.
    Definition Pos2N_pos_xO n : N.pos n~0 = (2 * N.pos n)%N := eq_refl.

     Lemma exp_by_squaring_correct :
      forall n x, exp_by_squaring m x n = (x ^ N.pos n)%F.
    Proof.
      induction n; intros; cbn [exp_by_squaring]; unfold nlet;
        rewrite (Pos2N_pos_xI n) || rewrite (Pos2N_pos_xO n) || idtac.
      all: try rewrite IHn.
      all: try destruct n eqn : H'; autorewrite with F_pow; try reflexivity.
      all: F_lia.
    Qed.

     Lemma run_length_encoding_nonempty:
      forall n, run_length_encoding n <> [].
    Proof.
      destruct n eqn : H'; simpl.
      + destruct (run_length_encoding p).
        { inversion 1. }
        destruct p0; destruct b; inversion 1.
      + destruct (run_length_encoding p).
        { inversion 1. }
        destruct p0; destruct b; inversion 1.
      + inversion 1.
    Qed.

    Lemma exp_by_squaring_encoded_simple_correct :
      forall n x, exp_by_squaring_encoded_simple m x n = (x ^ N.pos n)%F.
    Proof.
      intros. rewrite <- exp_by_squaring_correct; eauto.
      unfold exp_by_squaring_encoded_simple; induction n; simpl.
      - destruct (run_length_encoding n) eqn : Heq.
        + apply run_length_encoding_nonempty in Heq.
          inversion Heq.
        + destruct p. destruct b.
          * rewrite <- IHn.
            cbn. replace (n0 + 1)%nat with (S n0) by lia.
            unfold nlet; destruct n0; cbn; destruct n eqn : H'; unfold exp_square_and_multiply; unfold nlet; set (exp_from_encoding_simple _ x l) as expxl; F_lia.
          * rewrite <- IHn.
            cbn.
            unfold nlet.
            destruct n0; destruct n eqn : H'; try reflexivity.
      - rewrite <- IHn.
        destruct n eqn : H'.
        * destruct (run_length_encoding p~1) as [|[[|] n0] t]; try reflexivity.
          simpl.
          replace (n0 + 1)%nat with (S n0) by lia.
          unfold nlet.
          cbn.
          unfold exp_square.
          destruct n0; cbv [nlet Nat.iter]; simpl; F_lia.
        * destruct (run_length_encoding p~0) as [|[[|] n0] t]; try reflexivity.
          simpl.
          replace (n0 + 1)% nat with (S n0) by lia.
          unfold nlet.
          simpl.
          unfold exp_square.
          destruct n0; cbv [nlet Nat.iter]; simpl; F_lia.
        * unfold run_length_encoding.
          unfold exp_from_encoding_simple.
          simplify_F.
      - simplify_F.
    Qed.

    Lemma exp_by_squaring_encoded_correct :
      forall n x, exp_by_squaring_encoded m x n = (x ^ N.pos n)%F.

    Proof.
      intros. rewrite <- exp_by_squaring_encoded_simple_correct; eauto.
      unfold exp_by_squaring_encoded. unfold exp_by_squaring_encoded_simple.
      induction (run_length_encoding n).
      - cbn.
        reflexivity.
      - destruct a.
        destruct b; simpl exp_from_encoding; unfold exp_from_encoding_simple; fold exp_from_encoding_simple; destruct n0; try destruct n0; destruct l; try rewrite IHl; simpl exp_from_encoding_simple; try simplify_F.
        + unfold exp_square_and_multiply.
          simpl Nat.iter.
          simplify_F.
        + pose Nat_iter_plus_one.
          specialize e with (f := exp_square_and_multiply m x) (k := S (S n0)) (x := 1%F).
          rewrite <- e.
          replace (exp_square_and_multiply m x 1) with x.
          2: { unfold exp_square_and_multiply; simplify_F. }
          pose Nat_iter_plus_one.
          specialize e0 with (f := exp_square_and_multiply m x) (k := (S n0)) (x := x).
          rewrite <- e0.
          f_equal.
          unfold exp_square_and_multiply.
          simplify_F.
        + destruct p; destruct b; destruct n0; eauto.
          destruct l; eauto.
          unfold exp_from_encoding_simple.
          simplify_F.
        + destruct p; destruct b; destruct n0; eauto.
          destruct l; eauto.
          unfold exp_from_encoding_simple, exp_square.
          simpl Nat.iter.
          simplify_F.
        + destruct p; destruct b; destruct n1; eauto.
          destruct l; eauto.
          unfold exp_from_encoding_simple.
          simplify_F.
          pose Nat_iter_plus_one.
          specialize e with (f := exp_square m) (k := (S (S n0))) (x := x).
          rewrite <- e.
          unfold exp_square.
          simplify_F.
    Qed.

    Lemma clean_width :
      forall x, x < 2 ^ 32 -> x < 2 ^ width.
    Proof.
      intros; destruct width_cases as [ -> | -> ]; lia.
    Qed.

  End Proofs.

  Section Bedrock2.
    Section Lowering.
      Lemma letn_equal :
        forall A B (val : A) (body_l body_r : A -> B) (var : string),
          (let x := val in body_l x = body_r x)
          -> (let/n x as var := val in body_l x) = (let/n y as var := val in body_r y).
      Proof.
        intros. assumption.
      Qed.

      Lemma letn_nested :
        forall A B C (a : C) (val1 : A) (body1 : A -> B) (body2 : B -> C) (var var' : string),
          a = (let/n x as var' := val1 in let/n y as var := body1 x in body2 y)
          -> a = (let/n y as var := let/n x as var' := val1 in body1 x in body2 y).
      Proof.
        intros. assumption.
      Qed.

      Lemma letn_paren_equal :
        forall A B (a : A) (val : A) (body_r : A -> B) (var : string) left,
          left = (let/n y as var := val in (a, body_r y))
          -> left = (a, let/n y as var := val in body_r y).
      Proof.
        intros.
        rewrite H. reflexivity.
      Qed.
    End Lowering.

    Section Compilation.
      Hint Resolve @relax_bounds : compiler.

      Create HintDb lowering.
      Hint Unfold exp_by_squaring : lowering.
      Hint Unfold exp_by_squaring_encoded : lowering.
      Hint Unfold exp_from_encoding : lowering.
      Hint Unfold exp_by_squaring_encoded_simple : lowering.
      Hint Unfold exp_from_encoding_simple : lowering.
      Hint Unfold run_length_encoding : lowering.
      Hint Unfold exp_square : lowering.
      Hint Unfold exp_square_and_multiply : lowering.

      Ltac lower_step :=
        match goal with
        | [ |- forall _, _ ] =>
          intros
        | [ |- let _ := _ in _ = _ ] =>
          intros
        | [ |- _ = let/n _ as _ := ?x in _] =>
          is_var x; change (nlet _ ?x ?k) with (k x) at 1; cbv beta
        | [ |- _ = let/n _ as _ := (let/n _ as _ := _ in _) in _] =>
          eapply letn_nested
        | [ |- _ = let/n _ as _ := _ in _] =>
          eapply letn_equal with (body_l := fun _ => _)
        | [ |- _ = (_, let/n _ as _ := _ in _)] =>
          eapply letn_paren_equal
        end.

      Ltac lower_setup :=
        autounfold with lowering;
        lazymatch goal with
        | [ H := _ |- _ ] =>
          subst H
        end;
        repeat simpl Nat.add;
        cbn -[Nat.iter].

      Ltac lower :=
        lower_setup;
        repeat lower_step;
        reflexivity.

      (* TODO: Move to Rupicola's standard library and check if it breaks anything*)
      Ltac compile_try_copy_pointer :=
        lazymatch goal with
        | [ |- WeakestPrecondition.cmd _ _ _ ?mem _ (_ (nlet_eq [ _ ] ?x _)) ] =>
          lazymatch goal with
          | [ H : ?pred mem |- _ ] =>
            lazymatch pred with
            | context [ ?data ?ptr x ] =>
              simple eapply @compile_copy_pointer with (x_ptr := ptr) (Data := data)
            end
          end
        end.

      Local Ltac ecancel_assumption ::= ecancel_assumption_impl.

      Context {field_parameters : FieldParameters}.
      Context {field_representaton : FieldRepresentation}.
      Context {field_representation_ok : FieldRepresentation_ok}.

      Definition exp (e : positive) (x : F M_pos) := F.pow x (N.pos e).

      Instance spec_of_exp_6
      : spec_of "exp_6" :=
        fnspec! "exp_6" (sq_ptr x_ptr : word) / (sq x : F M_pos) R,
        { requires tr mem :=
            (FElem (Some tight_bounds) x_ptr x
             * FElem (Some tight_bounds) sq_ptr sq * R)%sep mem;
          ensures tr' mem' :=
            tr = tr'
            /\ (FElem (Some tight_bounds) x_ptr x
                * FElem (Some tight_bounds) sq_ptr (exp 6 x) * R)%sep mem'}.

      Ltac rewrite_exponentiation lemma :=
        lazymatch goal with
        | |- WeakestPrecondition.cmd _ _ _ ?mem _ (_ (?x ^ N.pos ?n)%F) =>
          eassert (?[rewritten] = (x ^ N.pos n)%F) as <-
              by (rewrite <- lemma by assumption;
                  lower; reflexivity)
        end.

      Section Exp_by_squaring.
        Hint Extern 1 => rewrite_exponentiation exp_by_squaring_correct; shelve : compiler_cleanup.

        Derive exp_6_body SuchThat
          (defn! "exp_6" ("res", "x") { exp_6_body },
          implements (exp 6) using [square; mul])
          As exp_6_body_correct.
        Proof.
          compile.
        Qed.
      End Exp_by_squaring.

      Instance spec_of_exp97 : spec_of "exp_97" :=
        fnspec! "exp_97" (sq_ptr x_ptr : word) / (sq x : F M_pos) R,
        { requires tr mem :=
            (FElem (Some tight_bounds) x_ptr x
             * FElem (Some tight_bounds) sq_ptr sq * R)%sep mem;
          ensures tr' mem' :=
            tr = tr'
            /\ (FElem (Some tight_bounds) x_ptr x
                * FElem (Some tight_bounds) sq_ptr (exp 97 x)  * R)%sep mem'}.

      Local Instance spec_of_exp_large : spec_of "fe25519_inv" :=
        fnspec! "fe25519_inv" (sq_ptr x_ptr : word) / (sq x : F M_pos) R,
        { requires tr mem :=
            (FElem (Some tight_bounds) x_ptr x
             * FElem None sq_ptr sq * R)%sep mem;
          ensures tr' mem' :=
            tr = tr'
            /\ (FElem (Some tight_bounds) x_ptr x
            * FElem (Some tight_bounds) sq_ptr (exp (2^255-21) x)  * R)%sep mem'}.

      Import LoopCompiler.
      Hint Resolve clean_width : compiler_side_conditions.
      Hint Extern 10 => lia : compiler_side_conditions.
      Hint Extern 1 => simple apply compile_square; shelve : compiler.
      Hint Extern 1 => simple apply compile_mul; shelve : compiler.
      Hint Extern 1 => compile_downto; shelve : compiler.
      Hint Extern 1 => compile_try_copy_pointer; shelve : compiler.

      Hint Extern 1 => rewrite_exponentiation exp_by_squaring_encoded_correct; shelve : compiler_cleanup.

      Derive exp_97_body SuchThat
             (defn! "exp_97" ("res", "x") { exp_97_body },
              implements (exp 97) using [square; mul])
             As exp_97_body_correct.
      Proof.
        compile.
      Qed.

      Print Assumptions exp_6_body. (* does not depend on [width] or [word] *)
      Print Assumptions exp_97_body. (* depends on [width] and  [word] :/ *)

      Derive fe25519_inv SuchThat
             (defn! "fe25519_inv" ("res", "x") { fe25519_inv },
              implements (exp (2^255-21)) using [square; mul])
             As fe25519_inv_correct_exp.
      Proof.
        compile.
      Qed.

      Context { F_M_pos : Z.pos M_pos = 2^255-19 }.
      Require Import Crypto.Spec.Curve25519.

      Lemma compile_inv : forall m l tr functions x,
            let v := F.inv x in
            forall {P} (pred : P v -> predicate) (k : nlet_eq_k P v) {k_impl}
                   (R : map.rep -> Prop) (out : F M_pos)
                   (x_ptr : word.rep) (x_var : string) (out_ptr : word.rep) (out_var : string)
                   (out_bounds : option bounds),

              spec_of_exp_large functions ->

              map.get l out_var = Some out_ptr ->
              map.get l x_var = Some x_ptr ->
              (FElem out_bounds out_ptr out ⋆ FElem (Some tight_bounds) x_ptr x ⋆ R) m ->

              (let v := v in
               forall m',
                 (FElem (Some loose_bounds) out_ptr v ⋆ FElem (Some tight_bounds) x_ptr x ⋆ R) m' ->
                 <{ Trace := tr; Memory := m'; Locals := l; Functions := functions }>
                 k_impl
                 <{ pred (k v eq_refl) }>) ->

              <{ Trace := tr; Memory := m; Locals := l; Functions := functions }>

              cmd.seq (cmd.call [] "fe25519_inv" [expr.var out_var; expr.var x_var]) k_impl

              <{ pred (let/n x as out_var eq:Heq := v in k x Heq) }>.
      Proof.
        repeat straightline.
        repeat (eexists; split; eauto).
        straightline_call.
        ecancel_assumption.
        repeat (eexists; split; eauto).
        repeat compile_step.
        unfold nlet_eq.
        intuition subst.
        eapply H3.
        repeat compile_step.
        intuition subst.
        subst v.
        replace (F.inv x) with (exp (2^255-21) x).
        2: { unshelve erewrite F.Fq_inv_fermat; rewrite F_M_pos; try vm_decide.
             exact Curve25519.prime_p.
             eauto.
        }
        ecancel_assumption.
      Qed.

      (*
      Context { F_M_pos : Z.pos M_pos = 2^255-19 }.
      Require Import Crypto.Spec.Curve25519.

      Derive fe25519_inv SuchThat
             (defn! inv ("res", "x") { fe25519_inv },
             implements (exp (2^255-21)) using [square; mul])
             As fe25519_inv_correct_exp.
      Proof.
        (* replace (exp (2^255-21)) with @F.inv.*)
        compile_setup_unfold_spec_of.
        unfold spec_of_UnOp, un_inv, un_model.
        cbv [ spec_of_UnOp unop_spec un_inv un_model ].
        intros.
        replace (F.inv (feval x)) with (exp (2^255-21) (feval x)).
        2: { unshelve erewrite F.Fq_inv_fermat; rewrite F_M_pos; try vm_decide.
             exact Curve25519.prime_p.
             lia.
             unfold feval; eauto.
        }
        compile_setup.
        rewrite_exponentiation exp_by_squaring_encoded_correct.

        destruct H2.
        destruct H3.
        destruct H3.

        eassert ((FElem _ px _ * _) mem0)%sep.
        unfold FElem.
        sepsimpl.
        eexists.
        sepsimpl.
        reflexivity.
        unfold un_xbounds in H2.

        unfold maybe_bounded.
        let x := open_constr:(Some _) in instantiate(2:=x).
        simpl.
        eapply H2.
        eapply H3.

        compile_step.
        compile_step.
        compile_step.

        unfold maybe_bounded.
        unfold un_xbounds in H2.
        unfold FElem.
        sepsimpl.
        eexists.
        sepsimpl.
        reflexivity.
        instantiate (2 := None).
        eauto.
        eapply H4.

        compile_step.
        compile_step.

        Set Typeclasses Debug.
        compile_step.
        Set Typeclasses Debug.
        compile_step.
        compile_step.
        compile_step.
        compile_step.

        instantiate (2 := pout). instantiate (1 := Rr).

        About fe25519.
        Print UnOp.
        Print Build_UnOp.
        Search UnOp.

        eapply H6.
        compile_step.

        let x := open_constr:(Some _) in instantiate(2:=pout).
        simpl.
        eapply H2.
        eapply H3.
        compile_step.

        ecancel_assumption.

        compile_step.
        compile_step.
        compile_step.
        compile_step.

        Set Typeclasses Debug.
        repeat compile_step.

        inversion H5.

        3: { instantiate (2 := "x"). repeat compile_step. }
        3: { instantiate (1 := "x"). repeat compile_step. }

        change (fun x => ?c x) with c.

    Global Instance spec_of_fe25519_inv : spec_of "fe25519_inv" :=
      fnspec! "fe25519_inv" (sq_ptr x_ptr : word) / (sq x : F M_pos) R,
      { requires tr mem :=
          (FElem (Some tight_bounds) x_ptr x
           * FElem (Some tight_bounds) sq_ptr sq * R)%sep mem;
        ensures tr' mem' :=
          tr = tr'
          /\ (FElem (Some tight_bounds) x_ptr x
          * FElem (Some tight_bounds) sq_ptr (F.inv x)  * R)%sep mem'}.

    Require Import Crypto.Spec.Curve25519. *)
    Lemma fe_inv_correct :
      Z.pos M_pos = 2^255-19 ->
      program_logic_goal_for_function! fe25519_inv.
    Proof.
      intros Hm HmPrime ? ** ? **.
      eapply Proper_call; [|eapply fe25519_inv_correct_exp; eauto 1; exact I].
      intros ? ** ? ** ? ** ?; intuition idtac.
    Qed.

    End Compilation.
  End Bedrock2.
End FElems.

(* LATER: Make a separate compilation lemma for (loop) *)

Require Import bedrock2.BasicC64Semantics.

Section Extraction.
  Definition _M_pos := (2 ^ 255 - 19)%positive.
  Context (_a24: F _M_pos).

  Instance fp : FieldParameters :=
    {| M_pos := _M_pos;
       a24 := _a24;
       mul := "mul";
       add := "add";
       sub := "sub";
       opp := "opp";
       square := "square";
       scmula24 := "scmula24";
       inv := "inv";
       from_bytes := "from_bytes";
       to_bytes := "to_bytes";
       select_znz := "select_znz";
       felem_copy := "felem_copy";
       from_word := "from_word" |}.
End Extraction.

#[export] Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (F.inv _) _))) =>
simple eapply compile_inv; shelve : compiler.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg perm zmodp matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop proba.
Require Import entropy binary_entropy_function channel hamming channel_code.

(** * Capacity of the binary symmetric channel *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope channel_scope.

(** Definition of the Binary Symmetric Channel (BSC) *)

Module BSC.
Section BSC_sect.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : R.
Hypothesis p_01 : 0 <= p <= 1.

Definition c : `Ch_1(A, A) :=
  fun a => locked (makeDist (Binary.f0 p_01 a) (Binary.f1 card_A p a)).

Lemma cE a : c a =1 Binary.f p a. Proof. rewrite /c; by unlock. Qed.

End BSC_sect.
End BSC.

Lemma closed p : 0 < p < 1 -> 0 <= p <= 1.
Proof. case => ?; split; by apply Rlt_le. Qed.

Local Open Scope channel_scope.
Local Open Scope entropy_scope.

Section bsc_capacity_proof.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable P : dist A.
Variable p : R.
Hypothesis p_01' : (0 < p < 1)%R.

Let p_01 := closed p_01'.

Lemma HP_HPW : `H P - `H(P , BSC.c card_A p_01) = - H2 p.
Proof.
rewrite {2}/entropy /=.
rewrite (eq_bigr (fun a => (`J( P, (BSC.c card_A p_01))) (a.1, a.2) *
  log ((`J( P, (BSC.c card_A p_01))) (a.1, a.2)))); last by case.
rewrite -(pair_big xpredT xpredT (fun a b => (`J( P, (BSC.c card_A p_01)))
  (a, b) * log ((`J( P, (BSC.c card_A p_01))) (a, b)))) /=.
rewrite {1}/entropy .
set a := \rsum_(_ in _) _. set b := \rsum_(_ <- _) _.
apply trans_eq with (- (a + (-1) * b)); first by field.
rewrite /b {b} big_distrr /= /a {a} -big_split /=.
rewrite !Set2sumE /= !JointDist.dE !BSC.cE /= !Binary.fxx.
rewrite /Binary.f eq_sym !(negbTE (Set2.a_neq_b card_A)) /H2.
set a := Set2.a _. set b := Set2.b _.
case: (Req_EM_T (P a) 0) => H1.
  rewrite H1 !(mul0R, mulR0, addR0, add0R).
  move: (pmf1 P); rewrite Set2sumE /= -/a -/b.
  rewrite H1 add0R => ->.
  rewrite /log Log_1 !(mul0R, mulR0, addR0, add0R, mul1R, mulR1); field.
rewrite /log LogM; last 2 first.
  case: p_01' => ? ?; fourier.
  move/eqP in H1.
  apply/ltRP; rewrite lt0R H1; exact/leRP/dist_ge0.
rewrite /log LogM; last 2 first.
  case: p_01' => ? ?; fourier.
  apply/ltRP; rewrite lt0R; apply/andP; split; [exact/eqP|exact/leRP/dist_ge0].
case: (Req_EM_T (P b) 0) => H2.
  rewrite H2 !(mul0R, mulR0, addR0, add0R).
  move: (pmf1 P); rewrite Set2sumE /= -/a -/b.
  rewrite H2 addR0 => ->.
  rewrite /log Log_1 !(mul0R, mulR0, addR0, add0R, mul1R, mulR1); field.
rewrite /log LogM; last 2 first.
  case: p_01' => ? ?; fourier.
  apply/ltRP; rewrite lt0R; apply/andP; split; [exact/eqP|exact/leRP/dist_ge0].
rewrite /log LogM; last 2 first.
  case: p_01' => ? ?; fourier.
  apply/ltRP; rewrite lt0R; apply/andP; split; [exact/eqP|exact/leRP/dist_ge0].
transitivity (p * (P a + P b) * log p + (1 - p) * (P a + P b) * log (1 - p) ).
  rewrite /log; by field.
move: (pmf1 P); rewrite Set2sumE /= -/a -/b => ->; rewrite /log; by field.
Qed.

Lemma IPW : `I(P ; BSC.c card_A p_01) = `H(P `o BSC.c card_A p_01) - H2 p.
Proof.
rewrite /mut_info addRC.
set a := `H(_ `o _).
apply trans_eq with (a + (`H P - `H(P , BSC.c card_A p_01))); first by field.
by rewrite HP_HPW.
Qed.

Lemma H_out_max : `H(P `o BSC.c card_A p_01) <= 1.
Proof.
rewrite {1}/entropy /= Set2sumE /= !OutDist.dE 2!Set2sumE /=.
set a := Set2.a _. set b := Set2.b _.
rewrite !BSC.cE !Binary.fxx /Binary.f /= !(eq_sym _ a).
rewrite (negbTE (Set2.a_neq_b card_A)).
move: (pmf1 P); rewrite Set2sumE /= -/a -/b => P1.
have -> : p * P a + (1 - p) * P b = 1 - ((1 - p) * P a + p * P b).
  rewrite -{2}P1; by field.
have H01 : 0 < ((1 - p) * P a + p * P b) < 1.
  move: (dist_ge0 P a) => H1.
  move: (dist_max P b) => H4.
  move: (dist_max P a) => H3.
  case: p_01' => Hp1 Hp2.
  split.
    case/Rle_lt_or_eq_dec : H1 => H1.
    - apply addR_gt0wl; by [apply mulR_gt0; fourier | apply mulR_ge0; fourier].
    - by rewrite -H1 mulR0 add0R (_ : P b = 1) ?mulR1 // -P1 -H1 add0R.
  rewrite -{2}P1.
  case: (Req_EM_T (P a) 0) => Hi.
    rewrite Hi mulR0 !add0R.
    rewrite Hi add0R in P1.
    by rewrite P1 mulR1.
  case: (Req_EM_T (P b) 0) => Hj.
    rewrite Hj addR0 in P1.
    rewrite Hj mulR0 !addR0 P1 mulR1.
    fourier.
    case/Rle_lt_or_eq_dec : H1 => H1.
    - apply leR_lt_add.
      + rewrite -{2}(mul1R (P a)); apply leR_wpmul2r; fourier.
      + rewrite -{2}(mul1R (P b)); apply ltR_pmul2r => //.
        apply/ltRP; rewrite lt0R; apply/andP; split; [exact/eqP|exact/leRP/dist_ge0].
    - rewrite -H1 mulR0 2!add0R.
      have -> : P b = 1 by rewrite -P1 -H1 add0R.
      by rewrite mulR1.
rewrite (_ : forall a b, - (a + b) = - a - b); last by move=> *; field.
rewrite -mulNR.
set q := (1 - p) * P a + p * P b.
apply: (@leR_trans (H2 q)); last exact: H2_max.
rewrite /H2 !mulNR; apply Req_le; field.
Qed.

Lemma bsc_out_H_half' : 0 < INR 1 / INR 2 < 1.
Proof. rewrite /= (_ : INR 1 = 1) // (_ : INR 2 = 2) //; split; fourier. Qed.

Lemma H_out_binary_uniform :
  `H(Uniform.d card_A `o BSC.c card_A p_01) = 1.
Proof.
rewrite {1}/entropy !Set2sumE /= !OutDist.dE !Set2sumE /=.
rewrite !BSC.cE !Binary.fxx /Binary.f (eq_sym _ (Set2.a _)).
rewrite (negbTE (Set2.a_neq_b card_A)).
rewrite -!mulRDl (_ : 1 - p + p = 1); last by field.
rewrite mul1R (_ : p + (1 - p) = 1); last by field.
rewrite mul1R -!mulRDl /= /Uniform.f card_A /=.
rewrite (_ : INR 1 = 1) // (_ : INR 2 = 2) // div1R /log LogV; last by fourier.
rewrite Log_n //=; field.
Qed.

End bsc_capacity_proof.

Section bsc_capacity_theorem.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : R.
Hypothesis p_01' : 0 < p < 1.
Let p_01 := closed p_01'.

(** The capacity of a Binary Symmetric Channel: *)

Theorem BSC_capacity : capacity (BSC.c card_A p_01) (1 - H2 p).
Proof.
rewrite /capacity; split.
- move=> d.
  move: (@IPW _ card_A d _ p_01') => tmp.
  suff : `H(d `o BSC.c card_A p_01) <= 1.
    move=> ?.
    unfold p_01 in *.
    fourier.
  by apply H_out_max.
- move=> d Hd.
  move: (@IPW _ card_A (Uniform.d card_A) _ p_01').
  rewrite H_out_binary_uniform => <-.
  by apply Hd.
Qed.

End bsc_capacity_theorem.

Section dH_BSC.

Variable p : R.
Hypothesis p_01 : (0 <= p <= 1)%R.

Let card_F2 : #| 'F_2 | = 2%nat. by rewrite card_Fp. Qed.

Let W := BSC.c card_F2 p_01.

Variables (M : finType) (n : nat) (f : encT [finType of 'F_2] M n).

Local Open Scope vec_ext_scope.

Lemma DMC_BSC_prop : forall m y,
  let d := dH y (f m) in
  W ``(y | (f m)) = ((1 - p) ^ (n - d) * p ^ d)%R.
Proof.
move=> m y d.
rewrite DMCE.
transitivity ((\rprod_(i < n | (f m) ``_ i == y ``_ i) (1 - p)) *
              (\rprod_(i < n | (f m) ``_ i != y ``_ i) p))%R.
  rewrite (bigID [pred i | (f m) ``_ i == y ``_ i]) /=.
  congr (_ * _).
  by apply eq_bigr => // i /eqP ->; rewrite BSC.cE Binary.fxx.
  apply eq_bigr => //= i /negbTE Htmp; rewrite BSC.cE /Binary.f eq_sym; by rewrite Htmp.
congr (_ * _).
by rewrite big_const /= iter_mulR /= card_dHC.
by rewrite big_const /= iter_mulR /= card_dH_vec.
Qed.

Local Close Scope vec_ext_scope.

End dH_BSC.


(** the concept of left action of a monoidal category on a category

written by Ralph Matthes in lockstep with the code in [UniMath.CategoryTheory.MonoidalOld.MonoidalCategoriesWhiskered]

naming is inspired from https://ncatlab.org/nlab/show/actegory:
the whole structure is an [actegory], the binary operation is the [action], the extra data are the [action_unitor] and the [actor], together with their inverses

2022

*)

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Foundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.

Section A.

Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *)

(** Data **)
Definition action_data (C : category) : UU :=
  bifunctor_data V C C.
Identity Coercion actionintobifunctor : action_data >-> bifunctor_data.

(** the following widens the concept of left unitor of a monoidal category, a right unitor is not appropriate for actions *)
Definition action_unitor_data {C : category} (A : action_data C) : UU :=
  ∏ (x : C), C⟦I_{Mon_V} ⊗_{A} x, x⟧.

Definition action_unitorinv_data {C : category} (A : action_data C) : UU :=
  ∏ (x : C), C⟦x, I_{Mon_V} ⊗_{A} x⟧.

Definition actor_data {C : category} (A : action_data C) : UU :=
  ∏ (v w : V) (x : C), C ⟦(v ⊗_{Mon_V} w) ⊗_{A} x, v ⊗_{A} (w ⊗_{A} x)⟧.

Definition actorinv_data {C : category} (A : action_data C) : UU :=
  ∏ (v w : V) (x : C), C ⟦v ⊗_{A} (w ⊗_{A} x), (v ⊗_{Mon_V} w) ⊗_{A} x⟧.

Definition actegory_data (C : category) : UU :=
    ∑ A : action_data C,
        (action_unitor_data A) × (action_unitorinv_data A) ×
           (actor_data A) × (actorinv_data A).

Definition make_actegory_data {C : category} {A : action_data C}
  (au : action_unitor_data A) (auinv : action_unitorinv_data A)
  (aα : actor_data A) (aαinv : actorinv_data A) : actegory_data C
  := (A,,au,,auinv,,aα,,aαinv).

Definition actegory_action_data {C : category} (AD : actegory_data C) : action_data C := pr1 AD.
Coercion actegory_action_data : actegory_data >-> action_data.

Definition actegory_unitordata {C : category} (AD : actegory_data C) : action_unitor_data AD
  := pr1 (pr2 AD).
Notation "au_{ AD }" := (actegory_unitordata AD).

Definition actegory_unitorinvdata {C : category} (AD : actegory_data C) : action_unitorinv_data AD
  := pr12 (pr2 AD).
Notation "auinv_{ AD }" := (actegory_unitorinvdata AD).

Definition actegory_actordata {C : category} (AD : actegory_data C) : actor_data AD
  := pr12 (pr2 (pr2 AD)).
Notation "aα_{ AD }" := (actegory_actordata AD).

Definition actegory_actorinvdata {C : category} (AD : actegory_data C) : actorinv_data AD
  := pr22 (pr2 (pr2 AD)).
Notation "aαinv_{ AD }" := (actegory_actorinvdata AD).

(** Axioms **)
Definition action_unitor_nat {C : category} {A : action_data C} (au : action_unitor_data A) : UU :=
  ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  I_{Mon_V} ⊗^{A}_{l} f · au y = au x · f.

Definition action_unitorinv_nat {C : category} {A : action_data C} (auinv : action_unitorinv_data A) : UU :=
  ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  auinv x · I_{Mon_V} ⊗^{A}_{l} f = f · auinv y.

Definition action_unitor_iso_law {C : category} {A : action_data C} (au : action_unitor_data A) (auinv : action_unitorinv_data A) : UU :=
  ∏ (x : C), is_inverse_in_precat (au x) (auinv x).

Definition action_unitor_law {C : category} {A : action_data C} (au : action_unitor_data A) (auinv : action_unitorinv_data A) : UU :=
  action_unitor_nat au × action_unitor_iso_law au auinv.

Definition action_unitorlaw_nat {C : category} {A : action_data C} {au : action_unitor_data A} {auinv : action_unitorinv_data A}
  (aul : action_unitor_law au auinv) : action_unitor_nat au := pr1 aul.

Definition action_unitorlaw_iso_law {C : category} {A : action_data C} {au : action_unitor_data A} {auinv : action_unitorinv_data A}
  (aul : action_unitor_law au auinv) : action_unitor_iso_law au auinv := pr2 aul.

Definition actor_nat_leftwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU
  := ∏ (v w : V) (z z' : C) (h : C⟦z,z'⟧),
    (aα v w z) · (v ⊗^{A}_{l} (w ⊗^{A}_{l} h)) = ((v ⊗_{Mon_V} w) ⊗^{A}_{l} h) · (aα v w z').

Definition actor_nat_rightwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU
  := ∏ (v v' w : V) (z : C) (f : V⟦v,v'⟧),
    (aα v w z) · (f ⊗^{A}_{r} (w ⊗_{A} z)) = ((f ⊗^{Mon_V}_{r} w) ⊗^{A}_{r} z) · (aα v' w z).

Definition actor_nat_leftrightwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU
  := ∏ (v w w' : V) (z : C) (g : V⟦w,w'⟧),
    (aα v w z) · (v ⊗^{A}_{l} (g ⊗^{A}_{r} z)) = ((v ⊗^{Mon_V}_{l} g) ⊗^{A}_{r} z) · (aα v w' z).

Definition actor_iso_law {C : category} {A : action_data C} (aα : actor_data A) (aαinv : actorinv_data A) : UU
  := ∏ (v w : V) (z : C), is_inverse_in_precat (aα v w z) (aαinv v w z).

Definition actor_law {C : category} {A : action_data C} (aα : actor_data A) (aαinv : actorinv_data A) : UU :=
  (actor_nat_leftwhisker aα) × (actor_nat_rightwhisker aα) ×
    (actor_nat_leftrightwhisker aα) × (actor_iso_law aα aαinv).

Definition actorlaw_natleft {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A}
  (aαl : actor_law aα aαinv) : actor_nat_leftwhisker aα := pr1 aαl.
Definition actorlaw_natright {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A}
  (aαl : actor_law aα aαinv) : actor_nat_rightwhisker aα := pr1 (pr2 aαl).
Definition actorlaw_natleftright {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A}
  (aαl : actor_law aα aαinv) : actor_nat_leftrightwhisker aα := pr1 (pr2 (pr2 aαl)).
Definition actorlaw_iso_law {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A}
  (aαl : actor_law aα aαinv) : actor_iso_law aα aαinv := pr2 (pr2 (pr2 aαl)).

Definition actegory_triangle_identity {C : category}
           {A : action_data C}
           (au : action_unitor_data A)
           (aα : actor_data A)
  := ∏ (v : V) (y : C), (aα v I_{Mon_V} y) · (v ⊗^{A}_{l} (au y)) = (ru_{Mon_V} v) ⊗^{A}_{r} y.

Definition actegory_triangle_identity' {C : category}
           {A : action_data C}
           (au : action_unitor_data A)
           (aα : actor_data A)
    := ∏ (v : V) (y : C), (aα I_{Mon_V} v y) · (au (v ⊗_{A} y)) = (lu_{Mon_V} v) ⊗^{A}_{r} y.

Definition actegory_pentagon_identity {C : category} {A : action_data C} (aα : actor_data A) : UU :=
  ∏ (w v v' : V) (z : C),
    ((α_{Mon_V} w v v') ⊗^{A}_{r} z) · (aα w (v ⊗_{Mon_V} v') z) · (w ⊗^{A}_{l} (aα v v' z)) =
      (aα (w⊗_{Mon_V} v) v' z) · (aα w v (v' ⊗_{A} z)).

Definition actegory_laws {C : category} (AD : actegory_data C) : UU :=
  is_bifunctor AD ×
  (action_unitor_law au_{AD} auinv_{AD}) × (actor_law aα_{AD} aαinv_{AD}) ×
    (actegory_triangle_identity au_{AD} aα_{AD}) × (actegory_pentagon_identity aα_{AD}).

Definition actegory (C : category) : UU :=
  ∑ (AD : actegory_data C), (actegory_laws AD).

Definition actegory_actdata {C : category} (Act : actegory C) : actegory_data C := pr1 Act.
Coercion actegory_actdata : actegory >-> actegory_data.

Definition actegory_actlaws {C : category} (Act : actegory C) : actegory_laws Act := pr2 Act.

Definition actegory_action_is_bifunctor {C : category} (Act : actegory C) : is_bifunctor Act
  := pr12 Act.

Coercion actegory_action
         {C : category}
         (Act : actegory C)
  : bifunctor V C C
  := _ ,, actegory_action_is_bifunctor Act.

Definition actegory_unitorlaw {C : category} (Act : actegory C) : action_unitor_law au_{Act} auinv_{Act} := pr12 (actegory_actlaws Act).
Definition actegory_unitornat {C : category} (Act : actegory C) : action_unitor_nat au_{Act} := action_unitorlaw_nat (actegory_unitorlaw Act).
Definition actegory_unitorisolaw {C : category} (Act : actegory C) : action_unitor_iso_law au_{Act} auinv_{Act} := action_unitorlaw_iso_law (actegory_unitorlaw Act).

Lemma actegory_unitorinvnat {C : category} (Act : actegory C) : action_unitorinv_nat auinv_{Act}.
Proof.
  intros x y f.
  apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_unitorisolaw Act x)).
  cbn.
  rewrite assoc.
  apply (z_iso_inv_on_left _ _ _ _ (_,,_,,actegory_unitorisolaw Act y)).
  apply pathsinv0, actegory_unitornat.
Qed.

Definition actegory_actorlaw {C : category} (Act : actegory C) : actor_law aα_{Act} aαinv_{Act} := pr122 (actegory_actlaws Act).
Definition actegory_actornatleft {C : category} (Act : actegory C) : actor_nat_leftwhisker aα_{Act} := actorlaw_natleft (actegory_actorlaw Act).
Definition actegory_actornatright {C : category} (Act : actegory C) : actor_nat_rightwhisker aα_{Act} := actorlaw_natright (actegory_actorlaw Act).
Definition actegory_actornatleftright {C : category} (Act : actegory C) : actor_nat_leftrightwhisker aα_{Act} := actorlaw_natleftright (actegory_actorlaw Act).
Definition actegory_actorisolaw {C : category} (Act : actegory C) : actor_iso_law aα_{Act} aαinv_{Act} := actorlaw_iso_law (actegory_actorlaw Act).

Lemma actor_nat1 {C : category} (Act : actegory C)
  {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) :
  (actegory_actordata Act v w z) · ((f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (v' ⊗^{Act}_{l} ((g ⊗^{Act}_{r} z) · (w' ⊗^{Act}_{l} h)))) =
    (((f ⊗^{Mon_V}_{r} w) · (v' ⊗^{Mon_V}_{l} g))  ⊗^{Act}_{r} z) · ((v' ⊗_{Mon_V} w') ⊗^{Act}_{l} h) · (actegory_actordata Act v' w' z').
Proof.
  rewrite assoc.
  rewrite (actegory_actornatright Act).
  rewrite assoc'.
  etrans. {
    apply cancel_precomposition.
    rewrite (bifunctor_leftcomp Act).
    rewrite assoc.
    rewrite (actegory_actornatleftright Act).
    apply idpath.
  }

  etrans. {
    apply cancel_precomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (actegory_actornatleft Act).
  }
  rewrite assoc.
  rewrite assoc.
  apply cancel_postcomposition.
  apply pathsinv0.
  rewrite (bifunctor_rightcomp Act).
  apply idpath.
Qed.

Lemma actor_nat2 {C : category}  (Act : actegory C)
  {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) :
  (actegory_actordata Act v w z) · (f ⊗^{Act} (g ⊗^{Act} h)) =
    ((f ⊗^{Mon_V} g) ⊗^{Act} h) · (actegory_actordata Act v' w' z').
Proof.
  intros.
  unfold functoronmorphisms1.
  exact (actor_nat1 Act f g h).
Qed.

Definition actegory_triangleidentity {C : category} (Act : actegory C) : actegory_triangle_identity au_{Act} aα_{Act} := pr1 (pr222 (actegory_actlaws Act)).
Definition actegory_pentagonidentity {C : category} (Act : actegory C) : actegory_pentagon_identity aα_{Act} := pr2 (pr222 (actegory_actlaws Act)).

Lemma isaprop_actegory_laws {C : category} (AD : actegory_data C)
  : isaprop (actegory_laws AD).
Proof.
  repeat (apply isapropdirprod)
  ; repeat (apply impred ; intro)
  ; repeat (try apply C)
  ; repeat (apply isaprop_is_inverse_in_precat).
Qed.

(** Some additional data and properties which one deduces from actegories **)

Lemma action_unitor_nat_z_iso {C : category} (Act : actegory C):
  nat_z_iso (leftwhiskering_functor Act I_{Mon_V}) (functor_identity C).
Proof.
  use make_nat_z_iso.
  - use make_nat_trans.
    + exact (λ x, au_{Act} x).
    + exact (λ x y f, actegory_unitornat Act x y f).
  - intro x. exists (auinv_{Act} x).
    apply (actegory_unitorisolaw Act x).
Defined.

Definition z_iso_from_actor_iso
  {C : category} (Act : actegory C) (v w : V) (x : C)
  : z_iso ((v ⊗_{Mon_V} w) ⊗_{Act} x) (v ⊗_{Act} (w ⊗_{Act} x))
  := make_z_iso
       (aα_{Act} v w x)
       (aαinv_{Act} v w x)
       (actegory_actorisolaw Act v w x).

Definition actorinv_nat_leftwhisker {C : category} (Act : actegory C) :
  ∏ (v w : V) (z z' : C) (h : C⟦z,z'⟧),
    (v ⊗^{Act}_{l} (w ⊗^{Act}_{l} h)) · (aαinv_{Act} v w z') = (aαinv_{Act} v w z) · ((v ⊗_{Mon_V} w) ⊗^{Act}_{l} h) .
Proof.
  intros v w z z' h.
  apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v w z')).
  apply actegory_actornatleft.
Qed.

Definition actorinv_nat_rightwhisker {C : category} (Act : actegory C) :
  ∏ (v v' w : V) (z: C) (f : V⟦v,v'⟧),
    (f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (aαinv_{Act} v' w z) = (aαinv_{Act} v w z) · ((f ⊗^{Mon_V}_{r} w) ⊗^{Act}_{r} z).
Proof.
  intros v v' w z f.
  apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v' w z)).
  apply actegory_actornatright.
Qed.

Definition actorinv_nat_leftrightwhisker {C : category} (Act : actegory C) :
  ∏ (v w w' : V) (z : C) (g : V⟦w,w'⟧),
    (v ⊗^{Act}_{l} (g ⊗^{Act}_{r} z)) · (aαinv_{Act} v w' z) = (aαinv_{Act} v w z) · ((v ⊗^{Mon_V}_{l} g) ⊗^{Act}_{r} z).
Proof.
  intros v w w' z g.
  apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v w' z)).
  apply actegory_actornatleftright.
Qed.

Definition actorinv_nat1 {C : category} (Act : actegory C)
  {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) :
  ((f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (v' ⊗^{Act}_{l} ((g ⊗^{Act}_{r} z) · (w' ⊗^{Act}_{l} h)))) · (aαinv_{Act} v' w' z') =
    (aαinv_{Act} v w z) · ((((f ⊗^{Mon_V}_{r} w) · (v' ⊗^{Mon_V}_{l} g)) ⊗^{Act}_{r} z) · ((v' ⊗_{Mon_V} w') ⊗^{ Act}_{l} h)).
Proof.
  apply (swap_nat_along_zisos
           (z_iso_from_actor_iso Act v w z)
           (z_iso_from_actor_iso Act v' w' z')
        ).
  unfold z_iso_from_actor_iso.
  unfold make_z_iso.
  unfold make_is_z_isomorphism.
  unfold pr1.
  apply actor_nat1.
Qed.

Lemma actorinv_nat2 {C : category} (Act : actegory C)
  {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) :
  (f ⊗^{Act} (g ⊗^{Act} h)) · (aαinv_{Act} v' w' z') = (aαinv_{Act} v w z) · ((f ⊗^{Mon_V} g) ⊗^{Act} h).
Proof.
  intros.
  unfold functoronmorphisms1.
  apply actorinv_nat1.
Qed.

Lemma pentagon_identity_actorinv {C : category} (Act : actegory C) (w v u : V) (z : C):
  w ⊗^{ Act}_{l} (aαinv_{Act} v u z)
  · aαinv_{Act} w (v ⊗_{Mon_V} u) z
  · αinv_{Mon_V} w v u ⊗^{Act}_{r} z =
    aαinv_{Act} w v (u ⊗_{Act} z)
  · aαinv_{Act} (w ⊗_{Mon_V} v) u z.
Proof.
  apply pathsinv0.
  apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Act _ _ _)).
  unfold z_iso_from_actor_iso.
  unfold make_z_iso.
  unfold make_is_z_isomorphism.
  etrans. { apply (pathsinv0 (id_right _)). }
  apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Act _ _ _)).
  cbn.
  apply pathsinv0.
  etrans. {
   rewrite assoc.
   apply cancel_postcomposition.
   apply (pathsinv0 (actegory_pentagonidentity Act w v u z)).
  }
  etrans. {
    rewrite assoc.
    rewrite assoc.
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (pathsinv0 (bifunctor_leftcomp Act _ _ _ _ _ _)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply cancel_precomposition.
    apply maponpaths.
    apply (pr2 (z_iso_from_actor_iso Act v u z)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply cancel_precomposition.
    apply (bifunctor_leftid Act).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply id_right.
  }
  etrans. {
    apply cancel_postcomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (pr2 (z_iso_from_actor_iso Act w (v⊗_{Mon_V}u) z)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply id_right.
  }
  etrans. {
    apply (pathsinv0 (bifunctor_rightcomp Act _ _ _ _ _ _)).
  }
  etrans. {
    apply maponpaths.
    apply (pr2 (pr2 (z_iso_from_associator_iso Mon_V w v u))).
  }
  apply (bifunctor_rightid Act).
Qed.

End A.

Arguments actegory_unitordata {_ _ _} _ _.
Arguments actegory_unitorinvdata {_ _ _} _ _.
Arguments actegory_actordata {_ _ _} _ _ _ _.
Arguments actegory_actorinvdata {_ _ _} _ _ _ _.

Module ActegoryNotations.
  Notation "au_{ Act }" := (actegory_unitordata Act).
  Notation "aα_{ Act }" := (actegory_actordata Act).
  Notation "au^{ Act }_{ x }" := (actegory_unitordata Act x ).
  Notation "aα^{ Act }_{ v , w , x }" := (actegory_actordata Act v w x).
  Notation "auinv^{ Act }_{ x }" := (actegory_unitorinvdata Act x ).
  Notation "aαinv^{ Act }_{ v , w , x }" := (actegory_actorinvdata Act v w x).
End ActegoryNotations.

Section EquivalenceFromTensorWithUnit.

  Import MonoidalNotations.
  Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C).

  Definition ladjunction_data_from_action_with_unit
    : Core.adjunction_data C C.
  Proof.
    exists (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}).
    exists (functor_identity C).
    use tpair.
    - apply (nat_z_iso_inv (action_unitor_nat_z_iso _ Act)).
    - apply (action_unitor_nat_z_iso _ Act).
  Defined.

  Definition lequivalence_from_action_with_unit
    : equivalence_of_cats C C.
  Proof.
    exists ladjunction_data_from_action_with_unit.
    split.
    - intro ; apply (nat_z_iso_inv (action_unitor_nat_z_iso _ Act)).
    - intro ; apply (action_unitor_nat_z_iso _ Act).
  Defined.

  Lemma leftwhiskering_fullyfaithful_action
    : fully_faithful (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}).
  Proof.
    apply fully_faithful_from_equivalence.
    exact (adjointificiation lequivalence_from_action_with_unit).
  Defined.

  Lemma leftwhiskering_faithful_action
    : faithful (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}).
  Proof.
    exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ leftwhiskering_fullyfaithful_action)).
  Defined.

End EquivalenceFromTensorWithUnit.

Section SecondTriangleEquality.

  Import MonoidalNotations.
  Import ActegoryNotations.

  Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C).

  Local Lemma lemma0 (v : V) (x : C) :
    (α_{Mon_V} I_{Mon_V} I_{Mon_V} v) ⊗^{Act}_{r} x · (I_{ Mon_V} ⊗^{ Mon_V}_{l} lu^{ Mon_V }_{ v}) ⊗^{ Act}_{r} x =
      (ru^{ Mon_V }_{ I_{ Mon_V}} ⊗^{ Mon_V}_{r} v) ⊗^{ Act}_{r} x.
  Proof.
    refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _).
    apply maponpaths.
    apply (monoidal_triangleidentity Mon_V I_{Mon_V} v).
  Qed.

  Local Lemma lemma2 (v : V) (x : C) :
    I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) = aαinv^{Act}_{ I_{Mon_V}, (I_{Mon_V} ⊗_{Mon_V} v), x} · (((I_{Mon_V} ⊗^{Mon_V}_{l} lu_{Mon_V} v) ⊗^{Act}_{r} x) · aα_{Act} I_{Mon_V} v x).
  Proof.
    set (aαiso := make_z_iso _ _ (actegory_actorisolaw Mon_V Act  I_{Mon_V} (I_{Mon_V} ⊗_{Mon_V} v) x)).
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ aαiso).
    apply pathsinv0.
    apply (actegory_actornatleftright Mon_V Act).
  Qed.

  Local Lemma lemma2' (v : V) (x : C) :
    (I_{ Mon_V} ⊗^{ Mon_V}_{l} lu^{ Mon_V }_{ v}) ⊗^{ Act}_{r} x =
      αinv^{ Mon_V }_{ I_{ Mon_V}, I_{ Mon_V}, v} ⊗^{ Act}_{r} x
             · (ru^{ Mon_V }_{ I_{ Mon_V}} ⊗^{ Mon_V}_{r} v) ⊗^{ Act}_{r} x.
  Proof.
    apply pathsinv0.
    set (αiso := make_z_iso _ _ (monoidal_associatorisolaw Mon_V  I_{Mon_V} I_{Mon_V} v)).
    set (αisor := functor_on_z_iso (rightwhiskering_functor Act x) αiso).
    apply (z_iso_inv_on_right _ _ _ αisor).
    apply pathsinv0.
    apply lemma0.
  Qed.

  Local Lemma lemma3 (v : V) (x : C) :
    I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) =
      aαinv^{Act}_{ I_{Mon_V}, (I_{Mon_V} ⊗_{Mon_V} v), x}
        · ((((αinv_{Mon_V} I_{Mon_V} I_{Mon_V} v) ⊗^{Act}_{r} x)
        · (ru_{Mon_V} I_{Mon_V} ⊗^{Mon_V}_{r} v) ⊗^{Act}_{r} x)
        · aα_{Act} I_{Mon_V} v x).
  Proof.
    refine (lemma2 v x @ _).
    apply maponpaths.
    apply maponpaths_2.
    apply lemma2'.
  Qed.

  Local Lemma right_whisker_with_action_unitor' (v : V) (x : C) :
    I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) =
      I_{Mon_V} ⊗^{Act}_{l} (aα_{Act} I_{Mon_V} v x · au_{Act} (v ⊗_{Act} x)).
  Proof.
    refine (lemma3 v x @ _).
    set (aαiso := make_z_iso _ _ (actegory_actorisolaw Mon_V Act  I_{Mon_V} (I_{Mon_V} ⊗_{Mon_V} v) x)).
    apply (z_iso_inv_on_right _ _ _ aαiso).
    set (αiso' := make_z_iso _ _ (monoidal_associatorisolaw Mon_V  I_{Mon_V} I_{Mon_V} v)).
    set (αisor := functor_on_z_iso (rightwhiskering_functor Act x) αiso').
    etrans. { apply assoc'. }
    apply (z_iso_inv_on_right _ _ _ αisor).
    apply pathsinv0.
    simpl.

    etrans. { apply assoc. }
    etrans.
    {
      apply maponpaths.
      apply (bifunctor_leftcomp Act _ _ _ _ _ _).
    }

    etrans. { apply assoc. }
    etrans. {
      apply maponpaths_2.
      apply (actegory_pentagonidentity Mon_V Act I_{Mon_V} I_{Mon_V} v x).
    }

    etrans.
    2: {
      apply (actegory_actornatright Mon_V Act).
    }

    etrans. { apply assoc'. }
    apply maponpaths.
    apply actegory_triangleidentity.
  Qed.

  Lemma right_whisker_with_action_unitor : actegory_triangle_identity' Mon_V au_{Act} aα_{Act}.
  Proof.
    intros v x.
    use faithful_reflects_commutative_triangle.
    3: { apply (leftwhiskering_faithful_action(V:=V)). }
    apply pathsinv0.
    refine (right_whisker_with_action_unitor' _ _ @ _).
    apply (bifunctor_leftcomp Act).
  Qed.

  Definition actegory_triangleidentity' := right_whisker_with_action_unitor.

End SecondTriangleEquality.


Require Import Core Notations.

(** * Some lemmas about integers *)

Definition IntMax := Int.repr Int.max_unsigned.

Lemma int_to_unsigned_eq : forall i j, i = j <-> Int.unsigned i = Int.unsigned j.
Proof.
  intros.
  destruct i.
  destruct j.
  split.
  * congruence.
  * apply Int.mkint_eq.
Qed.

Lemma int_to_unsigned_neq : forall i j, i <> j -> Int.unsigned i <> Int.unsigned j.
Proof.
  intros.
  destruct (zeq (Int.unsigned i) (Int.unsigned j)) eqn : G.
  pose (Int.eq_false _ _ H).
  unfold Int.eq in e0.
  rewrite G in e0.
  congruence.
  assumption.
Qed.

Lemma non_zero_surj :
  forall i, Int.add i Int.one <> Int.zero ->
       Int.unsigned (Int.add i Int.one) = Int.unsigned i + 1.
Proof.
  intros.
  destruct (Z.eq_dec (Int.unsigned (Int.add i Int.one)) (Int.unsigned i + 1)).
  intuition.
  unfold Int.add in n.
  assert (i <> IntMax).
  destruct (Int.eq_dec i IntMax).
  rewrite e in H.

  assert (Int.add IntMax Int.one = Int.zero).
  { unfold IntMax.
    unfold Int.add.
    unfold Int.zero.
    simpl; unfold Int.add; unfold Int.mul;
      repeat rewrite Int.unsigned_repr_eq;
      repeat rewrite Int.unsigned_repr_eq;
      repeat rewrite Zmod_small.
    replace (Int.max_unsigned + Int.unsigned Int.one) with (Int.modulus) by (auto with ints).
    pose (Int.mkint_eq).
    destruct  (Int.repr Int.modulus) eqn : IM.
    destruct (Int.repr 0) eqn : S0.
    apply Int.mkint_eq.
    assert (Int.repr Int.modulus =
            Int.mkint (Int.Z_mod_modulus Int.modulus) (Int.Z_mod_modulus_range' Int.modulus))
      by (auto with ints).
    rewrite H0 in IM.
    inversion IM.
    inversion S0.
    replace (match Int.repr 0 with
             | {| Int.intval := intval1 |} => intval1
             end) with 0 by (auto with ints).
    auto.
    cbv.
    split; congruence.
  }
  congruence.
  assumption.
  simpl; unfold Int.add; unfold Int.mul;
    repeat rewrite Int.unsigned_repr_eq;
    repeat rewrite Int.unsigned_repr_eq;
    repeat rewrite Zmod_small.
  auto with ints.
  assert (Int.unsigned i < Int.max_unsigned).
  assert (Int.unsigned i <> Int.unsigned IntMax) by (eapply (int_to_unsigned_neq _ _ H0)).
  destruct i; simpl in *.
  unfold IntMax in *.
  replace (Int.unsigned (Int.repr Int.max_unsigned)) with (Int.max_unsigned) in H1 by (auto with ints).
  unfold Int.max_unsigned in *.
  nia.
  unfold Int.max_unsigned in *.
  replace (Int.unsigned Int.one) with 1 by (auto with ints).
  pose (Int.unsigned_range i).
  nia.
Qed.

Lemma int_overflow_unsigned_to_add :
  forall z, 0 < Int.unsigned z + 1 < Int.modulus ->
       Int.add z Int.one <> Int.zero.
Proof.
  intros.
  unfold Int.zero.
  destruct (Int.eq (Int.add z Int.one) (Int.repr 0)) eqn: Sz.
  pose (Int.eq_spec (Int.add z Int.one) (Int.repr 0)) as E.
  unfold Int.eq in Sz.
  destruct (zeq (Int.unsigned (Int.add z Int.one))
                (Int.unsigned (Int.repr 0))).
  unfold Int.add in e.
  repeat rewrite Int.unsigned_repr_eq in e.
  rewrite Zmod_small in e.
  rewrite  Zmod_small in e.
  replace (Int.unsigned Int.one) with 1 in e by (auto with ints).  nia.
  nia.
  replace (Int.unsigned Int.one) with 1 by (auto with ints).  nia.
  congruence.
  pose (Int.eq_spec (Int.add z Int.one)  (Int.repr 0)).
  rewrite Sz in y.
  assumption.
Qed.

(* Induction principle for integers *)

Lemma int_induction :
  forall (P : int -> Prop),
    P Int.zero ->
    (forall i, P i -> P (Int.add i Int.one))
    -> forall i, P i.
Proof.
  induction i.
  eapply (natlike_ind (fun intval => forall intrange : -1 < intval < Int.modulus,
                           P {| Int.intval := intval; Int.intrange := intrange |})).
  (* Base case *)
  - intro.
    unfold Int.zero in H.
    assert ((Int.repr 0) = {| Int.intval := 0; Int.intrange := intrange0 |}).
    assert (Int.unsigned {| Int.intval := 0; Int.intrange := intrange0 |} =
            Int.unsigned (Int.repr (0))).
    { simpl.
      rewrite Int.unsigned_repr.
      auto.
      unfold Int.max_unsigned.
      nia. }
    destruct (Int.repr 0) eqn: S0.
    apply Int.mkint_eq.
    simpl in H1.
    nia.
    rewrite  H1 in H.
    assumption.
  - intros.
    assert (X: -1 < x < Int.modulus) by nia.
    pose (p := H2 X).
    pose (H0 {| Int.intval := x; Int.intrange := X |} p).
    assert ({| Int.intval := Z.succ x; Int.intrange := intrange0 |} =
            (Int.add {| Int.intval := x; Int.intrange := X |} Int.one)).
    unfold Int.add.
    unfold Int.one.
    unfold Int.unsigned.
    replace (Int.intval (Int.repr 1)) with 1 by (auto with ints).
    simpl.
    replace (x + 1) with (Z.succ x) by nia.
    assert (Int.unsigned {| Int.intval := Z.succ x; Int.intrange := intrange0 |} =
            Int.unsigned (Int.repr (Z.succ x))).
    simpl.
    rewrite Int.unsigned_repr.
    auto.
    unfold Int.max_unsigned.
    nia.
    destruct (Int.repr (Z.succ x)) eqn: Sa.
    apply Int.mkint_eq.
    simpl in H3.
    assumption.
    rewrite <- H3 in p0.
    assumption.
  - nia.
Qed.

Lemma intval_eq : forall (n i : int),
    match n with | {| Int.intval := intval |} => intval end =
    match i with | {| Int.intval := intval |} => intval end ->
    (n = i).
Proof.
  intros.
  destruct (n) eqn: Sn.
  destruct (i) eqn: Si.
  apply Int.mkint_eq.
  assumption.
Qed.

Lemma int_le_trans : forall a b c,
    (a <= b)%int = true ->
    (b <= c)%int = true ->
    (a <= c)%int = true.
Proof.
  intros.
  unfold Int.lt in *.
  repeat break_match.
  all: try discriminate.
  lia.
  reflexivity.
Qed.

Lemma int_lt_trans : forall a b c,
    (a < b)%int = true ->
    (b < c)%int = true ->
    (a < c)%int = true.
Proof.
  intros.
  unfold Int.lt in *.
  repeat break_match.
  all: try discriminate.
  reflexivity.
  lia.
Qed.

Lemma int64_lt_trans : forall a b c,
    (a < b)%int64 = true ->
    (b < c)%int64 = true ->
    (a < c)%int64 = true.
Proof.
  intros.
  unfold Int64.lt in *.
  repeat break_match.
  all: try discriminate.
  reflexivity.
  lia.
Qed.

Lemma int64_le_trans : forall a b c,
    (a <= b)%int64 = true ->
    (b <= c)%int64 = true ->
    (a <= c)%int64 = true.
Proof.
  intros.
  unfold Int64.lt, negb in *.
  repeat break_match.
  all: try discriminate.
  lia.
  reflexivity.
Qed.

Lemma int_le_signed_le : forall a b,
  (a <= b)%int = true <->
  Int.signed a <= Int.signed b.
Proof.
  split; intros.
  - unfold Int.lt in H.
    destruct zlt; [discriminate | lia].
  - unfold Int.lt.
    destruct zlt; [lia | reflexivity].
Qed.

Lemma int_lt_signed_lt : forall a b,
  (a < b)%int = true <->
  Int.signed a < Int.signed b.
Proof.
  split; intros.
  - unfold Int.lt in H.
    destruct zlt; [lia | discriminate].
  - unfold Int.lt.
    destruct zlt; [reflexivity | lia].
Qed.

Lemma sem_Cle_Cge : forall i a b m is1 is2,
  sem_cmp Cge (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some (Val.of_bool i)
  <->
  sem_cmp Cle (Vint b) (Tint is2 Signed noattr)
              (Vint a) (Tint is1 Signed noattr) m
  = Some (Val.of_bool i).
Proof.
  unfold sem_cmp, sem_binarith, sem_cast,
         classify_cmp, classify_cast, binarith_type;
    simpl.
  destruct is1, is2; simpl.
  all: destruct Archi.ptr64; simpl.
  all: unfold Val.of_bool.
  all: split; intros.
  all: repeat break_match.
  all: try reflexivity.
  all: try discriminate.
Qed.

Lemma int_le_sem_Cle : forall i a b m is1 is2,
  (a <= b)%int = i <->
  sem_cmp Cle (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some (Val.of_bool i).
Proof.
  destruct i.
  - unfold sem_cmp, sem_binarith, sem_cast, classify_cmp; simpl.
    split; intros.
    -- all: destruct is1, is2; simpl.
       all: destruct Archi.ptr64; simpl.
       all: rewrite H; reflexivity.
    -- all: destruct is1, is2; simpl.
       all: unfold classify_cast, binarith_type in H.
       all: destruct Archi.ptr64; simpl in H.
       all: unfold Val.of_bool in H.
       all: break_match.
       all: try discriminate.
       all: try reflexivity.
  - unfold sem_cmp, sem_binarith, sem_cast, classify_cmp; simpl.
    split; intros.
    -- all: destruct is1, is2; simpl.
       all: destruct Archi.ptr64; simpl.
       all: rewrite H; reflexivity.
    -- all: destruct is1, is2; simpl.
       all: unfold classify_cast, binarith_type in H.
       all: destruct Archi.ptr64; simpl in H.
       all: unfold Val.of_bool in H.
       all: break_match.
       all: try discriminate.
       all: try reflexivity.
Qed.

Lemma int_lt_sem_Clt : forall a b m is1 is2,
  (a < b)%int = true <->
  sem_cmp Clt (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vtrue.
Proof.
  unfold sem_cmp, sem_binarith, sem_cast, classify_cmp; simpl.
  split; intros.
  - all: destruct is1, is2; simpl.
    all: destruct Archi.ptr64; simpl.
    all: rewrite H; reflexivity.
  - all: destruct is1, is2; simpl.
    all: unfold classify_cast, binarith_type in H.
    all: destruct Archi.ptr64; simpl in H.
    all: unfold Val.of_bool in H.
    all: break_match.
    all: try discriminate.
    all: try reflexivity.
Qed.

Lemma sem_Clt_Cge : forall a b m is1 is2,
  sem_cmp Cge (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vtrue
  <->
  sem_cmp Clt (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vfalse.
Proof.
  unfold sem_cmp, sem_binarith, sem_cast,
         classify_cmp, classify_cast, binarith_type;
    simpl.
  destruct is1, is2; simpl.
  all: destruct Archi.ptr64; simpl.
  all: unfold Val.of_bool.
  all: split; intros.
  all: repeat break_match.
  all: try reflexivity.
  all: try discriminate.
Qed.

Lemma sem_Cle_Cgt : forall a b m is1 is2,
  sem_cmp Cgt (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vtrue
  <->
  sem_cmp Cle (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vfalse.
Proof.
  unfold sem_cmp, sem_binarith, sem_cast,
         classify_cmp, classify_cast, binarith_type;
    simpl.
  destruct is1, is2; simpl.
  all: destruct Archi.ptr64; simpl.
  all: unfold Val.of_bool.
  all: split; intros.
  all: repeat break_match.
  all: try reflexivity.
  all: try discriminate.
Qed.

Lemma sem_Clt_Cgt : forall a b m is1 is2,
  sem_cmp Cgt (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
  = Some Vtrue
  <->
  sem_cmp Clt (Vint b) (Tint is2 Signed noattr)
              (Vint a) (Tint is1 Signed noattr) m
  = Some Vtrue.
Proof.
  unfold sem_cmp, sem_binarith, sem_cast,
         classify_cmp, classify_cast, binarith_type;
    simpl.
  destruct is1, is2; simpl.
  all: destruct Archi.ptr64; simpl.
  all: unfold Val.of_bool.
  all: split; intros.
  all: repeat break_match.
  all: try reflexivity.
  all: try discriminate.
Qed.

Lemma sem_cmp_Int_le_dec {is1 is2 : intsize} : forall a b m,
  { sem_cmp Cle (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
    = Some Vtrue } +
  { sem_cmp Cle (Vint a) (Tint is1 Signed noattr)
              (Vint b) (Tint is2 Signed noattr) m
    = Some Vfalse }.
Proof.
  intros.
  destruct (Z_lt_le_dec (Int.signed b) (Int.signed a)) as [LT | LE];
    [right | left].
  - apply sem_Cle_Cgt.
    apply sem_Clt_Cgt.
    apply int_lt_sem_Clt.
    apply int_lt_signed_lt.
    assumption.
  - replace Vtrue with (Val.of_bool true).
      apply int_le_sem_Cle.
    apply int_le_signed_le.
    assumption.
    reflexivity.
Qed.

Lemma Zland_bounds : forall b c, 0 <= b <= Byte.modulus ->
                            0 <= c <= Byte.modulus ->
                            0 <= (b & c) <= Byte.modulus.
Admitted.


Require Export ZFtheory.
Require Export GenModel.
Require Export ZFcoc.
Require Export ModelZF.
Require Export List.

Module BuildModel := GenModel.MakeModel(CCM).
Import BuildModel.
Import T J R.
Import CCM.
Import ZFind_basic.
Import ZFnats.

Lemma app2_m2 m : morph2 (fun n x => app (app m n) x).
do 3 red; intros.
rewrite H,H0; reflexivity.
Qed.
Hint Resolve app2_m2.

Definition prf_term : term.
left; exists (fun _ => empty); do 2 red; reflexivity.
Defined.

(*Presburger signature and typing*)

Definition T : term.
left; exists (fun _ => N); do 2 red; reflexivity.
Defined.

Definition Zero : term.
left; exists (fun _ => zero); do 2 red; reflexivity.
Defined.

Lemma typ_0 : forall e, typ e Zero T.
do 2 red; simpl; intros e i H; apply zero_typ.
Qed.

Definition Succ : term -> term.
intro n; left; exists (fun i => succ (int n i)).
do 2 red; intros. rewrite H; reflexivity.
Defined.

Lemma typ_S : forall e t, typ e t T -> typ e (Succ t) T.
do 2 red; simpl; intros. apply succ_typ.
apply H; apply H0.
Qed.

Definition NatRec (f g n:term) : term.
left; exists (fun i => natrec (int f i)
  (fun m t => app (app (int g i) m) t) (int n i)).
repeat red; intros. apply natrec_morph.
 rewrite H; reflexivity.

 repeat red; intros. rewrite H, H0, H1. reflexivity.

 rewrite H; reflexivity.
Defined.

Lemma typ_Nrect : forall e n f g P,
  typ e n T ->
  typ e P (Prod T kind) ->
  typ e f (App P Zero) ->
  typ e g (Prod T (Prod (App (lift 1 P) (Ref 0))
              (App (lift 2 P) (Succ (Ref 1))))) ->
  typ e (NatRec f g n) (App P n).
do 2 red. simpl. intros.
red in H; specialize H with (1:=H3).
red in H0; specialize H0 with (1:=H3).
red in H1; specialize H1 with (1:=H3).
red in H2; specialize H2 with (1:=H3).
simpl in *.
replace (fun k0 : nat => i k0) with i in *; trivial.
set (c := int n i) in *; clearbody c.
set (f0 := int f i) in *; clearbody f0.
set (fS := int g i) in *; clearbody fS.

elim H using N_ind; intros.
 revert H6. apply in_set_morph.
  apply natrec_morph.
   reflexivity.
   do 2 red; intros. rewrite H7. rewrite H6. reflexivity.
   symmetry; assumption.
  rewrite H5; reflexivity.

 rewrite natrec_0. apply H1.

 rewrite natrec_S; auto.
  refine (let H6 := prod_elim _ _ _ _ _ H2 H4 in _).
   red; intros. apply prod_ext.
    apply app_ext; try assumption.
     apply int_morph; try reflexivity.
      do 2 red; intros. rewrite H7; reflexivity.

    red; intros. apply app_ext.
     apply int_morph; try reflexivity.
      do 2 red; intros. apply V.cons_morph; try assumption.
       do 2 red; intros. rewrite H7; reflexivity.

     rewrite H7; reflexivity.

  simpl in H6. clear H2.
  replace (fun k : nat => V.cons n0 i k) with (V.cons n0 i) in *;
    trivial.
  refine (let H7 := prod_elim _ _ _ _ _ H6 _ in _).
   do 2 red; intros. apply app_ext; try reflexivity.
    apply int_morph; try reflexivity.
     do 2 red; intros. rewrite H7; reflexivity.

   rewrite simpl_int_lift1. apply H5.

  simpl in H7. revert H7. apply in_set_morph; try reflexivity.
  set (fS' := fun n y => app (app fS n) y) in |-*.
   apply app_ext; try reflexivity.
    replace (fun k : nat => V.cons (natrec f0 fS' n0)
                                       (V.cons n0 i) k)
    with (V.cons (natrec f0 fS' n0) (V.cons n0 i)); trivial.
    rewrite simpl_int_lift. symmetry; apply simpl_int_lift1.
Qed.

Definition Add : term -> term -> term.
intros m n; left;
exists (fun i => add (int m i) (int n i)).
do 2 red; intros.
apply natrec_morph; try rewrite H; try reflexivity.
 do 2 red; intros. rewrite H1; reflexivity.
Defined.

Lemma typ_Add : forall e m n, typ e m T -> typ e n T ->
  typ e (Add m n) T.
do 2 red; simpl; intros.
replace (fun k : nat => i k) with i; trivial.
do 2 red in H0; simpl in H0; specialize H0 with (1:=H1).
do 2 red in H; simpl in H; specialize H with (1:=H1).
apply add_typ; trivial.
Qed.

Definition ind_schema_term : term.
left; exists (fun i => natrec (i 2) (fun n x => app (app (i 1) n) x) (i 0)).
do 2 red; intros.
apply natrec_morph; try apply H.
do 2 red; intros; simpl. apply app_ext; trivial.
  apply app_ext; trivial.
Defined.

(*Presburger Axioms*)

Lemma discr_term : forall e n i, val_ok e i ->
  ~ eq_typ e Zero (Add n (Succ Zero)).
red; intros. red in H0; simpl in *.
specialize H0 with (1 := H).
 rewrite add1 in H0.
 symmetry in H0; apply discr in H0. trivial.
Qed.

Lemma Succ_inj : forall e x y, typ e x T -> typ e y T ->
 eq_typ e (Add x (Succ Zero)) (Add y (Succ Zero)) ->
 eq_typ e x y.
red; intros. red in H, H0, H1; simpl in *.
specialize H with (1:=H2).
specialize H0 with (1:=H2).
specialize H1 with (1:=H2).
do 2 rewrite add1 in H1.
apply succ_inj; trivial.
Qed.

Lemma Add_0 : forall e n, typ e n T -> eq_typ e (Add n Zero) n.
destruct n; red; intros; simpl; rewrite add0; auto with *.
Qed.

Lemma Add_ass : forall e x y, typ e y T ->
 eq_typ e (Add (Add x y) (Succ Zero)) (Add x (Add y (Succ Zero))).
assert (morph2 (fun _ => succ)).
 do 3 red; intros x y H0 x1 y1 H1; rewrite H1; reflexivity.
do 2 red; intros; simpl.
replace (fun k : nat => i k) with i; trivial.
red in H0; simpl in H0; specialize H0 with (1:=H1).
repeat rewrite add1.
rewrite addS; trivial.
reflexivity.
Qed.

(*First order theory signature and Introduction*)

Lemma lift_Somen : forall A n k, A <> None ->
  lift_rec n k A <> None.
intros; destruct A.
 destruct s. simpl. red. intros. discriminate.

 elim H. trivial.
Qed.

Lemma lift_Some1 : forall A, A <> None -> lift 1 A <> None.
unfold lift. intros. apply lift_Somen. trivial.
Qed.

Lemma subst_Some : forall t a, t <> None -> subst a t <> None.
unfold subst; intros; destruct t; intro.
 destruct s; simpl in H0. discriminate.

 elim H; trivial.
Qed.

Lemma proof_irr : forall P p e, P <> None ->
  typ e p P ->
  typ e P prop ->
  forall i, val_ok e i -> int p i == prf_trm.
intros.
do 2 red in H0; simpl in H0; specialize H0 with (1:=H2).
do 2 red in H1; simpl in H1; specialize H1 with (1:=H2).
destruct P. 2 : elim H; trivial.
 unfold props in H1. unfold ZFcoc.props in H1.
 rewrite power_ax in H1. specialize H1 with (1:=H0).
 apply singl_elim; trivial.
Qed.

Lemma lift_prop : forall n, eq_term (lift n prop) prop.
simpl; red; reflexivity.
Qed.

Lemma lift_split : forall n t,
  eq_term (lift (S n) t) (lift 1 (lift n t)).
red; intros. destruct t.
 destruct s; simpl. do 2 red; simpl; intros.
 repeat rewrite V.lams0. rewrite <- V.shift_split.
 replace (fun k : nat => x0 k) with x0; trivial.
 replace (fun k : nat => y k) with y; trivial.
 rewrite H; reflexivity.

 simpl; trivial.
Qed.

Definition EQ_trm : term -> term -> term.
intros x y; left.
exists (fun i => EQ N (int x i) (int y i)).
do 2 red; intros. unfold EQ.
apply cond_set_morph; try rewrite H; reflexivity.
Defined.

Lemma EQ_trm_typ : forall e x y, typ e (EQ_trm x y) prop.
do 2 red; simpl; intros. unfold props. unfold ZFcoc.props.
rewrite power_ax; intros.
unfold EQ in H0. unfold cond_set in H0.
rewrite subset_ax in H0.
destruct H0. trivial.
Qed.

Lemma EQ_trm_eq_typ : forall e x y t, typ e t (EQ_trm x y) ->
  eq_typ e x y.
do 2 red; simpl; intros.
do 2 red in H; simpl in H; specialize H with (1:=H0).
replace (fun k : nat => i k) with i in H; trivial.
apply EQ_elim in H. destruct H as (_, (H, _)); trivial.
Qed.

Definition False_symb : term.
left. exists (fun _ => empty).
do 3 red; reflexivity.
Defined.

Lemma False_symb_intro : ~exists t, typ nil t False_symb.
red; intros H. destruct H; do 2 red in H; simpl in H.
refine (let i:= (fun _ => empty) : val in _); clearbody i.
assert (val_ok nil i).
 unfold val_ok; intros n t Herror.
 destruct n; simpl in Herror; discriminate.
specialize H with (1:=H0). apply empty_ax in H; trivial.
Qed.

Lemma False_symb_elim : forall e P,
  (exists t, typ e t False_symb) ->
  (exists t', typ e t' P).
intros. destruct H. exists x. do 2 red; simpl; intros.
do 2 red in H; simpl in H; specialize H with (1:=H0).
elim empty_ax with (1:=H).
Qed.

Definition True_symb : term.
left. exists (fun _ => singl empty).
do 3 red; reflexivity.
Defined.

Lemma True_symb_intro : forall e, exists t, typ e t True_symb.
exists False_symb; do 2 red; simpl; intros.
apply singl_intro.
Qed.

Definition Conj : term -> term ->term.
intros a b; left.
exists (fun i => let A := int a i in let B := int b i in
  subset (A ∪ B) (fun x => x ∈ A /\ x ∈ B)).
do 3 red; intros. apply subset_morph.
 rewrite H; reflexivity.

 split; intros.
  rewrite <- H; trivial.

  rewrite H; trivial.
Defined.

Lemma Conj_intro : forall e A B t, A <> None -> B <> None ->
  typ e t A /\ typ e t B -> typ e t (Conj A B).
intros e A B t HSA HSB H.
destruct H as (HA, HB); do 2 red; simpl; intros.
 do 2 red in HA, HB; simpl in *.
 specialize HA with (1:=H).
 specialize HB with (1:=H).
 apply subset_intro.
  destruct A; simpl in *.
   apply union2_intro1; trivial.

   elim HSA; reflexivity.

  destruct A; destruct B; simpl in *.
   split; trivial.

   destruct HSB; reflexivity.

   destruct HSA; reflexivity.

   destruct HSA; reflexivity.
Qed.

Lemma Conj_elim : forall e A B t, A <> None -> B <> None ->
  typ e t (Conj A B) -> typ e t A /\ typ e t B.
intros e A B t HSA HSB; intro H.
 do 2 red in H; simpl in H; split;
 do 2 red; intros i HE; specialize H with (1:=HE).
  destruct A; simpl in *; trivial.
  apply subset_elim2 in H. destruct H as (x', H0, (H1, _)).
  rewrite H0; trivial.

  destruct B; simpl in *; trivial.
  apply subset_elim2 in H. destruct H as (x', H0, (_, H1)).
  rewrite H0; trivial.
Qed.

Definition Disj : term -> term -> term.
intros x y; left. exists (fun i => int x i ∪ int y i).
do 3 red; intros. rewrite H; reflexivity.
Defined.

Lemma Disj_intro : forall e t A B,  A <> None -> B <> None ->
  typ e t A \/ typ e t B -> typ e t (Disj A B).
intros e t A B HSA HSB H.
 do 2 red; simpl; intros. destruct H; do 2 red in H;
 specialize H with (1:=H0); destruct A; destruct B; simpl in H.
  apply union2_intro1; trivial.

  destruct HSA; trivial.

  destruct HSB; trivial.

  destruct HSA; trivial.

  destruct HSA; trivial.

  apply union2_intro2; trivial.

  destruct HSB; trivial.

  destruct HSA; trivial.

  destruct HSA; trivial.
Qed.

Lemma Disj_elim : forall e t t1 t2 A B C, C <> None ->
  typ e C prop ->
  typ e t (Disj A B) ->
  typ (A::e) t1 (lift 1 C) ->
  typ (B::e) t2 (lift 1 C) ->
  typ e prf_term C.
do 2 red; simpl; intros e t t1 t2 A B C HSC HCP H H1 H2 i HE.
do 2 red in H; simpl in H; specialize H with (1:=HE).
generalize (lift_Some1 _ HSC); intros HSClift1.
apply union2_elim in H; destruct H.
 apply weakening with (A:=A) in HCP. rewrite lift_prop in HCP.
 generalize (proof_irr _ _ _ HSClift1 H1 HCP); intros.
 generalize (vcons_add_var _ _ _ _ HE H); intros.
 do 2 red in H1.
 specialize H1 with (1:=H3). specialize H0 with (1:=H3).
 case_eq (lift 1 C); intros.
  rewrite H4 in H1; rewrite <- H4 in H1.
  rewrite H0 in H1; rewrite simpl_int_lift1 in H1.
  case_eq C; intros.
   rewrite <- H5. exact H1.

   elim HSC; trivial.

  elim HSClift1; trivial.

 apply weakening with (A:=B) in HCP. rewrite lift_prop in HCP.
 generalize (proof_irr _ _ _ HSClift1 H2 HCP); intros.
 generalize (vcons_add_var _ _ _ _ HE H); intros.
 do 2 red in H2. specialize H2 with (1:=H3).
 specialize H0 with (1:=H3).
 case_eq (lift 1 C); intros. rewrite H4 in H2; rewrite <- H4 in H2.
  rewrite H0 in H2; rewrite simpl_int_lift1 in H2.
  case_eq C; intros.
   rewrite <- H5. exact H2.

   elim HSC; trivial.

  elim HSClift1; trivial.
Qed.

Definition Impl : term -> term -> term.
intros x y; left.
exists (fun i => prod (int x i) (fun _ => int y i)).
do 3 red; intros. apply prod_ext.
 rewrite H; reflexivity.

 red; intros. rewrite H; reflexivity.
Defined.

Lemma Impl_intro : forall e b A B, A <> None -> B <> None ->
  typ (A::e) b (lift 1 B) -> typ e (Abs A b) (Impl A B).
do 2 red; simpl; intros. apply prod_intro; intros.
 do 2 red; intros. rewrite H4; reflexivity.

 do 2 red; intros; reflexivity.

 do 2 red in H1; simpl in H1.
 assert (val_ok (A::e) (V.cons x i)).
  apply vcons_add_var0; trivial.
   red. destruct A.
    apply H3.
    elim H; reflexivity.
 specialize H1 with (1:=H4).
 generalize lift_Some1; intros. specialize H5 with (1:=H0).
 case_eq (lift 1 B); intros.
  rewrite H6 in H1.
  rewrite <- H6  in H1. rewrite simpl_int_lift1 in H1.
  apply H1.

  rewrite H6 in H5. elim H5; trivial.
Qed.

Lemma Impl_elim : forall e t u A B,
  A <> None -> B <> None ->
  typ e t (Impl A B) ->
  typ e u A ->
  typ e (App t u) B.
do 2 red; simpl; intros.
do 2 red in H1; simpl in H1; specialize H1 with (1:=H3).
do 2 red in H2; simpl in H2; specialize H2 with (1:=H3).
replace (fun k : nat => i k) with i in *; trivial.
destruct A.
 destruct B.
  apply prod_elim with (2:=H1); trivial.
   do 2 red; intros; reflexivity.

  elim H0; trivial.

 elim H; trivial.
Qed.

Definition Neg t := Impl t False_symb.

Lemma Neg_intro : forall na A e,
  typ e na (Impl A False_symb) ->
  typ e na (Neg A).
intros; unfold Neg; trivial.
Qed.

Lemma Neg_elim : forall na A e,
  typ e na (Neg A) ->
  typ e na (Impl A False_symb).
intros; unfold Neg; trivial.
Qed.

Definition Fall : term -> term.
intros t; left.
exists (fun i => prod N (fun z => int t (V.cons z i))).
do 3 red; intros. apply prod_ext; try rewrite H; try reflexivity.
 do 2 red; intros. rewrite H; rewrite H1; reflexivity.
Defined.

Lemma Fall_intro : forall e t B, B <> None ->
  typ (T::e) t B ->
  typ e (Abs T t) (Fall B).
do 2 red; intros; simpl. apply prod_intro.
 do 2 red; intros. rewrite H3; reflexivity.

 do 2 red; intros. rewrite H3; reflexivity.

 intros.
 replace (fun k : nat => i k) with i; trivial.
 do 2 red in H0. destruct B.
  apply H0. apply vcons_add_var0; trivial.

  elim H; reflexivity.
Qed.

Lemma Fall_elim : forall e t u B, B <> None ->
  typ e t (Fall B) ->
  typ e u T ->
  typ e (App t u) (subst u B).
do 2 red; simpl; intros.
do 2 red in H0; simpl in H0; intros; specialize H0 with (1:=H2).
do 2 red in H1; simpl in H1; intros; specialize H1 with (1:=H2).
generalize (subst_Some _ u H); intros.
case_eq (subst u B); intros.
 rewrite <- H4. rewrite int_subst_eq.
 apply prod_elim with (2:=H0); trivial.
  do 2 red; intros. rewrite H6; reflexivity.

 elim H3; trivial.
Qed.

Definition Exst : term -> term.
intro t; left.
exists (fun i => union (replf N (fun n => int t (V.cons n i)))).
do 3 red; intros. apply union_morph.
apply replf_morph; try reflexivity.
 red; intros. rewrite H1; rewrite H. reflexivity.
Defined.

Lemma Exst_intro : forall e t p a,
  t <> None ->
  typ e a T ->
  typ e p (subst a t) ->
  typ e p (Exst t).
do 2 red; simpl; intros.
do 2 red in H0. specialize H0 with (1:=H2). simpl in H0.
do 2 red in H1. specialize H1 with (1:=H2).
generalize subst_Some; intros. specialize H3 with (a:=a) (1:=H).
case_eq (subst a t); intros.
 rewrite H4 in H1. rewrite <- H4 in H1.
 rewrite int_subst_eq in H1.
 apply union_intro with (y:= int t (V.cons (int a i) i)); trivial.
  apply replf_intro with (2:=H0); try reflexivity.
   do 2 red; intros. rewrite H6; reflexivity.

 elim H3; trivial.
Qed.

Lemma Exst_elim : forall e t1 t2 A C,
  C <> None ->
  typ e C prop ->
  typ e t1 (Exst A) ->
  typ (A::T::e) t2 (lift 2 C) ->
  typ e prf_term C.
do 2 red; intros.
do 2 red in H1; simpl in H1; specialize H1 with (1:=H3).
apply weakening with (A:=T) in H0.
apply weakening with (A:=A) in H0.
do 2 rewrite <- lift_split in H0. rewrite lift_prop in H0.
generalize (lift_Somen _ 2 0 H); intro Hlift;
fold (lift 2 C) in Hlift.
apply union_elim in H1; destruct H1.
apply replf_elim in H4. 2 : do 2 red;
intros u v _ Ht; rewrite Ht; reflexivity.
destruct H4. rewrite H5 in H1.
assert (N == int T i). simpl; reflexivity. rewrite H6 in H4.
generalize (vcons_add_var _ _ _ _ H3 H4); intros.
generalize (vcons_add_var _ _ _ _ H7 H1); intros.
generalize (proof_irr _ _ _ Hlift H2 H0 _ H8); intros.
do 2 red in H2; simpl in H2; specialize H2 with (1:=H8).
case_eq (lift 2 C); intros.
 rewrite H10 in H2; rewrite <- H10 in H2.
 rewrite lift_split in H2.
 do 2 rewrite simpl_int_lift1 in H2.
 rewrite H9 in H2.
 case_eq C; intros.
  rewrite <- H11; trivial.

  elim H; trivial.

 elim Hlift; trivial.
Qed.

Lemma P_ax_intro1 : forall e, exists t,
  typ e t (Fall (Neg (EQ_trm Zero (Add (Ref 0) (Succ Zero))))).
exists (Abs T
  (Abs (EQ_trm Zero (Add (Ref 0) (Succ Zero))) prf_term)).
apply Fall_intro.
 intro; simpl in H; discriminate.

 apply Neg_intro. apply Impl_intro.
  intro; simpl in H; discriminate.

  intro; simpl in H; discriminate.

  do 2 red; simpl; intros. unfold val_ok in H.
  assert (nth_error (EQ_trm Zero (Add (Ref 0) (Succ Zero))::T::e)
    0 = value (EQ_trm Zero (Add (Ref 0) (Succ Zero)))); trivial.
  specialize H with (1:=H0). clear H0. red in H; simpl in H.
  rewrite add1 in H.
  rewrite EQ_discr in H. apply empty_ax in H; contradiction.
Qed.

Lemma P_ax_intro2 : forall e, exists t,
  typ e t (Fall (Fall (Impl
  (EQ_trm (Add (Ref 0) (Succ Zero)) (Add (Ref 1) (Succ Zero)))
  (EQ_trm (Ref 0) (Ref 1))))).
refine (let P1 := (EQ_trm (Add (Ref 0) (Succ Zero))
  (Add (Ref 1) (Succ Zero))) in _).
assert (P1 = (EQ_trm (Add (Ref 0) (Succ Zero))
  (Add (Ref 1) (Succ Zero)))); auto.
refine (let P2 := (EQ_trm (Ref 0) (Ref 1)) in _).
assert (P2 = (EQ_trm (Ref 0) (Ref 1))); auto.
rewrite <- H. rewrite <- H0. clearbody P1 P2.
exists (Abs T (Abs T (Abs P1 prf_term))).
apply Fall_intro.
 intro; simpl; discriminate.

 apply Fall_intro.
  intro; simpl; discriminate.

  apply Impl_intro.
   rewrite H; intro; simpl; discriminate.

   rewrite H0; intro; simpl; discriminate.

   do 2 red; intros.
   refine (let i':= V.shift 1 i in _).
   assert (i' = (V.shift 1 i)); auto.
   assert (eq_val i (V.cons (i 0) i')).
    symmetry. apply V.cons_ext; try reflexivity.
   case_eq (lift 1 P2); intros.
    rewrite <- H4. unfold val_ok in H1.
    assert (nth_error (P1::T::T::e) 0 = Some P1); trivial.
    assert (nth_error (P1::T::T::e) 1 = Some T) as H1T; trivial.
    assert (nth_error (P1::T::T::e) 2 = Some T) as H2T; trivial.
    generalize (H1 _ _ H5); intro H0P.
    generalize (H1 _ _ H1T); intro H1N.
    generalize (H1 _ _ H2T); intro H2N.
    assert (forall n, eq_term (lift n T) T) as HlT.
     red; simpl; red; intros; reflexivity.
    rewrite HlT in H1N, H2N. red in H1N, H2N.
    simpl in H1N, H2N. red in H0P; simpl in H0P.
    case_eq (lift 1 P1); intros.
     rewrite H6 in H0P. rewrite <- H6 in H0P.
     simpl. rewrite H3. rewrite simpl_int_lift1.
     rewrite H3 in H0P at 2. rewrite simpl_int_lift1 in H0P.
     rewrite H in H0P; simpl in H0P. rewrite H0; simpl.
     do 2 rewrite add1 in H0P.
     apply EQ_succ_inj with (x0 := i 0); trivial.

     rewrite H in H6; simpl in H6; discriminate.

    rewrite H0 in H4; simpl in H4; discriminate.
Qed.

Lemma P_ax_intro3 : forall e , exists t,
  typ e t (Fall (EQ_trm (Ref 0) (Add (Ref 0) Zero))).
exists (Abs T prf_term). apply Fall_intro.
 intro; simpl in H; discriminate.

 do 2 red; simpl; intros. rewrite EQ_add_0.
  apply singl_intro.

  unfold val_ok in H. assert (nth_error (T::e) 0 = Some T); trivial.
  specialize H with (1:=H0). red in H; simpl in H. trivial.
Qed.

Lemma P_ax_intro4 : forall e, exists t,
  typ e t (Fall(Fall (EQ_trm (Add (Add (Ref 0) (Ref 1)) (Succ Zero))
                   (Add (Ref 0) (Add (Ref 1) (Succ Zero)))))).
exists (Abs T (Abs T (prf_term))).
apply Fall_intro.
 intro; simpl in H; discriminate.

 apply Fall_intro.
  intro; simpl in H; discriminate.

  do 2 red; intros; simpl. unfold val_ok in H.
  assert (nth_error (T::T::e) 0 = Some T); trivial.
  assert (nth_error (T::T::e) 1 = Some T); trivial.
  rewrite EQ_add_succ.
   apply singl_intro.

   generalize (H _ _ H0); intro H2; simpl in H2; trivial.

   generalize (H _ _ H1); intro H2; simpl in H2; trivial.
Qed.

Lemma P_ax_intro5 : forall e P, P <> None ->
  exists t, typ e t (Impl (subst Zero P)
    (Impl (Fall (Impl P
      (subst (Add (Ref 0) (Succ Zero)) (lift_rec 1 1 P))))
    (Fall P))).
intros e P HNP.
exists (Abs (subst Zero P) (Abs (Fall (Impl (lift_rec 1 1 P)
  ((lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero)) (lift_rec 1 1 P))))))
    (Abs T ind_schema_term))).
assert (forall i, eq_val (V.cons (i 0) (V.shift 1 i)) i) as Hcons.
 intros; apply V.cons_ext; reflexivity.
apply Impl_intro.
 apply subst_Some; trivial.

 intro; simpl in *; discriminate.

 assert (forall x y z,
   eq_term (lift 1 (Impl (Fall (Impl x y)) z))
   (Impl (Fall (Impl (lift_rec 1 1 x)
     (lift_rec 1 1 y))) (lift 1 z))) as Hrewrite.
  red; simpl; red; intros.
   apply prod_ext.
    apply prod_ext; try reflexivity.
     do 2 red; intros. apply prod_ext; [ | red; intros];
     rewrite int_lift_rec_eq; apply int_morph; try reflexivity;
     rewrite V.cons_lams; [rewrite H, H1 | do 2 red; intros; rewrite H2
     | rewrite H, H1 | do 2 red; intros xx xy HP; rewrite HP]; reflexivity.

    do 2 red; intros. rewrite H. rewrite V.lams0.
    rewrite <- (Hcons y0). rewrite simpl_int_lift1. reflexivity.

 rewrite Hrewrite. apply Impl_intro.
  intro; simpl in H; discriminate.

  apply lift_Some1. intro; simpl in H; discriminate.

  rewrite <- lift_split.
  assert (forall t n, eq_term (lift n (Fall t))
    (Fall (lift_rec n 1 t))) as Hliftin.
   red; simpl; red; intros. apply prod_ext; try reflexivity.
    do 2 red; intros. rewrite int_lift_rec_eq.
    rewrite H1. rewrite H. rewrite V.cons_lams; try reflexivity.
     do 2 red; intros. rewrite H2; reflexivity.
  rewrite Hliftin. apply Fall_intro.
   apply lift_Somen; trivial.

   do 2 red; intros i Hhyp.
   unfold val_ok in Hhyp.
   assert (nth_error (T :: (Fall (Impl (lift_rec 1 1 P)
     (lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero))
     (lift_rec 1 1 P))))) :: (subst Zero P) :: e) 0 =
     value T) as Hind; trivial.
   assert (nth_error (T :: (Fall (Impl (lift_rec 1 1 P)
     (lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero))
     (lift_rec 1 1 P))))) :: (subst Zero P) :: e) 1 =
     value (Fall (Impl (lift_rec 1 1 P)
     (lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero))
     (lift_rec 1 1 P)))))) as Hsucc; trivial.
   assert (nth_error (T :: (Fall (Impl (lift_rec 1 1 P)
     (lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero))
     (lift_rec 1 1 P))))) :: (subst Zero P) :: e) 2 =
     value (subst Zero P)) as Hzero; trivial.
   generalize (Hhyp _ _ Hind); clear Hind; intro Hind; simpl in Hind.
   generalize (Hhyp _ _ Hsucc); clear Hsucc; intro Hsucc; simpl in Hsucc.
   generalize (Hhyp _ _ Hzero); clear Hzero; intro Hzero.
     simpl in Hzero. red in Hzero.
   clear Hrewrite Hhyp Hliftin.

   assert (forall i, eq_val (V.shift 2 (V.shift 1 i)) (V.shift 3 i)) as Hsplit.
    do 2 red; intros i0 a; unfold V.shift;
    setoid_replace (1 + (2 + a)) with (3 + a) by omega; reflexivity.
   case_eq (lift 3 (subst Zero P)); intros.
    2 : apply lift_Somen in H; [contradiction | apply subst_Some; trivial].

    rewrite H in Hzero; rewrite <- H in Hzero; clear s H.
    rewrite <- (Hcons i) in Hzero at 2. rewrite simpl_int_lift in Hzero.
    rewrite <- (Hcons (V.shift 1 i)) in Hzero.
    rewrite simpl_int_lift in Hzero. rewrite <- V.shift_split in Hzero.
    rewrite <- (Hcons (V.shift 2 i)) in Hzero.
    rewrite simpl_int_lift1 in Hzero. rewrite (Hsplit i) in Hzero.
    rewrite int_subst_eq in Hzero; simpl in Hzero.

   assert (forall z i, int (lift_rec 1 1 P) (fun k : nat =>
      V.cons z (V.lams 0 (V.shift 2) (fun k0 : nat => i k0)) k) ==
    int P (V.cons z (V.shift 3 i))) as Haux1.
    intros. replace ((fun k : nat => V.cons z (V.lams 0 (V.shift 2) (fun k0 =>
        i0 k0)) k)) with (V.cons z (V.lams 0 (V.shift 2) i0)); trivial.
      rewrite int_lift_rec_eq.
      rewrite <- V.cons_lams.
       2 : do 2 red; intros x y H1; rewrite H1; reflexivity.

       do 2 rewrite V.lams0. rewrite (Hsplit i0); reflexivity.
   assert (prod N (fun z : X => prod (int (lift_rec 1 1 P)
    (fun k : nat => V.cons z (V.lams 0 (V.shift 2) (fun k0 : nat => i k0)) k))
     (fun _ : X => int (lift_rec 1 1 (subst (Add (Ref 0) (Succ Zero))
      (lift_rec 1 1 P))) (fun k : nat =>
        V.cons z (V.lams 0 (V.shift 2) (fun k0 : nat => i k0)) k))) ==
    prod N (fun z : X => prod (int P (V.cons z (V.shift 3 i)))
      (fun _ : X => int P (V.cons (succ z) (V.shift 3 i))))) as Haux2.
    apply prod_ext; try reflexivity.
     do 2 red; intros. apply prod_ext.
      rewrite <- H0. apply Haux1.

      do 2 red. intros. rewrite Haux1 in H1.
      replace  (fun k : nat => V.cons y1 (V.lams 0 (V.shift 2) (fun k0 : nat
        => i k0)) k) with (V.cons y1 (V.lams 0 (V.shift 2) i)); trivial.
      rewrite int_lift_rec_eq. rewrite int_subst_eq.
      rewrite int_lift_rec_eq. rewrite <- V.cons_lams; simpl.
       2 : do 2 red; intros x y H3; rewrite H3; reflexivity.

       rewrite add1.
       rewrite <- H0. rewrite <- V.cons_lams.
       2:apply V.shift_morph; trivial.
       apply int_morph; try reflexivity.
         do 2 red; intros. apply V.cons_morph.
          rewrite V.lams_bv; try omega.
          rewrite V.lams0. unfold V.cons. reflexivity.

          rewrite V.lams0.
          replace ((fun k : nat => V.cons y1 (V.lams 0 (V.shift 1)
          (V.lams 0 (V.shift 2) i)) k)) with (V.cons y1 (V.lams 0 (V.shift 1)
          (V.lams 0 (V.shift 2) i))); trivial.
          rewrite V.shift_cons. rewrite V.lams0. apply V.shiftS_split.
    rewrite Haux2 in Hsucc. clear Haux1 Haux2.

   case_eq (lift_rec 2 1 P); intros.
    2 : apply lift_Somen in H; [contradiction | trivial].

    rewrite <- H; clear H. simpl. rewrite int_lift_rec_eq.
    rewrite <- (Hcons i) at 3. rewrite <- V.cons_lams.
     2 : do 2 red; intros x y H; rewrite H; reflexivity.

     rewrite V.lams0.
     replace (fun k : nat => V.shift 1 i k) with (V.shift 1 i); trivial.
     rewrite (Hsplit i). elim Hind using N_ind.
      intros. rewrite natrec_morph; auto.
       rewrite <- H0. apply H1.

       reflexivity.

       apply app2_m2.

       symmetry; trivial.

     rewrite natrec_0; trivial.

     intros. rewrite natrec_S; trivial.
      generalize prod_elim; intro Haux.
      specialize Haux with (2:=Hsucc) (3:=H). simpl in Haux.
      assert (eq_fun N
        (fun z : X =>
          prod (int P (V.cons z (V.shift 3 i)))
          (fun _ : X => int P (V.cons (succ z) (V.shift 3 i))))
        (fun z : X =>
          prod (int P (V.cons z (V.shift 3 i)))
          (fun _ : X => int P (V.cons (succ z) (V.shift 3 i))))) as H'.
      red; intros. apply prod_ext; [|do 2 red; intros]; rewrite H2; reflexivity.
      specialize Haux with (1:=H') (2:=Hsucc) (3:=H). clear H' Hsucc.
      generalize prod_elim; intro Haux1.
      assert ( eq_fun (int P (V.cons n (V.shift 3 i)))
        (fun _ : X => int P (V.cons (succ n) (V.shift 3 i)))
        (fun _ : X => int P (V.cons (succ n) (V.shift 3 i)))) as H'.
      red; intros; try reflexivity.
      specialize Haux1 with (1:=H') (2:=Haux) (3:=H0). clear H'. apply Haux1.
Qed.