(***********************************************************************)
(**  * Connecting nominal and LN semantics *)
(***********************************************************************)

(** Our final goal is to show that the abstract nominal machine
    implements the same semantics as the LN substitution-based small
    step relation.

    We'll do this by proving that any time the abstract machine takes a
    step, we can decode the machine configuration before and after the
    step to LN expressions, and those expressions are either identical
    or related by the LN step relation.

<<
                    machine_step
             (h,t,s)  ------>  (h',t',s')            nominal terms
                |                  |
                | decode           | decode
                v                  v
                e       - - ->     e'           locally nameless terms
                      step e e'
                         or
                        e = e'
>>

    This result is the [simulate_step] lemma near the end of this file.

 *)

Require Import Metalib.Metatheory.

Require Import Stlc.Definitions.
Require Import Stlc.Lemmas.

Require Import Stlc.Nominal.

Import StlcNotations.

(***********************************************************************)
(** ** Translating nominal terms to LN terms *)
(***********************************************************************)

(** We decode named terms to LN terms through the use of the
    [close_exp_wrt_exp] function. This function replaces all occurrences
    of a given atom by a new bound variable.

    The close function is defined in the [Stlc.Lemmas] module and can be
    automatically generated by LNgen.  *)

Fixpoint nom_to_exp (ne : n_exp) : exp :=
  match ne with
  | n_var x     => var_f x
  | n_app e1 e2 => app (nom_to_exp e1) (nom_to_exp e2)
  | n_abs x e1  => abs (close_exp_wrt_exp x (nom_to_exp e1))
end.

(** We also define a translation from machine configurations to LN
    terms. In this case we must substitute all definitions in the
    heap through the terms and create all of the applications in
    the stack. *)

Fixpoint apply_heap (h : heap) (e : exp) : exp  :=
  match h with
  | nil => e
  | (x , e') :: h' => apply_heap h' ([x ~> nom_to_exp e'] e)
  end.

(** Note that the stack could have some heap definitions in it,
    so we apply the substitutions in the heap there too. *)

Fixpoint apply_stack h (s : list frame) (e :exp) : exp :=
  match s with
  | nil => e
  | n_app2 e' :: s' =>
    apply_stack h s' (app e (apply_heap h (nom_to_exp e')))
  end.

(** The full decode function puts all of these parts together. *)

Definition decode (c:configuration) : exp  :=
  match c with
  | (h,e,s) => apply_stack h s (apply_heap h (nom_to_exp e))
  end.

(** Here's an example translation from the machine step demo. *)

Definition conf1 := ([(Y,n_var Z)], n_abs X (n_var X), [n_app2 (n_var Y)]).

Example decode1 : decode conf1 = (app (abs (var_b 0)) (var_f Z)).
Proof. (* WORKED IN CLASS *)
  default_simp.
  unfold close_exp_wrt_exp.
  default_simp.
Qed.
(***********************************************************************)
(** ** Connecting free variable functions.                             *)
(***********************************************************************)

(** Here is the first result about our decoding: that the two free
    variable functions agree.

    In this part of the file, we will take advantage of automation
    provided by the Lemmas module. In particular, this module defines a
    database of rewriting hints (called [lngen]) that can be used to
    automatically rewrite LN terms into simpler form. *)

Lemma fv_nom_fv_exp_eq : forall n,
    fv_nom n [=] fv_exp (nom_to_exp n).
Proof.
  induction n; intros; simpl; autorewrite with lngen; fsetdec.
Qed.

(** As we prove new lemmas, we can also extend the hint database with new
    rewritings. *)
Hint Rewrite fv_nom_fv_exp_eq : lngen.
Hint Resolve fv_nom_fv_exp_eq : lngen.

(** The Metatheory library contains two powerful tactics for simplifying
    goals:

     - [default_steps]: repeat a bunch of simplifying steps, such as
       simplifying the goal, inverting simple hypotheses, etc.

     - [default_simp]: above plus case analysis for booleans and other
       sums

    Below, we modify the behavior of these tactics by updating the
    following two definitions, so that the [lngen] hint databases will
    be available.  *)

Ltac default_auto        ::= auto with lngen.
Ltac default_autorewrite ::= autorewrite with lngen.

(** We also add a few more rewriting lemmas to the hint database to
    automate our proofs. *)

Hint Rewrite subst_exp_open_exp_wrt_exp : lngen.
Hint Rewrite swap_size_eq : lngen.
Hint Resolve le_S_n : lngen.

(***********************************************************************)
(** ** Decoded terms are locally closed *)
(***********************************************************************)

(** Next, we show that our decoding of nominal terms and configurations
    produces locally closed LN terms.

    Below, [alist induction] is a tactic from the metatheory library for
    induction over association lists (such as the heap).  *)

Lemma nom_to_exp_lc : forall t, lc_exp (nom_to_exp t).
Proof.
  induction t; default_steps.
Qed.
Hint Resolve nom_to_exp_lc : lngen.

Lemma apply_heap_lc : forall h e,
    lc_exp e -> lc_exp (apply_heap h e).
Proof.
  alist induction h; default_simp.
Qed.
Hint Resolve apply_heap_lc : lngen.

(** *** Exercise: [apply_stack_lc]

    State and prove a lemma called [apply_stack_lc] and add it to the
    [lngen] hint database so that the proof for [decode_lc] goes
    through. *)

(* SOLUTION: *)
Lemma apply_stack_lc : forall s h e,
    lc_exp e -> lc_exp (apply_stack h s e).
Proof.
  induction s; try destruct a; default_simp.
Qed.
Hint Resolve apply_stack_lc : lngen.

Lemma decode_lc : forall c, lc_exp (decode c).
Proof.
  intros [[h e] s]; default_simp.
  (* SOLUTION: *)
Qed.
(***********************************************************************)
(** ** Properties of apply_heap *)
(***********************************************************************)

(** Since the heap is just an iterated substitution, it inherits
    properties from [subst_exp].  *)

Lemma apply_heap_abs : forall h e,
  apply_heap h (abs e) = abs (apply_heap h e).
Proof.
  alist induction h; default_simp.
Qed.

Hint Rewrite apply_heap_abs : lngen.

Lemma apply_heap_app : forall h e1 e2,
  apply_heap h (app e1 e2) = app (apply_heap h e1) (apply_heap h e2).
Proof.
  alist induction h; default_simp.
Qed.

Hint Rewrite apply_heap_app : lngen.

(** *** Exercise: [apply_heap_open]

    This function is the [apply_heap] analogue to
    [subst_exp_open_exp_wrt_exp], commuting the heap-based
    substitution with the [open_exp_wrt_exp] operation.
 *)

Lemma apply_heap_open : forall h e e0,
    lc_exp e0 ->
    apply_heap h (open e e0)  =
       open (apply_heap h e) (apply_heap h e0).
Proof.
(* SOLUTION: *)
  alist induction h; intros; default_simp.
Qed.
Hint Rewrite apply_heap_open : lngen.

(** This last lemma "unsimpl"s the [apply_heap] function. *)

Lemma combine : forall h x e e',
  apply_heap h ([x ~> nom_to_exp e] e') = (apply_heap ((x,e)::h) e').
Proof.
  simpl. auto.
Qed.

(***********************************************************************)
(** ** Stacks as evaluation contexts                                    *)
(***********************************************************************)

(** Here is a quick lemma that uses the properties defined above.
    It shows that the stack behaves like an *evaluation context*,
    lifting a small-step reduction to a larger term.
 *)

Lemma apply_stack_cong : forall s h e e',
    step e e' ->
    step (apply_stack h s e) (apply_stack h s e').
Proof.
  induction s; intros; try destruct a; default_simp.
Qed.

(***********************************************************************)
(** * Connecting "freshening" *)
(***********************************************************************)

(** The abstract machine uses the nominal [swap] operation to make sure
    that the variables in abstractions are "fresh".  To be able prove that
    this machine implements the step relation for LN terms, we need to
    connect this operation to a LN version of "freshening".

    The [swap_spec] lemma below states that connection. If a variable [y]
    is "fresh", then substituting with it (in the LN representation) is the
    same as swapping with it (in the nominal representation).

<<
Lemma swap_spec : forall  n w y,
    y `notin` fv_exp (nom_to_exp n) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp n) =
    nom_to_exp (swap w y n).
>>

 *)

(** *** Exercise [close_exp_wrt_exp_freshen] *)

(** The [swap_spec] proof depends on the following auxiliary lemma about the
    close operation --- that we can equivalently rename the atom that
    we are closing with. *)
Lemma close_exp_wrt_exp_freshen : forall x y e,
    y `notin` fv_exp e ->
    close_exp_wrt_exp x e =
    close_exp_wrt_exp y ([x ~> var_f y] e).
Proof.
(* SOLUTION: *)
  intros x y e.
  unfold close_exp_wrt_exp.
  generalize 0 as k.
  generalize e. clear e.
  induction e; default_simp.
Qed.
(** One difficulty of [swap_spec] is that we need to use the induction
    not on direct subterms, but on those that have had a swapping applied
    to them. Swapping preserves the size of a nominal term, so we can
    prove this result by induction on [m], a bound on the size of the
    term.

    The difficulty in this proof comes from the [n_abs] case. In this
    case, the term is is of the form [n_abs x t] for some binding
    variable [x]. We don't know much about [x]; it could be [w], or [y]
    or some other variable. The first and last case are straightforward,
    but the middle case causes difficulty: even though [x] is not free in
    [n_abs x t], it _is_ free in [t]. Therefore, our induction hypothesis
    doesn't apply.

    To solve this problem, we need to generate a completely fresh
    variable [z] for the binder, use the lemma above to replace [y] and
    [w] with it, and then use the induction hypothesis.

 *)
Lemma swap_spec_aux : forall m t w y,
    size t <= m ->
    y `notin` fv_exp (nom_to_exp t) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp t) =
    nom_to_exp (swap w y t).
Proof.
  induction m; intros t w y SZ;
  destruct t; simpl in *; try omega;
  intros.
  + unfold swap_var; default_simp.
  + unfold swap_var; default_simp.
    { (* w is the binder *)
      rewrite subst_exp_fresh_eq; default_simp.
      autorewrite with lngen in *.
      rewrite (close_exp_wrt_exp_freshen w y); try fsetdec.
      rewrite IHm; default_simp.  }
    { (* y is the binder *)
       autorewrite with lngen in *.
       (* don't know anything about w or y. Either one could
          appear in n. So our IH is useless now. *)
       (* Let's pick a fresh variable z and use it with that. *)
       pick fresh z for (
              fv_exp (nom_to_exp t) \u
              fv_exp (nom_to_exp (swap w y t)) \u {{w}} \u {{y}}).

       (* Use the lemma above to change out the closed variables with
          the fresh one. *)
       rewrite (close_exp_wrt_exp_freshen y z); auto.
       rewrite (close_exp_wrt_exp_freshen w z); auto.

       (* Push the outer substitution into the expression *)
       rewrite subst_exp_close_exp_wrt_exp; auto.

       (* Now use IH three times to rearrange the swaps and substitutions. *)
       rewrite IHm with (y:=z); default_steps.
       rewrite IHm with (y:=z); default_steps.
       rewrite IHm with (y:=y); default_steps.

       rewrite shuffle_swap; auto.

       (* show freshness from last IH *)
       rewrite <- fv_nom_fv_exp_eq.
       apply fv_nom_swap.
       rewrite fv_nom_fv_exp_eq.
       fsetdec.
    }
    { (* neither w or y are binder in the abs case *)
       rewrite <- IHm; default_steps.
       autorewrite with lngen in *.
       fsetdec.
    }
  + rewrite IHm; auto; try omega; try fsetdec.
    rewrite IHm; auto; try omega; try fsetdec.
Qed.

Lemma swap_spec : forall t w y,
    y `notin` fv_exp (nom_to_exp t) ->
    w <> y ->
    [w ~> var_f y] (nom_to_exp t) =
    nom_to_exp (swap w y t).
Proof.
  intros.
  eapply swap_spec_aux with (t:=t)(m:=size t); auto.
Qed.

(***********************************************************************)
(** ** Connection for alpha-equivalence                                 *)
(***********************************************************************)

(** *** Challenge Exercise: [aeq_nom_to_exp]

    Show that alpha-equivalence for the nominal representation is definitional
    equality for LN terms.

    This result is not necessary for the simulation lemmas below, but it
    is another example of the a proof that takes advantage of the
    [swap_spec] and [close_exp_wrt_exp_freshen] lemmas  above.

    The second proof is much more challenging than the first and requires
    lemmas from [Lemmas.v].

*)

Lemma aeq_nom_to_exp : forall n1 n2, aeq n1 n2 -> nom_to_exp n1 = nom_to_exp n2.
Proof.
  (* SOLUTION: *)
  induction 1; default_simp;
  autorewrite with lngen in *.
  - congruence.
  - rewrite (close_exp_wrt_exp_freshen y x); auto.
    rewrite swap_spec; auto.
    congruence.
Qed.
Lemma nom_to_exp_eq_aeq : forall n1 n2, nom_to_exp n1 = nom_to_exp n2 -> aeq n1 n2.
Proof.
  (* SOLUTION: *)
  induction n1; intro n2; destruct n2; default_simp.
  destruct (x == x0).
  - subst. eauto with lngen.
  - assert (FX : x `notin` fv_exp (nom_to_exp n2)).
    { intro IN.
      assert (x `in` fv_exp (nom_to_exp (n_abs x0 n2))).
      { simpl. autorewrite with lngen. fsetdec. }
      simpl in *.
      rewrite <- H0 in H.
      autorewrite with lngen in *.
      fsetdec. }
    eapply aeq_abs_diff; auto.
    + autorewrite with lngen. auto.
    + eapply IHn1.
      rewrite <- swap_spec; eauto.
      rewrite subst_exp_spec.
      rewrite <- H0.
      autorewrite with lngen.
      auto.
Qed.
(***********************************************************************)
(** * Scoped configurations                                            *)
(***********************************************************************)

(** Not all abstract machine steps simulate small-steps of the
    substitution-based STLC.

    For example, if the domain of the heap is not unique (i.e. it has
    multiple definitions for the same variable) then its evaluation may
    not produce expected results.

    Similarly, if the [avoid] set that we pass to each machine step does
    not include initial the free variables of the term, then we could
    capture them in strange ways.

    Therefore, we will restrict our correctness lemmas so that they only
    apply to _well-scoped_ configurations; as defined below. *)

(***********************************************************************)
(** ** Scoped heaps                                                    *)
(***********************************************************************)

(** Well-scoped heaps behave "telescopically".  Each binding (x,e) added
    to the heap is for a unique name x and the free variables of e are
    bound in the remainder of the heap.

    The scoping relation is parameterized by [D], an "ambient
    scope". This will let us reason about the execution of the abstract
    machine for terms with free variables. *)

Inductive scoped_heap (D : atoms) : heap -> Prop :=
  | scoped_nil  : scoped_heap D nil
  | scoped_cons : forall x e h,
      x `notin` dom h \u D ->
      fv_exp (nom_to_exp e) [<=] dom h \u D ->
      scoped_heap D h ->
      scoped_heap D ((x,e)::h).

(** *** Recommended (Challenge) Exercise [apply_heap_get]

    We can use [get] to look up expressions in the heap. However, to know that
    we have the right result we need to know that the heap is well-scoped,
    i.e.  that later bindings do not affect earlier ones.

    State a lemma about the scoping of expressions that appear in the heap and
    use it to finish the [apply_heap_get] lemma below.  *)

(* SOLUTION: *)
Lemma scoped_get : forall h D1 D2 x e,
  scoped_heap D1 h ->
  get x h = Some e ->
  dom h \u D1 [<=] D2 ->
  fv_exp (nom_to_exp e) [<=] D2.
Proof.
  induction 1; intros; default_simp.
  fsetdec.
  eapply IHscoped_heap; auto; fsetdec.
Qed.

Lemma apply_heap_get :  forall h D x e,
    scoped_heap D h ->
    get x h = Some e ->
    apply_heap h (var_f x) = apply_heap h (nom_to_exp e).
Proof.
  induction 1; intros; default_simp.
  - Case "x is at the current heap location".
    rewrite subst_exp_fresh_eq; auto. fsetdec.
  - Case "x is later in the heap".
    rewrite subst_exp_fresh_eq; auto.
    (* SOLUTION: *)
    rewrite scoped_get with (D2:= dom h\u D ); default_simp; eauto.
Qed.
(***********************************************************************)
(** ** Scoped stacks                                                    *)
(***********************************************************************)

(** We also care about the free variables that can appear in stacks. (We
    will use this in the definition of well-scoped configurations below.)
*)

Fixpoint fv_stack s :=
  match s with
    nil => {}
  | n_app2 e :: s => fv_exp (nom_to_exp e) \u fv_stack s
  end.

(** Stacks that are well-scoped can discard irrelevant bindings
    from the heap. *)

Lemma apply_stack_fresh_eq : forall s x e1 h ,
    x `notin` fv_stack s ->
    apply_stack ((x, e1) :: h) s = apply_stack h s.
Proof.
  (* WORKED IN CLASS *)
  induction s; intros; try destruct a; default_simp.
  rewrite IHs; auto.
Qed.

(***********************************************************************)
(** * Simulation                                                       *)
(***********************************************************************)

(** A scoped configuration is one where all free variables in terms
    are either bound in the heap or come from [D] *)
Inductive scoped_conf : atoms -> configuration -> Prop :=
  scoped_conf_witness : forall D h e s,
    scoped_heap D h ->
    fv_exp (nom_to_exp e) [<=] dom h \u D ->
    fv_stack s [<=] dom h \u D  ->
    scoped_conf D (h,e,s).

(** *** Exercise [simulate_step]

    After stepping through the simulation result below, finish the
    missing case.

*)

(* Could be zero or one steps! *)
Lemma simulate_step : forall D h e s h' e' s' ,
    machine_step (dom h `union` D) (h,e,s) = TakeStep _ (h',e',s') ->
    scoped_conf D (h,e,s) ->
    decode (h,e,s) = decode (h',e',s') \/
    step (decode (h,e,s)) (decode (h',e',s')).
Proof.
  intros D h e s h' e' s' STEP SCOPE.
  inversion SCOPE; subst; clear SCOPE.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s.
  - inversion STEP.
  - destruct f eqn:?.
    + destruct e eqn:?; try solve [inversion STEP].
      right.
      destruct AtomSetProperties.In_dec.
      * (* Application case, we need to generate a fresh
           variable. *)

        destruct atom_fresh.
        inversion STEP; subst; clear STEP.

        (* simplify the context. *)
        simpl in *; autorewrite with lngen in *.
        (* but not too much *)
        rewrite combine.

        (* x0 is a fresh variable, so we can drop it from
           the heap in apply_stack. *)
        rewrite apply_stack_fresh_eq; auto; try fsetdec.
        (* before and after confs use the same stack. So we can step
           congruently. *)
        apply apply_stack_cong.

        simpl.

        (* pull the swap out as a freshening substitution *)
        assert (x <> x0) by fsetdec.
        rewrite <- swap_spec; auto; try fsetdec.
        rewrite (subst_exp_spec _ _ x).
        autorewrite with lngen; auto with lngen.
        default_simp.
        rewrite subst_exp_fresh_eq; autorewrite with lngen; auto.

        (* in the form that matches step beta *)
        apply step_beta; auto with lngen.
        rewrite <- apply_heap_abs.
        eapply apply_heap_lc.
        auto with lngen.

        rewrite H4. fsetdec.
      * (* Homework: Application case, the variable in the abstraction
           is fresh enough. *)
        (* SOLUTION: *)
        inversion STEP; subst; clear STEP;
          simpl in *;
          rewrite combine;
          rewrite apply_stack_fresh_eq; auto; try fsetdec.
        apply apply_stack_cong;
          autorewrite with lngen in *;
          simpl.
        rewrite subst_exp_spec.
        rewrite apply_heap_open; auto with lngen.

        apply step_beta; auto with lngen.
        rewrite <- apply_heap_abs.
        eapply apply_heap_lc.
        auto with lngen.
          - destruct e eqn:?; try solve [inversion STEP].
    + (* Expression is a variable, lookup in heap *)
      destruct (get x h) eqn:?; inversion STEP; subst; clear STEP.
      left.
      f_equal.
      apply apply_heap_get with (D:= D); auto.
    + (* Expression is an application, push arg on stack *)
      inversion STEP; subst; clear STEP.
      left.
      simpl.
      rewrite apply_heap_app.
      auto.
(* SOLUTION: *) Qed.
(** *** Exercise [simulate_done]

    Show that if the machine says [Done] then the LN term is a value.
*)

Lemma simulate_done : forall D h e s,
    machine_step (dom h \u D) (h,e,s) = Done _ ->
    scoped_conf D (h,e,s) ->
    is_value (nom_to_exp e).
Proof. (* SOLUTION: *)
  intros.
  inversion H0; subst.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s eqn:?.
  - destruct e; simpl in Heqb; inversion Heqb.
    econstructor; eauto.
  - destruct f eqn:?.
     + destruct e eqn:?; simpl; try solve [inversion H].
       econstructor; eauto.
  - destruct e; inversion H.
    simpl in Heqb. destruct (get x h); inversion H.
Qed.

(** *** Challenge exercise [simulate_error]

    Show that if the machine produces an error, the small step relation
    is stuck.

    This is a challenge exercise because you will need to figure out
    at least one nontrivial auxiliary lemma.

*)

(* SOLUTION: *)
Lemma apply_heap_get_none : forall x h,
    get x h = None ->
    apply_heap h (var_f x) = var_f x.
Proof.
  intros.
  alist induction h; simpl in *; auto.
  default_simp.
Qed.

Lemma no_step_stack : forall s h e0,
  not (is_value e0) ->
  not (exists e0', step e0 e0') ->
  not (exists e1, step (apply_stack h s e0) e1).
Proof.
  induction s; intros; try destruct a; simpl in *; auto.
  intros [e1 STEP].
  assert (K1: not (exists e1', step (app e0 (apply_heap h (nom_to_exp n))) e1')).
  { intros [e1' SS].
    inversion SS. subst. simpl in *. contradiction.
    subst. eauto. }
  assert (K2: not (is_value (app e0 (apply_heap h (nom_to_exp n))))).
  { simpl. auto. }
  pose (K := IHs h _ K2 K1). clearbody K.
  eauto.
Qed.

Lemma simulate_error : forall D h e s,
    machine_step (dom h \u D) (h,e,s) = Error _ ->
    scoped_conf D (h,e,s) ->
    not (exists e0, step (decode (h,e,s)) e0).
Proof.
(* SOLUTION: *)
  intros.
  simpl in *.
  destruct (isVal e) eqn:?.
  destruct s.
  - destruct e; try solve [inversion H]; simpl in Heqb; inversion Heqb.
  - destruct f eqn:?.
    destruct e eqn:?; try solve [inversion H]; simpl in Heqb; inversion Heqb.
    destruct (AtomSetProperties.In_dec).
    + destruct atom_fresh. inversion H.
    + inversion H.
  - destruct e; try solve [inversion H]; simpl in Heqb; inversion Heqb.
    destruct (get x h) eqn:?. inversion H.
    intros [e0 STEP].
    simpl in *.
    rewrite apply_heap_get_none in STEP; auto.
    eapply no_step_stack with (e0 := var_f x); auto.
       intros [e0' SS]. inversion SS. eauto.
Qed.
(***********************************************************************)

(** *** Challenge exercise [machine_is_scoped]

    Show that if the abstract machine is scoped, then any resulting
    configurations are also scoped. *)

Lemma machine_is_scoped: forall D h e s conf',
    machine_step (dom h \u D) (h,e,s) = TakeStep _ conf' ->
    scoped_conf D (h,e,s) ->
    scoped_conf D conf'.
Proof.
  (* SOLUTION: *)
  intros.
  simpl in H.
  inversion H0. subst.
  destruct (isVal e) eqn:?.
  destruct s eqn:?.
  - inversion H.
  - destruct f eqn:?.
     + destruct e eqn:?; try solve [inversion H].
       destruct AtomSetProperties.In_dec.
       ++ destruct atom_fresh.
          inversion H; subst; clear H.
          simpl in *.
          econstructor.
            -- econstructor; eauto. fsetdec.
            -- assert (x <> x0). fsetdec.
               autorewrite with lngen in *.
               rewrite <- swap_spec; try fsetdec.
               rewrite fv_exp_subst_exp_upper.
               simpl.
               fsetdec.
            -- simpl. fsetdec.
       ++ inversion H; subst; clear H.
          simpl in *.
          autorewrite with lngen in *.
          econstructor.
          -- econstructor; eauto. fsetdec.
          -- simpl.
             assert ((union (add x (dom h)) D) [=] (add x (union (dom h) D))).
             fsetdec. rewrite H.
             rewrite <- H6.
             eapply FSetDecideTestCases.test_Subset_add_remove.
          -- simpl. fsetdec.
  - destruct e eqn:?; try solve [inversion H].
    destruct (get x h) eqn:?;
    inversion H; subst; clear H.
    + split. auto.
      simpl in *.
      eapply scoped_get; eauto.
      fsetdec.
      auto.
    + simpl in *.
    inversion H; subst; clear H.
    econstructor.
    auto.
    fsetdec.
    simpl. fsetdec.
Qed.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo1.
Require Import Ranalysis.
Local Open Scope R_scope.

Definition Newton_integrable (f:R -> R) (a b:R) : Type :=
{ g:R -> R | antiderivative f g a b \/ antiderivative f g b a }.

Definition NewtonInt (f:R -> R) (a b:R) (pr:Newton_integrable f a b) : R :=
let (g,_) := pr in g b - g a.

Lemma FTCN_step1 :
forall (f:Differential) (a b:R),
Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
Proof. hammer_hook "NewtonInt" "NewtonInt.FTCN_step1".
intros f a b; unfold Newton_integrable; exists (d1 f);
unfold antiderivative; intros; case (Rle_dec a b);
intro;
[ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
| right; split;
[ intros; exists (cond_diff f x); reflexivity | auto with real ] ].
Defined.

Lemma FTC_Newton :
forall (f:Differential) (a b:R),
NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b
(FTCN_step1 f a b) = f b - f a.
Proof. hammer_hook "NewtonInt" "NewtonInt.FTC_Newton".
intros; unfold NewtonInt; reflexivity.
Qed.

Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P1".
intros f a; unfold Newton_integrable;
exists (fct_cte (f a) * id)%F; left;
unfold antiderivative; split.
intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x).
apply derivable_pt_mult.
apply derivable_pt_const.
apply derivable_pt_id.
exists H1; assert (H2 : x = a).
elim H; intros; apply Rle_antisym; assumption.
symmetry ; apply derive_pt_eq_0;
replace (f x) with (0 * id x + fct_cte (f a) x * 1);
[ apply (derivable_pt_lim_mult (fct_cte (f a)) id x);
[ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
| unfold id, fct_cte; rewrite H2; ring ].
right; reflexivity.
Qed.

Lemma NewtonInt_P2 :
forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P2".
intros; unfold NewtonInt; simpl;
unfold mult_fct, fct_cte, id.
destruct NewtonInt_P1 as [g _].
now apply Rminus_diag_eq.
Qed.

Lemma NewtonInt_P3 :
forall (f:R -> R) (a b:R) (X:Newton_integrable f a b),
Newton_integrable f b a.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P3".
unfold Newton_integrable; intros; elim X; intros g H;
exists g; tauto.
Defined.

Lemma NewtonInt_P4 :
forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b),
NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P4".
intros f a b (x,H). unfold NewtonInt, NewtonInt_P3; simpl; ring.
Qed.

Lemma NewtonInt_P5 :
forall (f g:R -> R) (l a b:R),
Newton_integrable f a b ->
Newton_integrable g a b ->
Newton_integrable (fun x:R => l * f x + g x) a b.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P5".
unfold Newton_integrable; intros f g l a b X X0;
elim X; intros x p; elim X0; intros x0 p0;
exists (fun y:R => l * x y + x0 y).
elim p; intro.
elim p0; intro.
left; unfold antiderivative; unfold antiderivative in H, H0; elim H;
clear H; intros; elim H0; clear H0; intros H0 _.
split.
intros; elim (H _ H2); elim (H0 _ H2); intros.
assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
reg.
exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity.
assumption.
unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
left; rewrite <- H5; unfold antiderivative; split.
intros; elim H6; intros; assert (H9 : x1 = a).
apply Rle_antisym; assumption.
assert (H10 : a <= x1 <= b).
split; right; [ symmetry ; assumption | rewrite <- H5; assumption ].
assert (H11 : b <= x1 <= a).
split; right; [ rewrite <- H5; symmetry ; assumption | assumption ].
assert (H12 : derivable_pt x x1).
unfold derivable_pt; exists (f x1); elim (H3 _ H10); intros;
eapply derive_pt_eq_1; symmetry ; apply H12.
assert (H13 : derivable_pt x0 x1).
unfold derivable_pt; exists (g x1); elim (H1 _ H11); intros;
eapply derive_pt_eq_1; symmetry ; apply H13.
assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
reg.
exists H14; symmetry ; reg.
assert (H15 : derive_pt x0 x1 H13 = g x1).
elim (H1 _ H11); intros; rewrite H15; apply pr_nu.
assert (H16 : derive_pt x x1 H12 = f x1).
elim (H3 _ H10); intros; rewrite H16; apply pr_nu.
rewrite H15; rewrite H16; ring.
right; reflexivity.
elim p0; intro.
unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
left; rewrite H5; unfold antiderivative; split.
intros; elim H6; intros; assert (H9 : x1 = a).
apply Rle_antisym; assumption.
assert (H10 : a <= x1 <= b).
split; right; [ symmetry ; assumption | rewrite H5; assumption ].
assert (H11 : b <= x1 <= a).
split; right; [ rewrite H5; symmetry ; assumption | assumption ].
assert (H12 : derivable_pt x x1).
unfold derivable_pt; exists (f x1); elim (H3 _ H11); intros;
eapply derive_pt_eq_1; symmetry ; apply H12.
assert (H13 : derivable_pt x0 x1).
unfold derivable_pt; exists (g x1); elim (H1 _ H10); intros;
eapply derive_pt_eq_1; symmetry ; apply H13.
assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
reg.
exists H14; symmetry ; reg.
assert (H15 : derive_pt x0 x1 H13 = g x1).
elim (H1 _ H10); intros; rewrite H15; apply pr_nu.
assert (H16 : derive_pt x x1 H12 = f x1).
elim (H3 _ H11); intros; rewrite H16; apply pr_nu.
rewrite H15; rewrite H16; ring.
right; reflexivity.
right; unfold antiderivative; unfold antiderivative in H, H0; elim H;
clear H; intros; elim H0; clear H0; intros H0 _; split.
intros; elim (H _ H2); elim (H0 _ H2); intros.
assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
reg.
exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity.
assumption.
Defined.

Lemma antiderivative_P1 :
forall (f g F G:R -> R) (l a b:R),
antiderivative f F a b ->
antiderivative g G a b ->
antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b.
Proof. hammer_hook "NewtonInt" "NewtonInt.antiderivative_P1".
unfold antiderivative; intros; elim H; elim H0; clear H H0; intros;
split.
intros; elim (H _ H3); elim (H1 _ H3); intros.
assert (H6 : derivable_pt (fun x:R => l * F x + G x) x).
reg.
exists H6; symmetry ; reg; rewrite <- H4; rewrite <- H5; ring.
assumption.
Qed.

Lemma NewtonInt_P6 :
forall (f g:R -> R) (l a b:R) (pr1:Newton_integrable f a b)
(pr2:Newton_integrable g a b),
NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) =
l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P6".
intros f g l a b pr1 pr2; unfold NewtonInt;
destruct (NewtonInt_P5 f g l a b pr1 pr2) as (x,o); destruct pr1 as (x0,o0);
destruct pr2 as (x1,o1); destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
elim o; intro.
elim o0; intro.
elim o1; intro.
assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1);
assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2);
elim H3; intros; assert (H5 : a <= a <= b).
split; [ right; reflexivity | left; assumption ].
assert (H6 : a <= b <= b).
split; [ left; assumption | right; reflexivity ].
assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
unfold antiderivative in H1; elim H1; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)).
unfold antiderivative in H0; elim H0; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).
unfold antiderivative in H; elim H; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)).
rewrite Heq; ring.
elim o; intro.
unfold antiderivative in H; elim H; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hgt)).
elim o0; intro.
unfold antiderivative in H0; elim H0; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)).
elim o1; intro.
unfold antiderivative in H1; elim H1; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hgt)).
assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2);
elim H3; intros; assert (H5 : b <= a <= a).
split; [ left; assumption | right; reflexivity ].
assert (H6 : b <= b <= a).
split; [ right; reflexivity | left; assumption ].
assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
Qed.

Lemma antiderivative_P2 :
forall (f F0 F1:R -> R) (a b c:R),
antiderivative f F0 a b ->
antiderivative f F1 b c ->
antiderivative f
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) a c.
Proof. hammer_hook "NewtonInt" "NewtonInt.antiderivative_P2".
intros; destruct H as (H,H1), H0 as (H0,H2); split.
2: apply Rle_trans with b; assumption.
intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt].
assert (H5 : a <= x <= b).
split; [ assumption | left; assumption ].
destruct (H _ H5) as (x0,H6).
assert
(H7 :
derivable_pt_lim
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x (f x)).
unfold derivable_pt_lim. intros eps H9.
assert (H7 : derive_pt F0 x x0 = f x) by (symmetry; assumption).
destruct (derive_pt_eq_1 F0 x (f x) x0 H7 _ H9) as (x1,H10); set (D := Rmin x1 (b - x)).
assert (H11 : 0 < D).
unfold D, Rmin; case (Rle_dec x1 (b - x)); intro.
apply (cond_pos x1).
apply Rlt_Rminus; assumption.
exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]].
case (Rle_dec (x + h) b) as [|[]].
apply H10.
assumption.
apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
left; apply Rlt_le_trans with (x + D).
apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
apply RRle_abs.
apply H13.
apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
rewrite Rplus_0_l; rewrite Rplus_comm; unfold D;
apply Rmin_r.
left; assumption.
assert
(H8 :
derivable_pt
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x).
unfold derivable_pt; exists (f x); apply H7.
exists H8; symmetry ; apply derive_pt_eq_0; apply H7.
assert (H5 : a <= x <= b).
split; [ assumption | right; assumption ].
assert (H6 : b <= x <= c).
split; [ right; symmetry ; assumption | assumption ].
elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x).
symmetry ; assumption.
assert (H10 : derive_pt F1 x x0 = f x).
symmetry ; assumption.
assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9);
assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10);
assert
(H13 :
derivable_pt_lim
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x (f x)).
unfold derivable_pt_lim; unfold derivable_pt_lim in H11, H12; intros;
elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3);
assert (H16 : 0 < D).
unfold D; unfold Rmin; case (Rle_dec x2 x3); intro.
apply (cond_pos x2).
apply (cond_pos x3).
exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]].
case (Rle_dec (x + h) b); intro.
apply H15.
assumption.
apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_r ].
replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x).
apply H14.
assumption.
apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
rewrite Heq; ring.
right; assumption.
assert
(H14 :
derivable_pt
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x).
unfold derivable_pt; exists (f x); apply H13.
exists H14; symmetry ; apply derive_pt_eq_0; apply H13.
assert (H5 : b <= x <= c).
split; [ left; assumption | assumption ].
assert (H6 := H0 _ H5); elim H6; clear H6; intros;
assert
(H7 :
derivable_pt_lim
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x (f x)).
unfold derivable_pt_lim; assert (H7 : derive_pt F1 x x0 = f x).
symmetry ; assumption.
assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8;
intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b));
assert (H11 : 0 < D).
unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro.
apply (cond_pos x1).
apply Rlt_Rminus; assumption.
exists (mkposreal _ H11); intros; destruct (Rle_dec x b) as [Hle|Hnle].
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)).
destruct (Rle_dec (x + h) b) as [Hle'|Hnle'].
cut (b < x + h).
intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)).
apply Rplus_lt_reg_l with (- h - b); replace (- h - b + b) with (- h);
[ idtac | ring ]; replace (- h - b + (x + h)) with (x - b);
[ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
rewrite <- Rabs_Ropp; apply RRle_abs.
apply Rlt_le_trans with D.
apply H13.
unfold D; apply Rmin_r.
replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with
(F1 (x + h) - F1 x); [ idtac | ring ]; apply H10.
assumption.
apply Rlt_le_trans with D.
assumption.
unfold D; apply Rmin_l.
assert
(H8 :
derivable_pt
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end) x).
unfold derivable_pt; exists (f x); apply H7.
exists H8; symmetry ; apply derive_pt_eq_0; apply H7.
Qed.

Lemma antiderivative_P3 :
forall (f F0 F1:R -> R) (a b c:R),
antiderivative f F0 a b ->
antiderivative f F1 c b ->
antiderivative f F1 c a \/ antiderivative f F0 a c.
Proof. hammer_hook "NewtonInt" "NewtonInt.antiderivative_P3".
intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
intros; destruct (total_order_T a c) as [[Hle|Heq]|Hgt].
right; unfold antiderivative; split.
intros; apply H1; elim H3; intros; split;
[ assumption | apply Rle_trans with c; assumption ].
left; assumption.
right; unfold antiderivative; split.
intros; apply H1; elim H3; intros; split;
[ assumption | apply Rle_trans with c; assumption ].
right; assumption.
left; unfold antiderivative; split.
intros; apply H; elim H3; intros; split;
[ assumption | apply Rle_trans with a; assumption ].
left; assumption.
Qed.

Lemma antiderivative_P4 :
forall (f F0 F1:R -> R) (a b c:R),
antiderivative f F0 a b ->
antiderivative f F1 a c ->
antiderivative f F1 b c \/ antiderivative f F0 c b.
Proof. hammer_hook "NewtonInt" "NewtonInt.antiderivative_P4".
intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
intros; destruct (total_order_T c b) as [[Hlt|Heq]|Hgt].
right; unfold antiderivative; split.
intros; apply H1; elim H3; intros; split;
[ apply Rle_trans with c; assumption | assumption ].
left; assumption.
right; unfold antiderivative; split.
intros; apply H1; elim H3; intros; split;
[ apply Rle_trans with c; assumption | assumption ].
right; assumption.
left; unfold antiderivative; split.
intros; apply H; elim H3; intros; split;
[ apply Rle_trans with b; assumption | assumption ].
left; assumption.
Qed.

Lemma NewtonInt_P7 :
forall (f:R -> R) (a b c:R),
a < b ->
b < c ->
Newton_integrable f a b ->
Newton_integrable f b c -> Newton_integrable f a c.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P7".
unfold Newton_integrable; intros f a b c Hab Hbc X X0; elim X;
clear X; intros F0 H0; elim X0; clear X0; intros F1 H1;
set
(g :=
fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end); exists g; left; unfold g;
apply antiderivative_P2.
elim H0; intro.
assumption.
unfold antiderivative in H; elim H; clear H; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)).
elim H1; intro.
assumption.
unfold antiderivative in H; elim H; clear H; intros;
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)).
Qed.

Lemma NewtonInt_P8 :
forall (f:R -> R) (a b c:R),
Newton_integrable f a b ->
Newton_integrable f b c -> Newton_integrable f a c.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P8".
intros.
elim X; intros F0 H0.
elim X0; intros F1 H1.
destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].

unfold Newton_integrable;
exists
(fun x:R =>
match Rle_dec x b with
| left _ => F0 x
| right _ => F1 x + (F0 b - F1 b)
end).
elim H0; intro.
elim H1; intro.
left; apply antiderivative_P2; assumption.
unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')).
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).

rewrite Heq' in X; apply X.

destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt''].
unfold Newton_integrable; exists F0.
left.
elim H1; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
elim H0; intro.
assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
elim H3; intro.
unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')).
assumption.
unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).
rewrite Heq''; apply NewtonInt_P1.
unfold Newton_integrable; exists F1.
right.
elim H1; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
elim H0; intro.
assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
elim H3; intro.
assumption.
unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')).
unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).

rewrite Heq; apply X0.
destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].

destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt''].
unfold Newton_integrable; exists F1.
left.
elim H1; intro.

elim H0; intro.
unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)).
assert (H3 := antiderivative_P4 f F0 F1 b a c H2 H).
elim H3; intro.
assumption.
unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')).
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt')).
rewrite Heq''; apply NewtonInt_P1.
unfold Newton_integrable; exists F0.
right.
elim H0; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
elim H1; intro.
assert (H3 := antiderivative_P4 f F0 F1 b a c H H2).
elim H3; intro.
unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')).
assumption.
unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')).

rewrite Heq' in X; apply X.

assert (X1 := NewtonInt_P3 f a b X).
assert (X2 := NewtonInt_P3 f b c X0).
apply NewtonInt_P3.
apply NewtonInt_P7 with b; assumption.
Qed.

Lemma NewtonInt_P9 :
forall (f:R -> R) (a b c:R) (pr1:Newton_integrable f a b)
(pr2:Newton_integrable f b c),
NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) =
NewtonInt f a b pr1 + NewtonInt f b c pr2.
Proof. hammer_hook "NewtonInt" "NewtonInt.NewtonInt_P9".
intros; unfold NewtonInt.
case (NewtonInt_P8 f a b c pr1 pr2) as (x,Hor).
case pr1 as (x0,Hor0).
case pr2 as (x1,Hor1).
destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].

case Hor0; intro.
case Hor1; intro.
case Hor; intro.
assert (H2 := antiderivative_P2 f x0 x1 a b c H H0).
assert
(H3 :=
antiderivative_Ucte f x
(fun x:R =>
match Rle_dec x b with
| left _ => x0 x
| right _ => x1 x + (x0 b - x1 b)
end) a c H1 H2).
elim H3; intros.
assert (H5 : a <= a <= c).
split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ].
assert (H6 : a <= c <= c).
split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ].
rewrite (H4 _ H5); rewrite (H4 _ H6).
destruct (Rle_dec a b) as [Hlea|Hnlea].
destruct (Rle_dec c b) as [Hlec|Hnlec].
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlec Hlt')).
ring.
elim Hnlea; left; assumption.
unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hlt Hlt'))).
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt')).
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).

rewrite <- Heq'.
unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
rewrite <- Heq' in Hor.
elim Hor0; intro.
elim Hor; intro.
assert (H1 := antiderivative_Ucte f x x0 a b H0 H).
elim H1; intros.
rewrite (H2 b).
rewrite (H2 a).
ring.
split; [ right; reflexivity | left; assumption ].
split; [ left; assumption | right; reflexivity ].
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)).
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).

elim Hor1; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
elim Hor0; intro.
elim Hor; intro.
assert (H2 := antiderivative_P2 f x x1 a c b H1 H).
assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2).
elim H3; intros.
rewrite (H4 a).
rewrite (H4 b).
destruct (Rle_dec b c) as [Hle|Hnle].
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt')).
destruct (Rle_dec a c) as [Hle'|Hnle'].
ring.
elim Hnle'; unfold antiderivative in H1; elim H1; intros; assumption.
split; [ left; assumption | right; reflexivity ].
split; [ right; reflexivity | left; assumption ].
assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0).
assert (H3 := antiderivative_Ucte _ _ _ c b H H2).
elim H3; intros.
rewrite (H4 c).
rewrite (H4 b).
destruct (Rle_dec b a) as [Hle|Hnle].
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)).
destruct (Rle_dec c a) as [Hle'|[]].
ring.
unfold antiderivative in H1; elim H1; intros; assumption.
split; [ left; assumption | right; reflexivity ].
split; [ right; reflexivity | left; assumption ].
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)).

rewrite Heq in Hor |- *.
elim Hor; intro.
elim Hor1; intro.
assert (H1 := antiderivative_Ucte _ _ _ b c H H0).
elim H1; intros.
assert (H3 : b <= c).
unfold antiderivative in H; elim H; intros; assumption.
rewrite (H2 b).
rewrite (H2 c).
ring.
split; [ assumption | right; reflexivity ].
split; [ right; reflexivity | assumption ].
assert (H1 : b = c).
unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
assumption.
rewrite H1; ring.
elim Hor1; intro.
assert (H1 : b = c).
unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
assumption.
rewrite H1; ring.
assert (H1 := antiderivative_Ucte _ _ _ c b H H0).
elim H1; intros.
assert (H3 : c <= b).
unfold antiderivative in H; elim H; intros; assumption.
rewrite (H2 c).
rewrite (H2 b).
ring.
split; [ assumption | right; reflexivity ].
split; [ right; reflexivity | assumption ].

destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].
elim Hor0; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
elim Hor1; intro.
elim Hor; intro.
assert (H2 := antiderivative_P2 _ _ _ _ _ _ H H1).
assert (H3 := antiderivative_Ucte _ _ _ b c H0 H2).
elim H3; intros.
rewrite (H4 b).
rewrite (H4 c).
case (Rle_dec b a) as [|[]].
case (Rle_dec c a) as [|].
assert (H5 : a = c).
unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
rewrite H5; ring.
ring.
left; assumption.
split; [ left; assumption | right; reflexivity ].
split; [ right; reflexivity | left; assumption ].
assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H1).
assert (H3 := antiderivative_Ucte _ _ _ b a H H2).
elim H3; intros.
rewrite (H4 a).
rewrite (H4 b).
case (Rle_dec b c) as [|[]].
case (Rle_dec a c) as [|].
assert (H5 : a = c).
unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
rewrite H5; ring.
ring.
left; assumption.
split; [ right; reflexivity | left; assumption ].
split; [ left; assumption | right; reflexivity ].
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt')).

rewrite <- Heq'.
unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
rewrite <- Heq' in Hor.
elim Hor0; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
elim Hor; intro.
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt)).
assert (H1 := antiderivative_Ucte f x x0 b a H0 H).
elim H1; intros.
rewrite (H2 b).
rewrite (H2 a).
ring.
split; [ left; assumption | right; reflexivity ].
split; [ right; reflexivity | left; assumption ].

elim Hor0; intro.
unfold antiderivative in H; elim H; clear H; intros _ H.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
elim Hor1; intro.
unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt')).
elim Hor; intro.
unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hgt' Hgt))).
assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H).
assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2).
elim H3; intros.
assert (H5 : c <= a).
unfold antiderivative in H1; elim H1; intros; assumption.
rewrite (H4 c).
rewrite (H4 a).
destruct (Rle_dec a b) as [Hle|Hnle].
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)).
destruct (Rle_dec c b) as [|[]].
ring.
left; assumption.
split; [ assumption | right; reflexivity ].
split; [ right; reflexivity | assumption ].
Qed.


Require Import Utf8 Arith.
Require List.
Import List.ListNotations.
Open Scope list_scope.

Notation "x < y <= z" := (x < y ∧ y <= z) (at level 70, y at next level).
Notation "x < y < z" := (x < y ∧ y < z) (at level 70, y at next level).
Notation "x < y ≤ z" := (x < y ∧ y <= z)%nat (at level 70, y at next level).
Notation "x ≤ y ≤ z" := (x <= y ∧ y <= z)%nat (at level 70, y at next level).
Notation "x ≤ y < z" := (x <= y ∧ y < z)%nat (at level 70, y at next level).

Theorem Nat_le_neq_lt : ∀ a b, a ≤ b → a ≠ b → a < b.
Proof.
intros a b Hab Hnab.
apply le_lt_eq_dec in Hab.
now destruct Hab.
Qed.

Theorem Nat_eq_add_2 : ∀ a b, a + b = 2
  → a = 2 ∧ b = 0 ∨ a = 1 ∧ b = 1 ∨ a = 0 ∧ b = 2.
Proof.
intros * Hab.
destruct a; [ now right; right | ].
destruct a. {
  right; left.
  split; [ easy | ].
  change 2 with (1 + 1) in Hab.
  now apply Nat.add_cancel_l in Hab.
}
destruct a; [ | easy ].
left.
split; [ easy | ].
change 2 with (2 + 0) in Hab at 2.
now apply Nat.add_cancel_l in Hab.
Qed.

(*
Definition Nat_le_neq_lt₁ : ∀ a b, a ≤ b → a ≠ b → a < b :=
  λ (a b : nat) (Hab : a ≤ b) (Hnab : a ≠ b),
  match le_lt_eq_dec a b Hab with
  | left Hle => Hle
  | right Heq => match Hnab Heq with end
  end.
*)

Theorem list_Forall_inv : ∀ A (P : A → Prop) a l,
  List.Forall P (a :: l) → P a ∧ List.Forall P l.
Proof.
intros A P a l H.
now inversion H.
Qed.

(*
Definition list_Forall_inv₁ : ∀ A (P : A → Prop) a l,
  List.Forall P (a :: l) → P a ∧ List.Forall P l
:=
  λ _ P a l H,
  match H in (List.Forall _ l') return (l' = a :: l → P a ∧ List.Forall P l) with
  | List.Forall_nil _ => λ H1, match H1 with eq_refl => I end
  | List.Forall_cons _ px pl => λ H1, match H1 with eq_refl => conj px pl end
  end eq_refl.
*)

(*
Inductive myForall (A : Type) (P : A → Type) : list A → Type :=
    myForall_nil : myForall _ P []
  | myForall_cons : ∀ (x : A) (l : list A), P x → myForall _ P l → myForall _ P (x :: l).

Definition list_Forall_inv₁ : ∀ A (P : A → Type) a l,
  myForall _ P (a :: l) → P a * myForall _ P l
:=
  λ _ P a l H,
  match H with
  | myForall_cons _ _ _ _ px pl => (px, pl)
  end.
*)

Theorem last_cons_id : ∀ A (a : A) al,
  List.last al a ≠ a
  → List.last (a :: al) a ≠ a.
Proof.
intros * Hal.
now destruct al.
Qed.

(*
Definition last_cons_id₁ : ∀ A (a : A) al,
  List.last al a ≠ a
  → List.last (a :: al) a ≠ a
:=
  λ A (a : A) (al : list A),
  match al as l return (List.last l a ≠ a → List.last (a :: l) a ≠ a) with
  | [] => id
  | _ :: _ => id
  end.
*)

Theorem last_cons_cons : ∀ A (a b : A) al d,
  List.last (a :: b :: al) d = List.last (b :: al) d.
Proof. easy. Qed.

(*
Definition last_cons_cons₁ : ∀ A (a b : A) al d,
  List.last (a :: b :: al) d = List.last (b :: al) d
:=
  λ _ _ _ _ _, eq_refl.
*)

Theorem last_cons_ne : ∀ A (a d : A) al,
  a ≠ d
  → List.last al d ≠ d
  → List.last (a :: al) d ≠ d.
Proof.
intros * Had Hal.
revert a Had.
induction al as [| a1]; intros; [ easy | ].
rewrite last_cons_cons.
simpl in Hal.
destruct al as [| a2]; [ easy | ].
now rewrite last_cons_cons.
Qed.

Theorem List_cons_comm_app : ∀ A (x : A) l l', l ++ x :: l' = l ++ [x] ++ l'.
Proof. easy. Qed.

Theorem Nat_mod_add_same_l : ∀ a b, a ≠ 0 → (a + b) mod a = b mod a.
Proof.
intros * Ha.
rewrite <- Nat.add_mod_idemp_l; [ | easy ].
now rewrite Nat.mod_same.
Qed.

Theorem Nat_mod_add_same_r : ∀ a b, b ≠ 0 → (a + b) mod b = a mod b.
Proof.
intros * Ha.
rewrite <- Nat.add_mod_idemp_r; [ | easy ].
now rewrite Nat.mod_same, Nat.add_0_r.
Qed.

Theorem Nat_div_add_same_l : ∀ a b, a ≠ 0 → (a + b) / a = 1 + b / a.
Proof.
intros * Ha.
replace a with (1 * a) at 1 by apply Nat.mul_1_l.
rewrite Nat.add_comm.
rewrite Nat.div_add; [ apply Nat.add_comm | easy ].
Qed.

Theorem Nat_div_add_same_r : ∀ a b, b ≠ 0 → (a + b) / b = a / b + 1.
Proof.
intros * Ha.
replace b with (1 * b) at 1 by apply Nat.mul_1_l.
now rewrite Nat.div_add.
Qed.

Theorem Nat_le_add_l : ∀ a b, b ≤ a + b.
Proof.
intros.
replace b with (0 + b) at 1 by easy.
apply Nat.add_le_mono_r.
apply Nat.le_0_l.
Qed.

Theorem Nat_add_sub_diag : ∀ a b c, b = c → a + b - c = a.
Proof.
intros * Hbc; subst b.
apply Nat.add_sub.
Qed.

Theorem Nat_mul_le_pos_l : ∀ a b, 1 ≤ a → b ≤ a * b.
Proof.
intros * Ha.
replace b with (1 * b) at 1 by apply Nat.mul_1_l.
apply Nat.mul_le_mono_nonneg_r; [ apply Nat.le_0_l | easy ].
Qed.

Theorem Nat_mul_le_pos_r : ∀ a b, 1 ≤ b → a ≤ a * b.
Proof.
intros * Ha.
replace a with (a * 1) at 1 by apply Nat.mul_1_r.
apply Nat.mul_le_mono_nonneg_l; [ apply Nat.le_0_l | easy ].
Qed.

Theorem Nat_sqr_sub_1 : ∀ a, a ^ 2 - 1 = (a + 1) * (a - 1).
Proof.
intros; simpl.
rewrite Nat.mul_sub_distr_l.
do 2 rewrite Nat.mul_1_r.
rewrite Nat.mul_add_distr_r.
rewrite Nat.mul_1_l.
rewrite Nat.sub_add_distr.
now rewrite Nat.add_sub.
Qed.

Theorem Nat_sqr_sub_1_mod : ∀ a, (a ^ 2 - 1) mod a = a - 1.
Proof.
intros.
destruct (zerop a) as [Ha| Ha]; [ now subst a | ].
assert (Haz : a ≠ 0) by (now intros H; subst a).
rewrite Nat_sqr_sub_1.
rewrite <- Nat.mul_mod_idemp_l; [ | easy ].
replace (a + 1) with (1 + 1 * a) by now rewrite Nat.mul_1_l, Nat.add_comm.
rewrite Nat.mod_add; [ | easy ].
destruct a; [ easy | ].
rewrite Nat.sub_succ, Nat.sub_0_r.
destruct a; [ easy | ].
rewrite Nat.mod_1_l.
-rewrite Nat.mul_1_l.
 rewrite Nat.mod_small; [ easy | apply Nat.lt_succ_diag_r ].
-apply -> Nat.succ_lt_mono.
 apply Nat.lt_0_succ.
Qed.

Theorem Nat_sqr_sub_1_div : ∀ a, (a ^ 2 - 1) / a = a - 1.
Proof.
intros.
destruct (zerop a) as [Ha| Ha]; [ now subst a | ].
assert (Haz : a ≠ 0) by (now intros H; subst a).
specialize (Nat.div_mod (a ^ 2 - 1) a Haz) as H.
apply Nat.mul_cancel_r with (p := a); [ easy | ].
apply Nat.add_cancel_r with (p := (a ^ 2 - 1) mod a).
rewrite Nat.mul_comm in H.
rewrite <- H; simpl; rewrite Nat.mul_1_r.
rewrite <- Nat.pow_2_r.
rewrite Nat_sqr_sub_1_mod; simpl.
rewrite Nat.mul_1_r.
rewrite <- Nat.pow_2_r.
rewrite Nat_sqr_sub_1.
now rewrite Nat.mul_comm, Nat.mul_add_distr_l, Nat.mul_1_r.
Qed.

Theorem Nat_sub_sub_swap : ∀ a b c, a - b - c = a - c - b.
Proof.
intros.
rewrite <- Nat.sub_add_distr.
rewrite Nat.add_comm.
now rewrite Nat.sub_add_distr.
Qed.

Theorem Nat_sub_sub_assoc : ∀ a b c,
  c ≤ b ≤ a + c
  → a - (b - c) = a + c - b.
Proof.
intros * (Hcb, Hba).
revert a c Hcb Hba.
induction b; intros.
-apply Nat.le_0_r in Hcb; subst c.
 now rewrite Nat.add_0_r.
-destruct c; [ now rewrite Nat.add_0_r | ].
 apply Nat.succ_le_mono in Hcb.
 rewrite Nat.add_succ_r in Hba.
 apply Nat.succ_le_mono in Hba.
 specialize (IHb a c Hcb Hba) as H1.
 rewrite Nat.sub_succ, H1.
 rewrite Nat.add_succ_r.
 now rewrite Nat.sub_succ.
Qed.

Theorem Nat_sub_sub_distr : ∀ a b c, c ≤ b ≤ a → a - (b - c) = a - b + c.
Proof.
intros.
rewrite <- Nat.add_sub_swap; [ | easy ].
apply Nat_sub_sub_assoc.
split; [ easy | ].
apply (Nat.le_trans _ a); [ easy | ].
apply Nat.le_add_r.
Qed.

Theorem Nat_mod_less_small : ∀ n a b,
  n * b ≤ a < (n + 1) * b
  → a mod b = a - n * b.
Proof.
intros * Hab.
assert (Hb : b ≠ 0). {
  now intros Hb; rewrite Hb, (Nat.mul_comm (n + 1)) in Hab.
}
replace a with (a - n * b + n * b) at 1 by now apply Nat.sub_add.
rewrite Nat.mod_add; [ | easy ].
apply Nat.mod_small.
apply Nat.add_lt_mono_r with (p := n * b).
rewrite Nat.add_comm in Hab; cbn in Hab.
now rewrite Nat.sub_add.
Qed.

Theorem Nat_div_less_small : ∀ n a b,
  n * b ≤ a < (n + 1) * b
  → a / b = n.
Proof.
intros * Hab.
assert (Hb : b ≠ 0). {
  now intros Hb; rewrite Hb, (Nat.mul_comm (n + 1)) in Hab.
}
replace a with (a - n * b + n * b) at 1 by now apply Nat.sub_add.
rewrite Nat.div_add; [ | easy ].
replace n with (0 + n) at 3 by easy; f_equal.
apply Nat.div_small.
apply Nat.add_lt_mono_r with (p := n * b).
rewrite Nat.add_comm in Hab; cbn in Hab.
now rewrite Nat.sub_add.
Qed.

Theorem Nat_div_add_div : ∀ a b c,
  b mod c < c - a
  → (a + b) / c = b / c.
Proof.
intros * Hb.
destruct c; [ easy | ].
specialize (Nat.div_mod b (S c) (Nat.neq_succ_0 c)) as H1.
rewrite H1.
rewrite Nat.add_comm, Nat.mul_comm, <- Nat.add_assoc.
rewrite Nat.div_add_l; [ | easy ].
rewrite Nat.div_add_l; [ | easy ].
f_equal.
rewrite Nat.div_small.
rewrite Nat.div_small; [ easy | ].
-now apply Nat.mod_upper_bound.
-now apply Nat.lt_add_lt_sub_r.
Qed.

Theorem Nat_gcd_le_l : ∀ a b, a ≠ 0 → Nat.gcd a b ≤ a.
Proof.
intros * Ha.
specialize (Nat.gcd_divide_l a b) as (c, Hc).
rewrite <- Nat.mul_1_l at 1.
rewrite Hc at 2.
apply Nat.mul_le_mono_pos_r.
-apply Nat.neq_0_lt_0.
 intros H.
 now apply Nat.gcd_eq_0_l in H.
-destruct c; [ easy | ].
 apply -> Nat.succ_le_mono.
 apply Nat.le_0_l.
Qed.

Theorem Nat_gcd_le_r : ∀ a b, b ≠ 0 → Nat.gcd a b ≤ b.
Proof.
intros * Hb.
rewrite Nat.gcd_comm.
now apply Nat_gcd_le_l.
Qed.

Theorem Nat_gcd_add_diag_l : ∀ n m, Nat.gcd (m + n) n = Nat.gcd m n.
Proof.
intros.
rewrite Nat.gcd_comm.
rewrite Nat.gcd_add_diag_r.
apply Nat.gcd_comm.
Qed.

Theorem Nat_gcd_sub_diag_l : ∀ n m, n ≤ m → Nat.gcd (m - n) n = Nat.gcd m n.
Proof.
intros * Hnm.
replace m with (m - n + n) at 2; [ | now apply Nat.sub_add ].
symmetry; apply Nat_gcd_add_diag_l.
Qed.

Theorem Nat_eq_mul_diag : ∀ p n, p = n * p → p = 0 ∨ n = 1.
Proof.
intros * H.
destruct n; [ now left | ].
destruct p; [ now left | right ].
destruct n; [ easy | exfalso ].
cbn in H.
apply Nat.succ_inj in H.
symmetry in H.
specialize (Nat.eq_le_incl _ _ H) as H1.
apply Nat.le_add_le_sub_l in H1.
now rewrite Nat.sub_diag in H1.
Qed.

Theorem Nat_sub_lt_mono_l : ∀ n m p : nat, n < m ≤ p → p - m < p - n.
Proof.
intros * (Hnm, Hmp).
revert n m Hnm Hmp.
induction p; intros; [ now apply Nat.le_0_r in Hmp; subst m | ].
destruct (eq_nat_dec m (S p)) as [Hm| Hm].
-subst m; rewrite Nat.sub_diag.
 now apply Nat.lt_add_lt_sub_l; rewrite Nat.add_0_r.
-rewrite Nat.sub_succ_l; cycle 1. {
   apply Nat.nlt_ge; intros H; apply Hm.
   now apply Nat.le_antisymm.
 }
 rewrite Nat.sub_succ_l; cycle 1. {
   apply (le_trans _ m); [ now apply Nat.lt_le_incl | ].
   apply Nat.nlt_ge; intros H; apply Hm.
   now apply Nat.le_antisymm.
 }
 apply -> Nat.succ_lt_mono.
 apply IHp; [ easy | ].
 apply Nat.nlt_ge; intros H; apply Hm.
 now apply Nat.le_antisymm.
Qed.

Theorem Nat_div_interv : ∀ n a b,
  n * b ≤ a < (n + 1) * b
  → a / b = n.
Proof.
intros * Hn.
revert a b Hn.
induction n; intros.
-rewrite Nat.mul_0_l, Nat.mul_1_l in Hn.
 now apply Nat.div_small.
-specialize (IHn (a - b) b) as H1.
 assert (H : n * b ≤ a - b < (n + 1) * b). {
   destruct Hn as (H2, H3).
   assert (Hba : b ≤ a). {
     eapply Nat.le_trans; [ | apply H2 ].
     apply Nat.le_add_r.
   }
   split.
   -apply (Nat.add_le_mono_r _ _ b).
    replace (n * b + b) with (S n * b) by apply Nat.add_comm.
    rewrite Nat.sub_add; [ apply H2 | easy ].
   -apply (Nat.add_lt_mono_r _ _ b).
    rewrite Nat.sub_add; [ | easy ].
    rewrite Nat.add_1_r in H3; cbn in H3.
    rewrite Nat.add_1_r; cbn.
    now rewrite Nat.add_assoc, Nat.add_shuffle0 in H3.
 }
 specialize (H1 H); clear H.
 assert (H : b ≤ a). {
   apply (Nat.mul_le_mono_pos_l _ _ (S n)); [ apply Nat.lt_0_succ | ].
   eapply le_trans; [ apply Hn | apply Nat.le_add_r ].
 }
 destruct b.
 +now do 2 rewrite Nat.mul_0_r in Hn.
 +replace a with (S b + (a - S b)); cycle 1. {
    rewrite Nat.add_sub_assoc; [ | easy ].
    now rewrite Nat.add_comm, Nat.add_sub.
  }
  rewrite Nat_div_add_same_l; [ | easy ].
  rewrite Nat.add_1_l.
  now f_equal.
Qed.

Theorem Nat_sqr_sub : ∀ a b, b ≤ a → (a - b) ^ 2 = a ^ 2 + b ^ 2 - 2 * a * b.
Proof.
intros * Hba.
cbn.
do 3 rewrite Nat.mul_1_r.
rewrite Nat.add_0_r.
rewrite Nat.mul_sub_distr_l.
do 2 rewrite Nat.mul_sub_distr_r.
rewrite Nat.mul_add_distr_r.
rewrite Nat_sub_sub_swap.
rewrite Nat_sub_sub_assoc; cycle 1. {
  split; [ now apply Nat.mul_le_mono_r | ].
  apply (le_trans _ (a * a)).
  -now apply Nat.mul_le_mono_l.
  -apply Nat.le_add_r.
}
rewrite Nat.sub_add_distr.
now replace (b * a) with (a * b) by apply Nat.mul_comm.
Qed.

Theorem Nat_sqr_sub_sqr : ∀ a b, a ^ 2 - b ^ 2 = (a + b) * (a - b).
Proof.
intros.
rewrite Nat.mul_sub_distr_l.
do 2 rewrite Nat.mul_add_distr_r.
rewrite Nat.sub_add_distr.
replace (a * a) with (a ^ 2) by now cbn; rewrite Nat.mul_1_r.
rewrite Nat.mul_comm, Nat.add_sub.
now f_equal; cbn; rewrite Nat.mul_1_r.
Qed.

Theorem Nat_pow_ge_1 : ∀ a b, 0 < a → 1 ≤ a ^ b.
Proof.
intros * Ha.
induction b; [ easy | cbn ].
replace 1 with (1 * 1) by easy.
apply Nat.mul_le_mono_nonneg; [ | easy | apply Nat.le_0_1 | easy ].
apply Nat.le_0_1.
Qed.

Theorem Nat_pow_neq_0 : ∀ a b, a ≠ 0 → a ^ b ≠ 0.
Proof.
intros * Ha.
destruct a; [ easy | ].
now apply Nat.pow_nonzero.
Qed.

Theorem Nat_div_small_iff: ∀ a b : nat, b ≠ 0 → a < b ↔ a / b = 0.
Proof.
intros * Hb.
split; [ apply Nat.div_small | ].
intros Hab.
destruct b; [ easy | clear Hb ].
unfold "/" in Hab.
specialize (Nat.divmod_spec a b 0 b (le_refl _)) as H1.
remember (Nat.divmod a b 0 b) as d eqn:Hd.
symmetry in Hd.
destruct d as (d, m); cbn in Hab.
subst d.
rewrite Nat.mul_0_r, Nat.sub_diag in H1.
do 2 rewrite Nat.add_0_r in H1.
rewrite Nat.add_0_l in H1.
rewrite (proj1 H1).
apply -> Nat.succ_le_mono.
apply Nat.le_sub_l.
Qed.

Theorem Nat_mul_sub_div_le : ∀ a b c,
  c ≤ a * b
  → (a * b - c) / b ≤ a.
Proof.
intros * Hc.
destruct (zerop b) as [Hb| Hb]. {
  subst b; cbn; apply Nat.le_0_l.
}
apply Nat.neq_0_lt_0 in Hb.
remember (a * b - c) as d eqn:Hd.
assert (H1 : a = (c + d) / b). {
  rewrite Hd.
  rewrite Nat.add_sub_assoc; [ | easy ].
  rewrite Nat.add_comm, Nat.add_sub.
  now rewrite Nat.div_mul.
}
rewrite H1.
apply Nat.div_le_mono; [ easy | ].
apply Nat_le_add_l.
Qed.

Definition bool_of_sumbool {A B : Prop} (P : sumbool A B) :=
  match P with
  | left _ _ => true
  | right _ _ => false
  end.
Definition sumbool_or {A B C D : Prop} (P : sumbool A B) (Q : sumbool C D) :=
  orb (bool_of_sumbool P) (bool_of_sumbool Q).

Notation "a ∨∨ b" := (sumbool_or a b) (at level 85, right associativity).


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

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                               Lib_Plus.v                                 *)
(****************************************************************************)

Require Export Lib_Minus.

Lemma plus_opp : forall n m : nat, n + m - m = n.
intros n m; elim (plus_comm m n); apply minus_plus.
Qed.
Hint Immediate plus_opp.

Lemma S_plus : forall n : nat, S n = n + 1.
intro; elim plus_comm; auto with arith.
Qed.
Hint Immediate S_plus.

Lemma lt_plus : forall n m : nat, 0 < n -> m < n + m.
simple induction n; simple induction m; auto with arith.
intros.
simpl in |- *; apply lt_n_S.
elim plus_comm; simpl in |- *.
elim plus_comm; apply H0; auto with arith.
Qed.
Hint Immediate lt_plus.

Lemma le_minus_plus : forall n m : nat, n - m <= n + m.
simple induction n; auto with arith.
Qed.
Hint Immediate le_minus_plus.

Lemma le_le_assoc_plus_minus :
 forall n m p : nat, n <= m -> n <= p -> m - n + p = m + (p - n).
intros.
elim H.
elim minus_n_n; simpl in |- *; elim le_plus_minus; auto with arith.
intros.
elim minus_Sn_m; simpl in |- *.
apply eq_S; auto with arith.
assumption.
Qed.
Hint Immediate le_le_assoc_plus_minus.

Lemma le_lt_plus : forall n m p q : nat, n <= p -> m < q -> n + m < p + q.
intros.
apply lt_le_trans with (n + q).
apply plus_lt_compat_l; try trivial.
apply plus_le_compat_r; try trivial.
Qed.

Lemma plus_eq_zero : forall a b : nat, a + b = 0 -> a = 0 /\ b = 0.
intros a b H.
split; apply sym_equal; apply le_n_O_eq; elim H; auto with arith.
Qed.
Hint Immediate plus_eq_zero.

Lemma le_transp_l : forall n m p : nat, n + m <= p -> m <= p - n.
simple induction n; intros.
simpl in H; elim minus_n_O; assumption.
elim H0.
elim plus_comm; rewrite plus_opp; auto with arith.
intros.
simpl in |- *; apply H; auto with arith.
Qed.
Hint Immediate le_transp_l.

Lemma le_transp_r : forall n m p : nat, n + m <= p -> n <= p - m.
intros.
apply le_transp_l.
elim plus_comm; assumption.
Qed.
Hint Immediate le_transp_r.


Require Export Poly.

Theorem silly1: forall (n m o p: nat),
    n = m -> [n;o] = [n;p] -> [n;o] = [m;p].
Proof.
  intros n m o p H1 H2.
  rewrite <- H1.
  apply H2.
Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly2a: forall (n m: nat),
    (n,n) = (m,m) -> (forall (q r: nat), (q,q) = (r,r) -> [q] = [r]) -> [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly_ex:
  (forall n, evenb n = true -> oddb (S n) = true) -> evenb 3 = true -> oddb 4 = true.
Proof.
  intros H.
  apply H.
Qed.

Theorem silly3_firsttry: forall (n: nat), true = beq_nat n 5 -> beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  simpl.
  symmetry.
  apply H.
Qed.

Theorem rec_exercise1: forall (l l': list nat),
    l = rev l' -> l' = rev l.
Proof.
  intros l1 l' H.
  rewrite -> H.
  symmetry.
  apply rev_involutive.
Qed.

Example trans_eq_example: forall (a b c d e f: nat),
    [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f].
Proof.
  intros a b c d e f H1 H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem trans_eq: forall (X: Type) (n m o: X),
    n = m -> m = o -> n = o.
Proof.
  intros X n m o H1 H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Example trans_eq_example': forall (a b c d e f: nat),
    [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f].
Proof.
  intros a b c d e f H1 H2.
  apply trans_eq with [c;d].
  apply H1.
  apply H2.
Qed.

Example trans_eq_exercise: forall (n m o p: nat),
    m = (minustwo o) -> (n + p) = m -> (n + p) = (minustwo o).
Proof.
  intros n m o p H1 H2.
  apply trans_eq with (n+p).
  reflexivity.
  rewrite -> H2.
  apply H1.
Qed.

Theorem s_injective: forall (n m: nat),
    S n = S m -> n = m.
Proof.
  intros n m H.
  inversion H.
  reflexivity.
Qed.

Theorem inversion_ex1: forall (n m o: nat),
    [n;m] = [o;o] -> [n] = [m].
Proof.
  intros n m o H.
  inversion H.
  reflexivity.
Qed.

Theorem inversion_ex2: forall (n m: nat),
    [n] = [m] -> n = m.
Proof.
  intros n m H.
  inversion H as [Hnm].
  reflexivity.
Qed.

Example inversion_ex3: forall (X: Type) (x y z: X) (l j: list X),
    x :: y :: l = z :: j -> y :: l = x :: j -> x = y.
Proof.
  intros X x y z l j H1 H2.
  inversion H1.
  inversion H2.
  rewrite -> H0.
  reflexivity.
Qed.

Theorem beq_nat_0_l: forall n,
    beq_nat 0 n = true -> n = 0.
Proof.
  intros n.
  destruct n as [|n'].
  - intros H.
    reflexivity.
  - intros H.
    inversion H.
Qed.

Theorem inversion_ex4: forall (n: nat),
    S n = O -> 2 + 2 = 5.
Proof.
  intros n contra.
  inversion contra.
Qed.

Theorem inversion_ex5: forall (n m: nat),
    false = true -> [n] = [m].
Proof.
  intros n m contra.
  inversion contra.
Qed.

Example inversion_ex6: forall (X: Type) (x y z: X) (l j: list X),
    x :: y :: l = [] -> y :: l = z :: j -> x = z.
Proof.
  intros X x y z l j H1 H2.
  inversion H1.
Qed.

Theorem f_equal: forall (A B: Type) (f: A -> B) (x y: A),
    x = y -> f x = f y.
Proof.
  intros  A B f x y eq.
  rewrite eq.
  reflexivity.
Qed.

Theorem S_inj: forall (n m: nat) (b: bool),
    beq_nat (S n) (S m) = b -> beq_nat n m = b.
Proof.
  intros n m b H.
  simpl in H.
  apply H.
Qed.

Theorem silly3': forall (n: nat),
    (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
    true = beq_nat n 5 ->
    true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H.
  apply eq in H.
  symmetry in H.
  apply H.
Qed.

Theorem plus_n_n_injective: forall n m,
    n + n = m + m -> n = m.
Proof.
  intros n.
  induction n as [|n'].
  - intros m H.
    destruct m.
    * reflexivity.
    * inversion H.
  - intros m H.
Admitted.

Theorem double_injective: forall n m,
    double n = double m -> n = m.
Proof.
  intros n.
  induction n as [|n'].
  - intros m H.
    destruct m.
    + reflexivity.
    + inversion H.
  - intros m H.
    destruct m.
    + inversion H.
    + apply f_equal.
      apply IHn'.
      inversion H.
      reflexivity.
Qed.

Theorem beq_nat_true: forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n.
  induction n.
  - intros m H.
    destruct m.
    * reflexivity.
    * inversion H.
  - intros m H.
    destruct m.
    * inversion H.
    * apply f_equal.
      apply IHn.
      inversion H.
      reflexivity.
Qed.

Theorem double_injective_take2_FAILED: forall n m,
    double n = double m -> n = m.
Proof.
  intros n m.
  induction m as [|m'].
  - intros eq.
    destruct n as [|n'].
    + reflexivity.
    + inversion eq.
  - intros eq.
    destruct n as [|n'].
    + inversion eq.
    + apply f_equal.
Abort.

Require Export Lists.

Theorem beq_id_true: forall x y,
    beq_id x y = true -> x = y.
Proof.
  intros [n] [m].
  simpl.
  intros H.
  apply f_equal.
  apply beq_nat_true in H.
  apply H.
Qed.

Theorem nth_error_after_last: forall (n: nat) (X: Type) (l: list X),
    length l = n -> nth_error l n = None.
Proof.
  intros.
  generalize dependent n.
  induction l.
  - intros.
    reflexivity.
  - intros.
Admitted.

Definition square n := n * n.

Lemma square_mult: forall n m,
    square (n * m) = square n * square m.
Proof.
  intros.
  unfold square.
  rewrite mult_assoc.
  assert (H: n * m * n = n * n * m).
  - rewrite mult_comm.
    rewrite mult_assoc.
    reflexivity.
  - rewrite H.
    rewrite mult_assoc.
    reflexivity.
Qed.

Definition foo (x: nat) := 5.

Fact silly_fact_1: forall m,
    foo m + 1 = foo (m + 1) + 1.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Definition bar (x: nat) :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2: forall m,
    bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m.
  - reflexivity.
  - reflexivity.
Qed.

Definition sillyfun (n: nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
       else false.

Theorem sillyfun_false: forall (n: nat),
    sillyfun n = false.
Proof.
  intros n.
  unfold sillyfun.
  destruct (beq_nat n 3).
  - reflexivity.
  - destruct (beq_nat n 5).
    + reflexivity.
    + reflexivity.
Qed.

Theorem combine_split: forall X Y (l: list (X * Y)) l1 l2,
    split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l.
  - intros l1 l2 eq.
    inversion eq.
    reflexivity.
  - simpl.
    destruct (split l).
    intros l2 l3 eq.
Admitted.

Definition sillyfun1(n: nat) :bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
       else false.

Theorem sillyfun1_odd: forall (n: nat),
    sillyfun1 n = true -> oddb n = true.
Proof.
  intros n eq.
  unfold sillyfun1 in eq.
  destruct (beq_nat n 3) eqn: Heqe3.
  - apply beq_nat_true in Heqe3.
    rewrite -> Heqe3.
    reflexivity.
  - destruct (beq_nat n 5) eqn: Heqe5.
    * apply beq_nat_true in Heqe5.
      rewrite -> Heqe5.
      reflexivity.
    * inversion eq.
Qed.

Theorem bool_fn_applied_thrice: forall (f: bool -> bool) (b: bool),
    f (f (f b)) = f b.
Proof.
  intros f b.
  destruct b.
  - destruct (f true) eqn: Hft.
    + rewrite Hft.
      apply Hft.
    + destruct (f false) eqn: Hff.
      * apply Hft.
      * apply Hff.
  - destruct (f false) eqn: Hff.
    + destruct (f true) eqn: Htt.
      * apply Htt.
      * apply Hff.
    + rewrite Hff.
      apply Hff.
Qed.

Theorem beq_nat_sym: forall (n m: nat),
    beq_nat n m = beq_nat m n.
Proof.
  intros n.
  induction n.
  - intros m.
    induction m.
    + reflexivity.
    + unfold beq_nat.
      reflexivity.
  - intros m.
    induction m.
    + unfold beq_nat.
      reflexivity.
    + simpl.
      apply IHn.
Qed.

Theorem beq_nat_trans: forall (n m p: nat),
    beq_nat n m = true ->
    beq_nat m p = true ->
    beq_nat n p = true.
Proof.
  intros n m p H1 H2.
  apply beq_nat_true in H1.
  apply beq_nat_true in H2.
  rewrite H1.
  rewrite H2.
  symmetry.
  apply beq_nat_relf.
Qed.

Definition split_combine_statement: Prop :=
  forall {X Y: Type} (l1: list X) (l2: list Y),
    length l1 = length l2 ->
    split (combine l1 l2) = (l1, l2).

Theorem split_combine: split_combine_statement.
Proof.
  intros X Y l1.
  induction l1.
  - intros l2 H.
    induction l2.
    + reflexivity.
    + simpl in H.
      destruct (length l2).
      * inversion H.
      * inversion H.
  - intros l2 H.
    induction l2.
    + simpl in H.
      destruct (length l1).
      * inversion H.
      * inversion H.
    + Admitted.


From DEZ Require Export
  Init.

Scheme Equality for prod.

Definition prod_fold_left (A B : Type)
  (f : A -> B -> A) (x : B * B) (a : A) : A :=
  match x with
  | (b0, b1) => f (f a b0) b1
  end.

Definition prod_fold_right (A B : Type)
  (f : B -> A -> A) (a : A) (x : B * B) : A :=
  match x with
  | (b0, b1) => f b0 (f b1 a)
  end.

Definition prod_bimap (A B C D : Type)
  (f : A -> C) (g : B -> D) (x : A * B) : C * D :=
  match x with
  | (a, b) => (f a, g b)
  end.

Definition prod_lmap (A B C : Type)
  (f : A -> C) (x : A * B) : C * B :=
  match x with
  | (a, b) => (f a, b)
  end.

Definition prod_rmap (A B C : Type)
  (g : B -> C) (x : A * B) : A * C :=
  match x with
  | (a, b) => (a, g b)
  end.

Definition prod_map (A B : Type) (f : A -> B) (x : A * A) : B * B :=
  match x with
  | (a, b) => (f a, f b)
  end.

Definition prod_swap (A B : Type) (x : A * B) : B * A :=
  match x with
  | (a, b) => (b, a)
  end.

Definition prod_sort_by (A : Type) (f : A -> A -> bool) (x : A * A) : A * A :=
  match x with
  | (a, b) => if f a b then (a, b) else (b, a)
  end.

(** The specializations are related as follows. *)

Fact eq_prod_bimap_prod_lmap (A B C : Type) (f : A -> C) (x : A * B) :
  prod_bimap f id x = prod_lmap f x.
Proof. reflexivity. Qed.

Fact eq_prod_bimap_prod_rmap (A B C : Type) (f : B -> C) (x : A * B) :
  prod_bimap id f x = prod_rmap f x.
Proof. reflexivity. Qed.

Fact eq_prod_bimap_prod_map (A B : Type) (f g : A -> B) (x : A * A) :
  prod_bimap f f x = prod_map f x.
Proof. reflexivity. Qed.

(** Some other properties also hold. *)

Lemma prod_map_id (A : Type) (x : A * A) :
  prod_map id x = x.
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_map_compose (A B C : Type) (g : B -> C) (f : A -> B) (x : A * A) :
  prod_map (g o f) x = prod_map g (prod_map f x).
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_lmap_id (A B : Type) (x : A * B) :
  prod_lmap id x = x.
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_lmap_compose (A B C D : Type)
  (g : C -> D) (f : A -> C) (x : A * B) :
  prod_lmap (g o f) x = prod_lmap g (prod_lmap f x).
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_rmap_id (A B : Type) (x : A * B) :
  prod_rmap id x = x.
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_rmap_compose (A B C D : Type)
  (g : C -> D) (f : B -> C) (x : A * B) :
  prod_rmap (g o f) x = prod_rmap g (prod_rmap f x).
Proof. destruct x as [a b]; auto. Qed.

Lemma prod_swap_involutive (A B : Type) (x : A * B) :
  prod_swap (prod_swap x) = x.
Proof. destruct x as [a b]; auto. Qed.


(* Simply typed lambda calculus *)

Require Import Env.
Require Import TransitiveClosure.

Inductive Ty :=
        | t_num   : Ty
        | t_arrow : Ty -> Ty -> Ty.

Definition Num := nat.

Inductive Exp :=
        | var    : Var -> Exp
        | num    : Num -> Exp
        | lambda : Ty  -> Exp -> Exp
        | app    : Exp -> Exp -> Exp.
(* does lambda need Ty? *)

Definition TEnv := Env Ty.

Inductive TYPE (env : TEnv) : Exp -> Ty -> Prop :=
	| ty_env (v : Var) (t : Ty): (InEnv v t env) -> TYPE env (var v) t
	| ty_num (n : Num) : TYPE env (num n) t_num
	| ty_lambda (body : Exp) (ty tbody : Ty) :
		TYPE (ty :: env) body tbody ->
		TYPE env (lambda ty body) (t_arrow ty tbody)
	| ty_app (f x : Exp) (t1 t2 : Ty) :
		TYPE env f (t_arrow t1 t2) ->
		TYPE env x t1 ->
		TYPE env (app f x) t2.

Lemma unicity
	(env: TEnv) (e : Exp) (t1 t2 : Ty)
	(Ht1 : TYPE env e t1)
	(Ht2 : TYPE env e t2)
	: t1 = t2.
Proof.
  revert t2 Ht2.
  induction Ht1; intros; inversion Ht2; subst; try congruence.
  f_equal. apply IHHt1. assumption.

  apply IHHt1_1 in H1.
  apply IHHt1_2 in H3.
  congruence.
Qed.

Fixpoint raise (e : Exp) (a b : nat) :=
 match e with
 | var v      => var (raise' a b v)
 | num n      => num n
 | lambda t x => lambda t (raise x a (S b))
 | app f x    => app (raise f a b) (raise x a b)
 end.

Lemma raise_0_id (e : Exp) (n : nat) :
	raise e 0 n = e.
Proof.
 revert n.
 induction e; intros; simpl; try (rewrite IHe1, IHe2); try reflexivity.
 unfold raise, raise'.
 destruct (ge_dec v n); auto.
 rewrite IHe. reflexivity.
Qed.

Lemma weakening_insert
        (env : TEnv) (e : Exp) (te tvi : Ty) (vi : Var) :
        TYPE env e te ->
        TYPE (insert env vi tvi) (raise e 1 vi) te.
 intros Hte.
 revert vi tvi.
 induction Hte; intros; try solve [constructor; auto].
 apply ty_env.
 unfold raise', InEnv, getEnv in *.
 destruct (ge_dec v vi).
 apply get_insert_ge; assumption.
 apply get_insert_lt. assumption.
 omega.

 apply ty_lambda; fold raise.
 rewrite <- uninsert; auto.
 eapply ty_app; fold raise; auto.
Qed.

Lemma weakening_cons
	(env : TEnv) (e : Exp) (te : Ty) tv :
	TYPE env e te ->
	TYPE (tv :: env) (raise e 1 0) te.
Proof.
 rewrite <- insert_0.
 apply weakening_insert.
Qed.

Fixpoint subst (e e' : Exp) (v : Var) :=
 match e with
 | var v'     => subst' v v' var e'
 | num n      => num n
 | lambda t x => lambda t (subst x (raise e' 1 0) (S v))
 | app    f x => app (subst f e' v) (subst x e' v)
 end.

Lemma substitution_ix env x t t' e e':
      TYPE (insert env x t) e'             t' ->
      TYPE env              e              t  ->
      x <= length env                         ->
      TYPE env              (subst e' e x) t'.
Proof.
 intros Ht' Ht Hlen.
 remember (insert env x t) as ENV.
 revert env x t e HeqENV Ht Hlen.
 induction Ht'; intros; try solve [constructor; auto].
   unfold subst, subst'.
   destruct (eq_nat_dec x v); subst.
    apply InEnv_insert in H. subst. assumption.
   destruct (lt_dec x v); subst.
    apply ty_env.
    destruct v. omega.
     rewrite minus_n_1.
     eapply insert_minus1; eassumption.
   apply ty_env. eapply insert_pre; try eassumption; try omega.

 simpl; subst; apply ty_lambda.
 eapply IHHt'. reflexivity.
 apply weakening_cons; assumption.
 simpl. omega.

 simpl; subst; eapply ty_app.
 eapply IHHt'1. reflexivity. assumption. assumption.
 eapply IHHt'2. reflexivity. assumption. assumption.
Qed.

Lemma substitution env t t' e e':
      TYPE (t :: env)       e'             t' ->
      TYPE env              e              t  ->
      TYPE env              (subst e' e 0) t'.
Proof.
 intros.
 eapply substitution_ix; try rewrite insert_0; try eassumption; try omega.
Qed.

Lemma decomposition env x t t' e e':
      TYPE env              (subst e' e x) t' ->
      TYPE env              e              t  ->
      x <= length env                         ->
      TYPE (insert env x t) e'             t'.
Proof.
 intros Hsub Ht Hlen.
 revert env x t t' e Hsub Ht Hlen.
 induction e'; intros.
 simpl in Hsub; unfold subst' in Hsub.
  apply ty_env.
  destruct (eq_nat_dec x v).
    replace t with t' by (eapply unicity; eassumption).
    replace v with x  by assumption.
    apply InEnv_insert_n. assumption.
   destruct (lt_dec x v).
   inversion Hsub.
   assert (v = S v0) as HvSv0. destruct v. omega. subst. simpl. rewrite <- minus_n_O. reflexivity.
   rewrite HvSv0.
   apply get_insert_ge. rewrite H. assumption.
   omega.
  apply get_insert_lt. inversion Hsub. assumption. omega.

 inversion Hsub. constructor.
 inversion Hsub. constructor.
 rewrite <- uninsert.
 eapply IHe'.
 eassumption.
 apply weakening_cons.
 assumption.
 simpl; omega.

 inversion Hsub; subst; eapply ty_app.
 eapply IHe'1; eassumption.
 eapply IHe'2; eassumption.
Qed.

Inductive val : Exp -> Prop :=
  | v_num n : val (num n)
  | v_lambda t b : val (lambda t b).

Inductive e_step : Exp -> Exp -> Prop :=
  | e_app1 e1 e1' e2 : e_step e1 e1' -> e_step (app e1 e2) (app e1' e2)
  | e_app2 e1 e2 e2' : val e1 -> e_step e2 e2' -> e_step (app e1 e2) (app e1 e2')
  | e_lam  t b x     : val x -> e_step (app (lambda t b) x) (subst b x 0).

Lemma preservation e e' t:
      TYPE [] e t ->
      e_step e e' ->
      TYPE [] e' t.
Proof.
 intros Ht He.
 revert t Ht.
 induction He; intros; inversion Ht; subst;
 try econstructor; try apply IHHe; try eassumption.
 inversion H2;
 eapply substitution;
 eassumption.
Qed.

Lemma progress e t:
      TYPE [] e t ->
      val e \/ (exists e', e_step e e').
Proof.
 intros Ht.
 remember [] as ENV.
 induction Ht; try solve [left; constructor].
 subst. apply not_InEnv_nil in H. destruct H.
 right.
  destruct IHHt1. assumption.
  destruct IHHt2. assumption.
  inversion H; subst; inversion Ht1; subst.
  eexists. eapply e_lam. assumption.

  destruct H0.
  eexists. eapply e_app2; eassumption.

  destruct H.
  eexists. eapply e_app1; eassumption.
Qed.

Inductive bigstep: Exp -> Exp -> Prop :=
  | b_num n    : bigstep (num n) (num n)
  | b_lam t b  : bigstep (lambda t b) (lambda t b)
  | b_app f t b x x' v :
        bigstep f (lambda t b)   ->
        bigstep x x'             ->
        bigstep (subst b x' 0) v ->
        bigstep (app f x) v.

Definition tc := transitive_closure Exp e_step.

Lemma bigstep__val e v:
      bigstep e v -> val v.
Proof.
 intros. induction H; try constructor; try assumption.
Qed.

Lemma e_step_noval e e':
      e_step e e' ->
      ~ val e.
Proof.
 intros H Hv.
 induction Hv;
 inversion H.
Qed.

Lemma e_step_deterministic e e' e'':
      e_step e e'  ->
      e_step e e'' ->
      e' = e''.
 intros He1 He2.
 revert e'' He2.
 induction He1; intros.
 inversion He2; subst.

 replace e1' with e1'0 in *.
  reflexivity. symmetry. apply IHHe1. assumption.
 eapply e_step_noval in H1. destruct H1.
 eassumption.

 inversion He1.

 inversion He2; subst.
 eapply e_step_noval in H. destruct H. eassumption.
 apply IHHe1 in H4. rewrite H4. reflexivity.

 eapply e_step_noval in H3. destruct H3. eassumption.

 inversion He2; subst.
 inversion H3.
 eapply e_step_noval in H. destruct H. eassumption.
 reflexivity.
Qed.

Lemma tc_app t b s s' v:
      tc (app (lambda t b) s) v ->
      tc s s' ->
      val v   ->
      tc (app (lambda t b) s') v.
Proof.
 intros Ha Hs Hv.
 revert t b v Ha Hv.
 induction Hs; intros; subst.
 assumption.
 apply IHHs.
 inversion Ha; subst.
 inversion Hv.
 inversion H0; subst.
 inversion H5.
 replace e2' with s' in *.
 eassumption.
 eapply e_step_deterministic; eassumption.

 eapply e_step_noval in H6. destruct H6. eassumption.
 assumption.
Qed.

Lemma tc_app2 t b s s' v:
      tc (app (lambda t b) s') v ->
      tc s s' ->
      val v   ->
      tc (app (lambda t b) s) v.
Proof.
 intros Ha Hs Hv.
 revert t b v Ha Hv.
 induction Hs; intros; subst.
 assumption.
 eapply tc_step. apply e_app2. constructor. eassumption.
 apply IHHs; assumption.
Qed.

Lemma tc_app1 e1 e1' e2 v:
      tc (app e1' e2) v ->
      tc e1 e1' ->
      tc (app e1 e2) v.
Proof.
 intros Ha Hs.
 revert e2 v Ha.
 induction Hs; intros; subst.
 assumption.
 eapply tc_step. apply e_app1. eassumption.
 apply IHHs; assumption.
Qed.

(* H0 : bigstep x x'
H1 : bigstep (subst b x' 0) v
IHbigstep2 : tc x x'
IHbigstep3 : tc (subst b x' 0) v
H : bigstep (lambda t b) (lambda t b)
IHbigstep1 : tc (lambda t b) (lambda t b)
s' : Exp
H2 : e_step x s'
H3 : transitive_closure Exp e_step s' x'
______________________________________(1/3)
transitive_closure Exp e_step (app (lambda t b) s') v
*)

Lemma bigstep__e_step e v:
      bigstep e v ->
      tc e v.
Proof.
 intros. induction H; try constructor.
 eapply tc_concat.
  inversion IHbigstep1; subst.
   inversion IHbigstep2; subst.
   eapply tc_step. eapply e_lam. eapply bigstep__val; eassumption.
  eassumption.
   eapply tc_step. eapply e_app2; try constructor; eassumption.

   inversion H3; subst.
    eapply tc_step. eapply e_lam. eapply bigstep__val. eassumption.
    assumption.

   eapply tc_app2 with (s' := x').
    eapply tc_step. eapply e_lam.
    eapply bigstep__val. eassumption.
    assumption. assumption.
    eapply bigstep__val; eassumption.

   eapply tc_app1 with (e1' := lambda t b).
    eapply tc_app2 with (s' := x').
     eapply tc_step. eapply e_lam. eapply bigstep__val; eassumption.
     assumption.
     assumption.
    eapply bigstep__val; eassumption.
    eassumption.

 apply tc_refl.
Qed.

Lemma val__bigstep v:
      val v ->
      bigstep v v.
Proof.
 intros Hv.
 destruct Hv; constructor.
Qed.

Lemma e_step__bigstep e e' v:
      e_step e e'  ->
      bigstep e' v ->
      bigstep e  v.
Proof.
 intros He Hbs.
 revert v Hbs.
 induction He; intros.
 inversion Hbs; subst.
 eapply b_app.
 apply IHHe; eassumption.
 eassumption.
 assumption.

 inversion Hbs; subst.
 eapply b_app; try eassumption.
 eapply IHHe; eassumption.

 apply val__bigstep in H.
 eapply b_app; try constructor; try eassumption.
Qed.


(** Semántica y verificación 22-1

  Números binarios

  Script con defninición de números binarios y sus
  propiedades aditivas básicas. Este script
  fue basado de los cursos de Favio Ezquiel
  Miranda Perea y modificado en ciertos aspectos.

  Edición por Luis Felipe Benítez Lluis

  Contenido:
        1 Definiciones básicas
        2 Lemas de inyectividad de operadores
        3 Lemas de inequidad de operadores
        4 Función sucesor y propiedades de sucesor
        5 Función predecesor y propiedades
        6 Funciones de conversión a representación usal de naturales
        7 Definición de suma en números binarios
        8 Seguridad de suma en nat, inversión de morfismos de representaciones

    Para acceder rápidamente a la sección deseada
    buscar la cadena ">n" donde "n" es el número de
    sección. *)
Require Import Coq.Arith.PeanoNat.
Require Import Arith.
Require Import ArithRing.
Require Import Setoid.
Require Import Omega.

(** >1 Definiciones básicas *)

(* Tido de dato que modela un número binario
    Los constructures U y D toman un natural y representan
    su doble mas 1 y 2 respectivamente. Se toma que los números
    con D sean de la forma 2x+2 para asegurar unicidad de expresión
    de 0. *)
Inductive BN :=
  Z: BN (* Cero*)
| U: BN -> BN (* x |-> 2x +1 *)
| D: BN -> BN. (* x |-> 2x +2 *)

Check BN_ind.
Check BN_rec.
Check BN_rect.

(** >2 Lemas de inyectividad de operadores**)
Lemma UInj: forall (a b:BN), U a = U b -> a = b.
Proof.
intros.
inversion H.
trivial.
Qed.

Lemma DInj: forall (a b:BN), D a = D b -> a = b.
Proof.
intros.
inversion H.
trivial.
Qed.
Lemma bnNonZ: forall (b:BN), b <> Z -> exists (c:BN), b = U c \/ b = D c.
Proof.
intros.
destruct b.
intuition.
exists b;left;trivial.
exists b;right;trivial.
Qed.

(** >3 Lemas de inequidad de operadores*)
Lemma ZnotU: forall (a:BN), Z <> U a.
Proof.
intros.
discriminate.
Qed.

Lemma ZnotD: forall (a:BN), Z <> D a.
Proof.
intros.
discriminate.
Qed.

Lemma UnotD: forall (a b:BN), U a <> D b.
Proof.
intros.
discriminate.
Qed.

Lemma DnotU: forall (a b:BN), D a <> U b.
Proof.
intros.
discriminate.
Qed.

Lemma bnotU : forall (a:BN), U a <> a.
Proof.
intros.
induction a.
(*a = Z*)
intuition.
inversion H.
(*a=U a*)
intuition.
inversion H.
apply IHa in H1.
trivial.
(*a=D a*)
intuition.
inversion H.
Qed.

Lemma bnotD : forall (a:BN), D a <> a.
Proof.
intros.
induction a.
(*a = Z*)
intuition.
inversion H.
(*a=U a*)
intuition.
inversion H.
(*a=D a*)
intuition.
inversion H.
apply IHa in H1.
trivial.
Qed.
Lemma U_not: forall (i j :BN), U i <> U j -> i <> j.
Proof.
intros.
contradict H.
apply f_equal.
trivial.
Qed.

Lemma D_not: forall (i j :BN), D i <> D j -> i <> j.
Proof.
intros.
contradict H.
apply f_equal.
trivial.
Qed.

Lemma UDCase: forall (x:BN), x <> Z -> exists (b:BN), x = U b \/ x = D b.
Proof.
intros.
destruct x.
intuition.
exists x;left;trivial.
exists x;right;trivial.
Qed.

(* Decidibilidad de la igualdad*)
Theorem dec_eq_BN: forall (a b:BN), {a = b} + {a <> b}.
Proof.
decide equality.
Qed.

(** >4 Función sucesor y propiedades de sucesor*)
Fixpoint sucBN (b:BN) : BN :=
  match b with
      Z => U Z
    | U x => D x (*S(U x) = S(2x + 1) = 2x + 2 = D x*)
    | D x => U (sucBN x) (*S(D x)= S(2x + 2) = S(S(2x + 1)) = S(2x + 1) + 1  *)
                 (* 2(S(x)) + 1 = 2(x+1) + 1 = (2x + 2) + 1 = S(2x + 1) + 1*)
  end.

Lemma suc_not_zero: forall (x:BN), sucBN x <> Z.
Proof.
intros.
destruct x.
simpl;discriminate.
simpl;discriminate.
simpl;discriminate.
Qed.

Lemma suc_DasucUa: forall (a:BN), D  a =sucBN (U a).
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma suc_Dsuca_sucsucDa: forall (a:BN), D (sucBN a) = sucBN (sucBN (D a)).
Proof.
intros. simpl. reflexivity.
Qed.

Lemma suc_sucUa: forall a:BN,   U (sucBN a)= sucBN (D a).
Proof.
intros.
simpl. reflexivity.
Qed.

Lemma ZnotSucBN: forall (a:BN), Z <> sucBN a.
Proof.
intros.
induction a.
simpl.
discriminate.
simpl.
discriminate.
simpl.
discriminate.
Qed.

Lemma SucBNisUorD: forall (a:BN),exists b:BN,
  sucBN a = U b \/ sucBN a = D b.
Proof.
  induction a.
  - simpl. exists Z. left. reflexivity.
  - simpl. exists a. right. reflexivity.
  - destruct IHa. destruct H.
  -- simpl. exists (sucBN a). left. reflexivity.
  -- simpl. exists (sucBN a). left. reflexivity.
Qed.

Lemma notSucBN : forall (a:BN), a <> sucBN a.
Proof.
intros.
destruct a.
simpl; discriminate.
simpl; discriminate.
simpl; discriminate.
Qed.

(** >5 Función predecesor y propiedades*)
(* Para la función predecesor se usa un valor indeterminado dado como
    un parámetro *)
Parameter (undefBN: BN).

Fixpoint predBN (b:BN): BN :=
 match b with
  Z => undefBN
 |U Z => Z
 |U x => D (predBN x)
 |D x => U x
 end.

Lemma predBNUD: forall (a:BN), a <> Z -> predBN (U a) = D (predBN a).
Proof.
intros.
destruct a.
contradict H.
trivial.
reflexivity.
reflexivity.
Qed.

Lemma predsucBNinv: forall (a:BN), predBN (sucBN a) = a.
Proof.
  induction a.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - pose proof SucBNisUorD as H.
    simpl.
    specialize H with (a:= a).
    destruct H.
    destruct H.
    -- rewrite H. rewrite <-H.
       rewrite IHa. reflexivity.
    -- rewrite H. rewrite <- H.
       rewrite IHa. reflexivity.
Qed.

Lemma sucpredBNinv: forall (a:BN), a <> Z -> sucBN (predBN a) = a.
Proof.
  induction a.
  - intro. contradict H. reflexivity.
  - destruct a.
  -- simpl. intro. reflexivity.
  -- assert (U a <> Z) as H.
     apply not_eq_sym.
     apply ZnotU.
     intro.
     apply IHa in H as H1.
     assert (predBN (U (U a))= D (predBN (U a))) as H2.
     simpl. reflexivity.
     rewrite H2.
     assert (sucBN (D (predBN (U a)))= U (sucBN (predBN (U a)))). simpl. reflexivity.
     rewrite H3.
     rewrite H1.
     reflexivity.
   -- simpl. reflexivity.
   - simpl. reflexivity.
Qed.

(** >E Rellenar este problema. Dificultad 3*)
Lemma SucBNinj: forall (a b : BN), sucBN a = sucBN b -> a = b.
Proof.
Admitted.

(** >6 Funciones de conversión a representación usal de naturales *)

(* Función que transforma números binarios BN a nat*)
Fixpoint toN (b:BN) : nat :=
  match b with
      Z => 0
    | U x => 2*(toN x) + 1
    | D x => 2*(toN x) + 2
  end.

(* Convierte un natural nat a BN mediate iteraciones de sucesor.
    puede ser algo ineficiente.*)
Fixpoint toBN (n: nat) : BN :=
  match n with
      0 => Z
    | S x => sucBN (toBN x)
  end.

Eval compute in (toN (predBN (toBN 47))).

Eval compute in toN(D(U(U Z))).

Eval compute in toN(sucBN(D(U(U Z)))).

Eval compute in toBN 16.

(* Seguridad de funciones sucesor*)
Lemma toN_sucBN : forall (b : BN), toN(sucBN b) = S(toN b).
Proof.
induction b.
simpl.
trivial.
simpl.
ring.
simpl.
rewrite IHb.
ring.
Qed.

Lemma sucBN_toBN : forall (n : nat), sucBN (toBN n) = toBN (S n).
Proof.
destruct n.
simpl.
trivial.
simpl.
trivial.
Qed.

Lemma inverse_op : forall (n : nat), toN(toBN n) = n.
Proof.
induction n.
simpl.
trivial.
simpl.
rewrite toN_sucBN.
rewrite IHn.
trivial.
Qed.

(** >7 Definición de suma en números binarios*)

Fixpoint plusBN (a b : BN) : BN :=
  match a,b with
    | Z, b => b
    | a, Z  => a
    | U x, U y => D(plusBN x y)
    | D x, U y => U(sucBN (plusBN x y))
    | U x, D y => U(sucBN (plusBN x y))
    | D x, D y => D(sucBN (plusBN x y))
  end.

Notation "a +_ b" := (plusBN a b) (at level 60).

Lemma plus_neutro: forall (b:BN), b +_ Z = b.
Proof.
intros.
destruct b.
simpl;trivial.
simpl;trivial.
simpl;trivial.
Qed.

Lemma plus_sucBN_ZU: forall (b : BN),  sucBN (b) = b +_ U Z.
Proof.
  intros.
  induction b.
  - simpl. reflexivity.
  - simpl. rewrite plus_neutro. reflexivity.
  - simpl. rewrite plus_neutro. reflexivity.
Qed.

Lemma plus_sucBN_ZUU: forall (b : BN),  sucBN(sucBN (b)) = b +_ D Z.
Proof.
intros.
induction b.
- simpl. reflexivity.
- simpl. rewrite plus_neutro.
  reflexivity.
- simpl. rewrite plus_neutro.
  reflexivity.
Qed.

Lemma plus_U: forall (b : BN),  sucBN (b +_ b) = U b.
Proof.
intros.
induction b.
simpl.
trivial.
simpl.
rewrite IHb.
trivial.
simpl.
rewrite IHb.
simpl.
trivial.
Qed.

Lemma plus_D: forall (b : BN),  sucBN (sucBN b +_ b) = D b.
Proof.
intros.
induction b.
simpl.
trivial.
simpl.
rewrite plus_U.
trivial.
simpl.
rewrite IHb.
trivial.
Qed.

Lemma plusSuc_l : forall (b c: BN), sucBN (b +_ c) = sucBN b +_ c.
Proof.
  induction b;induction c;try(reflexivity).
  - simpl.
    specialize IHb with (c:=c).
    rewrite IHb.
    reflexivity.
  - simpl.
    specialize IHb with (c:= c) as H1.
    rewrite H1.
    reflexivity.
Qed.

(** >E Rellenar este problema. Dificultad 2*)
Lemma plusComm: forall (a b:BN), (a +_ b) = (b +_ a).
Proof.
Admitted.

Lemma plusSuc_r : forall (b c: BN), sucBN (b +_ c) = b +_ sucBN c.
Proof.
intros.
rewrite plusComm.
rewrite plusSuc_l.
rewrite plusComm.
reflexivity.
Qed.

Lemma plusBN_Z_Z: forall (x y:BN), x +_ y = Z -> x = Z /\ y = Z.
Proof.
intros.
split.
induction x.
reflexivity.
  - symmetry in H.
  contradict H.
  destruct y.
  simpl.
  apply ZnotU.
  simpl. apply ZnotD with (a:= (x +_ y)).
  simpl. apply ZnotU with (a:= sucBN (x +_ y))  .
- symmetry in H.
  contradict H.
  destruct y.
  simpl.
  apply ZnotD.
  simpl. apply ZnotU with (a:= sucBN (x +_ y)).
  simpl. apply ZnotD with (a:=sucBN(x +_ y) )  .
- induction y.
  reflexivity.
  symmetry in H.
  contradict H.
  destruct x.
  simpl.
  apply ZnotU.
  simpl. apply ZnotD with (a:= (x +_ y)).
  simpl. apply ZnotU with (a:= sucBN (x +_ y))  .
  symmetry in H.
  contradict H.
  destruct x.
  simpl.
  apply ZnotD.
  simpl. apply ZnotU with (a:= sucBN (x +_ y)).
  simpl. apply ZnotD with (a:=sucBN(x +_ y) )  .
Qed.

Lemma plus_a_a : forall (a b:BN), a +_ a = b +_ b -> a = b.
Proof.
intros.
apply (f_equal sucBN) in H.
rewrite plus_U in H.
rewrite plus_U in H.
apply UInj.
trivial.
Qed.

Lemma plus_SucBNa_a : forall (a b:BN),
  sucBN a +_ a = sucBN b +_ b -> a = b.
Proof.
intros.
rewrite <- plusSuc_l in H.
rewrite <- plusSuc_l in H.
apply SucBNinj in H.
apply (f_equal sucBN) in H.
rewrite plus_U in H.
rewrite plus_U in H.
apply UInj.
trivial.
Qed.

(** >8 Seguridad de suma en nat, inversión de morfismos de representaciones*)
Lemma plusBN_toN : forall (a b : BN), toN(a +_ b) = toN a + toN b.
Proof.
intro.
induction a.
simpl.
trivial.
intros.
destruct b.
simpl.
ring.
simpl.
rewrite IHa.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
destruct b.
simpl.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
Qed.

Lemma plus_toBN:  forall (n m: nat), toBN(n + m) = toBN n +_ toBN m.
Proof.
intros.
induction n.
simpl.
trivial.
simpl.
rewrite IHn.
rewrite <- plusSuc_l.
trivial.
Qed.

(** >E Rellenar este teorema. Dificultad 2*)
Lemma inverse_op_1 : forall (b:nat), toN(toBN b) = b.
Proof.
Admitted.

Lemma inverse_op_2 : forall (b:BN), toBN(toN b) = b.
Proof.
intros.
induction b.
- simpl. reflexivity.
- simpl.
  do 3 rewrite plus_toBN.
  simpl.
  rewrite IHb.
  rewrite plus_neutro.
  rewrite <-plus_sucBN_ZU with (b +_ b).
  rewrite plus_U.
  reflexivity.
- simpl.
  rewrite Nat.add_0_r.
  rewrite plus_toBN.
  rewrite plus_toBN.
  rewrite IHb.
  simpl.
  pose proof plus_D (b) .
  rewrite <-H.
  rewrite <-plusSuc_l.
  rewrite plus_sucBN_ZUU.
  reflexivity.
Qed.