From Coq Require Import String List ZArith Lia.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
From compcert Require Import Maps Values ClightBigstep Events Memory.
Open Scope Z_scope.

Definition _s : ident := 54%positive.
Definition _str : ident := 53%positive.
Definition _strlen : ident := 55%positive.
(* Definition _t : ident := 57%positive. *)

Definition f_strlen := {|
  fn_return := tuint;
  fn_callconv := cc_default;
  fn_params := ((_str, (tptr tschar)) :: nil);
  fn_vars := nil;
  fn_temps := ((_s, (tptr tschar)) :: nil);
  fn_body :=
(Ssequence
  (Ssequence
    (Sset _s (Etempvar _str (tptr tschar)))
    (Sloop
    (* we don't need temporary variable _t *)
    (Sifthenelse (Ederef (Etempvar _s (tptr tschar)) tschar) Sskip Sbreak)
      (Sset _s
        (* add 1 to pointer _s *)
        (Ebinop Oadd (Etempvar _s (tptr tschar))
          (Econst_int (Int.repr 1) tint) (tptr tschar)))))
  (* return result of substraction of _s with original pointer _str,
     with equals to 'len' *)
  (Sreturn (Some (Ebinop Osub (Etempvar _s (tptr tschar))
                   (Etempvar _str (tptr tschar)) tint))))
|}.

Definition f_strlen_loop :=
    (Sloop
    (* we don't need temporary variable _t *)
    (Sifthenelse (Ederef (Etempvar _s (tptr tschar)) tschar) Sskip Sbreak)
      (Sset _s
        (* add 1 to pointer _s *)
        (Ebinop Oadd (Etempvar _s (tptr tschar))
          (Econst_int (Int.repr 1) tint) (tptr tschar)))).

Inductive strlen_spec (m : mem) (b : block) (ofs : ptrofs) : nat -> Prop :=
| LengthZero:
    Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) ->
    strlen_spec m b ofs 0
| LengthSucc:
    forall n c,
    Z.of_nat (S n) < Int.modulus ->
    Ptrofs.unsigned ofs + 1 < Ptrofs.modulus ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    Int.eq c Int.zero = false ->
    strlen_spec m b (Ptrofs.add ofs Ptrofs.one) n ->
    strlen_spec m b ofs (S n).

Definition nat_to_ofs (n : nat) := Ptrofs.repr (Z.of_nat n).

Hint Resolve Ptrofs.mul_one Ptrofs.add_zero : ptrofs.

Notation "x +* y" := (Ptrofs.add x y) (at level 80, right associativity).

Lemma ofs_succ_l : forall ofs i,
  Z.of_nat i < Int.modulus ->
  ((ofs +* (nat_to_ofs i)) +* Ptrofs.one) =
  (ofs +* (nat_to_ofs (S i))).
Proof.
  intros.
  rewrite Ptrofs.add_assoc.
  f_equal.
  unfold nat_to_ofs, Ptrofs.add, Ptrofs.one, Ptrofs.mul.
  rewrite Nat2Z.inj_succ.
  rewrite Ptrofs.unsigned_repr_eq.
  rewrite Zmod_small.
  reflexivity.
  replace Ptrofs.modulus with Int.modulus by reflexivity.
  lia.
Qed.

Lemma ofs_succ_r : forall ofs i,
  Z.of_nat i < Int.modulus ->
  ((ofs +* Ptrofs.one) +* (nat_to_ofs i)) =
  (ofs +* (nat_to_ofs (S i))).
Proof.
  intros.
  rewrite <-ofs_succ_l by assumption.
  rewrite Ptrofs.add_assoc, Ptrofs.add_assoc.
  f_equal.
  apply Ptrofs.add_commut.
Qed.

Lemma strlen_to_mem_0 :
  forall len m b ofs,
    strlen_spec m b ofs len ->
    strlen_spec m b (ofs +* (nat_to_ofs len)) 0.
Proof.
  induction len.
  all: intros.
  -
    replace (nat_to_ofs 0) with Ptrofs.zero by reflexivity.
    rewrite Ptrofs.add_zero.
    assumption.
  -
    inversion H.
    rewrite <-ofs_succ_r by lia.
    apply IHlen.
    assumption.
Qed.

Lemma strlen_to_mem :
  forall len m b ofs,
    strlen_spec m b ofs len ->
    forall i, (i < len)%nat ->
         exists c, Int.eq c Int.zero = false /\
           Mem.loadv Mint8signed m (Vptr b
             (ofs +* (nat_to_ofs i))) = Some (Vint c).
Proof .
  induction len.
  all: intros.
  - lia.
  -
    destruct i.
    all: inversion H.
    *
      exists c.
      split.
      assumption.
      rewrite Ptrofs.add_zero.
      assumption.
    *
      replace (ofs +* (nat_to_ofs (S i)))
        with ((ofs +* Ptrofs.one) +* (nat_to_ofs i)).
      apply IHlen.
      assumption.
      apply lt_S_n.
      assumption.
      rewrite ofs_succ_r by lia.
      reflexivity.
Qed.

Lemma strlen_loop_correct_gen :
  forall len i m b ofs ge e te,
    strlen_spec m b ofs (len + i) ->
    exists t te',
      te ! _str = Some (Vptr b ofs) ->
      te ! _s = Some (Vptr b (ofs +* (nat_to_ofs i))) ->
      exec_stmt ge e te m f_strlen_loop t te' m Out_normal
      /\ te' ! _s = Some (Vptr b (ofs +* (nat_to_ofs (len + i))))
      /\ te' ! _str = Some (Vptr b ofs) .
Proof.
  induction len; intros.
  -
    repeat eexists.
    eapply exec_Sloop_stop1.
    repeat econstructor.
    all: try eassumption.
    apply strlen_to_mem_0 in H.
    inversion_clear H.
    eassumption.
    econstructor.
    repeat econstructor.
    constructor.
  -
    assert (T : (i < S len + i)%nat) by lia.
    pose proof strlen_to_mem _ _ _ _ H _ T as HM; clear T.
    destruct HM as [c HM]; destruct HM as [HM1 HM2].
    pose proof strlen_to_mem_0 _ _ _ _ H as HO.
    replace (S len + i)%nat with (len + S i)%nat in * by lia.
    (* starting env *)
    remember (PTree.set _s
               (Vptr b (Ptrofs.add
               (Ptrofs.add ofs (nat_to_ofs i)) Ptrofs.one)) te)
      as Ite.
    inversion H; try lia.
    assert (Z.of_nat (S i) < Int.modulus) by lia.
    pose proof IHlen (S i) m b ofs ge e Ite H as IH.
    clear IHlen.
    destruct IH as [t' IH].
    destruct IH as [te' IH].
    eexists.
    eexists.
    intros.
    destruct IH.
    subst; rewrite PTree.gso by discriminate.
    eassumption.
    subst; rewrite PTree.gss; rewrite ofs_succ_l by lia; reflexivity.
    destruct H10; split;[| split].
    eapply exec_Sloop_loop.
    repeat econstructor.
    eassumption.
    eassumption.
    econstructor.
    rewrite HM1.
    simpl.
    econstructor.
    constructor.
    repeat econstructor.
    eassumption.
    econstructor.
    fold f_strlen_loop.
    replace (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
                        (ptrofs_of_int Signed (Int.repr 1))) with (Ptrofs.one) by (auto with ptrofs).
    rewrite <-HeqIte.
    eapply H9.
    rewrite H0.
    assumption.
    assumption.
Qed.

Theorem strlen_correct : forall len m b ofs ge e te,
  strlen_spec m b ofs len ->
  te ! _str = Some (Vptr b ofs) ->
  exists t te',
    exec_stmt ge e te m (fn_body f_strlen) t te' m
              (Out_return (Some (Vptrofs (nat_to_ofs len), tint))).
Proof.
  intros.
  replace (len) with (len + 0)%nat in H by lia.
  pose proof strlen_loop_correct_gen len 0%nat m b ofs ge e (PTree.set _s (Vptr b ofs) te) H.
  destruct H1 as [t' HM].
  destruct HM as [te' HM].
  repeat eexists.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  eassumption.
  fold f_strlen_loop.
  destruct HM.
  rewrite PTree.gso by discriminate.
  eassumption.
  rewrite PTree.gss.
  replace (ofs +* nat_to_ofs 0) with (ofs) by (auto with ptrofs).
  reflexivity.
  eassumption.
  econstructor.
  econstructor.
  econstructor.
  all: destruct HM.
  1,4,7: rewrite PTree.gso by discriminate.
  all: try eassumption.
  1,3,5: rewrite PTree.gss.
  all: try replace (ofs +* nat_to_ofs 0) with (ofs) by (auto with ptrofs).
  all: try reflexivity.
  all: destruct H2.
  eassumption.
  econstructor.
  eassumption.
  replace (len + 0)%nat with len by lia.
  cbn.
  unfold proj_sumbool.
  destruct Archi.ptr64 eqn:kek.
  all: destruct zle.
  1,3: destruct eq_block.
  rewrite Ptrofs.sub_add_l.
  rewrite Ptrofs.sub_idem.
  rewrite Ptrofs.add_zero_l.
  rewrite Ptrofs.divs_one.
  reflexivity.
  unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  rewrite kek.
  lia.
  contradict n; reflexivity.
  rewrite Ptrofs.sub_add_l.
  rewrite Ptrofs.sub_idem.
  rewrite Ptrofs.add_zero_l.
  rewrite Ptrofs.divs_one.
  reflexivity.
  unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  rewrite kek.
  lia.
  contradict n; reflexivity.

  contradict g.
  unfold Ptrofs.max_signed, Ptrofs.half_modulus, Ptrofs.modulus.
  unfold Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  rewrite kek.
  simpl.
  lia.
  contradict g.
  unfold Ptrofs.max_signed, Ptrofs.half_modulus, Ptrofs.modulus.
  unfold Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  rewrite kek.
  simpl.
  lia.
Qed.

Close Scope Z.


Require Import RelationClasses.
(* The classes in RelationClasses are useful to implement. Implementing
[PreOrder] will make the [reflexivity], [transitivity], and [etransitivity]
tactics work with your own relations (much better than manually figuring out
which transitivity lemma to apply!). Here's a nice way to make implementing
relation classes more convenient. *)

Ltac RelInstance_t :=
  intros;
  let refl := try solve [ hnf; intros; reflexivity ] in
  let trans := try solve [ hnf; intros; etransitivity; eauto ] in
  try match goal with
  | |- Reflexive _ =>
    hnf; intros; refl
  | |- Transitive _ =>
    hnf; intros; trans
  | |- PreOrder _ =>
    constructor; hnf; intros; [ refl | trans ]
  end.

Definition funext_eq A B (f1 f2: A -> B) := forall x, f1 x = f2 x.

Section Method1.
  (* the most basic way to provide an instance *)
  Instance funext_eq_PreOrder1 A B : PreOrder (funext_eq A B).
  Proof.
    RelInstance_t.
  Qed.
End Method1.

(* we can use tactics-in-terms with notations to create a term-like definition
that is actually a tactic *)
Notation RelInstance := (ltac:(RelInstance_t)) (only parsing).

Section Method2.
  (* this is more powerful than it looks - if [RelInstance] had not solved the
  goal, you can prove the remaining goals and finish the instance. *)
  Instance funext_eq_PreOrder2 A B : PreOrder (funext_eq A B) := RelInstance.
End Method2.

Section Method3.
  (* Program Instance makes this even more convenient by registering a tactic to
  run automatically. It does some of work that [RelInstance_t] is doing, so the
  tactic is written to handle Reflexive and Transitive goals in addition to
  PreOrder. *)
  Obligation Tactic := try RelInstance_t.
  Program Instance funext_eq_PreOrder3 A B : PreOrder (funext_eq A B).
End Method3.

Section Method4.
  Instance funext_eq_PreOrder A B : PreOrder (funext_eq A B) := RelInstance.
  (* here we re-use an existing instance; this particular case is not very
  useful, but if the instance is complicated and combines several existing
  instances, these kind of redundant instances like these can speed up typeclass
  resolution. *)
  Instance funext_eq_PreOrder4 : PreOrder (funext_eq nat nat).
  Proof.
    typeclasses eauto.
  Qed.
End Method4.


From mathcomp Require Import ssreflect ssrnat eqtype.
From deriving Require Import deriving.

Require Import type.

(* cf. https://github.com/arthuraa/deriving/blob/master/tests/records.v *)

Scheme t_rect := Induction for t Sort Type.

Time Definition t_indDef := [indDef for t_rect].
Canonical t_indType := IndType t t_indDef.

Module nored.

(* see https://github.com/arthuraa/deriving#simplification-and-performance-issues *)
Definition t_eqMixin : Equality.mixin_of t.
Proof. Time exact [derive nored eqMixin for t]. Time Qed.

End nored.

Optimize Heap. (* try to reduce the impact of making two different things in the same file *)

Time Definition t_eqMixin := [derive eqMixin for t].
Canonical t_eqType := EqType t t_eqMixin.


Add Search Blacklist "Private_" "_subproof".
Set Printing Depth 50.
Remove Search Blacklist "Private_" "_subproof".
Add Search Blacklist "Private_" "_subproof".
Add LoadPath "../..".
Require Import BetaJulia.BasicPLDefs.Identifier.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Recdef.
Create HintDb DBBetaJulia.
Declare Scope btjt_scope.
Delimit Scope btjt_scope with btjt.
Open Scope btjt.
Inductive cname : Type :=
  | NInt : _
  | NFlt : _
  | NStr : _.
Inductive ty : Type :=
  | TCName : cname -> ty
  | TPair : ty -> ty -> ty
  | TUnion : ty -> ty -> ty
  | TExist : id -> ty -> ty
  | TVar : id -> ty
  | TEV : id -> ty.
Definition tint := TCName NInt.
Definition tflt := TCName NFlt.
Definition tstr := TCName NStr.
Definition tIntInt := TPair tint tint.
Definition vX := Id 1.
Definition vY := Id 2.
Definition vZ := Id 3.
Definition tX := TVar vX.
Definition tY := TVar vY.
Definition teXX := TExist vX tX.
Fixpoint FV (t : ty) : id_set :=
  match t with
  | TCName _ => IdSet.empty
  | TPair t1 t2 => IdSet.union (FV t1) (FV t2)
  | TUnion t1 t2 => IdSet.union (FV t1) (FV t2)
  | TExist y t' => IdSet.remove y (FV t')
  | TVar y => IdSet.singleton y
  | TEV _ => IdSet.empty
  end.
Definition fresh (X : id) (fvs : id_set) := ~ IdSet.In X fvs.
Definition fresh_in_ty (X : id) (t : ty) := fresh X (FV t).
Definition free_in_ty (X : id) (t : ty) := IdSet.In X (FV t).
Hint Unfold fresh fresh_in_ty free_in_ty: DBBetaJulia.
Axiom (gen_fresh : id_set -> id).
Axiom (gen_fresh__fresh : forall fvs : id_set, fresh (gen_fresh fvs) fvs).
Definition get_fresh_in_ty (t : ty) := gen_fresh (FV t).
Reserved Notation "'[' x '@' y ']' t" (at level 30).
Fixpoint rename (x y : id) (t : ty) :=
  match t with
  | TCName _ => t
  | TPair t1 t2 => TPair ([x @ y] t1) ([x @ y] t2)
  | TUnion t1 t2 => TUnion ([x @ y] t1) ([x @ y] t2)
  | TExist z t' => TExist z (if beq_id x z then t' else [x @ y] t')
  | TVar z => if beq_id x z then TVar y else t
  | TEV z => t
  end
where "'[' x '@' y ']' t" := (rename x y t) : btjt_scope.
Fixpoint size (t : ty) :=
  match t with
  | TCName _ => 1
  | TPair t1 t2 => 1 + size t1 + size t2
  | TUnion t1 t2 => 1 + size t1 + size t2
  | TExist z t' => 1 + size t'
  | TVar z => 1
  | TEV z => 1
  end.
Lemma rename__size : forall (x y : id) (t : ty), size ([x @ y] t) = size t.
Proof.
(intros x y).
(induction t; simpl; try (solve [ reflexivity | rewrite IHt1; rewrite IHt2; reflexivity ])).
-
(apply f_equal).
(destruct (beq_idP x i)).
+
subst.
reflexivity.
+
assumption.
-
(destruct (beq_idP x i); reflexivity).
Qed.
Check lt.
Definition lt_size (t1 t2 : ty) := lt (size t1) (size t2).
Function
 subst (x : id) (s t : ty) {wf lt_size t} : ty :=
   match t with
   | TCName _ => t
   | TPair t1 t2 => TPair (subst x s t1) (subst x s t2)
   | TUnion t1 t2 => TUnion (subst x s t1) (subst x s t2)
   | TExist y t' =>
       if IdSet.mem y (FV s)
       then let z := gen_fresh (IdSet.union (FV s) (FV t')) in let tz := [y @ z] t' in TExist z (if beq_id x z then tz else subst x s t')
       else TExist y (if beq_id x y then t' else subst x s t')
   | TVar y => if beq_id x y then s else t
   | TEV y => t
   end.
Print All.
(* Auto-generated comment: Succeeded. *)


Require Import Base.
Require Import Circuit.
Require Import Monad.
Require Import Setoid.

Require Import StateSpace.Definitions.
Require Import StateSpace.Tactics.

Require Import Program.Equality.

Require Import List.
Import ListNotations.
Open Scope list_scope.

Import EnsembleNotation.
Open Scope ensemble_scope.

Section MG_to_SS.

  Set Implicit Arguments.
  (** ** Convert a marked graph to a state space *)
  Variable name : Set.
  Context `{name_dec : eq_dec name}.

  Variable transition : Set.
  Context `{transition_dec : eq_dec transition}.
  Variable MG : marked_graph transition.

  Import EnsembleNotation.
  Open Scope ensemble_scope.

  Inductive place_eq : forall {t1 t2 t1' t2' : transition}, place MG t1 t2 -> place MG t1' t2' -> Prop :=
  | place_refl : forall t1 t2 (p : place MG t1 t2), place_eq p p.

  Class MG_naming_scheme :=
  { transition_name : transition -> name
  ; place_name : forall {t1 t2} (p : place MG t1 t2), name

(*
  ;  name_is_place_dec : forall (x : name),
     {t1 : transition & {t2 : transition & {p : place MG t1 t2 & x = place_name p}}}
   + {forall t1 t2 (p : place MG t1 t2), x <> place_name p}
*)
  ; name_to_place : name -> option {t1 & {t2 & place MG t1 t2}}
  ; name_to_place_correct : forall x tin tout (p : place MG tin tout),
        name_to_place x = Some (existT _ tin (existT _ tout p))
    <-> x = place_name p

  ; transition_update_value : transition -> value -> value

  ; input_transition : Ensemble transition
  ; input_transition_dec : `{in_dec input_transition}

  ; transition_place_name_disjoint : forall t {t1 t2} (p : place MG t1 t2),
    transition_name t <> place_name p

    (* I'm not sure if t ∈ input_transition is the right restriction here, but
    we need this fact for proving well_formed, and it does not hold without this
    transition for click, e.g. with CLK+ and CLK-. On the other hand, what about
    4 phase handshake protocols? *)
  ; transition_name_injective : forall t t', t ∈ input_transition ->
    t <> t' -> transition_name t <> transition_name t'

   ; places_all_disjoint : forall {t1 t2 t1' t2' : transition}
                                        (p : place MG t1 t2) (p' : place MG t1' t2'),
      place_name p = place_name p' ->
      place_eq p p'

  }.
  Context `{MG_scheme : MG_naming_scheme}.

  Definition places_set : Ensemble name :=
    fun x => exists t1 t2 (p : place MG t1 t2), x = place_name p.
  Definition state_to_marking (σ : state name) : marking MG :=
    fun t1 t2 p => val_to_nat (σ (place_name p)).

  Lemma name_to_place_eq : forall t1 t2 (p : place MG t1 t2),
    name_to_place (place_name p) = Some (existT _ t1 (existT _ t2 p)).
  Proof.
    intros.
    apply name_to_place_correct; auto.
  Qed.
  Lemma name_to_place_neq : forall t,
    name_to_place (transition_name t) = None.
  Proof.
    intros t.
    destruct (name_to_place (transition_name t)) as [[t1 [t2 p]] | ] eqn:contra; auto.
    apply name_to_place_correct in contra.
    apply transition_place_name_disjoint in contra.
    contradiction.
  Qed.

  Definition fire_in_state (t : transition) (σ : state name) : state name :=
    fun x =>
    match name_to_place x with
    (* if x is not a place, do nothing *)
    | None => σ x
    | Some (existT _ tin (existT _ tout p)) =>
         (* corner case: do nothing *)
         if tin =? tout then σ x
         (* if x is a place leading into t, increment the value *)
         else if t =? tout then dec_value (σ x)
         (* if x is a place leading out of t, decrement the value *)
         else if t =? tin then inc_value (σ x)
         (* otherwise do nothing *)
         else σ x
    end.

  (* NOTE: this may not be the right relation for all marked graphs--get example from Peter *)
  Let transition_set : Ensemble name := fmap transition_name (fun (t : transition) => True).

  Inductive MG_SS_step
    : state name -> option (event name value) -> option (state name) -> Prop :=

  | transition_enabled σ σ' x v (t : transition) :
    x = transition_name t ->
    is_enabled MG t (state_to_marking σ) ->
    v = transition_update_value t (σ x) ->
    state_equiv_on (transition_set ∪ places_set)
                   (Some σ')
                   (Some (update (fire_in_state t σ) x v)) ->
    MG_SS_step σ (Some (Event x v)) (Some σ')

  | input_not_enabled σ x v t :
    x = transition_name t ->
    t ∈ input_transition ->
    ~ is_enabled MG t (state_to_marking σ) ->
   MG_SS_step σ (Some (Event x v)) None
  .

  Let output_transition : Ensemble transition :=
    (fun t => True) ∖ input_transition.
(*    fun t => t ∉ input_transition.*)
  Definition MG_SS : StateSpace name :=
  {| space_input := fmap transition_name input_transition
   ; space_output := fmap transition_name output_transition
   ; space_internal := places_set
   ; space_step := MG_SS_step
   |}.

  Lemma places_all_numbers_step : forall σ σ' e {t1 t2} (p : place MG t1 t2),
    σ (place_name p) <> X ->
    MG_SS ⊢ σ →{e} Some σ' ->
    σ' (place_name p) <> X.
  Proof.
    intros σ σ' e t1 t2 p Hwf Hstep.
    inversion Hstep; subst.
    rewrite H5.
    2:{ right. exists t1. exists t2. exists p. reflexivity. }
    unfold update.
    set (Hneq := transition_place_name_disjoint t p).
    reduce_eqb.
    unfold fire_in_state.
    rewrite name_to_place_eq.
    compare_next; auto.
    compare_next; auto.
    { destruct (σ (place_name p)); find_contradiction. }
    compare_next; auto.
    { destruct (σ (place_name p)); find_contradiction. }
  Qed.

  Lemma places_all_numbers : forall σ σ' tr {t1 t2} (p : place MG t1 t2),
    σ (place_name p) <> X ->
    MG_SS ⊢ σ →*{tr} Some σ' ->
    σ' (place_name p) <> X.
  Proof.
    intros ? ? ? ? ? ? ? Hstep.
    remember MG_SS as S.
    remember (Some σ') as τ.
    generalize dependent σ'.
    generalize dependent t2. generalize dependent t1.
    induction Hstep; intros t1 t2 p Hneq σ'' Hτ; subst.
    * inversion Hτ; subst; auto.
    * destruct e as [x v].
      inversion H; subst; clear H.
      rewrite H7.
        2:{ right. do 3 eexists. reflexivity. }
        unfold update.
        set (Hneq' := transition_place_name_disjoint t0 p).
        reduce_eqb.
        unfold fire_in_state.
        rewrite name_to_place_eq.
        specialize (IHHstep _ _ p Hneq σ' eq_refl).
        compare_next; auto.
        compare_next; auto.
        { destruct (σ' (place_name p)); find_contradiction. }
        compare_next; auto.
        { destruct (σ' (place_name p)); find_contradiction. }

    * inversion H.
  Qed.

  Arguments well_formed {name}.
  Lemma wf_MG_SS : well_formed MG_SS.
  Proof.
    set (Hdec := input_transition_dec).
    constructor;
    try match goal with
    | [ |- _ ⊥ _ ] =>
      simpl; constructor;
      intros x Hx; deep_decompose_set_structure;
      match goal with
      | [ H : transition_name ?t1 = transition_name ?t2 |- _ ] =>
        compare t1 t2;
        try (eapply transition_name_injective; eauto; fail)

      | [ H : transition_name ?t = place_name ?p |- _ ] =>
        let Hdisjoint := fresh "Hdisjoint" in
        set (Hdisjoint := transition_place_name_disjoint t p);
        find_contradiction
      end
    end.

    * intros ? ? ? ? Hstep.
      inversion Hstep; subst; simpl.
      { destruct (t ∈? input_transition).
        + left. econstructor; eauto.
        + right. econstructor; split; eauto.
          unfold output_transition. solve_set.
       }
      { destruct (t ∈? input_transition).
        + left. econstructor; eauto.
        + right. econstructor; split; eauto.
          unfold output_transition. solve_set.
       }
    * intros ? ? ? Hstep ? He Hexternal.
      inversion Hstep; subst.
      rewrite H5.
      2:{ simpl in Hexternal. deep_decompose_set_structure; subst;
          left; exists x0; split; auto; constructor.
      }
      unfold update.
      compare_next; auto.
      { contradiction (He (transition_update_value t (σ (transition_name t)))); auto. }
      unfold fire_in_state.
      assert (Hx : forall t1 t2 (p : place MG t1 t2), x <> place_name p).
      { simpl in Hexternal. deep_decompose_set_structure; subst;
        apply transition_place_name_disjoint.
      }
      assert (Hx' : name_to_place x = None).
      { simpl in Hexternal; deep_decompose_set_structure; subst;
          rewrite name_to_place_neq; auto.
      }
      rewrite Hx'; auto.

    * intros ? ? ? ? Hstep.
      inversion Hstep; subst.
      rewrite H6.
      2:{ left. exists t; split; auto; constructor. }
      unfold update; simpl.
      reduce_eqb. auto.
  Qed.

  Lemma MG_SS_val_not_X : forall σ0 tr σ,
    MG_SS ⊢ σ0 →*{tr} Some σ ->
    forall {t1 t2} (p : place MG t1 t2),
    σ0 (place_name p) <> X ->
    σ (place_name p) <> X.
  Proof.
    intros σ0 tr σ Hstep.
    remember (Some σ) as τ; generalize dependent σ.
    induction Hstep; intros σ Hτ t1 t2 p Hwf; inversion Hτ; subst; auto.
    * specialize (IHHstep σ' eq_refl t1 t2 p Hwf).
      inversion H; subst.
      rewrite H7.
      2:{ right. eexists. eexists. exists p. reflexivity. }
      unfold update. compare_next.
      { apply transition_place_name_disjoint in Heq; contradiction.
      }
      unfold fire_in_state.
      rewrite name_to_place_eq.
      compare_next; auto.
      compare_next. { destruct (σ' (place_name p)); try (inversion 1; fail); find_contradiction. }
      compare_next. { destruct (σ' (place_name p)); try (inversion 1; fail); find_contradiction. }
      auto.

    * specialize (IHHstep σ' eq_refl t1 t2 p Hwf).
      inversion H; subst.
  Qed.

  Unset Implicit Arguments.
End MG_to_SS.


Require Import BinInt.

Fixpoint skipn (n : nat) ( l :list nat) : list nat :=
  match n with
  | 0 => l
  | S n => match l with
           | nil => nil
           | cons a l => skipn n l
           end
  end.

Definition nth_default d n xs :=
  match skipn n xs with
  | cons x _ => x
  | _ => d
  end.

Ltac cintro vars :=
  let x := fresh in
  intros x;
  pose (vars' := @cons nat x vars);
  change x with (nth_default 0 (Z.to_nat 0) vars');
  repeat match goal with
  |- context[skipn (Z.to_nat ?s) vars] =>
      let s' := eval cbv in (Z.succ s) in
      change (skipn (Z.to_nat s) vars)
        with (skipn (Z.to_nat s') vars')
  end;
  change vars with (skipn (Z.to_nat 1) vars');
  clearbody vars';
  clear x;
  clear vars;
  rename vars' into vars.

Fixpoint foralln n (x : nat) (k : nat -> Prop) :=
  match n with
  | O => k x
  | S n =>
    forall x : nat, foralln n x k
  end.

Goal forall (vars : list nat) (a b c : nat),
   a + b + c = c + b + a.
  intros ?.
  cintro vars.
  cintro vars.
  cintro vars.
Abort.

Goal foralln 250 O (fun _=> True). cbv beta iota delta [foralln].
Proof. pose (vars := @nil nat). Time repeat cintro vars. Time Optimize Proof. exact I. Qed.
Goal foralln 500 O (fun _=> True). cbv beta iota delta [foralln].
Proof. pose (vars := @nil nat). Time repeat cintro vars. Time Optimize Proof. exact I. Qed.
Goal foralln 1000 O (fun _=> True). cbv beta iota delta [foralln].
Proof. pose (vars := @nil nat). Time repeat cintro vars. Time Optimize Proof. exact I. Qed.
Goal foralln 2000 O (fun _=> True). cbv beta iota delta [foralln].
Proof. pose (vars := @nil nat). Time repeat cintro vars. Time Optimize Proof. exact I. Qed.
Goal foralln 4000 O (fun _=> True). cbv beta iota delta [foralln].
Proof. pose (vars := @nil nat). Time repeat cintro vars. Time Optimize Proof. exact I. Qed.
(*
Finished transaction in 0.116 secs (0.085u,0.029s) (successful)
Evars: 2505 -> 1
Finished transaction in 0.001 secs (0.001u,0.s) (successful)

Finished transaction in 0.192 secs (0.188u,0.002s) (successful)
Evars: 5005 -> 1
Finished transaction in 0.003 secs (0.003u,0.s) (successful)

Finished transaction in 0.675 secs (0.67u,0.s) (successful)
Evars: 10005 -> 1
Finished transaction in 0.007 secs (0.007u,0.s) (successful)

Finished transaction in 1.98 secs (1.964u,0.004s) (successful)
Evars: 20005 -> 1
Finished transaction in 0.014 secs (0.014u,0.s) (successful)

Finished transaction in 7.248 secs (7.209u,0.01s) (successful)
Evars: 40005 -> 1
Finished transaction in 0.037 secs (0.037u,0.s) (successful)
*)


Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EnumEnsembles.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.lib.Equivalence_ext.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.path_lemmas.

Section FiniteGraph.

Context {V E: Type} {EV: EqDec V eq} {EE: EqDec E eq}.

Class FiniteGraph (pg: PreGraph V E) :=
{
  finiteV: Enumerable V (vvalid pg);
  finiteE: Enumerable E (evalid pg)
}.

Class LocalFiniteGraph (pg: PreGraph V E) :=
{
  local_enumerable: forall x, Enumerable E (out_edges pg x)
}.

Definition edge_func (pg: PreGraph V E) {lfg: LocalFiniteGraph pg} x := proj1_sig (local_enumerable x).

Lemma edge_func_spec: forall {pg : PreGraph V E} {lfg: LocalFiniteGraph pg} e x,
  In e (edge_func pg x) <-> evalid pg e /\ src pg e = x.
Proof.
  intros.
  unfold edge_func.
  destruct (local_enumerable x) as [? [?H ?H]]; simpl.
  specialize (H0 e).
  rewrite H0; unfold out_edges.
  clear - H0.
  unfold Ensembles.In; tauto.
Qed.

Lemma edge_func_step: forall {pg : PreGraph V E} {lfg: LocalFiniteGraph pg} x y,
  step pg x y <-> In y (map (dst pg) (edge_func pg x)).
Proof.
  intros.
  rewrite step_spec.
  rewrite in_map_iff.
  apply Morphisms_Prop.ex_iff_morphism.
  hnf; cbv beta; intro e.
  rewrite edge_func_spec.
  clear - e.
  tauto.
Qed.

Instance LocalFiniteGraph_FiniteGraph (g: PreGraph V E) (fg: FiniteGraph g): LocalFiniteGraph g.
Proof.
  intros.
  destruct fg as [[vs [?H ?H]] [es [?H ?H]]].
  constructor.
  intros.
  exists (filter (fun e => if equiv_dec (src g e) x then true else false) es).
  split.
  + apply NoDup_filter; auto.
  + intro e.
    rewrite filter_In.
    rewrite H2.
    unfold Ensembles.In, out_edges.
    destruct_eq_dec (src g e) x; [tauto |].
    assert (~ false = true) by congruence; tauto.
Defined.

Lemma finite_graph_si: forall (g1 g2: PreGraph V E),
  g1 ~=~ g2 ->
  FiniteGraph g1 ->
  FiniteGraph g2.
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + revert X; apply Enumerable_Same_set.
    destruct H as [? _]; rewrite Same_set_spec; auto.
  + revert Y; apply Enumerable_Same_set.
    destruct H as [_ [? _]]; rewrite Same_set_spec; auto.
Qed.

Lemma gen_dst_preserve_finite: forall (g: PreGraph V E) e t, FiniteGraph g -> FiniteGraph (pregraph_gen_dst g e t).
Proof.
  intros. apply Build_FiniteGraph; simpl.
  + apply finiteV.
  + apply finiteE.
Qed.

Lemma predicate_sub_finitegraph: forall (g: PreGraph V E) (p: NodePred V), FiniteGraph g -> FiniteGraph (predicate_subgraph g p).
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + destruct X as [l ?].
    exists (filter (fun v => if node_pred_dec p v then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p x); firstorder.
  + destruct Y as [l ?].
    exists (filter (fun e => if (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))) then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros e.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))); firstorder.
Qed.

Lemma predicate_partial_finitegraph: forall (g: PreGraph V E) (p: NodePred V), FiniteGraph g -> FiniteGraph (predicate_partialgraph g p).
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + destruct X as [l ?].
    exists (filter (fun v => if node_pred_dec p v then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p x); firstorder.
  + destruct Y as [l ?].
    exists (filter (fun e => if (node_pred_dec p (src g e)) then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros e.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p (src g e)); firstorder.
Qed.

Definition predicate_sub_localfinitegraph (g: PreGraph V E) (p: NodePred V) (LF: LocalFiniteGraph g): LocalFiniteGraph (predicate_subgraph g p).
Proof.
  refine (Build_LocalFiniteGraph _ _).
  intros.
  exists (filter (fun e => if (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))) then true else false) (edge_func g x)).
  split.
  + apply NoDup_filter.
    unfold edge_func.
    destruct (local_enumerable x); simpl.
    tauto.
  + intros.
    unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
    rewrite filter_In.
    rewrite edge_func_spec.
    destruct (Coqlib2.sumbool_dec_and (node_pred_dec p (src g x0)) (node_pred_dec p (dst g x0))).
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (true = true) by auto; tauto.
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (~ false = true) by congruence; tauto.
Defined.

Definition predicate_partial_localfinitegraph (g: PreGraph V E) (p: NodePred V) (LF: LocalFiniteGraph g) : LocalFiniteGraph (predicate_partialgraph g p).
Proof.
  refine (Build_LocalFiniteGraph _ _).
  intros.
  exists (filter (fun e => if (node_pred_dec p (src g e)) then true else false) (edge_func g x)).
  split.
  + apply NoDup_filter.
    unfold edge_func.
    destruct (local_enumerable x); simpl.
    tauto.
  + intros.
    unfold predicate_partialgraph, predicate_vvalid, predicate_weak_evalid; simpl; intros.
    rewrite filter_In.
    rewrite edge_func_spec.
    destruct (node_pred_dec p (src g x0)).
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (true = true) by auto; tauto.
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (~ false = true) by congruence; tauto.
Defined.

Lemma finite_graph_join: forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  FiniteGraph (gpredicate_subgraph PV1 PE1 g) ->
  FiniteGraph (gpredicate_subgraph PV2 PE2 g) ->
  FiniteGraph (gpredicate_subgraph PV PE g).
Proof.
  intros.
  constructor.
  + destruct X as [[l1 [?H ?H]] ?].
    destruct X0 as [[l2 [?H ?H]] ?].
    exists (l1 ++ l2).
    split.
    - apply NoDup_app_inv; auto.
      intros v ? ?.
      rewrite H2 in H5; rewrite H4 in H6.
      unfold Ensembles.In in H5, H6; simpl in H5, H6.
      rewrite Intersection_spec in H5, H6.
      destruct H5, H6, H as [_ ?].
      apply (H v); auto.
    - intros v.
      rewrite in_app_iff.
      rewrite H2, H4.
      unfold Ensembles.In; simpl; rewrite !Intersection_spec.
      destruct H as [? _]; specialize (H v); tauto.
  + destruct X as [? [l1 [?H ?H]]].
    destruct X0 as [? [l2 [?H ?H]]].
    exists (l1 ++ l2).
    split.
    - apply NoDup_app_inv; auto.
      intros e ? ?.
      rewrite H2 in H5; rewrite H4 in H6.
      unfold Ensembles.In in H5, H6; simpl in H5, H6.
      rewrite Intersection_spec in H5, H6.
      destruct H5, H6, H0 as [_ ?].
      apply (H0 e); auto.
    - intros e.
      rewrite in_app_iff.
      rewrite H2, H4.
      unfold Ensembles.In; simpl; rewrite !Intersection_spec.
      destruct H0 as [? _]; specialize (H0 e); tauto.
Qed.

Lemma FiniteGraph_EnumCovered: forall (g: PreGraph V E) (fin: FiniteGraph g) x, EnumCovered V (reachable g x).
Proof.
  intros.
  destruct fin as [[xs [? ?]] _].
  exists xs.
  split; auto.
  intros y ?.
  apply reachable_foot_valid in H1.
  rewrite H0.
  exact H1.
Qed.

Class ReachableFiniteGraph (pg: PreGraph V E) := {
  finiteR: forall x, vvalid pg x -> Enumerable V (reachable pg x)
}.

Lemma construct_reachable_list: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x, Decidable (vvalid g x) -> {l: list V | NoDup l /\ reachable_list g x l}.
Proof.
  intros.
  destruct H.
  + destruct (finiteR x v) as [l ?H].
    exists l.
    unfold reachable_list; auto.
  + exists nil.
    split; [constructor |].
    intro; simpl.
    pose proof reachable_head_valid g x y.
    tauto.
Qed.

Lemma RFG_reachable_decicable: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x y, vvalid g x -> Decidable (reachable g x y).
Proof.
  intros.
  pose proof finiteR x H.
  destruct X as [l [_ ?H]].
  unfold Ensembles.In in H0.
  destruct (in_dec equiv_dec y l); [left | right]; rewrite <- H0; auto.
Qed.

Lemma RFG_reachable_decicable': forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x y, Decidable (vvalid g x) -> Decidable (reachable g x y).
Proof.
  intros.
  destruct H; [apply RFG_reachable_decicable; auto | right].
  intro.
  apply reachable_head_valid in H; tauto.
Qed.

Lemma construct_reachable_set_list: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} S
  (V_DEC: forall x, In x S -> Decidable (vvalid g x)),
  {l: list V | NoDup l /\ reachable_set_list g S l}.
Proof.
  intros.
  induction S.
  + exists nil.
    split; [constructor |].
    intro.
    pose proof reachable_through_empty g.
    pose proof Empty_set_iff V.
    unfold Same_set, Included, Ensembles.In in *.
    simpl.
    firstorder.
  + spec IHS.
    - intros; apply V_DEC.
      right; auto.
    - destruct IHS as [l2 ?H].
      destruct (construct_reachable_list g a (V_DEC a (or_introl eq_refl))) as [l1 ?H].
      exists (nodup equiv_dec (l1 ++ l2)).
      split; [apply NoDup_nodup |].
      destruct H as [_ ?].
      destruct H0 as [_ ?].
      unfold reachable_set_list, reachable_list in *.
      intros.
      rewrite nodup_In.
      rewrite in_app_iff, reachable_through_set_eq.
      specialize (H x).
      specialize (H0 x).
      tauto.
Qed.

Lemma RFG_reachable_through_set_decicable: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} S y, (forall x, In x S -> Decidable (vvalid g x)) -> Decidable (reachable_through_set g S y).
Proof.
  intros.
  destruct (construct_reachable_set_list g S X) as [l [_ ?]].
  destruct (in_dec equiv_dec y l); [left | right]; rewrite <- (H y); auto.
Qed.

End FiniteGraph.


(************************************************************
* Lambda-calculus with exceptions,                          *
* Big-step semantics with error rules                       *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExn_Syntax.
Export BehaviorsWithErrors.
Export AssumeDeterministic.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : beh.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Semantics *)

(** Abort behaviors *)

Inductive abort : beh -> Prop :=
  | abort_exn : forall v, abort (beh_exn v)
  | abort_err : abort beh_err.

(** Characterisation of closures *)

Inductive isclo : val -> Prop :=
  | isclo_intro : forall x t3, isclo (val_clo x t3).

(** Reduction *)

Inductive bigred : trm -> beh -> Prop :=
  | bigred_var : forall x,
      bigred (trm_var x) beh_err
  | bigred_val : forall v,
      bigred v v
  | bigred_abs : forall x t,
      bigred (trm_abs x t) (val_clo x t)
  | bigred_app : forall t1 t2 x t3 v2 o,
      bigred t1 (val_clo x t3) ->
      bigred t2 v2 ->
      bigred (subst x v2 t3) o ->
      bigred (trm_app t1 t2) o
  | bigred_app_abort_1 : forall t1 t2 b,
      abort b ->
      bigred t1 b ->
      bigred (trm_app t1 t2) b
  | bigred_app_abort_2 : forall t1 t2 v1 b,
      abort b ->
      bigred t1 v1 ->
      bigred t2 b ->
      bigred (trm_app t1 t2) b
  | bigred_app_2_err : forall t1 t2 v1 v2,
      ~ isclo v1 ->
      bigred t1 v1 ->
      bigred t2 v2 ->
      bigred (trm_app t1 t2) beh_err
  | bigred_try : forall t1 t2 v1,
      bigred t1 v1 ->
      bigred (trm_try t1 t2) v1
  | bigred_try_1 : forall t1 t2 o2 v,
      bigred t1 (beh_exn v)->
      bigred (trm_app t2 v) o2 ->
      bigred (trm_try t1 t2) o2
  | bigred_try_1_err : forall t1 t2,
      bigred t1 beh_err ->
      bigred (trm_try t1 t2) beh_err
  | bigred_raise : forall t1 v1,
      bigred t1 v1 ->
      bigred (trm_raise t1) (beh_exn v1)
  | bigred_raise_abort_1 : forall t1 b,
      abort b ->
      bigred t1 b ->
      bigred (trm_raise t1) b
  | bigred_rand : forall k,
      (ParamDeterministic -> k = 0) ->
      bigred trm_rand (val_int k).

(** Divergence *)

CoInductive bigdiv : trm -> Prop :=
  | bigdiv_app_1 : forall t1 t2,
      bigdiv t1 ->
      bigdiv (trm_app t1 t2)
  | bigdiv_app_2 : forall t1 v1 t2,
      bigred t1 v1 ->
      bigdiv t2 ->
      bigdiv (trm_app t1 t2)
  | bigdiv_app_3 : forall t1 t2 x t3 v2,
      bigred t1 (val_clo x t3) ->
      bigred t2 v2 ->
      bigdiv (subst x v2 t3) ->
      bigdiv (trm_app t1 t2)
  | bigdiv_try_1 : forall t1 t2,
      bigdiv t1 ->
      bigdiv (trm_try t1 t2)
  | bigdiv_try_2 : forall t1 t2 v,
      bigred t1 (beh_exn v) ->
      bigdiv (trm_app t2 v) ->
      bigdiv (trm_try t1 t2)
  | bigdiv_raise_1 : forall t1,
      bigdiv t1 ->
      bigdiv (trm_raise t1).

(** Auxiliary *)

Definition terminates t := exists b, bigred t b.

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Induction principle on the height of a derivation *)

(** Ideally, would be automatically generated by Coq *)

Section BigredInd.

Inductive bigredh : nat -> trm -> beh -> Prop :=
  | bigredh_var : forall n x,
      bigredh (S n) (trm_var x) beh_err
  | bigredh_val : forall n v,
      bigredh (S n) v v
  | bigredh_abs : forall n x t,
      bigredh (S n) (trm_abs x t) (val_clo x t)
  | bigredh_app : forall n t1 t2 x t3 v2 b,
      bigredh n t1 (val_clo x t3) ->
      bigredh n t2 v2 ->
      bigredh n (subst x v2 t3) b ->
      bigredh (S n) (trm_app t1 t2) b
  | bigredh_app_abort_1 : forall n b t1 t2,
      abort b ->
      bigredh n t1 b ->
      bigredh (S n) (trm_app t1 t2) b
  | bigredh_app_abort_2 : forall n b t1 t2 v1,
      abort b ->
      bigredh n t1 v1 ->
      bigredh n t2 b ->
      bigredh (S n) (trm_app t1 t2) b
  | bigredh_app_2_err : forall n t1 t2 v1 v2,
      ~ isclo v1 ->
      bigredh n t1 v1 ->
      bigredh n t2 v2 ->
      bigredh (S n) (trm_app t1 t2) beh_err
  | bigredh_try : forall n t1 t2 v1,
      bigredh n t1 v1 ->
      bigredh (S n) (trm_try t1 t2) v1
  | bigredh_try_1 : forall n t1 t2 o2 v,
      bigredh n t1 (beh_exn v)->
      bigredh n (trm_app t2 v) o2 ->
      bigredh (S n) (trm_try t1 t2) o2
  | bigredh_try_1_err : forall n t1 t2,
      bigredh n t1 beh_err ->
      bigredh (S n) (trm_try t1 t2) beh_err
  | bigredh_raise : forall n t1 v1,
      bigredh n t1 v1 ->
      bigredh (S n) (trm_raise t1) (beh_exn v1)
  | bigredh_raise_abort_1 : forall n b t1,
      abort b ->
      bigredh n t1 b ->
      bigredh (S n) (trm_raise t1) b
  | bigredh_rand : forall n k,
      (ParamDeterministic -> k = 0) ->
      bigredh (S n) trm_rand (val_int k).

Hint Constructors bigred bigredh.
Hint Extern 1 (_ < _) => math.

Lemma bigredh_lt : forall n n' t b,
  bigredh n t b -> n < n' -> bigredh n' t b.
Proof.
  introv H. gen n'. induction H; introv L;
   (destruct n' as [|n']; [ false; math | autos* ]).
Qed.

Lemma bigred_bigredh : forall t b,
  bigred t b -> exists n, bigredh n t b.
Proof. hint bigredh_lt. introv H. induction H; try induct_height. Qed.

End BigredInd.

(************************************************************)
(* ** Determinacy property *)

Section Det.

Lemma abort_ret_false : forall v,
  abort (beh_ret v) -> False.
Proof. introv H. inverts H. Qed.

Hint Resolve abort_ret_false.
Hint Constructors isclo.

Lemma bigred_deterministic : forall t b1 b2,
  bigred t b1 -> bigred t b2 -> b1 = b2.
Proof.
  introv R. gen b2. induction R; introv D; inverts~ D.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR. inverts~ M. false*.
  forwards* M: IHR. inverts~ M. false*.
  forwards* M: IHR. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false* H.
  forwards* M: IHR1. inverts~ M. false*.
  forwards* M: IHR1. inverts~ M.
   forwards* M: IHR2. inverts~ M. false*.
  forwards* M: IHR. inverts~ M.
  forwards* M: IHR1. inverts~ M.
  forwards* M: IHR1. inverts~ M.
  forwards* M: IHR1. inverts~ M.
  forwards* M: IHR. inverts~ M.
  forwards* M: IHR. inverts~ M.
  forwards* M: IHR. inverts M. false*.
  forwards* M: IHR. inverts~ M. false*.
  rewrite Deterministic in *. rewrite~ H. rewrite~ H0.
Qed.

Lemma bigred_bigdiv_exclusive : forall t b,
  bigred t b -> bigdiv t -> False.
Proof.
  lets K: bigred_deterministic.
  introv R. induction R; introv D; inverts D; autos*.
  forwards* M: K R1. inverts~ M.
   forwards* M: K R2. inverts~ M.
  forwards* M: K R. inverts~ M. false*.
  forwards* M: K R. inverts~ M. false*.
  forwards* M: K R1. inverts~ M.
   forwards* M: K R2. inverts~ M. false*.
  forwards* M: K R1. inverts~ M.
  forwards* M: K R. inverts~ M.
  forwards* M: K R1. inverts~ M.
  forwards* M: K R. inverts~ M.
Qed.

End Det.

(************************************************************)
(* ** Full coverage property *)

Section Full.

(** Note: could be automated better using more advanced tactics *)

Hint Constructors bigred abort.
Hint Unfold terminates.

Lemma abort_or_val : forall b,
  abort b \/ exists v, b = beh_ret v.
Proof. intros. destruct* b. Qed.

Lemma not_terminates_bigdiv : forall t,
  ~ terminates t -> bigdiv t.
Proof.
  cofix IH. introv N. destruct t; try solve [ false* N ].
  tests (b1&R1) C1: (terminates t1).
    lets [A1|(v1&E1)]: (abort_or_val b1).
      false* N.
      subst. tests (b2&R2) C2: (terminates t2).
        lets [A2|(v2&E2)]: (abort_or_val b2).
          false* N.
          subst. tests C3: (~ isclo v1).
            false* N.
            inverts C3. tests (b4&R4) C4: (terminates (subst x v2 t3)).
              false *N.
              applys* bigdiv_app_3.
        applys* bigdiv_app_2.
    applys* bigdiv_app_1.
  tests (b1&R1) C1: (terminates t1).
    destruct b1 as [v1|v| ].
      false* N.
      tests (b2&R2) C2: (terminates (trm_app t2 v)).
        false* N.
        applys* bigdiv_try_2.
      false* N.
    applys* bigdiv_try_1.
  tests (b1&R1) C1: (terminates t).
    lets [A1|(v1&E1)]: (abort_or_val b1).
      false* N.
      subst. false* N.
    applys* bigdiv_raise_1.
Qed.

End Full.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.fta.KneserLemma.
Require Export CoRN.fta.CPoly_Shift.
Require Export CoRN.fta.CPoly_Contin1.
From Coq Require Import Lia.

(**
* FTA for regular polynomials
** The Kneser sequence
%\begin{convention}% Let [n] be a positive natural number.
%\end{convention}%
*)

Section Seq_Exists.
Variable n : nat.
Hypothesis lt0n : 0 < n.

(**
%\begin{convention}% Let [qK] be a real between 0 and 1, with
[[
forall (p : CCX), (monic n p) -> forall (c : IR), ((AbsCC (p![0])) [<] c) ->
 {z:CC | ((AbsCC z) [^]n [<] c) | ((AbsCC (p!z)) [<] qK[*]c)}.
]]
Let [p] be a monic polynomial over the complex numbers with degree
[n], and let [c0] be such that [(AbsCC (p![0])) [<] c0].
%\end{convention}%
*)

Section Kneser_Sequence.
Variable qK : IR.
Variable zltq : [0] [<=] qK.
Variable qlt1 : qK [<] [1].
Hypothesis q_prop : forall p : cpoly CC, monic n p -> forall c : IR,
AbsCC p ! [0] [<] c -> {z : CC | AbsCC z[^]n [<=] c | AbsCC p ! z [<] qK[*]c}.

Variable p : cpoly CC.
Hypothesis mp : monic n p.

Variable c0 : IR.
Hypothesis p0ltc0 : AbsCC p ! [0] [<] c0.

Record Knes_tup : Type :=
 {z_el    :> CC;
  c_el    :  IR;
  Kt_prop : AbsCC p ! z_el [<] c_el}.

Record Knes_tupp (tup : Knes_tup) : Type :=
  {Kntup     :> Knes_tup;
   Ktp_prop  :  c_el Kntup [=] qK[*]c_el tup;
   Ktpp_prop :  AbsCC (Kntup[-]tup) [^]n [<=] c_el tup}.

Definition Knes_fun : forall tup : Knes_tup, Knes_tupp tup.
Proof.
 intro tup.
 elim tup.
 intros z c pzltc.
 cut (AbsCC (Shift z p) ! [0] [<] c).
  intro Hsh.
  generalize (q_prop (Shift z p) (Shift_monic z p n mp) c Hsh).
  intro Hex.
  elim Hex.
  intros z'; intros.
  cut (AbsCC p ! (z'[+]z) [<] qK[*]c).
   intro HH.
   apply (Build_Knes_tupp (Build_Knes_tup z c pzltc) (Build_Knes_tup (z'[+]z) (qK[*]c) HH)).
    simpl in |- *; algebra.
   simpl in |- *; apply leEq_wdl with (AbsCC z'[^]n).
    assumption.
   apply (nexp_wd IR (AbsCC z') (AbsCC (z'[+]z[-]z)) n).
   apply AbsCC_wd.
   rational.
  apply less_wdl with (AbsCC (Shift z p) ! z').
   assumption.
  apply AbsCC_wd.
  apply Shift_apply.
 apply less_wdl with (AbsCC p ! z).
  assumption.
 generalize (Shift_apply z p [0]).
 intro H3.
 apply eq_symmetric_unfolded.
 apply AbsCC_wd.
 apply eq_transitive_unfolded with p ! ([0][+]z).
  assumption.
 algebra.
Defined.

Fixpoint Knes_fun_it (i : nat) : Knes_tup :=
  match i with
  | O   => Build_Knes_tup [0] c0 p0ltc0
  | S j => Knes_fun (Knes_fun_it j):Knes_tup
  end.

Definition sK := Knes_fun_it:nat -> CC.

Lemma sK_c : forall tup : Knes_tup, c_el (Knes_fun tup) [=] qK[*]c_el tup.
Proof.
 intro tup.
 generalize (Ktp_prop tup (Knes_fun tup)).
 auto.
Qed.

Lemma sK_c0 : forall i : nat, c_el (Knes_fun_it i) [=] qK[^]i[*]c0.
Proof.
 simple induction i.
  simpl in |- *.
  rational.
 intros.
 simpl in |- *.
 generalize (sK_c (Knes_fun_it n0)).
 intro H1.
 apply eq_transitive_unfolded with (qK[*]c_el (Knes_fun_it n0)).
  assumption.
 rstepr (qK[*] (nexp IR n0 qK[*]c0)).
 apply mult_wdr.
 exact H.
Qed.

Lemma sK_prop1 : forall i : nat, AbsCC p ! (sK i) [<=] qK[^]i[*]c0.
Proof.
 unfold sK in |- *.
 simple induction i.
  simpl in |- *.
  rstepr c0.
  apply less_leEq; exact p0ltc0.
 intros.
 simpl in |- *.
 generalize (Kt_prop (Knes_fun (Knes_fun_it n0))).
 intro H2.
 apply leEq_wdr with (c_el (Knes_fun (Knes_fun_it n0))).
  apply less_leEq; assumption.
 generalize (sK_c (Knes_fun_it n0)).
 intro H3.
 eapply eq_transitive_unfolded.
  apply H3.
 generalize (sK_c0 n0).
 intro H4.
 rstepr (qK[*] (nexp IR n0 qK[*]c0)).
 apply mult_wdr.
 exact H4.
Qed.

Lemma sK_it : forall tup : Knes_tup, AbsCC (Knes_fun tup[-]tup) [^]n [<=] c_el tup.
Proof.
 intro tup.
 generalize (Ktpp_prop tup (Knes_fun tup)).
 auto.
Qed.

Lemma sK_prop2 : forall i : nat, AbsCC (sK (S i) [-]sK i) [^]n [<=] qK[^]i[*]c0.
Proof.
 unfold sK in |- *.
 simpl in |- *.
 intro i.
 generalize (sK_it (Knes_fun_it i)).
 intro H0.
 eapply leEq_wdr.
  apply H0.
 exact (sK_c0 i).
Qed.

End Kneser_Sequence.

Section Seq_Exists_Main.

(**
** Main results
*)

Lemma seq_exists : {q : IR | [0] [<=] q | q [<] [1] and (forall p : cpoly CC,
 monic n p -> forall c : IR, AbsCC p ! [0] [<] c -> {s : nat -> CC | forall i,
  AbsCC p ! (s i) [<=] q[^]i[*]c /\ AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c})}.
Proof.
 elim (Kneser n lt0n).
 intros q; intros H H0.
 exists q.
  assumption.
 inversion_clear H0.
 rename X0 into H2.
 split. assumption.
  intros p mp c pzltc.
 exists (sK q H2 p mp c pzltc).
 split.
  exact (sK_prop1 q H2 p mp c pzltc i).
 exact (sK_prop2 q H2 p mp c pzltc i).
Qed.

End Seq_Exists_Main.

End Seq_Exists.

Section N_Exists.

Variable n : nat.
Hypothesis lt0n : 0 < n.
Variable q : IR.
Hypothesis zleq : [0] [<=] q.
Hypothesis qlt1 : q [<] [1].
Variable c : IR.
Hypothesis zltc : [0] [<] c.
(* begin hide *)
Let q_ : q[-][1] [#] [0] := qltone IR q qlt1.
(* end hide *)
Variable e : IR.
Variable zlte : [0] [<] e.

Lemma N_exists : {N : nat | forall m, N <= m -> (q[^]m[-]q[^]N[/] q[-][1][//]q_) [*]c [<=] e}.
Proof.
 cut ([0] [<] [1][-]q).
  intro H0.
  cut ([1][-]q [#] [0]).
   intro H3.
   cut (c [#] [0]).
    intro H1.
    cut ([0] [<] ([1][-]q) [*] (e[/] c[//]H1)).
     intro H2.
     elim (qi_yields_zero q zleq qlt1 (([1][-]q) [*] (e[/] c[//]H1)) H2).
     intros N HN.
     exists N.
     intros m leNm.
     rstepl ((q[^]N[-]q[^]m[/] [1][-]q[//]H3) [*]c).
     apply shift_mult_leEq with H1.
      assumption.
     apply shift_div_leEq'.
      assumption.
     apply leEq_transitive with (q[^]N).
      rstepl ([0][+] (q[^]N[-]q[^]m)).
      apply shift_plus_leEq.
      rstepr (q[^]m).
      apply nexp_resp_nonneg.
      assumption.
     assumption.
    apply mult_resp_pos.
     assumption.
    apply div_resp_pos.
     assumption.
    assumption.
   apply ap_symmetric_unfolded.
   apply less_imp_ap.
   assumption.
  apply ap_symmetric_unfolded.
  apply less_imp_ap.
  assumption.
 apply shift_less_minus.
 rstepl q.
 assumption.
Qed.

End N_Exists.

Section Seq_is_CC_CAuchy.

(**
** The Kneser sequence is Cauchy in [CC] *)

Variable n : nat.
Hypothesis lt0n : 0 < n.
Variable q : IR.
Hypothesis zleq : [0] [<=] q.
Hypothesis qlt1 : q [<] [1].
Variable c : IR.
Hypothesis zltc : [0] [<] c.

(** %\begin{convention}% Let:
 - [q_] prove [q[-][1] [#] [0]]
 - [nrtq := NRoot q n]
 - [nrtc := Nroot c n]
 - [nrtqlt1] prove [nrtq [<] [1]]
 - [nrtq_] prove [nrtq[-][1] [#] [0]]

%\end{convention}% *)

(* begin hide *)
Let q_ : q[-][1] [#] [0] := qltone IR q qlt1.
Let nrtq : IR := NRoot zleq lt0n.
Let nrtc : IR := NRoot (less_leEq _ _ _ zltc) lt0n.
Let nrtqlt1 : nrtq [<] [1] := NRoot_less_one q zleq n lt0n qlt1.
Let nrtq_ : nrtq[-][1] [#] [0] := qltone IR nrtq nrtqlt1.
(* end hide *)

Lemma zlt_nrtq : [0] [<=] nrtq.
Proof.
 unfold nrtq; apply NRoot_nonneg.
Qed.

Lemma zlt_nrtc : [0] [<] nrtc.
Proof.
 unfold nrtc; apply NRoot_pos; auto.
Qed.

Lemma nrt_pow : forall i (H : [0] [<=] q[^]i[*]c), NRoot H lt0n [=] nrtq[^]i[*]nrtc.
Proof.
 intros.
 apply root_unique with n.
    apply NRoot_nonneg.
   apply mult_resp_nonneg.
    apply nexp_resp_nonneg. exact zlt_nrtq.
    apply less_leEq. exact zlt_nrtc.
   auto.
 astepl (q[^]i[*]c).
 astepr ((nrtq[^]i) [^]n[*]nrtc[^]n).
 astepr (nrtq[^] (i * n) [*]nrtc[^]n).
 rewrite mult_comm.
 astepr ((nrtq[^]n) [^]i[*]nrtc[^]n).
 unfold nrtq in |- *. unfold nrtc in |- *.
 apply bin_op_wd_unfolded.
  apply un_op_wd_unfolded.
  algebra.
 algebra.
Qed.

Lemma abs_pow_ltRe : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) ->
 forall i, AbsIR (Re (s (S i)) [-]Re (s i)) [<=] nrtq[^]i[*]nrtc.
Proof.
 intros s H i.
 apply leEq_wdl with (AbsIR (Re (s (S i) [-]s i))).
  apply leEq_transitive with (AbsCC (s (S i) [-]s i)).
   apply absCC_absIR_re.
  generalize (H i).
  intro Hi.
  cut ([0] [<=] q[^]i[*]c).
   intro H0.
   cut (AbsCC (s (S i) [-]s i) [<=] NRoot H0 lt0n).
    intro H1.
    apply leEq_wdr with (NRoot H0 lt0n).
     assumption.
    apply nrt_pow.
   apply power_cancel_leEq with n.
     auto with arith.
    apply NRoot_nonneg.
   apply leEq_wdr with (q[^]i[*]c).
    exact (H i).
   algebra.
  apply mult_resp_nonneg.
   apply nexp_resp_nonneg.
   assumption.
  apply less_leEq; assumption.
 apply ABSIR_wd.
 apply Re_resp_inv.
Qed.

Lemma abs_pow_ltIm : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) ->
 forall i, AbsIR (Im (s (S i)) [-]Im (s i)) [<=] nrtq[^]i[*]nrtc.
Proof.
 intros s H i.
 apply leEq_wdl with (AbsIR (Im (s (S i) [-]s i))).
  apply leEq_transitive with (AbsCC (s (S i) [-]s i)).
   apply absCC_absIR_im.
  generalize (H i).
  intro Hi.
  cut ([0] [<=] q[^]i[*]c).
   intro H0.
   cut (AbsCC (s (S i) [-]s i) [<=] NRoot H0 lt0n).
    intro H1.
    apply leEq_wdr with (NRoot H0 lt0n).
     assumption.
    apply nrt_pow.
   apply power_cancel_leEq with n.
     auto with arith.
    apply NRoot_nonneg.
   apply leEq_wdr with (q[^]i[*]c).
    exact (H i).
   algebra.
  apply mult_resp_nonneg.
   apply nexp_resp_nonneg.
   assumption.
  apply less_leEq; assumption.
 apply ABSIR_wd.
 apply Im_resp_inv.
Qed.

Lemma SublemmaRe : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall N m,
 N <= m -> AbsIR (Re (s m) [-]Re (s N)) [<=] (nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc.
Proof.
 intros s Hi N m leNm.
 elim (le_lt_eq_dec N m leNm).
  intro ltNm.
  generalize (diff_is_sum (fun j : nat => Re (s j)) N m ltNm).
  intro Hsum.
  generalize (ABSIR_wd _ _ Hsum). (* Use AbsIR_wd *)
  intro Habseq.
  apply leEq_wdl with (ABSIR (Sum N (pred m) (fun i : nat => Re (s (S i)) [-]Re (s i)))).
   2: apply eq_symmetric_unfolded; apply Habseq.
  cut (N <= S (pred m)). intro leNm'.
   (* FIXME was 2:Lia *) 2: clear nrtq_ nrtqlt1 nrtc nrtq; lia.
  generalize (triangle_SumIR N (pred m) (fun i : nat => Re (s (S i)) [-]Re (s i)) leNm').
  intro Htri.
  apply leEq_transitive with (Sum N (pred m)
    (fun i : nat => csf_fun IR IR AbsIR (Re (s (S i)) [-]Re (s i)))).
   exact Htri.
  generalize (Sum_pres_leEq (fun i : nat => AbsIR (Re (s (S i)) [-]Re (s i)))
    (fun i : nat => nrtq[^]i[*]nrtc) (abs_pow_ltRe s Hi) N ( pred m)).
  intro Hlt.
  apply leEq_transitive with (Sum N (pred m) (fun i : nat => nrtq[^]i[*]nrtc)).
   cut (N <= pred m).
    intro leNpm.
    exact (Hlt leNpm).
   generalize (S_pred m N ltNm).
   intro Heq.
   apply lt_n_Sm_le.
   rewrite <- Heq.
   assumption.
  generalize (Sum_c_exp nrtq nrtq_ N (pred m)).
  intro Hs.
  generalize (Sum_comm_scal (fun i : nat => nrtq[^]i) nrtc N (pred m)).
  intro Hs2.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply Hs2.
  apply mult_resp_leEq_rht.
   generalize (Sum_c_exp nrtq nrtq_ N (pred m)).
   intro Hs3.
   cut (S (pred m) = m).
    intro Heq.
    rewrite Heq in Hs3.
    apply eq_imp_leEq; assumption.
   generalize (S_pred m N ltNm).
   auto.
  exact (less_leEq _ _ _ zlt_nrtc).
 intro HNm.
 rewrite HNm.
 apply leEq_wdl with (AbsIR [0]).
  apply leEq_wdl with ZeroR.
   apply leEq_wdr with ZeroR.
    exact (leEq_reflexive _ _).
   rational.
  apply eq_symmetric_unfolded; exact AbsIRz_isz.
 apply ABSIR_wd.
 rational.
Qed.

Lemma SublemmaIm : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall N m,
 N <= m -> AbsIR (Im (s m) [-]Im (s N)) [<=] (nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc.
Proof.
 intros s Hi N m leNm.
 elim (le_lt_eq_dec N m leNm).
  intro ltNm.
  generalize (diff_is_sum (fun j : nat => Im (s j)) N m ltNm).
  intro HSum.
  generalize (ABSIR_wd _ _ HSum). (* Use AbsIR_wd *)
  intro Habseq.
  apply leEq_wdl with (ABSIR (Sum N (pred m) (fun i : nat => Im (s (S i)) [-]Im (s i)))).
   2: apply eq_symmetric_unfolded; apply Habseq.
  cut (N <= S (pred m)). intro leNm'.
   (* FIXME was 2:Lia *) 2: clear nrtq_ nrtqlt1 nrtc nrtq; lia.
  generalize (triangle_SumIR N (pred m) (fun i : nat => Im (s (S i)) [-]Im (s i)) leNm').
  intro Htri.
  apply leEq_transitive with (Sum N (pred m)
    (fun i : nat => csf_fun IR IR AbsIR (Im (s (S i)) [-]Im (s i)))).
   exact Htri.
  generalize (Sum_pres_leEq (fun i : nat => AbsIR (Im (s (S i)) [-]Im (s i)))
    (fun i : nat => nrtq[^]i[*]nrtc) (abs_pow_ltIm s Hi) N ( pred m)).
  intro Hlt.
  apply leEq_transitive with (Sum N (pred m) (fun i : nat => nrtq[^]i[*]nrtc)).
   cut (N <= pred m).
    intro leNpm.
    exact (Hlt leNpm).
   generalize (S_pred m N ltNm).
   intro Heq.
   apply lt_n_Sm_le.
   simpl in |- *.
   rewrite <- Heq.
   assumption.
  generalize (Sum_c_exp nrtq nrtq_ N (pred m)).
  intro Hs.
  generalize (Sum_comm_scal (fun i : nat => nrtq[^]i) nrtc N (pred m)).
  intro Hs2.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply Hs2.
  apply mult_resp_leEq_rht.
   generalize (Sum_c_exp nrtq nrtq_ N (pred m)).
   intro Hs3.
   cut (S (pred m) = m).
    intro Heq.
    rewrite Heq in Hs3.
    apply eq_imp_leEq; assumption.
   generalize (S_pred m N ltNm).
   auto.
  exact (less_leEq _ _ _ zlt_nrtc).
 intro HNm.
 rewrite HNm.
 apply leEq_wdl with (AbsIR [0]).
  apply leEq_wdl with ZeroR.
   apply leEq_wdr with ZeroR.
    exact (leEq_reflexive _ _).
   rational.
  apply eq_symmetric_unfolded; exact AbsIRz_isz.
 apply ABSIR_wd.
 rational.
Qed.

Lemma seq_is_CC_Cauchy : forall s,
 (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> CC_Cauchy_prop s.
Proof.
 unfold CC_Cauchy_prop in |- *.
 split.
  (* Prove (Cauchy_prop (seq_re s)) *)
  unfold Cauchy_prop in |- *.
  intros e zlte.
  generalize (N_exists (*n lt0n*)  nrtq zlt_nrtq nrtqlt1 nrtc zlt_nrtc e zlte).
  intro Hex.
  elim Hex.
  intros N HN.
  exists N.
  intros m leNm.
  apply AbsIR_imp_AbsSmall.
  generalize (SublemmaRe s H N m leNm).
  intro H2.
  generalize (HN m leNm).
  intro H3.
  eapply leEq_transitive.
   2: apply H3.
  rstepr ((nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc).
  exact H2.
 (* Prove (Cauchy_prop (seq_im s)) *)
 unfold Cauchy_prop in |- *.
 intros e zlte.
 generalize (N_exists (*n lt0n*)  nrtq zlt_nrtq nrtqlt1 nrtc zlt_nrtc e zlte).
 intro Hex.
 elim Hex.
 intros N HN.
 exists N.
 intros m leNm.
 apply AbsIR_imp_AbsSmall.
 generalize (SublemmaIm s H N m leNm).
 intro H2.
 generalize (HN m leNm).
 intro H3.
 eapply leEq_transitive.
  2: apply H3.
 rstepr ((nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc).
 exact H2.
Qed.

End Seq_is_CC_CAuchy.

Lemma FTA_monic : forall (p : cpoly CC) (n : nat),
 0 < n -> monic n p -> {c : CC | p ! c [=] [0]}.
Proof.
 intros p n H0n mon.
 generalize (seq_exists n H0n).
 intro H.
 elim H.
 intros q qnonneg Hq1.
 elim Hq1.
 intros qlt10 Hq2.
 generalize (Hq2 p mon).
 intro Hq3.
 cut ([0] [<] AbsCC p ! [0][+][1]).
  intro Hp.
  elim (Hq3 (AbsCC p ! [0][+][1])).
   intros s Hs.
   cut (forall i : nat, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*] (AbsCC p ! [0][+][1])).
    intro Hs2.
    cut (CC_Cauchy_prop s).
     intro Hs3.
     exists (LimCC (Build_CC_CauchySeq s Hs3)).
     apply CC_SeqLimit_uniq with (fun n : nat => p ! (s n)).
      exact (poly_pres_lim (fun x : CC => p ! x) (contin_polyCC p) (Build_CC_CauchySeq s Hs3)).
     generalize (seq_yields_zero q qnonneg qlt10 (AbsCC p ! [0][+][1]) Hp (fun n0 : nat => p ! (s n0))).
     intro H0. apply H0.
     intro i. generalize (Hs i).
     intro H1; inversion_clear H1; assumption.
    exact (seq_is_CC_Cauchy n H0n q qnonneg qlt10 (AbsCC p ! [0][+][1]) Hp s Hs2).
   intro i; generalize (Hs i); intro Ha; elim Ha; intros; assumption.
  exact (less_plusOne _ (AbsCC p ! [0])).
 apply zero_lt_posplus1.
 apply AbsCC_nonneg.
Qed.

Lemma FTA_reg : forall (p : cpoly CC) (n : nat),
 0 < n -> degree n p -> {c : CC | p ! c [=] [0]}.
Proof.
 intros p n H H0.
 elim (FTA_monic (poly_norm _ p n H0) n); auto.
  intros. exists x.
  apply poly_norm_apply with n H0; auto.
 apply poly_norm_monic; auto.
Qed.