Require Import FcEtt.fc_invert.
Require Import Omega.
Require Import Coq.Arith.Wf_nat.
Require Import FcEtt.toplevel.

Require Import FcEtt.erase_syntax.
Require Import FcEtt.sigs.
Require Import FcEtt.fc_unique.
Require Import FcEtt.fc_invert.
Require Import FcEtt.fc_context_fv.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Module fc_get (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig) (unique: fc_unique_sig).
Import wf weak subst.

Module invert := fc_invert wf weak subst.
Import invert.

(* -------------------------------------------------------------------------------------- *)

(* This function looks at an annotated term and returns its type.
*)

Fixpoint get_tpg_n (n : nat) (G : context) (a : tm) { struct n } : tm :=
match n with
| 0 => a_Star
| S m =>
  match a with
  | a_Star => a_Star
  | a_Var_f x =>
    match binds_lookup _ x G with
    | inl (exist (Tm A) _) => A
    | _ => a_Star
    end
  | a_Pi  rho A B => a_Star
  | a_Abs rho A a =>
    let (x,_) := atom_fresh (dom G) in
    a_Pi rho A (close_tm_wrt_tm x (get_tpg_n m ((x,Tm A)::G) (open_tm_wrt_tm a (a_Var_f x))))
  | a_App a1 rho a2 =>
    match get_tpg_n m G a1 with
      | a_Pi rho A B => open_tm_wrt_tm B a2
      | _ => a_Star
    end
  | a_Conv a g => let (_,b) := get_deq_n m G g in b
  | a_CPi phi B => a_Star
  | a_CAbs phi a => let (x,_) := atom_fresh (dom G) in
                   a_CPi phi (close_tm_wrt_co x (get_tpg_n m ((x,Co phi)::G) (open_tm_wrt_co a (g_Var_f x))))
  | a_Fam F =>
    match binds_lookup _ F an_toplevel with
    | inl (exist (Ax a A) _) => A
    | _ => a_Star
    end
  | a_CApp a1 g2 =>
    match get_tpg_n m G a1 with
      | a_CPi phi B => open_tm_wrt_co B g2
      | _ => a_Star
    end
  | _ => a_Star
  end
end
with
get_iso_n (n : nat) (G : context) (g : co) : (constraint * constraint) :=
  match n with
  | 0 => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
  | S m =>
    match g with
    | (g_EqCong g1 A g2) =>
      let (A1, A2) := get_deq_n m G g1 in
      let (B1, B2) := get_deq_n m G g2 in
      (Eq A1 B1 A, Eq A2 B2 A)
    | g_CPiFst g =>
      let (T1,T2) := get_deq_n m G g in
      match (T1, T2) with
      | (a_CPi phi1 A2, a_CPi phi2 B2) => (phi1, phi2)
      | _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
      end
    | g_Sym g =>
      let (phi2, phi1) := get_iso_n m G g in
      (phi1, phi2)
    | g_IsoConv (Eq a1 a2 A) (Eq a1' a2' B) g =>
      (Eq a1 a2 A, Eq a1' a2' B)
    | _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
    end
  end
with
get_deq_n (n : nat) (G : context) (g : co) : (tm * tm) :=
  match n with
  | 0 => (a_Star, a_Star)
  | S m =>
    match g with
    | g_Var_f c => match binds_lookup _ c G with
                  | inl (exist (Co (Eq a b A)) _) => (a,b)
                  | _ => (a_Star, a_Star)
                  end
    | g_Refl a => (a,a)
    | g_Refl2 a b g => (a,b)
    | g_Beta a b => (a,b)
    | g_Sym g => let (a,b) := get_deq_n m G g in
                (b,a)
    | g_Trans g1 g2 =>
      let (a,c1) := get_deq_n m G g1 in
      let (c2, b) := get_deq_n m G g2 in
      (a,b)
    | g_PiCong rho g1 g2 =>
      let (x,_) := atom_fresh (dom G) in
      let (A1,A2) := get_deq_n m G g1 in
      let (B1,B2) := get_deq_n m ([(x, Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
      let B3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2 in
      (a_Pi rho A1 (close_tm_wrt_tm x B1), a_Pi rho A2 (close_tm_wrt_tm x B3))
    | g_AbsCong rho g1 g2 =>
      let (x,_) := atom_fresh (dom G) in
      let (A1,A2) := get_deq_n m G g1 in
      let (b1,b2) := get_deq_n m ([(x,Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
      let b3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x b2 in
      (a_Abs rho A1 (close_tm_wrt_tm x b1), a_Abs rho A2 (close_tm_wrt_tm x b3))
    | g_AppCong g1 rho g2 =>
      let (a1, b1) := get_deq_n m G g1 in
      let (a2, b2) := get_deq_n m G g2 in
      (a_App a1 rho a2, a_App b1 rho b2)
    | g_PiFst g =>
      let (a,b) := get_deq_n m G g in
      match (a,b) with
      | (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) => (A1, A2)
      | (_,_) => (a_Star, a_Star)
      end
    | g_PiSnd g1 g2 =>
      let (T1,T2) := get_deq_n m G g1 in
      let (a1,a2) := get_deq_n m G g2 in
      match (T1,T2) with
      | (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) =>
        (open_tm_wrt_tm B1 a1, open_tm_wrt_tm B2 a2)
      | (_,_) => (a_Star, a_Star)
      end
    | g_CPiCong g1 g3 =>
      let (phi1,phi2) := get_iso_n m G g1 in
      let (x,_) := atom_fresh (dom G) in
      let (B1,B2) := get_deq_n m ([(x,Co phi1)] ++ G)
                               (open_co_wrt_co g3 (g_Var_f x)) in
      let B3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x B2 in
      (a_CPi phi1 (close_tm_wrt_co x B1), a_CPi phi2 (close_tm_wrt_co x B3))
    | g_CAbsCong g1 g2 g3 =>
      let (phi1,phi2) := get_iso_n m G g1 in
      let (x,_) := atom_fresh (dom G) in
      let (b1,b2) := get_deq_n m ([(x,Co phi1)] ++ G)
                               (open_co_wrt_co g2 (g_Var_f x)) in
      let b3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x b2 in
      (a_CAbs phi1 (close_tm_wrt_co x b1), a_CAbs phi2 (close_tm_wrt_co x b3))

    | (g_CAppCong g1 g2 g3) =>
      let (a1, b1) := get_deq_n m G g1 in
      (a_CApp a1 g2,a_CApp b1 g3)
    | (g_CPiSnd g1 g2 g3) =>
      match get_deq_n m G g1 with
      | (a_CPi (Eq a a' A) B1, a_CPi (Eq b b' B) B2) =>
         (open_tm_wrt_co  B1   g2, open_tm_wrt_co  B2   g3 )
      | (_,_) => (a_Star, a_Star)
      end
    | (g_Cast g1 g2) =>
      match get_iso_n m G g2 with
      | (Eq a a' A, Eq b b' B) => (b,b')
      end
    |  (g_IsoSnd g) =>
       match get_iso_n m G g with
       | (Eq a a' A, Eq b b' B) => (A, B)
       end
    | _ => (a_Star, a_Star)
    end
  end.

Definition get_tpg (G : context) (a:tm) : tm :=
  get_tpg_n (size_tm a) G a.
Definition get_deq (G : context) (g:co) : (tm*tm) :=
  get_deq_n (size_co g) G g.
Definition get_iso (G : context) (g:co) : (constraint*constraint) :=
  get_iso_n (size_co g) G g.

Lemma get_n_correct : forall n,
    (forall G a A B, size_tm a <= n -> AnnTyping G a A -> get_tpg_n n G a = B -> A = B) /\
    (forall G D g A B A' B', size_co g <= n -> AnnDefEq G D g A B ->
                        get_deq_n n G g = (A',B') -> A = A' /\ B = B') /\
    (forall G D g A B A' B', size_co g <= n -> AnnIso G D g A B ->
                        get_iso_n n G g = (A',B') -> A = A' /\ B = B').

Proof.
  intro n.
  eapply (lt_wf_ind n). clear n. intros.
  split.
  { intros G a A B HS HT GT.
    destruct a; simpl in *; try  (destruct n; [inversion HS | try solve [inversion HT; subst;  auto]]).
    - inversion HT. subst. simpl.
      assert (U : uniq G). { eapply AnnCtx_uniq. eauto. }
      destruct (binds_lookup _ x G) as [ [ [A0 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H3 P U) => h0. inversion h0. auto.
      move: (binds_unique _ _ _ _ _ H3 P U) => h0. inversion h0.
      eapply NB in H3. done.
    - destruct (An_Abs_inversion HT) as (B1 & EQ & T1 & HB1). subst.
      simpl.
      destruct (atom_fresh (dom G)).
      f_equal.
      move: (HB1 x n0) => [R1 TB1]. clear HB1.
      move: (H n ltac:(omega)) => [h0 _].
      assert (size_tm (open_tm_wrt_tm a2 (a_Var_f x)) = size_tm a2). eauto with lngen.
      move: (h0 ((x, Tm a1) :: G) (open_tm_wrt_tm a2 (a_Var_f x)) (open_tm_wrt_tm B1 (a_Var_f x))
                (get_tpg_n n ((x, Tm a1) :: G) (open_tm_wrt_tm a2 (a_Var_f x)))
            ltac:(omega) TB1 ltac:(auto))
      => h1.
      rewrite <- h1.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm; eauto.
      move: (AnnTyping_context_fv HT) => [_ [_ [f1 _]]]. simpl in f1.
      fsetdec.
    - inversion HT. subst. simpl.
      move: (H n ltac:(omega)) => [h0 _].
      move: (@h0 G a1 (a_Pi rho A0 B0) (get_tpg_n n G a1) ltac:(omega) H5 eq_refl) => h1.
      rewrite <- h1.
      auto.
    - inversion HT. subst.
      Opaque an_toplevel.
      simpl.
      destruct (binds_lookup _ F an_toplevel) as [[ [A0 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0.
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0. auto.
      eapply NB in H2. done.
    - inversion HT. subst. simpl.
      remember (get_deq_n n G g) as GD. destruct GD as [A' B'].
      move: (H n ltac:(omega)) => [_ [h0 _]].
      destruct (h0 _ _ g _ _ A' B' ltac:(omega) H4).
      auto. subst. auto.
    - destruct (An_CAbs_inversion HT) as (B1 & EQ & HT1). subst. simpl.
      destruct (atom_fresh (dom G)). f_equal. simpl_env.
      move: (HT1 x n0) => [R1 TB1]. clear HT1.
      move: (H n ltac:(omega)) => [h0 _].
      assert (size_tm (open_tm_wrt_co a (g_Var_f x)) = size_tm a). eauto with lngen.
      move: (h0 _ (open_tm_wrt_co a (g_Var_f x)) _ _  ltac:(omega) TB1 eq_refl) => h1.
      rewrite <- h1.
      rewrite close_tm_wrt_co_open_tm_wrt_co; eauto.
      move: (AnnTyping_context_fv HT) => [_ [_ [_ f1]]]. simpl in f1.
      fsetdec.
   - inversion HT. subst. simpl.
     move: (H n ltac:(omega)) => [h0 _].
     move: (@h0 G a (a_CPi (Eq a0 b A1) B0) (get_tpg_n n G a)
                 ltac:(omega) H3 eq_refl) => h1.
     rewrite <- h1.
     auto.
  } split. {
    intros G D g A B A' B' SZ DE GET.
    destruct g; simpl in *; (destruct n; [inversion SZ| try solve [inversion DE; subst; simpl;  auto]]).
    - inversion DE. subst. simpl in GET.
      assert (U : uniq G). { eapply AnnCtx_uniq. eauto. }
      destruct (binds_lookup _ c G) as [[ [ A1 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H2 P U) => h0. inversion h0. destruct phi. inversion GET. subst.
      move: (binds_unique _ _ _ _ _ H2 P U) => h0. inversion h0. auto.
      eapply NB in H2. done.
    - inversion DE. subst.  simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET.
      remember (get_deq_n n G g) as GG.
      destruct GG. inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 G D g _ _ B' A' ltac:(omega) H6 ltac:(auto)) => [h1 h2]. subst.
      auto.
    - inversion DE. subst. simpl in GET.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      inversion GET. subst.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 G D g1 _ _ A' t0 ltac:(omega) H2 ltac:(auto)) => [h1 h2]. subst.
      move: (h0 G D g2 _ _ t1 B' ltac:(omega) H3 ltac:(auto)) => [h1 h2]. subst.
      auto.
    - destruct (An_PiCong_inversion DE) as (A1 & B1 & A2 & B2 & B3 &
                                             E1 & E2 & T1 & T2 & T3 & DE1 & DE2).
      simpl in GET.
      destruct (atom_fresh (dom G)).
      remember (get_deq_n n G g1) as GET1.
      destruct GET1 as [A1' A2'].
      remember (get_deq_n n ((x, Tm A1') :: G) (open_co_wrt_tm g2 (a_Var_f x))) as GET2.
      destruct GET2 as [B1' B2'].
      inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h1 _]].
      move: (h1 G D g1 A1 A2 A1' A2' ltac:(omega) DE1 ltac:(auto)) => [E1 E2].
      subst.
      assert (SS : size_co (open_co_wrt_tm g2 (a_Var_f x)) = size_co g2).
      auto with lngen.
      move: (DE2 x ltac:(auto)) => [DEx E3].
      move: (h1 ([(x, Tm A1')] ++ G) D
                (open_co_wrt_tm g2 (a_Var_f x))
                (open_tm_wrt_tm B1 (a_Var_f x))
                (open_tm_wrt_tm B2 (a_Var_f x))
                B1' B2' ltac:(omega) ltac:(auto) ltac:(auto)) => [E1 E2].
      subst.
      move: (AnnTyping_context_fv T1) => [f1 [_ _]]. simpl in f1.
      move: (AnnTyping_context_fv T2) => [f2 [_ _]]. simpl in f2.
      move: (AnnTyping_context_fv T3) => [f3 [_ _]]. simpl in f3.
      assert (x `notin` fv_tm_tm_tm B2 \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B3). fsetdec.
      split. f_equal. rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto. auto.
      f_equal.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm.
      rewrite tm_subst_tm_tm_var.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      rewrite <- E3.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto.
      auto.
      econstructor; eauto.
      econstructor. eapply AnnDefEq_lc; eauto.
    - destruct (An_AbsCong_inversion DE) as (A1 & A2 & b1 & b2 & b3 & C2 &
                                             E1 & E2 & T1 & T2 & DE1 & T3 & DE2).
      simpl in GET.
      destruct (atom_fresh (dom G)).
      remember (get_deq_n n G g1) as GET1.
      destruct GET1 as [A1' A2'].
      remember (get_deq_n n ((x, Tm A1') :: G) (open_co_wrt_tm g2 (a_Var_f x))) as GET2.
      destruct GET2 as [b1' b2'].
      inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h1 _]].
      move: (h1 G D g1 A1 A2 A1' A2' ltac:(omega) DE1 ltac:(auto)) => [E1 E2]. subst.
      assert (SS : size_co (open_co_wrt_tm g2 (a_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x ltac:(auto)) => [DEx [E3 [RC1 RC2]]].
      move: (h1 ([(x, Tm A1')] ++ G) D
                (open_co_wrt_tm g2 (a_Var_f x))
                (open_tm_wrt_tm b1 (a_Var_f x))
                (open_tm_wrt_tm b2 (a_Var_f x))
                b1' b2' ltac:(omega) ltac:(auto) ltac:(auto)) => [E1 E2].
      subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1 [_ [f2 _]]]]]. simpl in f1. simpl in f2.
      move: (AnnTyping_context_fv T3) => [f3 [_ _]]. simpl in f3.
      assert (x `notin` fv_tm_tm_tm b2 \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b3). fsetdec.
      split. f_equal.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto. auto.
      f_equal.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm.
      rewrite tm_subst_tm_tm_var.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      rewrite <- E3.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto.
      auto.
      econstructor; eauto.
      econstructor. eapply AnnDefEq_lc; eauto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      inversion GET.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
      auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g) as GG. destruct GG.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_iso_n n G g) as GG. destruct GG.
      move: (H n ltac:(omega)) => [_ [_ h0]].
      move: (h0 _ _ g _ _ c c0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H2 ltac:(auto)) => [E1 E2]. subst.
      move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - destruct (An_CPiCong_inversion DE) as (phi1 & phi2 & b1 & b2 & b3 &
                                             E1 & E2 & I1 & T1 & T2 & T3 & DE2).
      simpl in *.
      remember (get_iso_n n G g1) as GG1. destruct GG1 as [phi1' phi2'].
      destruct (atom_fresh (dom G)) as [x Fr].
      remember (get_deq_n n ((x, Co phi1') :: G) (open_co_wrt_co g2 (g_Var_f x))) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h1 _ _ g1 _ _ phi1' phi2' ltac:(omega) I1 ltac:(auto)) => [E1' E2']. subst.
      assert (SS : size_co (open_co_wrt_co g2 (g_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x Fr) => [DE2' EQ].
      inversion GET. clear GET.
      move: (h0 _ _ (open_co_wrt_co g2 (g_Var_f x)) _ _ t t0 ltac:(omega) DE2' ltac:(auto)) => [E1' E2']. subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1' [f1 [f2' f2]]]]]. simpl in *.
      move: (AnnTyping_context_fv T3) => [f3' [f3 _]]. simpl in *.
      split.
      + f_equal. rewrite close_tm_wrt_co_open_tm_wrt_co. auto. auto.
      + f_equal.
        rewrite co_subst_co_tm_open_tm_wrt_co.
        rewrite co_subst_co_co_var.
        rewrite co_subst_co_tm_fresh_eq; auto.
        rewrite <- EQ.
        rewrite close_tm_wrt_co_open_tm_wrt_co. auto.
        auto.
        econstructor; eauto.
        econstructor. eapply AnnIso_lc; eauto.
    - destruct (An_CAbsCong_inversion DE) as (phi1 & phi2 & b1 & b2 & b3
                                              & B1 & B2 & B3 &
                                              E1 & E2 & I1 & T1 & T2 & T3
                                              & DE1 & DE2).
      simpl in *.

            remember (get_iso_n n G g1) as GG1. destruct GG1 as [phi1' phi2'].
      destruct (atom_fresh (dom G)) as [x Fr].
      remember (get_deq_n n ((x, Co phi1') :: G) (open_co_wrt_co g2 (g_Var_f x))) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h1 _ _ g1 _ _ phi1' phi2' ltac:(omega) I1 ltac:(auto)) => [E1' E2']. subst.
      assert (SS : size_co (open_co_wrt_co g2 (g_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x Fr) => [DE2' EQ].
      inversion GET. clear GET.
      move: (h0 _ _ (open_co_wrt_co g2 (g_Var_f x)) _ _ t t0 ltac:(omega) DE2' ltac:(auto)) => [E1' E2']. subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1' [f1 [f2' f2]]]]]. simpl in *.
      move: (AnnTyping_context_fv T3) => [f3' [f3 _]]. simpl in *.
      split.
      + f_equal. rewrite close_tm_wrt_co_open_tm_wrt_co. auto. auto.
      + f_equal.
        rewrite co_subst_co_tm_open_tm_wrt_co.
        rewrite co_subst_co_co_var.
        rewrite co_subst_co_tm_fresh_eq; auto.
        rewrite <- EQ.
        rewrite close_tm_wrt_co_open_tm_wrt_co. auto.
        auto.
        econstructor; eauto.
        econstructor. eapply AnnIso_lc; eauto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H5 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_iso_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
      move: (h1 _ _ g2 _ _ c c0 ltac:(omega) H7 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
     }
      { intros G D g A B A' B' SZ H1 GET.
      destruct g; (destruct n; [inversion SZ|idtac]); inversion H1;
        simpl in *; subst.
      -  remember (get_iso_n n G g) as GG. destruct GG.
         move: (H n ltac:(omega)) => [_ [h0 h1]].
         move: (h1 _ _ g _ _ c c0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
         inversion GET. subst. auto.
      -  remember (get_deq_n n G g) as GG. destruct GG.
         move: (H n ltac:(omega)) => [_ [h0 h1]].
         move: (h0 _ _ g _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
         inversion GET. subst. auto.
      - remember (get_deq_n n G g1) as GG. destruct GG.
        remember (get_deq_n n G g2) as GG. destruct GG.
        move: (H n ltac:(omega)) => [_ [h0 h1]].
        move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.              move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H7 ltac:(auto)) => [E1 E2]. subst.             inversion GET. auto.
      - inversion GET. auto.
    }
Qed.

Lemma get_tpg_correct : (forall G a A B, AnnTyping G a A -> get_tpg G a = B -> A = B).
Proof.
  intros. unfold get_tpg in *.
  move: (get_n_correct (size_tm a)) => [h0 _].
  eapply h0; eauto.
Qed.

Lemma get_deq_correct: (forall G D g A B A' B',  AnnDefEq G D g A B ->
                                            get_deq G g = (A',B') -> A = A' /\ B = B').
Proof.
  intros. unfold get_deq in *.
  move: (get_n_correct (size_co g)) => [_ [h0 _]
                                       ].
  eapply h0; eauto.
Qed.

Lemma get_iso_correct: (forall G D g A B A' B',  AnnIso G D g A B ->
                                            get_iso G g = (A',B') -> A = A' /\ B = B').
Proof.
  intros. unfold get_deq in *.
  move: (get_n_correct (size_co g)) => [_ [_ h0]].
  eapply h0; eauto.
Qed.

Lemma An_PiCong_exists2: forall x1 x2 (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
    x1 `notin` (dom G \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B2 \u  fv_tm_tm_co g2)
    -> x2 `notin` (dom G \u singleton x1 \u fv_tm_tm_tm B2 \u fv_tm_tm_tm B3 \u  fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x1, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
               (open_tm_wrt_tm B1 (a_Var_f x1)) (open_tm_wrt_tm B2 (a_Var_f x1))
    → (open_tm_wrt_tm B3 (a_Var_f x2) =
       open_tm_wrt_tm B2 (a_Conv (a_Var_f x2) (g_Sym g1)))
    → get_tpg G A1 = a_Star
    → get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B1 (a_Var_f x1)) = a_Star
    → get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B2 (a_Var_f x1)) = a_Star
    → get_tpg G A2 = a_Star
    → get_tpg ([(x1,Tm A2)] ++ G) (open_tm_wrt_tm B3 (a_Var_f x1)) = a_Star
    → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 B1) (a_Pi rho A2 B3).
Proof.
intros.
destruct (AnnDefEq_regularity H1) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H2) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H5) => EQ. subst.
move: (get_tpg_correct T4 H6) => EQ. subst.
move: (get_tpg_correct T1 H4) => EQ. subst.
move: (get_tpg_correct T2 H7) => EQ. subst.
eapply (@An_PiCong_exists x1 x2); eauto.
+ eapply (@An_Pi_exists2 x1); eauto.
+ eapply (@An_Pi_exists2 x2); eauto.
rewrite H3.
rewrite (tm_subst_tm_tm_intro x1); eauto.
replace a_Star with  (tm_subst_tm_tm (a_Conv (a_Var_f x2) (g_Sym g1)) x1 a_Star); auto.
have t1: AnnCtx G by eauto with ctx_wff.
move: (AnnTyping_weakening T2 [(x1,Tm A1)] nil G eq_refl) => t2. simpl_env in t2.
move: (AnnTyping_weakening T1 [(x2,Tm A2)] nil G eq_refl) => t3. simpl_env in t3.
eapply AnnTyping_tm_subst with (A:= A1).
eapply AnnTyping_weakening with (F:=[(x1,Tm A1)]); eauto 4.
econstructor; eauto.
econstructor; eauto.
econstructor; eauto.
eapply AnnTyping_weakening with (F:=nil) (E:=[(x2,Tm A2)]); eauto.
simpl_env. eauto.
eapply AnnDefEq_weakening with (F:=nil) (E:=[(x2,Tm A2)]); simpl_env; eauto.
simpl_env.
eapply (fourth ann_weaken_available_mutual) with (D := dom G).
eapply AnnDefEq_weaken_available. eauto. simpl. fsetdec.
+ eapply (@An_Pi_exists2 x1); eauto.
Qed.

Lemma An_PiCong_exists3: forall x (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
    x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
    → B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
    → get_tpg G A1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B2 = a_Star
    → get_tpg G A2 = a_Star
    → get_tpg ([(x,Tm A2)] ++ G) B3 = a_Star
    → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 (close_tm_wrt_tm x B1)) (a_Pi rho A2 (close_tm_wrt_tm x B3)).
Proof.
intros.
destruct (AnnDefEq_regularity H0) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H4) => EQ. subst.
move: (get_tpg_correct T4 H5) => EQ. subst.
move: (get_tpg_correct T1 H3) => EQ. subst.
move: (get_tpg_correct T2 H6) => EQ. subst.
eapply (@An_PiCong_exists x x) with (B2 := close_tm_wrt_tm x B2); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@tm_subst_tm_tm_intro x).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_Pi_exists2 x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ pick fresh y.
  rewrite (tm_subst_tm_tm_spec _ _ x); auto.
  rewrite (tm_subst_tm_tm_intro y); auto.
  eapply (@An_Pi_exists2 x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
  replace a_Star with
     (tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) y a_Star); auto.

  replace B2 with (open_tm_wrt_tm (close_tm_wrt_tm x B2) (a_Var_f x)) in T4; autorewrite with lngen; auto.
  replace a_Star with (open_tm_wrt_tm a_Star (a_Var_f x)) in T4; auto.
  apply (@AnnTyping_tm_swap x y) in T4; autorewrite with lngen; eauto.
  replace (open_tm_wrt_tm a_Star (a_Var_f y)) with a_Star in T4; auto.

  have t1: AnnCtx G by eauto with ctx_wff.
  move: (AnnTyping_weakening T2 [(x,Tm A1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnTyping_weakening T1 [(x,Tm A2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnTyping_weakening T1 [(x,Tm A1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnTyping_weakening T2 [(x,Tm A2)] nil G eq_refl) => t5. simpl_env in t5.

  eapply AnnTyping_tm_subst with (A:= A1).
  eapply AnnTyping_weakening with (F:=[(y,Tm A1)]); eauto 4.
  econstructor; eauto.
  econstructor; eauto.
  eapply AnnDefEq_weakening with (F:=nil) (E:=[(x,Tm A2)]); simpl_env; eauto.
  simpl_env.
  eapply (fourth ann_weaken_available_mutual) with (D := dom G).
  eapply AnnDefEq_weaken_available. eauto. simpl. fsetdec.

  autorewrite with lngen. fsetdec.

+ eapply (@An_Pi_exists2 x); eauto.
   autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

Lemma An_AbsCong_exists3: forall x (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 B: tm),
    x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
    → B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
    → get_tpg G A1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B2 = B (* FIXME: isn't this assumption useless? (B seems to only occur here) *)
    → get_tpg G A2 = a_Star
    → RhoCheck rho x (erase_tm B1)
    → RhoCheck rho x (erase_tm B3)
    → AnnDefEq G D (g_AbsCong rho g1 g2)
               (a_Abs rho A1 (close_tm_wrt_tm x B1))
               (a_Abs rho A2 (close_tm_wrt_tm x B3)).
Proof.
intros.
destruct (AnnDefEq_regularity H0) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T4 H4) => EQ. subst.
move: (get_tpg_correct T1 H3) => EQ. subst.
move: (get_tpg_correct T2 H5) => EQ. subst.
eapply (@An_AbsCong_exists x x) with (b2 := close_tm_wrt_tm x B2)
(b1 := close_tm_wrt_tm x B1)
(b3 := close_tm_wrt_tm x (tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2))
(B := a_Pi rho A1 (close_tm_wrt_tm x (get_tpg ([(x, Tm A1)] ++ G) B2)));
  eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@tm_subst_tm_tm_intro x).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ autorewrite with lngen. auto.
+ autorewrite with lngen. auto.
+ eapply (@An_Abs_exists x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
  autorewrite with lngen.
  rewrite <- subst_tm_erase_tm in H7.
  simpl in H7.
  rewrite tm_subst_tm_tm_spec in H7.
  autorewrite with lngen in H7. auto.
Qed.

Lemma An_CPiCong_exists_3 :  ∀ c (G : context) D (g1 g3 : co) (phi1 : constraint)
       (B1 : tm) (phi2 : constraint) (B3 B2 : tm),
     c `notin` dom G \u D \u fv_co_co_co g3 \u fv_co_co_co g1
    -> AnnIso G D g1 phi1 phi2
    → AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) B1 B2
    → B3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c B2
    -> get_tpg ([(c,Co phi1)] ++ G) B1 = a_Star
    -> get_tpg ([(c,Co phi2)] ++ G) B3 = a_Star
    -> get_tpg ([(c,Co phi1)] ++ G) B2 = a_Star
    → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 (close_tm_wrt_co c B1))
               (a_CPi phi2 (close_tm_wrt_co c B3)).
Proof.
intros.
destruct (AnnIso_regularity H0).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H3) => EQ. subst.
move: (get_tpg_correct T4 H5) => EQ. subst.
eapply (@An_CPiCong_exists c c) with
(B2 := close_tm_wrt_co c B2); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@co_subst_co_tm_intro c).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_CPi_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ pick fresh y.
  rewrite (co_subst_co_tm_spec _ _ c); auto.
  rewrite (co_subst_co_tm_intro y); auto.
  eapply (@An_CPi_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen.
  replace a_Star with
     (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) y a_Star); auto.
  replace B2 with
    (open_tm_wrt_co (close_tm_wrt_co c B2) (g_Var_f c)) in T4; autorewrite with lngen; auto.
  replace a_Star with (open_tm_wrt_co a_Star (g_Var_f c)) in T4; auto.
  apply (@AnnTyping_co_swap c y) in T4; autorewrite with lngen; eauto.
  replace (open_tm_wrt_co a_Star (g_Var_f y)) with a_Star in T4; auto.
  have t1: AnnCtx G by eauto with ctx_wff.
  move: (AnnPropWff_weakening H6 [(c,Co phi1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnPropWff_weakening H7 [(c,Co phi2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnPropWff_weakening H6 [(c,Co phi1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnPropWff_weakening H7 [(c,Co phi2)] nil G eq_refl) => t5. simpl_env in t5.
  destruct phi1 as [a b A].
  inversion H6. subst.
  eapply AnnTyping_co_subst with (A1 := a) (A2:=b) (A3:=A)
              (D := dom ([(c,Co phi2)] ++ G)).
  { eapply AnnTyping_weakening with (F:=[(y,Co (Eq a b A))]); eauto.
    econstructor; eauto.
    econstructor; eauto.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
  }
  {
    destruct phi2.
    eapply An_Cast.
    eapply An_Assn.
    econstructor.  eauto.
    eauto. eauto.
    eauto.
    rewrite dom_app. simpl. auto.
    econstructor.
    eapply AnnIso_weakening with (F:=nil) (E:=[(c,Co (Eq a0 b0 A0))]) (G:=G);
      simpl_env; eauto.
  simpl_env.
  eapply (third ann_weaken_available_mutual) with (D := dom G).
  eapply AnnIso_weaken_available. eauto. simpl. fsetdec.
  }
  autorewrite with lngen. fsetdec.
+ eapply (@An_CPi_exists c); eauto.
   autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

Lemma An_CAbsCong_exists3 :
        ∀ (c : atom) (G : context) (D : available_props)
           (g1 g3 g4 : co) (phi1 : constraint) (a1 : tm)
           (phi2 : constraint) (a3 a2 B1 B3 : tm),
    AnnIso G D g1 phi1 phi2
    → c `notin` dom G \u D \u (fv_co_co_co g3) \u (fv_co_co_co g1)
        \u fv_co_co_co g4
    → AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) a1 a2
    → a3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c a2
    → get_tpg ([(c, Co phi1)] ++ G) a1 = B1
    -> get_tpg ([(c, Co phi2)] ++ G) a3 = B3
    → AnnDefEq G (dom G) g4 (a_CPi phi1 (close_tm_wrt_co c B1))
               (a_CPi phi2 (close_tm_wrt_co c B3))
    → AnnDefEq G D (g_CAbsCong g1 g3 g4)
               (a_CAbs phi1 (close_tm_wrt_co c a1))
               (a_CAbs phi2 (close_tm_wrt_co c a3))
                             .
Proof.
intros.
destruct (AnnIso_regularity H) as (T1 & T2).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H3) => EQ2. subst C3.
assert (AnnTyping ([(c,Co phi2)] ++ G)
                  (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c a2)
                  (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c C4)).
{
  pick fresh y.
  replace C4 with
  (open_tm_wrt_co (close_tm_wrt_co c C4) (g_Var_f c)) in T4;
    autorewrite with lngen; auto.
  replace a2 with
  (open_tm_wrt_co (close_tm_wrt_co c a2) (g_Var_f c)) in T4;
    autorewrite with lngen; auto.
  apply (@AnnTyping_co_swap c y) in T4; autorewrite with lngen; eauto.

  move: (AnnPropWff_weakening T1 [(c,Co phi1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnPropWff_weakening T2 [(c,Co phi2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnPropWff_weakening T1 [(c,Co phi1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnPropWff_weakening T2 [(c,Co phi2)] nil G eq_refl) => t5. simpl_env in t5.
  destruct phi1 as [a b A].
  inversion T1. subst.

  rewrite (co_subst_co_tm_spec a2 _ c); auto.
  rewrite (co_subst_co_tm_intro y); auto.

  rewrite (co_subst_co_tm_spec C4 _ c); auto.
  rewrite (co_subst_co_tm_intro y (close_tm_wrt_co c C4) ); auto.

  eapply AnnTyping_co_subst with (A1 := a) (A2:=b) (A3:=A)
              (D := dom ([(c,Co phi2)] ++ G)).
  { eapply AnnTyping_weakening with (F:=[(y,Co (Eq a b A))]); eauto 3 with ctx_wff.
    econstructor; eauto with ctx_wff.
    econstructor; eauto.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
  }
  {
    destruct phi2.
    eapply An_Cast.
    eapply An_Assn.
    econstructor.  eauto with ctx_wff.
    eauto. eauto.
    eauto.
    rewrite dom_app. simpl. auto.
    econstructor.
    eapply AnnIso_weakening with (F:=nil) (E:=[(c,Co (Eq a0 b0 A0))]) (G:=G);
      simpl_env; eauto with ctx_wff.
  simpl_env.
  eapply (third ann_weaken_available_mutual) with (D := dom G).
  eapply AnnIso_weaken_available. eauto. simpl. clear Fr. fsetdec.
  }
  autorewrite with lngen. fsetdec.
  autorewrite with lngen. fsetdec.
}
rewrite H2 in H4.
move: (get_tpg_correct H6 H4) => EQ3.
eapply (@An_CAbsCong_exists c c) with
(a2 := close_tm_wrt_co c a2)
  (B := a_CPi phi1 (close_tm_wrt_co c C4)); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@co_subst_co_tm_intro c).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ rewrite <- EQ3.
  rewrite H2.
  eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

End fc_get.


From L Require Import L Reduction Encodings InterpreterResults Rice DecidableRecognisable Enumerable.

Implicit Types P Q : term -> Prop.

Lemma id_computable : computable_fun (fun x : term => x).
Proof.
  exists I. split; value. intros. solveeq.
Qed.
Hint Resolve id_computable.

Definition π (u : term) s := eva (u (tenc s)).

Definition rel_eq P Q := forall x, P x <-> Q x.
Definition rel_incl P Q := forall x, P x -> Q x.

Notation "P <⋅> Q" := (rel_eq P Q) (at level 50).
Notation "f ^-1 A" := (fun s => A (f s)) (at level 40).

Notation "P <<=1 Q" := (rel_incl P Q) (at level 50).

Instance rel_eq_equiv : Equivalence rel_eq.
Proof.
  firstorder.
Qed.

Instance proper_rel_incl :
  Proper (rel_eq ==> rel_eq ==> iff) rel_incl.
Proof.
  firstorder.
Qed.

Instance proper_pi :
  Proper (equiv ==> rel_eq) π.
Proof.
  intros ? ? ? ?. unfold π. now rewrite H.
Qed.

Lemma inv_incl P Q (f : term -> term) : P <<=1 Q -> f ^-1 P <<=1 f ^-1 Q.
Proof.
  firstorder.
Qed.

Definition productive P :=
  exists g, computable_fun g /\ forall u, π u <<=1 P -> P (g u) /\ ~ π u (g u).

Definition creative P := recognisable P /\ productive (complement P).

Lemma productive_K : productive (fun s : term => ~ eva (s (tenc s))).
Proof.
  exists (fun x => x). split.
  - eapply id_computable.
  - unfold π. firstorder.
Qed.

Lemma productive_red P Q : productive P -> P ⪯ Q -> productive Q.
Proof.
  intros (g & (v & proc_v & ?) & ?) [f ? (u & ? & ?)].
  pose (k s := lambda (U (App (tenc s) (Encodings.Q (u 0))))).
  assert (forall s, π (k s) <⋅> f ^-1 (π s)). {
    unfold π. intros s t.
    transitivity (eva (U (App (tenc s) (Encodings.Q (u (tenc t)))))).
    eapply eva_proper. solveeq.
    rewrite H2, Q_correct, App_correct.
    now rewrite <- U_eva.
  }
  exists (fun x => f (g (k x))). split.
  - enough (computable_fun k) as (k' & ? & ?).
    + exists (lambda (u (v (k' 0)))). split; value.
      intros. eapply evaluates_equiv; split; value.
      transitivity (u (v (k' (tenc s)))). solveeq.
      now rewrite H5, H, H2.
    + admit.
  - assert True by tauto. intros s ?. pose proof (inv_incl (f := f) H5).
    rewrite <- H3 in H6.
    assert (f ^-1 Q <⋅> P) by firstorder. rewrite H7 in H6.
    eapply H0 in H6 as []. split.
    + now eapply f_red.
    + intros ?. eapply H8.
      eapply eva_proper. transitivity (U (App (tenc s) (Encodings.Q (u (tenc (g (k s))))))).
      solveeq. reflexivity.
      rewrite H2, Q_correct, App_correct, <- U_eva. eassumption.
Admitted.

Lemma extend g :
  computable_fun g -> exists k, computable_fun k /\ forall s t, pi (k s) t <-> pi s t \/ t = g s.
Proof.
  intros (u & ? & ?).
  exists (fun s => lambda (Eq 0 (u (tenc s)) (lambda T) (lambda (U (App (tenc s) (Q 1)))) I)). split.
  - admit.
  - intros.
    transitivity (eva (Eq (tenc t) (u (tenc s)) (lambda T) (lambda (U (App (tenc s) (Q (tenc t))))) I)).
    eapply eva_proper. solveeq.
    rewrite H0. destruct (Eq_correct t (g s)).
    decide (t = g s).
    + pose proof (H1 e) as ->.
      transitivity (eva T). eapply eva_proper. solveeq.
      firstorder; exists T; solveeq.
    + pose proof (H2 n) as ->.
      transitivity (eva (U (App (tenc s) (Q (tenc t))))). eapply eva_proper. solveeq.
      rewrite Q_correct, App_correct, <- U_eva. firstorder.
Admitted.

(* Definition infinite_list_c P := ~ exists L, forall s, P s <-> In s L. *)
Definition infinite_fun P := exists f : nat -> term, forall n, P (f n) /\ forall m, m < n -> f m <> f n.
Definition really_infinite P := ~ exists L, forall x, P x -> x el L.
Definition infinite P := forall n, ~~ exists A, card A >= n /\  forall x, x el A -> P x.

Lemma infinite_fun_infinite P : infinite_fun P -> infinite P.
Proof.
  intros [f] n. (* enough (exists A, card A = n -> forall x, x el A -> P x) by tauto. *)
  (* exists (map f (seq 1 n)). intros. *)
Admitted.

(* infinite -> really_infinite and really_infinite -> infinite_list *)
(* use really_infinite as definition *)

Lemma infinite_list B L : infinite B -> ~~ exists s, B s /\ ~ s el L.
Proof.
Admitted.

Lemma productive_inf P : productive P -> exists A, A <<=1 P /\ recognisable A /\ infinite A.
Proof.
  intros (g & ? & ?). destruct (extend H) as (k & (v & ? & ?) & ?).
  pose (f := fix f n := match n with 0 => D | S n => k (f n) end).
  assert (computable_gen enc tenc f). {
    exists (rho (lambda (lambda (0 (tenc D) (lambda (v (2 0))))))). split; value.
    intros n. eapply evaluates_equiv; split; value.
    induction n; try specialize (H2 (f n)); solveeq.
  }
  exists (fun s => exists n, g (f n) = s).
  assert (Hf : forall n, pi (f n) <<=1 P /\ P (g (f n))). {
    induction n.
    * cbn in *. split.
      -- intros ? ?. now eapply D_pi in H5.
      -- eapply H0. intros ? ?. now eapply D_pi in H5.
    * unfold f. fold f. split.
      -- intros ?. rewrite H3. intros [ | ->]; firstorder.
      -- eapply H0. intros ?. rewrite H3. intros [ | ->]; firstorder.
  }
  - repeat split.
    + intros ? [n <-]. eapply Hf.
    + destruct H as (u' & ? & ?). destruct H4 as (v' & ? & ?).
      eapply recognisable_range_total with (u := lambda (u' (v' 0))). value.
      intros. specialize (H6 n). specialize (H5 (f n)). solveeq.
    + eapply infinite_fun_infinite. exists (fun n => g (f n)). intros. split. eauto.
      intros ? ? ?.
      destruct (H0 (f n)) as [_ ?]; try eapply Hf. eapply H7. rewrite <- H6. clear H6 H7.
      induction H5; eapply H3; eauto.
Qed.

Definition simple P := recognisable P /\ infinite (complement P) /\ ~ exists A, A <<=1 complement P /\ recognisable A /\ infinite A.

Lemma simple_spec P : simple P -> ~ decidable P /\ ~ creative P.
Proof.
  intros. split.
  - intros [_] % dec_rec. eapply H.
    exists (complement P). repeat split. firstorder. eassumption. eapply H.
  - intros [? ? % productive_inf]. now eapply H.
Qed.

Definition ran (u : term) t := exists s, u (tenc s) ▷ tenc t.
Definition dom (u : term) s := exists t, u (tenc s) ▷ tenc t.

Definition Extr := lambda (0 (lambda (lambda 1)) D I).

Lemma Extr_spec s : Extr (oenc (Some s)) ▷ tenc s /\ ~ eva (Extr (oenc None)).
Proof.
  split.
  - eapply evaluates_equiv; split; value. solveeq.
  - assert (Extr (oenc None) ≡ Omega) as -> by solveeq. eapply eva_Omega.
Qed.

Ltac fdecide P := let H := fresh "H" in assert (H : ~~ (P \/ ~ P)) by tauto; apply H; clear H; intros [H|H].

Lemma filter_predicate X (A : list X) (p : X -> Prop) :
  ~~ exists B, forall x, x el B <-> x el A  /\ p x.
Proof.
  induction A; intros H.
  - apply H. exists []. firstorder.
  - apply IHA. intros [B]. fdecide (p a); apply H.
    + exists (a :: B). cbn. intros. rewrite H0. now intuition subst.
    + exists B. cbn. intros. rewrite H0. now intuition subst.
Qed.

Lemma simple_ex : exists P, simple P.
Proof.
  pose (El := I). pose (Not := I). pose (Beta := I). pose (R := fun {X} (x : X) (n : nat) => I).
  pose (u := (.\ "s"; !U (!App "s" (!Encodings.N (!C (.\ "n"; !Not (!El (!U (!App "s" (!Encodings.N "n"))) (!L_term (!Encodings.Add (!Beta "s") (!Beta "s"))))))))) : term).
  enough (forall s v, u (tenc s) ▷ tenc v <-> Inj L beta _ v > 2 * Inj L beta _ s).
  exists (ran u).
  repeat split.
  - admit.
  - unfold infinite. intros n.
    pose proof (@filter_predicate _ (seq 0 (2 * n)) (fun x => exists n, n el seq 0 (n - 1) /\ u (R _ Enumerable.L n) ▷ tenc x)).
    intros ?. eapply H0. clear H0. intros [B]. eapply H1. clear H1.
    exists (map (fun n => R _ L n) B). split.
    + admit.
    + intros ? (? & ? & ?) % in_map_iff. subst. intros [].
      eapply H in H1. eapply H0 in H2 as [[_ ?] % in_seq (? & [_ ?] % in_seq & ?)]. omega.
  - intros (B & ? & ? & ?). eapply recognisable_enumerable in H1 as [s].
    pose (s' := lambda (Extr (s 0))).
    eapply infinite_list with (L := L (2 * Inj L beta _ s')) in H2. eapply H2. clear H2. intros (t & ? & ?).
    enough (Inj L beta _ t > (2 * Inj L beta term_eq_dec s')).
    eapply H in H4. eapply H0; eauto. exists s'. eauto. unfold gt. eapply not_ge. intros ?.
    eapply H3. admit.
Admitted.

Definition m_complete P := recognisable P /\ forall Q, recognisable Q -> Q ⪯ P.

Definition mequiv P Q := P ⪯ Q /\ Q ⪯ P.
Notation "P ≡𝐦 Q" := (mequiv P Q) (at level 40).

Instance Subrel_mequiv : subrelation mequiv mreducible.
Proof.
  intros ? ? ?. eapply H.
Qed.

Instance mequiv_proper : Proper (mequiv ==> mequiv ==> iff) mreducible.
Proof.
  intros P1 P2 [] Q1 Q2 []. split; intros.
  - transitivity P1; eauto. transitivity Q1; eauto.
  - transitivity P2; eauto. transitivity Q2; eauto.
Qed.

Instance Equivalence_mequiv : Equivalence mequiv.
Proof.
  econstructor.
  - split; reflexivity.
  - intros ? ? []. split; eassumption.
  - intros ? ? ? [] []. split; now transitivity y.
Qed.

Lemma m_complete_red P Q :
  m_complete P -> m_complete Q -> P ≡𝐦 Q.
Proof.
  intros [] []. split; intuition.
Qed.

Lemma m_complete_K : m_complete eva.
Proof.
  split.
  - eapply mreducible_recognisable. eapply recognisable_eva. reflexivity.
  - intros. now eapply recognisable_iff.
Qed.

Lemma mcomplete_creative P : m_complete P -> creative P.
Proof.
  intros []. split. eauto.
  eapply productive_red. eapply productive_K. eapply mreducible_comp.
  transitivity eva. eapply eva_red. eapply H0. eapply recognisable_eva.
Qed.

Lemma simple_dec P : simple P -> ~ decidable P.
Proof.
  intros ? [_ ?] % dec_rec. eapply H.
  exists (complement P). firstorder.
Qed.

Lemma simple_creative P : simple P -> ~ creative P.
Proof.
  intros ? [? ? %productive_inf]. now eapply H.
Qed.

Lemma simple_nontrivial P : simple P -> exists s t, P s /\ ~ P t.
Admitted.

Lemma simple_between P :
  simple P -> 𝐎𝐦 <𝐦 mdegree_of P /\ mdegree_of P <𝐦 𝐎𝐦'.
Proof.
  intros. pose proof (simple_dec H). pose proof (simple_creative H).
  split.
  - split.
    + eapply 𝐎𝐦_spec. intros. hnf in H2.
Admitted.

Generalizable Variables n m.

Definition d_𝐦 P := fun Q => P ≡𝐦 Q.

Record mdegree :=
  { mdegree_a :> (term -> Prop) -> Prop ;
    mdegree_spec : exists P, forall Q, mdegree_a Q <-> P ≡𝐦 Q
  }.
Implicit Types a b : mdegree.
Notation "P ∈ a" := (mdegree_a a P) (at level 50).

Lemma mdegree_nonempty a : exists P, P ∈ a.
Proof.
  destruct a as (a & P & ?). exists P. cbn. now eapply i.
Qed.

Definition mdegree_of (R : (term -> Prop)) : mdegree.
Proof.
  exists (d_𝐦 R). exists R. firstorder.
Defined.

Definition leq_mdegree a b := forall P Q, P ∈ a -> Q ∈ b -> P ⪯ Q.
Notation "a ≤𝐦 b" := (leq_mdegree a b) (at level 40).

Lemma leq_mdegree_alt a b : a ≤𝐦 b <-> exists P Q, P ∈ a /\ Q ∈ b /\ P ⪯ Q.
Proof.
  split.
  - intros. destruct (mdegree_nonempty a) as [P], (mdegree_nonempty b) as [Q].
    exists P, Q. eauto.
  - intros (P & Q & HP & HQ & H). intros P' Q' H1 H2.
    destruct a as (a & Pa & Ha), b as (b & Pb & Hb). cbn in *. rewrite Ha, Hb in *.
    now rewrite <- H1, HP, <- H2, HQ.
Qed.

Definition mdegree_eq : mdegree -> mdegree -> Prop := (@predicate_equivalence (Tcons (term -> Prop) Tnil)).

Instance mdegree_eq_equiv : Equivalence mdegree_eq.
Proof.
  econstructor; firstorder.
Qed.

Notation "a =𝐦 b" := (mdegree_eq a b)  (at level 40).

Definition lt_mdegree a b := a ≤𝐦 b /\ ~ a =𝐦 b.
Notation "a <𝐦 b" := (lt_mdegree a b) (at level 40).

Instance leq_pre : PreOrder leq_mdegree.
Proof.
  econstructor.
  - intros (a & P & ?). unfold leq_mdegree. cbn in *.
    intros. now assert (P0 ≡𝐦 P /\ Q ≡𝐦 P) as [-> ->] by firstorder.
  - intros (a1 & Q1 & H1) (a2 & Q2 & H2) (a3 & Q3 & H3). unfold leq_mdegree. cbn. intros.
    transitivity Q2.
    + eapply H. eassumption. now eapply H2.
    + eapply H0. now eapply H2. eassumption.
Qed.

Instance leq_porder : PartialOrder mdegree_eq leq_mdegree.
Proof.
  hnf. intros a b. hnf. split.
  - destruct a as (a & P & ?). destruct b as (b & Q & ?). unfold leq_mdegree in *. cbn in *.
    intros. split.
    + intros. rewrite H in *.
      eapply i0 in H0. eapply i0 in H1. now rewrite <- H0, <- H1.
    + intros ? ? ? ?. cbn in *. rewrite H in *.
      eapply i0 in H0. eapply i0 in H1. now rewrite <- H0, <- H1.
  - intros []. unfold Basics.flip in H0.
    destruct a as (a & P & ?). destruct b as (b & Q & ?). unfold leq_mdegree in *. cbn in *.
    intros R. rewrite i, i0.
    enough (P ≡𝐦 Q) by now rewrite H1.
    split. eapply H. now eapply i. now eapply i0.
    eapply H0. now eapply i0. now eapply i.
Qed.

Instance le_strict : StrictOrder lt_mdegree.
Proof.
  eapply PartialOrder_StrictOrder. exact _.
Qed.

Definition 𝐨 : mdegree.
Proof.
  exists (fun P => forall x, ~ P x). exists (fun _ => False).
  intros. split; intros.
  - split. exists (fun x => x).
    + firstorder.
    + eauto.
    + now eapply mreducible_empty.
  - destruct H. now eapply mreducible_empty.
Defined.

Definition 𝐧 : mdegree.
Proof.
  exists (fun P => forall x, P x). exists (fun _ => True). split; intros.
  - split. exists (fun x => x).
    + firstorder.
    + eauto.
    + now eapply mreducible_full.
  - destruct H. now eapply mreducible_full.
Defined.

Definition decidable_mdegree a := exists P, P ∈ a /\ decidable P.
Definition recognisable_mdegree a := exists P, P ∈ a /\ recognisable P.

Lemma 𝐨_decidable : decidable_mdegree 𝐨.
Proof.
  exists (fun _ => False). split.
  - cbn. firstorder.
  - exists (lambda F). split; value.
    right. split. auto. solveeq.
Qed.

Lemma 𝐧_decidable : decidable_mdegree 𝐧.
Proof.
  exists (fun _ => True). split.
  - cbn. firstorder.
  - exists (lambda T). split; value.
    left. split. auto. solveeq.
Qed.

Definition 𝐎𝐦 : mdegree.
Proof.
  exists (fun P => (exists s, P s) /\ (exists s, ~ P s) /\ decidable P).
  exists lam. intros. split.
  + intros ([s ?] & [t ?] & ?).
    split. eapply mreducible_red; eauto.
    eapply decidable_lam.
    eapply mreducible_red with (s := lambda 0) (t := 0); eauto.
    firstorder congruence.
  + intros [ [] ]. repeat split.
    * exists (f (lambda 0)). eapply f_red. eauto.
    * exists (f (0 0)). rewrite <- f_red. firstorder congruence.
    * eapply mreducible_dec; eauto. eapply decidable_lam.
Defined.

Lemma 𝐎𝐦_spec a :
  (forall P, P ∈ a -> exists s t, P s /\ ~ P t) -> 𝐎𝐦 ≤𝐦 a.
Proof.
  intros. intros ? ? ? ?. cbn in *.
  specialize (H _ H1) as (? & ? & ? & ?).
  eapply mreducible_red; firstorder eauto.
Qed.

Lemma 𝐨_min a : (forall P, P ∈ a -> exists s, ~ P s) -> 𝐨 ≤𝐦 a.
Proof.
  intros ? ? ? ? ?.
  cbn in H0. transitivity (fun _ : term => False).
  + eapply mreducible_empty. eassumption.
  + destruct (H _ H1) as [s].
    exists (fun _ => s). firstorder. exists (lambda (tenc s)).
    split; value. intros. solveeq.
Qed.

Lemma 𝐧_min a : (forall P, P ∈ a -> exists s, P s) -> 𝐧 ≤𝐦 a.
Proof.
  intros ? ? ? ? ?.
  cbn in H0. transitivity (fun _ : term => True).
  + eapply mreducible_full. eassumption.
  + destruct (H _ H1) as [s].
    exists (fun _ => s). firstorder. exists (lambda (tenc s)).
    split; value. intros. solveeq.
Qed.

Lemma recognisable_mdegree_all a :
  recognisable_mdegree a -> forall P, P ∈ a -> recognisable P.
Proof.
  intros (Q & ? & ?) ? ?. destruct a as (a & ? & ?). cbn in *.
  eapply mreducible_recognisable; eauto.
  rewrite i in *. rewrite H in H1. now rewrite H1.
Qed.

Lemma mdegree_closed_recognisable a b :
  a ≤𝐦 b -> recognisable_mdegree b -> recognisable_mdegree a.
Proof.
  intros (P & Q & ? & ? & ?) % leq_mdegree_alt. eintros ? % recognisable_mdegree_all; eauto.
  exists P. split. eassumption. eapply mreducible_recognisable; eauto.
Qed.

Lemma leq_mdegree_lub a b : exists c,
    a ≤𝐦 c /\ b ≤𝐦 c /\ forall d, a ≤𝐦 d -> b ≤𝐦 d -> c ≤𝐦 d.
Proof.
  destruct a as (a & P & ?), b as (b & Q & ?).
  pose (R := (fun s => match s with
                         app 0 s => P s
                       | app _ s => Q s
                       | s => Q s
                    end)).
  assert (P ⪯ R). {
    exists (fun s => app 0 s).
    - cbn. firstorder.
    - exists (lambda (App (tenc 0) 0)). split; value. intros.
      eapply evaluates_equiv; split; value.
      transitivity (App (tenc 0) (tenc s)). solveeq.
      now rewrite App_correct.
  }
  assert (Q ⪯ R). {
    exists (fun s => app 1 s).
    - cbn. firstorder.
    - exists (lambda (App (tenc 1) 0)). split; value. intros.
      eapply evaluates_equiv; split; value.
      transitivity (App (tenc 1) (tenc s)). solveeq.
      now rewrite App_correct.
  }
  exists (mdegree_of R). rewrite !leq_mdegree_alt. cbn. repeat split.
  - exists P, R. repeat split.
    + now eapply i.
    + reflexivity.
    + reflexivity.
    + eassumption.
  - exists Q, R. repeat split.
    + now eapply i0.
    + reflexivity.
    + reflexivity.
    + eassumption.
  - intros (d & ? & ?). unfold leq_mdegree. cbn. intros H1 H2.
    intros ? D ? ?.
    assert (P ⪯ D) as [f]. { eapply H1. now eapply i. eauto. }
    assert (Q ⪯ D) as [g]. { eapply H2. now eapply i0. eauto. }
    rewrite <- H3.
    exists (fun s => match s with
             | app 0 s => f s
             | app _ s => g s
             | _ => g s
             end).
    cbn. intros. destruct s as [ | [[] | | ] |]; cbn; firstorder.
    destruct f_comp as (u & ? & ?), f_comp0 as (v & ? & ?).
    exists (lambda (0 (lambda (v 1)) (lambda (lambda (1 (lambda (0 (u 1) (lambda (v 2)))) (lambda (lambda (v 2))) (lambda (v 1))))) (lambda (v 1)))).
    split; value. intros. eapply evaluates_equiv; split; value.
    destruct s as [ | [ [] | | ] | ] eqn:E.
    + specialize (H8 s). subst. solveeq.
    + specialize (H6 t1). subst. solveeq.
    + specialize (H8 t1). specialize (H6 t1). subst. solveeq.
    + specialize (H8 t2). specialize (H6 t2). solveeq.
    + specialize (H8 t1). solveeq.
    + specialize (H8 s). subst. solveeq.
Qed.

Definition 𝐎𝐦' := mdegree_of (fun s => eva (s (tenc s))).

Lemma maximum_mdegree a :
  recognisable_mdegree a ->
  a ≤𝐦 𝐎𝐦'.
Proof.
  intros (P & ? & ?). eapply leq_mdegree_alt.
  exists P, (fun s : term => eva (s (tenc s))).
  do 2 try split; try now eauto.
  now eapply recognisable_iff.
Qed.