Require Export pv_in is_pos is_neg occ_in_modal.
Require Import Compare_dec Lia.
Require Import ltac_gen.

(* is_pos lemmas *)

Lemma is_pos_occ : forall (phi : Modal) (i : nat),
  is_pos phi i -> occ_in_modal phi i.
Proof.
  intros phi i Hpos. inversion Hpos. assumption.
Qed.

Lemma is_pos_notin : forall (phi : Modal) (i : nat),
  is_pos phi i  -> le i (length (pv_in phi)).
Proof.
  intros phi i H. inversion H.
  apply occ_in_modal_le. auto.
Qed.

Lemma is_pos_atom : forall (q : propvar) (i : nat),
  is_pos (atom q) i -> i = 1.
Proof.
  intros q i [[H1 H3] H2]. simpl in *.
  firstorder.
Qed.

Lemma is_pos_mneg : forall (psi : Modal) (i : nat),
  is_pos (mneg psi) i -> ~ (is_pos psi i) .
Proof.
  intros psi i [H1 H2] [H3 H4].
  simpl in H2. destruct (is_pos_pre psi i);
  discriminate.
Qed.

Lemma is_pos_mneg2 : forall (psi : Modal) (i : nat),
  ~ is_pos psi i ->
    occ_in_modal psi i ->
      is_pos (mneg psi) i.
Proof.
  intros phi i Hpos Hocc. constructor. apply occ_in_modal_mneg. auto.
  simpl. case_eq (is_pos_pre phi i); intros Hpos2.
  pose proof (occ_pos _ _ Hocc Hpos2). auto.
  reflexivity.
Qed.

Lemma is_pos_mconj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i ->
    ( occ_in_modal phi1 i -> is_pos phi1 i).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. constructor. auto.
  apply occ_in_modal_le in Hocc.
  if_then_else_dest_blind; auto.
Qed.

Lemma is_pos_mconj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i ->
    (le (length (pv_in phi1) + 1) i) ->
      is_pos phi2 (i - (length (pv_in phi1))).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2.
  if_then_else_dest_blind; auto. firstorder.
  constructor; auto.
  inversion H1 as [H3 H4].
  constructor. simpl in *. rewrite app_length in H4.
  intros H. firstorder.
  simpl in H4. rewrite app_length in H4.
  firstorder.
Qed.

Lemma is_pos_mdisj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i ->
  ( occ_in_modal phi1 i ->  (is_pos phi1 i)).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. constructor. auto.
  apply occ_in_modal_le in Hocc.
  if_then_else_dest_blind; auto.
Qed.

Lemma is_pos_mdisj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i ->
    ((length (pv_in phi1) + 1) <= i) ->
      is_pos phi2 (i - (length (pv_in phi1))).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2.
  if_then_else_dest_blind; auto. firstorder.
  constructor; auto.
  inversion H1 as [H3 H4].
  constructor. simpl in *. rewrite app_length in H4.
  intros H. firstorder.
  simpl in H4. rewrite app_length in H4.
  firstorder.
Qed.

Lemma is_pos_mconj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i ->
    ( occ_in_modal phi1 i ->  (is_pos phi1 i)) /\
    ((le (length (pv_in phi1) + 1) i) ->
       is_pos phi2 (i - (length (pv_in phi1)))).
Proof.
  intros phi1 phi2 i Hpos.
  pose proof is_pos_mconj_l.
  pose proof is_pos_mconj_r.
  firstorder.
Qed.

Lemma is_pos_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i ->
    ( occ_in_modal phi1 i ->  (is_pos phi1 i)) /\
    (( (length (pv_in phi1) + 1) <= i) ->
       is_pos phi2 (i - (length (pv_in phi1)))).
Proof.
  intros phi1 phi2 i Hpos.
  pose proof is_pos_mconj_l.
  pose proof is_pos_mconj_r.
  firstorder.
Qed.

Lemma is_pos_box : forall (phi : Modal) (i : nat),
  is_pos (box phi) i <-> is_pos phi i.
Proof.
  split; intros [H1 H2];
    (constructor; [apply occ_in_modal_box|]; auto).
Qed.

Lemma is_pos_dia : forall (phi : Modal) (i : nat),
  is_pos (dia phi) i <-> is_pos phi i.
Proof.
  split; intros [H1 H2];
    (constructor; [apply occ_in_modal_dia|]; auto).
Qed.

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

(* is_neg lemmas *)

Lemma is_neg_occ : forall (phi : Modal) (i : nat),
    is_neg phi i -> occ_in_modal phi i.
Proof.
  intros phi i Hpos. inversion Hpos. assumption.
Qed.

Lemma is_neg_mneg : forall (psi : Modal) (i : nat),
  is_neg (mneg psi) i -> ~(is_neg psi i).
Proof.
  intros psi i [H1 H2] [H3 H4].
  simpl in H2. destruct (is_neg_pre psi i);
  discriminate.
Qed.

Lemma is_neg_mneg2 : forall (psi : Modal) (i : nat),
  ~ is_neg psi i ->
    occ_in_modal psi i ->
      is_neg (mneg psi) i.
Proof.
  intros phi i Hpos Hocc. constructor. apply occ_in_modal_mneg. auto.
  simpl. case_eq (is_neg_pre phi i); intros Hpos2.
  pose proof (occ_neg _ _ Hocc Hpos2). auto.
  reflexivity.
Qed.

Lemma is_neg_box : forall (phi : Modal) (i : nat),
    is_neg (box phi) i <-> is_neg phi i.
Proof.
  split; intros [H1 H2];
    (constructor; [apply occ_in_modal_box|]; auto).
Qed.

Lemma is_neg_dia: forall (phi : Modal) (i : nat),
    is_neg (dia phi) i <-> is_neg phi i.
Proof.
  split; intros [H1 H2];
    (constructor; [apply occ_in_modal_dia|]; auto).
Qed.

Lemma is_neg_0 : forall (phi : Modal),
  ~ is_neg phi 0.
Proof. intros phi [H1 H2]. firstorder. Qed.

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

Lemma is_pos_atom2 : forall p,
    is_pos #p 1.
Proof.
  intros p. constructor. apply occ_in_modal_atom2.
  auto.
Qed.

Lemma is_pos_neg_pre_not_tf: forall phi i,
    occ_in_modal phi i ->
    ~ (is_pos_pre phi i = true /\ is_neg_pre phi i = true) /\
    ~ (is_pos_pre phi i = false /\ is_neg_pre phi i = false).
Proof.
  induction phi; intros i Hocc.
  - apply occ_in_modal_atom in Hocc. subst. simpl.
    apply conj; intros [H1 H2]; discriminate.
  - apply (occ_in_modal_mneg phi) in Hocc. simpl.
    destruct (IHphi i Hocc) as [H1 H2].
    destruct (is_pos_pre phi i); destruct (is_neg_pre phi i);
      firstorder.
  - destruct (occ_in_modal_dec phi1 i) as [Hocc1 | Hocc1].
    pose proof (IHphi1 _ Hocc1) as Hocc2. destruct Hocc2 as [H1 H2].
    inversion Hocc1 as [H3 H4].
    simpl. if_then_else_dest_blind; auto.
    apply occ_in_modal_mconj in Hocc. simpl.
    apply occ_in_modal_f in Hocc1. destruct Hocc1 as [H1 | H1].
    subst. inversion Hocc. contradiction.
    if_then_else_dest_blind; auto; firstorder. auto.
  - destruct (occ_in_modal_dec phi1 i) as [Hocc1 | Hocc1].
    pose proof (IHphi1 _ Hocc1) as Hocc2. destruct Hocc2 as [H1 H2].
    inversion Hocc1 as [H3 H4].
    simpl. if_then_else_dest_blind; auto.
    apply occ_in_modal_mdisj in Hocc. simpl.
    apply occ_in_modal_f in Hocc1. destruct Hocc1 as [H1 | H1].
    subst. inversion Hocc. contradiction.
    if_then_else_dest_blind; auto; firstorder. auto.
  - destruct (occ_in_modal_dec phi1 i) as [Hocc1 | Hocc1].
    pose proof (IHphi1 _ Hocc1) as Hocc2. destruct Hocc2 as [H1 H2].
    inversion Hocc1 as [H3 H4].
    simpl. unfold negb.
    if_then_else_dest_blind; auto; firstorder.
    apply occ_in_modal_f in Hocc1. destruct Hocc1 as [H1 | H1].
    subst. inversion Hocc. contradiction.
    apply Gt.gt_not_le in H1. simpl.
    if_then_else_dest_blind; auto.
    assert (occ_in_modal phi2 (i - length (pv_in phi1))).
      inversion Hocc. simpl in *. rewrite app_length in *.
      constructor; firstorder.
    apply conj; apply IHphi2; auto.
  - simpl. apply IHphi. apply occ_in_modal_box. auto.
  - simpl. apply IHphi. apply occ_in_modal_dia. auto.
Qed.

Lemma is_pos_neg_pre_not_t: forall phi i,
    occ_in_modal phi i ->
    ~ (is_pos_pre phi i = true /\ is_neg_pre phi i = true).
Proof.
  intros phi i Hocc. apply is_pos_neg_pre_not_tf. auto.
Qed.

Lemma is_pos_neg_pre_not_f: forall phi i,
    occ_in_modal phi i ->
    ~ (is_pos_pre phi i = false /\ is_neg_pre phi i = false).
Proof.
  intros phi i Hocc. apply is_pos_neg_pre_not_tf. auto.
Qed.

Lemma is_pos_neg_not: forall phi i,
    ~ (is_pos phi i /\ is_neg phi i).
Proof.
  intros phi i [[H1 H2] [H4 H3]].
  apply (is_pos_neg_pre_not_t phi i); auto.
Qed.

Lemma is_pos_mconj_l2 : forall phi1 phi2 i,
    is_pos phi1 i ->
    is_pos (phi1 m∧ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mconj_l. auto.
  simpl. rewrite H2. inversion H1 as [H3 H4].
  if_then_else_dest_blind; auto.
Qed.

Lemma is_pos_mdisj_l2 : forall phi1 phi2 i,
    is_pos phi1 i ->
    is_pos (phi1 m∨ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mdisj_l. auto.
  simpl. rewrite H2. inversion H1 as [H3 H4].
  if_then_else_dest_blind; auto.
Qed.

Lemma is_pos_mimpl_l2 : forall phi1 phi2 i,
    is_pos phi1 i ->
    ~ is_pos (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2] [H5 H6].
  simpl in H6. rewrite H2 in H6. inversion H1  as [H7 H8].
  if_then_else_dest_blind; auto. unfold negb in *.
  discriminate.
Qed.

Lemma is_pos_mconj_r2 : forall phi1 phi2 i,
    is_pos phi2 (i - length (pv_in phi1)) ->
    is_pos (phi1 m∧ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. pose proof H1 as H1'.
  apply occ_in_modal_mconj_r2 in H1.
  constructor. auto.
  simpl.  rewrite H2. if_then_else_dest_blind; auto.
  inversion H1'. firstorder.
Qed.

Lemma is_pos_mdisj_r2 : forall phi1 phi2 i,
    is_pos phi2 (i - length (pv_in phi1)) ->
    is_pos (phi1 m∨ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. pose proof H1 as H1'.
  apply occ_in_modal_mdisj_r2 in H1.
  constructor. auto.
  simpl.  rewrite H2. if_then_else_dest_blind; auto.
  inversion H1'. firstorder.
Qed.

Lemma is_pos_mimpl_l : forall phi1 phi2 i,
    occ_in_modal phi1 i ->
    ~ is_pos phi1 i ->
    is_pos (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i H1 H3.
  constructor. apply occ_in_modal_mimpl_l. auto.
  simpl. inversion H1 as [H2 H4].
  if_then_else_dest_blind; auto; firstorder.
Qed.

Lemma is_pos_mimpl_r : forall phi1 phi2 i,
    is_pos phi2 (i - length (pv_in phi1)) ->
    is_pos (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mimpl_r2. auto.
  simpl. unfold negb. if_then_else_dest_blind; auto.
  firstorder.
Qed.

Lemma is_pos_mimpl_r2 : forall phi1 phi2 i,
    is_pos (phi1 m→ phi2) i ->
    occ_in_modal phi2 (i - length (pv_in phi1)) ->
    is_pos phi2  (i - length (pv_in phi1)).
Proof.
  intros phi1 phi2 i [H1 H2] H3.
  constructor. auto.
  simpl in H2. if_then_else_dest_blind; auto.
  firstorder.
Qed.

Lemma is_pos_dec_occ : forall phi i,
    occ_in_modal phi i -> {is_pos phi i} + {~ is_pos phi i}.
Proof.
  induction phi; intros i Hocc.
  - apply occ_in_modal_atom in Hocc. subst.
    left. apply is_pos_atom2.
  - apply  (occ_in_modal_mneg phi) in Hocc.
    destruct (IHphi _ Hocc) as [H | H].
    right. intros H2. apply is_pos_mneg in H2.
    contradiction.
    left. apply is_pos_mneg2; auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    left. apply is_pos_mconj_l2. auto.
    right. intros H3. apply is_pos_mconj_l in H3.
    contradiction.  auto.
    apply occ_in_modal_mconj in Hocc.
    destruct (IHphi2 _ Hocc) as [H2 | H2]. left.
    apply is_pos_mconj_r2. auto.
    right. intros H3. apply is_pos_mconj_r in H3. auto.
    apply occ_in_modal_f in H1. destruct H1 as [H4| H4].
    subst. firstorder. apply Gt.gt_le_S in H4. firstorder.
    auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    left. apply is_pos_mdisj_l2. auto.
    right. intros H3. apply is_pos_mdisj_l in H3.
    contradiction.  auto.
    apply occ_in_modal_mdisj in Hocc.
    destruct (IHphi2 _ Hocc) as [H2 | H2]. left.
    apply is_pos_mdisj_r2. auto.
    right. intros H3. apply is_pos_mdisj_r in H3. auto.
    apply occ_in_modal_f in H1. destruct H1 as [H4| H4].
    subst. firstorder. apply Gt.gt_le_S in H4. firstorder.
    auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    right. apply is_pos_mimpl_l2. auto.
    left. apply is_pos_mimpl_l; auto.
    apply occ_in_modal_mimpl in Hocc.
    apply IHphi2 in Hocc. destruct Hocc as [H3 | H3].
    left. apply is_pos_mimpl_r. auto.
    right. intros H4. pose proof (is_pos_occ _ _ H4) as H5.
    apply occ_in_modal_mimpl in H5.
    apply is_pos_mimpl_r2 in H4. all : auto.
  - apply (occ_in_modal_box phi) in Hocc.
    apply IHphi in Hocc. destruct Hocc as [H1 | H1].
    left. apply is_pos_box. auto.
    right. intros H2. apply (is_pos_box phi) in H2.
    auto.
  - apply (occ_in_modal_dia phi) in Hocc.
    apply IHphi in Hocc. destruct Hocc as [H1 | H1].
    left. apply is_pos_dia. auto.
    right. intros H2. apply (is_pos_dia phi) in H2.
    auto.
Qed.

Lemma is_pos_dec : forall phi i, {is_pos phi i} + {~ is_pos phi i}.
Proof.
  intros phi i. destruct (occ_in_modal_dec phi i) as [H|H].
  2 : (right; intros H2; apply is_pos_occ in H2; contradiction).
  apply is_pos_dec_occ. auto.
Qed.

Lemma is_pos_neg_pre_f_t : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (is_pos_pre phi i = false  -> is_neg_pre phi i = true) /\
  (is_pos_pre phi i = true -> is_neg_pre phi i = false).
Proof.
  induction phi; intros i Hocc.
  - apply occ_in_modal_atom in Hocc. subst. simpl. auto.
  - apply (occ_in_modal_mneg phi) in Hocc. simpl.
    apply IHphi in Hocc. destruct Hocc as [H1 H2].
    destruct (is_pos_pre phi i); destruct (is_neg_pre phi  i);
      firstorder.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    pose proof (IHphi1 _ H1) as H2. simpl.
    inversion H1 as [H3 H4]. if_then_else_dest_blind; auto.
    contradiction.

    apply occ_in_modal_mconj in Hocc. pose proof (IHphi2 _ Hocc) as H2.
    inversion Hocc as [H3 H4]. simpl. apply occ_in_modal_f in H1.
    destruct H1. subst. contradiction. apply Gt.gt_not_le in H.
    if_then_else_dest_blind; auto. firstorder. auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    pose proof (IHphi1 _ H1) as H2. simpl.
    inversion H1 as [H3 H4]. if_then_else_dest_blind; auto.
    contradiction.

    apply occ_in_modal_mdisj in Hocc. pose proof (IHphi2 _ Hocc) as H2.
    inversion Hocc as [H3 H4]. simpl. apply occ_in_modal_f in H1.
    destruct H1. subst. contradiction. apply Gt.gt_not_le in H.
    if_then_else_dest_blind; auto. firstorder. auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    pose proof (IHphi1 _ H1) as H2. simpl.
    inversion H1 as [H3 H4]. unfold negb.
    if_then_else_dest_blind; auto; firstorder.

    apply occ_in_modal_mimpl in Hocc. pose proof (IHphi2 _ Hocc) as H2.
    inversion Hocc as [H3 H4]. simpl. apply occ_in_modal_f in H1.
    destruct H1. subst. contradiction. apply Gt.gt_not_le in H.
    unfold negb. if_then_else_dest_blind; auto; firstorder. auto.
  - simpl. apply IHphi. apply occ_in_modal_box. auto.
  - simpl. apply IHphi. apply occ_in_modal_dia. auto.
Qed.

Lemma is_pos_neg_f_t : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (~ is_pos phi i  -> is_neg phi i) /\
  (is_pos phi i -> ~ is_neg phi i).
Proof.
  intros phi i Hocc. destruct (is_pos_neg_pre_f_t phi i Hocc) as [H1 H2].
  split; intros H.
  constructor. auto.
  apply H1. case_eq (is_pos_pre phi i); intros H3.
  contradiction (H (occ_pos _ _ Hocc H3)).
  reflexivity.

  intros H3. apply (is_pos_neg_not phi i). auto.
Qed.

Lemma is_pos_neg_iff : forall phi i,
    occ_in_modal phi i ->
    is_pos phi i <-> ~ is_neg phi i.
Proof.
  intros phi i  H. split; intros H2.
  intros H3. apply (is_pos_neg_not phi i).
  auto.
  destruct (is_pos_dec phi i) as [H3 | H3]. auto.
  apply is_pos_neg_f_t in H3. firstorder.
  auto.
Qed.

Lemma is_pos_neg_f : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (~ is_pos phi i -> is_neg phi i).
Proof.
  intros phi i Hocc Hpos.
  apply is_pos_neg_f_t; assumption.
Qed.

Lemma is_pos_neg_t : forall (phi : Modal) (i : nat),
  (is_pos phi i -> ~is_neg phi i).
Proof.
  intros phi i Hpos.
  pose proof (is_pos_occ _ _ Hpos) as Hocc.
  apply is_pos_neg_f_t; assumption.
Qed.

Lemma is_neg_pos_f : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (~ is_neg phi i -> is_pos phi i).
Proof.
  intros phi i Hocc Hpos.
  destruct (is_pos_dec phi i) as [H1 | H1]. auto.
  apply is_pos_neg_f in H1; firstorder.
Qed.

Lemma is_neg_pos_t : forall (phi : Modal) (i : nat),
  (is_neg phi i -> ~ is_pos phi i).
Proof.
  intros phi i H1 H2. apply (is_pos_neg_not phi i).
  auto.
Qed.

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

Lemma is_pos_neg_or : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  is_pos phi i  \/ is_neg phi i.
Proof.
  intros phi i H.
  destruct (is_pos_dec phi i). auto.
  right. apply is_pos_neg_f; auto.
Qed.

Lemma is_pos_neg_mimpl_l : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mimpl phi1 phi2) i ->
  occ_in_modal phi1 i -> is_neg phi1 i.
Proof.
  intros phi1 phi2 i Hpos Hocc.
  destruct (is_pos_neg_or phi1 i Hocc) as [H1|H1].
  apply is_pos_mimpl_l2 with (phi2 := phi2)  in H1.
  contradiction (H1 Hpos). auto.
Qed.

(* ---------------------------------------------------------------------------- *)
(* is_neg lemmas *)

Lemma is_neg_notin : forall (phi : Modal) (i : nat),
  is_neg phi i  -> le i (length (pv_in phi)).
Proof.
  intros phi i H. inversion H.
  apply occ_in_modal_le. auto.
Qed.

Lemma is_neg_atom : forall (q : propvar) (i : nat),
  is_neg (atom q) i -> i = 1.
Proof.
  intros q i [[H1 H3] H2]. simpl in *.
  firstorder.
Qed.

Lemma is_neg_mconj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i ->
    ( occ_in_modal phi1 i -> is_neg phi1 i).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. constructor. auto.
  apply occ_in_modal_le in Hocc.
  if_then_else_dest_blind; auto.
Qed.

Lemma is_neg_mconj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i ->
    (le (length (pv_in phi1) + 1) i) ->
      is_neg phi2 (i - (length (pv_in phi1))).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. if_then_else_dest_blind; simpl in *;
                 auto; firstorder.
  simpl in *. rewrite app_length in *. firstorder.
Qed.

Lemma is_neg_mdisj_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i ->
  ( occ_in_modal phi1 i ->  (is_neg phi1 i)).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. constructor. auto.
  apply occ_in_modal_le in Hocc.
  if_then_else_dest_blind; auto.
Qed.

Lemma is_neg_mdisj_r : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i ->
    ((length (pv_in phi1) + 1) <= i) ->
      is_neg phi2 (i - (length (pv_in phi1))).
Proof.
  intros phi1 phi2 i [H1 H2] Hocc.
  simpl in H2. if_then_else_dest_blind; simpl in *;
                 auto; firstorder.
  simpl in *. rewrite app_length in *. firstorder.
Qed.

Lemma is_neg_mconj : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mconj phi1 phi2) i ->
    ( occ_in_modal phi1 i ->  (is_neg phi1 i)) /\
    ((le (length (pv_in phi1) + 1) i) ->
       is_neg phi2 (i - (length (pv_in phi1)))).
Proof.
  intros phi1 phi2 i Hpos.
  apply conj.
    apply is_neg_mconj_l with (phi2 := phi2); exact Hpos.

    apply is_neg_mconj_r with (phi1 := phi1); exact Hpos.
Qed.

Lemma is_neg_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mdisj phi1 phi2) i ->
    ( occ_in_modal phi1 i ->  (is_neg phi1 i)) /\
    (( (length (pv_in phi1) + 1) <= i) ->
       is_neg phi2 (i - (length (pv_in phi1)))).
Proof.
  intros phi1 phi2 i Hpos.
  apply conj.
    apply is_neg_mdisj_l with (phi2 := phi2); exact Hpos.

    apply is_neg_mdisj_r with (phi1 := phi1); exact Hpos.
Qed.

(* --------------------------------------------------------------- *)
Lemma is_neg_atom2 : forall p,
    ~ is_neg #p 1.
Proof. intros p H. inversion H. firstorder. Qed.

Lemma is_neg_mconj_l2 : forall phi1 phi2 i,
    is_neg phi1 i ->
    is_neg (phi1 m∧ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mconj_l. auto.
  simpl. rewrite H2. inversion H1 as [H3 H4].
  if_then_else_dest_blind; auto.
Qed.

Lemma is_neg_mdisj_l2 : forall phi1 phi2 i,
    is_neg phi1 i ->
    is_neg (phi1 m∨ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mdisj_l. auto.
  simpl. rewrite H2. inversion H1 as [H3 H4].
  if_then_else_dest_blind; auto.
Qed.

Lemma is_neg_mimpl_l2 : forall phi1 phi2 i,
    is_neg phi1 i ->
    ~ is_neg (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2] [H5 H6].
  simpl in H6. rewrite H2 in H6. inversion H1  as [H7 H8].
  if_then_else_dest_blind; auto. unfold negb in *.
  firstorder.
Qed.

Lemma is_neg_mconj_r2 : forall phi1 phi2 i,
    is_neg phi2 (i - length (pv_in phi1)) ->
    is_neg (phi1 m∧ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. pose proof H1 as H1'.
  apply occ_in_modal_mconj_r2 in H1.
  constructor. auto.
  simpl.  rewrite H2. if_then_else_dest_blind; auto.
  firstorder.
Qed.

Lemma is_neg_mdisj_r2 : forall phi1 phi2 i,
    is_neg phi2 (i - length (pv_in phi1)) ->
    is_neg (phi1 m∨ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2]. pose proof H1 as H1'.
  apply occ_in_modal_mdisj_r2 in H1.
  constructor. auto.
  simpl.  rewrite H2. if_then_else_dest_blind; firstorder.
Qed.

Lemma is_neg_mimpl_l : forall phi1 phi2 i,
    occ_in_modal phi1 i ->
    ~ is_neg phi1 i ->
    is_neg (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i H1 H3.
  constructor. apply occ_in_modal_mimpl_l. auto.
  simpl. inversion H1 as [H2 H4].
  if_then_else_dest_blind; firstorder.
Qed.

Lemma is_neg_mimpl_r : forall phi1 phi2 i,
    is_neg phi2 (i - length (pv_in phi1)) ->
    is_neg (phi1 m→ phi2) i.
Proof.
  intros phi1 phi2 i [H1 H2].
  constructor. apply occ_in_modal_mimpl_r2. auto.
  simpl. if_then_else_dest_blind; firstorder.
Qed.

Lemma is_neg_mimpl_r2 : forall phi1 phi2 i,
    is_neg (phi1 m→ phi2) i ->
    occ_in_modal phi2 (i - length (pv_in phi1)) ->
    is_neg phi2  (i - length (pv_in phi1)).
Proof.
  intros phi1 phi2 i [H1 H2] H3.
  constructor. auto. simpl in *.
  if_then_else_dest_blind; firstorder.
Qed.

Lemma is_neg_dec_occ : forall phi i,
    occ_in_modal phi i -> {is_neg phi i} + {~ is_neg phi i}.
Proof.
  induction phi; intros i Hocc.
  - apply occ_in_modal_atom in Hocc. subst.
    right. apply is_neg_atom2.
  - apply  (occ_in_modal_mneg phi) in Hocc.
    destruct (IHphi _ Hocc) as [H | H].
    right. intros H2. apply is_neg_mneg in H2.
    contradiction.
    left. apply is_neg_mneg2; auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    left. apply is_neg_mconj_l2. auto.
    right. intros H3. apply is_neg_mconj_l in H3.
    contradiction.  auto.
    apply occ_in_modal_mconj in Hocc.
    destruct (IHphi2 _ Hocc) as [H2 | H2]. left.
    apply is_neg_mconj_r2. auto.
    right. intros H3. apply is_neg_mconj_r in H3. auto.
    apply occ_in_modal_f in H1. destruct H1 as [H4| H4].
    subst. firstorder. apply Gt.gt_le_S in H4. firstorder.
    auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    left. apply is_neg_mdisj_l2. auto.
    right. intros H3. apply is_neg_mdisj_l in H3.
    contradiction.  auto.
    apply occ_in_modal_mdisj in Hocc.
    destruct (IHphi2 _ Hocc) as [H2 | H2]. left.
    apply is_neg_mdisj_r2. auto.
    right. intros H3. apply is_neg_mdisj_r in H3. auto.
    apply occ_in_modal_f in H1. destruct H1 as [H4| H4].
    subst. firstorder. apply Gt.gt_le_S in H4. firstorder.
    auto.
  - destruct (occ_in_modal_dec phi1 i) as [H1 | H1].
    destruct (IHphi1 _ H1) as [H2 | H2].
    right. apply is_neg_mimpl_l2. auto.
    left. apply is_neg_mimpl_l; auto.
    apply occ_in_modal_mimpl in Hocc.
    apply IHphi2 in Hocc. destruct Hocc as [H3 | H3].
    left. apply is_neg_mimpl_r. auto.
    right. intros H4. pose proof (is_neg_occ _ _ H4) as H5.
    apply occ_in_modal_mimpl in H5.
    apply is_neg_mimpl_r2 in H4. all : auto.
  - apply (occ_in_modal_box phi) in Hocc.
    apply IHphi in Hocc. destruct Hocc as [H1 | H1].
    left. apply is_neg_box. auto.
    right. intros H2. apply (is_neg_box phi) in H2.
    auto.
  - apply (occ_in_modal_dia phi) in Hocc.
    apply IHphi in Hocc. destruct Hocc as [H1 | H1].
    left. apply is_neg_dia. auto.
    right. intros H2. apply (is_neg_dia phi) in H2.
    auto.
Qed.

Lemma is_neg_dec : forall phi i, {is_neg phi i} + {~ is_neg phi i}.
Proof.
  intros phi i. destruct (occ_in_modal_dec phi i) as [H|H].
  2 : (right; intros H2; apply is_neg_occ in H2; contradiction).
  apply is_neg_dec_occ. auto.
Qed.

Lemma is_neg_pos_pre_f_t : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (is_neg_pre phi i = false  -> is_pos_pre phi i = true) /\
  (is_neg_pre phi i = true -> is_pos_pre phi i = false).
Proof.
  intros phi i Hocc.
  case_eq (is_pos_pre phi i); intros H2; split; try auto;
    intros H3; apply is_pos_neg_pre_f_t in H2; try rewrite H2 in *; auto.
Qed.

Lemma is_neg_pos_f_t : forall (phi : Modal) (i : nat),
  occ_in_modal phi i ->
  (~ is_neg phi i  -> is_pos phi i) /\
  (is_neg phi i -> ~ is_pos phi i).
Proof.
  intros phi i Hocc.
  destruct (is_pos_neg_f_t phi i Hocc) as [H1 H2].
  destruct (is_pos_dec phi i) as [H3 | H3];
    split; intros H4; try auto.
  contradiction (is_pos_neg_not phi i). auto.
  apply H1 in H3. contradiction.
Qed.

Lemma is_neg_pos_iff : forall phi i,
    occ_in_modal phi i ->
    is_neg phi i <-> ~ is_pos phi i.
Proof.
  intros phi i  H. split; intros H2.
  intros H3. apply (is_pos_neg_not phi i).
  auto.
  destruct (is_neg_dec phi i) as [H3 | H3]. auto.
  apply is_neg_pos_f_t in H3. firstorder.
  auto.
Qed.

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

Lemma is_neg_pos_mimpl_l : forall (phi1 phi2 : Modal) (i : nat),
  is_neg (mimpl phi1 phi2) i ->
  occ_in_modal phi1 i -> is_pos phi1 i.
Proof.
  intros phi1 phi2 i Hpos Hocc.
  destruct (is_pos_neg_or phi1 i Hocc) as [H1|H1]. auto.
  apply is_neg_mimpl_l2 with (phi2 := phi2)  in H1.
  firstorder.
Qed.


Require Import
  Coq.Unicode.Utf8
  HoTT.Basics.Overture
  HoTT.Classes.implementations.list.

(** The following section implements a datatype [FamilyProd] which
    is a kind of product/tuple. *)

Section family_prod.
  Context {I : Type}.

  (** [FamilyProd F ℓ] is a product type defined by

      <<
        FamilyProd F [i1;i2;...;in] = F i1 * F i2 * ... * F in * Unit
      >>

      It is convenient to have the [Unit] in the end.
  *)

  Definition FamilyProd (F : I → Type) : list I → Type
    := fold_right (λ (i:I) (A:Type), F i * A) Unit.

  (** Map function for [FamilyProd F ℓ],

      <<
        map_family_prod f (x1, x2, ..., xn, tt)
        = (f x1, f x2, ..., f xn, tt)
      >> *)

  Fixpoint map_family_prod {F G : I → Type} {ℓ : list I}
      (f : ∀ i, F i → G i)
      : FamilyProd F ℓ → FamilyProd G ℓ :=
    match ℓ with
    | nil => const tt
    | i :: ℓ' => λ '(x,s), (f i x, map_family_prod f s)
    end.

  (** [for_all_family_prod F P (x1, ..., xn, tt) = True] if
      [P i1 x1 ∧ P i2 x2 ∧ ... ∧ P in xn] holds. *)

  Fixpoint for_all_family_prod (F : I → Type) {ℓ : list I}
      (P : ∀ i, F i -> Type) : FamilyProd F ℓ → Type :=
    match ℓ with
    | nil => λ _, True
    | i :: ℓ' => λ '(x,s), P i x ∧ for_all_family_prod F P s
    end.

  (** [for_all_2_family_prod F G R (x1,...,xn,tt) (y1,...,yn,tt) = True]
      if [R i1 x1 y1 ∧ R i2 x2 y2 ∧ ... ∧ P in xn yn] holds. *)

  Fixpoint for_all_2_family_prod (F G : I → Type) {ℓ : list I}
      (R : ∀ i, F i -> G i -> Type)
      : FamilyProd F ℓ → FamilyProd G ℓ → Type :=
    match ℓ with
    | nil => λ _ _, True
    | i :: ℓ' => λ '(x,s) '(y,t), R i x y ∧ for_all_2_family_prod F G R s t
    end.

  (** If [R : ∀ i, relation (F i)] is a family of relations indexed by
      [i:I] and [R i] is reflexive for all [i], then

      <<
        for_all_2_family_prod F F R s s
      >>

      holds. *)
  Lemma reflexive_for_all_2_family_prod (F : I → Type)
    (R : ∀ i, Relation (F i)) `{!∀ i, Reflexive (R i)}
    {ℓ : list I} (s : FamilyProd F ℓ)
    : for_all_2_family_prod F F R s s.
  Proof with try reflexivity.
    induction ℓ...
    split...
    apply IHℓ.
  Defined.
End family_prod.


Module Type MONAD.
  Set Implicit Arguments.

  Parameter M : forall (A : Type), Type.
  Parameter bind : forall (A B : Type),
    M A -> (A -> M B) -> M B.
  Parameter ret : forall (A : Type),
    A -> M A.

  Infix ">>=" := bind (at level 20, left associativity) : monad_scope.
  Open Scope monad_scope.

  Axiom left_unit : forall (A B : Type) (f : A -> M B) (a : A),
    (ret a) >>= f = f a.
  Axiom right_unit : forall (A B : Type) (m : M A),
    m >>= (fun a : A => ret a) = m.
  Axiom bind_assoc : forall (A B C : Type) (m : M A) (f : A -> M B) (g : B -> M C) (x : B),
    (m >>= f) >>= g = m >>= (fun x => (f x) >>= g).

End MONAD.

Module ListMonad <: MONAD.

  Require Import List.

  Set Implicit Arguments.

  Definition M := list.

  Fixpoint bind (A : Type) (B : Type) (l : M A) (f : A -> M B) {struct l} : M B :=
    match l with
      | nil => nil
      | h::t => (f h)++(bind t f)
    end.

  Infix ">>=" := bind (at level 20, left associativity) : monad_scope.
  Open Scope monad_scope.

  Definition ret (A : Type) := fun a : A => a::nil.

  Lemma left_unit : forall (A B : Type) (f : A -> M B) (a : A),
    (ret a) >>= f = f a.
  Proof.
    intros ; simpl ; rewrite app_nil_end ; reflexivity.
  Defined.

  Lemma right_unit : forall (A B : Type) (m : M A),
    m >>= (fun a : A => ret a) = m.
  Proof.
    simple induction m.
    simpl. reflexivity.
    intros. simpl.
    cut (bind l (fun a0 : A => ret a0) = l).
    intros. rewrite H0. reflexivity.
    exact H.
  Defined.

  Lemma bind_assoc : forall (A B C : Type) (m : M A) (f : A -> M B) (g : B -> M C) (x : B),
    (m >>= f) >>= g = m >>= (fun x => (f x) >>= g).
  Proof.
    simple induction m.
    intros. simpl. reflexivity.
    intros. simpl.
    cut (l >>= f >>= g = l >>= (fun x0 : A => f x0 >>= g)).
    intros. rewrite < - H0.
    induction (f a).
    simpl. reflexivity.
    simpl. rewrite IHm0. rewrite app_ass. reflexivity.
    apply H. exact x.
  Defined.

End ListMonad.

(* Example *)
Import ListMonad.
Require Import Peano.
Require Import List.

Fixpoint downfrom (n : nat) {struct n} : (list nat) :=
  match n with
    | 0 => n::nil
    | S m => n::(downfrom m)
  end.


Require Import
  Coq.Unicode.Utf8
  HoTT.Basics.Overture
  HoTTClasses.implementations.list.

(** The following section implements a datatype [FamilyProd] which
    is a kind of product/tuple. *)

Section family_prod.
  Context {I : Type}.

  (** [FamilyProd F ℓ] is a product type defined by

      <<
        FamilyProd F [i1;i2;...;in] = F i1 * F i2 * ... * F in * Unit
      >>

      It is convenient to have the [Unit] in the end.
  *)

  Definition FamilyProd (F : I → Type) : list I → Type
    := fold_right (λ (i:I) (A:Type), F i * A) Unit.

  (** Map function for [FamilyProd F ℓ],

      <<
        map_family_prod f (x1, x2, ..., xn, tt)
        = (f x1, f x2, ..., f xn, tt)
      >> *)

  Fixpoint map_family_prod {F G : I → Type} {ℓ : list I}
      (f : ∀ i, F i → G i)
      : FamilyProd F ℓ → FamilyProd G ℓ :=
    match ℓ with
    | nil => const tt
    | i :: ℓ' => λ '(x,s), (f i x, map_family_prod f s)
    end.

  (** [for_all_family_prod F P (x1, ..., xn, tt) = True] if
      [P i1 x1 ∧ P i2 x2 ∧ ... ∧ P in xn] holds. *)

  Fixpoint for_all_family_prod (F : I → Type) {ℓ : list I}
      (P : ∀ i, F i -> Type) : FamilyProd F ℓ → Type :=
    match ℓ with
    | nil => λ _, True
    | i :: ℓ' => λ '(x,s), P i x ∧ for_all_family_prod F P s
    end.

  (** [for_all_2_family_prod F G R (x1,...,xn,tt) (y1,...,yn,tt) = True]
      if [R i1 x1 y1 ∧ R i2 x2 y2 ∧ ... ∧ P in xn yn] holds. *)

  Fixpoint for_all_2_family_prod (F G : I → Type) {ℓ : list I}
      (R : ∀ i, F i -> G i -> Type)
      : FamilyProd F ℓ → FamilyProd G ℓ → Type :=
    match ℓ with
    | nil => λ _ _, True
    | i :: ℓ' => λ '(x,s) '(y,t), R i x y ∧ for_all_2_family_prod F G R s t
    end.

  (** If [R : ∀ i, relation (F i)] is a family of relations indexed by
      [i:I] and [R i] is reflexive for all [i], then

      <<
        for_all_2_family_prod F F R s s
      >>

      holds. *)
  Lemma reflexive_for_all_2_family_prod (F : I → Type)
    (R : ∀ i, relation (F i)) `{!∀ i, Reflexive (R i)}
    {ℓ : list I} (s : FamilyProd F ℓ)
    : for_all_2_family_prod F F R s s.
  Proof with try reflexivity.
    induction ℓ...
    split...
    apply IHℓ.
  Defined.
End family_prod.


From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require FunctionalExtensionality List.

From Mon Require Export Base.
From Coq Require Import Relation_Definitions Morphisms.
From Mon Require Import SPropBase SPropMonadicStructures MonadExamples SpecificationMonads Monoid DijkstraMonadExamples.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr.
Set Warnings "notation-overridden,ambiguous-paths".
From Relational Require Import Commutativity.

Import GRing.Theory Num.Theory.
Import Order.POrderTheory.

Local Open Scope ring_scope.

Section FinProb.

  Context (R:realType).

  Import SPropNotations.

  Definition unit_interval := { r : R | 0 <= r <= 1 }.
  Let I := unit_interval.

  Definition Irel : relation I := fun i1 i2 => i1∙1 <= i2∙1.
  Global Instance Irel_preorder : PreOrder Irel.
  Proof.
    constructor.
    move=> ?; rewrite /Irel lexx //.
    move=> x y z ; rewrite /Irel.
    apply le_trans.
  Qed.

  Definition WI := @MonoCont I Irel _.

  (* Lemma since_its_true (b:bool) : ⟦b⟧ -> b. *)
  (* Proof. by case: b. Qed. *)

  (* Lemma its_true_anyway (b:bool) : b -> ⟦b⟧. *)
  (* Proof. by case: b. Qed. *)

  Lemma I_ge0 (x:I) : 0 <= x∙1.
  Proof. by move: (x∙2)=> /andP [-> _]. Qed.

  Lemma I_le1 (x:I) : x∙1 <= 1.
  Proof. by move: (x∙2)=> /andP [_ ->]. Qed.

  Hint Resolve I_ge0 : core.
  Hint Resolve I_le1 : core.

  #[program] Definition addI (x y : I) : I := ⦑ (x∙1 + y∙1) / 2%:~R ⦒.
  Next Obligation.
    intros x y. simpl.
    rewrite divr_ge0 ?Bool.andb_true_l ?ler0n ?addr_ge0 //.
    rewrite ler_pdivr_mulr.
    rewrite mul1r [2%:~R]/(1+1) ler_add //.
    rewrite ltr0n //.
  Qed.

  #[program] Definition mulI (x y:I) : I := ⦑ x∙1 * y∙1 ⦒.
  Next Obligation.
    intros. simpl.
    rewrite mulr_ge0 //=.
    rewrite -{3}(mul1r 1).
    rewrite ler_pmul //=.
  Qed.

  #[program] Definition negI (x:I) : I := ⦑ 1 - x∙1 ⦒.
  Next Obligation.
    intros. simpl.
    rewrite subr_ge0 (I_le1 x) /= ler_subl_addr -{1}(addr0 1) ler_add ?lerr //.
  Qed.

  Definition ProbS := I.
  Definition ProbAr (p:ProbS) := bool.

  Definition ProbM : Monad := Free ProbAr.

  #[program] Definition barycentric_sum (p:I) (x y: I) : I :=
    ⦑ p∙1 * x∙1 + (1-p∙1) * y∙1 ⦒.
  Next Obligation.
    intros p x y. simpl.
    set p' : I := negI p; change (1-p∙1) with p'∙1.
    rewrite addr_ge0 ?mulr_ge0 //.
    have: (1 = p∙1*1 + (1 - p∙1)*1) by rewrite !mulr1 addrA [_+1]addrC addrK.
    move=> heq; rewrite [X in _ <= X]heq.
    by rewrite ler_add // ler_pmul // (I_ge0 (negI p)).
  Qed.

  #[program] Definition wopProb (p:ProbS) : WI (ProbAr p) :=
    ⦑ fun f => barycentric_sum p (f true) (f false) ⦒.
  Next Obligation.
    intros p ? ? H.
    rewrite /Irel /=.
    rewrite ler_add // ler_pmul //; try by apply H.
    by rewrite (I_ge0 (negI p)).
  Qed.

  Definition θProb := OpSpecEffObs wopProb.

  Lemma mulIDl : left_distributive mulI addI.
  Proof.
    move=> ? ? ? ; apply sig_eq=> /=.
    by rewrite -mulrA [in t in (_ * t)]mulrC mulrA mulrDl.
  Qed.

  Lemma mulIDr : right_distributive mulI addI.
  Proof.
    move=> ? ? ? ; apply sig_eq=> /=; by rewrite mulrA mulrDr.
  Qed.

  Lemma addIX p1 p2 p3 p4 :
    addI (addI p1 p2) (addI p3 p4) = addI (addI p1 p3) (addI p2 p4).
  Proof.
    apply sig_eq => /=;
      by rewrite -2!mulrDl -2!addrA
                 [in t in _+t]addrA (addrC (p2∙1) (p3∙1)) !addrA.
  Qed.

  Lemma addIC : commutative addI.
  Proof. move=> ? ? ; apply sig_eq => /= ; by rewrite addrC. Qed.

  Lemma mulIC : commutative mulI.
  Proof. move=> ? ? ; apply sig_eq => /= ; by rewrite mulrC. Qed.

  Lemma mulIA : associative mulI.
  Proof. move=> ? ? ? ; apply sig_eq => /= ; by rewrite mulrA. Qed.

  Import FunctionalExtensionality.
  Lemma self_commute (p1 p2 : ProbS) : commute (wopProb p1) (wopProb p2).
  Proof.
    rewrite /commute /wopProb; apply sig_eq=> /=.
    extensionality k; apply sig_eq=> /=.
    rewrite !mulrDr !mulrA.
    do 2 rewrite [((1 - _)* _)as t in t * _]mulrC.
    rewrite 2![(p1∙1 * _)as t in t * _]mulrC.
    rewrite -2!addrA [in t in _+t]addrA [in t in _ + (t + _)]addrC !addrA.
    do 2 f_equal.
  Qed.
End FinProb.

(* Reflection for SProp (not needed in the end) *)

(* Inductive sreflect (P : SProp) : bool -> Type := *)
(* | SReflectT : P -> sreflect P true *)
(* | SReflectF : s~ P -> sreflect P false. *)

(* Lemma andSP (b1 b2 : bool) : sreflect (⟦b1⟧ /\ ⟦b2⟧) (b1 && b2). *)
(* Proof. case: b1; case: b2 => /=; first left=> //=; right=> [[[] []]]. Qed. *)

(* Definition elimST (P : SProp) (b : bool) : sreflect P b -> ⟦b⟧ -> P. *)
(* Proof. by case=> ? []. Qed. *)

(* Coercion elimST : sreflect >-> Funclass. *)


Add LoadPath "../..".
Require Export LFND_Shared.

Inductive vctx_LF :=
| bctx: nat -> vctx_LF
| cctx: ctx_LF -> vctx_LF
.

Inductive te_LF :=
| hyp_LF: vte -> te_LF
| lam_LF: ty -> te_LF -> te_LF
| appl_LF: te_LF -> te_LF -> te_LF
| box_LF: te_LF -> te_LF
| unbox_LF: te_LF -> te_LF
.

Lemma eq_te_LF_dec:
forall (M1: te_LF) (M2: te_LF),
  {M1 = M2} + {M1 <> M2}.
decide equality.
apply eq_vte_dec.
apply eq_ty_dec.
Qed.

Inductive lc_t_n_LF : nat -> te_LF -> Prop :=
 | lc_t_hyp_bte_LF: forall v n, n > v -> lc_t_n_LF n (hyp_LF (bte v))
 | lc_t_hyp_fte_LF: forall v n, lc_t_n_LF n (hyp_LF (fte v))
 | lc_t_lam_LF: forall M t n,
     lc_t_n_LF (S n) M ->
     lc_t_n_LF n (lam_LF t M)
 | lc_t_appl_LF: forall M N n,
     lc_t_n_LF n M -> lc_t_n_LF n N ->
     lc_t_n_LF n (appl_LF M N)
 | lc_t_box_LF: forall M n,
     lc_t_n_LF n M ->
     lc_t_n_LF n (box_LF M)
 | lc_t_unbox_LF: forall M n,
     lc_t_n_LF n M ->
     lc_t_n_LF n (unbox_LF M)
.

Definition lc_t_LF := lc_t_n_LF 0.

Fixpoint used_vars_te_LF (M: te_LF) : fset var :=
match M with
| hyp_LF (fte v) => \{v}
| hyp_LF (bte _) => \{}
| lam_LF _ M => used_vars_te_LF M
| appl_LF M N => used_vars_te_LF M \u used_vars_te_LF N
| box_LF M => used_vars_te_LF M
| unbox_LF M => used_vars_te_LF M
end.

Lemma closed_t_succ_LF:
forall M n,
  lc_t_n_LF n M -> lc_t_n_LF (S n) M.
intros; generalize dependent n;
induction M; intros; inversion H; subst;
eauto using lc_t_n_LF.
Qed.

Lemma closed_t_addition_LF:
forall M n m,
  lc_t_n_LF n M -> lc_t_n_LF (n + m) M.
intros; induction m;
[ replace (n+0) with n by auto |
  replace (n + S m) with (S (n+m)) by auto] ;
try apply closed_t_succ_LF;
assumption.
Qed.


(*
 - Definition of wild categories
 - Lemmas for invertible 2-cells
 - Equivalence of object
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat. Import Notations.

Local Open Scope cat.

(** Definition of wild category **)
(* They are just the data for prebicategories *)
Notation wild_cat_2cell_struct := prebicat_2cell_struct.
Notation wild_cat_1_id_comp_cells := prebicat_1_id_comp_cells.
Notation wild_cat_cells := prebicat_cells.
Notation wild_cat_2_id_comp_struct := prebicat_2_id_comp_struct.
Notation wild_cat := prebicat_data.
Notation make_wild_cat := make_prebicat_data.
Notation build_wild_cat := build_prebicat_data.

(** Lemmas for invertible 2-cells **)
Definition is_invertible_2cell {C : wild_cat}
           {a b : C} {f g : a --> b} (θ : f ==> g)
  : UU := g ==> f.

Definition make_is_invertible_2cell {C : wild_cat}
           {a b : C} {f g : a --> b}
           (θ : f ==> g)
           (γ : g ==> f)
  : is_invertible_2cell θ
  := γ.

Definition inv_cell {C : wild_cat} {a b : C} {f g : a --> b} {θ : f ==> g}
  (c : is_invertible_2cell θ) : g ==> f := c.

Notation "inv_θ ^-1" := (inv_cell inv_θ) : bicategory_scope.

Definition is_invertible_2cell_inv {C : prebicat_data} {a b : C} {f g : a --> b}
           {θ : f ==> g} (inv_θ : is_invertible_2cell θ)
  : is_invertible_2cell (inv_θ^-1)
  := make_is_invertible_2cell _ θ.

Definition is_invertible_2cell_id₂ {C : prebicat} {a b : C} (f : a --> b)
  : is_invertible_2cell (id2 f)
  := make_is_invertible_2cell (id2 f) (id2 f).

Definition invertible_2cell {C : wild_cat}
           {a b : C} (f g : a --> b) : UU
  := ∑ θ : f ==> g, is_invertible_2cell θ.

Definition make_invertible_2cell {C : wild_cat}
           {a b : C} {f g : a --> b}
           {θ : f ==> g} (inv_θ : is_invertible_2cell θ)
  : invertible_2cell f g
  := θ,, inv_θ.

Coercion cell_from_invertible_2cell {C : wild_cat}
         {a b : C} {f g : a --> b} (θ : invertible_2cell f g)
  : f ==> g
  := pr1 θ.

Coercion property_from_invertible_2cell {C : wild_cat}
         {a b : C} {f g : a --> b}
         (θ : invertible_2cell f g)
  : is_invertible_2cell θ
  := pr2 θ.

Definition id2_invertible_2cell {C : prebicat} {a b : C} (f : a --> b)
  : invertible_2cell f f
  := make_invertible_2cell (is_invertible_2cell_id₂ f).

(** Equivalence of objects **)
Definition are_equivalent {C : wild_cat} (a b : C)
  : UU
  := ∑ (f : a --> b) (g : b --> a), f · g ==> identity a × g · f ==> identity b.


From mathcomp Require Import all_ssreflect all_algebra vector reals ereal classical_sets.
From mathcomp Require Import zmodp.
Require Export preliminaries preliminaries_hull axiomsKnuth.

(******************************************************************************)
(*   encompass oriented s l == oriented is a ternary relation, s and l        *)
(*                             are lists of points such that                  *)
(*                             oriented l_i l_i.+1 s_k for all i and k        *)
(*   encompass_aux oriented l h == h describes an open convex region that     *)
(*                             contains l                                     *)
(*   encompass oriented l h == h describes a convex hull for the set of       *)
(*                             points l where the last segment is formed by   *)
(*                             the last and first elements                    *)
(******************************************************************************)

Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory.

Local Open Scope ring_scope.

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

Section spec.
Variable plane : zmodType.
Variable oriented : plane -> plane -> plane -> bool.

Definition is_left (p q r : plane) := [|| r == p, r == q | oriented p q r].
Hint Unfold is_left : core.

Definition all_left (x y : plane) : seq plane -> bool := all (is_left x y).

Fixpoint encompass_aux (l h : seq plane) : bool :=
  match h with
  | nil => false
  | t1 :: nil => true
  | t1 :: ((t2 :: _) as h') => all_left t1 t2 l && encompass_aux l h'
  end.

Definition encompass (s h : seq plane) :=
  match h with
  | nil => false
  | t :: h' => encompass_aux s (last t h' :: h)
  end.

Lemma encompassl0 l : encompass l [::] = false.
Proof. by []. Qed.

Definition convexHullSpec (l h : seq plane) :=
  uniq h && all (mem l) h && encompass l h.

(* TOTHINK: replace encompass : seq -> seq -> bool by a predicate
   seq -> plane -> bool? *)

Lemma encompass_auxE (l h : seq plane) :
  encompass_aux l h = (h != [::]) && all (fun x => encompass_aux [:: x] h) l.
Proof.
elim: h =>// a'; case=> [ _ | b' l' IHl'].
   by elim: l.
rewrite /= -/(encompass_aux l (b' :: l')) IHl' -all_predI; apply eq_all=>x.
by rewrite /= andbT.
Qed.

Lemma encompassE (s h : seq plane) :
  encompass s h = (h != [::]) && all (fun x => encompass [:: x] h) s.
Proof. by case: h =>// a l; rewrite {1}/encompass encompass_auxE. Qed.

Lemma encompass_aux_all_index (l h : seq plane) :
  encompass_aux l h = (h != [::]) &&
    [forall i : 'I_(size h), (i.+1mod == 0%N :> nat) || all_left h`_i h`_i.+1mod l].
Proof.
elim: h=>// a; case.
   by move=>/= _; apply/esym/forallP => i; rewrite modn1 eq_refl.
move=>b l' IHl' /=; rewrite -/(encompass_aux l (b :: l')) IHl' /=.
apply/idP/idP => [/andP[Habl H]|/forallP H].
  apply/forallP => -[] [//|n/=].
  rewrite ltnS => nlt.
  move: H => /forallP/(_ (Ordinal nlt)).
  move: nlt (nlt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|nm nm1].
    by rewrite modnn eqxx.
  by rewrite modn_small ?ltnS// modn_small ?ltnS.
apply/andP; split; first by move: H => /(_ ord0).
apply/forallP => -[i ilt].
move: H => /(_ (lift ord0 (Ordinal ilt))).
move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|ilt ilt1].
  by rewrite modnn eqxx.
by rewrite modn_small ?ltnS// modn_small ?ltnS.
Qed.

Lemma encompass_all_index (l s : seq plane) : encompass s l =
  (l != [::]) && [forall i : 'I_(size l), all_left l`_i l`_i.+1mod s].
Proof.
case: l => // a l /=.
rewrite -/(encompass_aux s (a :: l)) encompass_aux_all_index.
apply/idP/idP => [H|/forallP H].
   apply/forallP => -[i ilt].
   move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1].
     by rewrite modnn nth_last /=; move: H => /andP[H _].
   move: H => /andP[_ /andP [_ /forallP]] /(_ (Ordinal ilt1)) /=.
   by rewrite modn_small ?ltnS.
apply/andP; split.
   by move: H => /(_ ord_max); rewrite /= modnn nth_last.
apply/forallP => -[i ilt].
move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1].
  by rewrite modnn.
by move: H => /(_ (Ordinal ilt1))/=; rewrite modn_small ?ltnS.
Qed.

End spec.

Module SpecKA (KA : KnuthAxioms).
Section Dummy.
Variable R : realType.
Let plane := pair_vectType (regular_vectType R) (regular_vectType R).

Let oriented := KA.OT (R:=R).
Let Ax1 := KA.Axiom1 (R:=R).
Let Ax2 := KA.Axiom2 (R:=R).
Let Ax5 := KA.Axiom5 (R:=R).
Let Ax5' := KA.Axiom5' (R:=R).

Lemma encompassll_spec (l : seq plane) : uniq l ->
  encompass oriented l l =
  (l != [::]) &&
    [forall i : 'I_(size l), [forall j : 'I_(size l), [forall k : 'I_(size l),
      (i < j < k)%N ==> oriented l`_i l`_j l`_k]]].
Proof.
move=> /uniqP-/(_ 0%R) lu; apply/idP/idP.
  rewrite encompassE => /andP[-> /allP] ll /=.
  have sD i j : (i.+1 < size l)%N -> (j < size l)%N -> j != i -> j != i.+1 ->
      oriented l`_i l`_i.+1 l`_j.
    move=> isl jl ji jis.
    have /ll : l`_j \in l by rewrite mem_nth.
    have il : (i < size l)%N by rewrite (leq_trans _ isl).
    rewrite encompass_all_index => /andP[_] /forallP /(_ (Ordinal il)) /=.
    rewrite Zp_succE andbT/= modn_small// => /or3P[| |//] /eqP/lu; rewrite 2!inE.
       by move=> /(_ jl il)/eqP; rewrite (negbTE ji).
    by move=>/(_ jl isl)/eqP; rewrite (negbTE jis).
  apply/'forall_'forall_'forall_implyP => -[i ilt] [j jlt] [k klt] /= /andP[ij jk].
  elim: k => // k IHk in klt jk *.
  have {}IHk := IHk (ltnW klt).
  move: jk; rewrite leq_eqVlt => /predU1P[[jk]|].
    subst j.
    do 2 apply: Ax1.
    apply: sD => //; first by rewrite ltn_eqF.
    by rewrite ltn_eqF// (leq_trans ij).
  rewrite ltnS => jk; have {}IHk := IHk jk.
  move: ij; rewrite leq_eqVlt => /predU1P[ij|ij].
    subst j.
    apply: sD => //.
      by rewrite gtn_eqF// ltnS (leq_trans _ jk)// -addn2 leq_addr.
    by rewrite gtn_eqF// (leq_trans jk).
  apply: (@Ax5 _ l`_i.+1 _ l`_k).
  - apply: sD => //; first by rewrite (leq_trans ij)// ltnW.
      by rewrite gtn_eqF// (ltn_trans _ ij).
    by rewrite gt_eqF.
  - apply: sD; first by rewrite (leq_trans ij)// ltnW.
        by rewrite (ltn_trans _ klt).
      by rewrite gtn_eqF// (ltn_trans _ jk)// (ltn_trans _ ij).
    by rewrite gtn_eqF// (ltn_trans ij).
  - apply: sD => //; first by rewrite (leq_trans ij)// ltnW.
      rewrite gtn_eqF// ltnS (leq_trans _ (ltnW jk))// (leq_trans _ ij)//.
      by rewrite -addn2 leq_addr.
    by rewrite gtn_eqF// (leq_trans ij)// (leq_trans (ltnW jk)).
  - exact IHk.
  - do 2 apply Ax1.
    apply: sD => //.
      by rewrite ltn_eqF// (ltn_trans _ jk)// (leq_trans _ ij).
    by rewrite ltn_eqF// ltnS (leq_trans _ (ltnW jk))// ltnW// (ltn_trans _ ij).
rewrite encompassE => /andP[l0 sD] /=; rewrite l0 /=.
have id x : x \in l -> exists2 n, (n < size l)%N & l`_n = x.
   by move=> xl; exists (index x l); [rewrite index_mem|rewrite nth_index].
apply/allP => _ /id[i il <-].
rewrite encompass_all_index; rewrite l0; apply/forallP => -[j jlt].
rewrite /all_left/= /is_left/= andbT.
have [->|ij] := eqVneq i j.
   exact/or3P/Or31.
destruct l as [|a l] => //=.
have [ijs|ijs] := eqVneq i (j.+1 %% (size l).+1)%N.
   by apply/or3P/Or32; rewrite -ijs.
apply/or3P/Or33; move: jlt; rewrite leq_eqVlt => /predU1P[[je]|jlt].
   subst j; rewrite modnn.
   do 2 apply Ax1.
   move: sD => /'forall_'forall_'forall_implyP
               /(_ ord0 (Ordinal il) (Ordinal (leqnn _)));
               apply => /=.
   rewrite lt0n.
   move: ijs; rewrite modnn => ->/=.
   move: il; rewrite leq_eqVlt => /predU1P[[/eqP]|].
      by rewrite (negbTE ij).
   by rewrite ltnS.
move:ijs; rewrite modn_small => // ijs.
have [ji|ji] := ltnP j.+1 i.
   move: sD => /'forall_'forall_'forall_implyP
               /(_ (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt) (Ordinal il)).
   apply => /=.
   by rewrite ltnS leqnn.
apply: Ax1.
move: sD => /'forall_'forall_'forall_implyP
            /(_ (Ordinal il) (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt)).
apply => /=.
rewrite ltnS leqnn andbT ltnNge.
rewrite leq_eqVlt eq_sym (negbTE ij)/=.
rewrite leq_eqVlt eq_sym (negbTE ijs)/=.
by rewrite ltnNge ji.
Qed.

Lemma encompassll_subseq (l l' : seq plane) : uniq l ->
  encompass oriented l l ->
  subseq l' l ->
  l' != [::] ->
  encompass oriented l' l'.
Proof.
move=> lu; rewrite (encompassll_spec lu) => ll l'l l'0.
have l'u := subseq_uniq l'l lu; rewrite (encompassll_spec l'u) l'0 /=.
apply/'forall_'forall_'forall_implyP => i j k /andP[ij jk].
move: l'l => /subseq_incl-/(_ 0%R) [f [fl flt]].
move: ll => /andP[_] /'forall_'forall_'forall_implyP
  /(_ (f i)) /(_ (f j)) /(_ (f k)); rewrite 3!fl; apply.
by apply/andP; split; apply: flt.
Qed.

End Dummy.
End SpecKA.


Definition N := 4.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


Set Implicit Arguments.

Local Open Scope nat.

Require Import Coq.Arith.Le.
Require Import Coq.Arith.Max.

Ltac max_solver :=
  repeat
    match goal with
      | |- ?A <= ?A => eapply le_n
      | |- 0 <= _ => eapply le_0_n
      | |- max _ _ <= _ => eapply max_lub
      | |- ?S <= max ?A _ =>
        match A with
            context [ S ] => eapply le_trans; [ | eapply le_max_l]
        end
      | |- ?S <= max _ ?B =>
        match B with
            context [ S ] => eapply le_trans; [ .. | eapply le_max_r]
        end
    end.

Lemma both_le : forall a b a' b', a <= a' -> b <= b' -> max a b <= max a' b'.
  intros; max_solver; eauto.
  eapply le_trans; [ | eapply le_max_l]; eauto.
  eapply le_trans; [ | eapply le_max_r]; eauto.
Qed.

Local Close Scope nat.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.

Section triangle_existential_triangle.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma triangle__existential_triangle : triangle_postulate -> postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights.
Proof.
  intro triangle.
  destruct lower_dim_ex as [A [B [C]]].
  assert(~ Col A B C) by (unfold Col; assumption).
  assert_diffs.
  destruct (ex_trisuma A B C) as [D [E [F]]]; auto.
  exists A; exists B; exists C; exists D; exists E; exists F.
  repeat split.
    assumption.
    assumption.
    apply (triangle A B C); assumption.
Qed.

End triangle_existential_triangle.


Require Import Lia.
Require Import Nat.
From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import ordinals.
From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import PA_omega.
From Cyclic_PA.Logic Require Import proof_trees.
From Cyclic_PA.Logic Require Import substitute.

From Cyclic_PA.Logic Require Import formula_sub.
From Cyclic_PA.Logic Require Import inverse_neg.
From Cyclic_PA.Logic Require Import inverse_dem_1.
From Cyclic_PA.Logic Require Import inverse_dem_2.
From Cyclic_PA.Logic Require Import inverse_omega.
From Cyclic_PA.Logic Require Import inverse_quantif.

Fixpoint cut_elimination_atom (P : ptree) : ptree :=
match P with
| cut_ca C (atom a) d1 d2 alpha1 alpha2 P1 P2 =>
  (match PA_omega_axiom (atom a) with
  | true =>
      formula_sub_ptree P2 (neg (atom a)) C (1)
  | false =>
      contraction_a
        C d1 alpha1
        (formula_sub_ptree P1 (atom a) C (lor_ind (non_target C) (1)))
  end)

| cut_ad (atom a) D d1 d2 alpha1 alpha2 P1 P2 =>
  (match PA_omega_axiom (atom a) with
  | true =>
      contraction_a
        D d2 alpha2
        (formula_sub_ptree P2 (neg (atom a)) D (lor_ind (1) (non_target D)))
  | false =>
      formula_sub_ptree P1 (atom a) D (1)
  end)

| cut_cad C (atom a) D d1 d2 alpha1 alpha2 P1 P2 =>
  (match PA_omega_axiom (atom a) with
  | true =>
      weakening_ad C D d2 alpha2
        (contraction_a
          D d2 alpha2
          (formula_sub_ptree P2 (neg (atom a)) D (lor_ind (1) (non_target D))))
  | false =>
      exchange_ab
        D C d1 (ord_succ alpha1)
        (weakening_ad
          D C d1 alpha1
          (contraction_a
            C d1 alpha1
            (formula_sub_ptree P1 (atom a) C (lor_ind (non_target C) (1)))))
  end)
| deg_up d P' => cut_elimination_atom P'
| ord_up alpha P' => cut_elimination_atom P'
| _ => P
end.

Fixpoint cut_elimination_neg (P : ptree) : ptree :=
match P with
| cut_ca C (neg E) d1 d2 alpha1 alpha2 P1 P2 =>
    cut_ad
      E C d2 d1 alpha2 alpha1
      (dub_neg_sub_ptree P2 E (1))
      (exchange_ab C (neg E) d1 alpha1 P1)

| cut_ad (neg E) D d1 d2 alpha1 alpha2 P1 P2 =>
    cut_ca
      D E d2 d1 alpha2 alpha1
      (exchange_ab
        E D d2 alpha2
        (dub_neg_sub_ptree P2 E (lor_ind (1) (non_target D))))
      P1

| cut_cad C (neg E) D d1 d2 alpha1 alpha2 P1 P2 =>
    exchange_ab
      D C (ptree_deg (cut_cad
      D E C d2 d1 alpha2 alpha1
      (exchange_ab
      E D d2 alpha2
        (dub_neg_sub_ptree P2 E (lor_ind (1) (non_target D))))
          (exchange_ab C (neg E) d1 alpha1 P1))) (ptree_ord P)
        (cut_cad
          D E C d2 d1 alpha2 alpha1
          (exchange_ab
          E D d2 alpha2
            (dub_neg_sub_ptree P2 E (lor_ind (1) (non_target D))))
              (exchange_ab C (neg E) d1 alpha1 P1))
| deg_up d P' => cut_elimination_neg P'
| ord_up alpha P' => cut_elimination_neg P'
| _ => P
end.

Definition associativity_1' (P : ptree) : ptree :=
match ptree_formula P, ptree_deg P, ptree_ord P with
| lor (lor C A) B, d, alpha =>
    exchange_ab
      (lor A B) C d alpha
      (exchange_cab
        A C B d alpha
        (exchange_abd C A B d alpha P))

| _, _, _ => P
end.

Definition associativity_2' (P : ptree) : ptree :=
match ptree_formula P, ptree_deg P, ptree_ord P with
| lor C (lor A B), d, alpha =>
    exchange_abd
      A C B d alpha
      (exchange_cab
        A B C d alpha
        (exchange_ab C (lor A B) d alpha P))

| _, _, _ => P
end.

Lemma associativity1_valid :
    forall (P : ptree),
        valid P ->
            valid (associativity_1' P).
Proof.
intros P PV.
unfold associativity_1'.
destruct (ptree_formula P) eqn:PF;
try apply PV.
destruct f1;
try apply PV.
repeat split.
apply PF.
apply PV.
Qed.

Lemma associativity2_valid :
    forall (P : ptree),
        valid P ->
            valid (associativity_2' P).
Proof.
intros P PV.
unfold associativity_2'.
destruct (ptree_formula P) eqn:PF;
try apply PV.
destruct f2;
try apply PV.
repeat split.
apply PF.
apply PV.
Qed.

Definition contraction_help (P : ptree) : ptree :=
match ptree_formula P, ptree_deg P, ptree_ord P with
| lor (lor C D) E, d, alpha =>
    (match form_eqb D E with
    | true =>
        exchange_ab
          D C d alpha
          (contraction_ad
            D C d alpha
            (exchange_cab
              D C D d alpha
              (exchange_abd C D D d alpha P)))

    | false => P
    end)

| _, _, _ => P
end.

Fixpoint cut_elimination_lor (P : ptree) : ptree :=
match P with
| cut_ca C (lor E F) d1 d2 alpha1 alpha2 P1 P2 =>
    cut_ca
      C E
      (max (max d1 d2) (S (num_conn F)))
      d2
      (ord_succ (ord_max alpha1 alpha2))
      alpha2
      (cut_ca (lor C E) F d1 d2 alpha1 alpha2
        (associativity_2' P1)
        (demorgan2_sub_ptree P2 E F (1)))
      (demorgan1_sub_ptree P2 E F (1))

| cut_ad (lor E F) D d1 d2 alpha1 alpha2 P1 P2 =>
    contraction_a
      D
      (max (max d1 d2) (max (S (num_conn E)) (S (num_conn F))))
      (ord_succ (ord_succ (ord_max alpha1 alpha2)))
      (cut_cad
        D E D
        (max (max d1 d2) (S (num_conn F)))
        d2
        (ord_succ (ord_max alpha1 alpha2))
        alpha2
        (exchange_ab
          E D
          (max (max d1 d2) (S (num_conn F)))
          (ord_succ (ord_max alpha1 alpha2))
          (cut_cad
            E F D d1 d2 alpha1 alpha2 P1
            (demorgan2_sub_ptree P2 E F (lor_ind (1) (non_target D)))))
        (demorgan1_sub_ptree P2 E F (lor_ind (1) (non_target D))))

| cut_cad C (lor E F) D d1 d2 alpha1 alpha2 P1 P2 =>
    contraction_help
      (cut_cad
        (lor C D) E D
        (max (max d1 d2) (S (num_conn F)))
        d2
        (ord_succ (ord_max alpha1 alpha2))
        alpha2
        (exchange_cab
          C E D
          (max (max d1 d2) (S (num_conn F)))
          (ord_succ (ord_max alpha1 alpha2))
          (cut_cad (lor C E) F D d1 d2 alpha1 alpha2
            (associativity_2' P1)
            (demorgan2_sub_ptree P2 E F (lor_ind (1) (non_target D)))))
        (demorgan1_sub_ptree P2 E F (lor_ind (1) (non_target D))))

| deg_up d P' => cut_elimination_lor P'
| ord_up alpha P' => cut_elimination_lor P'
| _ => P
end.

Fixpoint cut_elimination (P : ptree) : ptree :=
match P with
| cut_ca C A d1 d2 alpha1 alpha2 P1 P2 =>
  (match A with
  | atom a => cut_elimination_atom P
  | neg E => cut_elimination_neg P
  | lor E F => cut_elimination_lor P
  | univ n E => P
  end)
| cut_ad A D d1 d2 alpha1 alpha2 P1 P2 =>
  (match A with
  | atom a => cut_elimination_atom P
  | neg E => cut_elimination_neg P
  | lor E F => cut_elimination_lor P
  | univ n E => P
  end)
| cut_cad C A D d1 d2 alpha1 alpha2 P1 P2 =>
  (match A with
  | atom a => cut_elimination_atom P
  | neg E => cut_elimination_neg P
  | lor E F => cut_elimination_lor P
  | univ n E => P
  end)
| deg_up d P' => cut_elimination P'
| ord_up alpha P' => cut_elimination P'
| _ => P
end.

Theorem cut_elimination_formula :
    forall (P : ptree),
        valid P ->
            ptree_formula (cut_elimination P) = ptree_formula P.
Proof.
intros P PV.
induction P;
unfold cut_elimination, cut_elimination_atom, cut_elimination_neg, cut_elimination_lor; fold cut_elimination.

1,2 : apply IHP;
      apply PV.

all : try reflexivity;
      destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O];
      unfold PA_omega_axiom.

2 : destruct f.
1,6 : destruct f0.
1,5,9 : destruct (correct_a a).

all : unfold ptree_formula;
      fold ptree_formula;
      try reflexivity.

3 : { unfold contraction_help, ptree_formula;
      rewrite form_eqb_refl;
      reflexivity. }
2 : { rewrite (formula_sub_ptree_formula_atom P1 a f0 P1V (1)).
      rewrite P1F.
      apply formula_sub_ind_1.
      unfold subst_ind_fit.
      reflexivity. }

1 : { rewrite (formula_sub_ptree_formula_neg P2 a f P2V (1));
      rewrite P2F.
      apply formula_sub_ind_1.
      unfold subst_ind_fit.
      reflexivity. }
Qed.

(*********TEMPORARY***********)

Lemma weak_ord_height :
    forall (P : ptree) (alpha : ord),
        ord_ltb alpha (ptree_ord P) = false ->
            ptree_ord (weak_ord_up P alpha) = alpha .
Proof.
intros P alpha IO.
unfold weak_ord_up.
destruct (ord_semiconnex_bool (ptree_ord P) alpha) as [LT | [GT | EQ]].
rewrite LT. reflexivity.
rewrite GT in IO. inversion IO.
apply ord_eqb_eq in EQ. destruct EQ.
rewrite ord_ltb_irrefl.
reflexivity.
Qed.

Theorem cut_elimination_ord :
    forall (P : ptree),
        valid P ->
            ord_ltb (ord_2_exp (ptree_ord P)) (ptree_ord (cut_elimination P)) = false.
Proof.
intros P PV.
pose (ptree_ord P) as alpha.
pose proof (ptree_ord_nf _ PV) as NA.
induction P;
unfold cut_elimination, cut_elimination_atom, cut_elimination_neg, cut_elimination_lor; fold cut_elimination.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
4-9 : destruct PV as [[[PF PV] PD] PO].
10 :  destruct PV as [[[[PF FC] PV] PD] PO].
11,12 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
13-16 : destruct PV as [[[PF PV] PD] PO].
19-21 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

2 : { fold cut_elimination cut_elimination_atom cut_elimination_neg cut_elimination_lor. fold cut_elimination.
      unfold ptree_ord; fold ptree_ord.
      pose proof (IHP PV (ptree_ord_nf _ PV)) as IHPV.
      destruct (ord_semiconnex_bool (ord_2_exp (ptree_ord P)) (ptree_ord (cut_elimination P))) as [LT | [ GT | EQ]].
    + rewrite LT in IHPV.
      inversion IHPV.
    + apply (ord_ltb_asymm _ _ (ord_ltb_trans _ _ _ GT (ord_lt_ltb _ _ (ord_2_exp_monot _ NO _ (ptree_ord_nf _ PV) IO)))).
    + apply ord_eqb_eq in EQ.
      destruct EQ.
      apply (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_2_exp_monot _ NO _ (ptree_ord_nf _ PV) IO))). }

1 : { fold cut_elimination cut_elimination_atom cut_elimination_neg cut_elimination_lor. fold cut_elimination.
      unfold ptree_ord; fold ptree_ord.
      apply (IHP PV NA). }

all : unfold ptree_ord in *; fold ptree_ord in *;
      try apply (ord_ltb_exp_false _ NA);
      unfold PA_omega_axiom.

2 : destruct f.
1,6 : destruct f0.
1,5,9 : destruct (correct_a a).

all : unfold contraction_help, ptree_formula, ptree_ord;
      try rewrite form_eqb_refl;
      try rewrite formula_sub_ptree_ord_atom;
      try rewrite formula_sub_ptree_ord_neg;
      try rewrite P1O in *;
      try rewrite P2O in *;
      try apply P1V;
      try apply P2V;
      fold ptree_ord;
      try apply ord_ltb_exp_false;
      try apply NA.

7,10 : rewrite (ord_max_symm (ptree_ord P2)).
9,10 : rewrite (ord_max_ltb_not_l _ _ (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_r _ _)))).
7,9,10 : apply (ord_ltb_succ_leb _ _ NA (nf_2_exp _ NA) (ord_lt_ltb _ _ (ord_succ_not_exp_fp _ NA))).

all : apply (ord_geb_trans _ (ord_succ (ord_max (ptree_ord P1) (ptree_ord P2))));
      try apply (ord_geb_trans (ord_2_exp (ord_succ (ord_succ (ord_max (ptree_ord P1) (ptree_ord P2))))) (ord_succ (ord_succ (ord_max (ptree_ord P1) (ptree_ord P2)))) (ord_succ (ord_max (ptree_ord P1) (ptree_ord P2))));
      try apply (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_succ_monot _)));
      try apply (ord_ltb_exp_false _ NA);
      try apply ord_geb_succ;
      try apply (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_l _ _)));
      try apply (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_r _ _)));
      try apply ord_ltb_irrefl;
      try apply ord_max_geb_l;
      try apply ord_max_geb_r.
Qed.

Theorem cut_elimination_valid :
    forall (P : ptree),
        valid P ->
            valid (cut_elimination P).
Proof.
intros P PV.
pose (ptree_ord P) as alpha.
pose proof (ptree_ord_nf _ PV) as NA.
induction P;
unfold cut_elimination, cut_elimination_atom, cut_elimination_neg, cut_elimination_lor; fold cut_elimination.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
4-9 : destruct PV as [[[PF PV] PD] PO].
10 :  destruct PV as [[[[PF FC] PV] PD] PO].
11,12 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
13-16 : destruct PV as [[[PF PV] PD] PO].
19-21 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1,2 : apply (IHP PV (ptree_ord_nf _ PV)).

17,18,19 : unfold PA_omega_axiom.
19 :  destruct f0; try case (correct_a a) eqn:Ra;
      unfold contraction_help, ptree_formula;
      try rewrite form_eqb_refl.
18 : destruct f; try case (correct_a a) eqn:Ra.
17 : destruct f0; try case (correct_a a) eqn:Ra.

all : unfold associativity_1', associativity_2';
      try rewrite P1F;
      try rewrite P2F;
      repeat split;
      unfold ptree_ord, ptree_deg, ptree_formula;
      fold ptree_ord ptree_deg ptree_formula;
      try apply dub_neg_valid;
      try apply demorgan1_valid;
      try apply demorgan2_valid;
      try rewrite (formula_sub_ptree_deg_atom _ _ _ P1V);
      try rewrite (formula_sub_ptree_deg_neg _ _ _ P2V);
      try rewrite (dub_neg_ptree_deg _ _ P2V);
      try rewrite (demorgan1_ptree_deg _ _ _ P2V);
      try rewrite (demorgan2_ptree_deg _ _ _ P2V);
      try rewrite (formula_sub_ptree_ord_atom _ _ _ P1V);
      try rewrite (formula_sub_ptree_ord_neg _ _ _ P2V);
      try rewrite (dub_neg_ptree_ord _ _ P2V);
      try rewrite (demorgan1_ptree_ord _ _ _ P2V);
      try rewrite (demorgan2_ptree_ord _ _ _ P2V);
      try rewrite (formula_sub_ptree_formula_atom _ _ _ P1V);
      try rewrite (formula_sub_ptree_formula_neg _ _ _ P2V);
      try rewrite (dub_neg_ptree_formula _ _ P2V);
      try rewrite (demorgan1_ptree_formula _ _ _ P2V);
      try rewrite (demorgan2_ptree_formula _ _ _ P2V);
      try apply PF;
      try apply P1F;
      try apply P2F;
      try rewrite P1F;
      try rewrite P2F;
      unfold dub_neg_sub_formula, demorgan1_sub_formula, demorgan2_sub_formula, formula_sub_ind, num_conn;
      unfold subst_ind_fit; fold subst_ind_fit;
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      try rewrite non_target_fit;
      try rewrite form_eqb_refl;
      unfold "&&";
      try rewrite non_target_sub';
      try apply PV;
      try apply P1V;
      try apply P2V;
      try apply PD;
      try apply P1D;
      try apply P2D;
      try apply PO;
      try apply P1O;
      try apply P2O;
      try apply FC;
      try reflexivity;
      try lia.

10 :  rewrite ord_max_symm;
      reflexivity.

5 : rewrite (ord_max_ltb_not_l _ _ (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_r _ _))));
    reflexivity.

all : try apply (formula_sub_valid_atom _ _ _ P1V Ra);
      try apply (formula_sub_valid_neg _ _ _ P2V Ra);
      pose proof (provable_closed' _ _ P1V P1F) as Cfa;
      pose proof (provable_closed' _ _ P2V P2F) as Cf0a0;
      try destruct (and_bool_prop _ _ Cfa) as [Cf Ca];
      try destruct (and_bool_prop _ _ Cf0a0) as [Ca0 Cf0];
      try apply Cf;
      try apply Cf0;
      try rewrite P1F;
      try rewrite P2F;
      unfold subst_ind_fit;
      fold subst_ind_fit;
      try rewrite non_target_fit;
      try reflexivity.
Qed.

Lemma cut_elim_ord_Zero :
    forall (P : ptree) (A : formula) (d : nat),
        P_proves P A (S d) Zero ->
            provable A d (ord_2_exp Zero).
Proof.
unfold provable, P_proves.
intros P.
induction P;
intros A d [[[PF' PV] PD'] PO'];
unfold ptree_deg, ptree_ord, ptree_formula in *;
fold ptree_deg ptree_ord ptree_formula in *.

1 : destruct PV as [ID PV];
    exists (ord_up (ord_2_exp Zero) P).
3 : exists (ord_up (ord_2_exp Zero) (node f)).

1,3 : repeat split;
      unfold ptree_formula;
      try apply PF';
      try destruct PO';
      try apply zero_lt;
      try apply PV;
      try apply nf_2_exp;
      try apply zero_nf;
      unfold ptree_deg; fold ptree_deg;
      lia.
1 : { destruct PV as [[IO PV] NO].
      destruct PO'.
      exfalso.
      inversion IO. }

7-18 :  try pose proof (ord_succ_neb_zero o) as NZ1;
        try pose proof (ord_succ_neb_zero (ord_max o o0)) as NZ2;
        try pose proof (ord_succ_neb_zero (ord_succ (ord_max o o0))) as NZ3;
        destruct PO';
        inversion NZ1;
        inversion NZ2;
        inversion NZ3.

1-6 : destruct PV as [[[PF PV] PD] PO];
      destruct PF',PO',PD.

1 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (exchange_ab f f0 (ptree_deg P1) (ptree_ord P1) P1).

2 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (exchange_cab f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

3 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (exchange_abd f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

4 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (exchange_cabd f f0 f1 f2 (ptree_deg P1) (ptree_ord P1) P1).

5 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (contraction_a f (ptree_deg P1) (ptree_ord P1) P1).

6 : destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]];
    exists (contraction_ad f f0 (ptree_deg P1) (ptree_ord P1) P1).

all : repeat split;
      try apply P1F;
      try apply P1V;
      try apply P1D;
      apply P1O.
Qed.

Lemma height_zero_not_lor :
    forall (P : ptree),
        valid P ->
            Zero = (ptree_ord P) ->
                forall (A B : formula),
                    (ptree_formula P) <> lor A B.
Proof.
intros P PV PO'.
induction P.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
4-9 : destruct PV as [[[PF PV] PD] PO].
10 :  destruct PV as [[[[PF FC] PV] PD] PO].
11,12 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
13-16 : destruct PV as [[[PF PV] PD] PO].
19-21 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

all : unfold ptree_ord in PO'; fold ptree_ord in PO'.

1 : { apply (IHP PV PO'). }
1 : { destruct PO'.
      inversion IO. }

1 : { intros A B.
      unfold ptree_formula.
      unfold valid, PA_omega_axiom in PV.
      destruct f;
      discriminate. }

7-18 :  try pose proof (ord_succ_neb_zero o) as NZ1;
        try pose proof (ord_succ_neb_zero (ord_max o o0)) as NZ2;
        try pose proof (ord_succ_neb_zero (ord_succ (ord_max o o0))) as NZ3;
        destruct PO';
        inversion NZ1;
        inversion NZ2;
        inversion NZ3.

all : try assert (ptree_formula P = ptree_formula P) as EQ;
      try reflexivity;
      unfold "<>" in *;
      intros A B PF';
      destruct PO';
      try rewrite PF in *;
      refine (IHP PV PO _ _ EQ).
Qed.

Lemma cut_elim_ord_one :
    forall (P : ptree) (A : formula) (d : nat),
        P_proves P A (S d) (cons Zero 0 Zero) ->
            provable A d (ord_2_exp (cons Zero 0 Zero)).
Proof.
unfold provable, P_proves.
intros P.
induction P;
intros A d [[[PF' PV] PD'] PO'];
unfold ptree_deg, ptree_ord, ptree_formula in *;
fold ptree_deg ptree_ord ptree_formula in *.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
4-9 : destruct PV as [[[PF PV] PD] PO].
10 :  destruct PV as [[[[PF FC] PV] PD] PO].
11,12 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
13-16 : destruct PV as [[[PF PV] PD] PO].
18 : destruct (PV czero) as [[[PF PzV] PD] PO].
19-21 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : { exists (ord_up (ord_2_exp (cons Zero 0 Zero)) P).
      repeat split.
      - apply PF'.
      - destruct PO'.
        apply coeff_lt.
        lia.
      - apply PV.
      - apply single_nf.
        apply zero_nf.
      - unfold ptree_deg; fold ptree_deg.
        lia. }

1 : { rewrite <- PO' in *.
      pose proof (ord_lt_one _ IO) as EQ.
      rewrite <- EQ in *.
      unfold P_proves in *.
      destruct (cut_elim_ord_Zero P A _ (PF' , PV , PD' , EQ)) as [P1 [[[P1F P1V] P1D] P1O]].
      exists (ord_up (ord_2_exp (ord_2_exp Zero)) P1).
      repeat split.
      - apply P1F.
      - destruct P1O.
        apply coeff_lt.
        lia.
      - apply P1V.
      - apply single_nf.
        apply zero_nf.
      - unfold ptree_deg; fold ptree_deg.
        lia. }

1 : { inversion PO'. }

9,15,16,18 :  apply ord_succ_one in PO';
              try destruct (ord_max_zero _ _ PO') as [OZ1 OZ2];
              try destruct PO';
              try destruct OZ1,OZ2;
              try pose proof (height_zero_not_lor _ P1V P1O (neg f) f1) as NE1;
              try pose proof (height_zero_not_lor _ P1V P1O f f0) as NE2;
              try pose proof (height_zero_not_lor _ PzV PO (substitution f n (projT1 czero)) f0) as NE3;
              try rewrite P1F in *;
              try rewrite PF in *;
              contradiction.

14 :  { apply ord_succ_one in PO'.
        pose proof (ord_succ_neb_zero (ord_max o o0)) as NE.
        destruct PO'.
        inversion NE. }

8 : { apply ord_succ_one in PO'.
      try destruct (ord_max_zero _ _ PO') as [OZ1 OZ2].
      try destruct OZ1,OZ2.
      assert (S (pred n) >= ptree_deg P1) as IE1. lia.
      destruct (cut_elim_ord_Zero _ _ _ (P1F, P1V, IE1, P1O)) as [P3 [[[P3F P3V] P3D] P3O]].
      assert (S (pred n0) >= ptree_deg P2) as IE2. lia.
      destruct (cut_elim_ord_Zero _ _ _ (P2F, P2V, IE2, P2O)) as [P4 [[[P4F P4V] P4D] P4O]].
      exists (demorgan_ab f f0 (ptree_deg P3) (ptree_deg P4) (ptree_ord P3) (ptree_ord P4) P3 P4).
      repeat split.
      - apply PF'.
      - apply P3F.
      - apply P3V.
      - apply P4F.
      - apply P4V.
      - unfold ptree_deg; fold ptree_deg.
        lia.
      - destruct P3O,P4O.
        reflexivity. }

7-12 : apply ord_succ_one in PO';
      try destruct (ord_max_zero _ _ PO') as [OZ1 OZ2];
      try destruct OZ1,OZ2;
      try rewrite PD,PO in *;
      try destruct (cut_elim_ord_Zero P _ _ (PF, PV, PD', PO')) as [P1 [[[P1F P1V] P1D] P1O]].

1-6 : try destruct PF',PO';
      try rewrite PD in PD';
      destruct (IHP _ _ (PF , PV , PD' , PO)) as [P1 [[[P1F P1V] P1D] P1O]].

12 :  assert (forall c, P_proves (p c) (substitution f n (projT1 c)) (S d) Zero) as IND.

12 :  destruct PO';
      intros c;
      unfold P_proves;
      destruct (PV c) as [[[PF PcV] PD] PO].

1 : exists (exchange_ab f f0 (ptree_deg P1) (ptree_ord P1) P1).

2 : exists (exchange_cab f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

3 : exists (exchange_abd f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

4 : exists (exchange_cabd f f0 f1 f2 (ptree_deg P1) (ptree_ord P1) P1).

5 : exists (contraction_a f (ptree_deg P1) (ptree_ord P1) P1).

6 : exists (contraction_ad f f0 (ptree_deg P1) (ptree_ord P1) P1).

7 : exists (weakening_ad f f0 (ptree_deg P1) (ptree_ord P1) P1).

8 : exists (negation_a f (ptree_deg P1) (ptree_ord P1) P1).

9 : exists (negation_ad f f0 (ptree_deg P1) (ptree_ord P1) P1).

10 : exists (quantification_a f n c (ptree_deg P1) (ptree_ord P1) P1).

11 : exists (quantification_ad f f0 n c (ptree_deg P1) (ptree_ord P1) P1).

13 : exists (w_rule_a f n d (cons Zero 0 Zero) (fun m => projT1(cut_elim_ord_Zero (p m) _ _ (IND m)))).

all : repeat split;
      try destruct (cut_elim_ord_Zero _ _ _ (IND t)) as [P1 [[[P1F P1V] P1D] P1O]];
      try apply PF;
      try apply P1F;
      try apply PV;
      try apply P1V;
      try apply P1D;
      try apply P1O;
      try destruct PF';
      unfold ptree_formula, ptree_ord, ptree_deg;
      fold ptree_formula ptree_ord ptree_deg;
      try destruct P1O;
      try reflexivity;
      try apply FC;
      try lia.
Qed.

(* *)
Definition cut_remove (alpha : ord) : Type :=
    (forall (P : ptree) (A : formula) (d : nat),
        P_proves P A (S d) alpha ->
            provable A d (ord_2_exp alpha)).

Lemma cut_elim_aux0 :
    forall (alpha : ord),
        nf alpha ->
            forall (P : ptree) (A : formula) (d : nat),
                P_proves P A (S d) alpha ->
                    provable A d (ord_2_exp alpha).
Proof.
apply (transfinite_induction cut_remove).
intros alpha NA IND.
unfold cut_remove.
destruct alpha as [| alpha1 n alpha2].

1 : intros P A d PP.
    apply (cut_elim_ord_Zero P _ _ PP).

case (ord_eqb (cons Zero 0 Zero) (cons alpha1 n alpha2)) eqn:EQO.

1 : intros P A d PP.
    apply ord_eqb_eq in EQO.
    destruct EQO.
    apply (cut_elim_ord_one P _ _ PP).

assert (ord_lt (cons Zero 0 Zero) (cons alpha1 n alpha2)) as IEO.
{ destruct (ord_semiconnex (cons Zero 0 Zero) (cons alpha1 n alpha2)) as [O1 | [O1 | O1]].
  - apply O1.
  - inversion O1 as [ | a1h a2h a1c a2c a1t a2t LT O1H O2H | a1h a1c a2c a1t a2t LT O1H O2H | a1h a1c a1t a2t LT O1H O2H ];
    inversion LT.
  - destruct O1.
    inversion EQO. }

assert (forall y : ord, nf y -> ord_lt y (cons alpha1 n alpha2) -> forall (P : ptree) (A : formula) (d : nat), P_proves P A d y -> provable A (pred d) (ord_2_exp y)) as IHP_PRED.
{ intros beta NB LT P A d PP.
  destruct d.
  - unfold pred.
    exists (weak_ord_up P (ord_2_exp beta)).
    unfold weak_ord_up.
    destruct PP as [[[PF PV] PD] PO].
    case (ord_ltb (ptree_ord P) (ord_2_exp beta)) eqn:IE;
    repeat split;
    try apply PF;
    try apply PV;
    try apply PD.
    apply (ord_ltb_lt _ _ IE).
    apply (nf_2_exp _ NB).
    destruct PO.
    destruct (ord_2_exp_fp (beta) NB) as [LTB | EQ].
    + apply ord_lt_ltb in LTB.
      rewrite IE in LTB.
      inversion LTB.
    + rewrite EQ.
      reflexivity.
  - apply (IND _ NB LT P _ _ PP). }

intros P.
induction P;
intros A d PP.

all : destruct PP as [[[PF' PV] PD'] PO'];
      unfold ptree_formula, ptree_deg, ptree_ord in *;
      fold ptree_formula ptree_deg ptree_ord in *;
      unfold cut_remove in IND.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
4-9 : destruct PV as [[[PF PV] PD] PO].
10 :  destruct PV as [[[[PF FC] PV] PD] PO].
11,12 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].
13-16 : destruct PV as [[[PF PV] PD] PO].
17,18 : destruct (PV czero) as [[[PF PzV] PD] PO].
19-21 : destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : apply IHP;
    repeat split.
    apply PF'.
    apply PV.
    lia.
    apply PO'.

1 : destruct PO'.
    assert (ptree_ord P = ptree_ord P) as EQ. reflexivity.
    destruct (IND (ptree_ord P) (ptree_ord_nf _ PV) IO P A d (PF', PV, PD', EQ)) as [P1 [[[P1F P1V] P1D] P1O]].
    exists (ord_up (ord_2_exp (cons alpha1 n alpha2)) P1).
    repeat split.
    apply P1F.
    destruct P1O.
    apply (ord_2_exp_monot _ NO _ (ptree_ord_nf _ PV) IO).
    apply P1V.
    apply (nf_2_exp _ NO).
    unfold ptree_deg; fold ptree_deg.
    lia.

1 : inversion PO'.

1-6 : destruct PO';
      try rewrite PD in *;
      try destruct (IHP _ _ (PF, PV, PD', PO)) as [P1 [[[P1F P1V] P1D] P1O]].

7 : rewrite PD,PO' in *;
    destruct (IND _ (nf_succ_nf _ NA) (ord_succ_monot _) _ _ _ (PF, PV, PD', PO)) as [P1 [[[P1F P1V] P1D] P1O]].

8,9 : assert (S d >= n0) as IE1;
      assert (S d >= n1) as IE2;
      rewrite P1D,P2D,PO' in *;
      try lia;
      destruct (IND _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_max_succ_l _ _) _ _ _ (P1F, P1V, IE1, P1O)) as [P3 [[[P3F P3V] P3D] P3O]];
      destruct (IND _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_max_succ_r _ _) _ _ _ (P2F, P2V, IE2, P2O)) as [P4 [[[P4F P4V] P4D] P4O]].

10-13 : rewrite PD,PO' in *;
        destruct (IND _ (nf_succ_nf _ NA) (ord_succ_monot _) _ _ _ (PF, PV, PD', PO)) as [P1 [[[P1F P1V] P1D] P1O]].

14 :  assert (forall c, P_proves (p c) (substitution f n0 (projT1 c)) (S d) o) as IHP.

14 :  destruct PO';
      intros c;
      unfold P_proves;
      destruct (PV c) as [[[PcF PcV] PcD] PcO].

15 : rewrite PO' in *.

16 : assert (forall m, P_proves (p m) (lor (substitution f n0 (projT1 m)) f0) (S d) o) as IHP.

16 :  destruct PO';
      intros c;
      unfold P_proves;
      destruct (PV c) as [[[PcF PcV] PcD] PcO].

17 : rewrite PO' in *.

1 : exists (exchange_ab f f0 (ptree_deg P1) (ptree_ord P1) P1).

2 : exists (exchange_cab f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

3 : exists (exchange_abd f f0 f1 (ptree_deg P1) (ptree_ord P1) P1).

4 : exists (exchange_cabd f f0 f1 f2 (ptree_deg P1) (ptree_ord P1) P1).

5 : exists (contraction_a f (ptree_deg P1) (ptree_ord P1) P1).

6 : exists (contraction_ad f f0 (ptree_deg P1) (ptree_ord P1) P1).

7 : exists (ord_up (ord_2_exp (ord_succ o)) (weakening_ad f f0 (ptree_deg P1) (ptree_ord P1) P1)).

8 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (demorgan_ab f f0 (ptree_deg P3) (ptree_deg P4) (ord_2_exp o) (ord_2_exp o0) P3 P4)).

9 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (demorgan_abd f f0 f1 (ptree_deg P3) (ptree_deg P4) (ord_2_exp o) (ord_2_exp o0) P3 P4)).

10 : exists (ord_up (ord_2_exp (ord_succ o)) (negation_a f (ptree_deg P1) (ptree_ord P1) P1)).

11 : exists (ord_up (ord_2_exp (ord_succ o)) (negation_ad f f0 (ptree_deg P1) (ptree_ord P1) P1)).

12 : exists (ord_up (ord_2_exp (ord_succ o)) (quantification_a f n0 c (ptree_deg P1) (ptree_ord P1) P1)).

13 : exists (ord_up (ord_2_exp (ord_succ o)) (quantification_ad f f0 n0 c (ptree_deg P1) (ptree_ord P1) P1)).

15 : exists (ord_up (ord_2_exp (ord_succ o)) (w_rule_a f n0 d (ord_2_exp o) (fun m => projT1(IND _ (ptree_ord_nf_hyp _ _ PO PzV) (ord_succ_monot _) (p m) _ _ (IHP m))))).

17 : exists (ord_up (ord_2_exp (ord_succ o)) (w_rule_ad f f0 n0 d (ord_2_exp o) (fun m => projT1(IND _ (ptree_ord_nf_hyp _ _ PO PzV) (ord_succ_monot _) (p m) _ _ (IHP m))))).

all : repeat split;
      try destruct IND as [P1 [[[P1F P1V] P1D] P1O]];
      unfold projT1;
      try apply PcF;
      try apply PF';
      try apply P1F;
      try apply P3F;
      try apply P4F;
      try apply PcV;
      try apply P1V;
      try apply P3V;
      try apply P4V;
      try destruct PF';
      unfold ptree_formula, ptree_ord, ptree_deg;
      fold ptree_formula ptree_ord ptree_deg;
      try lia;
      try apply PcO;
      try apply P1O;
      try apply P3O;
      try apply P4O;
      try apply FC;
      try rewrite <- P1O;
      try apply nf_2_exp;
      try apply NA.

1,4-9 : apply ord_succ_lt_exp_succ;
        try apply (nf_succ_nf _ NA);
        try apply (ord_succ_lt Zero _ IEO).

1,2 : rewrite ord_max_exp_comm;
      try apply ord_succ_lt_exp_succ;
      try apply (ord_succ_lt Zero _ IEO);
      try apply nf_ord_max;
      try apply (ptree_ord_nf_hyp _ _ P1O P1V);
      try apply (ptree_ord_nf_hyp _ _ P2O P2V).

3 : case (nat_eqb (max (max n0 n1) (S (num_conn f0))) (S (num_conn f0))) eqn:E1.
2 : case (nat_eqb (max (max n0 n1) (S (num_conn f))) (S (num_conn f))) eqn:E1.
1 : case (nat_eqb (max (max n0 n1) (S (num_conn f0))) (S (num_conn f0))) eqn:E1.

2,6 : rewrite PO' in *;
      assert (S d >= ptree_deg P1) as IE1;
      assert (S d >= ptree_deg P2) as IE2;
      try lia;
      assert ((S (num_conn f0)) < (max n0 n1)) as E2;
      rewrite nat_eqb_symm in E1;
      try rewrite (nat_eqb_eq _ _ (nat_max_neb_r_eqb_l _ _ E1));
      try apply (max_lem2 _ _ E1);
      destruct (IND _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_max_succ_l _ _) _ _ _ (P1F, P1V, IE1, P1O)) as [T1 [[[T1F T1V] T1D] T1O]];
      destruct (IND _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_max_succ_r _ _) _ _ _ (P2F, P2V, IE2, P2O)) as [T2 [[[T2F T2V] T2D] T2O]].

5 : rewrite PO' in *;
    assert (S d >= ptree_deg P1) as IE1;
    assert (S d >= ptree_deg P2) as IE2;
    try lia;
    assert ((S (num_conn f)) < (max n0 n1)) as E2;
    rewrite nat_eqb_symm in E1;
    try rewrite (nat_eqb_eq _ _ (nat_max_neb_r_eqb_l _ _ E1));
    try apply (max_lem2 _ _ E1);
    destruct (IND _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_trans _ _ _ (ord_lt_max_succ_l _ _) (ord_succ_monot _)) _ _ _ (P1F, P1V, IE1, P1O)) as [T1 [[[T1F T1V] T1D] T1O]];
    destruct (IND _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_trans _ _ _ (ord_lt_max_succ_r _ _) (ord_succ_monot _)) _ _ _ (P2F, P2V, IE2, P2O)) as [T2 [[[T2F T2V] T2D] T2O]].

2 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (cut_ca f f0 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)).

3 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (cut_cad f f0 f1 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)).

5 : exists (ord_up (ord_2_exp (ord_succ (ord_succ (ord_max o o0)))) (cut_ad f f0 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)).

2,3,5 : repeat split;
        unfold ptree_ord, ptree_deg; fold ptree_ord ptree_deg;
        try apply T1F;
        try apply T2F;
        try apply T1V;
        try apply T2V;
        try apply nf_2_exp;
        try apply NA;
        unfold num_conn in *; fold num_conn in *;
        try lia;
        rewrite <- T1O, <- T2O;
        rewrite ord_max_exp_comm;
        try apply ord_succ_lt_exp_succ;
        try apply dub_succ_exp_lt_exp_dub_succ;
        try apply (ord_succ_lt Zero _ IEO);
        try apply nf_ord_max;
        try apply (ptree_ord_nf_hyp _ _ P1O P1V);
        try apply (ptree_ord_nf_hyp _ _ P2O P2V).

1,3 : rewrite PO' in *;
      assert (n0 >= ptree_deg P1) as IE1;
      assert (n1 >= ptree_deg P2) as IE2;
      try lia;
      apply nat_eqb_eq in E1;
      destruct (IHP_PRED _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_max_succ_l _ _) P1 _ _ (P1F, P1V, IE1, P1O)) as [T1 [[[T1F T1V] T1D] T1O]];
      destruct (IHP_PRED _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_max_succ_r _ _) P2 _ _ (P2F, P2V, IE2, P2O)) as [T2 [[[T2F T2V] T2D] T2O]];
      unfold provable;
      destruct f0.

9 : rewrite PO' in *;
    assert (n0 >= ptree_deg P1) as IE1;
    assert (n1 >= ptree_deg P2) as IE2;
    try lia;
    apply nat_eqb_eq in E1;
    destruct (IHP_PRED _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_trans _ _ _ (ord_lt_max_succ_l _ _) (ord_succ_monot _ )) P1 _ _ (P1F, P1V, IE1, P1O)) as [T1 [[[T1F T1V] T1D] T1O]];
    destruct (IHP_PRED _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_trans _ _ _ (ord_lt_max_succ_r _ _) (ord_succ_monot _ )) P2 _ _ (P2F, P2V, IE2, P2O)) as [T2 [[[T2F T2V] T2D] T2O]];
    unfold provable;
    destruct f.

1 : exists (weak_ord_up (cut_elimination (cut_ca f (atom a) (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)) (ord_2_exp (ord_succ (ord_max o o0)))).
2 : exists (weak_ord_up (cut_elimination (cut_ca f (neg f0) (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)) (ord_2_exp (ord_succ (ord_max o o0)))).
3 : exists (weak_ord_up (cut_elimination (cut_ca f (lor f0_1 f0_2) (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)) (ord_2_exp (ord_succ (ord_max o o0)))).

5 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (cut_elimination (cut_cad f (atom a) f1 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2))).
6 : exists (ord_up (ord_2_exp (ord_succ (ord_max o o0))) (cut_elimination (cut_cad f (neg f0) f1 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2))).
7 : exists (weak_ord_up (cut_elimination (cut_cad f (lor f0_1 f0_2) f1 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)) (ord_2_exp (ord_succ (ord_max o o0)))).

9 : exists (ord_up (ord_2_exp (ord_succ (ord_succ (ord_max o o0)))) (cut_elimination (cut_ad (atom a) f0 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2))).
10 : exists (ord_up (ord_2_exp (ord_succ (ord_succ (ord_max o o0)))) (cut_elimination (cut_ad (neg f) f0 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2))).
11 : exists (weak_ord_up (cut_elimination (cut_ad (lor f1 f2) f0 (ptree_deg T1) (ptree_deg T2) (ptree_ord T1) (ptree_ord T2) T1 T2)) (ord_2_exp (ord_succ (ord_succ (ord_max o o0))))).

1-3,5-7,9-11 :  repeat split;
                try rewrite weak_ord_formula;
                try rewrite weak_ord_deg;
                try apply weak_ord_valid;
                unfold ptree_formula, ptree_deg, ptree_ord, valid;
                fold ptree_formula ptree_deg ptree_ord valid;
                try apply cut_elimination_formula;
                try apply cut_elimination_valid;
                try refine (T1F, T1V, T2F, T2V, _, _, _, _);
                try reflexivity;
                try apply dub_neg_valid;
                try rewrite dub_neg_ptree_deg;
                try rewrite dub_neg_ptree_formula;
                try rewrite dub_neg_ptree_ord;
                unfold dub_neg_sub_formula;
                try apply T1V;
                try apply T2V;
                try apply T1O;
                try apply T2O;
                try rewrite T1F;
                try rewrite T2F;
                try rewrite formula_sub_ind_lor;
                try rewrite non_target_sub;
                unfold formula_sub_ind, subst_ind_fit;
                fold subst_ind_fit;
                unfold formula_sub_ind_fit;
                try rewrite non_target_fit;
                try apply nf_2_exp;
                try apply NA;
                unfold cut_elimination, cut_elimination_atom, cut_elimination_neg, cut_elimination_lor, contraction_help, PA_omega_axiom, weak_ord_up;
                unfold ptree_formula; fold ptree_formula;
                try rewrite form_eqb_refl;
                try case (correct_a a) eqn:Ra;
                unfold ptree_deg, ptree_ord; fold ptree_deg ptree_ord;
                try rewrite (formula_sub_ptree_deg_neg _ _ _ T2V);
                try rewrite (formula_sub_ptree_ord_neg _ _ _ T2V);
                try rewrite (formula_sub_ptree_deg_atom _ _ _ T1V);
                try rewrite (formula_sub_ptree_ord_atom _ _ _ T1V);
                try rewrite <- T1O;
                try rewrite <- T2O;
                try rewrite (ord_lt_ltb _ _ (ord_2_exp_monot _ NA _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_max_succ_r _ _)));
                try rewrite (ord_lt_ltb _ _ (ord_2_exp_monot _ NA _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_max_succ_l _ _)));
                try rewrite (ord_max_ltb_not_l _ _ (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_r _ _))));
                unfold ptree_ord; fold ptree_ord;
                unfold num_conn in *; fold num_conn in *;
                try lia;
                try reflexivity;
                try rewrite (ord_max_symm o o0) in *;
                try rewrite (ord_max_symm (ord_2_exp o) _) in *;
                case (ord_ltb (ord_succ (ord_succ (ord_max (ord_2_exp o0) (ord_2_exp o)))) (ord_2_exp (ord_succ (ord_max o0 o)))) eqn:IO1;
                unfold ptree_ord; fold ptree_ord;
                try refine (ord_lt_trans _ _ _ _ (ord_ltb_lt _ _ IO1));
                try rewrite (ord_max_exp_comm _ _ (ptree_ord_nf_hyp _ _ P2O P2V) (ptree_ord_nf_hyp _ _ P1O P1V)) in *;
                try rewrite <- (ord_eqb_eq _ _ (dub_succ_geb_exp_succ_eqb _ (ord_succ_lt Zero _ IEO) (nf_succ_nf _ NA) IO1));
                try apply (ord_lt_trans _ _ _ (ord_succ_monot _) (dub_succ_exp_lt_exp_dub_succ _ (nf_succ_nf _ (nf_succ_nf _ NA))));
                try rewrite (ord_lt_ltb _ _ (dub_succ_exp_lt_exp_dub_succ _ (nf_succ_nf _ (nf_succ_nf _ NA))));
                try rewrite <- (ord_max_exp_comm _ _ (ptree_ord_nf_hyp _ _ P2O P2V) (ptree_ord_nf_hyp _ _ P1O P1V));
                repeat apply ord_lt_succ;
                try rewrite (ord_max_ltb_not_l _ _ (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (ord_lt_max_succ_l _ _))));
                try apply (ord_lt_max_succ_l _ _);
                try apply (ord_lt_max_succ_r _ _);
                try apply ord_succ_monot;
                try apply (ord_2_exp_monot _ NA _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_lt_trans _ _ _ (ord_lt_max_succ_l _ _) (ord_succ_monot _)));
                try apply (ord_2_exp_monot _ NA _ (ptree_ord_nf_hyp _ _ P1O P1V) (ord_lt_trans _ _ _ (ord_lt_max_succ_r _ _) (ord_succ_monot _)));
                try reflexivity.

all : try destruct (and_bool_prop _ _ (provable_closed' _ _ T1V T1F)) as [Cf Cuf];
      try destruct (and_bool_prop _ _ (provable_closed' _ _ T2V T2F)) as [Cuf0 Cf0];
      unfold num_conn in *; fold closed num_conn in *;
      assert (ptree_deg T1 >= ptree_deg T1) as T1DE;
      try lia.

1,2 : assert (max (ptree_deg T1) (ptree_deg T2) < num_conn f0 + 2) as DLT; try lia.

3 : assert (max (ptree_deg T1) (ptree_deg T2) < num_conn f + 2) as DLT; try lia;
    assert (P_proves (weakening_ad f0 (univ n2 f) (ptree_deg T1) (ord_2_exp o) T1) (lor f0 (univ n2 f)) (ptree_deg T1) (ord_succ (ord_2_exp o))) as T3P.

3 : { repeat split.
      apply T1F.
      apply Cf0.
      apply T1V.
      apply T1O.
      unfold ptree_deg. lia. }

1 : pose proof (quantif_ptree_deg _ _ _ _ _ _ _ (T1F, T1V, T1DE, T1O) T2V DLT (1)) as QSD;
    exists (weak_ord_up (quantif_sub_ptree T2 _ _ _ _ _ _ (T1F, T1V, T1DE, T1O) (1)) (ord_2_exp (ord_succ (ord_max o o0)))).

2 : pose proof (quantif_ptree_deg _ _ _ _ _ _ _ (T1F, T1V, T1DE, T1O) T2V DLT (lor_ind (1) (non_target f1))) as QSD;
    exists (weak_ord_up (quantif_sub_ptree T2 _ _ _ _ _ _ (T1F, T1V, T1DE, T1O) (lor_ind (1) (non_target f1))) (ord_2_exp (ord_succ (ord_max o o0)))).

3 : pose proof (quantif_ptree_deg _ _ _ _ _ _ _ T3P T2V DLT (lor_ind (1) (non_target f0))) as QSD;
    exists (weak_ord_up (contraction_a f0 (ptree_deg (quantif_sub_ptree T2 _ _ _ _ _ _ T3P (lor_ind (1) (non_target f0)))) (ord_add (ord_succ (ord_2_exp o)) (ord_2_exp o0)) (weak_ord_up (quantif_sub_ptree T2 _ _ _ _ _ _ T3P (lor_ind (1) (non_target f0))) (ord_add (ord_succ (ord_2_exp o)) (ord_2_exp o0)))) (ord_2_exp (ord_succ (ord_succ (ord_max o o0))))).

all : repeat split;
      try apply weak_ord_valid;
      repeat split;
      try apply weak_ord_valid;
      try apply (quantif_valid _ _ _ _ _ _ _ _ T2V Cf DLT);
      try apply (quantif_valid _ _ _ _ _ _ _ _ T2V Cf0 DLT);
      try rewrite weak_ord_formula;
      try rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ T2V);
      try rewrite T2F;
      unfold quantif_sub_formula;
      unfold formula_sub_ind, subst_ind_fit, formula_sub_ind_fit;
      fold subst_ind_fit formula_sub_ind_fit;
      try rewrite non_target_fit;
      try rewrite non_target_sub';
      try rewrite form_eqb_refl;
      try reflexivity;
      try apply nf_2_exp;
      try apply NA;
      try rewrite weak_ord_deg;
      unfold ptree_deg; fold ptree_deg;
      try lia;
      try rewrite weak_ord_height;
      unfold ptree_ord; fold ptree_ord;
      try reflexivity.

3 : { apply nf_add;
      try apply nf_nf_succ;
      try apply (ptree_ord_nf_hyp _ _ T1O T1V);
      try apply (ptree_ord_nf_hyp _ _ T2O T2V). }

all : try refine (ord_geb_trans _ _ _ _ (quantif_ptree_ord _ _ _ _ _ _ _ _ T2V _));
      try rewrite <- T2O;
      try rewrite ord_ltb_irrefl;
      try apply (exp_succ_lt_add _ _ (ptree_ord_nf_hyp _ _ P1O P1V) (ptree_ord_nf_hyp _ _ P2O P2V));
      try reflexivity.

1 : rewrite <- ord_max_succ_succ.
    apply (ord_geb_trans _ _ _ (exp_succ_lt_add _ _ (nf_nf_succ _ (ptree_ord_nf_hyp _ _ P1O P1V)) (nf_nf_succ _ (ptree_ord_nf_hyp _ _ P2O P2V)))).
    apply (ord_geb_trans _ _ _ (ord_ltb_asymm _ _ (ord_lt_ltb _ _ (add_right_incr _ _ _ (ord_2_exp_monot _ (nf_nf_succ _ (ptree_ord_nf_hyp _ _ P2O P2V)) _ (ptree_ord_nf_hyp _ _ P2O P2V) (ord_succ_monot _)))))).
    apply add_left_weak_monot.
    destruct o.
    apply ord_ltb_irrefl.
    apply ord_ltb_asymm.
    apply ord_lt_ltb.
    apply ord_succ_lt_exp_succ.
    apply (ptree_ord_nf_hyp _ _ P1O P1V).
    apply zero_lt.
Qed.

Lemma cut_elim_aux1 :
    forall (alpha : ord) (P : ptree) (A : formula) (d : nat),
        P_proves P A (S d) alpha ->
            provable A d (ord_2_exp alpha).
Proof.
intros alpha P A d [[[PF' PV] PD'] PO'].
rewrite PO'.
apply (cut_elim_aux0 _ (ptree_ord_nf _ PV) P _ _ (PF', PV, PD', (eq_refl _))).
Qed.

Lemma cut_elim_aux2 :
    forall (A : formula) (d : nat),
        {alpha : ord & provable A d alpha} ->
            {beta : ord & provable A 0 beta}.
Proof.
intros A d aAP.
induction d.
- apply aAP.
- apply IHd.
  destruct aAP as [alpha [P PP]].
  exists (ord_2_exp alpha).
  apply (cut_elim_aux1 _ _ _ _ PP).
Qed.

Theorem cut_elim :
    forall (A : formula) (d : nat) (alpha : ord),
        provable A d alpha ->
            {beta : ord & provable A 0 beta}.
Proof.
intros.
apply (cut_elim_aux2 A d).
exists alpha.
auto.
Qed.


From mathcomp.ssreflect
Require Import ssreflect.

From mathcomp.ssreflect
Require Import ssrnat seq ssrbool.

Theorem one_eq_two : False -> 1 = 2.
Proof.
    case.
Qed.

Theorem one_eq_two' : False -> 1 = 2.
Proof.
    exact: (False_ind (1 = 2)).
Qed.

Theorem one_eq_two'': False -> 1 = 2.
Proof.
    exact: (fun (f : False) => match f with end).
Qed.

Theorem imp_trans: (forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R).
Proof.
    move=> A B C.
    move=> H2 H1.
    move=> a.
    apply: H1.
    apply: H2.
    assumption.
Qed.

Theorem imp_trans': (forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R).
Proof.
    move=> A B C.
    move=> H1 H2 a.
    exact: (H2 (H1 a)).
Qed.

Theorem forall_distrib: (forall P Q : Prop -> Prop, (forall (x: Prop), (P x) -> (Q x)) -> ((forall (y : Prop), (P y)) -> (forall (z: Prop), (Q z)))).
Proof.
    move=> P Q.
    move=> H1.
    move=> H2.
    move=> z.
    apply: H1.
    apply: H2.
Qed.

Theorem imp_trans'' (P Q R : Prop) : (Q -> R) -> (P -> Q) -> P -> R.
Proof.
    move=> H1 H2.
    move=> p.
    apply: H1.
    apply: H2.
    exact: p.
Qed.

Theorem imp_trans''' (P Q R : Prop) : (Q -> R) -> (P -> Q) -> P -> R.
Proof.
    move=> H1 H2.
    move: (imp_trans P Q R)=> H.
    apply: H.
    exact H2.
    exact H1.
Qed.

Goal forall P R : Prop, P -> R -> P /\ R.
Proof.
    move=> P R.
    move=> p r.
    constructor 1; done.
Qed.

Goal forall P Q : Prop, P /\ Q -> Q.
Proof.
    move=> P Q.
    move=> R.
    destruct R as [ p q ].
    done.
Qed.

Goal forall P Q : Prop, P /\ Q -> Q.
Proof.
    move=> P Q.
    case.
    move=> p q.
    done.
Qed.

Goal forall P Q R : Prop, Q -> P \/ Q \/ R.
Proof.
    move=> P Q R.
    move=> q.
    right.
    left.
    done.
Qed.

Goal forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
    move=> P Q.
    move=> p_or_q.
    case p_or_q.
    move=> p.
    right.
    done.
    move=> q.
    left.
    done.
Qed.

Goal forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
    move=> P Q.
    case=> x.
    right; done.
    left; done.
Qed.

Theorem absurd (P Q : Prop) : P -> ~P -> Q.
Proof.
    move=> p H.
    move : (H p).
    apply: False_ind.
Qed.

Theorem contapos (P Q : Prop) : (P -> Q) -> (~Q -> ~P).
Proof.
    move=> H.
    move=> Hq.
    move /H.
    assumption.
Qed.

Theorem ex_imp_ex A (S T : A -> Prop): (exists a: A, S a) -> (forall x: A, S x -> T x) ->
    exists b: A, T b.
Proof.
    case=> a Hs Hst.
    exists a.
    apply: Hst.
    done.
Qed.

Inductive my_ex A (S: A -> Prop) : Prop := my_ex_intro x of S x.

Goal forall A (S : A -> Prop), my_ex A S <-> exists y: A, S y.
Proof.
    move=> A s.
    split.
    case.
    move=> H.
    move=> s_H.
    by exists H.
    move=> H; destruct H as [a s_x].
    move: (my_ex_intro A s a)=> H.
    by apply: H.
Qed.


Require Import Coq.Lists.List.
Require Import Eqdep_dec.
Require Import Peano_dec.

Inductive Vector (A : Set) : nat -> Set :=
  | Vnil : Vector A 0
  | Vcons : forall (a : A) (n : nat), Vector A n -> Vector A (S n).

Fixpoint vector2list (A : Set) (n : nat) (v : Vector A n) {struct v} :
 list A :=
  match v with
  | Vnil => nil (A:=A)
  | Vcons a n v' => a :: vector2list A n v'
  end.

Fixpoint list2vector (A : Set) (l : list A) {struct l} :
 Vector A (length l) :=
  match l return (Vector A (length l)) with
  | nil => Vnil A
  | a :: l' => Vcons A a (length l') (list2vector A l')
  end.

Section VectorSizes.

Let nilVectorHelp (A : Set) (n : nat) (p : n = 0) : Vector A n.
intros.
induction n as [| n Hrecn].
apply Vnil.
discriminate p.
Defined.

Lemma nilVector : forall (A : Set) (x : Vector A 0), Vnil A = x.
Proof.
intro.
replace (Vnil A) with (nilVectorHelp A 0 (refl_equal 0)).
generalize (refl_equal 0).
assert
 (forall (n : nat) (e : n = 0) (x : Vector A n), nilVectorHelp A n e = x).
intros.
induction x as [| a n x Hrecx].
reflexivity.
discriminate e.
apply H.
reflexivity.
Qed.

Let consVectorHelp (A : Set) (n m : nat) (p : n = S m)
  (a : A) (v : Vector A m) : Vector A n.
intros.
destruct n.
discriminate p.
rewrite p.
apply Vcons.
apply a.
apply v.
Defined.

Lemma consVector :
 forall (A : Set) (n : nat) (x : Vector A (S n)),
 {pair : A * Vector A n | Vcons A (fst pair) n (snd pair) = x}.
Proof.
intros.
assert
 {pair : A * Vector A n |
 consVectorHelp A _ _ (refl_equal (S n)) (fst pair) (snd pair) = x}.
generalize (refl_equal (S n)).
assert
 (forall (m : nat) (x : Vector A m) (e : m = S n),
  {pair : A * Vector A n | consVectorHelp A m n e (fst pair) (snd pair) = x}).
intros.
destruct x0 as [| a n0 v].
discriminate e.
generalize e.
inversion e.
generalize v.
rewrite H0.
intros.
exists (a, v0).
simpl in |- *.
unfold eq_rec_r in |- *.
generalize (sym_eq e0).
intro.
elim e1 using K_dec_set.
apply eq_nat_dec.
reflexivity.
apply H.
apply H.
Qed.

End VectorSizes.