Require Export GeoCoq.Meta_theory.Parallel_postulates.parallel_postulates.
Require Export GeoCoq.Meta_theory.Parallel_postulates.par_trans_NID.

Section T13.

Context `{TE:Tarski_euclidean}.

Lemma cop_npars__inter_exists :
 forall A1 B1 A2 B2,
  Coplanar A1 B1 A2 B2 -> ~ Par_strict A1 B1 A2 B2 ->
  exists X, Col X A1 B1 /\ Col X A2 B2.
Proof.
intros.
induction (eq_dec_points A1 B1).
  subst.
  exists A2.
  Col.
induction (eq_dec_points A2 B2).
  subst.
  exists A1.
  Col.
induction (inter_dec A1 B1 A2 B2).
  assumption.
exfalso.
apply H0.
split; assumption.
Qed.

Lemma cop_npar__inter_exists : forall A1 B1 A2 B2,
  Coplanar A1 B1 A2 B2 -> ~ Par A1 B1 A2 B2 -> exists X, Col X A1 B1 /\ Col X A2 B2.
Proof.
intros.
apply cop_npars__inter_exists.
  assumption.
intro.
apply H0.
left.
assumption.
Qed.

Lemma cop_npar__inter : forall A1 B1 A2 B2, A1 <> B1 -> A2 <> B2 ->
  Coplanar A1 B1 A2 B2 -> ~ Par A1 B1 A2 B2 -> exists X, Inter A1 B1 A2 B2 X.
Proof.
intros.
destruct (cop_npar__inter_exists A1 B1 A2 B2) as [X []].
  assumption.
  assumption.
exists X.
split.
  assumption.
split.
  induction (col_dec A2 A1 B1).
    exists B2.
    split.
      Col.
    intro.
    apply H2.
    right.
    repeat split; ColR.
  exists A2.
  split; Col.
split; Col.
Qed.

Lemma parallel_uniqueness :
 forall A1 A2 B1 B2 C1 C2 P : Tpoint,
  Par A1 A2 B1 B2 -> Col P B1 B2 ->
  Par A1 A2 C1 C2 -> Col P C1 C2 ->
  Col C1 B1 B2 /\ Col C2 B1 B2.
Proof.
    apply tarski_s_euclid_implies_playfair.
    unfold tarski_s_parallel_postulate; apply euclid.
Qed.

Lemma par_trans : forall A1 A2 B1 B2 C1 C2,
  Par A1 A2 B1 B2 -> Par B1 B2 C1 C2 -> Par A1 A2 C1 C2.
Proof.
    intros.
    apply playfair_implies_par_trans with B1 B2; [|assumption..].
    unfold playfair_s_postulate.
    apply parallel_uniqueness.
Qed.

Lemma inter__npar : forall A1 A2 B1 B2 X,
  Inter A1 A2 B1 B2 X -> ~ Par A1 A2 B1 B2.
Proof.
    intros.
    destruct H as [HA [[P []] []]].
    induction 1.
    apply (par_not_col A1 A2 B1 B2 X); Col.
    spliter.
    apply H0, (col3 B1 B2); Col.
Qed.

Lemma l12_16 : forall A1 A2 B1 B2 C1 C2 X,
  Par A1 A2 B1 B2 -> Coplanar B1 B2 C1 C2 -> Inter A1 A2 C1 C2 X -> exists Y, Inter B1 B2 C1 C2 Y.
Proof.
    intros.
    assert_diffs.
    apply cop_npar__inter; auto.
      destruct H1.
      auto.
    intro.
    apply inter__npar in H1.
    apply H1.
    apply par_trans with B1 B2; assumption.
Qed.

Lemma par_dec : forall A B C D, Par A B C D \/ ~ Par A B C D.
Proof. exact (par_trans__par_dec par_trans). Qed.

Lemma par_not_par : forall A B C D P Q, Par A B C D -> ~Par A B P Q -> ~Par C D P Q.
Proof.
intros A B C D P Q HPar HNPar.
intro HNPar'.
apply HNPar.
apply par_trans with C D; Par.
Qed.

Lemma cop_par__inter : forall A B C D P Q,
  Par A B C D -> ~Par A B P Q -> Coplanar C D P Q ->
  exists Y, Col P Q Y /\ Col C D Y.
Proof.
    intros A B C D P Q HPar HNPar HCop.
    destruct (cop_npar__inter_exists C D P Q) as [Y []].
      assumption.
      intro.
      apply HNPar, par_trans with C D; assumption.
    exists Y; split; Col.
Qed.

Lemma l12_19 :
  forall A B C D ,
   ~Col A B C -> Par A B C D -> Par B C D A ->
   Cong A B C D /\ Cong B C D A /\ TS B D A C /\ TS A C B D.
Proof.
    intros.
    assert(exists P, Midpoint P A C) by (eapply midpoint_existence).
    ex_and H2 P.
    double B P D'.
    assert(Cong C D' A B).
      apply (l7_13 P); assumption.
    assert(Cong B C D' A).
      apply (l7_13 P); Midpoint.
    assert(Par A B C D').
      assert_diffs; apply l12_17 with P; auto.
    assert(Par C D C D').
      eapply par_trans.
        apply par_symmetry.
        apply H0.
      apply H6.
    assert(Col C D D').
      apply par_id.
      assumption.
    assert(Par B C D' A).
      assert_diffs; apply l12_17 with P; Midpoint.
    assert(Par D A D' A).
      eapply par_trans.
        apply par_symmetry.
        apply H1.
      assumption.
    assert(Col A D D').
      apply par_id.
      Par.
    assert(D = D').
      assert_diffs; apply (l6_21 A D C D); Col.
        intro.
        apply H.
        assert(Col P C D).
          apply col_permutation_2.
          apply (col_transitivity_1 _ A); Col.
        assert(Col P C D').
          apply col_permutation_2.
          apply (col_transitivity_1 _ D); Col.
        assert(Col P A D').
          apply (col_transitivity_1 _ C); Col.
        apply (col3 P D'); Col.
        intro; treat_equalities; Col5.
    subst D'.
    split.
      Cong.
    split.
      Cong.
    assert(B <> D).
      intro; treat_equalities; Col5.
    split.
      apply l12_18_c with P; Cong; Col.
    apply l12_18_d with P; Cong; Col.
Qed.

Lemma l12_20_bis :
  forall A B C D,
   Par A B C D -> Cong A B C D -> TS B D A C ->
   Par B C D A /\ Cong B C D A /\ TS A C B D.
Proof.
    intros.
    assert(B <> C) by (assert_diffs; auto).
    assert(A <> D) by (assert_diffs; auto).
    assert(~ Col A B C).
      intro.
      assert(Col A B D).
        apply not_strict_par1 with C C; Col; Par.
      unfold TS in H1.
      spliter.
      contradiction.
    assert(exists P, Midpoint P A C) by (apply midpoint_existence).
    ex_and H5 P.
    double B P D'.
    assert(Par B C D' A).
      eapply l12_17.
        assumption.
        apply H5.
      apply l7_2.
      assumption.
    assert(Par A B C D').
      assert_diffs; apply l12_17 with P; auto.
    assert(Cong C D' A B).
      apply (l7_13 P); assumption.
    assert(Cong B C D' A).
      apply (l7_13 P); Midpoint.
    assert(Par C D C D').
      eapply par_trans.
        apply par_symmetry.
        apply H.
      assumption.
    assert(Col C D D').
      apply par_id; assumption.
    assert(Cong C D C D').
      apply (cong_transitivity _ _ A B); Cong.
    assert(D = D' \/ Midpoint C D D').
      apply l7_20; Col.
    induction H14.
    { subst D'.
      assert(Par B C D A) by Par.
      split.
        assumption.
      assert(HH:=l12_19 A B C D H4 H H14).
      spliter.
      split; assumption.
    }
    (************)
    exfalso.
    assert(TS A C B D).
      apply par_two_sides_two_sides; assumption.
    assert(~ Col A C D).
      apply (par_not_col A B C D A); Col.
      apply par_not_col_strict with C; Col.
    assert(~ Col D' A C).
      intro.
      apply H16.
      ColR.
    assert(TS A C B D').
      repeat split; Col.
      exists P.
      split.
        Col.
      Between.
    assert (TS A C D D').
      repeat split; Col.
      exists C.
      split.
        Col.
      Between.
    apply (l9_9 A C B D).
      assumption.
    apply l9_8_1 with D'; assumption.
Qed.

Lemma l12_20 :
 forall A B C D,
  Par A B C D -> Cong A B C D -> TS A C B D ->
  Par B C D A /\ Cong B C D A /\ TS A C B D.
Proof.
    intros.
    assert(TS B D A C).
      apply par_two_sides_two_sides.
        apply par_comm.
        assumption.
      assumption.
    assert(HH:=l12_20_bis A B C D H H0 H2).
    spliter.
    split.
      assumption.
    split.
      assumption.
    assumption.
Qed.

Lemma l12_21_a :
 forall A B C D,
  TS A C B D ->
  (Par A B C D -> CongA B A C D C A).
Proof.
    apply postulates_in_euclidean_context; simpl; repeat (try (left; reflexivity); right).
Qed.

Lemma l12_21 : forall A B C D,
 TS A C B D ->
 (CongA B A C D C A <-> Par A B C D).
Proof.
    intros.
    split.
      intro.
      apply l12_21_b ; assumption.
    intro.
    apply l12_21_a; assumption.
Qed.

Lemma l12_22_a : forall A B C D P,
 Out P A C -> OS P A B D -> Par A B C D ->
 CongA B A P D C P.
Proof.
    cut (forall A B C D P,
         A <> P -> Bet P A C -> OS P A B D -> Par A B C D ->
         CongA B A P D C P).
    { intros Haux A B C D P HOut HOS HPar.
      destruct HOut as [HAP [HCP [|]]].
        apply Haux; trivial.
      apply conga_sym, Haux; Par.
      apply col_one_side with A; Col; Side.
    }
    intros A B C D P HAP HBet HOS HPar.
    destruct (eq_dec_points A C).
    { subst C.
      apply out2__conga; [|apply out_trivial; auto].
      apply col_one_side_out with P; Side.
      apply par_id; Par.
    }
    destruct (segment_construction B A B A) as [B' []].
    assert_diffs.
    apply conga_trans with B' A C.
      apply l11_14; auto.
    apply l11_10 with B' C D A; try (apply out_trivial); auto; [|apply l6_6, bet_out; Between].
    apply l12_21_a; [|apply par_col_par_2 with B; Col].
    apply l9_2, l9_8_2 with B; [|apply col_one_side with P; Side; Col].
    assert (HNCol : ~ Col P A B) by (apply one_side_not_col123 with D, HOS).
    assert (HNCol1 : ~ Col B A C) by (intro; apply HNCol; ColR).
    repeat split; trivial.
      intro; apply HNCol1; ColR.
    exists A; Col.
Qed.

Lemma l12_22 :
  forall A B C D P,
  Out P A C -> OS P A B D ->
  (CongA B A P D C P <-> Par A B C D).
Proof.
    intros.
    split; intro.
      apply (l12_22_b _ _ _ _ P); assumption.
      apply l12_22_a; assumption.
Qed.

Lemma l12_23 :
 forall A B C,
  ~Col A B C ->
  exists B', exists C',
  TS A C B B' /\ TS A B C C' /\
      Bet B' A C' /\ CongA A B C B A C' /\ CongA A C B C A B'.
Proof.
    intros.
    assert(exists B0, Midpoint B0 A B) by (apply midpoint_existence).
    assert(exists C0, Midpoint C0 A C) by (apply midpoint_existence).
    ex_and H0 B0.
    ex_and H1 C0.
    prolong B C0 B' B C0.
    prolong C B0 C' C B0.
    exists B'.
    exists C'.
    assert(TS A C B B').
      apply mid_two_sides with C0; Col.
      split.
        assumption.
      Cong.
    assert(TS A B C C').
      eapply mid_two_sides with B0; Col.
      split.
        assumption.
      Cong.
    split.
      assumption.
    split.
      assumption.
    assert(Par A B' C B).
      eapply l12_17.
        intro.
        treat_equalities.
        assert(C0 = B0).
          apply (l7_17 A B).
              split.
              apply between_symmetry.
              assumption.
              Cong.
          assumption.
        treat_equalities.
        Col.
        apply H0.
      split.
        apply between_symmetry.
        assumption.
      Cong.
    assert(Par A C' B C).
      eapply l12_17.
        intro.
        treat_equalities.
        assert(C0 = B0).
          eapply l7_17.
            apply H0.
          split.
            apply between_symmetry.
            assumption.
          Cong.
        treat_equalities.
        Col.
        apply H2.
      split.
        apply between_symmetry.
        assumption.
      Cong.
    assert(Par A B' A C').
      eapply par_trans.
        apply H8.
      apply par_symmetry.
      apply par_right_comm.
      assumption.
    apply par_id in H10.
    assert(OS A C B0 C').
      eapply out_one_side_1.
        intro.
        apply H.
        assert_diffs.
        eapply (col_transitivity_1 _ B0); Col.
        apply col_trivial_2.
      apply bet_out.
        intro.
        treat_equalities.
        assert_diffs; auto.
      assumption.
    assert(OS A C B0 B).
      eapply out_one_side_1.
        intro.
        apply H.
        eapply (col_transitivity_1 _ B0); Col.
          intro.
          treat_equalities.
          Col.
        apply col_trivial_3.
      assert_diffs; apply bet_out; Between.
    assert(OS A C B C').
      apply one_side_transitivity with B0.
        apply one_side_symmetry.
        assumption.
      assumption.
    assert(TS A C B' C').
      apply l9_2.
      eapply l9_8_2.
        apply H6.
      assumption.
    split.
      apply col_two_sides_bet with C; assumption.
    split.
      apply l9_2 in H7.
      assert(HH:= l12_21_a A C' B C H7 H9); CongA.
    apply par_symmetry in H8.
    apply invert_two_sides in H6.
    assert(HH:= l12_21_a C B A B' H6 H8); CongA.
Qed.

Lemma cop2_npar__inter : forall A B A' B' X Y,
  Coplanar A B X Y -> Coplanar A' B' X Y -> ~ Par A B A' B' ->
  (exists P, Col P X Y /\ (Col P A B \/ Col P A' B')).
Proof.
    intros.
    induction(par_dec A B X Y).
      assert(~ Par A' B' X Y).
        intro.
        apply H1.
        apply(par_trans _ _ X Y); Par.
      destruct(cop_npar__inter_exists A' B' X Y) as [P []].
        assumption.
        assumption.
      exists P.
      split.
        Col.
      right.
      Col.
    destruct(cop_npar__inter_exists A B X Y) as [P []].
      assumption.
      assumption.
    exists P.
    split.
      Col.
    left.
    Col.
Qed.

Lemma not_par_one_not_par : forall A B A' B' X Y, ~Par A B A' B' -> ~Par A B X Y \/ ~Par A' B' X Y.
Proof.
    intros.
    destruct (par_dec A B X Y).
      right.
      intro.
      apply H.
      apply par_trans with X Y; Par.
    left.
    assumption.
Qed.

Lemma col_par_par_col : forall A B C A' B' C', Col A B C -> Par A B A' B' -> Par B C B' C' -> Col A' B' C'.
Proof.
    intros.
    apply par_distincts in H0.
    apply par_distincts in H1.
    spliter.
    assert(Par A B B C).
      right.
      repeat split; Col.
    assert(Par A' B' B' C').
      apply (par_trans _ _ A' B').
        Par.
      apply (par_trans _ _ B C).
        apply (par_trans _ _ A B); Par.
      Par.
    induction H7.
      apply False_ind.
      apply H7.
      exists B'.
      split; Col.
    spliter.
    Col.
Qed.

Lemma cop_par_perp__perp : forall A B C D P Q, Par A B C D -> Perp A B P Q -> Coplanar C D P Q ->
  Perp C D P Q.
Proof.
    apply universal_posidonius_postulate__perpendicular_transversal_postulate.
    apply playfair__universal_posidonius_postulate.
    unfold playfair_s_postulate; apply parallel_uniqueness.
Qed.

Lemma cop4_par_perp2__par : forall A B C D E F G H,
  Par A B C D -> Perp A B E F -> Perp C D G H ->
  Coplanar A B E G -> Coplanar A B E H ->
  Coplanar A B F G -> Coplanar A B F H ->
  Par E F G H.
Proof.
    apply par_perp_perp_implies_par_perp_2_par.
    intros A B; intros.
    apply (cop_par_perp__perp A B); assumption.
Qed.

End T13.

Section T13_2D.

Context `{T2D:Tarski_2D}.
Context `{TE:@Tarski_euclidean Tn TnEQD}.

Lemma not_par_strict_inter_exists :
 forall A1 B1 A2 B2,
  ~Par_strict A1 B1 A2 B2 ->
  exists X, Col X A1 B1 /\ Col X A2 B2.
Proof.
    intros A1 B1 A2 B2.
    apply (cop_npars__inter_exists).
    apply all_coplanar.
Qed.

Lemma not_par_inter_exists : forall A1 B1 A2 B2,
  ~ Par A1 B1 A2 B2 -> exists X, Col X A1 B1 /\ Col X A2 B2.
Proof.
    intros A1 B1 A2 B2.
    apply cop_npar__inter_exists.
    apply all_coplanar.
Qed.

Lemma l12_16_2D : forall A1 A2 B1 B2 C1 C2 X,
  Par A1 A2 B1 B2 -> Inter A1 A2 C1 C2 X -> exists Y, Inter B1 B2 C1 C2 Y.
Proof.
    intros.
    assert (HC := all_coplanar B1 B2 C1 C2).
    apply l12_16 with A1 A2 X; assumption.
Qed.

Lemma par_inter : forall A B C D P Q,
  Par A B C D -> ~Par A B P Q ->
  exists Y, Col P Q Y /\ Col C D Y.
Proof.
    intros.
    assert (HC := all_coplanar C D P Q).
    apply (cop_par__inter A B); assumption.
Qed.

Lemma not_par_inter : forall A B A' B' X Y, ~Par A B A' B' -> (exists P, Col P X Y /\ (Col P A B \/ Col P A' B')).
Proof.
    intros.
    assert (HC := all_coplanar).
    apply (cop2_npar__inter); auto.
Qed.

Lemma par_perp__perp : forall A B C D P Q, Par A B C D -> Perp A B P Q ->
  Perp C D P Q.
Proof.
    intros A B C D P Q HPar HPer.
    assert (HCop := all_coplanar C D P Q).
    apply (cop_par_perp__perp A B); assumption.
Qed.

Lemma par_perp2__par : forall A B C D E F G H,
  Par A B C D -> Perp A B E F -> Perp C D G H ->
  Par E F G H.
Proof.
    intros A B C D; intros.
    apply (cop4_par_perp2__par A B C D); try (apply all_coplanar); assumption.
Qed.

End T13_2D.


Require Import Nijn.Prelude.Checks.
Require Import Nijn.Prelude.Basics.Decidable.
Require Import Nijn.Prelude.Relations.WellfoundedRelation.

Declare Scope qr.
Open Scope qr.
Delimit Scope qr with qr.

(** * Quasi-orders *)
Record QuasiRel :=
  {
    carrier_qr :> Type ;
    ge_qr : carrier_qr -> carrier_qr -> Prop
  }.

Arguments ge_qr {_} _ _.

Notation "x >= y" := (ge_qr x y) : qr.

Class isQuasiRel ( X : QuasiRel ) :=
  {
    ge_qr_refl : forall (x : X),
      x >= x;
    ge_qr_trans : forall { x y z : X },
      x >= y -> y >= z -> x >= z
  }.

Close Scope qr.

(** * Compatible relations *)

Declare Scope compat.
Open Scope compat.
Delimit Scope compat with compat.

(** A compatible relation is a type equipped with two relations *)
Record CompatRel :=
  {
    carrier :> Type ;
    gt : carrier -> carrier -> Prop ;
    ge : carrier -> carrier -> Prop
  }.

Arguments gt {_} _ _.
Arguments ge {_} _ _.

Notation "x > y" := (gt x y) : compat.
Notation "x >= y" := (ge x y) : compat.

(** These are the axioms that should hold for compatible relations. Note that we do not require the relations to be well-founded, but that condition is formulated separately. *)
Class isCompatRel (X : CompatRel) :=
  {
    gt_trans : forall {x y z : carrier X},
      x > y -> y > z -> x > z ;
    ge_trans : forall {x y z : X},
      x >= y -> y >= z -> x >= z ;
    ge_refl : forall (x : X),
      x >= x ;
    compat : forall {x y : X},
      x > y -> x >= y ;
    ge_gt : forall {x y z : X},
      x >= y -> y > z -> x > z ;
    gt_ge : forall {x y z : X},
      x > y -> y >= z -> x > z
  }.

(** ** Lemmata for compatible relations *)
Proposition eq_gt
            {X : CompatRel}
            {x y z : X}
            (p : x = y)
            (q : y > z)
  : x > z.
Proof.
  induction p.
  exact q.
Qed.

Proposition gt_eq
            {X : CompatRel}
            {x y z : X}
            (p : x > y)
            (q : y = z)
  : x > z.
Proof.
  induction q.
  exact p.
Qed.

Proposition eq_ge
            {X : CompatRel}
            {x y z : X}
            (p : x = y)
            (q : y >= z)
  : x >= z.
Proof.
  induction p.
  exact q.
Qed.

Proposition ge_eq
            {X : CompatRel}
            {x y z : X}
            (p : x >= y)
            (q : y = z)
  : x >= z.
Proof.
  induction q.
  exact p.
Qed.

Proposition eq_to_ge
            {X : CompatRel}
            `{isCompatRel X}
            {x y : X}
            (p : x = y)
  : x >= y.
Proof.
  induction p.
  apply ge_refl.
Qed.

(** ** Minimal elements in a compatible relation *)
Definition is_minimal_element
           {X : CompatRel}
           (x : X)
  : Prop
  := forall (y : X), y >= x.

Record minimal_element (X : CompatRel) :=
  make_min_el
    {
      min_el :> X ;
      is_minimal : is_minimal_element min_el
    }.

Definition is_strict_minimal_element
           {X : CompatRel}
           (x : X)
  : Prop
  := forall (y : X), y <> x -> y > x.

Record strict_minimal_element (X : CompatRel) :=
  make_strict_min_el
    {
      strict_min_el :> X ;
      is_strict_minimal : is_strict_minimal_element strict_min_el
    }.

Definition is_minimal_to_strict_minimal
           {X : CompatRel}
           `{decEq X}
           `{isCompatRel X}
           (x : strict_minimal_element X)
  : minimal_element X.
Proof.
  simple refine (make_min_el _ _ _).
  - exact x.
  - intros y.
    destruct (dec_eq y x) as [ p | p ].
    + apply eq_to_ge.
      exact p.
    + exact (compat (is_strict_minimal _ x y p)).
Defined.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                  Zgcd.v                                  *)
(****************************************************************************)
Require Export misc.
Require Export Zadd.
Require Export Zle.
Require Export Euclid.
Require Export Peano_dec.
Require Export Zrec.
Require Export Zmult.
Require Export Zdiv.

Unset Standard Proposition Elimination Names.

(***************************)
Lemma gcd_unicity_apart_sign :
 forall a b d1 d2 : Z,
 is_gcd Z IdZ multZ OZ a b d1 ->
 is_gcd Z IdZ multZ OZ a b d2 -> d2 = d1 \/ d2 = oppZ d1.

intros.
elim
 (gcd_unicity_apart_unities Z IdZ addZ multZ OZ IZ oppZ
    Z_unitary_commutative_ring integrityZ a b d1 d2 H H0).
intros.
elim (inversibleZ x); intros.
left. elim H1; intros; elim H4; intros. rewrite H6. rewrite H2.
exact (mult_IZ d1).
right. elim H1; intros; elim H4; intros. rewrite H6. rewrite H2.
simpl in |- *; exact (mult_mIZ d1).
elim H1; intros; exact H2.
Qed.

(***********)
Lemma gcd_OZ_absZ : forall b : Z, is_gcd Z IdZ multZ OZ OZ b (absZ b).

intros. elim (abs_eq_or_oppZ b); intro y.
(* |b|=b *)
rewrite y.
unfold is_gcd in |- *; split.
unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I. left; reflexivity.
split; unfold divide in |- *; unfold IdZ in |- *. split. exact I. split. exact I.
elim (eq_OZ_dec b); intro y0.
left; exact y0.
right. split. exact y0. exists IZ. split. exact I. symmetry  in |- *; exact (mult_IZ b).
intros; exact H0.
(* |b|=(-b) *)
rewrite y.
unfold is_gcd in |- *; split.
unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I. left; reflexivity.
split; unfold divide in |- *; unfold IdZ in |- *; split. exact I. split. exact I.
elim (eq_OZ_dec b); intro y0.
left; exact y0.
right. split.
unfold not in |- *; intros; elim y0.
exact (opp_O Z IdZ addZ multZ OZ oppZ Z_ring b I H).
exists (oppZ IZ); split. exact I.
rewrite (mult_opp_opp Z IdZ addZ multZ OZ oppZ Z_ring b IZ I I).
symmetry  in |- *; exact (mult_IZ b). exact I. split. exact I.
elim H0; intros; elim H2; intros; elim H4; intros. rewrite H5.
left; reflexivity.
right; split. elim H5; intros; exact H6. elim H5; intros; elim H7; intros.
exists (oppZ x). split. exact I. elim H8; intros; rewrite H10.
symmetry  in |- *; exact (mult_opp_r Z IdZ addZ multZ OZ oppZ Z_ring q x I I).
Qed.

(******************)
Inductive is_gcdZ : Z -> Z -> Z -> Prop :=
  | gcd_OZ : forall b : Z, is_gcdZ OZ b (absZ b)
  | gcd_mod :
      forall b a d q r : Z,
      b <> OZ -> is_diveuclZ a b q r -> is_gcdZ r b d -> is_gcdZ b a d.

(******************)
Definition have_gcdZ (a b : Z) := {d : Z | is_gcdZ a b d}.

Definition gcdZ_i (a b : Z) := exist (is_gcdZ a b).

(* Inductive have_gcdZ [a, b: Z]: Set
  := gcdZ_i: (d: Z) (is_gcdZ a b d) -> (have_gcdZ a b). *)

(*******************)
Definition P (a : Z) := forall b : Z, have_gcdZ a b.

Lemma acc_P : forall n : Z, (forall m : Z, lt_absZ m n -> P m) -> P n.
Proof.
  intros. case (eq_OZ_dec n); intro. unfold P in |- *. intro.
  split with (absZ b). rewrite e. apply (gcd_OZ b).
  unfold P in |- *; intro. elim (divZ b n). intros. cut (lt_absZ r n); intros.
  elim (H r H0 n). intros. split with x.
  apply gcd_mod with (2 := i); trivial. inversion i. decompose [and] H1.
  unfold lt_absZ in |- *. rewrite (tech_le_pos_abs r H2). exact H4. exact n0.
Qed.

Lemma gcdZ_exists : forall a b : Z, have_gcdZ a b.
Proof.
  exact (recZ P acc_P).
Qed.

(****************)
Lemma gcdZ_is_gcd :
 forall a b d : Z, is_gcdZ a b d -> is_gcd Z IdZ multZ OZ a b d.

intros. elim H; intros. apply (gcd_OZ_absZ b0). unfold is_gcd in |- *.
split. elim H3; intros; elim H5; intros; exact H6.
split. elim H1; intros; elim H5; intros; elim H7; intros; rewrite H9.
apply (div_add Z IdZ addZ multZ OZ oppZ Z_ring (multZ b0 q) r d0).
elim H3; intros; elim H11; intros.
exact (div_mult Z IdZ addZ multZ OZ oppZ Z_ring b0 q d0 H12 I).
elim H3; intros; exact H10.
intros. elim H3; intros; elim H7; intros. apply (H9 q0).
cut (r = addZ a0 (oppZ (multZ b0 q))); intros. rewrite H10.
apply (div_add Z IdZ addZ multZ OZ oppZ Z_ring a0 (oppZ (multZ b0 q)) q0 H5).
apply (div_opp Z IdZ addZ multZ OZ oppZ Z_ring (multZ b0 q) q0).
exact (div_mult Z IdZ addZ multZ OZ oppZ Z_ring b0 q q0 H4 I).
elim H1; intros; elim H11; intros; elim H13; intros; rewrite H15.
elim (addZ_commutativity r (multZ b0 q)).
elim (addZ_associativity r (multZ b0 q) (oppZ (multZ b0 q))).
elim (addZ_opposite (multZ b0 q) I); intros.
elim H17; intros. elim H19; intros. rewrite H20. symmetry  in |- *. exact (add_OZ r).
exact H4.
Qed.

(*************)
Definition gcdZ (a b : Z) := pi1 Z (is_gcdZ a b) (gcdZ_exists a b).

(*******************)
Theorem gcdZ_correct : forall a b : Z, is_gcdZ a b (gcdZ a b).
Proof fun a b : Z => pi2 Z (is_gcdZ a b) (gcdZ_exists a b).

(*********************)
Lemma positive_is_gcdZ : forall a b d : Z, is_gcdZ a b d -> leZ OZ d.

intros; elim H; intros. apply (sign_absZ b0). exact H3.
Qed.

(********************)
Lemma unicity_is_gcdZ :
 forall a b d1 d2 : Z, is_gcdZ a b d1 -> is_gcdZ a b d2 -> d2 = d1.

intros.
elim
 (gcd_unicity_apart_sign a b d1 d2 (gcdZ_is_gcd a b d1 H)
    (gcdZ_is_gcd a b d2 H0)).
intros; exact H1.
intros;
 apply
  (le_opp_OZ2 d2 d1 H1 (positive_is_gcdZ a b d2 H0)
     (positive_is_gcdZ a b d1 H)).
Qed.

(*****************)
Lemma gcdZ_is_gcdZ : forall a b d : Z, is_gcdZ a b d -> d = gcdZ a b.

intros. apply (unicity_is_gcdZ a b (gcdZ a b) d (gcdZ_correct a b) H).
Qed.

(*************)
Lemma gcd_modZ :
 forall a b q r : Z, b <> OZ -> is_diveuclZ a b q r -> gcdZ r b = gcdZ b a.

intros. apply (gcdZ_is_gcdZ b a (gcdZ r b)).
apply (gcd_mod b a (gcdZ r b) q r H H0 (gcdZ_correct r b)).
Qed.

(*********************************)
Inductive verify_BezoutZ (a b : Z) : Set :=
    Bezout_i :
      forall u v : Z,
      addZ (multZ a u) (multZ b v) = gcdZ a b -> verify_BezoutZ a b.

(********************)
Definition Q (a : Z) := forall b : Z, verify_BezoutZ a b.

Lemma acc_Q : forall n : Z, (forall m : Z, lt_absZ m n -> Q m) -> Q n.
Proof.
  intros q f. case (eq_OZ_dec q); intro. unfold Q in |- *; intro b.
  split with IZ (sgnZ b). rewrite e. simpl in |- *. rewrite (sgn_abs b).
  apply (gcdZ_is_gcdZ OZ b (absZ b)); apply gcd_OZ. unfold Q in |- *; intro b.
  elim (divZ b q). intros div rem; intros. cut (lt_absZ rem q); intros.
  elim (f rem H q). intros. split with (addZ v (oppZ (multZ div u))) u.
  elim i. intros. elim H1. intros. elim H3. intros. pattern b at 1 in |- *.
  rewrite H5. elim (mult_add_distributivity q v (oppZ (multZ div u))); intros.
  rewrite H7. elim (mult_add_distributivity (multZ q div) rem u); intros.
  rewrite H8. rewrite (mult_opp_r Z IdZ addZ multZ OZ oppZ Z_ring q (multZ div u) I I).
  elim (addZ_commutativity (multZ rem u) (multZ (multZ q div) u)).
  rewrite
   (add_add Z addZ addZ_commutativity addZ_associativity
      (multZ q v) (oppZ (multZ q (multZ div u))) (multZ rem u)
      (multZ (multZ q div) u)).
    elim (addZ_commutativity (multZ rem u) (multZ q v)). rewrite e.
    elim (multZ_associativity q div u).
    elim (addZ_opposite (multZ q (multZ div u)) I); intros.
    elim H11; intros; elim H13; intros. rewrite H15.
    rewrite (add_OZ (gcdZ rem q)).
    exact (gcd_modZ b q div rem n i). unfold lt_absZ in |- *.
    elim i; intros; elim H0; intros. rewrite (tech_le_pos_abs rem H1).
    elim H2; trivial. exact n.
Qed.

Lemma Bezout_exists : forall a b : Z, verify_BezoutZ a b.
Proof.
  exact (recZ Q acc_Q).
Qed.

(******************)
Definition congruentZ (x y n : Z) :=
  divide Z IdZ multZ OZ n (addZ x (oppZ y)).

(*****************)
Lemma divide_selfZ : forall x : Z, divide Z IdZ multZ OZ x x.

intros. unfold divide in |- *. split. exact I. split. exact I.
elim (eq_OZ_dec x); intros. left; exact a.
right; split. exact b. exists IZ. split. exact I. symmetry  in |- *; exact (mult_IZ x).
Qed.

(**********************************)
Theorem chinese_remaindering_theorem :
 forall a b x y : Z,
 gcdZ a b = IZ -> {z : Z | congruentZ z x a /\ congruentZ z y b}.

intros. elim (Bezout_exists a b); intros.
exists (addZ (multZ x (multZ b v)) (multZ y (multZ a u))).
unfold congruentZ in |- *; split.
(* congruentZ (z, x, a) *)
replace (multZ b v) with (addZ IZ (oppZ (multZ a u))).
elim (mult_add_distributivity x IZ (oppZ (multZ a u))); intros.
rewrite H1; clear H0 H1. rewrite (mult_IZ x).
elim (mult_opp_r Z IdZ addZ multZ OZ oppZ Z_ring a u I I).
rewrite (multZ_associativity x a (oppZ u)). elim (multZ_commutativity a x).
elim (multZ_associativity a x (oppZ u)). rewrite (multZ_associativity y a u).
elim (multZ_commutativity a y). elim (multZ_associativity a y u).
elim
 (addZ_associativity x (multZ a (multZ x (oppZ u))) (multZ a (multZ y u))).
elim
 (addZ_commutativity
    (addZ (multZ a (multZ x (oppZ u))) (multZ a (multZ y u))) x).
elim
 (addZ_associativity
    (addZ (multZ a (multZ x (oppZ u))) (multZ a (multZ y u))) x
    (oppZ x)).
elim (addZ_opposite x I); intros. elim H1; intros. elim H3; intros.
rewrite H4; clear H0 H1 H2 H3 H4 H5.
rewrite (add_OZ (addZ (multZ a (multZ x (oppZ u))) (multZ a (multZ y u)))).
apply
 (div_add Z IdZ addZ multZ OZ oppZ Z_ring (multZ a (multZ x (oppZ u)))
    (multZ a (multZ y u)) a).
apply
 (div_mult Z IdZ addZ multZ OZ oppZ Z_ring a (multZ x (oppZ u)) a
    (divide_selfZ a) I).
apply
 (div_mult Z IdZ addZ multZ OZ oppZ Z_ring a (multZ y u) a (divide_selfZ a) I).
elim H. elim e.
elim (addZ_commutativity (multZ b v) (multZ a u)).
elim (addZ_associativity (multZ b v) (multZ a u) (oppZ (multZ a u))).
elim (addZ_opposite (multZ a u) I); intros. elim H1; intros. elim H3; intros.
rewrite H4; clear H0 H1 H2 H3 H4 H5. exact (add_OZ (multZ b v)).
(* congruentZ (z y b) *)
cut (multZ a u = addZ IZ (oppZ (multZ b v))); intros.
rewrite H0; clear H0.
elim (mult_add_distributivity y IZ (oppZ (multZ b v))); intros.
rewrite H1; clear H0 H1. rewrite (mult_IZ y).
elim (mult_opp_r Z IdZ addZ multZ OZ oppZ Z_ring b v I I).
rewrite (multZ_associativity y b (oppZ v)). elim (multZ_commutativity b y).
elim (multZ_associativity b y (oppZ v)). rewrite (multZ_associativity x b v).
elim (multZ_commutativity b x). elim (multZ_associativity b x v).
elim (addZ_commutativity (multZ b (multZ y (oppZ v))) y).
rewrite
 (addZ_associativity (multZ b (multZ x v)) (multZ b (multZ y (oppZ v))) y)
 .
elim
 (addZ_associativity
    (addZ (multZ b (multZ x v)) (multZ b (multZ y (oppZ v)))) y
    (oppZ y)).
elim (addZ_opposite y I); intros. elim H1; intros. elim H3; intros.
rewrite H4; clear H0 H1 H2 H3 H4 H5.
rewrite (add_OZ (addZ (multZ b (multZ x v)) (multZ b (multZ y (oppZ v))))).
apply
 (div_add Z IdZ addZ multZ OZ oppZ Z_ring (multZ b (multZ x v))
    (multZ b (multZ y (oppZ v))) b).
apply
 (div_mult Z IdZ addZ multZ OZ oppZ Z_ring b (multZ x v) b (divide_selfZ b) I).
apply
 (div_mult Z IdZ addZ multZ OZ oppZ Z_ring b (multZ y (oppZ v)) b
    (divide_selfZ b) I).
elim H. elim e.
elim (addZ_associativity (multZ a u) (multZ b v) (oppZ (multZ b v))).
elim (addZ_opposite (multZ b v) I); intros. elim H1; intros. elim H3; intros.
rewrite H4; clear H0 H1 H2 H3 H4 H5. symmetry  in |- *; exact (add_OZ (multZ a u)).
Qed.


Require Import Coq.ZArith.BinInt.
Inductive type := Z | prod (A B : type) | arrow (s d : type).
Inductive expr {var:type -> Type} : type -> Type :=
| LetIn {s d} (x : expr s) (f : var s -> expr d) : expr d
| App {s d} (f : expr (arrow s d)) (x : expr s) : expr d
| Abs {s d} (f : var s -> expr d) : expr (arrow s d)
| Var {t} (v : var t) : expr t
| Pair {A B} (x : expr A) (y : expr B) : expr (prod A B)
| Fst {A B} (x : expr (prod A B)) : expr A
| Snd {A B} (x : expr (prod A B)) : expr B
| Add (x y : expr Z) : expr Z
| Mul (x y : expr Z) : expr Z
| Sub (x y : expr Z) : expr Z
| Opp (x : expr Z) : expr Z
| Literal (v : BinInt.Z) : expr Z
| AddWithGetCarry (x y c : expr Z) : expr (prod Z Z)
| CastToSize (lower upper : BinInt.Z) (v : expr Z) : expr Z.

Delimit Scope etype_scope with etype.
Delimit Scope expr_scope with expr.
Bind Scope etype_scope with type.
Bind Scope expr_scope with expr.
Infix "*" := prod : etype_scope.
Infix "*" := Mul : expr_scope.
Infix "->" := arrow : etype_scope.
Infix "-" := Sub : expr_scope.
Infix "+" := Add : expr_scope.

(* Syntax of notations (e.g., \texttt{Infix "+" := add.}; \texttt{Notation "a + b" := (add a b).}) *)
(* Notation bodies must be parenthesized *)
(* How to use levels and associativity, how to pick levels, how to discover levels of existing notations (\texttt{Print Grammar constr}) *)
(* Controlling display: \texttt{format}, extra spaces, quoting symbols, boxes in \texttt{format} for display of indentation, newlines, and whitespace *)
(* Recursive notations: \texttt{..} for pair- and $\lambda$-like things *)
(* \texttt{Reserved Notation} and \texttt{only printing}, useful for ensuring that notations don't conflict *)
(* Using single-variable only-printing notations for hiding identifiers *)
(* Abbreviations vs notations (what it means when your \texttt{Notation} doesn't have quotes, and why you might want this) *)
(* Notation scopes, useful for overloading notations and selecting the right one automatically (\texttt{Bind Scope}, \texttt{Delimit Scope}, \texttt{Open Scope}) *)
(* Using binders for destructuring pairs *)
(* Parenthesizing notations: when to use parentheses, and when to use levels *)
(* Deliberate ordering of notations: how to express wildcard and negation in notation matching *)


(**)

Require Export Utf8_core.
Add LoadPath "/home/user/0data/diploma/experiments/1503/anc".
Require Export Bool.
Require Export a_base.
Export ListNotations.
Set Implicit Arguments.

Module Type sound_mod (X: base_mod).
Import X.

(** * Definitions

definition of Propositional Formulas*)
Inductive PropF : Set :=
 | Var : PropVars -> PropF
 | Bot : PropF
 | Conj : PropF -> PropF -> PropF
 | Disj : PropF -> PropF -> PropF
 | Impl : PropF -> PropF -> PropF
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A \u2228 B" := (Disj A B) (at level 15, right associativity) : My_scope.
Notation "A \u2227 B" := (Conj A B) (at level 15, right associativity) : My_scope.
Notation "A \u2192 B" := (Impl A B) (at level 16, right associativity) : My_scope.
Notation "\u22a5" := Bot (at level 0)  : My_scope.
Definition Neg A := A \u2192 \u22a5.
Notation "\u00ac A" := (Neg A) (at level 5) : My_scope.
Definition Top := \u00ac\u22a5.
Notation "\u22a4" := Top (at level 0) : My_scope.
Definition BiImpl A B := (A\u2192B)\u2227(B\u2192A).
Notation "A \u2194 B" := (BiImpl A B) (at level 17, right associativity) : My_scope.

(** Validness *)

(** Valuations are maps PropVars -> bool sending \u22a5 to false*)
Fixpoint TrueQ v A : bool := match A with
 | # P   => v P
 | \u22a5     => false
 | B \u2228 C => (TrueQ v B) || (TrueQ v C)
 | B \u2227 C => (TrueQ v B) && (TrueQ v C)
 | B \u2192 C => (negb (TrueQ v B)) || (TrueQ v C)
end.
(*G= G*)
Definition Satisfies v G := forall A, In A G -> Is_true (TrueQ v A).
Definition Models G A := forall v,Satisfies v G->Is_true (TrueQ v A).
Notation "G \u22a8 A" := (Models G A) (at level 80).
Definition Valid A := [] \u22a8 A.

(** Provability *)

Reserved Notation "G \u22a2 A" (at level 80).
Inductive Nc : list PropF-> PropF->Prop :=
| Nax   : forall G A  ,    In A G                           -> G \u22a2 A
| ImpI  : forall G A B,  A::G \u22a2 B                           -> G \u22a2 A \u2192 B
| ImpE  : forall G A B,     G \u22a2 A \u2192 B -> G \u22a2 A              -> G \u22a2 B
| BotC  : forall G A  , \u00acA::G \u22a2 \u22a5                              -> G \u22a2 A
| AndI  : forall G A B,     G \u22a2 A     -> G \u22a2 B              -> G \u22a2 A\u2227B
| AndE1 : forall G A B,     G \u22a2 A\u2227B                        -> G \u22a2 A
| AndE2 : forall G A B,     G \u22a2 A\u2227B                        -> G \u22a2 B
| OrI1  : forall G A B,     G \u22a2 A                           -> G \u22a2 A\u2228B
| OrI2  : forall G A B,     G \u22a2 B                           -> G \u22a2 A\u2228B
| OrE   : forall G A B C,   G \u22a2 A\u2228B -> A::G \u22a2 C -> B::G \u22a2 C -> G \u22a2 C
where "G \u22a2 A" := (Nc G A) : My_scope.

Definition Provable A := [] \u22a2 A.

(**The Theorems we are going to prove*)
Definition Prop_Soundness := forall A,Provable A->Valid A.
Definition Prop_Completeness := forall A,Valid A->Provable A.

(** * Theorems *)

Ltac mp := eapply ImpE.
Ltac AddnilL := match goal with
| |- _ ?G _ => change G with ([]++G)
end.
Ltac in_solve := intros;repeat
 (eassumption
||match goal with
   | H:In _ (_::_) |- _ => destruct H;[subst;try discriminate|]
   | H:In _ (_++_) |- _ => apply in_app_iff in H as [];subst
   | |- In _ (_++_) => apply in_app_iff;(left;in_solve;fail)||(right;in_solve;fail)
  end
||(constructor;reflexivity)
||constructor 2).
Ltac is_ass := econstructor;in_solve.

Ltac case_bool v A := let HA := fresh "H" in
(case_eq (TrueQ v A);intro HA;try rewrite HA in *;simpl in *;try trivial;try contradiction).

Local Ltac prove_satisfaction :=
intros ? K;destruct K;[subst;simpl;
match goal with
| [ H : TrueQ _ _ = _  |-  _ ] => rewrite H
end;exact I|auto].

Open Scope My_scope.

(*Check My_scope.Varseq_dec.
Check M.Varseq_dec.
Check base_mod.Varseq_dec.
Import base_mod.*)

Lemma PropFeq_dec : forall (x y : PropF), {x = y}+{x <> y}.
induction x;destruct y;try (right;discriminate);
 try (destruct (IHx1 y1);[destruct (IHx2 y2);[left;f_equal;assumption|]|];
  right;injection;intros;contradiction).
 destruct (Varseq_dec p p0).
   left;f_equal;assumption.
   right;injection;intro;contradiction.
 left;reflexivity.
Qed.

Lemma Excluded_Middle : forall G A, G \u22a2 A\u2228\u00acA.
intros;apply BotC;mp;[is_ass|apply OrI2;apply ImpI;mp;[is_ass|apply OrI1;is_ass]].
Qed.

Lemma weakening2 : forall G A, G \u22a2 A -> forall D, (forall B, In B G -> In B D) -> D \u22a2 A.
induction 1;[constructor|constructor 2|econstructor 3|constructor 4|constructor 5|econstructor 6
|econstructor 7|constructor 8|constructor 9|econstructor 10];try eauto;
[apply IHNc..|apply IHNc2|try apply IHNc3];intros;in_solve;eauto.
Qed.

Lemma weakening : forall G D A, G \u22a2 A -> G++D \u22a2 A.
intros;eapply weakening2;[eassumption|in_solve].
Qed.

Lemma deduction : forall G A B, G \u22a2 A \u2192 B -> A::G \u22a2 B.
intros;eapply ImpE with A;[eapply weakening2;[eassumption|in_solve]|is_ass].
Qed.

Lemma prov_impl : forall A B, Provable (A \u2192 B)->forall G, G \u22a2 A -> G \u22a2 B.
intros. mp.
  AddnilL;apply weakening. apply H.
  assumption.
Qed.

(* This tactic applies prov_impl in IH (apply prov_impl in IH doesn't work, because I want to keep the G quantified)*)
Ltac prov_impl_in IH := let H := fresh "K" in
try (remember (prov_impl IH) as H eqn:HeqH;clear IH HeqH).

(** Soundness *)

Theorem Soundness_general : forall A G, G \u22a2 A -> G \u22a8 A.
intros A G H0 v;induction H0;simpl;intros;auto;
 try simpl in IHNc;try simpl in IHNc1;try simpl in IHNc2;
  case_bool v A;try (case_bool v B;fail);
   try (apply IHNc||apply IHNc2;prove_satisfaction);
    case_bool v B;apply IHNc3;prove_satisfaction.
Qed.

Theorem Soundness : Prop_Soundness.
intros ? ? ? ?;eapply Soundness_general;eassumption.
Qed.

End sound_mod.


Require Import Setoid.

Class monad (M: Type -> Type) :=
  { ret {A}: A -> M A;
    bind {A B}: M A -> (A -> M B) -> M B;
    _: forall A B (x: A) (f: A -> M B), bind (ret x) f = f x;
    _: forall A (ma: M A), bind ma ret = ma;
    _: forall A B C (ma: M A) (f: A -> M B) (g: B -> M C), bind ma (fun x => bind (f x) g) = bind (bind ma f) g }.

Notation "E >>= F" := (bind E F) (at level 11, right associativity).

Notation "X <- E ; F" := (bind E (fun X => F)) (at level 11, right associativity).

Open Scope list_scope.

Inductive Proba {a: Type} := Outcome: list (nat * a) -> Proba.

Fixpoint uniform {a: Type} (xs: list a) := match xs with
| x :: xs =>
  match uniform xs with
  | Outcome os => Outcome ((1, x) :: os)
  end
| nil => Outcome nil
end.

Require Import List PeanoNat.

Fixpoint mulp {a} p (ys: list (nat * a)) := match ys with
  nil => nil
| (p', y)::ys' => (p*p', y)::mulp p ys'
end.

Lemma mulp_1 {a} (ys: list (nat * a)): mulp 1 ys = ys.
Proof.
    induction ys.
    - auto.
    - (*Search (mulp 1).*) simpl. case a0.
      intros. (*Search (?x+0).*)
      rewrite <-plus_n_O.
      rewrite IHys. apply eq_refl.
Qed.

Lemma mulp_xy {a} x y (l: list (nat * a)):
  mulp x (mulp y l) = mulp (x * y) l.
Proof.
  induction l.
  - auto.
  - case a0. intros. simpl. rewrite IHl.
  (*Search _ "assoc".*)
  rewrite Nat.mul_assoc. apply eq_refl.
Qed.

Lemma mulp_concat {a} x (l1 l2: list (nat * a)):
  mulp x l1 ++ mulp x l2 = mulp x (l1 ++ l2).
Proof.
  induction l1.
  - (*Search (nil ++ _).*) apply app_nil_l.
  - simpl. case a0. intros. rewrite <-IHl1. apply eq_refl.
Qed.

Fixpoint bindx {a b} (xs: list (nat * a)) (f: a -> @Proba b) := match xs with
  nil => Outcome nil
| (p, x)::xs' =>
    let 'Outcome y := f x in
    let 'Outcome ys' := bindx xs' f in
    Outcome (mulp p y ++ ys')
end.

Program Instance proba_monad : monad (@Proba) :=
  {
      ret _ x := Outcome ((1, x) :: nil);
      bind _ _ os f := let 'Outcome xs := os in bindx xs f
  }.

Next Obligation.
destruct (f x).
rewrite mulp_1.
rewrite app_nil_r.
auto.
Qed.

Next Obligation.
destruct ma.
induction l.
- auto.
- simpl. destruct a. rewrite IHl. rewrite Nat.mul_1_r. auto.
Qed.

Next Obligation.
destruct ma.
induction l.
- simpl. auto.
- destruct a. simpl. rewrite IHl.
  destruct (bindx l f), (f a).
  induction l1.
  + simpl. destruct (bindx l0 g). auto.
  + simpl mulp. destruct a0.
    rewrite <- app_comm_cons.
    simpl bindx. rewrite <- IHl1.
    destruct (g b).
    destruct (bindx l1 g).
    destruct (bindx l0 g).
    rewrite <- mulp_concat.
    rewrite <- mulp_xy.
    rewrite app_assoc.
    auto.
Defined.

Definition dice := uniform (1::2::3::4::5::6::nil).

Program Instance option_monad: monad option := {
  ret _ x := Some x;
  bind _ _ x f := match x with
    Some x => f x
  | None => None
  end
}.

Next Obligation.
destruct ma; auto.
Qed.

Next Obligation.
destruct ma; auto.
Qed.

(* Now diceTwice is polymorphic on the type of the monad *)
Definition diceTwice {m} {_: monad m} dice :=
    x <- dice; y <- dice; ret (x+y).
(*
  Alternative, equivalent definitions:
    dice >>= (fun x => dice >>= (fun y => ret (x + y))).
    bind dice (fun x => bind dice (fun y => ret (x+y))). *)

Check fold_left.
Definition probOf {a} m (f: a -> bool) :=
  let 'Outcome xs := m in
  fold_left (fun n '(p,y) => n + p) (filter (fun '(p,x) => f x) xs) 0.

Print diceTwice.
(* For example it can work on probability distributions *)
Compute (diceTwice dice).

Fixpoint range_ start stop xs :=
  if start =? stop then start::xs
  else match stop with
    (S x) => range_ start x (stop::xs)
  | 0 => stop::xs
  end.
Definition range start stop := range_ start stop nil.
Lemma rangeSn n: 1 <= n ->
  range 1 (S n) = range 1 n ++ (S n::nil).
Proof.
  intros H.
  induction n.
  - apply Nat.nle_succ_0 in H.
    contradiction.
  - destruct (n).
    + auto.
    + rewrite IHn. simpl.
      rewrite app_assoc_reverse.
      simpl.
      auto.
      Search ((_ ++ _) ++ _).

  simpl. auto.

Lemma mostProbableThrow n:
  forall m, 1 <= m <= n ->
  (probOf (diceTwice (uniform (range 1 n))) (fun x => x =? (1+m))) = m /\
  (probOf (diceTwice (uniform (range 1 n))) (fun x => x =? (2*n+1-m))) = m.
Proof.
  induction n.
  - intros m H.
    destruct m.
    auto.
    inversion H.
    apply Nat.nle_succ_0 in H1.
    contradiction.
  - intros m H.
    apply IHn in m.

Qed.

Require Extraction.

Extraction Language Haskell.

Extraction diceTwice.


Require Import String.

(*
data PTyp a = Var a | Forall (a -> PSigma a) | Fun (PSigma a) (PSigma a) | PInt

data PSigma a = And (PSigma a) (PSigma a) | Typ (PTyp a)
*)

(*
Inductive S := Base | Inter.

Inductive PTyp A : S -> Type :=
  | Var : A -> PTyp A Base
  | PInt : PTyp A Base
  | Fun : PTyp A Inter -> PTyp A Inter -> PTyp A Base
  | And : PTyp A Inter -> PTyp A Inter -> PTyp A Inter
  | Lift : PTyp A Base -> PTyp A Inter.
*)

Inductive PTyp A :=
  | Var : A -> PTyp A
  | PInt : PTyp A
  | Forall : (A -> PTyp A) -> PTyp A
  | Fun : PTyp A -> PTyp A -> PTyp A
  | And : PTyp A -> PTyp A -> PTyp A.

(*

----------
|t1 <: t2|
----------

a <: a                             Sub-Var

           t1 <: t2
------------------------------     Sub-Forall
forall a . t1 <: forall a . t2

t3 <: t1     t2 <: t4
---------------------              Sub-Arrow
t1 -> t2 <: t3 -> t4

t <: t1   t <: t2
-----------------                  Sub-&1
t <: t1 & t2

t1 <: t
------------                       Sub-&2
t1 & t2 <: t

t2 <: t
------------                       Sub-&3
t1 & t2 <: t

*)

Require Import Arith.
Require Import Setoid.

(* Subtyping relation *)

Inductive sub : nat -> PTyp nat -> PTyp nat -> Prop :=
  | SInt : forall i, sub i (PInt nat) (PInt nat)
  | SVar : forall i x, sub i (Var nat x) (Var nat x)
  | SForall : forall i f g, sub (i+1) (f i) (g i) -> sub i (Forall nat f) (Forall nat g)
  | SFun : forall i o1 o2 o3 o4, sub i o3 o1 -> sub i o2 o4 -> sub i (Fun nat o1 o2) (Fun nat o3 o4)
  | SAnd1 : forall i t t1 t2, sub i t t1 -> sub i t t2 -> sub i t (And nat t1 t2)
  | SAnd2 : forall i t t1 t2, sub i t1 t -> sub i (And nat t1 t2) t
  | SAnd3 : forall i t t1 t2, sub i t2 t -> sub i (And nat t1 t2) t.

Hint Resolve SVar SInt SForall SFun SAnd1 SAnd2 SAnd3.

Lemma reflex : forall t1 i, sub i t1 t1.
Proof.
induction t1; intros; auto.
Defined.

Lemma invAndS1 : forall t t1 t2 i, sub i t (And nat t1 t2) -> sub i t t1 /\ sub i t t2.
Proof.
(*
induction t; intros; split; try (inversion H); auto.
*)
induction t; intros.
(* Case Var *)
inversion H.
split.
exact H4.
exact H5.
(* Case Int *)
inversion H.
split.
exact H4.
exact H5.
(* Case Forall *)
inversion H0.
split.
exact H5.
exact H6.
(* Case Fun *)
inversion H.
split.
exact H4.
exact H5.
(* Case And *)
inversion H.
split.
exact H4.
exact H5.
assert (sub i t1 t0 /\ sub i t1 t3).
apply IHt1.
exact H4.
destruct H5.
split.
apply SAnd2.
exact H5.
apply SAnd2.
exact H6.
assert (sub i t2 t0 /\ sub i t2 t3).
apply IHt2.
exact H4.
destruct H5.
split.
apply SAnd3.
exact H5.
apply SAnd3.
exact H6.
Defined.

Definition transitivity_sub S Q T := forall i, sub i S Q -> sub i Q T -> sub i S T.

Lemma trans : forall Q T S, transitivity_sub S Q T.
induction Q.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
rewrite H4 in H. auto.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
(* Case Forall *)
unfold transitivity_sub. intros.
generalize H1 H0. clear H0. clear H1.
generalize S. clear S.
induction T; intro; intro; try (inversion H1); auto.
induction S; intro; try (inversion H6); intros; auto.
apply SForall.
inversion H7.
apply (H i); auto.
(* Case Fun *)
unfold transitivity_sub; intros.
generalize H0 H. clear H0. clear H.
generalize S. clear S.
induction T; intro; intro; try (inversion H0); auto.
induction S; intro; try (inversion H7); auto.
inversion H8.
apply SFun.
apply IHQ1; auto.
apply IHQ2; auto.
(* Case And *)
unfold transitivity_sub; intros.
assert (sub i S Q1 /\ sub i S Q2).
apply invAndS1; auto.
destruct H1.
generalize H1 H2.
induction T; intros.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply SAnd1.
apply IHT1; auto.
apply IHT2; auto.
apply IHQ1; auto.
apply IHQ2; auto.
Defined.

Definition Ortho A B := forall n, not (exists C, sub n A C /\ sub n B C).

Lemma p1 : forall (A B C : Prop), (A \/ B -> C) -> ((A -> C) /\ (B -> C)).
Proof.
intros.
split; intros.
apply H.
left.
exact H0.
apply H.
right.
exact H0.
Defined.

Definition equiv i t1 t2 := sub i t1 t2 /\ sub i t2 t1.

Definition contextEq i t1 t2 := (forall t, sub i t1 t -> sub i t2 t) /\ (forall t, sub i t t1 -> sub i t t2).

Definition narrowing_sub P Q X S T := forall i, sub i P Q -> (sub i X Q -> sub i S T) -> sub i X P -> sub i S T.

Lemma narrowing : forall X P Q S T, transitivity_sub X P Q -> narrowing_sub P Q X S T.
unfold narrowing_sub; intros.
apply H1.
apply H.
exact H2.
exact H0.
Defined.

Definition substitutability :
  forall t1 t2 i, equiv i t2 t1 -> contextEq i t2 t1 /\ contextEq i t1 t2.
intro. intro. intro. intro.
destruct H.
induction H; split; try split; intros.
(* Case Int *)
exact H.
exact H.
exact H.
exact H.
(* Case Var *)
exact H.
exact H.
exact H.
exact H.
(* Case Forall *)
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
(* Case Fun *)
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
(* Case And1 *)
(*
generalize i, t1, t2, H, H1, H0, IHsub1, IHsub2, t0, H2.
clear H2. clear t0. clear IHsub2. clear IHsub1. clear H0. clear H1. clear H. clear t2. clear t1. clear i. *)
induction t; intros.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0. (*H2*)
apply SAnd2.
apply IHsub1.
exact H8.
exact H2. (*H3*)
apply SAnd3.
apply IHsub2.
exact H8.
exact H2. (*H3*)
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

Lemma ForallInv : forall t p g i, (forall t : PTyp nat, sub i (Forall nat p) t -> sub i (Forall nat g) t) ->
                  sub (i + 1) (p i) t -> sub (i + 1) (g i) t.
intros.
assert (sub i (Forall nat g) (Forall nat (fun i => t))).
apply H.
apply SForall.
exact H0.
inversion H1.
exact H5.
Defined.

Lemma FunInv1 : forall o t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t1 t -> sub i o t.
intros.
(* assert (sub i (Fun nat t3 t4) (Fun )). *)
admit.
Defined.

Lemma FunInv2 : forall t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t2 t -> sub i t4 t.
intros.
assert (exists t10, sub i (Fun nat t3 t4) (Fun nat t10 t)).
exists t1.
apply H.
apply SFun.
apply reflex.
exact H0.
destruct H1.
inversion H1.
exact H8.
Defined.

Lemma funnyLemma : forall t1 t3 i (s : sub i t1 t3) t2, (forall t, sub i t2 t -> sub i t3 t) -> sub i t1 t2.
intro. intro. intro. intro.
induction s; intros.
(* Case PInt *)
apply H.
apply reflex.
(* Case Var *)
apply H.
apply reflex.
(* Case Forall *)
assert (sub i (Forall nat g) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
assert (sub (i+1) (f i) (p i)).
apply IHs. intro.
apply (ForallInv _ _ _ _ H).
apply SForall.
exact H6.
apply SAnd1.
apply IHt2_1.
intros.
apply H.
apply SAnd2.
exact H7.
exact H5.
apply IHt2_2.
intros.
apply H.
apply SAnd3.
exact H7.
exact H6.
(* Case Fun *)
(*
generalize i, o1, o2, o3, o4 , s1, s2, IHs1, IHs2, H.
clear H. clear IHs2. clear IHs1. clear s2. clear s1. clear o4. clear o3. clear o2. clear o1. clear i.
induction t2; intros.
assert (sub i (Fun nat o3 o4) (Var nat a)).
apply H. apply reflex.
inversion H0.
admit.
admit.
apply SFun.
*)

assert (sub i (Fun nat o3 o4) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
apply SFun.
assert (sub i o3 t2_1).
apply IHs1.
intros.
assert (sub i (Fun nat o3 o4) (Fun nat (Fun nat o1 o2) t2_1)).
apply H.
apply SFun.
apply IHt2_1.
intros.
apply H.

(* Using H! *)
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

(* A functional definition : algorithm *)

Fixpoint size (t : PTyp nat) (i : nat) : nat :=
  match t with
      | PInt => 1
      | Var x => 1
      | Forall f => 1 + size (f i) (i+1)
      | And o1 o2 => 1 + max (size o1 i) (size o2 i)
      | Fun o1 o2 => 1 + max (size o1 i) (size o2 i)
  end.

Fixpoint subTyp (n : nat) (t1 : PTyp nat) (t2 : PTyp nat) (i : nat) : Prop  :=
  match n with
      | 0 => False
      | S m =>
          match (t1,t2) with
            | (PInt,PInt) => True
            | (Var x, Var y) => if (eq_nat_dec x y) then True else False
            | (Forall f, Forall g) => subTyp m (f i) (g i) (i+1)
            | (And o1 o2, And o3 o4) => and (subTyp m o1 o3 i) (subTyp m o2 o4 i)
            | (Fun o1 o2, Fun o3 o4) => and (subTyp m o3 o1 i) (subTyp m o2 o4 i)
            | (_,_) => False
          end
  end.

Lemma implements : forall t1 t2 n i, subTyp (size t1 n) t1 t2 i -> sub i t1 t2.
Proof.
induction t1; intros.
simpl in H.
destruct t2; try destruct H.
destruct (eq_nat_dec a n0).
rewrite e.
apply SVar. reflexivity.
destruct H.
destruct t2; try destruct H.


From Undecidability.L Require Import L.
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import Lists LNat LProd.
From Complexity.NP.Clique Require Import FlatUGraph FlatClique kSAT_to_Clique.
From Complexity.NP.SAT Require Import kSAT SAT_inNP.
From Complexity.Libs.CookPrelim Require Import FlatFinTypes MorePrelim.

(** * k-SAT to FlatClique *)
(** We compute a flat graph corresponding to the graph of the k-SAT to Clique reduction and then use the correctness of that reduction to derive the correctness of the flat reduction. *)

(** ** correctness *)
Section fixSAT.
  Variable (k : nat).
  Variable (N : cnf).
  Context (Hkcnf : kCNF k N).

  Definition Ncl := |N|.

  (** All (clause, literal) positions *)
  Definition allPositions := list_prod (seq 0 Ncl) (seq 0 k).

  Proposition allPositions_sound : forall ci li, (ci, li) el allPositions -> exists l, cnfGetLiteral N ci li = Some l.
  Proof using Hkcnf.
    intros ci li Hel. apply in_prod_iff in Hel as (Hel1 & Hel2).
    apply in_seq in Hel1 as (_ & Hel1). apply in_seq in Hel2 as (_ & Hel2). cbn in Hel1, Hel2.
    unfold cnfGetLiteral, cnfGetClause, clauseGetLiteral.
    specialize (proj2 (nth_error_Some _ _) Hel1) as H1.
    destruct nth_error as [C | ] eqn:H2; [ | congruence].
    cbn.
    apply nth_error_In in H2.
    rewrite kCNF_clause_length in Hkcnf. apply Hkcnf in H2. rewrite <- H2 in Hel2.
    specialize (proj2 (nth_error_Some _ _) Hel2) as H3.
    destruct nth_error; [ eauto | congruence].
  Qed.

  Proposition in_allPositions_iff : forall ci li, (ci < Ncl /\ li < k) <-> (ci, li) el allPositions.
  Proof.
    intros ci li. unfold allPositions. rewrite in_prod_iff. rewrite !in_seq. split; lia.
  Qed.

  Definition Vf := flatProd Ncl k.
  Definition toVertex '(ci, li) := flatPair Ncl k ci li.

  Definition literalsConflict_decb (l1 l2 : literal) :=
    let (b1, v1) := l1 in
    let (b2, v2) := l2 in
    Nat.eqb v1 v2 && negb (Bool.eqb b1 b2).

  Fact negb_not b : negb b = true <-> not (b = true).
  Proof.
    rewrite negb_true_iff. destruct b; split; congruence.
  Qed.

  Proposition literalsConflict_decb_iff l1 l2 : literalsConflict_decb l1 l2 = true <-> literalsConflict l1 l2.
  Proof.
    unfold literalsConflict_decb, literalsConflict.
    destruct l1 as (b1 & v1), l2 as (b2 & v2).
    rewrite andb_true_iff. rewrite negb_not. rewrite Nat.eqb_eq, Bool.eqb_true_iff. tauto.
  Qed.

  Definition opt_literalsConflict_decb (o1 o2 : option literal) :=
    match o1, o2 with
    | Some l1, Some l2 => literalsConflict_decb l1 l2
    | _,_ => false
    end.

  Proposition opt_literalsConflict_decb_iff o1 o2 : opt_literalsConflict_decb o1 o2 = true <-> opt_literalsConflict o1 o2.
  Proof.
    unfold opt_literalsConflict, opt_literalsConflict_decb.
    destruct o1 as [l1 | ], o2 as [l2 | ]. 2-4: firstorder.
    apply literalsConflict_decb_iff.
  Qed.

  Definition makeEdge '((ci1, li1), (ci2, li2)) :=
    if Nat.eqb ci1 ci2 || opt_literalsConflict_decb (cnfGetLiteral N ci1 li1) (cnfGetLiteral N ci2 li2)
        then []
        else [(toVertex (ci1, li1), toVertex (ci2, li2))].
  Definition makeEdges := concat (map makeEdge (list_prod allPositions allPositions)).

  Lemma in_makeEdges_iff v1 v2: (v1, v2) el makeEdges <-> (exists ci1 li1 ci2 li2, (ci1 < Ncl /\ li1 < k) /\ (ci2 < Ncl /\ li2 < k) /\ v1 = toVertex (ci1, li1) /\ v2 = toVertex (ci2, li2) /\ ci1 <> ci2 /\ not (opt_literalsConflict (cnfGetLiteral N ci1 li1) (cnfGetLiteral N ci2 li2))).
  Proof using Hkcnf.
    unfold makeEdges. rewrite in_concat_map_iff.
    split.
    - intros (((ci1 & li1) & (ci2 & li2)) & (H1 & H2)%in_prod_iff & H3).
      specialize (allPositions_sound H1) as (l1 & H1').
      specialize (allPositions_sound H2) as (l2 & H2').
      apply in_allPositions_iff in H1. apply in_allPositions_iff in H2.
      exists ci1, li1, ci2, li2.
      unfold makeEdge in H3.
      destruct Nat.eqb eqn:H4; [cbn in H3; tauto | ].
      destruct opt_literalsConflict_decb eqn:H5; [ cbn in H3; tauto | ].
      cbn in H3. destruct H3 as [H3 | []]. inv H3.
      split; [ apply H1 | split; [ apply H2 | split; [easy | split; [easy | ]]]].
      rewrite <- Nat.eqb_eq, H4. rewrite <- opt_literalsConflict_decb_iff, H5. split; congruence.
  - intros (ci1 & li1 & ci2 & li2 & H1 & H2 & -> & -> & H3 & H4).
    exists ((ci1, li1), (ci2, li2)). split.
    + rewrite in_prod_iff, <- !in_allPositions_iff. tauto.
    + unfold makeEdge.
      rewrite <- Nat.eqb_eq in H3. rewrite <- opt_literalsConflict_decb_iff in H4.
      destruct Nat.eqb; [ congruence | clear H3].
      destruct opt_literalsConflict_decb; [congruence | clear H4].
      now cbn.
  Qed.

  Definition Gflat := (Vf, makeEdges).

  Proposition vertices_repr : finRepr (Vcnf k N) Vf.
  Proof.
    finRepr_simpl.
    - unfold finRepr. now rewrite Fin_cardinality.
    - unfold finRepr. now rewrite Fin_cardinality.
  Qed.

  Proposition unflattenVertex ci li: ci < Ncl -> li < k -> { Va : Fin.t Ncl & { Vb : Fin.t k & finReprEl' ci Va /\ finReprEl' li Vb /\ finReprEl' (toVertex (ci, li)) (Va, Vb)}}.
  Proof.
    intros H1 H2.
    fold (ofFlatType Ncl ci) in H1. fold (ofFlatType k li) in H2.
    rewrite <- Fin_cardinality in H1 at 1.
    rewrite <- Fin_cardinality in H2 at 1.
    apply finReprElP_exists in H1 as (Va & H1).
    apply finReprElP_exists in H2 as (Vb & H2).
    exists Va, Vb. split; [apply H1 | split; [apply H2 | ]].
    finRepr_simpl.
    - split; [now rewrite <- Fin_cardinality | apply H1].
    - split; [now rewrite <- Fin_cardinality | apply H2].
  Defined (* because informative*).

  Proposition index_pair (f1 f2 : finType) n1 n2 (v1 : f1) (v2 : f2) : finRepr f1 n1 -> finRepr f2 n2 -> index (v1, v2) = flatPair n1 n2 (index v1) (index v2).
  Proof.
    intros H1 H2.
    assert (finReprEl (flatProd n1 n2) (flatPair n1 n2 (index v1) (index v2)) (v1, v2)) as H'.
    { finRepr_simpl.
      - split; [apply H1 | reflexivity].
      - split; [apply H2 | reflexivity].
    }
    destruct H' as (_ & H'). apply H'.
  Qed.

  Lemma flat_edges : @isFlatEdgesOf makeEdges Vf (@Vcnf k N) (@Ecnf k N).
  Proof using Hkcnf.
    split.
    - intros v1 v2 H%in_makeEdges_iff.
      destruct H as (ci1 & li1 & ci2 & li2 & H1 & H2 & -> & -> & H3 & H4).
      split.
      + cbn. unfold flatPair, Vf, flatProd. nia.
      + destruct (unflattenVertex (proj1 H1) (proj2 H1)) as (Va1 & Va2 & H51 & H52 & H53).
        destruct (unflattenVertex (proj1 H2) (proj2 H2)) as (Vb1 & Vb2 & H61 & H62 & H63).
        exists (Va1, Va2), (Vb1, Vb2).
        split; [ | split; unfold isFlatVertexOf; easy].
        unfold Ecnf. rewrite H51, H52, H61, H62.
        split; [apply H4 | ].
        rewrite <- H51 in H3. rewrite <- H61 in H3. congruence.
    - intros (Va1 & Va2) (Vb1 & Vb2) [H1 H2].
      apply in_makeEdges_iff.
      exists (index Va1), (index Va2), (index Vb1), (index Vb2).
      repeat split.
      + specialize (index_le Va1). now rewrite Fin_cardinality.
      + specialize (index_le Va2). now rewrite Fin_cardinality.
      + specialize (index_le Vb1). now rewrite Fin_cardinality.
      + specialize (index_le Vb2). now rewrite Fin_cardinality.
      + unfold toVertex. apply index_pair; now rewrite <- Fin_cardinality.
      + setoid_rewrite index_pair; [reflexivity | rewrite <- Fin_cardinality; reflexivity | rewrite <- Fin_cardinality; reflexivity].
      + contradict H2. now apply injective_index in H2.
      + apply H1.
  Qed.

  Lemma flat_graph : isFlatGraphOf Gflat (Gcnf k N).
  Proof using Hkcnf.
    split.
    - apply vertices_repr.
    - apply flat_edges.
  Qed.

  Context (Hkgt : k > 0).
  Lemma SAT_implies_FlatClique : SAT N -> FlatClique (Gflat, Ncl).
  Proof using Hkgt Hkcnf.
    intros (a & H).
    specialize (exists_clique Hkgt Hkcnf H) as (L & [H1 H2]).
    destruct (clique_flatten flat_graph H2) as (l & H3 & H4).
    exists l. split; [ | split].
    - eapply isFlatGraphOf_wf, flat_graph.
    - apply H3.
    - rewrite H4, H1. easy.
  Qed.

  Lemma FlatClique_implies_SAT : FlatClique (Gflat, Ncl) -> SAT N.
  Proof using Hkgt Hkcnf.
    intros (l & [_ [H1 H2]]).
    specialize (clique_unflatten flat_graph H1) as (L & H3 & H4).
    eapply (exists_assignment Hkgt Hkcnf).
    split.
    2: apply H3.
    rewrite H4, H2. easy.
  Qed.

  Theorem SAT_equiv_FlatClique : SAT N <-> FlatClique (Gflat, Ncl).
  Proof using Hkgt Hkcnf.
    split; [apply SAT_implies_FlatClique | apply FlatClique_implies_SAT].
  Qed.
End fixSAT.

Definition trivialNoInstance := ((0, []):fgraph, 1).
Proposition trivialNoInstance_isNoInstance : not (FlatClique trivialNoInstance).
Proof.
  intros [l [_ [H1 H2]]]. destruct H1 as (H1 & _).
  destruct l; cbn in *; [congruence | ]. unfold list_ofFlatType in H1.
  specialize (H1 n ltac:(now left)). unfold ofFlatType in H1. lia.
Qed.

Definition reduction (k : nat) (N : cnf) :=
  if kCNF_decb k N && Nat.ltb 0 k then (Gflat k N, Ncl N) else trivialNoInstance.

Lemma kSAT_reduces_to_FlatClique k : forall N, kSAT k N <-> FlatClique (reduction k N).
Proof.
  intros N.
  unfold reduction. destruct kCNF_decb eqn:H1.
  - destruct k.
    + cbn -[trivialNoInstance]. unfold kSAT.
      split; [lia | specialize trivialNoInstance_isNoInstance; tauto].
    + cbn. split; intros.
      * apply SAT_implies_FlatClique; [apply H | lia | apply H].
      * apply kCNF_decb_iff in H1. apply FlatClique_implies_SAT in H; [ | apply H1| lia ].
        split; [lia | split; auto].
  - cbn -[trivialNoInstance]. split.
    + intros (_ & H3 & _). apply kCNF_decb_iff in H3. congruence.
    + intros []%trivialNoInstance_isNoInstance.
Qed.

(** ** extraction *)
From Complexity Require Import NP Complexity.Definitions.
From Undecidability.L Require Import Tactics.LTactics Complexity.UpToCNary.
From Complexity Require Import kSAT CookPrelim.PolyBounds.
From Undecidability.L.Datatypes Require Import LBool Lists LNat LProd LOptions.

(** allPositions *)
Definition c__allPositions := c__length + 16.
Definition allPositions_time (k : nat) (N : cnf) := c__length * (|N|) + seq_time (|N|) + seq_time k + prodLists_time (seq 0 (|N|)) (seq 0 k) + c__allPositions.
#[export]
Instance term_allPositions : computableTime' allPositions (fun k _ => (1, fun N _ => (allPositions_time k N, tt))).
Proof.
  extract. solverec.
  all: unfold allPositions_time, c__allPositions; solverec.
Qed.

Definition poly__allPositions n := c__length * n + (n + 2) * c__seq + poly__prodLists (n^2 + c__listsizeCons * n + 2 * c__listsizeNil) + c__allPositions.
Lemma allPositions_time_bound k N : allPositions_time k N <= poly__allPositions (size (enc N) + size (enc k)).
Proof.
  unfold allPositions_time. unfold seq_time.
  rewrite list_size_length at 1 2. rewrite size_nat_enc_r with (n := k) at 1.
  rewrite prodLists_time_bound.
  poly_mono prodLists_poly.
  2: { rewrite list_size_of_el.  2: { intros a (_ & H)%in_seq. rewrite nat_size_le.
        2: instantiate (1 := (|N|)); lia. reflexivity.
       }
       rewrite list_size_of_el. 2: { intros a (_ & H)%in_seq. rewrite nat_size_le.
        2: instantiate (1 := k); lia. reflexivity.
       }
       rewrite !seq_length. rewrite list_size_enc_length, !list_size_length.
       rewrite size_nat_enc_r with (n := k) at 2 3.
       instantiate (1 := ((size (enc N) + size (enc k))^2 + c__listsizeCons * (size (enc N) + size (enc k)) + 2* c__listsizeNil)). cbn -[Nat.mul c__listsizeCons]. leq_crossout.
  }
  unfold poly__allPositions. leq_crossout.
Qed.
Lemma allPositions_poly : monotonic poly__allPositions /\ inOPoly poly__allPositions.
Proof.
  unfold poly__allPositions; split; smpl_inO; try apply inOPoly_comp; smpl_inO; apply prodLists_poly.
Qed.

(** literalsConflict_decb *)
Definition c__literalsConflictDecb := c__eqbBool + 24.
Definition literalsConflict_decb_time (l1 l2 : literal) :=
  let (_, v1) := l1 in let (_, v2) := l2 in EqBool.eqbTime (X := nat) (size (enc v1)) (size (enc v2)) + c__literalsConflictDecb.
#[export]
Instance term_literalsConflict_decb : computableTime' literalsConflict_decb (fun l1 _ => (1, fun l2 _ => (literalsConflict_decb_time l1 l2, tt))).
Proof.
  extract. solverec.
  unfold c__literalsConflictDecb. solverec.
Qed.

(** opt_literalsConflict_decb *)
Definition c__optLiteralsConflictDecb := 10.
Definition opt_literalsConflict_decb_time (o1 o2 : option literal) :=
  match o1, o2 with
  | Some l1, Some l2 => literalsConflict_decb_time l1 l2
  | _, _ => 0
  end + c__optLiteralsConflictDecb.
#[export]
Instance term_opt_literalsConflict_decb : computableTime' opt_literalsConflict_decb (fun o1 _ => (1, fun o2 _ => (opt_literalsConflict_decb_time o1 o2, tt))).
Proof.
  extract. solverec.
  all: unfold opt_literalsConflict_decb_time, c__optLiteralsConflictDecb; nia.
Qed.

Definition poly__optLiteralsConflictDecb n := n * EqBool.c__eqbComp nat + 31 + c__optLiteralsConflictDecb.
Lemma opt_literalsConflict_decb_time_bound o1 o2 : opt_literalsConflict_decb_time o1 o2 <= poly__optLiteralsConflictDecb (size (enc o1)).
Proof.
  unfold opt_literalsConflict_decb_time, literalsConflict_decb_time.
  destruct o1 as [ (b1 & v1) | ], o2 as [(b2 & v2) | ]; cbn.
  2-4: unfold poly__optLiteralsConflictDecb; solverec.
  unfold EqBool.eqbTime. rewrite Nat.le_min_l.
  unfold poly__optLiteralsConflictDecb. rewrite size_option, size_prod; cbn. nia.
Qed.
Lemma opt_literalsConflict_decb_poly : monotonic poly__optLiteralsConflictDecb /\ inOPoly poly__optLiteralsConflictDecb.
Proof.
  unfold poly__optLiteralsConflictDecb; split; smpl_inO.
Qed.

(** toVertex *)
Definition c__toVertex := c__length + 8.
Definition toVertex_time (k : nat) (N : cnf) (p : nat *nat) := let (ci, li) := p in c__length * (|N|) + flatPair_time ci k + c__toVertex.
#[export]
Instance term_toVertex : computableTime' toVertex (fun k _ => (1, fun N _ => (1, fun p _ => (toVertex_time k N p, tt)))).
Proof.
  unfold toVertex, Ncl. extract. solverec.
  unfold c__toVertex; nia.
Qed.

Definition poly__toVertex n := c__length * n + (n * n * c__mult + c__mult * (n + 1) + (n * n + 1) * c__add + c__flatPair) + c__toVertex.
Lemma toVertex_time_bound k N p : toVertex_time k N p <= poly__toVertex (size (enc N) + size (enc k) + size (enc p)).
Proof.
  unfold toVertex_time. destruct p as (ci & li). unfold flatPair_time, mult_time, add_time.
  rewrite list_size_length. rewrite size_nat_enc_r with (n := ci) at 1 2 3.
  rewrite size_nat_enc_r with (n := k) at 1 2.
  pose (g := size (enc N) + size (enc k) + size (enc (ci, li))).
  replace_le (size (enc N)) with g by (subst g; lia) at 1.
  replace_le (size (enc k)) with g by (subst g; lia) at 1 2.
  replace_le (size (enc ci)) with g by (subst g; rewrite size_prod; cbn; lia) at 1 2 3.
  fold g.  unfold poly__toVertex. nia.
Qed.
Lemma toVertex_poly : monotonic poly__toVertex /\ inOPoly poly__toVertex.
Proof.
  unfold poly__toVertex; split; smpl_inO.
Qed.

(** cnfGetLiteral *)
Definition c__cnfGetLiteral := 15.
Definition cnfGetLiteral_time (N : cnf) (ci li : nat) :=
  nth_error_time N ci +
  match nth_error N ci with
  | Some C => nth_error_time C li
  | None => 0
  end + c__cnfGetLiteral.
#[export]
Instance term_cnfGetLiteral : computableTime' cnfGetLiteral (fun N _ => (1, fun ci _ => (1, fun li _ => (cnfGetLiteral_time N ci li, tt)))).
Proof.
  unfold cnfGetLiteral, optBind, cnfGetClause, clauseGetLiteral.
  extract.
  unfold cnfGetLiteral_time, c__cnfGetLiteral; recRel_prettify2. all: nia.
Qed.

Definition poly__cnfGetLiteral n := (n + 1) * c__ntherror * 2 + c__cnfGetLiteral.
Lemma cnfGetLiteral_time_bound N ci li : cnfGetLiteral_time N ci li <= poly__cnfGetLiteral (size (enc N)).
Proof.
  unfold cnfGetLiteral_time. destruct nth_error eqn:H1.
  - rewrite !nth_error_time_bound. rewrite !Nat.le_min_l.
    apply nth_error_In in H1. erewrite (list_el_size_bound H1).
    unfold poly__cnfGetLiteral; nia.
  - rewrite nth_error_time_bound. rewrite Nat.le_min_l.
    unfold poly__cnfGetLiteral; nia.
Qed.
Lemma cnfGetLiteral_poly : monotonic poly__cnfGetLiteral /\ inOPoly poly__cnfGetLiteral.
Proof.
  unfold poly__cnfGetLiteral; split; smpl_inO.
Qed.

Lemma cnfGetLiteral_size N ci li: size (enc (cnfGetLiteral N ci li)) <= size (enc N) + 5.
Proof.
  unfold cnfGetLiteral. destruct cnfGetClause eqn:H1.
  - cbn. unfold clauseGetLiteral. destruct nth_error eqn:H2.
    + apply nth_error_In in H2. apply nth_error_In in H1.
      rewrite size_option.
      rewrite (list_el_size_bound H2), (list_el_size_bound H1).
      solverec.
    + rewrite size_option. lia.
  - cbn. now rewrite size_option.
Qed.

(** makeEdge *)
Definition c__makeEdge := 43.
Definition makeEdge_time (k : nat) (N : cnf) (p : (nat * nat) * (nat * nat)) :=
  let '((ci1, li1), (ci2, li2)) := p in EqBool.eqbTime (X := nat) (size (enc ci1)) (size (enc ci2)) + cnfGetLiteral_time N ci1 li1 + cnfGetLiteral_time N ci2 li2 + opt_literalsConflict_decb_time (cnfGetLiteral N ci1 li1) (cnfGetLiteral N ci2 li2) + toVertex_time k N (ci1, li1) + toVertex_time k N (ci2, li2) + c__makeEdge.
#[export]
Instance term_makeEdge : computableTime' makeEdge (fun k _ => (1, fun N _ => (1, fun p _ => (makeEdge_time k N p, tt)))).
Proof.
  extract. recRel_prettify2. 1-2: nia.
  all: unfold makeEdge_time, c__makeEdge; nia.
Qed.

Definition poly__makeEdge n :=n * EqBool.c__eqbComp nat + 2 * poly__cnfGetLiteral n + poly__optLiteralsConflictDecb (n + 5) + 2 * poly__toVertex n + c__makeEdge.
Lemma makeEdge_time_bound k N p: makeEdge_time k N p <= poly__makeEdge (size (enc k) + size (enc N) + size (enc p)).
Proof.
  unfold makeEdge_time. destruct p as ((ci1 & li1) & (ci2 & li2)).
  rewrite !cnfGetLiteral_time_bound.
  rewrite opt_literalsConflict_decb_time_bound.
  rewrite !toVertex_time_bound.
  pose (g := size (enc k) + size (enc N) + size (enc ((ci1, li1), (ci2, li2)))).
  poly_mono cnfGetLiteral_poly. 2: { instantiate (1 := g). unfold g; nia. }
  poly_mono toVertex_poly. 2: { instantiate (1 := g). unfold g. rewrite !size_prod; cbn; nia. }
  poly_mono toVertex_poly at 2. 2: { instantiate (1 := g). unfold g. rewrite !size_prod; cbn; nia. }
  poly_mono opt_literalsConflict_decb_poly. 2: { rewrite cnfGetLiteral_size. instantiate (1 := g + 5). unfold g. lia. }
  unfold EqBool.eqbTime. rewrite Nat.le_min_l.
  fold g. replace_le (size (enc ci1)) with g by (unfold g; rewrite !size_prod; cbn; lia).
  unfold poly__makeEdge; nia.
Qed.
Lemma makeEdge_poly : monotonic poly__makeEdge /\ inOPoly poly__makeEdge.
Proof.
  unfold poly__makeEdge; split; smpl_inO; try apply inOPoly_comp; smpl_inO.
  all: first [apply cnfGetLiteral_poly | apply opt_literalsConflict_decb_poly | apply toVertex_poly].
Qed.

(** makeEdges *)
Definition c__makeEdges := 11.
Definition makeEdges_time (k : nat) (N : cnf) := 2 * allPositions_time k N + prodLists_time (allPositions k N) (allPositions k N) + map_time (makeEdge_time k N) (list_prod (allPositions k N) (allPositions k N))+ concat_time (map (makeEdge k N) (list_prod (allPositions k N) (allPositions k N))) + c__makeEdges.
#[export]
Instance term_makeEdges : computableTime' makeEdges (fun k _ => (1, fun N _ => (makeEdges_time k N, tt))).
Proof.
  extract. solverec.
  unfold makeEdges_time, c__makeEdges. simp_comp_arith. nia.
Qed.

Definition poly__makeEdges n :=
  2 * poly__allPositions n +
  poly__prodLists (((n + 4) * (n * n) + c__listsizeCons * n * n + c__listsizeNil) * 2) +
  (n^4 * (poly__makeEdge ((n + 4) * 3) + c__map) + c__map) + (n^4 * c__concat + (n^4 + 1) * c__concat) + c__makeEdges.

Lemma makeEdges_time_bound k N: makeEdges_time k N <= poly__makeEdges (size (enc N) + size (enc k)).
Proof.
  unfold makeEdges_time. rewrite allPositions_time_bound.
  rewrite prodLists_time_bound.
  pose (g := size (enc N) + size (enc k)).
  poly_mono prodLists_poly.
  2: { unfold allPositions. rewrite list_size_of_el.
    2: { intros (a & b) (H1 & H2)%in_prod_iff.
      apply in_seq in H1 as (_ &H1). apply in_seq in H2 as (_&H2). rewrite size_prod. cbn in *.
      rewrite nat_size_lt; [ | unfold Ncl in H1; apply H1].
      rewrite nat_size_lt with (a := b); [ | apply H2]. rewrite list_size_enc_length.
      reflexivity.
    }
    rewrite prod_length, !seq_length. unfold Ncl. rewrite size_nat_enc_r with (n := k) at 2 3 5 6.
    rewrite list_size_length.
    instantiate (1 := ((g + 4) * (g * g) + c__listsizeCons * g * g + c__listsizeNil) * 2).
    fold g. replace_le (size (enc N)) with g by (subst g; lia). replace_le (size (enc k)) with g by (subst g; lia). nia.
  }
  rewrite map_time_mono. 2: {
    intros ((ci1 & li1) & (ci2 & li2)) Hel. instantiate (1 := fun _ => _). cbn -[makeEdge_time Nat.add Nat.mul].
    rewrite makeEdge_time_bound.
    poly_mono makeEdge_poly.
    2: { apply in_prod_iff in Hel as (H1 & H2). apply in_allPositions_iff in H1 as (H1 & H1').
      apply in_allPositions_iff in H2 as (H2 & H2').
      rewrite !size_prod. cbn. unfold Ncl in *.
      rewrite nat_size_lt with (a := ci1); [ | apply H1].
      rewrite nat_size_lt with (a := li1); [ | apply H1'].
      rewrite nat_size_lt with (a := ci2); [ | apply H2].
      rewrite nat_size_lt with (a := li2); [ | apply H2'].
      rewrite list_size_enc_length. instantiate (1 := (g + 4) * 3). subst g. nia.
    }
    reflexivity.
  }
  rewrite map_time_const. rewrite prod_length; unfold allPositions. rewrite !prod_length, !seq_length.
  rewrite concat_time_exp. rewrite sumn_map_mono.
  2: { intros l (((ci1 & li1) & (ci2 &li2)) & <- & Hel)%in_map_iff. instantiate (1 := fun _ => c__concat).
    cbn -[Nat.mul]. unfold makeEdge. destruct Nat.eqb, opt_literalsConflict_decb; cbn -[Nat.mul]; lia.
  }
  rewrite sumn_map_const. rewrite !map_length, !prod_length, !seq_length.
  unfold Ncl. rewrite size_nat_enc_r with (n := k) at 2 3 4 5 6 7.
  rewrite list_size_length at 1 2 3 4 5 6.
  fold g.
  replace_le (size (enc N)) with g by (subst g; nia). replace_le (size (enc k)) with g by (subst g; nia).
  unfold poly__makeEdges; cbn [Nat.pow]; nia.
Qed.
Lemma makeEdges_poly : monotonic poly__makeEdges /\ inOPoly poly__makeEdges.
Proof.
  unfold poly__makeEdges; split; smpl_inO; try apply inOPoly_comp; smpl_inO.
  all: first [apply allPositions_poly | apply prodLists_poly | apply makeEdge_poly].
Qed.

Lemma makeEdges_length k N : |makeEdges k N| <= k * k * (|N|) * (|N|).
Proof.
  unfold makeEdges. rewrite length_concat, map_map.
  rewrite sumn_map_mono. 2: { intros ((ci1 & li1) & (ci2& li2)) _ . unfold makeEdge.
    instantiate (1 := fun _ => 1). destruct Nat.eqb, opt_literalsConflict_decb; cbn; lia.
  }
  rewrite sumn_map_const. rewrite prod_length; unfold allPositions. rewrite !prod_length, !seq_length.
  unfold Ncl. nia.
Qed.

Lemma makeEdges_fedges_wf k N : kCNF k N -> fedges_wf (Vf k N) (makeEdges k N).
Proof.
  intros H. eapply isFlatEdgesOf_fedges_wf, flat_edges, H.
Qed.

Lemma makeEdges_size_bound k N : kCNF k N -> size (enc (makeEdges k N)) <= (size (enc (Vf k N)) * 2 + 4) * k^2 * (|N|)^2 + c__listsizeCons * k^2 * (|N|)^2 + c__listsizeNil.
Proof.
  intros H. rewrite list_size_of_el.
  2: { intros (v1 & v2) Hel. eapply makeEdges_fedges_wf in Hel; [ | apply H].
    rewrite size_prod; cbn. destruct Hel as (H1 & H2).
    rewrite nat_size_lt ; [ | apply H1]. rewrite nat_size_lt with (a := v2); [ | apply H2].
    reflexivity.
  }
  rewrite makeEdges_length.
  cbn[Nat.pow]. nia.
Qed.

(** Gflat *)
Definition c__Gflat := 4.
Definition Gflat_time (k : nat) (N : cnf) :=c__length * (|N|) + c__length + c__mult1 + mult_time (|N|) k + makeEdges_time k N + c__Gflat.
#[export]
Instance term_Gflat : computableTime' Gflat (fun k _ => (1, fun N _ => (Gflat_time k N, tt))).
Proof.
  unfold Gflat, Vf.
  extract. solverec.
  unfold Gflat_time, c__Gflat; solverec.
Qed.

Definition poly__Gflat n := c__length * n + c__length + c__mult1 + (n * n * c__mult + c__mult * (n + 1)) + poly__makeEdges n + c__Gflat.
Lemma Gflat_time_bound (k : nat) (N : cnf) : Gflat_time k N <= poly__Gflat (size (enc N) + size (enc k)).
Proof.
  unfold Gflat_time. unfold mult_time.
  rewrite list_size_length. rewrite size_nat_enc_r with (n := k) at 1.
  rewrite makeEdges_time_bound.
  unfold poly__Gflat. nia.
Qed.
Lemma Gflat_poly : monotonic poly__Gflat /\ inOPoly poly__Gflat.
Proof.
  unfold poly__Gflat; split; smpl_inO; apply makeEdges_poly.
Qed.

Fact nat_size_mul a b: size (enc (a * b)) <= size (enc a) * size (enc b).
Proof.
  rewrite !size_nat_enc. unfold c__natsizeS; nia.
Qed.

Definition poly__GflatSize n := n * n + (n * n * 2 + 4) * n^4 + c__listsizeCons * n^4 + c__listsizeNil + 4.
Lemma Gflat_size_bound k N: kCNF k N -> size (enc (Gflat k N)) <= poly__GflatSize (size (enc N) + size (enc k)).
Proof.
  intros H. unfold Gflat. rewrite size_prod; cbn.
  rewrite makeEdges_size_bound by apply H.
  unfold Vf. rewrite nat_size_mul. unfold Ncl.
  rewrite list_size_length at 3 4. rewrite list_size_enc_length.
  rewrite size_nat_enc_r with (n := k) at 3 4.
  pose (g := size (enc N) + size (enc k)). fold g.
  replace_le (size (enc N)) with g by (unfold g;nia).
  replace_le (size (enc k)) with g by (unfold g;nia).
  unfold poly__GflatSize. cbn [Nat.pow]. nia.
Qed.
Lemma Gflat_size_poly : monotonic poly__GflatSize /\ inOPoly poly__GflatSize.
Proof.
  unfold poly__GflatSize; split; smpl_inO.
Qed.

(** reduction *)
Definition c__reduction := 14.
Definition reduction_time (k : nat) (N : cnf) := kCNF_decb_time k N + Gflat_time k N + c__length * (|N|) + c__length + (c__leb * 2 + c__ltb) + c__reduction.
#[export]
Instance term_reduction (k : nat): computableTime' (reduction k) (fun N _ => (reduction_time k N, tt)).
Proof.
  extract. solverec.
  all: unfold ltb_time, leb_time; rewrite Nat.le_min_l.
  all: unfold reduction_time, c__reduction; nia.
Qed.

(** full reduction statement *)
(** This is the flat version of the statement, including the polynomial running time.
The correctness statement is Lemma [kSAT_reduces_to_Clique] *)
Lemma kSAT_to_FlatClique_poly k: kSAT k ⪯p FlatClique.
Proof.
  eapply reducesPolyMO_intro with (f := (reduction k)).
  - evar (f : nat -> nat). exists f.
    + eexists (extT (reduction k)). eapply computesTime_timeLeq; [ | apply term_reduction].
      cbn. intros N _. split; [ | easy]. unfold reduction_time.
      rewrite kCNF_decb_time_bound, Gflat_time_bound.
      rewrite list_size_length. instantiate (f := fun n => poly__kCNFDecb (n + size (enc k)) + poly__Gflat (n + size (enc k)) + c__length * n + c__length + (c__leb * 2 + c__ltb) + c__reduction).
      subst f; simp_comp_arith; nia.
    + subst f; smpl_inO; apply inOPoly_comp; smpl_inO; first [apply kCNF_decb_poly  | apply Gflat_poly].
    + subst f; smpl_inO; first [apply kCNF_decb_poly  | apply Gflat_poly].
    + eexists (fun n => size (enc (trivialNoInstance)) + poly__GflatSize (n + size (enc k)) + n + 4).
      * intros N. unfold reduction. destruct kCNF_decb eqn:H1, Nat.ltb; cbn.
        2-4: lia.
        apply kCNF_decb_iff in H1. rewrite size_prod; cbn.
        rewrite Gflat_size_bound by apply H1. unfold Ncl. rewrite list_size_enc_length.
        nia.
      * smpl_inO. apply inOPoly_comp; smpl_inO; apply Gflat_size_poly.
      * smpl_inO. apply Gflat_size_poly.
  - apply kSAT_reduces_to_FlatClique.
Qed.