Require Import Spaces.Finite.
Require Import Algebra.Rings.CRing.
Require Import Algebra.AbGroups.

Local Open Scope mc_scope.

Declare Scope ideal_scope.
Delimit Scope ideal_scope with ideal.
Local Open Scope ideal_scope.

(** In this file we define Ideals *)

(** An additive subgroup I of a ring R is an ideal when: *)
Class IsIdeal {R : CRing} (I : Subgroup R) :=
  isideal (r x : R) : I x -> I (r * x).

Global Instance ishprop_isideal `{Funext} {R : CRing} (I : Subgroup R)
  : IsHProp (IsIdeal I) := ltac:(unfold IsIdeal; exact _).

(** An ideal of a ring [R] is a subgroup of R which is closed under left multiplication. *)
Record Ideal (R : CRing) := {
  ideal_subgroup : Subgroup R;
  ideal_isideal : IsIdeal ideal_subgroup;
}.

Coercion ideal_subgroup : Ideal >-> Subgroup.
Global Existing Instances ideal_isideal.

Definition issig_Ideal (R : CRing) : _ <~> Ideal R := ltac:(issig).

Global Instance ishset_ideal `{Univalence} {R : CRing} : IsHSet (Ideal R).
Proof.
  nrapply istrunc_equiv_istrunc.
  1: apply issig_Ideal.
  rapply istrunc_sigma.
Defined.

(** Here are some lemmas for proving certain elements are in an ideal. They are just special cases of the underlying subgroup lemmas. We write them out for clarity. *)
Section IdealElements.
  Context {R : CRing} (I : Ideal R) (a b : R).
  Definition ideal_in_zero : I cring_zero := subgroup_in_unit I.
  Definition ideal_in_plus : I a -> I b -> I (a + b) := subgroup_in_op I a b.
  Definition ideal_in_negate  : I a -> I (- a) := subgroup_in_inv  I a.
  Definition ideal_in_negate' : I (- a) -> I a := subgroup_in_inv' I a.
  Definition ideal_in_plus_negate : I a -> I b -> I (a - b) := subgroup_in_op_inv I a b.
  Definition ideal_in_negate_plus : I a -> I b -> I (-a + b) := subgroup_in_inv_op I a b.
  Definition ideal_in_plus_l : I (a + b) -> I b -> I a := subgroup_in_op_l I a b.
  Definition ideal_in_plus_r : I (a + b) -> I a -> I b := subgroup_in_op_r I a b.
End IdealElements.

(** The zero ideal is an ideal *)
Global Instance isideal_trivial_subgroup (R : CRing)
  : IsIdeal (R:=R) trivial_subgroup.
Proof.
  hnf; cbn. intros r x p.
  refine (_ @ rng_mult_zero_r r).
  f_ap.
Defined.

(** Zero ideal *)
Definition ideal_zero (R : CRing) : Ideal R
  := Build_Ideal R _ (isideal_trivial_subgroup R).

(** The unit ideal is an ideal *)
Global Instance isideal_maximal_subgroup (R : CRing)
  : IsIdeal (R:=R) maximal_subgroup.
Proof.
  split.
Defined.

(** Unit ideal *)
Definition ideal_unit (R : CRing) : Ideal R
  := Build_Ideal R _ (isideal_maximal_subgroup R).

(** Intersections of underlying subgroups of ideals are again ideals *)
Global Instance isideal_subgroup_intersection (R : CRing) (I J : Ideal R)
  : IsIdeal (subgroup_intersection I J).
Proof.
  intros r x [a b]; split; by apply isideal.
Defined.

(** Intersection of ideals *)
Definition ideal_intersection {R : CRing} : Ideal R -> Ideal R -> Ideal R
  := fun I J => Build_Ideal R _ (isideal_subgroup_intersection R I J).

(** The subgroup product of ideals is again an ideal. *)
Global Instance isideal_subgroup_product (R : CRing) (I J : Ideal R)
  : IsIdeal (subgroup_product I J).
Proof.
  intros r.
  refine (subgroup_product_ind I J _  _ _ _ _).
  + intros x p.
    apply tr, sgt_in.
    left; by apply isideal.
  + intros x p.
    apply tr, sgt_in.
    right; by apply isideal.
  + apply tr, sgt_in.
    left; apply isideal.
    apply ideal_in_zero.
  + intros x y p q IHp IHq.
    rewrite rng_dist_l.
    rewrite rng_mult_negate_r.
    by rapply subgroup_in_op_inv.
Defined.

(** Sum of ideals *)
Definition ideal_sum {R : CRing} : Ideal R -> Ideal R -> Ideal R
  := fun I J => Build_Ideal R _ (isideal_subgroup_product R I J).

Definition ideal_sum_ind {R : CRing} (I J : Ideal R)
  (P : forall x, ideal_sum I J x -> Type)
  (P_I_in : forall x y, P x (tr (sgt_in (inl y))))
  (P_J_in : forall x y, P x (tr (sgt_in (inr y))))
  (P_unit : P mon_unit (tr sgt_unit))
  (P_op : forall x y h k, P x (tr h) -> P y (tr k) -> P (x - y) (tr (sgt_op h k)))
  `{forall x y, IsHProp (P x y)}
  : forall x (p : ideal_sum I J x), P x p
  := subgroup_product_ind I J P P_I_in P_J_in P_unit P_op.

(** *** Product of ideals *)

(** First we form the "naive" product of ideals { a * b | a ∈ I /\ b ∈ J } *)
(** Note that this is not an ideal, but we can fix this later. *)
Inductive ideal_product_naive_type {R : CRing} (I J : Ideal R) : R -> Type :=
| ipn_in : forall x y, I x -> J y -> ideal_product_naive_type I J (x * y)
.

(** Now we can close this under addition to get the product ideal. *)

(** Product of ideals *)
Definition ideal_product {R : CRing} : Ideal R -> Ideal R -> Ideal R.
Proof.
  intros I J.
  snrapply Build_Ideal.
  1: exact (subgroup_generated (G := R) (ideal_product_naive_type I J)).
  intros r s.
  apply Trunc_functor.
  intros p.
  induction p as [s i | | g h p1 IHp1 p2 IHp2].
  + destruct i.
    apply sgt_in.
    rewrite simple_associativity.
    apply ipn_in.
    1: apply isideal.
    1,2: assumption.
  + rewrite rng_mult_zero_r.
    rapply sgt_unit.
  + rewrite rng_dist_l.
    rewrite rng_mult_negate_r.
    by rapply sgt_op.
Defined.

(** The kernel of a ring homomorphism is an ideal. *)
Definition ideal_kernel {R S : CRing} (f : CRingHomomorphism R S) : Ideal R.
Proof.
  snrapply Build_Ideal.
  1: exact (grp_kernel f).
  intros r x p; cbn in p.
  simpl.
  refine (rng_homo_mult _ _ _ @ _).
  refine (_ @ rng_mult_zero_r (f r)).
  f_ap.
Defined.

(** *** Ideal generated by a subset *)

(** It seems tempting to define ideals generated by a subset in terms of subgroups generated by a subset but this does not work. Ideals also have to be closed under left multiplciation by ring elements so they end up having more elements than the subgroup that gets generated. *)

(** Therefore we will do an analagous construction to the one done in Subgroup.v *)

(** Underlying type family of an ideal generated by subset *)
Inductive ideal_generated_type (R : CRing) (X : R -> Type) : R -> Type :=
(** The iddeal should contain all elements of the original family. *)
| igt_in (r : R) : X r -> ideal_generated_type R X r
(** It should contain zero. *)
| igt_zero : ideal_generated_type R X cring_zero
(** It should be closed under negation and addition. *)
| igt_add_neg (r s : R)
  : ideal_generated_type R X r
  -> ideal_generated_type R X s
  -> ideal_generated_type R X (r - s)
(** And finally, it should be closed under left multiplication. *)
| igt_mul (r s : R)
  : ideal_generated_type R X s
  -> ideal_generated_type R X (r * s)
.

Arguments ideal_generated_type {R} X r.
Arguments igt_in {R X r}.
Arguments igt_zero {R X}.
Arguments igt_add_neg {R X r s}.
Arguments igt_mul {R X r s}.

(** Again, as with subgroups we need to truncate this to make it a predicate. *)

(** Ideal generated by a subset *)
Definition ideal_generated {R : CRing} (X : R -> Type) : Ideal R.
Proof.
  snrapply Build_Ideal.
  { snrapply Build_Subgroup'.
    1: exact (fun x => merely (ideal_generated_type X x)).
    1: exact _.
    1: apply tr, igt_zero.
    intros x y p q; strip_truncations.
    by apply tr, igt_add_neg. }
  intros r x; apply Trunc_functor.
  apply igt_mul.
Defined.

(** Finitely generated ideal *)
Definition ideal_generated_finite {R : CRing} {n : nat} (X : Fin n -> R) : Ideal R.
Proof.
  apply ideal_generated.
  intros r.
  exact {x : Fin n & X x = r}.
Defined.

(** Principal ideal *)
Definition ideal_principal {R : CRing} (x : R) : Ideal R
  := ideal_generated (fun r => x = r).

(** *** Ideal equality *)

(** Classically, set based equality suffices for ideals. Since we are talking about predicates, we use pointwise iffs. This can of course be shown to be equivalent to the identity type. *)
Definition ideal_eq {R : CRing} (I J : Ideal R) := forall x, I x <-> J x.

(** With univalence we can characterize paths of ideals *)
Lemma equiv_path_ideal `{Univalence} {R : CRing} {I J : Ideal R} : ideal_eq I J <~> I = J.
Proof.
  refine ((equiv_ap' (issig_Ideal R)^-1 _ _)^-1 oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  rapply equiv_path_subgroup'.
Defined.

Global Instance ishprop_ideal_eq `{Funext} {R : CRing} (I J : Ideal R)
  : IsHProp (ideal_eq I J) := _.

Global Instance reflexive_ideal_eq {R : CRing} : Reflexive (@ideal_eq R).
Proof.
  intros I x; by split.
Defined.

Global Instance symmetric_ideal_eq {R : CRing} : Symmetric (@ideal_eq R).
Proof.
  intros I J p x; specialize (p x); by symmetry.
Defined.

Global Instance transitive_ideal_eq {R : CRing} : Transitive (@ideal_eq R).
Proof.
  intros I J K p q x; specialize (p x); specialize (q x); by transitivity (J x).
Defined.

(** We define the subset relation on ideals in the usual way: *)
Definition ideal_subset {R : CRing} (I J : Ideal R) := (forall x, I x -> J x).

Global Instance reflexive_ideal_subset {R : CRing} : Reflexive (@ideal_subset R)
  := fun _ _ => idmap.

Global Instance transitive_ideal_subset {R : CRing} : Transitive (@ideal_subset R).
Proof.
  intros x y z p q a.
  specialize (p a); specialize (q a).
  exact (q o p).
Defined.

Coercion ideal_eq_subset {R : CRing} {I J : Ideal R} : ideal_eq I J -> ideal_subset I J.
Proof.
  intros f x; apply f.
Defined.

(** Quotient (a.k.a colon) ideal *)
(** Note that this is quotient as in division rather than a colimit. In fact, the quotient ideal is more like an internal hom as we will see later. *)
(** Unfortunately, due to truncatedness constraints, we need to assume funext. *)
Definition ideal_quotient `{Funext} {R : CRing} (I J : Ideal R) : Ideal R.
Proof.
  snrapply Build_Ideal.
  { snrapply Build_Subgroup'.
    1: exact (fun r => forall x, J x -> I (r * x)).
    1: exact _.
    { intros r p.
      rewrite rng_mult_zero_l.
      apply ideal_in_zero. }
    hnf; intros x y p q r s.
    rewrite rng_dist_r.
    rewrite rng_mult_negate_l.
    apply ideal_in_plus_negate.
    1: by apply p.
    by apply q. }
  hnf; cbn.
  intros r x p q s.
  rewrite <- rng_mult_assoc.
  by apply isideal, p.
Defined.

(** The annihilator of an ideal. *)
Definition ideal_annihilator `{Funext} {R : CRing} (I : Ideal R) : Ideal R
  := ideal_quotient (ideal_zero R) I.

(** ** Properties of ideals *)

(** *** Coprime ideals *)

(** Two ideals are coprime if their sum is the unit ideal. *)
Definition Coprime {R : CRing} (I J : Ideal R) : Type
  := ideal_eq (ideal_sum I J) (ideal_unit R).
Existing Class Coprime.

Global Instance ishprop_coprime `{Funext} {R : CRing}
  (I J : Ideal R) : IsHProp (Coprime I J).
Proof.
    unfold Coprime.
    exact _.
Defined.

Lemma equiv_coprime_sum `{Funext} {R : CRing} (I J : Ideal R)
  : Coprime I J
  <~> hexists (fun '(((i ; p) , (j ; q)) : sig I * sig J)
      => i + j = cring_one).
Proof.
  simpl.
  srapply equiv_iff_hprop.
  { intros c.
    pose (snd (c cring_one) tt) as d; clearbody d; clear c.
    strip_truncations.
    apply tr.
    induction d.
    - destruct x.
      + exists ((g ; s), (cring_zero; ideal_in_zero _)).
        apply rng_plus_zero_r.
      + exists ((cring_zero; ideal_in_zero _), (g ; s)).
        apply rng_plus_zero_l.
    - exists ((cring_zero; ideal_in_zero _), (cring_zero; ideal_in_zero _)).
      apply rng_plus_zero_l.
    - destruct IHd1 as [[[x xi] [y yj]] p].
      destruct IHd2 as [[[w wi] [z zj]] q].
      srefine (((_;_),(_;_));_).
      + exact (x - w).
      + by apply ideal_in_plus_negate.
      + exact (y - z).
      + by apply ideal_in_plus_negate.
      + cbn.
        refine (_ @ ap011 (fun x y => x - y) p q).
        rewrite <- 2 rng_plus_assoc.
        f_ap.
        rewrite negate_sg_op.
        rewrite rng_plus_comm.
        rewrite rng_plus_assoc.
        reflexivity. }
  intro x.
  strip_truncations.
  intros r.
  split;[intro; exact tt|].
  intros _.
  destruct x as [[[x xi] [y yj]] p].
  rewrite <- rng_mult_one_r.
  change (x + y = 1) in p.
  rewrite <- p.
  rewrite rng_dist_l.
  apply tr.
  rapply sgt_op'.
  - apply sgt_in.
    left.
    by apply isideal.
  - apply sgt_in.
    right.
    by apply isideal.
Defined.

(** *** Ideal notations *)

(** We declare and import a module for various (unicode) ideal notations. These exist in their own special case, and can be imported and used in other files when needing to reason about ideals. *)

Module Import Notation.
  Infix "⊆" := ideal_subset       : ideal_scope.
  Infix "↔" := ideal_eq           : ideal_scope.
  Infix "+" := ideal_sum          : ideal_scope.
  Infix "⋅" := ideal_product      : ideal_scope.
  Infix "∩" := ideal_intersection : ideal_scope.
  Infix "::" := ideal_quotient    : ideal_scope.
  Notation "〈 X 〉" := (ideal_generated X)  : ideal_scope.
  Notation Ann := ideal_annihilator.
End Notation.

(** *** Ideal lemmas *)

Section IdealLemmas.

  Context {R : CRing}.

  (** Subset relation is antisymmetric *)
  Lemma ideal_subset_antisymm (I J : Ideal R) : I ⊆ J -> J ⊆ I -> I ↔ J.
  Proof.
    intros p q x; split; by revert x.
  Defined.

  (** The zero ideal is contained in all ideals *)
  Lemma ideal_zero_subset I : ideal_zero R ⊆ I.
  Proof.
    intros x p; rewrite p; apply ideal_in_zero.
  Defined.

  (** The unit ideal contains all ideals *)
  Lemma ideal_unit_subset I : I ⊆ ideal_unit R.
  Proof.
    hnf; cbn; trivial.
  Defined.

  (** Intersection includes into the left *)
  Lemma ideal_intersection_subset_l (I J : Ideal R) : I ∩ J ⊆ I.
  Proof.
    intro; exact fst.
  Defined.

  (** Intersection includes into the right *)
  Lemma ideal_intersection_subset_r (I J : Ideal R) : I ∩ J ⊆ J.
  Proof.
    intro; exact snd.
  Defined.

  (** Subsets of intersections *)
  Lemma ideal_intersection_subset (I J K : Ideal R)
    : K ⊆ I -> K ⊆ J -> K ⊆ I ∩ J.
  Proof.
    intros p q x r; specialize (p x r); specialize (q x r); by split.
  Defined.

  (** Ideals include into their sum on the left *)
  Lemma ideal_sum_subset_l (I J : Ideal R) : I ⊆ (I + J).
  Proof.
    intros x p.
    apply tr, sgt_in.
    left; exact p.
  Defined.

  (** Ideals include into their sum on the right *)
  Lemma ideal_sum_subset_r (I J : Ideal R) : J ⊆ (I + J).
  Proof.
    intros x p.
    apply tr, sgt_in.
    right; exact p.
  Defined.

  #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances.

  (** Products of ideals are included in their left factor *)
  Lemma ideal_product_subset_l (I J : Ideal R) : I ⋅ J ⊆ I.
  Proof.
    intros r p.
    strip_truncations.
    induction p as [r i | | r s p1 IHp1 p2 IHp2 ].
    + destruct i as [s t].
      rewrite commutativity.
      by apply isideal.
    + rapply ideal_in_zero.
    + by rapply ideal_in_plus_negate.
  Defined.

  (** Products of ideals are included in their right factor. *)
  Lemma ideal_product_subset_r (I J : Ideal R) : I ⋅ J ⊆ J.
  Proof.
    intros r p.
    strip_truncations.
    induction p as [r i | | r s p1 IHp1 p2 IHp2 ].
    + destruct i as [s t].
      by apply isideal.
    + rapply ideal_in_zero.
    + by rapply ideal_in_plus_negate.
  Defined.

  (** Products of ideals preserve subsets on the left *)
  Lemma ideal_product_subset_pres_l (I J K : Ideal R) : I ⊆ J -> I ⋅ K ⊆ J ⋅ K.
  Proof.
    intros p r q.
    strip_truncations.
    induction q as [r i | | r s ].
    + destruct i.
      apply tr, sgt_in, ipn_in.
      1: apply p.
      1,2: assumption.
    + apply ideal_in_zero.
    + by apply ideal_in_plus_negate.
  Defined.

  (** Products of ideals preserve subsets on the right *)
  Lemma ideal_product_subset_pres_r (I J K : Ideal R) : I ⊆ J -> K ⋅ I ⊆ K ⋅ J.
  Proof.
    intros p r q.
    strip_truncations.
    induction q as [r i | | r s ].
    + destruct i.
      apply tr, sgt_in, ipn_in.
      2: apply p.
      1,2: assumption.
    + apply ideal_in_zero.
    + by apply ideal_in_plus_negate.
  Defined.

  (** TODO: *)
  (** The product of ideals is an associative operation. *)
  (* Lemma ideal_product_assoc (I J K : Ideal R) : I ⋅ (J ⋅ K) ↔ (I ⋅ J) ⋅ K. *)

  (** Products of ideals are subsets of their intersection. *)
  Lemma ideal_product_subset_intersection (I J : Ideal R) : I ⋅ J ⊆ I ∩ J.
  Proof.
    apply ideal_intersection_subset.
    + apply ideal_product_subset_l.
    + apply ideal_product_subset_r.
  Defined.

  (** Sums of ideals are the smallest ideal containing the summand. *)
  Lemma ideal_sum_smallest (I J K : Ideal R) : I ⊆ K -> J ⊆ K -> (I + J) ⊆ K.
  Proof.
    intros p q.
    refine (ideal_sum_ind I J (fun x _ => K x) p q _ _).
    1: apply ideal_in_zero.
    intros y z s t.
    rapply ideal_in_plus_negate.
  Defined.

  (** Ideals absorb themselves under sum. *)
  Lemma ideal_sum_self (I : Ideal R) : I + I ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: by rapply ideal_sum_smallest.
    rapply ideal_sum_subset_l.
  Defined.

  (** Sums preserve inclusions in left summand. *)
  Lemma ideal_sum_subset_pres_l (I J K : Ideal R) : I ⊆ J -> (I + K) ⊆ (J + K).
  Proof.
    intros p.
    apply ideal_sum_smallest.
    { transitivity J.
      1: exact p.
      apply ideal_sum_subset_l. }
    apply ideal_sum_subset_r.
  Defined.

  (** Sums preserve inclusions in right summand. *)
  Lemma ideal_sum_subset_pres_r (I J K : Ideal R) : I ⊆ J -> (K + I) ⊆ (K + J).
  Proof.
    intros p.
    apply ideal_sum_smallest.
    1: apply ideal_sum_subset_l.
    transitivity J.
    1: exact p.
    apply ideal_sum_subset_r.
  Defined.

  (** Products left distribute over sums *)
  (** Note that this follows from left adjoints preserving colimits. The product of ideals is a functor whose right adjoint is the quotient ideal. *)
  Lemma ideal_dist_l (I J K : Ideal R) : I ⋅ (J + K) ↔ I ⋅ J + I ⋅ K.
  Proof.
    (** We split into two directions. *)
    apply ideal_subset_antisymm.
    (** We deal with the difficult inclusion first. The proof comes down to breaking down the definition and reassembling into the right. *)
    { intros r p.
      strip_truncations.
      induction p as [ r i | | r s p1 IHp1 p2 IHp2].
      - destruct i as [r s p q].
        strip_truncations.
        induction q as [ t k | | t k p1 IHp1 p2 IHp2 ].
        + apply tr, sgt_in.
          destruct k as [j | k].
          * left; by apply tr, sgt_in, ipn_in.
          * right; by apply tr, sgt_in, ipn_in.
        + apply tr, sgt_in; left.
          rewrite rng_mult_zero_r.
          apply ideal_in_zero.
        + rewrite rng_dist_l.
          rewrite rng_mult_negate_r.
          by apply ideal_in_plus_negate.
      - apply ideal_in_zero.
      - by apply ideal_in_plus_negate. }
    (** This is the easy direction which can use previous lemmas. *)
    apply ideal_sum_smallest.
    1,2: apply ideal_product_subset_pres_r.
    1: apply ideal_sum_subset_l.
    apply ideal_sum_subset_r.
  Defined.

  (** Products distribute over sums on the right. *)
  (** The proof is very similar to the left version *)
  Lemma ideal_dist_r (I J K : Ideal R) : (I + J) ⋅ K ↔ I ⋅ K + J ⋅ K.
  Proof.
    apply ideal_subset_antisymm.
    { intros r p.
      strip_truncations.
      induction p as [ r i | | r s p1 IHp1 p2 IHp2].
      - destruct i as [r s p q].
        strip_truncations.
        induction p as [ t k | | t k p1 IHp1 p2 IHp2 ].
        + apply tr, sgt_in.
          destruct k as [j | k].
          * left; by apply tr, sgt_in, ipn_in.
          * right; by apply tr, sgt_in, ipn_in.
        + apply tr, sgt_in; left.
          rewrite rng_mult_zero_l.
          apply ideal_in_zero.
        + rewrite rng_dist_r.
          rewrite rng_mult_negate_l.
          by apply ideal_in_plus_negate.
      - apply ideal_in_zero.
      - by apply ideal_in_plus_negate. }
    apply ideal_sum_smallest.
    1,2: apply ideal_product_subset_pres_l.
    1: apply ideal_sum_subset_l.
    apply ideal_sum_subset_r.
  Defined.

  (** Ideal sums are commutative *)
  Lemma ideal_sum_comm (I J : Ideal R) : I + J ↔ J + I.
  Proof.
    apply ideal_subset_antisymm; apply ideal_sum_smallest.
    1,3: apply ideal_sum_subset_r.
    1,2: apply ideal_sum_subset_l.
  Defined.

  (** Zero ideal is left additive identity. *)
  Lemma ideal_sum_zero_l I : ideal_zero R + I ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_sum_smallest.
    1: apply ideal_zero_subset.
    1: reflexivity.
    apply ideal_sum_subset_r.
  Defined.

  (** Zero ideal is right additive identity. *)
  Lemma ideal_sum_zero_r I : I + ideal_zero R ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_sum_smallest.
    1: reflexivity.
    1: apply ideal_zero_subset.
    apply ideal_sum_subset_l.
  Defined.

  (** Ideal products are commutative. *)
  (** This only holds because we are in a commutative ring. *)
  Lemma ideal_product_comm (I J : Ideal R) : I ⋅ J ↔ J ⋅ I.
  Proof.
    (** WLOG we show one direction *)
    assert (p : forall K L : Ideal R, K ⋅ L ⊆ L ⋅ K).
    { clear I J; intros I J.
      intros r p.
      strip_truncations.
      induction p as [r p | |].
      2: apply ideal_in_zero.
      2: by apply ideal_in_plus_negate.
      destruct p as [s t p q].
      rewrite rng_mult_comm.
      by apply tr, sgt_in, ipn_in. }
    apply ideal_subset_antisymm; apply p.
  Defined.

  (** Unit ideal is left multiplicative identity *)
  Lemma ideal_product_unit_l I : ideal_unit R ⋅ I ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_product_subset_r.
    intros r p.
    rewrite <- rng_mult_one_l.
    by apply tr, sgt_in, ipn_in.
  Defined.

  (** Unit ideal is right multiplicative ideal. *)
  Lemma ideal_product_unit_r I : I ⋅ ideal_unit R ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_product_subset_l.
    intros r p.
    rewrite <- rng_mult_one_r.
    by apply tr, sgt_in, ipn_in.
  Defined.

  (** Intersecting with unit ideal on the left does nothing. *)
  Lemma ideal_intresection_unit_l I : ideal_unit R ∩ I ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_intersection_subset_r.
    apply ideal_intersection_subset.
    1: apply ideal_unit_subset.
    reflexivity.
  Defined.

  (** Intersecting with unit ideal on right does nothing. *)
  Lemma ideal_intersection_unit_r I : I ∩ ideal_unit R ↔ I.
  Proof.
    apply ideal_subset_antisymm.
    1: apply ideal_intersection_subset_l.
    apply ideal_intersection_subset.
    1: reflexivity.
    apply ideal_unit_subset.
  Defined.

  (** Product of intersection and sum is subset of sum of products *)
  (** This is stated a bit more generally, like we would for a general ring .*)
  Lemma ideal_product_intersection_sum_subset (I J : Ideal R)
    : (I ∩ J) ⋅ (I + J) ⊆ (I ⋅ J + J ⋅ I).
  Proof.
    etransitivity.
    1: rapply ideal_dist_l.
    etransitivity.
    1: rapply ideal_sum_subset_pres_r.
    1: rapply ideal_product_subset_pres_l.
    1: apply ideal_intersection_subset_l.
    etransitivity.
    1: rapply ideal_sum_subset_pres_l.
    1: rapply ideal_product_subset_pres_l.
    1: apply ideal_intersection_subset_r.
    rapply ideal_sum_comm.
  Defined.

  (** Product of intersection and sum is a subset of product *)
  (** Note that this is a generalization of lcm * gcd = product *)
  (** In a commutative ring we can simplify the right hand side of the previous lemma. *)
  Lemma ideal_product_intersection_sum_subset' (I J : Ideal R)
    : (I ∩ J) ⋅ (I + J) ⊆ I ⋅ J.
  Proof.
    etransitivity.
    2: rapply ideal_sum_self.
    etransitivity.
    2: rapply ideal_sum_subset_pres_r.
    2: rapply ideal_product_comm.
    apply ideal_product_intersection_sum_subset.
  Defined.

  (** If the sum of ideals is the whole ring then their intersection is a subset of their product. *)
  Lemma ideal_intersection_subset_product (I J : Ideal R)
    : ideal_unit R ⊆ (I + J) -> I ∩ J ⊆ I ⋅ J.
  Proof.
    intros p.
    etransitivity.
    { apply ideal_eq_subset.
      symmetry.
      apply ideal_product_unit_r. }
    etransitivity.
    { rapply ideal_product_subset_pres_r.
      exact p. }
    rapply ideal_product_intersection_sum_subset'.
  Defined.

  (** This can be combined into a sufficient (but not necessery) condition for equality of intersections and products. *)
  Lemma ideal_intersection_is_product (I J : Ideal R)
    : Coprime I J -> I ∩ J ↔ I ⋅ J.
  Proof.
    intros p.
    apply ideal_subset_antisymm.
    - apply ideal_intersection_subset_product.
      unfold Coprime in p.
      apply symmetry in p.
      rapply p.
    - apply ideal_product_subset_intersection.
  Defined.

  Section AssumeFunext.
    Context `{Funext}.

    (** Ideals are subsets of their ideal quotients *)
    Lemma ideal_quotient_subset (I J : Ideal R) : I ⊆ (I :: J).
    Proof.
      intros x i r j.
      rewrite rng_mult_comm.
      by apply isideal.
    Defined.

    (** The ideal quotient is a right adjoint to the product in the monoidal lattice of ideals. *)
    Lemma ideal_quotient_subset_prod (I J K : Ideal R)
      : I ⋅ J ⊆ K <-> I ⊆ (K :: J).
    Proof.
      split.
      { intros p r i s j.
        by apply p, tr, sgt_in, ipn_in. }
      intros p x q.
      strip_truncations.
      induction q as [r x | | ].
      { destruct x.
        cbv in p.
        by apply p. }
      1: apply ideal_in_zero.
      by apply ideal_in_plus_negate.
    Defined.

    (** Ideal quotients partially cancel *)
    Lemma ideal_quotient_product_left (I J : Ideal R)
      : (I :: J) ⋅ J ⊆ I.
    Proof.
      by apply ideal_quotient_subset_prod.
    Defined.

    (** If J divides I then the ideal quotient of J by I is trivial. *)
    Lemma ideal_quotient_trivial (I J : Ideal R)
      : I ⊆ J -> J :: I ↔ ideal_unit R.
    Proof.
      intros p.
      apply ideal_subset_antisymm.
      1: cbv; trivial.
      intros r _ x q.
      by apply isideal, p.
    Defined.

    (** The ideal quotient of I by unit is I *)
    Lemma ideal_quotient_unit_bottom (I : Ideal R)
      : (I :: ideal_unit R) ↔ I.
    Proof.
      apply ideal_subset_antisymm.
      { intros r p.
        rewrite <- rng_mult_one_r.
        exact (p cring_one tt). }
      apply ideal_quotient_subset.
    Defined.

    (** The ideal quotient of unit by I is unit *)
    Lemma ideal_quotient_unit_top (I : Ideal R)
      : (ideal_unit R :: I) ↔ ideal_unit R.
    Proof.
      cbv; split; trivial.
    Defined.

    (** The ideal quotient by a sum is an intersection of ideal quotients *)
    Lemma ideal_quotient_sum (I J K : Ideal R)
      : (I :: (J + K)) ↔ (I :: J) ∩ (I :: K).
    Proof.
      apply ideal_subset_antisymm.
      { intros r p; split.
        + intros x j.
          hnf in p; apply p.
          by apply ideal_sum_subset_l.
        + intros x k.
          hnf in p; apply p.
          by apply ideal_sum_subset_r. }
      intros r [p q] x jk.
      hnf in p, q.
      strip_truncations.
      induction jk as [s x | | ].
      - destruct x.
        1: by apply p.
        by apply q.
      - rewrite rng_mult_zero_r.
        apply ideal_in_zero.
      - rewrite rng_dist_l.
        rewrite rng_mult_negate_r.
        by apply ideal_in_plus_negate.
    Defined.

    Lemma ideal_quotient_product (I J K : Ideal R)
      : (I :: J) :: K ↔ (I :: (J ⋅ K)).
    Proof.
      apply ideal_subset_antisymm.
      { hnf. intros x p y q. cbv in p.
        strip_truncations.
        induction q as [y i | | ].
        - destruct i as [ y z s t ].
          rewrite (rng_mult_comm y).
          rewrite rng_mult_assoc.
          by apply p.
        - rewrite rng_mult_zero_r.
          apply ideal_in_zero.
        - rewrite rng_dist_l.
          rewrite rng_mult_negate_r.
          by apply ideal_in_plus_negate. }
      intros x p y k z j; hnf in p.
      rewrite <- rng_mult_assoc.
      rewrite (rng_mult_comm y).
      by apply p, tr, sgt_in, ipn_in.
    Defined.

    (** Ideal quotients distribute over intersections *)
    Lemma ideal_quotient_intersection (I J K : Ideal R)
      : (I ∩ J :: K) ↔ (I :: K) ∩ (J :: K).
    Proof.
      apply ideal_subset_antisymm.
      1: intros r p; hnf in p; split; hnf; intros; by apply p.
      intros r [p q]; hnf in p, q; intros x k; by split; [apply p | apply q].
    Defined.

    (** Annihilators reverse the order of inclusion. *)
    Lemma ideal_annihilator_subset (I J : Ideal R) : I ⊆ J -> Ann J ⊆ Ann I.
    Proof.
      intros p x q y i.
      hnf in q.
      by apply q, p.
    Defined.

  End AssumeFunext.

End IdealLemmas.

(** TODO: Maximal ideals *)
(** TODO: Principal ideal *)
(** TODO: Prime ideals *)
(** TODO: Radical ideals *)
(** TODO: Minimal ideals *)
(** TODO: Primary ideals *)


Require Import Setoid.
Require Import ConstructiveEpsilon.

Definition iffT (X Y : Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).

Definition surj {X Y} (f : X -> Y) := forall y, exists x, f x = y.
Definition inj {X Y} (f : X -> Y) := forall x x', f x = f x' -> x = x'.
Definition bij {X Y} (f : X -> Y) := inj f /\ surj f.

(** * Basic logical notions. *)

Definition definite P := P \/ ~P.
Definition Definite {X} p := forall x : X, definite (p x).
Definition LEM := forall P, definite P.
Definition stable P := ~~P -> P.
Definition Stable {X} p := forall x : X, stable (p x).
Definition DNE := forall P, stable P.
Definition MP := forall (f : nat -> nat), stable (exists n, f n = 0).
Definition UC X Y := forall R, (forall x:X, exists! y:Y, R x y) -> exists f, forall x, R x (f x).

Fact LEM_DNE :
  (LEM <-> DNE) /\ (DNE -> MP).
Proof.
  unfold LEM, DNE, MP. repeat split.
  - intros lem p. now destruct (lem p).
  - intros dne p. apply dne. unfold definite; tauto.
  - intros dne f. apply dne.
Qed.

(* Lemmas for handling double negations. *)

Fact DN_remove {A B} :
  ~~A -> (A -> ~B) -> ~B.
Proof. tauto. Qed.

Fact DN_chaining {A B : Prop} :
  ~ ~ A -> ~ ~(A -> B) -> ~ ~ B.
Proof. tauto. Qed.

Fact DN {A : Prop} :
  A -> ~~A.
Proof. tauto. Qed.

Fact NNN_N A :
  ~~~A <-> ~A.
Proof. tauto. Qed.

Fact DN_forall_stable {X} p :
  Stable p -> (forall x : X, ~~p x) -> forall x, p x.
Proof. unfold Stable; firstorder. Qed.

(** * Definitions in synthetic computability.   *)

Definition decider {X} p f := forall x : X, p x <-> f x = true.
Definition Dec {X} p := inhabited(forall x : X, {p x} + {~p x}).
Definition Dec_sigT {X} p := forall x : X, {p x} + {~p x}.
Definition dec (P : Prop) := {P} + {~P}.
Definition witnessing {X} (p : X -> Prop) := ex p -> sigT p.
Definition enumerable {X} p := exists f : nat -> option X, forall x, p x <-> exists n, f n = Some x.

Definition Enumerable X := exists f : nat -> option X, forall x, exists n, f n = Some x.
Definition Discrete X := Dec (fun p : X * X => fst p = snd p).
Definition Separated X := Dec (fun p : X * X => fst p <> snd p).
Definition Markov X := forall p : X -> Prop, Dec p -> (~~ ex p) -> ex p.
Definition Witnessing X := forall p : X -> Prop, Dec_sigT p -> witnessing p.

(** ** Equivalent characterizations *)

Fact Dec_decider {X} p :
  Dec p <-> ex (@decider X p).
Proof.
  split.
  - intros [D].
    exists (fun x => if D x then true else false).
    intros x. destruct (D x); cbn; intuition congruence.
  - intros [f decf]. constructor. intros x.
    specialize (decf x).
    destruct (f x) eqn:Hx; [left; tauto|right].
    now intros ?%decf.
Qed.

Fact Dec_decider_nat p :
  Dec p -> exists f : nat -> nat, forall x : nat, p x <-> f x = 0.
Proof.
  intros [f decf]%Dec_decider.
  exists (fun n => if f n then 0 else 1).
  intros x. specialize (decf x).
  destruct (f x) eqn:Hx; try tauto.
  rewrite decf. split; congruence.
Qed.

Fact Dec_sigT_decider {X} p :
  Dec_sigT p <=> sigT (@decider X p).
Proof.
  split.
  - intros D.
    exists (fun x => if D x then true else false).
    intros x. destruct (D x); cbn; intuition congruence.
  - intros [f decf]. intros x.
    specialize (decf x).
    destruct (f x) eqn:Hx; [left; tauto|right].
    now intros ?%decf.
Qed.

Fact dec_Dec_sig_T P :
  dec P <=> Dec_sigT (fun _ : True => P).
Proof.
  split.
  - intros []; now constructor.
  - intros []; unfold dec; tauto.
Qed.

Lemma DN_Dec_equiv X (p : X -> Prop) :
  ~ ~ Dec p <-> ((Dec_sigT p -> False) -> False).
Proof.
  split.
  - intros nnH. apply (DN_remove nnH).
    intros [H]. intros nH. apply nH.
    intros x. apply H.
  - intros nnH nH. apply nnH. intros H.
    apply nH. constructor. apply H.
Qed.

Lemma Witnessing_equiv X :
  Witnessing X <=> forall (f : X -> bool), (exists x, f x = true) -> {x & f x = true}.
Proof.
  split; intros H.
  - intros f. apply H.
    intros x. decide equality.
  - intros p [f Hf]%Dec_sigT_decider Ex.
    unfold decider in *.
    destruct (H f).
    + destruct Ex as [x Hx]. exists x. now apply Hf.
    + exists x. now apply Hf.
Qed.

Definition Witnessing_nat : Witnessing nat.
Proof.
  intros p Dec_p H.
  specialize (constructive_indefinite_ground_description_nat p Dec_p H).
  intros [x Hx]. now exists x.
Defined.

Fact Discrete_sum {X} :
  Discrete X <-> inhabited(forall x y : X, {x = y} + {~ x = y}).
Proof.
  split; intros [H]; constructor.
  - intros x y. destruct (H (x,y)); cbn in *; tauto.
  - intros [x y]; cbn. destruct (H x y); tauto.
Qed.

Fact Separated_sum {X} :
  Separated X <-> inhabited(forall x y : X, {~ x = y} + {~~ x = y}).
Proof.
  split; intros [H]; constructor.
  - intros x y. destruct (H (x,y)); cbn in *; tauto.
  - intros [x y]; cbn. destruct (H x y); tauto.
Qed.

Fact enumerable_nat p :
  enumerable p -> exists f, forall x : nat, p x <-> exists n : nat, f n = S x.
Proof.
  intros [f Hf].
  exists (fun n => match f n with Some x => S x | _ => 0 end).
  intros x. rewrite Hf. split; intros [n Hn]; exists n.
  - now rewrite Hn.
  - destruct (f n); congruence.
Qed.

Fact enumerable_equiv X :
  Enumerable X <-> enumerable (fun x : X => True).
Proof.
  split; intros [g Hg]; exists g; firstorder.
Qed.

Fact MP_Markov_nat :
  MP <-> Markov nat.
Proof.
  split.
  - intros mp p [Dec_p] nnH.
    specialize (mp (fun x => if Dec_p x then 0 else 1)).
    destruct mp as [n Hn].
    + apply (DN_chaining nnH), DN.
      intros [n Hn]. exists n.
      destruct (Dec_p n) eqn:fn; congruence.
    + exists n. destruct (Dec_p n) eqn:?; congruence.
  - intros markov f.
    refine (markov (fun n => f n = 0) _).
    constructor; intros ?.
    decide equality.
Qed.

Lemma UC_Def_Dec X (p : X -> Prop) :
  UC X bool -> Definite p -> Dec p.
Proof.
  intros uc Def. apply Dec_decider.
  refine (uc (fun x y => p x <-> y = true) _).
  intros n. destruct (Def n) as [h|h].
  - exists true; split; [tauto|].
    intros []; try congruence.
    intros H. now rewrite H in h.
  - exists false; split.
    + split; try tauto; congruence.
    + intros []; try congruence.
    intros H. now rewrite H in h.
Qed.

Fact MP_Dec_stable :
  MP -> forall (p : nat -> Prop), Dec p -> stable (ex p).
Proof.
  intros mp p [f Hf]%Dec_decider nnH.
  destruct (mp (fun n => if f n then 0 else 1)) as [y Hy].
  - apply (DN_chaining nnH), DN. intros [y Hy].
    exists y. apply Hf in Hy. now destruct (f y).
  - exists y. apply Hf. now destruct (f y).
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (y : natural) (lf1 : natural) : natural := plus lf1 Zero.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_crisscross.
Require Export GeoCoq.Elements.OriginalProofs.proposition_33.
Require Export GeoCoq.Elements.OriginalProofs.proposition_35.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_36 :
   forall A B C D E F G H,
   PG A B C D -> PG E F G H -> Col A D E -> Col A D H -> Col B C F -> Col B C G -> Cong B C F G ->
   EF A B C D E F G H.
Proof.
intros.
assert ((Par A B C D /\ Par A D B C)) by (conclude_def PG ).
assert ((Par E F G H /\ Par E H F G)) by (conclude_def PG ).
assert (nCol E H G) by (forward_using lemma_parallelNC).
assert (neq E H) by (forward_using lemma_NCdistinct).
assert (nCol A B C) by (forward_using lemma_parallelNC).
assert (neq B C) by (forward_using lemma_NCdistinct).
assert (Cong E H F G) by (forward_using proposition_34).
assert (Cong F G E H) by (conclude lemma_congruencesymmetric).
assert (Cong B C E H) by (conclude lemma_congruencetransitive).
assert (Par B C A D) by (conclude lemma_parallelsymmetric).
assert (Par B C E H) by (conclude lemma_collinearparallel2).
assert (Par E H B C) by (conclude lemma_parallelsymmetric).
assert (Cong E H B C) by (conclude lemma_congruencesymmetric).
assert (~ ~ (CR E C B H \/ CR E B H C)).
 {
 intro.
 assert (CR E C B H) by (conclude lemma_crisscross).
 contradict.
 }
assert (EF A B C D E F G H).
by cases on (CR E C B H \/ CR E B H C).
{
 let Tf:=fresh in
 assert (Tf:exists M, (BetS E M C /\ BetS B M H)) by (conclude_def CR );destruct Tf as [M];spliter.
 assert (BetS H M B) by (conclude axiom_betweennesssymmetry).
 assert ((Par E B H C /\ Cong E B H C)) by (conclude proposition_33).
 assert (Par E B C H) by (forward_using lemma_parallelflip).
 assert (PG E B C H) by (conclude_def PG ).
 assert (EF A B C D E B C H) by (conclude proposition_35).
 assert (Col C F G) by (conclude lemma_collinear4).
 assert (Col G F C) by (forward_using lemma_collinearorder).
 assert (Col C B F) by (forward_using lemma_collinearorder).
 assert (Col C B G) by (forward_using lemma_collinearorder).
 assert (neq C B) by (conclude lemma_inequalitysymmetric).
 assert (Col B F G) by (conclude lemma_collinear4).
 assert (Col G F B) by (forward_using lemma_collinearorder).
 assert (Par F G E H) by (conclude lemma_parallelsymmetric).
 assert (Par G F H E) by (forward_using lemma_parallelflip).
 assert (Par E F G H) by (conclude_def PG ).
 assert (Par G H E F) by (conclude lemma_parallelsymmetric).
 assert (PG G H E F) by (conclude_def PG ).
 assert (Par C H E B) by (conclude lemma_parallelsymmetric).
 assert (Par B C E H) by (conclude lemma_parallelsymmetric).
 assert (Par C B H E) by (forward_using lemma_parallelflip).
 assert (PG C H E B) by (conclude_def PG ).
 assert (EF G H E F C H E B) by (conclude proposition_35).
 assert (EF G H E F E B C H) by (forward_using axiom_EFpermutation).
 assert (EF E B C H G H E F) by (conclude axiom_EFsymmetric).
 assert (EF A B C D G H E F) by (conclude axiom_EFtransitive).
 assert (EF A B C D E F G H) by (forward_using axiom_EFpermutation).
 close.
 }
{
 let Tf:=fresh in
 assert (Tf:exists M, (BetS E M B /\ BetS H M C)) by (conclude_def CR );destruct Tf as [M];spliter.
 assert (Par H E B C) by (forward_using lemma_parallelflip).
 assert (Cong H E B C) by (forward_using lemma_congruenceflip).
 assert ((Par H B E C /\ Cong H B E C)) by (conclude proposition_33).
 assert (Par H B C E) by (forward_using lemma_parallelflip).
 assert (PG H B C E) by (conclude_def PG ).
 assert (EF A B C D H B C E) by (conclude proposition_35).
 assert (Col C G F) by (conclude lemma_collinear4).
 assert (Col F G C) by (forward_using lemma_collinearorder).
 assert (Col C B G) by (forward_using lemma_collinearorder).
 assert (Col C B F) by (forward_using lemma_collinearorder).
 assert (neq C B) by (conclude lemma_inequalitysymmetric).
 assert (Col B G F) by (conclude lemma_collinear4).
 assert (Col F G B) by (forward_using lemma_collinearorder).
 assert (Par H E F G) by (forward_using lemma_parallelflip).
 assert (Par F G H E) by (conclude lemma_parallelsymmetric).
 assert (Par F G E H) by (forward_using lemma_parallelflip).
 assert (Par F E H G) by (forward_using lemma_parallelflip).
 assert (PG F E H G) by (conclude_def PG ).
 assert (Par C E H B) by (conclude lemma_parallelsymmetric).
 assert (Par C B E H) by (forward_using lemma_parallelflip).
 assert (PG C E H B) by (conclude_def PG ).
 assert (EF F E H G C E H B) by (conclude proposition_35).
 assert (EF F E H G H B C E) by (forward_using axiom_EFpermutation).
 assert (EF H B C E F E H G) by (conclude axiom_EFsymmetric).
 assert (EF A B C D F E H G) by (conclude axiom_EFtransitive).
 assert (EF A B C D E F G H) by (forward_using axiom_EFpermutation).
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


Definition atom := nat.

Inductive prop : Type :=
| Var : atom  -> prop
| Bot : prop
| Top : prop
| Zero : prop
| One : prop
| Disj : prop -> prop -> prop
| Conj : prop -> prop -> prop
| LDiv : prop -> prop -> prop
| RDiv : prop -> prop -> prop
| MCon : prop -> prop -> prop.

Definition Neg (p : prop) : prop := LDiv p Bot.

Notation "^x_ x" := (Var x) (at level 30).
Coercion atom_as_prop (a : atom) : prop := Var a.

Notation "⊥" := Bot. (* 22a5 *)
Notation "⊤" := Top. (* 22a4 *)
Notation "0" := Zero.
Notation "1" := One.
Notation "¬ P" := (Neg P) (at level 31). (* 00ac *)
Infix "∧" := Conj (left associativity, at level 32). (* 2227 *)
Infix "∨" := Disj (left associativity, at level 33). (* 2228 *)
Infix "⊃" := LDiv (right associativity, at level 34). (* 2283 *)
Infix "⊂" := RDiv (right associativity, at level 35). (* 2282 *)
Infix "⊗" := MCon (right associativity, at level 36). (* 2297 *)
Require Import PeanoNat.
Theorem propeq_dec : forall p q : prop, {p = q} + {p <> q}.
Proof.
  induction p; induction q;
      try (left; reflexivity);
      try (right; intros H; inversion H; contradiction H);
      try (destruct (IHp1 q1); destruct (IHp2 q2); subst;
        try (right; intros H; inversion H; contradiction n);
        left; reflexivity).
    destruct (PeanoNat.Nat.eq_dec a a0).
      - left. subst. reflexivity.
      - right. intros H. inversion H. contradiction n.
Qed.

Fixpoint propeq (p q : prop) : bool :=
  match (p, q) with
  | (^x_n, ^x_m) => PeanoNat.Nat.eqb n m
  | (⊥, ⊥) => true
  | (⊤, ⊤) => true
  | (0, 0) => true
  | (1, 1) => true
  | (p1 ∧ p2, q1 ∧ q2) => (propeq p1 q1) && (propeq p2 q2)
  | (p1 ∨ p2, q1 ∨ q2) => (propeq p1 q1) && (propeq p2 q2)
  | (p1 ⊃ p2, q1 ⊃ q2) => (propeq p1 q1) && (propeq p2 q2)
  | (p1 ⊂ p2, q1 ⊂ q2) => (propeq p1 q1) && (propeq p2 q2)
  | (p1 ⊗ p2, q1 ⊗ q2) => (propeq p1 q1) && (propeq p2 q2)
  | _ => false
  end.


Require Import QuantumLib.Quantum.
Require Export ZXCore.
Require Export GateDefinitions.
Require Export CoreRules.

Local Open Scope ZX_scope.

Lemma Z_is_Z : ZX_semantics (_Z_) = σz.
Proof.
  simpl.
  unfold Z_semantics.
  autorewrite with Cexp_db.
  simpl.
  solve_matrix.
Qed.

Lemma X_is_X : ZX_semantics (_X_) = σx.
Proof.
  simpl.
  unfold X_semantics; solve_matrix.
  all: autorewrite with Cexp_db.
  all: C_field_simplify; try lca.
  all: split; nonzero.
Qed.

Lemma _H_is_box : _H_ ∝ □.
Proof.
  prop_exists_nonzero (Cexp (PI/4)).
  simpl.
  unfold X_semantics, Z_semantics.
  Msimpl.
  solve_matrix;
  field_simplify_eq [Cexp_PI2 Cexp_PI4 Ci2 Csqrt2_sqrt2_inv Csqrt2_inv];
  try apply c_proj_eq; try simpl; try R_field_simplify; try reflexivity; (try split; try apply RtoC_neq; try apply sqrt2_neq_0; try auto).
Qed.

Lemma cnot_l_is_cnot : ZX_semantics _CNOT_ = (/ √ 2)%C .* cnot.
Proof.
  simpl.
  unfold Z_semantics, X_semantics.
  solve_matrix.
  all: autorewrite with Cexp_db.
  all: lca.
Qed.

Lemma cnot_inv_is_swapped_cnot : ZX_semantics _CNOT_inv_ = (/ √ 2)%C .* (swap × cnot × swap)%M.
Proof.
  simpl.
  unfold Z_semantics, X_semantics.
  solve_matrix.
  all: autorewrite with Cexp_db.
  all: lca.
Qed.

Lemma _Rz_is_Rz : forall α, ZX_semantics (_Rz_ α) = phase_shift α.
Proof.
  intros.
  simpl.
  unfold Z_semantics, phase_shift.
  simpl.
  lma.
Qed.


Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Arith.
Require Import ArithRing.
Require Import Setoid.
Require Import Omega.
Add LoadPath "C:\Users\spide\Documents\Tareas\VerificacionFormal\Tareas\Tarea3\Tarea3VFLuisBLluis" as camino.
Load Defs_BT .
(* From Tarea3VF Require Import Defs_BN . *)

(** Tarea 3 Verificación Formal
    Luis B. Lluis LL11
    El siguiente script contiene las propiedades
    de números por paridad. Este script es una concatenación
    de scripts bn2.v y orderbn.v
    de Favio Ezequiel Miranda con ligeras modificaciones,
    alteraciones en orden,adición de lemas, generalizaciones
    a teoremas existentes o adición de pruebas. Las modificaciones
    son mínimas.

    NOTA: Algunos teoremas están admitidos pues se mencionó que no era
          absolutamente necesario concretarlos todos.
          Se intentó concretar una mayoría
          (nadie quiere probar transitividad hahahahaha)

  Dependencias: Defs_BN y Defs_BT
  Contenido
  1.- bn2----------------no depends
      bn sucBN predBN toN toBN plusBN
  3.- orderbn------------depends bn2
      ltBN lteqBN

*)

(** 1.------------------------bn2---------------------------*)
(*Datatype for our numerical system with 0, U and D*)
(*
Inductive BN :=
  Z: BN
| U: BN -> BN
| D: BN -> BN.

Check BN_ind.
Check BN_rec.
Check BN_rect.  *)

Lemma UInj: forall (a b:BN), U a = U b -> a = b.
Proof.
intros.
inversion H.
trivial.
Qed.

Lemma DInj: forall (a b:BN), D a = D b -> a = b.
Proof.
intros.
inversion H.
trivial.
Qed.

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

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

  (* Lemma UnotD: forall (a:BN), U a <> D a. La cambié por la siguiente. C.V. 29/nov/2016 *)
Lemma UnotD: forall (a b:BN), U a <> D b.
Proof.
intros.
discriminate.
Qed.

Lemma DnotU: forall (a b:BN), D a <> U b. (* La agregué. C.V. 29/nov/2016 *)
Proof.
intros.
discriminate.
Qed.

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

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

Theorem dec_eq_BN: forall (a b:BN), {a = b} + {a <> b}.
Proof. (* This can be done fully automatic with decide equality *)
decide equality.
Qed.

(* (* Successor function for BN numbers  *)
Fixpoint sucBN (b:BN) : BN :=
  match b with
      Z => U Z
    | U x => D x (*S(U x) = S(2x + 1) = 2x + 2 = D x*)
    | D x => U (sucBN x) (*S(D x)= S(2x + 2) = S(S(2x + 1)) = S(2x + 1) + 1  *)
                 (* 2(S(x)) + 1 = 2(x+1) + 1 = (2x + 2) + 1 = S(2x + 1) + 1*)
  end.
 *)
Lemma ZnotSucBN: forall (a:BN), Z <> sucBN a.
Proof.
intros.
induction a.
simpl.
discriminate.
simpl.
discriminate.
simpl.
discriminate.
Qed.

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

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

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

(* (* Predeccesor function with error *)

Parameter (undefBN: BN). (* we assume a constant undefBN:BN representing an undefined BN number *)

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

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

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

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

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

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

(* Conversion functions *)

(* (* Recursive function that converts a number of type BN
 to its respective natural number*)
Fixpoint toN (b:BN) : nat :=
  match b with
      Z => 0
    | U x => 2*(toN x) + 1
    | D x => 2*(toN x) + 2
  end.

(* Converts a nat value to BN value.
   Inverse of the above one.*)
Fixpoint toBN (n: nat) : BN :=
  match n with
      0 => Z
    | S x => sucBN (toBN x)
  end.

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

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

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

Eval compute in toBN 16. *)

Lemma toN_sucBN : forall (b : BN), toN(sucBN b) = S(toN b).
Proof.
induction b.
simpl.
trivial.

simpl.
ring.

simpl.
rewrite IHb.
ring.
Qed.

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

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

Lemma SucBNinj: forall (a b : BN), sucBN a = sucBN b -> a = b.
Proof.
intros.
assert (predBN (sucBN a)= predBN (sucBN b)).
rewrite H. reflexivity.
pose proof predsucBNinv.
specialize H1 with (a:= a) as H2.
specialize H1 with (a:= b) as H3.
rewrite <-H2.
rewrite <-H3.
assumption.
Qed.

(* (* Definition of sum of BN elements*)

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

Notation "a ⊞ b" := (plusBN a b) (at level 60).
 *)
Lemma plusBN_toN : forall (a b : BN), toN(a ⊞ b) = toN a + toN b.
Proof.
intro.
induction a.
simpl.
trivial.
intros.
destruct b.
simpl.
ring.
simpl.
rewrite IHa.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
destruct b.
simpl.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
simpl.
rewrite toN_sucBN.
rewrite IHa.
ring.
Qed.

Lemma plus_neutro: forall (b:BN), b ⊞ Z = b.
Proof.
intros.
destruct b.
simpl;trivial.
simpl;trivial.
simpl;trivial.
Qed.
Lemma plus_sucBN_ZU: forall (b : BN),  sucBN (b) = b ⊞ U Z.
Proof.
  intros.
  induction b.
  - simpl. reflexivity.
  - simpl. rewrite plus_neutro. reflexivity.
  - simpl. rewrite plus_neutro. reflexivity.
Qed.
Lemma plus_sucBN_ZUU: forall (b : BN),  sucBN(sucBN (b)) = b ⊞ D Z.
Proof.
intros.
induction b.
- simpl. reflexivity.
- simpl. rewrite plus_neutro.
  reflexivity.
- simpl. rewrite plus_neutro.
  reflexivity.
Qed.

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

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

Lemma plusSuc : forall (b c: BN), sucBN (b ⊞ c) = sucBN b ⊞ c.
Proof.
  induction b.
  - induction c.
    -- simpl. reflexivity.
    -- simpl. reflexivity.
    -- simpl. reflexivity.
  - induction c.
    -- simpl. reflexivity.
    -- simpl. reflexivity.
    -- simpl. reflexivity.
  - induction c.
    -- simpl. reflexivity.
    -- simpl.
        specialize IHb with (c:=c).
        rewrite IHb.
        reflexivity.
    -- simpl.
       specialize IHb with (c:= c) as H1.
       rewrite H1.
       reflexivity.
Qed.

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

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

Lemma plusComm: forall (a b:BN), (a ⊞ b) = (b ⊞ a).
Proof.
intro.
induction a.
- intro. simpl. rewrite plus_neutro. reflexivity.
- intro.
  induction b.
  reflexivity.
  simpl. rewrite IHa. reflexivity.
  simpl. rewrite IHa. reflexivity.
- intro. induction b.
  simpl.  reflexivity.
  simpl. rewrite IHa. reflexivity.
  simpl. rewrite IHa. reflexivity.
Qed.

Lemma plusSuc_2 : forall (b c: BN), sucBN (b ⊞ c) = b ⊞ sucBN c.
Proof.
intros.
rewrite plusComm.
rewrite plusSuc.
rewrite plusComm.
reflexivity.
Qed.

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

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

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

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

Lemma addition_SucBNa_a : forall (a b:BN), sucBN a ⊞ a = sucBN b ⊞ b -> a = b.
Proof.
intros.
rewrite <- plusSuc in H.
rewrite <- plusSuc in H.
apply SucBNinj in H.
apply (f_equal sucBN) in H.
rewrite plus_U in H.
rewrite plus_U in H.
apply UInj.
trivial.
Qed.

(** 3.--------------orderbn---------------------------------*)

(* Inductive ltBN : BN -> BN -> Prop :=
 | ltBNZU : forall (a:BN), ltBN Z (U a)
 | ltBNZD : forall (a:BN), ltBN Z (D a)
 | ltBNUU : forall (a b:BN), ltBN a b -> ltBN (U a) (U b)
 | ltBNUDeq : forall (a :BN), ltBN (U a) (D a)
 | ltBNUD : forall (a b:BN), ltBN a b -> ltBN (U a) (D b)
 | ltBNDU : forall (a b:BN), ltBN a b -> ltBN (D a) (U b)
 | ltBNDD : forall (a b:BN), ltBN a b -> ltBN (D a) (D b).

Inductive lteqBN: BN -> BN -> Prop :=
 | lteqBNref: forall (a:BN), lteqBN a a
 | lteqBNl: forall (a b: BN), ltBN a b -> lteqBN a b.

Notation "a <BN b" := (ltBN a b) (at level 70).
Notation "a <BN b <BN c" := (ltBN a b /\ ltBN b c) (at level 70, b at next level).

Notation "a ≤BN b" := (lteqBN a b) (at level 70).
 *)
Lemma lt_U: forall (a b:BN), a <BN b <-> (U a) <BN U b.
Proof.
intros.
split.
+ intro.
  apply ltBNUU.
  assumption.
+ intro.
  inversion H.
  assumption.
Qed.

Lemma lt_D: forall (a b:BN), a <BN b <-> (D a) <BN D b.
Proof.
intros. split.
+ intros. apply ltBNDD.
  assumption.
+ intros.
  inversion H.
  assumption.
Qed.

Lemma ltBN_arefl: forall (a:BN), ~ a <BN a.
Proof.
intros.
induction a.
unfold not.
intros.
inversion H.
contradict IHa.
inversion IHa.
trivial.
contradict IHa.
inversion IHa.
trivial.
Qed.

Create HintDb PNatDb.

Hint Resolve ltBN_arefl: PNatDb.

Lemma ltBN_asym: forall (a b:BN), a <BN b -> ~ b <BN a.
Proof.
intros.
induction H.
unfold not;intros.
inversion H.
unfold not;intros.
inversion H.
contradict IHltBN.
inversion IHltBN.
trivial.
unfold not;intros.
inversion H.
apply (ltBN_arefl a).
trivial.
(*exact (ltBN_arefl a H2).*)
unfold not;intros.
inversion H0.
intuition.
contradict IHltBN.
inversion IHltBN.
rewrite H2 in H.
trivial.
trivial.
contradict IHltBN.
inversion IHltBN.
trivial.
Qed.

Hint Resolve ltBN_asym: PNatDb.

(*Lemma ltBN_antisym: forall (a b:BN), ltBN a b -> ltBN b a -> *)

Lemma ltBN_tr: forall (b c:BN), b <BN c -> forall (a:BN), a <BN b -> a <BN c.
Proof.
intro.
intro.
intro.
induction H.
- intros. inversion H.
- intros. inversion H.
- intros.
Admitted.

Hint Resolve ltBN_tr: PNatDb.

Lemma ltBN_trans: forall (a b c:BN), a <BN b -> b <BN c -> a <BN c.
Proof.
intros.
eapply ltBN_tr.
eexact H0.
trivial.
Qed.

Hint Resolve ltBN_trans: PNatDb.

Lemma lt_lteqBN_trans: forall (a b c:BN), a <BN b -> b ≤BN c -> a <BN c.
Proof.
intros.
inversion H0.
rewrite H2 in H.
trivial.
eapply ltBN_trans.
eexact H.
trivial.
Qed.

Hint Resolve lt_lteqBN_trans: PNatDb.

Lemma lteqBN_trans: forall (a b c:BN), a ≤BN b -> b ≤BN c -> a ≤BN c.
Proof.
intros.
inversion H.
trivial.
inversion H0.
rewrite H5 in H.
trivial.
constructor.
eapply ltBN_trans.
eexact H1.
trivial.
Qed.

Hint Resolve lteqBN_trans: PNatDb.

Lemma ltDs: forall (a:BN), (D a) <BN (U (sucBN a)).
Proof.
intros.
induction a.
simpl.
constructor.
constructor.
simpl.
constructor.
constructor.
simpl.
constructor.
trivial.
Qed.

Hint Resolve ltDs: PNatDb.
Lemma ltBN_aUZ: forall (a:BN), a <BN U Z -> a =Z.
Proof.
intros.
induction a.
reflexivity.
inversion H.
inversion H2.
inversion H.
inversion H2.
Qed.

Lemma lteqBN_Za: forall (a:BN), Z ≤BN a.
Proof.
intros.
destruct a.
- constructor.
- constructor.
  apply ltBNZU.
- constructor.
  apply ltBNZD.
Qed.

Lemma lts: forall (a:BN), a <BN (sucBN a).
Proof.
intros.
induction a.
constructor.
simpl.
constructor.
simpl.
constructor.
trivial.
Qed.

Hint Resolve lts: PNatDb.

Lemma lteqs: forall (a:BN), a ≤BN (sucBN a).
Proof.
intros.
induction a.
constructor.
constructor.
simpl.
constructor.
constructor.
simpl.
constructor.
constructor.
inversion IHa.
contradict H0.
apply notSucBN.
trivial.
Qed.

Hint Resolve lteqs: PNatDb.

Lemma ltpred : forall (a:BN), a <> Z -> (predBN a) <BN a.
Proof.
intros.
induction a.
- contradict H. reflexivity.
- simpl. destruct a.
  + constructor.
  + apply ltBNDU.
    apply IHa.
    apply not_eq_sym.
    apply ZnotU.
  + apply ltBNDU.
    apply IHa.
    apply not_eq_sym.
    apply ZnotD.
- simpl. apply ltBNUDeq.
Qed.

Hint Resolve ltpred: PNatDb.

Lemma lt1: forall (b a:BN), a <BN (sucBN b) -> a ≤BN b.
Proof.
intro.
induction b.
- intros.
  inversion H.
  constructor.
  inversion H2.
  inversion H2.
- intros.
  inversion H.
  * apply lteqBN_Za.
  * constructor.
  * constructor.
    constructor.
    assumption.
  * constructor.
    constructor.
    assumption.
- intros.
  inversion H.
  apply lteqBN_Za.
  inversion H2.
  -- constructor.
     constructor.
(*
     constructor.
  apply IHb.
  constructor.
  constructor.

intros.
induction a.
apply lteqBN_Za.

inversion H.
apply lteqBN_Za.
apply lteqBN_Za.
- admit.
-  *)

(* intro.
induction b.
- intros.
  apply ltBN_aUZ in H.
  rewrite H. constructor.
- intros.
   admit.
- intros. admit.
- intros.
apply lteqBN_Z.

induction H.
- apply lteqBN_Z.
- apply lteqBN_Z.
- inversion IHltBN. *)
Admitted.

Hint Resolve lt1: PNatDb.

Lemma lt2: forall (b a:BN), a ≤BN b -> a <BN (sucBN b).
Proof.
intro.
induction b.
- intros.
  inversion H.
  subst.
  constructor.
  subst.
  inversion H0.
- intros.
  inversion H.
  subst.
  constructor.
  subst.
  induction a.
  constructor.
  inversion H0.
  subst.
  simpl.
  constructor.
  assumption.
  simpl.
  constructor.
  inversion H0.
  assumption.
- intros.
  inversion H.
  apply lts.
  subst.
  inversion H0.
  constructor.
  simpl.
  constructor.
  apply lts.
  simpl.
  subst.
  constructor.
  apply IHb.
  constructor.
  assumption.
  simpl.
  constructor.
  apply IHb.
  constructor.
  assumption.
Qed.

Hint Resolve lt2: PNatDb.

Lemma lteqBN_suc_pred : forall (a b:BN), a <> Z -> a ≤BN (sucBN b) -> (predBN a) ≤BN b.
Proof.
intros.
assert ((predBN a) <BN a).
apply ltpred.
trivial.
assert (predBN a <BN sucBN b).
eapply lt_lteqBN_trans.
eexact H1.
trivial.
apply lt1.
trivial.
Qed.

Hint Resolve lteqBN_suc_pred: PNatDb.

Lemma ltaux1: forall (j:BN), Z ≤BN (D j) -> Z ≤BN j.
Proof.
intros.
apply lteqBN_Za.
Qed.

Lemma lteqBN_refl : forall (b:BN), b ≤BN b.
Proof.
intros.
constructor.
Qed.

Lemma lteqBN_Z : forall (b:BN), Z ≤BN b.
Proof.
intros.
destruct b.
constructor.
constructor;constructor.
constructor;constructor.
Qed.

Theorem not_lt_suc: forall (a:BN), ~ exists (b:BN), a <BN b /\ b <BN (sucBN a).
Proof.
intros.
intro.
induction a.
+ destruct H.
  destruct H.
  - apply ltBN_aUZ in H0.
  rewrite H0 in H.
  inversion H.
+ apply IHa.
  destruct H.
  destruct H.
  destruct x.
  inversion H.
  - simpl in H0.
(*     apply
destruct H.
destruct H.
induction a.
- apply ltBN_aUZ in H0.
  rewrite H0 in H.
  inversion H.
- simpl in H0.
  destruct x.
  + inversion H.
  +
  simpl in IHa. *)
Admitted.

Lemma trichotomy: forall (a b:BN), a <BN b \/ a=b \/ b <BN a.
Proof.
Admitted.

Lemma not_lt: forall (a b:BN), b ≤BN a -> ~ a <BN b.
Proof.
Admitted.

Lemma sucBN_lt: forall (a b:BN), sucBN a <> b -> a <BN b -> (sucBN a) <BN b.
Proof.
Admitted.

(* Next lemmas are used for Okasaki's size *)

Lemma lteqBN_U_U:forall (a b:BN), (U a) ≤BN (U b) -> a ≤BN b.
Proof.
intros.
inversion H.
constructor.
inversion H0.
constructor.
trivial.
Qed.

Lemma lteqBN_D_D : forall (a b : BN), (D a) ≤BN (D b)-> a ≤BN b.
Proof.
intros.
inversion H.
constructor.
inversion H0.
constructor.
trivial.
Qed.

Lemma lteqBN_U_D:forall (a b:BN), (U a) ≤BN (D b) -> a ≤BN b.
Proof.
intros.
inversion H.
inversion H0.
constructor.
constructor.
trivial.
Qed.

Lemma lteqBN_D_U:forall (a b:BN), (D a) ≤BN (U b) -> a ≤BN b.
Proof.
intros.
inversion H.
inversion H0.
constructor.
trivial.
Qed.
Lemma lt_suc_lteq: forall (a b:BN), a <BN b <-> (sucBN a) ≤BN b.
Proof.
intros.
split.
+ intro. induction H.
- simpl. destruct a.
  -- constructor.
  -- simpl. constructor.
     apply ltBNUU.
     constructor.
  -- constructor.
     apply ltBNUU.
     constructor.
- destruct a.
  -- constructor.
     constructor.
  -- constructor.
     constructor.
     constructor.
  -- constructor.
     constructor.
     constructor.
- simpl.
  constructor.
  constructor.
  assumption.
- constructor.
- simpl.
  constructor.
  constructor.
  assumption.
- simpl.
  admit. (* probar monotonia de U*)
- simpl.
  admit. (* probar monotonía  de D*)
+ intro.
(*   constructor.
  constructor.
  assumption.
- inversion H.
-   *)
(* intro. *)
pose proof (lts a).
eapply lt_lteqBN_trans.
apply H0.
assumption.
Admitted.

Lemma lteqBN_suc: forall (a b:BN), a ≤BN b -> (sucBN a) ≤BN (sucBN b).
Proof.
intros.
inversion H.
constructor.
apply lt_suc_lteq.
apply lt2.
trivial.
Qed.

Lemma bbalCond_eqs: forall (s t:BN), t ≤BN s -> s ≤BN sucBN t -> s = t \/ s = sucBN t.  (* nov-2016, C.V. *)
Proof.
intros.
inversion H.
intuition.
inversion H0.
intuition.
exfalso.
eapply not_lt_suc.
exists s.
split.
exact H1.
assumption.
Qed.


(*************************************************************************)
(**                                                                      *)
(** * Typing: preservation and progress                                  *)
(**                                                                      *)
(*************************************************************************)

Require Import Metalib.Metatheory.
Require Import Stlc.Definitions.
Import StlcNotations.

Require Import Stlc.Lemmas.

Require Import Stlc.Lec1.
(* Lemmas from Lec1 that are useful for today's homework: *)
Check subst_var.
Check typing_to_lc_exp.

(*************************************************************************)
(** * Typing contexts *)
(*************************************************************************)

(** We represent contexts as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.   *)

(** For STLC, contexts bind [atom]s to [typ]s.  We define an
    abbreviation [ctx] for the type of these contexts.

    Lists are defined in Coq's standard library, with the constructors
    [nil] and [cons].  The list library includes the [::] notation
    for cons as well as standard list operations such as append, map,
    and fold. The infix operation "++" is list append.

    The Metatheory library extends this reasoning by instantiating the
    AssocList library to provide support for association lists whose
    keys are [atom]s.  Everything in this library is polymorphic over
    the type of objects bound in the context.  Look in AssocList
    for additional details about the functions and predicates that we
    mention below.  *)

(** Context equality *)

(** When reasoning about contexts, we often need to talk about
    bindings in the "middle" of a context. Therefore, it is common
    for lemmas and definitions to use list append in their statements.
    Unfortunately, list append is associative, so two Coq expressions may
    denote the same context even though they are not equal.

    The tactic [simpl_env] reassociates all concatenations of
    contexts to the right.  *)

Lemma append_assoc_demo : forall (E0 E1 E2 E3:ctx),
  E0 ++ (E1 ++ E2) ++ E3 = E0 ++ E1 ++ E2 ++ E3.
Proof.
  intros.
  auto. (* Does nothing. *)
  simpl_env.
  reflexivity.
Qed.

(** To make contexts easy to read, instead of building them from
    [nil] and [cons], we prefer to build them from the following
    components:
      - [nil]: The empty list.
      - [one]: Lists consisting of exactly one item.
      - [++]:  List append.
*)

(** The simpl_env tactic actually puts lists built from only nil, one
    and [++] into a "normal form". This process reassociates all appends
    to the right, removes extraneous nils and converts cons to singleton
    lists with an append.
*)

Lemma simpl_env_demo : forall (x y:atom) (T1 T2:typ) (E F:ctx),
   ([(x, T1)] ++ nil) ++ (y,T2) :: (nil ++ E) ++ F =
   [(x,T1)] ++ [(y, T2)] ++ E ++ F.
Proof.
   intros.
   (* simpl_env puts the left side into the normal form. *)
   simpl_env.
   reflexivity.
Qed.

(** Context operations. *)

(** The ternary predicate [binds] holds when a given binding is
    present somewhere in a context.
*)

Lemma binds_demo : forall (x:atom) (T:typ) (E F:ctx),
  binds x T (E ++ [(x, T)] ++ F).
Proof.
  auto.
Qed.

(** The function [dom] computes the domain of a context, returning a
    finite set of [atom]s. Note that we cannot use Coq's equality for
    finite sets, we must instead use a defined relation [=] for atom
    set equality.  *)

Lemma dom_demo : forall (x y : atom) (T : typ),
  dom [(x, T)] [=] singleton x.
Proof.
  auto.
Qed.

(** The unary predicate [uniq] holds when each atom is bound at most
    once in a context.
*)

Lemma uniq_demo : forall (x y : atom) (T : typ),
  x <> y -> uniq ([(x,T)] ++ [(y, T)]).
Proof.
  auto.
Qed.

(*************************************************************************)
(** * Typing relation and cofinite quantification *)
(*************************************************************************)

(** The typing relation in the STLC definition states the typing rule for
    abstractions in a particular way.

<<
typing_abs
     : forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
       (forall x : atom,
        x `notin` L -> typing ([(x, T1)] ++ G) (open e (var_f x)) T2) ->
       typing G (abs e) (typ_arrow T1 T2)
>>

   To show that abstractions are well-typed, we must show that the body
   of the abstraction is well-typed for any choice of variable, except
   those from some unspecified set `L`.

   This type of rule differs from the quantification in the
   [lc_abs] rule (which does not restrict the variables at all) or
   the [lc_abs_exists] version (which only applies for one particular
   variable. We call this version "co-finite" quantification.

   To see why this version is necessary, we will start with a more
   traditional version of the rules that only uses a single variable
   in the abs rule and then see what goes wrong.
   (We say that the [typing_e] judgement below uses "exists-fresh"
   quantification in the abs rule.)

*)

Inductive typing_e : ctx -> exp -> typ -> Prop :=
  | typing_e_var : forall E (x : atom) T,
      uniq E ->
      binds x T E ->
      typing_e E (var_f x) T
  | typing_e_abs : forall x E e T1 T2,
      x `notin` dom E \u fv_exp e ->
      typing_e ([(x, T1)] ++ E) (e ^ x) T2 ->
      typing_e E (abs e) (typ_arrow T1 T2)
  | typing_e_app : forall E e1 e2 T1 T2,
      typing_e E e1 (typ_arrow T1 T2) ->
      typing_e E e2 T1 ->
      typing_e E (app e1 e2) T2.
Hint Constructors typing_e.

(*************************************************************************)
(** ** Weakening  *)
(*************************************************************************)

(** Weakening states that if an expression is typeable in some
    context, then it is typeable in any well-formed extension of
    that context.  This property is needed to prove the
    substitution lemma.

    As stated below, this lemma is not directly proveable.  The
    natural way to try proving this lemma proceeds by induction on the
    typing derivation for [e].
*)

Lemma typing_weakening_0 : forall E F e T,
  typing_e E e T ->
  uniq (F ++ E) ->
  typing_e (F ++ E) e T.
Proof.
  intros E F e T H J.
  induction H; auto.
  - Case "typing_abs".
    apply (typing_e_abs x).
    (* ... stuck here ... *)
Abort.

(** We are stuck in the [typing_abs] case because the induction
    hypothesis [IHtyping_e] applies only when we weaken the context at its
    head.  In this case, however, we need to weaken the context in
    the middle; compare the conclusion at the point where we're stuck
    to the hypothesis [H], which comes from the given typing derivation.

    We can obtain a more useful induction hypothesis by changing the
    statement to insert new bindings into the middle of the
    context, instead of at the head.  However, the proof still
    gets stuck, as can be seen by examining each of the cases in
    the proof below.

    Note: To view subgoal n in a proof, use the command "[Show n]".
    To work on subgoal n instead of the first one, use the command
    "[Focus n]".
*)

Lemma typing_weakening_strengthened_0 : forall (E F G : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H J.
  induction H.
  Case "typing_var".
    (* The G0 looks strange in the [typing_var] case. *)
  Focus 2.
  Case "typing_abs".
    (* The [typing_abs] case still does not have a strong enough IH. *)
Abort.

(** The hypotheses in the [typing_var] case include a context
    [G0] that that has no relation to what we need to prove.  The
    missing fact we need is that [G0 = (G ++ E)].

    The problem here arises from the fact that Coq's [induction]
    tactic lets us only prove something about all typing derivations.
    While it's clear to us that weakening applies to all typing
    derivations, it's not clear to Coq, because the context is
    written using concatenation.  The [induction] tactic expects that
    all arguments to a judgement are variables.  So we see [E0] in the
    proof instead of [(G ++ E)].

    The solution is to restate the lemma.  For example, we can prove

<<
  forall E F E' e T, typing E' e T ->
  forall G, E' = G ++ E -> uniq (G ++ F ++ E) -> typing (G ++ F ++ E) e T.
>>

    The equality gets around the problem with Coq's [induction]
    tactic.  The placement of the [(forall G)] quantifier gives us a
    sufficiently strong induction hypothesis in the [typing_abs] case.

    However, we prefer not to state the lemma in the way shown above,
    since it is not as readable as the original statement.  Instead,
    we use a tactic to introduce the equality within the proof itself.
    The tactic [(remember t as t')] replaces an object [t] with the
    identifier [t'] everywhere in the goal and introduces an equality
    [t' = t] into the context.  It is often combined with [generalize
    dependent], as illustrated below.
*)

Lemma typing_weakening_strengthened_1 :  forall (E F G : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G0 Eq Uniq; subst.
  - Case "typing_var". auto.
  - Case "typing_abs".
    eapply (typing_e_abs x).
    (* STILL STUCK! *)
Abort.

Print typing_abs.

(** At this point, we are very close. However, there is still one issue. We
    cannot show that [x] is fresh for the weakened context [F].

    This is the difficulty with the definition of [typing_e]. As in the local
    closure judgement, the induction hypotheses is not strong enough in the
    [abs] case.

    However, this time, we take a slightly different solution, with the
    cofinite quantification of the [typing_abs] rule.

<<
| typing_abs :
    forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
    (forall x, x `notin` L -> typing ([(x, T1)] ++ G) (e ^ x) T2) ->
    typing (abs e) (typ_arrow T1 T2) >>
>>

   The advantage of this definition is that it is easier to derive
   the "exists-fresh" version of the rule
   [typing_e_abs] as a lemma, than the version we used in [lc_exp].
   (See below, we prove this lemma after we show substitution.) At the same
   time, this version of the rule is sufficiently expressive to complete
   the proof of weakening.

*)

(** *** Exercise [typing_weakening_strengthened]

    Complete the proof below, using the [typing] relation from [Definitions.v].

    HINTS:

       - The [typing_var] case follows from [binds_weaken], the
         weakening lemma for the [binds] relation.

       - The [typing_abs] case follows from the induction
         hypothesis, but the [apply] tactic may be unable to unify
         things as you might expect.

           -- You'll need to specify the set to avoid with
              (L := dom (G0 ++ F ++ E) \u L)).

           -- In order to apply the induction hypothesis, use
              [rewrite_env] to reassociate the list operations.

           -- After applying the induction hypothesis, use
              [simpl_env] to use [uniq_push].

           -- Here, use [auto] to solve facts about finite sets of
              atoms, since it will simplify the [dom] function behind
              the scenes.  [fsetdec] does not work with the [dom]
              function.

       - The [typing_app] case follows directly from the induction
         hypotheses.
  *)

Lemma typing_weakening_strengthened :  forall (E F G : ctx) e T,
  typing (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G0 Eq Uniq; subst.
 (* FILL IN HERE *)
 Admitted.

(** *** Demo [typing_weakening]

    We can now prove our original statement of weakening.  The only
    interesting step is the use of the rewrite_env tactic.
*)

Lemma typing_weakening : forall (E F : ctx) e T,
    typing E e T ->
    uniq (F ++ E) ->
    typing (F ++ E) e T.
Proof.
  intros E F e T H J.
  rewrite_env (nil ++ F ++ E).
  apply typing_weakening_strengthened; auto.
Qed.

(*************************************************************************)
(** ** Substitution *)
(*************************************************************************)

(** Having proved weakening, we can now prove the usual substitution
    lemma, which we state both in the form we need and in the
    strengthened form needed to make the proof go through.

<<
  typing_subst_simple : forall E e u S T z,
    typing ([(z,S)] ++ E) e T ->
    typing E u S ->
    typing E ([z ~> u] e) T

  typing_subst : forall E F e u S T z,
    typing (F ++ [(z,S)] ++ E) e T ->
    typing E u S ->
    typing (F ++ E) ([z ~> u] e) T
>>

    The proof of the strengthened statement proceeds by induction on
    the given typing derivation for [e].  The most involved case is
    the one for variables; the others follow from the induction
    hypotheses.
*)

(** *** Exercise [typing_subst_var_case]

    Below, we state what needs to be proved in the [typing_var] case
    of the substitution lemma.  Fill in the proof.

    Proof sketch: The proof proceeds by a case analysis on [(x == z)],
    i.e., whether the two variables are the same or not.

      - If [(x = z)], then we need to show [(typing (F ++ E) u T)].
        This follows from the given typing derivation for [u] by
        weakening and the fact that [T] must equal [S].

      - If [(x <> z)], then we need to show [(typing (F ++ E) x T)].
        This follows by the typing rule for variables.

    HINTS: Lemmas [binds_mid_eq], [uniq_remove_mid],
    and [binds_remove_mid] are useful.

  *)

Lemma typing_subst_var_case : forall (E F : ctx) u S T (z x : atom),
  binds x T (F ++ [(z,S)] ++ E) ->
  uniq (F ++ [(z,S)] ++ E) ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] (var_f x)) T.
Proof.
  intros E F u S T z x H J K.
  simpl.
 (* FILL IN HERE *) Admitted.

(** *** Exercise [typing_subst]

    Complete the proof of the substitution lemma. The proof proceeds
    by induction on the typing derivation for [e].  The initial steps
    should use [remember as] and [generalize dependent] in a manner
    similar to the proof of weakening.

   HINTS:
      - Use the lemma proved above for the [typing_var] case.

      - The [typing_abs] case follows from the induction hypothesis.
          -- Use [simpl] to simplify the substitution.

          -- In order to use the induction hypothesis, use [subst_var]
             to push the substitution under the opening operation.

          -- Recall the lemma [typing_to_lc_exp] and the [rewrite_env]
             and [simpl_env] tactics.

      - The [typing_app] case follows from the induction hypotheses.
        Use [simpl] to simplify the substitution.
*)

Lemma typing_subst : forall (E F : ctx) e u S T (z : atom),
  typing (F ++ [(z,S)] ++ E) e T ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] e) T.
Proof.
(* FILL IN HERE *) Admitted.

(** *** Exercise [typing_subst_simpl]

    Complete the proof of the substitution lemma stated in the form we
    need it.  The proof is similar to that of [typing_weakening].

    HINT: You'll need to use [rewrite_env] to prepend [nil],
    and [simpl_env] to simplify nil away.
*)

Lemma typing_subst_simple : forall (E : ctx) e u S T (z : atom),
  typing ([(z,S)] ++ E) e T ->
  typing E u S ->
  typing E ([z ~> u] e) T.
Proof.
(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** * Type soundness *)
(*************************************************************************)

(*************************************************************************)
(** ** Preservation *)
(*************************************************************************)

(** *** Recommended Exercise [preservation]

    Complete the proof of preservation.  In this proof, we proceed by
    induction on the given typing derivation.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Variables don't step.

      - [typing_abs] case: Abstractions don't step.

      - [typing_app] case: By case analysis on how [e] steps. The
        [step_beta] case is interesting, since it follows by the
        substitution lemma.  The others follow directly from the
        induction hypotheses.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to perform case analyses and to rule out
         impossible cases.

       - In the [step_beta] subcase of the [typing_app] case:

          -- Use [inversion] on a typing judgement to obtain a
             hypothesis about when the body of the abstraction is
             well-typed.

          -- Use [subst_exp_intro] to rewrite the [open] operation
             into an [open] followed by a [subst].  You'll need to
             pick a fresh variable first using the
             [pick fresh x for S] tactic.

  *)

Lemma preservation : forall (E : ctx) e e' T,
  typing E e T ->
  step e e' ->
  typing E e' T.
Proof.
  intros E e e' T H.
  generalize dependent e'.
  induction H; intros e' J.
(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** ** Progress *)
(*************************************************************************)

(** *** Exercise [progress]

    Complete the proof of the progress lemma.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Can't happen; the empty context doesn't
        bind anything.

      - [typing_abs] case: Abstractions are values.

      - [typing_app] case: Applications reduce.  The result follows
        from an exhaustive case analysis on whether the two components
        of the application step or are values and the fact that a
        value must be an abstraction.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to rule out impossible cases.

       - The lemma [typing_to_lc_exp] will be useful for reasoning
         about local closure.

       - In the [typing_app] case:

          -- Use [destruct] to perform a case analysis on the
             conclusions of the induction hypotheses.

          -- Use [inversion] on a [value] judgement to determine that
             the value must be an abstraction.
  *)

Lemma progress : forall e T,
  typing nil e T ->
  is_value e \/ exists e', step e e'.
Proof.
  intros e T H.

  (* It will be useful to have a "non-destructed" form of the given
     typing derivation, since [induction] takes apart the derivation
     it is called on. *)
  assert (typing nil e T); auto.

  (* [remember nil as E] fails here because [nil] takes an implicit
     argument that Coq is unable to infer.  By prefixing [nil] with
     [@], we can supply the argument to nil explicitly. *)
  remember (@nil (atom * typ)) as E.

  induction H; subst.

(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** * Tactic support *)
(*************************************************************************)

(** When picking a fresh var or applying a rule that uses cofinite
    quantification, choosing a set of vars to be fresh for can be
    tedious.  In practice, it is simpler to use a tactic to choose the
    set to be as large as possible.

    The tactic [gather_atoms] is used to collect together all the
    atoms in the context.  It relies on an auxiliary tactic,
    [gather_atoms_with] (from MetatheoryAtom), which maps a function
    that returns a finite set of atoms over all hypotheses with the
    appropriate type.
*)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  constr:(A `union` B `union` C `union` D).

(** A number of other, useful tactics are defined by the Metatheory
    library, and each depends on [gather_atoms].  By redefining
    [gather_atoms], denoted by the [::=] in its definition below, we
    automatically update these tactics so that they use the proper
    notion of "all atoms in the context."

    For example, the tactic [(pick fresh x)] chooses an atom fresh for
    "everything" in the context.  It is the same as [(pick fresh x for
    L)], except where [L] has been computed by [gather_atoms].

*)

(*************************************************************************)
(** * Renaming *)
(*************************************************************************)

(** Substitution and weakening together give us a property we call
   renaming: (see [typing_rename below] that we can change the name
   of the variable used to open an expression in a typing
   derivation. In practice, this means that if a variable is not
   "fresh enough" during a proof, we can use this lemma to rename it
   to one with additional freshness constraints.

   Renaming is used below to show the correspondence between the
   exists-fresh version of the rules with the cofinite version, and
   also to show that typechecking is decidable.
*)

(** However, before we prove renaming, we need an auxiliary lemma about
    typing judgments which says that terms are well-typed only in
    unique contexts.
*)

Lemma typing_uniq : forall E e T,
  typing E e T -> uniq E.
Proof.
  intros E e T H.
  induction H; auto.
  - Case "typing_abs".
    pick fresh x.
    assert (uniq ([(x, T1)] ++ G)); auto.
    solve_uniq.
Qed.

(** Demo: the proof of renaming.

   Note that this proof does not proceed by induction: even if we add
   new typing rules to the language, as long as the weakening and
   substution properties hold we can use this proof.
*)
Lemma typing_rename : forall (x y : atom) E e T1 T2,
  x `notin` fv_exp e ->
  y `notin` dom E ->
  typing ([(x, T1)] ++ E) (e ^ x) T2 ->
  typing ([(y, T1)] ++ E) (e ^ y) T2.
Proof.
  intros x y E e T1 T2 Fr1 Fr2 H.
  destruct (x == y).
  - Case "x = y".
    subst; eauto.
  - Case "x <> y".
    assert (J : uniq ([(x, T1)] ++ E)).
      eapply typing_uniq; eauto.
    assert (J' : uniq E).
      inversion J; eauto.
    rewrite (@subst_exp_intro x); eauto.
    rewrite_env (nil ++ [(y, T1)] ++ E).
    apply typing_subst with (S := T1).
    simpl_env.
    + SCase "(open x s) is well-typed".
      apply typing_weakening_strengthened. eauto. auto.
    + SCase "y is well-typed".
      eapply typing_var; eauto.
Qed.

(*************************************************************************)
(** ** Exists-Fresh Definition *)
(*************************************************************************)

(** The use of cofinite quantification may make some people worry that we
    are not formalizing the "right" language. Below, we show that
    the "exists-fresh" version of the rules is the same as the cofinite
    version. *)

Lemma typing_abs_exists : forall E e T1 T2 (x : atom),
      x `notin` dom E \u fv_exp e ->
      typing ([(x,T1)] ++ E) (e ^ x) T2 ->
      typing E (abs e) (typ_arrow T1 T2).
Proof.
  intros.
  apply typing_abs with (L := dom E \u fv_exp e).
  intros y Fr.
  apply typing_rename with (x:=x); auto.
Qed.

(** *** Exercise [exists_cofinite] *)

Lemma exists_cofinite : forall E e T,
    typing_e E e T -> typing E e T.
Proof.
  (* FILL IN HERE *) Admitted.

(** *** Exercise [cofinite_exists] *)

Lemma cofinite_exists : forall G e T,
    typing G e T -> typing_e G e T.
Proof. (* FILL IN HERE *) Admitted.

(***********************************************************************)
(** ** Additional Exercises                                            *)
(***********************************************************************)

(** *** Challenge Exercise [fv_in_dom]

   We also want a property that states that the free variables of well-typed
   terms are contained within the domain of their typing contexts.

 *)
Lemma fv_in_dom : forall G e T,
    typing G e T -> fv_exp e [<=] dom G.
Proof.
  (* FILL IN HERE *) Admitted.