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

Require Import PeanoNat tools Bool.

Notation ϒ := unit.
Notation υ := tt.

Inductive bintree : Set := leaf : bool -> bintree | node : bintree -> bintree -> bintree.

Notation " 𝟣 " := (leaf true).
Notation " 𝟢 " := (leaf false).
Infix " ⊎ " := node (at level 40).

Fixpoint type (t : bintree) : Set :=
  match t with
  | 𝟣 => ϒ
  | 𝟢 => False
  | t1 ⊎ t2 => type t1 + type t2
  end.

Notation " ⟨ t ⟩ " := (type t).

Fixpoint domain (t : bintree) : list ⟨t⟩ :=
  match t with
  | 𝟣 => [υ]
  | 𝟢 => []
  | t1 ⊎ t2 => map inl (domain t1) ++ map inr (domain t2)
  end.

Notation " ⟪ t ⟫ " := (domain t).
Definition 𝒫 t := subsets ⟪t⟫.

Global Instance size_type : Size bintree := fun t => ⎢⟪t⟫⎥.

Remark size_leaf_true : ⎢𝟣⎥ = 1.
Proof. reflexivity. Qed.
Remark size_leaf_false : ⎢𝟢⎥ = 0.
Proof. reflexivity. Qed.
Remark size_node s t : ⎢s ⊎ t⎥ = ⎢s⎥+⎢t⎥.
Proof. unfold size,size_type;rsimpl; reflexivity. Qed.
Hint Rewrite size_leaf_true size_leaf_false size_node : simpl_rewrite.

Lemma domain_nodup t : NoDup ⟪t⟫.
Proof.
  induction t as [[]|];simpl.
  - apply NoDup_cons;[simpl;tauto|].
    apply NoDup_nil.
  - apply NoDup_nil.
  - apply NoDup_app.
    + intros [];repeat rewrite in_map_iff;intros (b&<-&Ib) (c&F&Ic);discriminate.
    + apply NoDup_map_injective,IHt1.
      split;intros x y E;inversion E;reflexivity.
    + apply NoDup_map_injective,IHt2.
      split;intros x y E;inversion E;reflexivity.
Qed.

Lemma domain_spec t x : x ∈ ⟪t⟫.
Proof.
  revert x;induction t as [[]|];simpl.
  - intros [];simpl;tauto.
  - intro a;apply a.
  - intros [x|x];apply in_app_iff;[left|right];apply in_map_iff;exists x;intuition.
Qed.
Hint Resolve domain_spec.

Corollary domain_incl t l : l ⊆ ⟪t⟫.
Proof. intros x _;auto. Qed.
Hint Resolve domain_incl.

Lemma domain_equiv t l : ⟪t⟫ ⊆ l -> ⟪t⟫ ≈ l.
Proof. intros h;apply antisymmetry;[apply h|auto]. Qed.

Lemma 𝒫_spec t l : exists m, m ∈ 𝒫 t /\ l ≈ m.
Proof. apply subsets_spec;auto. Qed.

Lemma 𝒫_NoDup t l : l ∈ 𝒫 t -> NoDup l.
Proof. apply subsets_NoDup,domain_nodup. Qed.
Hint Resolve 𝒫_NoDup.

Global Instance decidable_type t : decidable_set ⟨t⟩.
Proof.
  induction t as [[]|].
  - apply Build_decidable_set with (eqX := fun _ _ => true).
    intros [] [];apply ReflectT;reflexivity.
  - apply Build_decidable_set with (eqX := fun _ _ => false).
    intros [].
  - simpl;apply dec_sum;assumption.
Qed.

Definition complement t (D : list ⟨t⟩) := (fun e => negb (inb e D)):> ⟪t⟫.
Notation " ¬ " := complement.

Lemma complement_spec t (e : ⟨t⟩) D : ~ e ∈ D <-> e ∈ ¬ D.
Proof. unfold complement;rewrite filter_In,negb_true_iff,inb_false;split;auto||tauto. Qed.

Lemma NoDup_complement t (D : list ⟨t⟩): NoDup (¬D).
Proof. apply filter_NoDup,domain_nodup. Qed.

Global Instance complement_proper {t} :
  Proper (@equivalent ⟨t⟩ ==> @equivalent ⟨t⟩) (@complement t).
Proof. intros l m E e;rewrite <- complement_spec,E,complement_spec;reflexivity. Qed.

Lemma complement_nil t : ¬ [] ≈ ⟪t⟫.
Proof. intro e;rewrite <- complement_spec;simpl;split;auto. Qed.
Lemma complement_full t : ¬ ⟪t⟫ ≈ [].
Proof. intro e;rewrite <- complement_spec;simpl;split;auto. Qed.

(** * Decidable propositions *)
Class DecidableProp (P : Prop) := dec_prop: {P} + {~ P}.
Arguments dec_prop : clear implicits.
Arguments dec_prop P {DecidableProp}.

Ltac case_prop p :=
  let D := fresh "D" in
  let hyp := fresh "hyp" in
  destruct (dec_prop p) as [hyp|hyp].

Global Instance DecidableProp_Eq (A : Set) (x y : A) :
  decidable_set A -> DecidableProp (x=y).
Proof. intro;destruct_eqX x y;[left;reflexivity|right;assumption]. Qed.
Global Instance DecidableProp_In (A : Set) (x : A) l :
  decidable_set A -> DecidableProp (x ∈ l).
Proof. intro;case_in x l;[left|right];assumption. Qed.
Global Instance DecidableProp_Incl (A : Set) (l m : list A) :
  decidable_set A -> DecidableProp (l ⊆ m).
Proof.
  intro;case_eq (inclb l m);intro h;[left|right];
    revert h;[|rewrite <- not_true_iff_false];rewrite inclb_correct;tauto.
Qed.
Global Instance DecidableProp_Equiv (A : Set) (l m : list A) :
  decidable_set A -> DecidableProp (l ≈ m).
Proof.
  intro;case_eq (equivalentb l m);intro h;[left|right];
    revert h;[|rewrite <- not_true_iff_false];rewrite equivalentb_spec;tauto.
Qed.

Definition test (p : Prop) {d : DecidableProp p} : bool :=
  if (dec_prop p) then true else false.

Arguments test p {d}.

Lemma test_reflect p `{DecidableProp p} : reflect p (test p).
Proof. unfold test;case_prop p;[apply ReflectT|apply ReflectF];assumption. Qed.

Global Instance DecidableProp_neg p : DecidableProp p -> DecidableProp (~p).
Proof. intro D;case_prop p;[right|left];tauto. Qed.

Global Instance DecidableProp_conj p1 p2 :
  DecidableProp p1 -> DecidableProp p2 -> DecidableProp (p1 /\ p2).
Proof. intros D1 D2;case_prop p1;case_prop p2;(left;tauto)||(right;tauto). Qed.

Global Instance DecidableProp_disj p1 p2 :
  DecidableProp p1 -> DecidableProp p2 -> DecidableProp (p1 \/ p2).
Proof. intros D1 D2;case_prop p1;case_prop p2;(left;tauto)||(right;tauto). Qed.

Global Instance DecidableProp_impl p1 p2 :
  DecidableProp p1 -> DecidableProp p2 -> DecidableProp (p1 -> p2).
Proof. intros D1 D2;case_prop p1;case_prop p2;(left;tauto)||right;tauto. Qed.

Global Instance DecidableProp_iff p1 p2 :
  DecidableProp p1 -> DecidableProp p2 -> DecidableProp (p1 <-> p2).
Proof. intros D1 D2;case_prop p1;case_prop p2;(left;tauto)||right;tauto. Qed.

Global Instance DecidableProp_forall_bnd (A : Set) p l :
  (forall a : A, DecidableProp (p a)) ->
  DecidableProp (forall a, a ∈ l -> p a).
Proof.
  intros dp.
  case_eq (forallb (fun a => test (p a)) l);intro E;[left|right].
  - rewrite forallb_forall in E.
    intros a Ia.
    apply E in Ia.
    rewrite reflect_iff by apply test_reflect.
    assumption.
  - apply forallb_false_exists in E as (a&Ia&Fa).
    intros h;apply h in Ia.
    rewrite reflect_iff in Ia by apply test_reflect.
    rewrite Ia in Fa;discriminate.
Qed.

Global Instance DecidableProp_exists_bnd (A : Set) p l :
  (forall a : A, DecidableProp (p a)) -> DecidableProp (exists a, a ∈ l /\ p a).
Proof.
  intros dp.
  case_eq (existsb (fun a => test (p a)) l);intro E;[left|right].
  - apply existsb_exists in E as (a&Ia&Pa).
    rewrite <- reflect_iff in Pa by apply test_reflect.
    exists a;tauto.
  - intros (a&Ia&Pa);apply not_true_iff_false in E;apply E,existsb_exists.
    exists a;split;[assumption|].
    rewrite <- reflect_iff by apply test_reflect.
    assumption.
Qed.

Global Instance DecidableProp_forall_fn t p :
  (forall x : ⟨t⟩, DecidableProp (p x)) -> DecidableProp (forall x, p x).
Proof.
  intro D;case_prop (forall x, x ∈ ⟪t⟫ -> p x);[left|right].
  - intros x;apply hyp;auto.
  - intros h;apply hyp;intros x Ix;apply h.
Qed.

Global Instance DecidableProp_exists_fn t p :
  (forall x : ⟨t⟩, DecidableProp (p x)) -> DecidableProp (exists x, p x).
Proof.
  intro D;case_prop (exists x, x ∈ ⟪t⟫ /\ p x);[left|right].
  - destruct hyp as (x&Ix&Px);exists x;assumption.
  - intros (x&Px);apply hyp;exists x;split;auto.
Qed.

Global Instance DecidableProp_equiv_prop p q :
  DecidableProp p -> (p <-> q) -> DecidableProp q.
Proof. intros D E;case_prop p;[left|right];rewrite <- E;assumption. Qed.

Ltac prove_proper :=
  match goal with
  | _ : _ |- Proper ((@equivalent _) ==> iff) _ =>
    let l := fresh "l" in
    let m := fresh "m" in
    let E := fresh "E" in
    intros l m E;setoid_rewrite E;reflexivity
  end.

Lemma bounded_universal_quantification t p :
  Proper ((@equivalent _) ==> iff) p -> (forall x, x ∈ 𝒫 t -> p x) <-> (forall x, p x).
Proof.
  intros E;split;[|intuition].
  intros h x; destruct (𝒫_spec x) as (l&I&->).
  apply h,I.
Qed.

Lemma bounded_existantial_quantification t p :
  Proper ((@equivalent _) ==> iff) p -> (exists x, x ∈ 𝒫 t /\ p x) <-> (exists x, p x).
Proof.
  intros E;split;[firstorder|].
  intros (x&hx); destruct (𝒫_spec x) as (y&Iy&Ey).
  setoid_rewrite Ey in hx;exists y;tauto.
Qed.

Ltac simpl_quantif :=
  repeat (setoid_rewrite bounded_universal_quantification;[|prove_proper])
  || (setoid_rewrite bounded_existantial_quantification;[|prove_proper]).
Tactic Notation "simpl_quantif" "in" hyp(h) :=
  repeat (setoid_rewrite bounded_universal_quantification in h;[|prove_proper])
  || (setoid_rewrite bounded_existantial_quantification in h;[|prove_proper]).

Lemma dec_prop_set t p : (forall x : ⟨t⟩, DecidableProp (p x)) -> { l | forall e, e ∈ l <-> p e}.
Proof.
  intro h;exists ((fun x => test (p x)) :> ⟪t⟫);intro e.
  rewrite filter_In,<- reflect_iff by apply test_reflect;intuition auto.
Qed.

Lemma dec_prop_powerset t p :
  (forall x : list ⟨t⟩, DecidableProp (p x)) -> { l | forall e, e ∈ 𝒫 t -> e ∈ l <-> p e}.
Proof.
  intros D;exists ((fun x => test (p x)) :> 𝒫 t);intro e.
  rewrite filter_In,<- reflect_iff by apply test_reflect;intuition auto.
Qed.

Lemma dec_prop_powerset_bnd t p L :
  (forall x : list ⟨t⟩, DecidableProp (p x)) -> {l | forall e, e ∈ l <-> e ∈ L /\ p e}.
Proof.
  intros D;exists ((fun x => test (p x)) :> L);intro e.
  rewrite filter_In,<- reflect_iff by apply test_reflect;intuition auto.
Qed.

(** * Injective, surjective and bijective functions over finite types. *)
Global Instance decidable_injective s t (f : ⟨s⟩ -> ⟨t⟩) : DecidableProp (injective f).
Proof.
  eapply DecidableProp_equiv_prop;[|split;[intro h;split;apply h|intros [h];apply h]].
  typeclasses eauto.
Qed.

Global Instance decidable_surjective s t (f : ⟨s⟩ -> ⟨t⟩) : DecidableProp (surjective f).
Proof.
  eapply DecidableProp_equiv_prop;[|split;[intro h;split;apply h|intros [h];apply h]].
  typeclasses eauto.
Qed.

Global Instance decidable_bijective s t (f : ⟨s⟩ -> ⟨t⟩) :  DecidableProp (bijective f).
Proof.
  case_prop (injective f);[case_prop (surjective f);[left;split;assumption|]|];
    right;intros [I S];tauto.
Qed.

Lemma injective_inverse s t (f : ⟨s⟩ -> ⟨t⟩) :
  injective f -> { g | (forall a, g (f a) = Some a) /\ forall a b, g b = Some a -> f a = b }.
Proof.
  intros I.
  set (g' := fun b => (fun a => f a =?= b) :> ⟪s⟫).
  set (g := fun b => match g' b with a::_ => Some a | _ => None end).
  exists g;split.
  - intros a;unfold g,g'.
    case_eq ((fun a0 : ⟨s⟩ => f a0 =?= f a) :> ⟪s⟫).
    + intro F;exfalso.
      cut (a ∈ []);[intro FF;apply FF|].
      rewrite <- F;clear F.
      simpl_In.
      rewrite eqX_correct.
      split;[apply domain_spec|reflexivity].
    + intros b ? E;f_equal.
      apply I.
      cut (b ∈ (b :: l));[|now left].
      rewrite <- E;clear E.
      simpl_In.
      rewrite eqX_correct.
      tauto.
  - intros a b;unfold g,g'.
    case_eq ((fun a0 : ⟨s⟩ => f a0 =?= b) :> ⟪s⟫);[discriminate|].
    intros c ? E ee;inversion ee;subst;clear ee.
    cut (a ∈ (a :: l));[|now left].
    rewrite <- E;clear E.
    simpl_In.
    rewrite eqX_correct.
    tauto.
Qed.

Lemma injective_inverse_iff s t (f : ⟨s⟩ -> ⟨t⟩) :
  injective f <-> exists g, (forall a, g (f a) = Some a) /\ forall a b, g b = Some a -> f a = b.
Proof.
  split;[intro I;destruct (injective_inverse I) as (g&hg);exists g;apply hg|].
  intros (g&h1&_).
  split;intros a b E.
  cut (Some a = Some b);[intros EE;inversion EE;reflexivity|].
  rewrite <- (h1 a),E, (h1 b);reflexivity.
Qed.

Lemma exists_unique_function_from_empty_type s :
  ⟪s⟫ = [] -> forall t, { f : ⟨s⟩ -> ⟨t⟩ | forall g a, f a = g a }.
Proof.
  induction s as [[]|].
  - discriminate.
  - intros D t; exists (fun x : False => match x with end);intros g a.
    pose proof (domain_spec a) as F;exfalso;rewrite D in F;apply F.
  - simpl;intros D t.
    apply app_eq_nil in D as (D1&D2).
    apply map_eq_nil in D1.
    apply map_eq_nil in D2.
    destruct (IHs1 D1 t) as (f1&_).
    destruct (IHs2 D2 t) as (f2&_).
    exists (fun x => match x with inl y => f1 y | inr y => f2 y end);intros ? a.
    pose proof (@domain_spec (s1 ⊎ s2) a) as F;exfalso;simpl in *.
    rewrite D1,D2 in F;apply F.
Qed.

Lemma bijective_inverse s t (f : ⟨s⟩ -> ⟨t⟩) :
  bijective f -> { g | (forall a, g (f a) = a) /\ forall b, f (g b) = b }.
Proof.
  intros (I&S).
  cut (⟨s⟩ + {⟪s⟫ = [] /\ ⟪t⟫ = []}).
  - intros [a0|F].
    + destruct (injective_inverse I) as (g&h1&h2).
      set (g' := fun b => match g b with Some a => a | None => a0 end).
      exists g';split.
      * intro a;unfold g'.
         rewrite h1;reflexivity.
      * intros b;unfold g'.
         destruct (is_surjective b) as (a&<-).
         rewrite h1;reflexivity.
    + clear I S.
      destruct F as (F1&F2).
      destruct (exists_unique_function_from_empty_type F1 t) as (f'&_).
      destruct (exists_unique_function_from_empty_type F2 s) as (g'&_).
      exists g';split;intros a;pose proof (domain_spec a) as F;exfalso;
        [rewrite F1 in F|rewrite F2 in F];apply F.
  - case_eq ⟪s⟫;[|intros a ? _;left;exact a].
    intros Ds;right;split;[reflexivity|].
    case_eq ⟪t⟫;[reflexivity|].
    intros b ? _;exfalso.
    destruct (is_surjective b) as (a&_).
    cut (a ∈ []);[intro F;apply F|].
    rewrite <- Ds;apply domain_spec.
Qed.

Definition inverse { s t } (f : ⟨s⟩ -> ⟨t⟩) {b : bijective f} :=
  proj1_sig (bijective_inverse b).
Arguments inverse : clear implicits.
Arguments inverse { s t } f { b }.
Notation " f ̃ " := (inverse f) (at level 0).

Lemma inverse_compose_id1 { s t } (f : ⟨s⟩ -> ⟨t⟩) {b : bijective f} : f ̃ ∘ f ≃ id.
Proof.
  unfold inverse;destruct (bijective_inverse b) as (g&(h1&h2));simpl;intro x;apply h1.
Qed.
Lemma inverse_compose_id2 { s t } (f : ⟨s⟩ -> ⟨t⟩) {b : bijective f} : f ∘ (f ̃) ≃ id.
Proof.
  unfold inverse;destruct (bijective_inverse b) as (g&(h1&h2));simpl;intro;apply h2.
Qed.

Lemma inverse_elim1 { s t } (f : ⟨s⟩ -> ⟨t⟩) {b : bijective f} x : f ̃ (f x) = x.
Proof.
  unfold inverse;destruct (bijective_inverse b) as (g&(h1&h2));simpl;apply h1.
Qed.
Lemma inverse_elim2 { s t } (f : ⟨s⟩ -> ⟨t⟩) {b : bijective f} x : f (f ̃ x) = x.
Proof.
  unfold inverse;destruct (bijective_inverse b) as (g&(h1&h2));simpl;apply h2.
Qed.

Lemma bijective_inverse_iff s t (f : ⟨s⟩ -> ⟨t⟩) :
  bijective f <-> exists g, (forall a, g (f a) = a) /\ forall b, f (g b) = b.
Proof.
  split;[intro B;exists (f ̃);split;[apply inverse_compose_id1|apply inverse_compose_id2]|].
  intros (g&h1&h2);split;split.
  - intros x y E;rewrite <- (h1 x),E,h1;reflexivity.
  - intros y;exists (g y);apply h2.
Qed.

Lemma is_injective_sequiv {A B} (f : A -> B) :
  injective f -> forall C, forall g h : C -> A, f ∘ g ≃ f ∘ h -> g ≃ h .
Proof. intros Inj C g h E x;apply is_injective,E. Qed.

Lemma inverse_unique s t (ϕ : ⟨s⟩ -> ⟨t⟩) `{bijective _ _ ϕ}:
  forall ψ, (ϕ ∘ ψ ≃ id) -> ψ ≃ ϕ ̃.
Proof.
  intros ψ h.
  eapply is_injective_sequiv;[apply H|].
  rewrite h,inverse_compose_id2;reflexivity.
Qed.

Lemma inverse_compose s t u ϕ ψ `{bijective ⟨s⟩ ⟨t⟩ ϕ} `{bijective ⟨t⟩ ⟨u⟩ ψ} :
  (ψ ∘ ϕ)̃ ≃ ϕ ̃ ∘ ψ ̃.
Proof.
  symmetry;apply inverse_unique.
  transitivity (ψ ∘ (ϕ ∘ (ϕ) ̃) ∘ (ψ) ̃);[repeat rewrite compose_assoc;reflexivity|].
  rewrite inverse_compose_id2,compose_id_r,inverse_compose_id2;reflexivity.
Qed.

Lemma inverse_proper s t ϕ ψ `{bijective ⟨s⟩ ⟨t⟩ ϕ} `{bijective ⟨s⟩ ⟨t⟩ ψ} :
  ϕ ≃ ψ -> ϕ ̃ ≃ ψ ̃.
Proof.
  intros E;apply inverse_unique.
  rewrite <- E,inverse_compose_id2;reflexivity.
Qed.

Global Instance inverse_bijective s t ϕ `{bijective ⟨s⟩ ⟨t⟩ ϕ} : bijective (ϕ ̃).
Proof.
  apply bijective_inverse_iff;exists ϕ;split;[apply inverse_compose_id2
                                        |apply inverse_compose_id1].
Qed.

Lemma inverse_id s : (@id ⟨s⟩) ̃ ≃ id.
Proof. symmetry;apply inverse_unique;reflexivity. Qed.

Lemma inverse_involutive s t ϕ `{bijective ⟨s⟩ ⟨t⟩ ϕ} : ϕ ̃ ̃ ≃ ϕ.
Proof. symmetry;apply inverse_unique,inverse_compose_id1. Qed.

Lemma inverse_eq_iff s t ϕ `{bijective ⟨s⟩ ⟨t⟩ ϕ} x y : ϕ ̃ x = y <-> x = ϕ y.
Proof.
  split;intro;subst;[symmetry;apply inverse_compose_id2
                    |apply (inverse_compose_id1 y)].
Qed.

Lemma injective_size s t (f : ⟨s⟩ -> ⟨t⟩) : injective f -> ⎢s⎥ <= ⎢t⎥.
Proof.
  intros I.
  unfold size,size_type.
  transitivity ⎢map f ⟪s⟫⎥;[rsimpl;reflexivity|].
  apply NoDup_incl_length.
  - apply NoDup_map_injective,domain_nodup;assumption.
  - intros ? _;apply domain_spec.
Qed.
Lemma surjective_size s t (f : ⟨s⟩ -> ⟨t⟩) : surjective f -> ⎢t⎥ <= ⎢s⎥.
Proof.
  intros I.
  unfold size,size_type.
  transitivity ⎢map f ⟪s⟫⎥;[|rsimpl;reflexivity].
  apply NoDup_incl_length.
  - apply domain_nodup.
  - intros ? _;apply in_map_iff.
    destruct (is_surjective a) as (b&<-).
    exists b;split;[reflexivity|apply domain_spec].
Qed.

Corollary bijective_size s t (f : ⟨s⟩ -> ⟨t⟩) : bijective f -> ⎢t⎥ = ⎢s⎥.
Proof.
  intros (h1&h2);apply antisymmetry;[eapply surjective_size|eapply injective_size];
    eassumption.
Qed.

Lemma injective_size_bijective s t (f : ⟨s⟩ -> ⟨t⟩) :
  injective f -> ⎢t⎥ <= ⎢s⎥ -> bijective f.
Proof.
  intros I len;split;[assumption|].
  case_eq (forallb (fun a => existsb (fun b => f b =?= a) ⟪s⟫)
                   ⟪t⟫);intro E.
  - revert E.
    rewrite forallb_forall.
    setoid_rewrite existsb_exists.
    setoid_rewrite eqX_correct.
    intros E;split.
    intros y;destruct (E y) as (x&_&<-).
    + apply domain_spec.
    + exists x;reflexivity.
  - revert E.
    rewrite forallb_false_exists.
    intros (a&Ia&E).
    apply not_true_iff_false in E.
    rewrite existsb_exists in E.
    setoid_rewrite eqX_correct in E.
    pose proof (map_length f ⟪s⟫) as F.
    exfalso.
    cut (S ⎢s⎥ <= ⎢t⎥);[revert len;clear;lia|].
    transitivity (⎢a :: rm a (map f ⟪s⟫)⎥).
    + rsimpl.
      rewrite rm_notin;[rsimpl;reflexivity|].
      rewrite in_map_iff;intros (b&<-&Ib);apply E;exists b;tauto.
    + apply NoDup_incl_length.
      * apply NoDup_cons.
        -- rewrite rm_In;tauto.
        -- apply filter_NoDup,NoDup_map_injective,domain_nodup;apply I.
      * intros ? _;apply domain_spec.
Qed.

Lemma surjective_size_bijective s t (f : ⟨s⟩ -> ⟨t⟩) :
  surjective f -> ⎢s⎥ <= ⎢t⎥ -> bijective f.
Proof.
  intros hS len;split;[|assumption].
  case_eq (existsb (fun a => existsb (fun b => negb (a =?= b) && f a =?= f b) ⟪s⟫)
                   ⟪s⟫);intro E.
  - exfalso;revert E.
    rewrite existsb_exists.
    setoid_rewrite existsb_exists.
    setoid_rewrite andb_true_iff.
    setoid_rewrite negb_true_iff.
    setoid_rewrite eqX_false.
    setoid_rewrite eqX_correct.
    intros (x&Ix&y&Iy&N&E).
    cut (⎢ x :: ⟪s⟫ ∖ x ⎥ <= ⎢map f (⟪s⟫ ∖ x) ⎥);[clear;rsimpl;lia|].
    transitivity ⎢t⎥.
    + rewrite <- len.
      apply NoDup_incl_length.
      * apply NoDup_cons.
        -- rewrite rm_In;tauto.
        -- apply filter_NoDup,domain_nodup.
      * rewrite <- rm_equiv by assumption;reflexivity.
    + apply NoDup_incl_length.
      * apply domain_nodup.
      * intros a _;apply in_map_iff;destruct (is_surjective a) as (b&<-).
        destruct_eqX x b;subst.
        -- exists y;split;[symmetry;assumption|].
           apply rm_In;split;[apply domain_spec|assumption].
        -- exists b;split;[reflexivity|].
           apply rm_In;split;[apply domain_spec|assumption].
  - split;intros x y Exy;destruct_eqX x y;[reflexivity|exfalso].
    apply not_true_iff_false in E;apply E.
    rewrite existsb_exists;setoid_rewrite existsb_exists.
    setoid_rewrite andb_true_iff.
    setoid_rewrite negb_true_iff.
    setoid_rewrite eqX_false.
    setoid_rewrite eqX_correct.
    exists x;split;[apply domain_spec|].
    exists y;split;[apply domain_spec|].
    tauto.
Qed.
Corollary endofunction_injective_iff_bijective s (f : ⟨s⟩ -> ⟨s⟩) :
  injective f <-> bijective f.
Proof. split;intro h;[apply injective_size_bijective;[|reflexivity]|];apply h. Qed.
Corollary endofunction_surjective_iff_bijective s (f : ⟨s⟩ -> ⟨s⟩) :
  surjective f <-> bijective f.
Proof. split;intro h;[apply surjective_size_bijective;[|reflexivity]|];apply h. Qed.

(** * Pre-Image *)

Remark preimage_dec {s t} (f : ⟨s⟩ -> ⟨t⟩) l a : DecidableProp (exists b, b ∈ l /\ f a = b).
Proof. typeclasses eauto. Qed.

Definition preimage {s t} (f : ⟨s⟩ -> ⟨t⟩) l :=
  proj1_sig (dec_prop_set (preimage_dec f l)).

Notation " f ¯¹ " := (preimage f) (at level 40).

Lemma preimage_spec {s t} (f : ⟨s⟩ -> ⟨t⟩) l a :
  a ∈  f ¯¹ l <-> exists b, b ∈ l /\ f a = b.
Proof. unfold preimage;destruct (dec_prop_set _) as (L&hL);simpl;apply hL. Qed.

Lemma preimage_inverse s t f `{bijective ⟨s⟩ ⟨t⟩ f} l : f ¯¹ l ≈ map (f ̃) l.
Proof.
  intro a;rewrite preimage_spec,in_map_iff.
  setoid_rewrite inverse_eq_iff.
  setoid_rewrite and_comm at 2.
  assert (E: forall x y : ⟨t⟩, x = y <-> y = x) by (firstorder subst;reflexivity).
  setoid_rewrite E at 1;reflexivity.
Qed.

(** * Correspondance with lists. *)

Fixpoint bintree_of_nat n :=
  match n with
  | 0 => 𝟢
  | S n => 𝟣 ⊎ (bintree_of_nat n)
  end.

Lemma bintree_of_nat_size n : ⎢ bintree_of_nat n ⎥ = n.
Proof. induction n;[|rsimpl;rewrite size_node,IHn;simpl];reflexivity. Qed.

Definition 𝒯 {A} (l : list A) := (bintree_of_nat ⎢l⎥).
Fixpoint 𝒯e {A : Set} (l : list A) : ⟨𝒯 l⟩ -> A :=
  match l with
  | [] => fun x : False => match x with end
  | a::l => fun x => match x with inl _ => a | inr y => @𝒯e A l y end
  end.
Notation 𝒯l l := (@𝒯e _ l).

Lemma translation_internal {A:Set} (l : list A) (a : ⟨𝒯 l⟩) : 𝒯e a ∈ l.
Proof. revert a;induction l;intros [];simpl;intuition. Qed.

Lemma translation_invert {A:Set} `{decidable_set A} (l : list A) a :
  a ∈ l -> { b : ⟨𝒯 l⟩ | 𝒯e b = a}.
Proof.
  revert a;induction l;simpl.
  - tauto.
  - intros b.
    destruct_eqX a b.
    + intros _;exists (inl υ);reflexivity.
    + case_in b l.
      * intros _;destruct (IHl b I) as (c&<-).
        exists (inr c);reflexivity.
      * intros F;exfalso.
        apply I;destruct F as [->|F];tauto.
Qed.

Lemma translation_total {A:Set} (l : list A) a : a ∈ l -> exists b : ⟨𝒯 l⟩, 𝒯e b = a.
Proof.
  revert a;induction l;simpl.
  - tauto.
  - intros b [<-|Ib].
    + exists (inl υ);reflexivity.
    + destruct (IHl b Ib) as (c&<-).
      exists (inr c);reflexivity.
Qed.

Lemma translation_injective {A : Set} (l : list A) :
  NoDup l -> injective (𝒯l l).
Proof.
  induction l;simpl.
  - split;intros _ [].
  - intros ND;apply NoDup_cons_iff in ND as (nI&ND).
    pose proof (IHl ND) as ih;clear IHl.
    split;intros [[]|] [[]|].
    + reflexivity.
    + intros ->;exfalso;apply nI,translation_internal.
    + intros <-;exfalso;apply nI,translation_internal.
    + intros E;apply ih in E as ->;reflexivity.
Qed.

Lemma incl_set_pred_make_function {A B : Set} (l : list (list A)) (m : list (list B)) f :
  injective f -> NoDupEq l -> map (map f) l ≲ m ->
  exists g : ⟨𝒯 l⟩ -> ⟨𝒯 m⟩, (forall x, map f (𝒯e x) ≈ 𝒯e (g x)) /\ injective g.
Proof.
  intro Inj;induction l.
  - intros _ _;exists (fun x : False => match x with end).
    split;[|split];intros [].
  - intros (nI&ND).
    intros hyp.
    destruct (IHl ND) as (g&hg&Ig).
    + intros b Ib;apply hyp;right;apply Ib.
    + destruct (hyp (map f a)) as (b&Ib&Eb);[now left|].
      destruct (translation_total Ib) as (k&<-).
      case_in k (map g ⟪𝒯 l⟫).
      * exfalso.
        apply in_map_iff in I as (t&<-&It).
        rewrite <- hg in Eb.
        apply (nI _ (translation_internal t)).
        intros x;split.
        -- intros Ix;cut (f x ∈ map f a);[rewrite Eb|];rewrite in_map_iff.
           ++ intros (y&E&Iy);apply Inj in E as ->;assumption.
           ++ exists x;tauto.
        -- intros Ix;cut (f x ∈ map f (𝒯e t));[rewrite <- Eb|];
             rewrite in_map_iff.
           ++ intros (y&E&Iy);apply Inj in E as ->;assumption.
           ++ exists x;tauto.
      * exists (fun x => match x with inl _ => k | inr y => g y end).
        split.
        -- intros [[]|].
           ++ simpl;assumption.
           ++ rewrite <- hg;simpl;reflexivity.
        -- split;intros [[]|] [[]|].
           ++ reflexivity.
           ++ intros -> ;exfalso;apply I,in_map_iff;exists t;split;auto.
           ++ intros <- ;exfalso;apply I,in_map_iff;exists t;split;auto.
           ++ intro;f_equal;apply Ig;assumption.
Qed.

(** * Fixpoints *)
Section fixpoints.
  Context {t : bintree} {f : ⟨t⟩ -> ⟨t⟩} {a : ⟨t⟩}.

  Definition iterator i := map (fun k => iter_fun f k a) (seq 0 (S i)).

  Notation Ω := iterator.

  Lemma iterator_spec : forall n x, x ∈ Ω n <-> exists m, m <= n /\ x = iter_fun f m a.
  Proof.
    intros n x;unfold Ω.
    rewrite in_map_iff.
    setoid_rewrite in_seq;simpl.
    split;intros (k&E1&E2);subst;exists k;split;reflexivity||lia.
  Qed.

  Lemma iterator_Sn : forall n, Ω (S n) = Ω n ++[iter_fun f (S n) a].
  Proof.
    intro n;unfold Ω.
    replace (S (S n)) with (S n + 1) by lia.
    cut (forall k s, seq s (k + 1) = seq s k ++ [s+k]).
    - intros ->;rewrite map_app;reflexivity.
    - clear;intro k;induction k;[intro s;simpl;f_equal;lia|].
      intros s;simpl;rewrite IHk;f_equal;f_equal;f_equal;lia.
  Qed.

  Lemma iterator_incr k :  iter_fun f (S k) a ∈ Ω k \/ ⎢{{Ω (S k)}}⎥ = S (S k).
  Proof.
    induction k.
    - simpl;unfold Basics.compose,id;simpl.
      destruct_eqX a (f a);simpl;auto.
      repeat rewrite <- E;auto.
    - destruct IHk as [ih|ih].
      + left;rewrite iterator_Sn.
        rewrite in_app_iff.
        apply iterator_spec in ih as (m&Im&E).
        destruct_eqX k m.
        * right;left.
          simpl in *;unfold Basics.compose in *.
          repeat rewrite E;reflexivity.
        * left;apply iterator_spec;exists (S m).
          split;[lia|].
          simpl in *;unfold Basics.compose in *.
          repeat rewrite E;reflexivity.
      + case_in (iter_fun f (S (S k)) a) (Ω (S k));[tauto|].
        right.
        rewrite iterator_Sn.
        replace {{Ω (S k) ++ [iter_fun f (S (S k)) a]}}
          with ({{Ω (S k)}}++ [iter_fun f (S (S k)) a]);
          [rsimpl in *;rewrite ih;simpl;lia|].
        revert I;generalize (iter_fun f (S (S k)) a);
          generalize (Ω (S k));clear.
        intro l;induction l;simpl.
        * reflexivity.
        * intros b Nb.
          case_in a {{l}};case_in a {{l++[b]}}.
          -- apply IHl;tauto.
          -- exfalso;apply I0;simpl_In in *;tauto.
          -- exfalso;apply I;simpl_In in *;simpl in I0.
             firstorder subst;tauto.
          -- simpl;rewrite IHl;[reflexivity|tauto].
  Qed.

  Corollary exists_max_iterator : exists k, iter_fun f (S k) a ∈ Ω k.
  Proof.
    destruct (iterator_incr ⎢ t ⎥) as [E|FF].
    - exists ⎢t⎥;assumption.
    - exfalso;cut (⎢ {{Ω (S ⎢t⎥)}} ⎥ <= ⎢t⎥);[lia|].
      apply NoDup_incl_length;[apply NoDup_undup|auto].
  Qed.

  Proposition exists_iterates_list : exists L, forall x, (exists n, iter_fun f n a = x) <-> x ∈ L.
  Proof.
    destruct exists_max_iterator as (k&Ek).
    exists (Ω k);split.
    - intros (n&<-).
      induction n.
      + apply iterator_spec;exists 0;split;[lia|reflexivity].
      + apply iterator_spec in IHn as (m&Im&E).
        apply Nat.succ_le_mono in Im.
        apply Nat.le_succ_r in Im as [Im|Im].
        * apply iterator_spec;exists (S m);split;[assumption|].
          simpl;unfold Basics.compose;rewrite E;reflexivity.
        * inversion Im;subst.
          simpl;unfold Basics.compose;rewrite E;tauto.
    - rewrite iterator_spec;intros (n&_&->);exists n;reflexivity.
  Qed.

  Theorem exists_loop : exists n m, n < m /\ iter_fun f n a = iter_fun f m a.
  Proof.
    destruct exists_max_iterator as (k&Ik).
    apply iterator_spec in Ik as (m&hm&E).
    exists m,(S k);split;[lia|symmetry;assumption].
  Qed.
End fixpoints.

Theorem exists_uniform_fixpoint t (f : ⟨t⟩ -> ⟨t⟩) :
  injective f -> exists ω, forall a, iter_fun f (S ω) a = a.
Proof.
  intro Inj;cut (forall a b, f a = f b <-> a = b);
    [clear Inj;intro Inj|intros ? ?;split;[apply Inj|intros ->;reflexivity]].
  cut (exists N, forall a, a ∈ ⟪t⟫ -> iter_fun f (S N) a = a);
    [intros (N&hN);exists N;intro a;apply hN;auto|].
  cut (forall a, exists N, iter_fun f (S N) a = a).
  - intro hyp.
    induction ⟪t⟫.
    + exists 0;simpl;tauto.
    + destruct (hyp a) as (Na&Ea).
      destruct IHl as (Nl&El).
      exists ((S Na)*(S Nl)-1).
      replace (S((S Na)*(S Nl)-1)) with ((S Na)*(S Nl)).
      * intros b [<-|Ib].
        -- rewrite Nat.mul_comm,iter_fun_times.
           apply iter_fun_fix,Ea.
        -- rewrite iter_fun_times;apply iter_fun_fix,El,Ib.
      * simpl;lia.
  - intro a.
    destruct (@exists_loop _ f a) as (n&m&L&E).
    revert m L E;induction n;[intros [|m] L E;[lia|exists m;symmetry;apply E]|].
    intros [|m] L E;[lia|].
    simpl in E.
    unfold Basics.compose in E.
    rewrite Inj in E.
    apply (IHn m);lia||assumption.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 5 *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

Set Implicit Arguments.

(** * Universal polymorphism *)

(* In this problem set you will be asked to add universal polymorphism to
 * simply typed lambda calculus.  Universal polymorphism is the formal concept
 * underneath C++'s templates and Java's generics.  The idea is to let something
 * (a function, a class, etc.) be usable with different types.  For example,
 * instead of having a length function with type [list Nat -> Nat] for lists of
 * natural numbers and another one with type [list String -> Nat] for lists of
 * strings, we can have a single length function [length] with type
 * [\forall X. list X -> Nat].  Here [X] is a *type variable*, standing for an
 * abitrary type that will be given later.  [length] is defined as
 * [\\X. \ls : list X. ...].  The [\\X. _] part is called a *type abstraction*,
 * saying that this term is type-generic with regard to type [X]. To specialize
 * [length] for lists of natural numbers, we explicitly write [length [Nat] ],
 * which is called a specialization or *type application*.  A type of the form
 * [\forall X. _] is called a universal type.
 *
 * In summary, to add universal polymorphism, we need to add three things to the
 * language:
 * (1) universal types (the type for type-generic terms): [\forall X. t]
 * (2) type abstraction (the introduction form for type-generic terms): [\\X. e]
 * (3) type application (the elimination form): [e [t] ].
 *
 * The word "polymorphism" in the functional-programming community means using
 * universal types to write type-generic code, hence the name "universal
 * polymorphism."  The kind of "polymorphism" used in the OOP community, dealing
 * with late binding and dynamic dispatch, is called "ad-hoc polymorphism".
 *)

(* Syntax of types *)
Inductive type :=
| Nat
| Fun (dom ran : type)
(* new stuff from here *)
| VarT (a : var)
(* A type could be a type variable, introduced somewhere else. *)
| Universal (a : var) (t : type)
(* Universal type [\forall X. t] *)
.

(* Expression syntax *)
Inductive exp :=
| Var (x : var)
| Const (n : nat)
| Plus (e1 e2 : exp)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)
(* new stuff from here *)
| AbsT (x : var) (e1 : exp)
(* Type abstraction [\\X. e] *)
| AppT (e1 : exp) (t : type)
(* Type application [e [t] ] *)
.

(* Values (final results of evaluation) *)
Inductive value : exp -> Prop :=
| VConst : forall n, value (Const n)
| VAbs : forall x e1, value (Abs x e1)
| VAbsT : forall x e, value (AbsT x e)
(* Type abstraction is also a value. *)
.

(* Substitution (not capture-avoiding, for the usual reason) *)
Fixpoint subst (e1 : exp) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => if y ==v x then e1 else Var y
  | Const n => Const n
  | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
  | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
  | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
  | AbsT y e2' => AbsT y (subst e1 x e2') (* type variables and term variables are in different namespaces, so it doesn't matter whether y = x here *)
  | AppT e2' t => AppT (subst e1 x e2') t
  end.

(* Substitution of type in type (not capture-avoiding, for the usual reason) *)
Fixpoint subst_t_t (t1 : type) (x : var) (t2 : type) : type :=
  match t2 with
  | Nat => Nat
  | Fun t2' t2'' => Fun (subst_t_t t1 x t2') (subst_t_t t1 x t2'')
  | VarT y => if y ==v x then t1 else VarT y
  | Universal y t2' => Universal y (if y ==v x then t2' else subst_t_t t1 x t2')
  end.

(* Substitution of type in exp (not capture-avoiding, for the usual reason) *)
Fixpoint subst_t_e (t1 : type) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => Var y
  | Const n => Const n
  | Plus e2' e2'' => Plus (subst_t_e t1 x e2') (subst_t_e t1 x e2'')
  | Abs y e2' => Abs y (subst_t_e t1 x e2')
  | App e2' e2'' => App (subst_t_e t1 x e2') (subst_t_e t1 x e2'')
  | AbsT y e2' => AbsT y (if y ==v x then e2' else subst_t_e t1 x e2')
  | AppT e2' t2' => AppT (subst_t_e t1 x e2') (subst_t_t t1 x t2')
  end.

(* Evaluation contexts *)
Inductive context :=
| Hole
| Plus1 (C : context) (e2 : exp)
| Plus2 (v1 : exp) (C : context)
| App1 (C : context) (e2 : exp)
| App2 (v1 : exp) (C : context)
| CtxAppT (C : context) (t : type)
.

(* Plugging an expression into a context *)
Inductive plug : context -> exp -> exp -> Prop :=
| PlugHole : forall e, plug Hole e e
| PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
| PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
| PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
| PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')
| PlugAppT : forall e e' C t,
    plug C e e' ->
    plug (CtxAppT C t) e (AppT e' t)
(* Evaluate the type-generic term to a value before subsituting for type. *)
.

(* Small-step, call-by-value evaluation *)
Inductive step0 : exp -> exp -> Prop :=
| Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
| Add : forall n1 n2,
    step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
| BetaT : forall x e t,
    step0 (AppT (AbsT x e) t) (subst_t_e t x e)
(* Replace formal type argument [x] with actual type [t]. *)
.

Inductive step : exp -> exp -> Prop :=
| StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

Definition trsys_of (e : exp) := {|
  Initial := {e};
  Step := step
|}.

(* Type well-formedness *)
(* Because now we have the ability to write nonsense types (e.g. by misspelling
 * type variables), we need to define what types are well-formed.  This
 * definition also takes in a set of variable names to be the set of visible
 * type variables, called a type-variable context or kinding context.
 * We use [fmap var unit] as [set var], to avoid reasoning about both [fmap] and
 * [set], to keep things simple.  Notice, then, the similarities with the
 * original typing judgment for simply typed lambda calculus.  The difference
 * here is that type variables don't have their own "types"; they're just
 * in-scope or not! *)
Inductive wfty : fmap var unit -> type -> Prop :=
| WfNat : forall L,
    wfty L Nat
| WfFun : forall L t1 t2,
    wfty L t1 ->
    wfty L t2 ->
    wfty L (Fun t1 t2)
| WfVarT : forall L x,
    L $? x = Some tt ->
    wfty L (VarT x)
| WfUniversal : forall L x t,
    wfty (L $+ (x, tt)) t ->
    wfty L (Universal x t)
.

(* Expression typing relation *)
(* Now the typing relation also needs to take in a kinding context as
 * argument. *)
Inductive hasty : fmap var unit -> fmap var type -> exp -> type -> Prop :=
| HtVar : forall L G x t,
    G $? x = Some t
    -> wfty L t (* Need to make sure [t] is well-formed. *)
    -> hasty L G (Var x) t
| HtConst : forall L G n,
    hasty L G (Const n) Nat
| HtPlus : forall L G e1 e2,
    hasty L G e1 Nat
    -> hasty L G e2 Nat
    -> hasty L G (Plus e1 e2) Nat
| HtAbs : forall L G x e1 t1 t2,
    hasty L (G $+ (x, t1)) e1 t2
    -> hasty L G (Abs x e1) (Fun t1 t2)
| HtApp : forall L G e1 e2 t1 t2,
    hasty L G e1 (Fun t1 t2)
    -> hasty L G e2 t1
    -> hasty L G (App e1 e2) t2
| HtAbsT : forall L G x e t,
    (* To avoid capturing type variables in the typing context, we empty out
     * the latter!  This is a restriction of the expressiveness of the language
     * due to our simplistic treatment of [subst].  We can think of this
     * restriction as saying that polymorphism is only allowed at the beginning
     * of a top-level function definition, rather than nested within terms at
     * arbitrary positions. *)
    hasty (L $+ (x, tt)) $0 e t
    -> hasty L G (AbsT x e) (Universal x t)
| HtAppT : forall L G e x t1 t2 t,
    hasty L G e (Universal x t1)
    (* Our non-capture-avoiding subsitution is only sound when [t2] is a
     * closed type. *)
    -> wfty $0 t2 (* Need to make sure [t2] is well-formed. *)
    -> t = subst_t_t t2 x t1
    -> hasty L G (AppT e t2) t
.

Hint Constructors value plug step0 step wfty hasty.

(* BEGIN some automation magic. The [t] tactic will be handy for you. *)

Ltac with12 t := (t; []) || (t; [|]).

Ltac t0 := match goal with
           | [ H : ex _ |- _ ] => invert H
           | [ H : _ /\ _ |- _ ] => invert H
           | [ |- context[?x ==v ?y] ] => cases (x ==v y); simplify
           | [ |- context[_ $+ (?x, _) $? ?y] ] => cases (x ==v y); simplify
           | [ H : step _ _ |- _ ] => invert H
           | [ H : step0 _ _ |- _ ] => invert1 H
           | [ H : hasty _ _ ?e _, H' : value ?e |- _ ] => with12 ltac:(invert H'; invert H)
           | [ H : hasty _ _ _ _ |- _ ] => invert2 H
           | [ H : plug _ _ _ |- _ ] => invert1 H
           | [ H : Some _ = Some _ |- _ ] => invert H
           | [ H : wfty _ _ |- _ ] => invert2 H
           end; subst.

Ltac t := simplify; subst; propositional; repeat (t0; simplify); try equality.

(* End automation magic. Don't forget to try the [t] tactic. *)

(* Some lemmas to guide automation *)

Lemma weakening_override : forall V G G' (x : var) (t : V),
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                -> G' $+ (x, t) $? x' = Some t').
Proof.
  t; eauto.
Qed.

Hint Resolve weakening_override.

(* Replacing a typing context with an equal one has no effect (useful to guide
 * proof search). *)
Lemma hasty_change : forall L G e t,
    hasty L G e t
    -> forall G', G' = G
            -> hasty L G' e t.
Proof.
  t.
Qed.

Hint Resolve hasty_change.

(* The counterpart of [hasty_change] for type variables *)
Lemma hasty_change_t : forall L G e t,
    hasty L G e t
    -> forall L', L' = L
            -> hasty L' G e t.
Proof.
  t.
Qed.

Hint Resolve hasty_change_t.

Module Type S.

  (* We provide you some lemma statements as a roadmap for the final theorem. *)

  (* Raising a typing derivation to a larger typing context *)
  Axiom weakening : forall L G e t,
    hasty L G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
                  -> hasty L G' e t.

  (* The counterpart of [weakening] for [wfty] *)
  Axiom weakening_wfty : forall L t,
      wfty L t
      -> forall L', (forall x t, L $? x = Some t -> L' $? x = Some t)
                    -> wfty L' t.

  (* The counterpart of [weakening] for type variables *)
  Axiom weakening_t : forall L G e t,
      hasty L G e t
      -> forall L', (forall x t, L $? x = Some t -> L' $? x = Some t)
                    -> hasty L' G e t.

  (* Replacing a variable with a properly typed term preserves typing. *)
  Axiom substitution : forall L G x t' e t e',
      hasty L (G $+ (x, t')) e t
      -> hasty $0 $0 e' t'
      -> hasty L G (subst e' x e) t.

  (* Replacing a type variable with a well-formed type preserves typing. *)
  Axiom substitution_t_e : forall L G x e t t',
      hasty (L $+ (x, tt)) G e t
      -> wfty $0 t'
      (* G' is a supermap of [fmap_map (subst_t_t t' x) G], where [fmap_map f m] means
       * apply [f] to every domain value in [m].  [fmap_map] is not defined in [Frap],
       * so we use this Prop-y version. *)
      -> forall G',
          (forall y t, G $? y = Some t -> G' $? y = Some (subst_t_t t' x t)) ->
          hasty L G' (subst_t_e t' x e) (subst_t_t t' x t).

  (* This is the final safety theorem we really want. *)
  Axiom safety : forall e t, hasty $0 $0 e t
                             -> invariantFor (trsys_of e)
                                             (fun e' => value e'
                                                        \/ exists e'', step e' e'').

End S.


Require Import List.
Import ListNotations.

Require Import JRWTactics.

Require Import EQ ANY MAP.

Set Firstorder Solver (subst; eauto).

Module alist (K : EQ) (V : ANY) : MAP with Definition key := K.t with Definition value := V.t.
  Definition key := K.t.
  Definition value := V.t.

  Definition t := list (key * value).

  Definition empty : t := nil.

  Fixpoint alist_get (k : key) (m : t) : option value  :=
    match m with
    | [] => None
    | (k1,v1) :: m' => if K.t_eq_dec k k1 then Some v1 else alist_get k m'
    end.

  Definition get := alist_get.

  Definition shadow (k : key) (v : value) (m : t) : t := (k,v) :: m.

  Fixpoint alist_delete (k : key) (m : t) : t :=
    match m with
    | [] => m
    | (k1,v1) :: m' => if K.t_eq_dec k k1 then alist_delete k m' else (k1,v1) :: alist_delete k m'
    end.

  Definition delete := alist_delete.

  Lemma alist_get_delete_same :
    forall k a,
      alist_get k (alist_delete k a) = None.
  Proof.
    induction a; simpl; intros.
    - auto.
    - repeat (break_match; simpl); subst; congruence.
  Qed.

  Lemma alist_get_delete_diff :
    forall k k' a,
      k <> k' ->
      alist_get k' (alist_delete k a) = alist_get k' a.
  Proof.
    induction a; simpl; intros.
    - auto.
    - repeat (break_match; simpl); subst; auto; congruence.
  Qed.

  Lemma alist_get_shadow_same :
    forall k v a,
      alist_get k (shadow k v a) = Some v.
  Proof.
    intros.
    simpl. break_if; congruence.
  Qed.

  Lemma alist_get_shadow_diff :
    forall k k' v a,
      k <> k' ->
      alist_get k' (shadow k v a) = alist_get k' a.
  Proof.
    intros.
    simpl. break_if; congruence.
  Qed.

  Lemma get_empty :
    forall k,
      get k empty = None.
  Proof.
    auto.
  Qed.

  Lemma delete_shadow_same :
    forall k v m,
      alist_delete k (shadow k v m) = alist_delete k m.
  Proof.
    intros.
    simpl. break_if; congruence.
  Qed.

  Lemma delete_shadow_diff :
    forall k' k v m,
      k <> k' ->
      alist_delete k' (shadow k v m) = shadow k v (alist_delete k' m).
  Proof.
    intros.
    simpl. break_if; try congruence.
    auto.
  Qed.

  Lemma delete_empty :
    forall k,
      alist_delete k empty = empty.
  Proof.
    auto.
  Qed.

  Definition get_shadow_same := alist_get_shadow_same.
  Definition get_shadow_diff := alist_get_shadow_diff.

  Definition get_delete_same := alist_get_delete_same.
  Definition get_delete_diff := alist_get_delete_diff.
End alist.


(** * Common facts about UIP and proof irrelevance *)
Require Coq.Strings.String.
Require Import Coq.Logic.EqdepFacts.

Set Implicit Arguments.

Lemma Eq_rect_eq_UIP_helper {U x y} (p : x = y :> U)
: p = match p in (_ = y) return (x = y) with eq_refl => eq_refl end.
Proof.
  destruct p; reflexivity.
Defined.

Lemma Eq_rect_eq_UIP_ U : Eq_rect_eq U -> UIP_ U.
Proof.
  lazy; intro H.
  intros x y p1 p2.
  destruct p2.
  specialize (H x (fun y => x = y) eq_refl p1); simpl in *.
  rewrite <- Eq_rect_eq_UIP_helper in H.
  symmetry; assumption.
Qed.

Definition dec_eq_adjust' {U x} (p : forall y : U, {x = y} + {x <> y}) y
: {x = y} + {x <> y}
  := match p x, p y with
       | left pf, left pf' => left (eq_trans (eq_sym pf) pf')
       | right pf, _ => match pf eq_refl with end
       | _, right pf => right pf
     end.

Lemma concat_Vp {U x y} (p : x = y :> U)
: eq_trans (eq_sym p) p = eq_refl.
Proof.
  destruct p; reflexivity.
Defined.

Lemma dec_eq_uip' {U x y} (pf : x = y)
      (p : forall y : U, {x = y} + {x <> y})
: pf = match dec_eq_adjust' p y with
         | left pf' => pf'
         | right pf' => match pf' pf with end
       end.
Proof.
  destruct pf.
  unfold dec_eq_adjust'.
  destruct (p x) as [|n].
  { symmetry; apply concat_Vp. }
  { destruct (n eq_refl). }
Defined.

Lemma dec_eq_uip {U x}
      (dec : forall y : U, {x = y} + {x <> y})
      y
      (p q : x = y :> U)
: p = q.
Proof.
  etransitivity; [ | symmetry ].
  { apply (dec_eq_uip' _ dec). }
  { etransitivity; [ apply (dec_eq_uip' _ dec) | ].
    edestruct @dec_eq_adjust' as [|n]; try reflexivity.
    destruct (n p). }
Qed.

Ltac UIP_by_decide_equality :=
  intros; apply dec_eq_uip; repeat decide equality.

Lemma UIP_bool {x y : bool} (p q : x = y) : p = q.
Proof. UIP_by_decide_equality. Qed.
Lemma UIP_unit {x y : unit} (p q : x = y) : p = q.
Proof. UIP_by_decide_equality. Qed.
Lemma UIP_ascii {x y : Ascii.ascii} (p q : x = y) : p = q.
Proof. UIP_by_decide_equality. Qed.
Lemma UIP_string {x y : String.string} (p q : x = y) : p = q.
Proof. UIP_by_decide_equality. Qed.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.
Require Extraction.

Extraction pred.

Lemma zgtz : 0 > 0 -> False.
  crush.
Qed.

Definition pred_strong1 (n : nat) : n > 0 -> nat :=
  match n with
  | O => fun pf : 0 > 0 => match zgtz pf with end
  | S n' => fun _ => n'
  end.

Theorem two_gt0 : 2 > 0.
  crush.
Qed.

Eval compute in pred_strong1 two_gt0.

Definition pred_strong1' (n : nat) : n > 0 -> nat :=
  match n return n > 0 -> nat with
  | O => fun pf : 0 > 0 => match zgtz pf with end
  | S n' => fun _ => n'
  end.

Extraction pred_strong1.

Print sig.

Locate "{ _ : _ | _ }".

Definition pred_strong2 (s : {n : nat | n > 0}) : nat :=
  match s with
  | exist O pf => match zgtz pf with end
  | exist (S n') _ => n'
  end.

Eval compute in pred_strong2 (exist _ 2 two_gt0).

Extraction pred_strong2.

Definition pred_strong3 (s : {n : nat | n > 0}) : {m : nat | proj1_sig s = S m} :=
  match s return {m : nat | proj1_sig s = S m} with
  | exist O pf => match zgtz pf with end
  | exist (S n') pf => exist _ n' (eq_refl _)
  end.

Eval compute in pred_strong3 (exist _ 2 two_gt0).

Extraction pred_strong3.

Definition pred_strong4 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
            match n with
            | O => fun _ => False_rec _ _
            | S n' => fun _ => exist _ n' _
            end); crush.
Defined.

Print pred_strong4.

Eval compute in pred_strong4 two_gt0.

Definition pred_strong4' : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
            match n with
            | O => fun _ => False_rec _ _
            | S n' => fun _ => exist _ n' _
            end); abstract crush.
Defined.

Print pred_strong4'.

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

Definition pred_strong5 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
            match n with
            | O => fun _ => !
            | S n' => fun _ => [n']
            end); crush.
Defined.

Eval compute in pred_strong5 two_gt0.

Obligation Tactic := crush.

Program Definition pred_strong6 (n : nat) (_ : n > 0) : {m : nat | n = S m} :=
  match n with
  | O => _
  | S n' => n'
  end.

Print sumbool.

Locate "{ _ } + { _ }".

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
  refine (fix f (n m : nat): {n = m} + {n <> m} :=
            match n, m with
            | O, O => Yes
            | S n', S m' => Reduce (f n' m')
            | _, _ => No
            end); congruence.
Defined.

Eval compute in eq_nat_dec 2 2.

Eval compute in eq_nat_dec 2 3.

Extraction eq_nat_dec.

Definition eq_nat_dec' : forall n m : nat, {n = m} + {n <> m}.
  decide equality.
Defined.

Extract Inductive sumbool => "bool" ["true" "false"].
Extraction eq_nat_dec'.

Notation "x || y" := (if x then Yes else Reduce y).

Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.
  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~(In x ls)}.
    refine (fix f (x : A) (ls : list A) : {In x ls} + {~(In x ls)} :=
              match ls with
              | nil => No
              | x' :: ls' => A_eq_dec x x' || f x ls'
              end); crush.
  Defined.
End In_dec.

Eval compute in In_dec eq_nat_dec 2 (1 :: 2 :: nil).

Eval compute in In_dec eq_nat_dec 3 (1 :: 2 :: nil).

Extraction In_dec.

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)).
Notation "??" := (Unknown _).
Notation "[| x |]" := (Found _ x _).

Definition pred_strong7 : forall n : nat, {{m | n = S m}}.
  refine (fun n =>
            match n return {{m | n = S m}} with
            | O => ??
            | S n' => [|n'|]
            end); trivial.
Defined.

Eval compute in pred_strong7 2.

Eval compute in pred_strong7 0.

Print sumor.

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

Definition pred_strong8 : forall n : nat, {m | n = S m} + {n = 0}.
  refine (fun n =>
            match n with
            | O => !!
            | S n' => [||n'||]
            end); trivial.
Defined.

Eval compute in pred_strong8 2.

Eval compute in pred_strong8 0.

Notation "x <- e1 ; e2" := (match e1 with
                            | Unknown => ??
                            | Found x _ => e2
                            end)
                             (right associativity, at level 60).

Definition doublePred : forall n1 n2 : nat, {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
  refine (fun n1 n2 =>
            m1 <- pred_strong7 n1;
            m2 <- pred_strong7 n2;
            [|(m1, m2)|]); tauto.
Defined.

Notation "x <-- e1 ; e2" := (match e1 with
                             | inright _ => !!
                             | inleft (exist x _) => e2
                             end)
                              (right associativity, at level 60).

Definition doublePred' : forall n1 n2 : nat, {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)} + {n1 = 0 \/ n2 = 0}.
  refine (fun n1 n2 =>
            m1 <-- pred_strong8 n1;
            m2 <-- pred_strong8 n2;
            [||(m1, m2)||]); tauto.
Defined.

Inductive exp : Set :=
| Nat : nat -> exp
| Plus : exp -> exp -> exp
| Bool : bool -> exp
| And : exp -> exp -> exp.

Inductive type : Set := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n,
    hasType (Nat n) TNat
| HtPlus : forall e1 e2,
    hasType e1 TNat
    -> hasType e2 TNat
    -> hasType (Plus e1 e2) TNat
| HtBool : forall b,
    hasType (Bool b) TBool
| HtAnd : forall e1 e2,
    hasType e1 TBool
    -> hasType e2 TBool
    -> hasType (And e1 e2) TBool.

Definition eq_type_dec : forall t1 t2 : type, {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

Notation "e1 ;; e2" := (if e1 then e2 else ??)
                         (right associativity, at level 60).

Definition typeCheck : forall e : exp, {{t | hasType e t}}.
  Hint Constructors hasType.

  refine (fix F (e : exp) : {{t | hasType e t}} :=
            match e return {{t | hasType e t}} with
            | Nat _ => [|TNat|]
            | Plus e1 e2 =>
              t1 <- F e1;
              t2 <- F e2;
              eq_type_dec t1 TNat;;
              eq_type_dec t2 TNat;;
              [|TNat|]
            | Bool _ => [|TBool|]
            | And e1 e2 =>
              t1 <- F e1;
              t2 <- F e2;
              eq_type_dec t1 TBool;;
              eq_type_dec t2 TBool;;
              [|TBool|]
            end); crush.
Defined.

Eval simpl in typeCheck (Nat 0).

Eval simpl in typeCheck (Plus (Nat 1) (Nat 2)).

Eval simpl in typeCheck (Plus (Nat 1) (Bool false)).

Extraction typeCheck.

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
                          (right associativity, at level 60).

Lemma hasType_det : forall e t1, hasType e t1 -> forall t2, hasType e t2 -> t1 = t2.
  induction 1; inversion 1; crush.
Qed.

Definition typeCheck' : forall e : exp, {t : type | hasType e t} + {forall t, ~(hasType e t)}.
  Hint Constructors hasType.

  Hint Resolve hasType_det.

  refine (fix F (e : exp) : {t : type | hasType e t} + {forall t, ~(hasType e t)} :=
            match e return {t : type | hasType e t} + {forall t, ~(hasType e t)} with
            | Nat _ => [||TNat||]
            | Plus e1 e2 =>
              t1 <-- F e1;
              t2 <-- F e2;
              eq_type_dec t1 TNat;;;
              eq_type_dec t2 TNat;;;
              [||TNat||]
            | Bool _ => [||TBool||]
            | And e1 e2 =>
              t1 <-- F e1;
              t2 <-- F e2;
              eq_type_dec t1 TBool;;;
              eq_type_dec t2 TBool;;;
              [||TBool||]
            end); clear F; crush' tt hasType; eauto.
Defined.

Eval simpl in typeCheck' (Nat 0).

Eval simpl in typeCheck' (Plus (Nat 1) (Nat 2)).

Eval simpl in typeCheck' (Plus (Nat 1) (Bool false)).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: Ordered.v

    Definition of ordered list and some properties

    Definition: ordered
                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

Require Export List.
From Huffman Require Export Permutation.
From Huffman Require Export Aux.

Section ordered.
Variable A : Type.
Variable order : A -> A -> Prop.
Variable order_trans : forall a b c : A, order a b -> order b c -> order a c.

(* Ordered list with respect to an order *)
Inductive ordered : list A -> Prop :=
  | ordered_nil : ordered nil
  | ordered_one : forall a : A, ordered (a :: nil)
  | ordered_cons :
      forall (a b : A) (l : list A),
      order a b -> ordered (b :: l) -> ordered (a :: b :: l).
Hint Constructors ordered : core.

(* Inversion theorem *)
Theorem ordered_inv_order :
 forall (a b : A) (l : list A), ordered (a :: b :: l) -> order a b.
Proof using.
intros a b l H; inversion H; auto.
Qed.

(* Inversion theorem *)
Theorem ordered_inv :
 forall (a : A) (l : list A), ordered (a :: l) -> ordered l.
Proof using.
intros a l H; inversion H; auto.
Qed.

(* The second element of a list can be skipped *)
Theorem ordered_skip :
 forall (a b : A) (l : list A), ordered (a :: b :: l) -> ordered (a :: l).
Proof using A order order_trans.
intros a b l; case l; clear l; auto.
intros c l H; apply ordered_cons.
apply order_trans with (b := b); auto.
apply ordered_inv_order with (1 := H).
apply ordered_inv_order with (1 := ordered_inv _ _ H).
apply ordered_inv with (1 := ordered_inv _ _ H).
Qed.

(* All the element of the list are smaller than the first one *)
Theorem ordered_trans :
 forall (a b : A) (l : list A), ordered (a :: l) -> In b l -> order a b.
Proof using A order order_trans.
intros a b l; generalize a b; elim l; clear l a b.
intros a b H H2; inversion H2.
simpl in |- *; intros c l H a b H0 [H1| H1].
rewrite <- H1; apply ordered_inv_order with (1 := H0).
apply order_trans with (b := c); auto.
apply ordered_inv_order with (1 := H0).
apply H; auto.
apply ordered_inv with (1 := H0).
Qed.

(*
  In an ordered list split in two, elements of the first part
  are always smaller than the ones of the second part
*)
Theorem ordered_trans_app :
 forall (a b : A) (l1 l2 : list A),
 ordered (l1 ++ l2) -> In a l1 -> In b l2 -> order a b.
Proof using A order order_trans.
intros a b l1 l2; generalize a b; elim l1; simpl in |- *; clear l1 a b.
intros a b H H1; case H1.
intros c l H a b H0 [H1| H1] H2.
rewrite <- H1; apply ordered_trans with (1 := H0); auto with datatypes.
apply H; auto.
apply ordered_inv with (1 := H0); auto.
Qed.

(* If the order is antisymmetric, there is only one ordered list *)
Theorem ordered_perm_antisym_eq :
 (forall a b : A, order a b -> order b a -> a = b) ->
 forall l1 l2 : list A,
 permutation l1 l2 -> ordered l1 -> ordered l2 -> l1 = l2.
Proof using A order order_trans.
intros antisym l1; elim l1; clear l1; simpl in |- *; auto.
intros l2 H1 H2 H3; apply sym_equal; apply permutation_nil_inv.
apply permutation_sym; auto.
intros a l1 Rec l2; case l2; simpl in |- *.
intros H; absurd (length (a :: l1) = length (A:=A) nil).
simpl in |- *; red in |- *; intros; discriminate.
apply permutation_length; auto.
intros a0 l H H0 H1.
cut (a = a0).
intros H3; apply f_equal2 with (f := cons (A:=A)); auto.
apply Rec; auto.
apply permutation_inv with (a := a); auto.
pattern a at 2 in |- *; rewrite H3; auto.
apply ordered_inv with (1 := H0); auto.
apply ordered_inv with (1 := H1); auto.
generalize (permutation_in _ a _ _ H); simpl in |- *;
 (intros H2; case H2; auto; clear H2; intros H2).
generalize (permutation_in _ a0 _ _ (permutation_sym _ _ _ H)); simpl in |- *;
 (intros H3; case H3; auto; clear H3; intros H3).
apply antisym.
apply ordered_trans with (1 := H0); auto.
apply ordered_trans with (1 := H1); auto.
Qed.

End ordered.
Hint Constructors ordered : core.
Arguments ordered [A].

(* Ordered list are preserved by maps *)
Theorem ordered_map_inv :
 forall (A B : Type) (order : A -> A -> Prop) (g : B -> A) (l : list B),
 ordered (fun x y => order (g x) (g y)) l -> ordered order (map g l).
Proof using.
intros A B order g l; elim l; simpl in |- *; auto.
intros a1 l1; case l1; simpl in |- *; auto.
intros b l0 H H0; inversion H0; auto.
Qed.


Require Import stdpp.list.
Require Import ssreflect.

Require Import Flowers.Utils.

(** ** Terms *)

Inductive term :=
| TVar (n : nat)
| TFun (f : name) (args : list term).

(* Definition sig : Type :=
  name -> option nat.

Context (Σ : sig).

Definition andb_map {A} (f : A -> bool) (l : list A) : bool :=
  foldr (λ x b, b && f x) true l.

Lemma andb_map_In {A} {f : A -> bool} {x : A} : ∀ (l : list A),
  In x l -> andb_map f l -> f x.
Proof.
  elim => [Hx H |a l IH Hx H].
  * elim Hx.
  * elim Hx => [Heq |HIn];
    rewrite /andb_map//= in H; apply andb_prop_elim in H.
    - rewrite -Heq; easy.
    - apply IH; easy.
Qed.

Fixpoint wf (t : fterm) : bool :=
  match t with
  | TVar _ => true
  | TFun f args =>
      Σ (f, length args) && andb_map wf args
  end.

Definition term :=
  { t : fterm | wf t }. *)

(* Lemma wf_fun_inv f : ∀ args,
  wf (TFun f args) -> Forall wf args.
Proof.
  move => args Hwf.
  apply In_Forall. move => t HIn.
  apply (andb_map_In args); auto.
  rewrite /wf in Hwf.
  apply andb_prop_elim in Hwf. easy.
Qed. *)

Lemma term_induction_full :
  ∀ (P : term -> Prop) (Pn : nat -> Prop)
  (IHn : ∀ n, Pn n)
  (IHvar : ∀ n, Pn n -> P (TVar n))
  (IHfun : ∀ f args, Forall P args -> P (TFun f args)),
  ∀ t, P t.
Proof.
  intros; move: t; fix IH 1; induction t.
  * apply IHvar. apply IHn.
  * apply IHfun. elim args; auto.
Qed.

Lemma term_induction :
  ∀ (P : term -> Prop)
  (IHvar : ∀ n, P (TVar n))
  (IHfun : ∀ f args, Forall P args -> P (TFun f args)),
  ∀ t, P t.
Proof.
  intros. eapply term_induction_full; eauto.
  exact (fun _ => I).
Qed.

Fixpoint tsubst (n : nat) (u : term) (t : term) : term :=
  match t with
  | TVar m => if n =? m then u else t
  | TFun f args => TFun f (tsubst n u <$> args)
  end.

Fixpoint tshift (n : nat) (c : nat) (t : term) : term :=
  match t with
  | TVar m => TVar (if m <? c then m else m + n)
  | TFun f args => TFun f (tshift n c <$> args)
  end.

Fixpoint tunshift (n : nat) (c : nat) (t : term) : term :=
  match t with
  | TVar m => TVar (if m <? c then m else m - n)
  | TFun f args => TFun f (tunshift n c <$> args)
  end.

Lemma tshift_zero c : ∀ t,
  tshift 0 c t = t.
Proof.
  induction t as [|?? IH] using term_induction; simpl.
  * destruct (n <? c); auto.
  * f_equal. rewrite Forall_eq_map in IH.
    by rewrite list_fmap_id in IH.
Qed.

Lemma tshift_add c n m : ∀ t,
  tshift (n + m) c t = tshift n c (tshift m c t).
Proof.
  induction t as [|?? IH] using term_induction; simpl.
  * destruct (n0 <? c) eqn:Heqb.
    by rewrite Heqb.
    assert (Hm : n0 + m <? c = false).
    { rewrite Nat.ltb_nlt in Heqb.
      apply Nat.ltb_nlt. lia. }
    rewrite Hm.
    by rewrite -Nat.add_assoc [m + n]Nat.add_comm Nat.add_assoc.
  * f_equal. rewrite Forall_eq_map in IH.
    by repeat rewrite (list_fmap_compose (tshift _ c)) in IH.
Qed.

Lemma tshift_comm c n m t :
  tshift n c (tshift m c t) = tshift m c (tshift n c t).
Proof.
  by rewrite -tshift_add Nat.add_comm tshift_add.
Qed.

Lemma tunshift_zero c : ∀ t,
  tunshift 0 c t = t.
Proof.
  induction t as [|?? IH] using term_induction; simpl.
  * destruct (n <? c); auto. by rewrite Nat.sub_0_r.
  * f_equal. rewrite Forall_eq_map in IH.
    by rewrite list_fmap_id in IH.
Qed.

Lemma tsubst_tshift c m t :
  tsubst c (TVar (c + m)) (tshift m (S c) t) = tshift m c t.
Proof.
  induction t using term_induction; simpl.
  * case n, c eqn:?; simpl; auto.
    case (S n <? S (S n0)) eqn:?.
    case (n <? n0) eqn:?; simpl.
    assert (S n <? S n0 = true).
    { Search (_ <? _ = true).
      rewrite Nat.ltb_lt in Heqb0.
      apply lt_n_S in Heqb0.
      rewrite -Nat.ltb_lt in Heqb0.
      auto. }
    rewrite H.
    assert (n0 =? n = false).
    { Search "ltb_lt".
      apply Nat.ltb_lt in Heqb0.
      apply Nat.lt_neq in Heqb0.
      apply Nat.neq_sym in Heqb0.
      by apply Nat.eqb_neq in Heqb0. }
    by rewrite H0.
    case (n0 =? n) eqn:?.
    apply Nat.eqb_eq in Heqb1.
    rewrite Heqb1.
    assert (S n <? S n = false).
    { by apply Nat.ltb_irrefl. }
    by rewrite H.
    assert (S n <? S n0 = false).
    { apply Nat.ltb_nlt.
      apply Nat.ltb_nlt in Heqb0.
      intro; destruct Heqb0.
      Search (S _ < S _ -> _ < _).
      by apply lt_S_n. }
    rewrite H.
    apply Nat.ltb_nlt in Heqb0.
    apply Nat.eqb_neq in Heqb1.
    assert (n <= n0).
    { apply Nat.ltb_lt in Heqb. lia. }
    Search (_ <= _ -> _ \/ _).
    apply le_lt_or_eq in H0.
    intuition. by symmetry in H1.
    assert (S n <? S n0 = false).
    { apply Nat.ltb_nlt in Heqb.
      pose proof (Nat.lt_lt_succ_r (S n) (S n0)).
      pose proof (contrapose H).
      apply Nat.ltb_nlt. by apply H0. }
    rewrite H.
    destruct m eqn:?; simpl.
    repeat rewrite Nat.add_0_r.
    destruct (n0 =? n) eqn:?; auto.
    apply Nat.eqb_eq in Heqb0.
    by rewrite Heqb0.
    assert (n0 =? n + (S n1) = false).
    { apply Nat.eqb_neq. intro.
      rewrite H0 in H.
      apply Nat.ltb_nlt in H.
      lia. }
    by rewrite H0.
  * apply Forall_eq_map in H. rewrite -list_fmap_compose.
    by rewrite H.
Qed.

Lemma tsubst_tshift_vacuous n u m c t :
  n < m ->
  tsubst (n + c) u (tshift m c t) = tshift m c t.
Proof.
  intros H.
  induction t as [|?? IH] using term_induction; simpl.
  * destruct (n0 <? c) eqn:Heqb.
    - assert (Hnc : n + c =? n0 = false).
      { apply Nat.eqb_neq. apply Nat.ltb_lt in Heqb. lia. }
      by rewrite Hnc.
    - assert (Hnc : n + c =? n0 + m = false).
      { apply Nat.eqb_neq. apply Nat.ltb_nlt in Heqb. lia. }
      by rewrite Hnc.
  * apply Forall_eq_map in IH. rewrite -list_fmap_compose.
    by rewrite IH.
Qed.

Lemma tsubst_tshift_vacuous2 : ∀ t m c,
  tsubst c (TVar (c + m)) (tshift m (S c) t) = tshift m c t.
Proof.
  elim/term_induction => [n |f args IH] m c /=.
  * destruct (n <? S c) eqn:Hltb.
    - destruct (c =? n) eqn:Heqb.
      + apply Nat.eqb_eq in Heqb.
        assert (H : n <? c = false).
        { apply Nat.ltb_nlt. lia. }
        by rewrite H Heqb.
      + assert (H : n <? c = true).
        { apply Nat.ltb_lt in Hltb.
          apply Nat.ltb_lt.
          apply Nat.eqb_neq in Heqb.
          lia. }
        by rewrite H.
    - destruct (c =? n + m) eqn:Heqb.
      + apply Nat.eqb_eq in Heqb.
        rewrite Heqb in Hltb.
        apply Nat.ltb_nlt in Hltb.
        lia.
      + assert (H : n <? c = false).
        { apply Nat.ltb_nlt in Hltb.
          apply Nat.ltb_nlt.
          lia. }
        by rewrite H.
  * rewrite Forall_forall in IH; specialize (IH m).
    rewrite Forall_forall in IH; specialize (IH c).
    rewrite Forall_eq_map in IH. rewrite -IH.
    by rewrite -list_fmap_compose.
Qed.

Lemma tunshift_tshift m n c t :
  tunshift (m + n) c (tshift n c t) = tunshift m c t.
Proof.
  induction t using term_induction; simpl.
  * f_equal.
    destruct (n0 <? c) eqn:?. by rewrite Heqb.
    assert (n0 + n <? c = false).
    { apply Nat.ltb_nlt.
      apply Nat.ltb_nlt in Heqb. lia. }
    rewrite H. lia.
  * apply Forall_eq_map in H. rewrite -list_fmap_compose.
    by rewrite H.
Qed.


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

Require Import HoTT.Basics HoTT.Types HoTT.Cubical.
Require Import Extensions EquivalenceVarieties.
Require Import ReflectiveSubuniverse Accessible.
Require Import Homotopy.Suspension.

Local Open Scope nat_scope.
Local Open Scope path_scope.

(** Suppose given a family of maps [f : forall (i:I), S i -> T i].  A type [X] is said to be [f]-local if for all [i:I], the map [(T i -> X) -> (S i -> X)] given by precomposition with [f i] is an equivalence.  Our goal is to show that the [f]-local types form a reflective subuniverse, with a reflector constructed by localization.  That is, morally we want to say

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| islocal_localize : forall i, IsEquiv (fun (g : T i -> X) => g o f i).
>>

This is not a valid HIT by the usual rules, but if we expand out the definition of [IsEquiv] and apply [path_sigma] and [path_forall], then it becomes one.  We get a simpler definition (no 2-path constructors) if we do this with [BiInv] rather than [IsEquiv]:

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| lsect : forall i (g : S i -> X), T i -> X
| lissect : forall i (g : S i -> X) (s : S i), lsect i g (f i s) = g s
| lretr : forall i (g : S i -> X), T i -> X
| lisretr : forall i (h : T i -> X) (t : T i), lretr i (h o f i) t = h t.
>>

This definition works, and from it one can prove that the [f]-local types form a reflective subuniverse.  However, the proof inextricably involves [Funext].  We can avoid [Funext] in the same way that we did in the definition of a [ReflectiveSubuniverse], by using pointwise path-split precomposition equivalences.  Observe that the assertion [ExtendableAlong n f C] consists entirely of points, paths, and higher paths in [C].  Therefore, for any [n] we might choose, we can define [Localize f X] as a HIT to universally force [ExtendableAlong n (f i) (fun _ => Localize f X)] to hold for all [i].  For instance, when [n] is 2 (the smallest value which will ensure that [Localize f X] is actually [f]-local), we get

<<
Inductive Localize f (X : Type) : Type :=
| loc : X -> Localize X
| lrec : forall i (g : S i -> X), T i -> X
| lrec_beta : forall i (g : S i -> X) (s : T i), lrec i g (f i s) = g s
| lindpaths : forall i (h k : T i -> X) (p : h o f i == k o f i) (t : T i), h t = k t
| lindpaths_beta : forall i (h k : T i -> X) (p : h o f i == k o f i) (s : S i),
                     lindpaths i h k p (f i s) = p s.
>>

However, just as for [ReflectiveSubuniverse], in order to completely avoid [Funext] we need the [oo]-version of path-splitness.  Written out as above, this would involve infinitely many constructors (but it would not otherwise be problematic, so for instance it can be constructed semantically in model categories).  We can't actually write out infinitely many constructors in Coq, of course, but since we have a finite definition of [ooExtendableAlong], we can just assert directly that [ooExtendableAlong (f i) (fun _ => Localize f X)] holds for all [i].

Then, however, we have to express the hypotheses of the induction principle.  We know what these should be for each path-constructor and higher path-constructor, so all we need is a way to package up those infinitely many hypotheses into a single one, analogously to [ooExtendableAlong].  Thus, we begin this file by defining a "dependent" version of [ooExtendableAlong], and of course we start this with a version for finite [n].  *)

(** ** Dependent extendability *)

Fixpoint ExtendableAlong_Over@{a b c d m}
         (n : nat) {A : Type@{a}} {B : Type@{b}} (f : A -> B)
         (C : B -> Type@{c})
         (D : forall b, C b -> Type@{d})
         (ext : ExtendableAlong@{a b c m} n f C)
: Type@{m}
  := match n return ExtendableAlong@{a b c m} n f C -> Type@{m} with
       | 0 => fun _ => Unit
       | S n => fun ext' =>
                (forall (g : forall a, C (f a)) (g' : forall a, D (f a) (g a)),
                  sig@{m m}     (** Control universe parameters *)
                  (fun (rec : forall b, D b ((fst ext' g).1 b)) =>
                         forall a, (fst ext' g).2 a # rec (f a) = g' a )) *
                forall (h k : forall b, C b)
                       (h' : forall b, D b (h b)) (k' : forall b, D b (k b)),
                  ExtendableAlong_Over n f (fun b => h b = k b)
                    (fun b c => c # h' b = k' b) (snd ext' h k)
     end ext.
Check ExtendableAlong_Over@{a b c d m}.
(** [ExtendableAlong_Over] takes 5 universe parameters:
    - size of A
    - size of B
    - size of C
    - size of D
    - size of result (>= A,B,C,D) *)

(** Like [ExtendableAlong], these can be postcomposed with known equivalences. *)
Definition extendable_over_postcompose' (n : nat)
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C)
           (D E : forall b, C b -> Type)
           (g : forall b c, D b c <~> E b c)
: ExtendableAlong_Over n f C D ext
  -> ExtendableAlong_Over n f C E ext.
Proof.
  revert C ext D E g; simple_induction n n IHn; intros C ext D E g; simpl.
  1:by apply idmap.
  intros ext'.
  split.
  - intros h k.
    exists (fun b => g b ((fst ext h).1 b)
                     ((fst ext' h (fun a => (g _ _)^-1 (k a))).1 b)).
    intros a.
    refine ((ap_transport ((fst ext h).2 a) (g (f a)) _)^ @ _).
    apply moveR_equiv_M.
    exact ((fst ext' h (fun a => (g _ _)^-1 (k a))).2 a).
  - intros p q p' q'.
    refine (IHn (fun b => p b = q b) _
                (fun b => fun c => transport (D b) c ((g b (p b))^-1 (p' b))
                                   = ((g b (q b))^-1 (q' b)))
                _ _
                (snd ext' p q (fun b => (g b (p b))^-1 (p' b))
                              (fun b => (g b (q b))^-1 (q' b)))).
    intros b c.
    refine (_ oE equiv_moveR_equiv_M _ _).
    apply equiv_concat_l.
    refine (_ @ (ap_transport c (g b) _)^).
    apply ap, symmetry, eisretr.
Defined.

Definition extendable_over_postcompose (n : nat)
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C)
           (D E : forall b, C b -> Type)
           (g : forall b c, D b c -> E b c)
           `{forall b c, IsEquiv (g b c)}
: ExtendableAlong_Over n f C D ext
  -> ExtendableAlong_Over n f C E ext
:= extendable_over_postcompose' n C f ext D E
     (fun b c => Build_Equiv _ _ (g b c) _).

(** And if the dependency is trivial, we obtain them from an ordinary [ExtendableAlong]. *)
Definition extendable_over_const
           (n : nat) {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ExtendableAlong n f C) (D : B -> Type)
: ExtendableAlong n f D
  -> ExtendableAlong_Over n f C (fun b _ => D b) ext.
Proof.
  revert C ext D.
  simple_induction n n IHn; intros C ext D ext'.
  1:exact tt.
  split.
  - intros g g'.
    exists ((fst ext' g').1).
    exact (fun a => transport_const ((fst ext g).2 a) _
                                    @ (fst ext' g').2 a).
  - intros h k h' k'.
    refine (extendable_over_postcompose' _ _ _ _ _ _ _
              (IHn (fun b => h b = k b) (snd ext h k)
                   (fun b => h' b = k' b) (snd ext' h' k'))).
    exact (fun b c => equiv_concat_l (transport_const c (h' b)) (k' b)).
Defined.

(** This lemma will be used in stating the computation rule for localization. *)
Fixpoint apD_extendable_eq (n : nat) {A B : Type} (C : B -> Type) (f : A -> B)
         (ext : ExtendableAlong n f C) (D : forall b, C b -> Type)
         (g : forall b c, D b c)
         (ext' : ExtendableAlong_Over n f C D ext)
         {struct n}
: Type.
Proof.
  destruct n.
  - exact Unit.
  - apply prod.
    + exact (forall (h : forall a, C (f a)) (b : B),
               g b ((fst ext h).1 b) = (fst ext' h (fun a => g (f a) (h a))).1 b).
    + exact (forall h k, apD_extendable_eq
                           n A B (fun b => h b = k b) f (snd ext h k)
                           (fun b c => c # g b (h b) = g b (k b))
                           (fun b c => apD (g b) c)
                           (snd ext' h k _ _)).
Defined.

(** Here's the [oo]-version. *)
Definition ooExtendableAlong_Over
         {A B : Type} (f : A -> B) (C : B -> Type)
         (D : forall b, C b -> Type) (ext : ooExtendableAlong f C)
  := forall n, ExtendableAlong_Over n f C D (ext n).
(** Universe parameters are the same as for [ExtendableAlong_Over]. *)
Check ooExtendableAlong_Over@{a b c d r}.

(** The [oo]-version for trivial dependency. *)
Definition ooextendable_over_const
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ooExtendableAlong f C) (D : B -> Type)
: ooExtendableAlong f D
  -> ooExtendableAlong_Over f C (fun b _ => D b) ext
:= fun ext' n => extendable_over_const n C f (ext n) D (ext' n).

(** A crucial fact: the [oo]-version is inherited by types of homotopies. *)
Definition ooextendable_over_homotopy
           {A B : Type} (C : B -> Type) (f : A -> B)
           (ext : ooExtendableAlong f C)
           (D : forall b, C b -> Type)
           (r s : forall b c, D b c)
: ooExtendableAlong_Over f C D ext
  -> ooExtendableAlong_Over f C (fun b c => r b c = s b c) ext.
Proof.
  intros ext' n.
  revert C ext D r s ext'.
  simple_induction n n IHn; intros C ext D r s ext'.
  1:exact tt.
  split.
  - intros g g'.
    simple refine (_;_); simpl.
    + intros b.
      refine (_ @ (fst (snd (ext' 2) _ _
                            (fun b' => r b' ((fst (ext n.+1) g).1 b'))
                            (fun b' => s b' ((fst (ext n.+1) g).1 b')))
                       (fun _ => 1) _).1 b).
      * refine (transport2 (D b) (p := 1) _ _).
        refine ((fst (snd (snd (ext 3) _ _) (fun b' => 1)
                          ((fst (snd (ext 2) _ _) (fun a : A => 1)).1)
                ) _).1 b); intros a.
        symmetry; refine ((fst (snd (ext 2) _ _) (fun a' => 1)).2 a).
      * intros a; simpl.
        refine (_ @
          ap (transport (D (f a)) ((fst (ext n.+1) g).2 a)^) (g' a)
          @ _);
        [ symmetry; by apply apD
        | by apply apD ].
    + intros a; simpl.
      set (h := (fst (ext n.+1) g).1).
      match goal with
          |- context[   (fst (snd (ext' 2) _ _ ?k1 ?k2) (fun _ => 1) ?l).1 ]
          => pose (p := (fst (snd (ext' 2) _ _  k1  k2) (fun _ => 1) l).2 a);
            simpl in p
      end.
      rewrite transport_paths_Fl in p.
      apply moveL_Mp in p.
      refine (ap (transport _ _) (1 @@ p) @ _); clear p.
      unfold transport2; rewrite concat_p_pp.
      match goal with
          |- transport ?P ?p ((ap ?f ?q @ ap ?f ?r) @ ?s) = ?t
          => refine (ap (transport P p) ((ap_pp f q r)^ @@ (idpath s)) @ _)
      end.
      pose (p := (fst (snd (snd (ext 3) h h) (fun b' : B => 1)
                           ((fst (snd (ext 2) h h) (fun a0 : A => 1)).1))
                      (fun a' : A => ((fst (snd (ext 2) h h)
                                           (fun a' : A => 1)).2 a')^)).2 a);
        simpl in p.
      refine (ap (transport _ _) (ap (ap _) (p @@ 1) @@ 1) @ _); clear p.
      rewrite concat_Vp; simpl; rewrite concat_1p.
      refine (transport_paths_FlFr_D _ _ @ _).
      Open Scope long_path_scope.
      Local Opaque transport_pV. (* work around bug 4533 *)
      rewrite !ap_pp, !concat_p_pp, ap_transport_pV, !concat_p_pp.
      Local Transparent transport_pV. (* work around bug 4533 *)
      refine ((((_  @@ 1) @ concat_1p _) @@ 1 @@ 1 @@ 1) @ _).
      * rewrite ap_V, concat_pp_p.
        do 2 apply moveR_Vp.
        rewrite concat_p1.
        symmetry; apply transport_pV_ap.
      * rewrite !concat_pp_p.
        refine ((1 @@ _) @ (concat_p1 _)).
        apply moveR_Vp; rewrite concat_p1.
        apply transport_pV_ap.
      Close Scope long_path_scope.
  - intros h k h' k'.
    refine (extendable_over_postcompose' _ _ _ _ _ _
             (fun b c => equiv_cancelL (apD (r b) c) _ _) _).
    refine (IHn _ _ _ _ _
                (fun n => snd (ext' n.+1) h k
                              (fun b => r b (h b)) (fun b => s b (k b)))).
Qed.

(** ** Local types *)

Import IsLocal_Internal.

Definition islocal_equiv_islocal (f : LocalGenerators@{a})
           (X : Type@{i}) {Y : Type@{j}}
           (Xloc : IsLocal@{i i' a} f X)
           (g : X -> Y) `{IsEquiv@{i j} _ _ g}
: IsLocal@{j j' a} f Y.
Proof.
  intros i.
  (** We have to fiddle with the max universes to get this to work, since [ooextendable_postcompose] requires the max universe in both cases to be the same, whereas we don't want to assume that the hypothesis and conclusion are related in any way. *)
  apply lift_ooextendablealong@{a a j k j'}.
  refine (ooextendable_postcompose@{a a i j k k k k k k}
            _ _ (f i) (fun _ => g) _).
  apply lift_ooextendablealong@{a a i i' k}.
  apply Xloc.
Defined.

(** A basic operation on local generators is the pointwise suspension. *)
Definition susp_localgen (f : LocalGenerators@{a}) : LocalGenerators@{a}.
Proof.
  econstructor; intros i.
  exact (functor_susp@{a a a a a a a a a a a a} (f i)).
Defined.

(** ** Localization as a HIT *)

Module Export LocalizationHIT.

  Private Inductive Localize (f : LocalGenerators@{a}) (X : Type@{i})
  : Type@{max(a,i)} :=
  | loc : X -> Localize f X.

  Arguments loc {f X} x.

  (** Note that the following axiom actually contains a point-constructor.  We could separate out that point-constructor and make it an actual argument of the private inductive type, thereby getting a judgmental computation rule for it.  However, since locality is an hprop, there seems little point to this. *)
  Axiom islocal_localize
  : forall (f : LocalGenerators@{a}) (X : Type@{i}),
      IsLocal@{i k a} f (Localize f X).

  Fixpoint Localize_ind
           (f : LocalGenerators@{a}) (X : Type@{i})
           (P : Localize f X -> Type@{j})
           (loc' : forall x, P (loc x))
           (islocal' : forall i, ooExtendableAlong_Over@{a a i j k}
                                   (f i) (fun _ => Localize@{a i} f X)
                                   (fun _ => P)
                                   (islocal_localize@{a i k} f X i))
           (z : Localize f X) {struct z}
  : P z
    := match z with
         | loc x => fun _ => loc' x
       end islocal'.

  (** We now state the computation rule for [islocal_localize].  Since locality is an hprop, we never actually have any use for it, but the fact that we can state it is a reassuring check that we have defined a meaningful HIT. *)
  Axiom Localize_ind_islocal_localize_beta :
    forall (f : LocalGenerators) (X : Type)
           (P : Localize f X -> Type)
           (loc' : forall x, P (loc x))
           (islocal' : forall i, ooExtendableAlong_Over
                                   (f i) (fun _ => Localize f X)
                                   (fun _ => P)
                                   (islocal_localize f X i))
           i n,
      apD_extendable_eq n (fun _ => Localize f X) (f i)
                        (islocal_localize f X i n) (fun _ => P)
                        (fun _ => Localize_ind f X P loc' islocal')
                        (islocal' i n).

End LocalizationHIT.

(** Now we prove that localization is a reflective subuniverse. *)

Section Localization.

  Context (f : LocalGenerators).

  (** The induction principle is an equivalence. *)
  Definition ext_localize_ind (X : Type)
      (P : Localize f X -> Type)
      (Ploc : forall i, ooExtendableAlong_Over
                          (f i) (fun _ => Localize f X)
                          (fun _ => P) (islocal_localize f X i))
  : ooExtendableAlong loc P.
  Proof.
    intros n; generalize dependent P.
    simple_induction n n IHn; intros P Ploc.
    1:exact tt.
    split.
    - intros g.
      exists (Localize_ind f X P g Ploc).
      intros x; reflexivity.
    - intros h k; apply IHn; intros i m.
      apply ooextendable_over_homotopy.
      exact (Ploc i).
  Defined.

End Localization.

(** We define a wrapper around [LocalGenerators].  See the comments in HIT/Truncations for an explanation.  Unlike there, here we make the wrapper a [Record] rather than a [Definition], so that a projection has to be inserted to convert one to the other.  This forces us to write [Loc f] as a parameter to all reflective-subuniverse functions, which is really entirely reasonable; we only allowed ourselves to write [n] rather than [Tr n] in the case of truncations because things like connectedness are traditionally defined only for the truncation modality, so users may prefer not to have to think about the fact that there is a modality present. *)
Record Localization_ReflectiveSubuniverse := Loc { unLoc : LocalGenerators }.

Module Localization_ReflectiveSubuniverses <: ReflectiveSubuniverses.

  (** Here we have to use the extra universe parameter that we built into the definition of [ReflectiveSubuniverse]: a set of localization generators is parametrized by the universe that it lives in, but also by the universe that the *generators* live in, which must be smaller. *)
  Definition ReflectiveSubuniverse : Type@{u} := Localization_ReflectiveSubuniverse@{a}.
  Check ReflectiveSubuniverse@{u a}.

  Definition O_reflector : ReflectiveSubuniverse@{u a} -> Type@{i} -> Type@{i}
    := fun O => Localize@{a i} (unLoc O).

  Definition In : ReflectiveSubuniverse@{u a} -> Type@{i} -> Type@{i}
    := fun O X => IsLocal@{i i a} (unLoc O) X.

  Definition O_inO :
    forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}),
      In O (O_reflector O T)
    := fun O => islocal_localize@{a i i} (unLoc O).

  Definition to :
    forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), T -> O_reflector O T
    := fun O => @loc@{a i} (unLoc O).

  Definition inO_equiv_inO :
    forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}),
      In@{u a i} O T -> forall f : T -> U, IsEquiv f ->
      In@{u a j} O U
    := fun O => islocal_equiv_islocal@{a i j i j k} (unLoc O).

  Definition hprop_inO@{u a i} `{Funext}
             (O : ReflectiveSubuniverse@{u a}) (T : Type@{i})
  : IsHProp (In@{u a i} O T).
  Proof.
    apply (@trunc_forall@{a i i} _); intros i.
    apply ishprop_ooextendable@{a a i i i  i i i i i  i i i}.
  Defined.

  Definition extendable_to_O
             (O : ReflectiveSubuniverse@{u a}) {P : Type@{i}}
             {Q : Type@{j}} {Q_inO : In@{u a j} O Q}
  : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q).
  Proof.
    apply ext_localize_ind@{a i j i k}; intros ?.
    apply ooextendable_over_const.
    apply Q_inO.
  Defined.

  (** The separated subuniverse corresponding to localization at [f] is localization at the pointwise suspension of [f].  This (and the following two definitions that prove it) is CORS Lemma 2.15, except that we can't use exactly the same proof since we have to avoid funext.  Instead we use the non-funext version proven using wild 0-groupoids in [Homotopy.Suspension]. *)
  Definition IsSepFor@{u a} (O' O : ReflectiveSubuniverse@{u a}) : Type@{u}
    := paths@{u} (Loc (susp_localgen (unLoc O))) O'.

  Definition inO_paths_from_inSepO@{u a i iplus}
             (O' O : ReflectiveSubuniverse@{u a}) (sep : IsSepFor O' O)
             (A : Type@{i}) (A_inO : In@{u a i} O' A) (x y : A)
    : In@{u a i} O (x = y).
  Proof.
    destruct O as [f]; destruct sep; unfold In, IsLocal in *; intros i; cbn in *.
    specialize (A_inO i).
    (** Unfortunately, [ooextendable_iff_functor_susp] has a ridiculous number of universe parameters.  Fortunately, most of them can be [i], and it's fairly easy to figure out which have to be [a].  But a few of them have to be something strictly larger than [i], which is why we included such a universe parameter [iplus] in these fields of [ReflectiveSubuniverse]. *)
    assert (e := fst (ooextendable_iff_functor_susp@{a a i i a a a i i iplus i a a a i i iplus i i i i i i i i i i i i iplus i i i iplus i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i} (f i) _) A_inO (x,y)).
    cbn in e.
    refine (ooextendable_postcompose' _ _ _ _ e).
    intros b.
    symmetry; apply equiv_dp_const.
  Defined.

  Definition inSepO_from_inO_paths@{u a i iplus}
             (O' O : ReflectiveSubuniverse@{u a}) (sep : IsSepFor O' O)
             (A : Type@{i}) (e : forall (x y : A), In@{u a i} O (x = y))
    : In@{u a i} O' A.
  Proof.
    destruct O as [f]; destruct sep; unfold In, IsLocal in *; intros i; cbn in *.
    apply (ooextendable_iff_functor_susp@{a a i i a a a i i iplus i a a a i i iplus i i i i i i i i i i i i iplus i i i iplus i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i i} (f i)).
    intros [x y].
    refine (ooextendable_postcompose' _ _ _ _ (e x y i)).
    intros b.
    apply equiv_dp_const.
  Defined.

End Localization_ReflectiveSubuniverses.

(** If you import the following module [LocM], then you can call all the reflective subuniverse functions with a [LocalGenerators] as the parameter. *)
Module Import LocM := ReflectiveSubuniverses_Theory Localization_ReflectiveSubuniverses.
(** If you don't import it, then you'll need to write [LocM.function_name]. *)
Export LocM.Coercions.

Coercion Localization_ReflectiveSubuniverse_to_ReflectiveSubuniverse := idmap
  : Localization_ReflectiveSubuniverse -> ReflectiveSubuniverse.

(** Here is the "real" definition of the notation [IsLocal].  Defining it this way allows it to inherit typeclass inference from [In], unlike (for instance) the slightly annoying case of [IsTrunc n] versus [In (Tr n)]. *)
Notation IsLocal f := (In (Loc f)).

Section LocalTypes.
  Context (f : LocalGenerators).

  (** A remark on universes: recall that [ooExtendableAlong] takes four universe parameters, three for the sizes of the types involved and one for the max of all of them.  In the definition of [IsLocal f X] we set that max universe to be the same as the size of [X], so that [In (Loc f) X] would lie in the same universes as [X], which is necessary for our definition of a reflective subuniverse.  However, in practice we may need this extendability property with the max universe being larger, to avoid coalescing universes undesiredly.  Thus, in making it available by the following name, we also insert a [lift] to generalize the max universe. *)
  Definition ooextendable_islocal {X : Type@{i}} {Xloc : IsLocal f X} i
  : ooExtendableAlong@{a a i k} (f i) (fun _ => X)
    := (lift_ooextendablealong _ _ (Xloc i)).

  Global Instance islocal_loc (X : Type) : IsLocal f (Localize f X)
    := islocal_localize f X.

  Global Instance isequiv_precomp_islocal `{Funext}
         {X : Type} `{IsLocal f X} i
  : IsEquiv (fun g => g o f i)
  := isequiv_ooextendable (fun _ => X) (f i) (ooextendable_islocal i).

  (** The non-dependent eliminator *)
  Definition Localize_rec {X Z : Type} `{IsLocal f Z} (g : X -> Z)
  : Localize f X -> Z.
  Proof.
    refine (Localize_ind f X (fun _ => Z) g _); intros i.
    apply ooextendable_over_const.
    apply ooextendable_islocal.
  Defined.

  Definition local_rec {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X)
  : lgen_codomain f i -> X
  := (fst (ooextendable_islocal i 1%nat) g).1.

  Definition local_rec_beta {X} `{IsLocal f X} {i} (g : lgen_domain f i -> X) s
  : local_rec g (f i s) = g s
    := (fst (ooextendable_islocal i 1%nat) g).2 s.

  Definition local_indpaths {X} `{IsLocal f X} {i} {h k : lgen_codomain f i -> X}
             (p : h o f i == k o f i)
  : h == k
    := (fst (snd (ooextendable_islocal i 2) h k) p).1.

  Definition local_indpaths_beta {X} `{IsLocal f X} {i} (h k : lgen_codomain f i -> X)
             (p : h o f i == k o f i) s
  : local_indpaths p (f i s) = p s
    := (fst (snd (ooextendable_islocal i 2) h k) p).2 s.

End LocalTypes.

Arguments local_rec : simpl never.
Arguments local_rec_beta : simpl never.
Arguments local_indpaths : simpl never.
Arguments local_indpaths_beta : simpl never.

(** ** Localization and accessibility *)

(** Localization subuniverses are accessible, essentially by definition. *)
Module Accessible_Localization
  <: Accessible_ReflectiveSubuniverses Localization_ReflectiveSubuniverses.

  Import Localization_ReflectiveSubuniverses.

  Definition acc_gen : ReflectiveSubuniverse -> LocalGenerators
    := unLoc.

  Definition inO_iff_islocal
             (O : ReflectiveSubuniverse@{u a}) (X : Type@{i})
  : iff@{i i i} (In O X) (IsLocal (acc_gen O) X)
    := (idmap , idmap).

End Accessible_Localization.

(** Conversely, if a reflective subuniverse is accessible, then it can be "nudged" to an equivalent localization.  The nudged version has the advantages of satisfying its computation rules judgmentally. *)

Module Nudge_ReflectiveSubuniverses
       (Os : ReflectiveSubuniverses)
       (Acc : Accessible_ReflectiveSubuniverses Os).

  (** Once again, we are annoyed that "application of modules is restricted to paths". *)
  Module Data <: ReflectiveSubuniverses_Restriction_Data
                   Localization_ReflectiveSubuniverses.
    Definition New_ReflectiveSubuniverse := Os.ReflectiveSubuniverse.
    Definition ReflectiveSubuniverses_restriction
    : New_ReflectiveSubuniverse -> Localization_ReflectiveSubuniverses.ReflectiveSubuniverse
      := fun O => Loc (Acc.acc_gen O).
  End Data.

  Module Nudged <: ReflectiveSubuniverses
    := ReflectiveSubuniverses_Restriction Localization_ReflectiveSubuniverses Data.

End Nudge_ReflectiveSubuniverses.


Require Export GeoCoq.Highschool.circumcenter.

Section Concyclic.

Context `{TE:Tarski_euclidean}.

Definition Concyclic A B C D := Coplanar A B C D /\ exists O, Cong O A O B /\ Cong O A O C /\ Cong O A O D.

Lemma concyclic_aux : forall A B C D, Concyclic A B C D ->
  exists O, Cong O A O B /\ Cong O A O C /\ Cong O A O D /\ Coplanar A B C O.
Proof.
  intros A B C D [HCop [O1]]; spliter.
  destruct (col_dec A B C).
    exists O1; repeat split; Cop.
  destruct (l11_62_existence A B C O1) as [O []].
  exists O.
  repeat split; try apply cong2_per2__cong with O1 O1; Cong; Cop.
Qed.

Lemma concyclic_trans : forall A B C D E,
 ~ Col A B C ->
 Concyclic A B C D  -> Concyclic A B C E -> Concyclic A B D E.
Proof.
intros.
split.
unfold Concyclic in *; spliter.
apply coplanar_trans_1 with C; Col; Cop.
apply concyclic_aux in H0.
apply concyclic_aux in H1.
decompose [ex and] H0;clear H0.
decompose [ex and] H1;clear H1.
exists x.
repeat split;Cong.
assert (x=x0).
assert_diffs.
apply is_circumcenter_uniqueness with A B C;try assumption.
unfold is_circumcenter;repeat split;[eCong..|Cop].
unfold is_circumcenter;repeat split;[eCong..|Cop].
subst.
Cong.
Qed.

Lemma concyclic_perm_1: forall A B C D,
  Concyclic A B C D -> Concyclic A B D C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_2 : forall A B C D,
  Concyclic A B C D -> Concyclic A C B D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_3 : forall A B C D,
  Concyclic A B C D -> Concyclic A C D B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_4 : forall A B C D,
  Concyclic A B C D -> Concyclic A D B C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_5 : forall A B C D,
  Concyclic A B C D -> Concyclic A D C B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_6 : forall A B C D,
  Concyclic A B C D -> Concyclic B A C D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_7 : forall A B C D,
  Concyclic A B C D -> Concyclic B A D C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_8 : forall A B C D,
  Concyclic A B C D -> Concyclic B C A D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_9 : forall A B C D,
  Concyclic A B C D -> Concyclic B C D A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_10 : forall A B C D,
  Concyclic A B C D -> Concyclic B D A C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_11 : forall A B C D,
  Concyclic A B C D -> Concyclic B D C A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_12 : forall A B C D,
  Concyclic A B C D -> Concyclic C A B D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_13 : forall A B C D,
  Concyclic A B C D -> Concyclic C A D B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_14 : forall A B C D,
  Concyclic A B C D -> Concyclic C B A D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_15 : forall A B C D,
  Concyclic A B C D -> Concyclic C B D A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_16 : forall A B C D,
  Concyclic A B C D -> Concyclic C D A B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_17 : forall A B C D,
  Concyclic A B C D -> Concyclic C D B A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_18 : forall A B C D,
  Concyclic A B C D -> Concyclic D A B C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_19 : forall A B C D,
  Concyclic A B C D -> Concyclic D A C B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_20 : forall A B C D,
  Concyclic A B C D -> Concyclic D B A C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_21 : forall A B C D,
  Concyclic A B C D -> Concyclic D B C A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_22 : forall A B C D,
  Concyclic A B C D -> Concyclic D C A B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_perm_23 : forall A B C D,
  Concyclic A B C D -> Concyclic D C B A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; eCong..].
Qed.

Lemma concyclic_1123 : forall A B C,
 ~ Col A B C ->
 Concyclic A A B C.
Proof.
intros A B C HABC.
unfold Concyclic.
split.
apply coplanar_trivial.
destruct (exists_circumcenter A B C HABC) as [G HG].
exists G.
apply circumcenter_cong in HG;spliter;repeat split;Cong.
Qed.

End Concyclic.


Require Import Context Stlc TypeSystem Syntax Ty Subtype List Utils Semantics.

(** Erasure and simulation proofs **)

(* erasure functions for types, terms and contexts *)

Fixpoint erase_ty (t : ty) : stlc_ty :=
  match t with
    | ty_bool _ => stlc_bool
    | arrow l r _ => stlc_arrow (erase_ty l) (erase_ty r)
  end.

Fixpoint erase_term (t : term) : stlc_term :=
  match t  with
    | tm_false => stlc_false
    | tm_true => stlc_true
    | tm_var i => stlc_var i
    | tm_app l r => stlc_app (erase_term l) (erase_term r)
    | tm_abs i T t => stlc_abs i (erase_ty T) (erase_term t)
    | tm_trust t => erase_term t
    | tm_distrust t => erase_term t
    | tm_check t => erase_term t
  end.

Definition erase_context (ctx : finite_map ty) : stlc_context :=
  map (fun p => match p with
                  | (i,t) => (i, erase_ty t)
                end) ctx.

(** lemma 12 **)

Lemma subtype_erase : forall T T', subtype T T' -> erase_ty T = erase_ty T'.
Proof.
  intros T T' H ; induction H ; simpl ; f_equal ; auto.
Qed.

(** Theorem 13 **)

Lemma lookup_erase : forall i (t : ty) g, lookup i g = Some t -> lookup i (erase_context g) = Some (erase_ty t).
Proof.
  intros i t g H.
  induction g ; try solve by inversion.
  destruct a. simpl. remember (eq_id_dec i i0) as e ; destruct e ; subst ;auto.
  simpl in H. rewrite <- Heqe in H. inv H. auto.
  apply IHg. simpl in H. rewrite <- Heqe in H. auto.
Qed.

Lemma extend_erase : forall i (t : ty) g, erase_context (extend i t g) = extend i (erase_ty t) (erase_context g).
Proof.
  intros i t g ; induction g.
  simpl ; auto.
  destruct a ; simpl.
  remember (eq_id_dec i i0) as e ; destruct e ; subst ; auto.
  simpl. f_equal ; auto.
Qed.

Lemma update_secty_erase : forall t s, erase_ty (update_secty t s) = erase_ty t.
Proof.
  intros t s ; induction t ; simpl ; auto.
Qed.

Lemma update_erase : forall t s, erase_ty (update t s) = erase_ty t.
Proof.
  intros t s ; induction t ; simpl ; auto.
Qed.

Lemma subst_erase : forall x v t, erase_term (subst x v t) = Stlc.subst x (erase_term v) (erase_term t).
Proof.
  intros x v t ; induction t ; simpl ;
    try (match goal with
           [ |- context[if beq_id ?X ?Y then _ else _]] => remember (beq_id X Y) as e ; destruct e
         end) ; auto.
   rewrite <- IHt1. rewrite <- IHt2. auto.
   rewrite <- IHt ; auto.
Qed.

Lemma value_erase : forall t, value t -> stlc_value (erase_term t).
Proof.
  intros t H ; inv H ; simpl ; auto.
Qed.

Hint Resolve lookup_erase subtype_erase value_erase.

(* proof of the theorem 5 - if e is well typed, |e| is also well typed in the sltc *)

Theorem erase_typing : forall ctx e T, has_type ctx e T -> stlc_has_type (erase_context ctx) (erase_term e) (erase_ty T).
Proof with eauto.
  intros ctx e T HT.
  induction HT ; simpl ; try econstructor ...
  rewrite <- extend_erase ...
  rewrite -> update_secty_erase ...
  rewrite -> update_erase ...
  rewrite -> update_erase ...
  apply subtype_erase in H.
  rewrite <- H ...
Qed.

(** simulation **)

Theorem simulation : forall ctx t T, has_type ctx t T -> exists v, (erase_term t) ==>s* v -> exists g, t ==>* g /\ (erase_term g) = v.
Proof.
  intros ctx t T HT.
  induction t ; try (eexists ; intros ; eexists ; split ; eauto ; try econstructor; fail).
Qed.