Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Ensembles.

Require Import gen.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Global Parameter V : Set.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* In this file we define two Hilbert calculi based on sets for the propositonal
   bi-intuitionistic logics wBIL and sBIL.  *)

(* Definitions Language *)

(* First, let us define the propositional formulae we use here. *)

Inductive BPropF (W : Set) : Type :=
 | Var : W -> BPropF W
 | Bot : BPropF W
 | Top : BPropF W
 | And : BPropF W -> BPropF W -> BPropF W
 | Or : BPropF W -> BPropF W -> BPropF W
 | Imp : BPropF W -> BPropF W -> BPropF W
 | Excl : BPropF W -> BPropF W -> BPropF W
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.

Definition wNeg (A : BPropF V) := Excl (Top _) A.
Definition Neg (A : BPropF V) := Imp A (Bot _).

Fixpoint DN_form (n : nat) (A : (BPropF V)) : (BPropF V) :=
match n with
 | 0 => A
 | S m => Neg (wNeg (DN_form m A))
end.

Inductive DN_clos_set (Γ : @Ensemble (BPropF V)): @Ensemble (BPropF V) :=
  | InitClo : forall A, In _ Γ A -> DN_clos_set Γ A
  | IndClo : forall A,  DN_clos_set Γ A -> DN_clos_set Γ (Neg (wNeg A)).

Lemma eq_dec_form : forall x y : BPropF V, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v w). destruct s. left. subst. reflexivity.
    right. intro. inversion H. apply n. symmetry in H1. assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n. auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n. auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n. auto.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n. auto.
Qed.

Fixpoint size_form (A : BPropF V) : nat :=
match A with
 | # P => 1
 | Bot _ => 1
 | Top _ => 1
 | And B C => 1 + (size_form B) + (size_form C)
 | Or B C => 1 + (size_form B) + (size_form C)
 | Imp B C => 1 + (size_form B) + (size_form C)
 | Excl B C => 1 + (size_form B) + (size_form C)
end.

Fixpoint subst (f : V -> (BPropF V)) (A : (BPropF V)) : (BPropF V) :=
match A with
 | # P => (f P)
 | Bot _ => Bot _
 | Top _ => Top _
 | And B C => And (subst f B) (subst f C)
 | Or B C => Or (subst f B) (subst f C)
 | Imp B C => Imp (subst f B) (subst f C)
 | Excl B C => Excl (subst f B) (subst f C)
end.

(* Now, we can prove that some properties of formulae hold. *)

Definition is_atomicT (A : BPropF V) : Type :=
                  (exists (P : V), A = # P) + (A = Bot _) + (A = Top _).

(* We can define some types of lists formulae. For example, we can define
   lists of formulae which contain only propositional variables. *)

Definition is_Atomic (Γ : @Ensemble (BPropF V)) : Type :=
    forall (A : BPropF V), (Γ A) -> ((exists (P : V), A = # P) + (A = Bot _) + (A = Top _)).

(* We define here the axioms. *)

Definition RA1 (A B C : BPropF V) : BPropF V := (A → B) → ((B → C) → (A → C)).
Definition RA2 (A B : BPropF V) : BPropF V := A → (Or A B).
Definition RA3 (A B : BPropF V) : BPropF V := B → (Or A B).
Definition RA4 (A B C : BPropF V) : BPropF V := (A → C) → ((B → C) → ((Or A B) → C)).
Definition RA5 (A B : BPropF V) : BPropF V := (And A B) → A.
Definition RA6 (A B : BPropF V) : BPropF V := (And A B) → B.
Definition RA7 (A B C : BPropF V) : BPropF V := (A → B) → ((A → C) → (A → (And B C))).
Definition RA8 (A B C : BPropF V) : BPropF V := (A → (B → C)) → ((And A B) → C).
Definition RA9 (A B C : BPropF V) : BPropF V := ((And A B) → C) → (A → (B → C)).
Definition RA10 (A B : BPropF V) : BPropF V := (A → B) → ((Neg B) → (Neg A)).
Definition RA11 (A B : BPropF V) : BPropF V := A → (Or B (Excl A B)).
Definition RA12 (A B : BPropF V) : BPropF V := (Excl A B) → (wNeg (A → B)).
Definition RA13 (A B C : BPropF V) : BPropF V := (Excl (Excl A B) C) → (Excl A (Or B C)).
Definition RA14 (A B : BPropF V) : BPropF V := (Neg (Excl A B)) → (A → B).
Definition RA15 (A : BPropF V) : BPropF V := A → (Top _).
Definition RA16 (A : BPropF V) : BPropF V := (Bot _) → A.

Inductive BIAxioms (A : BPropF V) : Prop :=
 | RA1_I : (exists B C D, A = (RA1 B C D)) -> BIAxioms A
 | RA2_I : (exists B C, A = (RA2 B C)) -> BIAxioms A
 | RA3_I :  (exists B C, A = (RA3 B C)) -> BIAxioms A
 | RA4_I :  (exists B C D, A = (RA4 B C D)) -> BIAxioms A
 | RA5_I :  (exists B C, A = (RA5 B C)) -> BIAxioms A
 | RA6_I :  (exists B C, A = (RA6 B C)) -> BIAxioms A
 | RA7_I :  (exists B C D, A = (RA7 B C D)) -> BIAxioms A
 | RA8_I :  (exists B C D, A = (RA8 B C D)) -> BIAxioms A
 | RA9_I :  (exists B C D, A = (RA9 B C D)) -> BIAxioms A
 | RA10_I :  (exists B C, A = (RA10 B C)) -> BIAxioms A
 | RA11_I :  (exists B C, A = (RA11 B C)) -> BIAxioms A
 | RA12_I :  (exists B C, A = (RA12 B C)) -> BIAxioms A
 | RA13_I :  (exists B C D, A = (RA13 B C D)) -> BIAxioms A
 | RA14_I :  (exists B C, A = (RA14 B C)) -> BIAxioms A
 | RA15_I :  (exists B, A = (RA15 B)) -> BIAxioms A
 | RA16_I :  (exists B, A = (RA16 B)) -> BIAxioms A.

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later.

   We start by giving the rules common to both calculi. *)

Inductive IdRule : rls ((@Ensemble (BPropF V)) * (BPropF V)) :=
  | IdRule_I : forall A (Γ : @Ensemble _),
                  (Γ A) -> (IdRule [] (pair Γ A)).

(* Need to define above a set of axioms, and put it directly in the rule I guess. *)

Inductive AxRule : rls ((@Ensemble (BPropF V)) * (BPropF V)) :=
  | AxRule_I : forall Γ (A : BPropF V),
          (BIAxioms A) -> AxRule [] (pair Γ A)
.

Inductive MPRule : rls ((@Ensemble (BPropF V)) * (BPropF V)) :=
  | MPRule_I : forall A B Γ,
          MPRule [(pair Γ (A → B)); (pair Γ A)]
                    (pair Γ B)
.

(* Then we turn to the distinctive rules of each calculus. *)

Inductive DNwRule : rls ((@Ensemble (BPropF V)) * (BPropF V)) :=
  | DNwRule_I : forall (A : BPropF V) Γ,
          DNwRule [(pair (@Empty_set (BPropF V)) A)]
                    (pair Γ (Neg (wNeg A)))
.

Inductive DNsRule : rls ((@Ensemble (BPropF V)) * (BPropF V)) :=
  | DNsRule_I : forall (A : BPropF V) Γ,
          DNsRule [(pair Γ A)]
                    (pair Γ (Neg (wNeg A)))
.

(* At last we can define our calculus GLS and its proof-search version PSGLS. *)

Inductive wBIC_rules (s : ((@Ensemble (BPropF V)) * (BPropF V))) : Prop :=
  | Id : IdRule [] s -> wBIC_rules s
  | Ax : AxRule [] s -> wBIC_rules s
  | MP : forall ps, (forall prem, List.In prem ps -> wBIC_rules prem) -> MPRule ps s -> wBIC_rules s
  | DNw : forall ps, (forall prem, List.In prem ps -> wBIC_rules prem) -> DNwRule ps s -> wBIC_rules s
.

Inductive sBIC_rules (s : ((@Ensemble (BPropF V)) * (BPropF V))) : Prop :=
  | Ids : IdRule [] s -> sBIC_rules s
  | Axs : AxRule [] s -> sBIC_rules s
  | MPs : forall ps, (forall prem, List.In prem ps -> sBIC_rules prem) -> MPRule ps s -> sBIC_rules s
  | DNs : forall ps, (forall prem, List.In prem ps -> sBIC_rules prem) -> DNsRule ps s -> sBIC_rules s
.

(* Define the general notion of derivable pair. *)

Fixpoint list_disj (l : list (BPropF V)) : BPropF V :=
match l with
 | nil => Bot _
 | h :: t => Or h (list_disj t)
end.

Definition wpair_derrec (G : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
    exists (l : list (BPropF V)), NoDup l /\ (forall A, List.In A l -> ((snd G) A)) /\
        (wBIC_rules (fst G, list_disj l)).

Definition spair_derrec (G : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
    exists (l : list (BPropF V)), NoDup l /\ (forall A, List.In A l -> ((snd G) A)) /\
        (sBIC_rules (fst G, list_disj l)).

Definition complete (G : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
    forall (A : BPropF V), (fst G) A \/ (snd G) A.


(*begin hide*)
Require Import String. Open Scope string_scope.
Require Import Program.

From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
Import ssreflect ssrnat ssrbool ssrfun eqtype fintype.

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

Add LoadPath "./" as Top.
Require Import Top.CaseTactic.
Require Import Top.Syntax.
Require Import Top.Semantics.
Require Import Top.Coincidence.

Require Import Vector.
Require Import VectorEq.
Require Import ZArith.
(*end hide*)

Theorem Substitution_IntExp :
  forall (E E' : Env) (ie : IntExp E) (σ : Σ(E')) (σ' : Σ(E)) (δ : Δ E E'),
    (forall (w : Var E), ⟦ δ w ⟧ᵢ σ  = σ' ! w) -> ⟦ ie ⫽ᵢ δ ⟧ᵢ σ = ⟦ ie ⟧ᵢ σ'.
Proof.
  ¿?. (* Hueco a completar *)
Qed.

Theorem Substitution_BoolExp :
  forall (E : Env) (ae : Assert E) (E' : Env) (σ : Σ(E')) (σ' : Σ(E)) (δ : Δ E E') ,
    (forall (w : Var E), ⟦ δ w ⟧ᵢ σ  = σ' ! w) -> ⟦ ae ⫽ₐ δ ⟧ₐ σ = ⟦ ae ⟧ₐ σ'.
Proof.
  ¿?. (* Hueco a completar *)
Qed.


(* Computation needed to show termination of the Bernstein-Yang modular inversion algorithm *)

From ConCert.Extraction Require Import Loader.
From Coq Require Import Bool.
From Coq Require Import ZArith.

Import Z.
Local Open Scope Z.
Definition steps := Eval vm_compute in 2 ^ 44 : N.
Definition shiftl a b := Eval cbv in Z.shiftl a b.
Definition shiftr a b := Eval cbv in Z.shiftr a b.
Definition divstep d f g :=
  if (0 <? d) && odd g
  then (1 - d, g, shiftr (g - f) 1)
  else (1 + d, f, shiftr (g + (if odd g then 1 else 0) * f) 1 ).
Fixpoint needs_n_steps (d a b : Z) n :=
  match n with
  | 0%nat => true
  | S n => if (b =? 0)
          then false
          else let '(d', a', b') := divstep d a b in needs_n_steps d' a' b' n
  end.
Fixpoint min_needs_n_steps_nat (a b : Z) n (acc : Z) fuel :=
  match fuel with
  | 0%nat => 0
  | S fuel =>
    let a2 := a * a in
    if acc <? a2
        then acc
        else
          let length := a2 + b * b in
          if acc <? length
             then min_needs_n_steps_nat (a + 2) 0 n acc fuel
             else if needs_n_steps 1 a (shiftr b 1) n || needs_n_steps 1 a (- (shiftr b 1)) n
                  then min_needs_n_steps_nat (a + 2) 0 n (min length acc) fuel
                  else min_needs_n_steps_nat a (b + 2) n acc fuel
  end.
Definition nat_shiftl := Eval cbv in Nat.shiftl.
Definition W n := min_needs_n_steps_nat 1 0 n (shiftl 1 62) (nat_shiftl 1 44).

Extract Constant nat_shiftl => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a << b }".
(* Unsound in general, but fine for this program *)
Extract Constant shiftl => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a << b }".
Extract Constant shiftr => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a >> b }".

From ConCert.Extraction Require Import ExtrRustBasic.
From ConCert.Extraction Require Import ExtrRustUncheckedArith.
Redirect "../tests/extracted-code/rust-extract/BernsteinYangTermination.rs" ConCert Extract W.


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From ShortLogrels Require Import prelude language stlc_cbv.

Fixpoint val_rel (τ : type) (v : expr) : Prop :=
  match τ with
  | TUnit => v = TT
  | TProd τ1 τ2 => ∃ v1 v2, v = Pair v1 v2 ∧ val_rel τ1 v1 ∧ val_rel τ2 v2
  | TFun τ1 τ2 => is_val v ∧ ∀ w, val_rel τ1 w → Normalizes (val_rel τ2) (App v w)
  end.

Lemma val_rel_is_val τ v : val_rel τ v → is_val v.
Proof.
  revert v; induction τ; intros v; simpl in *; subst.
  - intros ?; subst; constructor.
  - firstorder; subst; constructor; auto.
  - intuition.
Qed.

Definition expr_rel (τ : type) (e : expr) := Normalizes (val_rel τ) e.

Theorem Fundamental Γ e τ :
  typed Γ e τ → ∀ env, env_rel val_rel Γ env → expr_rel τ e.[env_subst env].
Proof.
  intros Htp.
  induction Htp; intros env Henv; simpl.
  - simpl.
    assert (val_rel tp (env_subst env v)).
    { eapply env_rel_lookup1 in Henv as [? [? ?]]; [|eauto; fail].
      erewrite env_subst_lookup; eauto. }
    apply Normalizes_val; [eapply val_rel_is_val; eauto|assumption].
  - apply Normalizes_val; [constructor|simpl; trivial].
  - eapply (Normalizes_bind _ _ _ (λ e, Pair e _));
      [repeat econstructor; fail|apply IHHtp1; trivial; fail|].
    intros v1 Hv11 Hv12.
    eapply (Normalizes_bind _ _ _ (λ e, Pair _ e)); [|apply IHHtp2; trivial; fail|].
    { repeat econstructor; trivial. }
    intros v2 Hv21 Hv22.
    apply Normalizes_val; [constructor; trivial; fail|eexists _, _; eauto].
  - eapply (Normalizes_bind _ _ _ (λ e, Fst e));
      [repeat econstructor; fail|apply IHHtp; trivial; fail|].
    intros v Hv1 (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply Normalizes_head_step_back; [constructor; auto; fail|].
    apply Normalizes_val; assumption.
  - eapply (Normalizes_bind _ _ _ (λ e, Snd e));
      [repeat econstructor; fail|apply IHHtp; trivial; fail|].
    intros v Hv1 (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply Normalizes_head_step_back; [constructor; auto; fail|].
    apply Normalizes_val; assumption.
  - apply Normalizes_val; [constructor; fail|].
    split; [constructor; fail|].
    intros w Hw.
    assert (is_val w) by (eapply val_rel_is_val; eauto).
    eapply Normalizes_head_step_back; [constructor; auto; fail|].
    asimpl.
    apply (IHHtp (_ :: _)).
    apply env_rel_cons; assumption.
  - eapply (Normalizes_bind _ _ _ (λ e, App e _));
      [repeat econstructor; fail|apply IHHtp1; trivial; fail|].
    intros v1 Hv11 Hv12.
    eapply (Normalizes_bind _ _ _ (λ e, App _ e)); [|apply IHHtp2; trivial; fail|].
    { repeat econstructor; trivial. }
    intros v2 Hv21 Hv22.
    apply Hv12; trivial.
Qed.

Corollary type_safety e τ : typed nil e τ → Normalizes (λ _, True) e.
Proof.
  intros Htp.
  eapply Normalizes_mono; [tauto|].
  replace e with e.[env_subst nil] by (asimpl; reflexivity).
  eapply (Fundamental nil); [eassumption|apply env_rel_nil].
Qed.


(** * Functors involving product categories *)
Require Import Category.Core Functor.Core Category.Prod Functor.Composition.Core.
Require Import Functor.Paths.
Require Import Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation fst_type := fst.
Local Notation snd_type := snd.
Local Notation pair_type := pair.

Local Open Scope morphism_scope.
Local Open Scope functor_scope.

(** ** First and second projections from a product precategory *)
Section proj.
  Context {C : PreCategory}.
  Context {D : PreCategory}.

  Definition fst : Functor (C * D) C
    := Build_Functor (C * D) C
                     (@fst _ _)
                     (fun _ _ => @fst _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition snd : Functor (C * D) D
    := Build_Functor (C * D) D
                     (@snd _ _)
                     (fun _ _ => @snd _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End proj.

(** ** Product of two functors from the same domain *)
Section prod.
  Variables C D D' : PreCategory.

  Definition prod (F : Functor C D) (F' : Functor C D')
  : Functor C (D * D')
    := Build_Functor
         C (D * D')
         (fun c => (F c, F' c))
         (fun s d m => (F _1 m, F' _1 m))
         (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _)
                                      (composition_of F' _ _ _ _ _))
         (fun _ => path_prod' (identity_of F _) (identity_of F' _)).
End prod.

Local Infix "*" := prod : functor_scope.

(** ** Pairing of two functors *)
Section pair.
  Variables C D C' D' : PreCategory.
  Variable F : Functor C D.
  Variable F' : Functor C' D'.

  Local Open Scope functor_scope.

  Definition pair : Functor (C * C') (D * D')
    := (F o fst) * (F' o snd).
End pair.

Local Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope.

(** ** Partially applied functors out of a product precategory *)
Section induced.
  Variables C D E : PreCategory.

  Variable F : Functor (C * D) E.

  Local Open Scope core_scope.

  Local Ltac t :=
    simpl; intros;
    repeat (rewrite <- ?composition_of, <- ?identity_of, ?left_identity, ?right_identity; simpl);
    trivial.

  (** Note: This is just the currying exponential law. *)
  (** TODO: Come up with a better name for this? *)
  Definition induced_fst (d : D) : Functor C E.
  Proof.
    refine (Build_Functor
              C E
              (fun c => F (c, d))
              (fun _ _ m => @morphism_of _ _ F (_, _) (_, _) (m, identity d))
              _
              _);
    abstract t.
  Defined.

  Definition induced_snd (c : C) : Functor D E.
  Proof.
    refine (Build_Functor
              D E
              (fun d => F (c, d))
              (fun _ _ m => @morphism_of _ _ F (_, _) (_, _) (identity c, m))
              _
              _);
    abstract t.
  Defined.
End induced.

Local Set Warnings Append "-notation-overridden".
Module Export FunctorProdCoreNotations.
  Infix "*" := prod : functor_scope.
  Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope.
End FunctorProdCoreNotations.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Basic_Cons.Product.
From Categories Require Import PreSheaf.PreSheaf.

Section Product.
  Context (C : Category) (F G : PShCat C).

  Local Hint Extern 1 =>
  match goal with
    [F : (_ ^op –≻ Type_Cat)%functor |- _] => rewrite (F_id F)
  end.
  Local Hint Extern 1 =>
  match goal with
    [F : (_ ^op –≻ Type_Cat)%functor |- context [(F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  (** The pointwise product presheaf. *)
  Program Definition pointwise_product_psh : PShCat C :=
    {|
      FO := fun x => ((F _o x) * (G _o x))%object%type;
      FA := fun _ _ f u => (F _a f (fst u), G _a f (snd u))%morphism%object
    |}.

  Local Hint Extern 1 =>
  repeat
    match goal with
      [f : (?p –≻ _)%nattrans,
           h : (_ –≻ _)%morphism, c : _, x : (?p _o)%object _ |- _] =>
      cbn_rewrite (equal_f (Trans_com f h) x)
    end.

  (** The pointwise product presheaf is the product of presheaves. *)
  Program Definition PSh_Product : (F × G)%object :=
    {|
      product := pointwise_product_psh;
      Pi_1 := {| Trans := fun _ => fst |};
      Pi_2 := {| Trans := fun _ => snd |};
      Prod_morph_ex :=
        fun p' f g => {|Trans := fun x u => (Trans f x u, Trans g x u) |}
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros p' r1 r2 f g H1 H2 H3 H4; cbn in *.
    rewrite <- H3 in H1; rewrite <- H4 in H2; clear H3 H4.
    apply NatTrans_eq_simplify.
    extensionality v; extensionality z.
    assert (W1 := f_equal (fun w : (p' –≻ F)%nattrans => Trans w v z) H1).
    assert (W2 := f_equal (fun w : (p' –≻ G)%nattrans => Trans w v z) H2).
    cbn in W1, W2.
    match goal with
      [|- ?A = ?B] => destruct A; destruct B; cbn in *; auto
    end.
  Qed.

End Product.

Instance PSh_Has_Products (C : Category) : Has_Products (PShCat C) :=
  PSh_Product C.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


From Coq Require Import Reals.
From Flocq Require Import Core.
From Gappa Require Import Gappa_tactic.
Open Scope R_scope.

Goal
  forall x y : R,
  3/4 <= x <= 3 ->
  0 <= sqrt x <= 1775 * powerRZ 2 (-10).
Proof.
  gappa.
Qed.

Definition rnd := rounding_float rndZR 53 (-1074).

Goal
  forall a_ b_ a b : R,
  a = rnd a_ ->
  b = rnd b_ ->
  52 / 16 <= a <= 53 / 16 ->
  22 / 16 <= b <= 30 / 16 ->
  0 <= rnd (a - b) - (a - b) <= 0.
Proof.
  unfold rnd ; gappa.
Qed.


From Coq Require Import ZArith .
From mQhasm Require Import mQhasm .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition mul25519_stage1 : program :=

let          qtwo :=   zConst (2%Z) in
let         wsize :=   64%positive in
let      pow2 x n := zBinop zMul x (zPow qtwo n) in

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let         carry := 999 in
let           tmp := 998 in

let           r0l :=  20 in
let           r1l :=  21 in
let           r2l :=  22 in
let           r3l :=  23 in
let           r4l :=  24 in
let           r5l :=  25 in
let           r6l :=  26 in
let           r7l :=  27 in
let           r8l :=  28 in

let           r0h :=  40 in
let           r1h :=  41 in
let           r2h :=  42 in
let           r3h :=  43 in
let           r4h :=  44 in
let           r5h :=  45 in
let           r6h :=  46 in
let           r7h :=  47 in
let           r8h :=  48 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
[::

      (*  mulrax = *[uint64 *](xp + 0) *)
      (*  (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*  r0l = mulrax *)
      (*  r0h = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r0l (zVar mulrax);
zAssign r0h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 8) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (* r1l = mulrax *)
      (* r1h = mulrdx *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r1l (zVar mulrax);
zAssign r1h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 0) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (* carry? r1l += mulrax *)
      (* r1h += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r1l (zBinop zAdd (zVar r1l) (zVar mulrax));
zSplit carry r1l (zVar r1l) wsize;
zAssign r1h (zBinop zAdd (zVar r1h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 16) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (* r2l = mulrax *)
      (* r2h = mulrdx *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r2l (zVar mulrax);
zAssign r2h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 8) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (* carry? r2l += mulrax *)
      (* r2h += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r2l (zBinop zAdd (zVar r2l) (zVar mulrax));
zSplit carry r2l (zVar r2l) wsize;
zAssign r2h (zBinop zAdd (zVar r2h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 0) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (* carry? r2l += mulrax *)
      (* r2h += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r2l (zBinop zAdd (zVar r2l) (zVar mulrax));
zSplit carry r2l (zVar r2l) wsize;
zAssign r2h (zBinop zAdd (zVar r2h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 24) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (* r3l = mulrax *)
      (* r3h = mulrdx *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r3l (zVar mulrax);
zAssign r3h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 16) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (* carry? r3l += mulrax *)
      (* r3h += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r3l (zBinop zAdd (zVar r3l) (zVar mulrax));
zSplit carry r3l (zVar r3l) wsize;
zAssign r3h (zBinop zAdd (zVar r3h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (* mulrax = *[uint64 *](xp + 8) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (* carry? r3l += mulrax *)
      (* r3h += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r3l (zBinop zAdd (zVar r3l) (zVar mulrax));
zSplit carry r3l (zVar r3l) wsize;
zAssign r3h (zBinop zAdd (zVar r3h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 0) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (* carry? r3l += mulrax *)
      (* r3h += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r3l (zBinop zAdd (zVar r3l) (zVar mulrax));
zSplit carry r3l (zVar r3l) wsize;
zAssign r3h (zBinop zAdd (zVar r3h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 32) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (* r4l = mulrax *)
      (* r4h = mulrdx *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r4l (zVar mulrax);
zAssign r4h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 24) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (* carry? r4l += mulrax *)
      (* r4h += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r4l (zBinop zAdd (zVar r4l) (zVar mulrax));
zSplit carry r4l (zVar r4l) wsize;
zAssign r4h (zBinop zAdd (zVar r4h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 16) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (* carry? r4l += mulrax *)
      (* r4h += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r4l (zBinop zAdd (zVar r4l) (zVar mulrax));
zSplit carry r4l (zVar r4l) wsize;
zAssign r4h (zBinop zAdd (zVar r4h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 8) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (* carry? r4l += mulrax *)
      (* r4h += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r4l (zBinop zAdd (zVar r4l) (zVar mulrax));
zSplit carry r4l (zVar r4l) wsize;
zAssign r4h (zBinop zAdd (zVar r4h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 0) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (* carry? r4l += mulrax *)
      (* r4h += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r4l (zBinop zAdd (zVar r4l) (zVar mulrax));
zSplit carry r4l (zVar r4l) wsize;
zAssign r4h (zBinop zAdd (zVar r4h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 32) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (* r5l = mulrax *)
      (* r5h = mulrdx *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r5l (zVar mulrax);
zAssign r5h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 24) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (* carry? r5l += mulrax *)
      (* r5h += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r5l (zBinop zAdd (zVar r5l) (zVar mulrax));
zSplit carry r5l (zVar r5l) wsize;
zAssign r5h (zBinop zAdd (zVar r5h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 16) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (* carry? r5l += mulrax *)
      (* r5h += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r5l (zBinop zAdd (zVar r5l) (zVar mulrax));
zSplit carry r5l (zVar r5l) wsize;
zAssign r5h (zBinop zAdd (zVar r5h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 8) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (* carry? r5l += mulrax *)
      (* r5h += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r5l (zBinop zAdd (zVar r5l) (zVar mulrax));
zSplit carry r5l (zVar r5l) wsize;
zAssign r5h (zBinop zAdd (zVar r5h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 32) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (* r6l = mulrax *)
      (* r6h = mulrdx *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r6l (zVar mulrax);
zAssign r6h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 24) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (* carry? r6l += mulrax *)
      (* r6h += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r6l (zBinop zAdd (zVar r6l) (zVar mulrax));
zSplit carry r6l (zVar r6l) wsize;
zAssign r6h (zBinop zAdd (zVar r6h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 16) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (* carry? r6l += mulrax *)
      (* r6h += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r6l (zBinop zAdd (zVar r6l) (zVar mulrax));
zSplit carry r6l (zVar r6l) wsize;
zAssign r6h (zBinop zAdd (zVar r6h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 32) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (* r7l = mulrax *)
      (* r7h = mulrdx *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r7l (zVar mulrax);
zAssign r7h (zVar mulrdx);
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 24) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (* carry? r7l += mulrax *)
      (* r7h += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r7l (zBinop zAdd (zVar r7l) (zVar mulrax));
zSplit carry r7l (zVar r7l) wsize;
zAssign r7h (zBinop zAdd (zVar r7h) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (* mulrax = *[uint64 *](xp + 32) *)
      (* (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (* r8l = mulrax *)
      (* r8h = mulrdx *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r8l (zVar mulrax);
zAssign r8h (zVar mulrdx)
] .

Definition mul25519_stage1_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            y0 :=   5 in
let            y1 :=   6 in
let            y2 :=   7 in
let            y3 :=   8 in
let            y4 :=   9 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4; y0; y1; y2; y3; y4].

Definition mul25519_stage1_pre : bexp := zTrue.

Definition mul25519_stage1_post : bexp :=
let      pow2 x n := zBinop zMul x (zPow qtwo n) in
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let         carry := 999 in
let           tmp := 998 in

let           r0l :=  20 in
let           r1l :=  21 in
let           r2l :=  22 in
let           r3l :=  23 in
let           r4l :=  24 in
let           r5l :=  25 in
let           r6l :=  26 in
let           r7l :=  27 in
let           r8l :=  28 in

let           r0h :=  40 in
let           r1h :=  41 in
let           r2h :=  42 in
let           r3h :=  43 in
let           r4h :=  44 in
let           r5h :=  45 in
let           r6h :=  46 in
let           r7h :=  47 in
let           r8h :=  48 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEq
  (
    (radix51 [::zVar x0; zVar x1; zVar x2; zVar x3; zVar x4])
    @*
    (radix51 [::zVar y0; zVar y1; zVar y2; zVar y3; zVar y4])
  )
  (
    radix51 [:: zBinop zAdd (zVar r0l) (pow2 (zVar r0h) 64%positive);
                zBinop zAdd (zVar r1l) (pow2 (zVar r1h) 64%positive);
                zBinop zAdd (zVar r2l) (pow2 (zVar r2h) 64%positive);
                zBinop zAdd (zVar r3l) (pow2 (zVar r3h) 64%positive);
                zBinop zAdd (zVar r4l) (pow2 (zVar r4h) 64%positive);
                zBinop zAdd (zVar r5l) (pow2 (zVar r5h) 64%positive);
                zBinop zAdd (zVar r6l) (pow2 (zVar r6h) 64%positive);
                zBinop zAdd (zVar r7l) (pow2 (zVar r7h) 64%positive);
                zBinop zAdd (zVar r8l) (pow2 (zVar r8h) 64%positive)
            ]
  ).

Definition mul25519_stage1_spec :=
  {| spre := mul25519_stage1_pre;
     sprog := mul25519_stage1;
     spost := mul25519_stage1_post |}.

Add Rec LoadPath "../lib/gbarith/src/" as GBArith.
Add ML Path "../lib/gbarith/src/".
From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_mul25519_stage1 : valid_ispec (mul25519_stage1_inputs, mul25519_stage1_spec).
Proof.
  Time verify_zspec.
  (* 843.868s *)
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


From Coq Require Import Lists.List.
From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From appliedfm Require Import int_or_ptr.vst.cmodel.constants.
From appliedfm Require Import int_or_ptr.vst.cmodel.val.

From CertiCoq Require Import Block.vst.cmodel.certicoq_block_header.

Local Open Scope Z.

Record Block := {
  block_header:> BlockHeader;
  block_fields: list int_or_ptr;
  block_fields__block_header_field_count: Zlength block_fields = block_header_field_count block_header;
}.

Program Definition block_init (h: BlockHeader):
  Block
 := {|
  block_header := h;
  block_fields := repeat None (Z.to_nat (block_header_field_count h));
  block_fields__block_header_field_count := _;
|}.
Next Obligation.
  intros h.
  pose proof (block_header_field_count__range h) as HH1.
  now rewrite sublist.Zlength_repeat by lia.
Qed.

Lemma block_fields__Zlength (b: Block):
    1 <= Zlength (block_fields b) < two_p (word_size * 8 - 10).
Proof.
    rewrite block_fields__block_header_field_count.
    apply block_header_field_count__range.
Qed.


Variables A B C : Prop.

Lemma or_commutative : A \/ B -> B \/ A.

tauto.

Qed.

Print or_commutative.

Lemma distr_and : A -> B /\ C -> (A -> B) /\ (A -> C).

tauto.

Qed.

Lemma Peirce : ((A -> B) -> A) -> A.

try tauto.

(*tauto.*)

Lemma NNPeirce : ~ ~ (((A -> B) -> A) -> A).

tauto.

Require Import Classical.

Check NNPP.

Lemma Peirce : ((A -> B) -> A) -> A.

apply NNPP.

tauto.

Qed.

Section club.

Variables Scottish RedSocks WearKilt Married GoOutSunday : Prop.


From Coq Require Import Ensembles List.
From Catincoq.lib Require Import tactics list defs.

(** This file describes the function one_of_each : P(P(X)) -> P(P(X)),
defined in defs.v, which, given a set of sets S1..Sn, returns the set
of sets {e1..en} such that ei is in Si. The formal definition is not
obviously right, so we prove the equivalence with the analog function
on lists: list_list_prod *)

Lemma list_fun_rel_dom {A B} (dom : Ensemble A) (R : A -> B -> Prop) :
  functional_relation_domain dom R ->
  forall l : list A, Forall dom l -> exists l' : list B, Forall2 R l l'.
Proof.
  intros [Rdef _] l doml.
  induction l.
  - exists nil. constructor.
  - spec Rdef a. destruct Rdef as [Rdef _].
    spec Rdef by now inversion doml; congruence.
    spec IHl by now inversion doml; congruence.
    destruct Rdef as (b & Hb).
    destruct IHl as (l' & Hl').
    exists (b :: l'). now constructor.
Qed.

Definition set_of_list {X} : list X -> Ensemble X :=
  fun l x => In x l.

Definition sets_of_lists {X} : list (list X) -> Ensemble (Ensemble X) :=
  fun l => set_of_list (map set_of_list l).

Definition inclusion_set_of_set {A} (X Y : Ensemble (Ensemble A)) :=
  forall x, X x -> exists y, Y y /\ Same_set _ x y.

Definition same_set_of_set {A} (X Y : Ensemble (Ensemble A)) :=
  inclusion_set_of_set X Y /\
  inclusion_set_of_set Y X.

Lemma Extensionality_Ensembles' {U} (A B : Ensemble U) :
  Same_set U A B <-> A = B.
Proof.
  split. apply Extensionality_Ensembles. intros ->; firstorder.
Qed.

Lemma Extensionality_Ensembles'' {U} (A : Ensemble U) :
  Same_set U A = eq A.
Proof.
  apply Extensionality_Ensembles'; split; intros B.
  apply Extensionality_Ensembles. intros ->; firstorder.
Qed.

Lemma one_of_each_spec_list {X} (L : list (list X)) :
  NoDup (map set_of_list L) ->
  same_set_of_set
    (one_of_each (sets_of_lists L))
    (sets_of_lists (list_list_prod L)).
Proof.
  intros Hnodup.
  destruct (in_dec_refined nil L) as [Hnil | Hnil].
  now intros []; firstorder discriminate.
  {
    (* case where one of the lists is empty *)
    split.
    - intros image (f & fi & (Hf & WQ) & E).
      exfalso.
      destruct (Hf (set_of_list nil)) as [fnil _].
      spec fnil. {
        unfold sets_of_lists, set_of_list.
        rewrite in_map_iff.
        firstorder.
      }
      destruct fnil as (x, Hx).
      apply fi in Hx.
      tauto.
    - apply list_list_prod_nil in Hnil.
      rewrite Hnil. unfold sets_of_lists at 2. simpl.
      unfold set_of_list. simpl.
      intros x [].
  }
  split.
  - (* suppose we have a choice function f : P(X) -> X. We show that
     the direct image of [[L]] through f is in [[list_list_prod L]] *)
    intros image (f & fi & Hf & E).
    apply Extensionality_Ensembles in E. subst image.
    rewrite Extensionality_Ensembles''.
    exists (relational_image f (sets_of_lists L)). split; auto.
    (* for this, we apply f to the list of [l] where l \in L to get fL,
    the list of images of L through f *)
    epose proof list_fun_rel_dom _ f Hf (map set_of_list L).
    spec H by now apply Forall_forall.
    destruct H as [fL HfL].
    unfold sets_of_lists, sets_of_lists, set_of_list at 1.
    rewrite in_map_iff.
    (* this fL is indeed the fL in the image, which is almost a tautology.. *)
    exists fL. split.
    { rewrite <-Extensionality_Ensembles''.
      split.
      - intros fx Hx.
        change (In fx fL) in Hx.
        unfold Ensembles.In.
        edestruct (Forall2_In _ _ _ HfL fx Hx).
        now firstorder.
      - intros fl. unfold Ensembles.In.
        intros (A & AL & Afl).
        change (In A (map set_of_list L)) in AL.
        change (In fl fL).
        rewrite in_map_iff in AL. destruct AL as (l & <- & lL).
        epose proof In_Forall2 f _ _ HfL (set_of_list l).
        rewrite in_map_iff in H. spec H by firstorder.
        destruct H as (fl_ & fl_fL & l_fl_).
        enough (fl = fl_) by congruence.
        eapply Hf; eauto.
    }
    (* now that the trivial thing is proved, let's prove fL is in
    list_list_prod *)
    rewrite list_list_prod_in'.
    apply Forall2_swap_iff in HfL.
    eapply Forall2_map_inv; eauto.
    simpl.
    intros a l lL fa.
    apply fi in fa. auto.
  - intros b.
    unfold sets_of_lists at  1.
    unfold set_of_list at 1.
    rewrite in_map_iff.
    intros (l & <- & lL).
    rewrite list_list_prod_in' in lL.
    rewrite Extensionality_Ensembles''.
    exists (set_of_list l). split; auto.
    unfold one_of_each.
    set (f := fun e x => exists i,
                  nth_error l i = Some x /\
                  set_of_list (nth i L nil) = e).
    exists f.
    split 4.
    + (* f choses an element inside the set *)
      subst f.
      (* intros e fe ne (i & Efe & <-). *)
      intros e fe (i & Efe & <-).
      unfold set_of_list.
      destruct (nth_Forall2 _ _ _ lL i fe Efe) as (m & im & fem).
      erewrite nth_error_nth; eauto.
    + (* f is a functional relation *)
      split.
      * intros e; split.
        -- intros Le.
           unfold sets_of_lists in *.
           unfold set_of_list in *.
           apply In_nth_error in Le.
           destruct Le as (i & Le).
           apply nth_error_map in Le.
           destruct Le as (Li & HLi & ->).
           destruct (Forall2_nth _ _ _ lL _ _ HLi) as (x & m  & xm).
           exists x. exists i. firstorder.
           erewrite nth_error_nth; eauto.
        -- intros (x & i & ix & <-).
           destruct (nth_Forall2 _ _ _ lL _ _ ix) as (m & Lm  & xm).
           erewrite nth_error_nth; eauto.
           hnf.
           rewrite in_map_iff. exists m; firstorder.
           eapply nth_error_In; eauto.
      * (* here, we need the nodup hypothesis: no two lists have the
        same set of elements *)
        intros e x y (i & ix & ei) (j & jy & ej).
        assert (iL : i < Datatypes.length L). {
          erewrite <-Forall2_length; eauto.
          apply nth_error_Some. congruence.
        }
        assert (jL : j < Datatypes.length L). {
          erewrite <-Forall2_length; eauto.
          apply nth_error_Some. congruence.
        }
        enough (i = j) by congruence.
        rewrite NoDup_nth_error in Hnodup.
        spec Hnodup i j.
        spec Hnodup by now rewrite map_length.
        apply Hnodup.
        transitivity (Some e); [ | symmetry ].
        -- rewrite <-ei. eapply map_nth_error. now apply nth_error_nth'.
        -- rewrite <-ej. eapply map_nth_error. now apply nth_error_nth'.
    + (* l is included in f(L) *)
      unfold Included, Ensembles.In, set_of_list.
      intros x Hx.
      hnf.
      apply In_nth_error in Hx.
      destruct Hx as (i, Hi).
      destruct (nth_Forall2 _ _ _ lL _ _ Hi) as (m & im & xm).
      exists (set_of_list m).
      split.
      * unfold sets_of_lists.
        unfold sets_of_lists, set_of_list at 1.
        rewrite in_map_iff.
        exists m.
        firstorder.
        eapply nth_error_In; eauto.
      * exists i. firstorder.
        erewrite nth_error_nth; eauto.
    + hnf.
      intros x (e & eL & i & ix & ie).
      eapply nth_error_In; eauto.
Qed.


Require Export NaturalDeduction.
Require Import SequentCalculus.
Require Import NDSCEquiv.

Section LJTstar.

Context {atom : Type}.

Reserved Notation "Γ ⇒* P" (no associativity, at level 61).

Inductive remove (x : prop atom) : list (prop atom) -> list (prop atom) -> Prop :=
| remove_here {l} : remove x (x :: l) l
| remove_later {h l l'} : remove x l l' -> remove x (h :: l) (h :: l').

Lemma In_ex_remove : forall x l, In x l <-> exists l', remove x l l'.
Proof.
split; intros.
+ induction l; destruct H; subst.
  - exists l; constructor.
  - destruct (IHl H) as [l0]. exists (a :: l0); constructor; auto.
+ destruct H as [l']. induction H.
  - left; reflexivity.
  - right; assumption.
Qed.

Corollary remove_In : forall x l l', remove x l l' -> In x l.
Proof.
intros. rewrite In_ex_remove. eauto.
Qed.

Lemma In_remove : forall y x l l', remove x l l' ->
  (In y l <-> y = x \/ In y l').
Proof.
induction 1; intuition.
+ destruct H; intuition.
+ left. symmetry; assumption.
+ destruct H1; subst.
  - right; left; reflexivity.
  - destruct (H0 H1); intuition.
+ destruct H4; subst.
  - left; reflexivity.
  - right; auto.
Qed.

Lemma remove_subcontext : forall x l l', remove x l l' -> x :: l' ⊆ l.
Proof.
intros; intros y ?. rewrite (In_remove _ _ _ _ H).
destruct H0; auto.
Qed.

Lemma remove_subcontext_rev : forall x l l', remove x l l' -> l ⊆ x :: l'.
Proof.
intros. intros y ?. rewrite (In_remove _ _ _ _ H) in H0.
simpl. destruct H0; auto.
Qed.

Inductive LJTstar_proves : list (prop atom) -> prop atom -> Prop :=
| LJTstar_init {Γ P} : In P Γ -> Γ ⇒* P
| LJTstar_bot_elim {Γ P} : In ⊥ Γ -> Γ ⇒* P
| LJTstar_top_intro {Γ} : Γ ⇒* ⊤
| LJTstar_and_intro {Γ P Q} : Γ ⇒* P -> Γ ⇒* Q -> Γ ⇒* P ∧ Q
| LJTstar_and_elim {Γ P Q R Γ'} : remove (P ∧ Q) Γ Γ' ->
  P :: Q :: Γ' ⇒* R -> Γ ⇒* R
| LJTstar_or_introl {Γ P Q} : Γ ⇒* P -> Γ ⇒* P ∨ Q
| LJTstar_or_intror {Γ P Q} : Γ ⇒* Q -> Γ ⇒* P ∨ Q
| LJTstar_or_elim {Γ P Q R Γ'} : remove (P ∨ Q) Γ Γ' ->
  P :: Γ' ⇒* R -> Q :: Γ' ⇒* R -> Γ ⇒* R
| LJTstar_impl_intro {Γ P Q} : P :: Γ ⇒* Q -> Γ ⇒* P ⊃ Q
| LJTstar_impl_assump_elim {Γ P Q R Γ'} :
  remove (P ⊃ Q) Γ Γ' -> In P Γ' -> Q :: Γ' ⇒* R ->
  Γ ⇒* R
| LJTstar_red_top_impl {Γ P Q Γ'} : remove (⊤ ⊃ P) Γ Γ' ->
  P :: Γ' ⇒* Q -> Γ ⇒* Q
| LJTstar_red_and_impl {Γ P Q R S Γ'} : remove (P ∧ Q ⊃ R) Γ Γ' ->
  P ⊃ Q ⊃ R :: Γ' ⇒* S -> Γ ⇒* S
| LJTstar_red_or_impl {Γ P Q R S Γ'} : remove (P ∨ Q ⊃ R) Γ Γ' ->
  P ⊃ R :: Q ⊃ R :: Γ' ⇒* S -> Γ ⇒* S
| LJTstar_impl_impl_elim {Γ P Q R S Γ'} : remove ((P ⊃ Q) ⊃ R) Γ Γ' ->
  P :: Q ⊃ R :: Γ' ⇒* Q -> R :: Γ' ⇒* S -> Γ ⇒* S
where "Γ ⇒* P" := (LJTstar_proves Γ P).

Example LJTstar_no_Peirce : forall x y:atom, x <> y -> let P := atom_prop x in
  let Q := atom_prop y in ~ (nil ⇒* ((P ⊃ Q) ⊃ P) ⊃ P).
Proof.
intros; subst P Q. intro.
(* only possible first step is LJTstar_impl_intro *)
inversion_clear H0;
repeat match goal with
| H0 : In _ _ |- _ => destruct H0; subst
| H0 : remove _ _ _ |- _ => inversion_clear H0
end.
(* only possible next step is LJTstar_impl_impl_elim *)
inversion H1; subst;
repeat match goal with
| H0 : In _ _ |- _ => destruct H0; try discriminate; subst
| H0 : remove _ _ _ |- _ => inversion H0; subst
end.
(* in subgoal [ x; y ⊃ x ] ⇒* y, cannot make any more progress *)
clear H1 H3 H0. inversion H2; subst; repeat match goal with
| H0 : In _ _ |- _ => destruct H0; try discriminate; subst
| H0 : remove _ _ _ |- _ => inversion H0; subst
end; congruence.
Qed.

Theorem LJTstar_soundness {Γ P} : Γ ⇒* P -> Γ ⊢ P.
Proof.
induction 1; try match goal with
| H : remove _ _ _ |- _ ⊢ _ =>
  rewrite <- (remove_subcontext _ _ _ H); clear H
end.
+ apply ND_assumption; assumption.
+ apply ND_exfalso_quodlibet. apply ND_assumption; assumption.
+ apply ND_True_intro.
+ apply ND_and_intro; assumption.
+ apply @ND_and_elim with (P := P) (Q := Q).
  - apply ND_assumption. prove_In.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves).
    prove_subcontext.
+ apply ND_or_introl; assumption.
+ apply ND_or_intror; assumption.
+ apply @ND_proof_by_cases with (P := P) (Q := Q).
  - apply ND_assumption. prove_In.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves1).
    prove_subcontext.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves2).
    prove_subcontext.
+ apply ND_cond_proof; assumption.
+ apply @ND_cut with (P := Q).
  - apply @ND_modus_ponens with (P := P).
    * apply ND_assumption. prove_In.
    * apply ND_assumption. right; assumption.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves).
    prove_subcontext.
+ apply @ND_cut with (P := P).
  - apply @ND_modus_ponens with (P := ⊤).
    * apply ND_assumption. prove_In.
    * apply ND_True_intro.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves).
    prove_subcontext.
+ apply @ND_cut with (P := P ⊃ Q ⊃ R).
  - do 2 apply ND_cond_proof. apply @ND_modus_ponens with (P := P ∧ Q).
    * apply ND_assumption. prove_In.
    * apply ND_and_intro; apply ND_assumption; prove_In.
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves).
    prove_subcontext.
+ apply @ND_cut with (P := Q ⊃ R).
  - apply ND_cond_proof. apply @ND_modus_ponens with (P := P ∨ Q).
    * apply ND_assumption. prove_In.
    * apply ND_or_intror; apply ND_assumption; prove_In.
  - apply @ND_cut with (P := P ⊃ R).
    * apply ND_cond_proof. apply @ND_modus_ponens with (P := P ∨ Q).
      { apply ND_assumption. prove_In. }
      { apply ND_or_introl; apply ND_assumption; prove_In. }
    * refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves).
      prove_subcontext.
+ apply @ND_cut with (P := R).
  - apply @ND_modus_ponens with (P := P ⊃ Q).
    * apply ND_assumption; prove_In.
    * apply ND_cond_proof. apply @ND_cut with (P := Q ⊃ R).
      { apply ND_cond_proof. apply @ND_modus_ponens with (P := P ⊃ Q).
        + apply ND_assumption; prove_In.
        + apply ND_cond_proof. apply ND_assumption; prove_In.
      }
      { refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves1).
        prove_subcontext. }
  - refine (ND_context_extension _ _ _ _ _ eq_refl IHLJTstar_proves2).
    prove_subcontext.
Qed.

Fixpoint prop_cost (P : prop atom) : nat :=
match P with
| atom_prop _ => 0
| ⊤ => 0
| ⊥ => 0
| Q ∧ R => 2 + (prop_cost Q + prop_cost R)
| Q ∨ R => 1 + (prop_cost Q + prop_cost R)
| Q ⊃ R => 1 + (prop_cost Q + prop_cost R)
end.

Fixpoint add_cost_to_list (n:nat) (l:list nat) {struct n} : list nat :=
match n, l with
| 0, nil => 1 :: nil
| 0, h :: t => S h :: t
| S m, nil => 0 :: add_cost_to_list m nil
| S m, h :: t => h :: add_cost_to_list m t
end.

Fixpoint context_cost (Γ : list (prop atom)) : list nat :=
match Γ with
| nil => nil
| P :: Γ' => add_cost_to_list (prop_cost P) (context_cost Γ')
end.

Inductive context_cost_equiv : list nat -> list nat -> Prop :=
| context_cost_equiv_base : context_cost_equiv nil nil
| context_cost_equiv_cons {h l r} : context_cost_equiv l r ->
  context_cost_equiv (h :: l) (h :: r)
(* cases for unequal numbers of 0 at end *)
| context_cost_equiv_nil_l {l} : context_cost_equiv l nil ->
  context_cost_equiv (0 :: l) nil
| context_cost_equiv_nil_r {r} : context_cost_equiv nil r ->
  context_cost_equiv nil (0 :: r).

Instance context_cost_equiv_equiv : Equivalence context_cost_equiv.
Proof.
constructor.
+ intro l; induction l; auto using context_cost_equiv.
+ intros l1 l2 H; induction H; auto using context_cost_equiv.
+ intros l1 l2 l3 H0 H1; revert l3 H1; induction H0; inversion 1; subst;
  auto using context_cost_equiv.
Qed.

Instance context_cost_cons_equiv_proper :
  Proper (eq ==> context_cost_equiv ==> context_cost_equiv) (@cons nat).
Proof.
intros m n [] l1 l2 ?; auto using context_cost_equiv_cons.
Qed.

(* reverse lexical ordering *)
Inductive context_cost_lt : list nat -> list nat -> Prop :=
| context_cost_lt_later {h h' t t'} :
  context_cost_lt t t' -> context_cost_lt (h :: t) (h' :: t')
| context_cost_lt_here {h h' t t'} :
  h < h' -> context_cost_equiv t t' -> context_cost_lt (h :: t) (h' :: t')
| context_cost_lt_nil_here {h t} :
  0 < h -> context_cost_lt nil (h :: t)
| context_cost_lt_nil_later {h t} :
  context_cost_lt nil t -> context_cost_lt nil (h :: t).

Instance context_cost_cons_lt_proper :
  Proper (eq ==> context_cost_lt ++> context_cost_lt) (@cons nat).
Proof.
intros m n [] l1 l2 ?; auto using context_cost_lt_later.
Qed.

Require Import Arith.

Lemma context_cost_nil_le :
  forall l, context_cost_equiv nil l \/ context_cost_lt nil l.
Proof.
induction l; auto using context_cost_equiv, context_cost_lt.
destruct IHl.
+ destruct a; auto using context_cost_equiv, context_cost_lt with arith.
+ right. auto using context_cost_lt.
Qed.

Instance context_cost_equiv_lt_proper :
  Proper (context_cost_equiv ==> context_cost_equiv ==> iff) context_cost_lt.
Proof.
cut (Proper (context_cost_equiv ==> context_cost_equiv ==> Basics.impl)
  context_cost_lt).
+ intros Himpl l l' H l0 l0' H0; split.
  - exact (Himpl l l' H l0 l0' H0).
  - symmetry in H, H0. exact (Himpl l' l H l0' l0 H0).
+ intros l l' H; induction H; intros l0 l0' H0; induction H0;
  unfold Basics.impl; inversion 1; subst; auto using context_cost_lt.
  all: try match goal with
  | H : _ < 0 |- _ => contradict H; auto with arith
  end.
  - apply context_cost_lt_later. eapply IHcontext_cost_equiv; eauto.
  - apply context_cost_lt_here; trivial.
    rewrite <- H. rewrite <- H0. assumption.
  - eapply IHcontext_cost_equiv in H3; eauto. inversion H3.
  - apply context_cost_lt_nil_later. eapply IHcontext_cost_equiv; eauto.
  - eapply IHcontext_cost_equiv in H3; eauto.
  - destruct (context_cost_nil_le r0).
    * apply context_cost_lt_here; trivial.
      rewrite <- H. assumption.
    * apply context_cost_lt_later.
      eapply IHcontext_cost_equiv in H2; eauto. reflexivity.
  - apply context_cost_lt_later. eapply IHcontext_cost_equiv; eauto.
Qed.

Instance context_cost_lt_trans : Transitive context_cost_lt.
Proof.
intros l1 l2 l3 H0 H1; revert l3 H1; induction H0; inversion 1; subst;
auto using context_cost_lt.
+ apply context_cost_lt_later. rewrite <- H5. assumption.
+ apply context_cost_lt_later. rewrite H0. assumption.
+ apply context_cost_lt_here; eauto with arith.
  etransitivity; eauto.
+ apply context_cost_lt_nil_later. clear H1.
  induction H4; auto using context_cost_lt.
  apply context_cost_lt_nil_here. eauto with arith.
+ apply context_cost_lt_nil_here. eauto with arith.
+ apply context_cost_lt_nil_later. rewrite <- H5. assumption.
Qed.

Proposition context_cost_lt_wf : well_founded context_cost_lt.
Proof.
intro l; induction l.
+ constructor. inversion 1.
+ revert a; induction IHl; intro a. induction (lt_wf a). constructor.
  inversion 1; subst; eauto.
  - pose proof (H2 _ H7). constructor. intros. rewrite H8 in H5.
    exact (Acc_inv H4 H5).
  - constructor; inversion 1.
Qed.

Instance add_cost_to_list_proper :
  Proper (eq ==> context_cost_equiv ==> context_cost_equiv)
  add_cost_to_list.
Proof.
intros m n [] l1 l2 ?. clear n. revert l1 l2 H; induction m; intros.
+ destruct H; simpl.
  - reflexivity.
  - f_equiv. assumption.
  - f_equiv. assumption.
  - f_equiv. assumption.
+ destruct H; simpl.
  - reflexivity.
  - f_equiv; auto.
  - f_equiv; auto.
  - f_equiv; auto.
Qed.

Instance add_cost_to_list_incr :
  Proper (eq ==> context_cost_lt ++> context_cost_lt)
  add_cost_to_list.
Proof.
intros m n [] l1 l2 ?. clear n. revert l1 l2 H; induction m; intros.
+ destruct H; simpl; auto using context_cost_lt with arith.
  - destruct (context_cost_nil_le t); auto using context_cost_lt with arith.
+ destruct H; simpl; auto using context_cost_lt with arith.
  - apply context_cost_lt_here; trivial. repeat f_equiv; assumption.
  - destruct (context_cost_nil_le t); auto using context_cost_lt with arith.
    apply context_cost_lt_here; trivial. repeat f_equiv; assumption.
Qed.

Lemma add_cost_to_list_lt :
  forall n l, context_cost_lt l (add_cost_to_list n l).
Proof.
induction n; destruct l; simpl; auto using context_cost_lt with arith.
apply context_cost_lt_here.
+ constructor.
+ reflexivity.
Qed.

Fixpoint nth_tail (n:nat) (l:list nat) : list nat :=
match n with
| 0 => l
| S m => match l with
         | nil => nil
         | _ :: l' => nth_tail m l'
         end
end.

Lemma nth_tail_nil : forall n, nth_tail n nil = nil.
Proof.
induction n; simpl; trivial.
Qed.

Lemma nth_tail_lt : forall n l l',
  context_cost_lt (nth_tail n l) (nth_tail n l') ->
  context_cost_lt l l'.
Proof.
induction n.
+ simpl; trivial.
+ destruct l, l'; simpl; auto using context_cost_lt.
  - intros. apply IHn. rewrite nth_tail_nil. clear IHn. revert n0 l' H. induction n.
    * intros. simpl in H |-*. auto using context_cost_lt.
    * intros. simpl. destruct l'; simpl in H; auto using context_cost_lt.
      inversion H.
  - inversion 1.
Qed.

Lemma nth_tail_add_cost_ge : forall n m l,
  m >= n -> context_cost_lt (nth_tail n l) (nth_tail n (add_cost_to_list m l)).
Proof.
induction n.
+ simpl. intros. apply add_cost_to_list_lt.
+ destruct l; intros; destruct m; try match goal with
  | H : 0 >= S _ |- _ => contradict H; unfold not; inversion 1
  end; simpl; auto with arith.
  rewrite <- (nth_tail_nil n) at 1. auto with arith.
Qed.

Lemma nth_tail_add_cost_lt : forall n m l,
  m < n -> nth_tail n l = nth_tail n (add_cost_to_list m l).
Proof.
intros. revert n l H; induction m; intros.
+ destruct n; try (inversion H; fail). destruct l; simpl.
  - rewrite nth_tail_nil; reflexivity.
  - reflexivity.
+ destruct n; try (inversion H; fail). destruct l; simpl.
  - rewrite <- (nth_tail_nil n) at 1. auto with arith.
  - auto with arith.
Qed.

Lemma add_cost_to_list_comm : forall n m l,
  add_cost_to_list n (add_cost_to_list m l) =
  add_cost_to_list m (add_cost_to_list n l).
Proof.
induction n; destruct m, l; simpl; f_equal; auto.
Qed.

Lemma remove_context_cost : forall Γ Γ' P, remove P Γ Γ' ->
  context_cost Γ = add_cost_to_list (prop_cost P) (context_cost Γ').
Proof.
induction 1.
+ reflexivity.
+ simpl. rewrite IHremove. apply add_cost_to_list_comm.
Qed.

Proposition reduce_context_cost_lt : forall Γ Γ' Γ'' P, remove P Γ Γ' ->
  (forall Q, In Q Γ'' -> prop_cost Q < prop_cost P) ->
  context_cost_lt (context_cost (Γ'' ++ Γ')) (context_cost Γ).
Proof.
intros. rewrite (remove_context_cost _ _ _ H).
apply nth_tail_lt with (n := prop_cost P).
assert (context_cost_equiv (nth_tail (prop_cost P) (context_cost (Γ'' ++ Γ')))
  (nth_tail (prop_cost P) (context_cost Γ'))).
+ clear Γ H. induction Γ''.
  - reflexivity.
  - simpl. rewrite <- nth_tail_add_cost_lt.
    * apply IHΓ''. intros. apply H0. right; assumption.
    * apply H0. prove_In.
+ rewrite H1. apply nth_tail_add_cost_ge. constructor.
Qed.

Instance add_cost_to_list_incr_l :
  Proper (lt ++> context_cost_equiv ==> context_cost_lt) add_cost_to_list.
Proof.
intros m n ? l1 l2 ?. rewrite H0. clear l1 H0.
revert n H l2; induction m; destruct n, l2; intros; simpl;
try match goal with
| H : _ < 0 |- _ => inversion H
end.
+ apply context_cost_lt_later. apply add_cost_to_list_lt.
+ apply context_cost_lt_later. apply add_cost_to_list_lt.
+ apply context_cost_lt_later. apply IHm. auto with arith.
+ apply context_cost_lt_later. apply IHm. auto with arith.
Qed.

(* Now, for a series of results that each subgoal in an LJT* rule
   reduces the cost *)
Lemma context_cost_lt_cons_l {Γ P Q} :
  prop_cost P < prop_cost Q ->
  context_cost_lt (context_cost (P :: Γ)) (context_cost (Q :: Γ)).
Proof.
intros. simpl. apply add_cost_to_list_incr_l; trivial. reflexivity.
Qed.

Lemma context_cost_lt_cons_r {Γ Γ' P} :
  context_cost_lt (context_cost Γ) (context_cost Γ') ->
  context_cost_lt (context_cost (P :: Γ)) (context_cost (P :: Γ')).
Proof.
intros. simpl. apply add_cost_to_list_incr; trivial.
Qed.

Proposition LJTstar_and_intro_cost1 {Γ P Q} :
  context_cost_lt (context_cost (P :: Γ)) (context_cost (P ∧ Q :: Γ)).
Proof.
apply context_cost_lt_cons_l. simpl. eauto with arith.
Qed.

Proposition LJTstar_and_intro_cost2 {Γ P Q} :
  context_cost_lt (context_cost (Q :: Γ)) (context_cost (P ∧ Q :: Γ)).
Proof.
apply context_cost_lt_cons_l. simpl. eauto with arith.
Qed.

Proposition LJTstar_and_elim_cost {Γ P Q R Γ'} :
  remove (P ∧ Q) Γ Γ' ->
  context_cost_lt (context_cost (R :: P :: Q :: Γ'))
    (context_cost (R :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := P :: Q :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_or_introl_cost {Γ P Q} :
  context_cost_lt (context_cost (P :: Γ))
    (context_cost (P ∨ Q :: Γ)).
Proof.
apply context_cost_lt_cons_l. simpl; eauto with arith.
Qed.

Proposition LJTstar_or_intror_cost {Γ P Q} :
  context_cost_lt (context_cost (Q :: Γ))
    (context_cost (P ∨ Q :: Γ)).
Proof.
apply context_cost_lt_cons_l. simpl; eauto with arith.
Qed.

Proposition LJTstar_or_elim_cost1 {Γ P Q R Γ'} :
  remove (P ∨ Q) Γ Γ' -> context_cost_lt
    (context_cost (R :: P :: Γ'))
    (context_cost (R :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := P :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_or_elim_cost2 {Γ P Q R Γ'} :
  remove (P ∨ Q) Γ Γ' -> context_cost_lt
    (context_cost (R :: Q :: Γ'))
    (context_cost (R :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := Q :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_impl_intro_cost {Γ P Q} :
  context_cost_lt (context_cost (Q :: P :: Γ))
    (context_cost (P ⊃ Q :: Γ)).
Proof.
assert (remove (P ⊃ Q) (P ⊃ Q :: Γ) Γ) by eauto using remove.
apply reduce_context_cost_lt with (1 := H) (Γ'' := Q :: P :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_impl_assump_elim_cost {Γ P Q R Γ'} :
  remove (P ⊃ Q) Γ Γ' -> context_cost_lt
    (context_cost (R :: Q :: Γ'))
    (context_cost (R :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := Q :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_red_top_impl_cost {Γ P Q Γ'} :
  remove (⊤ ⊃ P) Γ Γ' -> context_cost_lt
    (context_cost (Q :: P :: Γ'))
    (context_cost (Q :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := P :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_red_and_impl_cost {Γ P Q R S Γ'} :
  remove (P ∧ Q ⊃ R) Γ Γ' -> context_cost_lt
    (context_cost (S :: P ⊃ Q ⊃ R :: Γ'))
    (context_cost (S :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := P ⊃ Q ⊃ R :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl. repeat rewrite <- plus_n_Sm. rewrite plus_assoc. eauto with arith.
Qed.

Proposition LJTstar_red_or_impl_cost {Γ P Q R S Γ'} :
  remove (P ∨ Q ⊃ R) Γ Γ' -> context_cost_lt
    (context_cost (S :: P ⊃ R :: Q ⊃ R :: Γ'))
    (context_cost (S :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := P ⊃ R :: Q ⊃ R :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_impl_impl_elim_cost1 {Γ P Q R S Γ'} :
  remove ((P ⊃ Q) ⊃ R) Γ Γ' -> context_cost_lt
    (context_cost (Q :: P :: Q ⊃ R :: Γ'))
    (context_cost (S :: Γ)).
Proof.
intros. simpl context_cost at 2. rewrite <- add_cost_to_list_lt.
apply reduce_context_cost_lt with (1 := H) (Γ'' := Q :: P :: Q ⊃ R :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Proposition LJTstar_impl_impl_elim_cost2 {Γ P Q R S Γ'} :
  remove ((P ⊃ Q) ⊃ R) Γ Γ' -> context_cost_lt
    (context_cost (S :: R :: Γ'))
    (context_cost (S :: Γ)).
Proof.
intros. apply context_cost_lt_cons_r.
apply reduce_context_cost_lt with (1 := H) (Γ'' := R :: nil).
intros; repeat match goal with
| H : In _ (_ :: _) |- _ => destruct H; subst
| H : In _ nil |- _ => destruct H
end; simpl; eauto with arith.
Qed.

Theorem LJTstar_completeness :
  forall Γ P, Γ ⊢ P -> Γ ⇒* P.
Proof.
intros. rewrite ND_SC_equiv in H.
pose proof (context_cost_lt_wf (context_cost (P :: Γ))).
remember (context_cost (P :: Γ)) as c. revert Γ P H Heqc.
induction H0. intros. subst.
pose proof (fun Γ' P' H2 H3 => H0 (context_cost (P' :: Γ')) H2 Γ' P' H3 eq_refl).
clear H H0.
destruct H1.
+ apply LJTstar_init. assumption.
+ apply LJTstar_bot_elim. assumption.
+ apply LJTstar_top_intro.
+ apply LJTstar_and_intro.
  - apply H2; trivial. apply LJTstar_and_intro_cost1.
  - apply H2; trivial. apply LJTstar_and_intro_cost2.
+ rewrite In_ex_remove in H. destruct H as [Γ'].
  apply (LJTstar_and_elim H). apply H2.
  - eauto using LJTstar_and_elim_cost.
  - apply @SC_admits_cut with (P := P ∧ Q).
    * apply SC_and_intro; apply SC_init; prove_In.
    * rewrite (remove_subcontext_rev _ _ _ H) in H1.
      refine (SC_context_extension _ _ _ _ _ eq_refl H1).
      prove_subcontext.
+ apply LJTstar_or_introl. apply H2; trivial. apply LJTstar_or_introl_cost.
+ apply LJTstar_or_intror. apply H2; trivial. apply LJTstar_or_intror_cost.
+ rewrite In_ex_remove in H. destruct H as [Γ'].
  apply (LJTstar_or_elim H); apply H2.
  - eauto using LJTstar_or_elim_cost1.
  - apply @SC_admits_cut with (P := P ∨ Q).
    * apply SC_or_introl; apply SC_init; prove_In.
    * rewrite (remove_subcontext_rev _ _ _ H) in H1_.
      refine (SC_context_extension _ _ _ _ _ eq_refl H1_).
      prove_subcontext.
  - eauto using LJTstar_or_elim_cost2.
  - apply @SC_admits_cut with (P := P ∨ Q).
    * apply SC_or_intror; apply SC_init; prove_In.
    * rewrite (remove_subcontext_rev _ _ _ H) in H1_0.
      refine (SC_context_extension _ _ _ _ _ eq_refl H1_0).
      prove_subcontext.
+ apply LJTstar_impl_intro. apply H2; trivial.
  apply LJTstar_impl_intro_cost.
+ revert Q R H H1_0 H2; induction H1_; intros Q0 R0 H' H1_0' H2;
  rewrite In_ex_remove in H'; destruct H' as [Γ'].
  - apply (LJTstar_impl_assump_elim H0).
    * pose proof (remove_subcontext_rev _ _ _ H0). apply H1 in H.
      destruct H; trivial. contradict H.
      clear H0 H1_0' H1; revert Q0; induction P; try discriminate.
      unfold not; injection 1; intros. contradiction (IHP1 P2).
    * apply H2.
      { eauto using LJTstar_impl_assump_elim_cost. }
      { apply @SC_admits_cut with (P := P ⊃ Q0).
        + apply SC_impl_intro. apply SC_init; prove_In.
        + rewrite (remove_subcontext_rev _ _ _ H0) in H1_0'.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
          prove_subcontext. }
  - apply LJTstar_bot_elim; assumption.
  - apply (LJTstar_red_top_impl H). apply H2.
    * eauto using LJTstar_red_top_impl_cost.
    * apply @SC_admits_cut with (P := ⊤ ⊃ Q0).
      { apply SC_impl_intro; apply SC_init; prove_In. }
      { rewrite (remove_subcontext_rev _ _ _ H) in H1_0'.
        refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
        prove_subcontext. }
  - apply (LJTstar_red_and_impl H). apply H2.
    * eauto using LJTstar_red_and_impl_cost.
    * apply @SC_admits_cut with (P := P ∧ Q ⊃ Q0).
      { apply SC_impl_intro.
        apply @SC_and_elim with (P := P) (Q := Q); try prove_In.
        apply @SC_impl_elim with (P := P) (Q := Q ⊃ Q0); try prove_In.
        + apply SC_init; prove_In.
        + apply @SC_impl_elim with (P := Q) (Q := Q0); try prove_In.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In. }
      { assert (Γ ⇒ R0).
        + apply @SC_impl_elim with (P := P ∧ Q) (Q := Q0).
          - apply (remove_subcontext _ _ _ H). prove_In.
          - apply SC_and_intro; assumption.
          - assumption.
        + rewrite (remove_subcontext_rev _ _ _ H) in H0.
          refine (SC_context_extension _ _ _ _ _ eq_refl H0).
          prove_subcontext.
      }
  - rewrite In_ex_remove in H. destruct H as [Γ''].
    apply (LJTstar_and_elim H). apply H2.
    * eauto using LJTstar_and_elim_cost.
    * apply @SC_admits_cut with (P := R).
      { apply @SC_admits_cut with (P := P ∧ Q).
        + apply SC_and_intro; apply SC_init; prove_In.
        + rewrite (remove_subcontext_rev _ _ _ H) in H1_.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_).
          prove_subcontext. }
      { apply @SC_admits_cut with (P := Q0).
        + apply @SC_impl_elim with (P := R) (Q := Q0).
          - apply remove_In in H0. apply remove_subcontext_rev in H.
            apply H in H0. destruct H0; try discriminate.
            do 3 right; assumption.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In.
        + apply @SC_admits_cut with (P := P ∧ Q).
          - apply SC_and_intro; apply SC_init; prove_In.
          - rewrite (remove_subcontext_rev _ _ _ H) in H1_0'.
            refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
            prove_subcontext. }
  - apply (LJTstar_red_or_impl H). apply H2.
    * eauto using LJTstar_red_or_impl_cost.
    * apply @SC_admits_cut with (P := P ∨ Q ⊃ Q0).
      { apply SC_impl_intro.
        apply @SC_or_elim with (P := P) (Q := Q); try prove_In.
        + apply @SC_impl_elim with (P := P) (Q := Q0); try prove_In.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In.
        + apply @SC_impl_elim with (P := Q) (Q := Q0); try prove_In.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In. }
      { assert (Γ ⇒ R0).
        + apply @SC_impl_elim with (P := P ∨ Q) (Q := Q0).
          - apply (remove_subcontext _ _ _ H). prove_In.
          - apply SC_or_introl; assumption.
          - assumption.
        + rewrite (remove_subcontext_rev _ _ _ H) in H0.
          refine (SC_context_extension _ _ _ _ _ eq_refl H0).
          prove_subcontext. }
  - apply (LJTstar_red_or_impl H). apply H2.
    * eauto using LJTstar_red_or_impl_cost.
    * apply @SC_admits_cut with (P := P ∨ Q ⊃ Q0).
      { apply SC_impl_intro.
        apply @SC_or_elim with (P := P) (Q := Q); try prove_In.
        + apply @SC_impl_elim with (P := P) (Q := Q0); try prove_In.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In.
        + apply @SC_impl_elim with (P := Q) (Q := Q0); try prove_In.
          - apply SC_init; prove_In.
          - apply SC_init; prove_In. }
      { assert (Γ ⇒ R0).
        + apply @SC_impl_elim with (P := P ∨ Q) (Q := Q0).
          - apply (remove_subcontext _ _ _ H). prove_In.
          - apply SC_or_intror; assumption.
          - assumption.
        + rewrite (remove_subcontext_rev _ _ _ H) in H0.
          refine (SC_context_extension _ _ _ _ _ eq_refl H0).
          prove_subcontext. }
  - rewrite In_ex_remove in H. destruct H as [Γ''].
    apply (LJTstar_or_elim H); apply H2.
    * eauto using LJTstar_or_elim_cost1.
    * apply @SC_admits_cut with (P := R).
      { apply @SC_admits_cut with (P := P ∨ Q).
        + apply SC_or_introl; apply SC_init; prove_In.
        + rewrite (remove_subcontext_rev _ _ _ H) in H1_1.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_1).
          prove_subcontext. }
      { apply @SC_impl_elim with (P := R) (Q := Q0).
        + right; right. apply remove_In in H0.
          apply (remove_subcontext_rev _ _ _ H) in H0.
          destruct H0; try discriminate. assumption.
        + apply SC_init; prove_In.
        + apply @SC_admits_cut with (P := P ∨ Q).
          - apply SC_or_introl. apply SC_init; prove_In.
          - rewrite (remove_subcontext_rev _ _ _ H) in H1_0'.
            refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
            prove_subcontext. }
    * eauto using LJTstar_or_elim_cost2.
    * apply @SC_admits_cut with (P := R).
      { apply @SC_admits_cut with (P := P ∨ Q).
        + apply SC_or_intror; apply SC_init; prove_In.
        + rewrite (remove_subcontext_rev _ _ _ H) in H1_2.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_2).
          prove_subcontext. }
      { apply @SC_impl_elim with (P := R) (Q := Q0).
        + right; right. apply remove_In in H0.
          apply (remove_subcontext_rev _ _ _ H) in H0.
          destruct H0; try discriminate. assumption.
        + apply SC_init; prove_In.
        + apply @SC_admits_cut with (P := P ∨ Q).
          - apply SC_or_intror. apply SC_init; prove_In.
          - rewrite (remove_subcontext_rev _ _ _ H) in H1_0'.
            refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
            prove_subcontext. }
  - apply (LJTstar_impl_impl_elim H).
    * apply H2.
      { eauto using LJTstar_impl_impl_elim_cost1. }
      { apply @SC_admits_cut with (P := (P ⊃ Q) ⊃ Q0).
        + apply SC_impl_intro.
          apply @SC_impl_elim with (P := P) (Q := Q);
          try (prove_In || apply SC_init; prove_In).
          apply @SC_impl_elim with (P := Q) (Q := Q0);
          (prove_In || apply SC_init; prove_In).
        + rewrite (remove_subcontext_rev _ _ _ H) in H1_.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_).
          prove_subcontext. }
    * apply H2.
      { eauto using LJTstar_impl_impl_elim_cost2. }
      { apply @SC_admits_cut with (P := (P ⊃ Q) ⊃ Q0).
        + apply SC_impl_intro. apply SC_init; prove_In.
        + rewrite (remove_subcontext_rev _ _ _ H) in H1_0'.
          refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
          prove_subcontext. }
  - eapply IHH1_1; eauto. apply @SC_admits_cut with (P := R).
    * assumption.
    * pose proof (remove_In _ _ _ H0).
      apply @SC_impl_elim with (P := R) (Q := Q0).
      { right; right; assumption. }
      { apply SC_init; prove_In. }
      { refine (SC_context_extension _ _ _ _ _ eq_refl H1_0').
        prove_subcontext. }
Qed.

Theorem ND_LJTstar_equiv : forall Γ P,
  Γ ⊢ P <-> Γ ⇒* P.
Proof.
split; [ apply LJTstar_completeness | apply LJTstar_soundness ].
Qed.

End LJTstar.


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

Require Import ZArith_base.
Require Import Zpow_def.
Require Import BinInt.
Require Import BinNat.
Require Import Ndiv_def Zdiv_def.
Require Import Setoid.
Require Export Ring2.
Require Export Ring2_polynom.
Import List.

Set Implicit Arguments.

(* An object to return when an expression is not recognized as a constant *)
Definition NotConstant := false.

(** Z is a ring and a setoid*)

Lemma Zsth : Setoid_Theory Z (@eq Z).
constructor;red;intros;subst;trivial.
Qed.

Definition Zr : Ring Z.
apply (@Build_Ring Z Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z));
try apply Zsth; try (red; red; intros; rewrite H; reflexivity).
 exact Zplus_comm. exact Zplus_assoc.
 exact Zmult_1_l.  exact Zmult_1_r. exact Zmult_assoc.
 exact Zmult_plus_distr_l.  intros; apply Zmult_plus_distr_r. trivial. exact Zminus_diag.
Defined.

(** Two generic morphisms from Z to (abrbitrary) rings, *)
(**second one is more convenient for proofs but they are ext. equal*)
Section ZMORPHISM.
 Variable R : Type.
 Variable Rr: Ring R.
Existing Instance Rr.

 Ltac rrefl := gen_reflexivity Rr.

(*
Print HintDb typeclass_instances.
Print Scopes.
*)

 Fixpoint gen_phiPOS1 (p:positive) : R :=
  match p with
  | xH => 1
  | xO p => (1 + 1) * (gen_phiPOS1 p)
  | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p))
  end.

 Fixpoint gen_phiPOS (p:positive) : R :=
  match p with
  | xH => 1
  | xO xH => (1 + 1)
  | xO p => (1 + 1) * (gen_phiPOS p)
  | xI xH => 1 + (1 +1)
  | xI p => 1 + ((1 + 1) * (gen_phiPOS p))
  end.

 Definition gen_phiZ1 z :=
  match z with
  | Zpos p => gen_phiPOS1 p
  | Z0 => 0
  | Zneg p => -(gen_phiPOS1 p)
  end.

 Definition gen_phiZ z :=
  match z with
  | Zpos p => gen_phiPOS p
  | Z0 => 0
  | Zneg p => -(gen_phiPOS p)
  end.
 Notation "[ x ]" := (gen_phiZ x).

 Definition get_signZ z :=
  match z with
  | Zneg p => Some (Zpos p)
  | _ => None
  end.

   Ltac norm := gen_ring_rewrite.
   Ltac add_push :=  gen_add_push.
Ltac rsimpl := simpl;  set_ring_notations.

 Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
 Proof.
  induction x;rsimpl.
  ring_rewrite IHx. destruct x;simpl;norm.
  ring_rewrite IHx;destruct x;simpl;norm.
  gen_reflexivity.
 Qed.

 Lemma ARgen_phiPOS_Psucc : forall x,
   gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
 Proof.
  induction x;rsimpl;norm.
  ring_rewrite IHx ;norm.
  add_push 1;gen_reflexivity.
 Qed.

 Lemma ARgen_phiPOS_add : forall x y,
   gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y).
 Proof.
  induction x;destruct y;simpl;norm.
  ring_rewrite Pplus_carry_spec.
  ring_rewrite ARgen_phiPOS_Psucc.
  ring_rewrite IHx;norm.
  add_push (gen_phiPOS1 y);add_push 1;gen_reflexivity.
  ring_rewrite IHx;norm;add_push (gen_phiPOS1 y);gen_reflexivity.
  ring_rewrite ARgen_phiPOS_Psucc;norm;add_push 1;gen_reflexivity.
  ring_rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;gen_reflexivity.
  ring_rewrite IHx;norm;add_push(gen_phiPOS1 y);gen_reflexivity.
  add_push 1;gen_reflexivity.
  ring_rewrite ARgen_phiPOS_Psucc;norm;add_push 1;gen_reflexivity.
 Qed.

 Lemma ARgen_phiPOS_mult :
   forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y.
 Proof.
  induction x;intros;simpl;norm.
  ring_rewrite ARgen_phiPOS_add;simpl;ring_rewrite IHx;norm.
  ring_rewrite IHx;gen_reflexivity.
 Qed.

(*morphisms are extensionaly equal*)
 Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
 Proof.
  destruct x;rsimpl; try ring_rewrite same_gen; gen_reflexivity.
 Qed.

 Lemma gen_Zeqb_ok : forall x y,
   Zeq_bool x y = true -> [x] == [y].
 Proof.
  intros x y H.
  assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1.
  ring_rewrite H1;gen_reflexivity.
 Qed.

 Lemma gen_phiZ1_add_pos_neg : forall x y,
 gen_phiZ1
    match (x ?= y)%positive Eq with
    | Eq => Z0
    | Lt => Zneg (y - x)
    | Gt => Zpos (x - y)
    end
 == gen_phiPOS1 x + -gen_phiPOS1 y.
 Proof.
  intros x y.
  assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y).
  generalize (Pminus_mask_Gt y x).
  replace Eq with (CompOpp Eq);[intro H1;simpl|trivial].
  rewrite <- Pcompare_antisym in H1.
  destruct ((x ?= y)%positive Eq).
  ring_rewrite H;trivial. ring_rewrite ring_opp_def;gen_reflexivity.
  destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial.
  unfold Pminus; ring_rewrite Heq1;rewrite <- Heq2.
  ring_rewrite ARgen_phiPOS_add;simpl;norm.
  ring_rewrite ring_opp_def;norm.
  destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial.
  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
  ring_rewrite ARgen_phiPOS_add;simpl;norm.
  set_ring_notations. add_push (gen_phiPOS1 h). ring_rewrite ring_opp_def ; norm.
 Qed.

 Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
  match CompOpp x with Eq => be | Lt => bl | Gt => bg end
  = match x with Eq => be | Lt => bg | Gt => bl end.
 Proof. destruct x;simpl;intros;trivial. Qed.

 Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
 Proof.
  intros x y; repeat ring_rewrite same_genZ; generalize x y;clear x y.
  induction x;destruct y;simpl;norm.
  apply ARgen_phiPOS_add.
  apply gen_phiZ1_add_pos_neg.
  replace Eq with (CompOpp Eq);trivial.
  rewrite <- Pcompare_antisym;simpl.
  ring_rewrite match_compOpp.
  ring_rewrite ring_add_comm.
  apply gen_phiZ1_add_pos_neg.
  ring_rewrite ARgen_phiPOS_add; norm.
 Qed.

Lemma gen_phiZ_opp : forall x, [- x] == - [x].
 Proof.
  intros x. repeat ring_rewrite same_genZ. generalize x ;clear x.
  induction x;simpl;norm.
  ring_rewrite ring_opp_opp.  gen_reflexivity.
 Qed.

 Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y].
 Proof.
  intros x y;repeat ring_rewrite same_genZ.
  destruct x;destruct y;simpl;norm;
  ring_rewrite  ARgen_phiPOS_mult;try (norm;fail).
  ring_rewrite ring_opp_opp ;gen_reflexivity.
 Qed.

 Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
 Proof. intros;subst;gen_reflexivity. Qed.

(*proof that [.] satisfies morphism specifications*)
 Lemma gen_phiZ_morph : @Ring_morphism Z R Zr Rr.
 apply (Build_Ring_morphism Zr Rr gen_phiZ);simpl;try gen_reflexivity.
   apply gen_phiZ_add. intros. ring_rewrite ring_sub_def.
replace (x-y)%Z with (x + (-y))%Z. ring_rewrite gen_phiZ_add.
ring_rewrite gen_phiZ_opp. gen_reflexivity.
reflexivity.
 apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext.
 Defined.

End ZMORPHISM.


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

(** Library for manipulating integers based on binary encoding.
    These are the basic modules, required by [Omega] and [Ring] for instance.
    The full library is [ZArith]. *)

Require Export BinPos.
Require Export BinNat.
Require Export BinInt.
Require Export Zcompare.
Require Export Zorder.
Require Export Zeven.
Require Export Zminmax.
Require Export Zmin.
Require Export Zmax.
Require Export Zabs.
Require Export Znat.
Require Export auxiliary.
Require Export ZArith_dec.
Require Export Zbool.
Require Export Zmisc.
Require Export Wf_Z.

Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
  Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
  Zmult_plus_distr_r: zarith.

Require Export Zhints.


Require Export List.

Inductive ltree (A : Type) : Type :=
  lnode: A -> list (ltree A) ->  ltree A .

Section define_iter_list.
Variables (A B : Type) (f : A ->  B) (op : B -> B ->  B) (e : B).

Fixpoint iter_list (l : list A) : B :=
 match l with   nil => e
               | a :: tl => op (f a) (iter_list tl) end.

End define_iter_list.
Implicit Arguments iter_list.

(* It is hard to explain, but if we define iter_list outside a section
  then the following definition is not accepted. *)

Fixpoint lcount (A : Type) (t : ltree A) {struct t} : nat :=
 match t with lnode _ a l => iter_list (lcount A) plus 1 l end.

(* Here is an alternative definition of iter_list that cannot
   be used to define lcount by replacing iter_list with iter_list'.
   It is a well-known property of guarded definitions for structural
   recursion that objects with the same type cannot be interchanged.
   Here the function cannot be used because recursive calls to
   iter_list' contain instances of f that are not applied to arguments.
   It is thus impossible to check whether these instances satisfy a
   structural guard condition. *)

Fixpoint iter_list' (A B : Type) (f : A ->  B) (op : B -> B ->  B) (e : B)
                    (l : list A) {struct l} : B :=
 match l with
   nil => e
  | a :: tl => op (f a) (iter_list' A B f op e tl)
 end.
Implicit Arguments iter_list'.


Require Import HoTT.

Require Import Syntax.All.
Require Import Typing.All.
Require Import Metatheorem.UniqueTyping.
Require Import Metatheorem.Elimination.
Require Import Metatheorem.Presuppositions.

Definition acceptable {σ} {Σ : signature σ} (T : raw_type_theory Σ)
  : Type
:= (is_tight_type_theory T)
  * (substitutive T)
  * (congruous T)
  * (presuppositive_raw_type_theory T).


Require Import Coq.Arith.Arith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Bool.Bool.
Require Import Coq.micromega.Lia.
Require Import Coq.Numbers.Cyclic.Int63.Sint63.
Require Import Coq.Lists.List.
Require Import Coq.Program.Program.

Import ListNotations.

Local Open Scope sint63_scope.

Definition steps := Eval vm_compute in 2 ^ 44 : N.
Definition sint_max := Eval vm_compute in 1 << 62 - 1.

Definition asr a := let b := if (get_digit a 62) then 1 << 62 else 0 in Int63.lor (lsr a 1) b.
Definition int_min a b := if a <? b then a else b.

Definition divstep_int (d f g : int) :=
  if (get_digit (opp d) 62) && (negb (is_even g))
  then (1 - d, g, asr (g - f))
  else (1 + d, f, asr (g + (g land 1) * f)).

Fixpoint needs_n_steps_int (d a b : int) n :=
  match n with
  | 0%nat => true
  | S n => if (b =? 0)
          then false
          else let '(d', a', b') := divstep_int d a b in needs_n_steps_int d' a' b' n
  end.

Program Fixpoint min_needs_n_steps_nat_int (a b : int) n (acc : int) fuel {measure fuel (N.lt)} :=
  match fuel with
  | 0%N => 1 << 61
  | _ =>  if (leb acc (mul a a))
              then acc
              else if (leb acc (add (mul a a) (mul b b)))
                   then min_needs_n_steps_nat_int (a + 2) 0 n acc (N.pred fuel)
                   else if needs_n_steps_int 1 a (b >> 1) n || needs_n_steps_int 1 a (opp (b >> 1)) n
                        then min_needs_n_steps_nat_int (a + 2) 0 n (int_min (a * a + b * b) acc) (N.pred fuel)
                        else min_needs_n_steps_nat_int a (b + 2) n acc (N.pred fuel)
  end.

Solve Obligations with try lia.
Next Obligation. exact (Acc_intro_generator (50) ltac:(apply measure_wf; apply N.lt_wf_0)). Defined.

Definition W n := min_needs_n_steps_nat_int 1 0 n sint_max steps.

(** Below is the faster version which combines computations  *)

Fixpoint divsteps_aux steps fuel d a b :=
  match fuel with
  | 0%nat => steps
  | S fuel => if (b =? 0)
             then steps
             else let '(d', a', b') := divstep_int d a b in divsteps_aux (S steps) fuel d' a' b'
  end.

Definition divsteps := divsteps_aux 0 100.

Definition max_list := Eval compute in repeat sint_max 60.

Program Fixpoint table_b (a a2 b : int) (bound : int) (acc : list int) fuel {measure fuel (N.lt)} :=
  match fuel with
  | 0%N => acc
  | _ => let length := a2 + b * b in
        if (leb length bound)
        then
          let steps := divsteps 1 a (b >> 1) in
          let steps_opp := divsteps 1 a (opp (b >> 1)) in
          let n := max steps steps_opp in
          let new_list := (fix aux l i acc2 :=
                             match l with
                             | [] => acc2
                             | a :: l => aux l (S i) (acc2 ++ [(if (length <? a) && (i <=? n)%nat then length else a)])
                             end) acc 0%nat [] in
          table_b a a2 (b + 2) bound new_list (N.pred fuel)
        else
          acc
  end.

Solve Obligations with try lia.
Next Obligation. exact (Acc_intro_generator (50) ltac:(apply measure_wf; apply N.lt_wf_0)). Defined.

Program Fixpoint table_a (a b : int) (bound : int) (acc : list int) fuel_a fuel_b {measure fuel_a (N.lt)} :=
  match fuel_a with
  | 0%N => acc
  | _ =>  let a2 := a * a in
         if (leb a2 bound)
         then
           table_a (a + 2) 0 bound (table_b a a2 b bound acc fuel_b) (N.pred fuel_a) fuel_b
         else
           acc
  end.

Solve Obligations with try lia.
Next Obligation. exact (Acc_intro_generator (50) ltac:(apply measure_wf; apply N.lt_wf_0)). Defined.

Definition table n := table_a 1 0 (1 << n) max_list steps steps.


Require Import InfSeqExt.infseq.
Require Import Classical.

Section sec_classical.

Variable T : Type.

Lemma weak_until_until_or_always :
  forall (J P : infseq T -> Prop) (s : infseq T),
    weak_until J P s -> until J P s \/ always J s.
Proof using.
intros J P s.
case (classic (eventually P s)).
- intros evP wu.
  left.
  induction evP.
  * apply U0. assumption.
  * apply weak_until_Cons in wu.
    case wu.
    + intros PC.
      apply U0. assumption.
    + intros [Js wu'].
      apply U_next; trivial.
      apply IHevP.
      assumption.
- intros evP wu.
  right.
  apply not_eventually_always_not in evP.
  apply weak_until_always_not_always in wu; trivial.
Qed.

Lemma not_until_weak_until :
  forall (J P : infseq T -> Prop) (s : infseq T),
    ~ until J P s -> weak_until (J /\_ ~_ P) (~_ J /\_ ~_ P) s.
Proof using.
intros J P.
cofix c.
intros s.
case (classic (P s)).
- intros Ps un.
  contradict un.
  apply U0.
  assumption.
- intros Ps.
  case (classic (J s)); destruct s as [x s].
  * intros Js un.
    apply W_tl.
    + unfold and_tl, not_tl.
      split; trivial.
    + simpl.
      apply c.
      intros unn.
      contradict un.
      apply U_next; trivial.
  * intros Js un.
    apply W0.
    split; trivial.
Qed.

Lemma not_weak_until_until :
  forall (J P : infseq T -> Prop) (s : infseq T),
    ~ weak_until J P s -> until (J /\_ ~_ P) (~_ J /\_ ~_ P) s.
Proof using.
intros J P s wun.
case (classic (until (J /\_ ~_ P) (~_ J /\_ ~_ P) s)); trivial.
intros un.
contradict wun.
revert s un.
cofix c.
intros s.
case (classic (P s)).
- intros Ps un.
  apply W0.
  assumption.
- intros Ps.
  case (classic (J s)); destruct s as [x s].
  * intros Js un.
    apply W_tl; trivial.
    simpl.
    apply c.
    intros unn.
    contradict un.
    apply U_next; trivial.
    split; trivial.
  * intros Js un.
    contradict un.
    apply U0.
    split; trivial.
Qed.

Lemma not_eventually_not_always :
  forall (P : infseq T -> Prop) (s : infseq T),
  ~ eventually (~_ P) s -> always P s.
Proof using.
intros P.
cofix c.
intro s.
destruct s as [e s].
intros evnP.
apply Always.
- case (classic (P (Cons e s))); trivial.
  intros orP.
  apply (E0 _ (~_ P)) in orP.
  contradict evnP.
  assumption.
- apply c.
  simpl.
  intros evP.
  contradict evnP.
  apply E_next.
  assumption.
Qed.

Lemma not_always_eventually_not :
  forall (P : infseq T -> Prop) (s : infseq T),
  ~ always P s -> eventually (~_ P) s.
Proof using.
intros P s alP.
case (classic ((eventually (~_ P)) s)); trivial.
intros evP.
apply not_eventually_not_always in evP.
contradict alP.
assumption.
Qed.

Lemma not_until_release :
  forall (J P : infseq T -> Prop) (s : infseq T),
  ~ until (~_ J) (~_ P) s -> release J P s.
Proof using.
intros J P.
cofix c.
intros s.
case (classic (J s)).
- intros Js un.
  destruct s as [x s].
  apply R0; trivial.
  case (classic (P (Cons x s))); trivial.
  intros Ps.
  contradict un.
  apply U0.
  apply Ps.
- intros Js un.
  destruct s as [x s].
  apply R_tl.
  * case (classic (P (Cons x s))); trivial.
    intros Ps.
    contradict un.
    apply U0.
    apply Ps.
  * simpl.
    apply c.
    intros unn.
    contradict un.
    apply U_next; trivial.
Qed.

Lemma not_release_until :
  forall (J P : infseq T -> Prop) (s : infseq T),
  ~ release (~_ J) (~_ P) s -> until J P s.
Proof using.
intros J P s rl.
case (classic (until J P s)); trivial.
intros un.
contradict rl.
revert s un.
cofix c.
intros s un.
case (classic (P s)).
- intros Ps.
  contradict un.
  apply U0.
  assumption.
- intros Ps.
  case (classic (J s)).
  * intros Js.
    destruct s as [x s].
    apply R_tl; trivial.
    simpl.
    apply c.
    intros unn.
    contradict un.
    apply U_next; trivial.
  * intros Js.
    destruct s as [x s].
    apply R0; unfold not_tl; assumption.
Qed.

Lemma not_inf_often_continuously_not :
  forall (P : infseq T -> Prop) (s : infseq T),
  ~ inf_often P s -> continuously (~_ P) s.
Proof using.
intros P s ioP.
apply not_always_eventually_not in ioP.
induction ioP.
- apply not_eventually_always_not in H.
  apply E0.
  assumption.
- apply E_next.
  assumption.
Qed.

Lemma not_continously_inf_often_not :
  forall (P : infseq T -> Prop) (s : infseq T),
  ~ continuously P s -> inf_often (~_ P) s.
Proof using.
intros P.
cofix c.
intros [x s] cnyP.
apply Always.
- unfold continuously in cnyP.
  apply not_eventually_always_not in cnyP.
  apply always_now in cnyP.
  unfold not_tl in cnyP.
  apply not_always_eventually_not in cnyP.
  assumption.
- apply c.
  intros cnynP.
  contradict cnyP.
  apply E_next.
  assumption.
Qed.

Lemma not_tl_and_tl_or_tl :
  forall (P Q : infseq T -> Prop) (s : infseq T),
  (~_ (P /\_ Q)) s -> ((~_ P) \/_ (~_ Q)) s.
Proof using.
intros P Q s; unfold not_tl, and_tl, or_tl.
apply not_and_or.
Qed.

End sec_classical.

Arguments weak_until_until_or_always [T J P s] _.
Arguments not_until_weak_until [T J P s] _.
Arguments not_weak_until_until [T J P s] _.
Arguments not_eventually_not_always [T P s] _.
Arguments not_always_eventually_not [T P s] _.
Arguments not_until_release [T J P s] _.
Arguments not_release_until [T J P s] _.
Arguments not_inf_often_continuously_not [T P s] _.
Arguments not_continously_inf_often_not [T P s] _.
Arguments not_tl_and_tl_or_tl [T P Q s] _.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.
Require Import Zdec_complements.
Require Import definition.
Require Import Zabs_complements.
Require Import Tactiques.

Lemma Zabs_ind_bis :
 forall (P : Z -> Z -> Prop) (x y : Z),
 (x = 0%Z /\ y = 0%Z -> P x y) ->
 ((0 < Z.abs x)%Z \/ (0 < Z.abs y)%Z -> P x y) -> P x y.

Proof.
intros.
cut ({x = 0%Z /\ y = 0%Z} + {(0 < Z.abs x)%Z \/ (0 < Z.abs y)%Z}).
intros.
elim H1.
auto.
auto.
apply Zabs_Zle_2.
Qed.

Lemma Zabs_ind_ter :
 forall (P1 : Reelc -> Reelc -> Prop) (P : R -> R -> Reelc -> Reelc -> Prop)
   (x y : R) (xc yc : Reelc),
 (P y x yc xc -> P x y xc yc) ->
 (forall (x y : R) (xc yc : Reelc), P1 xc yc -> P x y xc yc) ->
 P1 xc yc \/ P1 yc xc -> P x y xc yc.

Proof.
intros.
elim H1.
generalize (H0 x y xc yc).
auto.
intro.
apply H.
generalize H2.
generalize (H0 y x yc xc).
auto.
Qed.

Lemma Zabs_ind_4 :
 forall (P : Z -> Prop) (x : Z),
 (x = 0%Z -> P x) -> ((0 < Z.abs x)%Z -> P x) -> P x.

Proof.
intros.
cut ({x = 0%Z} + {(0 < Z.abs x)%Z}).
intros.
elim H1.
auto.
auto.
cut ({Z.abs x = 0%Z} + {(0 < Z.abs x)%Z}).
intro.
elim H1.
intro.
left.
apply Zabs_O.
auto.
intro; right; auto.
apply Zabs_Zle_1.
Qed.

Lemma Zabs_ind_lt_O :
 forall (P : Z -> Prop) (z : Z),
 (Z.abs z = 1%Z -> P z) -> ((1 < Z.abs z)%Z -> P z) -> (0 < Z.abs z)%Z -> P z.

Proof.
intros.
cut ((0 < Z.abs z)%Z -> (1 < Z.abs z)%Z \/ 1%Z = Z.abs z).
intros.
elim H2.
auto.
auto.
auto.
intro.
apply Zle_lt_or_eq.
RingReplace 1%Z (Z.succ 0).
apply Zlt_le_succ.
auto.
Qed.

Lemma Zabs_ind_le_1 :
 forall (P : Z -> Prop) (z : Z),
 ((Z.abs z <= 1)%Z -> P z) -> ((1 < Z.abs z)%Z -> P z) -> P z.

Proof.
intros.
cut ((Z.abs z <= 1)%Z \/ (1 < Z.abs z)%Z).
intros.
elim H1.
auto.
auto.
apply Zle_or_lt.
Qed.

Lemma ind_gt_le :
 forall (P : Z -> Prop) (z a : Z),
 ((a <= z)%Z -> P z) -> ((z < a)%Z -> P z) -> P z.

Proof.
intros.
cut ((a <= z)%Z \/ (z < a)%Z).
intro.
elim H1.
auto.
auto.
apply Zle_or_lt.
Qed.

Lemma Zabs_pos_ind :
 forall (P : Z -> Prop) (z : Z),
 ((0 < z)%Z -> P z) -> ((z < 0)%Z -> P z) -> (0 < Z.abs z)%Z -> P z.

Proof.
intros.
cut ({z = Z.abs z} + {z = (- Z.abs z)%Z}); [ idtac | apply Zabs_dec ].
intro.
elim H2.
intro; apply H.
rewrite a; auto.
intro; apply H0.
rewrite b.
apply Zplus_lt_reg_l with (Z.abs z).
rewrite Zplus_comm; rewrite Zplus_opp_l; rewrite <- Zplus_0_r_reverse; auto.
Qed.

Lemma Zind_plus_1 :
 forall (z a : Z) (P : Z -> Prop),
 (z = a -> P z) -> ((z < a)%Z -> P z) -> (z < a + 1)%Z -> P z.

Proof.
intros.
cut ((z < a + 1)%Z -> {(z < a)%Z} + {z = a}).
intros.
elim H2; auto.
intro.
apply Z_le_lt_eq_dec.
apply Zlt_succ_le; auto.
Qed.

Lemma Zind_le :
 forall (z a : Z) (P : Z -> Prop),
 (z = a -> P z) -> ((z < a)%Z -> P z) -> (z <= a)%Z -> P z.

Proof.
intros.
cut ((z <= a)%Z -> {(z < a)%Z} + {z = a}).
intros.
elim H2; auto.
intro.
apply Z_le_lt_eq_dec.
auto.
Qed.

Lemma Zind_le_ZERO :
 forall (z : Z) (P : Z -> Prop),
 (0%Z = z -> P z) -> ((0 < z)%Z -> P z) -> (0 <= z)%Z -> P z.

Proof.
intros.
cut ((0 <= z)%Z -> {(0 < z)%Z} + {0%Z = z}).
intros.
elim H2; auto.
intro.
apply Z_le_lt_eq_dec.
auto.
Qed.