Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.Structures.
Require Export Parser.ProductiveFun.
Require Export Parser.ProductiveInd.
Require Export Parser.NullableFun.
Require Export Parser.HasConflictInd.
Require Export Parser.ShouldNotFollowFun.
Require Export Parser.SubSyntax.
Require Export Parser.Prefix.

Opaque nullable_fun.
Opaque productive_fun.
Opaque should_not_follow_fun.
Opaque first_fun.

Inductive visitable (x: id): forall A, Syntax A -> Prop :=
| VDisjL:
    forall A (s1 s2: Syntax A),
      visitable x A s1 ->
      visitable x A (Disjunction s1 s2)
| VDisjR:
    forall A (s1 s2: Syntax A),
      visitable x A s2 ->
      visitable x A (Disjunction s1 s2)
| VSeqL:
    forall A1 A2 (s1: Syntax A1) (s2: Syntax A2) ts v,
      visitable x A1 s1 ->
      matches s2 ts v ->
      visitable x (A1 * A2) (Sequence s1 s2)
| VSeqR:
    forall A1 A2 (s1: Syntax A1) (s2: Syntax A2) v,
      matches s1 [] v ->
      visitable x A2 s2 ->
      visitable x (A1 * A2) (Sequence s1 s2)
| VMap:
    forall A B (f: A -> B) g (s: Syntax A),
      visitable x A s ->
      visitable x B (Map f g s)
| VVar:
    visitable x (get_type x) (Var x)
| VRec:
    forall y,
      visitable x (get_type y) (e y) ->
      visitable x (get_type y) (Var y)
.

Arguments visitable x { A }.

Hint Constructors visitable: visitable.

Definition left_recursive (x: id) := visitable x (e x).

Program Definition visitable_inversion { A } x (s: Syntax A) (H: visitable x s) :=
  match H in visitable _ s' return
    match s' return Prop with
    | Disjunction s1' s2' => visitable x s1' \/ visitable x s2'
    | Sequence s1' s2' =>
      (visitable x s1' /\ exists ts v, matches s2' ts v) \/
      (exists v, matches s1' [] v /\ visitable x s2')
    | Map f g s' => visitable x s'
    | Var y => x = y \/ visitable x (e y)
    | _ => True
    end
  with
  | VDisjL _ _ _ _ _ => _
  | _ => _
  end.

Solve Obligations with eauto 6.

Fail Next Obligation. (* no more obligations visitable_inversion *)

Ltac visitable_inversion :=
  match goal with
  | H: visitable _ (Disjunction _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Sequence _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Map _ _ _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  | H: visitable _ (Var _) |- _ =>
    poseNew (Mark H "visitable_inversion");
    pose proof (visitable_inversion _ _ H)
  end.

Lemma visitable_extend:
  forall A (s: Syntax A) x ts v,
    visitable x s ->
    matches (e x) ts v ->
    exists ts' v, matches s (ts ++ ts') v.
Proof.
  intros.
  revert v ts H0.
  induction H;
    repeat light || instantiate_any ||
      options || destruct_match;
    eauto 6 with matches.
Qed.

Ltac visitable_extend :=
  match goal with
  | H1: visitable ?x ?s,
    H2: matches (e ?x) _ _ |- _ =>
    poseNew (Mark s "visitable_extend");
    pose proof (visitable_extend _ _ _ _ _ H1 H2)
  end.

Lemma visitable_non_empty_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v tsx vx,
      matches_without [ x ] s (t :: ts) v ->
      matches (e x) (t :: tsx) vx ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || visitable_inversion || inversion_solve || invert_constructor_equalities ||
           visitable_extend || invert_matches || app_cons_destruct;
    eauto with has_conflict_ind.

  - eapply has_conflict_disj_first;
      repeat light || options || eapply first_fun_complete || destruct_match;
      eauto using matches_incl, incl_nil.

  - eapply has_conflict_disj_first;
      repeat light || options || eapply first_fun_complete || destruct_match;
      eauto using matches_incl, incl_nil.

  - eapply has_conflict_seq_follow;
      repeat light || eapply first_fun_complete;
      eauto using should_not_follow_fun_first, matches_incl, incl_nil.

  - repeat light || invert_constructor_equalities || rewrite <- app_assoc in * ||
           options || nullable_fun_spec || destruct_match;
     eauto using
       should_not_follow_fun_first,
       first_fun_complete,
       has_conflict_seq_follow,
       matches_incl, incl_nil.
Qed.

Lemma visitable_prefix_conflict:
  forall x A (s: Syntax A) t ts v,
    visitable x s ->
    prefix s (e x) ->
    matches_without [ x ] s (t :: ts) v ->
    has_conflict_ind s.
Proof.
  intros.
  repeat prefix || light;
    eauto using visitable_non_empty_conflict';
    eauto using matches_incl, incl_nil.
Qed.

Lemma visitable_not_nullable_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v1 v2,
      prefix s (e x) ->
      matches s (t :: ts) v1 ->
      (forall v, ~ matches s [] v) ->
      matches (e x) [] v2 ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || prefix_sub || nullable_fun_spec || options || destruct_match ||
           visitable_extend || prefix || app_cons_destruct || invert_constructor_equalities;
    eauto with has_conflict_ind matches.

  - pose proof (visitable_extend _ _ _ _ _ H H7); lights.
    apply has_conflict_disj_first with (get_kind t);
    repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - pose proof (visitable_extend _ _ _ _ _ H H8); lights.
    apply has_conflict_disj_first with (get_kind t);
    repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - pose proof (visitable_extend _ _ _ _ _ H H13); lights.
    apply has_conflict_seq_follow with (get_kind t);
      repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
      eauto.

  - destruct xs2 eqn:XS2; lights;
      eauto with has_conflict_ind matches.
    destruct ts' eqn:TSP; repeat light || prefix_sub || prefix.
    + pose proof (visitable_extend _ _ _ _ _ H H5); lights.
      apply has_conflict_seq_follow with (get_kind t);
        repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
        eauto.
    + destruct (nullable_fun s1) eqn:N1;
        repeat light || nullable_fun_spec || prefix_sub || prefix.
      * pose proof (visitable_extend _ _ _ _ _ H H5); lights.
        apply has_conflict_seq_follow with (get_kind t);
          repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
          eauto.
      * apply has_conflict_seq_l.
        eapply_any;
          repeat light || nullable_fun_spec; eauto.

  - destruct (nullable_fun s1) eqn:N1;
      repeat light || nullable_fun_spec || prefix_sub || prefix.
    destruct (nullable_fun s2) eqn:N2;
      repeat light || nullable_fun_spec || prefix_sub || prefix;
      eauto with matches exfalso.
    destruct ts'; repeat light || nullable_fun_spec.
    apply has_conflict_seq_r.
    eapply_any;
      repeat light || nullable_fun_spec; eauto.

  - eauto with matches exfalso.
  - apply has_conflict_var.
    eapply_any; lights;
      eauto using prefix_var with matches.
Qed.

Lemma visitable_not_nullable_conflict:
  forall x A (s: Syntax A) v,
    visitable x s ->
    prefix s (e x) ->
    (forall v, ~ matches s [] v) ->
    matches (e x) [] v ->
    has_conflict_ind s.
Proof.
  repeat light || visitable_extend.
  destruct ts';
    repeat light; eauto using visitable_not_nullable_conflict' with exfalso.
Qed.

Lemma visitable_not_first_conflict':
  forall x A (s: Syntax A),
    visitable x s ->
    forall k ts v,
      prefix s (e x) ->
      matches s ts v ->
      ~ In k (first_fun s) ->
      In k (first_fun (e x)) ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || prefix_sub || options || destruct_match || nullable_fun_spec ||
           visitable_extend || prefix || app_cons_destruct || invert_constructor_equalities;
    eauto with has_conflict_ind matches first_fun exfalso;
    eauto 6 with has_conflict_ind prefix first_fun.
Qed.

Lemma visitable_not_first_conflict:
  forall x A (s: Syntax A),
    visitable x s ->
    forall t ts v,
      prefix s (e x) ->
      ~ In (get_kind t) (first_fun s) ->
      matches (e x) (t :: ts) v ->
      has_conflict_ind s.
Proof.
  repeat light || visitable_extend;
    eauto using first_fun_complete, visitable_not_first_conflict'.
Qed.

Lemma subsyntax_prefix:
  forall A1 A2 (s1: Syntax A1) (s2: Syntax A2),
    subsyntax s1 s2 ->
    prefix s1 s2.
Proof.
  unfold subsyntax, prefix, accepts;
    repeat light || exists [] || lists; eauto.
Qed.

Lemma subsyntax_prefix_seq_l:
  forall A1 A2 A (s1: Syntax A1) (s2: Syntax A2) (s: Syntax A) ts v,
    subsyntax (Sequence s1 s2) s ->
    matches s2 ts v ->
    prefix s1 s.
Proof.
  unfold subsyntax, accepts, prefix; lights;
    eauto with matches.
Qed.

Lemma visitable_subsyntax_conflict:
  forall x A (s: Syntax A),
    visitable x s ->
    forall ts v,
      matches_without [ x ] s ts v ->
      subsyntax s (e x) ->
      has_conflict_ind s.
Proof.
  induction 1;
    repeat light || invert_matches || inversion_solve || nullable_fun_spec ||
           prefix_sub || invert_constructor_equalities;
    eauto with has_conflict_ind subsyntax.

  - destruct ts; lights.
    + decide_nullable_one s1;
        repeat light || nullable_fun_spec.
      * eapply has_conflict_disj_nullable;
          repeat light || options || destruct_match || nullable_fun_spec;
          eauto using matches_incl, incl_nil.
      * apply has_conflict_disj_l.
        unshelve epose proof (H1 [] _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        apply visitable_not_nullable_conflict with x v0;
          repeat light; eauto using subsyntax_prefix with subsyntax.
    + destruct (in_dec kind_eq_dec (get_kind t) (first_fun s1)).
      * eapply has_conflict_disj_first;
          repeat light || apply_anywhere first_fun_sound || rewrite first_fun_spec ||
                 invert_constructor_equalities;
          eauto 6 using matches_incl, incl_nil with lights.
      * apply has_conflict_disj_l.
        unshelve epose proof (H1 (t :: ts) _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        eapply visitable_not_first_conflict;
          eauto using subsyntax_prefix with subsyntax.

  - destruct ts; lights.
    + decide_nullable_one s2;
        repeat light || nullable_fun_spec.
      * eapply has_conflict_disj_nullable;
          repeat light || options || destruct_match || nullable_fun_spec;
          eauto using matches_incl, incl_nil.
      * apply has_conflict_disj_r.
        unshelve epose proof (H1 [] _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        apply visitable_not_nullable_conflict with x v0;
          repeat light; eauto using subsyntax_prefix with subsyntax.
    + destruct (in_dec kind_eq_dec (get_kind t) (first_fun s2)).
      * eapply has_conflict_disj_first;
          repeat light || apply_anywhere first_fun_sound || rewrite first_fun_spec ||
                 invert_constructor_equalities;
          eauto 6 using matches_incl, incl_nil with lights.
      * apply has_conflict_disj_r.
        unshelve epose proof (H1 (t :: ts) _);
          unfold accepts in *; eauto using matches_incl, incl_nil with matches;
            lights.
        eapply visitable_not_first_conflict;
          eauto using subsyntax_prefix with subsyntax.

  - decide_nullable_one s2;
      repeat light || nullable_fun_spec || unshelve eauto with has_conflict_ind subsyntax.

    destruct xs2; lights; eauto using matches_incl, incl_nil with exfalso.
    destruct xs1; lights; eauto using matches_incl, incl_nil with exfalso.

    + unshelve epose proof (H2 (t :: xs2) _);
        unfold accepts in *; lights; eauto using matches_incl, incl_nil with matches.

      visitable_extend; lights.
      eapply has_conflict_seq_follow;
        repeat light || eapply first_fun_complete || eapply should_not_follow_fun_first;
        eauto with matches.

    + repeat light || productive_fun_spec.
      apply has_conflict_seq_l.
      eapply visitable_prefix_conflict;
        eauto using subsyntax_prefix_seq_l.
Qed.

Lemma self_visitable_conflict:
  forall x ts v,
    matches (Var x) ts v ->
    visitable x (e x) ->
    has_conflict_ind (Var x).
Proof.
  repeat light || invert_matches || matches_forget_x.
  eauto using has_conflict_var, visitable_subsyntax_conflict
    with visitable matches subsyntax has_conflict_ind.
Qed.

Lemma productive_left_recursive_not_ll1:
  forall x,
    productive_ind (Var x) ->
    left_recursive x ->
    ~ ll1_ind (Var x).
Proof.
  unfold ll1_ind, left_recursive; repeat light || rewrite productive_ind_correct in *;
    eauto using self_visitable_conflict.
Qed.


(*|
###########################################
Unable to find an instance for the variable
###########################################

:Link: https://stackoverflow.com/q/8874951
|*)

(*|
Question
********

Context: I'm working on exercises in `Software Foundations
<http://www.cis.upenn.edu/~bcpierce/sf/>`__.

.. coq:: none
|*)

Fixpoint evenb (n : nat) : bool :=
  match n with
  | 0 => true
  | 1 => false
  | S (S m) => evenb m
  end.

(*||*)

Theorem neg_move : forall x y : bool,
    x = negb y -> negb x = y.
Proof. Admitted.

Theorem evenb_n__oddb_Sn : forall n : nat,
    evenb n = negb (evenb (S n)).
Proof.
  intros n. induction n as [| n'].
  - simpl. reflexivity.
  - Fail rewrite -> neg_move. (* .fails *)

(*| Before the last line, my subgoal is this: |*)

    Show. (* .unfold .goals *)

(*| And I want to transform it into this: |*)

    symmetry. (* .none *) apply neg_move. (* .none *) symmetry. (* .none *)
    Show. (* .unfold .goals *)
    Undo 3. (* .none *)

(*|
When I try to step through ``rewrite -> neg_move``, however, it
produces this error:
|*)

    Fail rewrite -> neg_move. (* .unfold .messages *)

(*|
I'm sure this is really simple, but what am I doing wrong? (Please
don't give anything away for solving ``evenb_n__oddb_Sn``, unless I'm
doing it completely wrong).
|*)

(*|
Answer
******

As danportin mentioned, Coq is telling you that it does not know how
to instantiate ``y``. Indeed, when you do ``rewrite -> neg_move``, you
ask it to replace some ``negb x`` by a ``y``. Now, what ``y`` is Coq
supposed to use here? It cannot figure it out.

One option is to instantiate ``y`` explicitly upon rewriting:

.. code-block:: coq

    rewrite -> neg_move with (y:=some_term).

This will perform the rewrite and ask you to prove the premises, here
it will add a subgoal of the form ``x = negb some_term``.

Another option is to specialize ``neg_move`` upon rewriting:

.. code-block:: coq

    rewrite -> (neg_move _ _ H)

Here ``H`` must be a term of type ``some_x = negb some_y``. I put two
wildcards for the ``x`` and the ``y`` parameters of ``neg_move`` since
Coq is able to infer them from ``H`` as being ``some_x`` and
``some_y`` respectively. Coq will then try to rewrite an occurence of
``negb some_x`` in your goal with ``some_y``. But you first need to
get this ``H`` term in your hypotheses, which might be some additional
burden...

(Note that the first option I gave you should be equivalent to
``rewrite -> (neg_move _ some_term)``)

Another option is ``erewrite -> negb_move``, which will add
uninstantiated variables that will look like ``?x`` and ``?y``, and
try to do the rewrite. You will then have to prove the premise, which
will look like ``(evenb (S (S n'))) = negb ?y``, and hopefully in the
process of solving this subgoal, Coq will find out what ``?y`` should
have been from the start (there are some restrictions though, and some
problems may arise is Coq solves the goal without figuring out what
``?y`` must be).

----

However, for your particular problem, it is quite easier:
|*)

    Show. (* .unfold .goals *)
    symmetry.
    Show. (* .unfold .goals *)
    apply neg_move.
    Show. (* .unfold .goals *)

(*|
And that's what you wanted (backwards, do another ``symmetry.`` if you
care).
|*)


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

#
A lew lemmas for common reduction case
used several times in the global lemmas

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".
Add LoadPath "..\controlBlock\".
Add LoadPath "..\inputBuffers\".
Add LoadPath "..\outputBuffers\".
Add LoadPath "..\memoryBlocks\".

Require Import dtrTransform relationPred globalInv globalStep inputLib controlLib outputLib memoryLib.

Set Implicit Arguments.

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

(* At least 2 buses in a triplicated version are correct (equal to the bus argument) *)
(* Used in the main lemmas and the final correctness property                        *)

Inductive atleast2 : forall S, {|S|} -> {|S#(S#S)|} -> Prop :=
| Al2_1 : forall S (s t:{|S|}), atleast2 s {s,{s,t}}
| Al2_2 : forall S (s t:{|S|}), atleast2 s {s,{t,s}}
| Al2_3 : forall S (s t:{|S|}), atleast2 s {t,{s,s}}.
Hint Constructors atleast2.

(* Cases of reduction occurring several times in step(g) reduction of the complete transformed circuit *)

Lemma case1_df : forall S T (i1 i2 i3 i4 i5: {|S|}) (o1 o2 o3 o4 o5 y z: {|T|})
                             oo3 oo4 oo5 oo6 oo7 oo8 oo9
                            (c1 c2 c3 c4 c5 c6: circuit S T)
                        (cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                 pure_bset {i1,i2,i3,i4,i5,o1,o2,o3,o4,o5,y,z}
              -> Dtr1_df (ibs1 i2 i1) (dtrOB_T z o1 z o1 y) c1 c2 c3 cc2'
              -> step c1 i1 o1 c2
              -> step c2 i2 o2 c3
              -> step c3 i3 o3 c4
              -> step c4 i4 o4 c5
              -> step c5 i5 o5 c6
              -> step cc2' i2 oo3 cc3
              -> step cc3  i3 oo4 cc3'
              -> step cc3' i3 oo5 cc4
              -> step cc4  i4 oo6 cc4'
              -> step cc4' i4 oo7 cc5
              -> step cc5  i5 oo8 cc5'
              -> step cc5' i5 oo9 cc6
              -> atleast2 o1 oo3
              /\ atleast2 o2 oo5
              /\ atleast2 o3 oo7
              /\ atleast2 o4 oo9
              /\  Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S2 S3 S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9 SS10. SimpS.
Apply step_Dtr1_df with S2 S3 SS4 in D. SimpS.
Apply step_Dtr2_d'rr'' with S3 S4 SS5 in H12. SimpS.
Apply step_Dtr3_d'rr'' with S4 SS6 in H12. SimpS.
Apply step_Dtr4_d'rr' with S5 SS7 in H12. SimpS.
Apply step_Dtr5_d'rr' with SS8 in H12. SimpS.
Apply step_Dtr0_r' with S6 SS9 in H12. SimpS.
Apply step_Dtr1_r' with SS10 in H12. SimpS. split; easy.
Qed.

Lemma case3_d'rr' : forall S T (i1 i2 i3 i4 i5: {|S|}) (o0 o1 o2 o3 o4 o5 x: {|T|})
                             oo3 oo4 oo5 oo6 oo7 oo8 oo9
                            (c1 c2 c3 c4 c5 c6: circuit S T)
                        (cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                 pure_bset {i1,i2,i3,i4,i5,o0,o1,o2,o3,o4,o5,x}
              -> Dtr3_d'rr' (ibs1 i2 i1) (dtrOB_T o1 o0 o1 o0 x) c1 c2 cc2'
              -> step c1 i1 o1 c2
              -> step c2 i2 o2 c3
              -> step c3 i3 o3 c4
              -> step c4 i4 o4 c5
              -> step c5 i5 o5 c6
              -> step cc2' i2 oo3 cc3
              -> step cc3  i3 oo4 cc3'
              -> step cc3' i3 oo5 cc4
              -> step cc4  i4 oo6 cc4'
              -> step cc4' i4 oo7 cc5
              -> step cc5  i5 oo8 cc5'
              -> step cc5' i5 oo9 cc6
              -> atleast2 o1 oo3
              /\ atleast2 o2 oo5
              /\ atleast2 o3 oo7
              /\ atleast2 o4 oo9
              /\  Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S2 S3 S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9 SS10. SimpS.
Apply step_Dtr3_d'rr'' with S3 SS4 in D. SimpS.
Apply step_Dtr4_d'rr' with S4 SS5 in H12. SimpS.
Apply step_Dtr5_d'rr' with S4 SS6 in H12. SimpS.
Apply step_Dtr0_r' with S5 SS7 in H12. SimpS.
Apply step_Dtr1_r' with S5 SS8 in H12. SimpS.
Apply step_Dtrs0 with S6 SS9 in H12. SimpS.
Apply step_Dtrs1 with S6 SS10 in H12. SimpS.
split; easy.
Qed.

Lemma case0_dr : forall S T (i0 i1 i2 i3 i4: {|S|})
                           (o o0 o1 o2 o3 o4 z1 z2: {|T|})
                           (oo1 oo2 oo3 oo4 oo5 oo6 oo7 oo8:{|T # (T # T)|})
                           (c0 c1 c2 c3 c4 c5: circuit S T)
                           (cc1' cc2 cc2' cc3 cc3' cc4 cc4' cc5: circuit S (T # (T # T))) cc1 f f' f'',
                pure_bset {i0,i1,i2,i3,i4,o,o0,o1,o2,o3,o4,z1,z2}
             -> dtr0_dr c0 c1 cc1
             -> step c0 i0 o0 c1
             -> step c1 i1 o1 c2
             -> step c2 i2 o2 c3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step (-{f}-(-{f'}-(-{f''}-dtrcore (ibs0 i0) cbs0 cc1 (dtrOB_T z1 o0 z2 o0 o)))) i1 oo1 cc1'
             -> step cc1' i1 oo2 cc2
             -> step cc2  i2 oo3 cc2'
             -> step cc2' i2 oo4 cc3
             -> step cc3  i3 oo5 cc3'
             -> step cc3' i3 oo6 cc4
             -> step cc4  i4 oo7 cc4'
             -> step cc4' i4 oo8 cc5
             -> atleast2 o0 oo2
             /\ atleast2 o1 oo4
             /\ atleast2 o2 oo6
             /\ atleast2 o3 oo8
             /\ Dtrs0 (ibs0 i4) (obs0 o4 o3) c4 c5 cc5.
Proof.
introv P D S1 S2 S3 S4 S5.
introv SS1 SS2 SS3 SS4 SS5 SS6 SS7 SS8. SimpS.
Apply invstepDTRc in SS1. SimpS.
Apply step0_tcbv in H13. SimpS.
Apply step_ibs in H12; try apply pure_buildBus. SimpS.
Apply step0_mb_dr_F with D S2 in H14.
destruct H14 as [X1|X1]; SimpS.
- Apply step_obs_sf in H15. SimpS.
  rewrite rew_orS2 in H16. Inverts H16.
  assert (D1: Dtr1_d'rf (ibs1 i1 i0) (dtrOB_T o1 z1 o1 z2 o0) c0 c1 c2
                     (globcir (true,true,true) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 z2 o0)))
      by (constructor; try easy).
  Apply step_Dtr1_d'rf with SS2 in D1. SimpS.
  Apply step_Dtr2_d'rr' with S2 S3 SS3 in H14. SimpS.
  Apply step_Dtr3_d'rr' with S3 SS4 in H14. SimpS.
  Apply step_Dtr4_d'rr' with S4 SS5 in H14. SimpS.
  Apply step_Dtr5_d'rr' with SS6 in H14. SimpS.
  Apply step_Dtr0_r' with S5 SS7 in H14. SimpS.
  Apply step_Dtr1_r' with S5 SS8 in H14. SimpS.
  split; easy.
- Apply step_obs_sf in H15. SimpS.
  case_eq (beq_buset_t z2 o0); intro E; rewrite E in H16; Inverts H16.
  + apply beq_buset_imp_eq in E. subst.
    assert (D1: Dtr1_r (ibs1 i1 i0) (dtrOB_T o1 z1 o1 o0 o0) c0 c1 c2
                     (globcir (false,false,false) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 o0 o0)))
        by (constructor; try easy).
    Apply step_Dtr1_r with SS2 in D1. SimpS.
    Apply step_Dtr0_r' with S3 SS3 in H14. SimpS.
    Apply step_Dtr1_r' with SS4 in H12. SimpS.
    Apply step_Dtrs0 with S4 SS5 in H12. SimpS.
    Apply step_Dtrs1 with SS6 in H12. SimpS.
    Apply step_Dtrs0 with S5 SS7 in H12. SimpS.
    Apply step_Dtrs1 with SS8 in H12. SimpS.
    split; easy.
  + apply dtr1_r_imp_d'r in H13.
    assert (D1: Dtr1_d'rf (ibs1 i1 i0) (dtrOB_T o1 z1 o1 z2 o0) c0 c1 c2
                     (globcir (true,true,true) cbs1 (ibs1 i1 i0) x40 (dtrOB_T o1 z1 o1 z2 o0)))
        by (constructor; try easy).
    Apply step_Dtr1_d'rf with SS2 in D1. SimpS.
    Apply step_Dtr2_d'rr' with S3 SS3 in H14. SimpS.
    Apply step_Dtr3_d'rr' with S3 SS4 in H14. SimpS.
    Apply step_Dtr4_d'rr' with S4 SS5 in H14. SimpS.
    Apply step_Dtr5_d'rr' with SS6 in H14. SimpS.
    Apply step_Dtr0_r' with S5 SS7 in H14. SimpS.
    Apply step_Dtr1_r' with S5 SS8 in H14. SimpS.
    split; easy.
Qed.

Lemma foursteps: forall S T (i3 i4 i5: {|S|})
                           (o2 o3 o4 o5: {|T|})
                           (oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c3 c4 c5 c6: circuit S T)
                           (cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i3,i4,i5,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i3) (obs0 o3 o2) c3 c4 cc4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S5 S6.
introv SS6 SS7 SS8 SS9. SimpS.
Apply step_Dtrs0 with S5 SS6 in D. SimpS.
Apply step_Dtrs1 with S5 SS7 in H7. SimpS.
Apply step_Dtrs0 with S6 SS8 in H7. SimpS.
Apply step_Dtrs1 with S6 SS9 in H7. SimpS.
easy.
Qed.

Lemma sixsteps: forall S T (i2 i3 i4 i5: {|S|})
                           (o1 o2 o3 o4 o5: {|T|})
                           (oo4 oo5 oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c2 c3 c4 c5 c6: circuit S T)
                           (cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i2,i3,i4,i5,o1,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i2) (obs0 o2 o1) c2 c3 cc3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc3  i3 oo4 cc3'
             -> step cc3' i3 oo5 cc4
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o2 oo5
             /\ atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S4 S5 S6.
introv SS4 SS5 SS6 SS7 SS8 SS9. SimpS.
Apply step_Dtrs0 with S4 SS4 in D. SimpS.
Apply step_Dtrs1 with S4 SS5 in H9. SimpS.
split. easy.
eapply foursteps. 2: exact H9. 2: exact S5. 2: exact S6. 2: exact SS6.
                  2: exact SS7. 2: exact SS8. 2: exact SS9. CheckPure.
Qed.

Lemma eightsteps: forall S T (i1 i2 i3 i4 i5: {|S|})
                           (o0 o1 o2 o3 o4 o5: {|T|})
                           (oo2 oo3 oo4 oo5 oo6 oo7 oo8 oo9:{|T # (T # T)|})
                           (c1 c2 c3 c4 c5 c6: circuit S T)
                           (cc2 cc2' cc3 cc3' cc4 cc4' cc5 cc5' cc6: circuit S (T # (T # T))),
                pure_bset {i1,i2,i3,i4,i5,o0,o1,o2,o3,o4,o5}
             -> Dtrs0 (ibs0 i1) (obs0 o1 o0) c1 c2 cc2
             -> step c2 i2 o2 c3
             -> step c3 i3 o3 c4
             -> step c4 i4 o4 c5
             -> step c5 i5 o5 c6
             -> step cc2  i2 oo2 cc2'
             -> step cc2' i2 oo3 cc3
             -> step cc3  i3 oo4 cc3'
             -> step cc3' i3 oo5 cc4
             -> step cc4  i4 oo6 cc4'
             -> step cc4' i4 oo7 cc5
             -> step cc5  i5 oo8 cc5'
             -> step cc5' i5 oo9 cc6
             -> atleast2 o1 oo3
             /\ atleast2 o2 oo5
             /\ atleast2 o3 oo7
             /\ atleast2 o4 oo9
             /\ Dtrs0 (ibs0 i5) (obs0 o5 o4) c5 c6 cc6.
Proof.
introv P D S3 S4 S5 S6.
introv SS2 SS3 SS4 SS5 SS6 SS7 SS8 SS9. SimpS.
eapply foursteps in D. 3: exact S3. 3: exact S4. 3: exact SS2. 3: exact SS3.
                       3: exact SS4. 3: exact SS5. 2: CheckPure. SimpS.
split. easy. split. easy.
eapply foursteps. 2: exact H12. 2: exact S5. 2: exact S6. 2: exact SS6.
                  2: exact SS7. 2: exact SS8. 2: exact SS9. CheckPure.
Qed.


Require Import ImperativeOp Lists.List.
Import ListNotations.

Definition P :=
    Int const 0 :=: (VInt 1);;
    Int  var 1;;
    Bool var 2;;
    (Var 1) ::= Num (VInt 0);;

    While (Op (Var 1) neq  (Num (VInt 1)))
      (Var 1) ::= (Op (Var 1) plus (Const 0)).

  Definition E := [(2, VarType 1 Bool);
                   (1, VarType 0 Int);
                   (0, ConstType Int (VInt 1))].

  Definition M := [(1, VBool false); (0, VInt 1)].

  Example e : ([],[]) {{P}} (E,M).
   Proof. eapply EvSeq.
     - apply EvDeclC.
     - eapply EvSeq.
       * apply EvDecl.
       * eapply EvSeq.
         + apply EvDecl.
         + eapply EvSeq.
           -- apply EvAss.
              ** eapply EvVarL. reflexivity.
              ** apply EvNumR.
           -- eapply EvWhileT.
                ** eapply EvNeqTR.
                   ++ eapply EvVarR.
                      --- reflexivity.
                      --- reflexivity.
                   ++ apply EvNumR.
                   ++ intros H. inversion H.
                ** eapply EvSeq.
                   ++ apply EvAss.
                      --- eapply EvVarL. reflexivity.
                      --- eapply EvPlusR.
                          *** eapply EvVarR. reflexivity. reflexivity.
                          *** eapply EvConstR. reflexivity.
                          *** reflexivity.
                   ++ eapply EvWhileF.
                     --- eapply EvNeqFR.
                         *** eapply EvVarR.
                             +++ reflexivity.
                             +++ reflexivity.
                         *** apply EvNumR.
                         *** reflexivity.
  Qed.

  Example e2 : ([],[]) {{P}} (E,M).
  Proof. repeat econstructor. auto. Qed.


Require Import core core_axioms unscoped.
Import UnscopedNotations.

(** Eta laws. *)
Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.


(* Test the behaviour of hnf and simpl introduced in revision *)

Parameter n:nat.
Definition a:=0.

Eval simpl in (fix plus (n m : nat) {struct n} : nat :=
  match n with
  | 0 => m
  | S p => S (p + m)
  end) a a.

Eval hnf in match (plus (S n) O) with S n => n | _ => O end.


(**
  [TypeTheory.Initiality.Typing]

  Part of the [Initiality] package for the [UniMath.TypeTheory] library

  This file sets up the contexts, judgements, and derivations of the toy type theory under consideration.
*)

Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Initiality.Syntax.

Section Contexts.
  (** Note: for now, we take the type expressions of a context to be over _all_ variables of the context, not just the earlier ones — so-called _flat_ contexts, as opposed to _stratified_.  We will add stratification later, in [SplitTypeCat_Contextual].

  See Bauer–Lumsdaine–Hasselwarter 2020 on general type theories for a discussion of the philosophy of this choice. Also note how in the present proof of initiality, it works nicely: the main interpretation proof never mentions stratification, nor context equality, working entirely with naturality in typed flat contexts. *)
  Definition context_of_length n := dB_vars n -> ty_expr n.
  Identity Coercion id_context_of_length : context_of_length >-> Funclass.

  Definition context
    := ∑ (n : nat), context_of_length n.

  Definition context_length : context -> nat := pr1.
  Coercion context_length : context >-> nat.

  Definition context_types : forall Γ : context, _ := pr2.
  Coercion context_types : context >-> context_of_length.

  Definition make_context {n} : context_of_length n -> context
    := fun Γ => (n,,Γ).
  Coercion make_context : context_of_length >-> context.

  Definition empty_context : context
    := make_context (dB_0_rect _).

  Definition context_extend (Γ : context) (A : ty_expr Γ) : context.
  Proof.
    exists (S (context_length Γ)).
    refine (rename_ty dB_next ∘ _).
    refine (dB_Sn_rect _ _ _).
    - exact A.
    - intros i. exact (Γ i).
  Defined.

End Contexts.

Arguments context_extend : simpl never.

Delimit Scope context_scope with context.
Bind Scope context_scope with context.
Bind Scope context_scope with context_of_length.
Notation "[: :]" := (empty_context) (format "[: :]") : context_scope.
Notation "Γ ;; A"
  := (context_extend Γ A) (at level 50, left associativity) : context_scope.
(* TODO: not sure what level to use here; try it and see… *)
Notation "[: A ; .. ; Z :] "
  := (context_extend .. (context_extend (empty_context) A) .. Z) : context_scope.

Section Judgements.

(** NOTE: we take as primitive just the four main hypothetical judgements.

Other judgements, such as well-formed contexts and context maps, will be “auxiliary” judgements defined in terms of these afterwards.

The inductive definition of derivability involves only the primitive judgements. *)
  Polymorphic Inductive judgement
  :=
    | ty_judgement (Γ : context) (A : ty_expr Γ)
    | tyeq_judgement (Γ : context) (A A' : ty_expr Γ)
    | tm_judgement (Γ : context) (A : ty_expr Γ) (a : tm_expr Γ)
    | tmeq_judgement (Γ : context) (A : ty_expr Γ) (a a' : tm_expr Γ).

End Judgements.

Delimit Scope judgement_scope with judgement.
Bind Scope judgement_scope with judgement.
Open Scope judgement_scope.

Notation "[! Γ |- A === B !]" := (tyeq_judgement Γ A B) (format "[!  Γ  |-  A  ===  B  !]")  : judgement_scope.
Notation "[! Γ |- A !]" := (ty_judgement Γ A) (format "[!  Γ  |-  A  !]")  : judgement_scope.
Notation "[! Γ |- a ::: A !]" := (tm_judgement Γ A a) (format "[!  Γ  |-  a  :::  A  !]")  : judgement_scope.
Notation "[! Γ |- a === a' ::: A !]" := (tmeq_judgement Γ A a a') (format "[!  Γ  |-  a  ===  a'  :::  A  !]")  : judgement_scope.
(* NOTE: these [===], [:::] are horrible!  But I can’t make it work with just e.g. [=], since parsing fails as [=] is already a binary notation (even if the scope of that notation is closed).  Is it possible to use better scoping to allow just [=] here, and so on? *)

Section Derivations.

  Inductive derivation : judgement -> UU
  :=
    (** variable rule *)
    | derive_var (Γ : context) (i : Γ)
      :    derivation [! Γ |- Γ i !]
      -> derivation [! Γ |- (var_expr i) ::: Γ i !]
    (** structural rules for equality: equiv rels, plus type-conversion *)
    | derive_tyeq_refl (Γ : context) (A : _)
      :    derivation [! Γ |- A !]
      -> derivation [! Γ |- A === A !]
    | derive_tyeq_sym (Γ : context) (A A' : _)
      :    derivation [! Γ |- A === A' !]
      -> derivation [! Γ |- A' === A !]
    | derive_tyeq_trans (Γ : context) (A0 A1 A2 : _)
      :    derivation [! Γ |- A0 !]
        -> derivation [! Γ |- A1 !]
        -> derivation [! Γ |- A2 !]
        -> derivation [! Γ |- A0 === A1 !]
        -> derivation [! Γ |- A1 === A2 !]
      -> derivation [! Γ |- A0 === A2 !]
    | derive_tmeq_refl (Γ : context) (A : _) (a : _)
      :    derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- a === a ::: A !]
    | derive_tmeq_sym (Γ : context) (A : _) (a a' : _)
      :    derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- a' === a ::: A !]
    | derive_tmeq_trans (Γ : context) (A : _) (a0 a1 a2 : _)
      :    derivation [! Γ |- a0 ::: A !]
        -> derivation [! Γ |- a1 ::: A !]
        -> derivation [! Γ |- a2 ::: A !]
        -> derivation [! Γ |- a0 === a1 ::: A !]
        -> derivation [! Γ |- a1 === a2 ::: A !]
      -> derivation [! Γ |- a0 === a2 ::: A !]
    | derive_tm_conv (Γ : context) (A A' : _) (a : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A' !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- a ::: A' !]
    | derive_tmeq_conv (Γ : context) (A A' : _) (a a' : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A' !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- a === a' ::: A' !]

    (** logical rules  *)
    | derive_U (Γ : context)
      : derivation [! Γ |- U_expr !]
    | derive_El (Γ : context) (a : _)
      :    derivation [! Γ |- a ::: U_expr !]
      -> derivation [! Γ |- El_expr a !]
    | derive_Pi (Γ : context) (A : _) (B : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
      -> derivation [! Γ |- Pi_expr A B !]
    | derive_lam (Γ : context) A B b
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ ;; A |- b ::: B !]
      -> derivation [! Γ |- lam_expr A B b ::: Pi_expr A B !]
    | derive_app (Γ : context) A B f a
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ |- f ::: Pi_expr A B !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation [! Γ |- app_expr A B f a ::: subst_top_ty a B !]
    | derive_beta (Γ : context) A B b a
      :    derivation [! Γ |- A !]
        -> derivation [! Γ ;; A |- B !]
        -> derivation [! Γ ;; A |- b ::: B !]
        -> derivation [! Γ |- a ::: A !]
      -> derivation
             [! Γ |- app_expr A B (lam_expr A B b) a === subst_top_tm a b
                                                     ::: subst_top_ty a B !]

    (** congruence rules for constructors *)
    (* no congruence rule needed for U *)
    | derive_El_cong (Γ : context) (a a' : _)
      :    derivation [! Γ |- a === a' ::: U_expr !]
      -> derivation [! Γ |- El_expr a === El_expr a' !]
    | derive_Pi_cong (Γ : context) (A A' : _) (B B' : _)
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
      -> derivation [! Γ |- Pi_expr A B === Pi_expr A' B' !]
    | derive_lam_cong (Γ : context) A A' B B' b b'
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
        -> derivation [! Γ ;; A |- b === b' ::: B !]
      -> derivation [! Γ |- lam_expr A B b === lam_expr A' B' b'
                                                 ::: Pi_expr A B !]
    | derive_app_cong (Γ : context) A A' B B' f f' a a'
      :    derivation [! Γ |- A !]
        -> derivation [! Γ |- A === A' !]
        -> derivation [! Γ ;; A |- B === B' !]
        -> derivation [! Γ |- f === f' ::: Pi_expr A B !]
        -> derivation [! Γ |- a === a' ::: A !]
      -> derivation [! Γ |- app_expr A B f a === app_expr A' B' f' a'
                                                   ::: subst_top_ty a B !]
  .

  Coercion derivation : judgement >-> UU.

End Derivations.

Section Derivation_Helpers.
(** Some utility functions to make inductions over derivations more manageable.*)

  Local Open Scope context_scope.

  Context (P : forall J:judgement, derivation J -> Type).
  Local Arguments P {_} _.

  Definition case_for_var_rule
  := forall (Γ : context) (i : Γ)
            (d_Γi : [! Γ |- Γ i !]) (p_Γi : P d_Γi),
    P (derive_var Γ i d_Γi).

  Record cases_for_equiv_rel_rules
  := {
    case_tyeq_refl
    : forall (Γ : context) (A : ty_expr Γ)
             (d : [! Γ |- A !]) (p : P d),
        P (derive_tyeq_refl Γ A d)
  ; case_teq_sym
    : forall (Γ : context) (A A' : ty_expr Γ)
             (d : [! Γ |- A === A' !]) (p : P d),
      P (derive_tyeq_sym Γ A A' d)
  ; case_tyeq_trans
    : forall (Γ : context) (A0 A1 A2 : ty_expr Γ)
             (d0 : [! Γ |- A0 !]) (p0 : P d0)
             (d1 : [! Γ |- A1 !]) (p1 : P d1)
             (d2 : [! Γ |- A2 !]) (p2 : P d2)
             (d01 : [! Γ |- A0 === A1 !]) (p01 : P d01)
             (d12 : [! Γ |- A1 === A2 !]) (p12 : P d12),
      P (derive_tyeq_trans Γ A0 A1 A2 d0 d1 d2 d01 d12)
  ; case_tmeq_refl
    : forall (Γ : context) (A : ty_expr Γ) (a : tm_expr Γ)
             (d : [! Γ |- a ::: A !]) (p : P d),
      P (derive_tmeq_refl Γ A a d)
  ; case_tmeq_sym
    : forall (Γ : context) (A : ty_expr Γ) (a a' : tm_expr Γ)
             (d : [! Γ |- a === a' ::: A !]) (p : P d),
      P (derive_tmeq_sym Γ A a a' d)
  ; case_tmeq_trans
    : forall (Γ : context) (A : ty_expr Γ) (a0 a1 a2 : tm_expr Γ)
             (d0 : [! Γ |- a0 ::: A !]) (p0 : P d0)
             (d1 : [! Γ |- a1 ::: A !]) (p1 : P d1)
             (d2 : [! Γ |- a2 ::: A !]) (p2 : P d2)
             (d01 : [! Γ |- a0 === a1 ::: A !]) (p01 : P d01)
             (d12 : [! Γ |- a1 === a2 ::: A !]) (p12 : P d12),
      P (derive_tmeq_trans Γ A a0 a1 a2 d0 d1 d2 d01 d12)
  }.

  Record cases_for_conv_rules
  := {
    case_tm_conv
    : forall (Γ : context) (A A' : ty_expr Γ) (a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_A' : [! Γ |- A' !]) (p_A' : P d_A')
             (d_AA' : [! Γ |- A === A' !]) (p_AA' : P d_AA')
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
        P (derive_tm_conv Γ A A' a d_A d_A' d_AA' d_a)
  ; case_tmeq_conv
    : forall (Γ : context) (A A' : ty_expr Γ) (a a' : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_A' : [! Γ |- A' !]) (p_A' : P d_A')
             (d_AA' : [! Γ |- A === A' !]) (p_AA' : P d_AA')
             (d_aa' : [! Γ |- a === a' ::: A !]) (p_aa' : P d_aa'),
      P (derive_tmeq_conv Γ A A' a a' d_A d_A' d_AA' d_aa')
  }.

  Record cases_for_universe_rules
  := {
    case_for_U
    : forall (Γ : context),
        P (derive_U Γ)
  ; case_for_El
    : forall (Γ : context) (a : tm_expr Γ)
             (d_a : [! Γ |- a ::: U_expr !]) (p_a : P d_a),
      P (derive_El Γ a d_a)
  ; case_for_El_cong
    : forall (Γ : context) (a a' : tm_expr Γ)
             (d_aa' : [! Γ |- a === a' ::: U_expr !]) (p_aa' : P d_aa'),
      P (derive_El_cong Γ a a' d_aa')
  }.

  Record cases_for_pi_rules
  := {
    case_for_Pi
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B),
      P (derive_Pi Γ A B d_A d_B)
  ; case_for_lam
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (b : tm_expr (Γ ;; A))
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_b : [! Γ ;; A |- b ::: B !]) (p_b : P d_b),
      P (derive_lam Γ A B b  d_A d_B d_b)
  ; case_for_app
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (f a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_f : [! Γ |- f ::: Pi_expr A B !]) (p_f : P d_f)
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
      P (derive_app Γ A B f a d_A d_B d_f d_a)
  ; case_for_beta
    : forall (Γ : context) (A : ty_expr Γ) (B : ty_expr (Γ ;; A))
             (b : tm_expr (Γ ;; A)) (a : tm_expr Γ)
             (d_A : [! Γ |- A !]) (p_A : P d_A)
             (d_B : [! Γ ;; A |- B !]) (p_B : P d_B)
             (d_b : [! Γ ;; A |- b ::: B !]) (p_b : P d_b)
             (d_a : [! Γ |- a ::: A !]) (p_a : P d_a),
      P (derive_beta Γ A B b a d_A d_B d_b d_a)
  }.

  Record cases_for_pi_cong_rules
  := {
    case_for_Pi_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB),
      P (derive_Pi_cong Γ A A' B B' d_A d_AA d_BB)
  ; case_for_lam_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (b b' : tm_expr (Γ ;; A))
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB)
        (d_bb : [! Γ ;; A |- b === b' ::: B !]) (p_bb : P d_bb),
      P (derive_lam_cong Γ A A' B B' b b' d_A d_AA d_BB d_bb)
  ; case_for_app_cong
    : forall (Γ : context) (A A' : ty_expr Γ) (B B' : ty_expr (Γ ;; A))
        (f f' a a' : tm_expr Γ)
        (d_A : [! Γ |- A !]) (p_A : P d_A)
        (d_AA : [! Γ |- A === A' !]) (p_AA : P d_AA)
        (d_BB : [! Γ ;; A |- B === B' !]) (p_BB : P d_BB)
        (d_ff : [! Γ |- f === f' ::: Pi_expr A B !]) (p_ff : P d_ff)
        (d_aa : [! Γ |- a === a' ::: A !]) (p_aa : P d_aa),
      P (derive_app_cong Γ A A' B B' f f' a a' d_A d_AA d_BB d_ff d_aa)
    }.

  Definition derivation_rect_grouped
      (H_var_rule : case_for_var_rule)               (* 1 case *)
      (H_equiv_rel_rules : cases_for_equiv_rel_rules) (* 6 cases *)
      (H_conv_rules : cases_for_conv_rules)           (* 2 cases *)
      (H_universe_rules : cases_for_universe_rules)   (* 3 cases *)
      (H_pi_rules : cases_for_pi_rules)               (* 4 cases *)
      (H_pi_cong_rules : cases_for_pi_cong_rules)     (* 3 cases *)
    : forall J (d : derivation J), P d.
  Proof.
    destruct H_equiv_rel_rules, H_conv_rules,
      H_universe_rules, H_pi_rules, H_pi_cong_rules.
    apply derivation_rect; eauto.
  Defined.

End Derivation_Helpers.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(* Utilities methods used for defining the semantics of the operators *)

Require Import List.
Require Import String.
Require Import Utils.
Require Import ZArith.
Require Import BrandRelation.
Require Import ForeignData.
Require Import Data.
Require Import DataLift.
Require Import Iterators.

Section OperatorsUtils.
  Context {fdata:foreign_data}.

  Definition string_sort := insertion_sort StringOrder.le_dec.

  Fixpoint dsum (ns:list data) : option Z
    := match ns with
         | nil => Some 0%Z
         | dnat n::ls => lift (Zplus n) (dsum ls)
         | _ => None
       end.

  Lemma dsum_nil :
    dsum nil = Some (0%Z).
  Proof.
    reflexivity.
  Qed.

  Lemma Zquot_zero n :
    Z.quot n 0%Z = 0%Z.
  Proof.
    now apply Z.quot_0_r_ext.
  Qed.

  Definition darithmean_alt (ns:list data) : option Z
    := match ns with
       | nil  => Some (0%Z) (* Unneeded betwen Z.quot 0 0 = 0 , see Zquot.Zquot_0_r *)
       | _ => lift (fun x => Z.quot x (Z_of_nat (List.length ns))) (dsum ns)
       end.

  Definition darithmean (ns:list data) : option Z
    := lift (fun x => Z.quot x (Z_of_nat (List.length ns))) (dsum ns).

  Lemma darithmean_alt_correct (ns:list data):
    darithmean_alt ns = darithmean ns.
  Proof.
    destruct ns; reflexivity.
  Qed.

  Definition lifted_stringbag (l : list data) : option (list string) :=
    lift_map (ondstring (fun x => x)) l.
  Definition lifted_zbag (l : list data) : option (list Z) :=
    lift_map (ondnat (fun x => x)) l.
  Definition lifted_min (l : list data) : option data :=
    lift dnat (lift bnummin (lifted_zbag l)).
  Definition lifted_max (l : list data) : option data :=
    lift dnat (lift bnummax (lifted_zbag l)).

  Definition lifted_fbag (l : list data) : option (list float) :=
    lift_map (ondfloat (fun x => x)) l.

  Definition lifted_fsum (l:list data) : option data :=
    lift dfloat (lift float_list_sum (lifted_fbag l)).
  Definition lifted_farithmean (l:list data) : option data :=
    lift dfloat (lift float_list_arithmean (lifted_fbag l)).
  Definition lifted_fmin (l : list data) : option data :=
    lift dfloat (lift float_list_min (lifted_fbag l)).
  Definition lifted_fmax (l : list data) : option data :=
    lift dfloat (lift float_list_max (lifted_fbag l)).

  Definition lifted_join (sep : string) (l : list data) : option data :=
    lift dstring (lift (concat sep) (lifted_stringbag l)).

End OperatorsUtils.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.StringOperations.

Global Set Implicit Arguments.

Lemma nat_of_ascii_small x
: Ascii.nat_of_ascii x < 256.
Proof.
  apply Compare_dec.leb_complete.
  revert x.
  intros [[] [] [] [] [] [] [] []]; lazy; reflexivity.
Qed.

Lemma substring_correct3 {s : string} m (H : length s <= m)
  : substring 0 m s = s.
Proof.
  revert m H.
  induction s; simpl.
  { intros; destruct m; trivial. }
  { intros; destruct m.
    { apply Lt.lt_n_0 in H.
      destruct H. }
    { rewrite IHs; trivial.
      apply Le.le_S_n; trivial. } }
Qed.

Lemma substring_correct3' {s : string}
  : substring 0 (length s) s = s.
Proof.
  apply substring_correct3; reflexivity.
Qed.

Lemma substring_correct0 {s : string} {n}
  : substring n 0 s = ""%string.
Proof.
  revert n; induction s; intro n; destruct n; simpl; trivial.
Qed.

Lemma substring_correct0' {s : string} {n m} (H : length s <= n)
  : substring n m s = ""%string.
Proof.
  revert n m H; induction s; simpl; intros n m H.
  { destruct n, m; trivial. }
  { destruct n, m; trivial.
    { apply le_Sn_0 in H; destruct H. }
    { rewrite IHs; eauto with arith. }
    { rewrite IHs; eauto with arith. } }
Qed.

Lemma substring_correct4 {s : string} {n m m'}
      (H : length s <= n + m) (H' : length s <= n + m')
  : substring n m s = substring n m' s.
Proof.
  revert n m m' H H'.
  induction s; simpl in *.
  { intros; destruct m, m', n; trivial. }
  { intros; destruct m, m', n; trivial; simpl in *;
    try (apply Lt.lt_n_0 in H; destruct H);
    try (apply Lt.lt_n_0 in H'; destruct H');
    try apply Le.le_S_n in H;
    try apply Le.le_S_n in H';
    try solve [ try rewrite plus_comm in H;
                try rewrite plus_comm in H';
                simpl in *;
                rewrite !substring_correct0' by auto with arith; trivial ].
    { apply f_equal.
      apply IHs; trivial. }
    { apply IHs; trivial. } }
Qed.

Lemma string_concat_empty_r {s} : (s ++ "" = s)%string.
Proof.
  induction s; simpl; f_equal; trivial.
Qed.

Lemma string_concat_empty_l {s} : ("" ++ s = s)%string.
Proof.
  reflexivity.
Qed.

Lemma substring_concat {x y z} {s : string}
  : (substring x y s ++ substring (x + y) z s)%string = substring x (y + z) s.
Proof.
  revert x y z.
  induction s; simpl; intros.
  { destruct (y + z), x, y, z; reflexivity. }
  { destruct x, y, z; try reflexivity; simpl;
    rewrite ?plus_0_r, ?substring_correct0, ?string_concat_empty_r;
    try reflexivity.
    { apply f_equal.
      apply IHs. }
    { rewrite IHs; simpl; reflexivity. } }
Qed.

Lemma substring_concat' {y z} {s : string}
  : (substring 0 y s ++ substring y z s)%string = substring 0 (y + z) s.
Proof.
  rewrite <- substring_concat; reflexivity.
Qed.

Lemma substring_concat0 {s1 s2 : string}
  : substring 0 (length s1) (s1 ++ s2) = s1.
Proof.
  induction s1; simpl.
  { rewrite substring_correct0; trivial. }
  { rewrite IHs1; trivial. }
Qed.

Lemma concat_length {s1 s2 : string}
  : length (s1 ++ s2) = length s1 + length s2.
Proof.
  induction s1.
  { reflexivity. }
  { simpl.
    rewrite IHs1; reflexivity. }
Qed.

Lemma substring_concat_length {s1 s2 : string}
  : substring (length s1) (length s2) (s1 ++ s2) = s2.
Proof.
  induction s1; simpl.
  { rewrite substring_correct3'; trivial. }
  { erewrite substring_correct4.
    { exact IHs1. }
    { rewrite concat_length; reflexivity. }
    { rewrite concat_length; reflexivity. } }
Qed.

Lemma substring_length {s n m}
  : length (substring n m s) = (min (length s) (m + n)) - n.
Proof.
  revert n m; induction s; intros.
  { destruct n, m; reflexivity. }
  { simpl.
    destruct n, m; simpl; trivial; rewrite IHs; simpl;
    try omega;
    rewrite (plus_comm m (S n)); simpl;
    rewrite (plus_comm n m); simpl;
    reflexivity. }
Qed.

Lemma substring_substring {s n m n' m'}
  : substring n m (substring n' m' s) = substring (n + n') (min m (m' - n)) s.
Proof.
  revert n m n' m'.
  induction s; intros.
  { destruct n, m, n', m'; reflexivity. }
  { destruct n', m';
    rewrite <- ?plus_n_O, <- ?minus_n_O, ?Min.min_0_r, ?Min.min_0_l;
    destruct n, m;
    trivial; simpl;
    rewrite ?IHs, ?substring_correct0, <- ?plus_n_O, <- ?minus_n_O;
    simpl;
    try reflexivity.
    rewrite (plus_comm _ (S _)); simpl.
    rewrite (plus_comm n n').
    reflexivity. }
Qed.

Lemma substring1_get {n str}
  : substring n 1 str
    = option_rect (fun _ => String.string) (fun a => String.String a ""%string) ""%string (get n str).
Proof.
  revert n; induction str; intro n.
  { destruct n; reflexivity. }
  { destruct n; simpl.
    { destruct str; reflexivity. }
    { rewrite <- IHstr; reflexivity. } }
Qed.

Lemma substring_min {x x' y y' z str} (H : substring x y str = substring x' y' str)
  : substring x (min y z) str = substring x' (min y' z) str.
Proof.
  pose proof (fun y x => @substring_substring str 0 z x y) as H'; simpl in *.
  setoid_rewrite Nat.sub_0_r in H'.
  setoid_rewrite Min.min_comm in H'.
  rewrite <- !H', H; reflexivity.
Qed.

Lemma get_string_of_list str n
: String.get n (string_of_list str) = List.nth_error str n.
Proof.
  revert n; induction str as [|ch str IHstr]; intros;
  destruct n as [|n]; simpl in *; auto.
Qed.

Lemma length_list_of_string str
: List.length (list_of_string str) = String.length str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma length_string_of_list ls
: String.length (string_of_list ls) = List.length ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma list_of_string_substring n m str
: StringOperations.list_of_string (String.substring n m str) = List.take m (List.drop n (StringOperations.list_of_string str)).
Proof.
  revert n m; induction str as [|?? IHstr];
  intros [|?] [|?];
  simpl;
  rewrite ?IHstr;
  reflexivity.
Qed.

Lemma list_of_string_of_list ls
: list_of_string (string_of_list ls) = ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma string_of_list_of_string str
: string_of_list (list_of_string str) = str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma get_list_of_string str n
: List.nth_error (list_of_string str) n = String.get n str.
Proof.
  rewrite <- get_string_of_list, string_of_list_of_string; reflexivity.
Qed.

Lemma substring_min_length str x y
: substring x (min y (length str)) str = substring x y str.
Proof.
  apply Min.min_case_strong; try reflexivity.
  intro H.
  apply substring_correct4; omega.
Qed.

Lemma string_copy_length n ch
: String.length (string_copy n ch) = n.
Proof.
  induction n; simpl; eauto.
Qed.

Fixpoint split_string (s : string) : (string * string) :=
  match s with
  | EmptyString => ("", "")
  | String a s' => if Ascii.ascii_dec a "." then ("", s')
                   else (let (s1, s2) := split_string s' in
                         (String a s1, s2))
  end%string.

Lemma split_string_ValidDomainName_length :
  forall d,
    d <> ""%string
    -> lt (String.length (snd (split_string d))) (String.length d).
Proof.
  induction d; simpl; intros; try congruence.
  destruct (Ascii.ascii_dec a "."); simpl; eauto.
  destruct d; simpl in *; eauto.
  destruct (if Ascii.ascii_dec a0 "." then (""%string, d)
               else (let (s1, s2) := split_string d in (String a0 s1, s2))).
  simpl in *.
  etransitivity.
  apply IHd.
  congruence.
  eauto with arith.
Qed.

Lemma well_founded_string_length
  : well_founded (fun y r : string => lt (String.length y) (String.length r)%nat).
Proof.
  unfold well_founded; intro; induction a; econstructor.
  - destruct y; simpl; omega.
  - intros; destruct y; simpl; intros.
    + econstructor; destruct y; simpl; omega.
    + econstructor; intros.
      eapply IHa; simpl in *; omega.
Qed.


(* 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.
 *)

(** printing NRoot %\ensuremath{\sqrt[n]{\cdot}}% *)
(** printing sqrt %\ensuremath{\sqrt{\cdot}}% *)

Require Export CoRN.reals.OddPolyRootIR.
Import CRing_Homomorphisms.coercions.

(**
* Roots of Real Numbers *)

Section NRoot.
(**
** Existence of roots

%\begin{convention}% Let [n] be a natural number and [c] a nonnegative real.
[p] is the auxiliary polynomial [_X_[^]n[-] (_C_ c)].
%\end{convention}%
*)

Variable n : nat.
Hypothesis n_pos : 0 < n.
Variable c : IR.
Hypothesis c_nonneg : [0] [<=] c.

(* begin hide *)
Let p := _X_[^]n[-]_C_ c.
(* end hide *)

Lemma CnrootIR : {x : IR | [0] [<=] x | x[^]n [=] c}.
Proof.
 intros.
 cut (monic n p). intro.
  elim (Ccpoly_pos' _ p [0] n); auto.
  intro X. intros H0 H1.
  cut {x : IR | [0] [<=] x /\ x [<=] X /\ p ! x [=] [0]}. intro H2.
   elim H2. clear H2. intro. intro H2.
   elim H2. clear H2. intros H2 H3. elim H3. clear H3. intros.
   exists x. auto.
    apply cg_inv_unique_2.
   astepl (_X_ ! x[^]n[-] (_C_ c) ! x).
   astepl ((_X_[^]n) ! x[-] (_C_ c) ! x).
   Step_final (_X_[^]n[-]_C_ c) ! x.
  apply Civt_poly; auto.
   apply monic_apzero with n; auto.
  unfold p in |- *.
  astepl ((_X_[^]n) ! [0][-] (_C_ c) ! [0]).
  astepl (_X_ ! [0][^]n[-]c).
  astepl ([0][^]n[-]c).
  astepl ([0][-]c).
  astepl ( [--]c).
  astepr ( [--]ZeroR). apply inv_resp_leEq. auto.
  unfold p in |- *.
 apply monic_minus with 0.
   apply degree_le_c_.
  pattern n at 1 in |- *. replace n with (1 * n).
  apply monic_nexp.
   apply monic_x_.
  auto with arith.
 auto.
Qed.

End NRoot.

(** We define the root of order [n] for any nonnegative real number and
prove its main properties:
 - $\left(\sqrt[n]x\right)^n=x$#(sqrt(n) x)^n =x#;
 - $0\leq\sqrt[n]x$#0≤sqrt(n)x#;
 - if [[0] [<] x] then $0<\sqrt[n]x$#0<sqrt(n)x#;
 - $\sqrt[n]{x^n}=x$#sqrt(n) x^n =x#;
 - the nth root is monotonous;
 - in particular, if [x [<] [1]] then $\sqrt[n]x<1$#sqrt(n) x<1#.

[(nroot ??)] will be written as [NRoot].
*)

Section Nth_Root.

Lemma nroot : forall x k, [0] [<=] x -> 0 < k -> {y : IR | [0] [<=] y | y[^]k [=] x}.
Proof.
 intros.
 elim (CnrootIR k H0 x H). intro y. intros.
 exists y; auto.
Qed.

Definition NRoot x n Hx Hn : IR := proj1_sig2T _ _ _ (nroot x n Hx Hn).

Lemma NRoot_power : forall x k Hx Hk, NRoot x k Hx Hk[^]k [=] x.
Proof.
 intros.
 unfold NRoot in |- *.
 apply proj2b_sig2T.
Qed.

Hint Resolve NRoot_power: algebra.

Lemma NRoot_nonneg : forall x k Hx Hk, [0] [<=] NRoot x k Hx Hk.
Proof.
 intros.
 unfold NRoot in |- *.
 apply proj2a_sig2T.
Qed.

Lemma NRoot_pos : forall x Hx k Hk, [0] [<] x -> [0] [<] NRoot x k Hx Hk.
Proof.
 intros. rename X into H.
 cut ([0] [<=] NRoot x k Hx Hk); intros.
  cut (NRoot x k Hx Hk [<] [0] or [0] [<] NRoot x k Hx Hk). intros H1.
   elim H1; clear H1; intro H1.
    rewrite -> leEq_def in H0; elim (H0 H1).
   auto.
  apply ap_imp_less.
  apply un_op_strext_unfolded with (nexp_op (R:=IR) k).
  astepl x; astepr ZeroR.
  apply pos_ap_zero; auto.
 apply NRoot_nonneg.
Qed.

Lemma NRoot_power' : forall x k Hx' Hk, [0] [<=] x -> NRoot (x[^]k) k Hx' Hk [=] x.
Proof.
 intros.
 apply root_unique with k; auto.
  apply NRoot_nonneg.
 apply NRoot_power.
Qed.

Lemma NRoot_pres_less : forall x Hx y Hy k Hk, x [<] y -> NRoot x k Hx Hk [<] NRoot y k Hy Hk.
Proof.
 intros.
 apply power_cancel_less with k.
  apply NRoot_nonneg.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 eapply less_wdr.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 auto.
Qed.

Lemma NRoot_less_one : forall x Hx k Hk, x [<] [1] -> NRoot x k Hx Hk [<] [1].
Proof.
 intros.
 apply power_cancel_less with k.
  apply less_leEq; apply pos_one.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 astepr OneR.
 assumption.
Qed.

Lemma NRoot_cancel : forall x Hx y Hy k Hk, NRoot x k Hx Hk [=] NRoot y k Hy Hk -> x [=] y.
Proof.
 intros.
 apply eq_transitive_unfolded with (NRoot x k Hx Hk[^]k).
  apply eq_symmetric_unfolded; apply NRoot_power.
 apply eq_transitive_unfolded with (NRoot y k Hy Hk[^]k).
  2: apply NRoot_power.
 apply nexp_wd; algebra.
Qed.

(** %\begin{convention}% Let [x,y] be nonnegative real numbers.
%\end{convention}% *)

Variables x y : IR.
Hypothesis Hx : [0] [<=] x.
Hypothesis Hy : [0] [<=] y.

Lemma NRoot_wd : forall k Hk Hk', x [=] y -> NRoot x k Hx Hk [=] NRoot y k Hy Hk'.
Proof.
 intros.
 apply root_unique with k; auto.
   apply NRoot_nonneg.
  apply NRoot_nonneg.
 eapply eq_transitive_unfolded.
  eapply eq_transitive_unfolded.
   2: apply H.
  apply NRoot_power.
 apply eq_symmetric_unfolded; apply NRoot_power.
Qed.

Lemma NRoot_unique : forall k Hk, [0] [<] x -> x[^]k [=] y -> x [=] NRoot y k Hy Hk.
Proof.
 intros. rename H into H0.
 apply root_unique with k; auto.
  apply NRoot_nonneg.
 eapply eq_transitive_unfolded.
  apply H0.
 apply eq_symmetric_unfolded; apply NRoot_power.
Qed.

End Nth_Root.

Arguments NRoot [x n].

#[global]
Hint Resolve NRoot_power NRoot_power': algebra.

Lemma NRoot_resp_leEq : forall x y xpos ypos k kpos,
 x [<=] y -> NRoot (x:=x) (n:=k) xpos kpos [<=] NRoot (x:=y) (n:=k) ypos kpos.
Proof.
 intros.
 rewrite -> leEq_def; intro H0.
 assert (NRoot ypos kpos[^]k [<=] NRoot xpos kpos[^]k).
  apply power_resp_leEq.
   apply NRoot_nonneg.
  apply less_leEq; auto.
 assert (x [=] y).
  apply leEq_imp_eq; auto.
  eapply leEq_wdl.
   eapply leEq_wdr.
    eexact H1.
   algebra.
  algebra.
 clear H H1.
 generalize (NRoot_wd _ _ xpos ypos k kpos kpos H2).
 intro.
 apply (less_irreflexive_unfolded _ (NRoot ypos kpos)).
 astepr (NRoot xpos kpos).
 auto.
Qed.

Lemma NRoot_cancel_less : forall x (Hx:[0][<=]x) y (Hy:[0][<=]y) k (Hk Hk':0<k), NRoot Hx Hk [<] NRoot Hy Hk' -> x [<] y.
Proof.
 intros x Hx y Hy k Hk Hk' H.
 astepl (NRoot Hx Hk[^]k).
 astepr (NRoot Hy Hk'[^]k).
 apply nexp_resp_less.
   auto with *.
  apply NRoot_nonneg.
 assumption.
Qed.

Lemma NRoot_str_ext : forall k (Hk Hk':0 < k) x y (Hx:[0][<=]x) (Hy:[0][<=]y), NRoot Hx Hk [#] NRoot Hy Hk' -> x[#]y.
Proof.
 intros k Hk Hk' x y Hx Hy H0.
 destruct (ap_imp_less _ _ _ H0) as [H1|H1].
  apply less_imp_ap.
  refine (NRoot_cancel_less _ _ _ _ _ _ _ H1).
 apply Greater_imp_ap.
 refine (NRoot_cancel_less _ _ _ _ _ _ _ H1).
Qed.

(*---------------------------------*)
Section Square_root.
(*---------------------------------*)

(**
** Square root *)

Definition sqrt x xpos : IR := NRoot (x:=x) (n:=2) xpos (lt_O_Sn 1).

Lemma sqrt_sqr : forall x xpos, sqrt x xpos[^]2 [=] x.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_power.
Qed.

Hint Resolve sqrt_sqr: algebra.

Lemma sqrt_nonneg : forall x xpos, [0] [<=] sqrt x xpos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_nonneg.
Qed.

Lemma sqrt_wd : forall x y xpos ypos, x [=] y -> sqrt x xpos [=] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_wd.
 auto.
Qed.

Hint Resolve sqrt_wd: algebra_c.

Lemma sqrt_to_nonneg : forall x, [0] [<=] x -> forall x2pos, sqrt (x[^]2) x2pos [=] x.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg. auto. auto.
   Step_final (x[^]2).
Qed.

Lemma sqrt_to_nonpos : forall x, x [<=] [0] -> forall x2pos, sqrt (x[^]2) x2pos [=] [--]x.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg.
   astepl ( [--]ZeroR). apply inv_resp_leEq. auto.
   auto.
 astepl (x[^]2). rational.
Qed.

Lemma sqrt_mult : forall x y xpos ypos xypos, sqrt (x[*]y) xypos [=] sqrt x xpos[*]sqrt y ypos.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg.
   apply mult_resp_nonneg; apply sqrt_nonneg.
  auto.
 astepl (x[*]y).
 astepl (sqrt x xpos[^]2[*]sqrt y ypos[^]2).
 rational.
Qed.

Hint Resolve sqrt_mult: algebra.

Lemma sqrt_mult_wd : forall x y z xpos ypos zpos,
 z [=] x[*]y -> sqrt z zpos [=] sqrt x xpos[*]sqrt y ypos.
Proof.
 intros.
 cut ([0] [<=] x[*]y). intro.
  Step_final (sqrt (x[*]y) H0).
 apply mult_resp_nonneg; auto.
Qed.

Lemma sqrt_less : forall x y ypos, x[^]2 [<] y -> x [<] sqrt y ypos.
Proof.
 intros.
 apply power_cancel_less with 2.
  apply sqrt_nonneg.
 astepr y. auto.
Qed.

Lemma sqrt_less' : forall x y ypos, x[^]2 [<] y -> [--]x [<] sqrt y ypos.
Proof.
 intros.
 apply power_cancel_less with 2.
  apply sqrt_nonneg.
 rstepl (x[^]2). astepr y. auto.
Qed.

Lemma sqrt_resp_leEq : forall x y xpos ypos, x [<=] y -> sqrt x xpos [<=] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_resp_leEq.
 auto.
Qed.

Lemma sqrt_resp_less : forall x y xpos ypos, x [<] y -> sqrt x xpos [<] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_pres_less.
 auto.
Qed.

End Square_root.

#[global]
Hint Resolve sqrt_wd: algebra_c.
#[global]
Hint Resolve sqrt_sqr sqrt_mult: algebra.

Section Absolute_Props.

(**
** More on absolute value

With the help of square roots, we can prove some more properties of absolute
values in [IR].
*)

Lemma AbsIR_sqrt_sqr : forall x x2pos, AbsIR x [=] sqrt (x[^]2) x2pos.
Proof.
 intros x xxpos. unfold AbsIR in |- *. simpl in |- *. unfold ABSIR in |- *.
 apply equiv_imp_eq_max; intros.
   apply power_cancel_leEq with 2.
     auto.
    apply mult_cancel_leEq with (Two:IR). apply pos_two.
     rstepl (x[+][--]x).
    rstepr (y[+]y).
    apply plus_resp_leEq_both; auto.
   astepl ([1][*]x[*]x).
   rstepl (x[^]2[+][0]).
   apply shift_plus_leEq'.
   rstepr ((y[-]x) [*] (y[-][--]x)).
   apply mult_resp_nonneg.
    apply shift_zero_leEq_minus. auto.
    apply shift_zero_leEq_minus. auto.
   apply leEq_transitive with (sqrt (x[^]2) xxpos).
   apply power_cancel_leEq with 2. auto.
     apply sqrt_nonneg.
   astepr (x[^]2).
   apply leEq_reflexive.
  auto.
 apply leEq_transitive with (sqrt (x[^]2) xxpos).
  apply power_cancel_leEq with 2. auto.
    apply sqrt_nonneg.
  astepr (x[^]2).
  rstepl (x[^]2).
  apply leEq_reflexive.
 auto.
Qed.

Hint Resolve AbsIR_sqrt_sqr: algebra.

Lemma AbsIR_resp_mult : forall x y, AbsIR (x[*]y) [=] AbsIR x[*]AbsIR y.
Proof.
 intros.
 astepl (sqrt ((x[*]y) [^]2) (sqr_nonneg _ (x[*]y))).
 cut ([0] [<=] x[^]2[*]y[^]2). intro.
  astepl (sqrt (x[^]2[*]y[^]2) H).
  Step_final (sqrt (x[^]2) (sqr_nonneg _ x) [*]sqrt (y[^]2) (sqr_nonneg _ y)).
 apply mult_resp_nonneg; apply sqr_nonneg.
Qed.

Lemma AbsIR_mult_pos : forall x y, [0] [<=] y -> AbsIR (x[*]y) [=] AbsIR x[*]y.
Proof.
 intros.
 apply eq_transitive_unfolded with (AbsIR x[*]AbsIR y).
  apply AbsIR_resp_mult.
 apply bin_op_wd_unfolded.
  algebra.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--]y y).
  apply Max_comm.
 apply leEq_imp_Max_is_rht.
 apply leEq_transitive with ZeroR.
  astepr ( [--]ZeroR).
  apply inv_resp_leEq; assumption.
 assumption.
Qed.

Lemma AbsIR_mult_pos' : forall x y, [0] [<=] x -> AbsIR (x[*]y) [=] x[*]AbsIR y.
Proof.
 intros.
 astepl (AbsIR (y[*]x)).
 eapply eq_transitive_unfolded.
  apply AbsIR_mult_pos; auto.
 algebra.
Qed.

Lemma AbsIR_nexp : forall x n, AbsIR (nexp _ n x) [=] nexp _ n (AbsIR x).
Proof.
 intros.
 induction  n as [| n Hrecn].
  simpl in |- *; apply AbsIR_eq_x; apply less_leEq; apply pos_one.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply AbsIR_resp_mult.
 algebra.
Qed.

Lemma AbsIR_nexp_op : forall n x, AbsIR (x[^]n) [=] AbsIR x[^]n.
Proof.
 intros; simpl in |- *; apply AbsIR_nexp.
Qed.

Lemma AbsIR_less_square : forall x y, AbsIR x [<] y -> x[^]2 [<] y[^]2.
Proof.
 intros.
 eapply less_wdl.
  2: apply AbsIR_eq_x; apply sqr_nonneg.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op.
 apply nexp_resp_less; auto.
 apply AbsIR_nonneg.
Qed.

Lemma AbsIR_leEq_square : forall x y, AbsIR x [<=] y -> x[^]2 [<=] y[^]2.
Proof.
 intros.
 eapply leEq_wdl.
  2: apply AbsIR_eq_x; apply sqr_nonneg.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op.
 apply nexp_resp_leEq; auto.
 apply AbsIR_nonneg.
Qed.

Lemma AbsIR_division : forall x y y_ y__, AbsIR (x[/] y[//]y_) [=] (AbsIR x[/] AbsIR y[//]y__).
Proof.
 intros x y H Hy.
 rstepr (AbsIR x[*] ([1][/] AbsIR y[//]Hy)).
 apply eq_transitive_unfolded with (AbsIR (x[*] ([1][/] y[//]H))).
  apply un_op_wd_unfolded; rational.
 apply eq_transitive_unfolded with (AbsIR x[*]AbsIR ([1][/] y[//]H)).
  apply AbsIR_resp_mult.
 apply mult_wdr.
 cut (y [<] [0] or [0] [<] y).
  intros H0.
  elim H0.
   intros.
   apply eq_transitive_unfolded with ( [--] ([1][/] y[//]H)).
    apply AbsIR_eq_inv_x.
    rstepr ([0][/] [--]y[//]inv_resp_ap_zero _ _ H).
    apply shift_leEq_div.
     astepl ( [--]ZeroR).
     apply inv_resp_less; assumption.
    rstepl ( [--]OneR).
    astepr ( [--]ZeroR); apply inv_resp_leEq; apply less_leEq; apply pos_one.
   rstepl ([1][/] [--]y[//]inv_resp_ap_zero _ _ H).
   apply div_wd.
    algebra.
   apply eq_symmetric_unfolded; apply AbsIR_eq_inv_x.
   apply less_leEq; assumption.
  intros.
  apply eq_transitive_unfolded with ([1][/] y[//]H).
   apply AbsIR_eq_x.
   apply less_leEq; apply recip_resp_pos; assumption.
  apply div_wd; [ algebra
    | apply eq_symmetric_unfolded; apply AbsIR_eq_x; apply less_leEq; assumption ].
 apply ap_imp_less.
 assumption.
Qed.

(** Some special cases. *)

Lemma AbsIR_recip : forall x x_ x__, AbsIR ([1][/] x[//]x_) [=] ([1][/] AbsIR x[//]x__).
Proof.
 intros x H Ha.
 apply eq_transitive_unfolded with (AbsIR [1][/] AbsIR x[//]Ha).
  apply AbsIR_division.
 apply div_wd.
  2: algebra.
 apply AbsIR_eq_x; apply less_leEq; apply pos_one.
Qed.

Lemma AbsIR_div_two : forall x, AbsIR (x [/]TwoNZ) [=] AbsIR x [/]TwoNZ.
Proof.
 intros.
 apply eq_transitive_unfolded with (AbsIR x[/] AbsIR Two[//] AbsIR_resp_ap_zero _
   (ap_symmetric_unfolded _ _ _ (less_imp_ap _ _ _ (pos_two _)))).
  apply AbsIR_division.
 apply div_wd.
  algebra.
 apply AbsIR_eq_x; apply less_leEq; apply pos_two.
Qed.

(** Cauchy-Schwartz for IR and variants on that subject. *)

Lemma triangle_IR : forall x y, AbsIR (x[+]y) [<=] AbsIR x[+]AbsIR y.
Proof.
 intros.
 astepl (sqrt ((x[+]y) [^]2) (sqr_nonneg _ (x[+]y))).
 astepr (sqrt (x[^]2) (sqr_nonneg _ x) [+]sqrt (y[^]2) (sqr_nonneg _ y)).
 apply power_cancel_leEq with 2. auto.
   astepl ([0][+]ZeroR). apply plus_resp_leEq_both; apply sqrt_nonneg.
  astepl ((x[+]y) [^]2).
 rstepl (x[^]2[+]y[^]2[+]Two[*] (x[*]y)).
 rstepr (sqrt (x[^]2) (sqr_nonneg IR x) [^]2[+]sqrt (y[^]2) (sqr_nonneg IR y) [^]2[+]
   Two[*] (sqrt (x[^]2) (sqr_nonneg IR x) [*]sqrt (y[^]2) (sqr_nonneg IR y))).
 apply plus_resp_leEq_both.
  astepr (x[^]2[+]y[^]2). apply leEq_reflexive.
  apply mult_resp_leEq_lft.
  apply power_cancel_leEq with 2. auto.
    apply mult_resp_nonneg; apply sqrt_nonneg.
  rstepr (sqrt (x[^]2) (sqr_nonneg _ x) [^]2[*]sqrt (y[^]2) (sqr_nonneg _ y) [^]2).
  astepr (x[^]2[*]y[^]2).
  astepl (x[^]2[*]y[^]2).
  apply leEq_reflexive.
 apply less_leEq. apply pos_two.
Qed.

Lemma triangle_SumIR : forall k l s,
 k <= S l -> AbsIR (Sum k l s) [<=] Sum k l (fun i => AbsIR (s i)).
Proof.
 intros. induction  l as [| l Hrecl].
 generalize (toCle _ _ H); clear H; intro H.
  inversion H as [|m H0 H1].
   unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
   rstepr ZeroR.
   astepr (AbsIR [0]).
   apply eq_imp_leEq. apply AbsIR_wd. rational.
   inversion H0.
  unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
  rstepr (ABSIR (s 0)).
  apply eq_imp_leEq. apply AbsIR_wd. rational.
  elim (le_lt_eq_dec k (S (S l))); try intro y.
   apply leEq_wdl with (AbsIR (Sum k l s[+]s (S l))).
    apply leEq_wdr with (Sum k l (fun i : nat => AbsIR (s i)) [+]AbsIR (s (S l))).
     apply leEq_transitive with (AbsIR (Sum k l s) [+]AbsIR (s (S l))).
      apply triangle_IR.
     apply plus_resp_leEq. apply Hrecl. auto with arith.
     apply eq_symmetric_unfolded.
    apply Sum_last with (f := fun i : nat => AbsIR (s i)).
   apply AbsIR_wd.
   apply eq_symmetric_unfolded. apply Sum_last.
   rewrite y.
  unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
  rstepr ZeroR.
  astepr (AbsIR [0]).
  apply eq_imp_leEq. apply AbsIR_wd. rational.
  auto.
Qed.

Lemma triangle_IR_minus : forall x y, AbsIR (x[-]y) [<=] AbsIR x[+]AbsIR y.
Proof.
 intros.
 unfold cg_minus in |- *.
 apply leEq_wdr with (AbsIR x[+]AbsIR [--]y).
  apply triangle_IR.
 apply bin_op_wd_unfolded.
  algebra.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--]y y).
  apply bin_op_wd_unfolded; algebra.
 apply Max_comm.
Qed.

Lemma weird_triangleIR : forall x y, AbsIR x[-]AbsIR (y[-]x) [<=] AbsIR y.
Proof.
 intros.
 apply shift_minus_leEq.
 simpl in |- *; unfold ABSIR in |- *; apply Max_leEq.
  rstepl (y[+][--] (y[-]x)).
  apply plus_resp_leEq_both; [ apply lft_leEq_Max | apply rht_leEq_Max ].
 rstepl ( [--]y[+] (y[-]x)).
 apply plus_resp_leEq_both; [ apply rht_leEq_Max | apply lft_leEq_Max ].
Qed.

Lemma triangle_IR_minus' : forall x y, AbsIR x[-]AbsIR y [<=] AbsIR (x[-]y).
Proof.
 intros.
 eapply leEq_wdr.
  2: apply AbsIR_minus.
 apply shift_minus_leEq; apply shift_leEq_plus'.
 apply weird_triangleIR.
Qed.

Lemma triangle_SumxIR : forall n (f : forall i, i < n -> IR),
 AbsIR (Sumx f) [<=] Sumx (fun i H => AbsIR (f i H)).
Proof.
 simple induction n.
  intros; simpl in |- *.
  apply eq_imp_leEq; apply AbsIRz_isz.
 clear n; intros.
 simpl in |- *; eapply leEq_transitive.
  apply triangle_IR.
 apply plus_resp_leEq.
 eapply leEq_wdr.
  apply H.
 apply Sumx_wd.
 intros; algebra.
Qed.

Lemma triangle_Sum2IR : forall m n (f : forall i, m <= i -> i <= n -> IR),
 m <= S n -> AbsIR (Sum2 f) [<=] Sum2 (fun i Hm Hn => AbsIR (f i Hm Hn)).
Proof.
 intros.
 unfold Sum2 in |- *.
 eapply leEq_wdr.
  apply triangle_SumIR.
  assumption.
 apply Sum_wd'.
  assumption.
 intros.
 elim (le_lt_dec m i); intro;
   [ simpl in |- * | exfalso; apply (le_not_lt m i); auto with arith ].
 elim (le_lt_dec i n); intro;
   [ simpl in |- * | exfalso; apply (le_not_lt i n); auto with arith ].
 algebra.
Qed.

Lemma AbsIR_str_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<] e -> AbsIR b [<] AbsIR a[+]e.
Proof.
 do 3 intro. intro H.
 apply shift_less_plus'.
 eapply leEq_less_trans.
  apply triangle_IR_minus'.
 eapply less_wdl; [ apply H | apply AbsIR_minus ].
Qed.

Lemma AbsIR_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<=] e -> AbsIR b [<=] AbsIR a[+]e.
Proof.
 intros.
 apply shift_leEq_plus'.
 eapply leEq_transitive.
  apply triangle_IR_minus'.
 eapply leEq_wdl; [ apply H | apply AbsIR_minus ].
Qed.

End Absolute_Props.

Section Consequences.

(**
** Cauchy sequences

With these results, we can also prove that the sequence of reciprocals of a
Cauchy sequence that is never zero and whose Limit is not zero is also a
Cauchy sequence.
*)

Lemma Cauchy_Lim_recip : forall seq y, Cauchy_Lim_prop2 seq y ->
 forall seq_ y_, Cauchy_Lim_prop2 (fun n : nat => [1][/] seq n[//]seq_ n) ([1][/] y[//]y_).
Proof.
 intros seq y H Hn Hy.
 red in |- *; red in H.
 intros eps He.
 cut {n0 : nat | forall n : nat, n0 <= n -> AbsIR y [/]TwoNZ [<=] AbsIR (seq n)}.
  intro H0.
  elim H0; clear H0; intros n0 Hn0.
  cut ([0] [<] eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y)).
   intro H0.
   elim (H _ H0); clear H.
   intros N HN.
   exists (max N n0).
   intros.
   apply AbsIR_imp_AbsSmall.
   apply leEq_wdl with (([1][/] _[//]AbsIR_resp_ap_zero _ (Hn m)) [*]
     ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*]AbsIR (seq m[-]y)).
    rstepr ((Two[/] _[//]AbsIR_resp_ap_zero _ Hy) [*] ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*]
      (eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y))).
    apply mult_resp_leEq_both.
       astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive.
        apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hn.
       apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy.
      apply AbsIR_nonneg.
     apply mult_resp_leEq_rht.
      rstepr ([1][/] _[//] div_resp_ap_zero_rev _ _ _ (two_ap_zero _) (AbsIR_resp_ap_zero _ Hy)).
      apply recip_resp_leEq.
       apply pos_div_two; apply AbsIR_pos; apply Hy.
      apply Hn0.
      apply le_trans with (max N n0); auto with arith.
     apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy.
    apply AbsSmall_imp_AbsIR.
    apply HN.
    apply le_trans with (max N n0); auto with arith.
   apply eq_transitive_unfolded with
     (AbsIR ([1][/] _[//]Hn m) [*]AbsIR ([1][/] _[//]Hy) [*]AbsIR (y[-]seq m)).
    repeat apply mult_wd; apply eq_symmetric_unfolded.
      apply AbsIR_recip.
     apply AbsIR_recip.
    apply AbsIR_minus.
   apply eq_transitive_unfolded with (AbsIR (([1][/] _[//]Hn m) [*] ([1][/] _[//]Hy) [*] (y[-]seq m))).
    eapply eq_transitive_unfolded.
     2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
    apply mult_wdl.
    apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply AbsIR_wd.
   rational.
  astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive.
   apply pos_div_two; assumption.
  astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive;
    apply AbsIR_pos; apply Hy.
 cut {n0 : nat | forall n : nat, n0 <= n -> AbsSmall (AbsIR y [/]TwoNZ) (seq n[-]y)}.
  2: apply H.
  2: eapply less_wdr.
   3: apply AbsIR_div_two.
  2: apply AbsIR_pos.
  2: apply div_resp_ap_zero_rev; apply Hy.
 intro H0.
 elim H0; intros n0 Hn0; clear H0; exists n0; intros.
 apply leEq_transitive with (AbsIR y[-]AbsIR (seq n[-]y)).
  apply shift_leEq_minus; apply shift_plus_leEq'.
  rstepr (AbsIR y [/]TwoNZ).
  apply AbsSmall_imp_AbsIR.
  apply Hn0; assumption.
 apply weird_triangleIR.
Qed.

Lemma Cauchy_recip : forall seq seq_, Lim seq [#] ([0]:IR) ->
 Cauchy_prop (fun n => [1][/] seq n[//]seq_ n).
Proof.
 intros seq Hn Hy.
 apply Cauchy_prop2_prop.
 exists ([1][/] _[//]Hy).
 apply Cauchy_Lim_recip.
 apply Cauchy_complete.
Qed.

Lemma Lim_recip : forall seq seq_ seq__,
 Lim (Build_CauchySeq _ _ (Cauchy_recip seq seq_ seq__)) [=] ([1][/] _[//]seq__).
Proof.
 intros.
 apply eq_symmetric_unfolded; apply Limits_unique.
 simpl in |- *; apply Cauchy_Lim_recip.
 apply Cauchy_complete.
Qed.

End Consequences.

Section Part_Function_NRoot.

(** *** Functional Operators

%\begin{convention}%
Let [F:PartIR] and denote by [P] its domain, which must be entirely nonnegative.
%\end{convention}%
*)

Variables F : PartIR.

Let P := Dom F.

Let R := extend P (fun x Hx => [0][<=]F x Hx).

Let Ext2R := ext2 (P:=P) (R:=fun x Hx => [0][<=]F x Hx).

Variable n : nat.

Hypothesis Hn : 0 < n.

Lemma part_function_NRoot_strext : forall x y Hx Hy,
 NRoot (Ext2R x Hx) Hn [#] NRoot (Ext2R y Hy) Hn -> x [#] y.
Proof.
 intros x y Hx Hy H.
 refine (pfstrx _ _ _ _ _ _ (NRoot_str_ext _ _ _ _ _ _ _ H)).
Qed.

Lemma part_function_NRoot_pred_wd : pred_wd _ R.
Proof.
 intros x y H H0.
 elim H.
 intros H1 H2.
 split.
  apply (dom_wd _ F x y H1 H0).
 intros H3.
 astepr (F x H1).
 auto.
Qed.

Definition FNRoot := Build_PartFunct IR _ part_function_NRoot_pred_wd
 (fun x Hx => NRoot (Ext2R x Hx) Hn) part_function_NRoot_strext.

Section Included.

Variable S:IR -> CProp.

Lemma included_FNRoot : included S P ->
 (forall x, S x -> forall Hx, [0][<=]F x Hx) -> included S (Dom FNRoot).
Proof.
 intros H H0.
 simpl in |- *.
 unfold extend in |- *.
 split.
  apply H; assumption.
 intros; apply H0; assumption.
Qed.

Lemma included_FNRoot' : included S (Dom FNRoot) -> included S P.
Proof.
 intro H; simpl in H; eapply included_extend; unfold R in *; apply H.
Qed.

End Included.

End Part_Function_NRoot.

#[global]
Hint Resolve included_FNRoot included_FNRoot' : included.


Require Import LogRelIE.InstPTy.
Require Import LogRelIE.PseudoType.

Require Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.

Module B := Coq.Init.Datatypes.

Require Import RecTypes.Contraction.

Require Import InstPTy.

Require Import Coq.micromega.Lia.

Inductive SimplePContr : PTy → Prop :=
  | SimpContrPUnit : SimplePContr ptunit
  | SimpContrPBool : SimplePContr ptbool
  | SimpContrPArrow {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptarr τ τ')
  | SimpContrPSum {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptsum τ τ')
  | SimpContrPProd {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptprod τ τ')
  | SimpContrPRec {τ} : SimplePContr τ → SimplePContr (ptrec τ)
  | SimpContrPEmulDV {n p τ} : SimpleContr τ → SimplePContr (pEmulDV n p τ)
  with SimplePRec : PTy → Prop :=
  | SimplePAlpha {i} : SimplePRec (ptvar i)
  | SimplePRecContr {τ} : SimplePContr τ → SimplePRec τ.

Scheme simp_p_contr_mut_ind := Induction for SimplePContr Sort Prop
  with simp_p_rec_mut_ind := Induction for SimplePRec Sort Prop.

Combined Scheme simp_p_contr_comb_ind from simp_p_contr_mut_ind, simp_p_rec_mut_ind.

#[export]
Hint Constructors SimplePContr : simple_p_contr_rec.
#[export]
Hint Constructors SimplePRec : simple_p_contr_rec.

Definition pUnfoldOnce (τ : PTy) : PTy :=
  match τ with
    | ptrec τ => τ [(beta1 (ptrec τ))]
    | _ => τ
  end.

Fixpoint pUnfoldn (n : nat) (τ : PTy) :=
  match n with
    | 0 => τ
    | S n => pUnfoldn n (pUnfoldOnce τ)
  end.

Inductive ContrPEnv : PEnv → Prop :=
| ContrPEnvEmpty : ContrPEnv pempty
| ContrPEnvEvar {Γ τ} :
  ContrPEnv Γ →
  SimplePContr τ →
  ContrPEnv (Γ p▻ τ).

Definition SimplePContrSub ( ξ : Sub PTy) : Prop := forall i : Ix, SimplePContr (ξ i).
Definition SimplePRecSub ( ξ : Sub PTy) : Prop := forall i : Ix, SimplePRec (ξ i).

Lemma SimplePContrRec_ren :
  (forall τ (sτ : SimplePContr τ) (ξ : Sub Ix), SimplePContr τ[ξ]) /\
  (forall τ (sτ : SimplePRec τ) (ξ : Sub Ix), SimplePRec τ[ξ]).
Proof.
  apply simp_p_contr_comb_ind; cbn; intros;
    repeat change (apPTy ?ξ ?τ) with τ[ξ];
    constructor; auto.
Qed.

Corollary SimplePRec_wk {τ} : SimplePRec τ → SimplePRec τ[wk].
Proof. intros s. now apply SimplePContrRec_ren. Qed.

Lemma SimplePContrSub_implies_SimplePRecSub {ξ} : SimplePContrSub ξ → SimplePRecSub ξ.
Proof.
  unfold SimplePContrSub, SimplePRecSub.
  intros.
  specialize (H i).
  exact (SimplePRecContr H).
Qed.

Lemma SimplePRecSub_implies_SimplePRecSubUp {ξ} : SimplePRecSub ξ → SimplePRecSub (up ξ).
Proof.
  unfold SimplePRecSub.
  intros.

  destruct i; cbn.
  constructor.

  apply SimplePRec_wk.
  exact (H i).
Qed.

Lemma SimplePRecSub_implies_SimplePRec {τ ξ} : SimplePRec τ → SimplePRecSub ξ → SimplePRec τ[ξ].
Proof.
  intro H.
  apply (simp_p_rec_mut_ind
           (fun τ (_ : SimplePContr τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePContr τ[ξ]))
           (fun τ (_ : SimplePRec τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePRec τ[ξ]))); cbn; eauto with simple_p_contr_rec.

  intros.
  constructor.
  eauto using H0, SimplePRecSub_implies_SimplePRecSubUp.
Qed.

Lemma SimplePContrSub_implies_SimplePContr {τ ξ} : SimplePContr τ → SimplePRecSub ξ → SimplePContr τ[ξ].
  intro H.
  apply (simp_p_contr_mut_ind
           (fun τ (_ : SimplePContr τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePContr τ[ξ]))
           (fun τ (_ : SimplePRec τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePRec τ[ξ]))).
  cbn.
  constructor.

  intros.
  cbn.
  constructor.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply H1.
  assumption.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply H1.
  assumption.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply (H1 ξ0 H2).

  intros.
  cbn.
  constructor.
  apply (H0 ξ0↑).
  apply SimplePRecSub_implies_SimplePRecSubUp.
  assumption.

  intros.
  cbn.
  constructor.
  assumption.

  intros.
  cbn.
  exact (H0 i).

  intros.
  specialize (H0 ξ0).
  apply SimplePRecSub_implies_SimplePRec.
  apply SimplePRecContr.
  assumption.
  assumption.
  assumption.
Qed.

Lemma SimplePRecSub_beta {τ} : SimplePContr τ -> SimplePRecSub (beta1 τ).
Proof.
  intros srec i; cbn.
  destruct i; cbn; constructor; auto.
Qed.

Lemma punfold_preserves_contr {τ} : SimplePContr τ -> SimplePContr (τ [beta1 (ptrec τ)]).
Proof.
  eauto using SimplePContrSub_implies_SimplePContr, SimplePRecSub_beta, SimpContrPRec.
Qed.

Lemma SimplePContr_pUnfoldOnce (τ : PTy) : SimplePContr τ -> SimplePContr (pUnfoldOnce τ).
Proof.
  destruct τ; cbn; eauto with simple_p_contr_rec.
  intros contr.
  dependent destruction contr.
  eauto using punfold_preserves_contr.
Qed.

#[export]
Hint Resolve SimplePContr_pUnfoldOnce : simple_p_contr_rec.

Lemma SimplePRec_pUnfoldOnce (τ : PTy) : SimplePRec τ -> SimplePRec (pUnfoldOnce τ).
Proof.
  destruct 1;
  eauto using SimplePRec, SimplePContr_pUnfoldOnce.
Qed.

#[export]
Hint Resolve SimplePRec_pUnfoldOnce : simple_contr_rec.

Lemma SimplePRec_invert_arrow {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec τ ∧ SimplePRec σ.
Proof.
  intros carr.
  remember (τ p⇒ σ) as τ'.
  destruct carr; [inversion Heqτ'|].
  destruct H; inversion Heqτ'.
  now subst.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow : simple_contr_p_rec.

Lemma SimplePRec_invert_arrow_argty {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec τ.
Proof.
  eapply SimplePRec_invert_arrow.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow_argty : simple_contr_p_rec.

Lemma SimplePRec_invert_arrow_retty {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec σ.
Proof.
  eapply SimplePRec_invert_arrow.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow_retty : simple_contr_p_rec.

Fixpoint LMC_pty (τ : PTy) {struct τ} : nat :=
  match τ with
  | ptrec τ => S (LMC_pty τ)
  | _ => 0
  end.

Lemma LMC_ind_pty : forall (P : PTy -> Type),
    (forall τ, SimplePContr τ -> LMC_pty τ = 0 -> P τ) ->
    (forall n, (forall τ, SimplePContr τ -> LMC_pty τ = n -> P τ) -> (forall τ, SimplePContr τ -> LMC_pty τ = S n -> P τ)) ->
    forall τ, SimplePContr τ -> P τ.
Proof.
  intros P P0 Ps τ.
  remember (LMC_pty τ) as n.
  revert τ Heqn.
  induction n; eauto.
Qed.

Lemma decide_pmu (τ : PTy) : (exists τ', τ = ptrec τ') \/ LMC_pty τ = 0.
Proof.
  destruct τ; cbn; eauto.
Qed.

Lemma LMC_SimplePContr (τ : PTy) : SimplePContr τ → forall ξ, LMC_pty τ[ξ] = LMC_pty τ.
Proof.
  induction τ; cbn; try lia.
  intros.
  f_equal.
  eapply IHτ.
  intros.
  inversion H.
  assumption.
  intros.
  exfalso.
  inversion H.
Qed.

Lemma LMC_pUnfoldOnce (τ : PTy) : SimplePContr τ → LMC_pty τ > 0 → LMC_pty (pUnfoldOnce τ) = pred (LMC_pty τ).
Proof.
  intros.
  destruct (decide_pmu τ) as [(τ' & ?) | ?]; [| lia].
  subst. cbn. pose proof (LMC_SimplePContr τ').
  assert (SimplePContr τ') by (inversion H; assumption).
  specialize (H1 H2 (beta1 (ptrec τ'))).
  rewrite H1.
  lia.
Qed.

Lemma pUnfoldn_dec_lmc (τ : PTy) (n : nat) : SimplePContr τ → LMC_pty τ >= n → LMC_pty (pUnfoldn n τ) = LMC_pty τ - n.
Proof.
  revert τ; induction n; intros.
  - cbn; lia.
  - cbn.
    replace (LMC_pty τ - S n) with (LMC_pty (pUnfoldOnce τ) - n).
    eapply IHn.
    + eauto with simple_p_contr_rec.
    + rewrite LMC_pUnfoldOnce; try lia.
      assumption.
    + rewrite LMC_pUnfoldOnce; try lia.
      assumption.
Qed.

Lemma pUnfoldn_LMC {τ} : SimplePContr τ -> LMC_pty (pUnfoldn (LMC_pty τ) τ) = 0.
Proof.
  intros contrτ.
  replace 0 with (LMC_pty τ - LMC_pty τ) by lia.
  eapply pUnfoldn_dec_lmc.
  - assumption.
  - lia.
Qed.

Lemma pUnfoldn_LMC_rec {τ} : SimplePRec τ -> LMC_pty (pUnfoldn (LMC_pty τ) τ) = 0.
Proof.
  destruct 1.
  - now cbn.
  - now eapply pUnfoldn_LMC.
Qed.


Require Export Coq.Strings.String.

Definition beq_string x y :=
  if string_dec x y then true else false.

Definition total_map (A:Type) := string -> A.

Definition t_update {A:Type} (m : total_map A) (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Notation "{ --> d }" := (t_empty d) (at level 0).

(* xxx *)
Lemma t_apply_empty: forall (A: Type) (x: string) (v: A), { --> v } x = v.
Proof.
intros.
trivial.
Qed.