From Coq Require Export String.

Definition manual_grade_for_negation_fn_applied_twice : option (nat * string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b. destruct b eqn:Eb.
  - rewrite H. rewrite H. simpl. reflexivity.
  - rewrite H. rewrite H. simpl. reflexivity.
Qed.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* EXAMPLE FOR SECTION 6.3                                               *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

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

Import ListNotations.
Open Scope list_scope.

Inductive nt: Type:= | S' | A | B.
Inductive t: Type:= | a | b.
Inductive rs: nt -> list (nt + t) -> Prop:=
  r1: rs S' [inr a; inl S']
| r2: rs S' [inr b].

Notation sf:= (list (nt + t)).
Notation nlist:= (list nt).
Notation tlist:= (list t).

Lemma rs_finite:
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In S' ntl /\
forall left: nt,
forall right: sf,
rs left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: nt, In (inl s) right -> In s ntl) /\
(forall s: t, In (inr s) right -> In s tl).
Proof.
exists 2, [S'], [a; b].
split.
- simpl; left; reflexivity.
- intros left right H.
  inversion H.
  + simpl.
    split.
    * omega.
    * {
      split.
      - left; reflexivity.
      - split.
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
          * {
            destruct H2 as [H2 | H2].
            - left; inversion H2. reflexivity.
            - contradiction.
            }
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2. left; reflexivity.
          * {
            destruct H2 as [H2 | H2].
            - inversion H2.
            - contradiction.
            }
      }
  + simpl. split.
    * omega.
    * {
      split.
      - left; reflexivity.
      - split.
        + intros s H2. destruct H2 as [H2 | H2].
          * inversion H2.
          * contradiction.
        + intros s H2.
          destruct H2 as [H2 | H2].
          * inversion H2. right; left; reflexivity.
          * contradiction.
      }
Qed.

Definition g: cfg nt t:= {|
start_symbol:= S';
rules:= rs;
rules_finite:= rs_finite |}.

Lemma derives2_g_aab:
derives2 g [inl S'] [inr a; inr a; inr b].
Proof.
assert (derives2 g [inr a; inr a; inr b] [inr a; inr a; inr b]).
  {
  apply derives2_refl.
  }
change [inr a; inr a; inr b] with ([inr a; inr a] ++ [inr nt b]) in H.
apply derives2_step
with (s1:= [inr a; inr a]) (right:= [inr b]) (s2:= []) (left:= S') in H.
- change ([inr a; inr a] ++ [inl S']) with ([inr a] ++ [inr a; inl S']) in H.
  apply derives2_step
  with (s1:= [inr a]) (right:= [inr a; inl S']) (s2:= []) (left:= S') in H.
  + change ([inr a] ++ [inl S']) with ([inr a; inl S']) in H.
    apply derives2_step
	with (s1:= []) (right:= [inr a; inl S']) (s2:= []) (left:= S') in H.
    * simpl in H; exact H.
    * simpl; apply r1.
  + simpl; apply r1.
- simpl; apply r2.
Qed.

Lemma derives3_g_aab:
derives3 g S' [a; a; b].
Proof.
apply derives3_step with (ltnt:= [inr a; inl S']).
- simpl; apply r1.
- apply derives3_aux_t.
  rewrite <- app_nil_r.
  apply derives3_aux_nt.
  + apply derives3_aux_empty.
  + apply derives3_step with (ltnt:= [inr a; inl S']).
    * simpl; apply r1.
    * apply derives3_aux_t.
      rewrite <- app_nil_r.
      {
      apply derives3_aux_nt.
      - apply derives3_aux_empty.
      - apply derives3_rule; simpl; apply r2.
      }
Qed.

Lemma derives6_g_aab:
derives6 g 3 [inl S'] [inr a; inr a; inr b].
Proof.
assert (derives6 g 0 [inr a; inr a; inr b] [inr a; inr a; inr b]).
  {
  apply derives6_0.
  }
change [inr a; inr a; inr b] with ([inr a; inr a] ++ [inr nt b]) in H.
apply derives6_sum
with (s1:= [inr a; inr a]) (right:= [inr b]) (s2:= []) (left:= S') in H.
- change ([inr a; inr a] ++ [inl S'] ++ []) with ([inr a] ++ [inr a; inl S']) in H.
  apply derives6_sum
  with (s1:= [inr a]) (right:= [inr a; inl S']) (s2:= []) (left:= S') in H.
  + change ([inr a] ++ [inl S'] ++ []) with ([inr a; inl S']) in H.
    apply derives6_sum
	with (s1:= []) (right:= [inr a; inl S']) (s2:= []) (left:= S') in H.
    * simpl in H; exact H.
    * simpl; apply r1.
  + simpl; apply r1.
- simpl; apply r2.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Morphism instances for relations.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

From Coq Require Import Program.Program.
From Mon Require Import SRelation.SRelation_Definitions.
From Mon Require Import SRelation.SMorphisms.

Generalizable Variables A l.

(** Morphisms for relations *)

Instance srelation_conjunction_morphism : SProper (srelation_equivalence (A:=A) s==>
  srelation_equivalence s==> srelation_equivalence) srelation_conjunction.
  Proof. firstorder. Qed.

Instance srelation_disjunction_morphism : SProper (srelation_equivalence (A:=A) s==>
  srelation_equivalence s==> srelation_equivalence) srelation_disjunction.
  Proof. firstorder. Qed.

(* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *)

Lemma spredicate_equivalence_pointwise (l : Tlist) :
  SProper (@spredicate_equivalence l s==> pointwise_lifting siff l) id.
Proof. do 2 red. unfold spredicate_equivalence. auto. Qed.

Lemma spredicate_implication_pointwise (l : Tlist) :
  SProper (@spredicate_implication l s==> pointwise_lifting s_impl l) id.
Proof. do 2 red. unfold spredicate_implication. auto. Qed.

(** The instantiation at relation allows rewriting applications of relations
    [R x y] to [R' x y]  when [R] and [R'] are in [relation_equivalence]. *)

Instance srelation_equivalence_pointwise :
  SProper (srelation_equivalence s==> pointwise_srelation A (pointwise_srelation A siff)) id.
Proof. intro. apply (spredicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed.

Instance subsrelation_pointwise :
  SProper (subsrelation s==> pointwise_srelation A (pointwise_srelation A s_impl)) id.
Proof. intro. apply (spredicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed.

Lemma flip_pointwise_srelation A (R : srelation A) :
  srelation_equivalence (pointwise_srelation A (flip R)) (flip (pointwise_srelation A R)).
Proof. intros. split; firstorder. Qed.


From Undecidability.L Require Import L.
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import Lists LNat LProd.
From Undecidability.Shared.Libs.PSL Require Import FinTypes.
From Complexity.NP.Clique Require Import FlatUGraph Clique UGraph.
From Complexity.Libs.CookPrelim Require Import MorePrelim FlatFinTypes.

(** * Clique on flat graphs and NP containment *)

Definition isfClique (G : fgraph) (l : list fvertex) :=
  let (V, E) := G in
  list_ofFlatType V l /\ dupfree l /\ (forall v1 v2, v1 el l -> v2 el l -> v1 <> v2 -> (v1, v2) el E).

Definition isfKClique (k : nat) (G : fgraph) (l : list fvertex) := isfClique G l /\ |l| = k.

Definition FlatClique '(G, k) := exists l, fgraph_wf G /\ isfKClique k G l.

Fixpoint allPairsOfEdges_decb l E :=
  match l with
  | [] => true
  | v1 :: l => forallb (fun v2 => fedges_edge_in_decb E (v1, v2)) l && allPairsOfEdges_decb l E
  end.

Definition isfClique_decb (G : fgraph) l :=
  let (V, E) := G in list_ofFlatType_dec V l && dupfreeb Nat.eqb l && allPairsOfEdges_decb l E.

Lemma allPairsOfEdges_decb_iff V E l:
  fgraph_wf (V, E) -> (forall v, v el l -> isfVertex V v) -> dupfree l
  -> allPairsOfEdges_decb l E = true <-> (forall v1 v2, v1 el l -> v2 el l -> v1 <> v2 -> (v1, v2) el E).
Proof.
  intros H0 H Hdup.
  induction l; cbn; [easy | ].
  split.
  - rewrite andb_true_iff. intros [H1 H2].
    rewrite forallb_forall in H1.
    intros v1 v2 [-> | Hel1] [-> | Hel2].
    + easy.
    + intros _. eapply fedges_edge_in_decb_iff, H1, Hel2.
    + intros _. destruct H0 as (H0 & _). apply H0. apply fedges_edge_in_decb_iff, H1, Hel1.
    + intros Hneq. apply IHl; try easy. now inv Hdup.
  - intros H1. apply andb_true_iff. split.
    + apply forallb_forall. intros v Hel. apply fedges_edge_in_decb_iff.
      destruct (nat_eq_dec a v); [now inv Hdup | ].
      now apply H1.
    + apply IHl.
      * intros; now apply H.
      * now inv Hdup.
      * intros; now apply H1.
Qed.

Lemma isfClique_decb_iff G l : fgraph_wf G -> isfClique_decb G l = true <-> isfClique G l.
Proof.
  intros H. destruct G as (V & E). unfold isfClique_decb, isfClique.
  rewrite !andb_true_iff, list_ofFlatType_dec_correct, dupfreeb_iff. 2: symmetry; apply Nat.eqb_eq.
  split.
  - intros [[H1 H2] H3]. split; [apply H1 | split; [apply H2 | ]].
    eapply allPairsOfEdges_decb_iff; easy.
  - intros [H1 [H2 H3]]. split; [split; [apply H1 | apply H2] | ].
    now eapply allPairsOfEdges_decb_iff.
Qed.

Definition isfKClique_decb k G l := isfClique_decb G l && Nat.eqb (length l) k.

Lemma isfKClique_decb_iff k G l : fgraph_wf G -> isfKClique_decb k G l = true <-> isfKClique k G l.
Proof.
  intros H. unfold isfKClique_decb, isfKClique.
  rewrite andb_true_iff, (isfClique_decb_iff _ H),  Nat.eqb_eq. easy.  Qed.

(** agreement with the non-flat definition *)
Section fixGraph.
  Variable (UG : UGraph).
  Variable (G : fgraph).
  Context (H : isFlatGraphOf G UG).

  (** We require dupfreeness as list_finReprEl' does not enforce any order or how often an element appears *)
  Lemma clique_flat_agree l (L: list (V UG)): dupfree l -> dupfree L -> list_finReprEl' l L -> isfClique G l <-> isClique L.
  Proof using H.
    destruct G as (fV & fE). destruct H as (Hv & He). inv He.
    intros Hdup1 Hdup2 [H1 H2]. unfold isfClique, isClique. split.
    - intros (F1 & F2 & F3). split; [ | easy].
      intros v1 v2 Hel1 Hel2 Hneq. apply H2 in Hel1. apply H2 in Hel2.
      assert (index v1 <> index v2) as Hneq'.
      { intros Heq. apply Hneq. now apply injective_index in Heq. }
      specialize (F3 _ _ Hel1 Hel2 Hneq').
      apply R__edgesSound in F3 as (_ & (V1 & V2 & F3 & ->%injective_index & ->%injective_index)).
      apply F3.
    - intros (F1 & _ ). split; [ | split; [easy | ]].
      + intros v Hel. apply H1 in Hel as (v' & _ & ->).
        rewrite Hv. unfold isfVertex. apply index_le.
      + intros v1 v2 Hel1 Hel2 Hneq.
        apply H1 in Hel1 as (V1 & Hel1 & ->).
        apply H1 in Hel2 as (V2 & Hel2 & ->).
        apply R__edgesComplete.
        apply F1; easy.
  Qed.

  (** Constructively flatten and unflatten a clique. *)
  Lemma clique_flatten (L : list (V UG)) : isClique L -> {l : list fvertex & isfClique G l /\ |l| = |L| }.
  Proof using H.
    intros Hc. exists (map index L). split; [ | now rewrite map_length].
    eapply clique_flat_agree.
    - apply FinFun.Injective_map_NoDup. 2: apply Hc. unfold injective. apply injective_index.
    - apply Hc.
    - apply isFlatListOf_list_finReprEl'. reflexivity.
    - exact Hc.
  Defined. (* because informative*)

  Lemma clique_unflatten (l : list nat) : isfClique G l -> { L : list (V UG) & isClique L /\ |L| = |l| }.
  Proof using H.
    intros Hc. destruct G as (Vf & Ef) eqn:Heq.
    unfold isfClique in Hc.
    edestruct (finRepr_exists_list (proj1 H) (proj1 Hc)) as (L & H1).
    exists L. split; [ | rewrite H1; now rewrite map_length ].
    rewrite <- Heq in H. eapply clique_flat_agree.
    4: rewrite Heq; apply Hc.
    - apply Hc.
    - eapply map_dupfree. rewrite <- H1. apply Hc.
    - apply isFlatListOf_list_finReprEl', H1.
  Defined. (* because informative*)
End fixGraph.

(** ** extraction *)
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Complexity.Libs.CookPrelim Require Import PolyBounds FlatFinTypes.
From Undecidability.L.Datatypes Require Import LProd LOptions LBool LSum.
From Undecidability.L.Functions Require Import EqBool.

(** fedges_edge_in_decb *)
Definition c__fedgesEdgeInDecb := 6.
Definition fedges_edge_in_decb_time (E : list fedge) (e : fedge) := list_in_decb_time E e + c__fedgesEdgeInDecb.
#[export]
Instance term_fedges_edge_in_decb : computableTime' fedges_edge_in_decb (fun E _ => (1, fun e _ => (fedges_edge_in_decb_time E e, tt))).
Proof.
  extract. solverec.
  unfold fedges_edge_in_decb_time, c__fedgesEdgeInDecb. easy.
Qed.

(** allPairsOfEdges_decb *)
Definition allPairsOfEdges_decb_step (E : list fedge) (v1 : fvertex) (v2 : fvertex) := fedges_edge_in_decb E (v1, v2).

Definition c__allPairsOfEdgesDecbStep := 4.
Definition allPairsOfEdges_decb_step_time (E : list fedge) (v1 : fvertex) (v2 : fvertex) := fedges_edge_in_decb_time E (v1, v2) + c__allPairsOfEdgesDecbStep.
#[export]
Instance term_allPairsOfEdges_decb_step : computableTime' allPairsOfEdges_decb_step (fun E _ => (1, fun v1 _ => (1, fun v2 _ => (allPairsOfEdges_decb_step_time E v1 v2, tt)))).
Proof.
  extract. solverec. unfold allPairsOfEdges_decb_step_time, c__allPairsOfEdgesDecbStep. solverec.
Qed.

Definition c__allPairsOfEdgesDecb := 19.
Fixpoint allPairsOfEdges_decb_time (l : list fvertex) (E : list fedge) :=
  match l with
  | [] => 0
  | v1 :: l => forallb_time (allPairsOfEdges_decb_step_time E v1) l + allPairsOfEdges_decb_time l E
  end + c__allPairsOfEdgesDecb.
#[export]
Instance term_allPairsOfEdges_decb : computableTime' allPairsOfEdges_decb (fun l _ => (5, fun E _ => (allPairsOfEdges_decb_time l E, tt))).
Proof.
  apply computableTimeExt with (x :=
  fix allPairsOfEdges_decb (l : list nat) (E : list (nat * nat)) {struct l} : bool :=
    match l with
    | [] => true
    | v1 :: l0 =>
        forallb (allPairsOfEdges_decb_step E v1) l0 &&
        allPairsOfEdges_decb l0 E
    end). 1: easy.
  extract. solverec.
  all: unfold allPairsOfEdges_decb_time, c__allPairsOfEdgesDecb; simp_comp_arith; solverec.
Qed.

Definition c__allPairsOfEdgesDecbBound1 := c__fedgesEdgeInDecb + c__allPairsOfEdgesDecbStep + c__forallb.
Definition c__allPairsOfEdgesDecbBound2 := c__forallb + c__allPairsOfEdgesDecb.
Definition poly__allPairsOfEdgesDecb n :=
  n * n * (poly__listInDecb (X := nat * nat) n + c__allPairsOfEdgesDecbBound1) + (n + 1) * c__allPairsOfEdgesDecbBound2.
Lemma allPairsOfEdges_decb_time_bound l E : allPairsOfEdges_decb_time l E <= poly__allPairsOfEdgesDecb (size (enc E) + size (enc l)).
Proof.
  induction l; cbn.
  - unfold poly__allPairsOfEdgesDecb, c__allPairsOfEdgesDecbBound2. lia.
  - rewrite IHl. unfold forallb_time.
    rewrite sumn_map_mono.
    2:{ intros v Hel. unfold allPairsOfEdges_decb_step_time. unfold fedges_edge_in_decb_time.
        rewrite list_in_decb_time_bound at 1. instantiate (1 := fun _ => _). cbn. reflexivity.
    }
    rewrite sumn_map_const.
    rewrite list_size_length.
    poly_mono (@list_in_decb_poly (nat * nat) _ _ _ _). 2: { instantiate (1 := size (enc E) + size (enc (a::l))). lia. }
    unfold poly__allPairsOfEdgesDecb.
    poly_mono (@list_in_decb_poly (nat * nat) _ _ _ _) at 2. 2: { instantiate (1 := size (enc E) + size (enc (a::l))). rewrite list_size_cons. lia. }
    rewrite list_size_cons at 3 4 6.

    (* nia is too dumb to solve this; leq_crossout is smart enough and fast, but produces proof terms which are too large*)
    replace_le (size (enc l)) with (size (enc E) + size (enc l)) by lia at 1.
    remember (size (enc E) + size (enc l)) as g eqn:H1.
    replace (size (enc E) + (size (enc a) + size (enc l) + c__listsizeCons)) with (g + size (enc a) + c__listsizeCons) by lia.
    replace (poly__listInDecb (X := nat * nat) (size (enc E) + size (enc (a :: l))) + c__fedgesEdgeInDecb +
 c__allPairsOfEdgesDecbStep + c__forallb) with (poly__listInDecb (X := nat * nat) (size (enc E) + size (enc (a::l))) + c__allPairsOfEdgesDecbBound1) by (unfold c__allPairsOfEdgesDecbBound1; lia).
    unfold c__allPairsOfEdgesDecbBound2.
    unfold c__listsizeCons.
    lia.
Qed.
Lemma allPairsOfEdges_decb_poly : monotonic poly__allPairsOfEdgesDecb /\ inOPoly poly__allPairsOfEdgesDecb.
Proof.
  unfold poly__allPairsOfEdgesDecb; split; smpl_inO; apply list_in_decb_poly.
Qed.

Definition c__isfCliqueDecb := 21.
Definition isfClique_decb_time (G : fgraph) (l : list fvertex) := let (V, E) := G in list_ofFlatType_dec_time V l + dupfreeb_time l + allPairsOfEdges_decb_time l E + c__isfCliqueDecb.
#[export]
Instance term_isfClique_decb : computableTime' isfClique_decb (fun G _ => (1, fun l _ => (isfClique_decb_time G l, tt))).
Proof.
  extract. solverec. unfold c__isfCliqueDecb; solverec.
Qed.

Definition poly__isfCliqueDecb n := poly__listOfFlatTypeDec n + poly__dupfreeb (X := nat) n + poly__allPairsOfEdgesDecb n + c__isfCliqueDecb.
Lemma isfClique_decb_time_bound G l : isfClique_decb_time G l <= poly__isfCliqueDecb (size (enc G) + size (enc l)).
Proof.
  unfold isfClique_decb_time. destruct G as (V & E).
  rewrite list_ofFlatType_dec_time_bound.
  rewrite dupfreeb_time_bound.
  rewrite allPairsOfEdges_decb_time_bound.
  poly_mono list_ofFlatType_dec_poly. 2: { instantiate (1 := size (enc (V, E)) + size (enc l)). rewrite size_prod; cbn. lia. }
  poly_mono (@dupfreeb_poly nat _ _ _ _). 2: { instantiate (1 := size (enc (V, E)) + size (enc l)). rewrite size_prod; cbn. lia. }
  poly_mono allPairsOfEdges_decb_poly. 2: { instantiate (1 := size (enc (V, E)) + size (enc l)). rewrite size_prod; cbn. lia. }
  unfold poly__isfCliqueDecb; solverec.
Qed.
Lemma isfClique_decb_poly: monotonic poly__isfCliqueDecb /\ inOPoly poly__isfCliqueDecb.
Proof.
  unfold poly__isfCliqueDecb; split; smpl_inO.
  all: first [apply list_ofFlatType_dec_poly | apply dupfreeb_poly | apply allPairsOfEdges_decb_poly].
Qed.

(** isfKClique_decb *)
Definition c__isfKCliqueDecb := 12 + c__length.
Definition isfKClique_decb_time (k : nat) (G : fgraph) (l : list fvertex) :=
  isfClique_decb_time G l + c__length * (|l|) + eqbTime (X := nat) (size (enc (|l|))) (size (enc k))
  + c__isfKCliqueDecb.
#[export]
Instance term_isfKClique_decb : computableTime' isfKClique_decb (fun k _ => (1, fun G _ => (1, fun l _ => (isfKClique_decb_time k G l, tt)))).
Proof.
  extract. solverec.
  unfold isfKClique_decb_time, c__isfKCliqueDecb. solverec.
Qed.

Definition poly__isfKCliqueDecb n := poly__isfCliqueDecb n + c__length * n + n * c__eqbComp nat + c__isfKCliqueDecb.
Lemma isfKClique_decb_time_bound k G l : isfKClique_decb_time k G l <= poly__isfKCliqueDecb (size (enc G) + size (enc l)).
Proof.
  unfold isfKClique_decb_time. destruct G as (V & E).
  rewrite isfClique_decb_time_bound. rewrite list_size_length at 1.
  unfold eqbTime. rewrite Nat.le_min_l, list_size_enc_length.
  unfold poly__isfKCliqueDecb. solverec.
Qed.
Lemma isfKClique_decb_poly : monotonic poly__isfKCliqueDecb /\ inOPoly poly__isfKCliqueDecb.
Proof.
  unfold poly__isfKCliqueDecb; split; smpl_inO; apply isfClique_decb_poly.
Qed.

(** fedges_symmetric_decb *)
Definition fedges_symmetric_decb_step (E : list fedge) (e : fedge) := let (v1, v2) := e in fedges_edge_in_decb E (v2, v1).

Definition c__fedgesSymmetricDecbStep := 8.
Definition fedges_symmetric_decb_step_time (E : list fedge) (e : fedge) := let (v1, v2) := e in fedges_edge_in_decb_time E (v2, v1) + c__fedgesSymmetricDecbStep.
#[export]
Instance term_fedges_symmetric_decb_step : computableTime' fedges_symmetric_decb_step (fun E _ => (1, fun e _ => (fedges_symmetric_decb_step_time E e, tt))).
Proof.
  extract. solverec. unfold c__fedgesSymmetricDecbStep; solverec.
Qed.

Definition c__fedgesSymmetricDecb := 3.
Definition fedges_symmetric_decb_time (E : list fedge) := forallb_time (fedges_symmetric_decb_step_time E) E + c__fedgesSymmetricDecb.
#[export]
Instance term_fedges_symmetric_decb : computableTime' fedges_symmetric_decb (fun E _ => (fedges_symmetric_decb_time E, tt)).
Proof.
  apply computableTimeExt with (x := fun E => forallb (fedges_symmetric_decb_step E) E).
  1: easy.
  extract. solverec. unfold fedges_symmetric_decb_time, c__fedgesSymmetricDecb; simp_comp_arith; solverec.
Qed.

Definition poly__fedgesSymmetricDecb n := n * (poly__listInDecb (X := nat * nat) n + c__fedgesEdgeInDecb + c__fedgesSymmetricDecbStep + c__forallb) + c__forallb + c__fedgesSymmetricDecb.
Lemma fedges_symmetric_decb_time_bound E : fedges_symmetric_decb_time E <= poly__fedgesSymmetricDecb (size (enc E)).
Proof.
  unfold fedges_symmetric_decb_time. unfold forallb_time.
  rewrite sumn_map_mono.
  2: { intros (v1 & v2) Hel. unfold fedges_symmetric_decb_step_time.
       unfold fedges_edge_in_decb_time. rewrite list_in_decb_time_bound.
       instantiate (1 := fun _ => _). cbn; reflexivity.
  }
  rewrite sumn_map_const. rewrite list_size_length.
  unfold poly__fedgesSymmetricDecb. lia.
Qed.
Lemma fedges_symmetric_decb_poly : monotonic poly__fedgesSymmetricDecb /\ inOPoly poly__fedgesSymmetricDecb.
Proof.
  unfold poly__fedgesSymmetricDecb; split; smpl_inO; apply list_in_decb_poly.
Qed.

(** fedge_wf_decb *)
Definition c__fedgeWfDecb := 2 * c__ltb + 12.
Definition fedge_wf_decb_time (V : nat) := 2 * c__leb * (1 + V) + c__fedgeWfDecb.
#[export]
Instance term_fedge_wf : computableTime' fedge_wf_decb (fun V _ => (1, fun e _ => (fedge_wf_decb_time V, tt))).
Proof.
  extract. solverec.
  unfold ltb_time, leb_time. rewrite !Nat.le_min_r.
  unfold fedge_wf_decb_time, c__fedgeWfDecb. solverec.
Qed.

(** fedges_wf_decb *)
Definition c__fedgesWfDecb := c__forallb + 3.
Definition fedges_wf_decb_time (V : nat) (E : list fedge) := (|E|) * (fedge_wf_decb_time V + c__forallb) + c__fedgesWfDecb.
#[export]
Instance term_fedges_wf : computableTime' fedges_wf_decb (fun V _ => (1, fun E _ => (fedges_wf_decb_time V E, tt))).
Proof.
  extract. solverec.
  unfold forallb_time. rewrite sumn_map_const.
  unfold fedges_wf_decb_time, c__fedgesWfDecb. solverec.
Qed.

Definition poly__fedgesWfDecb n := n * (2 * c__leb * (1 + n) + c__fedgeWfDecb + c__forallb) + c__fedgesWfDecb.
Lemma fedges_wf_decb_time_bound V E : fedges_wf_decb_time V E <= poly__fedgesWfDecb (size (enc V) + size (enc E)).
Proof.
  unfold fedges_wf_decb_time. rewrite list_size_length. unfold fedge_wf_decb_time.
  rewrite size_nat_enc_r with (n := V) at 1.
  unfold poly__fedgesWfDecb. leq_crossout.
Qed.
Lemma fedges_wf_decb_poly : monotonic poly__fedgesWfDecb /\ inOPoly poly__fedgesWfDecb.
Proof.
  unfold poly__fedgesWfDecb; split; smpl_inO.
Qed.

(** fgraph_wf_decb *)
Definition c__fgraphWfDecb := 11.
Definition fgraph_wf_decb_time (G : fgraph) := let (V, E) := G in fedges_symmetric_decb_time E + fedges_wf_decb_time V E + c__fgraphWfDecb.
#[export]
Instance term_fgraph_wf_decb : computableTime' fgraph_wf_decb (fun G _ => (fgraph_wf_decb_time G, tt)).
Proof.
  extract. solverec. unfold c__fgraphWfDecb; solverec.
Qed.

Definition poly__fgraphWfDecb n := poly__fedgesSymmetricDecb n + poly__fedgesWfDecb n + c__fgraphWfDecb.
Lemma fgraph_wf_decb_time_bound G : fgraph_wf_decb_time G <= poly__fgraphWfDecb (size (enc G)).
Proof.
  unfold fgraph_wf_decb_time. destruct G as (V & E).
  rewrite fedges_symmetric_decb_time_bound, fedges_wf_decb_time_bound.
  poly_mono fedges_symmetric_decb_poly. 2: { instantiate (1 := size (enc (V, E))). rewrite size_prod; cbn; lia. }
  poly_mono fedges_wf_decb_poly. 2: { instantiate (1 := size (enc (V, E))). rewrite size_prod; cbn; lia. }
  unfold poly__fgraphWfDecb; lia.
Qed.
Lemma fgraph_wf_decb_poly : monotonic poly__fgraphWfDecb /\ inOPoly poly__fgraphWfDecb.
Proof.
  unfold poly__fgraphWfDecb; split; smpl_inO; first [apply fedges_symmetric_decb_poly | apply fedges_wf_decb_poly].
Qed.

(** ** NP containment *)
Lemma FlatClique_in_NP : inNP FlatClique.
Proof.
  eapply inNP_intro with (R := fun '(G, k) l =>  fgraph_wf G /\ isfKClique k G l).
  1: apply linDec_polyTimeComputable.
  2: {
    eexists.
    - intros (G & k) cert. cbn. firstorder.
    - intros (G & k). cbn. intros (l & H1). exists l. split; [apply H1 | ].
      destruct G as (V & E). destruct H1 as [_ ((H1 & H2 & _) & _)].
      enough (size (enc l) <= size (enc (seq 0 V))) as H3.
      { rewrite H3. rewrite list_size_of_el.
        2: { intros a (_ & Hb)%in_seq. rewrite nat_size_le; [ | rewrite Hb; reflexivity].
             reflexivity.
        }
        rewrite seq_length. cbn -[Nat.mul]. rewrite size_nat_enc_r with (n := V) at 2 3.
        instantiate (1 := fun n => n * n + c__listsizeCons * n + c__listsizeNil).
        rewrite !size_prod.  cbn -[Nat.mul]. nia.
      }
      eapply list_incl_dupfree_size.
      + intros a Hel. apply H1 in Hel. apply in_seq. split; [lia | apply Hel].
      + apply H2.
    - smpl_inO.
    - smpl_inO.
  }
  eexists. split.
  - constructor. exists (fun '(G, k, l) => fgraph_wf_decb G && isfKClique_decb k G l).
    + extract. recRel_prettify2. rewrite isfKClique_decb_time_bound, fgraph_wf_decb_time_bound.
      poly_mono isfKClique_decb_poly. 2: {instantiate (1 := size (enc (a, b1, b0, b))). rewrite !size_prod; cbn. lia. }
      poly_mono fgraph_wf_decb_poly. 2: {instantiate (1 := size (enc (a, b1, b0, b))). rewrite !size_prod; cbn. lia. }
      instantiate (1 := fun n => _). cbn. generalize (size (enc (a, b1, b0, b))). reflexivity.
    + intros ((G & k) & l). cbn. rewrite andb_true_iff. rewrite fgraph_wf_decb_iff.
      split.
      * intros [H1 H2]; split; [apply H1 | rewrite isfKClique_decb_iff; easy].
      * intros [H1 H2]; split; [apply H1 | rewrite <- isfKClique_decb_iff; easy ].
  - split; smpl_inO; first [apply fgraph_wf_decb_poly | apply isfKClique_decb_poly].
Qed.


Require Import VST.floyd.proofauto.
Require Import onepile.
Require Import simple_spec_stdlib.
Require Import simple_spec_pile.
Require Import PileModel.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

Definition onepile (sigma: option (list Z)) (gv: globals): mpred :=
 match sigma with
 | None => data_at_ Ews (tptr tpile) (gv _the_pile)
 | Some il => EX p:val, data_at Ews (tptr tpile) p (gv _the_pile) *
                        pilerep il p * pile_freeable p
 end.

Local Open Scope assert.

Definition Onepile_init_spec :=
 DECLARE _Onepile_init
 WITH gv: globals
 PRE [ ]
    PROP() PARAMS () GLOBALS (gv) SEP(onepile None gv; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL() SEP(onepile (Some nil) gv; mem_mgr gv).

Definition Onepile_add_spec :=
 DECLARE _Onepile_add
 WITH n: Z, sigma: list Z, gv: globals
 PRE [ tint ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(onepile (Some sigma) gv; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(onepile (Some (n::sigma)) gv; mem_mgr gv).

Definition Onepile_count_spec :=
 DECLARE _Onepile_count
 WITH sigma: list Z, gv: globals
 PRE [  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS () GLOBALS (gv)
    SEP(onepile (Some sigma) gv)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(onepile (Some sigma) gv).

Definition OnepileASI:funspecs := [ Onepile_init_spec; Onepile_add_spec; Onepile_count_spec].


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj7synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (lv0) (plus (plus (mult lv1 lv2) lv2) (mult lv3 lv2))).
Admitted.
QuickChick conj7synthconj6.


(******************************************************************

 Preservation of products by right biadjoints

 ******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.Limits.Products.

Local Open Scope cat.

Section BiadjunctionPreservation.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_data L).

  Section PreserveProducts.
    Context (HB₁ : is_univalent_2_1 B₁)
            (HB₂ : is_univalent_2_1 B₂)
            {y₁ y₂ : B₂}
            (p : binprod_cone y₁ y₂)
            (Hp : has_binprod_ump p)
            (x : B₁).

    Definition right_biadj_preserves_binprod_1cell
      : bicat_of_univ_cats
          ⟦ univ_hom HB₁ x (psfunctor_binprod_cone R p)
            ,
            univalent_category_binproduct
              (univ_hom HB₁ x (R y₁))
              (univ_hom HB₁ x (R y₂)) ⟧
      := biadj_left_hom R x p
         ∙ postcomp_binprod_cone HB₂ p (L x)
         ∙ pair_functor (biadj_right_hom R x y₁) (biadj_right_hom R x y₂).

    Definition left_adj_equiv_right_biadj_preserves_binprod_1cell
      : left_adjoint_equivalence right_biadj_preserves_binprod_1cell.
    Proof.
      use comp_left_adjoint_equivalence.
      - use (@comp_left_adjoint_equivalence
               bicat_of_univ_cats
               (univ_hom _ _ _)
               (univ_hom _ _ _)
               (univalent_category_binproduct
                  (univ_hom _ _ _)
                  (univ_hom _ _ _))).
        + apply equiv_cat_to_adj_equiv.
          exact (biadj_hom_equiv R x p).
        + apply (has_binprod_ump_binprod_cat_ump _ _ Hp).
      - use equiv_cat_to_adj_equiv.
        use pair_adj_equivalence_of_cats.
        + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)).
        + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₂)).
    Defined.

    Definition right_biadj_preserves_binprod_nat_trans_data
      : nat_trans_data
          (postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x)
          (pr1 right_biadj_preserves_binprod_1cell).
    Proof.
      intro f.
      simple refine (_ ,, _) ; cbn ; cbn in f.
      - refine ((_ ◃ (linvunitor _ • (_ ▹ _) • rassociator _ _ _))
                • lassociator _ _ _
                • lassociator _ _ _
                • (((psnaturality_of (biadj_unit R) f)^-1 ▹ _) ▹ _)
                • (rassociator _ _ _ ▹ _)
                • rassociator _ _ _
                • (_ ◃ (psfunctor_comp R _ _ ▹ _))
                • (_ ◃ psfunctor_comp R _ _)).
        exact ((invertible_modcomponent_of (biadj_triangle_r R) p)^-1
                • lunitor _
                • (_ ◃ (lunitor _ • runitor _))).
      - refine ((_ ◃ (linvunitor _ • (_ ▹ _) • rassociator _ _ _))
                • lassociator _ _ _
                • lassociator _ _ _
                • (((psnaturality_of (biadj_unit R) f)^-1 ▹ _) ▹ _)
                • (rassociator _ _ _ ▹ _)
                • rassociator _ _ _
                • (_ ◃ (psfunctor_comp R _ _ ▹ _))
                • (_ ◃ psfunctor_comp R _ _)).
        exact ((invertible_modcomponent_of (biadj_triangle_r R) p)^-1
                • lunitor _
                • (_ ◃ (lunitor _ • runitor _))).
    Defined.

    Opaque psfunctor_comp.

    Definition right_biadj_preserves_binprod_is_nat_trans
      : is_nat_trans _ _ right_biadj_preserves_binprod_nat_trans_data.
    Proof.
      intros f₁ f₂ α.
      use pathsdirprod.
      - simpl.
        refine (vassocr _ _ _ @ _ @ vassocr _ _ _).
        etrans.
        {
          rewrite !vassocr.
          rewrite vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocl.
        apply maponpaths.
        etrans.
        {
          rewrite !vassocr.
          rewrite <- rwhisker_rwhisker.
          rewrite !vassocl.
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_rwhisker.
          rewrite !vassocl.
          apply idpath.
        }
        do 2 apply maponpaths.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply maponpaths.
          apply idpath.
        }
        refine (!_).
        etrans.
        {
          rewrite !vassocr.
          rewrite !rwhisker_vcomp.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply maponpaths.
            do 2 apply maponpaths_2.
            apply maponpaths.
            refine (!_).
            exact (psnaturality_inv_natural (biadj_unit R) _ _ _ _ α).
          }
          rewrite <- !rwhisker_vcomp.
          rewrite !vassocl.
          cbn.
          apply idpath.
        }
        apply maponpaths.
        etrans.
        {
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          rewrite <- rwhisker_lwhisker_rassociator.
          rewrite <- rwhisker_vcomp.
          rewrite !vassocl.
          apply idpath.
        }
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- !rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        apply maponpaths.
        rewrite !vassocr.
        rewrite !rwhisker_vcomp.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          refine (!_).
          apply psfunctor_rwhisker.
        }
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        refine (!_).
        apply psfunctor_rwhisker.
      - simpl.
        refine (vassocr _ _ _ @ _ @ vassocr _ _ _).
        etrans.
        {
          rewrite !vassocr.
          rewrite vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocl.
        apply maponpaths.
        etrans.
        {
          rewrite !vassocr.
          rewrite <- rwhisker_rwhisker.
          rewrite !vassocl.
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_rwhisker.
          rewrite !vassocl.
          apply idpath.
        }
        do 2 apply maponpaths.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply maponpaths.
          apply idpath.
        }
        refine (!_).
        etrans.
        {
          rewrite !vassocr.
          rewrite !rwhisker_vcomp.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply maponpaths.
            do 2 apply maponpaths_2.
            apply maponpaths.
            refine (!_).
            exact (psnaturality_inv_natural (biadj_unit R) _ _ _ _ α).
          }
          rewrite <- !rwhisker_vcomp.
          rewrite !vassocl.
          cbn.
          apply idpath.
        }
        apply maponpaths.
        etrans.
        {
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          rewrite <- rwhisker_lwhisker_rassociator.
          rewrite <- rwhisker_vcomp.
          rewrite !vassocl.
          apply idpath.
        }
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- !rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        apply maponpaths.
        rewrite !vassocr.
        rewrite !rwhisker_vcomp.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          refine (!_).
          apply psfunctor_rwhisker.
        }
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        refine (!_).
        apply psfunctor_rwhisker.
    Qed.

    Transparent psfunctor_comp.

    Definition right_biadj_preserves_binprod_nat_trans
      : postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x
        ⟹
        pr1 right_biadj_preserves_binprod_1cell.
    Proof.
      use make_nat_trans.
      - exact right_biadj_preserves_binprod_nat_trans_data.
      - exact right_biadj_preserves_binprod_is_nat_trans.
    Defined.

    Definition right_biadj_preserves_binprod_is_nat_z_iso
      : is_nat_z_iso right_biadj_preserves_binprod_nat_trans.
    Proof.
      intro.
      use is_z_iso_binprod_z_iso.
      + use is_inv2cell_to_is_z_iso.
        is_iso ; apply property_from_invertible_2cell.
      + use is_inv2cell_to_is_z_iso.
        is_iso ; apply property_from_invertible_2cell.
    Defined.

    Definition right_biadj_preserves_binprod_nat_z_iso
      : nat_z_iso
          (postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x)
          right_biadj_preserves_binprod_1cell.
    Proof.
      use make_nat_z_iso.
      - exact right_biadj_preserves_binprod_nat_trans.
      - exact right_biadj_preserves_binprod_is_nat_z_iso.
    Defined.
  End PreserveProducts.

  Definition right_biadj_preserves_binprods
             (HB₁ : is_univalent_2_1 B₁)
             (HB₂ : is_univalent_2_1 B₂)
    : preserves_binprods R.
  Proof.
    intros y₁ y₂ p Hp.
    use (has_binprod_cat_ump_binprod_ump HB₁).
    intro x.
    use left_adjoint_equivalence_invertible.
    - exact (right_biadj_preserves_binprod_1cell HB₁ HB₂ p x).
    - apply left_adj_equiv_right_biadj_preserves_binprod_1cell.
      exact Hp.
    - apply right_biadj_preserves_binprod_nat_trans.
    - use is_nat_z_iso_to_is_invertible_2cell.
      apply right_biadj_preserves_binprod_is_nat_z_iso.
  Defined.
End BiadjunctionPreservation.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus lv1 (plus lv2 lv0))).
Admitted.
QuickChick conj14synthconj6.