Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Decidability.
Require Export Coq.micromega.Lia.

Ltac inv H := inversion H; subst.

Module Algo.

(* This is the Algo typing for  Iso + Fsub *)

Inductive exposure : env -> typ -> typ -> Prop :=
  | exposure_nat: forall E,
      exposure E typ_nat typ_nat
  | exposure_top : forall E,
      exposure E typ_top typ_top
  | exposure_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      exposure E U T ->
      exposure E (typ_fvar X) T
  | exposure_arrow: forall E A1 A2,
      exposure E (typ_arrow A1 A2) (typ_arrow A1 A2)
  | exposure_all : forall E S T,
      exposure E (typ_all S T) (typ_all S T)
  | exposure_rec: forall E A,
      exposure E (typ_mu A) (typ_mu A)
  | exposure_label: forall E X A,
      exposure E (typ_label X A) (typ_label X A)
  | exposure_rcd: forall E A,
      rt_type A ->
      exposure E A A
.

Inductive exposure2 : env -> typ -> typ -> Prop :=
  | exposure2_nat: forall E,
      exposure2 E typ_nat typ_nat
  | exposure2_top : forall E,
      exposure2 E (typ_mu typ_top) typ_top
  (* | exposure2_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      exposure2 E U T ->
      exposure2 E (typ_fvar X) T *)
  | exposure2_arrow: forall E A1 A2,
      exposure2 E (typ_arrow A1 A2) (typ_arrow A1 A2)
  | exposure2_all : forall E S T,
      exposure2 E (typ_all S T) (typ_all S T)
  | exposure2_rec: forall E A,
      exposure2 E (typ_mu A) (typ_mu A)
  | exposure2_label: forall E X A,
      exposure2 E (typ_label X A) (typ_label X A)
  | exposure2_rcd: forall E A,
      rt_type A ->
      exposure2 E A A
.

Fixpoint collectLabele (e: exp) : atoms :=
  match e with
  | (exp_rcd_cons i e1 e2) => {{i}} \u collectLabele e2
  | _ => {}
  end.

Inductive typing : env -> exp -> typ -> Prop :=
  | typing_nat: forall G,
    wf_env G ->
    typing G (exp_nat) (typ_nat)
  | typing_var : forall E x T,
      wf_env E ->
      binds x (bind_typ T) E ->
      typing E (exp_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x : atom, x `notin` L ->
        typing (x ~ bind_typ V ++ E) (open_ee e1 x) T1) ->
      typing E (exp_abs V e1) (typ_arrow V T1)
  | typing_app : forall T11 T12 E e1 e2 T1 T2,
      typing E e1 T1 ->
      exposure E T1 (typ_arrow T11 T12) ->
      typing E e2 T2 ->
      sub E T2 T11 ->
      typing E (exp_app e1 e2) T12
  | typing_tabs : forall L E V e1 T1,
      (forall X : atom, X `notin` L ->
        typing (X ~ bind_sub V ++ E) (open_te e1 X) (open_tt T1 X)) ->
      typing E (exp_tabs V e1) (typ_all V T1)
  | typing_tapp : forall E e1 T1 T11 T12 T2,
      typing E e1 T1 ->
      exposure E T1 (typ_all T11 T12) ->
      sub E T2 T11 ->
      typing E (exp_tapp e1 T2) (open_tt T12 T2)
  | typing_fold : forall G A S e T,
     typing G e S ->
     sub G S (open_tt A T) ->
     exposure2 G (typ_mu A) T ->
     WF G T -> (* cannot be removed  *)
     typing G (exp_fold T
      (* (typ_mu A)  *)
      e) T
 (* | typing_fold_top : forall G A S e,
      typing G e S ->
      WF G (typ_mu A) ->
      sub G S (open_tt A typ_top) ->
      typing G (exp_fold typ_top
        (* (typ_mu A) conflicting choice of annotation *)
        e) typ_top *)
 | typing_unfold : forall G A A' T e,
     typing G e A' ->
     sub G A' A ->
     exposure G A (typ_mu T) ->
     typing G (exp_unfold A e)  (open_tt T A)
     (* typing G e A -> sub G A (typ_mu T) ->
     typing G (exp_unfold A e)  (open_tt T A) *)
  | typing_proj : forall G e T T' i Ti,
      typing G e T ->
      exposure G T T' ->
      Tlookup i T' = Some Ti ->
      typing G (exp_rcd_proj e i) Ti
  | typing_rcd_nil : forall G,
      wf_env G ->
      typing G exp_rcd_nil typ_rcd_nil
  | typing_rcd_cons: forall G e1 e2 T1 T2 i,
      typing G e1 T1 ->
      typing G e2 T2 ->
      rt_type T2 ->
      rt_expr e2 ->
      i \notin (collectLabele e2) ->
      typing G (exp_rcd_cons i e1 e2) (typ_rcd_cons i T1 T2)
.

Hint Constructors exposure.
Hint Constructors exposure2.

Lemma exposure_sound: forall E A B,
  wf_env E -> WF E A ->
  exposure E A B -> sub E A B.
Proof with auto.
  intros.
  induction H1;try solve [apply Reflexivity;auto]...
  - eapply sa_trans_tvar with (U:=U)...
    apply IHexposure... apply WF_from_binds_typ with (x:=X)...
Qed.

Lemma exposure2_sound: forall E A B,
  wf_env E -> WF E B ->
  exposure2 E A B -> sub E A B.
Proof with auto.
  intros.
  induction H1;try solve [apply Reflexivity;auto]...
  - constructor...
    apply WF_rec with (L:={})...
Qed.

Definition not_var_typ U :=
  match U with
  | typ_fvar _ => False
  | _ => True
  end.

Lemma exposure_promote: forall E S T U,
  WF E T ->
  exposure E S T -> sub E S U -> not_var_typ U ->
  sub E T U.
Proof with auto.
  intros. generalize dependent T.
  induction H1;intros...
  - inv H1...
  - inv H2...
  - inv H3;inv_rt. apply IHsub...
    + apply sub_regular in H1. destruct_hypos.
      pose proof binds_uniq _ _ _ H1 H H5.
      subst...
  - inv H0...
  - inv H3;inv_rt...
    eapply sa_all with (L:=L)...
  - inv H5;inv_rt. eapply sa_rec with (L:=L)...
  - inv H0...
  - inv H9;inv_rt...
Qed.

Lemma exposure_weakening: forall E S T X U,
  exposure E S T ->
  exposure (X ~ bind_sub U ++ E) S T.
Proof with auto.
  intros. induction H...
  eapply exposure_trans_tvar with (U:=U0)...
Qed.

Lemma exposure_weakening_bind: forall E S T a,
  exposure E S T ->
  exposure (a :: E) S T.
Proof with auto.
  intros. induction H...
  rewrite_env ([ a ] ++ E)...
  eapply exposure_trans_tvar with (U:=U)...
Qed.

Lemma exposure_weakening_bind2: forall E1 E2 S T a,
  exposure (E1 ++ E2) S T ->
  exposure (E1 ++ a ++ E2) S T.
Proof with auto.
  intros. dependent induction H...
  eapply exposure_trans_tvar with (U:=U)...
Qed.

Lemma exposure2_weakening: forall E S T X U,
  exposure2 E S T ->
  exposure2 (X ~ bind_sub U ++ E) S T.
Proof with auto.
  intros. induction H...
  (* eapply exposure_trans_tvar with (U:=U0)... *)
Qed.

Lemma exposure2_weakening_bind: forall E S T a,
  exposure2 E S T ->
  exposure2 (a :: E) S T.
Proof with auto.
  intros. induction H...
  (* rewrite_env ([ a ] ++ E)...
  eapply exposure_trans_tvar with (U:=U)... *)
Qed.

Lemma exposure2_weakening_bind2: forall E1 E2 S T a,
  exposure2 (E1 ++ E2) S T ->
  exposure2 (E1 ++ a ++ E2) S T.
Proof with auto.
  intros. dependent induction H...
  (* eapply exposure_trans_tvar with (U:=U)... *)
Qed.

Lemma exposure_ex: forall E A,
  wf_env E -> WF E A -> exists B,
  exposure E A B /\ not_var_typ B /\ WF E B.
Proof with auto.
  intros. revert A H0.
  induction E;intros...
  {
    dependent induction H0.
    (* + dependent induction H0. *)
    - exists typ_top;simpl...
    - exists typ_nat;simpl...
    - inv H0.

    - exists (typ_arrow A B).
      split;simpl...
    - exists (typ_all T1 T2).
      repeat split;simpl...
      apply WF_all with (L:=L)...
    - exists (typ_mu A).
      repeat split;simpl...
      apply WF_rec with (L:=L)...
    - exists (typ_label X A).
      repeat split;simpl...
    - exists (typ_rcd_nil)...
      repeat split;simpl...
    - exists (typ_rcd_cons i T1 T2)...
      repeat split;simpl...
  }

  {
    dependent induction H0.
    (* + dependent induction H0. *)
    - exists typ_top;simpl...
    - exists typ_nat;simpl...
    - inv H0.
      + inv H. dependent induction H5.
        * exists typ_top. repeat split;simpl...
          apply exposure_trans_tvar with (U:=typ_top)...
        * exists typ_nat. repeat split;simpl...
          apply exposure_trans_tvar with (U:=typ_nat)...
        * pose proof WF_from_binds_typ _ _ H4 H1.
          destruct (IHE H4 _ H2). destruct_hypos.
          exists x. repeat split;simpl...
          { apply exposure_trans_tvar with (U:= X0)...
            apply exposure_trans_tvar with (U:= U)...
            rewrite_env (X ~ bind_sub X0 ++ E).
            apply exposure_weakening...
          }
          { rewrite_env (nil ++ X ~ bind_sub X0 ++ E).
            eapply WF_weakening... }
        * inv H. exists (typ_arrow A B).
          repeat split;simpl...
          { apply exposure_trans_tvar with (U:=(typ_arrow A B))... }
          { rewrite_env (nil ++ X ~ bind_sub (typ_arrow A B) ++ E).
            eapply WF_weakening... }
        * inv H. exists (typ_all T1 T2).
          repeat split;simpl...
          { apply exposure_trans_tvar with (U:=(typ_all T1 T2))... }
          { rewrite_env (nil ++ X ~ bind_sub (typ_all T1 T2) ++ E).
            eapply WF_weakening... }
        * inv H. exists (typ_mu A).
          repeat split;simpl...
          { apply exposure_trans_tvar with (U:=(typ_mu A))... }
          { rewrite_env (nil ++ X ~ bind_sub (typ_mu A) ++ E).
            eapply WF_weakening... }
        * inv H. exists (typ_label X0 A).
          repeat split;simpl...
          { apply exposure_trans_tvar with (U:= (typ_label X0 A))... }
          { rewrite_env (nil ++ X ~ bind_sub  (typ_label X0 A) ++ E).
            eapply WF_weakening... }
        * exists typ_rcd_nil. repeat split;simpl...
          apply exposure_trans_tvar with (U:=typ_rcd_nil)...
        * inv H. exists (typ_rcd_cons i T1 T2).
          repeat split;simpl...
          { apply exposure_trans_tvar with (U:= (typ_rcd_cons i T1 T2))... }
          { rewrite_env (nil ++ X ~ bind_sub  (typ_rcd_cons i T1 T2) ++ E).
            eapply WF_weakening... }
      + assert (wf_env E). { inv H... }
        assert (WF E U).
        { eapply WF_from_binds_typ... apply H1. }
        destruct (IHE H2 _ H3) as [S ]. destruct_hypos.
        exists S. repeat split;simpl...
        { apply exposure_trans_tvar with (U:= U)...
          apply exposure_weakening_bind...
        }
        { rewrite_env (nil ++ [a] ++ E).
          apply WF_weakening... }
    - exists (typ_arrow A B).
      split;simpl...
    - exists (typ_all T1 T2).
      repeat split;simpl...
      apply WF_all with (L:=L)...
    - exists (typ_mu A).
      repeat split;simpl...
      apply WF_rec with (L:=L)...
    - exists (typ_label X A).
      repeat split;simpl...
    - exists (typ_rcd_nil)...
      repeat split;simpl...
    - exists (typ_rcd_cons i T1 T2)...
      repeat split;simpl...
  }
Qed.

Lemma exposure_WF: forall E A B,
  wf_env E -> WF E A -> exposure E A B ->
  WF E B.
Proof.
  intros.
  pose proof exposure_sound H H0 H1.
  apply sub_regular in H2.
  destruct_hypos. auto.
Qed.

Lemma exposure2_WF: forall E A B,
  wf_env E -> WF E B -> exposure2 E A B ->
  WF E B.
Proof.
  intros.
  pose proof exposure2_sound H H0 H1.
  apply sub_regular in H2.
  destruct_hypos. auto.
Qed.

Lemma typing_rt_expr_novar : forall E e (X:atom),
  typing E e X -> rt_expr e -> False.
Proof with auto.
  intros.
  dependent induction H;
  try match goal with
  | [H : rt_expr _ |- _] => inversion H
  end.
Qed.

Lemma typing_collectLabel_inclusion : forall E e T,
  typing E e T -> rt_type T -> rt_expr e ->
  collectLabel T [<=]
  collectLabele e.
Proof with auto.
  intros. induction H;inv_rt;try solve [inversion H1].
  - (* nil *)
    reflexivity.
  - (* cons *)
    simpl. rewrite IHtyping2... reflexivity.
Qed.

Lemma typing_regular : forall E e T,
  typing E e T ->
  wf_env E /\ expr e /\ WF E T.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  -
    repeat split...
    apply wf_typ_from_binds_typ with (x:=x)...
  -
    pick fresh Y.
    assert (wf_env (Y ~ bind_typ V ++ E)).
    specialize_x_and_L Y L...
    destruct_hypos...
    dependent destruction H1...
    repeat split...
    +
      apply expr_abs with (L:=L)...
      apply WF_type with (E:=E) ...
      intros.
      apply H0...
    +
      constructor...
      specialize_x_and_L Y L...
      destruct_hypos.
      add_nil.
      apply wf_typ_strengthening with (x:=Y) (U:=V)...
  -
    pose proof exposure_WF H3 H8 H0.
    dependent destruction H9...
  -
    pick fresh Y.
    assert (wf_env (Y ~ bind_sub V ++ E)).
    specialize_x_and_L Y L...
    destruct_hypos...
    dependent destruction H1...
    repeat split...
    +
      apply expr_tabs with (L:=L)...
      apply WF_type with (E:=E) ...
      intros.
      apply H0...
    +
      apply WF_all with (L:=L)...
      intros.
      eapply H0...
  -
    pose proof exposure_WF H2 H4 H0.
    dependent destruction H5.
    repeat split...
    constructor...
    get_type...
    pick fresh X.
    rewrite subst_tt_intro with (X:=X)...
    rewrite_env (map (subst_tb X  T2) nil ++ E).
    apply subst_tb_wf with (Q:=bind_sub T11)...
    apply H6...
    get_well_form...
  -
    apply exposure2_sound in H1...
    get_well_form...
    repeat split...
    constructor...
    apply WF_type with (E:=G)...
    (* get_well_form... *)
  -
    repeat split...
    constructor...
    apply WF_type with (E:=G)... { get_well_form... }
    apply sub_regular in H0. destruct_hypos...
    apply wf_open_rec2...
    apply exposure_WF in H1...
  -
    repeat split...
    apply wf_rcd_lookup with (i:=i) (T:=T')...
    apply exposure_sound in H0... get_well_form...
  -
    repeat split...
    constructor...
    rewrite typing_collectLabel_inclusion...
    apply H0.
Qed.

Lemma exposure_typ_strengthening: forall E1 E2 S T X U,
  exposure (E1 ++ X ~ bind_typ U ++ E2) S T ->
  exposure (E1 ++ E2) S T.
Proof with auto.
  intros. dependent induction H...
  eapply exposure_trans_tvar with (U:=U0)...
  2:{ apply IHexposure with (X0:=X) (U1:=U)... }
  apply binds_app_iff in H. destruct H.
  { apply binds_app_iff. left... }
  apply binds_app_iff in H. destruct H.
  { inv H. inv H1. inv H1. }
  apply binds_app_iff. right...
Qed.

Lemma exposure2_typ_strengthening: forall E1 E2 S T X U,
  exposure2 (E1 ++ X ~ bind_typ U ++ E2) S T ->
  exposure2 (E1 ++ E2) S T.
Proof with auto.
  intros. dependent induction H...
  (* eapply exposure_trans_tvar with (U:=U0)...
  2:{ apply IHexposure with (X0:=X) (U1:=U)... }
  apply binds_app_iff in H. destruct H.
  { apply binds_app_iff. left... }
  apply binds_app_iff in H. destruct H.
  { inv H. inv H1. inv H1. }
  apply binds_app_iff. right... *)
Qed.

Lemma label_choose_reserve_e:
  forall (X : atom) (u : exp) [e : exp],
  expr e -> rt_expr e -> collectLabele e [=] collectLabele (subst_ee X u e).
Proof with auto.
  intros.
  induction H;simpl;try reflexivity...
  + inversion H0.
  + rewrite IHexpr2... reflexivity.
Qed.

Lemma typing_replacing: forall E1 E2 e T U X Y,
  typing (E1++ X ~ bind_typ U ++E2) e T ->
  X <> Y ->
  wf_env ( E1 ++ Y ~ bind_typ U ++ E2) ->
  typing (E1 ++ Y ~ bind_typ U ++E2) (subst_ee X Y e) T.
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros.
  - constructor. auto.
  - simpl. destruct (x == X)...
    { subst. apply typing_var...
      assert (binds X (bind_typ U) (E1 ++ X ~ bind_typ U ++ E2))...
      pose proof binds_unique _ _ _ _ _ H0 H3.
      rewrite H4... apply uniq_from_wf_env... }
    { apply typing_var with (T:=T)... analyze_binds H0. }
  - apply typing_abs with (L:=L \u {{ X }}
      \u dom (E1 ++ Y ~ bind_typ U ++ E2) )...
    intros.
    specialize_x_and_L x L.
    rewrite subst_ee_open_ee_var...
    rewrite_env ((x~bind_typ V ++ E1) ++ Y ~ bind_typ U ++ E2).
    apply H0...
    rewrite_env (x~bind_typ V ++ (E1 ++ Y ~ bind_typ U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ X ~ bind_typ U ++ E2) in H10.
      apply wf_typ_strengthening in H10.
      apply WF_weakening... }
  - apply typing_app with (T11:=T11) (T2:=T2) (T1:=T1)...
    + apply exposure_typ_strengthening in H0.
      apply exposure_weakening_bind2...
    + apply Sub_weakening... apply Sub_typ_strengthening in H2...
  - simpl. apply typing_tabs with (L:=L \u {{ X }}
  \u dom (E1 ++ Y ~ bind_typ U ++ E2) ).
    intros.
    specialize_x_and_L X0 L.
    rewrite subst_ee_open_te_var...
    rewrite_env ((X0~bind_sub V ++ E1) ++ Y ~ bind_typ U ++ E2).
    apply H0...
    rewrite_env (X0~bind_sub V ++ (E1 ++ Y ~ bind_typ U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ X ~ bind_typ U ++ E2) in H10.
      apply wf_typ_strengthening in H10.
      apply WF_weakening... }
  - apply typing_tapp with (T11:=T11) (T2:=T2) (T1:=T1)...
    + apply exposure_typ_strengthening in H0.
      apply exposure_weakening_bind2...
    + apply Sub_weakening... apply Sub_typ_strengthening in H1...
  - apply typing_fold with (T:= T) (S:=S)(A:=A)...
    + apply Sub_weakening... apply Sub_typ_strengthening in H0...
    (* + apply Sub_weakening... apply Sub_typ_strengthening in H1... *)
    + apply exposure2_typ_strengthening in H1.
      apply exposure2_weakening_bind2...
    + apply WF_weakening... apply wf_typ_strengthening in H2...
  - apply typing_unfold with (A:= A) (A' := A')...
    + apply Sub_weakening... apply Sub_typ_strengthening in H0...
    + apply exposure_typ_strengthening in H1.
      apply exposure_weakening_bind2...
    (* + apply Sub_weakening... apply Sub_typ_strengthening in H1... *)
  - apply typing_proj with (T:=T)(T':=T')...
    + apply exposure_typ_strengthening in H0.
      apply exposure_weakening_bind2...
  - simpl. apply typing_rcd_nil...
  - simpl. apply typing_rcd_cons...
    + apply IHtyping1...
    + apply IHtyping2...
    + apply subst_tt_rt_expr... apply typing_regular in H0.
      destruct_hypos...
    + rewrite <- label_choose_reserve_e...
      apply typing_regular in H0. destruct_hypos...
Qed.

Lemma uniq_map_app_r:
  forall (A : Type) (E F : list (atom * A)) (f : A -> A),
  uniq (map f F ++ E) -> uniq (F ++ E).
Proof.
  intros.
  apply uniq_app_iff in H. apply uniq_app_iff.
  destruct_hypos. repeat split;auto.
  { apply uniq_map_1 in H. auto. }
  { apply disjoint_map_1 in H1. auto. }
Qed.

Lemma binds_typ_replacing_subst_tb: forall E X Y T x,
  binds x (bind_typ T) E ->
  binds x (bind_typ (subst_tt X Y T)) ((map (subst_tb X Y) E)).
Proof.
  intros. induction E.
  - inv H.
  - destruct H.
    + subst. left. reflexivity.
    + right. apply IHE. auto.
Qed.

Lemma binds_sub_replacing_subst_tb: forall E X Y T x,
  binds x (bind_sub T) E ->
  binds x (bind_sub (subst_tt X Y T)) ((map (subst_tb X Y) E)).
Proof.
  intros. induction E.
  - inv H.
  - destruct H.
    + subst. left. reflexivity.
    + right. apply IHE. auto.
Qed.

Lemma binds_sub_replacing: forall E1 E2 U X Y x T,
    binds  x (bind_sub T) (E1++ X ~ bind_sub U ++E2) ->
    X <> Y -> x <> X ->
    wf_env ( E1 ++ X ~ bind_sub U ++ E2) ->
    binds  x (bind_sub (subst_tt X Y T)) (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2).
Proof with auto.
  intros.
  apply binds_app_iff in H. apply binds_app_iff.
  destruct H.
  - left. apply binds_sub_replacing_subst_tb...
  - right. inv H. { inv H3... exfalso... }
    apply wf_env_cons in H2. inv H2.
    pose proof WF_from_binds_typ _ _ H7 H3.
    apply WF_imply_dom in H4.
    rewrite <- subst_tt_fresh...
Qed.

Lemma exposure_replacing: forall E1 E2 A B U X Y,
    exposure (E1++ X ~ bind_sub U ++E2) A B ->
    wf_env ((E1++ X ~ bind_sub U ++E2) ) ->
    X <> Y ->
    wf_env (map (subst_tb X Y)  E1 ++ Y ~ bind_sub U ++ E2) ->
    exposure (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2);constructor;auto;apply WF_replacing;auto]...
  -
    destruct (X0==X)...
    + subst. assert (binds X (bind_sub U) (E1 ++ X ~ bind_sub U ++ E2) )...
      pose proof binds_uniq _ _ _ H1 H H4. subst.
      apply exposure_trans_tvar with (U:=subst_tt X Y U)...
      * rewrite <- subst_tt_fresh...
        apply wf_env_cons in H1. inv H1.
        apply WF_imply_dom in H9...
      * apply IHexposure...
    + apply exposure_trans_tvar with (U:=subst_tt X Y U0)...
      2:{ apply IHexposure... }
      apply binds_sub_replacing...
  - apply exposure_rcd.
      apply Infrastructure.subst_tt_rt_type...

Qed.

Lemma exposure2_replacing: forall E1 E2 A B U X Y,
    exposure2 (E1++ X ~ bind_sub U ++E2) A B ->
    wf_env ((E1++ X ~ bind_sub U ++E2) ) ->
    X <> Y ->
    wf_env (map (subst_tb X Y)  E1 ++ Y ~ bind_sub U ++ E2) ->
    exposure2 (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2);constructor;auto;apply WF_replacing;auto]...
  - apply exposure2_rcd.
    apply Infrastructure.subst_tt_rt_type...
  (* -
    destruct (X0==X)...
    + subst. assert (binds X (bind_sub U) (E1 ++ X ~ bind_sub U ++ E2) )...
      pose proof binds_uniq _ _ _ H1 H H4. subst.
      apply exposure_trans_tvar with (U:=subst_tt X Y U)...
      * rewrite <- subst_tt_fresh...
        apply wf_env_cons in H1. inv H1.
        apply WF_imply_dom in H9...
      * apply IHexposure...
    + apply exposure_trans_tvar with (U:=subst_tt X Y U0)...
      2:{ apply IHexposure... }
      apply binds_sub_replacing... *)
Qed.

Lemma subst_te_collect: forall i X A e,
    i `notin` collectLabele e ->
    rt_expr e ->
    expr e ->
    i `notin` collectLabele (subst_te X A e).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply notin_union in H.
  destruct H.
  apply notin_union.
  split...
Qed.

Lemma typing_replacing2: forall E1 E2 e T U X Y,
  typing (E1++ X ~ bind_sub U ++E2) e T ->
  X <> Y ->
  wf_env ( map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2) ->
  typing (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_te X Y e) (subst_tt X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros.
  - constructor. auto.
  - destruct (x == X)...
    { subst. apply typing_var...
      assert (binds X (bind_sub U) (E1 ++ X ~ bind_sub U ++ E2))...
      pose proof binds_unique _ _ _ _ _ H0 H3.
      apply uniq_from_wf_env in H.
      specialize (H4 H). inv H4.
    }
    { apply typing_var... apply binds_app_iff in H0. apply binds_app_iff.
      destruct H0.
      - left. apply binds_typ_replacing_subst_tb...
      - right. destruct H0. { inv H0... }
        apply wf_env_cons in H. inv H.
        pose proof wf_typ_from_binds_typ _ _ H6 H0.
        apply WF_imply_dom in H3.
        rewrite <- subst_tt_fresh...
    }
  - simpl. apply typing_abs with (L:=L \u {{ X }} \u
      dom (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)
     )...
    intros.
    specialize_x_and_L x L.
    rewrite subst_te_open_ee_var...
    rewrite_env (map (subst_tb X Y) (x ~ bind_typ V ++ E1) ++ Y ~ bind_sub U ++ E2).
    apply H0...
    rewrite_env (x ~ bind_typ (subst_tt X Y V) ++ (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ (X ~ bind_sub U) ++ E2) in H10.
      apply WF_replacing... }
  - simpl. apply typing_app with (T11:= subst_tt X Y T11) (T2:=subst_tt X Y T2) (T1:=subst_tt X Y T1)...
    + apply IHtyping1...
    +
      eapply exposure_replacing with (Y:=Y) in H0...
      apply typing_regular in H... destruct_hypos...
    + apply IHtyping2...
    + apply sub_replacing...
  - simpl. apply typing_tabs with (L:=L \u {{ X }}
  \u dom (E1 ++ Y ~ bind_typ U ++ E2) ).
    intros.
    specialize_x_and_L X0 L.
    rewrite subst_te_open_te_var...
    rewrite subst_tt_open_tt_var...
    rewrite_env ( map (subst_tb X Y) (X0~bind_sub V ++ E1) ++ Y ~ bind_sub U ++ E2).
    apply H0...
    rewrite_env (X0~bind_sub (subst_tt X Y V) ++ (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env(E1 ++ (X ~ bind_sub U) ++ E2) in H10.
      apply WF_replacing... }
  - simpl. rewrite subst_tt_open_tt...
    apply typing_tapp with (T11:=subst_tt X Y T11) (T2:=subst_tt X Y T2) (T1:=subst_tt X Y  T1)...
    + apply IHtyping...
    + eapply exposure_replacing with (Y:=Y) in H0...
      apply typing_regular in H... destruct_hypos...
    + apply sub_replacing...
  - simpl. apply typing_fold with
      (S:= subst_tt X Y S) (A:=subst_tt X Y  A)
      (T:= subst_tt X Y T)...
    + apply IHtyping...
    + apply sub_replacing with (Y:=Y) in H0...
      rewrite subst_tt_open_tt in H0...
    + apply exposure2_replacing with (Y:=Y) in H1...
      get_well_form...
    (* + apply sub_replacing with (Y:=Y) in H1... *)
    + apply WF_replacing with (Y:=Y) in H2...
  - simpl. rewrite subst_tt_open_tt...
    apply typing_unfold with (A':= subst_tt X Y A') (A:= subst_tt X Y A)...
    + apply IHtyping...
    + apply sub_replacing with (Y:=Y) in H0...
    + apply exposure_replacing with (Y:=Y) in H1...
      get_well_form...
  - simpl. apply typing_proj with (T:=subst_tt X Y T) (T':=subst_tt X Y T')...
    + apply IHtyping...
    + apply exposure_replacing with (Y:=Y) in H0...
      apply typing_regular in H. destruct_hypos...
    + apply lookup_some_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2))...
      { apply typing_regular in H. destruct_hypos...
        apply exposure_sound in H0... get_well_form... }
      { destruct T';inversion H1... }
  - simpl. apply typing_rcd_nil...
  - simpl. apply typing_rcd_cons...
    + apply IHtyping1...
    + apply IHtyping2...
    + apply Infrastructure.subst_tt_rt_type...
    + apply subst_te_rt_expr... apply typing_regular in H0.
      destruct_hypos...
    + apply subst_te_collect...
      apply typing_regular in H0. destruct_hypos...
Qed.

Lemma typing_replacing_var: forall E2 A U X Y T,
    typing (X ~ bind_typ U ++E2) (open_ee A X) T ->
    X \notin fv_ee A \u  {{Y}} ->
    wf_env (Y ~ bind_typ U ++ E2) ->
    typing (Y ~ bind_typ U ++E2) (open_ee A Y) T.
Proof with auto.
  intros.
  rewrite_env (nil ++ Y ~ bind_typ U ++ E2).
  rewrite subst_ee_intro with (x:=X)...
  apply typing_replacing...
Qed.

End Algo.

Hint Constructors Algo.typing.

Lemma sub_inv_arrow: forall E A T1 T2, sub E A (typ_arrow T1 T2) ->
  (exists X:atom, A = X) \/
  (exists S1 S2, A = typ_arrow S1 S2 /\ sub E T1 S1 /\ sub E S2 T2).
Proof.
  intros.
  dependent induction H;inv_rt.
  - left. exists X. auto.
  - right. exists A1, A2. auto.
Qed.

Lemma sub_inv_all: forall E A T1 T2, sub E A (typ_all T1 T2) ->
  (exists X:atom, A = X) \/
  (exists S2 L, equiv E A (typ_all T1 S2) /\
   forall X, X \notin L -> sub (X ~ bind_sub T1 ++ E)
    (open_tt S2 X) (open_tt T2 X)).
Proof with auto.
  intros.
  dependent induction H;inv_rt.
  - left. exists X. auto.
  - right. exists T0, L. split; auto.
    split.
    + apply sa_all with (L:=L)...
      intros. specialize (H1 X H3). get_well_form...
      apply Reflexivity...
    + apply sa_all with (L:=L)...
      intros.
      add_nil. apply sub_narrowing with (Q:=T1)...
      specialize (H1 X H3). get_well_form...
      apply Reflexivity...
Qed.

Lemma open_close_reverse_rec: forall T X X0,
  (* (X \notin fv_tt T \u {{X0}}) ->  *)
  (* (X0 \notin fv_tt T) -> *)
  forall k, WFD T k ->
  subst_tt X X0 T = open_tt_rec k X0 (close_tt_rec k X T).
   (* subst_tt X0 X T = close_tt_rec k X (open_tt_rec k (typ_fvar X0) T). *)
Proof with auto.
intros T.
induction T;intros;simpl in *;try solve [f_equal;auto]...
- inv H. destruct (k == n);try lia...
- destruct (a == X)... simpl. destruct (k == k); try lia...
- inv H. rewrite IHT1 with (k:=k)...
  rewrite IHT2 with (k:=k)...
- inv H. rewrite IHT1 with (k:=k)...
  rewrite IHT2 with (k:=S k)...
- inv H. rewrite IHT with (k:=S k)...
- inv H. rewrite IHT with (k:=k)...
- inv H. rewrite IHT1 with (k:=k)...
rewrite IHT2 with (k:=k)...
Qed.

Lemma open_close_reverse: forall T (X0 X:atom),
  type T ->
  (* (X \notin fv_tt T \u {{ X0 }}) ->  *)
   subst_tt X X0 T = open_tt (close_tt T X) X0.
Proof with auto.
intros. unfold open_tt, close_tt.
rewrite <- open_close_reverse_rec...
apply close_type_wfd...
Qed.

Theorem minimum_typing: forall E e T, typing E e T ->
exists S, Algo.typing E e S /\ sub E S T .
(* /\ expr_label E e (collectLabel T). *)
Proof with auto.
  intros.
  induction H.
  -
    exists typ_nat...
  -
    exists T. split...
    (* 2:{ apply expr_label_var with (T:=T)... } *)
    apply Reflexivity...
    eapply wf_typ_from_binds_typ with (x:=x)...

  -
    pick_fresh X. specialize_x_and_L X L.
    destruct H0 as [T2 [? ?]].
    assert (Hwf: wf_env E).
    { apply typing_regular in H.
      destruct_hypos. inv H... }
    exists (typ_arrow V T2). split...
    { apply Algo.typing_abs with (L:=L \u {{X}} \u dom E).
      intros.
      apply Algo.typing_replacing_var with (X:=X)...
      apply typing_regular in H... destruct_hypos.
      inv H...
    }
    { eapply sa_arrow.
      { apply Reflexivity...
        apply typing_regular in H.
        destruct_hypos. inv H... }
      rewrite_env (nil ++ X ~ bind_typ V ++ E) in H1.
      apply Sub_typ_strengthening in H1... }
  -
    destruct IHtyping1 as [Tarr' [? ?]].
    destruct IHtyping2 as [T2' [? ?]].
    pose proof sub_regular H2. destruct_hypos.
    destruct (Algo.exposure_ex H5 H6) as [N1 [? [? ?]]].
    epose proof Algo.exposure_promote H10 H8 H2 I.
    destruct (sub_inv_arrow H11).
    { destruct H12. subst. inv H9.  }
    destruct H12 as [N11 [N12 ?]]. destruct_hypos.
    exists N12. split...
    eapply Algo.typing_app with (T11:=N11) (T1:=Tarr') (T2:=T2')...
    { subst... }
    { eapply sub_transitivity with (Q:=T1)... }
  -
    pick_fresh X. specialize_x_and_L X L.
    destruct H0 as [S ]. destruct_hypos.
    assert (Hwf: wf_env E).
    { apply typing_regular in H.
      destruct_hypos. inv H... }
    (* assert (exists S', S = open_tt S' X) by admit. *)
    (* destruct H2 as [S'];subst. *)
    exists (typ_all V (close_tt S X)). split...
    { apply Algo.typing_tabs with (L:=L \u {{X}} \u dom E).
      intros.
      rewrite <- open_close_reverse...
      2:{ apply Algo.typing_regular in H0. destruct_hypos...
          apply WF_type in H4... }
      replace (open_te e1 X0) with (subst_te X X0 (open_te e1 X)).
      2:{ rewrite <- subst_te_intro... }
      rewrite_env (map (subst_tb X X0) nil ++ X0 ~ bind_sub V ++ E).
      apply Algo.typing_replacing2...
      { constructor...
        apply sub_regular in H1. destruct_hypos.
        inv H1...
      }
    }
    { eapply sa_all with (L:=L \u {{X}} \u dom E).
      { apply Reflexivity...
        apply typing_regular in H.
        destruct_hypos. inv H... }
      { apply Reflexivity...
        apply typing_regular in H.
        destruct_hypos. inv H... }
      intros.
      rewrite <- open_close_reverse...
      2:{ apply Algo.typing_regular in H0. destruct_hypos...
          apply WF_type in H4... }
      replace (open_tt T1 X0) with (subst_tt X X0 (open_tt T1 X)).
      2:{ rewrite <- subst_tt_intro... }
      rewrite_env (map (subst_tb X X0) nil ++ X0 ~ bind_sub V ++ E).
      apply sub_replacing...
      { constructor...
        apply sub_regular in H1. destruct_hypos.
        inv H1...
      }
    }
  -
    destruct IHtyping as [Tall' ?]. destruct_hypos.
    pose proof sub_regular H2. destruct_hypos.
    destruct (Algo.exposure_ex H3 H4) as [N1 [? [? ?]]].
    epose proof Algo.exposure_promote H8 H6 H2 I. simpl in H9.
    destruct (sub_inv_all H9).
    { destruct H10. subst. inv H7.  }
    destruct H10 as [N11 [L ]]. destruct_hypos.
    destruct H10.
    inversion H10;subst;inv_rt. { inversion H7. }

    exists (open_tt T0 T). split...
    2:{
      pick_fresh X0.
      rewrite_env (map (subst_tb X0 T) nil ++ E).
      replace (open_tt T0 T) with (subst_tt X0 T (open_tt T0 X0)).
      2:{ rewrite <- subst_tt_intro... }
      replace (open_tt T2 T) with (subst_tt X0 T (open_tt T2 X0)).
      2:{ rewrite <- subst_tt_intro... }
      apply sub_through_subst_tt with (Q:=T1)...
      apply sub_transitivity with (Q:= open_tt N11 X0)...
      { apply H19... }
      { apply H11... }
    }
    eapply Algo.typing_tapp with (T11:=S1) (T1:=Tall')...
    { apply sub_transitivity with (Q:=T1)... }
  -
    destruct IHtyping as [S]. destruct_hypos.
    pose proof sub_regular H2. destruct_hypos.
    (* destruct (Algo.exposure_ex H3 H4) as [N ]. destruct_hypos.
    epose proof Algo.exposure_promote H8 H6 H2. *)

    dependent destruction H;inv_rt.
    {
      exists (typ_top). split...
      eapply  Algo.typing_fold with (S:=S) (A:=typ_top)...
    }

    assert (WF E (typ_mu A2)).
    { apply WF_rec with (L:=L)...
      intros. specialize_x_and_L X L. get_well_form... }

    exists (typ_mu A2). split...
    2:{ apply Reflexivity... }
    eapply  Algo.typing_fold with (S:=S) (A:=A2)...
      (* 2:{ constructor... } *)
      eapply sub_transitivity with (Q:=open_tt A (typ_mu A2))...

      { pick_fresh Y.
      specialize_x_and_L Y L.
      apply sub_nominal_inversion in H1...
      rewrite subst_tt_intro with (X:=Y)...
      rewrite subst_tt_intro with (X:=Y) (U:=typ_mu A2)...
      rewrite_env (map (subst_tb Y (typ_mu A2)) nil ++ E).
      apply sub_through_subst_tt with (Q:=typ_top)... }
  -
    destruct IHtyping as [S]. destruct_hypos.
    pose proof sub_regular H0. destruct_hypos.
    pose proof sub_regular H2. destruct_hypos.
    destruct (Algo.exposure_ex H3 H4) as [N ]. destruct_hypos.
    (* pose proof sub_transitivity H2 H0. *)
    epose proof Algo.exposure_promote H11 H9 H0 I.
    dependent destruction H12;inv_rt.
    { inversion H10. }
    exists (open_tt A1 A).
    split...
    {
      eapply Algo.typing_unfold with (A' := S)... }
    { pick_fresh Y.
      specialize_x_and_L Y L.
      apply sub_nominal_inversion in H14...
      rewrite subst_tt_intro with (X:=Y)...
      rewrite subst_tt_intro with (X:=Y) (U:=A)...
      rewrite_env (map (subst_tb Y A) nil ++ E).
      apply sub_through_subst_tt with (Q:=typ_top)... }
  -
    destruct IHtyping as [S']. destruct_hypos.
    exists S'. split...
    apply sub_transitivity with (Q:=S)...
  -
    destruct IHtyping as [S']. destruct_hypos.
    pose proof sub_regular H2. destruct_hypos.
    destruct (Algo.exposure_ex H3 H4) as [N ]. destruct_hypos.
    assert (Algo.not_var_typ T). { destruct T;try inversion H0... simpl... }
    epose proof Algo.exposure_promote H8 H6 H2 H9.
    destruct (rcd_types_match _ H10 H0).
    2:{ destruct H11. subst. inversion H7. }
    destruct H11 as [Ti']. destruct_hypos.
    exists Ti'. split...
    apply Algo.typing_proj with (T:=S') (T':=N)...
  -
    exists typ_rcd_nil. split...
    constructor...
    + reflexivity.
    + intros. inversion H0.
  -
    destruct IHtyping1 as [T1' [? ?]].
    destruct IHtyping2 as [T2' [? ?]].
    assert (rt_type T2').
    { dependent destruction H7;inv_rt...
      { apply Algo.typing_rt_expr_novar in H6... destruct H6. }
    }
    exists (typ_rcd_cons i T1' T2')... split...
    + apply sub_rcd_proper...
      rewrite Algo.typing_collectLabel_inclusion... apply H6.
Qed.

Theorem typing_algo_sound: forall E e T, Algo.typing E e T ->
  typing E e T.
Proof with auto.
  intros.
  induction H...
  - apply typing_abs with (L:=L)...
  - eapply typing_app with (T1:=T11).
    + apply typing_sub with (S:=T1)...
      apply Algo.typing_regular in H. destruct_hypos.
      apply Algo.exposure_sound...
    + apply typing_sub with (S:=T2)...
  - apply typing_tabs with (L:=L)...
  - apply typing_tapp with (T1:=T11)...
    + apply typing_sub with (S:=T1)...
      apply Algo.typing_regular in H. destruct_hypos.
      apply Algo.exposure_sound...
  - apply typing_fold with (A:=A)...
    (* + apply Reflexivity... get_well_form...  *)
    + apply Algo.exposure2_sound... get_well_form...
    + apply typing_sub with (S:=S)...
  - apply typing_unfold...
    + apply typing_sub with (S:=A')...
    + get_well_form. apply Algo.exposure_sound...
  - apply typing_proj with (T:=T')...
    + apply typing_sub with (S:=T)...
      apply Algo.typing_regular in H. destruct_hypos. apply Algo.exposure_sound...
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__8__2.
Require Export lemma__8__7.
Require Export lemma__NCdistinct.
Require Export lemma__collinearorder.
Require Export lemma__collinearright.
Require Export lemma__inequalitysymmetric.
Require Export lemma__rightangleNC.
Require Export logic.
Definition lemma__rectangleparallelogram : forall A B C D, (euclidean__defs.RE A B C D) -> (euclidean__defs.PG A B C D).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) ((euclidean__defs.Per D A B) /\ ((euclidean__defs.Per A B C) /\ ((euclidean__defs.Per B C D) /\ ((euclidean__defs.Per C D A) /\ (euclidean__defs.CR A C B D))))) as H0.
- assert ((euclidean__defs.Per D A B) /\ ((euclidean__defs.Per A B C) /\ ((euclidean__defs.Per B C D) /\ ((euclidean__defs.Per C D A) /\ (euclidean__defs.CR A C B D))))) as H0 by exact H.
assert ((euclidean__defs.Per D A B) /\ ((euclidean__defs.Per A B C) /\ ((euclidean__defs.Per B C D) /\ ((euclidean__defs.Per C D A) /\ (euclidean__defs.CR A C B D))))) as __TmpHyp by exact H0.
destruct __TmpHyp as [H1 H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
split.
-- exact H1.
-- split.
--- exact H3.
--- split.
---- exact H5.
---- split.
----- exact H7.
----- exact H8.
- assert (* Cut *) (euclidean__axioms.nCol D A B) as H1.
-- destruct H0 as [H1 H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
apply (@lemma__rightangleNC.lemma__rightangleNC D A B H1).
-- assert (* Cut *) (euclidean__axioms.nCol A B C) as H2.
--- destruct H0 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
apply (@lemma__rightangleNC.lemma__rightangleNC A B C H4).
--- assert (* Cut *) (euclidean__axioms.nCol C D A) as H3.
---- destruct H0 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
apply (@lemma__rightangleNC.lemma__rightangleNC C D A H9).
---- assert (* Cut *) (exists M, (euclidean__axioms.BetS A M C) /\ (euclidean__axioms.BetS B M D)) as H4.
----- destruct H0 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H11.
----- destruct H4 as [M H5].
destruct H5 as [H6 H7].
destruct H0 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
assert (* Cut *) (~(euclidean__defs.Meet A B C D)) as H16.
------ intro H16.
assert (exists P, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B P) /\ (euclidean__axioms.Col C D P)))) as H17 by exact H16.
destruct H17 as [P H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
assert (* Cut *) (~(A = P)) as H25.
------- intro H25.
assert (* Cut *) (euclidean__axioms.Col C D A) as H26.
-------- apply (@eq__ind__r euclidean__axioms.Point P (fun A0 => (euclidean__defs.RE A0 B C D) -> ((euclidean__defs.Per D A0 B) -> ((euclidean__defs.Per A0 B C) -> ((euclidean__defs.Per C D A0) -> ((euclidean__defs.CR A0 C B D) -> ((euclidean__axioms.nCol D A0 B) -> ((euclidean__axioms.nCol A0 B C) -> ((euclidean__axioms.nCol C D A0) -> ((euclidean__axioms.BetS A0 M C) -> ((euclidean__defs.Meet A0 B C D) -> ((euclidean__axioms.neq A0 B) -> ((euclidean__axioms.Col A0 B P) -> (euclidean__axioms.Col C D A0)))))))))))))) with (x := A).
---------intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
exact H24.

--------- exact H25.
--------- exact H.
--------- exact H8.
--------- exact H10.
--------- exact H14.
--------- exact H15.
--------- exact H1.
--------- exact H2.
--------- exact H3.
--------- exact H6.
--------- exact H16.
--------- exact H19.
--------- exact H23.
-------- apply (@euclidean__tactics.Col__nCol__False C D A H3 H26).
------- assert (* Cut *) (~(D = P)) as H26.
-------- intro H26.
assert (* Cut *) (euclidean__axioms.Col A B D) as H27.
--------- apply (@eq__ind__r euclidean__axioms.Point P (fun D0 => (euclidean__defs.RE A B C D0) -> ((euclidean__defs.Per D0 A B) -> ((euclidean__defs.Per B C D0) -> ((euclidean__defs.Per C D0 A) -> ((euclidean__defs.CR A C B D0) -> ((euclidean__axioms.nCol D0 A B) -> ((euclidean__axioms.nCol C D0 A) -> ((euclidean__axioms.BetS B M D0) -> ((euclidean__defs.Meet A B C D0) -> ((euclidean__axioms.neq C D0) -> ((euclidean__axioms.Col C D0 P) -> (euclidean__axioms.Col A B D0))))))))))))) with (x := D).
----------intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
exact H23.

---------- exact H26.
---------- exact H.
---------- exact H8.
---------- exact H12.
---------- exact H14.
---------- exact H15.
---------- exact H1.
---------- exact H3.
---------- exact H7.
---------- exact H16.
---------- exact H21.
---------- exact H24.
--------- assert (* Cut *) (euclidean__axioms.Col D A B) as H28.
---------- assert (* Cut *) ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col B D A) /\ ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col A D B) /\ (euclidean__axioms.Col D B A))))) as H28.
----------- apply (@lemma__collinearorder.lemma__collinearorder A B D H27).
----------- destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
---------- apply (@euclidean__tactics.Col__nCol__False C D A H3).
-----------apply (@euclidean__tactics.not__nCol__Col C D A).
------------intro H29.
apply (@euclidean__tactics.Col__nCol__False D A B H1 H28).

-------- assert (* Cut *) (euclidean__defs.Per B A D) as H27.
--------- apply (@lemma__8__2.lemma__8__2 D A B H8).
--------- assert (* Cut *) (euclidean__axioms.Col B A P) as H28.
---------- assert (* Cut *) ((euclidean__axioms.Col B A P) /\ ((euclidean__axioms.Col B P A) /\ ((euclidean__axioms.Col P A B) /\ ((euclidean__axioms.Col A P B) /\ (euclidean__axioms.Col P B A))))) as H28.
----------- apply (@lemma__collinearorder.lemma__collinearorder A B P H23).
----------- destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H29.
---------- assert (* Cut *) (euclidean__axioms.neq P A) as H29.
----------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A P H25).
----------- assert (* Cut *) (euclidean__defs.Per P A D) as H30.
------------ apply (@lemma__collinearright.lemma__collinearright B A P D H27 H28 H29).
------------ assert (* Cut *) (euclidean__axioms.neq P D) as H31.
------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric D P H26).
------------- assert (* Cut *) (euclidean__defs.Per P D A) as H32.
-------------- apply (@lemma__collinearright.lemma__collinearright C D P A H14 H24 H31).
-------------- assert (* Cut *) (euclidean__defs.Per A D P) as H33.
--------------- apply (@lemma__8__2.lemma__8__2 P D A H32).
--------------- assert (* Cut *) (~(euclidean__defs.Per P A D)) as H34.
---------------- apply (@lemma__8__7.lemma__8__7 P D A H33).
---------------- apply (@H34 H30).
------ assert (* Cut *) (euclidean__axioms.neq A B) as H17.
------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H17.
-------- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H2).
-------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H18.
------- assert (* Cut *) (euclidean__axioms.neq C D) as H18.
-------- assert (* Cut *) ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D A) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A C)))))) as H18.
--------- apply (@lemma__NCdistinct.lemma__NCdistinct C D A H3).
--------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H19.
-------- assert (* Cut *) (euclidean__axioms.neq D C) as H19.
--------- assert (* Cut *) ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D A) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A C)))))) as H19.
---------- apply (@lemma__NCdistinct.lemma__NCdistinct C D A H3).
---------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H26.
--------- assert (* Cut *) (A = A) as H20.
---------- apply (@logic.eq__refl Point A).
---------- assert (* Cut *) (euclidean__axioms.Col A B A) as H21.
----------- right.
left.
exact H20.
----------- assert (* Cut *) (B = B) as H22.
------------ apply (@logic.eq__refl Point B).
------------ assert (* Cut *) (euclidean__axioms.Col A B B) as H23.
------------- right.
right.
left.
exact H22.
------------- assert (* Cut *) (C = C) as H24.
-------------- apply (@logic.eq__refl Point C).
-------------- assert (* Cut *) (euclidean__axioms.Col C D C) as H25.
--------------- right.
left.
exact H24.
--------------- assert (* Cut *) (D = D) as H26.
---------------- apply (@logic.eq__refl Point D).
---------------- assert (* Cut *) (euclidean__axioms.Col C D D) as H27.
----------------- right.
right.
left.
exact H26.
----------------- assert (* Cut *) (euclidean__axioms.BetS D M B) as H28.
------------------ apply (@euclidean__axioms.axiom__betweennesssymmetry B M D H7).
------------------ assert (* Cut *) (euclidean__defs.Par A B C D) as H29.
------------------- exists A.
exists B.
exists D.
exists C.
exists M.
split.
-------------------- exact H17.
-------------------- split.
--------------------- exact H18.
--------------------- split.
---------------------- exact H21.
---------------------- split.
----------------------- exact H23.
----------------------- split.
------------------------ exact H17.
------------------------ split.
------------------------- exact H27.
------------------------- split.
-------------------------- exact H25.
-------------------------- split.
--------------------------- exact H19.
--------------------------- split.
---------------------------- exact H16.
---------------------------- split.
----------------------------- exact H6.
----------------------------- exact H28.
------------------- assert (* Cut *) (~(euclidean__defs.Meet A D B C)) as H30.
-------------------- intro H30.
assert (exists P, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D P) /\ (euclidean__axioms.Col B C P)))) as H31 by exact H30.
destruct H31 as [P H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
assert (* Cut *) (~(A = P)) as H39.
--------------------- intro H39.
assert (* Cut *) (euclidean__axioms.Col B C A) as H40.
---------------------- apply (@eq__ind__r euclidean__axioms.Point P (fun A0 => (euclidean__defs.RE A0 B C D) -> ((euclidean__defs.Per D A0 B) -> ((euclidean__defs.Per A0 B C) -> ((euclidean__defs.Per C D A0) -> ((euclidean__defs.CR A0 C B D) -> ((euclidean__axioms.nCol D A0 B) -> ((euclidean__axioms.nCol A0 B C) -> ((euclidean__axioms.nCol C D A0) -> ((euclidean__axioms.BetS A0 M C) -> ((~(euclidean__defs.Meet A0 B C D)) -> ((euclidean__axioms.neq A0 B) -> ((A0 = A0) -> ((euclidean__axioms.Col A0 B A0) -> ((euclidean__axioms.Col A0 B B) -> ((euclidean__defs.Par A0 B C D) -> ((euclidean__defs.Meet A0 D B C) -> ((euclidean__axioms.neq A0 D) -> ((euclidean__axioms.Col A0 D P) -> (euclidean__axioms.Col B C A0)))))))))))))))))))) with (x := A).
-----------------------intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
exact H38.

----------------------- exact H39.
----------------------- exact H.
----------------------- exact H8.
----------------------- exact H10.
----------------------- exact H14.
----------------------- exact H15.
----------------------- exact H1.
----------------------- exact H2.
----------------------- exact H3.
----------------------- exact H6.
----------------------- exact H16.
----------------------- exact H17.
----------------------- exact H20.
----------------------- exact H21.
----------------------- exact H23.
----------------------- exact H29.
----------------------- exact H30.
----------------------- exact H33.
----------------------- exact H37.
---------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H41.
----------------------- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H41.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder B C A H40).
------------------------ destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
----------------------- apply (@euclidean__tactics.Col__nCol__False C D A H3).
------------------------apply (@euclidean__tactics.not__nCol__Col C D A).
-------------------------intro H42.
apply (@euclidean__tactics.Col__nCol__False A B C H2 H41).

--------------------- assert (* Cut *) (~(B = P)) as H40.
---------------------- intro H40.
assert (* Cut *) (euclidean__axioms.Col A D B) as H41.
----------------------- apply (@eq__ind__r euclidean__axioms.Point P (fun B0 => (euclidean__defs.RE A B0 C D) -> ((euclidean__defs.Per D A B0) -> ((euclidean__defs.Per A B0 C) -> ((euclidean__defs.Per B0 C D) -> ((euclidean__defs.CR A C B0 D) -> ((euclidean__axioms.nCol D A B0) -> ((euclidean__axioms.nCol A B0 C) -> ((euclidean__axioms.BetS B0 M D) -> ((~(euclidean__defs.Meet A B0 C D)) -> ((euclidean__axioms.neq A B0) -> ((euclidean__axioms.Col A B0 A) -> ((B0 = B0) -> ((euclidean__axioms.Col A B0 B0) -> ((euclidean__axioms.BetS D M B0) -> ((euclidean__defs.Par A B0 C D) -> ((euclidean__defs.Meet A D B0 C) -> ((euclidean__axioms.neq B0 C) -> ((euclidean__axioms.Col B0 C P) -> (euclidean__axioms.Col A D B0)))))))))))))))))))) with (x := B).
------------------------intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
intro H58.
exact H37.

------------------------ exact H40.
------------------------ exact H.
------------------------ exact H8.
------------------------ exact H10.
------------------------ exact H12.
------------------------ exact H15.
------------------------ exact H1.
------------------------ exact H2.
------------------------ exact H7.
------------------------ exact H16.
------------------------ exact H17.
------------------------ exact H21.
------------------------ exact H22.
------------------------ exact H23.
------------------------ exact H28.
------------------------ exact H29.
------------------------ exact H30.
------------------------ exact H35.
------------------------ exact H38.
----------------------- assert (* Cut *) (euclidean__axioms.Col D A B) as H42.
------------------------ assert (* Cut *) ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col D B A) /\ ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col A B D) /\ (euclidean__axioms.Col B D A))))) as H42.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D B H41).
------------------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H43.
------------------------ apply (@euclidean__tactics.Col__nCol__False C D A H3).
-------------------------apply (@euclidean__tactics.not__nCol__Col C D A).
--------------------------intro H43.
apply (@euclidean__tactics.Col__nCol__False D A B H1 H42).

---------------------- assert (* Cut *) (euclidean__axioms.neq P A) as H41.
----------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A P H39).
----------------------- assert (* Cut *) (euclidean__axioms.Col D A P) as H42.
------------------------ assert (* Cut *) ((euclidean__axioms.Col D A P) /\ ((euclidean__axioms.Col D P A) /\ ((euclidean__axioms.Col P A D) /\ ((euclidean__axioms.Col A P D) /\ (euclidean__axioms.Col P D A))))) as H42.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D P H37).
------------------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H43.
------------------------ assert (* Cut *) (euclidean__defs.Per P A B) as H43.
------------------------- apply (@lemma__collinearright.lemma__collinearright D A P B H8 H42 H41).
------------------------- assert (* Cut *) (euclidean__defs.Per C B A) as H44.
-------------------------- apply (@lemma__8__2.lemma__8__2 A B C H10).
-------------------------- assert (* Cut *) (euclidean__axioms.Col C B P) as H45.
--------------------------- assert (* Cut *) ((euclidean__axioms.Col C B P) /\ ((euclidean__axioms.Col C P B) /\ ((euclidean__axioms.Col P B C) /\ ((euclidean__axioms.Col B P C) /\ (euclidean__axioms.Col P C B))))) as H45.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C P H38).
---------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H46.
--------------------------- assert (* Cut *) (euclidean__axioms.neq P B) as H46.
---------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B P H40).
---------------------------- assert (* Cut *) (euclidean__defs.Per P B A) as H47.
----------------------------- apply (@lemma__collinearright.lemma__collinearright C B P A H44 H45 H46).
----------------------------- assert (* Cut *) (euclidean__defs.Per B A P) as H48.
------------------------------ apply (@lemma__8__2.lemma__8__2 P A B H43).
------------------------------ assert (* Cut *) (~(euclidean__defs.Per P B A)) as H49.
------------------------------- apply (@lemma__8__7.lemma__8__7 P A B H48).
------------------------------- apply (@H49 H47).
-------------------- assert (* Cut *) (euclidean__axioms.neq A D) as H31.
--------------------- assert (* Cut *) ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D A) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A C)))))) as H31.
---------------------- apply (@lemma__NCdistinct.lemma__NCdistinct C D A H3).
---------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H40.
--------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H32.
---------------------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H32.
----------------------- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H2).
----------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H35.
---------------------- assert (D = D) as H33 by exact H26.
assert (* Cut *) (euclidean__axioms.Col A D A) as H34.
----------------------- right.
left.
exact H20.
----------------------- assert (* Cut *) (euclidean__axioms.Col A D D) as H35.
------------------------ right.
right.
left.
exact H33.
------------------------ assert (* Cut *) (euclidean__axioms.Col B C B) as H36.
------------------------- right.
left.
exact H22.
------------------------- assert (* Cut *) (euclidean__axioms.Col B C C) as H37.
-------------------------- right.
right.
left.
exact H24.
-------------------------- assert (* Cut *) (euclidean__defs.Par A D B C) as H38.
--------------------------- exists A.
exists D.
exists B.
exists C.
exists M.
split.
---------------------------- exact H31.
---------------------------- split.
----------------------------- exact H32.
----------------------------- split.
------------------------------ exact H34.
------------------------------ split.
------------------------------- exact H35.
------------------------------- split.
-------------------------------- exact H31.
-------------------------------- split.
--------------------------------- exact H36.
--------------------------------- split.
---------------------------------- exact H37.
---------------------------------- split.
----------------------------------- exact H32.
----------------------------------- split.
------------------------------------ exact H30.
------------------------------------ split.
------------------------------------- exact H6.
------------------------------------- exact H7.
--------------------------- assert (* Cut *) (euclidean__defs.PG A B C D) as H39.
---------------------------- split.
----------------------------- exact H29.
----------------------------- exact H38.
---------------------------- exact H39.
Qed.


(**********************************************************************)
(* 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 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                         Wave_Factor.v                              *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega List Max.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.
Require Import IntensionalLib.Wave_as_SF.SF_Eval.
Require Import IntensionalLib.Wave_as_SF.Star.
Require Import IntensionalLib.Wave_as_SF.Wave_Factor.

Lemma factor_fork:
forall p q u t,
sf_red(App (App (App Fop (App (App (Op Node) p) q)) u) t)
    (App (App t (App (Op Node) p)) q).
Proof.
intros; unfold Fop.
eapply transitive_red.
eapply2 star_opt_beta3.
unfold subst, subst_rec; fold subst_rec.
rewrite ! (subst_rec_closed is_leaf).
2: simpl; auto.
insert_Ref_out. simpl.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 fork_test. auto.
eval_tac. eval_tac. eval_tac. eval_tac.
eval_tac. eval_tac. eval_tac. eval_tac.
eapply succ_red. eapply2 f_red.
eval_tac. eval_tac. eval_tac. eval_tac.
eval_tac. eval_tac. eval_tac. eval_tac.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eval_tac. all: auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eval_tac. all: auto.
Qed.


Require Export MMLL.Misc.Hybrid.
Require Export MMLL.OL.CutCoherence.Bipoles.

Set Implicit Arguments.

(** ** Rules of the encoded proof system *)
Section KT4InferenceRules.

Context {SI : Signature}.
Context {SY : OLSyntax}.

  Inductive ContantEnc := TOPZERO | ZEROTOP .

  Definition CteRulesDefs (t:ContantEnc) (s:Side):=
    match t,s with
    | TOPZERO, Left => Top
    | ZEROTOP, Left => Zero
    | TOPZERO, Right => Zero
    | ZEROTOP, Right => Top
    end.

  Inductive RulesEnc := PLUSWITH | WITHPLUS.

  Definition RulesDefs (t:RulesEnc) (s:Side) (A B : uexp)  :=
       match t,s with
      | PLUSWITH, Left => AOr (d|A|) (d|B|)
      | PLUSWITH, Right => AAnd (u|A|) ( u|B|)
      | WITHPLUS, Left => AAnd (d|A|) (d|B|)
      | WITHPLUS, Right => AOr (u|A|) ( u|B|)
      end.

Inductive ModalEnc := QUESTBANG.

  Definition ModalDefs (t:ModalEnc) (i: subexp) (s:Side) (A : uexp)  :=
       match t, s with
      | QUESTBANG, Left => Quest i (d|A|)
      | QUESTBANG, Right => Bang i (u|A|)
     end.

  Class OORules :=
    {
      rulesCte : constants -> ContantEnc ;
      rulesBin : connectives -> RulesEnc;
      rulesUnary : uconnectives -> ModalEnc
    }.

End KT4InferenceRules.

Section CutCohBipoles.
  Context {SI : Signature}.

Inductive Constants := TT | FF.
Inductive Connectives := AND | OR.
Inductive UConnectives := BOX.
Inductive Quantifiers := .

Global Instance SimpleOLSig : OLSyntax:=
  {|
    OLType := nat;
    constants := Constants;
    uconnectives := UConnectives;
    connectives := Connectives ;
    quantifiers := Quantifiers
  |}.

 Instance TT_BODY : CteBody := {
    cte := TT;
    rc_rightBody := CteRulesDefs ZEROTOP Right;
    rc_leftBody := CteRulesDefs ZEROTOP Left
  }.

 Instance FF_BODY : CteBody := {
    cte := FF;
    rc_rightBody := CteRulesDefs TOPZERO Right;
    rc_leftBody := CteRulesDefs TOPZERO Left
  }.

 Instance AND_BODY : BinBody := {
    con := AND;
    rb_rightBody := RulesDefs PLUSWITH Right;
    rb_leftBody := RulesDefs PLUSWITH Left
  }.

 Instance OR_BODY : BinBody := {
    con := OR;
    rb_rightBody := RulesDefs WITHPLUS Right;
    rb_leftBody := RulesDefs WITHPLUS Left
  }.

 Instance BOX_BODY i: UnBody := {
    ucon := BOX;
    ru_rightBody := ModalDefs QUESTBANG i Right ;
    ru_leftBody := ModalDefs QUESTBANG i Left
  }.

  Section CutCoherence.

Instance TT_CUTCOHERENT : CteCutCoherent TT_BODY .
Proof.
   constructor.
   simpl. solveLL.
 Defined.

Instance FF_CUTCOHERENT : CteCutCoherent FF_BODY .
Proof.
   constructor.
   simpl. solveLL.
 Defined.

Instance AND_CUTCOHERENT : BinCutCoherent (RCUT:=CUTLN) AND_BODY .
Proof with sauto.
  constructor.
  intros *. intros lenF lenG isFF isFG.
  simpl.
  LLStore.
  LLWith.
  all: LLStore.
  -  TFocus(CUTL F ).
       eapply ltn with (m:=n)...
       inversion H.
      LLTensor [d^| F |] [AOr (u^| F |) (u^| G |)].
             LLRelease. solveLL.
             LLRelease. solveLL.
             LFocus(AOr (u^| F |) (u^| G |)) [u| F |].
   -  TFocus(CUTL G ).
      apply ltn with (m:=m)...
      inversion H.
      LLTensor [d^| G |] [AOr (u^| F |) (u^| G |)].
             LLRelease. solveLL.
             LLRelease. solveLL.
             LFocus(AOr (u^| F |) (u^| G |)) [u| G |].
 Defined.

Instance OR_CUTCOHERENT : BinCutCoherent (RCUT:=CUTLN) OR_BODY .
Proof with sauto.
  constructor.
  intros *. intros lenF lenG isFF isFG.
  simpl.
  LLWith.
  all: do 2 LLStore.
  -  TFocus(CUTL F ).
       eapply ltn with (m:=n)...
       inversion H.
      LLTensor  [AOr (d^| F |) (d^| G |)] [u^| F |].
             LLRelease. LLStore.
             LFocus(AOr (d^| F |) (d^| G |)) [d| F |].
             LLRelease. solveLL.
   -  TFocus(CUTL G ).
      apply ltn with (m:=m)...
      inversion H.
      LLTensor  [AOr (d^| F |) (d^| G |)] [u^| G |].
             LLRelease. LLStore.
             LFocus(AOr (d^| F |) (d^| G |)) [d| G |].
             LLRelease. solveLL.
    Defined.

Instance BOX_CUTCOHERENT {UNB: UnbSignature} i : m4 i = true -> mt i = true -> UnCutCoherent (RCUT:=CUTLN) (BOX_BODY i).
Proof with sauto.
  constructor.
  intros *. intros lenF isFF.
  simpl.
  LLStoreC.
  LLStore.
  LFocus. createWorld.
  solveSignature1.
  copyK4 i (u^|F |) (@nil TypedFormula).
  reflexivity.
  finishExp.
  rewrite plustpropT...
  LLStore.
  TFocus(CUTL F ).
       eapply ltn with (m:=n)...
       inversion H1.
  LLTensor [d^|F|]  (@nil oo).
  all: LLRelease; LLStore;solveLL.
  UFocus; apply allU.
  Defined.

End CutCoherence.

  Inductive buildTheoryCons : oo ->  Prop :=
  | cteTTR : isOLFormula (t_cons TT_BODY.(cte)) ->
        buildTheoryCons (CteBipole TT_BODY Right)
  | cteTTL : isOLFormula (t_cons TT_BODY.(cte)) ->
        buildTheoryCons (CteBipole TT_BODY Left)
  | cteFFR : isOLFormula (t_cons FF_BODY.(cte)) ->
        buildTheoryCons (CteBipole FF_BODY Right)
  | cteFFL : isOLFormula (t_cons FF_BODY.(cte)) ->
        buildTheoryCons (CteBipole FF_BODY Left).

Inductive buildTheory : oo ->  Prop :=
  | bconANDR : forall F G,
          isOLFormula ( t_bin AND_BODY.(con) F G) ->
          buildTheory  (BinBipole AND_BODY Right F G)
  | bconANDL : forall F G,
          isOLFormula ( t_bin AND_BODY.(con) F G) ->
          buildTheory  (BinBipole AND_BODY Left F G)
  | bconORR : forall F G,
          isOLFormula ( t_bin OR_BODY.(con) F G) ->
          buildTheory  (BinBipole OR_BODY Right F G)
  | bconORL : forall F G,
          isOLFormula ( t_bin OR_BODY.(con) F G) ->
          buildTheory  (BinBipole OR_BODY Left F G).

  Inductive buildTheoryM {a: subexp}: oo ->  Prop :=
  | mdBOXR : forall F,  mt a = true -> m4 a = true ->
    isOLFormula (t_ucon (BOX_BODY a).(ucon) F) ->
              buildTheoryM (UnBipole (BOX_BODY a) Right F)
  | mdBOXL : forall F,  mt a = true -> m4 a = true ->
    isOLFormula (t_ucon (BOX_BODY a).(ucon) F) ->
              buildTheoryM (UnBipole (BOX_BODY a) Left F).

 (** A theory containing only the logical rules and init *)
  Inductive KT4Theory {a:subexp} : oo -> Prop :=
  | ooth_consC : forall OO, buildTheoryCons OO ->  KT4Theory OO
  | ooth_rulesC : forall OO, buildTheory OO ->  KT4Theory OO
  | ooth_initC : forall OO, isOLFormula OO -> KT4Theory (RINIT OO)
  | ooth_boxC : forall OO, buildTheoryM (a:=a) OO -> KT4Theory OO
  | ooth_posC : forall OO,  isOLFormula OO -> KT4Theory (POS OO loc)
  | ooth_negC : forall OO, isOLFormula OO -> KT4Theory (NEG OO loc)
.

 (** A theory containing the logical rules, init and cut *)
  Inductive KT4TheoryCut (n:nat) {a:subexp} : oo -> Prop :=
  | oothc_consC : forall OO, buildTheoryCons OO ->  KT4TheoryCut n OO
  | oothc_rulesC : forall OO, buildTheory OO ->  KT4TheoryCut n OO
  | oothc_initC : forall OO, isOLFormula OO -> KT4TheoryCut n (RINIT OO)
  | oothc_boxC : forall OO, buildTheoryM (a:=a) OO -> KT4TheoryCut n OO
  | oothc_posC : forall OO,  isOLFormula OO -> KT4TheoryCut n (POS OO loc)
  | oothc_negC : forall OO, isOLFormula OO -> KT4TheoryCut n (NEG OO loc)
  | oothc_cutln : forall OO, CUTLN n (CUTL OO) -> KT4TheoryCut n (CUTL OO).

 Lemma CuteRuleNBound {SIU: UnbSignature}: forall h n B L X ,  seqN (CUTLN n) h B L X ->
                                             forall m, n<=m -> seq (CUTLN m) B L X .
  Proof with solveF.
    induction h using strongind ; intros.
    inversion H ...
    init2 i C.
    inversion H0;solveF;
      repeat match goal with
             | [ Hs : seqN (CUTLN n) ?h ?B1 ?N1 ?X1 |- _] =>
               let Hs1 := fresh in
               assert (Hs1 : seq (CUTLN m) B1 N1 X1) by
                   (
                     eapply H  with (m:= h) (n:= n) ;solveF
                   );clear Hs
             end;try solveLL;auto.
    -
    rewrite H3.
    LLTensor M N B0 D.
    -
    LFocus F ;eauto.
    -
    UFocus i F;eauto ...
    -
    BFocus i F;eauto ...
    -
    TFocus F;eauto ...
    inversion H3...
    apply @ltn with (m:= m0)...
    -
    LLExists t.
    -
    apply H4 in properX...
    eapply H  with (m:= h) (n:= n) ;solveF.
    -
   apply InvSubExpPhaseU in H4...
   2:{ apply allU. }
   createWorld.
    eapply @GenK4RelU' with (C4:=x) (CK:=x0) (CN:=x1)...
    eapply H  with (m:= h) (n:= n) ;solveF.
    eapply HeightGeq. exact H14.
    lia.
    -
   apply InvSubExpPhaseU in H3...
   2:{ apply allU. }
   createWorld i.
    eapply @GenK4RelU' with (C4:=x) (CK:=x0) (CN:=x1)...
    solveSignature1.
    eapply H  with (m:= h) (n:= n) ;solveF.
    eapply HeightGeq. exact H14.
    lia. solveSignature1.
  Qed.

  Lemma CuteRuleN : forall n F, CUTLN n F ->
                                             forall m, n<=m -> CUTLN m F.
  Proof with sauto.
    intros.
    inversion H...
    econstructor;eauto.
    (transitivity n);auto.
  Qed.

  Lemma CuteRuleNBound' {USI: UnbSignature}: forall n B L X ,
      seq (CUTLN n)  B L X ->
      forall m, n<=m -> seq (CUTLN m) B L X .
    intros.
    apply seqtoSeqN in H. destruct H.
    eapply CuteRuleNBound;eauto.
  Qed.

 (** There are no (object logic) formulas of size 0 *)
  Lemma CuteRuleN0 : forall F, ~ (CUTLN 0 F).
  Proof with solveF.
    intros F Hn.
    inversion Hn...
    generalize (LengthFormula H H0); intro.
    lia.
  Qed.

 Definition KT4 i := KT4Theory (a:=i).
 Definition KT4C i n := KT4TheoryCut (a:=i) n.

 Local Hint Constructors  KT4TheoryCut KT4Theory  : core.
 Local Hint Unfold RINIT CUTL CUTC  : core.
 Local Hint Unfold KT4 KT4C : core.

Lemma CutRuleNBound {SIU: UnbSignature}: forall h i n B L X ,  seqN (KT4C i n) h B L X ->
                         forall m, n<=m -> seq (KT4C i m) B L X .
  Proof with solveF.
    induction h using strongind ; intros.
    inversion H ...
    init2 i0 C.
    inversion H0;solveF;
      repeat match goal with
             | [ Hs : seqN (KT4C i n) ?h ?B1 ?N1 ?X1 |- _] =>
               let Hs1 := fresh in
               assert (Hs1 : seq (KT4C i m) B1 N1 X1) by
                   (
                     eapply H  with (m:= h) (n:= n)  (B:= B1);solveF
                   );clear Hs
             end;solveLL;auto.
    -
    rewrite H3. LLTensor M N B0 D.
    -
    LFocus F ;eauto.
    -
    UFocus i0 F;eauto ...
    -
    BFocus i0 F;eauto ...
    -
    TFocus F;eauto ...
    unfold KT4C in H3.
    unfold KT4C.
    inversion H3...
    eapply oothc_cutln.
     eapply CuteRuleN;eauto.
    -
    LLExists t.
    -
    apply H4 in properX.
     eapply H  with (m:= h) (n:= n)  ;solveF.
    -
       apply InvSubExpPhaseU in H4...
   2:{ apply allU. }
   createWorld.
    eapply @GenK4RelU' with (C4:=x) (CK:=x0) (CN:=x1)...
    eapply H  with (m:= h) (n:= n) ;solveF.
    eapply HeightGeq. exact H14.
    lia.
    -
   apply InvSubExpPhaseU in H3...
   2:{ apply allU. }
   createWorld i0.
    eapply @GenK4RelU' with (C4:=x) (CK:=x0) (CN:=x1)...
    solveSignature1.
    eapply H  with (m:= h) (n:= n) ;solveF.
    eapply HeightGeq. exact H14.
    lia. solveSignature1.
   Qed.

  Lemma CutRuleNBound' {SIU: UnbSignature}:  forall i n B L X ,
  seq (KT4C i n)  B L X ->
                         forall m, n<=m -> seq (KT4C i m) B L X .
  Proof with solveF.
    intros.
    apply seqtoSeqN in H. destruct H.
    eapply CutRuleNBound;eauto.

  Qed.

  (** Some easy equivalences on the  above theories *)
 Lemma OOTheryCut0 : forall i F,
 KT4 i F <-> (KT4C i 0) F.
 Proof.
    intros.
    autounfold.
    split;intro H ;inversion H;subst;auto.
    *
    inversion H0;subst.
    assert (m =  0%nat) by lia;subst.
    generalize (LengthFormula H3 H4);intro.
    lia.
  Qed.

  Lemma TheoryEmb1 : forall n i F  ,
  KT4 i  F -> (KT4C i n) F.
 Proof.
    intros.
    inversion H;subst; solve[constructor;auto].
  Qed.

  Lemma TheoryEmb2 : forall n i F  , ((CUTLN n) F) -> (KT4C i n) F.
Proof.
    intros.
    inversion H;subst.
    apply oothc_cutln;auto.
  Qed.

 End CutCohBipoles.

Global Hint Constructors  KT4TheoryCut KT4Theory  : core.
Global Hint Unfold RINIT CUTL CUTC  : core.
Global Hint Unfold KT4 KT4C : core.