Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__angledistinct.
Require Export lemma__collinearorder.
Require Export lemma__equalanglesNC.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__oppositesidesymmetric.
Require Export lemma__planeseparation.
Require Export lemma__ray4.
Require Export lemma__samesidesymmetric.
Require Export lemma__supplements.
Require Export lemma__supplementsymmetric.
Require Export logic.
Require Export proposition__27.
Definition proposition__28B : forall A B C D G H, (euclidean__axioms.BetS A G B) -> ((euclidean__axioms.BetS C H D) -> ((euclidean__defs.RT B G H G H D) -> ((euclidean__defs.OS B D G H) -> (euclidean__defs.Par A B C D)))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro G.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (* Cut *) (euclidean__defs.OS D B G H) as H4.
- assert (* Cut *) ((euclidean__defs.OS D B G H) /\ ((euclidean__defs.OS B D H G) /\ (euclidean__defs.OS D B H G))) as H4.
-- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric G H B D H3).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H5.
- assert (* Cut *) (exists a b c d e, (euclidean__defs.Supp a b c e d) /\ ((euclidean__defs.CongA B G H a b c) /\ (euclidean__defs.CongA G H D e b d))) as H5.
-- assert (exists X Y Z U V, (euclidean__defs.Supp X Y U V Z) /\ ((euclidean__defs.CongA B G H X Y U) /\ (euclidean__defs.CongA G H D V Y Z))) as H5 by exact H2.
assert (exists X Y Z U V, (euclidean__defs.Supp X Y U V Z) /\ ((euclidean__defs.CongA B G H X Y U) /\ (euclidean__defs.CongA G H D V Y Z))) as __TmpHyp by exact H5.
destruct __TmpHyp as [x H6].
destruct H6 as [x0 H7].
destruct H7 as [x1 H8].
destruct H8 as [x2 H9].
destruct H9 as [x3 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exists x.
exists x0.
exists x2.
exists x1.
exists x3.
split.
--- exact H11.
--- split.
---- exact H13.
---- exact H14.
-- destruct H5 as [a H6].
destruct H6 as [b H7].
destruct H7 as [c H8].
destruct H8 as [d H9].
destruct H9 as [e H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
assert (* Cut *) (euclidean__defs.CongA a b c B G H) as H15.
--- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric B G H a b c H13).
--- assert (* Cut *) (euclidean__axioms.neq G H) as H16.
---- assert (* Cut *) ((euclidean__axioms.neq a b) /\ ((euclidean__axioms.neq b c) /\ ((euclidean__axioms.neq a c) /\ ((euclidean__axioms.neq B G) /\ ((euclidean__axioms.neq G H) /\ (euclidean__axioms.neq B H)))))) as H16.
----- apply (@lemma__angledistinct.lemma__angledistinct a b c B G H H15).
----- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H25.
---- assert (* Cut *) (euclidean__defs.CongA e b d G H D) as H17.
----- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric G H D e b d H14).
----- assert (* Cut *) (H = H) as H18.
------ apply (@logic.eq__refl Point H).
------ assert (* Cut *) (euclidean__defs.Out G H H) as H19.
------- apply (@lemma__ray4.lemma__ray4 G H H).
--------right.
left.
exact H18.

-------- exact H16.
------- assert (* Cut *) (euclidean__defs.Supp A G H H B) as H20.
-------- split.
--------- exact H19.
--------- exact H0.
-------- assert (* Cut *) (euclidean__defs.Supp B G H H A) as H21.
--------- apply (@lemma__supplementsymmetric.lemma__supplementsymmetric A G H B H H20).
--------- assert (* Cut *) (euclidean__defs.CongA e b d H G A) as H22.
---------- apply (@lemma__supplements.lemma__supplements a b c e d B G H H A H15 H11 H21).
---------- assert (euclidean__defs.CongA G H D e b d) as H23 by exact H14.
assert (* Cut *) (euclidean__defs.CongA G H D H G A) as H24.
----------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive G H D e b d H G A H23 H22).
----------- assert (* Cut *) (euclidean__axioms.nCol H G A) as H25.
------------ apply (@euclidean__tactics.nCol__notCol H G A).
-------------apply (@euclidean__tactics.nCol__not__Col H G A).
--------------apply (@lemma__equalanglesNC.lemma__equalanglesNC G H D H G A H24).

------------ assert (* Cut *) (euclidean__defs.CongA H G A A G H) as H26.
------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA H G A H25).
------------- assert (* Cut *) (euclidean__defs.CongA G H D A G H) as H27.
-------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive G H D H G A A G H H24 H26).
-------------- assert (* Cut *) (euclidean__defs.CongA A G H G H D) as H28.
--------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric G H D A G H H27).
--------------- assert (* Cut *) (G = G) as H29.
---------------- apply (@logic.eq__refl Point G).
---------------- assert (* Cut *) (euclidean__axioms.Col G H G) as H30.
----------------- right.
left.
exact H29.
----------------- assert (* Cut *) (euclidean__axioms.nCol A G H) as H31.
------------------ apply (@euclidean__tactics.nCol__notCol A G H).
-------------------apply (@euclidean__tactics.nCol__not__Col A G H).
--------------------apply (@lemma__equalanglesNC.lemma__equalanglesNC G H D A G H H27).

------------------ assert (* Cut *) (~(euclidean__axioms.Col G H A)) as H32.
------------------- intro H32.
assert (* Cut *) (euclidean__axioms.Col A G H) as H33.
-------------------- assert (* Cut *) ((euclidean__axioms.Col H G A) /\ ((euclidean__axioms.Col H A G) /\ ((euclidean__axioms.Col A G H) /\ ((euclidean__axioms.Col G A H) /\ (euclidean__axioms.Col A H G))))) as H33.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder G H A H32).
--------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H38.
-------------------- apply (@euclidean__tactics.Col__nCol__False A G H H31 H33).
------------------- assert (* Cut *) (euclidean__axioms.TS A G H B) as H33.
-------------------- exists G.
split.
--------------------- exact H0.
--------------------- split.
---------------------- exact H30.
---------------------- apply (@euclidean__tactics.nCol__notCol G H A H32).
-------------------- assert (* Cut *) (euclidean__axioms.TS B G H A) as H34.
--------------------- apply (@lemma__oppositesidesymmetric.lemma__oppositesidesymmetric G H A B H33).
--------------------- assert (* Cut *) (euclidean__axioms.TS D G H A) as H35.
---------------------- apply (@lemma__planeseparation.lemma__planeseparation G H D B A H4 H34).
---------------------- assert (* Cut *) (euclidean__axioms.TS A G H D) as H36.
----------------------- apply (@lemma__oppositesidesymmetric.lemma__oppositesidesymmetric G H D A H35).
----------------------- assert (* Cut *) (euclidean__defs.Par A B C D) as H37.
------------------------ apply (@proposition__27.proposition__27 A B C D G H H0 H1 H28 H36).
------------------------ exact H37.
Qed.


(**
    TODO
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Require Import TypeTheory.CompCats.DiscreteComprehensionCat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Local Definition D_ob {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_D_ob (C := C).

Local Definition F_ob {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_F_ob (C := C).

Local Definition D_lift_ob {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_D_lift_ob (C := C).

Local Definition D_ob_isaset {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_D_ob_isaset (C := C).

Local Definition D_id {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_D_id (C := C).

Local Definition D_comp {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_D_comp (C := C).

Local Definition F_mor {C : category} :=
  discrete_comprehension_cat_structure_with_default_mor_F_mor (C := C).

Section DiscCompCat_mor.

  Context (C : category).

  Definition DiscCompCatDef_TY
             (DC : discrete_comprehension_cat_structure_with_default_mor C)
    : preShv C.
  Proof.
    set (D_ob := pr1 DC).
    set (D_lift_ob := pr1 (pr2 (pr2 DC))).
    set (D_ob_isaset := pr1 (pr2 (pr2 (pr2 DC)))).
    set (D_id := pr1 (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 DC))))))).
    set (D_comp := pr2 (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 DC))))))).
    simpl in *.
    use tpair.
    - use tpair.
      + intros Γ. use tpair.
        * exact (D_ob Γ).
        * exact (D_ob_isaset Γ).
      + exact D_lift_ob.
    - use make_dirprod.
      + intros Γ. apply funextsec; intros A. apply D_id.
      + intros Γ Γ' Γ'' f g. apply funextsec; intros A.
        apply (D_comp _ _ _ _ _ _ _ _ (idpath _) (idpath _)).
  Defined.

  Definition DiscCompCatDef_mor_data
             (X Y : discrete_comprehension_cat_structure_with_default_mor C)
    : UU
    := ∑ (F_TY : ∏ {Γ : C}, D_ob X Γ → D_ob Y Γ),
       (* ϕ : *) ∏ (Γ : C) (A : D_ob X Γ),
            pr1 (F_ob X Γ A) --> pr1 (F_ob Y Γ (F_TY A)).

  Local Definition F_TY
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    := pr1 mor.

  Local Definition ϕ
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    := pr2 mor.

  Definition DiscCompCatDef_mor_axiom_F_TY
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : UU
    := ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : D_ob X Γ),
       F_TY mor _ (D_lift_ob X _ _ f A) = D_lift_ob Y _ _ f (F_TY mor _ A).

  Definition DiscCompCatDef_mor_axiom_ϕ_dpr
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : UU
    := ∏ (Γ : C) (A : D_ob X Γ),
       ϕ mor Γ A ;; pr2 (F_ob Y Γ (F_TY mor _ A)) = pr2 (F_ob X Γ A).

  Definition F_ob_compare
             {X : discrete_comprehension_cat_structure_with_default_mor C}
             {Γ : C} {A A' : D_ob X Γ} (e : A = A')
    : z_iso (pr1 (F_ob X Γ A)) (pr1 (F_ob X Γ A')).
  Proof.
    apply idtoiso, maponpaths, maponpaths, e.
  Defined.

  Lemma F_ob_compare_id {X : discrete_comprehension_cat_structure_with_default_mor C}
        {Γ : C} (A : D_ob X Γ)
    : F_ob_compare (idpath A) = identity_z_iso (pr1 (F_ob X Γ A)).
  Proof.
    apply idpath.
  Qed.

  Lemma F_ob_compare_id_general {X : discrete_comprehension_cat_structure_with_default_mor C}
        {Γ : C} {A : D_ob X Γ}
        (e : A = A)
    : F_ob_compare e = identity_z_iso (pr1 (F_ob X Γ A)).
  Proof.
    apply @pathscomp0 with (F_ob_compare (idpath _)).
    apply maponpaths, D_ob_isaset.
    apply idpath.
  Qed.

  Lemma F_ob_compare_comp {X : discrete_comprehension_cat_structure_with_default_mor C}
        {Γ : C} {A A' A'' : D_ob X Γ} (e : A = A') (e' : A' = A'')
    : pr1 (F_ob_compare (e @ e')) = F_ob_compare e ;; F_ob_compare e'.
  Proof.
    etrans. 2: { apply idtoiso_concat_pr. }
    unfold F_ob_compare. apply maponpaths, maponpaths.
    etrans. 2: apply maponpathscomp0.
    apply maponpaths.
    apply maponpathscomp0.
  Qed.

  Lemma F_ob_compare_comp_general {X : discrete_comprehension_cat_structure_with_default_mor C}
        {Γ : C} {A A' A'' : D_ob X Γ}
        (e : A = A') (e' : A' = A'') (e'' : A = A'')
    : pr1 (F_ob_compare e'') = F_ob_compare e ;; F_ob_compare e'.
  Proof.
    refine (_ @ F_ob_compare_comp _ _).
    apply maponpaths, maponpaths, D_ob_isaset.
  Qed.

  Definition Δ
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
             (F_TY_ax : DiscCompCatDef_mor_axiom_F_TY mor)
    : ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : D_ob X Γ),
      C ⟦ pr1 (F_ob Y Γ' (F_TY mor Γ' (D_lift_ob X Γ Γ' f A))),
          pr1 (F_ob Y Γ' (D_lift_ob Y Γ Γ' f (F_TY mor Γ A))) ⟧.
  Proof.
    intros Γ A Γ' f.
    use F_ob_compare.
    apply F_TY_ax.
  Defined.

  Lemma Δ_ϕ
        {X Y : discrete_comprehension_cat_structure_with_default_mor C}
        (G : DiscCompCatDef_mor_data X Y)
        {Γ : C} {A A' : D_ob X Γ}
        (e : A = A')
    : F_ob_compare e ;; ϕ G Γ A' = ϕ G Γ A ;; F_ob_compare (maponpaths (F_TY G _) e).
  Proof.
    destruct e; simpl. etrans. apply id_left. apply pathsinv0, id_right.
  Defined.

  Definition DiscCompCatDef_mor_axiom_ϕ_qq
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
             (F_TY_ax : DiscCompCatDef_mor_axiom_F_TY mor)
    : UU
    := ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : D_ob X Γ),
       pr1 (F_mor X Γ' Γ (D_lift_ob X _ _ f A) A f (idpath _)) ;; ϕ mor Γ A =
       ϕ mor Γ' (D_lift_ob X _ _ f A) ;; Δ mor F_TY_ax Γ Γ' f A ;; pr1 (F_mor Y Γ' Γ (D_lift_ob Y _ _ f (F_TY mor _ A)) (F_TY mor _ A) f (idpath _))
  .

  Definition DiscCompCatDef_mor_axioms
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : UU
    := ∑ (F_TY_ax : DiscCompCatDef_mor_axiom_F_TY mor)
        (ϕ_dpr_ax : DiscCompCatDef_mor_axiom_ϕ_dpr mor),
      (* ϕ_qq_ax : *) DiscCompCatDef_mor_axiom_ϕ_qq mor F_TY_ax.

  Definition isaprop_DiscCompCatDef_mor_axiom_F_TY
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : isaprop (DiscCompCatDef_mor_axiom_F_TY mor).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply D_ob_isaset.
  Qed.

  Definition isaprop_DiscCompCatDef_mor_axiom_ϕ_dpr
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : isaprop (DiscCompCatDef_mor_axiom_ϕ_dpr mor).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply homset_property.
  Qed.

  Definition isaprop_DiscCompCatDef_mor_axiom_ϕ_qq
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
             (F_TY_ax : DiscCompCatDef_mor_axiom_F_TY mor)
    : isaprop (DiscCompCatDef_mor_axiom_ϕ_qq mor F_TY_ax).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply homset_property.
  Qed.

  Definition isaprop_DiscCompCatDef_mor_axioms
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor_data X Y)
    : isaprop (DiscCompCatDef_mor_axioms mor).
  Proof.
    apply Propositions.isaproptotal2.
    - intros ?. apply isapropdirprod.
      + apply isaprop_DiscCompCatDef_mor_axiom_ϕ_dpr.
      + apply isaprop_DiscCompCatDef_mor_axiom_ϕ_qq.
    - intros. apply isaprop_DiscCompCatDef_mor_axiom_F_TY.
  Qed.

  Definition DiscCompCatDef_mor
             (X Y : discrete_comprehension_cat_structure_with_default_mor C)
    : UU
    := ∑ (mor : DiscCompCatDef_mor_data X Y), DiscCompCatDef_mor_axioms mor.

  Definition DiscCompCatDef_mor_to_mor_data
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (mor : DiscCompCatDef_mor X Y)
    : DiscCompCatDef_mor_data X Y
    := pr1 mor.

  Coercion DiscCompCatDef_mor_to_mor_data : DiscCompCatDef_mor >-> DiscCompCatDef_mor_data.

  Definition DiscCompCatDef_mor_eq
             {X Y : discrete_comprehension_cat_structure_with_default_mor C}
             (F G : DiscCompCatDef_mor X Y)
             (F_TY_eq : ∏ Γ (A : D_ob X Γ), F_TY F _ A = F_TY G _ A)
             (ϕ_eq : ∏ Γ (A : D_ob X Γ),
                     ϕ F _ A ;; F_ob_compare (F_TY_eq Γ A) = ϕ G _ A)
    : F = G.
  Proof.
    use total2_paths_f. 2: apply isaprop_DiscCompCatDef_mor_axioms.
    use total2_paths_f.
    - repeat (apply funextsec; intros ?). apply F_TY_eq.
    - etrans. use transportf_forall.
      apply funextsec; intros Γ.
      etrans. use transportf_forall.
      apply funextsec; intros A.
      refine (_ @ ϕ_eq Γ A).
      etrans. apply (functtransportf
                       (λ x, x Γ A)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), pr1 (F_ob Y Γ y) ⟧)).
      etrans. apply (functtransportf
                       (λ x, F_ob Y Γ x)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), pr1 y ⟧)).
      etrans. apply (functtransportf
                       (λ x, pr1 x)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), y ⟧)).
      etrans. apply pathsinv0, idtoiso_postcompose.
      apply maponpaths.
      unfold F_ob_compare.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply D_ob_isaset.
  Defined.

  Definition DiscCompCatDef_precat_ob_mor
    : precategory_ob_mor
    := (_ ,, DiscCompCatDef_mor).

  Definition DiscCompCatDef_mor_id_data
             (X : discrete_comprehension_cat_structure_with_default_mor C)
    : DiscCompCatDef_mor_data X X.
  Proof.
    use tpair.
    + intros Γ. apply idfun.
    + intros Γ A. apply identity.
  Defined.

  Definition DiscCompCatDef_mor_id_axioms
             (X : discrete_comprehension_cat_structure_with_default_mor C)
    : DiscCompCatDef_mor_axioms (DiscCompCatDef_mor_id_data X).
  Proof.
    use tpair. 2: use make_dirprod.
    + intros Γ Γ' f A. apply idpath.
    + intros Γ A. apply id_left.
    + intros Γ Γ' f A.
      etrans. apply id_right.
      apply pathsinv0.
      etrans. apply assoc'.
      etrans. apply id_left.
      apply id_left.
  Qed.

  Definition DiscCompCatDef_mor_id
             (X : discrete_comprehension_cat_structure_with_default_mor C)
    : DiscCompCatDef_mor X X
    := (_ ,, DiscCompCatDef_mor_id_axioms X).

  Definition DiscCompCatDef_mor_comp_data
             (X Y Z : discrete_comprehension_cat_structure_with_default_mor C)
             (F : DiscCompCatDef_mor_data X Y)
             (G : DiscCompCatDef_mor_data Y Z)
    : DiscCompCatDef_mor_data X Z.
  Proof.
    use tpair.
    + intros Γ A. apply (F_TY G _ (F_TY F _ A)).
    + intros Γ A. apply (ϕ F _ _ ;; ϕ G _ _).
  Defined.

  Definition DiscCompCatDef_mor_comp_axioms
             (X Y Z : discrete_comprehension_cat_structure_with_default_mor C)
             (F : DiscCompCatDef_mor X Y)
             (G : DiscCompCatDef_mor Y Z)
    : DiscCompCatDef_mor_axioms (DiscCompCatDef_mor_comp_data X Y Z F G).
  Proof.
    use tpair. 2: use make_dirprod.
    + intros Γ Γ' f A. cbn.
      etrans. apply maponpaths.
      apply (pr1 (pr2 F)).
      apply (pr1 (pr2 G)).
    + intros Γ A. cbn.
      etrans. apply assoc'.
      etrans. apply maponpaths.
      apply (pr1 (pr2 (pr2 G))).
      apply (pr1 (pr2 (pr2 F))).
    + intros Γ Γ' f A. cbn.
      etrans. apply assoc.
      etrans. apply maponpaths_2.
      apply (pr2 (pr2 (pr2 F))).
      etrans. apply assoc'.
      etrans. apply maponpaths.
      apply (pr2 (pr2 (pr2 G))).
      etrans. apply assoc.
      apply maponpaths_2.
      etrans. apply assoc'.
      etrans. 2: apply assoc.
      apply maponpaths.

      etrans. apply assoc.
      etrans. apply maponpaths_2, Δ_ϕ.
      etrans. apply assoc'.

      apply maponpaths.
      apply pathsinv0.
      apply F_ob_compare_comp_general.
  Qed.

  Definition DiscCompCatDef_mor_comp
             (X Y Z : discrete_comprehension_cat_structure_with_default_mor C)
             (F : DiscCompCatDef_mor X Y)
             (G : DiscCompCatDef_mor Y Z)
    : DiscCompCatDef_mor X Z
    := (_ ,, DiscCompCatDef_mor_comp_axioms X Y Z F G).

  Definition DiscCompCatDef_precat_id_comp
    : precategory_id_comp (DiscCompCatDef_precat_ob_mor)
    := (DiscCompCatDef_mor_id , DiscCompCatDef_mor_comp).

  Definition DiscCompCatDef_precat_data
    : precategory_data
    := (_ ,, DiscCompCatDef_precat_id_comp).

  Definition DiscCompCatDef_precat_id_left
             (X Y : DiscCompCatDef_precat_data)
             (F : DiscCompCatDef_precat_data ⟦ X, Y ⟧)
    : identity X ;; F = F.
  Proof.
    use DiscCompCatDef_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply id_left.
  Qed.

  Definition DiscCompCatDef_precat_id_right
             (X Y : DiscCompCatDef_precat_data)
             (F : DiscCompCatDef_precat_data ⟦ X, Y ⟧)
    : F ;; identity Y = F.
  Proof.
    use DiscCompCatDef_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply id_right.
  Qed.

  Definition DiscCompCatDef_precat_assoc
             (X Y Z W : DiscCompCatDef_precat_data)
             (F : DiscCompCatDef_precat_data ⟦ X, Y ⟧)
             (G : DiscCompCatDef_precat_data ⟦ Y, Z ⟧)
             (H : DiscCompCatDef_precat_data ⟦ Z, W ⟧)
    : F ;; (G ;; H) = (F ;; G) ;; H.
  Proof.
    use DiscCompCatDef_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply assoc.
  Qed.

  Definition DiscCompCatDef_precat_assoc'
             (X Y Z W : DiscCompCatDef_precat_data)
             (F : DiscCompCatDef_precat_data ⟦ X, Y ⟧)
             (G : DiscCompCatDef_precat_data ⟦ Y, Z ⟧)
             (H : DiscCompCatDef_precat_data ⟦ Z, W ⟧)
    : (F ;; G) ;; H = F ;; (G ;; H).
  Proof.
    use DiscCompCatDef_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply assoc'.
  Qed.

  Definition DiscCompCatDef_precat_axioms
    : is_precategory DiscCompCatDef_precat_data.
  Proof.
    use make_is_precategory.
    - apply DiscCompCatDef_precat_id_left.
    - apply DiscCompCatDef_precat_id_right.
    - apply DiscCompCatDef_precat_assoc.
    - apply DiscCompCatDef_precat_assoc'.
  Qed.

  Definition DiscCompCatDef_precat : precategory
    := (_ ,, DiscCompCatDef_precat_axioms).

  Definition DiscCompCatDef_precat_has_homsets
    : has_homsets DiscCompCatDef_precat.
  Proof.
    intros X Y.
    apply isaset_total2. 2: intros ?; apply isasetaprop, isaprop_DiscCompCatDef_mor_axioms.
    - apply isaset_total2.
      + repeat (apply impred_isaset; intros ?).
        apply D_ob_isaset.
      + intros ?.
        repeat (apply impred_isaset; intros ?).
        apply homset_property.
  Defined.

  Definition DiscCompCatDef_cat : category
    := (DiscCompCatDef_precat ,, DiscCompCatDef_precat_has_homsets).

End DiscCompCat_mor.


(* Formalisation of Guarded Recursive Types using the cbn forcing translation in Template Coq
   with the ordered set of natural numbers as forcing conditions *)

Require Import Template.monad_utils Template.Ast
        Template.Template Template.LiftSubst.
Require Import String PeanoNat.
Require Import Forcing.TemplateForcing.

(* Some axioms *)
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Open Scope string.

Definition Obj : Type := nat.
Definition Hom : Obj -> Obj -> Prop := fun n m => m <= n.

(** Yoneda embedding  *)
Definition Ynat_obj := nat.
Definition Ynat_hom := (fun (P Q : Ynat_obj) => forall R, Hom Q R -> Hom P R).
Definition Yid_nat_hom (P : Ynat_obj) := (fun (R : Ynat_obj) (k : Hom P R) => k).
Definition Ynat_comp (P Q R : Ynat_obj) (g : Ynat_hom Q R) (f : Ynat_hom P Q)
  := (fun (S : Ynat_obj) (k : Hom R S) => f S (g S k)).

Notation "P ≤ Q" := (Ynat_hom P Q) (at level 70).
Notation "#" := Yid_nat_hom.
Notation "f ∘ g" := (fun (R : Ynat_obj) (k : Hom _ R) => f R (g R k)) (at level 40).

(* Now, laws hold definitionally *)
Lemma nat_cat_left_id P R (g : R ≤ P)  : (# R) ∘ g = g.
Proof. reflexivity. Qed.

Lemma nat_cat_right_id P R (f : P ≤ R)  : f ∘ (# R) = f.
Proof. reflexivity. Qed.

Lemma nat_cat_assoc P Q R S (f : P ≤ Q) (g : Q ≤ R) (h : R ≤ S):
  f ∘ (g ∘ h) = (f ∘ g) ∘ h.
Proof. reflexivity. Qed.

Definition Ynat_cat : category :=
  makeCat "Ynat_obj" "Ynat_hom" "Yid_nat_hom" "Ynat_comp".

(* Translating Type *)

Quote Definition qType := Type.

Definition tr_Type_syn := Eval compute in translate_simple true Ynat_cat qType.

(* A translation of Type from the forcing plugin *)
Definition tpᶠ : forall p p0 : Ynat_obj, p ≤ p0 -> Type
  := fun (p p0 : Ynat_obj) (_ : p ≤ p0) => forall p1 : Ynat_obj, p0 ≤ p1 -> Type.

(* Unqouting the syntax for the translated Type *)
Make Definition unqType := Eval compute in tr_Type_syn.

Lemma unqType_forcing_plugin_eq : unqType = tpᶠ.
Proof. reflexivity. Qed.

(* Lemmas from the the implementation of guarded recursive types using
the forcing transalation plugin. *)

Lemma Yle_to_le : forall n m, n ≤ m -> m <= n.
Proof.
  intros n m H.
  unfold Hom in H.
  eapply H.
  eapply le_n.
Qed.

Lemma le_to_Yle : forall n m, n <= m -> m ≤ n.
Proof.
unfold Hom.
intros n m H R H'.
refine (Nat.le_trans _ n _ _ _); tauto.
Qed.

Lemma Yle_Sn_0 : forall n, 0 ≤ S n -> False.
Proof.
  unfold Hom;
  intros n H.
  specialize (H (S n) (le_n (S n))).
  inversion H.
Qed.

Definition Yle_S' m : S m ≤ m.
Proof.
  eapply le_to_Yle.
  eapply le_S.
  eapply le_n.
Defined.

Definition Ynat_irr p q (α α' : p ≤ q): α = α'.
Proof.
  unfold Hom in α,α'.
  apply (functional_extensionality_dep α α').
  intro r.
  apply (functional_extensionality_dep (α r) (α' r)).
  intro α''.
  apply ProofIrrelevance.proof_irrelevance.
Defined.

(* The definition of [later] operator *)

Quote Definition qTypeConstr := (Type -> Type).

Definition tr_TypeConstr_syn := Eval compute in translate_type_simple true Ynat_cat qTypeConstr.

Make Definition gArrowTypeType := Eval compute in tr_TypeConstr_syn.

Definition later : gArrowTypeType.
Proof.
  unfold gArrowTypeType.
  intros p T q f.
  destruct q.
  exact unit.
  exact (T q (f ∘ (Yle_S' q)) q (# _)).
Defined.

Notation "⊳ A" := (later A) (at level 40).


Require Import Undecidability.Axioms.EA.
Require Import Undecidability.Shared.Pigeonhole.
Require Import Undecidability.Synthetic.FinitenessFacts.
Require Import Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Import Undecidability.Synthetic.DecidabilityFacts.
Require Import Undecidability.Shared.ListAutomation.
Require Import List Arith.

Import ListNotations ListAutomationNotations.

Definition majorizes (f: nat -> nat) (p: nat -> Prop): Prop
  := forall n, ~~ exists L, length L = n /\ NoDup L /\
               forall x, In x L -> x <= f n /\ p x.

Definition exceeds f (p : nat -> Prop) :=
  forall n, ~~ exists i, n < i <= f n /\ p i.

Lemma exceeds_majorizes f p :
  exceeds f p -> majorizes (fun n => Nat.iter n f 0) p.
Proof.
  intros He n. induction n.
  - cprove exists []. repeat split.
    + econstructor.
    + inversion H.
    + inversion H.
  - cunwrap. destruct IHn as (l & <- & IH1 & IH2).
    specialize (He (Nat.iter (length l) f 0)). cunwrap.
    destruct He as (i & [H1 H2] & H3).
    cprove exists (i :: l).
    split; [ | split].
    + reflexivity.
    + econstructor. intros [] % IH2. 2:eauto. lia.
    + intros m [-> | [H4 H5] % IH2]; split; eauto.
      rewrite numbers.Nat_iter_S in *. lia.
Qed.

Lemma dedekind_infinite_exceeds (p q : nat -> Prop) :
  (forall x, q x -> p x) -> dedekind_infinite q -> exists f, exceeds f p.
Proof.
  intros Hq [F] % dedekind_infinite_spec. 2: exact _.
  exists (fun n => proj1_sig (F (seq 0 (S n)))).
  intros n. destruct F as [i [Hi1 Hi2]]; cbn.
  cprove exists i; repeat split; eauto.
  destruct (lt_dec n i); eauto.
  destruct Hi1. eapply in_seq. split. lia. cbn. lia.
Qed.

Definition ttId := EA.TT.

Lemma IsFilter_NoDup {X} l l' (p : X -> Prop) :
  IsFilter p l l' -> NoDup l -> NoDup l'.
Proof.
  induction 1; inversion 1; subst.
  - eauto.
  - econstructor. eapply IsFilter_spec in H as (? & ? & ?).  firstorder. eauto.
  - eauto.
Qed.

From Undecidability.Shared.Libs.PSL Require Import Power EqDec.

Definition gen (n : nat) : list (list nat) := power (seq 0 (S n)).

Lemma dupfree_Nodup {X} (A : list X) :
  Dupfree.dupfree A <-> NoDup A.
Proof.
  induction A;split;intros H;inv H;repeat econstructor;tauto.
Qed.

Lemma dupfree_rep {X : eqType} (A : list X) U : Dupfree.dupfree U -> Dupfree.dupfree (rep A U).
Proof.
  induction 1.
  - cbn. econstructor.
  - cbn. destruct Dec; cbn.
    + econstructor. intros ? % in_filter_iff. 1:firstorder.
      exact IHdupfree.
    + exact IHdupfree.
Qed.

Lemma gen_spec' n l : NoDup l -> list_max l <= n -> exists l', NoDup l' /\ (forall z, In z l <-> In z l') /\ In l' (gen n).
Proof.
  intros H1 % dupfree_Nodup H2.
  exists (@rep (EqDec.EqType nat) l (seq 0 (S n))). split; [ | split].
  - eapply dupfree_Nodup, dupfree_rep, dupfree_Nodup, seq_NoDup.
  - intros z. rewrite rep_equi. reflexivity. intros x Hx.
    eapply list_max_le, Forall_forall in H2. eapply in_seq. 2:eauto. cbn. lia.
  - eapply (@rep_power (EqDec.EqType nat)).
Qed.

Lemma power_length {X : eqType} (l : list X) : length (power l) = 2 ^ (length l).
Proof.
  induction l; cbn.
  - reflexivity.
  - rewrite app_length, map_length, <- IHl. lia.
Qed.

Lemma gen_length n : length (gen n) = 2 ^ (S n).
Proof.
  unfold gen.
  now rewrite power_length, seq_length.
Qed.

Definition star_of p n := (fun z => (~~ p z /\ z <= n) \/ z > n).

Lemma star_of_nnex n p : (* listable until *)
  ~~ exists i, i < 2^(S n) /\ forall z, ~ In z (nth i (gen n) []) <-> star_of p n z.
Proof.
  enough (~~ exists l, list_max l <= n /\ NoDup l /\ forall z, ~ In z l <-> star_of p n z).
  - cunwrap. destruct H as (l & H1 & H2 & H3).
    epose proof (@gen_spec' n l) as H.
    specialize (H ltac:(firstorder) ltac:(firstorder)) as (l' & H4 & H5 & H6).
    eapply In_nth in H6 as (i & ? & ?).
    cprove exists i. split. rewrite <- gen_length. eauto.
    rewrite H0. setoid_rewrite <- H5. eassumption.
  - pose proof (IsFilter_nnex (seq 0 (S n)) (compl p)). cunwrap.
    destruct H as (l' & Hf). pose proof Hf as (H1 & H2 & H3) % IsFilter_spec.
    cprove exists l'. split. 2:split.
    + eapply list_max_le, Forall_forall. intros ? [? % in_seq _] % H3. lia.
    + eapply IsFilter_NoDup; eauto. eapply seq_NoDup.
    + intros. rewrite H3. unfold star_of. rewrite in_seq. split.
      * intros ?. assert (z <= n \/ z > n) as [Hz | Hz] by lia.
        -- left. split; eauto. intros Hp. eapply H. split. cbn. lia. eauto.
        -- right. eauto.
      * intros [[] | ] [ ]. tauto. lia.
Qed.

(* instead: listable quantification *)
Lemma finite_quant_DN n m (p : nat -> Prop) : (forall i, n < i <= m -> ~~ p i) -> ~~ (forall i, n < i <= m -> p i).
Proof.
  assert (n < m \/ m <= n) as [Hnm | ] by lia. 2:{ intros. cprove intros. lia. }
  intros H. induction m in n, Hnm, H |- *.
  - cprove intros. lia.
  - ccase (p (S m)) as [Hp | Hp].
    + assert (n = m \/ n < m) as [] by lia.
      * subst. cprove intros. assert (i = S m) as ->  by lia. eauto.
      * intros ?. eapply IHm.
        -- eassumption.
        -- intros. destruct (Nat.eqb_spec i (S m)); subst. eauto. eapply H. lia.
        -- intros IH. eapply H1. intros. destruct (Nat.eqb_spec i (S m)); subst. eauto. eapply IH. lia.
    + exfalso. eapply H. 2: eauto. lia.
Qed.

Lemma nnex_forall_class n m p :
  ~~ (exists i, n < i <= m /\ ~ p i) <-> ~ forall i, n < i <= m -> p i.
Proof.
  split.
  - intros H Hi. apply H. intros (i & ? & ?). eauto.
  - intros H Hi. apply finite_quant_DN in H. apply H. intros ? ? ?.
    apply Hi. eauto.
Qed.

Notation "p ⊨ QT" := (forall L, Forall2 reflects L (map p (projT1 QT)) -> eval_tt (projT2 QT) L = true) (at level 50).
Notation "l ⊫ QT" := (eval_tt QT l = true) (at level 50).

Lemma list_reflects L : ~~ exists l, Forall2 reflects l L.
Proof.
  induction L as [ | P L].
  - cprove exists []. econstructor.
  - cunwrap. destruct IHL as (l & IH).
    ccase P as [H | H].
    + cprove exists (true :: l). econstructor; firstorder.
    + cprove exists (false :: l). econstructor; firstorder.
Qed.

Lemma reflects_ext b1 b2 p q : reflects b1 p -> reflects b2 q -> p <-> q -> b1 = b2.
Proof.
  destruct b1, b2; firstorder congruence.
Qed.

Lemma list_max_in x l : In x l -> x <= list_max l.
Proof.
  induction l; cbn.
  - firstorder.
  - intros [-> | ]. lia. eapply IHl in H. unfold list_max in H. lia.
Qed.

Theorem tt_complete_exceeds p :
  K0 ⪯ₜₜ p -> exists f, exceeds f (compl p).
Proof.
  intros [g Hg].
  destruct (ttId g) as [c Hc].
  pose (a n i := c (nth i (gen n) [])).
  exists (fun n => 1 + list_max (concat [ projT1 (g (a n i)) | i ∈ seq 0 (2^(S n))])).
  intros n. eapply nnex_forall_class. intros H.
  eapply (@star_of_nnex n p). intros (i & Hi1 & Hi2).
  assert (forall j, n < j /\ In j (projT1 (g (a n i))) -> p j). {
    intros j (H1 & H2). eapply H. split.
    - lia.
    - match goal with [ |- _ <= 1 + ?J] => enough (j <= J) by lia end.
      eapply list_max_in. eapply in_concat_iff. eexists. split. eassumption.
      eapply in_map_iff. exists i. split. eauto. eapply in_seq. lia.
   }
   assert (forall x, In x (projT1 (g (a n i))) -> ~~ p x <-> star_of p n x). {
     intros x Hx.
     assert (x <= n \/ n < x) as [HH | HH] by lia.
    - unfold star_of. split. intros ?. left. eauto. intros [[]|]. eauto. lia.
    - unfold star_of. split; eauto.
   } red in Hg. unfold reflects in Hg.
   apply (@list_reflects (map p (projT1 (g (a n i))))).
   intros (lp & Hlp).
   pose proof (Hg _ _ Hlp) as H2.
   enough (lp ⊫ projT2 (g (a n i)) <-> ~ lp ⊫ projT2 (g (a n i))) by tauto.
   rewrite <- H2 at 1.
   unfold K0.
   unfold a at 1.
   rewrite Hc. fold (a n i).
   rewrite <- Bool.not_true_iff_false.
   unfold not.
   match goal with [ |- (?l1 ⊫ _ -> False) <-> (?l2 ⊫ _ -> False)] => enough (l1 = l2) by now subst end.
   clear - Hlp H1 Hi2.
   revert H1 Hlp Hi2. generalize (projT1 (g (a n i))) as L. clear.
   induction lp; intros L Hpstar Hlp Hlist; cbn -[nth].
   - destruct L; inv Hlp. reflexivity.
   - destruct L; inv Hlp. cbn -[nth].
     f_equal.
     + specialize (Hpstar n0 ltac:(firstorder)). rewrite <- Hlist in Hpstar.
       eapply reflects_ext. eapply decider_complement. 2: eapply H2.
       intros l.
       eapply (inb_spec _ (uncurry Nat.eqb) (decider_eq_nat) (n0 , l)).
       unfold reflects in H2. rewrite H2 in *. rewrite Bool.not_true_iff_false, Bool.not_false_iff_true in Hpstar.
       symmetry. eapply Hpstar.
     + eapply IHlp. intros. eapply Hpstar. eauto. eauto. eauto.
Qed.

(* Check tt_complete_exceeds. *)
(* Print Assumptions tt_complete_exceeds. *)

(** Output:

<<
tt_complete_exceeds
	 : forall (ax : CT) (p : nat -> Prop),
       K0 (CT_to_EA ax) ⪯ₜₜ p -> exists f : nat -> nat, exceeds f (compl p)
Axioms:
ttId
  : forall (model : model_of_computation) (ax : CT)
	  (f : nat -> {_ : list nat & truthtable}),
    exists c : list nat -> nat,
      forall (l : list nat) (x : nat),
      W (CT_to_EA ax) (c l) x <->
      eval_tt (projT2 (f x))
        [negb (inb (uncurry Nat.eqb) x0 l) | x0 ∈ projT1 (f x)] = false
star_of_nnex
  : forall model : model_of_computation,
    CT ->
    forall (n : nat) (p : nat -> Prop),
    ~
    ~
    (exists i : nat,
       i < 2 ^ n /\
       (forall z : nat, ~ z el nth i (gen n) [] <-> star_of p n z))
>>
*)


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import QArith.
Require Import QOrderedType.
Require Import ZArith.
Require Import List.
Require Import Psatz.

Require Import Misc.
Require Import Linalg.
Require Import Canonizer.
Require Import Heuristics.

Require Import Vpl.Impure.

Open Scope Z_scope.

(** * Projection of a polyhedron on a given variable *)

Definition isExactProjection n pol proj :=
  forall p s, 0 < s -> in_poly p (expand_poly s proj) = true <->
                 exists t k, 0 < t /\ in_poly (assign n k (mult_vector t p)) (expand_poly (s * t) pol) = true.

Definition isExactProjection1 n pol proj :=
  forall p, in_poly p proj = true <-> exists t k, 0 < t /\ in_poly (assign n k (mult_vector t p)) (expand_poly t pol) = true.

Lemma isExactProjection_weaken1 :
  forall n pol proj, isExactProjection n pol proj -> isExactProjection1 n pol proj.
Proof.
  intros n pol proj H p.
  specialize (H p 1). rewrite expand_poly_1 in H; rewrite H by lia.
  split; intros [t [k Htk]]; exists t; exists k; rewrite Z.mul_1_l in *; auto.
Qed.

Lemma isExactProjection_assign :
  forall n p x t pol proj, 0 < t -> isExactProjection n pol proj -> in_poly p (expand_poly t pol) = true ->
                      in_poly (assign n x p) (expand_poly t proj) = true.
Proof.
  intros n p x t pol proj Ht Hproj Hpol.
  rewrite (Hproj _ t) by lia. exists 1. exists (nth n p 0). split; [lia|].
  rewrite <- Hpol. f_equiv; [|f_equal; lia].
  rewrite mult_vector_1. rewrite assign_assign.
  apply assign_id.
Qed.

Lemma isExactProjection_assign_1 :
  forall n p x pol proj, isExactProjection1 n pol proj -> in_poly p pol = true ->
                      in_poly (assign n x p) proj = true.
Proof.
  intros n p x pol proj Hproj Hpol.
  rewrite (Hproj _) by lia. exists 1. exists (nth n p 0). split; [lia|].
  rewrite <- Hpol. rewrite expand_poly_1. f_equiv.
  rewrite mult_vector_1. rewrite assign_assign.
  apply assign_id.
Qed.

Module Type ProjectOperator (Import Imp: FullImpureMonad).

  Parameter project : (nat * polyhedron) -> imp polyhedron.

  Parameter project_projected :
    forall n pol, WHEN proj <- project (n, pol) THEN absent_var proj n.

  Parameter project_no_new_var :
    forall n k pol, absent_var pol k -> WHEN proj <- project (n, pol) THEN absent_var proj k.

  Parameter project_in_iff :
    forall n pol, WHEN proj <- project (n, pol) THEN isExactProjection n pol proj.

End ProjectOperator.

Module FourierMotzkinProject (Import Imp: FullImpureMonad) <: ProjectOperator Imp.

  Definition merge_constraints n c1 c2 :=
    let '(g, (aa, bb)) := Z.ggcd (nth n (fst c1) 0) (nth n (fst c2) 0) in
    add_constraint (mult_constraint bb c1) (mult_constraint (-aa) c2).

  Lemma Q_exists_rec :
    forall (l1 l2 : list Q) (y1 : Q), ((exists x : Q, (forall y : Q, In y l1 -> (y <= x)%Q) /\ (forall z : Q, In z l2 -> (x <= z)%Q)) <->
                                  (forall y z : Q, In y l1 -> In z l2 -> (y <= z)%Q)) ->
                                 ((exists x : Q, (forall y : Q, In y (y1 :: l1) -> (y <= x)%Q) /\ (forall z : Q, In z l2 -> (x <= z)%Q)) <->
                                  (forall y z : Q, In y (y1 :: l1) -> In z l2 -> (y <= z)%Q)).
  Proof.
    intros l1 l2 y1 [Himp1 Himp2].
    split.
    - intros [x [Hxy Hxz]] y z Hiny Hinz.
      specialize (Hxy y Hiny). specialize (Hxz z Hinz). q_order.
    - intros H. destruct Himp2 as [x [Hxy Hxz]].
      + intros y z Hiny Hinz. apply H; simpl; auto.
      + destruct (Qlt_le_dec x y1).
        * exists y1. split.
          -- intros y [Hy1| Hiny]; [rewrite Hy1 | specialize (Hxy y Hiny)]; q_order.
          -- intros z Hinz. apply H; simpl; auto.
        * exists x. split.
          -- intros y [Hy1 | Hiny]; [rewrite Hy1 in *; q_order | apply Hxy; auto].
          -- auto.
  Qed.

  Lemma Q_exists_min :
    forall (l : list Q), exists x : Q, forall y : Q, In y l -> (x <= y)%Q.
  Proof.
    induction l as [|y1 l IH].
    - exists 0%Q; intros; simpl in *; tauto.
    - destruct IH as [x IH].
      destruct (Qlt_le_dec x y1).
      + exists x. intros y [Hy1 | Hiny]; [rewrite Hy1 in *; q_order | apply (IH y Hiny)].
      + exists y1. intros y [Hy1 | Hiny]; [rewrite Hy1 | specialize (IH y Hiny)]; q_order.
  Qed.

  Lemma Q_exists_between :
    forall (l1 l2 : list Q), (exists x : Q, (forall y : Q, In y l1 -> (y <= x)%Q) /\ (forall z : Q, In z l2 -> (x <= z)%Q)) <->
                        (forall y z : Q, In y l1 -> In z l2 -> (y <= z)%Q).
  Proof.
    induction l1 as [|y1 l1 IH1].
    - intros l2. split.
      + intros; simpl in *; tauto.
      + intros H; destruct (Q_exists_min l2) as [x Hx]; exists x.
        split; [intros; simpl in *; tauto | apply Hx].
    - intros l2; apply Q_exists_rec. apply IH1.
  Qed.

  Definition bound k c p :=
    (inject_Z (snd c - dot_product (assign k 0 p) (fst c))%Z / inject_Z (nth k (fst c) 0)%Z)%Q.

  Lemma assign_0_eq :
    forall k c p s, nth k (fst c) 0 = 0 -> satisfies_constraint (assign k s p) c = satisfies_constraint p c.
  Proof.
    intros k c p s H.
    unfold satisfies_constraint. f_equal. apply dot_product_assign_left_zero; auto.
  Qed.

  Lemma assign_pos_bound :
    forall k c p s t , 0 < nth k (fst c) 0 -> 0 < t ->
                  satisfies_constraint (assign k s (mult_vector t p)) (mult_constraint_cst t c) =
                  (Qle_bool (inject_Z s / inject_Z t) (bound k c p))%Q.
  Proof.
    intros k c p s t Hckpos Htpos. unfold bound.
    destruct t as [|tpos|tneg]; [lia| |lia].
    destruct (nth k (fst c) 0) as [|upos|uneg] eqn:Hu; [lia| |lia].
    unfold satisfies_constraint, Qle_bool, Qdiv, Qmult, Qinv, inject_Z; simpl.
    rewrite !dot_product_assign_left, dot_product_mult_left, mult_nth.
    rewrite eq_iff_eq_true; reflect. destruct (snd c); nia.
  Qed.

  Lemma assign_neg_bound :
    forall k c p s t , nth k (fst c) 0 < 0 -> 0 < t ->
                  satisfies_constraint (assign k s (mult_vector t p)) (mult_constraint_cst t c) =
                  (Qle_bool (bound k c p) (inject_Z s / inject_Z t))%Q.
  Proof.
    intros k c p s t Hckpos Htpos. unfold bound.
    destruct t as [|tpos|tneg]; [lia| |lia].
    destruct (nth k (fst c) 0) as [|upos|uneg] eqn:Hu; [lia|lia|].
    unfold satisfies_constraint, Qle_bool, Qdiv, Qmult, Qinv, inject_Z; simpl.
    rewrite !dot_product_assign_left, dot_product_mult_left, mult_nth.
    rewrite eq_iff_eq_true; reflect. destruct (snd c); nia.
  Qed.

  Lemma is_projected_separate :
    forall n pol p s, 0 < s ->
      (exists t k, 0 < t /\ in_poly (assign n k (mult_vector t p)) (expand_poly (s * t) pol) = true) <->
      (in_poly p (expand_poly s (filter (fun c => nth n (fst c) 0 =? 0) pol)) = true /\
       forall y z, In y (map (fun c => bound n (mult_constraint_cst s c) p) (filter (fun c => nth n (fst c) 0 <? 0) pol)) ->
              In z (map (fun c => bound n (mult_constraint_cst s c) p) (filter (fun c => nth n (fst c) 0 >? 0) pol)) ->
              (y <= z)%Q).
  Proof.
    intros n pol p s Hs.
    rewrite <- Q_exists_between.
    split.
    - intros [t [k [Ht Hin]]]. split.
      + unfold in_poly, expand_poly in *.
        rewrite forallb_map, forallb_forall in *. intros c Hinc.
        rewrite filter_In in Hinc. destruct Hinc as [Hinc Hnthc].
        specialize (Hin c Hinc). reflect.
        rewrite assign_0_eq, Z.mul_comm, <- mult_constraint_cst_comp, mult_constraint_cst_eq in Hin by (simpl; auto).
        exact Hin.
      + exists ((inject_Z k) / (inject_Z t))%Q. split.
        * intros y Hy. rewrite in_map_iff in Hy; destruct Hy as [c [Hy Hinc]].
          rewrite filter_In in Hinc; destruct Hinc as [Hinc Hnthc]. reflect.
          rewrite <- Hy. rewrite <- Qle_bool_iff, <- assign_neg_bound by auto.
          rewrite mult_constraint_cst_comp. unfold in_poly in Hin. rewrite forallb_forall in Hin.
          apply Hin. rewrite Z.mul_comm. unfold expand_poly. apply in_map. auto.
        * intros y Hy. rewrite in_map_iff in Hy; destruct Hy as [c [Hy Hinc]].
          rewrite filter_In in Hinc; destruct Hinc as [Hinc Hnthc]. reflect.
          rewrite <- Hy. rewrite <- Qle_bool_iff, <- assign_pos_bound by auto.
          rewrite mult_constraint_cst_comp. unfold in_poly in Hin. rewrite forallb_forall in Hin.
          apply Hin. rewrite Z.mul_comm. unfold expand_poly. apply in_map. auto.
    - intros [Hin0 [x [Hinneg Hinpos]]].
      exists (Zpos (Qden x)). exists (Qnum x).
      split; [lia|].
      unfold in_poly, expand_poly in *. rewrite forallb_map, forallb_forall in *.
      intros c Hinc.
      destruct (Z.compare_spec (nth n (fst c) 0) 0).
      + rewrite assign_0_eq, Z.mul_comm, <- mult_constraint_cst_comp, mult_constraint_cst_eq by (simpl; auto; lia).
        apply Hin0. rewrite filter_In. reflect; auto.
      + rewrite Z.mul_comm, <- mult_constraint_cst_comp, assign_neg_bound, Qle_bool_iff, <- Qmake_Qdiv by (auto; lia).
        apply Hinneg. rewrite in_map_iff; exists c; split; [auto|].
        rewrite filter_In; reflect; auto.
      + rewrite Z.mul_comm, <- mult_constraint_cst_comp, assign_pos_bound, Qle_bool_iff, <- Qmake_Qdiv by (auto; lia).
        apply Hinpos. rewrite in_map_iff; exists c; split; [auto|].
        rewrite filter_In; reflect; auto.
  Qed.

  Lemma merge_constraints_correct :
    forall n c1 c2 p, nth n (fst c1) 0 < 0 -> nth n (fst c2) 0 > 0 ->
                 satisfies_constraint p (merge_constraints n c1 c2) =
                 Qle_bool (bound n c1 p) (bound n c2 p).
  Proof.
    intros n c1 c2 p Hneg Hpos.
    unfold merge_constraints, bound.
    destruct (nth n (fst c1) 0) as [|a|a] eqn:Ha; [lia|lia|].
    destruct (nth n (fst c2) 0) as [|b|b] eqn:Hb; [lia| |lia].
    generalize (Z.ggcd_correct_divisors (Zneg a) (Zpos b)). generalize (Z.ggcd_gcd (Zneg a) (Zpos b)).
    destruct Z.ggcd as [g [aa bb]] eqn:Hggcd. simpl. intros Hg [Hag Hbg].
    unfold satisfies_constraint, Qle_bool, Qdiv, Qmult, Qinv, inject_Z. simpl.
    rewrite add_vector_dot_product_distr_right, !dot_product_mult_right.
    rewrite !dot_product_assign_left, Ha, Hb, eq_iff_eq_true; reflect.
    rewrite Z.mul_le_mono_pos_l with (p := g) by lia. nia.
  Qed.

  Lemma merge_constraints_mult_constraint_cst :
    forall n c1 c2 s, merge_constraints n (mult_constraint_cst s c1) (mult_constraint_cst s c2) =
                 mult_constraint_cst s (merge_constraints n c1 c2).
  Proof.
    intros n c1 c2 s; unfold merge_constraints, mult_constraint_cst, add_constraint, mult_constraint.
    simpl. destruct (Z.ggcd (nth n (fst c1) 0) (nth n (fst c2) 0)) as [g [aa bb]]. simpl.
    f_equal. nia.
  Qed.

  Definition pure_project n p :=
    let zero := filter (fun c => nth n (fst c) 0 =? 0) p in
    let pos := filter (fun c => nth n (fst c) 0 >? 0) p in
    let neg := filter (fun c => nth n (fst c) 0 <? 0) p in
    zero ++ flatten (map (fun nc => map (merge_constraints n nc) pos) neg).

  Definition project np := pure (pure_project (fst np) (snd np)).

  Theorem pure_project_in_iff :
    forall n pol, isExactProjection n pol (pure_project n pol).
  Proof.
    intros n pol p s Hs.
    rewrite is_projected_separate by auto.
    unfold pure_project. rewrite expand_poly_app, in_poly_app, andb_true_iff.
    f_equiv. unfold in_poly, expand_poly.
    rewrite forallb_map, <- flatten_forallb, forallb_map, forallb_forall.
    split.
    - intros H y z Hiny Hinz.
      rewrite in_map_iff in Hiny, Hinz; destruct Hiny as [cy [Hy Hiny]]; destruct Hinz as [cz [Hz Hinz]].
      specialize (H cy Hiny). rewrite forallb_map, forallb_forall in H. specialize (H cz Hinz).
      rewrite filter_In in Hiny, Hinz; reflect.
      rewrite <- Hy, <- Hz, <- Qle_bool_iff, <- merge_constraints_correct by (simpl; lia).
      rewrite merge_constraints_mult_constraint_cst; exact H.
    - intros H cy Hincy. rewrite forallb_map, forallb_forall. intros cz Hincz.
      rewrite <- merge_constraints_mult_constraint_cst, merge_constraints_correct by (rewrite filter_In in *; reflect; simpl; lia).
      rewrite Qle_bool_iff; apply H; rewrite in_map_iff; [exists cy | exists cz]; auto.
  Qed.

  Theorem project_in_iff :
    forall n pol, WHEN proj <- project (n, pol) THEN isExactProjection n pol proj.
  Proof.
    intros n pol proj Hproj.
    unfold project in Hproj. apply mayReturn_pure in Hproj. simpl in Hproj. rewrite <- Hproj.
    apply pure_project_in_iff; auto.
  Qed.

  Theorem merge_constraints_projected :
    forall n c1 c2, nth n (fst (merge_constraints n c1 c2)) 0 = 0.
  Proof.
    intros n c1 c2.
    unfold merge_constraints, add_constraint, mult_constraint.
    generalize (Z.ggcd_correct_divisors (nth n (fst c1) 0) (nth n (fst c2) 0)).
    destruct Z.ggcd as [g [aa bb]]. intros [H1 H2]. simpl.
    rewrite add_vector_nth, !mult_nth. nia.
  Qed.

  Lemma pure_project_constraint_in :
    forall n pol c, In c (pure_project n pol) ->
               ((In c pol /\ nth n (fst c) 0 = 0) \/
                (exists y z, In y pol /\ In z pol /\ nth n (fst y) 0 < 0 /\ 0 < nth n (fst z) 0 /\ c = merge_constraints n y z)).
  Proof.
    intros n pol c Hin. unfold pure_project in Hin.
    rewrite in_app_iff in Hin. destruct Hin as [Hin | Hin].
    - left; rewrite filter_In in Hin. reflect; tauto.
    - right; rewrite flatten_In in Hin. destruct Hin as [u [Hinu Huin]].
      rewrite in_map_iff in Huin; destruct Huin as [nc [Hu Hnc]].
      rewrite <- Hu, in_map_iff in Hinu. destruct Hinu as [pc [Hc Hpc]].
      rewrite <- Hc. exists nc; exists pc.
      rewrite filter_In in *; reflect; tauto.
  Qed.

  Theorem pure_project_projected :
    forall n pol c, In c (pure_project n pol) -> nth n (fst c) 0 = 0.
  Proof.
    intros n pol c Hin. apply pure_project_constraint_in in Hin.
    destruct Hin as [[Hcin Hcn] | [y [z [Hyin [Hzin [Hyn [Hzn Hc]]]]]]].
    - auto.
    - rewrite Hc. apply merge_constraints_projected.
  Qed.

  Theorem project_projected :
    forall n pol, WHEN proj <- project (n, pol) THEN forall c, In c proj -> nth n (fst c) 0 = 0.
  Proof.
    intros n pol proj Hproj c Hinproj.
    unfold project in Hproj; apply mayReturn_pure in Hproj; rewrite <- Hproj in *; simpl in *.
    eapply pure_project_projected; eauto.
  Qed.

  Theorem merge_constraints_no_new_var :
    forall n k c1 c2, nth k (fst c1) 0 = 0 -> nth k (fst c2) 0 = 0 -> nth k (fst (merge_constraints n c1 c2)) 0 = 0.
  Proof.
    intros n k c1 c2 Hc1 Hc2.
    unfold merge_constraints, add_constraint, mult_constraint.
    destruct Z.ggcd as [g [aa bb]]. simpl.
    rewrite add_vector_nth, !mult_nth. nia.
  Qed.

  Theorem pure_project_no_new_var :
    forall n k pol, (forall c, In c pol -> nth k (fst c) 0 = 0) -> (forall c, In c (pure_project n pol) -> nth k (fst c) 0 = 0).
  Proof.
    intros n k pol H c Hin.
    apply pure_project_constraint_in in Hin.
    destruct Hin as [[Hcin Hcn] | [y [z [Hyin [Hzin [Hyn [Hzn Hc]]]]]]].
    - auto.
    - rewrite Hc. apply merge_constraints_no_new_var; auto.
  Qed.

  Theorem project_no_new_var :
    forall n k pol, (forall c, In c pol -> nth k (fst c) 0 = 0) -> WHEN proj <- project (n, pol) THEN (forall c, In c proj -> nth k (fst c) 0 = 0).
  Proof.
    intros n k pol H proj Hproj.
    unfold project in Hproj; apply mayReturn_pure in Hproj; rewrite <- Hproj in *; simpl in *.
    eapply pure_project_no_new_var; eauto.
  Qed.

End FourierMotzkinProject.

(** * Polyhedral projection on the first [n] dimensions *)

Module Type PolyProject (Import Imp: FullImpureMonad).
  Parameter project : nat * polyhedron -> imp polyhedron.

  Parameter project_inclusion :
    forall n p pol, in_poly p pol = true -> WHEN proj <- project (n, pol) THEN in_poly (resize n p) proj = true.

  Parameter project_invariant : nat -> polyhedron -> list Z -> Prop.

  Parameter project_invariant_inclusion :
    forall n pol p, in_poly p pol = true -> project_invariant n pol (resize n p).

  Parameter project_id :
    forall n pol p, (forall c, In c pol -> fst c =v= resize n (fst c)) -> project_invariant n pol p -> in_poly p pol = true.

  Parameter project_next_r_inclusion :
    forall n pol p, project_invariant n pol p ->
               WHEN proj <- project (S n, pol) THEN
               (forall c, In c proj -> nth n (fst c) 0 <> 0 -> satisfies_constraint p c = true) ->
                 project_invariant (S n) pol p.

  Parameter project_invariant_resize :
    forall n pol p, project_invariant n pol p <-> project_invariant n pol (resize n p).

  Parameter project_invariant_export : nat * polyhedron -> imp polyhedron.

  Parameter project_invariant_export_correct :
    forall n p pol, WHEN res <- project_invariant_export (n, pol) THEN in_poly p res = true <-> project_invariant n pol p.

  Parameter project_constraint_size :
    forall n pol c, WHEN proj <- project (n, pol) THEN In c proj -> fst c =v= resize n (fst c).

End PolyProject.

Module PolyProjectImpl (Import Imp: FullImpureMonad) (Canon : PolyCanonizer Imp) (Proj : ProjectOperator Imp) <: PolyProject Imp.

  Ltac bind_imp_destruct H id1 id2 :=
  apply mayReturn_bind in H; destruct H as [id1 [id2 H]].

  Fixpoint do_project d k pol :=
    match k with
    | O => pure pol
    | S k1 =>
      BIND proj <- Proj.project ((d + k1)%nat, pol) -;
      BIND canon <- Canon.canonize proj -;
      do_project d k1 canon
    end.

  Lemma do_project_succ :
    forall k d pol, impeq (do_project d (S k) pol)
                     (BIND proj1 <- do_project (S d) k pol -; BIND proj <- Proj.project (d, proj1) -; Canon.canonize proj).
  Proof.
    induction k.
    - intros; simpl in *. rewrite Nat.add_0_r.
      rewrite impeq_bind_pure_l. f_equiv; intro proj1. rewrite impeq_bind_pure_r. reflexivity.
    - intros d pol; simpl in *.
      rewrite impeq_bind_assoc. rewrite Nat.add_succ_r. f_equiv; intro proj.
      rewrite impeq_bind_assoc. f_equiv; intro canon.
      rewrite IHk. reflexivity.
  Qed.

  Lemma do_project_in_iff :
    forall k s d p pol, 0 < s ->
                   WHEN proj <- do_project d k pol THEN
                        in_poly p (expand_poly s proj) = true <->
                   exists t m, length m = k /\ 0 < t /\
                          in_poly (resize d (mult_vector t p) ++ m ++ skipn (d + k)%nat (mult_vector t p))
                                  (expand_poly (s * t) pol) = true.
  Proof.
    induction k.
    - intros s d p pol Hs proj Hproj; simpl in *.
      apply mayReturn_pure in Hproj; rewrite Hproj.
      split.
      + intros Hin. exists 1. exists nil. simpl.
        split; [auto|split;[lia|]].
        rewrite !mult_vector_1, Nat.add_0_r, resize_skipn_eq, Z.mul_1_r.
        exact Hin.
      + intros [t [m [Hm [Ht Hin]]]].
        destruct m; simpl in *; [|congruence].
        rewrite Nat.add_0_r, resize_skipn_eq, Z.mul_comm, <- expand_poly_comp, expand_poly_eq in Hin by auto.
        exact Hin.
    - intros s d p pol Hs proj Hproj; simpl in *.
      bind_imp_destruct Hproj proja Hproja.
      bind_imp_destruct Hproj canon Hcanon.
      rewrite (IHk s d p canon Hs proj Hproj).
      split; intros [t [m [Hmlen [Ht Hin]]]]; assert (Hst : 0 < s * t) by nia.
      + rewrite (Canon.canonize_correct proja) in Hin by auto.
        rewrite (Proj.project_in_iff _ _ _ Hproja _ _ Hst) in Hin.
        destruct Hin as [r [u [Hr Hin]]].
        exists (t * r). exists (mult_vector r m ++ (u :: nil)).
        split; [rewrite app_length, mult_vector_length, Nat.add_1_r; auto|].
        split; [nia|].
        rewrite <- Hin, Z.mul_assoc. f_equiv.
        rewrite !mult_vector_app, <- !mult_vector_resize, <- !mult_vector_skipn, !mult_vector_comp.
        rewrite assign_app_ge; rewrite resize_length; [|lia].
        rewrite assign_app_ge; rewrite mult_vector_length, Hmlen; [|lia].
        replace (d + k - d - k)%nat with 0%nat by lia.
        rewrite <- app_assoc.
        f_equiv; [f_equal; f_equal; nia|].
        f_equiv. unfold assign. rewrite skipn_skipn. replace (1 + (d + k))%nat with (d + S k)%nat by lia.
        simpl. f_equiv. f_equiv. f_equal. nia.
      + exists t. exists (resize k m). split; [apply resize_length|].
        split; [auto|].
        rewrite (Canon.canonize_correct proja) by auto.
        rewrite (Proj.project_in_iff _ _ _ Hproja _ _ Hst).
        exists 1. exists (nth k m 0).
        split; [lia|].
        rewrite mult_vector_1. rewrite <- Hin.
        f_equiv; [|f_equal; lia].
        rewrite assign_app_ge; rewrite resize_length; [|lia].
        rewrite assign_app_ge; rewrite resize_length; [|lia].
        replace (d + k - d - k)%nat with 0%nat by lia.
        unfold assign.
        rewrite skipn_skipn. replace (1 + (d + k))%nat with (d + S k)%nat by lia.
        replace m with (resize k m ++ (nth k m 0 :: nil)) at 3 by (rewrite <- resize_succ; apply resize_length_eq; auto).
        rewrite <- app_assoc. reflexivity.
  Qed.

  Fixpoint simplify_poly (n : nat) (p : polyhedron) :=
    match n with
    | 0%nat => p
    | S n =>
      let nz := filter (fun c => negb (nth n (fst c) 0 =? 0)) p in
      let z := filter (fun c => nth n (fst c) 0 =? 0) p in
      match find_eq n nz with
      | None => nz ++ simplify_poly n z
      | Some c => c :: mult_constraint (-1) c ::
                   simplify_poly n (map (fun c1 => make_constraint_with_eq n c c1) nz ++ z)
      end
    end.

  Lemma simplify_poly_correct :
    forall n pol p t, 0 < t -> in_poly p (expand_poly t (simplify_poly n pol)) = in_poly p (expand_poly t pol).
  Proof.
    induction n.
    - intros; simpl; reflexivity.
    - intros pol p t Ht. simpl.
      set (nz := filter (fun c => negb (nth n (fst c) 0 =? 0)) pol).
      set (z := filter (fun c => nth n (fst c) 0 =? 0) pol).
      transitivity (in_poly p (expand_poly t nz) && in_poly p (expand_poly t z)).
      + destruct (find_eq n nz) as [c|] eqn:Hfindeq.
        * unfold in_poly in *. simpl. rewrite IHn; auto. rewrite andb_assoc.
          replace (satisfies_constraint p (mult_constraint_cst t c) &&
                   satisfies_constraint p (mult_constraint_cst t (mult_constraint (-1) c))) with
              (dot_product p (fst c) =? t * snd c)
            by (unfold satisfies_constraint, mult_constraint; simpl; rewrite eq_iff_eq_true, dot_product_mult_right; reflect; lia).
          assert (Hcnth : nth n (fst c) 0 <> 0) by (apply find_eq_nth in Hfindeq; lia).
          destruct (dot_product p (fst c) =? t * snd c) eqn:Heq; simpl; reflect.
          -- unfold expand_poly.
             rewrite map_app, forallb_app, map_map, !forallb_map. f_equal. apply forallb_ext.
             intros c1. rewrite make_constraint_with_eq_correct; auto.
          -- destruct (forallb (satisfies_constraint p) (expand_poly t nz)) eqn:Hin; simpl; [|reflexivity]. exfalso; apply Heq.
             unfold expand_poly in Hin. rewrite forallb_map, forallb_forall in Hin.
             eapply find_eq_correct; eauto.
        * rewrite expand_poly_app, in_poly_app. rewrite IHn by auto. reflexivity.
      + rewrite eq_iff_eq_true. reflect. unfold expand_poly, in_poly, nz, z; rewrite !forallb_map, !forallb_forall.
        split.
       * intros [H1 H2] c Hc; specialize (H1 c); specialize (H2 c).
         rewrite filter_In in H1, H2. destruct (nth n (fst c) 0 =? 0); auto.
       * intros H. split; intros c Hcin; rewrite filter_In in Hcin; apply H; tauto.
  Qed.

  Lemma simplify_poly_preserve_zeros :
    forall n m pol, (forall c, In c pol -> nth m (fst c) 0 = 0) -> (forall c, In c (simplify_poly n pol) -> nth m (fst c) 0 = 0).
  Proof.
    induction n.
    - intros; auto.
    - intros m pol H c Hc.
      simpl in Hc.
      set (nz := filter (fun c => negb (nth n (fst c) 0 =? 0)) pol) in *.
      set (z := filter (fun c => nth n (fst c) 0 =? 0) pol) in *.
      destruct (find_eq n nz) as [c1|] eqn:Hfindeq.
      + simpl in Hc.
        assert (Hc1 : nth m (fst c1) 0 = 0) by (apply find_eq_in in Hfindeq; apply H; unfold nz in Hfindeq; rewrite filter_In in Hfindeq; tauto).
        destruct Hc as [Hc | [Hc | Hc]];
          [rewrite <- Hc; auto | rewrite <- Hc; unfold mult_constraint; simpl; rewrite mult_nth; lia|].
        eapply IHn; [|apply Hc].
        intros c2 Hin2; rewrite in_app_iff, in_map_iff in Hin2.
        destruct Hin2 as [[c3 [Heq2 Hin3]] | Hin2]; [|apply H; unfold z in Hin2; rewrite filter_In in Hin2; tauto].
        rewrite <- Heq2, make_constraint_with_eq_preserve_zeros; auto. apply H.
        unfold nz in Hin3; rewrite filter_In in Hin3; tauto.
      + rewrite in_app_iff in Hc.
        destruct Hc as [Hc | Hc]; [apply H; unfold nz in Hc; rewrite filter_In in Hc; tauto|].
        eapply IHn; [|apply Hc]. intros c1 Hc1; apply H; unfold z in Hc1; rewrite filter_In in Hc1; tauto.
  Qed.

  Definition project (np : nat * polyhedron) : imp polyhedron :=
    let (n, p) := np in
    let k := poly_nrl p in
    BIND r <- do_project n (k - n)%nat p -; pure (simplify_poly n r).

  Lemma project_in_iff :
    forall s n p pol, 0 < s -> WHEN proj <- project (n, pol) THEN
                              in_poly p (expand_poly s proj) = true <->
                         exists t m, 0 < t /\ in_poly (resize n (mult_vector t p) ++ m) (expand_poly (s * t) pol) = true.
  Proof.
    intros s n p pol Hs proj Hproj.
    unfold project in Hproj.
    bind_imp_destruct Hproj r Hr; apply mayReturn_pure in Hproj; rewrite <- Hproj in *.
    rewrite simplify_poly_correct by auto.
    remember (poly_nrl pol) as u.
    rewrite (do_project_in_iff _ _ _ _ _ Hs _ Hr).
    split.
    - intros [t [m [Hmlen [Ht Hin]]]]; exists t. exists m. split; [auto|].
      rewrite <- in_poly_nrlength with (n := u) in Hin by (rewrite expand_poly_nrl; nia).
      rewrite <- in_poly_nrlength with (n := u) by (rewrite expand_poly_nrl; nia).
      rewrite app_assoc in Hin. rewrite resize_app_ge in Hin; [exact Hin|].
      rewrite app_length, resize_length, Hmlen. lia.
    - intros [t [m [Ht Hin]]]; exists t. exists (resize (u - n)%nat m).
      split; [apply resize_length|]. split; [auto|].
      rewrite <- in_poly_nrlength with (n := u) in Hin by (rewrite expand_poly_nrl; nia).
      rewrite <- in_poly_nrlength with (n := u) by (rewrite expand_poly_nrl; nia).
      rewrite app_assoc, resize_app_ge by (rewrite app_length, !resize_length; lia).
      destruct (u <=? n)%nat eqn:Hun; reflect.
      + rewrite resize_app_ge in * by (rewrite resize_length; lia). exact Hin.
      + rewrite resize_app_le in * by (rewrite resize_length; lia). rewrite !resize_length in *.
        rewrite resize_resize; [exact Hin|lia].
  Qed.

  Lemma project_in_iff1 :
    forall n p pol, WHEN proj <- project (n, pol) THEN
                    in_poly p proj = true <->
               exists t m, 0 < t /\ in_poly (resize n (mult_vector t p) ++ m) (expand_poly t pol) = true.
  Proof.
    intros n p pol proj Hproj.
    rewrite <- expand_poly_1 with (p := proj).
    assert (H01 : 0 < 1) by lia.
    rewrite (project_in_iff _ _ _ _ H01 _ Hproj). apply exists_ext. intros t.
    destruct t; reflexivity.
  Qed.

  Theorem project_inclusion :
    forall n p pol, in_poly p pol = true -> WHEN proj <- project (n, pol) THEN in_poly (resize n p) proj = true.
  Proof.
    intros n p pol Hp proj Hproj.
    rewrite (project_in_iff1 _ _ _ _ Hproj). exists 1. exists (skipn n p).
    split; [lia|].
    rewrite mult_vector_1, resize_resize, resize_skipn_eq, expand_poly_1 by lia.
    auto.
  Qed.

  Definition project_invariant n p v :=
    exists t m, 0 < t /\ in_poly (resize n (mult_vector t v) ++ m) (expand_poly t p) = true.

  Theorem project_invariant_inclusion :
    forall n pol p, in_poly p pol = true -> project_invariant n pol (resize n p).
  Proof.
    intros n pol p H.
    exists 1. exists (skipn n p).
    split; [lia|].
    rewrite mult_vector_1, resize_resize, resize_skipn_eq, expand_poly_1 by lia.
    auto.
  Qed.

  Theorem project_id :
    forall n pol p, (forall c, In c pol -> fst c =v= resize n (fst c)) -> project_invariant n pol p -> in_poly p pol = true.
  Proof.
    intros n pol p Hclen Hinv. rewrite poly_nrl_def in Hclen.
    destruct Hinv as [t [m [Ht Hinv]]].
    rewrite <- in_poly_nrlength with (n := n) in Hinv by (rewrite expand_poly_nrl; auto; lia).
    rewrite resize_app in Hinv by (apply resize_length).
    rewrite in_poly_nrlength in Hinv by (rewrite expand_poly_nrl; auto; lia).
    rewrite expand_poly_eq in Hinv; auto.
  Qed.

  Theorem project_invariant_resize :
    forall n pol p, project_invariant n pol p <-> project_invariant n pol (resize n p).
  Proof.
    intros n pol p. unfold project_invariant.
    apply exists_ext. intros t.
    rewrite <- mult_vector_resize. rewrite resize_resize by lia.
    reflexivity.
  Qed.

  Lemma do_project_no_new_var :
    forall k d pol n, (forall c, In c pol -> nth n (fst c) 0 = 0) -> WHEN proj <- do_project d k pol THEN (forall c, In c proj -> nth n (fst c) 0 = 0).
  Proof.
    induction k.
    - intros; simpl in *. xasimplify eauto.
    - intros; simpl in *. xasimplify eauto.
      generalize (Proj.project_no_new_var _ _ _ H _ Hexta). intros H1.
      generalize (Canon.canonize_no_new_var _ _ H1 _ Hexta0). intros H2.
      apply (IHk _ _ _ H2 _ Hexta1).
  Qed.

  Lemma do_project_constraints :
    forall k d pol n, (d <= n < d + k)%nat -> WHEN proj <- do_project d k pol THEN (forall c, In c proj -> nth n (fst c) 0 = 0).
  Proof.
    induction k.
    - intros; lia.
    - intros d pol n Hn proj Hproj.
      simpl in Hproj.
      bind_imp_destruct Hproj proja Hproja.
      bind_imp_destruct Hproj canon Hcanon.
      destruct (n =? d + k)%nat eqn:Heqn; reflect.
      + rewrite Heqn. generalize (Proj.project_projected _ _ _ Hproja). intros H1.
        generalize (Canon.canonize_no_new_var _ _ H1 _ Hcanon). intros H2.
        apply (do_project_no_new_var _ _ _ _ H2 _ Hproj).
      + assert (H : (d <= n < d + k)%nat) by lia.
        apply (IHk _ _ _ H _ Hproj).
  Qed.

  Theorem project_constraint_size :
    forall n pol c, WHEN proj <- project (n, pol) THEN In c proj -> fst c =v= resize n (fst c).
  Proof.
    intros n pol c proj Hproj Hin.
    apply vector_nth_veq.
    unfold project in Hproj.
    bind_imp_destruct Hproj r Hr; apply mayReturn_pure in Hproj; rewrite <- Hproj in *.
    intros k.
    rewrite nth_resize.
    destruct (k <? n)%nat eqn:Hkn; reflect; [reflexivity|].
    assert (Hcr : forall c1, In c1 r -> nth k (fst c1) 0 = 0).
    - intros c1 Hin1.
      destruct (k <? n + (poly_nrl pol - n))%nat eqn:Hkrl; reflect.
      + apply (do_project_constraints _ _ _ _ (conj Hkn Hkrl) _ Hr); auto.
      +  assert (Hnrl : (poly_nrl pol <= k)%nat) by lia.
         rewrite <- poly_nrl_def in Hnrl.
         assert (H : forall c, In c pol -> nth k (fst c) 0 = 0).
         * intros c2 Hin2; specialize (Hnrl c2 Hin2).
           apply nth_eq with (n := k) in Hnrl. rewrite nth_resize in Hnrl. destruct (k <? k)%nat eqn:Hkk; reflect; lia.
         * apply (do_project_no_new_var _ _ _ _  H _ Hr _ Hin1).
    - eapply simplify_poly_preserve_zeros; eauto.
  Qed.

  Theorem project_next_r_inclusion :
    forall n pol p, project_invariant n pol p ->
               WHEN proj <- project (S n, pol) THEN
               (forall c, In c proj -> nth n (fst c) 0 <> 0 -> satisfies_constraint p c = true) ->
               project_invariant (S n) pol p.
  Proof.
    intros n pol p Hinv proj Hproj Hsat.
    destruct Hinv as [t [m [Ht Hinv]]].
    apply (project_in_iff1 _ _ _ _ Hproj).
    unfold in_poly. rewrite forallb_forall. intros c Hinproj.
    destruct (nth n (fst c) 0 =? 0) eqn:Hzero; reflect; [|apply Hsat; auto].
    unfold project_invariant in Hinv.
    rewrite <- resize_skipn_eq with (d := 1%nat) (l := m) in Hinv.
    rewrite app_assoc in Hinv.
    assert (H : in_poly (resize n (mult_vector t p) ++ resize 1 m) (expand_poly t proj) = true).
    - rewrite (project_in_iff _ _ _ _ Ht _ Hproj). exists 1. exists (skipn 1%nat m).
      split; [lia|]. rewrite mult_vector_1. rewrite resize_length_eq by (rewrite app_length, !resize_length; lia).
      rewrite Z.mul_1_r; apply Hinv.
    - unfold in_poly in H. rewrite forallb_forall in H.
      rewrite <- mult_constraint_cst_eq with (k := t) by auto.
      specialize (H (mult_constraint_cst t c)).
      generalize (project_constraint_size _ _ _ _ Hproj Hinproj); intros Hsize.
      rewrite resize_succ, Hzero in Hsize.
      setoid_replace (0 :: nil) with (@nil Z) using relation veq in Hsize by (rewrite <- is_eq_veq; reflexivity).
      rewrite app_nil_r in Hsize. symmetry in Hsize; rewrite nrlength_def in Hsize.
      replace (fst c) with (fst (mult_constraint_cst t c)) in Hsize by reflexivity.
      rewrite <- satisfies_constraint_nrlength with (n := n) in H by auto.
      rewrite <- satisfies_constraint_nrlength with (n := n) by auto.
      rewrite resize_app in H by (apply resize_length). apply H.
      unfold expand_poly. apply in_map. auto.
  Qed.

  Definition project_invariant_export (np : nat * polyhedron) : imp polyhedron :=
    project np.

  Theorem project_invariant_export_correct :
    forall n p pol, WHEN res <- project_invariant_export (n, pol) THEN in_poly p res = true <-> project_invariant n pol p.
  Proof.
    intros n p pol proj Hproj.
    apply (project_in_iff1 _ _ _ _ Hproj).
  Qed.

End PolyProjectImpl.

Require Import ImpureAlarmConfig.
Module Proj := FourierMotzkinProject CoreAlarmed.
Module Export PPI := PolyProjectImpl CoreAlarmed Canon Proj.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_extension_1 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_2 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable defray_4 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_5 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).

Theorem lemma_layoff_6 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Proof.
  time tac.
Qed.

End FOFProblem.