From stdpp Require Export list.
From Nominal Require Export Group Swap.
Open Scope nominal_scope.

(* Permutation is just a list of pair of names. *)
Notation Perm := (list Swap).

Definition perm_swap (p: Perm): Name → Name :=
  λ a, foldl (λ x y, swap y x) a p.

(* Properties *)
Lemma perm_swap_app (r s: Perm) a: perm_swap (r ++ s) a = perm_swap s (perm_swap r a).
Proof. unfold perm_swap; rewrite foldl_app; simpl; auto. Qed.

Lemma perm_swap_left_rev (p: Perm): ∀ a, perm_swap (reverse p) (perm_swap p a) = a.
Proof with auto.
  assert (HH: ∀ {A} (x: A) y, x :: y = [x] ++ y)... induction p; intros.
  - simpl...
  - rewrite HH, reverse_app, reverse_singleton, <-perm_swap_app, <-app_assoc,
      3?perm_swap_app; simpl; rewrite IHp; apply swap_involutive.
Qed.

Lemma perm_swap_right_rev (p : Perm) a: perm_swap p (perm_swap (reverse p) a) = a.
Proof with auto.
  assert (HH: ∀ {A} (x: A) y, x :: y = [x] ++ y)... induction p.
  - simpl...
  - rewrite HH, reverse_app, reverse_singleton, <- perm_swap_app, <-app_assoc,
      3?perm_swap_app; simpl; rewrite swap_involutive...
Qed.

Lemma perm_swap_neither (a b c: Name): a ≠ b → a ≠ c → perm_swap ⟨b,c⟩ a = a.
Proof. unfold perm_swap, foldl; intros; rewrite swap_neither1; intuition. Qed.

Lemma perm_swap_left (a b: Name): perm_swap ⟨a,b⟩ a = b.
Proof. unfold perm_swap, foldl; apply swap_left. Qed.

Lemma perm_swap_right (a b: Name): perm_swap ⟨b,a⟩ a = b.
Proof. unfold perm_swap, foldl. apply swap_right. Qed.

Lemma perm_swap_neq p: ∀ a b, a ≠ b → perm_swap p a ≠ perm_swap p b.
Proof. induction p as [|[] ? IHp]; [| intros; simpl; apply IHp,swap_neq]; auto. Qed.

(* Permutation domain *)
Fixpoint perm_dom (p: Perm): NameSet :=
  match p with
  | [] => ∅
  | (a,b) :: p' => {[a; b]} ∪ perm_dom p'
  end.

(* Proof depends on listset_empty implementation. TODO: alternative? *)
Lemma perm_dom_concat p: ∀ p', perm_dom (p ++ p') = (perm_dom p) ∪ (perm_dom p').
Proof.
Transparent listset_empty.
  induction p.
  - intros; simpl; unfold empty, listset_empty, union, listset_union; simpl;
      destruct (perm_dom p'); reflexivity.
  - intros; simpl; destruct a as [a b]; rewrite IHp, assoc; auto.
    unfold Assoc, union, listset_union; intros [] [] []; rewrite assoc; [auto | typeclasses eauto].
Opaque listset_empty.
Qed.

Lemma perm_notin_domain_id (p: Perm) (a: Name): a ∉ (perm_dom p) → perm_swap p a = a.
Proof.
  intros; induction p as [| [b c] p'].
  - reflexivity.
  - assert (HH: ∀ A (x: A) y, x :: y = [x] ++ y). { reflexivity. }
    rewrite HH, perm_swap_app; simpl in H; do 2 apply not_elem_of_union in H as [H ?];
    rewrite perm_swap_neither; set_solver.
Qed.

(** *Permutation as list forms a Group *)
#[export] Instance perm_neutral: Neutral Perm := @nil Swap.
#[export] Instance perm_operator: Operator Perm := @app Swap.
#[export] Instance perm_inverse: Inverse Perm := @reverse Swap.
#[export] Instance perm_equiv: Equiv Perm :=
  λ p q: Perm, ∀ a: Name, perm_swap p a = perm_swap q a.
#[export] Instance perm_equivalence: Equivalence (≡@{Perm}).
Proof. repeat split; repeat intro; [symmetry | etransitivity]; eauto. Qed.

#[export] Instance PermGrp: Group Perm.
Proof with auto.
  split; unfold op, perm_operator, neutral, perm_neutral, inv, perm_inverse,
         equiv, perm_equiv in *; repeat intro...
  - typeclasses eauto.
  - rewrite 2?perm_swap_app; do 2 match goal with H : context[_ = _] |- _ => rewrite H end...
  - transitivity (perm_swap (reverse y) (perm_swap x (perm_swap (reverse x) a)));
    [rewrite H, perm_swap_left_rev | rewrite perm_swap_right_rev]...
  - rewrite app_assoc...
  - rewrite app_nil_r...
  - rewrite perm_swap_app, perm_swap_right_rev...
  - rewrite perm_swap_app, perm_swap_left_rev...
Qed.

(* PermGroup Properties *)
Lemma perm_equiv_neutral a: ⟨a,a⟩ ≡@{Perm} ɛ.
Proof. unfold equiv, perm_equiv, perm_swap; intros; simpl; case_decide; auto. Qed.

Open Scope nominal_scope.

Lemma perm_expand (a b c: Name):
  c ≠ a -> c ≠ b -> ⟨a,c⟩ ≡@{Perm} ⟨a,b⟩ + ⟨b,c⟩ + ⟨a,b⟩.
Proof.
  intros; unfold equiv, perm_equiv, perm_swap; intros; simpl;
    repeat case_decide; subst; congruence.
Qed.

Lemma swap_perm a b: ⟨a,b⟩ ≡@{Perm} ⟨b,a⟩.
Proof.
  unfold equiv, perm_equiv, perm_swap; intros; simpl;
    repeat case_decide; subst; auto.
Qed.

Lemma perm_duplicate a b: ⟨a,b⟩ + ⟨a,b⟩ ≡@{Perm} ɛ.
Proof.
  unfold equiv, perm_equiv, perm_swap; intros; simpl;
    repeat case_decide; subst; first [congruence | auto].
Qed.

Lemma perm_inv a b: ⟨a,b⟩ ≡@{Perm} -⟨a,b⟩.
Proof. unfold equiv, perm_equiv, inv, perm_inverse; simpl; intros; repeat (case_decide); auto. Qed.

Lemma perm_comm_distr a b p: ⟨a,b⟩ + p ≡ p + ⟨perm_swap p a, perm_swap p b⟩.
Proof.
  unfold equiv, perm_equiv, op, perm_operator; intros x;
  destruct (decide (a = x)), (decide (b = x)); subst; rewrite 2!perm_swap_app.
  - rewrite 2!perm_equiv_neutral; auto.
  - rewrite 2!perm_swap_left; auto.
  - rewrite 2!perm_swap_right; auto.
  - rewrite 2!perm_swap_neither; try apply perm_swap_neq; intuition.
Qed.

Lemma perm_notin_dom_comm a b p:
  a ∉ perm_dom p → b ∉ perm_dom p → ⟨a,b⟩ + p ≡@{Perm} p + ⟨a,b⟩.
Proof.
  intros; rewrite perm_comm_distr; unfold equiv, perm_equiv; intros x;
    rewrite 2!(perm_notin_domain_id p); auto.
Qed.

Lemma perm_dom_inv p a: a ∉ perm_dom p → a ∉ perm_dom (-p).
Proof.
  induction p as [| p p' IHp]; intros H.
  - simpl in *; auto.
  - assert (HH: ∀ A (x: A) y, x :: y = [x] ++ y). { intros; simpl; auto. }
    unfold inv, perm_inverse; rewrite reverse_cons; rewrite HH in H.
    rewrite perm_dom_concat in *; set_solver.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Permutation Arith Omega.

Require Import utils pos vec ill.

Set Implicit Arguments.

(** ** eILL reduces to ILL *)

Local Infix "~p" := (@Permutation _) (at level 70).

Definition ll_vars := nat.

Inductive eill_cmd : Set :=
  | in_ll_cmd_inc  : ll_vars -> ll_vars -> ll_vars -> eill_cmd
  | in_ll_cmd_dec  : ll_vars -> ll_vars -> ll_vars -> eill_cmd
  | in_ll_cmd_fork : ll_vars -> ll_vars -> ll_vars -> eill_cmd.

Notation LL_INC  := in_ll_cmd_inc.
Notation LL_DEC  := in_ll_cmd_dec.
Notation LL_FORK := in_ll_cmd_fork.

Definition eill_cmd_vars c :=
  match c with
    | LL_INC  a p q => a::p::q::nil
    | LL_DEC  a p q => a::p::q::nil
    | LL_FORK p q r => p::q::r::nil
  end.

(* The embedding of eill commands into ill
   or its (!,&,-o) fragment *)

Definition eill_cmd_map c :=
  match c with
    | LL_INC  a p q => (£a ⊸ £p) -o £ q
    | LL_DEC  a p q => £a ⊸ £p -o £ q
    | LL_FORK p q r => (£p ﹠ £q) -o £ r
  end.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ ⟦ ⟧ Γ Δ Σ *)

Notation "'[i' c ']'" := (eill_cmd_map c) (at level 0).

Reserved Notation "Si ; Ga '⊦' x" (at level 70, no associativity).

Inductive G_eill (Σ : list eill_cmd) : list ll_vars -> ll_vars -> Prop :=
  | in_eill_ax  : forall u,                                    Σ; u::∅ ⊦ u
  | in_eill_perm : forall Γ Δ p,    Γ ~p Δ                 ->  Σ; Γ     ⊦ p
                                                           ->  Σ; Δ     ⊦ p
  | in_eill_inc : forall Γ a p q,   In (LL_INC a p q) Σ    ->  Σ; a::Γ  ⊦ p
                                                           ->  Σ; Γ     ⊦ q
  | in_eill_dec : forall Γ Δ p q r, In (LL_DEC p q r) Σ    ->  Σ; Γ     ⊦ p
                                                           ->  Σ; Δ     ⊦ q
                                                           ->  Σ; Γ++Δ  ⊦ r
  | in_eill_fork : forall Γ p q r,  In (LL_FORK p q r) Σ   ->  Σ; Γ     ⊦ p
                                                           ->  Σ; Γ     ⊦ q
                                                           ->  Σ; Γ     ⊦ r
where "Si ; Ga ⊦ u" := (G_eill Si Ga u).

Definition EILL_SEQUENT := (list eill_cmd * list ll_vars * ll_vars)%type.

Definition EILL_PROVABILITY (c : EILL_SEQUENT) := match c with (Σ,Γ,A) => Σ; Γ ⊦ A end.

Theorem g_eill_mono_Si Σ Σ' Γ u : incl Σ Σ' -> Σ; Γ ⊦ u -> Σ'; Γ ⊦ u.
Proof.
  revert Σ Σ' Γ; intros Si Si' Ga.
  intros H H1; revert H1 Si' H.
  induction 1 as [ u
                 | Ga De p H1 H2 IH2
                 | Ga a p q H1 H2 IH2
                 | Ga De p q r H1 H2 IH2 H3 IH3
                 | Ga p q r H1 H2 IH2 H3 IH3
                 ]; intros Si' HSi.
  + apply in_eill_ax.
  + apply in_eill_perm with (1 := H1); auto.
  + apply in_eill_inc with (1 := HSi _ H1); auto.
  + apply in_eill_dec with (1 := HSi _ H1); auto.
  + apply in_eill_fork with (1 := HSi _ H1); auto.
Qed.

(* G_eill is sound wrt. the S_ill

   this proof only uses somes of the rules of
   the cut-free (!,&,-o) fragment
*)

Theorem G_eill_sound Σ Γ p : Σ; Γ ⊦ p -> map (fun c => ![i c]) Σ ++ map £ Γ ⊢ £ p.
Proof.
  revert Σ; intros Si.
  induction 1 as [ u
                 | Ga De p H1 H2 IH2
                 | Ga a p q H1 H2 IH2
                 | Ga De p q r H1 H2 IH2 H3 IH3
                 | Ga p q r H1 H2 IH2 H3 IH3
                 ].
  + rewrite <- map_map; apply S_ill_weak; apply in_llp_ax.
  + revert IH2; apply in_llp_perm.
    apply Permutation_app; auto.
    apply Permutation_map; auto.
  + rewrite <- map_map; apply S_ill_weak_cntr with (1 := in_map _ _ _ H1); simpl.
    unfold ll_lbang; rewrite map_map.
    apply in_llp_bang_l.
    apply in_llp_perm with (((£ a ⊸ £ p) ⊸ £ q) :: ((map (fun c => ❗ [i c]) Si ++ map £ Ga) ++ nil)).
    * rewrite <- app_nil_end; auto.
    * apply in_llp_limp_l.
      2: apply in_llp_ax.
      apply in_llp_limp_r.
      revert IH2; apply in_llp_perm.
      simpl; apply Permutation_sym, Permutation_cons_app; auto.
  + rewrite <- map_map.
    apply S_ill_cntr.
    unfold ll_lbang; rewrite map_map.
    rewrite <- map_map; apply S_ill_weak_cntr with (1 := in_map _ _ _ H1); simpl; rewrite map_map.
    apply in_llp_bang_l.
    rewrite map_app.
    apply in_llp_perm with (£ p ⊸ £ q ⊸ £ r :: (map (fun c => ❗ [i c]) Si ++ map £ Ga)
                                            ++ (map (fun c => ❗ [i c]) Si ++ map £ De)).
    * apply Permutation_cons; auto.
      unfold ll_lbang; rewrite map_map.
      rewrite app_ass; apply Permutation_app; auto.
      do 2 rewrite <- app_ass; apply Permutation_app; auto.
      apply Permutation_app_comm.
    * apply in_llp_limp_l; auto.
      apply in_llp_perm with (£ q ⊸ £ r :: ((map (fun c => ❗ [i c]) Si ++ map £ De) ++ nil)).
      - rewrite <- app_nil_end; auto.
      - apply in_llp_limp_l; auto.
        apply in_llp_ax.
  + rewrite <- map_map; apply S_ill_weak_cntr with (1 := in_map _ _ _ H1); simpl.
    unfold ll_lbang; rewrite map_map.
    apply in_llp_bang_l.
    apply in_llp_perm with (£ p & £ q ⊸ £ r :: ((map (fun c => ❗ [i c]) Si ++ map £ Ga) ++ nil)).
    * rewrite <- app_nil_end; auto.
    * apply in_llp_limp_l.
      - apply in_llp_with_r; auto.
      - apply in_llp_ax.
Qed.

Section TPS.

  Variables (n : nat) (s : ll_vars -> vec nat n -> Prop) (rx : pos n -> ll_vars).

  Fact ll_tps_vec_map_list_mono :
       (forall (p : pos n), s (rx p) (vec_one p))
     -> forall v, ll_tps_list s (map £ (vec_map_list v rx)) v.
  Proof.
    intros H v; rewrite map_vec_map_list.
    induction v as [ | p | v w Hv Hw ] using (@vec_nat_induction n).

    rewrite vec_map_list_zero; simpl; tauto.

    rewrite vec_map_list_one; simpl.
    exists (vec_one p), vec_zero; rew vec; repeat split; auto.

    apply ll_tps_perm with (1 := Permutation_sym (vec_map_list_plus _ _ _)).
    apply ll_tps_app.
    exists v, w; repeat split; auto.
  Qed.

  Fact ll_tps_vec_map_list :
       (forall (p : pos n) (v : vec nat n), s (rx p) v <-> v = vec_one p)
     -> forall v w, ll_tps_list s (map £ (vec_map_list v rx)) w <-> v = w.
  Proof.
    intros H v; rewrite map_vec_map_list.
    induction v as [ | p | v w Hv Hw ] using (@vec_nat_induction n); intros z.

    rewrite vec_map_list_zero; simpl; tauto.

    rewrite vec_map_list_one; simpl.
    split.
    intros (a & b & H1 & H2 & H3).
    apply H in H2; subst; rew vec.
    intros [].
    exists (vec_one p), vec_zero; rew vec; repeat split; auto.
    apply H; auto.

    split.
    intros Hz.
    apply ll_tps_perm with (1 := vec_map_list_plus _ _ _) in Hz.
    apply ll_tps_app in Hz.
    destruct Hz as (a & b & H1 & H2 & H3).
    apply Hv in H2.
    apply Hw in H3.
    subst; auto.

    intros [].
    apply ll_tps_perm with (1 := Permutation_sym (vec_map_list_plus _ _ _)).
    apply ll_tps_app.
    exists v, w; repeat split; auto.
    apply Hv; auto.
    apply Hw; auto.
  Qed.

End TPS.

Section g_eill_complete_bound.

  Variable (Si : list eill_cmd) (Ga : list ll_vars) (n : nat).

  Notation vars := (flat_map eill_cmd_vars Si ++ Ga).

  (* This is a surjection from [0,n-1] into the vars of Si,Ga *)

  Hypothesis (w : vec ll_vars n)
             (w_surj : forall u, In u vars -> exists p, u = vec_pos w p).

  Let rx p := vec_pos w p.

  Let Hrx l : incl l (flat_map eill_cmd_vars Si ++ Ga) -> exists v, l ~p vec_map_list v rx.
  Proof.
    induction l as [ | x l IHl ]; intros H.
    + exists vec_zero; rewrite vec_map_list_zero; auto.
    + destruct IHl as (v & Hv).
      { intros ? ?; apply H; right; auto. }
      assert (In x vars) as Hx.
      {  apply H; left; auto. }
      destruct w_surj with (u := x)
        as (p & ?); subst; auto.
      exists (vec_plus (vec_one p) v).
      apply Permutation_sym.
      apply Permutation_trans with (1 := vec_map_list_plus _ _ _).
      rewrite vec_map_list_one.
      apply perm_skip, Permutation_sym; auto.
  Qed.

  Let s x v := Si; vec_map_list v rx ⊦ x.

  Notation "⟦ A ⟧" := (ll_tps s A) (at level 65).
  Notation "'[<' Γ '|-' A '>]'" := (ll_sequent_tps s Γ A) (at level 65).

  Theorem G_eill_complete_bound x : [< map (fun c => ❗[i c]) Si ++ map £ Ga |- £ x >] vec_zero ->
                              Si; Ga ⊦ x.
  Proof.
    intros H.
    do 2 red in H.
    destruct (@Hrx Ga) as (v & Hv).
    { intros ? ?; apply in_or_app; right; auto. }
    apply in_eill_perm with (1 := Permutation_sym Hv).
    fold (s x v).
    rewrite <- (vec_zero_plus v), vec_plus_comm.
    apply H.
    rewrite ll_tps_app.
    exists vec_zero, v.
    repeat split; auto; try (rew vec; fail).
    all: cycle 1.
    { apply ll_tps_perm with (map £ (vec_map_list v (fun p => rx p))).
      apply Permutation_map, Permutation_sym; auto.
      apply ll_tps_vec_map_list_mono; auto.
      intros p.
      red.
      rewrite vec_map_list_one.
      apply in_eill_ax. }

    rewrite <- map_map.
    apply ll_tps_list_bang_zero.
    intros A HA.
    apply in_map_iff in HA.
    destruct HA as (c & H1 & H2); subst.
    destruct c as [ (* p q | *) a p q | a p q | p q r ]; simpl.

    (* (_ -o _) -o _ *)

    + intros y Hy; rew vec; unfold s.
      apply in_eill_inc with a p; auto.
      destruct (@Hrx (a::nil)) as (z & Hz).
      intros ? [ [] | [] ]; apply in_or_app; left.
      * apply in_flat_map; exists (LL_INC a p q); simpl; auto.
      * apply in_eill_perm with (vec_map_list (vec_plus z y) rx).
        - apply Permutation_trans with (1 := vec_map_list_plus _ _ _).
          change (a::vec_map_list y rx) with ((a::nil)++vec_map_list y rx).
          apply Permutation_app; auto.
          apply Permutation_sym; auto.
        - apply Hy; red.
          apply in_eill_perm with (1 := Hz), in_eill_ax.

    (* _ -o (_ -o _) *)

    + intros u Hu y Hy.
      rew vec.
      rewrite vec_plus_comm.
      apply in_eill_perm with (1 := Permutation_sym (vec_map_list_plus _ _ _)).
      apply in_eill_dec with a p; auto.

    (* (_ & _) -o _ *)

    + intros u (H3 & H4).
      rew vec.
      apply in_eill_fork with p q; auto.
  Qed.

End g_eill_complete_bound.

Section g_eill_complete.

  Variable (Si : list eill_cmd) (Ga : list ll_vars).

  Notation vars := (flat_map eill_cmd_vars Si ++ Ga).

  Let vv := nat_sort vars.

  Let Hvv1 : list_injective vv.
  Proof. apply nat_sorted_injective, nat_sort_sorted. Qed.

  Let Hvv2 : incl vv (flat_map eill_cmd_vars Si ++ Ga)
          /\ incl (flat_map eill_cmd_vars Si ++ Ga) vv.
  Proof. apply nat_sort_eq. Qed.

  Let n := length vv.
  Let w : vec ll_vars n := proj1_sig (list_vec vv).
  Let Hw : vec_list w = vv.
  Proof. apply (proj2_sig (list_vec vv)). Qed.

  Let w_surj : forall u, In u vars -> exists p, u = vec_pos w p.
  Proof.
    intros u Hu.
    apply Hvv2 in Hu; rewrite <- Hw in Hu.
    revert Hu; apply vec_list_inv.
  Qed.

  Variables (x : ll_vars)
            (Hvalid : forall n s, @ll_sequent_tps n s (map (fun c : eill_cmd => ❗ [ic]) Si ++ map £ Ga) (£ x) vec_zero).

  Theorem G_eill_complete : Si; Ga ⊦ x.
  Proof.
    apply G_eill_complete_bound with (1 := w_surj), Hvalid.
  Qed.

End g_eill_complete.

(* eill is a fragment of ILL and G-eill is sound and complete for it *)

Theorem G_eill_correct Si Ga p :
           Si; Ga ⊦ p <-> map (fun c => ![i c]) Si ++ map £ Ga ⊢ £ p.
Proof.
  split.
  - apply G_eill_sound.
  - intros H.
    apply G_eill_complete.
    intros n s; revert H; apply ll_tps_sound.
Qed.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order.

From deriving Require Import deriving.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive three := A of bool & bool | B | C.

Definition three_indDef :=
  [indDef for three_rect].
Canonical three_indType :=
  Eval hnf in IndType three three_indDef.

Definition three_eqMixin :=
  [derive eqMixin for three].
Canonical three_eqType :=
  Eval hnf in EqType three three_eqMixin.
Definition three_choiceMixin :=
  [derive choiceMixin for three].
Canonical three_choiceType :=
  Eval hnf in ChoiceType three three_choiceMixin.
Definition three_countMixin :=
  [derive countMixin for three].
Canonical three_countType :=
  Eval hnf in CountType three three_countMixin.
Definition three_finMixin :=
  [derive finMixin for three].
Canonical three_finType :=
  Eval hnf in FinType three three_finMixin.
Definition three_orderMixin :=
  [derive lazy orderMixin for three].
Canonical three_porderType :=
  Eval hnf in POrderType tt three three_orderMixin.
Canonical three_latticeType :=
  Eval hnf in LatticeType three three_orderMixin.
Canonical three_distrLatticeType :=
  Eval hnf in DistrLatticeType three three_orderMixin.
Canonical three_orderType :=
  Eval hnf in OrderType three three_orderMixin.


Require Export Jordan3.

(*==========================================================
============================================================
                 TOPOLOGICAL FMAPS, HMAPS -

                 WITH TAGS AND EMBEDDINGS

                          PART 4:

               MAPS, OPERATIONS, PROPERTIES / B...

COMPLETE: OK!!
============================================================
==========================================================*)

(*
cd Desktop/JFD/JFD08/GALAPAGOS/HMAPSTE_08/
coqtop -opt

Load Jordan1.
Load Jordan2.
Load Jordan3.
*)

(*==========================================================
                   expf_B : expf on B
===========================================================*)

(* OK: *)

Lemma inv_hmap_L_B:forall (m:fmap)(k:dim)(x:dart),
 inv_hmap m -> succ m k x ->
   inv_hmap (L (B m k x) k x (A m k x)).
Proof.
intros.
simpl in |- *.
unfold prec_L in |- *.
split.
 generalize (inv_hmap_B m k x).
   tauto.
 split.
  generalize (exd_B m k x x).
    generalize (succ_exd m k x).
    tauto.
  split.
   generalize (exd_B m k x (A m k x)).
     generalize (succ_exd_A m k x).
     tauto.
   split.
    unfold succ in |- *.
      rewrite A_B.
     tauto.
     tauto.
    split.
     unfold pred in |- *.
       rewrite A_1_B.
      tauto.
      tauto.
     unfold succ in H0.
       rewrite cA_B.
      elim (eq_dart_dec x x).
       intro.
   apply succ_bottom.
        tauto.
        unfold succ in |- *.
          tauto.
       tauto.
      tauto.
      unfold succ in |- *.
       tauto.
Qed.

(* OK: *)

Lemma exd_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     exd (L (B m k x) k x y) z <-> exd m z.
Proof.
simpl in |- *.
intros.
generalize (exd_B m k x z).
tauto.
Qed.

(* OK: *)

Lemma A_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     A (L (B m k x) k x y) j z = A m j z.
Proof.
induction m.
 simpl in |- *.
   intros.
   unfold succ in H0.
   simpl in H0.
   tauto.
 simpl in |- *.
   unfold prec_I in |- *.
   unfold succ in |- *.
   intros.
   elim (eq_dim_dec k j).
  elim (eq_dart_dec x z).
   intro.
     rewrite a.
     intro.
     rewrite a0.
     tauto.
   intros.
     rewrite a.
     rewrite A_B_bis.
    tauto.
    intro.
      symmetry  in H1.
      tauto.
  intro.
    rewrite A_B_ter.
   tauto.
   tauto.
 simpl in |- *.
   unfold prec_L in |- *.
   unfold succ in |- *.
   unfold pred in |- *.
   intros.
   elim (eq_dim_dec k j).
  elim (eq_dim_dec d k).
   intros.
     rewrite a.
     rewrite a0.
     elim (eq_dim_dec j j).
    intro.
      elim (eq_dart_dec x z).
     intro.
       rewrite a2.
       tauto.
     elim (eq_dart_dec d0 x).
      elim (eq_dart_dec d0 z).
       intros.
         rewrite a3 in a2.
         tauto.
       tauto.
      simpl in |- *.
        elim (eq_dim_dec j j).
       intros.
         rewrite A_B_bis.
        tauto.
        intro.
          symmetry  in H1.
          tauto.
       tauto.
    tauto.
   simpl in |- *.
     elim (eq_dart_dec x z).
    intros.
      rewrite <- a0.
      elim (eq_dim_dec d k).
     tauto.
     rewrite a.
       tauto.
    intros.
      rewrite <- a.
      rewrite A_B_bis.
     tauto.
     intro.
       symmetry  in H1.
       tauto.
  elim (eq_dim_dec d k).
   elim (eq_dim_dec d j).
    intros.
      rewrite a0 in a.
      tauto.
    elim (eq_dart_dec d0 x).
     tauto.
     simpl in |- *.
       elim (eq_dim_dec d j).
      tauto.
      intros.
        rewrite A_B_ter.
       tauto.
       tauto.
   simpl in |- *.
     intros.
     rewrite A_B_ter.
    tauto.
    tauto.
Qed.

(* IDEM: *)

Lemma A_1_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     A_1 (L (B m k x) k x y) j z = A_1 m j z.
Proof.
induction m.
 simpl in |- *.
   intros.
   unfold succ in H0.
   simpl in H0.
    tauto.
simpl in |- *.
  unfold prec_I in |- *.
  unfold succ in |- *.
  intros.
  elim (eq_dim_dec k j).
 elim (eq_dart_dec (A m k x) z).
  intro.
    rewrite <- a in |- *.
    intro.
    rewrite <- a0 in |- *.
    rewrite A_1_A in |- *.
   auto.
   tauto.
  simpl in H0; unfold succ in |- *.
     tauto.
 intros.
   simpl in H0.
   rewrite <- a in |- *.
   rewrite A_1_B_bis in |- *.
  auto.
 auto.
    tauto.
 intro.
   symmetry  in H1.
    tauto.
simpl in H0.
  intro.
  rewrite A_1_B_ter in |- *.
  tauto.
 tauto.
simpl in |- *.
  unfold prec_L in |- *.
  unfold succ in |- *.
  unfold pred in |- *.
  intros.
  simpl in H0.
  generalize H0.
  clear H0.
  elim (eq_dim_dec k j).
 elim (eq_dim_dec d k).
  intros a b.
    rewrite a in |- *.
    rewrite <- b in |- *.
    rewrite a in H.
    elim (eq_dart_dec d0 x).
   elim (eq_dart_dec d1 z).
    elim (eq_dim_dec k k).
     symmetry  in |- *.
        tauto.
     tauto.
   elim (eq_dim_dec k k).
     tauto.
    tauto.
  elim (eq_dart_dec (A m k x) z).
   elim (eq_dim_dec k k).
    elim (eq_dart_dec d1 z).
     intros.
       rewrite <- a0 in a2.
       rewrite <- a2 in H.
       rewrite A_1_A in H.
       absurd (x <> nil).
        tauto.
      apply exd_not_nil with m.
        tauto.
      apply succ_exd with k.
        tauto.
      unfold succ in |- *.
         tauto.
      tauto.
     unfold succ in |- *.
        tauto.
    intros.
      rewrite <- a1 in |- *.
      rewrite A_1_A in |- *.
      tauto.
     tauto.
    unfold succ in |- *.
       tauto.
    tauto.
  simpl in |- *.
    elim (eq_dim_dec k k).
   elim (eq_dart_dec d1 z).
     tauto.
   intros.
     rewrite A_1_B_bis in |- *.
     tauto.
    tauto.
   intro.
     symmetry  in H1.
      tauto.
   tauto.
 elim (eq_dart_dec (A m k x) z).
  elim (eq_dim_dec d j).
   elim (eq_dart_dec d1 z).
    intros.
      rewrite <- a2 in a0.
       tauto.
   intros.
     rewrite <- a1 in |- *.
     rewrite <- a0 in |- *.
     rewrite A_1_A in |- *.
     tauto.
    tauto.
   unfold succ in |- *.
      tauto.
  intros.
    rewrite <- a0 in |- *.
    rewrite <- a in |- *.
    rewrite A_1_A in |- *.
    tauto.
   tauto.
  unfold succ in |- *.
     tauto.
 simpl in |- *.
   intros.
   elim (eq_dim_dec d j).
  intro.
    rewrite <- a in a0.
     tauto.
 intro.
   rewrite <- a in |- *.
   rewrite A_1_B_bis in |- *.
   tauto.
  tauto.
 intro.
   symmetry  in H1.
    tauto.
elim (eq_dim_dec d k).
 elim (eq_dart_dec d0 x).
  elim (eq_dim_dec d j).
   intros.
     rewrite a1 in a.
      tauto.
   tauto.
 simpl in |- *.
   elim (eq_dim_dec d j).
  intros.
    rewrite a0 in a.
     tauto.
 intros.
   rewrite A_1_B_ter in |- *.
   tauto.
  tauto.
simpl in |- *.
  elim (eq_dim_dec d j).
 elim (eq_dart_dec d1 z).
   tauto.
 intros.
   rewrite A_1_B_ter in |- *.
   tauto.
  tauto.
intros.
  rewrite A_1_B_ter in |- *.
  tauto.
 tauto.
Qed.

(* OK: *)

Lemma F_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     F (L (B m k x) k x y) z = F m z.
Proof.
intros.
unfold F in |- *.
unfold y in |- *.
rewrite A_1_L_B.
 rewrite A_1_L_B.
  tauto.
  tauto.
  tauto.
 tauto.
 tauto.
Qed.

(* OK!! *)

Lemma cA_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cA (L (B m k x) k x y) j z = cA m j z.
Proof.
simpl in |- *.
intros.
elim (eq_dim_dec k j).
 intro.
   elim (eq_dart_dec x z).
  rewrite a.
    intro.
    rewrite a0.
    rewrite a0 in H0.
    generalize (A_cA m j z (A m j z)).
    intros.
    symmetry  in |- *.
    apply H1.
   tauto.
   apply succ_exd with k.
    tauto.
    tauto.
   apply succ_exd_A.
    tauto.
    rewrite <- a.
      tauto.
   tauto.
  intro.
    elim (eq_dart_dec (cA_1 (B m k x) j (A m k x)) z).
   intro.
     rewrite <- a.
     rewrite <- a in a0.
     rewrite cA_1_B in a0.
    generalize a0.
      clear a0.
      elim (eq_dart_dec (A m k x) (A m k x)).
     intros.
       rewrite <- a1.
       rewrite cA_top.
      rewrite cA_B.
       elim (eq_dart_dec x x).
        tauto.
        tauto.
       tauto.
       tauto.
      tauto.
      apply succ_exd with k.
       tauto.
       tauto.
     tauto.
    tauto.
    tauto.
   intro.
     rewrite <- a.
     rewrite cA_B.
    elim (eq_dart_dec x z).
     tauto.
     intro.
       elim (eq_dart_dec (top m k x) z).
      intro.
        rewrite <- a in b0.
        rewrite cA_1_B in b0.
       generalize b0.
         elim (eq_dart_dec (A m k x) (A m k x)).
        tauto.
        tauto.
       tauto.
       tauto.
      tauto.
    tauto.
    tauto.
 intro.
   rewrite cA_B_ter.
  tauto.
  tauto.
  tauto.
Qed.

(* IDEM: *)

Lemma cA_1_L_B:forall(m : fmap)(k j : dim)(x z : dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cA_1 (L (B m k x) k x y) j z = cA_1 m j z.
Proof.
simpl in |- *.
intros.
elim (eq_dim_dec k j).
 intro.
   elim (eq_dart_dec (A m k x) z).
  rewrite a in |- *.
    intro.
    rewrite <- a0 in |- *.
    assert (cA m j x = A m j x).
   apply A_cA.
     tauto.
   apply succ_exd with k.
     tauto.
    tauto.
   rewrite <- a in |- *.
     apply succ_exd_A.
     tauto.
    tauto.
    tauto.
  rewrite <- H1 in |- *.
    rewrite cA_1_cA in |- *.
    tauto.
   tauto.
  apply succ_exd with k.
    tauto.
   tauto.
 elim (eq_dart_dec (cA (B m k x) j x) z).
  intros.
    rewrite <- a in |- *.
    rewrite cA_1_B in |- *.
   elim (eq_dart_dec (A m k x) (A m k x)).
    intros.
      generalize a0.
      clear a0.
      rewrite <- a in |- *.
      rewrite cA_B in |- *.
     elim (eq_dart_dec x x).
      intros.
        rewrite <- a2 in |- *.
        rewrite cA_1_bottom in |- *.
        tauto.
       tauto.
      apply succ_exd with k.
        tauto.
       tauto.
      tauto.
     tauto.
     tauto.
    tauto.
   tauto.
   tauto.
 intros.
   rewrite <- a in |- *.
   rewrite cA_1_B in |- *.
  elim (eq_dart_dec (A m k x) z).
    tauto.
  elim (eq_dart_dec (bottom m k x) z).
   intros.
     rewrite <- a in b.
     rewrite cA_B in b.
    generalize b.
      elim (eq_dart_dec x x).
      tauto.
     tauto.
    tauto.
   unfold succ in |- *.
     unfold succ in H0.
      tauto.
   tauto.
  tauto.
  tauto.
intro.
  rewrite cA_1_B_ter in |- *.
  tauto.
 tauto.
 tauto.
Qed.

Lemma cF_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cF (L (B m k x) k x y) z = cF m z.
Proof.
simpl in |- *.
unfold cF in |- *.
intros.
rewrite cA_1_L_B.
 rewrite cA_1_L_B.
  tauto.
  tauto.
  tauto.
 tauto.
 tauto.
Qed.

(* WITH Iter: *)

Lemma Iter_cF_L_B:
 forall (m:fmap)(k:dim)(x:dart)(i:nat)( z:dart),
  inv_hmap m -> succ m k x ->
   let y:= A m k x in
    Iter (cF (L (B m k x) k x (A m k x))) i z
      =   Iter (cF m) i z.
Proof.
 intros.
induction i.
 simpl in |- *.
   tauto.
 simpl in |- *.
   rewrite IHi.
   rewrite cF_L_B.
  tauto.
  tauto.
tauto.
Qed.

Definition expfo(m:fmap)(x:dart)(z t:dart):=
  expf (L (B m zero x) zero x (A m zero x)) z t.

(* OK:
BUT REMOVE inv_hmap m IN THE DEF OF expo
IN Jordan2...  ??
*)

Lemma expfo_expf:forall(m:fmap)(x:dart)(z t:dart),
  inv_hmap m -> succ m zero x ->
    (expfo m x z t <-> expf m z t).
Proof.
unfold expfo in |- *.
unfold expf in |- *.
unfold MF.expo in |- *.
simpl in |- *.
unfold prec_L in |- *.
unfold succ in |- *.
unfold pred in |- *.
intros.
unfold MF.f in |- *.
unfold McF.f in |- *.
assert (exd m x).
 apply succ_exd with zero.
  tauto.
  unfold succ in |- *.
    tauto.
 split.
  intros.
    decompose [and] H2.
    clear H2.
    split.
   tauto.
   generalize (exd_B m zero x z).
     split.
    tauto.
    elim H11.
      intros i Hi.
      split with i.
      rewrite Iter_cF_L_B in Hi.
     tauto.
     tauto.
     tauto.
  unfold succ in |- *.
    intro.
    decompose [and] H2.
    clear H2.
    split.
   split.
    apply inv_hmap_B.
      tauto.
    split.
     generalize (exd_B m zero x x).
       tauto.
     split.
      generalize (exd_B m zero x (A m zero x)).
        assert (exd m (A m zero x)).
       apply succ_exd_A.
        tauto.
        tauto.
       tauto.
      split.
       rewrite A_B.
        tauto.
        tauto.
       split.
        rewrite A_1_B.
         tauto.
         tauto.
        rewrite cA_B.
         elim (eq_dart_dec x x).
          intro.
            apply succ_bottom.
           tauto.
           unfold succ in |- *.
             tauto.
          tauto.
         tauto.
         unfold succ in |- *.
           tauto.
   split.
    generalize (exd_B m zero x z).
      tauto.
    elim H6.
      intros i Hi.
      split with i.
      rewrite Iter_cF_L_B.
     tauto.
     tauto.
     tauto.
Qed.

(*==========================================================
                   eqc_B : eqc on B, L_B
===========================================================*)

(* RECALL:
eqc =
fix eqc (m : fmap) (x y : dart) {struct m} : Prop :=
  match m with
  | V => False
  | I m0 x0 => x = x0 /\ y = x0 \/ eqc m0 x y
  | L m0 _ x0 y0 =>
      eqc m0 x y \/ eqc m0 x x0 /\ eqc m0 y0 y
     \/ eqc m0 x y0 /\ eqc m0 x0 y
  end
*)

(* OK: LONG... *)

Lemma eqc_B_CN: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
    eqc m z t ->
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t).
Proof.
induction m.
 simpl in |- *.
   unfold succ in |- *.
   simpl in |- *.
   tauto.
 rename t into u.
 unfold succ in |- *.
   simpl in |- *.
   intros.
   unfold succ in IHm.
   intros.
   unfold prec_I in H.
   decompose [and] H.
   clear H.
   generalize (IHm k x z t H2 H0).
   intros.
   intuition.
 unfold succ in |- *.
   simpl in |- *.
   unfold prec_L in |- *.
   intros.
   generalize H0.
   clear H0.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     rewrite <- a.
     tauto.
   simpl in |- *.
     intros.
     unfold succ in IHm.
     elim H1.
    intro.
      generalize (IHm k x z t H0 H6 H).
      tauto.
    intro.
      elim H.
     intros.
       decompose [and] H8.
       clear H8.
       clear H1.
       generalize (IHm k x z d0 H0 H6 H9).
       generalize (IHm k x d1 t H0 H6 H10).
       intros.
       elim H1.
      elim H8.
       intros.
         tauto.
       intros.
         elim H11.
        intros.
          clear H11.
          tauto.
        intro.
          clear H11.
          tauto.
      intros.
        elim H11.
       clear H11.
         intro.
         elim H8.
        intro.
          tauto.
        intro.
          elim H12.
         clear H12.
           intro.
           tauto.
         intro.
           clear H12.
           assert (eqc (B m k x) z t).
          apply eqc_trans with (A m k x).
           tauto.
           tauto.
          tauto.
       intro.
         clear H11.
         elim H8.
        intro.
          tauto.
        intro.
          elim H11.
         clear H11.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with x.
           tauto.
           tauto.
          tauto.
         intro.
           clear H11.
           tauto.
     intro.
       clear H.
       clear H1.
       decompose [and] H8.
       clear H8.
       generalize (IHm k x z d1 H0 H6 H).
       generalize (IHm k x d0 t H0 H6 H1).
       intros.
       elim H8.
      intro.
        elim H9.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          tauto.
        clear H11.
          intro.
          tauto.
      intro.
        elim H10.
       clear H10.
         intro.
         elim H9.
        intro.
          tauto.
        intro.
          elim H11.
         clear H11.
           intro.
           tauto.
         clear H11.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with (A m k x).
           tauto.
           tauto.
          tauto.
       intro.
         clear H10.
         elim H9.
        intro.
          tauto.
        intro.
          elim H10.
         clear H10.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with x.
           tauto.
           tauto.
          tauto.
         elim H10.
          clear H10.
            intro.
            tauto.
          tauto.
  simpl in |- *.
    intros.
    unfold succ in IHm.
    elim H1.
   intro.
     generalize (IHm k x z t H0 H6 H).
     tauto.
   intro.
     elim H.
    intros.
      decompose [and] H8.
      clear H8.
      clear H1.
      generalize (IHm k x z d0 H0 H6 H9).
      generalize (IHm k x d1 t H0 H6 H10).
      intros.
      elim H1.
     elim H8.
      intros.
        tauto.
      intros.
        elim H11.
       intros.
         clear H11.
         tauto.
       intro.
         clear H11.
         tauto.
     intros.
       elim H11.
      clear H11.
        intro.
        elim H8.
       intro.
         tauto.
       intro.
         elim H12.
        clear H12.
          intro.
          tauto.
        intro.
          clear H12.
          assert (eqc (B m k x) z t).
         apply eqc_trans with (A m k x).
          tauto.
          tauto.
         tauto.
      intro.
        clear H11.
        elim H8.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with x.
          tauto.
          tauto.
         tauto.
        intro.
          clear H11.
          tauto.
    intro.
      clear H.
      clear H1.
      decompose [and] H8.
      clear H8.
      generalize (IHm k x z d1 H0 H6 H).
      generalize (IHm k x d0 t H0 H6 H1).
      intros.
      elim H8.
     intro.
       elim H9.
      intro.
        tauto.
      intro.
        elim H11.
       clear H11.
         intro.
         tauto.
       clear H11.
         intro.
         tauto.
     intro.
       elim H10.
      clear H10.
        intro.
        elim H9.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          tauto.
        clear H11.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with (A m k x).
          tauto.
          tauto.
         tauto.
      intro.
        clear H10.
        elim H9.
       intro.
         tauto.
       intro.
         elim H10.
        clear H10.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with x.
          tauto.
          tauto.
         tauto.
        elim H10.
         clear H10.
           intro.
           tauto.
         tauto.
Qed.

(* OK! IDEM *)

Lemma eqc_B_CS: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t) ->
    eqc m z t.
Proof.
induction m.
 simpl in |- *.
   unfold succ in |- *.
   simpl in |- *.
   tauto.
  rename t into u.
 unfold succ in |- *.
   simpl in |- *.
   intros.
   unfold prec_I in H.
   decompose [and] H.
   clear H.
   generalize (IHm k x z t H2 H0).
   simpl in |- *.
   intros.
   assert (x <> d).
  intro.
    rewrite <- H3 in H5.
    apply H5.
    apply succ_exd with k.
   tauto.
   tauto.
  assert (A m k x <> d).
   intro.
     rewrite <- H6 in H5.
     elim H5.
     apply succ_exd_A.
    tauto.
    unfold succ in |- *.
      tauto.
   intuition.
 unfold succ in |- *.
   simpl in |- *.
   unfold prec_L in |- *.
   intros k x z t H.
   unfold succ in IHm.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     rewrite a.
     tauto.
   simpl in |- *.
     intros.
     rewrite a in H6.
     elim H5.
    intro.
      elim H7.
     generalize (IHm k x z t H0 H).
       tauto.
     intro.
       elim H8.
      intro.
        generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      intro.
        clear H8.
        generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
    clear H5.
      intro.
      elim H5.
     clear H5.
       intro.
       decompose [and or] H5.
      clear H5.
        generalize (IHm k x z t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x d1 t H0 H).
        generalize (IHm k x z d0 H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d0.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d1.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
     intro.
       clear H5.
       intuition.
      generalize (IHm k x z t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x d1 t H0 H).
        generalize (IHm k x z d0 H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d0.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d1.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
  simpl in |- *.
    intros.
    elim H5.
   intro.
     elim H7.
    generalize (IHm k x z t H0 H).
      tauto.
    intro.
      elim H8.
     intro.
       generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     intro.
       clear H8.
       generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
   clear H5.
     intro.
     elim H5.
    clear H5.
      intro.
      decompose [and or] H5.
     clear H5.
       generalize (IHm k x z t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x d1 t H0 H).
       generalize (IHm k x z d0 H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d0.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d1.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
    intro.
      clear H5.
      intuition.
     generalize (IHm k x z t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x d1 t H0 H).
       generalize (IHm k x z d0 H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d0.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d1.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
Qed.

(* OK: *)

Theorem eqc_B: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
    (eqc m z t <->
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t)).
Proof.
simpl in |- *.
intros.
split.
 apply eqc_B_CN.
  tauto.
  tauto.
 apply eqc_B_CS.
  tauto.
  tauto.
Qed.

(* DEFINITION OF eqco WHICH ALLOWS TO PUT AHEAD
ANY 0-LINK: *)

Definition eqco(m:fmap)(k:dim)(x z t:dart):=
  eqc (L (B m k x) k x (A m k x)) z t.

Lemma eqco_eqc:forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
    (eqco m k x z t <-> eqc m z t).
Proof.
unfold eqco in |- *.
simpl in |- *.
intros.
generalize (eqc_B m k x z t H H0).
simpl in |- *.
tauto.
Qed.

(* OK: *)

Lemma eqc_B_eqc :forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
    eqc (B m k x) z t -> eqc m z t.
Proof.
unfold succ in |- *.
induction m.
 simpl in |- *.
   tauto.
rename t into u.
 simpl in |- *.
   unfold prec_I in |- *.
   intros.
   decompose [and] H.
   clear H.
   elim H1.
  intro.
    tauto.
  intro.
    right.
    apply (IHm k x z t H2 H0 H).
 simpl in |- *.
   unfold prec_L in |- *.
   intros k x z t H.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     tauto.
   simpl in |- *.
     intros.
     intuition.
    left.
      apply (IHm k x z t).
     tauto.
     tauto.
     tauto.
    right.
      left.
      generalize (IHm k x z d0 H0 H).
      generalize (IHm k x d1 t H0 H).
      tauto.
    generalize (IHm k x z d1 H0 H).
      generalize (IHm k x d0 t H0 H).
      tauto.
  simpl in |- *.
    intros.
    generalize (IHm k x z d0 H0 H).
    generalize (IHm k x d1 t H0 H).
    generalize (IHm k x z d1 H0 H).
    generalize (IHm k x d0 t H0 H).
    generalize (IHm k x z t H0 H).
    tauto.
Qed.

(* OK, USEFUL IN nc/B,L: *)

Lemma eqc_eqc_B : forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
     eqc (B m k x) x (A m k x) ->
        eqc m z t -> eqc (B m k x) z t.
Proof.
intros.
generalize (eqc_B_CN m k x z t H H0 H2).
intro.
elim H3.
  tauto.
clear H3.
  intro.
  elim H3.
 clear H3.
   intro.
   apply eqc_trans with x.
   tauto.
 apply eqc_trans with (A m k x).
   tauto.
  tauto.
clear H3.
  intro.
   eapply eqc_trans with (A m k x).
  tauto.
apply eqc_trans with x.
 apply eqc_symm.
    tauto.
 tauto.
Qed.

(*=========================================================
                     END OF PART 4
==========================================================*)


From Hammer Require Import Hammer.

Class Decidable (P : Prop) := {
Decidable_witness : bool;
Decidable_spec : Decidable_witness = true <-> P
}.

Lemma Decidable_sound : forall P (H : Decidable P),
Decidable_witness = true -> P.
Proof. hammer_hook "DecidableClass" "DecidableClass.Decidable_sound".
intros P H Hp; apply -> Decidable_spec; assumption.
Qed.

Lemma Decidable_complete : forall P (H : Decidable P),
P -> Decidable_witness = true.
Proof. hammer_hook "DecidableClass" "DecidableClass.Decidable_complete".
intros P H Hp; apply <- Decidable_spec; assumption.
Qed.

Lemma Decidable_sound_alt : forall P (H : Decidable P),
~ P -> Decidable_witness = false.
Proof. hammer_hook "DecidableClass" "DecidableClass.Decidable_sound_alt".
intros P [wit spec] Hd; simpl; destruct wit; tauto.
Qed.

Lemma Decidable_complete_alt : forall P (H : Decidable P),
Decidable_witness = false -> ~ P.
Proof. hammer_hook "DecidableClass" "DecidableClass.Decidable_complete_alt".
intros P [wit spec] Hd Hc; simpl in *; intuition congruence.
Qed.

Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).

Ltac _decide_ P H :=
let b := fresh "b" in
set (b := decide P) in *;
assert (H : decide P = b) by reflexivity;
clearbody b;
destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].

Tactic Notation "decide" constr(P) "as" ident(H) :=
_decide_ P H.

Tactic Notation "decide" constr(P) :=
let H := fresh "H" in _decide_ P H.

Require Import Bool Arith ZArith.

Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
Decidable_witness := Bool.eqb x y
}.
Next Obligation.
apply eqb_true_iff.
Qed.

Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
Decidable_witness := Nat.eqb x y
}.
Next Obligation.
apply Nat.eqb_eq.
Qed.

Program Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := {
Decidable_witness := Nat.leb x y
}.
Next Obligation.
apply Nat.leb_le.
Qed.

Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
Decidable_witness := Z.eqb x y
}.
Next Obligation.
apply Z.eqb_eq.
Qed.


(** * Decidable [In] Predicate *)

Set Implicit Arguments.

Require Export Coq.Lists.List.
Require Export Coq.Arith.Arith.

(** In the current work, we need a decidable version of [In] predicate.
   - The standard [In] in the Coq library is not suitable for the current work.
   - It is necessary in defining language syntax.
     (Cf. the definition of [pterm] in [without_FreeVar_language_syntax.v])
   - We need an decidable, but equivalent variant. *)

Definition decidable (A:Type)
  := forall a b :A, {a = b} + { a <> b}.

Fixpoint IN A (decA:decidable A)(a:A)(l:list A) {struct l} : Prop :=
  match l with
    | nil    => False
    | b :: m => if decA a b then True else IN decA a m
  end.

(** Abbreviations for [IN] in case of natural numbers.
   We remark that any denumerably decidable set can be use
   instead of [nat].
   Here we use natural numbers for any kind of names for simplicity. *)

Notation name := nat.
Notation eqdec := eq_nat_dec.

Notation "k == i" := (eqdec k i) (at level 70).

Notation IN_name := (@IN name eqdec).

Notation " x @ l " := (IN_name x l) (at level 70).
Notation " x # l " := (~ IN_name  x l) (at level 70).

Notation rm_name := (remove eqdec).

(** Tactics for destructing the decidable equality between naturals numbers. *)

Ltac case_var :=
  let ldestr k i := destruct (k == i); [try subst k | idtac] in
  match goal with
  | |- context [?k == ?i]      => ldestr k i
  | H: context [?k == ?i] |- _ => ldestr k i
  end.

Ltac case_dec decA :=
  match goal with
    | |- context [decA ?a ?b]       => destruct (decA a b)
    | _ : context [decA ?a ?b] |- _ => destruct (decA a b)
  end.

(** A specified tactic for uninteresting cases *)

Ltac neq_case :=
  match goal with
    | H : ?x <> ?y |- _ =>
      right; red; intro Heq; inversion Heq; congruence
  end.

(** Decidability of being-in-a-list *)

Lemma decIN : forall A decA (x:A) (l:list A),
  {IN decA x l} + {~ IN decA x l}.
Proof.
  induction l as [| a]; simpl;
    [ right
      | case_dec decA
    ]; auto.
Defined.

Notation "x <-? l" := (decIN eqdec x l) (at level 70).

Ltac case_IN :=
  match goal with
    | |- context [?x <-? ?l]       => destruct (x <-? l)
    | H : context [?x <-? ?l] |- _ => destruct (x <-? l)
  end.

(** Uniqueness of proofs of being-in-a-list *)

Lemma IN_proof_uniq : forall A decA (a:A)(l:list A)(p q:IN decA a l),
  p = q.
Proof.
  induction l; simpl; intros p q;
    [ elim p
      | case_dec decA;
        [ case p; case q; reflexivity
          | apply IHl
        ]
    ].
Qed.

Hint Resolve decIN IN_proof_uniq : datatypes.

(** Equivalence of [IN] and [In] *)

Lemma IN_In : forall A decA (l:list A)(a:A),
  IN decA a l <-> In a l.
Proof.
  induction l; simpl;
    [ tauto
      | split; intros; case_dec decA; firstorder; congruence].
Qed.

(** Repalcing [IN] with [In] in order to use the library about [In]. *)

Ltac rew_IN :=
  match goal with
    | |- context [IN _ _ _]       => rewrite IN_In
    | H : context [IN _ _ _] |- _ => rewrite IN_In in H
  end.

Ltac rew_In decA :=
  match goal with
    | |- context [In _ _]       => rewrite <- (IN_In decA)
    | H : context [In _ _] |- _ => rewrite <- (IN_In decA) in H
  end.

(** Useful lemmas about [IN] *)

Lemma IN_eq : forall A decA (a:A) (l:list A),
  IN decA a (a :: l).
Proof.
  intros; rewrite IN_In; auto with datatypes.
Qed.

Lemma IN_cons : forall A decA (l : list A)(a b:A),
  IN decA b l ->
  IN decA b (a::l).
Proof.
  intros; repeat rew_IN; auto using in_cons.
Qed.

Lemma neq_IN_cons : forall A decA (l : list A) (a b:A),
  a <> b ->
  IN decA b (a::l) ->
  IN decA b l.
Proof.
  intros until 1; simpl; case_dec decA; congruence.
Qed.

Hint Resolve IN_In IN_eq IN_cons neq_IN_cons : datatypes.

Lemma IN_rm_1 : forall A decA (a b : A) (l: list A),
  IN decA a (remove decA b l) ->
  IN decA a l.
Proof.
  induction l as [| c l IHl]; simpl; intros; auto.
  repeat case_dec decA; auto.
  apply IHl; apply neq_IN_cons with c; auto.
Qed.

Lemma IN_rm_2 : forall A decA (a b:A) (l:list A),
  a <> b ->
  IN decA a l ->
  IN decA a (remove decA b l).
Proof.
  induction l as [|c]; simpl; intros; auto.
  repeat case_dec decA;
    [ congruence
      | auto
      | subst; apply IN_eq
      | repeat rew_IN; auto using in_cons ].
Qed.

Lemma IN_rm_neq : forall A decA (a b : A) (l: list A),
  IN decA a (remove decA b l) ->
  a <> b.
Proof.
  induction l as [| c l IHl]; simpl; intros; auto.
  intro; subst.
  case_dec decA; firstorder.
  elim IHl; eauto using neq_IN_cons.
Qed.

Hint Resolve IN_rm_1 IN_rm_2 IN_rm_neq : datatypes.

Lemma IN_or_app : forall A decA (a:A) (l m :list A),
  IN decA a l \/ IN decA a m ->
  IN decA a (l ++ m).
Proof.
  intros; repeat rew_IN; auto with datatypes.
Qed.

Lemma IN_app_or : forall A decA (a:A) (l m :list A),
  IN decA a (l ++ m) ->
  IN decA a l \/ IN decA a m.
Proof.
  intros; repeat rew_IN; auto with datatypes.
Qed.

Implicit Arguments IN_app_or [A decA a l m].

Lemma IN_appL : forall A decA (a:A)(l m: list A),
  IN decA a l ->
  IN decA a (l ++ m).
Proof.
  intros; apply IN_or_app; left; assumption.
Qed.

Lemma IN_appR : forall A decA (a:A)(l m: list A),
  IN decA a m ->
  IN decA a (l ++ m).
Proof.
  intros; apply IN_or_app; right; assumption.
Qed.

Hint Resolve IN_or_app IN_app_or IN_appL IN_appR : datatypes.

Lemma notIN_rm_1 : forall A decA (a : A) (l: list A),
  ~ IN decA a (remove decA a l).
Proof.
  induction l; simpl; intros; intuition.
  case_dec decA; auto.
  simpl in H; case_dec decA; auto.
Qed.

Lemma notIN_rm_2 : forall A decA (a b:A) (l:list A),
  ~ IN decA a (remove decA b l) ->
  a <> b ->
  ~ IN decA a l.
Proof.
  firstorder using notIN_rm_1.
Qed.

Hint Resolve notIN_rm_1 notIN_rm_2 : datatypes.

Lemma notIN_app_1 : forall A decA (a:A) (l m :list A),
  ~ IN decA a (l ++ m) ->
  ~ IN decA a l /\ ~ IN decA a m.
Proof.
  firstorder with datatypes.
Qed.

Lemma notIN_app_2 : forall A decA (a:A) (l m :list A),
  ~ IN decA a l ->
  ~ IN decA a m ->
  ~ IN decA a (l ++ m).
Proof.
  intuition; elim (IN_app_or H1); assumption.
Qed.

Lemma notIN_app_3 : forall A decA (a:A)(l m: list A),
  ~ IN decA a (l ++ m) -> ~ IN decA a l.
Proof.
  intros; elim (notIN_app_1 _ _ _ _ H); tauto.
Qed.

Lemma notIN_app_4 : forall A decA (a:A)(l m: list A),
  ~ IN decA a (l ++ m) -> ~ IN decA a m.
Proof.
  intros; elim (notIN_app_1 _ _ _ _ H); tauto.
Qed.

Lemma notIN_cons_1 : forall A decA (a b:A)(l:list A),
  ~ IN decA a (b :: l) ->
  a <> b.
Proof.
  intuition; subst; apply H; auto with datatypes.
Qed.

Lemma notIN_cons_2 : forall A decA (a b:A)(l:list A),
  ~ IN decA a (b :: l) ->
  ~ IN decA a l.
Proof.
  intuition; subst; apply H; auto with datatypes.
Qed.

Hint Resolve notIN_app_1 notIN_app_2 notIN_app_3 notIN_app_4 : datatypes.
Hint Resolve IN_cons notIN_cons_1 notIN_cons_2 : datatypes.

Lemma notIN_cons_3 : forall A decA (a b:A) (l:list A),
  a <> b ->
  ~ IN decA b l ->
  ~ IN decA b (a :: l).
Proof.
  firstorder; simpl; case_dec decA; auto.
Qed.

Lemma notIN_singleton_1 : forall A decA (a b:A),
  a <> b ->
  ~ IN decA b (a :: nil).
Proof.
  firstorder; simpl; case_dec decA; auto.
Qed.

Lemma notIN_empty_1 : forall A decA (a:A),
  ~ IN decA a nil.
Proof.
  firstorder.
Qed.

Lemma rm_cons : forall A decA a b (l:list A),
  a <> b ->
  b :: remove decA a l = remove decA a (b :: l).
Proof.
  intros; simpl; destruct (decA a b);
    [ elim H
      | ];
    auto.
Qed.

Hint Resolve notIN_cons_3 notIN_singleton_1 notIN_empty_1 rm_cons : datatypes.

(* added *)

Lemma rm_app :
  forall (A : Type) (decA : decidable A) x l m,
    (remove decA x l) ++ (remove decA x m)
    = (remove decA x (l ++ m)).
Proof.
  induction l as [| y l]; auto; simpl; intros.
  case_dec decA.
  - subst; auto.
  - simpl. f_equal; auto.
Qed.

Lemma rm_rm_eq_rm :
  forall (A : Type) (decA : decidable A) x l,
    remove decA x (remove decA x l) = (remove decA x l).
Proof.
  induction l as [ | a l]; auto; simpl; intros.
  case_dec decA; subst; auto.
  rewrite <- rm_cons; auto.
  f_equal; auto.
Qed.

Lemma rm_neq_eq :
  forall  (A : Type) (decA : decidable A) x y l,
    remove decA x (remove decA y l) =  remove decA y (remove decA x l).
Proof.
  induction l as [ | a l]; auto; simpl; intros.
  case_dec decA; subst; auto.
  - destruct (decA x a).
    + subst; auto.
    + rewrite IHl. simpl. destruct (decA a a); tauto.
  - destruct (decA x a).
    + subst; rewrite <- IHl; simpl; destruct (decA a a); subst; auto.
      * congruence.
    + try repeat rewrite <- rm_cons; auto; f_equal; auto.
Qed.

Hint Resolve rm_app rm_rm_eq_rm rm_neq_eq : datatypes.


From mathcomp.ssreflect Require Import all_ssreflect seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import MPST.Common.Forall.

Notation member := List.In.

Lemma forall_member A P (l : seq A) :
  Forall P l <-> forall x, member x l -> P x.
Proof.
  elim l=>// x {l}l [IhL IhR] /=; split.
  + by move=>[Px /IhL-Pl] x0 [<-|/Pl].
  + move=> H; split.
    - by apply: H; left.
    - by apply: IhR=>x0 x0_l; apply: H; right.
Qed.

Lemma memberP (A : eqType) (x : A) l : reflect (member x l) (x \in l).
Proof.
  elim l; first by apply: ReflectF.
  move=> a {l}l Ih/=; rewrite in_cons; case: eqP=>[->|x_aF].
  + by apply: ReflectT; left.
  + case: Ih=>[x_l|x_lF].
    - by apply: ReflectT; right.
    - by apply: ReflectF=>[[/esym-x_a|x_l]].
Qed.

Lemma cat_eq_nil (A : eqType) (K1 K2 : seq A)
  : K1 ++ K2 == [::] <-> K1 == [::] /\ K2 == [::].
Proof.
  split.
  - by move=>/eqP; case: K1=>//=->.
  - by move=>[/eqP->/eqP->].
Qed.

Lemma flatten_eq_nil (A : eqType) (Ks : seq (seq A)) :
  flatten Ks == [::] <-> forall K, member K Ks -> K == [::].
Proof.
  split.
  - by elim: Ks=>//= K Ks Ih /cat_eq_nil-[/eqP-> /Ih-H {}K [->|/H]].
  - elim: Ks=>//= K Ks Ih H; apply/cat_eq_nil;split; first by apply/H; left.
      by apply/Ih=>K' H'; apply/H; right.
Qed.

Lemma member_map A B (P : B -> Prop) (f : A -> B) L :
  (forall x, member x [seq f x | x <- L] -> P x) <->
  (forall x, member x L -> P (f x)).
Proof.
  split=>H x M.
  - apply: H; elim: L M=>// y L Ih [<-|]; first by left.
    by rewrite -/(member _ _) => /Ih-H /=; right.
  - elim: L H M=>// y L /=Ih H [<-|H'].
    + by apply: H; left.
    + by apply: Ih=>// z M; apply: H; right.
Qed.
Hint Rewrite member_map : mpst.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal46.

Set Printing Depth 1000.
Definition lfind_eval  y z:=
mem z y.

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) (Cons Zero Nil)))).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil)).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)))).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Zero) (Nil).


Require Import Basics.
Require Import Spaces.Nat.Core.
Local Close Scope trunc_scope.

Local Open Scope nat_scope.

Ltac nat_absurd_trivial :=
  unfold ">" in *; unfold "<" in *;
  match goal with
  | [ H : ?n.+1 <= 0 |- _ ] => contradiction (not_leq_Sn_0 n H)
  | [ H : ?n.+1 <= ?n |- _ ] => contradiction (not_lt_n_n n H)
  | [ H1 : ?k.+1 <= ?n |- _ ] =>
      match goal with
      | [ H2 : ?n <= ?k |- _] =>
          contradiction (not_leq_Sn_n k (@leq_trans _ _ _ H1 H2))
      end
  end.

#[export] Hint Resolve not_lt_n_n : nat.
#[export] Hint Resolve not_lt_n_0 : nat.
#[export] Hint Resolve not_leq_Sn_0 : nat.
#[export] Hint Extern 2 => nat_absurd_trivial : nat.

(** This is defined so that it can be added to the [nat] auto hint database. *)
Local Definition symmetric_paths_nat (n m : nat)
  : n = m -> m = n := @symmetric_paths nat n m.

Local Definition transitive_paths_nat (n m k : nat)
  : n = m -> m = k -> n = k := @transitive_paths nat n m k.

#[export] Hint Resolve symmetric_paths_nat | 5 : nat.
#[export] Hint Resolve transitive_paths_nat : nat.
#[export] Hint Resolve leq_0_n : nat.
#[export] Hint Resolve leq_trans : nat.
#[export] Hint Resolve leq_antisym : nat.

Proposition assoc_nat_add (n m k : nat)
  : n + (m + k) = (n + m) + k.
Proof.
  revert m k; induction n.
  - reflexivity.
  - intros m k. change (n.+1 + (m + k)) with (n + (m + k)).+1.
    apply (transitive_paths _ _ _ (nat_add_n_Sm _ _)).
    change (m + k).+1 with (m.+1 + k);
    change (n.+1 + m) with (n + m).+1.
    apply (transitive_paths _ _ _ (IHn m.+1 k)).
    apply (ap (fun zz => zz + k)).
    apply symmetric_paths, nat_add_n_Sm.
Defined.

Proposition not_lt_implies_geq {n m : nat} : ~(n < m) -> m <= n.
Proof.
  intros not_lt.
  destruct (@leq_dichot m n); [ assumption | contradiction].
Defined.

Proposition not_leq_implies_gt {n m : nat} : ~(n <= m) -> m < n.
Proof.
  intros not_leq.
  destruct (@leq_dichot n m); [ contradiction | assumption].
Defined.

Proposition lt_implies_not_geq {n m : nat} : (n < m) -> ~(m <= n).
Proof.
  intros ineq1 ineq2.
  contradiction (not_lt_n_n n). by apply (leq_trans ineq1).
Defined.

Proposition leq_implies_not_gt {n m : nat} : (n <= m) -> ~(m < n).
Proof.
  intros ineq1 ineq2.
  contradiction (not_lt_n_n n); by refine (leq_trans _ ineq2).
Defined.

Ltac convert_to_positive :=
  match goal with
  | [ H : ~ (?n < ?m) |- _] =>  apply not_lt_implies_geq in H
  | [ H : ~ (?n <= ?m) |- _] => apply not_leq_implies_gt in H
  | [|- ~ (?n < ?m) ] => apply leq_implies_not_gt
  | [|- ~ (?n <= ?m) ] => apply lt_implies_not_geq
  end.

#[export] Hint Extern 2 => convert_to_positive : nat.

(** Because of the inductive definition of [<=], one can destruct the proof of [n <= m] and get a judgemental identification between [n] and [m] rather than a propositional one, which may be preferable to the following lemma. *)
Proposition leq_split {n m : nat} : (n <= m) -> sum (n < m) (n = m).
Proof.
  intro l. induction l.
  - now right.
  - left. exact (leq_S_n' _ _ l).
Defined.

Proposition diseq_implies_lt (n m : nat)
  : n <> m -> sum (n < m) (n > m).
Proof.
  intros diseq.
  destruct (dec (n < m)) as [| a]; [ now left |].
  right. destruct (@leq_dichot n m) as [n_leq_m | gt];
    [ | assumption].
  destruct n_leq_m;
    [ now contradiction diseq
    | contradiction a; now apply leq_S_n'].
Defined.

Proposition lt_implies_diseq (n m : nat)
  : n < m -> (n <> m).
Proof.
  intros ineq eq. rewrite eq in ineq.
  contradiction (not_lt_n_n m).
Defined.

#[export] Hint Resolve lt_implies_diseq : nat.

(** This lemma is just for convenience in the case where the user forgets to unfold the definition of [<]. *)
Proposition n_lt_Sn (n : nat) : n < n.+1.
Proof.
  exact (leq_n n.+1).
Defined.

Proposition leq_S' (n m : nat) : n.+1 <= m -> n <= m.
Proof.
  intro l.
  now apply leq_S_n, leq_S.
Defined.

Ltac easy_eq_to_ineq :=
  match goal with
  | [ H : ?x = ?n    |- ?x <= ?n ] => destruct H; constructor
  | [ H : ?x.+1 = ?n |- ?x <= ?n ] => rewrite <- H; constructor;
                                      constructor
  | [ H : ?x.+1 = ?n |- ?x < ?n  ] => rewrite <- H; apply leq_n
  | [ H : ?x.+2 = ?n |- ?x <= ?n ] => rewrite <- H; apply leq_S';
                                      apply leq_S'; apply leq_n
  | [ H : ?x.+2 = ?n |- ?x < ?n ] => rewrite <- H; apply leq_S_n';
                                      apply leq_S
  end.

#[export] Hint Extern 3 => easy_eq_to_ineq : nat.

Proposition mixed_trans1 (n m k : nat)
  : n <= m -> m < k -> n < k.
Proof.
  intros l j. apply leq_S_n' in l.
  apply (@leq_trans (n.+1) (m.+1) k); trivial.
Defined.

Ltac leq_trans_resolve :=
  match goal with
  | [ H : ?n <= ?m |- ?n <= ?k ] => apply (leq_trans H)
  | [ H : ?k <= ?m |- ?n <= ?k ] => refine (leq_trans _ H)
  | [ H : ?n <= ?m |- ?n < ?k ] => apply (mixed_trans1 _ _ _ H)
  | [ H : ?m <= ?k |- ?n < ?k ] => refine (leq_trans _ H)
  | [ H : ?m <  ?k |- ?n < ?k ] => refine (mixed_trans1 _ _ _ _ H)
  | [ H : ?n <  ?m |- ?n < ?k ] => apply (leq_trans H)
  end.

#[export] Hint Extern 2 => leq_trans_resolve : nat.

Proposition mixed_trans2 (n m k : nat)
  : n < m -> m <= k -> n < k.
Proof.
  intros l j. apply (@leq_trans (n.+1) m k); trivial.
Defined.

#[export] Hint Resolve mixed_trans1 : nat.
#[export] Hint Resolve mixed_trans2 : nat.

Proposition sub_n_n (n : nat) : n - n = 0.
Proof.
  induction n.
  - reflexivity.
  - simpl; exact IHn.
Defined.

Proposition sub_n_0 (n : nat) : n - 0 = n.
Proof.
 destruct n; reflexivity.
Defined.

Ltac rewrite_subn0 :=
  match goal with
  | [ |- context [ ?n - 0 ] ] => rewrite -> sub_n_0
  end.

Ltac rewrite_subnn :=
  match goal with
  | [ |- context [ ?n - ?n ] ] => rewrite -> sub_n_n
  end.

#[export] Hint Rewrite -> sub_n_0 : nat.
#[export] Hint Rewrite -> sub_n_n : nat.
#[export] Hint Resolve sub_n_0 : nat.

Proposition add_n_sub_n_eq (m n : nat) : m + n - n = m.
Proof.
  destruct m.
  - induction n.
    + reflexivity.
    + assumption.
  - induction n.
    + simpl. destruct (add_n_O m); reflexivity.
    + simpl. destruct (add_n_Sm m n). assumption.
Defined.

Proposition add_n_sub_n_eq' (m n : nat) : n + m - n = m.
Proof.
  destruct (nat_add_comm m n). exact (add_n_sub_n_eq m n).
Defined.

Proposition n_lt_m_n_leq_m { n m : nat } : n < m -> n <= m.
Proof.
  intro H. apply leq_S, leq_S_n in H; exact H.
Defined.

#[export] Hint Resolve n_lt_m_n_leq_m : nat.

Proposition lt_trans (n m k : nat) : n < m -> m < k -> n < k.
Proof.
  eauto with nat.
Defined.

Proposition not_both_less (n m : nat) : n < m -> ~(m < n).
Proof.
  intros l a; contradiction (not_lt_n_n _ (lt_trans _ _ _ l a)).
Defined.

Proposition n_leq_add_n_k (n m : nat) : n <= n + m.
Proof.
  induction n.
  - apply leq_0_n.
  - simpl; apply leq_S_n', IHn.
Defined.

Proposition n_leq_add_n_k' (n m : nat) : n <= m + n.
Proof.
  induction m.
  - exact(leq_n n).
  - simpl. apply leq_S. assumption.
Defined.

Proposition natineq0eq0 {n : nat} : n <= 0 -> n = 0.
Proof.
  destruct n.
  - reflexivity.
  - intro. contradiction (not_leq_Sn_0 n).
Defined.

Proposition subsubadd (n m k : nat) : n - (m + k) = n - m - k.
Proof.
  revert m k; induction n.
  - reflexivity.
  - intro m; induction m; intro k.
    + change (0 + k) with k; reflexivity.
    + change (m.+1 + k) with (m + k).+1; apply IHn.
Defined.

#[export] Hint Resolve subsubadd : nat.

Proposition subsubadd' (n m k : nat) : n - m - k = n - (m + k).
Proof.
  auto with nat.
Defined.

Definition nleqSm_dichot {n m : nat}
  : (n <= m.+1) -> sum (n <= m) (n = m.+1).
Proof.
  revert m; induction n.
  - intro. left. exact (leq_0_n m).
  - induction m.
    + intro l. apply leq_S_n, natineq0eq0 in l.
      right; apply ap; exact l.
    + intro l. apply leq_S_n, IHn in l; induction l as [a | b].
      * left. apply leq_S_n'; exact a.
      * right. apply ap; exact b.
Defined.

Proposition sub_leq_0 (n m : nat) : n <= m -> n - m = 0.
Proof.
  intro l; induction l.
  - exact (sub_n_n n).
  - change (m.+1) with (1 + m). destruct n.
    + reflexivity.
    + destruct (nat_add_comm m 1).
      destruct (symmetric_paths _ _ (subsubadd n.+1 m 1)).
      destruct (symmetric_paths _ _ IHl).
      reflexivity.
Defined.

Proposition sub_leq_0_converse (n m : nat) : n - m = 0 -> n <= m.
Proof.
  revert m; induction n.
  - auto with nat.
  - intros m eq. destruct m.
    + simpl in eq. apply symmetric_paths in eq.
      contradiction (not_eq_O_S n eq).
    + simpl in eq. apply leq_S_n', IHn, eq.
Defined.

Proposition sub_gt_0_lt (n m : nat) : n - m > 0 -> m < n.
Proof.
  intro ineq.
  destruct (@leq_dichot n m) as [n_leq_m |]; [ | assumption].
  apply sub_leq_0 in n_leq_m.
  contradiction (not_lt_n_n 0). now rewrite n_leq_m in ineq.
Defined.

Proposition lt_sub_gt_0 (n m : nat) : m < n -> 0 < n - m.
Proof.
  revert m; induction n.
  - intros m ineq. contradiction (not_lt_n_0 m).
  - induction m.
    + simpl. easy.
    + simpl. intro ineq. apply leq_S_n in ineq.
      now apply IHn in ineq.
Defined.

Proposition natminuspluseq (n m : nat)
  : n <= m -> (m - n) + n = m.
Proof.
  revert m; induction n.
  - intros. destruct m; [reflexivity |]. simpl.
    apply (ap S), symmetric_paths, add_n_O.
  - intros m l. induction m.
    + contradiction (not_leq_Sn_0 n).
    + simpl. apply leq_S_n, IHn in l.
      destruct (nat_add_n_Sm (m - n) n).
      destruct (symmetric_paths _ _ l).
      reflexivity.
Defined.

Proposition natminusplusineq (n m : nat) : n <= n - m + m.
Proof.
  destruct (@leq_dichot m n) as [l | g].
  - destruct (symmetric_paths _ _ (natminuspluseq _ _ l));
      constructor.
  - apply n_lt_m_n_leq_m in g.
    now destruct (symmetric_paths _ _ (sub_leq_0 n m _)).
Defined.

Proposition natminuspluseq' (n m : nat)
  : n <= m -> n + (m - n) = m.
Proof.
  intros. destruct (symmetric_paths _ _ (nat_add_comm n (m - n))).
  apply natminuspluseq. assumption.
Defined.

#[export] Hint Rewrite -> natminuspluseq : nat.
#[export] Hint Rewrite -> natminuspluseq' : nat.

#[export] Hint Resolve leq_S_n' : nat.

Ltac leq_S_n_in_hypotheses :=
  match goal with
  | [ H : ?n.+1 <= ?m.+1 |- _ ] => apply leq_S_n in H
  | [ H : ?n < ?m.+1 |- _ ] => apply leq_S_n in H
  | [ H : ?m.+1 > ?n |- _ ] => apply leq_S_n in H
  | [ H : ?m.+1 >= ?n.+1 |- _ ] => apply leq_S_n in H
  end.

#[export] Hint Extern 4 => leq_S_n_in_hypotheses : nat.

Proposition nataddpreservesleq { n m k : nat }
  : n <= m -> n + k <= m + k.
Proof.
  intro l.
  induction k.
  - destruct (add_n_O n), (add_n_O m); exact l.
  - destruct (nat_add_n_Sm n k), (nat_add_n_Sm m k);
      apply leq_S_n'; exact IHk.
Defined.

#[export] Hint Resolve nataddpreservesleq : nat.

Proposition nataddpreservesleq' { n m k : nat }
  : n <= m -> k + n <= k + m.
Proof.
  destruct (symmetric_paths _ _ (nat_add_comm k m)),
    (symmetric_paths _ _ (nat_add_comm k n)).
  exact nataddpreservesleq.
Defined.

#[export] Hint Resolve nataddpreservesleq' : nat.

Proposition nataddpreserveslt { n m k : nat }
  : n < m -> n + k < m + k.
Proof.
  unfold "<".
  change (n + k).+1 with (n.+1 + k).
  generalize (n.+1). intros n' l.
  induction k.
  - destruct (add_n_O n'), (add_n_O m); exact l.
  - destruct (nat_add_n_Sm n' k), (nat_add_n_Sm m k);
      apply leq_S_n'; exact IHk.
Defined.

Proposition nataddpreserveslt' { n m k : nat }
  : n < m -> k + n < k + m.
Proof.
  destruct (symmetric_paths _ _ (nat_add_comm k n)),
    (symmetric_paths _ _ (nat_add_comm k m));
    exact nataddpreserveslt.
Defined.

Proposition nataddreflectslt { n m k : nat }
  : n + k < m + k -> n < m.
Proof.
  induction k.
  - destruct (add_n_O n), (add_n_O m); trivial.
  - intro l. destruct (nat_add_n_Sm n k), (nat_add_n_Sm m k) in l.
    apply leq_S_n, IHk in l; exact l.
Defined.

Proposition nataddreflectsleq { n m k : nat }
  : n + k <= m + k -> n <= m.
Proof.
  destruct n.
  - intros ?; apply leq_0_n.
  - intro a. change (n.+1 + k) with (n + k).+1 in a.
    now apply (@nataddreflectslt n m k).
Defined.

Proposition nataddreflectslt' { n m k : nat }
  : k + n < k + m -> n < m.
Proof.
  destruct (symmetric_paths _ _ (nat_add_comm k n)),
    (symmetric_paths _ _ (nat_add_comm k m));
    exact nataddreflectslt.
Defined.

Proposition nataddreflectsleq' { n m k : nat }
  : k + n <= k + m -> n <= m.
Proof.
  destruct (symmetric_paths _ _ (nat_add_comm k n)),
    (symmetric_paths _ _ (nat_add_comm k m));
    exact nataddreflectsleq.
Defined.

Proposition natsubreflectsleq { n m k : nat }
  : k <= m -> n - k <= m - k -> n <= m.
Proof.
  intros ineq1 ineq2.
  apply (@nataddpreservesleq _ _ k) in ineq2.
  apply (@leq_trans _ (n - k + k) _ (natminusplusineq _ _)).
  apply (@leq_trans _ (m - k + k)  _ _).
  destruct (symmetric_paths _ _ (natminuspluseq k m ineq1)); easy.
Defined.

Proposition nataddsub_assoc_lemma {k m : nat}
  : (k <= m) -> m.+1 - k = (m - k).+1.
Proof.
  revert m; induction k.
  - intros m l; simpl. destruct m; reflexivity.
  - induction m.
    + simpl; intro g; contradiction (not_leq_Sn_0 _ g).
    + intro l; apply leq_S_n in l.
      change (m.+2 - k.+1) with (m.+1 - k).
      change (m.+1 - k.+1) with (m - k).
      exact (IHk _ l).
Defined.

Proposition nataddsub_assoc (n : nat) {m k : nat}
  : (k <= m) -> n + (m - k) = n + m - k.
Proof.
  revert m k. induction n.
  - reflexivity.
  - intros m k l.
    change (n.+1 + (m - k)) with (n + (m - k)).+1;
      change (n.+1 + m) with (n +m).+1.
    destruct k, m;
      [ reflexivity
      | reflexivity
      | contradiction (not_lt_n_0 k _)
      | ].
    simpl "-". apply leq_S_n in l.
    destruct (symmetric_paths _ _ (nat_add_n_Sm n (m - k))).
    destruct  (nataddsub_assoc_lemma l).
    apply (IHn m.+1 k).
    apply leq_S.
    assumption.
Defined.

Proposition nataddsub_comm (n m k : nat)
  : m <= n -> (n - m) + k = (n + k) - m.
Proof.
  intro l.
  destruct (nat_add_comm k n).
  destruct (nataddsub_assoc k l).
  apply nat_add_comm.
Defined.

Proposition nataddsub_comm_ineq_lemma (n m : nat)
  : n.+1 - m <= (n - m).+1.
Proof.
  revert m.
  induction n.
  - induction m; [ apply leq_n | apply leq_S; apply leq_n ].
  - intro m; induction m.
    + apply leq_n.
    + apply IHn.
Defined.

Proposition nataddsub_comm_ineq (n m k : nat)
  : (n + k) - m <= (n - m) + k.
Proof.
  induction k.
  - destruct (add_n_O n), (add_n_O (n - m)); constructor.
  - destruct (add_n_Sm n k).
    refine (leq_trans (nataddsub_comm_ineq_lemma (n+k) m) _).
    destruct (add_n_Sm (n - m) k).
    now apply leq_S_n'.
Defined.

Proposition nat_sub_add_ineq (n m : nat) : n <= n - m + m.
Proof.
  destruct (@leq_dichot m n) as [l | gt].
  - destruct (symmetric_paths _ _ (nataddsub_comm _ _ m l)).
    destruct (symmetric_paths _ _ (add_n_sub_n_eq n m)).
    apply leq_refl; done.
  - apply n_lt_m_n_leq_m in gt.
    destruct (symmetric_paths _ _ (sub_leq_0 n m _)).
    assumption.
Defined.

Proposition i_lt_n_sum_m (n m i : nat)
  : i < n - m -> m <= n.
Proof.
  revert m i; induction n.
  - intros m i l. simpl in l. contradiction (not_lt_n_0 _ _).
  - intros m i l. induction m.
    + apply leq_0_n.
    + apply leq_S_n'. simpl in l. apply (IHn m i l).
Defined.

Proposition nataddsub_assoc_implication (n : nat) {m k z : nat}
  : (k <= m) -> n + (m - k) = z -> n + m - k = z.
Proof.
  intro H.
  destruct (symmetric_paths _ _ (nataddsub_assoc n H)); done.
Defined.

#[export] Hint Resolve nataddsub_assoc_implication : nat.

Proposition nat_add_sub_eq (n : nat) {k: nat}
  : (k <= n) -> k + (n - k) = n.
Proof.
  intro H.
  destruct (symmetric_paths _ _ (nataddsub_assoc k H));
  destruct (nat_add_comm n k); exact (add_n_sub_n_eq _ _).
Defined.

#[export] Hint Resolve nat_add_sub_eq : nat.

Proposition predeqminus1 { n : nat } : n - 1 = pred n.
Proof.
  induction n.
  - reflexivity.
  - apply sub_n_0.
Defined.

Proposition predn_leq_n (n : nat) : pred n <= n.
Proof.
  case n; [ apply leq_n | intro; apply leq_S; apply leq_n].
Defined.

#[export] Hint Resolve predn_leq_n : nat.

Proposition S_predn (n i: nat) : (i < n) -> S(pred n) = n.
Proof.
  intros l.
  induction n.
  - contradiction (not_lt_n_0 i).
  - reflexivity.
Defined.

#[export] Hint Rewrite S_predn : nat.
#[export] Hint Rewrite <- pred_Sn : nat.

#[export] Hint Resolve S_predn : nat.
#[export] Hint Resolve leq_n_pred : nat.

Proposition pred_equiv (k n : nat) : k < n -> k < S (pred n).
Proof.
  intro ineq; destruct n.
  - contradiction (not_lt_n_0 _ _).
  - assumption.
Defined.

Proposition n_leq_pred_Sn (n : nat) : n <= S (pred n).
Proof.
  destruct n; auto.
Defined.

Proposition leq_implies_pred_lt (i n k : nat)
  : (n > i) -> n <= k -> pred n < k.
Proof.
  intro ineq; destruct n.
  - contradiction (not_lt_n_0 i).
  - intro; assumption.
Defined.

Proposition pred_lt_implies_leq (n k : nat)
  : pred n < k -> n <= k.
Proof.
  intro l; destruct n.
  - apply leq_0_n.
  - assumption.
Defined.

Proposition lt_implies_pred_geq (i j : nat) : i < j -> i <= pred j.
Proof.
  intro l; apply leq_n_pred in l; assumption.
Defined.

#[export] Hint Resolve lt_implies_pred_geq : nat.

Proposition j_geq_0_lt_implies_pred_geq (i j k : nat)
  : i < j -> k.+1 <= j -> k <= pred j.
Proof.
  intros l ineq.
  destruct j.
  - contradiction (not_lt_n_0 i).
  - now simpl; apply leq_S_n.
Defined.

#[export] Hint Resolve lt_implies_pred_geq : nat.

Proposition pred_gt_implies_lt (i j : nat)
  : i < pred j -> i.+1 < j.
Proof.
  intros ineq.
  assert (H := leq_S_n' _ _ ineq). assert (i < j) as X. {
    apply (@mixed_trans2 _ (pred j) _);
      [assumption  | apply predn_leq_n].
  }
  destruct (symmetric_paths _ _ (S_predn _ _ X)) in H.
  assumption.
Defined.

Proposition pred_preserves_lt {i n: nat} (p : i < n) m
  : (n < m) -> (pred n < pred m).
Proof.
  intro l.
  apply leq_S_n. destruct (symmetric_paths _ _ (S_predn n i _)).
  set (k :=  transitive_lt i n m p l).
  destruct (symmetric_paths _ _ (S_predn m i _)).
  assumption.
Defined.

Proposition natsubpreservesleq { n m k : nat }
  : n <= m -> n - k <= m - k.
Proof.
  induction k.
  - destruct (symmetric_paths _ _ (sub_n_0 n)),
      (symmetric_paths _ _ (sub_n_0 m)); done.
  - intro l. change (k.+1) with (1 + k).
    destruct (nat_add_comm k 1).
    destruct (symmetric_paths _ _ (subsubadd n k 1)).
    destruct (symmetric_paths _ _ (subsubadd m k 1)).
    destruct (symmetric_paths _ _ (@predeqminus1 (n -k))).
    destruct (symmetric_paths _ _ (@predeqminus1 (m -k))).
    apply leq_n_pred, IHk. exact l.
Defined.

#[export] Hint Resolve natsubpreservesleq : nat.

Proposition sub_less { n k : nat } : n - k <= n.
Proof.
  revert k.
  induction n.
  - intros; apply leq_0_n.
  - induction k.
    + apply leq_n.
    + simpl; apply (@leq_trans _ n _);
        [ apply IHn | apply leq_S, leq_n].
Defined.

#[export] Hint Resolve sub_less : nat.
#[export] Hint Resolve leq_S_n' : nat.

Proposition sub_less_strict { n k : nat }
  : 0 < n -> 0 < k -> n - k < n.
Proof.
  intros l l'.
  unfold "<".
  destruct k, n;
  try (contradiction (not_lt_n_0 _ _)).
  simpl; apply leq_S_n', sub_less.
Defined.

Proposition natpmswap1 (k m n : nat)
  : n <= k -> k < n + m -> k - n < m.
Proof.
  intros l q.
  assert (q' : k - n + n < m + n) by
    (destruct (symmetric_paths _ _ (natminuspluseq n k l));
     destruct (nat_add_comm n m);
     assumption).
  exact (nataddreflectslt q').
Defined.

#[export] Hint Resolve natpmswap1 : nat.

Proposition natpmswap2 (k m n : nat)
  : n <= k -> k - n <= m -> k <= n + m.
Proof.
  intros l q.
  apply (@nataddpreservesleq' (k - n) m n) in q.
  destruct (symmetric_paths _ _ (nataddsub_assoc n l)) in q.
  destruct (symmetric_paths _ _ (add_n_sub_n_eq' k n)) in q;
    assumption.
Defined.

#[export] Hint Resolve natpmswap2 : nat.

Proposition natpmswap3 (k m n : nat)
  : k <= n -> m <= n - k -> k + m <= n.
Proof.
  intros ineq qe.
  apply (@nataddpreservesleq' m (n - k) k) in qe.
  destruct (symmetric_paths _ _ (nataddsub_assoc k ineq)) in qe.
  destruct (symmetric_paths _ _ (add_n_sub_n_eq' n k)) in qe;
    assumption.
Defined.

#[export] Hint Resolve natpmswap3 : nat.

Proposition natpmswap4 (k m n : nat)
  : k - n < m -> k < n + m.
Proof.
  intro l; apply (@nataddpreserveslt (k - n) m n) in l.
  destruct (nat_add_comm m n).
  now apply (mixed_trans1 k (k - n + n) (m + n)
               (nat_sub_add_ineq _ _)).
Defined.

#[export] Hint Resolve natpmswap4 : nat.

Proposition n_leq_m_n_leq_plus_m_k (n m k : nat)
  : n <= m -> n <= m + k.
Proof.
  intro l; apply (leq_trans l); exact (n_leq_add_n_k m k).
Defined.

Proposition nat_add_bifunctor (n n' m m' : nat)
  : n <= m -> n' <= m' -> n + n' <= m + m'.
Proof.
  revert n' m m'; induction n.
  - intros n' m m' l l'. simpl.
    apply (leq_trans l'). exact (n_leq_add_n_k' m' m).
  - intros n' m; induction m.
    + intros. contradiction (not_leq_Sn_0 n).
    + intros m' l l'. apply leq_S_n in l. simpl.
      apply leq_S_n', IHn.
      * exact l.
      * exact l'.
Defined.

#[export] Hint Resolve nat_add_bifunctor : nat.
#[export] Hint Resolve nataddpreserveslt : nat.
#[export] Hint Resolve nataddpreservesleq' : nat.
#[export] Hint Resolve nataddpreserveslt' : nat.
#[export] Hint Resolve natineq0eq0 : nat.
#[export] Hint Resolve n_leq_add_n_k : nat.
#[export] Hint Resolve n_leq_m_n_leq_plus_m_k : nat.

#[export] Hint Immediate add_n_sub_n_eq : nat.
#[export] Hint Immediate add_n_sub_n_eq' : nat.

#[export] Hint Rewrite <- add_n_O : nat.
#[export] Hint Rewrite -> add_O_n : nat.
#[export] Hint Rewrite -> add_n_sub_n_eq : nat.
#[export] Hint Rewrite -> add_n_sub_n_eq' : nat.
#[export] Hint Rewrite -> nataddsub_assoc : nat.

Ltac autorewrite_or_fail := progress ltac:(autorewrite with nat).

#[export] Hint Extern 7 => autorewrite_or_fail : nat.

Proposition strong_induction (P : nat -> Type)
  : (forall n : nat, (forall m : nat,  (m < n) -> P m) -> P n) ->
  forall n : nat, P n.
Proof.
  intro a.
  assert (forall n m: nat, m < n -> P m) as X. {
    induction n.
    - intros m l. contradiction (not_lt_n_0 m).
    - intros m l. apply leq_S_n in l.
      destruct l as [ | n].
      + apply a; intros ? ?; now apply IHn.
      + now apply (IHn m), leq_S_n'.
  }
  intro n. apply (X (n.+1) n), (leq_n n.+1).
Defined.

(** This inductive type is defined because it lets you loop from [i = 0] up to [i = n] by structural induction on a proof of [increasing_geq n 0]. With the existing [leq] type and the inductive structure of [n], it is easier and more natural to loop downwards from [i = n] to [i = 0], but harder to find the least natural number in the interval $[0,n]$ satisfying a given property. *)

Local Unset Elimination Schemes.

Inductive increasing_geq (n : nat) : nat -> Type :=
| increasing_geq_n : increasing_geq n n
| increasing_geq_S (m : nat) : increasing_geq n m.+1 ->
                               increasing_geq n m.

Scheme increasing_geq_ind := Induction for increasing_geq Sort Type.
Scheme increasing_geq_rec := Minimality for increasing_geq Sort Type.
Definition increasing_geq_rect := increasing_geq_rec.

Local Set Elimination Schemes.

Proposition increasing_geq_S_n (n m : nat)
  : increasing_geq n m -> increasing_geq n.+1 m.+1.
Proof.
  intro a.
  induction a.
  - constructor.
  - now constructor.
Defined.

Proposition increasing_geq_n_0 (n :nat) : increasing_geq n 0.
Proof.
  induction n.
  - constructor.
  - induction IHn.
    + constructor; now constructor.
    + constructor; now assumption.
Defined.

Lemma increasing_geq_minus (n k : nat)
  : increasing_geq n (n - k).
Proof.
  induction k.
  - destruct (symmetric_paths _ _ (sub_n_0 n)); constructor.
  - destruct (@leq_dichot n k) as [l | g].
    + destruct (symmetric_paths _ _ (sub_leq_0 _ _ _)) in IHk.
      apply leq_S in l.
      destruct (symmetric_paths _ _ (sub_leq_0 _ _ _)). exact IHk.
    + change k.+1 with (1 + k). destruct (nat_add_comm k 1).
      destruct (symmetric_paths _ _ (subsubadd n k 1)).
      destruct (symmetric_paths _ _ (@predeqminus1 (n - k))).
      apply increasing_geq_S.
      unfold ">", "<" in *.
      apply lt_sub_gt_0 in g.
      now (destruct (symmetric_paths _ _ (S_predn (n - k) 0 _))).
Defined.

Lemma ineq_sub' (n k : nat) : k < n -> n - k = (n - k.+1).+1.
Proof.
  intro ineq.
  destruct n.
  - contradiction (not_lt_n_0 k).
  - change (n.+1 - k.+1) with (n - k). apply leq_S_n in ineq.
    apply (nataddsub_assoc_lemma _).
Defined.

Lemma ineq_sub (n m : nat) : n <= m -> m - (m - n) = n.
Proof.
  revert m; induction n.
  - intros. destruct (symmetric_paths _ _ (sub_n_0 m)),
      (symmetric_paths _ _ (sub_n_n m));
      reflexivity.
  - intros m ineq. change (m - n.+1) with (m - (1 + n)).
    (destruct (nat_add_comm n 1)).
    destruct (symmetric_paths _ _ (subsubadd m n 1)).
    destruct (S_predn (m - n) 0 (lt_sub_gt_0 _ _ ineq)); simpl;
      destruct (symmetric_paths _ _ (sub_n_0 (pred (m - n)))).
    assert (0 < m - n) as dp by exact (lt_sub_gt_0 _ _ ineq).
    assert (pred (m - n) < m) as sh by
        ( unfold "<";
          destruct (symmetric_paths _ _ (S_predn _ 0 _));
          exact sub_less).
    destruct (symmetric_paths _ _ (ineq_sub' _ _ _)).
    destruct (symmetric_paths _ _ (S_predn _ 0 _)).
    apply (ap S), IHn, leq_S', ineq.
Defined.

Proposition leq_equivalent (n m : nat)
  : n <= m <-> increasing_geq m n.
Proof.
  split.
  - intro ineq. induction ineq.
    + constructor.
    + apply increasing_geq_S_n in IHineq; constructor; assumption.
  - intro a.
    induction a.
    + constructor.
    + exact (leq_S' _ _ _).
Defined.

(** This tautology accepts a (potentially opaqued or QED'ed) proof of [n <= m], and returns a transparent proof which can be computed with (i.e., one can loop from n to m) *)
Definition leq_wrapper {n m : nat} : n <= m -> n <= m.
Proof.
  intro ineq.
  destruct (@leq_dichot n m) as [l | g].
  - exact l.
  - contradiction (not_lt_n_n m (@mixed_trans2 _ _ _ g ineq)).
Defined.

Proposition symmetric_rel_total_order (R : nat -> nat -> Type)
            {p : Symmetric R} {p' : Reflexive R}
  : (forall n m : nat, n < m -> R n m) -> (forall n m : nat, R n m).
Proof.
  intros A n m.
  destruct (@leq_dichot m n) as [m_leq_n | m_gt_n].
  - apply symmetry. destruct m_leq_n.
    + apply reflexivity.
    + apply A. apply leq_S_n'. assumption.
  - apply A, m_gt_n.
Defined.


Require Import Specification Setoid.

Definition fn { T V : Type } (P : T >> V) (Q : T >> V) : T >> V :=
  fun s s' => (exists s', P s s') /\ (exists s', Q s s') /\ (P s s' \/ Q s s').

Notation "P ⊔ Q" := (fn P Q) (at level 90, right associativity, format "P  ⊔  Q").

Theorem lext : forall T U (P P' Q : T >> U), (forall s s', P s s' <-> P' s s') -> forall s s', (P ⊔ Q) s s' <-> (P' ⊔ Q) s s'.
Proof. firstorder. Qed.

Theorem rext : forall T U (P Q Q' : T >> U), (forall s s', Q s s' <-> Q' s s') -> forall s s', (P ⊔ Q) s s' <-> (P ⊔ Q') s s'.
Proof. firstorder. Qed.

Theorem ext : forall T U (P P' Q Q' : T >> U),
    (forall s s', P s s' <-> P' s s') -> (forall s s', Q s s' <-> Q' s s') -> forall s s', (P ⊔ Q) s s' <-> (P' ⊔ Q') s s'.
Proof. firstorder. Qed.


Require Export ProjectiveGeometry.Dev.basic_matroid_list.

Parameter rk_singleton_ge : forall A, rk (A :: nil)  >= 1.
Parameter rk_couple_ge : forall A B, ~ A = B -> rk(A :: B :: nil) >= 2.
Parameter rk_three_points_on_lines : forall A B, exists C, rk (A :: B :: C :: nil) = 2 /\ rk (B :: C :: nil) = 2 /\ rk (A :: C :: nil) = 2.
Parameter rk_inter : forall A B C D, rk(A :: B :: C :: D :: nil) <= 3 -> exists J : Point, rk(A :: B :: J :: nil) = 2 /\ rk (C :: D :: J :: nil) = 2.
Parameter rk_lower_dim : exists A0 A1 A2 A3, rk( A0 :: A1 :: A2 :: A3 :: nil) = 4.
Parameter rk_upper_dim : forall e, rk(e) <= 4.

Lemma rk_singleton_1 : forall A, rk(A :: nil) <= 1.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_singleton : forall A, rk(A :: nil) = 1.
Proof.
intros.
assert(H := rk_singleton_ge A).
assert(HH := rk_singleton_1 A).
omega.
Qed.

Lemma matroid1_b_useful2 : forall (l : list Point) (a : Point), length (a :: l) >= 1 -> rk (a :: l) >= 1.
Proof.
intros.
assert(HH := rk_singleton a).
assert(HH0 := matroid2 (a :: nil) (a :: l)).
assert(HH1 : incl (a :: nil) (a :: l));[my_inO|].
assert(HH2 := HH0 HH1).
omega.
Qed.

Lemma rk_couple_2 : forall A B, rk(A :: B :: nil) <= 2.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_couple : forall A B : Point,~ A = B -> rk(A :: B :: nil) = 2.
Proof.
intros.
assert(HH := rk_couple_2 A B).
assert(HH0 := rk_couple_ge A B H).
omega.
Qed.

Lemma rk_triple_3 : forall A B C : Point, rk (A :: B :: C :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma couple_rk1 : forall A B, rk(A :: B :: nil) = 2 -> ~ A = B.
Proof.
intros.
intro.
rewrite H0 in H.
assert(HH : equivlist (B :: B :: nil) (B :: nil));[my_inO|].
rewrite HH in H.
assert(HH0 := rk_singleton_1 B).
omega.
Qed.

Lemma couple_rk2 : forall A B, rk(A :: B :: nil) = 1 -> A = B.
Proof.
intros.
case_eq(eq_dec A B).
intros.
assumption.
intros.
assert(HH := rk_couple A B n).
omega.
Qed.

Lemma rule_1 : forall A B AiB, forall MA MB mAiB,
rk(A) <= MA -> rk(B) <= MB -> rk(AiB) >= mAiB -> incl AiB (list_inter A B) ->
rk(A ++ B) <= MA + MB - mAiB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
omega.
Qed.

Lemma rule_2 : forall A B AiB, forall mAuB mAiB MB,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(B) <= MB -> incl AiB (list_inter A B) ->
rk(A) >= mAuB + mAiB - MB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
omega.
Qed.

Lemma rule_3 : forall A B AiB, forall MA MB mAuB,
rk(A) <= MA -> rk(B) <= MB -> rk(A ++ B) >= mAuB -> incl AiB (list_inter A B) ->
rk(AiB) <= MA + MB - mAuB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
omega.
Qed.

Lemma rule_4 : forall A B AiB, forall mAuB mAiB MA,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(A) <= MA -> incl AiB (list_inter A B) ->
rk(B) >= mAuB + mAiB - MA.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
omega.
Qed.

Lemma rule_5 : forall A B, forall mA mB,
rk(A) >= mA -> mA >= mB -> incl A B ->
rk(B) >= mA.
Proof.
intros.
assert(HH := matroid2 A B H1).
omega.
Qed.

Lemma rule_6 : forall A B, forall MA MB,
rk(B) <= MB -> MB <= MA -> incl A B ->
rk(A) <= MB.
Proof.
intros.
assert(HH := matroid2 A B H1).
omega.
Qed.

Lemma rule_7 : forall A B, forall mA mB,
rk(B) >= mB -> mB >= mA -> incl B A ->
rk(A) >= mB.
Proof.
intros.
assert(HH := matroid2 B A H1).
omega.
Qed.

Lemma rule_8 : forall A B, forall MA MB,
rk(A) <= MA -> MA <= MB -> incl B A ->
rk(B) <= MA.
Proof.
intros.
assert(HH := matroid2 B A H1).
omega.
Qed.

Parameter rk_pappus : forall A B C D E F G H I,
rk(A :: B :: nil) = 2 -> rk(A :: C :: nil) = 2 -> rk(A :: D :: nil) = 2 ->
rk(A :: E :: nil) = 2 -> rk(A :: F :: nil) = 2 ->
rk(B :: C :: nil) = 2 -> rk(B :: D :: nil) = 2 -> rk(B :: E :: nil) = 2 ->
rk(B :: F :: nil) = 2 ->
rk(C :: D :: nil) = 2 -> rk(C :: E :: nil) = 2 -> rk(C :: F :: nil) = 2 ->
rk(D :: E :: nil) = 2 -> rk(D :: F :: nil) = 2 ->
rk(E :: F :: nil) = 2 ->
rk(A :: B :: C :: nil) = 2 -> rk(D :: E :: F :: nil) = 2 ->
rk(A :: E :: G :: nil) = 2 -> rk(B :: D :: G :: nil) = 2 ->
rk(A :: F :: H :: nil) = 2 -> rk(C :: D :: H :: nil) = 2 ->
rk(B :: F :: I :: nil) = 2 -> rk(C :: E :: I :: nil) = 2 -> rk(G :: H :: I :: nil) = 2.

Ltac rk_couple_triple :=
  match goal with

| H : rk(?A :: ?B :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => assumption
| H : rk(?B :: ?A :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => rewrite couple_equal in H;assumption

| H : rk(?A :: ?B :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => assumption
| H : rk(?A :: ?C :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_1 in H;assumption
| H : rk(?B :: ?A :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_2 in H;assumption
| H : rk(?B :: ?C :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_3 in H;assumption
| H : rk(?C :: ?A :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_4 in H;assumption
| H : rk(?C :: ?B :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_5 in H;assumption
end.


Require Export prosa.model.priority.classes.
Require Export prosa.analysis.facts.behavior.completion.

(** Throughout this file, we assume ideal uniprocessor schedules. *)
Require Import prosa.model.processor.ideal.

(** * Busy Interval for JLFP-models *)
(** In this file we define the notion of busy intervals for uniprocessor for JLFP schedulers. *)
Section BusyIntervalJLFP.

  (** Consider any type of jobs. *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** Next, consider any ideal uniprocessor schedule of this arrival sequence. *)
  Variable sched : schedule (ideal.processor_state Job).

  (** Assume a given JLFP policy. *)
  Context `{JLFP_policy Job}.

  (** In this section, we define the notion of a busy interval. *)
  Section BusyInterval.

    (** Consider any job j. *)
    Variable j : Job.
    Hypothesis H_from_arrival_sequence : arrives_in arr_seq j.

    (** We say that t is a quiet time for j iff every higher-priority job from
         the arrival sequence that arrived before t has completed by that time. *)
    Definition quiet_time (t : instant) :=
      forall (j_hp : Job),
        arrives_in arr_seq j_hp ->
        hep_job j_hp j ->
        arrived_before j_hp t ->
        completed_by sched j_hp t.

    (** Based on the definition of quiet time, we say that interval
         <<[t1, t_busy)>> is a (potentially unbounded) busy-interval prefix
         iff the interval starts with a quiet time where a higher or equal
         priority job is released and remains non-quiet. We also require
         job j to be released in the interval. *)
    Definition busy_interval_prefix (t1 t_busy : instant) :=
      t1 < t_busy /\
      quiet_time t1 /\
      (forall t, t1 < t < t_busy -> ~ quiet_time t) /\
      t1 <= job_arrival j < t_busy.

    (** Next, we say that an interval <<[t1, t2)>> is a busy interval iff
         [t1, t2) is a busy-interval prefix and t2 is a quiet time. *)
    Definition busy_interval (t1 t2 : instant) :=
      busy_interval_prefix t1 t2 /\
      quiet_time t2.

  End BusyInterval.

  (** In this section we define the computational
      version of the notion of quiet time. *)
  Section DecidableQuietTime.

    (** We say that t is a quiet time for j iff every higher-priority job from
        the arrival sequence that arrived before t has completed by that time. *)
    Definition quiet_time_dec (j : Job) (t : instant) :=
      all
        (fun j_hp => hep_job j_hp j ==> (completed_by sched j_hp t))
        (arrivals_before arr_seq t).

    (** We also show that the computational and propositional definitions are equivalent. *)
    Lemma quiet_time_P :
      forall j t, reflect (quiet_time j t) (quiet_time_dec j t).
    Proof.
      intros; apply/introP.
      - intros QT s ARRs HPs BEFs.
        move: QT => /allP QT.
        specialize (QT s); feed QT.
        eapply arrived_between_implies_in_arrivals; eauto 2.
          by move: QT => /implyP Q; apply Q in HPs.
      - move => /negP DEC; intros QT; apply: DEC.
        apply/allP; intros s ARRs.
        apply/implyP; intros HPs.
        apply QT; try done.
        + by apply in_arrivals_implies_arrived in ARRs.
        + by eapply in_arrivals_implies_arrived_between in ARRs; eauto 2.
    Qed.

  End DecidableQuietTime.

End BusyIntervalJLFP.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.omega.Omega
        Bedrock.Word.

Section Nat.
  Variable sz : nat.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Definition format_nat (n : nat) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    format_word (natToWord sz n) ce.

  Definition encode_nat (n : nat) (ce : CacheFormat) : B * CacheFormat :=
    encode_word (natToWord sz n) ce.

  Lemma refine_format_nat :
    forall n ce,
      refine (format_nat n ce) (ret (encode_nat n ce)).
  Proof.
    reflexivity.
  Qed.

  Definition decode_nat (b : B) (cd : CacheDecode) : option (nat * B * CacheDecode) :=
    `(w, b, cd) <- decode_word (sz:=sz) b cd;
      Some (wordToNat w, b, cd).

  Local Open Scope nat.
  Theorem Nat_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    : CorrectDecoder monoid (fun n => n < pow2 sz)
                              (fun _ _ => True) format_nat decode_nat P.
  Proof.
    unfold CorrectDecoder, format_nat, decode_nat.
    split.
    { intros env xenv xenv' n n' ext ? Eeq Ppred Ppred_rest Penc.
      destruct (proj1 (Word_decode_correct P_OK) _ _ _ _ _ ext env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      - rewrite H; simpl; eexists; intuition eauto.
        repeat f_equal.
        destruct (wordToNat_natToWord' sz n).
        assert (x0 = 0).
        { destruct x0; eauto.
          rewrite <- H1 in Ppred. exfalso. simpl in Ppred.
          clear - Ppred.
          replace (wordToNat (natToWord sz n) + (pow2 sz + x0 * pow2 sz)) with
          (pow2 sz + (wordToNat (natToWord sz n) + x0 * pow2 sz)) in Ppred by omega.
          remember (wordToNat (natToWord sz n) + x0 * pow2 sz) as n'; clear Heqn'.
          omega. }
        rewrite H2 in H1. simpl in H1. rewrite <- plus_n_O in H1. eauto.
        }
    { intros env xenv xenv' n n' ext Eeq OK_env Penc.
      destruct (decode_word n' xenv) as [ [ [? ? ] ? ] | ] eqn: ? ;
        simpl in *; try discriminate.
      injections.
      eapply (proj2 (Word_decode_correct P_OK)) in Heqo;
        destruct Heqo; destruct_ex; intuition; subst; eauto.
      unfold format_word in *; computes_to_inv; injections.
      eauto.
      rewrite natToWord_wordToNat; repeat eexists; eauto.
      apply wordToNat_bound.
    }
  Qed.
End Nat.