(**
  Ciro Iván García López
  Tesis de Maestría
  Session Type Systems Verification
  Unam - 2021

  This file contains the definitions for the processes.
*)

From Coq Require Import Bool.Bool.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Sets.Constructive_sets.

From Tmcod Require Import Defs_Process.
From Tmcod Require Import Defs_Tactics.
From Tmcod Require Import Facts_Names.

(**
*)
Lemma Body_Parallel_Body_Each :
forall ( P Q : Process),
Body (P ↓ Q) -> (Body P /\ Body Q).
Proof.
  constructor;
    try constructor;
    intros;
    inversions H;
    specialize (H0 x);
    simpl in H0;
    inversions H0; auto.
Qed.
#[global]
Hint Resolve Body_Parallel_Body_Each : Piull.

(**
*)
Lemma Body_Process_Equivalence_Res :
forall (P : Process),
Body P <-> lc (ν P).
Proof.
  split;
  intros; try inversions H; Piauto.
Qed.
#[global]
Hint Resolve Body_Process_Equivalence_Res : Piull.

(**
*)
Lemma Exchange_Open :
forall ( P : Process)(x y k i : nat),
i <> k ->
{i ~> y} ( {k ~> x} P ) = {k ~> x} ( {i ~> y} P ).
Proof.
  induction P; intros; simpl; Piauto.
  + destruct x;
     destruct y;
        try rewrite (Eq_Open_Name i y0 k x0 _);
        try rewrite (Eq_Open_Name i y0 k x0 i1);
        Piauto.
  + rewrite IHP1; Piauto.
    rewrite IHP2; Piauto.
  + rewrite IHP; auto.
    destruct x;
     destruct y;
        try rewrite (Eq_Open_Name i y0 k x0 _);
        try rewrite (Eq_Open_Name i y0 k x0 i1); Piauto.
  + destruct x;
      try rewrite (Eq_Open_Name i y k x0 i0); Piauto.
  + rewrite IHP; auto.
    destruct x;
      try rewrite (Eq_Open_Name i y k x0 i0); Piauto.
  + rewrite IHP; auto.
  + rewrite IHP; auto.
    destruct x;
      try rewrite (Eq_Open_Name i y k x0 i0); Piauto.
  + rewrite IHP; auto.
    destruct x;
      try rewrite (Eq_Open_Name i y k x0 i0); Piauto.
Qed.
#[global]
Hint Resolve Exchange_Open : Piull.

(**
*)
Lemma Subst_Open_Exchange :
forall ( P : Process )( x y z w k: nat ),
FName w = (Subst_Name x y (FName z)) ->
{y \ x} ({k ~> z} P) = {k ~> w} ({y \ x} P).
Proof.
  induction P; intros; simpl;
    repeat rewrite (Subst_Name_Open_Name_Ex _ _ _ _  w _ );
    try rewrite (IHP _ _ _ w _);
    try rewrite (IHP1 _ _ _ w _);
    try rewrite (IHP2 _ _ _ w _);
    Piauto.
Qed.
#[global]
Hint Resolve Subst_Open_Exchange : Piull.

(**
*)
Lemma Subst_By_Equal :
forall ( P : Process )( x : nat ),
{ x \ x } P = P.
Proof.
  InductionProcess P Subst_Name_By_Equal.
Qed.
#[global]
Hint Resolve Subst_By_Equal : Piull.

(**
*)
Lemma Equal_Process_Equal_Open :
forall ( x : nat )( P Q: Process ),
(P = Q ) -> (Open_Rec 0 x P = Open_Rec 0 x Q).
Proof.
  intros.
  rewrite <- H.
  auto.
Qed.
#[global]
Hint Resolve Equal_Process_Equal_Open : Piull.

(**
*)
Lemma Process_Lca_Open_S :
forall ( P : Process )(i: nat),
(forall (x : nat), lca i ({i ~> x} P)) -> lca (S i) P.
Proof.
  intro.
  induction P; intros; Piauto.
  + constructor;
      apply (Lca_Name_Open _ _);
      intros;
      specialize (H x0);
      inversions H; auto.
  + constructor;
      apply (IHP1 _) || apply (IHP2 _);
      intros;
      specialize (H x);
      inversions H;
      auto.
  + constructor;
      try apply (Lca_Name_Open _ _);
      try intros;
      try specialize (H x0);
      try inversions H; auto.
    - apply (IHP _).
      intros.
      specialize (H x0).
      inversions H.
      auto.
  + constructor.
      try apply (Lca_Name_Open _ _);
      try intros;
      try specialize (H x0);
      try inversions H; auto.
  + constructor.
      try apply (Lca_Name_Open _ _);
      try intros;
      try specialize (H x0);
      try inversions H; auto.
    - apply (IHP _).
      intros.
      specialize (H x0).
      inversions H.
      auto.
  + constructor.
    simpl in H.
    apply IHP.
    intros.
    specialize (H x).
    inversions H.
    auto.
  + constructor.
      try apply (Lca_Name_Open _ _);
      try intros;
      try specialize (H x0);
      try inversions H; auto.
    simpl in H.
    apply IHP.
    intros.
    specialize (H x0).
    inversions H.
    auto.
  + constructor.
      try apply (Lca_Name_Open _ _);
      try intros;
      try specialize (H x0);
      try inversions H; auto.
    simpl in H.
    apply IHP.
    intros.
    specialize (H x0).
    inversions H.
    auto.
Qed.
#[global]
Hint Resolve Process_Lca_Open_S : Piull.

(**
*)
Lemma Lca_Process_Rd :
forall ( P : Process )( k x: nat ),
lca (S k) P -> lca k ({k ~> x} P).
Proof.
  intro.
  induction P; intros; simpl; try inversions H.
  + constructor.
  + constructor; apply Lca_Name_Rd; auto.
  + constructor.
    apply IHP1; auto.
    apply IHP2; auto.
  + constructor; try apply Lca_Name_Rd; auto.
  + constructor; try apply Lca_Name_Rd; auto.
  + constructor; try apply Lca_Name_Rd; auto.
  + simpl.
    constructor.
    inversions H.
    apply IHP; auto.
  + simpl.
    inversions H.
    constructor.
    - apply Lca_Name_Rd; auto.
    - apply IHP; auto.
  + simpl.
    inversions H.
    constructor.
    - apply Lca_Name_Rd; auto.
    - apply IHP; auto.
Qed.
#[global]
Hint Resolve Lca_Process_Rd : Piull.

(**
*)
Lemma Subst_Lca_Process :
forall ( P : Process )( k : nat ),
lca k P -> forall (x y : nat ), lca k ({y \ x} P).
Proof.
  induction P; intros;
    try constructor;
    try inversions H;
    try constructor;
    try apply Subst_Lca_Name;
    auto.
Qed.
#[global]
Hint Resolve Subst_Lca_Process : Piull.

(**
*)
Lemma Lca_Name_Open_Close_Subst :
forall ( x : Name )( x0 y k : nat),
lca_name k x ->
Open_Name k y (Close_Name k x0 x) = Subst_Name x0 y x.
Proof.
  intros.
  inversions H; simpl.
  + DecidSimple x1 x0.
  + DecidSimple k i.
Qed.
#[global]
Hint Resolve Lca_Name_Open_Close_Subst : Piull.

(**
*)
Lemma Lca_Open_Close_Subst :
forall ( P : Process )( x y k : nat ),
lca k P -> { k ~> y } Close_Rec k x P = { y \ x } P.
Proof.
  intros P.
  induction P; intros; simpl; inversions H; try auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
  + rewrite IHP1; auto.
    rewrite IHP2; auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
    rewrite IHP; auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
    rewrite IHP; auto.
  + inversions H.
    rewrite IHP; auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
    rewrite IHP; auto.
  + repeat rewrite Lca_Name_Open_Close_Subst; auto.
    rewrite IHP; auto.
Qed.
#[global]
Hint Resolve Lca_Open_Close_Subst : Piull.

(**
*)
Lemma Lca_Bex :
forall (P : Process)(i j k : nat),
i < j -> j < k ->
lca k (P) -> lca k ({i <~> j} P).
Proof.
  intro.
  induction P;
    try intros;
    try simpl;
    try inversions H1;
    try constructor;
    try apply Lca_Name_Bex;
    try apply IHP; try lia; auto.
Qed.
#[global]
Hint Resolve Lca_Bex : Piull.

(**
*)
Lemma Subst_Bex_Exchange_Names :
forall (N : Name)(x u i j : nat),
i <> j -> Subst_Name x u (Bex_Name i j N) =  Bex_Name i j (Subst_Name x u N) .
Proof.
  intros.
  destruct N; simpl.
  + DecidSimple x0 x.
  + DecidSimple i0 i.
    rewrite n.
    DecidSimple i0 j.
Qed.
#[global]
Hint Resolve Subst_Bex_Exchange_Names : Piull.

(**
*)
Lemma Subst_Bex_Exchange :
forall ( P : Process)(u x i j : nat),
i <> j -> {u \ x} ({i <~> j} P) =  {i <~> j} ( {u \ x} P).
Proof.
  InductionProcess P Subst_Bex_Exchange_Names.
Qed.
#[global]
Hint Resolve Subst_Bex_Exchange : Piull.

(**
*)
Lemma Subst_Open_NEq_Exchange :
forall (Q : Process)(x y u : nat),
x <> y ->
({u \ x} Q) ^ y = {u \ x} (Q ^ y).
Proof.
  intros.
  simpl.
  rewrite (Subst_Open_Exchange Q x u y y 0); auto.
  simpl.
  DecidSimple y x.
Qed.
#[global]
Hint Resolve Subst_Open_NEq_Exchange : Piull.

(**
*)
Lemma Subst_Open_Eq_Exchange_Names :
forall (N : Name)(x u i : nat),
Subst_Name x u (Open_Name i x N) = Open_Name i u (Subst_Name x u N).
Proof.
  intros.
  destruct N; simpl.
  + DecidSimple x0 x.
  + DecidSimple i i0.
    simpl.
    DecidSimple x x.
Qed.
#[global]
Hint Resolve Subst_Open_Eq_Exchange_Names : Piull.

(**
*)
Lemma Subst_Open_Eq_Exchange :
forall ( Q : Process)(u x i: nat),
({u \ x} ({i ~> x} Q )) = {i ~> u}({u \ x} Q).
Proof.
  InductionProcess Q Subst_Open_Eq_Exchange_Names.
Qed.
#[global]
Hint Resolve Subst_Open_Eq_Exchange : Piull.

(**
*)
Lemma Equality_Subst_Equality :
forall (P Q : Process)(x u : nat),
P = Q -> {x \ u} P = {x \ u} Q.
Proof.
  intros.
  rewrite H.
  auto.
Qed.
#[global]
Hint Resolve Equality_Subst_Equality : Piull.

(**
*)
Lemma Subst_Close_By_Equal_Name_Names :
forall (u y i : nat)(x : Name),
Subst_Name y u (Close_Name i y x) = Close_Name i y x.
Proof.
  destruct x; auto.
   simpl.
   DecidSimple x y.
   rewrite n.
   simpl.
   DecidSimple x y.
   apply beq_nat_true in e.
   apply beq_nat_false in n.
   lia.
Qed.
#[global]
Hint Resolve Subst_Close_By_Equal_Name_Names : Piull.

(**
*)
Lemma Subst_Close_By_Equal_Name :
forall (P : Process)(u x i: nat),
{u \ x} Close_Rec i x P = Close_Rec i x P.
Proof.
  InductionProcess P Subst_Close_By_Equal_Name_Names.
Qed.
#[global]
Hint Resolve Subst_Close_By_Equal_Name : Piull.

(**
*)
Lemma Subst_Close_Dif_Name_Names :
forall (x0 u i z : nat)(x : Name),
x0 <> z -> u <> z ->
Subst_Name x0 u (Close_Name i z x ) = Close_Name i z (Subst_Name x0 u x).
Proof.
  intros.
  destruct x; auto.
  simpl.
  destruct (bool_dec (x =? z) true).
  + destruct (bool_dec (x =? x0) true).
    - apply beq_nat_true in e0.
      apply beq_nat_true in e.
      rewrite <- e0 in H.
      contradiction.
    - apply not_true_iff_false in n.
      rewrite e.
      rewrite n.
      simpl.
      rewrite e.
      auto.
  + destruct (bool_dec (x =? x0) true).
    - apply not_true_iff_false in n.
      rewrite n. rewrite e.
      simpl. rewrite e.
      DecidSimple u z.
    - apply not_true_iff_false in n.
      apply not_true_iff_false in n0.
      rewrite n. rewrite n0.
      simpl.
      rewrite n. rewrite n0.
      auto.
Qed.
#[global]
Hint Resolve Subst_Close_Dif_Name_Names : Piull.

(**
*)
Lemma Subst_Close_Dif_Name :
forall (P : Process)(u x i z: nat),
x <> z -> u <> z ->
{u \ x} Close_Rec i z P = Close_Rec i z ({u \ x}P).
Proof.
  InductionProcess P Subst_Close_Dif_Name_Names.
Qed.
#[global]
Hint Resolve Subst_Close_Dif_Name : Piull.

(**
*)
Lemma Double_Subst_AlreadySubst_Eq_Names :
forall (x0 u y0 : nat)(x : Name),
x0 <> y0 ->
Subst_Name x0 u (Subst_Name x0 y0 x) = Subst_Name x0 y0 x.
Proof.
  intros.
  destruct x; auto.
  simpl.
  DecidSimple x x0; simpl.
  + DecidSimple y0 x0.
  + repeat (rewrite n; simpl).
    auto.
Qed.
#[global]
Hint Resolve Double_Subst_AlreadySubst_Eq_Names : Piull.

(**
*)
Lemma Double_Subst_AlreadySubst_Eq :
forall (P : Process)( u x y : nat),
x <> y ->
({u \ x} ({y \ x} P)) = {y \ x} P.
Proof.
  InductionProcess P Double_Subst_AlreadySubst_Eq_Names.
Qed.
#[global]
Hint Resolve Double_Subst_AlreadySubst_Eq : Piull.

(**
*)
Lemma Double_Subst_Expan_NFVar_Names :
forall (x : Name)(x0 y0 u : nat),
~ u ∈ FVars_Name x ->
Subst_Name x0 y0 x = Subst_Name u y0 (Subst_Name x0 u x).
Proof.
  destruct x; intros; auto.
  simpl.
  assert (HX : x <> u).
  simpl in H.
  unfold not.
  intros.
  apply H.
  rewrite H0.
  constructor.
  DecidSimple x x0; simpl.
  + DecidSimple u u.
  + rewrite n; simpl.
    DecidSimple x u.
Qed.
#[global]
Hint Resolve Double_Subst_Expan_NFVar_Names : Piull.

(**
*)
Lemma Double_Subst_Expan_NFVar :
forall (P : Process)(x y u : nat),
~ u ∈ FVars P ->
({y \ x} P) = ({y \ u} ({u \ x} P)).
Proof.
  induction P;
    intros; simpl;
    simpl in H;
    try rewrite (Double_Subst_Expan_NFVar_Names x _ _ u);
    try rewrite (Double_Subst_Expan_NFVar_Names y _ _ u);
    try rewrite (IHP1 _ _ u);
    try rewrite (IHP2 _ _ u);
    try rewrite (IHP _ _ u);
    try UnionSearch H;
    auto.
Qed.
#[global]
Hint Resolve Double_Subst_Expan_NFVar : Piull.

(**
*)
Lemma Double_Subst_By_Same_Name_Names :
forall (x : Name)(x0 u x1 : nat),
Subst_Name x0 u (Subst_Name x1 x0 x) = Subst_Name x1 u (Subst_Name x0 u x).
Proof.
  destruct x; auto.
  intros.
  simpl.
  DecidSimple x x1; simpl.
  + DecidSimple x x0; simpl.
    - DecidSimple x0 x0; simpl.
      DecidSimple u x1; simpl.
    - DecidSimple x0 x0; simpl.
      rewrite n; simpl.
      DecidSimple x x1; simpl.
  + DecidSimple x x0; simpl.
    - DecidSimple x0 x0; simpl.
      rewrite n; simpl.
      rewrite e; simpl.
      DecidSimple u x1; simpl.
    - DecidSimple x0 x0; simpl.
      rewrite n0; simpl.
      rewrite n; simpl.
      rewrite n0; simpl.
      auto.
Qed.
#[global]
Hint Resolve Double_Subst_By_Same_Name_Names : Piull.

(**
*)
Lemma Double_Subst_By_Same_Name :
forall (P : Process)(u x x0 : nat),
({u \ x} ({x \ x0} P)) = ({u \ x0} ({u \ x} P)).
Proof.
  InductionProcess P Double_Subst_By_Same_Name_Names.
Qed.
#[global]
Hint Resolve Double_Subst_By_Same_Name : Piull.

(**
*)
Lemma Double_Subst_All_Dif_Names :
forall (x : Name)(x0 u x1 y0 : nat),
x1 <> x0 -> y0 <> x0 -> u <> x1 ->
Subst_Name x0 u (Subst_Name x1 y0 x) = Subst_Name x1 y0 (Subst_Name x0 u x).
Proof.
  intros.
  destruct x; auto.
  simpl.
  destruct (bool_dec (x =? x1) true).
  + destruct (bool_dec (x =? x0) true).
    - apply beq_nat_true in e.
      apply beq_nat_true in e0.
      rewrite e in e0.
      contradiction.
    - apply not_true_iff_false in n.
      rewrite n.
      rewrite e.
      simpl.
      rewrite e.
      specialize (beq_nat_false_inv y0 x0 H0) as Hx.
      rewrite Hx.
      auto.
  + destruct (bool_dec (x =? x0) true).
    - apply not_true_iff_false in n.
      rewrite e; rewrite n.
      simpl.
      rewrite e.
      DecidSimple u x1.
    - apply not_true_iff_false in n.
      apply not_true_iff_false in n0.
      repeat (rewrite n; rewrite n0; simpl).
      auto.
Qed.
#[global]
Hint Resolve Double_Subst_All_Dif_Names : Piull.

(**
*)
Lemma Double_Subst_All_Dif :
forall (P : Process)(u x y x0 : nat),
x0 <> x -> y <> x -> u <> x0 ->
({u \ x} ({y \ x0} P)) = ({y \ x0} ({u \ x} P)).
Proof.
  induction P; intros; simpl;
    try rewrite (Double_Subst_All_Dif_Names x _ _ _ _);
    try rewrite (Double_Subst_All_Dif_Names y _ _ _ _);
    try rewrite IHP1;
    try rewrite IHP2;
    try rewrite IHP; Piauto.
Qed.
#[global]
Hint Resolve Double_Subst_All_Dif : Piull.

(**
*)
Lemma Close_Permutation_Names :
forall (x : Name)(i j u v : nat),
u <> v ->
Close_Name i u (Close_Name j v x) = Close_Name j v (Close_Name i u x).
Proof.
  intros.
  destruct x; simpl; Piauto.
  DecidSimple x v.
  + DecidSimple x u.
    - apply beq_nat_true in e.
      apply beq_nat_true in e0.
      lia.
    - rewrite n.
      simpl.
      rewrite e.
      Piauto.
  + DecidSimple x u.
    - rewrite n.
      simpl.
      rewrite e.
      Piauto.
    - rewrite n; rewrite n0.
      simpl.
      rewrite n; rewrite n0.
      Piauto.
Qed.
#[global]
Hint Resolve Close_Permutation_Names : Piull.

(**
*)
Lemma Close_Permutation :
forall (P : Process)(i j u v : nat),
u <> v ->
Close_Rec i u (Close_Rec j v P) = Close_Rec j v (Close_Rec i u P).
Proof.
  intro.
  induction P; intros; simpl;
    try rewrite Close_Permutation_Names;
    try rewrite (Close_Permutation_Names y _ _ _ _);
    try rewrite IHP1;
    try rewrite IHP2;
    try rewrite IHP;
    Piauto.
Qed.
#[global]
Hint Resolve Close_Permutation : Piull.

(**
*)
Lemma IsClosingInj_inv :
forall (P : Process)(x y : nat),
IsClosingInj P x -> y = x.
Proof.
  intros.
  inversions H.
  ePiauto.
Qed.
#[global]
Hint Resolve IsClosingInj_inv : Piull.

(**
*)
Lemma Subst_Res :
forall ( P : Process )( u v : nat),
{u \ v} ( ν P ) = ν ( {u \ v}  P ).
Proof.
  Piauto.
Qed.
#[global]
Hint Resolve Subst_Res : Piull.

(**
*)
Lemma Subst_Parallel :
forall ( P Q : Process )( u x : nat),
{u \ x} (P ↓ Q ) = ({u \ x} P ) ↓ ({u \ x}Q ).
Proof.
  Piauto.
Qed.
#[global]
Hint Resolve Subst_Parallel : Piull.

(**
*)
Lemma IsClosing_Process :
forall ( P Q : Process )( x0 : nat ),
IsClosing P x0 -> IsClosing Q x0.
Proof.
  constructor.
  intros.
  inversions H.
  specialize (H1 u v ({u \ v} Close x0 P)).
  Piauto.
Qed.
#[global]
Hint Resolve IsClosing_Process : Piull.

(**
*)
Lemma IsClosingInj_Process :
forall ( P Q : Process )( x0 : nat ),
IsClosingInj P x0 -> IsClosingInj Q x0.
Proof.
  constructor.
  intros.
  inversions H.
  specialize (H1 u (Close x0 P)).
  Piauto.
Qed.
#[global]
Hint Resolve IsClosingInj_Process : Piull.

(**
*)
Lemma IsClosing_inv :
forall ( P : Process )( x0 u v : nat ),
(IsClosing P x0) -> u <> x0 /\ x0 <> v.
Proof.
  intros.
  inversions H.
  eauto with Piull.
Qed.
#[global]
Hint Resolve IsClosing_inv : Piull.

(** FVars_Close_NotIn
*)
Lemma Close_Res_Rew :
forall (P : Process)(u i: nat),
Close_Rec i u (ν P) = (ν (Close_Rec (S i) u P)).
Proof.
  Piauto.
Qed.
#[global]
Hint Resolve Close_Res_Rew : Piull.


(**
  [TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Maps]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).

  Main contents:

  - definition of _compatibility_ between term-structures and _q_-morphism structures [iscompatible_term_qq]
  - construction, from any term-structure, of a compatible _q_-morphism structure [compatible_qq_from_term]
  - construction, from any _q_-morphism structure, of a compatible term-structure [compatible_term_from_qq]
*)

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

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

Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.

Section Fix_Base_Category.

Context {C : category} {X : obj_ext_structure C}.

Local Notation "Γ ◂ A" := (comp_ext _ Γ A) (at level 30).
Local Notation "'Ty'" := (fun X Γ => TY X $p Γ) (at level 10).
Local Notation "A [ f ]" := (#p (TY X) f A) (at level 4).
Local Notation "'Tm'" := (fun Y Γ => TM Y $p Γ) (at level 10).

Local Notation Δ := comp_ext_compare.

(** * Compatibility between term-structures and q-morphism structures

We define _compatibility_ between a term-structure and a _q_-morphism structure, as a commutativity condition between the _q_-morphisms and the maps _Q_ of the term-structure.  *)

Section Compatible_Structures.

(** ** Definitions *)

Definition iscompatible_term_qq
    (Y : term_fun_structure C X)
    (Z : qq_morphism_structure X)
  : UU
:= ∏ Γ Γ' A (f : C⟦Γ', Γ⟧),
     te Y A[f] = #p (TM _) (qq Z f A) (te Y A).

Lemma isaprop_iscompatible_term_qq
  (Y : term_fun_structure C X)
  (Z : qq_morphism_structure X)
  : isaprop (iscompatible_term_qq Y Z).
Proof.
  do 4 (apply impred; intro).
  apply setproperty.
Qed.

Definition compatible_term_structure (Z : qq_morphism_structure X)
  : UU
:= ∑ Y : term_fun_structure _ X, iscompatible_term_qq Y Z.

Coercion term_structure_of_compatible {Z : qq_morphism_structure X}
  : compatible_term_structure Z -> term_fun_structure _ X
:= pr1.

Definition compatible_qq_morphism_structure (Y : term_fun_structure _ X)
  : UU
:= ∑ Z : qq_morphism_structure X, iscompatible_term_qq Y Z.

Coercion qq_morphism_structure_of_compatible {Y : term_fun_structure _ X}
  : compatible_qq_morphism_structure Y -> qq_morphism_structure X
:= pr1.

Definition iscompatible'_term_qq
    (Y : term_fun_structure C X)
    (Z : qq_morphism_structure X)
  : UU
:= ∏ Γ Γ' A (f : C⟦Γ', Γ⟧) , Q Y A[f] = #Yo (qq Z f A) ;; Q Y A.

(** ** Misc lemmas on compatibility *)

(* TODO: try to eliminate older [iscompatible'] entirely, and remove both it and this lemma.  *)
Definition iscompatible_iscompatible'
    (Y : term_fun_structure C X)
    (Z : qq_morphism_structure X)
  : iscompatible_term_qq Y Z
  <-> iscompatible'_term_qq Y Z.
Proof.
  unfold iscompatible_term_qq, iscompatible'_term_qq.
  split; intros H Γ Γ' A f; specialize (H Γ Γ' A f).
  - apply nat_trans_eq. { apply homset_property. }
    intros Γ''. cbn. unfold yoneda_objects_ob, yoneda_morphisms_data.
    apply funextsec; intros g.
    etrans. apply maponpaths, H.
    apply pathsinv0, functor_comp_pshf.
  - assert (H' := nat_trans_eq_pointwise H); clear H.
    assert (H'' := toforallpaths (H' _) (identity _)); clear H'.
    cbn in H''; unfold yoneda_morphisms_data in H''.
    refine (_ @ H'' @ _).
    + apply pathsinv0, functor_id_pshf.
    + apply maponpaths_2, id_left.
Qed.

End Compatible_Structures.

(* TODO: find more natural home for this *)
Lemma map_from_term_recover
    {Y} {Z} (W : iscompatible_term_qq Y Z)
    {Γ' Γ : C} {A : Ty X Γ} (f : Γ' --> Γ ◂ A)
    {e : (pp Y) $nt (Q Y A $nt f)
         = A [ f ;; π A ]}
  : pr1 (term_to_section (Q Y A $nt f))
      ;; Δ e ;; qq Z (f ;; π A) A
    = f.
Proof.
  assert (W' : iscompatible'_term_qq Y Z).
    apply iscompatible_iscompatible'; assumption.
  unfold iscompatible'_term_qq in W'.
  apply (Q_pp_Pb_unique Y).
  - unfold yoneda_morphisms_data; cbn.
    etrans. apply @pathsinv0, assoc.
    etrans. apply maponpaths, qq_π.
    etrans. apply @pathsinv0, assoc.
    etrans. apply maponpaths.
      etrans. apply assoc.
      apply maponpaths_2, comp_ext_compare_π.
    etrans. apply assoc.
    etrans. 2: { apply id_left. }
    apply maponpaths_2.
    exact (pr2 (term_to_section _)).
  - etrans. refine (!toforallpaths (nat_trans_eq_pointwise (W' _ _ _ _) _) _).
    etrans. apply Q_comp_ext_compare.
    apply term_to_section_recover.
Qed.

(** * Term-structures from _q_-morphism structures

Given a _q_-morphism structure, we construct from it a (compatible) term structure: its terms are just the _sections_ of the projection maps, and its _Q_-maps are constructed from the _q_-morphisms.

Key definitions: [term_from_qq], [iscompatible_term_from_qq] *)

Section compatible_term_structure_from_qq.

Variable Z : qq_morphism_structure X.

(** ** Definition of the presheaf of terms *)

(* TODO: abstract second half out as “sections”, with pr1 an access function + a coercion. *)
Definition tm_from_qq_carrier (Γ : C) : UU :=
  ∑ A : Ty X Γ,
  ∑ s : C⟦Γ, Γ ◂ A⟧, s ;; π _ = identity _ .

Lemma isaset_tm_from_qq Γ : isaset (tm_from_qq_carrier Γ).
Proof.
  apply (isofhleveltotal2 2).
  - apply setproperty.
  - intro. apply (isofhleveltotal2 2).
    + apply homset_property.
    + intro. apply isasetaprop. apply homset_property.
Qed.

Definition tm_from_qq_functor_ob Γ : hSet := make_hSet _ (isaset_tm_from_qq Γ).

Definition tm_from_qq_functor_mor Γ Γ' (f : C⟦Γ',Γ⟧)
  : tm_from_qq_carrier Γ → tm_from_qq_carrier Γ'.
Proof.
  intro Ase.
  exists ((pr1 Ase) [f]).
  eapply pb_of_section.
  - apply (qq_π_Pb Z).
  - apply (pr2 (pr2 Ase)).
Defined.

Definition tm_from_qq_functor_data : functor_data C^op HSET.
Proof.
  exists tm_from_qq_functor_ob.
  exact tm_from_qq_functor_mor.
Defined.

Lemma section_eq_from_tm_from_qq_eq {Γ}
  {t t' : (tm_from_qq_functor_data Γ : hSet)}
  (e : t = t')
  : pr1 (pr2 t) ;; Δ (maponpaths pr1 e)
    = pr1 (pr2 t').
Proof.
  destruct e; simpl.
  etrans. apply maponpaths, comp_ext_compare_id_general.
  apply id_right.
Qed.

Lemma tm_from_qq_eq {Γ} (t t' : (tm_from_qq_functor_data Γ : hSet))
  (eA : pr1 t = pr1 t')
  (es : (pr1 (pr2 t)) ;; Δ eA = (pr1 (pr2 t')))
  : t = t'.
Proof.
  destruct t as [A [s e]], t' as [A' [s' e']]; simpl in *.
  use total2_paths_f; simpl.
    apply eA.
  apply subtypePath. intro; apply homset_property.
  simpl. eapply pathscomp0. use (pr1_transportf (Ty X Γ)).
  simpl. eapply pathscomp0. apply functtransportf.
  eapply pathscomp0. eapply pathsinv0. apply idtoiso_postcompose.
  exact es.
Qed.

(* A useful more specialised case of equality on terms. *)

Lemma tm_from_qq_eq' {Γ : C} (A : Ty X Γ)
  {Γ'} {f f' : Γ' --> Γ} (e_ff' : f = f')
  {s : Γ' --> Γ' ◂ A[f]} (es : s ;; π _ = identity _)
  {s' : Γ' --> Γ' ◂ A[f']} (es' : s' ;; π _ = identity _)
  (e_ss' : s' = s ;; Δ (maponpaths (fun f => A[f]) e_ff'))
: (( A[f] ,, (s,, es)) : tm_from_qq_functor_data Γ' : hSet)
  = (A[f'] ,, (s',, es')).
Proof.
  destruct e_ff'; simpl in *.
  apply maponpaths.
  rewrite id_right in e_ss'.
  destruct e_ss'.
  apply maponpaths. apply homset_property.
Qed.

Lemma is_functor_tm_from_qq : is_functor tm_from_qq_functor_data.
Proof.
  split; [unfold functor_idax | unfold functor_compax].
  - intro Γ; apply funextsec; intro t. destruct t as [A [s e]]; cbn.
    use tm_from_qq_eq; simpl.
    + apply functor_id_pshf.
    + etrans. apply maponpaths, @pathsinv0, qq_id.
      etrans. apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
      apply id_left.
  - intros Γ Γ' Γ'' f g; apply funextsec; intro t.
    destruct t as [A [s e]]; cbn in *.
    use tm_from_qq_eq; simpl.
    + apply functor_comp_pshf.
    + {
      apply PullbackArrowUnique; cbn.
      - rewrite <- assoc.
        etrans. { apply maponpaths, comp_ext_compare_π. }
        apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
      - apply (MorphismsIntoPullbackEqual (qq_π_Pb Z _ _)).
        + etrans. 2: { apply assoc. }
          etrans.
          2: {
            apply maponpaths, @pathsinv0.
            apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
          }
          etrans. 2: { apply @pathsinv0, id_right. }
          etrans. apply @pathsinv0, assoc.
          etrans. eapply maponpaths, qq_π.
          etrans. apply assoc.
          etrans. 2: { apply id_left. }
          apply maponpaths_2.
          etrans. apply @pathsinv0, assoc.
          etrans. { apply maponpaths, comp_ext_compare_π. }
          apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
        + repeat rewrite <- assoc.
          etrans. apply maponpaths. rewrite assoc.
            apply @pathsinv0, qq_comp_general.
          etrans. apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
          etrans. apply @pathsinv0, assoc.
          apply maponpaths.
          apply @pathsinv0.
          apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)). }
Qed.

Definition tm_from_qq : functor _ _
  := tpair _ _ is_functor_tm_from_qq.

Arguments tm_from_qq : simpl never.

(* TODO: search for uses of [tm_from_qq_eq] to see where this can be used (should save a good few lines of code). *)
Lemma tm_from_qq_eq_reindex
    {Γ Γ' : C} (f : Γ' --> Γ)
    (Ase : tm_from_qq Γ : hSet) (Ase' : tm_from_qq Γ' : hSet)
    (eA : pr1 Ase' = #p (TY X) f (pr1 Ase))
    (es : pr1 (pr2 Ase') ;; Δ eA ;; qq Z f _ = f ;; pr1 (pr2 Ase))
  : Ase' = # tm_from_qq f Ase.
Proof.
  use tm_from_qq_eq.
  - exact eA.
  - cbn. apply PullbackArrowUnique; cbn.
    + etrans. apply @pathsinv0, assoc.
      etrans. apply maponpaths, comp_ext_compare_π.
      apply (pr2 (pr2 Ase')).
    + apply es.
Qed.

Lemma pr2_tm_from_qq_paths
    {Γ : C} {t t' : tm_from_qq Γ : hSet} (e : t = t')
  : pr1 (pr2 t) = pr1 (pr2 t') ;; (Δ (maponpaths pr1 (!e))) .
Proof.
  destruct e. apply pathsinv0, id_right.
Qed.

Definition pp_from_qq_data (Γ : C^op)
  : tm_from_qq Γ --> Ty X Γ.
Proof.
  exact pr1.
Defined.

Lemma is_nat_trans_pp_from_qq
  : is_nat_trans _ _ pp_from_qq_data.
Proof.
  intros Γ Γ' f.
  apply idpath.
Defined.

Definition pp_from_qq : preShv C ⟦tm_from_qq, TY X⟧
  := tpair _ _ is_nat_trans_pp_from_qq.

Arguments pp_from_qq : simpl never.

Definition te_from_qq {Γ:C} (A : Ty X Γ)
  : tm_from_qq $p (Γ ◂ A).
Proof.
  exists A [π A].
  apply (section_from_diagonal _ (qq_π_Pb Z _ _)).
  exists (identity _). apply id_left.
Defined.

Definition term_from_qq_data : term_fun_structure_data C X.
Proof.
  exists tm_from_qq.
  exists pp_from_qq.
  intros; apply te_from_qq.
Defined.

(** ** Typing of te, and pullback property *)
Section Tm_fun_axioms_from_qq.

Variable Γ : C.
Variable A : Ty X Γ.

Definition Q_from_qq : Yo (Γ ◂ A) --> tm_from_qq.
Proof.
  simpl in A.
  apply yy, te_from_qq.
Defined.

Definition pp_te_from_qq
  : pp_from_qq $nt (te_from_qq A) = A [ π A ].
Proof.
  apply idpath.
Qed.

Definition Q_pp_from_qq
  : # Yo (π _) ;; yy A = Q_from_qq ;; pp_from_qq.
Proof.
  apply (@term_fun_str_square_comm _ _ term_from_qq_data).
  apply pp_te_from_qq.
Qed.

Definition section_qq_π  (Γ' : C) (f : C⟦ Γ', Γ⟧)
    (s : C ⟦ Γ', Γ' ◂ A[f] ⟧)
    (e : s ;; π (A[f]) = identity Γ')
  : s ;; qq Z f A ;; π A = f.
Proof.
  etrans. apply @pathsinv0, assoc.
  etrans. apply @maponpaths, qq_π.
  etrans. apply assoc.
  etrans. apply maponpaths_2. exact e.
  apply id_left.
Qed.

Lemma Q_from_qq_reconstruction
    {Γ' : C} ( ft : C ⟦ Γ', Γ ◂ A ⟧ )
  : ft
  = pr1 (pr2 (Q_from_qq $nt ft)) ;; qq Z ft _ ;; qq Z _ A.
Proof.
  cbn.
  apply pathsinv0.
  etrans. {
    apply maponpaths_2.
    apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)). }
  use (_ @ id_right _).
  etrans. apply @pathsinv0, assoc.
  apply maponpaths.
  apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
Qed.

(* TODO: try to speed this up! *)
Lemma isPullback_Q_pp_from_qq : isPullback Q_pp_from_qq.
Proof.
  apply pb_if_pointwise_pb. intros Γ'.
  apply isPullback_HSET. intros f [A' [s e]] e_A_A'; simpl in e_A_A'.
  destruct e_A_A'.
  use tpair.
  - exists (s ;; qq Z f A).
    simpl; unfold yoneda_morphisms_data.
    split. { apply (section_qq_π _ _ _ e). }
    use tm_from_qq_eq. cbn.
    + etrans.
        apply @pathsinv0, functor_comp_pshf.
      apply maponpaths_2.
      cbn.
      etrans. apply @pathsinv0, assoc.
      etrans. apply maponpaths, qq_π.
      etrans. apply assoc.
      etrans. apply maponpaths_2, e.
      apply id_left.
    + use (map_into_Pb_unique (qq_π_Pb Z _ _  )).
      * cbn.
        use (_ @ !e).
        etrans. apply @pathsinv0, assoc.
        etrans. apply @maponpaths, comp_ext_compare_π.
        apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
      * etrans. apply @pathsinv0, assoc.
        use (maponpaths _ _ @ _).
        { use (qq Z _ _ ;; qq Z _ _). }
        -- etrans.
          2: {
            eapply z_iso_inv_on_right.
            etrans. 2: { apply @pathsinv0, assoc. }
            apply qq_comp. }
          apply @pathsinv0, z_iso_inv_on_right.
          apply @pathsinv0.
          etrans. apply assoc.
          etrans. apply maponpaths_2, @pathsinv0, comp_ext_compare_comp.
          apply comp_ext_compare_qq_general.
          apply (section_qq_π _ _ _ e).
        -- etrans. { apply assoc. }
          etrans. { apply maponpaths_2,
                  (PullbackArrow_PullbackPr2 (make_Pullback _ _)). }
          etrans. { apply @pathsinv0, assoc. }
          etrans. 2: { apply id_right. }
          apply maponpaths,
                  (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
  - intros ft. apply subtypePath.
    { intro. apply isapropdirprod.
    + apply homset_property.
    + apply setproperty. }
    cbn. destruct ft as [ ft [ e1 e2 ] ]. cbn; cbn in e1.
    unfold yoneda_morphisms_data in e1.
    etrans. apply Q_from_qq_reconstruction.
    etrans. apply maponpaths_2, maponpaths_2, (pr2_tm_from_qq_paths e2).
    cbn.
    etrans. apply @pathsinv0, assoc.
    etrans. apply @pathsinv0, assoc.
    apply maponpaths.
    etrans. apply maponpaths.
      apply @pathsinv0, z_iso_inv_on_right.
      use (_ @ !assoc _ _ _).
      apply qq_comp.
    etrans. 2: { exact (comp_ext_compare_qq Z (!e1) _). }
    etrans. apply assoc.
    apply maponpaths_2.
    etrans. apply maponpaths, @pathsinv0, comp_ext_compare_inv.
    apply pathsinv0, comp_ext_compare_comp_general.
Time Qed.

End Tm_fun_axioms_from_qq.

Arguments Q_from_qq { _ } _ : simpl never.
Arguments tm_from_qq : simpl never.
Arguments pp_from_qq : simpl never.

(** ** Assembly into a compatible term-structure *)

Definition term_from_qq : term_fun_structure C X.
Proof.
  exists term_from_qq_data.
  intros ? ?.
  exists (pp_te_from_qq _ _).
  apply isPullback_Q_pp_from_qq.
Defined.

Definition iscompatible_term_from_qq
  : iscompatible_term_qq term_from_qq Z.
Proof.
  intros ? ? ? ?.
  (* TODO: use [tm_from_qq_eq'] here *)
  use tm_from_qq_eq; simpl.
  - etrans. apply pathsinv0, functor_comp_pshf.
    etrans. 2: { apply functor_comp_pshf. }
    apply maponpaths_2; cbn.
    apply @pathsinv0, qq_π.
  - apply PullbackArrowUnique.
    + cbn.
      etrans. apply @pathsinv0, assoc.
      etrans. apply maponpaths, comp_ext_compare_π.
      apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
    + apply (map_into_Pb_unique (qq_π_Pb Z _ _)).
      * cbn.
        etrans. apply @pathsinv0, assoc.
        etrans. apply maponpaths, qq_π.
        etrans. apply assoc.
        etrans. apply maponpaths_2.
          etrans. apply @pathsinv0, assoc.
          etrans. apply maponpaths, comp_ext_compare_π.
          apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
        etrans. apply id_left.
        apply pathsinv0.
        etrans. apply @pathsinv0, assoc.
        etrans. apply maponpaths.
          apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
        apply id_right.
      * cbn.
        etrans. apply @pathsinv0, assoc.
        etrans. apply @pathsinv0, assoc.
        etrans. apply maponpaths.
          etrans. apply maponpaths_2.
            etrans. apply comp_ext_compare_comp.
            etrans. apply maponpaths, comp_ext_compare_comp.
            apply assoc.
          etrans. apply @pathsinv0, assoc.
          etrans. apply maponpaths.
            etrans. apply assoc.
            apply @pathsinv0. apply qq_comp_general.
          etrans. apply @pathsinv0, assoc.
          etrans. apply maponpaths, comp_ext_compare_qq.
          etrans. apply maponpaths, qq_comp.
          apply assoc.
        etrans. apply assoc.
        etrans. apply maponpaths_2.
          etrans. apply maponpaths.
            etrans. apply assoc.
            etrans. apply maponpaths_2.
              etrans. apply @pathsinv0, comp_ext_compare_comp.
              apply comp_ext_compare_id_general.
            apply id_left.
          apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
        etrans. apply id_left.
        apply pathsinv0.
        etrans. apply @pathsinv0, assoc.
        etrans. apply maponpaths.
          apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
        apply id_right.
Time Qed.

Definition compatible_term_from_qq : compatible_term_structure Z
  := (term_from_qq,, iscompatible_term_from_qq).

End compatible_term_structure_from_qq.

Arguments tm_from_qq : simpl never.
Arguments tm_from_qq_functor_mor : simpl never.
Arguments pp_from_qq : simpl never.
Arguments te_from_qq : simpl never.
Arguments Q_from_qq _ {_} _ : simpl never.

(** * Defining a (compatible) _q_-morphism structure, given a term structure

Key definitions: [qq_from_term], [iscompatible_qq_from_term] *)

(* TODO: see if this section can be simplified to construct the q-morphisms more directly. *)

Section compatible_comp_structure_from_term.

Variable Y : term_fun_structure C X.

Section qq_from_term.

Variables Γ Γ' : C.
Variable f : C⟦Γ', Γ⟧.
Variable A : Ty X Γ.

Let Xk := make_Pullback _ (isPullback_Q_pp Y A).

(** ** Groundwork in presheaves

We first construct maps of presheaves that will be the image of the _q_-morphisms under the Yoneda embedding. *)

Definition Yo_of_qq : _ ⟦Yo (Γ' ◂ A[f]), Yo (Γ ◂ A) ⟧.
Proof.
  use (PullbackArrow Xk).
  - apply (#Yo (π _) ;; #Yo f ).
  - apply (Q Y).
  - abstract (
        clear Xk;
        assert (XT := Q_pp Y A[f]);
        eapply pathscomp0; try apply XT; clear XT;
        rewrite <- assoc; apply maponpaths;
        apply pathsinv0, yy_natural
    ).
Defined.

Lemma Yo_of_qq_commutes_1 : # Yo (π _ ) ;; # Yo f = Yo_of_qq ;; # Yo (π _ ) .
Proof.
  apply pathsinv0.
  apply (PullbackArrow_PullbackPr1 Xk).
Qed.

Lemma Yo_of_qq_commutes_2 : Yo_of_qq ;; Q _ A = Q Y _ .
Proof.
  apply (PullbackArrow_PullbackPr2 Xk).
Qed.

Lemma isPullback_Yo_of_qq : isPullback Yo_of_qq_commutes_1.
Proof.
  simple refine (isPullback_two_pullback _ _ _ _ _ _ _ _ _ ).
  - apply (TY X).
  - apply (TM Y).
  - apply (yy A).
  - apply pp.
  - apply Q.
  - apply Q_pp.
  - apply isPullback_Q_pp.
  - match goal with [|- isPullback ?HH ] => generalize HH end.
    rewrite <- (@yy_natural C).
    rewrite Yo_of_qq_commutes_2.
    intro.
    apply isPullback_Q_pp.
Qed.

(** ** Construction of the _q_-morphisms *)
Definition qq_term :  _ ⟦Γ' ◂ A[f] , Γ ◂ A⟧.
Proof.
  apply (invweq (make_weq _ (yoneda_fully_faithful _  _ _ ))).
  apply Yo_of_qq.
Defined.

Lemma Yo_qq_term_Yo_of_qq : # Yo qq_term = Yo_of_qq.
Proof.
  unfold qq_term.
  assert (XT := homotweqinvweq
     (make_weq _ (yoneda_fully_faithful _ (Γ'◂ A[f]) (Γ ◂ A)))).
  apply XT.
Qed.

Lemma qq_commutes_1 :  qq_term ;; π _ = π _ ;; f.
Proof.
  assert (XT:= Yo_of_qq_commutes_1).
  rewrite <- Yo_qq_term_Yo_of_qq in XT.
  do 2 rewrite <- functor_comp in XT.
  apply (invmaponpathsweq (make_weq _ (yoneda_fully_faithful _ _ _ ))).
  apply @pathsinv0, XT.
Qed.

Definition isPullback_qq : isPullback (!qq_commutes_1).
Proof.
  use (isPullback_preimage_square _ _ Yo).
  - apply yoneda_fully_faithful.
  - assert (XT:= isPullback_Yo_of_qq).
    match goal with |[|- isPullback ?HHH] => generalize HHH end.
    rewrite Yo_qq_term_Yo_of_qq.
    intro. assumption.
Qed.

End qq_from_term.

(** ** Assembly into a compatible _q_-morphism structure. *)

Definition qq_from_term_data : qq_morphism_data X.
Proof.
  use tpair.
  - intros. apply qq_term.
  - cbn. intros. simpl.
    exists (qq_commutes_1 _ _ _ _ ).
    apply isPullback_qq.
Defined.

Lemma is_split_qq_from_term : qq_morphism_axioms qq_from_term_data.
Proof.
  split.
  - intros Γ A. simpl.
    apply (invmaponpathsweq (make_weq _ (yoneda_fully_faithful _ _ _ ))).
    etrans; [ apply (homotweqinvweq (make_weq _ (yoneda_fully_faithful _ _ _ ))) | idtac ].
    apply pathsinv0.
    unfold Yo_of_qq.
    apply PullbackArrowUnique.
    + etrans. apply maponpaths. cbn. apply idpath.
      rewrite <- functor_comp.
      etrans. eapply pathsinv0. use (functor_comp Yo).
      apply maponpaths.
      etrans. { apply comp_ext_compare_π. }
      apply pathsinv0, id_right.
    + etrans. apply maponpaths. cbn. apply idpath.
      apply comp_ext_compare_Q.
  - intros.
    apply (invmaponpathsweq (make_weq _ (yoneda_fully_faithful _ _ _ ))).
    etrans; [ apply (homotweqinvweq (make_weq _ (yoneda_fully_faithful _ _ _ ))) | idtac ].
    sym. apply PullbackArrowUnique.
    + etrans. apply maponpaths. cbn. apply idpath.
      rewrite <- functor_comp.
      etrans. eapply pathsinv0. use (functor_comp Yo).
      apply maponpaths.
      rewrite <- assoc. rewrite qq_commutes_1 .
      repeat rewrite assoc.
      rewrite assoc4.
      etrans. apply maponpaths_2. apply maponpaths. eapply qq_commutes_1 .
      apply maponpaths_2.
      repeat rewrite assoc.
      apply maponpaths_2.
      apply comp_ext_compare_π.
    + etrans. apply maponpaths. cbn. apply idpath.
      etrans. apply maponpaths_2. apply functor_comp.
      rewrite <- assoc.
      rewrite Yo_qq_term_Yo_of_qq.
      rewrite  Yo_of_qq_commutes_2 .
      etrans. apply maponpaths_2. apply functor_comp.
      rewrite <- assoc.
      etrans. apply maponpaths. apply maponpaths_2. apply Yo_qq_term_Yo_of_qq.
      etrans. apply maponpaths. apply Yo_of_qq_commutes_2 .
      apply comp_ext_compare_Q.
Qed.

Definition qq_from_term
  : qq_morphism_structure X.
Proof.
  exists qq_from_term_data.
  apply is_split_qq_from_term.
Defined.

Lemma iscompatible'_qq_from_term : iscompatible'_term_qq Y qq_from_term.
Proof.
  intros Γ Γ' A f.
  assert (XR:= Yo_of_qq_commutes_2).
  apply pathsinv0.
  rewrite Yo_qq_term_Yo_of_qq.
  apply XR.
Qed.

Lemma iscompatible_qq_from_term : iscompatible_term_qq Y qq_from_term.
Proof.
  apply (pr2 (iscompatible_iscompatible' _ _)).
  apply iscompatible'_qq_from_term.
Qed.

Definition compatible_qq_from_term : compatible_qq_morphism_structure Y
  := (qq_from_term,, iscompatible_qq_from_term).

End compatible_comp_structure_from_term.

End Fix_Base_Category.


Require Import Category.
Require Import Coq.
Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.
Require Import List.

Set Universe Polymorphism.

Class Functor (C D:Category) := {
  fobj : @object C -> @object D;
  fmap {a b} : (a → b) -> (fobj a → fobj b);
  mapId {a} : fmap (@id C a) = id;
  mapCompose {a b c} {f:a → b} {g:b → c} : fmap (f ∘ g) = fmap f ∘ fmap g
}.

Instance IdentityFunctor C : Functor C C :=
  {| fobj a := a; fmap a b f := f |}.
Proof.
  all: intros;reflexivity.
Defined.

Instance Cat : Category := {|
  object := Category;
  morphism := Functor;
  id := IdentityFunctor;
  composition a b c f g := {| fobj a := fobj (fobj a);
                              fmap a b f := fmap (fmap f) |}
|}.
Proof.
  - intros.
    rewrite mapId.
    rewrite mapId.
    reflexivity.
  - intros.
    rewrite mapCompose.
    rewrite mapCompose.
    reflexivity.
  - cbn.
    intros.
    case f.
    intros.
    f_equal; apply proof_irrelevance.
  - cbn.
    intros.
    case f.
    intros.
    f_equal; apply proof_irrelevance.
  - cbn.
    intros.
    f_equal; apply proof_irrelevance.
Defined.

Definition endoFunctor `{C:Category} := Functor C C.

Definition listEndoFunctor : @endoFunctor Coq.
  refine {|
    fobj := list : @object Coq -> @object Coq;
    fmap := map
  |}.
  - intro A.
    extensionality l.
    apply map_id.
  - intros A B C f g.
    extensionality l.
    induction l.
    + reflexivity.
    + cbn in *.
      congruence.
Defined.

Instance Const (C D:Category) (o:@object D) : Functor C D := {|
  fobj a := o;
  fmap a b f:= id
|}.
Proof.
  - intros.
    reflexivity.
  - intros.
    rewrite Category.rightId.
    reflexivity.
Defined.


(** * Adámek's theorem

The main result is Adámek's theorem for constructing initial algebras of
omega-cocontinuous functors ([colimAlgIsInitial]) which is used to construct
inductive types.

Written by: Anders Mörtberg and Benedikt Ahrens, 2015-2016
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.

Require Import UniMath.CategoryTheory.Chains.Chains.

Local Open Scope cat.

(** * Adámek's theorem for constructing initial algebras of omega-cocontinuous functors *)
(** This section proves that (L,α : F L -> L) is the initial algebra
    where L is the colimit of the initial chain:
<<
         !          F !           F^2 !
     0 -----> F 0 ------> F^2 0 --------> F^3 0 ---> ...
>>
This result is also known as Adámek's theorem % \cite{Adamek1974}: \par %

  https://ncatlab.org/nlab/show/initial+algebra+of+an+endofunctor#AdameksTheorem

Adámek, Jiří. "Free algebras and automata realizations in the language of categories."
Commentationes Mathematicae Universitatis Carolinae 015.4 (1974): 589-602.

*)
Section colim_initial_algebra.

Context {C : category} (InitC : Initial C).

(* It is important that these are not packaged together as it is
   sometimes necessary to control how opaque HF is. See
   [isalghom_pr1foldr] in Lists.v *)
Context {F : functor C C} (HF : is_omega_cocont F).

Let Fchain : chain C := initChain InitC F.

Variable (CC : ColimCocone Fchain).

Let L : C := colim CC.
Let FFchain : chain C := mapchain F Fchain.
Let Fa : cocone FFchain (F L) := mapcocone F _ (colimCocone CC).
Let FHC' : isColimCocone FFchain (F L) Fa :=
  HF Fchain L (colimCocone CC) (isColimCocone_from_ColimCocone CC).
Let FHC : ColimCocone FFchain := make_ColimCocone _ _ _ FHC'.

Local Definition shiftCocone : cocone FFchain L.
Proof.
use make_cocone.
- intro n; apply (coconeIn (colimCocone CC) (S n)).
- abstract (intros m n e; destruct e ;
            apply (coconeInCommutes (colimCocone CC) (S m) _ (idpath _))).
Defined.

Local Definition unshiftCocone (x : C) (cc : cocone FFchain x) : cocone Fchain x.
Proof.
use make_cocone.
- simpl; intro n.
  induction n as [|n]; simpl.
  + apply InitialArrow.
  + apply (coconeIn cc _).
- abstract (simpl; intros m n e; destruct e;
            destruct m as [|m]; [ apply InitialArrowUnique
                                | apply (coconeInCommutes cc m _ (idpath _))]).
Defined.

Local Definition shiftIsColimCocone : isColimCocone FFchain L shiftCocone.
Proof.
intros x cc; simpl.
use tpair.
+ use tpair.
  * apply colimArrow, (unshiftCocone _ cc).
  * abstract (intro n; apply (colimArrowCommutes CC x (unshiftCocone x cc) (S n))).
+ abstract (intros p; apply subtypePath;
             [ intro f; apply impred; intro; apply homset_property
             | apply colimArrowUnique; intro n;
               destruct n as [|n]; [ apply InitialArrowUnique | apply (pr2 p) ]]).
Defined.

Local Definition shiftColimCocone : ColimCocone FFchain :=
  make_ColimCocone FFchain L shiftCocone shiftIsColimCocone.

Definition colim_algebra_mor : C⟦F L,L⟧ := colimArrow FHC L shiftCocone.

Local Definition is_z_iso_colim_algebra_mor : is_z_isomorphism colim_algebra_mor :=
  isColim_is_z_iso _ FHC _ _ shiftIsColimCocone.

Let α : z_iso (F L) L := make_z_iso' _ is_z_iso_colim_algebra_mor.
Let α_inv : z_iso L (F L) := z_iso_inv_from_z_iso α.
Let α_alg : algebra_ob F := tpair (λ X : C, C ⟦ F X, X ⟧) L α.

Lemma unfold_inv_from_z_iso_α :
  inv_from_z_iso α = colimArrow shiftColimCocone _ (colimCocone FHC).
Proof.
apply idpath.
Qed.

(** Given an algebra:
<<
          a
   F A ------> A
>>
 we now define an algebra morphism ad:
<<
          α
   F L ------> L
    |          |
    |          | ad
    |          |
    V     a    V
   F A ------> A
>>

*)
Section algebra_mor.

Variable (Aa : algebra_ob F).

Local Notation A := (alg_carrier _ Aa).
Local Notation a := (alg_map _ Aa).

Local Definition cocone_over_alg (n : nat) : C ⟦ dob Fchain n, A ⟧.
Proof.
induction n as [|n Fn]; simpl.
- now apply InitialArrow.
- now apply (# F Fn · a).
Defined.

(* a_n : F^n 0 -> A *)
Local Notation an := cocone_over_alg.

(* This makes Coq not unfold dmor during simpl *)
Arguments dmor : simpl never.

Lemma isCoconeOverAlg n Sn (e : edge n Sn) : dmor Fchain e · an Sn = an n.
Proof.
destruct e.
induction n as [|n IHn].
- now apply InitialArrowUnique.
- simpl; rewrite assoc.
  apply cancel_postcomposition, pathsinv0.
  eapply pathscomp0; [|simpl; apply functor_comp].
  now apply maponpaths, pathsinv0, IHn.
Qed.

(* ad = a† = a dagger *)
Local Definition ad : C⟦L,A⟧.
Proof.
apply colimArrow.
use make_cocone.
- apply cocone_over_alg.
- red; apply isCoconeOverAlg.
Defined.

Lemma ad_is_algebra_mor : is_algebra_mor _ α_alg Aa ad.
Proof.
apply pathsinv0, z_iso_inv_to_left, colimArrowUnique; simpl; intro n.
destruct n as [|n].
- now apply InitialArrowUnique.
- rewrite assoc, unfold_inv_from_z_iso_α.
  eapply pathscomp0;
    [apply cancel_postcomposition, (colimArrowCommutes shiftColimCocone)|].
  simpl; rewrite assoc, <- functor_comp.
  apply cancel_postcomposition, maponpaths, (colimArrowCommutes CC).
Qed.

Local Definition ad_mor : algebra_mor F α_alg Aa := tpair _ _ ad_is_algebra_mor.

End algebra_mor.

Lemma colimAlgIsInitial_subproof (Aa : category_FunctorAlg F)
        (Fa' : algebra_mor F α_alg Aa) : Fa' = ad_mor Aa.
Proof.
apply algebra_mor_eq; simpl.
apply colimArrowUnique; simpl; intro n.
destruct Fa' as [f hf]; simpl.
unfold is_algebra_mor in hf; simpl in hf.
induction n as [|n IHn]; simpl.
- now apply InitialArrowUnique.
- rewrite <- IHn, functor_comp, <- assoc.
  eapply pathscomp0; [| eapply maponpaths; apply hf].
  rewrite assoc.
  apply cancel_postcomposition, pathsinv0, (z_iso_inv_to_right _ _ _ _ α).
  rewrite unfold_inv_from_z_iso_α; apply pathsinv0.
  now eapply pathscomp0; [apply (colimArrowCommutes shiftColimCocone)|].
Qed.

Lemma colimAlgIsInitial : isInitial (category_FunctorAlg F) α_alg.
Proof.
apply make_isInitial; intros Aa.
exists (ad_mor Aa).
apply colimAlgIsInitial_subproof.
Defined.

Definition colimAlgInitial : Initial (category_FunctorAlg F) :=
  make_Initial _ colimAlgIsInitial.

End colim_initial_algebra.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import Coq.Lists.List.
Require Import Coq.NArith.BinNat.
Require Import Coq.ZArith.ZArith.

Require Import CompCert.Events.

Require Import Common.CoqMaps.
Require Import Common.Values.
Require Import Common.Either.

Require Import Intermediate.Machine.

Require Import I2SFI.Compiler.

Require Import TargetSFI.Machine.
Require Import TargetSFI.CS.
Require Import TargetSFI.ExecutionError.

Require Import Tests.CompilerPBTests.
Require Import Tests.IntermediateProgramGeneration.
Require Import Tests.I2SFI.I2SFICompUtil.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.

Module DoNotation.
  Import ssrfun.
  Notation "'do!' X <- A ; B" :=
    (bindGen A (fun X => B))
      (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

Inductive checker_type : Type :=
| CStore : checker_type
| CJump : checker_type
| CStack : checker_type.

(**************************
 * Log data structures
 **************************)
(* first list rescords event of interest to the test
   second list records the program counter of the executed instructions *)
Definition log_type (entry_type:Type) :=
  ((list entry_type) * (list RiscMachine.address))%type.

(**************************
 * Log Update Functions
 **************************)
(* env, old state, trace, new state, old log
   Returns: updated log *)
Definition update_records {entry_type:Type} :=
  Env.t ->
  MachineState.t -> CompCert.Events.trace ->
  MachineState.t ->
  (log_type entry_type) ->
  (log_type entry_type).

Definition get_freq_store (i : instr_type) :=
  match i with
  | Nop => 1%nat
  | Label => 4%nat
  | Const => 4%nat
  | Mov => 2%nat
  | BinOp => 6%nat
  | Load => 4%nat
  | Store => 0%nat
  | Alloc => 4%nat
  | Bnz => 1%nat (* could generate infinite loops *)
  | Jump => 1%nat
  | Jal => 1%nat
  | Call => 4%nat
  | Return => 2%nat
  | Halt => 1%nat
  end.

Definition get_freq_jump (i : instr_type) :=
  match i with
  | Nop => 1%nat
  | Label => 4%nat
  | Const => 4%nat
  | Mov => 2%nat
  | BinOp => 6%nat
  | Load => 4%nat
  | Store => 4%nat
  | Alloc => 4%nat
  | Bnz => 1%nat (* could generate infinite loops *)
  | Jump => 20%nat
  | Jal => 1%nat
  | Call => 4%nat
  | Return => 2%nat
  | Halt => 1%nat
  end.

Definition get_freq_call (i : instr_type) :=
  match i with
  | Nop => 1%nat
  | Label => 4%nat
  | Const => 4%nat
  | Mov => 2%nat
  | BinOp => 6%nat
  | Load => 4%nat
  | Store => 40%nat
  | Alloc => 4%nat
  | Bnz => 1%nat (* could generate infinite loops *)
  | Jump => 40%nat
  | Jal => 1%nat
  | Call => 40%nat
  | Return => 2%nat
  | Halt => 1%nat
  end.

Definition get_weigths (ct : checker_type) : instr_weight :=
  match ct with
  | CStore => get_freq_store
  | CJump => get_freq_jump
  | CStack => get_freq_call
  end.

Definition gen_code_address_offset : G N :=
  freq [ (8%nat, choose_N (0%N, 15%N));
           (8%nat, elems
                   [ (2*16+8)%N
                     ; (3*16+8)%N
                     ; (4*16+8)%N
                     ; (5*16+8)%N
                     ; (6*16+8)%N
                     ; (7*16+8)%N
                     ; (8*16+8)%N
                     ; (9*16+8)%N
                     ; (10*16+8)%N
                     ; (11*16+8)%N
                     ; (12*16+8)%N
                     ; (13*16+8)%N
                     ; (14*16+8)%N] ) ;
           ( 2%nat,
             (
               do! k <- elems [1%N; 2%N; 3%N; 4%N; 5%N; 6%N; 7%N; 8%N; 9%N ];
                 do! l <- elems [0%N; 1%N; 2%N; 3%N; 4%N; 5%N; 6%N; 7%N;
                                  8%N; 9%N; 10%N; 11%N; 12%N; 13%N; 14%N; 15%N ];
                 returnGen (16*k+l)%N
             )
           )
       ].

Definition genIConstCodeAddress
           (ct : checker_type)
           (max_components : nat)
           (r : Intermediate.Machine.register)
           (pi : prog_int)
           (cid : Component_id)
  : G (list instr) :=
  match ct with
  | CJump =>
    do! cid' <- choose_N (1%N, ((N.of_nat max_components) - 1)%N);
      do! cid1 <- elems [0%N;cid'];
      do! pid <- choose_N (1%N, (N.of_nat MAX_PROC_PER_COMP));
      do! offset <- (
          do! k <- elems [1%N; 2%N; 3%N ];
            do! l <- elems [0%N; 1%N; 2%N; 3%N; 4%N; 5%N; 6%N; 7%N;
                             8%N; 9%N; 10%N; 11%N; 12%N; 13%N; 14%N; 15%N ];
            returnGen (16*k+l)%N
        );
      let v := SFI.address_of
                 cid1
                 (2*(pid - 1))%N
                 offset in
      returnGen ((IConst (IInt (Z.of_N v)) r)::nil)
  | _ =>
    do! pid <-
      ( match BinNatMap.find cid pi with
        | None => returnGen 1%nat
        | Some (exp,_) => choose (0%nat,((List.length exp) - 1)%nat)
        end);
      do! offset <-  gen_code_address_offset;
      let v := SFI.address_of
                 cid
                 (2*(N.of_nat pid))%N
                 offset in
      returnGen ((IConst (IInt (Z.of_N v)) r)::nil)
  end.

Definition genTargetedStore
           (ct : checker_type)
           (max_components : nat)
           (r1 r2: Intermediate.Machine.register)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (Block_id * (nat+list value))))
           (cid : Component_id)
    : G (list instr) :=

      (* 50% in component zero *)
      do! cid' <- choose_N (1%N, ((N.of_nat max_components) - 1)%N);
      do! cid1 <- elems [0%N;cid'];

      (* (* valid slot id *) *)
      do! bid <-
        match ct with
        | CStack =>
          freq [ (1%nat,returnGen 0%N);
                   (1%nat, choose_N (1%N,3%N)) ]
        | _ =>
          (match BinNatMap.find cid' buffers with
           | None =>
             choose_N (0%N, ((N.of_nat MAX_NO_BUFFERS_PER_COMP)-1)%N)
           | Some lst => choose_N (1%N, N.of_nat (List.length lst) )
           end)
        end;

      do! offset' <- choose_N (1%N, N.of_nat MAX_BUFFER_SIZE);
      do! offset <-
        match ct with
        | CStack => returnGen 0%N
        | _ => elems [0%N;offset']
        end;

      let v := SFI.address_of cid1
                              (2*bid+1)%N
                              offset in
      do! li <- genIConstCodeAddress ct max_components r2 pi cid;

      returnGen  (li ++ (IConst (IInt (Z.of_N v)) r1)::nil)%list.

Definition genStoreAddresConstInstr
           (ct : checker_type)
           (max_components : nat)
           (r1 r2: Intermediate.Machine.register)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (Block_id * (nat+list value))))
           (cid : Component_id)
    : G (list instr) :=
  match ct with
  | CStore
  | CStack
    => genTargetedStore ct max_components r1 r2 pi buffers cid
  | _ =>
    do! res <- genPtrImVal pi buffers cid true;
      match res with
      | None => returnGen nil
      | Some ptr =>
        returnGen ((IConst ptr r1)::nil)
      end
  end.

Definition eval_program {X:Type}
           (update_fun : update_records)
           (* (ct : checker_type) *)
           (p : sfi_program)
           (fuel : nat)
  : (@Either (CompCert.Events.trace*MachineState.t*nat)%type ExecutionError)
    * (log_type X)
  :=
  ((CS.eval_program_with_state
     (log_type X)
     update_fun
     fuel
     p
     (RiscMachine.RegisterFile.reset_all)) (nil,nil)).

Definition sfi_check_correct {log_entry_type : Type}
           (t : undef_allowed)
           (ct : checker_type)
           (update_fun : @update_records
                           log_entry_type)
           (log_checker_error_fun : @log_checker_error
                                      (@log_type log_entry_type)
                                      ExecutionError
           )
           (log_checker_fun : @log_checker
                                (@log_type log_entry_type)
                                (* execution result *)
                                (CompCert.Events.trace * MachineState.t * nat)
           )
           (fuel : nat)
  : Checker :=
  (* if we have 0 components we have a silly case *)
  let max_components := ((N.to_nat SFI.COMP_MAX) - 1)%nat in
  check_correct
    t
    (match ct with
        | CStore => get_freq_store
        | CJump => get_freq_jump
        | CStack => get_freq_call
        end)
    (genIConstCodeAddress ct max_components)
    (genStoreAddresConstInstr ct max_components)
    3%nat
    3%nat
    log_checker_error_fun
    log_checker_fun
    compile_program
    (eval_program update_fun)
    fuel.


Require Import ListAux.
Lemma uniquel2consistent_cons0 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_member  il_0 u_0)) -> (list_member  il_1 u_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons1 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_once  il_1 u_0)/\(list_member  il_0 u_0)) -> (not (u_0 = i_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons2 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_once  il_1 u_0)/\(list_member  il_0 u_0)) -> (list_once  il_0 u_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons3 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_once  il_1 u_0)/\(list_member  il_0 u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons4 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_once  il_0 u_0)/\(not (list_once  il_1 u_0))/\(list_member  il_0 u_0)) -> (u_0 = i_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons5 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((u_0 = i_0)/\(not (list_once  il_0 u_0))/\(not (list_once  il_1 u_0))/\(list_member  il_0 u_0)) -> (list_head  il_1 i_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons6 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_0 = i_0))/\(not (list_once  il_0 u_0))/\(not (list_once  il_1 u_0))/\(list_member  il_0 u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons7 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_0))) -> (not (list_head  il_0 u_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons8 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_0))) -> (not (list_once  il_0 u_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons9 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_member  il_0 u_0))) -> (list_head  il_1 u_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons10 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_member  il_0 u_0))) -> (u_0 = i_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons11 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_member  il_0 u_0))) -> (list_once  il_1 i_0)).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons12 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))/\(not (list_member  il_0 u_0))) -> (not (list_once  il_1 u_0))).
Proof. solve_push. Qed.

Lemma uniquel2consistent_cons13 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))/\(not (list_member  il_0 u_0))) -> (not (u_0 = i_0))).
Proof. solve_push. Qed.


Require Import RelationClasses Morphisms Setoid Lia.

From mathcomp Require Import all_ssreflect.

From GraphTheory Require Import edone finite_quotient preliminaries.
From GraphTheory Require Import digraph sgraph minor checkpoint cp_minor.
From GraphTheory Require Import setoid_bigop structures pttdom ptt.
From GraphTheory Require Import mgraph mgraph2 skeleton bounded.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Arguments edge_set [Lv Le] G _,[Lv Le G] _.

Section ExtractionDef.
Variable sym : Type.
Notation graph := (graph unit (flat sym)).
Notation graph2 := (graph2 unit (flat sym)).

(* TODO: resolve this name clash *)
Local Notation link_rel := checkpoint.link_rel.

(* same as in mgraph2_tw2.v, but different from [reduction.graph_of_term]
   (the latter start from a 2pdom term rather than a 2p term) *)
Definition graph_of_term: term sym -> graph2 := eval (fun a : flat sym => @g2_var _ _ a).

(** * Term Extraction for 2p-graphs in TW2 *)

(** ** Extraction function for connected graphs *)

(** *** Termination Metric *)

Definition term_of_measure (G : graph2) :=
  (input == output :> G) + 2*#|edge G|.

Local Notation measure G := (term_of_measure G).

Ltac normH := match goal
  with
  | [ H : is_true (_ <= _) |- _] => move/leP : H
  | [ H : is_true (_ == _) |- _] => move/eqP : H
  end.
Ltac elim_ops := rewrite -multE -plusE -!(rwP leP).

Ltac slia := repeat normH; elim_ops; intros; lia.

Lemma measure_card (G' G : graph2) :
  #|edge G'| < #|edge G| -> measure G' < measure G.
Proof.
  rewrite /term_of_measure.
  do 2 case: (input == output) => /=; slia.
Qed.

Lemma measure_io (G' G : graph2) :
  (input == output :> G) -> (input != output :> G') -> #|edge G'| <= #|edge G| ->
  measure G' < measure G.
Proof.
  rewrite /term_of_measure.
  do 2 case: (input == output) => //=; slia.
Qed.

Lemma measure_subgraph (G : graph2) V E (con : @consistent _ _ G V E) x y e :
  e \notin E -> measure (@point (subgraph_for con) x y) < measure G.
Proof.
  move => He. apply: measure_card. rewrite card_sig.
  apply: proper_card. apply/properP. split; by [exact/subsetP| exists e].
Qed.

Lemma measure_node (G : graph2) V E (con : @consistent _ _ G V E) v x y :
  connected [set: skeleton G] ->
  v \notin V -> measure (@point (subgraph_for con) x y) < measure G.
Proof.
  move => /connectedTE conn_G Hv.
  case/connect_irredP : (conn_G v (val x)) => p _.
  have vx: v != val x. { apply: contraNN Hv => /eqP->. exact: valP. }
  case: (splitL p vx) => u [vu] _ {p vx}. move: vu.
  rewrite /=/sk_rel. case/andP=> _ /existsP[e He].
  refine (@measure_subgraph _ _ _ _ _ _ e _).
  apply: contraNN Hv. move/con =>H.
  move: He. by rewrite !inE => /orP[/andP[/eqP<- _]|/andP[_ /eqP<-]].
Qed.

(** *** Subroutines *)

Definition lens (G : graph2) :=
  [&& edge_set G (@bag G IO input)  == set0 ,
      edge_set G (@bag G IO output) == set0 &
      @link_rel (skeleton G) input output].

Lemma get_edge (G : graph) (U : {set G}) (x y : skeleton G) :
  x \in U -> y \in U -> x -- y -> exists e : edge G, e \in edge_set U.
Proof.
  move => Hx Hy. rewrite /=/sk_rel => /andP[_].
  case/existsP=> e He. exists e. move: He.
  by rewrite !inE => /orP[]/andP[/eqP-> /eqP->]; rewrite Hx Hy.
Qed.

Lemma edgeless_bag (G : graph) (U : {set G}) (x : skeleton G) :
  connected [set: skeleton G] -> x \in @CP G U ->
  edge_set (@bag G U x)  == set0 -> @bag G U x == [set x].
Proof.
  move => con_G cp_x.
  apply: contraTT => /bag_nontrivial [y Y1 Y2]. rewrite eq_sym in Y2.
  have con_Px := connected_bag con_G cp_x.
  have [||z Pz xz] := connected_card_gt1 con_Px _ _ Y2.
    exact: bag_id. done.
  apply/set0Pn. apply: get_edge xz => //. exact: bag_id.
Qed.

Lemma lens_io_set (G : graph2) :
  lens G -> @edge_set _ _ G IO = edges input output :|: edges output input.
Proof.
  move => /and3P [A B _]. apply/setP => e. apply/idP/idP.
  - rewrite !inE.
    (repeat let H := fresh in case: (boolP (_ == _)) => H) => //= _.
    + apply: contraTT A => _. apply/set0Pn; exists e.
      by rewrite inE (eqP H) (eqP H1) (@bag_id G).
    + apply: contraTT B => _. apply/set0Pn; exists e.
      by rewrite inE (eqP H0) (eqP H2) (@bag_id G).
  - by case/setUP ; apply: edge_in_set; rewrite !inE eqxx.
Qed.

Lemma lens_sinterval (G : graph2) :
  connected [set: skeleton G] -> lens G ->
  (@sinterval G input output = ~: IO).
Proof.
  move=> G_conn /and3P[] /edgeless_bag/eqP-/(_ G_conn (CP_extensive _)).
  rewrite !inE -setTD eqxx =>/(_ isT) bag_i.
  move=> /edgeless_bag/eqP-/(_ G_conn (CP_extensive _)).
  rewrite !inE eqxx orbT =>/(_ isT) bag_o /andP[iNo _].
  rewrite (sinterval_bag_cover G_conn iNo) bag_i bag_o setUAC.
  rewrite setDUl setDv set0U setDE. apply: esym; apply/setIidPl.
  apply/subsetP=> x x_sI. rewrite !inE negb_or.
  apply/andP; split; apply: contraTneq x_sI =>->; by rewrite sinterval_bounds.
Qed.

Arguments cp : clear implicits.
Arguments Path : clear implicits.

Definition CK4F (G : graph2) := connected [set: skeleton G] /\ K4_free (sskeleton G).

(** If G is a lens with non non-adjacent input and output, then it has
at least two parallel components *)
Lemma split_K4_nontrivial (G : graph2) :
  input != output :> G ->
  lens G ->
  ~~ @adjacent _ _ G input output ->
  CK4F G ->
  1 < #|components (@sinterval (skeleton G) input output)|.
Proof.
  move => A B C [D E].
  apply/equivalence_partition_gt1P.
  - move => x y z _ _ _. exact: (sedge_in_equiv (G := skeleton G)).
  - set H := sinterval _ _. apply: ssplit_K4_nontrivial (E) (D).
    + by rewrite /edge_rel/=/sk_rel A.
    + by case/and3P : B.
Qed.

Fact redirect_proof1 (T : finType) x (A : {set T}) : x \in x |: A.
Proof. by rewrite !inE eqxx. Qed.
Arguments redirect_proof1 {T x A}.

(** subgraph induced by [i |: H] without i-selfloops and with output set
to [o] *)
Lemma redirect_consistent (G : graph2) (H : {set G}) (o : G) :
  let H' := input |: (o |: H) in
  consistent H' (edge_set H' :\: edges input input).
Proof. apply: consistent_setD. exact: induced_proof. Qed.

Fact redirect_output_proof (T : finType) x y (B : {set T}) : x \in y |: (x |: B).
Proof. by rewrite !inE eqxx. Qed.
Arguments redirect_output_proof {T x y B}.

Definition redirect_to (G : graph2) (H : {set G}) (o:G) :=
  @point (induced (input |: (o |: H)))
         (Sub input (setU11 _ _))
         (Sub o redirect_output_proof).

(** subgraph induced by [i |: H] without i-selfloops and with [o] set
to some neighbor of [i] in H *)
Definition redirect (G : graph2) (H : {set G}) : graph2 :=
  if [pick z in H | adjacent input z] isn't Some z then 1 (* unit_graph2 tt *)
  else redirect_to H z.

Definition component (G : graph2) (H : {set G}) : graph2 :=
  @point (induced (input |: (output |: H)))
         (Sub input (setU11 _ _))
         (Sub output (setU1r _ (setU11 _ _))).

Definition induced2 (G : graph2) (V :{set G}) :=
  match @idP (input \in V), @idP (output \in V) with
  | ReflectT p, ReflectT q => point (induced V) (Sub input p) (Sub output q)
  | _,_ => G
  end.

Lemma induced2_induced (G : graph2) (V :{set G}) (iV : input \in V) (oV :output \in V) :
  induced2 V = point (induced V) (Sub input iV) (Sub output oV).
Proof.
  rewrite /induced2.
  case: {-}_ / idP; last by rewrite iV.
  case: {-}_ / idP; last by rewrite oV.
  move => p q. by rewrite (bool_irrelevance p oV) (bool_irrelevance q iV).
Qed.

Open Scope ptt_ops.

(** Possibly empty sequence of (trivial) terms corresponding to direct
i-o edges. Yields nonempty parallel composition when concatenated with
the terms for the i-o components *)
Definition tm_ (G : graph2) (e : edge G): term sym :=
  if e \in edges input output then tm_var (elabel e) else (tm_var (elabel e))°.

Definition tmEs (G : graph2) : seq (term sym) := [seq tm_ e | e in edge_set G IO].

(** *** The Extraction Functional *)

(** Here we define the extraction function. The case distinctions are chosen
such that we can make use of induced subgraphs (rather than the more generic
[subgraph_for] construction) as much as possible. *)

Definition simple_check_point_term (g : graph2 -> term sym) (G : graph2) : term sym :=
  let (i,o) := (input : G, output : G) in
  if  (edge_set (@bag G IO i) != set0) || (edge_set (@bag G IO o) != set0)
  then g (bgraph IO i) · g (igraph i o) · g (bgraph IO o)
  else if [pick z in @cp G i o :\: IO] isn't Some z then 1 (* never happens *)
       else g (igraph i z) · g(bgraph IO z) · g(igraph z o).

(** NOTE: we assume the input graph to be connected and K4-free *)
Definition term_of_rec (term_of : graph2 -> term sym) (G : graph2) :=
  if input == output :> G
  then (* input equals output *)
    let E := edge_set G IO in
    if [pick e in E] isn't Some e then
      if [pick C in @components G [set~ input]] is Some C then
        dom (term_of (redirect C)) ∥ term_of (induced2 (~: C))
      else 1
    else tm_ e ∥ term_of (point (remove_edges [set e]) input output)
  else (* distinct input and output *)
    if lens G
    then (* no checkpoints and no bags on i and o *)
      let P := components (@sinterval (skeleton G) input output) in
      let E := edge_set G IO in
      if [pick e in E] isn't Some e
      then
        if [pick C in P] isn't Some C then 1 (* never happens *)
        else term_of (component C) ∥ term_of (induced2 (~: C))
      else if (P == set0) && (E :\ e == set0)
           then  tm_ e
           else  tm_ e ∥ term_of (point (remove_edges [set e]) input output)
    else (* at least one nontrivial bag or checkpoint *)
      @simple_check_point_term term_of G.

Definition term_of := Fix top term_of_measure term_of_rec.

(** *** Termination Argument *)

Notation sigraph := cp_minor.igraph.
Lemma sskeleton_add (G : graph) (x y : G) :
  sgraph.subgraph (sskeleton (igraph x y))
                  (sgraph.add_edge (sigraph G x y) istart iend).
Proof.
  exists id => // u v uv _; move: u v uv. apply sskelP.
  - move=> u v. by rewrite sg_sym.
  - move=> e sNt. rewrite /edge_rel /= -!val_eqE /=. apply/orP; left.
    by rewrite /edge_rel/=/sk_rel/edge_rel/=/sk_rel sNt adjacent_edge.
  - by rewrite /edge_rel/= -!val_eqE /= !eqxx => ->.
Qed.

Lemma CK4F_igraph (G : graph2) (x y : G) :
  x \in cp G input output -> y \in cp G input output ->
  CK4F G -> x != y -> CK4F (igraph x y).
Proof.
  move => Hx Hy [conn_G K4F_G] xy.
  split; first exact: connected_igraph.
  apply: subgraph_K4_free (sskeleton_add _ _) _.
  exact: igraph_K4F K4F_G.
Qed.

Lemma measure_igraph (G : graph2) :
    connected [set: skeleton G] ->
    (edge_set (@bag G IO input) != set0) || (edge_set (@bag G IO output) != set0) ->
    measure (@igraph _ _ G input output) < measure G.
Proof.
  move=> G_conn A.
  suff [e] : exists e, e \notin @interval_edges _ _ G input output
    by exact: measure_subgraph.
  have [i_cp o_cp] : input \in @CP G IO /\ output \in @CP G IO
    by split; apply: CP_extensive; rewrite !inE eqxx.
  case/orP: A => /set0Pn[e He]; exists e; last rewrite interval_edges_sym.
  all: by rewrite (disjointFr (interval_bag_edges_disj G_conn _ _) He).
Qed.

(* TOTHINK: how to align induced subgraphs for simple graphs and
induced subgraphs for multigraphs *)
Lemma connected_induced (G : graph) (V : {set skeleton G}) :
  connected V -> connected [set: skeleton (induced V)].
Proof.
  move => conV. apply: connectedTI => u v.
  move: (conV (val u) (val v) (valP u) (valP v)).
  case/upathPR => p /upathW.
  elim: p u => [?|a p IH u].
  - move/pathp_nil/val_inj ->. exact: connect0.
  - rewrite pathp_cons /= -!andbA => /and5P [A B C D E].
    apply: (connect_trans (y := Sub a B)); last exact: IH.
    apply: connect1. move: C. rewrite /edge_rel/=/sk_rel -val_eqE.
    by rewrite adjacent_induced.
Qed.

Lemma induced_K4_free (G : graph2) (V : {set G}) :
  K4_free (sskeleton G) -> K4_free (induced V).
Proof.
  apply: minor_K4_free.
  apply: (minor_trans (y := skeleton G)).
  apply: sub_minor. apply: skel_sub.
  (* NOTE: this is a relation on the respecive skeletons *)
  apply: sub_minor. apply: sub_sub. exact: induced_sub.
Qed.

Lemma CK4F_sub (G : graph2) (V : {set G})  x :
  @connected G V -> CK4F G -> CK4F (point (induced V) x x).
Proof.
  move => conV CK4F_G. split.
  - exact: connected_induced.
  - apply: subgraph_K4_free (sub_pointxx _) _.
    apply: induced_K4_free. apply CK4F_G.
Qed.

Lemma CK4F_induced2 (G : graph2) (V : {set G}) :
    @connected G V -> CK4F G -> CK4F (induced2 V).
Proof.
  move=> V_conn G_CK4F. rewrite /induced2.
  case: {-}_ / idP => // i_V. case: {-}_ / idP => // o_V.
  split; first exact: connected_induced.
  case: G_CK4F => _. apply: subgraph_K4_free.
  exists val; first exact: val_inj.
  move=> x y xy _. move: xy. rewrite /edge_rel/= -!(inj_eq val_inj) /=.
  case/or3P=> [xy|->|->] //. apply/orP. left.
  pattern x, y. revert x y xy.
  apply skelP; first by move=> x y xy; rewrite sgP.
  move=> e. rewrite /edge_rel/=/sk_rel -!(inj_eq val_inj)/= => -> /=.
  exact: adjacent_edge.
Qed.

Lemma rec_bag (G : graph2) (x : G) :
  CK4F G -> x \in @CP (skeleton G) IO -> input != output :> G ->
  CK4F (bgraph IO x) /\ measure (bgraph IO x) < measure G.
Proof.
  move => [conn_G K4F_G] cp_x Dio. split.
  - apply: CK4F_sub => //. exact: connected_bag.
  - suff: (input \notin @bag G IO x) || (output \notin @bag G IO x).
    { by case/orP; exact: measure_node. }
    rewrite -negb_and. apply:contraNN Dio => /andP[].
    rewrite !(bag_cp conn_G) // => [/eqP-> /eqP-> //||];
      by apply CP_extensive; rewrite !inE eqxx.
Qed.

Lemma CK4F_remove_component (G : graph2) (C : {set G}) :
  C \in @components G [set~ input] -> CK4F G -> CK4F (induced2 (~: C)).
Proof.
  move=> C_comp G_CK4F. apply: CK4F_induced2 (G_CK4F). case: G_CK4F => G_conn _.
  have Hi : (@input _ _ G)\notin[set~ input] by rewrite !inE negbK.
  apply: (@remove_component G) Hi C_comp G_conn _. rewrite setCK. exact: connected1.
Qed.

Lemma measure_remove_component (G : graph2) (C : {set G}) :
  CK4F G -> C \in @components G (~: IO) -> measure (induced2 (~: C)) < measure G.
Proof.
  move=> [G_conn _] C_comp.
  case/and3P: (@partition_components G (~: IO)) => /eqP compU _ compN0.
  have /set0Pn[x x_C] : C != set0 by apply: contraTneq C_comp =>->.
  have {x_C} : x \notin ~: C by rewrite inE negbK.
  have : (input  : G) \notin ~: IO by rewrite !inE negbK eqxx.
  have : (output : G) \notin ~: IO by rewrite !inE negbK eqxx.
  rewrite -compU.
  move/bigcupP/(_ (ex_intro2 _ _ C C_comp _))=> /negP oNC.
  move/bigcupP/(_ (ex_intro2 _ _ C C_comp _))=> /negP iNC.
  have {iNC oNC} [iNC oNC] : input \in ~: C /\ output \in ~: C by rewrite !inE.
  rewrite induced2_induced. exact: measure_node.
Qed.

Lemma CK4F_one : CK4F 1.
Proof.
  split. move => [] [] _ _. exact: connect0.
  apply small_K_free. by rewrite card_unit.
Qed.

Lemma CK4F_redirect (G : graph2) C :
  CK4F G -> input == output :> G -> C \in @components G [set~ input] ->
  CK4F (redirect C).
Proof.
  move => CK4F_G Eio HC.
  have D := @partition_components G [set~ input].
  have Csub: C \subset [set~ input].
  { rewrite -(cover_partition D). apply/subsetP => z Hz.
    exact: mem_cover HC _. }
  rewrite /redirect.
  case: pickP => [z /andP [Z1 Z2]|_]; last exact: CK4F_one.
  have conn_iC : @connected G (input |: C).
  { apply: (@connectedU_edge G _ _ input z) => //.
    - by rewrite set11.
    - rewrite /edge_rel/=/sk_rel Z2 andbT.
      move/(subsetP Csub) in Z1. by rewrite !inE eq_sym in Z1.
    - apply: connected1.
    - apply: connected_in_components HC.  }
  split.
  - apply: connected_induced. by rewrite [z |: C]setU1_mem.
  - have: K4_free (induced (input |: C)).
    { apply: induced_K4_free. by apply CK4F_G. }
    apply: iso_K4_free.
    setoid_rewrite <-sskeleton_adjacent.
    by rewrite (setU1_mem Z1).
    by rewrite adjacent_induced.
Qed.

Lemma measure_redirect (G : graph2) C :
  CK4F G -> input == output :> G -> C \in @components G [set~ input] ->
  measure (redirect C) < measure G.
Proof.
  move => CK4F_G Eio HC.
  have D := @partition_components G [set~ input].
  have Csub: C \subset [set~ input].
  { rewrite -(cover_partition D). apply/subsetP => z Hz.
    exact: mem_cover HC _. }
  rewrite /redirect. case: pickP => [x /andP [Hx1 Hx2]|].
  - apply: measure_io => //=.
    + rewrite -val_eqE /=. apply: contraTN Hx1 => /eqP<-.
      apply: contraTN Csub => A. apply/subsetPn. exists input => //. by rewrite setC11.
    + rewrite card_sig. exact: max_card.
  - move => _. apply: measure_card => /=. rewrite card_void.
    have/set0Pn [x Hx] : C != set0.
    { case/and3P : D => _ _. by apply: contraNN => /eqP <-. }
    have: x != input. move/(subsetP Csub) in Hx. by rewrite !inE in Hx.
    apply: has_edge. by apply CK4F_G.
Qed.

Lemma connected_component_set (G : graph2) C :
  CK4F G -> lens G -> C \in components (@sinterval (skeleton G) input output) ->
  @connected G (input |: (output |: C)).
Proof.
  set sI := sinterval _ _. move=> [G_conn G_K4F] G_lens C_comp.
  case: (sinterval_components C_comp) => -[u] u_C iu [v] v_C ov.
  apply: connectedU_edge iu _ _; rewrite 3?inE ?eqxx ?u_C //;
  first exact: connected1.
  apply: connectedU_edge ov _ _; rewrite 1?inE ?eqxx ?v_C //;
  first exact: connected1.
  exact: connected_in_components C_comp.
Qed.

Lemma CK4F_lens (G : graph2) C :
  CK4F G -> lens G -> C \in components (@sinterval (skeleton G) input output) ->
  CK4F (component C).
Proof.
  set sI := sinterval _ _. move=> [G_conn G_K4F] G_lens C_comp.
  split; last by apply: subgraph_K4_free G_K4F; exact: sskeleton_subgraph_for.
  apply: connected_induced. exact: connected_component_set.
Qed.

Lemma lens_components (G : graph2) C :
  CK4F G -> lens G -> edge_set G IO == set0 ->
  C \in components (@sinterval G input output) ->
  exists2 D, D \in components (@sinterval G input output) & D != C.
Proof.
  set sI := sinterval _ _. case/and3P: (partition_components sI).
  set P := components _.
  move=> /eqP compU compI comp0 [G_conn G_K4F] G_lens Eio0 C_comp.
  have iNo : input != output :> G
    by case/and3P: G_lens => _ _ /(@sg_edgeNeq (link_graph G))->.
  have Nio : ~~ @adjacent _ _ G input output.
  { apply: contraTN Eio0 => io. apply/set0Pn.
    case/existsP: io => e. rewrite inE => He. exists e.
    by case/orP: He; apply: edge_in_set; rewrite in_set2 eqxx. }
  have : 1 < #|P| by exact: split_K4_nontrivial.
  rewrite (cardD1 C) C_comp add1n ltnS => /card_gt0P[/= D].
  rewrite !inE => /andP[DNC] D_comp. by exists D.
Qed.

Lemma measure_lens (G : graph2) C :
  CK4F G -> lens G -> edge_set G IO == set0 ->
  C \in components (@sinterval (skeleton G) input output) ->
  measure (component C) < measure G.
Proof.
  set sI := sinterval _ _. case/and3P: (partition_components sI).
  set P := components _.
  move=> /eqP compU compI comp0 G_CK4F G_lens Eio0 C_comp.
  case: (lens_components G_CK4F G_lens Eio0 C_comp) => [D] D_comp DNC.
  have /set0Pn[x x_D] : D != set0 by apply: contraTneq D_comp =>->.
  move/trivIsetP: compI => /(_ D C D_comp C_comp DNC)/disjointFr/(_ x_D) xNC.
  have G_conn : connected [set: skeleton G] by case: G_CK4F.
  suff : x \notin input |: (output |: C) by exact: measure_node.
  have : x \in sI by rewrite -compU; apply/bigcupP; exists D.
  rewrite ![in ~~ _]inE xNC orbF.
  apply: contraTN =>/orP[]/eqP->; by rewrite (@sinterval_bounds G).
Qed.

Section SplitCP.
Variables (G : graph2).
Hypothesis CK4F_G : CK4F G.
Hypothesis Hio : input != output :> G.
Variable (z : G).
Hypothesis Hz : z \in cp G input output :\: IO.

Let Hz' : z \in cp G input output.
Proof. by case/setDP: (Hz). Qed.

Let Zi : z != input.
Proof. move: Hz. rewrite !inE negb_or -andbA. by case/and3P. Qed.

Let Zo : z != output.
Proof. move: Hz. rewrite !inE negb_or -andbA. by case/and3P. Qed.

(* output not in left side, input not in right side *)
(* neither input nor output is in the central bag *)

Lemma CK4F_split_cpL : CK4F (igraph input z).
Proof.
  apply: CK4F_igraph => //; first exact: (@mem_cpl G). by rewrite eq_sym.
Qed.

Lemma CK4F_split_cpR : CK4F (igraph z output).
Proof.
  apply: CK4F_igraph => //. rewrite cp_sym. exact: mem_cpl.
Qed.

Lemma CK4F_split_cpM : CK4F (@bgraph _ _ G IO z).
Proof.
  apply rec_bag => //.
  apply/bigcupP. exists (input,output) => //. by rewrite !inE /= !eqxx.
Qed.

Lemma measure_split_cpL : measure (igraph input z) < measure G.
Proof.
  apply: (measure_node (v := output)); first apply CK4F_G.
  have Ho: output \in @interval G z output. exact: intervalR.
  apply: contraNN Zo => C.
  by rewrite eq_sym -in_set1 -(intervalI_cp Hz') inE C.
Qed.

Lemma measure_split_cpR : measure (igraph z output) < measure G.
Proof.
  apply: (measure_node (v := input)); first apply CK4F_G.
  have Hi := @intervalL G input z.
  apply: contraNN Zi => C.
  by rewrite eq_sym -in_set1 -(intervalI_cp Hz') inE C.
Qed.

Lemma measure_split_cpM : measure (@bgraph _ _ G IO z) < measure G.
Proof.
  apply: (measure_node (v := input)); first apply CK4F_G.
  rewrite (@bag_cp G) 1?eq_sym //; first apply CK4F_G.
  - apply: CP_extensive. by rewrite !inE eqxx.
  - apply/bigcupP. exists (input,output) => //. by rewrite !inE /= !eqxx.
Qed.

End SplitCP.

Definition simple_check_point_wf (f g : graph2 -> term sym) (G : graph2) :
  CK4F G ->
  input != output :> G ->
  ~~ lens G ->
  (forall H : graph2, CK4F H -> measure H < measure G -> f H = g H) ->
  simple_check_point_term f G = simple_check_point_term g G.
Proof.
  move => CK4F_G Eio nlens_G Efg.
  rewrite /simple_check_point_term.
  case: ifP => [A|A].
  - (* output not in left bag, e notin interval, input not in right bag *)
    rewrite ![f (bgraph _ _)]Efg;
      try (apply rec_bag => //; apply: CP_extensive; by rewrite !inE eqxx).
    do 2 f_equal. rewrite Efg //.
    * apply: CK4F_igraph => //=; last rewrite cp_sym; exact: (@mem_cpl G).
    * apply: measure_igraph => //; by case: CK4F_G.
  - case: pickP => [z Hz|//]; repeat congr tm_dot.
    + rewrite Efg //. exact: CK4F_split_cpL. exact: measure_split_cpL.
    + have {Hz} Hz : z \in @CP G IO by move: Hz; rewrite inE CP_set2 => /andP[_ ->].
      by rewrite Efg //; apply rec_bag => //.
    + rewrite Efg //. exact: CK4F_split_cpR. exact: measure_split_cpR.
Qed.

Lemma CK4F_remove_edges (G : graph2) (E : {set edge G}) :
  CK4F G -> input != output :> G -> lens G ->
  components (@sinterval G input output) != set0 \/ edge_set IO :\: E != set0 ->
  E \subset edge_set IO ->
  CK4F (point (remove_edges E) input output).
Proof.
  move => CK4F_G Hio lens_G Ps E_sub_IO.
  split; last by case: CK4F_G => _; apply: iso_K4_free; exact: sskeleton_remove_io.
  case: CK4F_G => G_conn _. apply: remove_edges_connected G_conn.
  suff io_conn : connect (@sk_rel _ _ (remove_edges E)) input output.
  { move=> e /(subsetP E_sub_IO). rewrite !inE. case/andP=> /orP[]/eqP-> /orP[]/eqP-> //.
    rewrite connect_symI //. exact: sk_rel_sym. }
  move: Ps. set sI := sinterval _ _. case.
  - case/set0Pn=> /= C C_comp.
    case/and3P: (partition_components sI) => /eqP compU compI comp0.
    have C_sub : C \subset sI by rewrite -compU; exact: bigcup_sup.
    case: (@sinterval_components G C _ _ C_comp) => -[u u_C iu][v v_C ov].
    have [uNio vNio] : u \notin IO /\ v \notin IO.
    { have [u_sI v_sI] := (subsetP C_sub u u_C, subsetP C_sub v v_C).
      rewrite !in_set2. split; [move: u_sI | move: v_sI];
      apply: contraTN => /orP[]/eqP->; by rewrite (@sinterval_bounds G). }
    have /connect1 iu_conn := remove_edges_cross (E_sub_IO) iu uNio.
    apply: connect_trans iu_conn _.
    have := remove_edges_cross (E_sub_IO) ov vNio. rewrite sk_rel_sym.
    move/connect1. apply: connect_trans.
    apply: remove_edges_restrict (E_sub_IO) _.
    have := @connected_in_components G sI C C_comp u v u_C v_C.
    apply: connect_mono. apply: restrict_mono => z /= Hz.
    have {Hz} Hz : z \in sI by rewrite -compU; apply/bigcupP; exists C.
    rewrite !inE negb_or. apply/andP.
    by split; apply: contraTneq Hz => ->; rewrite /sI (@sinterval_bounds G).
  - case/set0Pn => e /setDP [E1 E2]. apply: connect1.
    rewrite /sk_rel/= Hio /=. rewrite lens_io_set // in E1. case/setUP : E1 => E1.
    + apply: adjacentI. instantiate (1 := Sub e E2). by rewrite !inE /= in E1 *.
    + rewrite adjacent_sym. apply: adjacentI. instantiate (1 := Sub e E2). by rewrite !inE /= in E1 *.
Qed.

Lemma measure_remove_edges (G : graph2) (E : {set edge G}) (i o : G) :
  E != set0 -> measure (point (remove_edges E) i o) < measure G.
Proof.
  case/set0Pn => e inIO. apply: measure_card => /=. rewrite card_sig.
  apply: (card_ltnT (x := e)). by rewrite /= negbK.
Qed.

Lemma CK4F_remove_loops (G : graph2) (E : {set edge G}) :
  CK4F G -> input == output :> G -> E \subset edge_set IO ->
  CK4F (point (remove_edges E) input output).
Proof.
  move=> [G_conn G_CK4F] /eqP Eio E_sub_IO. rewrite -Eio.
  have loopP : {in E, forall e, source e = target e}.
  { move => e /(subsetP E_sub_IO). rewrite !inE.
    case/andP. by do 2 case/orP=> [/eqP->|/eqP->]. }
 split.
  - apply: iso_connected G_conn. symmetry. exact: remove_loops.
  - apply: iso_K4_free G_CK4F. apply: diso_comp (iso_pointxx _) _.
    case: G {G_conn E_sub_IO} E Eio loopP => G i o E /= <- loopP. symmetry.
    apply: diso_comp (iso_pointxx _) _. exact: remove_loops.
Qed.

Lemma CK4F_lens_rest (G : graph2) C :
  CK4F G -> lens G -> edge_set G IO == set0 ->
  C \in @components G (@sinterval G input output) -> CK4F (induced2 (~: C)).
Proof.
  set sI := sinterval _ _. case/and3P: (partition_components sI).
  set P := components _.
  move=> /eqP compU /trivIsetP compI comp0 G_CK4F G_lens Eio0 C_comp.
  apply: CK4F_induced2 (G_CK4F). have [G_conn _] := G_CK4F.
  have : C \subset cover P := bigcup_sup _ C_comp.
  rewrite compU /sI lens_sinterval // subsetC subUset !sub1set => /andP[Gi Go].
  apply: connected_center (Gi) => x Hx.
  have [D [D_comp DNC x_ioD]] :
    exists D, [/\ D \in P, D != C & x \in input |: (output |: D)].
  { case: (lens_components G_CK4F G_lens Eio0 C_comp) => D D_comp DNC.
    case: (altP (x =P input))  => [->|Di]; last case: (altP (x =P output)) => [->|Do].
    - exists D; split => //. exact: setU11.
    - exists D; split => //. exact: (setU1r _ (setU11 _ _)).
    - have x_cover : x \in cover P
        by rewrite compU /sI lens_sinterval // !inE negb_or Di Do.
      exists (pblock P x). split; first exact: pblock_mem.
      + rewrite inE in Hx. apply: contraNneq Hx => <-. by rewrite mem_pblock.
      + by rewrite !in_setU mem_pblock x_cover. }
  have : connect (restrict (input |: (output |: D)) (@sedge G)) input x.
  { apply: connected_component_set => //. exact: setU11. }
  apply connect_mono. apply: restrict_mono => z /=. rewrite !in_setU1.
  case/or3P=> [/eqP->//|/eqP->//|Hz].
  by rewrite inE (disjointFr (compI D C D_comp C_comp DNC) Hz).
Qed.

Lemma measure_lens_rest (G : graph2) C :
  CK4F G -> lens G -> C \in @components G (@sinterval G input output) ->
  measure (induced2 (~: C)) < measure G.
Proof.
  move=> G_CK4F G_lens. rewrite lens_sinterval //; last by case: G_CK4F.
  exact: measure_remove_component.
Qed.

Lemma term_of_rec_eq (f g : graph2 -> term sym) (G : graph2) :
  CK4F G -> (forall H : graph2, CK4F H -> measure H < measure G -> f H = g H) ->
  term_of_rec f G = term_of_rec g G.
Proof.
  move=> CK4F_G Efg. rewrite /term_of_rec.
  case: (boolP (@input _ _ G == output)) => Hio.
  - case: pickP => [e Eio|Es]; last first.
    + case: pickP => //= C HC. rewrite !Efg //.
      * exact: CK4F_remove_component.
      * move: HC. rewrite -[set1 input]setUid {2}(eqP Hio).
        exact: measure_remove_component.
      * exact: CK4F_redirect.
      * exact: measure_redirect.
    + congr tm_par. rewrite Efg //.
      * apply CK4F_remove_loops => //. by rewrite sub1set.
      * apply: measure_remove_edges. exact: set10.
  - case: (boolP (lens G)) => [deg_G|ndeg_G].
    + case: picksP => [e Eio|/eqP Es]; last first.
      * case: pickP => [C HC|//]. congr tm_par.
        -- apply: Efg. exact: CK4F_lens. exact: measure_lens.
        -- apply: Efg. exact: CK4F_lens_rest. exact: measure_lens_rest.
      * case: (boolP (_ && _)) => Ps //. rewrite Efg //.
        -- apply: CK4F_remove_edges => //.
           ++ rewrite negb_and in Ps. exact/orP.
           ++ by rewrite sub1set.
        -- apply: measure_remove_edges. exact: set10.
    + exact: simple_check_point_wf.
Qed.

Lemma term_of_eq : forall (G : graph2), CK4F G -> term_of G = term_of_rec term_of G.
Proof. apply: Fix_eq term_of_rec_eq. Qed.

End ExtractionDef.


Require Export D.

(** **** Problem #22 : 1 star (override_shadow)  *)
Theorem override_shadow : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros. unfold override.
  destruct beq_nat. reflexivity. reflexivity.
Qed.


(** **** Consistency *)

Require Export ND.

Section Consistency.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Definition consistent (T : theory) := ~ T ⊩CE ⊥.
  Definition consistent_max T := consistent T /\ forall f, consistent (T ⋄ f) -> f ∈ T.

  Lemma consistent_prv T phi :
    consistent T -> T ⊩CE phi -> consistent (T ⋄ phi).
  Proof.
    intros HT Hphi. intros Hpsi2. now apply HT, (prv_T_remove Hphi).
  Qed.

  Lemma consistency_inheritance T1 T2 :
    consistent T2 -> T1 ⊑ T2 -> consistent T1.
  Proof.
    intros H H2 H3. now eapply H, Weak_T, H2.
  Qed.

  Fact consistent_neg T phi :
    consistent T -> (¬ phi) ∈ T -> ~ phi ∈ T.
  Proof.
    intros HT H H2. apply HT.
    use_theory [phi; ¬ phi]. oapply 1. ctx.
  Qed.

  Fact consistent_neg2 T phi :
    consistent T -> (T ⋄ phi) ⊩CE ⊥ -> consistent (T ⋄ (¬ phi)).
  Proof.
    intros HT H. now apply consistent_prv, prv_T_impl.
  Qed.

  Fact consistent_max_out T phi :
    consistent_max T -> ~ phi ∈ T -> ~ consistent (T ⋄ phi).
  Proof.
    intros []; intuition.
  Qed.

  Lemma consistent_max_impl T phi psi :
    consistent_max T -> (phi --> psi ∈ T <-> (phi ∈ T -> psi ∈ T)).
  Proof.
    intros; split; destruct H as [H1 H2].
    - intros H H'. apply H2. apply consistent_prv; try assumption.
      use_theory [phi; phi --> psi]. oapply 1. ctx.

    - intros H. apply H2. intros (A & HA1 & HA2) % prv_T_impl.
      apply H1. apply (prv_T_remove (phi := psi)).
      + apply elem_prv, H, H2, consistent_prv. assumption. use_theory A.
        oindirect. oimport HA2. oapply 0. ointros. oexfalso. oapply 2. ctx.
      + use_theory (psi :: A). oimport HA2. oapply 0. ointros. ctx.
  Qed.

  Section Classical.
    Hypothesis XM : forall X, X \/ ~ X.
    Ltac indirect := match goal with
                      | [ |- ?H ] => destruct (XM H); [assumption | exfalso]
                    end.

    Lemma inconsistent T phi :
      ~ consistent (T ⋄ phi) -> T ⋄ phi ⊩CE ⊥.
    Proof.
      destruct (XM (T ⋄ phi ⊩CE ⊥)); tauto.
    Qed.

    Lemma consistent_max_out2 T phi :
      consistent_max T -> ~ phi ∈ T -> (¬ phi) ∈ T.
    Proof.
      intros [HT1 HT2] H2. now apply consistent_max_out, inconsistent, consistent_neg2, HT2 in H2.
    Qed.
  End Classical.
End Consistency.