Require Import Quote List Ergo Term TermUtils.
Require Import Containers.OrderedType Nfix.Nfix.

Generalizable All Variables.

Definition typeZ := typeArith DomainZ.
Definition tplus t u :=
  app (Op DomainZ Plus) (tcons t (tcons u tnil)).
Definition tmult t u :=
  app (Op DomainZ Mult) (tcons t (tcons u tnil)).
Definition tminus t u :=
  app (Op DomainZ Minus) (tcons t (tcons u tnil)).
Definition topp t :=
  app (Op DomainZ Opp) (tcons t tnil).
Definition tdiv t u :=
  app (Op DomainZ Div) (tcons t (tcons u tnil)).

Notation "t [+] u" := (tplus t u)(at level 24).
Notation "t [-] u" := (tminus t u)(at level 23).
Notation "t [*] u" := (tmult t u)(at level 22).
Notation "t [/] u" := (tdiv t u)(at level 21).
Notation "[ z ]" := (app (Cst DomainZ (z%Z)) tnil).

Inductive ZRing : term -> term -> Prop :=
| ZRing_add_0_l :
  forall u, ZRing u ([0] [+] u) (* wt *)
| ZRing_add_comm :
  forall u v, ZRing (u [+] v) (v [+] u)
| ZRing_add_assoc :
  forall u v w, ZRing (u [+] (v [+] w)) ((u [+] v) [+] w)
| ZRing_mul_1_l :
  forall u, ZRing u ([1] [*] u) (* wt *)
| ZRing_mul_comm :
  forall u v, ZRing (u [*] v) (v [*] u)
| ZRing_mul_assoc :
  forall u v w, ZRing (u [*] (v [*] w)) ((u [*] v) [*] w)
| ZRing_distr_l :
  forall u v w, ZRing ((u [+] v) [*] w) ((u [*] w) [+] (v [*] w))
| ZRing_sub_def :
  forall u v, ZRing (u [-] v) (u [+] (topp v))
| ZRing_opp_def :
  forall u, ZRing [0] (u [+] topp u) (* wt *)
    (* a bit more than a ring, we add a thing about euclidean division
       in order to obtain that it is also an integral ring. It is an
       intricate way to state that but the other intuitive ways raise issues :
       - u * v = 0 -> u = 0 \/ v = 0 ends up in a disjunction which is no good
       - k * u = k * v -> u * v requires ZRing to be mutually inductive
       with mext
       *)
| ZRing_div_cancel :
  forall k u, k =/= 0%Z -> ZRing u (([k] [*] u) [/] [k]).  (* wt *)

(* (* I-substitutions *) *)
(* Definition isubst := list (term * term). *)
(* Fixpoint assoc (t : term) (s : isubst) := *)
(*   match s with *)
(*     | nil => None *)
(*     | (p, P)::q =>  *)
(*       if p == t then Some P else assoc t q *)
(*   end. *)

(* Nested Fixpoint subst (t : term) (s : isubst) : term := *)
(*   match assoc t s with *)
(*     | Some P => P *)
(*     | None => *)
(*       match t with *)
(*         | app f l => app f (subst_terms l s) *)
(*       end *)
(*   end *)
(* with subst_terms (lt : terms) (s : isubst) : terms := *)
(*   match lt with *)
(*     | nil => nil *)
(*     | cons t q => (subst t s)::(subst_terms q s) *)
(*   end. *)

(* Property subst_1 : forall t, subst t nil = t. *)
(* Proof. *)
(*   induction t using term_terms_rect_default; simpl. *)
(*   f_equal; induction lt; simpl; auto. *)
(*   rewrite IHlt, H; intuition. *)
(* Qed. *)
(* Property subst_2 : forall s t p, assoc t s = Some p -> subst t s = p.  *)
(* Proof. *)
(*   intros; destruct t; simpl. *)
(*   rewrite H; reflexivity. *)
(* Qed. *)
(* Definition none_integer (s : isubst) (M : varmaps) := *)
(*   forall p, In p s ->  *)
(*     ~ well_typed (varmaps_vty M) (varmaps_vsy M) (fst p) typeZ. *)

(* Property assoc_in_1 :   *)
(*   forall s t P, assoc t s = Some P -> In (t, P) s. *)
(* Proof. *)
(*   induction s; intros; simpl in *. *)
(*   discriminate. *)
(*   destruct a as [p P']; destruct (eq_dec p t); [left | right]. *)
(*   inversion H; subst; rewrite H0; reflexivity. *)
(*   intuition. *)
(* Qed. *)

(* (* Property wt_subst_1 :  *) *)
(* (*   forall M t s,  *) *)
(* (*     all_ill_typed s M -> *) *)
(* (*     has_type (varmaps_vty M) (varmaps_vsy M) t  *) *)
(* (*     (type_of (varmaps_vty M) (varmaps_vsy M) t) = true -> *) *)
(* (*     subst t s = t. *) *)
(* (* Proof. *) *)
(* (*   intro M; induction t using term_terms_rect_default; intros. *) *)
(* (*   simpl; destruct (assoc (app f lt) s) as [ ]_eqn:Hassoc. *) *)
(* (*   assert (R := H0 (app f lt, t) (assoc_in_1 _ _ _ Hassoc)). *) *)
(* (*   simpl fst in R; congruence. *) *)
(* (*   f_equal; clear Hassoc. *) *)
(* (*   apply has_type_1 in H1. *) *)
(* (*   inversion_clear H1; revert H2. *) *)
(* (*   generalize (type_of (varmaps_vty M) (varmaps_vsy M) (app f lt));  *) *)
(* (*     generalize (lookup_type (varmaps_vty M) (varmaps_vsy M) f); intros. *) *)
(* (*   revert t t0 H2; induction lt; intros; simpl. *) *)
(* (*   reflexivity. *) *)
(* (*   inversion_clear H2; f_equal. *) *)
(* (*   apply H; intuition. apply has_type_2 in H3. *) *)
(* (*   rewrite <- (has_type_is_type_of _ _ _ _ H3); exact H3. *) *)
(* (*   apply IHlt with t3 t0; intuition. *) *)
(* (* Qed. *) *)

(* Definition is_integer M t := *)
(*   well_typed (varmaps_vty M) (varmaps_vsy M) t typeZ. *)
(* Property is_integer_cst : forall M k, is_integer M [k]. *)
(* Proof. *)
(*   constructor; simpl; constructor. *)
(* Qed. *)
(* Property is_integer_tplus : forall M t u,  *)
(*   is_integer M t -> is_integer M u -> is_integer M (t [+] u). *)
(* Proof. *)
(*   intros; constructor; simpl; repeat constructor; assumption. *)
(* Qed. *)
(* Property is_integer_tminus : forall M t u,  *)
(*   is_integer M t -> is_integer M u -> is_integer M (t [-] u). *)
(* Proof. *)
(*   intros; constructor; simpl; repeat constructor; assumption. *)
(* Qed. *)
(* Property is_integer_tmult : forall M t u,  *)
(*   is_integer M t -> is_integer M u -> is_integer M (t [*] u). *)
(* Proof. *)
(*   intros; constructor; simpl; repeat constructor; assumption. *)
(* Qed. *)
(* Property is_integer_topp : forall M t,  *)
(*   is_integer M t -> is_integer M (topp t). *)
(* Proof. *)
(*   intros; constructor; simpl; repeat constructor; assumption. *)
(* Qed. *)
(* Ltac is_integer := *)
(*   auto using is_integer_cst, is_integer_tplus, is_integer_tminus, *)
(*     is_integer_tmult, is_integer_topp. *)
(* Ltac case_integer M t := *)
(*   destruct (well_typed_dec (varmaps_vty M) (varmaps_vsy M) t typeZ). *)

(* Inductive subst_bad_eqn (M : varmaps) (t u : term) : Prop := *)
(* | subst_bad_eqn_intro : *)
(*   forall (s : isubst) (Hills : none_integer s M) *)
(*     (Hwt_t : is_integer M (subst t s)) (Hwt_u : is_integer M (subst u s)), *)
(*     ZRing (subst t s) (subst u s) -> subst_bad_eqn M t u. *)

(* Remark subst_bad_eqn_wt :  *)
(*   forall M t u, ZRing t u ->  *)
(*     is_integer M t -> is_integer M u -> subst_bad_eqn M t u. *)
(* Proof. *)
(*   intros; exists nil; auto. *)
(*   intros ? p; inversion p. *)
(*   rewrite subst_1; assumption. *)
(*   rewrite subst_1; assumption. *)
(*   rewrite 2subst_1; assumption. *)
(* Qed. *)
Hint Constructors ZRing.

Lemma is_eq_refl `{OrderedType A} : forall (x : A), x == x = true.
Proof.
  intros; destruct (eq_dec x x); auto; false_order.
Qed.
Lemma is_eq_sym `{OrderedType A} : forall (x y : A), (x == y) = (y == x).
Proof.
  intros; destruct (eq_dec x y); destruct (eq_dec y x); auto; false_order.
Qed.

(* Theorem rewrite_ZRing_wt :  *)
(*   forall M t u, ZRing t u -> subst_bad_eqn M t u. *)
(* Proof. *)
(*   intros M t u H; destruct H. *)
(*   (* - 1 *) *)
(*   case_integer M u. *)
(*   apply subst_bad_eqn_wt; auto. *)
(*   is_integer. *)
(*   pose (s := (u, [1])::nil). *)
(*   assert (Hu : subst u s = [1]). *)
(*   apply subst_2; simpl; rewrite is_eq_refl; reflexivity. *)
(*   assert (Hu0 : subst (u[+][0]) s = [1][+][0]). *)
(*   simpl; fold (u [+] [0]). *)
(*   destruct (eq_dec u (u [+] [0])). *)
(*   admit. (* occur check *) *)
(*   rewrite Hu; destruct (eq_dec u [0]). *)
(*   contradiction n; rewrite H0; apply has_type_1; reflexivity. *)
(*   reflexivity. *)
(*   exists s. *)
(*   repeat intro. inversion H; [|contradiction]. *)
(*   subst; simpl in H0; auto. *)
(*   rewrite Hu0; is_integer. rewrite Hu; is_integer. *)
(*   rewrite Hu0, Hu; auto. *)
(*   (* - 2 *) *)
(*   admit. *)
(*   (* - 3 *) *)
(*   admit. *)
(*   (* - 4 *) *)
(*   case_integer M u. *)
(*   apply subst_bad_eqn_wt; auto. *)
(*   is_integer. *)
(*   pose (s := (u, [1])::nil). *)
(*   assert (Hu : subst u s = [1]). *)
(*   apply subst_2; simpl; rewrite is_eq_refl; reflexivity. *)
(*   assert (H1u : subst ([1][*]u) s = [1][*][1]). *)
(*   simpl; fold ([1][*]u). *)
(*   destruct (eq_dec u ([1][*]u)). *)
(*   admit.  (* occur check *) *)
(*   rewrite Hu; destruct (eq_dec u [1]). *)
(*   contradiction n; rewrite H0; apply has_type_1; reflexivity. *)
(*   reflexivity. *)
(*   exists s. *)
(*   repeat intro. inversion H; [|contradiction]. *)
(*   subst; simpl in H0; auto. *)
(*   rewrite H1u; is_integer. rewrite Hu; is_integer. *)
(*   rewrite H1u, Hu; auto. *)
(*   (* - 5 *) *)
(*   admit. *)
(*   (* - 6 *) *)
(*   admit. *)
(*   (* - 7 *) *)
(*   admit. *)
(*   (* - 8 *) *)
(*   admit. *)
(*   (* - 9 *) *)
(*   case_integer M u. *)
(*   apply subst_bad_eqn_wt; auto. *)
(*   is_integer. is_integer. *)
(*   pose (s := (u, [1])::nil). *)
(*   assert (Hu : subst u s = [1]). *)
(*   apply subst_2; simpl; rewrite is_eq_refl; reflexivity. *)
(*   assert (Huu : subst (u[+]topp u) s = [1][+]topp [1]). *)
(*   simpl; fold (u [+] topp u). *)
(*   destruct (eq_dec u (u [+] topp u)). *)
(*   admit.  (* occur check *) *)
(*   fold (topp u); rewrite Hu; destruct (eq_dec u (topp u)). *)
(*   admit.  (* occur check *) *)
(*   reflexivity. *)
(*   assert (H0 : subst [0] s = [0]). *)
(*   simpl; destruct (eq_dec u [0]); auto. *)
(*   contradiction n; rewrite H; apply has_type_1; reflexivity. *)
(*   exists s. *)
(*   repeat intro. inversion H; [|contradiction]. *)
(*   subst; simpl in H0; auto. *)
(*   rewrite Huu; is_integer. rewrite H0; is_integer. *)
(*   rewrite Huu, H0; auto. *)
(* Qed. *)

(** Properties of [ZRing] with respect to typing *)
Notation "'type' 'of' t 'in' M" :=
  (type_of (varmaps_vty M) (varmaps_vsy M) t) (at level 1).
Notation "'wt' t 'in' M" :=
  (has_type (varmaps_vty M) (varmaps_vsy M) t
    (type of t in M))(at level 1, t at level 200).
Ltac ite H :=
  match goal with
    | H : (if ?E then ?C else false) = true |- _ =>
      let Hif := fresh "if" in
        destruct E as [ ]_eqn:Hif; try discriminate H
  end.
Ltac find_type :=
  match goal with
    | H : has_type ?vty ?vsy ?t ?ty = true |- _ =>
      rewrite (has_type_is_type_of vty vsy t ty H) in *
    | _ => idtac "Nothing to do."
  end.

Property ZRing_well_type_1 :
  forall M u v, wt u in M = true -> wt v in M = true ->
    ZRing u v -> type of u in M = typeArith DomainZ.
Proof.
  intros M u v wfu wfv H; destruct H; simpl in *; try reflexivity.
  ite wfu; find_type; reflexivity.
  ite wfu; find_type; reflexivity.
  do 2 ite wfu; find_type; reflexivity.
Qed.
Property ZRing_well_type_2 :
  forall M u v, wt u in M = true -> wt v in M = true ->
    ZRing u v -> type of v in M = typeArith DomainZ.
Proof.
  intros M u v wfu wfv H; destruct H; simpl in *; reflexivity.
Qed.
Corollary ZRing_well_type_eq :
  forall M u v, wt u in M = true -> wt v in M = true ->
    ZRing u v -> type of u in M = type of v in M.
Proof.
  intros; rewrite
    (ZRing_well_type_1 M u v H H0 H1), (ZRing_well_type_2 M u v H H0 H1).
  reflexivity.
Qed.

Module GenericCongrClosure.
Section WithRelation.
  Variable R : term -> term -> Prop.

  Inductive mext : term -> term -> Prop :=
  | mext_rule : forall t u, R t u -> mext t u
  | mext_refl :
    forall t, mext t t
  | mext_sym :
    forall t u, mext u t -> mext t u
  | mext_trans :
    forall t v u, mext t v -> mext v u -> mext t u
  | mext_congr :
    forall f lt lu, mext_terms lt lu -> mext (app f lt) (app f lu)
  with mext_terms : terms -> terms -> Prop :=
  | mext_nil :
    mext_terms nil nil
  | mext_cons :
    forall t u lt lu,
      mext t u -> mext_terms lt lu -> mext_terms (t::lt) (u::lu).
  Generate Scheme mext.

  Fixpoint forall2 {A B : Type} (f : A -> B -> Prop)
    (la : list A) (lb : list B) :=
    match la, lb with
      | nil, nil => True
      | a::qa, b::qb => f a b /\ forall2 f qa qb
      | _, _ => False
    end.
  Fixpoint forall3 {A B C : Type} (f : A -> B -> C -> Prop)
    (la : list A) (lb : list B) (lc : list C) :=
    match la, lb, lc with
      | nil, nil, nil => True
      | a::qa, b::qb, c::qc => f a b c /\ forall3 f qa qb qc
      | _, _, _ => False
    end.

  Definition Congruence (C : term -> term -> Prop) :=
    forall f lt lu, forall2 C lt lu -> C (app f lt) (app f lu).

  (** Since [mext] is the reflexive, symmetric, transitive and congruent
     closure of [R], it is contained in any congruence relation extending [R].
     *)
  Section Closure.
    Variable C : term -> term -> Prop.
    Variable C_refl : Reflexive C.
    Variable C_sym : Symmetric C.
    Variable C_trans : Transitive C.
    Variable C_congr : Congruence C.
    Variable C_R : forall t u, R t u -> C t u.

    Theorem smallest_closure : forall t u, mext t u -> C t u.
    Proof.
      intros; induction H using mext_mutual_ind with
        (P := fun t u H => C t u)
        (P0 := fun lt lu H => forall2 C lt lu); simpl; eauto.
    Qed.
  End Closure.

  Definition path := list nat.
  Inductive rel_at : path -> term -> term -> Prop :=
  | rel_at_here : forall t u, R t u -> rel_at nil t u
  | rel_at_next : forall n p f lt lu, rel_at_terms n p lt lu ->
    rel_at (n::p) (app f lt) (app f lu)
  with rel_at_terms : nat -> path -> terms -> terms -> Prop :=
  | rel_at_terms_0 : forall p t u l,
    rel_at p t u -> rel_at_terms O p (t::l) (u::l)
  | rel_at_terms_S : forall n p t lt lu,
    rel_at_terms n p lt lu -> rel_at_terms (S n) p (t::lt) (t::lu).
  Generate Scheme rel_at.

  Inductive rel_chain : list path -> term -> term -> Prop :=
  | rel_chain_nil : forall t, rel_chain nil t t
  | rel_chain_cons :
    forall t v u p lp, rel_at p t v -> rel_chain lp v u ->
      rel_chain (p::lp) t u.
  Definition linked (t u : term) :=
    exists lp : list path, rel_chain lp t u.

  (** Alternative constructors for [rel_chain] *)
  Lemma rel_chain_app : forall t v u lp lp',
    rel_chain lp t v -> rel_chain lp' v u -> rel_chain (lp ++ lp') t u.
  Proof.
    intros t v u lp; revert t v u; induction lp; intros; simpl.
    inversion_clear H; auto.
    inversion_clear H.
    constructor 2 with v0; auto; apply IHlp with v; assumption.
  Qed.
  Lemma rel_chain_singl : forall t v p,
    rel_at p t v -> rel_chain (p::nil) t v.
  Proof.
    intros; constructor 2 with v; auto; constructor.
  Qed.

  (** [linked] is a congruence relation *)
  Property linked_refl : Reflexive linked.
  Proof.
    intro t; exists nil; constructor.
  Qed.
  Variable R_sym : Symmetric R.
  Property linked_sym : Symmetric linked.
  Proof.
    intros t u [lp H]; exists (rev lp); induction H.
    constructor.
    apply rel_chain_app with v; auto.
    apply rel_chain_singl.
    Lemma rel_at_sym : forall t u p, rel_at p t u -> rel_at p u t.
    Proof.
      intros.
      induction H using rel_at_mutual_ind with
        (P := fun p t u H => rel_at p u t)
        (P0 := fun n p lt lu H => rel_at_terms n p lu lt);
        constructor; auto.
    Qed.
    apply rel_at_sym; assumption.
  Qed.
  Property linked_trans : Transitive linked.
  Proof.
    intros t v u [lp H] [lp' H'];
      exists (lp ++ lp'); apply rel_chain_app with v; auto.
  Qed.

  Fixpoint plunge_and_flatten (n : nat) (ll : list (list path)) : list path :=
    match ll with
      | nil => nil
      | l::qq => (map (cons n) l) ++ (plunge_and_flatten (S n) qq)
    end.
  Property linked_congr : Congruence linked.
  Proof.
    intros f lt lu H.
    Lemma collect_paths : forall lt lu, forall2 linked lt lu ->
      exists ll, forall3 rel_chain ll lt lu.
    Proof.
      intro lt; induction lt; intros;
        destruct lu; simpl in *; try contradiction H.
      exists nil; exact I.
      destruct H as [Ha Hl]; assert (IH := IHlt lu Hl); clear IHlt Hl.
      destruct Ha as [pa Hla]; destruct IH as [ll Hll].
      exists (pa :: ll); simpl; tauto.
    Qed.
    generalize (collect_paths lt lu H); clear H; intros [ll Hll].
    exists (plunge_and_flatten O ll).
    Lemma plunge_rel_chain :
      forall f lp t u pre post, rel_chain lp t u ->
        rel_chain (map (cons (List.length pre)) lp)
        (app f (pre ++ (t :: post))) (app f (pre ++ (u :: post))).
    Proof.
      intro f; induction lp as [|p lp]; intros; simpl.
      inversion_clear H; constructor.
      inversion_clear H.
      assert (IH := IHlp v u pre post H1); clear IHlp.
      constructor 2 with (app f (pre ++ tcons v post)).
      clear IH H1.
      Lemma rel_at_terms_pre :
        forall pre p t u post, rel_at p t u ->
          rel_at_terms (length pre) p
          (pre ++ (t :: post)) (pre ++ (u :: post)).
      Proof.
        induction pre; intros; simpl in *; constructor; auto.
      Qed.
      constructor 2; apply rel_at_terms_pre; assumption.
      assumption.
    Qed.
      Lemma app_rev_fold : forall {A} (l l' : list A) (a : A),
        l ++ (a :: l') = (l ++ (a ::nil)) ++ l'.
      Proof.
        induction l; intros; simpl in *; auto.
        assert (IH := IHl l' a0); rewrite IH; auto.
      Qed.
    Lemma plunge_and_flatten_linked : forall f ll n pre lt lu,
      forall3 rel_chain ll lt lu -> n = List.length pre ->
      rel_chain (plunge_and_flatten n ll)
      (app f (pre ++ lt)) (app f (pre ++ lu)).
    Proof.
      intros f; induction ll as [|lp ll]; intros;
        destruct lt as [|t lt]; destruct lu as [|u lu];
          simpl in *; try contradiction; subst.
      constructor.
      destruct H; apply rel_chain_app with (app f (pre ++ (tcons u lt))).
      apply plunge_rel_chain; assumption.
      rewrite (app_rev_fold pre lt u), (app_rev_fold pre lu u).
      apply IHll; auto.
      rewrite app_length; simpl; omega.
    Qed.
    exact (plunge_and_flatten_linked f ll O nil lt lu
      Hll (refl_equal O)).
  Qed.

  (** We can then prove tha [linked] and [mext] are the same relations.
     The first inclusion is proven by a simple induction, the reverse
     inclusion is given by [smallest_closure] and the fact that [linked]
     is a congruence relation. *)
  Theorem mext_iff : forall t u, linked t u <-> mext t u.
  Proof.
    intros; split; intro H.
    destruct H as [lp Hlp].
    induction Hlp.
      apply mext_refl.
      apply mext_trans with v; auto.
      clear lp Hlp IHHlp u.
      induction H using rel_at_mutual_ind with
        (P := fun p t v H => mext t v)
        (P0 := fun n p lt lv H => mext_terms lt lv) (p := p).
      constructor; assumption.
      constructor; assumption.
      constructor; auto. clear; induction l; constructor; auto using mext_refl.
      constructor; auto; apply mext_refl.
    refine (smallest_closure _
      linked_refl linked_sym linked_trans linked_congr _ t u H).
    intros; exists (nil :: nil).
    constructor 2 with u0; constructor; assumption.
  Qed.

  (** So now we have an alternative, equivalent, characterization of the
     refl-sym-trans+congr closure performed by [mext], in the sense of a
     chain of atomic rewritings. *)
End WithRelation.
End GenericCongrClosure.

(** Preuve papier du dernier théoreme (pas celui de Fermat) :

   Supposons une relation R entre termes, et on s'intéresse à la congruence
   définie par [mext] sur (R + l'égalité via interprétation pour les
   termes bien typés notée ~), ou de manière équivalente à [linked] sur
   cette même relation. On note ça a <->* b. On veut prouver que si a
   et b sont bien typés, a <->* b implique a ~ b, ie. que leurs
   interpretations sont égales, sous certaines conditions sur R.

   Supposons que sur les termes bien typés, R est incluse dans ~.
   Supposons existe un canonizer K : term -> term, tel que pour tous termes
   u et v, u <->*_R v (ie. n'utilisant que des égalités de R) est équivalent
   à K u = K v.
   Supposons aussi que pour tout u, u <->*_R K u.
   Supposons enfin que K préserve le caractère bien typé, et que
   pour tout u v bien typés, u ~ v -> K u ~ K v.

   Lemma 1 : K est idempotent.
   Proof.
     Soit u, par définition du canonizer, il suffit de noter que
     K u <->*_R u, ce qui donne K (K u) = K u.
   Qed.
   Lemma 1' : K(f(u1,....un)) = K(f(K u1, .... K un)).
   Proof.
     ...
   Qed.
   Lemma 2 : Soit u bien typé, alors u ~ K u.
   Proof.
     Par induction sur la structure du terme u, en regardant ce que
     fait K au cas par cas.
   Qed.

   Lemma 3 : Soit u et v tel que u ~[p] v, et tel que K u est bien typé.
     Alors, K v est bien typé et K u ~ K v.
   Proof.
     Par induction sur le chemin p.
     Si p = ., alors u ~ v et donc u bien typé et v bien typé. Par ppté
     du canonizer, on a K u ~ K v et en particulier K v bien typé.
     Si p = k.q, alors u = f(u1,... un), v = f(v1, ... vn),
     avec uk ~[q] vk et uj = vj pour tout j différent de k.
     Par hypothèse d'induction sur uk et vk, on a :
     (IH) K uk bien typé -> K vk bien typé et K uk ~ K vk.

   Qed.

   Theorem X : Soient u v deux termes, v bien typé et K u bien typé,
     alors u <->* v implique K u ~ K v (ce qui fait sens puisque K u
     et K v sont bien typés).
   Proof.
     Par induction sur la suite de réécritures.
     Si u = v, alors K u = K v d'où le résultat.
     Si u <->[p] w et w <->* v, alors 2 cas :
       * soit la règle utilisée dans u <->[p] w est de R, auquel cas
         on a K u = K w donc K w est bien typé et par hypothèse d'induction
         on a K w ~ K v, d'où le résultat ;
       * soit la règle utilisée est ~, auquel cas...
         ... on a K w bien typé et K u ~ K w ... (lemme nedded !)
         On peut donc appliquer l'hypothèse de récurrence
         et on a K w ~ K v. Comme K u ~ K w, par transitivté on a le résultat.
   Qed.
   Corollary X' : Soient u v bien typés, u <->* v -> u ~ v.
   Proof.
     On a K u bien typé, donc d'apres X, on a K u ~ K v. Comme d'autre part,
     on a u ~ K u et v ~ K v par le lemme 2, on a le résultat.
   Qed.

*)

(* Module StepEquality. *)
(*   Import GenericCongrClosure. *)
(* (*   Variable M : varmaps. *) *)
(* (*   Let vty : type_env := varmaps_vty M. *) *)
(* (*   Let vsy : term_env vty := varmaps_vsy M. *) *)

(* (*   Notation "t :> ty" := (has_type vty vsy t ty = true)(at level 65). *) *)
(* (*   Notation "t :/> ty" := (has_type vty vsy t ty = false)(at level 65). *) *)

(* (*   Inductive step (u v : term) : Prop := *) *)
(* (*   | step_ring : ZRing u v -> step u v *) *)
(* (*   | step_wt : forall ty (Hu : u :> ty) (Hv : v :> ty), *) *)
(* (*       interp vty vsy u ty Hu = interp vty vsy v ty Hv -> step u v. *) *)

(*   Definition sanitize (M : varmaps) (t : term) : term := *)
(*     if wt t in M then t else *)
(*       match t with *)
(*         | app (Op DomainZ op) (cons a (cons b nil)) => *)
(*           match op with *)
(*             | Plus => *)
(*               if a == [0] then b *)
(*               else if b == topp a then [0] else t *)
(*             | Mult =>  *)
(*               if a == [1] then b else t *)
(*             | Div => *)
(*               match a with *)
(*                 | app (Op DomainZ Mult) (cons ku (cons u nil)) => *)
(*                   match ku with *)
(*                     | app (Cst DomainZ k) nil => *)
(*                       if b == [k] then if k == 0%Z then t else u else t *)
(*                     | _ => t *)
(*                   end *)
(*                 | _ => t *)
(*               end *)
(*             | _ => t *)
(*           end  *)
(*         | _ => t *)
(*       end. *)
(*   Remark sanitize_wt : forall M u, wt u in M = true -> sanitize M u = u. *)
(*   Proof. *)
(*     intros; unfold sanitize; rewrite H; reflexivity. *)
(*   Qed. *)
(*   Property sanitize_stable :  *)
(*     forall M u, ZRing u (sanitize M u) \/ u = sanitize M u. *)
(*   Proof. *)
(*     intros; set (su := sanitize M u) in *. *)
(*     unfold sanitize in su; destruct (wt u in M). *)
(*     right; reflexivity. *)
(*     destruct u as [f lt]; destruct f. *)
(*     right; reflexivity. *)
(*     right; reflexivity. *)
(*     destruct dom; try (right; reflexivity). *)
(*     destruct lt as [|a lt]; [right; reflexivity |]. *)
(*     destruct lt as [|b lt]; [right; reflexivity |]. *)
(*     destruct lt as [|? ?]; [| right; reflexivity]. *)
(*     destruct op; try (right; reflexivity). *)
(*     destruct (eq_dec a [0]). *)
(*     left; rewrite H; unfold su; constructor. *)
(*     destruct (eq_dec b (topp a)). *)
(*     left; rewrite H0; unfold su; constructor. *)
(*     right; reflexivity. *)
(*     destruct (eq_dec a [1]). *)
(*     left; rewrite H; unfold su; constructor. *)
(*     right; reflexivity. *)
(*     destruct a as [f lt]; destruct f; try (right; reflexivity). *)
(*     destruct dom; try (right; reflexivity). *)
(*     destruct op; try (right; reflexivity). *)
(*     destruct lt as [|ku lt]; [right; reflexivity |]. *)
(*     destruct lt as [|u lt]; [right; reflexivity |]. *)
(*     destruct lt as [|? ?]; [| right; reflexivity]. *)
(*     destruct ku as [g lu]; destruct g; try (right; reflexivity). *)
(*     destruct dom; try (right; reflexivity). *)
(*     destruct lu; [|right; reflexivity]. *)
(*     destruct (eq_dec b [z]); [|right; reflexivity]. *)
(*     destruct (eq_dec z 0%Z); [right; reflexivity |]. *)
(*     rewrite H; left; constructor; auto. *)
(*   Qed. *)

(*   Remark rel_at_or :  *)
(*     forall (R S T : term -> term -> Prop),  *)
(*       (forall u v, R u v <-> (S u v \/ T u v)) -> *)
(*       forall p u v, rel_at R p u v -> rel_at S p u v \/ rel_at T p u v. *)
(*   Proof. *)
(*     intros R S T Hiff p u v H. *)
(*     induction H using rel_at_mutual_ind with *)
(*       (P := fun p u v H => rel_at S p u v \/ rel_at T p u v) *)
(*       (P0 := fun n p lu lv H =>  *)
(*         rel_at_terms S n p lu lv \/ rel_at_terms T n p lu lv). *)
(*     rewrite Hiff in r; destruct r; [left | right]; constructor; assumption. *)
(*     destruct IHrel_at; [left | right]; constructor; assumption. *)
(*     destruct IHrel_at; [left | right]; constructor; assumption. *)
(*     destruct IHrel_at; [left | right]; constructor; assumption. *)
(*   Qed. *)

(*   (* Si  t <-> u, t bien typé et u mal typé,  *)
(*      alors la règle utilisée est dans ZRing *) *)
(*   Variable M : varmaps. *)
(*   Let vty : type_env := varmaps_vty M. *)
(*   Let vsy : term_env vty := varmaps_vsy M. *)

(*   Notation "t :> ty" := (has_type vty vsy t ty = true)(at level 65). *)
(*   Notation "t :/> ty" := (has_type vty vsy t ty = false)(at level 65). *)
(*   Definition ieq (u v : term) : Prop := *)
(*     exists ty, exists Hu : u :> ty, exists Hv : v :> ty, *)
(*         interp vty vsy u ty Hu = interp vty vsy v ty Hv. *)

(*   Inductive step (u v : term) : Prop := *)
(*   | step_ring1 : ZRing u v -> step u v *)
(*   | step_ring2 : ZRing v u -> step u v *)
(*   | step_wt : forall ty (Hu : u :> ty) (Hv : v :> ty), *)
(*       interp vty vsy u ty Hu = interp vty vsy v ty Hv -> step u v. *)

(*   Property step_iff : forall u v, *)
(*     step u v <-> (ZRing u v \/ (ZRing v u \/ ieq u v)). *)
(*   Proof. *)
(*     intros u v; split; intro H. *)
(*     destruct H; [ left | right; left | right; right ]; auto. *)
(*     exists ty; exists Hu; exists Hv; assumption. *)
(*     destruct H. constructor; assumption. *)
(*     destruct H. constructor; assumption. *)
(*     destruct H as [ty [x [y H]]]. *)
(*     constructor 3 with ty x y; assumption. *)
(*   Qed. *)

(*   Lemma rel_at_stable_type :  *)
(*     forall (R : term -> term -> Prop)  *)
(*       (HR : forall u v ty ty', R u v -> u :> ty -> v :> ty' -> ty = ty'), *)
(*     forall p u v ty ty', rel_at R p u v ->  *)
(*       u :> ty -> v :> ty' -> ty = ty'. *)
(*   Proof. *)
(*     intros r HR p u v ty ty' H; revert ty ty'. *)
(*     induction H using rel_at_mutual_ind with *)
(*       (P := fun p u v H => forall ty ty', u :> ty -> v :> ty' -> ty = ty') *)
(*       (P0 := fun n p lu lv H => forall tyf ty ty',  *)
(*         well_typed_terms vty vsy lu tyf ty -> *)
(*         well_typed_terms vty vsy lv tyf ty' -> ty = ty'). *)
(*     intros; exact (HR t u ty ty' r0 H H0). *)
(*     intros; apply has_type_1 in H; apply has_type_1 in H0. *)
(*     inversion_clear H; inversion_clear H0; exact (IHrel_at _ _ _ H1 H). *)
(*     intros. inversion H0; subst; clear H0. *)
(*     inversion H1; subst; clear H1. *)
(*     revert H4 H8; clear; revert t2; induction l; intros. *)
(*     inversion H4; inversion H8; subst; assumption. *)
(*     inversion H4; inversion H8; subst. *)
(*     inversion H10; subst; apply (IHl t0); assumption. *)
(*     intros; inversion H; inversion H0; subst. *)
(*     inversion H10; subst; eauto. *)
(*   Qed. *)
(*   Corollary rel_at_ieq_stable :  *)
(*     forall p u v ty ty', rel_at ieq p u v -> u :> ty -> v :> ty' -> ty = ty'. *)
(*   Proof. *)
(*     apply rel_at_stable_type; intros. *)
(*     destruct H as [ty0 [Hu [Hv _]]]. *)
(*     generalize (has_type_is_type_of _ _ _ _ Hu) *)
(*       (has_type_is_type_of _ _ _ _ H0); intros; subst. *)
(*     generalize (has_type_is_type_of _ _ _ _ H1); intros; subst. *)
(*     rewrite (has_type_is_type_of _ _ _ _ Hv); reflexivity. *)
(*   Qed. *)

(*   Lemma wt_rel_at_wt : *)
(*     forall p u v, rel_at ieq p u v -> wt u in M = true -> wt v in M = true. *)
(*   Proof. *)
(*     induction p; intros. *)
(*     inversion_clear H. *)
(*     destruct H1 as [ty [Ht [Hu H]]]. *)
(*     fold vty; fold vsy; rewrite <- (has_type_is_type_of _ _ _ _ Hu); auto. *)
(*     inversion H; subst; clear H. *)
(*     apply has_type_2; apply has_type_1 in H0; constructor. *)
(*     inversion H0; subst; clear H0; simpl in *. *)
(*     set (tyf := lookup_type (varmaps_vty M) (varmaps_vsy M) f) in *. *)
(*     clearbody tyf; revert p IHp lt lu H5 H3. *)
(*     induction a; intros; simpl in *. *)
(*     inversion H5; subst; clear H5. *)
(*     inversion H3; subst; clear H3; simpl in *; constructor; auto. *)
(*     apply has_type_2 in H6; apply has_type_1. *)
(*     assert (Hr := has_type_is_type_of _ _ _ _ H6); rewrite Hr in H6. *)
(*     assert (IH := IHp t u H H6). *)
(*     rewrite (rel_at_ieq_stable p t u _ _ H H6 IH) in Hr. *)
(*     rewrite Hr; assumption. *)
(*     inversion H5; subst; clear H5. *)
(*     inversion H3; subst; clear H3; simpl in *; constructor (eauto). *)
(*   Abort. *)

(* (*     Check well_typed_terms. *) *)
(* (*     intros p u v H; induction H using rel_at_mutual_ind with *) *)
(* (*       (P := fun p u v H => wt u in M = true -> wt v in M = true) *) *)
(* (*       (P0 := fun n p lu lv H => forall ty ty', *) *)
(* (*         well_typed_terms vty vsy lu ty ty' ->  *) *)
(* (*         well_typed_terms vty vsy lv ty ty'). *) *)
(* (*     destruct r as [ty [Ht [Hu H]]]. *) *)
(* (*     fold vty; fold vsy; rewrite <- (has_type_is_type_of _ _ _ _ Hu); auto. *) *)
(* (*     intro Z; apply has_type_2; apply has_type_1 in Z. *) *)
(* (*     inversion_clear Z; constructor. fold vty in *; fold vsy in *. *) *)
(* (*     simpl in *. Print types_of. *) *)
(* (*     exact (IHrel_at _ _ H). *) *)

(*   Lemma wt_eq_it_rule :  *)
(*     forall p u v, wt u in M = true -> wt v in M = false -> *)
(*       rel_at step p u v -> rel_at ZRing p u v. *)
(*   Proof. *)
(*     cut (forall p u v, wt u in M = true -> wt v in M = false -> *)
(*       rel_at step p u v ->  *)
(*       rel_at ZRing p u v \/ rel_at (fun u v => *)
(*         forall ty (Hu : u :> ty) (Hv : v :> ty), *)
(*           interp vty vsy u ty Hu = interp vty vsy v ty Hv) p u v). *)
(*     intro cut; intros. *)
(*     destruct (cut p u v H H0 H1). *)
(*     assumption. *)
(*     admit. *)
(*     intros; revert H H0. *)
(*   Abort. *)

(* (* *)
(*   t <->* u et t :> ty in M et u :> ty in M, alors  M(t) = M(u). *)

(*   Probablement par induction sur la taille (longueur ?) de la suite de *)
(*   réécritures. *)

(*   * si t = u, c évident *)
(*   * si t <-> u', u' <->* u,  *)
(*     - si u' est bien typé, il est forcément de type ty, *)
(*     on applique l'IH à u' et u, et par transitivité on a M(t) = M(u') = M(u). *)
(*     - si u' n'est pas bien typé... *)

(*     *) *)
(*   Inductive ring_term : term -> Prop := *)
(*   | ring_cst : forall k, ring_term [k] *)
(*   | ring_plus : forall u v, ring_term (u [+] v) *)
(*   | ring_mult : forall u v, ring_term (u [*] v) *)
(*   | ring_minus : forall u v, ring_term (u [-] v) *)
(*   | ring_opp : forall u, ring_term (topp u) *)
(*   | ring_div : forall u k, ring_term (u [/] [k]). *)
(*   Definition is_ring_term (t : term) := *)
(*     match t with *)
(*       | app (Cst DomainZ _) nil => true *)
(*       | app (Op DomainZ Opp) (cons _ nil) => true *)
(*       | app (Op DomainZ op) (cons _ (cons b nil)) => *)
(*         match op with  *)
(*           | Plus | Mult | Minus => true *)
(*           | Div =>  *)
(*             match b with | app (Cst DomainZ _) nil => true | _ => false end *)
(*           | _ => false *)
(*         end *)
(*       | _ => false *)
(*     end. *)

(*   Inductive is_ring_term_spec (t : term) : bool -> Prop := *)
(*   | is_ring_term_true :  *)
(*     forall (Hring : ring_term t), is_ring_term_spec t true *)
(*   | is_ring_term_false :  *)
(*     forall (Hring : ~ring_term t), is_ring_term_spec t false. *)
(*   Ltac prove_irt_spec := *)
(*     match goal with *)
(*       | |- is_ring_term_spec ?t false => *)
(*         solve [constructor; intro H; inversion H] *)
(*       | |- is_ring_term_spec ?t true => *)
(*         constructor; constructor *)
(*       | _ => fail "Not a goal of the form is_ring_term t b." *)
(*     end. *)
(*   Property is_ring_term_dec : forall t, is_ring_term_spec t (is_ring_term t). *)
(*   Proof. *)
(*     destruct t; destruct f; simpl. *)
(*     prove_irt_spec. *)
(*     destruct dom; try prove_irt_spec. *)
(*     destruct lt; prove_irt_spec. *)
(*     destruct dom; try prove_irt_spec. *)
(*     destruct op; repeat (destruct lt; try prove_irt_spec). *)
(*     destruct t0; try prove_irt_spec. *)
(*     destruct f; try destruct dom; try destruct lt; prove_irt_spec. *)
(*   Qed. *)
(*   Opaque is_ring_term. *)

(*   Inductive ring_subterms : term -> Prop := *)
(*   | ring_top : forall t, ring_term t -> ring_subterms t *)
(*   | ring_app : forall f lt t, List.In t lt ->  *)
(*     ring_subterms t -> ring_subterms (app f lt). *)
(*   Nested Fixpoint has_ring_subterms (t : term) : bool := *)
(*     if is_ring_term t then true *)
(*     else  *)
(*       match t with  *)
(*         | app _ lt => has_ring_subterms_terms lt *)
(*       end *)
(*   with has_ring_subterms_terms (lt : terms) : bool := *)
(*     match lt with *)
(*       | nil => false *)
(*       | t::q => if has_ring_subterms t then true  *)
(*         else has_ring_subterms_terms q *)
(*     end. *)

(*   Inductive has_ring_subterms_spec (t : term) : bool -> Prop := *)
(*   | has_ring_subterms_true :  *)
(*     forall (Hsubring : ring_subterms t), has_ring_subterms_spec t true *)
(*   | has_ring_subterms_false :  *)
(*     forall (Hsubring : ~ring_subterms t), has_ring_subterms_spec t false. *)
(*   Inductive has_ring_subterms_terms_spec (l : terms) : bool -> Prop := *)
(*   | has_ring_subterms_terms_true :  *)
(*     forall t (Hin : In t l) (Hsubring : ring_subterms t), *)
(*       has_ring_subterms_terms_spec l true *)
(*   | has_ring_subterms_terms_false :  *)
(*     forall (Hsubring : forall t, In t l -> ~ring_subterms t),  *)
(*       has_ring_subterms_terms_spec l false. *)

(*   Property has_ring_subterms_mutual_dec :  *)
(*     (forall t, has_ring_subterms_spec t (has_ring_subterms t)) /\ *)
(*     (forall l, has_ring_subterms_terms_spec l (has_ring_subterms_terms l)). *)
(*   Proof. *)
(*     apply term_mutual_ind. *)
(*     intros; simpl; unfold has_ring_subterms_terms in H. *)
(*     destruct H. *)
(*     match goal with | |- context f [if ?X then true else true] =>  *)
(*       let Z := context f [true] in  *)
(*       (cut Z; [intro cut; destruct X; exact cut |]) end. *)
(*     constructor; constructor 2 with t; assumption. *)
(*     destruct (is_ring_term_dec (app f lt)); constructor. *)
(*     constructor; assumption. *)
(*     intro abs; inversion abs; subst; auto. exact (Hsubring _ H1 H2). *)
(*     constructor; intros; contradiction. *)
(*     intros; simpl; destruct H. *)
(*     constructor 1 with t; intuition. *)
(*     destruct H0. *)
(*     constructor 1 with t0; intuition. *)
(*     constructor 2; intros; inversion H; subst; auto. *)
(*   Qed. *)
(*   Definition has_ring_subterms_dec :=  *)
(*     Eval simpl in (proj1 has_ring_subterms_mutual_dec). *)
(*   Opaque has_ring_subterms has_ring_subterms_terms has_type. *)

(*   Definition trou : term := [42]. *)
(*   Fixpoint cleanse (M : varmaps) (t : term) : term := *)
(*     if wt t in M then t *)
(*     else *)
(*       if has_ring_subterms t then *)
(*         match t with | app f l => *)
(*           app f (map (cleanse M) l) *)
(*         end *)
(*       else trou. *)
(*   Inductive cleanse_spec (M : varmaps) (t : term) : term  -> Prop := *)
(*   | cleanse_wt : *)
(*     forall (Hwt : wt t in M = true), cleanse_spec M t t *)
(*   | cleanse_subterms :  *)
(*     forall f l  *)
(*       (Hwt : wt t in M = false) (Hsub : ring_subterms t), *)
(*       cleanse_spec M t (app f (map (cleanse M) l)) *)
(*   | cleanse_hole :  *)
(*     forall (Hwt : wt t in M = false) (Hsub : ~ (ring_subterms t)), *)
(*       cleanse_spec M t trou. *)
(* (*   Property cleanse_dec : forall M t, cleanse_spec M t (cleanse M t). *) *)
(* (*   Proof. *) *)
(* (*     intros; destruct t as [f l]; unfold cleanse. *) *)
(* (*     destruct (wt (app f l) in M) as [ ]_eqn:Hwt. *) *)
(* (*     constructor 1; assumption. *) *)
(* (*     destruct (has_ring_subterms_dec (app f l)). *) *)
(* (*     constructor; assumption.  *) *)
(* (*     constructor; assumption. *) *)
(* (*   Qed. *) *)
(* End StepEquality. *)

Section IllTypedEqualities.
  Variable M : varmaps.

  Inductive bad_equality : term -> term -> Prop :=
  | bad_0_neutral : forall u, bad_equality u ([0][+]u)
  | bad_1_neutral : forall u, bad_equality u ([1][*]u)
  | bad_opp_cancel : forall u, bad_equality [0] (u[+]topp u)
  | bad_div_cancel : forall k u, k =/= 0%Z -> bad_equality u (([k][*]u)[/][k]).

  Theorem ill_typed_ZRing_1 :
    forall t u, wt t in M = true -> wt u in M = false ->
      ZRing t u -> bad_equality t u.
  Proof.
    intros t u Hwt Hit E; destruct E; try constructor; simpl in *;
      repeat (ite Hwt); repeat (ite Hit); congruence.
  Qed.
  Theorem ill_typed_ZRing_2 :
    forall t u, wt t in M = false -> wt u in M = true ->
      ZRing t u -> False.
  Proof.
    intros t u Hwt Hit E; destruct E; simpl in *;
      repeat (ite Hwt); repeat (ite Hit); try congruence.
    rewrite <- (has_type_is_type_of _ _ _ _ if0) in Hwt; congruence.
    rewrite <- (has_type_is_type_of _ _ _ _ if0) in Hwt; congruence.
    rewrite <- (has_type_is_type_of _ _ _ _ if1) in Hwt; congruence.
  Qed.

End IllTypedEqualities.

Section WithModelsAndR.
  Variable R : term -> term -> Prop.
  Variable M : varmaps.
  Let vty : type_env := varmaps_vty M.
  Let vsy : term_env vty := varmaps_vsy M.

  Notation "t :> ty" := (has_type vty vsy t ty = true)(at level 65).
  Notation "t :/> ty" := (has_type vty vsy t ty = false)(at level 65).

  Inductive mext : term -> term -> Prop :=
  | mext_wt :
    forall t u ty (Ht : t :> ty) (Hu : u :> ty),
      interp vty vsy t ty Ht = interp vty vsy u ty Hu -> mext t u
  | mext_refl :
    forall t, mext t t
  | mext_sym :
    forall t u, mext u t -> mext t u
  | mext_trans :
    forall t v u, mext t v -> mext v u -> mext t u
  | mext_congr :
    forall f lt lu, mext_terms lt lu -> mext (app f lt) (app f lu)
  | mext_rule :
    forall t u, R t u -> mext t u
  with mext_terms : terms -> terms -> Prop :=
  | mext_nil :
    mext_terms nil nil
  | mext_cons :
    forall t u lt lu,
      mext t u -> mext_terms lt lu -> mext_terms (t::lt) (u::lu).
  Generate Scheme mext.
End WithModelsAndR.

Definition eq := mext ZRing.
Definition eq_refl := mext_refl ZRing.
Definition eq_sym := mext_sym ZRing.
Definition eq_trans := mext_trans ZRing.
Definition eq_congr := mext_congr ZRing.

(* Notation "'types' 'of' f 'above' l 'in' M" := *)
(*   (types_of l (lookup_type (varmaps_vty M) (varmaps_vsy M) f))  *)
(*   (at level 1). *)
(* Notation "'wts' f 'above' l 'in' M" := *)
(*   (have_type (varmaps_vty M) (varmaps_vsy M)  *)
(*     l (lookup_type (varmaps_vty M) (varmaps_vsy M) f) *)
(*     (types of f above l in M)) *)
(*   (at level 1, l at level 200). *)
(* Section OnVerraBien. *)
(*   Variable M : varmaps. *)
(*   Notation vty := (varmaps_vty M). *)
(*   Notation vsy := (varmaps_vsy M). *)

(*   Definition P (u v : term) : eq M u v -> Prop := fun _ => *)
(*     match wt u in M, wt v in M with *)
(*       | true, true => Term.eq vty vsy u v *)
(*       | true, false =>        *)
(*         forall w, wt w in M = true -> eq M v w -> Term.eq vty vsy w u *)
(*       | false, true =>        *)
(*         forall w, wt w in M = true -> eq M u w -> Term.eq vty vsy w v *)
(*       | false, false => *)
(*         True *)
(* (*         forall w w', wt w in M = true -> wt w' in M = true ->  *) *)
(* (*           eq M u w -> eq M v w' -> Term.eq vty vsy w w' *) *)
(*     end. *)
(*   Definition Pl (lu lv : terms) :  mext_terms ZRing M lu lv -> Prop := fun _ => *)
(*     forall f, match wts f above lu in M, wts f above lv in M with *)
(*                 | true, true => eq_terms vty vsy lu lv *)
(*                 | true, false => True *)
(*                 | false, true => True *)
(*                 | false, false => *)
(*                   True *)
(*               end. *)
(*   Theorem P_is_true : forall u v (H : eq M u v), P u v H. *)
(*   Proof. *)
(*     unfold eq; apply (@mext_mutual_ind ZRing M P Pl);  *)
(*       unfold P in *; unfold Pl in *; intros. *)
(*     (* - int *) *)
(*     rewrite <- (has_type_is_type_of vty vsy t ty Ht), Ht. *)
(*     rewrite <- (has_type_is_type_of vty vsy u ty Hu), Hu. *)
(*     admit. (* ok *) *)
(*     (* - refl *) *)
(*     case_eq (wt t in M); intro Ht. *)
(*     apply Term.eq_refl.  *)
(*     trivial. *)
(*     (* - sym *) *)
(*     case_eq (wt t in M); intro Ht; *)
(*       case_eq (wt u in M); intro Hu; rewrite Ht, Hu in H; trivial. *)
(*     apply Term.eq_sym; assumption. *)
(*     (* - trans *) *)
(*     case_eq (wt t in M); intro Ht; *)
(*       case_eq (wt u in M); intro Hu;  *)
(*         case_eq (wt v in M); intro Hv;  *)
(*         rewrite ?Ht, ?Hu, ?Hv in *. *)
(*     apply Term.eq_trans with v; assumption. *)
(*     apply H0; auto; apply eq_sym; auto. *)
(*     intros; apply Term.eq_trans with v; auto using Term.eq_sym. *)
(*     intros; apply H; auto; apply eq_trans with u; assumption. *)
(*     intros; apply Term.eq_trans with v; auto using Term.eq_sym. *)
(*     intros; apply H0; auto; apply eq_trans with t; auto using eq_sym. *)
(*     trivial. *)
(*     trivial. *)
(*     (* - congr *) *)
(*     case_eq (wt app f lt in M); intro Ht; *)
(*       case_eq (wt app f lu in M); intro Hu. *)
(*     apply Term.eq_congr. *)
(*     assert (Hf := H f); clear H. *)
(*     change (wts f above lt in M = true) in Ht; rewrite Ht in Hf. *)
(*     change (wts f above lu in M = true) in Hu; rewrite Hu in Hf. *)
(*     assumption. *)
(*     admit. *)
(*     admit. *)
(*     trivial. *)
(*     (* - rule *) *)
(*     case_eq (wt t in M); intro Ht; *)
(*       case_eq (wt u in M); intro Hu. *)
(*     admit. (* ok *) *)
(*     admit. *)
(*     admit. *)
(*     trivial. *)
(*     (* - tnil *) *)
(*     assert (Hwt : wts f above tnil in M = true). *)
(*     simpl; apply tequal_2; reflexivity. *)
(*     rewrite Hwt; constructor. *)
(*     (* - tcons *) *)

(*   Qed. *)

(* End OnVerraBien. *)

Axiom eq_wt_iff : forall M t u,
  let vty := varmaps_vty M in
  let vsy := varmaps_vsy M in
    has_type vty vsy t (type_of vty vsy t) = true ->
    has_type vty vsy u (type_of vty vsy u) = true ->
    (eq M t u <-> Term.eq vty vsy t u).

Theorem eq_ring : forall M, @Ring_theory.ring_theory
  term ([0]) ([1]) tplus tmult tminus topp (eq M).
Proof.
  intros; constructor; intros; try (apply mext_rule; constructor; auto);
    (apply mext_sym; apply mext_rule; constructor; auto).
Qed.
Theorem eq_integral : forall M k u v,
  eq M ([k][*]u) ([k][*]v) -> k =/= 0%Z -> eq M u v.
Proof.
  intros.
  apply eq_trans with (([k][*]u)[/][k]).
  apply mext_rule; constructor; assumption.
  apply eq_trans with (([k][*]v)[/][k]).
  apply eq_congr; repeat (constructor; auto).
  apply mext_sym; apply mext_rule; constructor; assumption.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about the empty type *)

Require Import Basics.Overture Basics.Equivalences.
Local Open Scope path_scope.

(** ** Unpacking *)
(** ** Eta conversion *)
(** ** Paths *)
(** ** Transport *)
(** ** Functorial action *)
(** ** Equivalences *)
(** ** Universal mapping properties *)

Global Instance contr_from_Empty {_ : Funext} (A : Empty -> Type) :
  Contr (forall x:Empty, A x).
Proof.
  refine (Build_Contr (forall x:Empty, A x) (Empty_ind A) _).
  intros f; apply path_forall; intros x; elim x.
Defined.

Lemma Empty_rec {T : Type} (falso: Empty) : T.
Proof. case falso. Defined.

Global Instance isequiv_empty_rec `{Funext} (A : Type)
: IsEquiv (fun (_ : Unit) => @Empty_rec A) | 0
  := isequiv_adjointify _
  (fun _ => tt)
  (fun f => path_forall _ _ (fun x => Empty_rec x))
  (fun x => match x with tt => idpath end).

Definition equiv_empty_rec `{Funext} (A : Type)
  : Unit <~> (Empty -> A)
  := (Build_Equiv _ _ (fun (_ : Unit) => @Empty_rec A) _).

(** ** Behavior with respect to truncation *)

Global Instance hprop_Empty : IsHProp Empty.
Proof. intro x. destruct x. Defined.

Global Instance all_to_empty_isequiv (T : Type) (f : T -> Empty) : IsEquiv f.
Proof.
  refine (Build_IsEquiv _ _ _
    (Empty_ind (fun _ => T))                (* := equiv_inf *)
    (fun fals:Empty => match fals with end) (* : f o equiv_inf == idmap *)
    (fun t:T => match (f t) with end)       (* : equiv_inf o f == idmap *)
    (_)                                     (* adjointify part *)  ).
  intro t.
  exact (Empty_rec (f t)).
Defined.

Definition equiv_to_empty {T : Type} (f : T -> Empty) : T <~> Empty
  := Build_Equiv T Empty f _.

(** ** Paths *)

(** We could probably prove some theorems about non-existing paths in
   [Empty], but this is really quite useless. As soon as an element
   of [Empty] is hypothesized, we can prove whatever we like with
   a simple elimination. *)


(* -*- mode: coq; mode: visual-line -*-  *)

Require Export Basics.
Require Export WildCat.Core.
Require Export WildCat.Equiv.
Require Export WildCat.Type.
Require Export WildCat.Opposite.
Require Export WildCat.FunctorCat.
Require Export WildCat.NatTrans.
Require Export WildCat.Prod.

(** ** Two-variable hom-functors *)

Global Instance is0functor_hom {A} `{Is01Cat A}
  : @Is0Functor (A^op * A) Type _ _ (uncurry (@Hom A _)).
Proof.
  apply Build_Is0Functor.
  intros [a1 a2] [b1 b2] [f1 f2] g; cbn in *.
  exact (f2 $o g $o f1).
Defined.

(** This requires morphism extensionality! *)
Global Instance is1functor_hom {A} `{HasMorExt A}
  : @Is1Functor (A^op * A) Type _ _ _ _ (uncurry (@Hom A _)) _.
Proof.
  apply Build_Is1Functor.
  - intros [a1 a2] [b1 b2] [f1 f2] [g1 g2] [p1 p2] q; cbn in *.
    apply path_hom.
    exact (((p2 $@R q) $@R _) $@ (_ $@L p1)).
  - intros [a1 a2] f; cbn in *.
    apply path_hom.
    exact (cat_idr _ $@ cat_idl f).
  - intros [a1 a2] [b1 b2] [c1 c2] [f1 f2] [g1 g2] h; cbn in *.
    apply path_hom.
    refine (cat_assoc _ _ _ $@ _).
    refine (cat_assoc _ _ _ $@ _).
    refine (_ $@ cat_assoc_opp _ _ _).
    refine (g2 $@L _).
    refine (_ $@ cat_assoc_opp _ _ _).
    refine (cat_assoc_opp _ _ _).
Defined.

(** ** The covariant Yoneda lemma *)

(** This is easier than the contravariant version because it doesn't involve any "op"s. *)

Definition opyon {A : Type} `{Is01Cat A} (a : A) : A -> Type
  := fun b => (a $-> b).

Global Instance is0coh1functor_opyon {A : Type} `{Is01Cat A} (a : A)
  : Is0Functor (opyon a).
Proof.
  apply Build_Is0Functor.
  unfold opyon; intros b c f g; cbn in *.
  exact (f $o g).
Defined.

Definition opyoneda {A : Type} `{Is01Cat A} (a : A)
           (F : A -> Type) {ff : Is0Functor F}
  : F a -> (opyon a $=> F).
Proof.
  intros x b f.
  exact (fmap F f x).
Defined.

Definition un_opyoneda {A : Type} `{Is01Cat A}
  (a : A) (F : A -> Type) {ff : Is0Functor F}
  : (opyon a $=> F) -> F a
  := fun alpha => alpha a (Id a).

Global Instance is1natural_opyoneda {A : Type} `{Is1Cat A}
  (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a)
  : Is1Natural (opyon a) F (opyoneda a F x).
Proof.
  apply Build_Is1Natural.
  unfold opyon, opyoneda; intros b c f g; cbn in *.
  exact (fmap_comp F g f x).
Defined.

Definition opyoneda_issect {A : Type} `{Is1Cat A} (a : A)
           (F : A -> Type) `{!Is0Functor F, !Is1Functor F}
           (x : F a)
  : un_opyoneda a F (opyoneda a F x) = x
  := fmap_id F a x.

(** We assume for the converse that the coherences in [A] are equalities (this is a weak funext-type assumption).  Note that we do not in general recover the witness of 1-naturality.  Indeed, if [A] is fully coherent, then a transformation of the form [yoneda a F x] is always also fully coherently natural, so an incoherent witness of 1-naturality could not be recovered in this way.  *)
Definition opyoneda_isretr {A : Type} `{Is1Cat_Strong A} (a : A)
           (F : A -> Type) `{!Is0Functor F, !Is1Functor F}
           (alpha : opyon a $=> F) {alnat : Is1Natural (opyon a) F alpha}
           (b : A)
  : opyoneda a F (un_opyoneda a F alpha) b $== alpha b.
Proof.
  unfold opyoneda, un_opyoneda, opyon; intros f.
  refine ((isnat alpha f (Id a))^ @ _).
  cbn.
  apply ap.
  exact (cat_idr_strong f).
Defined.

(** Specialization to "full-faithfulness" of the Yoneda embedding.  (In quotes because, again, incoherence means we can't recover the witness of naturality.)  *)
Definition opyon_cancel {A : Type} `{Is01Cat A} (a b : A)
  : (opyon a $=> opyon b) -> (b $-> a)
  := un_opyoneda a (opyon b).

Definition opyon1 {A : Type} `{Is01Cat A} (a : A) : Fun01 A Type.
Proof.
  rapply (Build_Fun01 _ _ _ _ (opyon a)).
Defined.

(** We can also deduce "full-faithfulness" on equivalences. *)
Definition opyon_equiv {A : Type} `{HasEquivs A} `{!Is1Cat_Strong A}
           (a b : A)
  : (opyon1 a $<~> opyon1 b) -> (b $<~> a).
Proof.
  intros f.
  refine (cate_adjointify (f.1 a (Id a)) (f^-1$.1 b (Id b)) _ _) ;
    apply GpdHom_path; pose proof (f.2); pose proof (f^-1$.2); cbn in *.
  - refine ((isnat (fun a => (f.1 a)^-1$) (f.1 a (Id a)) (Id b))^ @ _); cbn.
    refine (_ @ cate_issect (f.1 a) (Id a)); cbn.
    apply ap.
    serapply cat_idr_strong.
  - refine ((isnat f.1 (f^-1$.1 b (Id b)) (Id a))^ @ _); cbn.
    refine (_ @ cate_isretr (f.1 b) (Id b)); cbn.
    apply ap.
    serapply cat_idr_strong.
Defined.

(** ** The contravariant Yoneda lemma *)

(** We can deduce this from the covariant version with some boilerplate. *)

Definition yon {A : Type} `{Is01Cat A} (a : A) : A^op -> Type
  := @opyon (A^op) _ a.

Global Instance is0coh1functor_yon {A : Type} `{Is01Cat A} (a : A)
  : Is0Functor (yon a)
  := @is0coh1functor_opyon A _ a.

Definition yoneda {A : Type} `{Is01Cat A} (a : A)
           (F : A^op -> Type) `{!Is0Functor F}
  : F a -> (yon a $=> F)
  := @opyoneda (A^op) _ a F _.

Definition un_yoneda {A : Type} `{Is01Cat A} (a : A)
           (F : A^op -> Type) `{!Is0Functor F}
  : (yon a $=> F) -> F a
  := @un_opyoneda (A^op) _ a F _.

Global Instance is1natural_yoneda {A : Type} `{Is1Cat A} (a : A)
       (F : A^op -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a)
  : Is1Natural (yon a) F (yoneda a F x)
  := @is1natural_opyoneda (A^op) _ _ a F _ _ x.

Definition yoneda_issect {A : Type} `{Is1Cat A} (a : A)
           (F : A^op -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a)
  : un_yoneda a F (yoneda a F x) = x
  := @opyoneda_issect (A^op) _ _ a F _ _ x.

Definition yoneda_isretr {A : Type} `{Is1Cat_Strong A} (a : A)
           (F : A^op -> Type) `{!Is0Functor F}
           (* Without the hint here, Coq guesses to first project from [Is1Cat_Strong A] and then pass to opposites, whereas what we need is to first pass to opposites and then project. *)
           `{@Is1Functor _ _ _ (is1cat_is1cat_strong A^op) _ _ F _}
           (alpha : yon a $=> F) {alnat : Is1Natural (yon a) F alpha}
           (b : A)
  : yoneda a F (un_yoneda a F alpha) b $== alpha b
  := @opyoneda_isretr A^op _ (is1cat_strong_op A) a F _ _ alpha alnat b.

Definition yon_cancel {A : Type} `{Is01Cat A} (a b : A)
  : (yon a $=> yon b) -> (a $-> b)
  := un_yoneda a (yon b).

Definition yon1 {A : Type} `{Is01Cat A} (a : A) : Fun01 A^op Type
  := opyon1 a.

Definition yon_equiv {A : Type} `{HasEquivs A} `{!Is1Cat_Strong A}
           (a b : A)
  : (yon1 a $<~> yon1 b) -> (a $<~> b)
  := (@opyon_equiv A^op _ _ _ _ a b).


(************************************************************
* Lambda-calculus with exceptions and sums,                 *
* Syntax                                                    *
*************************************************************)

Set Implicit Arguments.
Require Export LibVar Common.

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

(************************************************************)
(* ** Syntax *)

(** Grammar of values and terms *)

Inductive val : Type :=
  | val_int : int -> val
  | val_abs : var -> trm -> val
  | val_inj : bool -> val -> val

with trm : Type :=
  | trm_val : val -> trm
  | trm_var : var -> trm
  | trm_abs : var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_inj : bool -> trm -> trm
  | trm_case : trm -> trm -> trm -> trm
  | trm_try : trm -> trm -> trm
  | trm_raise : trm -> trm.

Coercion trm_val : val >-> trm.
Implicit Types v : val.
Implicit Types t : trm.

(** Substitution *)

Fixpoint subst (x:var) (v:val) (t:trm) : trm :=
  let s := subst x v in
  match t with
  | trm_val v1 => trm_val v1
  | trm_var y => If x = y then v else t
  | trm_abs y t3 => trm_abs y (If x = y then t3 else s t3)
  | trm_app t1 t2 => trm_app (s t1) (s t2)
  | trm_inj b t1 => trm_inj b (s t1)
  | trm_case t1 t2 t3 => trm_case (s t1) (s t2) (s t3)
  | trm_try t1 t2 => trm_try (s t1) (s t2)
  | trm_raise t1 => trm_raise (s t1)
  end.

(************************************************************)
(* ** Freshness *)

(** Two modes for freshness: "not used" and "not free" *)

Inductive vars_opt := not_used | not_free.

Definition add_bound f E (x:var) :=
  match f with
  | not_used => E \u \{x}
  | not_free => E \- \{x}
  end.

(** Set of free variables and used variables *)

Fixpoint trm_vars (f:vars_opt) (t:trm) : vars :=
  let r := trm_vars f in
  match t with
  | trm_val v1 => val_vars f v1
  | trm_var x => \{x}
  | trm_abs x t1 => add_bound f (r t1) x
  | trm_app t1 t2 => (r t1) \u (r t2)
  | trm_inj b t1 => (r t1)
  | trm_case t1 t2 t3 => (r t1) \u (r t2) \u (r t3)
  | trm_try t1 t2 => (r t1) \u (r t2)
  | trm_raise t1 => (r t1)
  end

with val_vars (f:vars_opt) (v:val) : vars :=
  match v with
  | val_int n => \{}
  | val_abs x t1 => add_bound f (trm_vars f t1) x
  | val_inj b v1 => val_vars f v1
  end.

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

(************************************************************)
(* ** Specific lemmas for reasoning on sets of variables *)

Lemma notin_remove : forall A x (E F:fset A),
  x \notin (E \- F) = (x \notin E \/ x \in F).
Proof.
  intros. unfolds notin. rewrite in_remove.
  unfolds notin. rew_logic*.
Qed.

Lemma notin_remove_l : forall A x (E F:fset A),
  x \notin (E \- F) -> x \notin E \/ x \in F.
Proof. introv H. rewrite~ notin_remove in H. Qed.

Lemma notin_remove_r : forall A x (E F:fset A),
  (x \notin E \/ x \in F) -> x \notin (E \- F).
Proof. introv H. rewrite~ notin_remove. Qed.

Lemma notin_remove_inv : forall A x (E F:fset A),
  x \notin (E \- F) -> x \notin F -> x \notin E.
Proof. introv H1 H2. destruct~ (notin_remove_l H1). false. Qed.

Lemma notin_remove_weaken : forall E F (x:var),
  x \notin E ->
  x \notin (E \- F).
Proof. intros. applys~ notin_remove_r. Qed.

Lemma notin_to_fresh : forall xs n E F,
  fresh E n xs ->
  (forall x, x \notin E -> x \notin F) ->
  fresh F n xs.
Proof.
  induction xs; introv Fr H.
  auto.
  destruct n. false. simpls. destruct Fr.
   split~. applys* IHxs.
Qed.

Lemma fresh_remove_weaken : forall E F n xs,
  fresh E n xs ->
  fresh (E \- F) n xs.
Proof.
  intros. applys* notin_to_fresh. applys* notin_remove_weaken.
Qed.

Lemma remove_self : forall A (E:fset A),
  E \- E = \{}.
Proof.
  intros. applys fset_extens; intros x H.
  rewrite in_remove in H. false*.
  rewrite in_empty in H. false.
Qed.

Lemma union_remove : forall A (E F:fset A),
  (forall x, x \in E -> x \notin F) ->
  (E \u F) \- F = E.
Proof.
  introv M. applys fset_extens; intros x H.
  rewrite in_remove, in_union in H. destruct H as [[?|?] ?].
    auto.
    false*.
  rewrite in_remove, in_union. auto.
Qed.

Lemma union_remove' : forall A (E F:fset A),
  (forall x, x \in E -> x \notin F) ->
  (F \u E) \- F = E.
Proof.
  introv M. applys fset_extens; intros x H.
  rewrite in_remove, in_union in H. destruct H as [[?|?] ?].
    false*.
    auto.
  rewrite in_remove, in_union. auto.
Qed.

Hint Rewrite union_empty_l union_empty_r remove_self : fset_simpl.
Ltac fset_simpl := autorewrite with fset_simpl.

Lemma notin_elim_single : forall A (y:A) (E:fset A),
  y \notin E ->
 (forall x, x \in E -> x \notin \{y}).
Proof.
  introv H M. rewrite notin_singleton. intro_subst. false.
Qed.

Lemma notin_remove_single_inv : forall A x y (E:fset A),
  x \notin (E \- \{y}) -> x <> y -> x \notin E.
Proof.
  introv H1 H2. applys* notin_remove_inv.
  rewrite~ notin_singleton.
Qed.

(************************************************************)
(* ** Freshness *)

(** Properties of [add_bound] *)

Lemma notin_add_bound : forall x f y E,
  x \notin add_bound f E y ->
  x \notin E \- \{y}.
Proof.
  intros. destruct f; simpls.
  applys~ notin_remove_weaken.
  auto.
Qed.

(** Substitution is the identity function on fresh vars *)

Lemma subst_id : forall f x v t,
  x \notin trm_vars f t ->
  subst x v t = t.
Proof.
  induction t; introv F; simpls; fequals~.
  case_if*. subst. notin_false.
  case_if*. applys IHt. destruct f; simpls~.
   applys~ notin_remove_inv F.
Qed.

Lemma subst_notin : forall t x y v,
  x \notin (trm_vars not_used t) ->
  x \notin (val_vars not_used v) ->
  x \notin (trm_vars not_used (subst y v t)).
Proof. induction t; introv Frt Frv; simpls~; try case_if*. Qed.

Lemma fresh_subst : forall xs n t y v,
  fresh (trm_vars not_used t) n xs ->
  fresh (val_vars not_used v) n xs ->
  fresh (trm_vars not_used (subst y v t)) n xs.
Proof.
  induction xs; introv Frt Frv.
  auto.
  destruct n. false. simpls.
   destruct Frt. destruct Frv.
   hint subst_notin. auto.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Locate "+".
Locate "_ + _".
Print Init.Nat.add.

(* Equality between Strings *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, eqb_string s s = true.
Proof.
  intro s. unfold eqb_string.
  destruct (string_dec s s) as [Heq | Hne].
  - reflexivity.
  - destruct Hne. reflexivity. Qed.

Theorem eqb_string_true_iff : forall (x y : string),
    eqb_string x y = true <-> x = y.
Proof.
  intros x y. split.
  - unfold eqb_string. destruct (string_dec x y) as [Heq | Hne].
    + intro. apply Heq.
    + discriminate.
  - intro Heq. rewrite Heq. apply eqb_string_refl. Qed.

Theorem eqb_string_false_iff : forall (x y : string),
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(* Total Maps *)

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

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

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

Notation "'_' !-> v" := (t_empty v)
                            (at level 100, right associativity).
Notation "x !-> v ; m" := (t_update m x v)
                                (at level 100, v at next level, right associativity).

Definition example_empty := (_ !-> false).
Definition example_map :=
  ( "bar" !-> true
  ; "foo" !-> true
  ; _     !-> false
  ).

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof. intros A x v. unfold t_empty. reflexivity. Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) (x : string) (v : A),
    (x !-> v; m) x = v.
Proof.
  intros A m x v. unfold t_update. rewrite eqb_string_refl.
  reflexivity. Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) (x1 x2 : string) (v : A),
    x1 <> x2 -> (x1 !-> v; m) x2 = m x2.
Proof.
  intros A m x1 x2 v Hne. unfold t_update.
  rewrite <- eqb_string_false_iff in Hne. rewrite Hne. reflexivity. Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2; x !-> v1; m) = (x !-> v2; m).
Proof.
  intros A m x v1 v2. apply functional_extensionality. intro x'.
  unfold t_update. destruct (eqb_string x x') as [Heq | Hne].
  - reflexivity.
  - reflexivity. Qed.

Lemma eqb_stringP : forall (x y : string),
    reflect (x = y) (eqb_string x y).
Proof.
  intros x y. destruct (eqb_string x y) eqn:E.
  - apply ReflectT. rewrite <- eqb_string_true_iff. apply E.
  - apply ReflectF. rewrite <- eqb_string_true_iff. intro nE.
    rewrite E in nE. discriminate. Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x; m) = m.
Proof.
  intros A m x. apply functional_extensionality. intro x'.
  unfold t_update. destruct (eqb_stringP x x') as [Heq | Hne].
  - rewrite Heq. reflexivity.
  - reflexivity. Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A) v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1; x2 !-> v2; m) =
    (x2 !-> v2; x1 !-> v1; m).
Proof.
  intros A m v1 v2 x1 x2 Hxne. apply functional_extensionality. intro x.
  unfold t_update. destruct (eqb_stringP x1 x) as [E1 | nE1].
  - destruct (eqb_stringP x2 x) as [E2 | nE2].
    + rewrite E1 in Hxne. rewrite E2 in Hxne. destruct Hxne. reflexivity.
    + reflexivity.
  - reflexivity. Qed.

(* Partial Maps *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A := _ !-> None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) : partial_map A := (x !-> Some v; m).

Notation "x |-> v ; m" := (update m x v)
                            (at level 100, v at next level, right associativity).

Notation "x |-> v" := (update empty x v)
                        (at level 100).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof. intros A x. unfold empty. apply t_apply_empty. Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) (x : string) (v : A),
    (x |-> v; m) x = Some v.
Proof. intros A m x v. unfold update. apply t_update_eq. Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) (x1 x2 : string) (v : A),
    x2 <> x1 ->
    (x2 |-> v; m) x1 = m x1.
Proof.
  intros A m x1 x2 v Hne. unfold update.
  apply t_update_neq. apply Hne. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2; x |-> v1; m) = (x |-> v2; m).
Proof. intros A m x v1 v2. unfold update. apply t_update_shadow. Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same. Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A) v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 |-> v1; x2 |-> v2; m) =
    (x2 |-> v2; x1 |-> v1; m).
Proof.
  intros A m v1 v2 x1 x2 Hne. unfold update.
  apply t_update_permute. apply Hne. Qed.

Definition inclusion {A : Type} (m m' : partial_map A) : Prop :=
  forall (x : string) (v : A), m x = Some v -> m' x = Some v.

Lemma inclusion_update : forall (A : Type) (m m' : partial_map A)
                           (x : string) (v : A),
    inclusion m m' ->
    inclusion (x |-> v; m) (x |-> v; m').
Proof.
  intros A m m' x v H. unfold inclusion in *. intros x0 v0.
  unfold update. unfold t_update.
  destruct (eqb_stringP x x0).
  - trivial.
  - apply (H x0 v0). Qed.


From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.TM.Util Require Import TM_facts.

Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes.

Import L_Notations.

(* ** Extraction of Turing Machine interpreter  *)

Import GenEncode.
MetaCoq Run (tmGenEncodeInj "move_enc" move).
#[export] Hint Resolve move_enc_correct : Lrewrite.

Import TM.
Local Notation L := TM.Lmove.
Local Notation R := TM.Rmove.
Local Notation N := TM.Nmove.

Definition move_eqb (m n : move) : bool :=
  match m,n with
    N,N => true
  | L,L => true
  | R,R => true
  | _,_ => false
  end.

Lemma move_eqb_spec x y : reflect (x = y) (move_eqb x y).
Proof.
  destruct x, y;constructor. all:easy.
Qed.

#[export]
Instance eqb_move:
  eqbClass move_eqb.
Proof.
  intros ? ?. eapply move_eqb_spec.
Qed.

#[export]
Instance eqbComp_bool : eqbComp move.
Proof.
  constructor. unfold move_eqb.
  extract.
Qed.

(* *** Encoding Tapes *)
Section reg_tapes.
  Variable sig : Type.
  Context `{reg_sig : encodable sig}.

  Implicit Type (t : TM.tape sig).
  Import GenEncode.
  MetaCoq Run (tmGenEncode "tape_enc" (TM.tape sig)).
  Hint Resolve tape_enc_correct : Lrewrite.

  #[export] Instance encInj_tape_enc {H : encInj reg_sig} : encInj (encodable_tape_enc).
  Proof. register_inj. Qed.

  (*Internalize constructors **)

  #[export] Instance term_leftof : computable (@leftof sig).
  Proof.
    extract constructor.
  Qed.

  #[export] Instance term_rightof : computable (@rightof sig).
  Proof.
    extract constructor.
  Qed.

  #[export] Instance term_midtape : computable (@midtape sig).
  Proof.
    extract constructor.
  Qed.

End reg_tapes.

Section fix_sig.
  Variable sig : finType.
  Context `{reg_sig : encodable sig}.

  Definition mconfigAsPair {B : finType} {n} (c:mconfig sig B n):= let (x,y) := c in (x,y).

  #[export] Instance encodable_mconfig (B : finType) `{encodable B} n: encodable (mconfig sig B n).
  Proof using reg_sig.
    eapply (registerAs mconfigAsPair).
  Defined.

  #[export] Instance term_mconfigAsPair (B : finType) `{encodable B} n: computable (@mconfigAsPair B n).
  Proof.
    apply cast_computable.
  Qed.

  #[export] Instance term_cstate (B : finType) `{encodable B} n: computable (@cstate sig B n).
  Proof.
    apply computableExt with (x:=fun x => fst (mconfigAsPair x)).
    2:{extract. }
    intros [];reflexivity.
  Qed.

  #[export] Instance term_ctapes (B : finType) `{encodable B} n: computable (@ctapes sig B n).
  Proof.
    apply computableExt with (x:=fun x => snd (mconfigAsPair x)).
    2:{extract. }
    intros [];reflexivity.
  Qed.

  #[export] Instance encodable_mk_mconfig (B : finType) `{encodable B} n: computable (@mk_mconfig sig B n).
  Proof.
    computable_casted_result.
    extract.
  Qed.
End fix_sig.

#[export] Hint Resolve tape_enc_correct : Lrewrite.


Require Export Iron.Language.DelayedSimpleUS.Base.
Require Export Iron.Language.DelayedSimpleUS.Ty.

(********************************************************************)
(* Value Expressions *)
Inductive exp : Type :=
 (* Variables want to be named. *)
 | XVar    (v: name) : exp

 (* Function abstraction. *)
 | XAbs    (ss: @env exp) (v: name) (t: ty) (x: exp) : exp

 (* Function application. *)
 | XApp    (x1: exp) (x2: exp) : exp.

Hint Constructors exp.

(* A substitution is an environment of expression bindings. *)
Definition substx := @env exp.

(* Indirect induction principle for expressions.

   In the definition of 'exp', abstractions contain a list of
   subexpressions, so 'exp' is indirectly defined via the list
   data type.

   In the following induction principle, when proving a property
   of abstractions we know the property being proved applies to
   subexpressions contained in those lists. The automatically
   generated induction principle 'exp_ind' doesn't give us this.
*)
Theorem exp_iind
 : forall
    (PX : exp -> Prop)

 ,  (  forall n
    ,  PX (XVar n))

 -> (  forall ss n t x
    ,  Forall (fun b => PX (expOfBind b)) ss
    -> PX x
    -> PX (XAbs ss n t x))

 -> (  forall x1 x2
    ,  PX x1  -> PX x2
    -> PX (XApp x1 x2))

 -> forall  x, PX x.
Proof.
 intros PX.
 intros Hvar Habs Happ.
 refine (fix IHX x: PX x := _).

 case x; intros.
 - apply Hvar.
 - eapply Habs.
   induction ss as [| b].
   + apply Forall_nil.
   + apply Forall_cons.
     * destruct b. simpl. eapply IHX.
     * assumption.
   + apply IHX.
 - apply Happ.
   + apply IHX.
   + apply IHX.
Qed.

(********************************************************************)
(* Values *)
Inductive Value : exp -> Prop :=
 | ValueAbs
   :  forall ss v t x
   ,  Value (XAbs ss v t x).

Hint Constructors Value.

Lemma isValue_not_var
 : forall v
 , ~Value (XVar v).
Proof.
 intros. intuition. inverts H.
Qed.
Hint Resolve isValue_not_var.

Lemma isValue_not_app
 : forall x1 x2
 , ~Value (XApp x1 x2).
Proof.
 intros. intuition. inverts H.
Qed.
Hint Resolve isValue_not_app.

(* Done expressions have finished evaluating. *)
Inductive Done  : exp -> Prop :=
 | DoneVar
   :  forall v
   ,  Done (XVar v)

 | DoneValue
   :  forall x
   ,  Value  x
   -> Done   x

 | DoneApp
   :  forall x1 x2
   ,  Done x1 /\ ~Value x1
   -> Done (XApp x1 x2).

Hint Constructors Done.

(* Invert all hypothesis that are compound done statements. *)
Ltac inverts_done :=
 repeat
  (match goal with
   | [ H: Done (XApp _ _) |- _ ] => inverts H
   end).


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Export Domains.notations.

(** * Setoids and equality.

      This module introduces setoids, which consist of a type packaged together with
      an equivalence relation.  We roughly follow the techniques described in the paper
      _Packaging Mathematical Structures_ by Garillot et al. (TPHOLS 2009).  The mainstay
      of this technique is using canonoical structures to automatically infer structures
      given the carrier type.

      We use the symbol ≈ to indicate the equality relation on setoids.  For the vast
      majority of this development, ≈ will be the notion of equivalence of interest.
  *)

Delimit Scope equiv_scope with eq.
Open Scope equiv_scope.

Module Eq.
  Record mixin_of (T:Type) :=
    Mixin
    { eq : T -> T -> Prop
    ; refl : forall x, eq x x
    ; symm : forall x y, eq x y -> eq y x
    ; trans : forall x y z,
             eq x y -> eq y z -> eq x z
    }.
  Structure type : Type :=
    Pack { carrier :> Type ; mixin : mixin_of carrier }.

End Eq.
Definition eq_op T := Eq.eq _ (Eq.mixin T).
Notation "x ≈ y" := (@eq_op _ x y) : equiv_scope.
Notation "x ≉ y" := (~(@eq_op _ x y)) : equiv_scope.
Coercion Eq.carrier : Eq.type >-> Sortclass.

Lemma eq_refl : forall (T:Eq.type) (x:T), x ≈ x.
Proof.
  intros. destruct T. destruct mixin. apply refl.
Qed.

Lemma eq_trans : forall (T:Eq.type) (x y z:T), x ≈ y -> y ≈ z -> x ≈ z.
Proof.
  intros. destruct T. destruct mixin. eapply trans; eauto.
Qed.

Lemma eq_symm : forall (T:Eq.type) (x y:T), x ≈ y -> y ≈ x.
Proof.
  intros. destruct T. destruct mixin. eapply symm; eauto.
Qed.

Hint Resolve eq_refl eq_symm eq_trans.

Add Parametric Relation (T:Eq.type) : (Eq.carrier T) (@eq_op T)
  reflexivity proved by (@eq_refl T)
  symmetry proved by (@eq_symm T)
  transitivity proved by (@eq_trans T)
  as eq_op_rel.

Record eq_dec (T:Eq.type) :=
    EqDec
    { eqdec :> forall x y:T, {x ≈ y}+{x ≉ y} }.

Arguments eqdec [T] [e] x y.


Require Import TraceModel.
Require Import CommonST.

Axiom src : language.

Definition semp (P:par src) (t : trace) := exists C, sem src (C[P]) t.
Definition semc (C:ctx src) (t : trace) := exists P, sem src (C[P]) t.

Definition trace_equiv P1 P2 := forall t, semp P1 t <-> semp P2 t.

Definition obs_equiv P1 P2 := forall C t, sem src (C[P1]) t <-> sem src (C[P2]) t.

Definition fats := forall P1 P2, trace_equiv P1 P2 <-> obs_equiv P1 P2.

(* In this model fats_rtl and decomposition are trivial *)

Lemma fats_rtl : forall P1 P2, obs_equiv P1 P2 -> trace_equiv P1 P2.
Proof.
  unfold obs_equiv, trace_equiv, semp. intros P1 P2 Hobs t.
  split; intros [C H].
  - rewrite -> Hobs in H. eauto.
  - rewrite <- Hobs in H. eauto.
Qed.

Lemma decomposition : forall C P t, sem src (C[P]) t -> (semp P t /\ semc C t).
Proof.
  unfold semp, semc. eauto.
Qed.

(* Composition is not trivial though *)

Definition composition := forall C P t, semp P t -> semc C t -> sem src (C[P]) t.

Lemma composition_trivial : composition.
Proof.
  unfold composition, semp, semc.
  intros C P m [C' H1] [P' H2].
Abort. (* what we are left with looks like recomposition *)

(* Composition follows from recomposition *)

Definition recomposition := forall C1 P1 C2 P2 t,
    sem src (C1[P1]) t -> sem src (C2[P2]) t -> sem src (C1[P2]) t.

Lemma recomposition_composition : recomposition -> composition.
Proof.
  unfold recomposition, composition, semp, semc.
  intros Hrecomp C P m [C' H1] [P' H2]. eapply Hrecomp; eassumption.
Qed.

(* Recomposition also follows from composition *)

Lemma composition_recomposition : composition -> recomposition.
Proof.
  unfold recomposition, composition, semp, semc.
  intros Hcomp C1 P1 C2 P2 t H0 H1.
  apply Hcomp; eexists; eassumption.
Qed.

(* FATs follows from recomposition *)

Lemma recomposition_fats : recomposition -> fats.
Proof.
  unfold recomposition, fats, trace_equiv, obs_equiv, semp.
  intros Hrecomp P1 P2. split; [| now apply fats_rtl].
  intros Htequiv C t. split; intro Hsem.
  - assert (H: exists C : ctx src, sem src (C [P1]) t) by eauto.
    rewrite -> Htequiv in H. destruct H as [C' H]. eapply Hrecomp; eassumption.
  - assert (H: exists C : ctx src, sem src (C [P2]) t) by eauto.
    rewrite <- Htequiv in H. destruct H as [C' H]. eapply Hrecomp; eassumption.
Qed.


(** NetKAT Packets *)
Require Export Field Value Classes.

Module Type PACKET (F : FIELDSPEC) (V : VALUESPEC(F)).
  Definition t : Type := forall f:F.t, (V.t f).
  Parameter finite : Finite t.
  Parameter eq_dec : EqType t.
  Global Instance : Finite t := finite.
  Global Instance : EqType t := eq_dec.
  Parameter mod : t -> forall f : F.t, V.t f -> t.
End PACKET.

Module Packet (F : FIELDSPEC) (V : VALUESPEC(F)) : PACKET(F)(V).

  Definition t : Type := forall f:F.t, (V.t f).

  (* feel the power of automatic instance resolution...!! *)
  Definition finite : Finite t := _.
  Definition eq_dec : EqType t := dep_fun_EqType _ _.
  Global Instance : Finite t := finite.
  Global Instance : EqType t := eq_dec.

  Program Definition mod (pk : t) (f : F.t) (v : V.t f) : t :=
    fun f' => if (f' =d= f)%bool then v else pk f'.

End Packet.


Require Import Iron.SimplePCFa.Value.Exp.
Require Import Iron.SimplePCFa.Value.Lift.

(* Substitute for the outer-most binder in an expression *)
Fixpoint substVV (d: nat) (u: val) (vv: val) :=
  match vv with
  | VVar ix
  => match nat_compare ix d with
     | Eq  => u
     | Gt  => VVar (ix - 1)
     | Lt  => VVar ix
     end
  | VConst c     => VConst c
  | VLam t x     => VLam t (substVX (S d) (liftXV 0 u) x)
  | VFix t v     => VFix t (substVV (S d) (liftXV 0 u) v)
  end

with    substVX (d: nat) (u: val) (xx: exp) :=
  match xx with
  | XVal v       => XVal   (substVV d u v)
  | XLet t x1 x2 => XLet t (substVX d u x1) (substVX (S d) (liftXV 0 u) x2)
  | XApp v1 v2   => XApp   (substVV d u v1) (substVV d u v2)
  | XOp1 o v     => XOp1 o (substVV d u v)
  | XIf v1 x2 x3 => XIf    (substVV d u v1) (substVX d u x2) (substVX d u x3)
  end.


Require Import HoTT.
From HoTT.Categories Require Import
     Category Functor NaturalTransformation FunctorCategory.
From GR.bicategories Require Import
     general_category
     bicategory.bicategory
     bicategory.examples.full_sub
     bicategory.adjoint
     bicategory.univalent
     bicategory.locally_strict
     bicategory.strict
     lax_functor.lax_functor.

Definition image
           {C D : BiCategory}
           (F : LaxFunctor C D)
  : BiCategory
  := full_sub D (fun Y => merely {X : C & F X = Y }).

Global Instance univalent_image
       `{Univalence}
       {C D : BiCategory}
       `{@Univalent _ D}
       (F : LaxFunctor C D)
  : Univalent (image F)
  := _.

Global Instance is_2category_image
       {C D : BiCategory}
       `{is_2category D}
       (F : LaxFunctor C D)
  : is_2category (image F).
Proof.
  apply is_2category_full_sub.
  apply _.
Defined.


Require Coq.Logic.Eqdep_dec.
Require Import Coq.NArith.NArith.
Require Import Coq.Arith.Arith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.micromega.Lia.
Import Nat.

Scheme Equality for nat.
(* We would use [Scheme Minimality for nat Sort Type.], but we want
   [nat_rect_nodep] to unfold directly to [nat_rect] so that
   unification doesn't have a hard time unifying [nat_rect] and
   [nat_rect_nodep] on large arguments. *)
Definition nat_rect_nodep {P} : P -> (nat -> P -> P) -> nat -> P
  := nat_rect (fun _ => P).
Definition nat_rect_arrow_nodep {P Q} := @nat_rect_nodep (P -> Q).

Global Instance nat_rect_nodep_Proper {P}
  : Proper (Logic.eq ==> (Logic.eq ==> Logic.eq ==> Logic.eq) ==> Logic.eq ==> Logic.eq) (@nat_rect_nodep P) | 10.
Proof.
  cbv [Proper respectful nat_rect_nodep].
  intros x y ???? n m ?; subst m y.
  revert x; induction n; cbn; intros; auto.
Qed.

Global Instance nat_rect_arrow_nodep_Proper {P Q}
  : Proper ((Logic.eq ==> Logic.eq) ==> (Logic.eq ==> (Logic.eq ==> Logic.eq) ==> Logic.eq ==> Logic.eq) ==> Logic.eq ==> Logic.eq ==> Logic.eq) (@nat_rect_arrow_nodep P Q) | 10.
Proof.
  cbv [Proper respectful nat_rect_nodep].
  intros ??? ??? n m ?; subst m.
  induction n; cbn; intros; eauto.
Qed.

Module Thunked.
  Definition nat_rect P (O_case : unit -> P) (S_case : nat -> P -> P) (n : nat) : P
    := Datatypes.nat_rect (fun _ => P) (O_case tt) S_case n.

  Global Instance nat_rect_Proper {P}
    : Proper ((Logic.eq ==> Logic.eq) ==> (Logic.eq ==> Logic.eq ==> Logic.eq) ==> Logic.eq ==> Logic.eq) (@nat_rect P) | 10.
  Proof.
    repeat intro; eapply nat_rect_nodep_Proper; eauto.
  Qed.
End Thunked.
(** Strongly prefer unfolding these versions of [nat_rect] to the
    underlying [nat_rect] principle.  Possibly -1 would suffice rather
    than expand, but I don't think there's harm in [expand] because
    [nat_rect] ought not be much more complicated than any of these *)
Global Strategy expand [nat_rect_arrow_nodep nat_rect_nodep Thunked.nat_rect].

Create HintDb natsimplify discriminated.

Global Hint Resolve mod_bound_pos plus_le_compat : arith.
#[global] Hint Rewrite @mod_small @mod_mod @mod_1_l @mod_1_r succ_pred using lia : natsimplify.

#[global] Hint Rewrite sub_diag add_0_l add_0_r sub_0_r sub_succ : natsimplify.

Local Open Scope nat_scope.

Lemma mod_bound_nonneg x y : 0 <= x mod y.
Proof.
  now apply Nat.le_0_l.
Qed.

Lemma mod_bound_lt x y : 0 < y -> x mod y < y.
Proof. apply Nat.mod_bound_pos; lia. Qed.

Global Hint Resolve mod_bound_nonneg mod_bound_lt : arith.

Lemma min_def {x y} : min x y = x - (x - y).
Proof. apply Min.min_case_strong; lia. Qed.
Lemma max_def {x y} : max x y = x + (y - x).
Proof. apply Max.max_case_strong; lia. Qed.
Ltac coq_lia := lia.
Ltac handle_min_max_for_lia_gen min max :=
  repeat match goal with
         | [ H : context[min _ _] |- _ ] => rewrite !min_def in H || setoid_rewrite min_def in H
         | [ H : context[max _ _] |- _ ] => rewrite !max_def in H || setoid_rewrite max_def in H
         | [ |- context[min _ _] ] => rewrite !min_def || setoid_rewrite min_def
         | [ |- context[max _ _] ] => rewrite !max_def || setoid_rewrite max_def
         end.
Ltac handle_min_max_for_lia_case_gen min max :=
  repeat match goal with
         | [ H : context[min _ _] |- _ ] => revert H
         | [ H : context[max _ _] |- _ ] => revert H
         | [ |- context[min _ _] ] => apply Min.min_case_strong
         | [ |- context[max _ _] ] => apply Max.max_case_strong
         end;
  intros.
Ltac handle_min_max_for_lia := handle_min_max_for_lia_gen min max.
Ltac handle_min_max_for_lia_case := handle_min_max_for_lia_case_gen min max.
(* In 8.4, Nat.min is a definition, so we need to unfold it *)
Ltac handle_min_max_for_lia_compat_84 :=
  let min := (eval cbv [min] in min) in
  let max := (eval cbv [max] in max) in
  handle_min_max_for_lia_gen min max.
Ltac handle_min_max_for_lia_case_compat_84 :=
  let min := (eval cbv [min] in min) in
  let max := (eval cbv [max] in max) in
  handle_min_max_for_lia_case_gen min max.
Ltac lia_with_min_max :=
  handle_min_max_for_lia;
  try handle_min_max_for_lia_compat_84;
  lia.
Ltac lia_with_min_max_case :=
  handle_min_max_for_lia_case;
  try handle_min_max_for_lia_case_compat_84;
  lia.
Tactic Notation "lia" := coq_lia.
Tactic Notation "lia" "*" := lia_with_min_max_case.
Tactic Notation "lia" "**" := lia_with_min_max.

Global Instance nat_rect_Proper {P} : Proper (Logic.eq ==> forall_relation (fun _ => forall_relation (fun _ => Logic.eq)) ==> forall_relation (fun _ => Logic.eq)) (@nat_rect P).
Proof.
  cbv [forall_relation]; intros O_case O_case' ? S_case S_case' HS n; subst O_case'; revert O_case.
  induction n as [|n IHn]; cbn [nat_rect]; intro; rewrite ?IHn, ?HS; reflexivity.
Qed.
Global Instance nat_rect_Proper_nondep {P} : Proper (Logic.eq ==> pointwise_relation _ (pointwise_relation _ Logic.eq) ==> Logic.eq ==> Logic.eq) (@nat_rect (fun _ => P)).
Proof. repeat intro; subst; apply (@nat_rect_Proper (fun _ => P)); eauto. Qed.

Global Instance nat_rect_Proper_nondep_gen {P} (R : relation P) : Proper (R ==> (Logic.eq ==> R ==> R) ==> Logic.eq ==> R) (@nat_rect (fun _ => P)) | 100.
Proof.
  cbv [forall_relation respectful]; intros O_case O_case' HO S_case S_case' HS n n' ?; subst n'; revert O_case O_case' HO.
  induction n as [|n IHn]; cbn [nat_rect]; intros; eauto.
Qed.

Lemma nat_eq_dec_S x y
  : match nat_eq_dec (S x) (S y), nat_eq_dec x y with
    | left pfS, left pf => pfS = f_equal S pf
    | right _, right _ => True
    | _, _ => False
    end.
Proof.
  unfold nat_eq_dec; simpl.
  match goal with
  | [ |- match match ?e with _ => _ end with _ => _ end ]
    => destruct e
  end; simpl; try exact I.
  reflexivity.
Defined.

Lemma UIP_nat_transparent x y (p1 p2 : x = y :> nat) : p1 = p2.
Proof.
  transitivity (match nat_eq_dec x y, nat_eq_dec y y with
                | left pf1, left pf2 => eq_trans pf1 (eq_sym pf2)
                | _, _ => p1
                end);
    [ revert p2 | revert p1 ];
    subst y; intro p;
      destruct (nat_eq_dec x x) as [q|q]; case q; reflexivity.
Defined.

Lemma nat_beq_false_iff x y : nat_beq x y = false <-> x <> y.
Proof.
  split; intro H; repeat intro; subst.
  { erewrite internal_nat_dec_lb in H by reflexivity; congruence. }
  { destruct (nat_beq x y) eqn:H'; [ | reflexivity ].
    apply internal_nat_dec_bl in H'; subst; congruence. }
Qed.

Ltac nat_beq_to_eq :=
  repeat match goal with
         | [ H : nat_beq _ _ = true |- _ ] => apply internal_nat_dec_bl in H
         | [ H : is_true (nat_beq _ _) = true |- _ ] => apply internal_nat_dec_bl in H
         | [ |- nat_beq _ _ = true ] => apply internal_nat_dec_lb
         | [ |- is_true (nat_beq _ _) ] => apply internal_nat_dec_lb
         | [ H : nat_beq _ _ = false |- _ ] => apply nat_beq_false_iff in H
         | [ |- nat_beq _ _ = false ] => apply nat_beq_false_iff
         end.

Lemma div_minus : forall a b, b <> 0 -> (a + b) / b = a / b + 1.
Proof.
  intros a b H.
  assert (H0 : b = 1 * b) by lia.
  rewrite H0 at 1.
  rewrite <- Nat.div_add by auto.
  reflexivity.
Qed.

Lemma pred_mod : forall m, (0 < m)%nat -> ((pred m) mod m)%nat = pred m.
Proof.
  intros m H; apply Nat.mod_small.
  destruct m; try lia; rewrite Nat.pred_succ; auto.
Qed.

Lemma div_add_l' : forall a b c, a <> 0 -> (a * b + c) / a = b + c / a.
Proof.
  intros; rewrite Nat.mul_comm; auto using div_add_l.
Qed.

Lemma mod_add_l : forall a b c, b <> 0 -> (a * b + c) mod b = c mod b.
Proof.
  intros; rewrite Nat.add_comm; auto using mod_add.
Qed.

Lemma mod_add_l' : forall a b c, b <> 0 -> (b * a + c) mod b = c mod b.
Proof.
  intros; rewrite Nat.mul_comm; auto using mod_add_l.
Qed.

Lemma mod_div_eq0 : forall a b, b <> 0 -> a mod b / b = 0.
Proof.
  intros; apply Nat.div_small, mod_bound_pos; lia.
Qed.

Lemma divide2_1mod4_nat : forall c x, c = x / 4 -> x mod 4 = 1 -> exists y, 2 * y = (x / 2).
Proof.
  assert (4 <> 0) as ne40 by lia.
  induction c; intros x H H0; pose proof (div_mod x 4 ne40) as H1; rewrite <- H in H1. {
    rewrite H0 in H1.
    simpl in H1.
    rewrite H1.
    exists 0; auto.
  } {
    rewrite mult_succ_r in H1.
    assert (4 <= x) as le4x by (apply Nat.div_str_pos_iff; lia).
    rewrite <- Nat.add_1_r in H.
    replace x with ((x - 4) + 4) in H by lia.
    rewrite div_minus in H by auto.
    apply Nat.add_cancel_r in H.
    replace x with ((x - 4) + (1 * 4)) in H0 by lia.
    rewrite Nat.mod_add in H0 by auto.
    pose proof (IHc _ H H0) as H2.
    destruct H2 as [x0 H2].
    exists (x0 + 1).
    rewrite <- (Nat.sub_add 4 x) in H1 at 1 by auto.
    replace (4 * c + 4 + x mod 4) with (4 * c + x mod 4 + 4) in H1 by lia.
    apply Nat.add_cancel_r in H1.
    replace (2 * (x0 + 1)) with (2 * x0 + 2)
      by (rewrite Nat.mul_add_distr_l; auto).
    rewrite H2.
    rewrite <- Nat.div_add by lia.
    f_equal.
    simpl.
    apply Nat.sub_add; auto.
  }
Qed.

Lemma Nat2N_inj_lt : forall n m, (N.of_nat n < N.of_nat m)%N <-> n < m.
Proof.
  split; intros. {
    rewrite nat_compare_lt.
    rewrite Nnat.Nat2N.inj_compare.
    rewrite N.compare_lt_iff; auto.
  } {
    rewrite <- N.compare_lt_iff.
    rewrite <- Nnat.Nat2N.inj_compare.
    rewrite <- nat_compare_lt; auto.
  }
Qed.

Lemma lt_min_l : forall x a b, (x < min a b)%nat -> (x < a)%nat.
Proof.
  intros ? ? ? lt_min.
  apply Nat.min_glb_lt_iff in lt_min.
  destruct lt_min; assumption.
Qed.

(* useful for hints *)
Lemma eq_le_incl_rev : forall a b, a = b -> b <= a.
Proof.
  intros; lia.
Qed.

Lemma beq_nat_eq_nat_dec {R} (x y : nat) (a b : R)
  : (if EqNat.beq_nat x y then a else b) = (if eq_nat_dec x y then a else b).
Proof.
  destruct (eq_nat_dec x y) as [H|H];
    [ rewrite (proj2 (@beq_nat_true_iff _ _) H); reflexivity
    | rewrite (proj2 (@beq_nat_false_iff _ _) H); reflexivity ].
Qed.

Lemma pow_nonzero a k : a <> 0 -> a ^ k <> 0.
Proof.
  intro; induction k; simpl; nia.
Qed.

Global Hint Resolve pow_nonzero : arith.

Lemma S_pred_nonzero : forall a, (a > 0 -> S (pred a) = a)%nat.
Proof.
  destruct a; simpl; lia.
Qed.

#[global] Hint Rewrite S_pred_nonzero using lia : natsimplify.

Lemma mod_same_eq a b : a <> 0 -> a = b -> b mod a = 0.
Proof. intros; subst; apply mod_same; assumption. Qed.

#[global] Hint Rewrite @mod_same_eq using lia : natsimplify.
Global Hint Resolve mod_same_eq : arith.

Lemma mod_mod_eq a b c : a <> 0 -> b = c mod a -> b mod a = b.
Proof. intros; subst; autorewrite with natsimplify; reflexivity. Qed.

#[global] Hint Rewrite @mod_mod_eq using (reflexivity || lia) : natsimplify.

Local Arguments minus !_ !_.

Lemma S_mod_full a b : a <> 0 -> (S b) mod a = if eq_nat_dec (S (b mod a)) a
                                               then 0
                                               else S (b mod a).
Proof.
  change (S b) with (1+b); intros.
  pose proof (mod_bound_pos b a).
  rewrite add_mod by assumption.
  destruct (eq_nat_dec (S (b mod a)) a) as [H'|H'];
    destruct a as [|[|a]]; autorewrite with natsimplify in *;
      try congruence; try reflexivity.
Qed.

#[global] Hint Rewrite S_mod_full using lia : natsimplify.

Lemma S_mod a b : a <> 0 -> S (b mod a) <> a -> (S b) mod a = S (b mod a).
Proof.
  intros; rewrite S_mod_full by assumption.
  edestruct eq_nat_dec; lia.
Qed.

#[global] Hint Rewrite S_mod using (lia || autorewrite with natsimplify; lia) : natsimplify.

Lemma eq_nat_dec_refl x : eq_nat_dec x x = left (Logic.eq_refl x).
Proof.
  edestruct eq_nat_dec; try congruence.
  apply f_equal, Eqdep_dec.UIP_dec, eq_nat_dec.
Qed.

#[global] Hint Rewrite eq_nat_dec_refl : natsimplify.

(** Helper to get around the lack of function extensionality *)
Definition eq_nat_dec_right_val n m (pf0 : n <> m) : { pf | eq_nat_dec n m = right pf }.
Proof.
  revert dependent n; induction m as [|m IHm]; destruct n as [|n]; simpl;
    intro pf0;
    [ (exists pf0; exfalso; abstract congruence)
    | eexists; reflexivity
    | eexists; reflexivity
    | ].
  { specialize (IHm n).
    destruct IHm as [? IHm]; [ lia | ].
    eexists; rewrite IHm; reflexivity. }
Qed.

Lemma eq_nat_dec_S_n n : eq_nat_dec (S n) n = right (proj1_sig (@eq_nat_dec_right_val _ _ (@neq_succ_diag_l n))).
Proof.
  edestruct eq_nat_dec_right_val; assumption.
Qed.

#[global] Hint Rewrite eq_nat_dec_S_n : natsimplify.

Lemma eq_nat_dec_n_S n : eq_nat_dec n (S n) = right (proj1_sig (@eq_nat_dec_right_val _ _ (n_Sn n))).
Proof.
  edestruct eq_nat_dec_right_val; assumption.
Qed.

#[global] Hint Rewrite eq_nat_dec_n_S : natsimplify.

#[global] Hint Rewrite Max.max_0_l Max.max_0_r Max.max_idempotent Min.min_0_l Min.min_0_r Min.min_idempotent : natsimplify.

(** Helper to get around the lack of function extensionality *)
Definition le_dec_right_val n m (pf0 : ~n <= m) : { pf | le_dec n m = right pf }.
Proof.
  destruct (le_dec n m) eqn:Heq; [ | eexists; reflexivity ].
  exfalso; clear Heq; apply pf0; assumption.
Qed.

(** Helper to get around the lack of function extensionality *)
Definition lt_dec_right_val n m (pf0 : ~n < m) : { pf | lt_dec n m = right pf }
  := @le_dec_right_val _ _ pf0.

Lemma lt_dec_irrefl n : lt_dec n n = right (proj1_sig (@lt_dec_right_val _ _ (lt_irrefl n))).
Proof. edestruct lt_dec_right_val; assumption. Qed.
#[global] Hint Rewrite lt_dec_irrefl : natsimplify.

Lemma not_lt_n_pred_n n : ~n < pred n.
Proof. destruct n; simpl; lia. Qed.

Lemma lt_dec_n_pred_n n : lt_dec n (pred n) = right (proj1_sig (@lt_dec_right_val _ _ (not_lt_n_pred_n n))).
Proof. edestruct lt_dec_right_val; assumption. Qed.
#[global] Hint Rewrite lt_dec_n_pred_n : natsimplify.

Lemma le_dec_refl n : le_dec n n = left (le_refl n).
Proof.
  edestruct le_dec; try ((idtac + exfalso); lia).
  apply f_equal, le_unique.
Qed.
#[global] Hint Rewrite le_dec_refl : natsimplify.

Lemma le_dec_pred_l n : le_dec (pred n) n = left (le_pred_l n).
Proof.
  edestruct le_dec; [ | destruct n; simpl in *; (idtac + exfalso); lia ].
  apply f_equal, le_unique.
Qed.
#[global] Hint Rewrite le_dec_pred_l : natsimplify.

Lemma le_pred_plus_same n : n <= pred (n + n).
Proof. destruct n; simpl; lia. Qed.

Lemma le_dec_pred_plus_same n : le_dec n (pred (n + n)) = left (le_pred_plus_same n).
Proof.
  edestruct le_dec; [ | destruct n; simpl in *; (idtac + exfalso); lia ].
  apply f_equal, le_unique.
Qed.
#[global] Hint Rewrite le_dec_pred_plus_same : natsimplify.

Lemma minus_S_diag x : (S x - x = 1)%nat.
Proof. lia. Qed.
#[global] Hint Rewrite minus_S_diag : natsimplify.

Lemma min_idempotent_S_l x : min (S x) x = x.
Proof. lia *. Qed.
#[global] Hint Rewrite min_idempotent_S_l : natsimplify.

Lemma min_idempotent_S_r x : min x (S x) = x.
Proof. lia *. Qed.
#[global] Hint Rewrite min_idempotent_S_r : natsimplify.

Lemma mod_pow_same b e : b <> 0 -> e <> 0 -> b^e mod b = 0.
Proof.
  intros; destruct e as [|e]; [ lia | simpl ].
  rewrite mul_comm, mod_mul by lia; lia.
Qed.

Lemma setbit_high : forall x i, (x < 2^i -> setbit x i = x + 2^i)%nat.
Proof.
  intros x i H; apply bits_inj; intro n.
  rewrite setbit_eqb.
  destruct (beq_nat i n) eqn:H'; simpl.
  { apply beq_nat_true in H'; subst.
    symmetry; apply testbit_true.
    rewrite div_minus, div_small by lia.
    reflexivity. }
  { assert (H'' : (((x + 2 ^ i) / 2 ^ n) mod 2) = ((x / 2 ^ n) mod 2)).
    { assert (2^(i-n) <> 0) by auto with arith.
      assert (2^(i-n) <> 0) by lia.
      destruct (lt_eq_lt_dec i n) as [ [?|?] | ? ]; [ | subst; rewrite <- beq_nat_refl in H'; congruence | ].
      { assert (i <= n - 1) by lia.
        assert (2^i <= 2^n) by auto using pow_le_mono_r with arith.
        assert (2^i <= 2^(n - 1)) by auto using pow_le_mono_r with arith.
        assert (2^(n-1) <> 0) by auto with arith.
        assert (2^(n-1) + 2^(n-1) = 2^n)
          by (transitivity (2^(S (n - 1))); [ simpl; lia | apply f_equal; lia ]).
        assert ((2^(n - 1) - 1) + (2^(n - 1)) < 2^n) by lia.
        rewrite !div_small; try lia. }
      { replace (2^i) with (2^(i - n) * 2^n)
          by (rewrite <- pow_add_r, ?le_plus_minus_r, ?sub_add by lia; lia).
        rewrite div_add by auto with arith.
        rewrite <- add_mod_idemp_r, mod_pow_same, add_0_r by lia.
        reflexivity. } }
    { match goal with
      | [ |- ?x = ?y ]
        => destruct x eqn:H0; destruct y eqn:H1; try reflexivity;
             try apply testbit_true in H0;
             try apply testbit_true in H1;
             first [ rewrite <- H0; clear H0 | rewrite <- H1; clear H1 ];
             first [ symmetry; apply testbit_true | apply testbit_true ]
      end;
        rewrite H'' in *; assumption. } }
Qed.

Lemma max_0_iff a b : Nat.max a b = 0%nat <-> (a = 0%nat /\ b = 0%nat).
Proof. lia **. Qed.

Lemma push_f_nat_rect {P P'} (f : P -> P') PO PS PS' n
      (HS : forall x rec, f (PS x rec)
                          = PS' x (f rec))
  : f (nat_rect (fun _ => P) PO PS n)
    = nat_rect
        (fun _ => _)
        (f PO)
        PS'
        n.
Proof.
  induction n as [|n IHn]; cbn [nat_rect]; [ reflexivity | ].
  rewrite HS, IHn; reflexivity.
Qed.

Lemma push_f_nat_rect_arrow {P P'} (f : P -> P') {A} PO PS PS' n v
      (HS : forall x rec v, f (PS x rec v)
                            = PS' x (fun v => f (rec v)) v)
      (PS'_Proper : Proper (Logic.eq ==> pointwise_relation _ Logic.eq ==> Logic.eq ==> Logic.eq) PS')
  : f (nat_rect (fun _ => A -> P) PO PS n v)
    = nat_rect
        (fun _ => _)
        (fun v => f (PO v))
        PS'
        n
        v.
Proof.
  revert v; induction n as [|n IHn]; cbn [nat_rect]; [ reflexivity | ]; intro.
  rewrite HS; apply PS'_Proper; eauto.
Qed.

Lemma min_x_xy x y : Nat.min x (Nat.min x y) = Nat.min x y.
Proof. now rewrite Nat.min_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite min_x_xy : natsimplify.

Lemma min_x_yx x y : Nat.min x (Nat.min y x) = Nat.min x y.
Proof. now rewrite Nat.min_comm, <- Nat.min_assoc, Nat.min_comm; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite min_x_yx : natsimplify.

Lemma min_xy_x x y : Nat.min (Nat.min x y) x = Nat.min x y.
Proof. now rewrite Nat.min_comm, Nat.min_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite min_xy_x : natsimplify.

Lemma min_yx_x x y : Nat.min (Nat.min y x) x = Nat.min y x.
Proof. now rewrite <- Nat.min_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite min_yx_x : natsimplify.

Lemma max_x_xy x y : Nat.max x (Nat.max x y) = Nat.max x y.
Proof. now rewrite Nat.max_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite max_x_xy : natsimplify.

Lemma max_x_yx x y : Nat.max x (Nat.max y x) = Nat.max x y.
Proof. now rewrite Nat.max_comm, <- Nat.max_assoc, Nat.max_comm; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite max_x_yx : natsimplify.

Lemma max_xy_x x y : Nat.max (Nat.max x y) x = Nat.max x y.
Proof. now rewrite Nat.max_comm, Nat.max_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite max_xy_x : natsimplify.

Lemma max_yx_x x y : Nat.max (Nat.max y x) x = Nat.max y x.
Proof. now rewrite <- Nat.max_assoc; autorewrite with natsimplify. Qed.
#[global] Hint Rewrite max_yx_x : natsimplify.

Ltac inversion_nat_eq_step :=
  match goal with
  | [ H : O = S _ |- _ ] => solve [ inversion H ]
  | [ H : S _ = O |- _ ] => solve [ inversion H ]
  | [ H : O = O |- _ ] => clear H
  | [ H : O = O |- _ ] => pose proof (@UIP_nat _ _ eq_refl H); subst H
  | [ H : S _ = S _ |- _ ]
    => apply (f_equal pred) in H; cbn [pred] in H
  end.
Ltac inversion_nat_eq := repeat inversion_nat_eq_step.

Ltac inversion_nat_rel_step :=
  first [ inversion_nat_eq_step
        | match goal with
          | [ H : S _ <= O |- _ ] => exfalso; clear -H; lia
          | [ H : _ < O |- _ ] => exfalso; clear -H; lia
          | [ H : O >= S _ |- _ ] => exfalso; clear -H; lia
          | [ H : O > _ |- _ ] => exfalso; clear -H; lia
          | [ H : O <= _ |- _ ] => clear H
          | [ H : O < S _ |- _ ] => clear H
          | [ H : _ >= O |- _ ] => clear H
          | [ H : S _ > O |- _ ] => clear H
          | [ H : S _ <= S _ |- _ ] => apply le_S_n in H
          | [ H : S _ < S _ |- _ ] => rewrite <- succ_lt_mono in H
          | [ H : S _ >= S _ |- _ ] => progress cbv [ge] in H
          | [ H : S _ > S _ |- _ ] => progress cbv [gt] in H
          end ].
Ltac inversion_nat_rel := repeat inversion_nat_rel_step.