Require Export Base.

Module SProdCategory.

Structure mixin_of (C: Category) := Mixin {
  sprod {I}: (I -> C) -> C;
  sfork {I} {X: C} {F: I -> C}: (forall i, X ~> F i) -> X ~> sprod F;
  pi {I} {F: I -> C} (i: I): sprod F ~> F i;
  sfork_ump {I} {X: C} {F: I -> C} (f: forall i, X ~> F i) (g: X ~> sprod F): sfork f = g <-> forall i, pi i ∘ g = f i;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation SProdCategory := type.

End Exports.
End SProdCategory.

Export SProdCategory.Exports.

Section SProdCategory_theory.
Context {C: SProdCategory}.

Definition sprod: forall {I}, (I -> C) -> C := @SProdCategory.sprod C (SProdCategory.class C).
Definition sfork: forall {I} {X: C} {F: I -> C}, (forall i, X ~> F i) -> X ~> sprod F := @SProdCategory.sfork C (SProdCategory.class C).
Definition pi: forall {I} {F: I -> C} (i: I), sprod F ~> F i := @SProdCategory.pi C (SProdCategory.class C).
Definition sfork_ump: forall {I} {X: C} {F: I -> C} (f: forall i, X ~> F i) (g: X ~> sprod F), sfork f = g <-> forall i, pi i ∘ g = f i := @SProdCategory.sfork_ump C (SProdCategory.class C).

Notation "∏ i .. j , x" := (sprod (fun i => .. (sprod (fun j => x)) ..)) (at level 40, i binder).
Notation "∏' i .. j , f" := (sfork (fun i => .. (sfork (fun j => f)) ..)) (at level 40, i binder).
Notation π := pi.

Lemma to_sprod_eq {I} {F: I -> C} {X: C} (f g: X ~> sprod F): f = g <-> forall i, π i ∘ f = π i ∘ g.
Proof.
  split.
  now intros [].
  intros H.
  transitivity (∏' i, (π i ∘ g)).
  symmetry.
  all: now apply sfork_ump.
Qed.

Definition spmap {I} {F G: I -> C} (η: forall i, F i ~> G i): sprod F ~> sprod G :=
  ∏' i, (η i ∘ π i).

Notation "(∏) i .. j , f" := (spmap (fun i => .. (spmap (fun j => f)) ..)) (at level 40, i binder).

Lemma pi_sfork {I} {F: I -> C} {X: C} (η: forall i, X ~> F i) (i: I): π i ∘ sfork η = η i.
Proof. now apply sfork_ump. Qed.

Lemma pi_spmap {I} {F G: I -> C} (η: forall i, F i ~> G i) (i: I): π i ∘ spmap η = η i ∘ π i.
Proof. exact (pi_sfork (fun i => η i ∘ π i) i). Qed.

Lemma sfork_comp {I} {X Y: C} {F: I -> C} (f: forall i, Y ~> F i) (g: X ~> Y): ∏' i, (f i ∘ g) = sfork f ∘ g.
Proof.
  apply to_sprod_eq.
  intros i.
  rewrite comp_assoc.
  now rewrite !pi_sfork.
Qed.

Lemma spmap_sfork {I} {F G: I -> C} {X: C} (f: forall i, F i ~> G i) (g: forall i, X ~> F i): spmap f ∘ sfork g = ∏' i, (f i ∘ g i).
Proof.
  apply to_sprod_eq.
  intros i.
  rewrite comp_assoc.
  rewrite pi_spmap.
  rewrite <- comp_assoc.
  now rewrite !pi_sfork.
Qed.

Lemma spmap_id {I} (F: I -> C): (∏) i, id (F i) = id (sprod F).
Proof.
  apply to_sprod_eq.
  intros i.
  rewrite pi_spmap.
  rewrite comp_id_r.
  apply comp_id_l.
Qed.

Lemma spmap_comp {I} {F G H: I -> C} (η: forall i, G i ~> H i) (ϵ: forall i, F i ~> G i): (∏) i, (η i ∘ ϵ i) = spmap η ∘ spmap ϵ.
Proof.
  apply to_sprod_eq.
  intros i.
  rewrite comp_assoc.
  rewrite !pi_spmap.
  rewrite <- !comp_assoc.
  f_equal.
  symmetry.
  apply pi_spmap.
Qed.

End SProdCategory_theory.

Notation "∏ i .. j , x" := (sprod (fun i => .. (sprod (fun j => x)) ..)) (at level 40, i binder).
Notation "∏' i .. j , f" := (sfork (fun i => .. (sfork (fun j => f)) ..)) (at level 40, i binder).
Notation π := pi.
Notation "(∏) i .. j , f" := (spmap (fun i => .. (spmap (fun j => f)) ..)) (at level 40, i binder).

Instance sfork_pw C I X F: Proper (forall_relation (fun _ => eq) ==> eq) (@sfork C I X F).
Proof.
  intros f g H.
  f_equal.
  now extensionality i.
Qed.

Instance spmap_pw C I F G: Proper (forall_relation (fun _ => eq) ==> eq) (@spmap C I F G).
Proof.
  intros f g H.
  f_equal.
  now extensionality i.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

Axiom i : Type.
Parameter i_WhyType : WhyType i.
Existing Instance i_WhyType.

Axiom b : Type.
Parameter b_WhyType : WhyType b.
Existing Instance b_WhyType.

Parameter top: b.

Parameter bot: b.

Parameter infix_slasbs: b -> b -> b.

Parameter infix_bsassl: b -> b -> b.

Parameter neg: b -> b.

(* Why3 assumption *)
Definition xor (x:b) (y:b) : b :=
  infix_slasbs (infix_bsassl x y) (neg (infix_slasbs x y)).

Axiom Assoc :
  forall (x:b) (y:b) (z:b), ((xor (xor x y) z) = (xor x (xor y z))).

Axiom Unit_def_l : forall (x:b), ((xor bot x) = x).

Axiom Unit_def_r : forall (x:b), ((xor x bot) = x).

Axiom Inv_def_l : forall (x:b), ((xor x x) = bot).

Axiom Inv_def_r : forall (x:b), ((xor x x) = bot).

Axiom Comm : forall (x:b) (y:b), ((xor x y) = (xor y x)).

Axiom Assoc1 :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs (infix_slasbs x y) z) = (infix_slasbs x (infix_slasbs y z))).

Axiom Mul_distr_l :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (xor y z)) = (xor (infix_slasbs x y) (infix_slasbs x z))).

Axiom Mul_distr_r :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs (xor y z) x) = (xor (infix_slasbs y x) (infix_slasbs z x))).

Axiom Comm1 : forall (x:b) (y:b), ((infix_slasbs x y) = (infix_slasbs y x)).

Axiom Unit_def_l1 : forall (x:b), ((infix_slasbs top x) = x).

Axiom Unit_def_r1 : forall (x:b), ((infix_slasbs x top) = x).

Axiom NonTrivialRing : ~ (bot = top).

Axiom Idempotence : forall (x:b), ((infix_slasbs x x) = x).

Axiom br_equivalent_law_1 : forall (a:b), ((xor a a) = bot).

(* Why3 assumption *)
Definition infix_lseq (x:b) (y:b) : Prop := ((infix_bsassl x y) = y).

Axiom Refl : forall (x:b), infix_lseq x x.

Axiom Trans :
  forall (x:b) (y:b) (z:b), infix_lseq x y -> infix_lseq y z ->
  infix_lseq x z.

Axiom Antisymm :
  forall (x:b) (y:b), infix_lseq x y -> infix_lseq y x -> (x = y).

Axiom glb_infimum :
  forall (x:b) (y:b),
  infix_lseq (infix_slasbs x y) x /\
  infix_lseq (infix_slasbs x y) y /\
  (forall (w:b), infix_lseq w x /\ infix_lseq w y ->
   infix_lseq w (infix_slasbs x y)).

Axiom lub_supremum :
  forall (x:b) (y:b),
  infix_lseq x (infix_bsassl x y) /\
  infix_lseq y (infix_bsassl x y) /\
  (forall (w:b), infix_lseq x w /\ infix_lseq y w ->
   infix_lseq (infix_bsassl x y) w).

Axiom comm_meet :
  forall (x:b) (y:b), ((infix_bsassl x y) = (infix_bsassl y x)).

Axiom comm_join :
  forall (x:b) (y:b), ((infix_slasbs x y) = (infix_slasbs y x)).

Axiom assoc_meet :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (infix_slasbs y z)) = (infix_slasbs (infix_slasbs x y) z)).

Axiom assoc_join :
  forall (x:b) (y:b) (z:b),
  ((infix_bsassl x (infix_bsassl y z)) = (infix_bsassl (infix_bsassl x y) z)).

Axiom absorp_meet :
  forall (x:b) (y:b), ((infix_slasbs x (infix_bsassl x y)) = x).

Axiom absorp_join :
  forall (x:b) (y:b), ((infix_bsassl x (infix_slasbs x y)) = x).

Axiom idem_meet : forall (x:b), ((infix_slasbs x x) = x).

Axiom idem_join : forall (x:b), ((infix_bsassl x x) = x).

Axiom order :
  forall (x:b) (y:b), ((infix_bsassl x y) = x) -> ((infix_slasbs x y) = y).

Axiom dl_dist_one :
  forall (a:b) (b1:b) (c:b),
  ((infix_bsassl a (infix_slasbs b1 c)) =
   (infix_slasbs (infix_bsassl a b1) (infix_bsassl a c))).

Axiom dl_dist_two :
  forall (a:b) (b1:b) (c:b),
  ((infix_slasbs a (infix_bsassl b1 c)) =
   (infix_bsassl (infix_slasbs a b1) (infix_slasbs a c))).

Axiom dist_meet :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (infix_bsassl y z)) =
   (infix_bsassl (infix_slasbs x y) (infix_slasbs x z))).

Axiom dist_join :
  forall (x:b) (y:b) (z:b),
  ((infix_bsassl x (infix_slasbs y z)) =
   (infix_slasbs (infix_bsassl x y) (infix_bsassl x z))).

Axiom Refl1 : forall (x:b), infix_lseq x x.

Axiom Trans1 :
  forall (x:b) (y:b) (z:b), infix_lseq x y -> infix_lseq y z ->
  infix_lseq x z.

Axiom Antisymm1 :
  forall (x:b) (y:b), infix_lseq x y -> infix_lseq y x -> (x = y).

Axiom glb_infimum1 :
  forall (x:b) (y:b),
  infix_lseq (infix_slasbs x y) x /\
  infix_lseq (infix_slasbs x y) y /\
  (forall (w:b), infix_lseq w x /\ infix_lseq w y ->
   infix_lseq w (infix_slasbs x y)).

Axiom lub_supremum1 :
  forall (x:b) (y:b),
  infix_lseq x (infix_bsassl x y) /\
  infix_lseq y (infix_bsassl x y) /\
  (forall (w:b), infix_lseq x w /\ infix_lseq y w ->
   infix_lseq (infix_bsassl x y) w).

Axiom comm_meet1 :
  forall (x:b) (y:b), ((infix_bsassl x y) = (infix_bsassl y x)).

Axiom comm_join1 :
  forall (x:b) (y:b), ((infix_slasbs x y) = (infix_slasbs y x)).

Axiom assoc_meet1 :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (infix_slasbs y z)) = (infix_slasbs (infix_slasbs x y) z)).

Axiom assoc_join1 :
  forall (x:b) (y:b) (z:b),
  ((infix_bsassl x (infix_bsassl y z)) = (infix_bsassl (infix_bsassl x y) z)).

Axiom absorp_meet1 :
  forall (x:b) (y:b), ((infix_slasbs x (infix_bsassl x y)) = x).

Axiom absorp_join1 :
  forall (x:b) (y:b), ((infix_bsassl x (infix_slasbs x y)) = x).

Axiom idem_meet1 : forall (x:b), ((infix_slasbs x x) = x).

Axiom idem_join1 : forall (x:b), ((infix_bsassl x x) = x).

Axiom order1 :
  forall (x:b) (y:b), ((infix_bsassl x y) = x) -> ((infix_slasbs x y) = y).

Axiom lowerBoundZero : forall (x:b), infix_lseq bot x.

Axiom upperBoundOne : forall (x:b), infix_lseq x top.

Axiom ident_meet : forall (x:b), ((infix_slasbs x top) = x).

Axiom ident_join : forall (x:b), ((infix_bsassl x bot) = x).

Axiom bound_glb : forall (x:b), ((infix_slasbs x bot) = bot).

Axiom bound_lub : forall (x:b), ((infix_bsassl x top) = top).

Axiom cl_compl_top : forall (a:b), exists x:b, ((infix_bsassl a x) = top).

Axiom cl_compl_bot : forall (a:b), exists x:b, ((infix_slasbs a x) = bot).

Axiom lattice_ring :
  forall (x:b) (y:b),
  (infix_lseq x y <-> ((infix_slasbs x y) = x)) /\
  (((infix_slasbs x y) = x) <-> ((infix_bsassl x y) = y)).

Axiom comm_and :
  forall (x:b) (y:b), ((infix_slasbs x y) = (infix_slasbs y x)).

Axiom comm_or :
  forall (x:b) (y:b), ((infix_bsassl x y) = (infix_bsassl y x)).

Axiom dist_and :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (infix_bsassl y z)) =
   (infix_bsassl (infix_slasbs x y) (infix_slasbs x z))).

Axiom dist_or :
  forall (x:b) (y:b) (z:b),
  ((infix_bsassl x (infix_slasbs y z)) =
   (infix_slasbs (infix_bsassl x y) (infix_bsassl x z))).

Axiom ident_and : forall (x:b), ((infix_slasbs x top) = x).

Axiom ident_or : forall (x:b), ((infix_bsassl x bot) = x).

Axiom uniq_compl :
  forall (x:b) (y:b) (z:b), ((neg x) = y) /\ ((neg x) = z) -> (y = z).

Axiom compl_and : forall (x:b), ((infix_slasbs x (neg x)) = bot).

Axiom compl_or : forall (x:b), ((infix_bsassl x (neg x)) = top).

Axiom idem_and : forall (x:b), ((infix_slasbs x x) = x).

Axiom idem_or : forall (x:b), ((infix_bsassl x x) = x).

Axiom boundbot : forall (x:b), infix_lseq bot x.

Axiom boundtop : forall (x:b), infix_lseq x top.

Axiom bound_and : forall (x:b), ((infix_slasbs x bot) = bot).

Axiom bound_or : forall (x:b), ((infix_bsassl x top) = top).

Axiom absorp_and :
  forall (x:b) (y:b), ((infix_slasbs x (infix_bsassl x y)) = x).

Axiom absorp_or :
  forall (x:b) (y:b), ((infix_bsassl x (infix_slasbs x y)) = x).

Axiom assoc_and :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs x (infix_slasbs y z)) = (infix_slasbs (infix_slasbs x y) z)).

Axiom assoc_or :
  forall (x:b) (y:b) (z:b),
  ((infix_bsassl x (infix_bsassl y z)) = (infix_bsassl (infix_bsassl x y) z)).

Axiom demorgan_and :
  forall (x:b) (y:b),
  ((neg (infix_slasbs x y)) = (infix_bsassl (neg x) (neg y))).

Axiom demorgan_or :
  forall (x:b) (y:b),
  ((neg (infix_bsassl x y)) = (infix_slasbs (neg x) (neg y))).

Axiom negtop : ((neg top) = bot).

Axiom negbot : ((neg bot) = top).

Axiom double_neg : forall (x:b), ((neg (neg x)) = x).

Axiom dist_ord :
  forall (x:b) (y:b) (z:b), infix_lseq x z ->
  ((infix_bsassl x (infix_slasbs y z)) = (infix_slasbs (infix_bsassl x y) z)).

(* Why3 assumption *)
Definition infix_mngtas (x:b) (y:b) : b := infix_bsassl (neg x) y.

(* Why3 assumption *)
Definition usequiv (x:b) (y:b) : b :=
  infix_slasbs (infix_mngtas x y) (infix_mngtas y x).

Axiom disj_and :
  forall (x:b) (y:b),
  (x = (infix_slasbs x y)) /\ ((infix_slasbs x y) = top) -> (x = top).

Axiom disj_or : forall (x:b) (y:b), (x = top) -> ((infix_bsassl x y) = top).

Axiom modus_ponens :
  forall (x:b) (y:b), ((infix_slasbs x (infix_mngtas x y)) = top) ->
  (y = top).

Axiom modus_tollens :
  forall (x:b) (y:b), ((infix_slasbs (infix_mngtas x y) (neg y)) = top) ->
  ((neg x) = top).

Axiom implic :
  forall (x:b) (y:b), ((infix_mngtas x y) = (infix_bsassl (neg x) y)).

Axiom absur :
  forall (x:b) (y:b),
  ((infix_slasbs (infix_mngtas x y) (infix_mngtas x (neg y))) = (neg x)).

Axiom disj_syl :
  forall (x:b) (y:b), ((infix_slasbs (infix_bsassl x y) (neg x)) = top) ->
  (y = top).

Axiom impl_chain :
  forall (x:b) (y:b) (z:b),
  ((infix_slasbs (infix_mngtas x y) (infix_mngtas y z)) = top) ->
  ((infix_mngtas x z) = top).

Axiom impl_comb :
  forall (x:b) (y:b) (z:b) (w:b),
  ((infix_slasbs (infix_mngtas x y) (infix_mngtas z w)) = top) ->
  ((infix_mngtas (infix_slasbs x z) (infix_slasbs y w)) = top).

Axiom currying :
  forall (x:b) (y:b) (z:b),
  ((infix_mngtas (infix_slasbs x y) z) = (infix_mngtas x (infix_mngtas y z))).

Axiom contrapos :
  forall (x:b) (y:b), ((infix_mngtas x y) = (infix_mngtas (neg y) (neg x))).

Axiom binary : forall (x:b), (x = top) \/ (x = bot).

Axiom ifnottop_thenbot : forall (t:b), ~ (t = top) -> (t = bot).

Axiom ifnotbot_thentop : forall (t:b), ~ (t = bot) -> (t = top).

(* Why3 assumption *)
Inductive formula :=
  | Prop1 : b -> formula
  | Var : i -> formula
  | Neg : formula -> formula
  | And : formula -> formula -> formula
  | Or : formula -> formula -> formula
  | Impl : formula -> formula -> formula.
Axiom formula_WhyType : WhyType formula.
Existing Instance formula_WhyType.

(* Why3 assumption *)
Fixpoint eval (e:formula) (v:i -> b) {struct e}: b :=
  match e with
  | Prop1 b1 => b1
  | Var i1 => v i1
  | Neg e1 => neg (eval e1 v)
  | And e1 e2 => infix_slasbs (eval e1 v) (eval e2 v)
  | Or e1 e2 => infix_bsassl (eval e1 v) (eval e2 v)
  | Impl e1 e2 => infix_mngtas (eval e1 v) (eval e2 v)
  end.

(* Why3 assumption *)
Definition infix_eqeq (f1:formula) (f2:formula) : Prop :=
  forall (v:i -> b), ((eval f1 v) = (eval f2 v)).

(* Why3 assumption *)
Inductive atom :=
  | B : b -> atom
  | I : i -> atom
  | Nb : b -> atom
  | Ni : i -> atom.
Axiom atom_WhyType : WhyType atom.
Existing Instance atom_WhyType.

(* Why3 assumption *)
Definition cnf_clause := Init.Datatypes.list atom.

(* Why3 assumption *)
Definition cnf := Init.Datatypes.list (Init.Datatypes.list atom).

(* Why3 assumption *)
Fixpoint eval_cnf_clause (e:Init.Datatypes.list atom)
  (v:i -> b) {struct e}: b :=
  match e with
  | Init.Datatypes.nil => bot
  | Init.Datatypes.cons (B b1) Init.Datatypes.nil => b1
  | Init.Datatypes.cons (I i1) Init.Datatypes.nil => v i1
  | Init.Datatypes.cons (Nb b1) Init.Datatypes.nil => neg b1
  | Init.Datatypes.cons (Ni i1) Init.Datatypes.nil => neg (v i1)
  | Init.Datatypes.cons (B b1) tl => infix_bsassl b1 (eval_cnf_clause tl v)
  | Init.Datatypes.cons (I i1) tl =>
      infix_bsassl (v i1) (eval_cnf_clause tl v)
  | Init.Datatypes.cons (Nb b1) tl =>
      infix_bsassl (neg b1) (eval_cnf_clause tl v)
  | Init.Datatypes.cons (Ni i1) tl =>
      infix_bsassl (neg (v i1)) (eval_cnf_clause tl v)
  end.

(* Why3 assumption *)
Fixpoint eval_cnf (e:Init.Datatypes.list (Init.Datatypes.list atom))
  (v:i -> b) {struct e}: b :=
  match e with
  | Init.Datatypes.nil => top
  | Init.Datatypes.cons hd tl =>
      infix_slasbs (eval_cnf_clause hd v) (eval_cnf tl v)
  end.

(* Why3 assumption *)
Definition equiv_cnf (f1:Init.Datatypes.list (Init.Datatypes.list atom))
    (f2:Init.Datatypes.list (Init.Datatypes.list atom)) : Prop :=
  forall (v:i -> b), ((eval_cnf f1 v) = (eval_cnf f2 v)).

Axiom comm_and1 :
  forall (x:formula) (y:formula), infix_eqeq (And x y) (And y x).

Axiom comm_or1 :
  forall (x:formula) (y:formula), infix_eqeq (Or x y) (Or y x).

Axiom dist_and1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (And x (Or y z)) (Or (And x y) (And x z)).

Axiom dist_or1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (Or x (And y z)) (And (Or x y) (Or x z)).

Axiom ident_and1 : forall (x:formula), infix_eqeq (And x (Prop1 top)) x.

Axiom ident_or1 : forall (x:formula), infix_eqeq (Or x (Prop1 bot)) x.

Axiom uniq_compl1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (Neg x) y /\ infix_eqeq (Neg x) z -> infix_eqeq y z.

Axiom compl_and1 :
  forall (x:formula), infix_eqeq (And x (Neg x)) (Prop1 bot).

Axiom compl_or1 : forall (x:formula), infix_eqeq (Or x (Neg x)) (Prop1 top).

Axiom idem_and1 : forall (x:formula), infix_eqeq (And x x) x.

Axiom idem_or1 : forall (x:formula), infix_eqeq (Or x x) x.

Axiom bound_and1 :
  forall (x:formula), infix_eqeq (And x (Prop1 bot)) (Prop1 bot).

Axiom bound_or1 :
  forall (x:formula), infix_eqeq (Or x (Prop1 top)) (Prop1 top).

Axiom absorp_and1 :
  forall (x:formula) (y:formula), infix_eqeq (And x (Or x y)) x.

Axiom absorp_or1 :
  forall (x:formula) (y:formula), infix_eqeq (Or x (And x y)) x.

Axiom assoc_and1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (And x (And y z)) (And (And x y) z).

Axiom assoc_or1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (Or x (Or y z)) (Or (Or x y) z).

Axiom demorgan_and1 :
  forall (phi1:formula) (phi2:formula),
  infix_eqeq (Neg (And phi1 phi2)) (Or (Neg phi1) (Neg phi2)).

Axiom demorgan_or1 :
  forall (phi1:formula) (phi2:formula),
  infix_eqeq (Neg (Or phi1 phi2)) (And (Neg phi1) (Neg phi2)).

Axiom negtop1 : infix_eqeq (Neg (Prop1 top)) (Prop1 bot).

Axiom negbot1 : infix_eqeq (Neg (Prop1 bot)) (Prop1 top).

Axiom double_neg1 : forall (x:formula), infix_eqeq (Neg (Neg x)) x.

Axiom dist_ord1 :
  forall (x:b) (y:b) (z:b), infix_lseq x z ->
  ((infix_bsassl x (infix_slasbs y z)) = (infix_slasbs (infix_bsassl x y) z)).

Axiom disj_and1 :
  forall (x:formula) (y:formula), infix_eqeq (And x y) (Prop1 top) ->
  infix_eqeq x (Prop1 top).

Axiom disj_or1 :
  forall (x:formula) (y:formula), infix_eqeq x (Prop1 top) ->
  infix_eqeq (Or x y) (Prop1 top).

Axiom modus_ponens1 :
  forall (x:formula) (y:formula),
  infix_eqeq (And x (Impl x y)) (Prop1 top) -> infix_eqeq y (Prop1 top).

Axiom modus_tollens1 :
  forall (x:formula) (y:formula),
  infix_eqeq (And (Impl x y) (Neg y)) (Prop1 top) ->
  infix_eqeq (Neg x) (Prop1 top).

Axiom implic1 :
  forall (x:formula) (y:formula), infix_eqeq (Impl x y) (Or (Neg x) y).

Axiom absur1 :
  forall (x:formula) (y:formula),
  infix_eqeq (And (Impl x y) (Impl x (Neg y))) (Neg x).

Axiom disj_syl1 :
  forall (x:formula) (y:formula),
  infix_eqeq (And (Or x y) (Neg x)) (Prop1 top) -> infix_eqeq y (Prop1 top).

Axiom impl_chain1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (And (Impl x y) (Impl y z)) (Prop1 top) ->
  infix_eqeq (Impl x z) (Prop1 top).

Axiom impl_comb1 :
  forall (x:formula) (y:formula) (z:formula) (w:formula),
  infix_eqeq (And (Impl x y) (Impl z w)) (Prop1 top) ->
  infix_eqeq (Impl (And x z) (And y w)) (Prop1 top).

Axiom currying1 :
  forall (x:formula) (y:formula) (z:formula),
  infix_eqeq (Impl (And x y) z) (Impl x (Impl y z)).

Axiom contrapos1 :
  forall (x:formula) (y:formula),
  infix_eqeq (Impl x y) (Impl (Neg y) (Neg x)).

Axiom pierce :
  forall (x:formula) (y:formula),
  infix_eqeq (Impl (Impl (Impl x y) x) x) (Or x (Neg x)).

(* Why3 assumption *)
Fixpoint size (phi:formula) {struct phi}: Numbers.BinNums.Z :=
  match phi with
  | Neg phi1 => (1%Z + (size phi1))%Z
  | (And phi1 phi2)|((Or phi1 phi2)|(Impl phi1 phi2)) =>
      ((1%Z + (size phi1))%Z + (size phi2))%Z
  | _ => 1%Z
  end.

Axiom size'spec : forall (phi:formula), (0%Z <= (size phi))%Z.

(* Why3 assumption *)
Fixpoint size_cnf_clause
  (phi:Init.Datatypes.list atom) {struct phi}: Numbers.BinNums.Z :=
  match phi with
  | Init.Datatypes.nil => 0%Z
  | Init.Datatypes.cons _ tl => (1%Z + (size_cnf_clause tl))%Z
  end.

Axiom size_cnf_clause'spec :
  forall (phi:Init.Datatypes.list atom), (0%Z <= (size_cnf_clause phi))%Z.

(* Why3 assumption *)
Fixpoint size_cnf
  (phi:Init.Datatypes.list (Init.Datatypes.list atom)) {struct phi}: Numbers.BinNums.Z :=
  match phi with
  | Init.Datatypes.nil => 0%Z
  | Init.Datatypes.cons hd tl => (1%Z + (size_cnf tl))%Z
  end.

Axiom size_cnf'spec :
  forall (phi:Init.Datatypes.list (Init.Datatypes.list atom)),
  (0%Z <= (size_cnf phi))%Z.

(* Why3 assumption *)
Fixpoint is_impl_free (phi:formula) {struct phi}: Prop :=
  match phi with
  | Prop1 _ => True
  | Var _ => True
  | Neg phi1 => is_impl_free phi1
  | (Or phi1 phi2)|(And phi1 phi2) => is_impl_free phi1 /\ is_impl_free phi2
  | Impl _ _ => False
  end.

(* Why3 assumption *)
Fixpoint is_nnfc (phi:formula) {struct phi}: Prop :=
  match phi with
  | Prop1 _ => True
  | Var _ => True
  | Neg (Prop1 _) => True
  | Neg (Var _) => True
  | Neg _ => False
  | (Or phi1 phi2)|(And phi1 phi2) => is_nnfc phi1 /\ is_nnfc phi2
  | Impl _ _ => False
  end.

Axiom nnfc_is_implfree :
  forall (phi:formula), is_nnfc phi -> is_impl_free phi.

(* Why3 assumption *)
Fixpoint is_cnf_clause (phi:formula) {struct phi}: Prop :=
  match phi with
  | Prop1 _ => True
  | Var _ => True
  | Neg (Prop1 _) => True
  | Neg (Var _) => True
  | Neg _ => False
  | Or phi1 phi2 => is_cnf_clause phi1 /\ is_cnf_clause phi2
  | And _ _ => False
  | Impl _ _ => False
  end.

Axiom cnf_clause_is_implfree :
  forall (phi:formula), is_cnf_clause phi -> is_impl_free phi.

Axiom cnf_clause_is_nnfc :
  forall (phi:formula), is_cnf_clause phi -> is_nnfc phi.

(* Why3 assumption *)
Fixpoint is_cnf (phi:formula) {struct phi}: Prop :=
  match phi with
  | Prop1 _ => True
  | Var _ => True
  | Neg (Prop1 _) => True
  | Neg (Var _) => True
  | Neg _ => False
  | Or phi1 phi2 => is_cnf_clause phi1 /\ is_cnf_clause phi2
  | And phi1 phi2 => is_cnf phi1 /\ is_cnf phi2
  | Impl _ _ => False
  end.

Axiom cnf_clause_is_cnf :
  forall (phi:formula), is_cnf_clause phi -> is_cnf phi.

Axiom cnf_is_implfree : forall (phi:formula), is_cnf phi -> is_impl_free phi.

Axiom cnf_is_nnfc : forall (phi:formula), is_cnf phi -> is_nnfc phi.

Axiom cnf_clause1 :
  forall (phi1:formula) (phi2:formula), is_cnf (Or phi1 phi2) ->
  is_cnf_clause phi1 /\ is_cnf_clause phi2.

(* Why3 assumption *)
Fixpoint impl_free (phi:formula) {struct phi}: formula :=
  match phi with
  | Prop1 t => Prop1 t
  | Var i1 => Var i1
  | Neg phi1 => Neg (impl_free phi1)
  | Or phi1 phi2 => Or (impl_free phi1) (impl_free phi2)
  | And phi1 phi2 => And (impl_free phi1) (impl_free phi2)
  | Impl phi1 phi2 => Or (Neg (impl_free phi1)) (impl_free phi2)
  end.

Axiom impl_free'spec :
  forall (phi:formula), forall (v:i -> b),
  ((eval phi v) = (eval (impl_free phi) v)) /\ is_impl_free (impl_free phi).

Parameter nnfc: formula -> formula.

Axiom nnfc'def :
  forall (phi:formula), is_impl_free phi ->
  match phi with
  | Neg (Neg phi1) => ((nnfc phi) = (nnfc phi1))
  | Neg (And phi1 phi2) =>
      ((nnfc phi) = (Or (nnfc (Neg phi1)) (nnfc (Neg phi2))))
  | Neg (Or phi1 phi2) =>
      ((nnfc phi) = (And (nnfc (Neg phi1)) (nnfc (Neg phi2))))
  | And phi1 phi2 => ((nnfc phi) = (And (nnfc phi1) (nnfc phi2)))
  | Or phi1 phi2 => ((nnfc phi) = (Or (nnfc phi1) (nnfc phi2)))
  | _ => ((nnfc phi) = phi)
  end.

Axiom nnfc'spec :
  forall (phi:formula), is_impl_free phi ->
  (forall (v:i -> b), ((eval phi v) = (eval (nnfc phi) v))) /\
  is_impl_free phi /\ is_nnfc (nnfc phi).

Parameter distr: formula -> formula -> formula.

Axiom distr'def :
  forall (phi1:formula) (phi2:formula),
  is_impl_free phi1 /\
  is_impl_free phi2 /\
  is_nnfc phi1 /\ is_nnfc phi2 /\ is_cnf phi1 /\ is_cnf phi2 ->
  match (phi1, phi2) with
  | (And phi11 phi12, phi21) =>
      ((distr phi1 phi2) = (And (distr phi11 phi21) (distr phi12 phi21)))
  | (phi11, And phi21 phi22) =>
      ((distr phi1 phi2) = (And (distr phi11 phi21) (distr phi11 phi22)))
  | (_, _) => ((distr phi1 phi2) = (Or phi1 phi2))
  end.

Axiom distr'spec :
  forall (phi1:formula) (phi2:formula),
  is_impl_free phi1 /\
  is_impl_free phi2 /\
  is_nnfc phi1 /\ is_nnfc phi2 /\ is_cnf phi1 /\ is_cnf phi2 ->
  (forall (v:i -> b),
   ((infix_bsassl (eval phi1 v) (eval phi2 v)) = (eval (distr phi1 phi2) v))) /\
  is_impl_free (distr phi1 phi2) /\
  is_nnfc (distr phi1 phi2) /\ is_cnf (distr phi1 phi2).

Parameter cnfc: formula -> formula.

Axiom cnfc'def :
  forall (phi:formula), is_impl_free phi /\ is_nnfc phi ->
  match phi with
  | Or phi1 phi2 => ((cnfc phi) = (distr (cnfc phi1) (cnfc phi2)))
  | And phi1 phi2 => ((cnfc phi) = (And (cnfc phi1) (cnfc phi2)))
  | _ => ((cnfc phi) = phi)
  end.

Axiom cnfc'spec :
  forall (phi:formula), is_impl_free phi /\ is_nnfc phi ->
  (forall (v:i -> b), ((eval phi v) = (eval (cnfc phi) v))) /\
  is_impl_free phi /\ is_nnfc (cnfc phi) /\ is_cnf (cnfc phi).

(* Why3 assumption *)
Definition t (phi:formula) : formula := cnfc (nnfc (impl_free phi)).

Axiom t'spec :
  forall (phi:formula), forall (v:i -> b),
  ((eval phi v) = (eval (t phi) v)) /\
  is_impl_free (t phi) /\ is_nnfc (t phi) /\ is_cnf (t phi).

Parameter to_cnf_aux: formula -> Init.Datatypes.list atom.

Axiom to_cnf_aux'spec :
  forall (phi:formula),
  is_impl_free phi /\ is_nnfc phi /\ is_cnf_clause phi -> forall (v:i -> b),
  ((eval phi v) = (eval_cnf_clause (to_cnf_aux phi) v)).

Parameter phi: formula.

Axiom H : is_impl_free phi.

Axiom H1 : is_nnfc phi.

Axiom H2 : is_cnf phi.

Parameter result: Init.Datatypes.list (Init.Datatypes.list atom).

Parameter result1: Init.Datatypes.list (Init.Datatypes.list atom).

Parameter result2: Init.Datatypes.list (Init.Datatypes.list atom).

Parameter x: formula.

Parameter x1: formula.

Axiom H3 : (phi = (And x x1)).

Axiom Ensures : forall (v:i -> b), ((eval x1 v) = (eval_cnf result1 v)).

Axiom Ensures1 : forall (v:i -> b), ((eval x v) = (eval_cnf result2 v)).

Axiom H4 : (result = (Init.Datatypes.app result2 result1)).

Parameter v: i -> b.

(* Why3 goal *)
Theorem to_cnf'vc : ((eval phi v) = (eval_cnf result v)).

auto.


From Equations Require Import Equations.
Require Import Equations.Prop.Subterm.

Require Import Psatz.

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.StrictPositivityLemma.
Require Export SystemFR.ReducibilitySubst.

Opaque makeFresh.
Opaque PeanoNat.Nat.eq_dec.
Opaque reducible_values.
Opaque strictly_positive.

Lemma strictly_positive_push_forall2:
  forall T ρ A B v X,
    ~(X ∈ pfv T type_var) ->
    non_empty ρ A ->
    twf A 0 ->
    twf B 0 ->
    twf T 1 ->
    wf A 0 ->
    wf B 1 ->
    wf T 0 ->
    is_erased_type A ->
    is_erased_type B ->
    is_erased_type T ->
    pfv A term_var = nil ->
    pfv B term_var = nil ->
    pfv T term_var = nil ->
    valid_interpretation ρ ->
    strictly_positive (topen 0 T (fvar X type_var)) (X :: nil) ->
    (forall a,
        [ ρ ⊨ a : A ]v ->
        [ ρ ⊨ v : topen 0 T (open 0 B a) ]v) ->
    [ ρ ⊨ v : topen 0 T (T_forall A B) ]v.
Proof.
  intros; instantiate_non_empty; repeat step.
  apply reducible_values_subst_head with
    (makeFresh (
       pfv T type_var ::
       pfv A type_var ::
       pfv B type_var ::
       nil
    ));
    repeat step || list_utils;
    try finisher.

  rewrite cons_app.
  match goal with
  | H: wf ?B 1 |- [ ((?X,?RC) :: nil) ++ ?ρ ⊨ ?v : ?T ]v =>
    eapply strictly_positive_push_forall with
      ((X, fun a v => [ ρ ⊨ v : open 0 B a ]v) :: nil) A
  end; eauto;
    repeat step || apply wf_topen || apply twf_topen || apply is_erased_type_topen ||
           fv_open || list_utils || apply wf_open || apply twf_open ||
           apply reducibility_is_candidate ||
           t_instantiate_reducible || apply reducible_values_subst_head2 || simp_red || t_closing;
    try finisher;
    eauto with twf;
    eauto with wf;
    eauto 2 with fv step_tactic.
  - eapply strictly_positive_rename_one; eauto; steps; try finisher.
  - rewrite (is_erased_term_tfv a0) in *; (steps; eauto with erased).
Qed.


(**
Content :
- Some lemma on Yoneda
- Famillies of Types in CwF (DepTypes prefixe mostly)
- Pi Types in CwF (CwF_Pi prefixe)
- Sigma Types in CwF (CwF_Sig prefixe)
- Identity Types in CwF (CwF_Id prefixe)
**)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.ALV1.CwF_def.

Notation "'pr1121' x" := (pr1(pr1(pr2(pr1(x))))) (at level 30).
Notation "'pr2121' x" := (pr2(pr1(pr2(pr1(x))))) (at level 30).

Section Fix_Category.
(** * Preliminaries *)
(** General context for a category with famillies and some usefull notations *)
Context {CwF : cwf}.
Local Definition C : category := pr1(CwF).
Local Definition pp : mor_total(preShv(C)) := pr12 CwF.
Local Definition Ty : functor _ _ := target pp.
Local Definition Tm : functor _ _ := source pp.
(* extension of context *)
Local Definition ext (Γ : C) (A : Ty Γ : hSet) : C := pr11 pr22 CwF Γ A.
Local Notation "Γ .: A" :=  (ext Γ A) (at level 24).

Local Definition pi {Γ : C} (A : Ty Γ : hSet) : C⟦Γ.:A,Γ⟧ := pr21 pr22 CwF _ A.
(* just a simple to use pp as a nat_trans *)
Local Definition Nat_trans_morp {C : category} (Γ : C) (p : mor_total(preShv C))
: HSET_univalent_category ⟦ (pr21 p : functor _ _) Γ, (pr11 p : functor _ _) Γ ⟧ := pr12 p Γ.

Notation "p __: Γ" := (Nat_trans_morp Γ p)  (at level 24).
Local Definition pp_ (Γ : C) : (Tm Γ : hSet) → (Ty Γ : hSet) := pp __: Γ.

Lemma Ty_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Ty Γ'' : hSet)
: #Ty (f;;g) A = #Ty f (#Ty g A).
Proof.
  exact (!((toforallpaths _ _ _ (!(pr22 Ty _ _ _  g f))) A)).
Qed.

Lemma Tm_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Tm Γ'' : hSet)
: #Tm (f;;g) A = #Tm f (#Tm g  A).
Proof.
  exact (!((toforallpaths _ _ _ (!(pr22 Tm _ _ _  g f))) A)).
Qed.

Lemma Ty_identity {Γ : C} (A : Ty Γ : hSet) : A = #Ty (identity Γ) A.
Proof.
  assert (eqA : A = (identity (pr1 Ty Γ) A)) by auto.
  rewrite eqA.
  apply (!((toforallpaths _ _ _ (pr12 Ty _ )) A)).
Qed.

(** * Tm as a Display **)
Section tm.
Local Definition tm {Γ : C} (A : Ty Γ : hSet) : UU
:= ∑ (a : Tm Γ : hSet), pp_ _ a = A.

Local Definition pr1_tm {Γ : C} {A : Ty Γ : hSet} (a : tm A) : Tm Γ : hSet := pr1 a.
Coercion pr1_tm : tm >-> pr1hSet.

Lemma ppComp1 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A) :
  pp_ _ (# Tm f a ) = # Ty f A.
Proof.
  apply pathsinv0, (pathscomp0(!(maponpaths (# Ty f) (pr2 a)))).
  apply pathsinv0, (toforallpaths _ _ _ (pr22 pp _ _ f) a) .
Qed.

Definition reind_cwf {Γ : C} (A : Ty Γ : hSet) {Γ'} (f : C⟦Γ',Γ⟧)
: Ty Γ' : hSet := #Ty f A.
Local Definition reind_tm {Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (x : tm A)
: tm (#Ty f A) := #Tm f x,,ppComp1 f x.

Local Definition te {Γ : C} (A : Ty Γ : hSet) : tm (#Ty (pi A) A)
:= pr12 pr22 CwF _ A.
(* proof of pp (te A) = Ty (pi A) A*)
Local Definition te' {Γ : C} (A : Ty Γ : hSet) : pp_ _ (te A) = #Ty (pi A) A := pr212 pr22 CwF Γ A.
Definition CwF_Pullback {Γ} (A : Ty Γ : hSet) : isPullback (yy A) pp (#Yo (pi A)) (yy(te A)) (cwf_square_comm (te' A)) := pr22 pr22 CwF Γ A.

Local Definition tm_transportf {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A ≃ tm A'.
Proof.
  use weqbandf.
  -  exact (idweq (Tm Γ : hSet)).
  -  induction e. intro x. exact (idweq _).
Defined.

Local Definition tm_transportb {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A' ≃ tm A := invweq(tm_transportf e).

Lemma tm_transportf_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportf (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportb_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportb (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportbf {Γ} {A A' : Ty Γ : hSet} (e : A = A') : tm_transportb e = tm_transportf (!e).
Proof.
  induction e.
  refine (subtypePath isapropisweq _).
  apply (idpath _).
Qed.

Lemma reind_compose_tm
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: reind_tm (g ;; f) a
= tm_transportb (Ty_composition _ _ _) (reind_tm g (reind_tm f a)).
Proof.
  apply subtypePath.
  -  intro x. apply (setproperty (Ty Γ'' : hSet)).
  -  rewrite tm_transportbf. apply Tm_composition.
Qed.

Lemma maponpaths_2_reind_tm
{Γ Γ' : C} {f f' : C⟦Γ',Γ⟧} (e : f = f') {A : Ty Γ : hSet} (a : tm A)
: reind_tm f a = tm_transportb (maponpaths (fun g => #Ty g A) e) (reind_tm f' a).
Proof.
  induction e.
  rewrite maponpaths_eq_idpath; [|apply idpath].
  now rewrite tm_transportb_idpath.
Qed.

Lemma tm_transportf_compose {Γ : C} {A A' A'' : Ty Γ : hSet} (e : A = A')
(e' : A' = A'') (a : tm A)
: tm_transportf (e @ e') a = tm_transportf e' (tm_transportf e a).
Proof.
  induction e.
  induction e'.
  reflexivity.
Qed.

Lemma tm_transportf_irrelevant {Γ} {A A' : Ty Γ : hSet} (e e' : A = A')
(t : tm A)
: tm_transportf e t = tm_transportf e' t.
Proof.
  apply (maponpaths (fun e => tm_transportf e t)).
  apply (setproperty (Ty Γ : hSet)).
Qed.

Lemma tm_transport_compose {Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) (A : Ty Γ : hSet) (a : tm A)
: tm_transportf ((Ty_composition g f A)) (reind_tm (g;;f) a) = reind_tm g (reind_tm f a).
Proof.
  rewrite reind_compose_tm.
  rewrite tm_transportbf.
  rewrite <- tm_transportf_compose ,pathsinv0l.
  reflexivity.
Qed.

Lemma tm_transportf_bind {Γ} {A A' A'': Ty Γ : hSet} {e : A' = A} {e' : A'' = A'}
{t} {t'} {t''} (ee : t = tm_transportf e t') (ee' : t' = tm_transportf e' t'')
: t = tm_transportf (e' @ e) t''.
Proof.
  etrans. 2: { apply pathsinv0, tm_transportf_compose. }
  etrans. { eassumption. }
  apply maponpaths; assumption.
Qed.

Lemma reind_compose_tm'
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: tm_transportf (Ty_composition _ _ _)
        (reind_tm (g ;; f) a)
      = reind_tm g (reind_tm f a).
Proof.
  rewrite reind_compose_tm. rewrite tm_transportbf.
  now rewrite <- tm_transportf_compose, pathsinv0l, tm_transportf_idpath.
Qed.

Lemma reind_id_tm {Γ : C}{A : Ty Γ : hSet} (a : tm A)
: reind_tm (identity _) a
= tm_transportb ((toforallpaths _ _ _ (pr12 Ty _ )) A) a.
Proof.
  apply subtypePath.
  -  intros x. apply (setproperty (Ty Γ : hSet)).
  -  apply ((toforallpaths _ _ _ (pr12 Tm _ )) a).
Qed.

End tm.

Section Yoneda.

(** * Few usefull lemma on yoneda **)

Lemma yonedainv {A B : C} (f : C⟦A,B⟧) : Yo^-1 (#Yo f) = f.
Proof.
  apply id_left.
Qed.

Lemma transportyo {A B : C} {f g : C⟦A,B⟧} (e : #Yo f = #Yo g) : f = g.
Proof.
  apply (pathscomp0 (!(yonedainv f))), pathsinv0
  ,(pathscomp0 (!(yonedainv g))), (!(maponpaths Yo^-1 e)).
Qed.

Lemma yonedacarac {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧)
: # Yo ((f :nat_trans _ _) Γ (identity Γ)) = f.
Proof.
  assert (H : (# Yo ((f : nat_trans _ _) Γ (identity Γ)) : nat_trans _ _) Γ (identity Γ)
               = (f : nat_trans _ _) Γ (identity Γ)) by apply (id_left _).
  assert (Map1 : (f : nat_trans _ _) Γ (identity Γ) = yoneda_map_1 C (pr2 C) Γ (Yo(Δ)) f) by reflexivity.
  assert (Map2 : # Yo ((f : nat_trans _ _) Γ (identity Γ)) = yoneda_map_2 C (pr2 C) Γ (Yo(Δ))
         ((f : nat_trans _ _) Γ (identity Γ))).
  -  unfold yoneda_map_2; cbn; unfold yoneda_morphisms; unfold yoneda_morphisms_data; cbn.
     assert (nattrans : is_nat_trans_yoneda_morphisms_data C _ Γ Δ
         ((f :nat_trans _ _) Γ (identity Γ))
          = yoneda_map_2_ax C (pr2 C) Γ (yoneda_objects C _ Δ)
          ((f : nat_trans _ _) Γ (identity Γ))).
     --  assert (prop : isaprop(is_nat_trans (yoneda_objects C _ Γ)
         (yoneda_objects C (homset_property C) Δ)
         (yoneda_morphisms_data C _ Γ Δ
         ((f : nat_trans _ _) Γ (identity Γ))))) by (apply isaprop_is_nat_trans;exact (pr2 hset_category));
        exact (pr1 (prop _ _)).
     --  apply pair_path_in2; apply nattrans.
  -  rewrite Map2; rewrite Map1; apply yoneda_map_1_2.
Qed.

Lemma invyoneda {A B : C} (f : _⟦Yo A,Yo B⟧) : #Yo (Yo^-1 f) = f.
Proof.
  apply yonedacarac.
Qed.

Lemma yyidentity {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
: B = (@yy (pr1 C) (pr2 C) Ty (Γ.:A) B : nat_trans _ _) (Γ.:A) (identity (Γ.:A)).
Proof.
  apply pathsinv0; eapply pathscomp0.
  -  apply (toforallpaths _ (# Ty _) _ (functor_id Ty (Γ.:A))).
  -  reflexivity.
Qed.

End Yoneda.

Section qq.
(** morphism between contexts *)

Let Xk {Γ : C} (A : Ty Γ : hSet) :=
  make_Pullback _ _ _ _ _ _ (pr22 pr22 CwF Γ A).

Local Definition qq_yoneda {Γ  Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: (preShv C) ⟦Yo (Δ .: (#Ty f A)), Yo (Γ.: A) ⟧.
Proof.
  use (PullbackArrow (Xk A)).
  -  apply (#Yo (pi _) ;; #Yo f ).
  -  apply (yy (te _)).
  -  abstract (
        clear Xk;
        assert (XT := (cwf_square_comm (te' (#Ty f A) )));
        eapply pathscomp0; try apply XT; clear XT;
        rewrite <- assoc; apply maponpaths;
        apply pathsinv0, yy_natural
     ).
Defined.

Lemma qq_yoneda_commutes_1 {Γ Δ : C} (A : Ty Γ : hSet) (f : C ⟦Δ,Γ⟧)
: (# Yo (pi (#Ty f A)) ;; # Yo f) = (qq_yoneda A f) ;; # Yo (pi A ) .
Proof.
  apply pathsinv0.
  apply (PullbackArrow_PullbackPr1 (Xk _)).
Qed.

Lemma qq_yoneda_commutes {Γ Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: (qq_yoneda A f) ;; yy (te A) = yy (te (#Ty f A)).
Proof.
  apply (PullbackArrow_PullbackPr2 (Xk A)).
Qed.

Local Definition qq_term {Γ  Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: C ⟦ Δ.:(#Ty f A) , Γ.: A⟧.
Proof.
  apply (invweq (make_weq _ (yoneda_fully_faithful _ (homset_property _) _ _ ))) ,
  (qq_yoneda A f).
Defined.

Lemma qq_yoneda_compatibility {Γ  Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧) :
 #Yo(qq_term A f) = qq_yoneda A f.
Proof.
  apply (homotweqinvweq
  (make_weq _ (yoneda_fully_faithful _ (homset_property _) ( _ .:(#Ty f A)) (Γ.:A)))).
Qed.

Lemma qq_term_te {Γ Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: #Tm (qq_term A f) (te A) = te (#Ty f A).
Proof.
  assert (Hyp := qq_yoneda_commutes A f).
  rewrite <- qq_yoneda_compatibility in Hyp.
  apply (pathscomp0 (yy_natural  _ _ _ _ _)) in Hyp.
  apply (invmaponpathsweq (@yy _ (pr2 C) _ _) ).
  exact Hyp.
Qed.

Lemma qq_term_pullback {Γ  Δ :C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: f ;; pi (#Ty f A) = (qq_term A f);; pi A.
Proof.
  assert (XT := (qq_yoneda_commutes_1 A f)).
  rewrite <- qq_yoneda_compatibility in XT.
  do 2 rewrite <- functor_comp in XT.
  apply (invmaponpathsweq (make_weq _ (yoneda_fully_faithful _ (homset_property _) _ _ ))).
  cbn; cbn in XT; exact XT.
Qed.

Section Familly_Of_Types.
(** Famillies of types in a Category with famillies**)
Lemma Subproof_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: identity (Yo Γ) ;; yy A = yy a ;;pp.
Proof.
  apply pathsinv0, (pathscomp0(yy_comp_nat_trans Tm Ty pp Γ a)) ,pathsinv0,
  (pathscomp0(id_left _ )), ((maponpaths yy) (!(pr2 a))).
Qed.

Definition γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : (preShv C)⟦Yo Γ,Yo (Γ.:A)⟧
:= pr11((CwF_Pullback A) (Yo Γ) (identity _) (yy a) (Subproof_γ a)).

Lemma  γ_pull {Γ : C} (A : Ty Γ : hSet)
: γ (te A) ;; yy (te (#Ty (pi A) A)) = yy (te A).
Proof.
  exact (pr221((CwF_Pullback _) (Yo (Γ.:A)) (identity _) (yy _) (Subproof_γ _))).
Qed.

Lemma pull_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : γ a ;; #Yo (pi A) = identity _.
Proof.
  apply pathsinv0, (pathscomp0(!(pr121 (CwF_Pullback _
        (Yo Γ) (identity (Yo Γ)) (yy a)
        (Subproof_γ a))))); auto.
Qed.

Lemma γNat {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A)
: (f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ) =
  (γ (reind_tm f a ) ;; #Yo (qq_term A f) : nat_trans _ _) Δ (identity Δ).
Proof.
  assert (Yoγ : #Yo ((f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ)) =
  #Yo((γ (reind_tm f a) : nat_trans _ _) Δ (identity Δ) ;; qq_term A f)).
  -  do 2 (rewrite (pr22 (yoneda C (pr2 C)) _ _ _); rewrite yonedacarac).
     refine (MorphismsIntoPullbackEqual (CwF_Pullback A)
     (#Yo f ;; γ a) (γ (reind_tm f a) ;; #Yo (qq_term A f)) _ _).
     --  rewrite <- assoc.
         eapply pathscomp0.
         *  rewrite (cancel_precomposition _ _ _ _ _ _ _
            (pr121((CwF_Pullback _) (Yo Γ) (identity (Yo Γ)) (yy(a)) (Subproof_γ a )))).
            apply id_right.
         *  rewrite qq_yoneda_compatibility.
            rewrite <- assoc.
            apply pathsinv0.
            eapply pathscomp0.
            **  rewrite (cancel_precomposition _ _ _ _ _ _ _
                (pr121 ((pr22 (Xk A))
                (Yo (_.: # Ty f A)) (# Yo (pi (#Ty f A));; # Yo f)
                (yy (te (#Ty f A))) (qq_yoneda_subproof Γ Δ A f)))).
                rewrite assoc.
                rewrite  (cancel_postcomposition _ _ _
                (pr121 ((CwF_Pullback _) (Yo Δ) (identity (Yo Δ))
                (yy(#Tm f a)) (Subproof_γ (reind_tm f a) )))).
                apply (pr1 (pr121 (preShv C)) _ (Yo Γ) (#Yo f)).
            **  reflexivity.
    --  rewrite <- assoc.
        apply (pathscomp0  (cancel_precomposition _ _ _ _ _ _ _
        (pr221((CwF_Pullback _) (Yo Γ) (identity (Yo Γ)) (yy(a)) (Subproof_γ a ))))).
        rewrite qq_yoneda_compatibility.
        rewrite <- assoc.
        apply pathsinv0.
        eapply pathscomp0.
        *  rewrite (cancel_precomposition _ _ _ _ _ _ _
           (pr221 ((pr22 (Xk A))
           (Yo (_.: # Ty f A)) (# Yo (pi (#Ty f A));; # Yo f)
           (yy (te (#Ty f A))) (qq_yoneda_subproof Γ Δ A f)))).
           apply (pr221( (pr22(pr22 CwF Δ (#Ty f A)))
           (Yo Δ) (identity (Yo Δ)) (yy(#Tm f a)) (Subproof_γ (reind_tm f a )))).
        *  apply yy_natural.
  -  apply (transportyo Yoγ).
Qed.

Lemma γPullback1 {Γ : C} (A : Ty Γ : hSet)
: γ (te A) ;; #Yo (qq_term A (pi A)) ;; yy(te A) = identity _;; yy (te A).
Proof.
  rewrite id_left.
  assert (γ (te A) ;; yy ( te (# Ty (pi A) A)) = yy( te A)) by
  (rewrite <- (pr221 (pr22 (pr22 CwF (Γ.:A) (#Ty (pi A) A))
    (Yo (Γ.:A)) (identity _) (yy (te A))
    (Subproof_γ (te A) ))); auto) .
  rewrite (qq_yoneda_compatibility A (pi A)), <- assoc, <- X.
  refine (cancel_precomposition _ _ _ _ _ _ _ _).
  rewrite X.
  apply (qq_yoneda_commutes A (pi A)).
Qed.

Lemma  γPullback2 {Γ : C} (A : Ty Γ : hSet)
: γ (te A) ;; #Yo (qq_term A (pi A)) ;; #Yo (pi A) = identity _;;(#Yo (pi A)).
Proof.
  assert (Eq1 : #Yo (pi (#Ty (pi A) A)) ;; #Yo (pi A) = qq_yoneda A (pi A) ;; #Yo (pi A)) by (
  rewrite <- (pr121((pr22(make_Pullback (yy A) pp
    (yoneda (pr1 CwF) (homset_property (pr1 CwF))
    (Γ.:A))
    (# (yoneda (pr1 CwF) (homset_property (pr1 CwF)))
    (pi A))
    (yy (pr112 (pr22 CwF Γ A)))
    (cwf_square_comm (pr212 (pr22 CwF Γ A)))
    (CwF_Pullback A))) (Yo (_ .: (#Ty (pi A) A)))
    (#Yo (pi (#Ty (pi A) A)) ;; #Yo (pi A)) (yy (te (#Ty (pi A) A)))
    (qq_yoneda_subproof Γ (Γ.: A) A (pi A))));
  auto).
  rewrite (qq_yoneda_compatibility A (pi A)), <- assoc.
  assert (Eq2 : γ (te A);; #Yo (pi (#Ty (pi A) A)) = identity _) by
  (apply pathsinv0, (pathscomp0(!(pr121 (CwF_Pullback _
        (Yo (Γ.:A)) (identity (Yo (Γ.:A))) (yy (te A))
        (Subproof_γ (te A))))));
  auto).
  apply (pathscomp0 (cancel_precomposition _ _ _ _ _ _ (γ (te A)) (!Eq1))).
  rewrite assoc.
  apply (pathscomp0 (cancel_postcomposition _ _ _ (Eq2))).
  reflexivity.
Qed.

Definition γ_qq {Γ} {A : Ty Γ: hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm (#Ty f A)) : C⟦Γ',Γ.: A⟧.
Proof.
  exact (Yo^-1 (γ a) ;; qq_term A f).
Defined.

Lemma γ_pi {Γ} {A : Ty Γ: hSet} (a : tm A) : Yo^-1 (γ a) ;; pi A = identity _.
Proof.
  assert (Yoeq : #Yo(Yo^-1 (γ a) ;; pi A) = #Yo(identity Γ)).
  -  apply (pathscomp0 (pr22 Yo _ _ _  _ _ )).
     apply pathsinv0 , (pathscomp0 (pr12 Yo _)).
     assert (simplman : identity (pr1 (yoneda C (homset_property C)) Γ)
     = identity (Yo Γ)) by auto.
     apply (pathscomp0 simplman).
     rewrite (!(pull_γ a)).
     apply cancel_postcomposition.
     assert (simplman2 : # (pr1 (yoneda C (homset_property C))) (Yo^-1 (γ a))
     = #Yo (Yo^-1 (γ a))) by auto.
     apply pathsinv0, (pathscomp0 simplman2), invyoneda.
  -  apply (maponpaths (Yo^-1) ) in Yoeq.
     rewrite yonedainv, yonedainv in Yoeq.
     exact Yoeq.
Qed.

Lemma te_subtitution {Γ} {A : Ty Γ : hSet} (a : tm A) : #Tm (Yo^-1(γ a)) (te A) = a.
Proof.
  assert (inter : @yy _ (pr2 C) _ _ (#Tm (Yo^-1(γ a)) (te A)) = yy a).
  -  rewrite yy_natural, invyoneda.
     exact (pr221((CwF_Pullback _) (Yo _) (identity _) (yy _) (Subproof_γ _))).
  -  apply (maponpaths (invmap yy) ) in inter.
     do 2 rewrite homotinvweqweq in inter.
     exact inter.
Qed.

Lemma reind_id_tm' {Γ : C} {A : Ty Γ : hSet}  (a : tm A) (b : tm A)
(e : # Ty (identity Γ) A = # Ty (Yo^-1 (γ b) ;; pi A) A)
: tm_transportf e (reind_tm (identity _) a)
= tm_transportf ((Ty_identity _) @ e) a.
Proof.
  apply subtypePath.
  -  intros x. apply (setproperty (Ty Γ : hSet)).
  -  apply ((toforallpaths _ _ _ (pr12 Tm _ )) a).
Qed.

Lemma Ty_γ_id {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: # Ty (Yo^-1 (γ a)) (# Ty (pi A) A) = A.
Proof.
  simple refine (!(Ty_composition _ _ _) @ _).
  apply (pathscomp0 ((toforallpaths  _ _ _ (maponpaths _ (γ_pi _)) )A)).
  apply ((toforallpaths _ _ _ (pr12 Ty _ )) A).
Qed.

Definition DepTypesType {Γ : C} {A : Ty Γ : hSet} (B : Ty(Γ.:A) : hSet)
(a : tm A)
: Ty Γ : hSet := ( γ a;;yy B : nat_trans _ _) Γ (identity Γ).

Definition DepTypesElem_pr1 {Γ : C} {A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
(b : tm B) (a : tm A)
: Tm Γ : hSet := (γ a;;yy b : nat_trans _ _) Γ (identity Γ).

Lemma DepTypesComp {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
(b : tm B) (a : tm A)
: pp_  Γ (DepTypesElem_pr1 b a) = DepTypesType B a.
Proof.
  apply pathsinv0,(pathscomp0(maponpaths _ (!(pr2 b)))),pathsinv0,
  (toforallpaths _ _ _ (pr22 pp (Γ.:A) Γ ((γ a : nat_trans _ _ ) Γ (identity Γ))) b).
Qed.

Definition DepTypesElems {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
(b : tm B) (a : tm A)
: tm (DepTypesType B a) := DepTypesElem_pr1 b a ,, DepTypesComp b a.

Lemma DepTypesNat {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ.: A) : hSet)
(f : C^op ⟦Γ,Δ⟧) (a : tm A)
: #Ty f (DepTypesType B a) = DepTypesType (#Ty (qq_term A f) B) (reind_tm f a).
Proof.
  unfold DepTypesType, reind_tm; rewrite yy_natural, assoc.
  assert (Fucn : (# (pr1 Ty) ((γ a :nat_trans _ _) Γ (identity Γ)) ;; # (pr1 Ty) f) B =
  # Ty f (# Ty ((γ a :nat_trans _ _) Γ (identity Γ)) B)) by auto.
  apply (pathscomp0 (!Fucn)),(pathscomp0(!((toforallpaths _ _ _
  ((pr22 Ty) _ _ _ ((γ a: nat_trans _ _) Γ (identity Γ) : C⟦Γ,Γ.:A⟧) f)) B))),
  (pathscomp0(toforallpaths _ _ _ (maponpaths (# Ty) (γNat f a)) B)).
  reflexivity.
Qed.

Lemma DepTypesEta {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
: DepTypesType (#Ty (qq_term A (pi A)) B) (te A) = B.
Proof.
  assert (Natu : @γ (Γ.:A) (#Ty (pi A) A) (te A) ;; yy (# Ty (qq_term A (pi A)) B)
  = @γ (Γ.:A) (#Ty (pi A) A) (te A) ;; #Yo (qq_term A (pi A)) ;;
  (@yy (@pr1 _ _ C) (@pr2 _ _ C) Ty (Γ .: A)) B).
  -  rewrite (cancel_precomposition _ _ _ _ (yy (#Ty (qq_term A (pi A)) B))
     (#Yo (qq_term A (pi A));; yy B) _).
     *  rewrite assoc; reflexivity.
     *  rewrite yy_natural; reflexivity.
  -  assert (Id: @γ (Γ .: A) (# Ty (@pi Γ A) A) (te A) ;; #Yo (qq_term A (pi A))
     = identity _).
     *  refine (MorphismsIntoPullbackEqual
        (pr22(make_Pullback (yy A) pp
        (yoneda (pr1 CwF) (homset_property (pr1 CwF)) (Γ.:A))
        (# (yoneda (pr1 CwF) (homset_property (pr1 CwF))) (pi A))
        (yy (te A))
        (cwf_square_comm (te' A))
        (CwF_Pullback A)))
        (γ (te A) ;; #Yo (qq_term A (pi A))) (identity _) (γPullback2 A) (γPullback1 A)).
     *  rewrite Id, (id_left _) in Natu.
        unfold DepTypesType.
        rewrite Natu; exact (!(yyidentity B)).
Qed.

Lemma DepTypesrewrite {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
(a b : tm A) (e : pr1 a = pr1 b)
: DepTypesType B a = DepTypesType B b.
Proof.
  destruct a as [a pa]; destruct b as [b pb].
  cbn in e; induction e.
  assert (ProofIrr : pa = pb) by apply (setproperty( Ty Γ : hSet)).
  rewrite ProofIrr.
  reflexivity.
Qed.

End Familly_Of_Types.
End qq.

(** ** Pi Type over Category with famillies *)

Section Pi_structure.

Definition CwF_PiTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet), (Ty Γ : hSet).

Definition CwF_PiTypeNat (π : CwF_PiTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet),
  reind_cwf (π _ A B) f  = π _ (reind_cwf A f) (reind_cwf B (qq_term A f)).

Definition CwF_pi_form_struct : UU
:= ∑ pi : CwF_PiTypeFormer, CwF_PiTypeNat pi.

Definition pr1_PiFormer (π : CwF_pi_form_struct) : CwF_PiTypeFormer := pr1 π.
Coercion pr1_PiFormer : CwF_pi_form_struct >-> CwF_PiTypeFormer.

Lemma ppComp3 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) {π : CwF_PiTypeFormer}
(nπ : CwF_PiTypeNat π) {B : Ty (Γ.: A) : hSet} (c : tm (π _ A B))
: pp_ _ (# Tm f c)  = (π Δ (# Ty f A) (# Ty (qq_term A f) B)).
Proof.
  apply pathsinv0, (pathscomp0(!(nπ _ _ f A B))),
  (pathscomp0(!(maponpaths (# Ty f) (pr2 c)))),
   pathsinv0, (toforallpaths _ _ _ (pr22 pp _ _ f) c) .
Qed.

Definition CwF_PiAbs (π : CwF_PiTypeFormer): UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet) (b : tm B), tm (π _ A B) .

Definition CwF_PiAbsNat (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π) (Λ : CwF_PiAbs π)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet)
(B : Ty (Γ .: A) : hSet) (b : tm B), reind_tm f (Λ Γ A B b) =
tm_transportf (! (! ppComp1 f (Λ Γ A B b) @ ppComp3 f nπ (Λ Γ A B b)))
(Λ Δ (# Ty f A) (# Ty (qq_term A f) B) (reind_tm (qq_term A f) b)).

Definition CwF_Pi_intro_struct (π : CwF_pi_form_struct) : UU
:= ∑ Λ : CwF_PiAbs π, CwF_PiAbsNat π (pr2 π) Λ.

Definition CwF_PiApp (π : CwF_PiTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet) (c : tm (π _ A B)) (a : tm A),
tm (DepTypesType B a).

Definition CwF_PiAppNat  (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π) (app : CwF_PiApp π) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet)
(c : tm (π _ A B)) (a : tm A),
reind_tm f (app _ _ _ c a) = (tm_transportf  (!(DepTypesNat B f a))
(app _ (#Ty f A) (# Ty (qq_term A f) B)
 (tm_transportf (nπ _ _ f A B) (reind_tm f c)) (reind_tm f a))).

Definition CwF_Pi_app_struct (π : CwF_pi_form_struct) : UU
:= ∑ app : CwF_PiApp π, CwF_PiAppNat π (pr2 π) app.

Definition CwF_PiAppAbs (π : CwF_PiTypeFormer) (Λ : CwF_PiAbs π) (app : CwF_PiApp π)
:= ∏ Γ ( A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet) (b : tm B) (a : tm A),
app _ _ _ (Λ _ A _ b) a = DepTypesElems b a.

Definition CwF_Pi_comp_struct (π : CwF_pi_form_struct)
(lam : CwF_Pi_intro_struct π) (app : CwF_Pi_app_struct π) : UU
:= CwF_PiAppAbs π (pr1 lam) (pr1 app).

Definition CwF_PiAbsAppComp (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π)
(Λ : CwF_PiAbs π) (app : CwF_PiApp π)
: UU
:= ∏ (Γ : C) (A : Ty Γ: hSet) (B : Ty (Γ .: A) : hSet) (c : tm (π Γ A B)),
c = Λ Γ A B (tm_transportf (DepTypesEta B)
(app (Γ .: A) (# Ty (pi A) A) (# Ty (qq_term A (pi A)) B)
(tm_transportf (nπ Γ (Γ .: A) (pi A) A B) (reind_tm (pi A) c)) (te A))).

End Pi_structure.

(** ** Sigma Type over Category with famillies *)
Section Sigma_structure.

Definition CwF_SigTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet), Ty Γ : hSet.

Definition CwF_SigTypeNat (σ : CwF_SigTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet),
#Ty f (σ _ A B) = σ _ (#Ty f A) (#Ty (qq_term A f) B).

Definition CwF_SigAbs (σ : CwF_SigTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (a : tm A)
(b : tm (DepTypesType B a) ), tm (σ _ A B).

Definition CwF_SigAbsNat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ)
(pair : CwF_SigAbs σ)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(a : tm A) (b : tm (DepTypesType B a)), reind_tm f (pair Γ A B a b) =
tm_transportf (! nσ Γ Δ f A B)
(pair Δ (# Ty f A) (# Ty (qq_term A f) B) (reind_tm f a)
(tm_transportf (DepTypesNat B f a) (reind_tm f b))).

Definition CwF_SigPr1 (σ : CwF_SigTypeFormer) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c: tm (σ _ A B)), tm A.

Definition CwF_SigPr1Nat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ) (p1 : CwF_SigPr1 σ) : UU
:= ∏ (Γ Δ : C)  (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c : tm (σ _ A B)),
reind_tm f (p1 _ _ _ c) =
p1 _ (#Ty f A) (#Ty (qq_term A f) B) (tm_transportf (nσ _ _ f _ _) (reind_tm f c)).

Definition CwF_SigPr2 (σ : CwF_SigTypeFormer) (p1 : CwF_SigPr1 σ) :UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet)
(c : tm (σ _ A B) ), tm (DepTypesType B (p1 _ _ _ c)).

Definition CwF_SigPr2Nat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ) (p1 : CwF_SigPr1 σ)
(np1 : CwF_SigPr1Nat σ nσ p1) (p2 : CwF_SigPr2 σ p1)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(c : tm (σ Γ A B)),
reind_tm f (p2 Γ A B c) = tm_transportf (! DepTypesNat B f (p1 Γ A B c))
(tm_transportf (DepTypesrewrite (# Ty (qq_term A f) B)
(p1 Δ (# Ty f A) (# Ty (qq_term A f) B) (tm_transportf (nσ Γ Δ f A B) (reind_tm f c)))
(reind_tm f (p1 Γ A B c)) (maponpaths pr1 (! np1 Γ Δ f A B c)))
(p2 Δ (# Ty f A) (# Ty (qq_term A f) B) (tm_transportf (nσ Γ Δ f A B) (reind_tm f c)))).

Definition CwF_SigAbsPr1 (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ) (p1 : CwF_SigPr1 σ)
: UU := ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (a : tm A) (b : tm (DepTypesType B a)),
p1 _ _ _ (pair _  _ _ a b) = a.

Definition CwF_SigAbsPr2 (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ) (p1 : CwF_SigPr1 σ)
(p2 : CwF_SigPr2 σ p1) (Ap1 : CwF_SigAbsPr1 σ pair p1)
: UU := ∏ (Γ : C^op) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(a : tm A) (b : tm (DepTypesType B a)),
b = tm_transportf
(DepTypesrewrite B (p1 Γ A B (pair Γ A B a b)) a (maponpaths pr1 (Ap1 Γ A B a b)))
(p2 Γ A B (pair Γ A B a b)).

Definition CwF_SigAbsPr (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ)
(p1 : CwF_SigPr1 σ) (p2 : CwF_SigPr2 σ p1) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c : tm (σ _ A B)),
pair _ _ _ (p1 _ _ _ c) (p2 _ _ _ c ) = c.

End Sigma_structure.

Section Identity_Structure.
  (** Identity Types over a Category with famillies *)

Definition CwF_IdTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (a b : tm A), Ty Γ : hSet.

Definition CwF_IdTypeNat (id : CwF_IdTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a b : tm A),
#Ty f (id _ A a b)  = id _ (#Ty f A) (reind_tm f a) (reind_tm f b).

Definition CwF_IdRefl (Id : CwF_IdTypeFormer) : UU
:= ∏ Γ (A: Ty Γ :hSet) (a :tm A), tm (Id _ _ a a).

Definition CwF_IdReflNatContext (Id : CwF_IdTypeFormer) (nid : CwF_IdTypeNat Id)
(refl : CwF_IdRefl Id) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A),
reind_tm f (refl _ A a) =
tm_transportf (!(nid _ _ f _ a a)) (refl _ (#Ty f A) (reind_tm f a)).

Definition CwF_maponpathsIdForm {Id : CwF_IdTypeFormer}
{Γ} {A A'} (e_A : A = A')
{a} {a'} (e_a : a = tm_transportb e_A a')
{b} {b'} (e_b : b = tm_transportb e_A b')
: Id Γ A a b = Id Γ A' a' b'.
Proof.
  destruct e_A.
  rewrite (tm_transportbf _) in e_a, e_b;
   cbn in e_a, e_b.
  apply Auxiliary.maponpaths_12; assumption.
Qed.

Definition CwF_IdBasedFam (Id : CwF_IdTypeFormer) {Γ : C} (A : Ty Γ : hSet) (a : tm A)
: Ty (Γ.:A) : hSet := Id _ _ (reind_tm _ a) (te A).

Definition CwF_IdBasedFamNatural (Id : CwF_IdTypeFormer) (nid : CwF_IdTypeNat Id)
{Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
: #Ty (qq_term A f) (CwF_IdBasedFam Id A a) = CwF_IdBasedFam Id _ (reind_tm f a).
Proof.
  unfold CwF_IdBasedFam.
  etrans.
  -  exact (nid _ _ (qq_term A f) _ _ _).
  -  use CwF_maponpathsIdForm.
     --  refine (!(Ty_composition _ _ A) @ _).
         apply pathsinv0, (pathscomp0 (!(Ty_composition _ _ A))).
         refine ((toforallpaths _ _ _ _) A).
         exact (maponpaths _ (qq_term_pullback _ _)).
     --  etrans. {apply pathsinv0, tm_transport_compose. }
         etrans. 2: { apply maponpaths, tm_transport_compose. }
         etrans. 2: {rewrite tm_transportbf; apply  tm_transportf_compose. }
         etrans. {eapply maponpaths. refine (maponpaths_2_reind_tm _ _).
         apply (!(qq_term_pullback _ _)). }
         etrans. { rewrite tm_transportbf; apply (!(tm_transportf_compose _ _ _)). }
         apply tm_transportf_irrelevant.
     --  apply subtypePath; [intro x; apply (setproperty (Ty _ : hSet))|
         rewrite tm_transportbf ;apply qq_term_te].
Qed.

Definition CwF_Id_map {Id} (nid : CwF_IdTypeNat Id) {Γ} {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
: C⟦Γ,_.:CwF_IdBasedFam Id A a⟧.
Proof.
  simple refine (γ_qq (Yo^-1 (γ b)) _). unfold CwF_IdBasedFam.
  simple refine (tm_transportb _ eqab).
  abstract(
  simple refine (nid  _ _ _ _ _ _ @ _);
  use CwF_maponpathsIdForm;
  [ apply Ty_γ_id
  | rewrite tm_transportbf ;
    refine (_ @ tm_transportf_irrelevant _ _ _);
    simple refine (tm_transportf_bind (!reind_compose_tm' _ _ _) _);
    [ apply (pathscomp0 (!(Ty_γ_id b))) , (!(Ty_composition _ _ _)) |
      simple refine (maponpaths_2_reind_tm _ _ @ _);
      [exact (identity _) | apply γ_pi |
      rewrite tm_transportbf; apply (pathscomp0 (reind_id_tm' _ _ _));
      apply tm_transportf_irrelevant ]]
  | apply subtypePath;
    [  intros x; apply (setproperty (Ty Γ : hSet))
     | rewrite tm_transportbf; apply te_subtitution]]).
Defined.

Definition CwF_IdBased_path_inducton {Id} (nid : CwF_IdTypeNat Id) (refl : CwF_IdRefl Id) := ∏ Γ (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ .: CwF_IdBasedFam Id A a) :  hSet)
(d : tm  (#Ty (CwF_Id_map nid a a (refl _ _ a)) P))
(b : tm A) (eqab : tm (Id _ _ a b)),
tm (#Ty (CwF_Id_map nid a b eqab) P).

End Identity_Structure.
End Fix_Category.


Require Import Coqlib.
Require Import Maps.
Require Import LibTactics.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import logic.

Require Import lemmas.
Require Import lemmas_ins.

Require Import Coq.Logic.FunctionalExtensionality.

Require Import sep_lemma.
Require Import reg_lemma.

Require Import ctxswitch_spec.

Open Scope nat.
Open Scope code_scope.
Open Scope mem_scope.

(*+ Lemmas about TimReduce +*)
Theorem astar_TimReduce :
  forall p q,
    (p ** q) ↓ = (p ↓) ** (q ↓).
Proof.
  intros; simpl; eauto.
Qed.

Theorem GenRegs_TimeReduce :
  forall grst p,
    (GenRegs grst ** p) ↓ = GenRegs grst ** (p ↓).
Proof.
  intros.
  simpl.
  destruct grst.
  destruct p0.
  destruct p0.
  destruct f1, f2, f0, f.
  simpl.
  eauto.
Qed.

Theorem GenRegs_rm_one_TimReduce' :
  forall grst (rr : GenReg) ,
    GenRegs_rm_one grst rr ↓ = GenRegs_rm_one grst rr.
Proof.
  intros.
  simpl.
  destruct grst.
  destruct p.
  destruct p.
  destruct f1, f2, f0, f.
  simpls.
  destruct rr; simpls; eauto.
Qed.

Theorem GenRegs_rm_one_TimReduce :
  forall grst (rr : GenReg) p,
    (GenRegs_rm_one grst rr ** p) ↓ = GenRegs_rm_one grst rr ** (p ↓).
Proof.
  intros.
  simpl.
  rewrite GenRegs_rm_one_TimReduce'; eauto.
Qed.

Theorem FrameState_TimeReduce :
  forall id vi F p,
    (FrameState id vi F ** p) ↓ = FrameState id vi F ** (p ↓).
Proof.
  intros.
  simpls.
  unfold FrameState.
  eauto.
Qed.

Theorem RegSt_TimeReduce :
  forall rn v p,
    (rn |=> v ** p) ↓ = rn |=> v ** (p ↓).
Proof.
  intros.
  simpl; eauto.
Qed.

Theorem MemSto_TimeReduce :
  forall l v p,
    (l |-> v ** p) ↓ = l |-> v ** (p ↓).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma save_reg_TimeReduce' :
  forall n l vl,
    save_reg l n vl ↓ = save_reg l n vl.
Proof.
  intro n.
  induction n; intros.
  -
    simpls.
    destruct vl; eauto.
  -
    destruct vl.
    {
      simpl.
      eauto.
    }
    {
      simpl.
      rewrite IHn; eauto.
    }
Qed.

Lemma save_reg_TimeReduce :
  forall n l vl p,
    (save_reg l n vl ** p) ↓ = save_reg l n vl ** (p ↓).
Proof.
  intros.
  simpl.
  rewrite save_reg_TimeReduce'; eauto.
Qed.

Theorem Context_TimeReduce' :
  forall ctx,
    (context ctx) ↓ = context ctx.
Proof.
  intros.
  unfold context.
  destruct ctx.
  destruct p.
  destruct p.
  destruct p.
  unfold context'.
  repeat (rewrite save_reg_TimeReduce; eauto).
Qed.

Theorem Context_TimeReduce :
  forall ctx p,
    (context ctx ** p) ↓ = context ctx ** (p ↓).
Proof.
  intros.
  simpls.
  unfold context.
  destruct ctx.
  destruct p0.
  destruct p0.
  destruct p0.
  unfold context'.
  do 3 rewrite save_reg_TimeReduce.
  simpl; eauto.
Qed.

Lemma stack_seg_TimeReduce :
  forall l fm,
    stack_seg l fm ↓ = stack_seg l fm.
Proof.
  intros.
  destruct fm.
  unfold stack_seg.
  simpl; eauto.
Qed.

Lemma stack_frame_TimeReduce :
  forall l fm1 fm2,
    stack_frame l fm1 fm2 ↓ = stack_frame l fm1 fm2.
Proof.
  intros.
  unfold stack_frame.
  rewrite astar_TimReduce.
  do 2 rewrite stack_seg_TimeReduce.
  simpl; eauto.
Qed.

Lemma Stk_TimeReduce' :
  forall lfp l,
    stack' l lfp ↓ = stack' l lfp.
Proof.
  intro lfp.
  induction lfp; intros.
  -
    simpl; eauto.
  -
    simpl.
    destruct a.
    simpl.
    do 2 rewrite stack_seg_TimeReduce; eauto.
    rewrite IHlfp; eauto.
Qed.

Lemma Stk_TimeReduce1 :
  forall stk,
    stack stk ↓ = stack stk.
Proof.
  intros.
  unfold stack.
  destruct stk.
  rewrite Stk_TimeReduce'; eauto.
Qed.

Theorem Stk_TimeReduce :
  forall stk p,
    (stack stk ** p) ↓ = stack stk ** (p ↓).
Proof.
  intros.
  destruct stk.
  unfold stack.
  simpl.
  rewrite Stk_TimeReduce'; eauto.
Qed.

Theorem conj_TimeReduce :
  forall p1 p2,
    (p1 //\\ p2) ↓ = (p1 ↓) //\\ (p2 ↓).
Proof.
  intros; eauto.
Qed.

Theorem disj_TimeReduce :
  forall p1 p2,
    (p1 \\// p2) ↓ = (p1 ↓) \\// (p2 ↓).
Proof.
  intros; eauto.
Qed.

Theorem pure_TimeReduce :
  forall pu p,
    ([| pu |] ** p) ↓ = [| pu |] ** (p ↓).
Proof.
  intros; eauto.
Qed.

Theorem Atrue_TimeReduce :
  forall p,
    (Atrue ** p) ↓ = Atrue ** (p ↓).
Proof.
  intros; eauto.
Qed.

Theorem Afalse_TimReduce :
  forall p,
    (Afalse ** p) ↓ = Afalse ** (p ↓).
Proof.
  intros; eauto.
Qed.

Ltac TimReduce_simpl :=
  match goal with
  | |- context [(context ?ctx) ↓] =>
    rewrite Context_TimeReduce'; TimReduce_simpl
  | |- context [(stack ?stk) ↓] =>
    rewrite Stk_TimeReduce1; TimReduce_simpl
  | |- context [(GenRegs ?grst ** ?p) ↓] =>
    rewrite GenRegs_TimeReduce; TimReduce_simpl
  | |- context [(GenRegs_rm_one ?grst ?rr ** ?p) ↓] =>
    rewrite GenRegs_rm_one_TimReduce; TimReduce_simpl
  | |- context [(FrameState ?id ?vi ?F ** ?p) ↓] =>
    rewrite FrameState_TimeReduce; TimReduce_simpl
  | |- context [(?rn |=> ?v ** ?p) ↓] =>
    rewrite RegSt_TimeReduce; TimReduce_simpl
  | |- context [(?l |-> ?v ** ?p) ↓] =>
    rewrite MemSto_TimeReduce; TimReduce_simpl
  | |- context [(context ?ctx ** ?p) ↓] =>
    rewrite Context_TimeReduce; TimReduce_simpl
  | |- context [(stack ?stk ** ?p) ↓] =>
    rewrite Stk_TimeReduce; TimReduce_simpl
  | |- context [([| ?pu |] ** ?p) ↓] =>
    rewrite pure_TimeReduce; TimReduce_simpl
  | |- context [(Atrue ** ?p) ↓] =>
    rewrite Atrue_TimeReduce; TimReduce_simpl
  | |- context [(Afalse ** ?p) ↓] =>
    rewrite Afalse_TimReduce; TimReduce_simpl
  | |- context [(stack' _ _) ↓] =>
    rewrite Stk_TimeReduce'; TimReduce_simpl
  | |- context [(stack_frame _ _ _) ↓] =>
    rewrite stack_frame_TimeReduce; TimReduce_simpl
  | |- context [(GenRegs_rm_one ?grst ?rr) ↓] =>
    rewrite GenRegs_rm_one_TimReduce'; TimReduce_simpl
  | |- context [(?p1 //\\ ?p2) ↓] =>
    rewrite conj_TimeReduce; TimReduce_simpl
  | |- context [(?p1 \\// ?p2) ↓] =>
    rewrite disj_TimeReduce; TimReduce_simpl
  | |- context [(?p1 ** ?p2) ↓] =>
    rewrite astar_TimReduce; TimReduce_simpl
  | _ => simpl TimReduce
  end.

Ltac TimReduce_simpl_in H :=
  match type of H with
  | _ |= ?p =>
    match p with
    | context [(GenRegs ?grst ** ?p) ↓] =>
      rewrite GenRegs_TimeReduce in H; TimReduce_simpl_in H
    | context [(FrameState ?id ?vi ?F ** ?p) ↓] =>
      rewrite FrameState_TimeReduce in H; TimReduce_simpl_in H
    | context [(?rn |=> ?v ** ?p) ↓] =>
      rewrite RegSt_TimeReduce in H; TimReduce_simpl_in H
    | context [(?l |-> ?v ** ?p) ↓] =>
      rewrite MemSto_TimeReduce in H; TimReduce_simpl_in H
    | context [(context ?ctx ** ?p) ↓] =>
      rewrite Context_TimeReduce in H; TimReduce_simpl_in H
    | context [(stack ?stk ** ?p) ↓] =>
      rewrite Stk_TimeReduce in H; TimReduce_simpl_in H
    | context [([| ?pu |] ** ?p) ↓] =>
      rewrite pure_TimeReduce in H; TimReduce_simpl_in H
    | context [(Atrue ** ?p) ↓] =>
      rewrite Atrue_TimeReduce in H; TimReduce_simpl_in H
    | context [(Afalse ** ?p) ↓] =>
      rewrite Afalse_TimReduce in H; TimReduce_simpl_in H
    | context [(?p1 //\\ ?p2) ↓] =>
      rewrite conj_TimeReduce in H; TimReduce_simpl_in H
    | context [(?p1 \\// ?p2) ↓] =>
      rewrite disj_TimeReduce in H; TimReduce_simpl_in H
    | _ => simpl TimReduce in H
    end
  end.

(*+ Lemmas about DlyFrameFree +*)
Lemma Atrue_DlyFrameFree :
  forall p,
    DlyFrameFree p -> DlyFrameFree (Atrue ** p).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma Afalse_DlyFrameFree :
  forall p,
    DlyFrameFree p -> DlyFrameFree (Afalse ** p).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma RegSt_DlyFrameFree :
  forall rn v p,
    DlyFrameFree p -> DlyFrameFree (rn |=> v ** p).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma MapSto_DlyFrameFree :
  forall l v p,
    DlyFrameFree p -> DlyFrameFree (l |-> v ** p).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma astar_DlyFrameFree :
  forall p1 p2,
    DlyFrameFree p1 -> DlyFrameFree p2 -> DlyFrameFree (p1 ** p2).
Proof.
  intros.
  simpl; eauto.
Qed.

Lemma save_reg_DlyFrameFree' :
  forall n l vl,
    DlyFrameFree (save_reg l n vl).
Proof.
  intro n.
  induction n; intros.
  -
    simpls; eauto.
    destruct vl; eauto.
    simpl; eauto.
    simpl; eauto.
  -
    destruct vl; simpl; eauto.
Qed.

Lemma save_reg_DlyFrameFree :
  forall n l vl p,
    DlyFrameFree p ->
    DlyFrameFree (save_reg l n vl ** p).
Proof.
  intros.
  eapply astar_DlyFrameFree; eauto.
  eapply save_reg_DlyFrameFree'.
Qed.

Lemma Context_DlyFrameFree' :
  forall l rl ri rg ry,
    DlyFrameFree (context' l rl ri rg ry).
Proof.
  intros.
  unfold context'.
  do 3 (eapply save_reg_DlyFrameFree; eauto).
  simpl; eauto.
Qed.

Lemma Context_DlyFrameFree :
  forall ctx p,
    DlyFrameFree p -> DlyFrameFree (context ctx ** p).
Proof.
  intros.
  unfold context.
  destruct ctx.
  destruct p0.
  destruct p0.
  destruct p0.
  eapply astar_DlyFrameFree; eauto.
  eapply Context_DlyFrameFree'; eauto.
Qed.

Lemma Stack_DlyFrameFree' :
  forall lfp l,
    DlyFrameFree (stack' l lfp).
Proof.
  intro lfp.
  induction lfp; intros.
  -
    simpls; eauto.
  -
    destruct a.
    simpl.
    repeat (split; eauto).
    destruct f.
    simpl.
    repeat (split; eauto).
    destruct f0.
    simpl.
    repeat (split; eauto).
Qed.

Lemma Stack_DlyFrameFree :
  forall stk p,
    DlyFrameFree p -> DlyFrameFree (stack stk ** p).
Proof.
  intros.
  unfold stack.
  destruct stk; eauto.
  eapply astar_DlyFrameFree; eauto.
  eapply Stack_DlyFrameFree'; eauto.
Qed.

Ltac DlyFrameFree_elim :=
  match goal with
  | |- DlyFrameFree (Atrue ** ?p) =>
    eapply Atrue_DlyFrameFree; DlyFrameFree_elim
  | |- DlyFrameFree (Afalse ** ?p) =>
    eapply Afalse_DlyFrameFree; DlyFrameFree_elim
  | |- DlyFrameFree (?rn |=> ?v ** ?p) =>
    eapply RegSt_DlyFrameFree; DlyFrameFree_elim
  | |- DlyFrameFree (?l |-> ?v ** ?p) =>
    eapply MapSto_DlyFrameFree; DlyFrameFree_elim
  | |- DlyFrameFree (context ?ctx ** ?p) =>
    eapply Context_DlyFrameFree; DlyFrameFree_elim
  | |- DlyFrameFree (stack ?stk ** ?p) =>
    eapply Stack_DlyFrameFree; DlyFrameFree_elim
  | _ =>
    try solve [simpl; eauto]
  end.


(* Distributed under the terms of the MIT license. *)
Set Warnings "-notation-overridden".

From MetaCoq.Utils Require Import utils.
From MetaCoq.Template Require Import All Checker.
From MetaCoq.Translations Require Import translation_utils MiniHoTT.
Import MCMonadNotation.

Unset MetaCoq Strict Unquote Universe Mode.

Local Set Primitive Projections.
Record prod A B := pair { π1 : A ; π2 : B }.

Arguments π1 {_ _} _.
Arguments π2 {_ _} _.
Arguments pair {_ _} _ _.

Declare Scope prod_scope.
Notation "( x ; y )" := (pair x y) : prod_scope.
Notation " A × B " := (prod A B) : type_scope.
Open Scope prod_scope.

MetaCoq Quote Definition tprod := prod.
MetaCoq Quote Definition tpair := @pair.
MetaCoq Run (t <- tmQuote prod ;;
            match t with
            | tInd i _ => tmDefinition "prod_ind" i
            | _ => tmFail "bug"
            end).
Definition proj1 (t : term) : term
  := tProj (mkProjection prod_ind 2 0) t.
Definition proj2 (t : term) : term
  := tProj (mkProjection prod_ind 2 (S 0)) t.

MetaCoq Quote Definition tbool := bool.
MetaCoq Quote Definition ttrue := true.
Definition timesBool (A : term) := tApp tprod [A; tbool].
Definition pairTrue typ tm := tApp tpair [typ; tbool; tm; ttrue].

Local Instance tit : config.checker_flags := config.type_in_type.
Local Existing Instance Checker.default_fuel.

Fixpoint tsl_rec (fuel : nat) (Σ : global_env_ext) (E : tsl_table) (Γ : context) (t : term) {struct fuel}
  : tsl_result term :=
  match fuel with
  | O => raise NotEnoughFuel
  | S fuel =>
  match t with
  | tRel  n => ret (tRel n)
  | tSort s => ret (tSort s)

  | tCast t c A => t' <- tsl_rec fuel Σ E Γ t ;;
                  A' <- tsl_rec fuel Σ E Γ A ;;
                  ret (tCast t' c A')

  | tProd n A B => A' <- tsl_rec fuel Σ E Γ A ;;
                  B' <- tsl_rec fuel Σ E (Γ ,, vass n A) B ;;
                  ret (timesBool (tProd n A' B'))

  | tLambda n A t => A' <- tsl_rec fuel Σ E Γ A ;;
                    t' <- tsl_rec fuel Σ E (Γ ,, vass n A) t ;;
                    match infer' Σ (Γ ,, vass n A) t with
                    | Checked B =>
                      B' <- tsl_rec fuel Σ E (Γ ,, vass n A) B ;;
                      ret (pairTrue (tProd n A' B') (tLambda n A' t'))
                    | TypeError t => raise (TypingError t)
                    end

  | tLetIn n t A u => t' <- tsl_rec fuel Σ E Γ t ;;
                     A' <- tsl_rec fuel Σ E Γ A ;;
                     u' <- tsl_rec fuel Σ E (Γ ,, vdef n t A) u ;;
                     ret (tLetIn n t' A' u')

  | tApp t us => t' <- tsl_rec fuel Σ E Γ t ;;
                monad_fold_left (fun t u => u' <- tsl_rec fuel Σ E Γ u ;;
                                         ret (tApp (proj1 t) [u'])) us t'

  | tConst s univs => lookup_tsl_table' E (ConstRef s)
  | tInd i univs => lookup_tsl_table' E (IndRef i)
  | tConstruct i n univs => lookup_tsl_table' E (ConstructRef i n)
  | tProj p t => t' <- tsl_rec fuel Σ E Γ t ;;
                ret (tProj p t')

  | tFix bodies n =>
    Γ' <- monad_map (fun '{| dname := na; dtype := ty; dbody := b; rarg := r |} =>
                      ty' <- tsl_rec fuel Σ E Γ ty ;;
                      ret {| decl_name := na; decl_body := None; decl_type := ty'|})
                   bodies;;
    bodies' <- monad_map (fun '{| dname := na; dtype := ty; dbody := b; rarg := r |} =>
                           ty' <- tsl_rec fuel Σ E Γ ty ;;
                           b'  <- tsl_rec fuel Σ E (Γ ++ Γ') b ;;
                           ret {| dname := na; dtype := ty';
                                  dbody := b'; rarg := r |})
                        bodies ;;
    ret (tFix bodies' n)
  | _ => raise TranslationNotHandeled (* var evar meta case cofix *)
  end
  end.

(* Definition recompose_prod (nas : list name) (ts : list term) (u : term) *)
(*   : term *)
(*   := let nats := List.combine nas ts in *)
(*      List.fold_right (fun t u => tProd (fst t) (snd t) u) u nats. *)

Definition combine' {A B} (p : list A * list B) : list (A * B)
  := List.combine  (fst p) (snd p).

Fixpoint replace pat u t {struct t} :=
  if eq_term uGraph.init_graph t pat then u else
    match t with
    | tCast t c A => tCast (replace pat u t) c (replace pat u A)
    | tProd n A B => tProd n (replace pat u A) (replace (up pat) (up u) B)
    | tLambda n A t => tLambda n (replace pat u A) (replace (up pat) (up u) t)
    | tLetIn n t A B => tLetIn n (replace pat u t) (replace pat u A)
                              (replace (up pat) (up u) B)
    | tApp t us => tApp (replace pat u t) (List.map (replace pat u) us)
    | tProj p t => tProj p (replace pat u t)
    | _ => t (* todo *)
    end.

Fixpoint subst_app (t : term) (us : list term) : term :=
  match t, us with
  | tLambda _ A t, u :: us => subst_app (t {0 := u}) us
  | _, [] => t
  | _, _ => mkApps t us
  end.

(* If tm of type typ = Π [A0] [A1] ... . [B], returns *)
(* a term of type [Π A0 A1 ... . B] *)
Definition pouet (tm typ : term) : term.
  simple refine (let '((names, types), last) := decompose_prod typ in
                 let L' := List.fold_left _ (List.combine names types) [] in _).
  exact (fun Γ' A => Γ' ,, vass (fst A) (snd A)).
  refine (let args := fold_left_i (fun l i _ => tRel i :: l) L' [] in _).
  refine (fst (List.fold_left _ L' (subst_app tm args, last))).
  refine (fun '(tm, typ) decl =>
            let A := tProd decl.(decl_name) decl.(decl_type) typ in
            (pairTrue A (tLambda decl.(decl_name) decl.(decl_type) tm),
             timesBool A)).
Defined.

Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) (kn : kername)
           (mind : mutual_inductive_body)
  : tsl_result (tsl_table * list mutual_inductive_body).
  refine (let tsl := fun Γ t => match tsl_rec fuel (fst ΣE) (snd ΣE) Γ t with
                             | Success x => x
                             | Error _ => todo "tsl"
                             end in
          let kn' := (mp, tsl_ident (snd kn)) in _).
  unshelve refine (let LI := List.split (mapi _ mind.(ind_bodies)) in
          ret (List.concat (fst LI),
               [{| ind_npars := mind.(ind_npars);
                   ind_params := _;
                   ind_bodies := snd LI;
                   ind_universes := mind.(ind_universes);
                   ind_variance := mind.(ind_variance)|}])). (* FIXME always ok? *)
  intros i ind.
  simple refine (let ind_type' := _ in
                 let ctors' := List.split (mapi _ ind.(ind_ctors)) in
                 (_ :: fst ctors',
                  {| ind_name := tsl_ident ind.(ind_name);
                     ind_sort := ind.(ind_sort);
                     ind_indices := ind.(ind_indices);
                     ind_type := ind_type';
                     ind_kelim := ind.(ind_kelim);
                     ind_ctors := snd ctors';
                     ind_projs := [];
                     ind_relevance := ind.(ind_relevance) |})).
  + (* arity *)
    refine (let L := decompose_prod ind.(ind_type) in _).
    simple refine (let L' := List.fold_left _ (combine' (fst L)) [] in _).
    exact (fun Γ' A => Γ' ,, vass (fst A) (tsl Γ' (snd A))).
    refine (List.fold_left _ L' (snd L)).
    exact (fun t decl => tProd decl.(decl_name) decl.(decl_type) t).
  + (* constructors *)
    intros k [name argctx indices typ nargs].
    simple refine (let ctor_type' := _ in
                   ((ConstructRef (mkInd kn i) k,
                     pouet (tConstruct (mkInd kn' i) k []) _),
                    (Build_constructor_body (tsl_ident name) argctx indices ctor_type' nargs))).
    * refine (fold_left_i (fun t i _ => replace (proj1 (tRel i)) (tRel i) t)
                          mind.(ind_bodies) _).
      refine (let L := decompose_prod typ in _).
      simple refine (let L' := List.fold_left _ (combine' (fst L))
                                              [] in _).
      exact (fun Γ' A => Γ' ,, vass (fst A) (tsl Γ' (snd A))).
      refine (List.fold_left _ L' _).
      exact (fun t decl => tProd decl.(decl_name) decl.(decl_type) t).
      exact (match snd L with
             | tApp t us => tApp t (List.map (tsl L') us)
             | _ as t => t
             end).
    * refine (fold_left_i (fun t l _ => replace (tRel l) (tInd (mkInd kn' i) []) t)
                          mind.(ind_bodies) ctor_type').
  + (* table *)
    refine (IndRef (mkInd kn i), pouet (tInd (mkInd kn' i) []) ind_type').
  + exact mind.(ind_finite).
  + (* parameters *)
    simple refine (List.fold_right _ [] (mind.(ind_params))).
    exact (fun A Γ' => Γ' ,, vass (decl_name A) (tsl Γ' (decl_type A))).
Defined.

Fixpoint refresh_universes (t : term) {struct t} :=
  match t with
  | tSort s => tSort (if Universe.is_level s then s else fresh_universe)
  | tProd na b t => tProd na b (refresh_universes t)
  | tLetIn na b t' t => tLetIn na b t' (refresh_universes t)
  | tCast x x0 x1 => tCast (refresh_universes x) x0 (refresh_universes x1)
  | tLambda x x0 x1 => tLambda x (refresh_universes x0) (refresh_universes x1)
  | tApp x x0 => tApp (refresh_universes x) (List.map refresh_universes x0)
  | tProj x x0 => tProj x (refresh_universes x0)
  | _ => t
  end.

Global Instance tsl_fun : Translation
  := {| tsl_id := tsl_ident ;
        tsl_tm := fun ΣE t => t' <- tsl_rec fuel (fst ΣE) (snd ΣE) [] t ;;
                           ret (refresh_universes t');
        tsl_ty := Some (fun ΣE t => t' <- tsl_rec fuel (fst ΣE) (snd ΣE) [] t ;;
                                 ret (refresh_universes t')) ;
        tsl_ind := tsl_mind_body |}.

Tactic Notation "tSpecialize" ident(H) uconstr(t)
  := apply π1 in H; specialize (H t).
Tactic Notation "tIntro" ident(H)
  := refine (fun H => _; true).

Definition NotFunext :=
  ((forall (A B : Set) (f g : A -> B), (forall x:A, f x = g x) -> f = g) -> False).

Unset Universe Checking.

MetaCoq Run (TC <- TranslateRec emptyTC NotFunext ;;
                     tmDefinition "TC" TC ;;
                     Implement TC "notFunext" NotFunext).
Next Obligation.
  unfold NotFunextᵗ; cbn in *.
  tIntro H.
  tSpecialize H unit. tSpecialize H unit.
  tSpecialize H (fun x => x; true). tSpecialize H (fun x => x; false).
  tSpecialize H (fun x => eq_reflᵗ _ _; true).
  inversion H.
Defined.

MetaCoq Run (Implement TC "notη" ((forall (A B : Set) (f : A -> B), f = fun x => f x) -> False)).

Next Obligation.
  tIntro H.
  tSpecialize H unit. tSpecialize H unit.
  tSpecialize H (fun x => x; false). cbn in H.
  inversion H.
Defined.

(* Require Import Vector Even. *)
(* Definition SS := S. *)
(* MetaCoq Run (TC <- Translate emptyTC "nat" ;; *)
(*                      TC <- Translate TC "even" ;; *)
(*                      tmDefinition "TC2" TC). *)

(* Inductive foo := *)
(* | bar : (nat -> foo) -> foo. *)
(* Definition bar' := bar. *)
(* MetaCoq Run (TranslateRec TC2 bar'). *)

Definition UIP := forall A (x y : A) (p q : x = y), p = q.

MetaCoq Run (TC <- TranslateRec TC UIP ;;
                     tmDefinition "eqTC" TC).

Definition eqᵗ_eq {A} x y
  : eqᵗ A x y -> x = y.
Proof.
  destruct 1; reflexivity.
Defined.

Definition eq_eqᵗ {A} x y
  : x = y -> eqᵗ A x y.
Proof.
  destruct 1; reflexivity.
Defined.

Definition isequiv_eqᵗ_eq {A} x y
  : IsEquiv (@eqᵗ_eq A x y).
Proof.
  unshelve eapply isequiv_adjointify.
  apply eq_eqᵗ.
  all: intros []; reflexivity.
Defined.

Theorem preserves_UIP : UIP -> UIPᵗ.
Proof.
  unfold UIP, UIPᵗ.
  intros H.
  tIntro A. tIntro x. tIntro y. tIntro p. tIntro q.
  cbn in *.
  apply eq_eqᵗ. refine (equiv_inj _ (H := isequiv_eqᵗ_eq _ _) _).
  apply H.
Defined.

Definition wFunext
  := forall A (B : A -> Type) (f g : forall x, B x), (forall x, f x = g x) -> f = g.

MetaCoq Run (TC <- TranslateRec eqTC (wFunext -> False) ;;
                     tmDefinition "eqTC'" TC ;;
                     Implement TC "notwFunext" (wFunext -> False)).
Next Obligation.
  tIntro H.
  tSpecialize H unit. tSpecialize H (fun _ => unit; true).
  tSpecialize H (fun x => x; true). tSpecialize H (fun x => x; false).
  tSpecialize H (fun x => eq_reflᵗ _ _; true).
  inversion H.
Defined.

Definition wUnivalence
  := forall A B, Equiv A B -> A = B.

MetaCoq Run (TC <- Translate eqTC' "idpath" ;;
                     TC <- ImplementExisting TC "paths_ind" ;;
                     tmDefinition "eqTC''" TC).
Next Obligation.
  tIntro A. tIntro a. tIntro P. tIntro t.
  tIntro y. tIntro p. destruct p. exact t.
Defined.

MetaCoq Run (TC <- TranslateRec eqTC'' wUnivalence ;;
                     tmDefinition "eqTC3" TC).

Theorem preserves_wUnivalence : wUnivalence -> wUnivalenceᵗ.
Proof.
  unfold wUnivalence, wUnivalenceᵗ.
  intros H.
  tIntro A. tIntro B. tIntro H.
  cbn in *.
  apply eq_eqᵗ. apply H0. destruct H as [[f bf] Hf]; cbn in *.
  exists f. destruct Hf as [[g bg] [s _] [r _] _]; cbn in *.
  unshelve eapply isequiv_adjointify. assumption.
  all: intro; apply eqᵗ_eq; auto.
Defined.

Definition bool_of_Equivᵗ {A B} (e : Equivᵗ A B) : bool.
  now destruct e as [[_ b] _].
Defined.

Definition UA := forall A B, IsEquiv (paths_ind A (fun B _ => Equiv A B) (equiv_idmap A) B).

MetaCoq Run (TC <- Translate eqTC3 "isequiv_idmap" ;;
                     TC <- Translate TC "equiv_idmap" ;;
                     TC <- Translate TC "UA" ;;
                     tmDefinition "eqTC4" TC).

Axiom fx : Funext.
Axiom ua : UA.

Lemma eqᵗ_unit_unit (e e' : eqᵗ Type unit unit) : e = e'.
  refine (equiv_inj (eqᵗ_eq _ _) _).
  - apply isequiv_eqᵗ_eq.
  - refine (equiv_inj _ (H:=ua _ _) _).
    apply path_equiv; cbn. apply fx.
    apply fx. intro; apply path_unit.
Defined.

MetaCoq Run (Implement eqTC4 "notUA" (UA -> False)).
Next Obligation.
  unfold UAᵗ; tIntro ua.
  tSpecialize ua unit.
  tSpecialize ua unit.
  destruct ua as [[g bg] H1 H2 _]; cbn -[paths_indᵗ] in *.
  simple refine (let e1 := BuildEquivᵗ unit unit (idmap; true) _ in _); cbn. {
    unshelve econstructor; cbn. exact (idmap; true).
    all: tIntro x; reflexivity. }
  simple refine (let e2 := BuildEquivᵗ unit unit (idmap; false) _ in _); cbn. {
    unshelve econstructor; cbn. exact (idmap; true).
    all: tIntro x; reflexivity. }
  assert (e1 = e2). {
    etransitivity. symmetry. eapply eqᵗ_eq.
    exact (π1 H1 e1).
    etransitivity. 2: eapply eqᵗ_eq; exact (π1 H1 e2).
    clearbody e1 e2; clear.
    assert (g e1 = g e2). apply eqᵗ_unit_unit.
    now rewrite X. }
  apply (f_equal bool_of_Equivᵗ) in X. cbn in X.
  inversion X.
Defined.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions Coq.Classes.Morphisms.
Require Import Fiat.Common.Telescope.Core.

Module Export Telescope.
  Definition flattenT_R_lift {X : Type} {t : Telescope} (P : forall A, relation A -> Prop)
             (R : relation X)
             (H : P _ R)
             (H_forall : forall A T (R' : forall a : A, relation (T a)),
                           (forall a : A, P _ (R' a))
                           -> P _ (forall_relation R'))
  : P _ (@flattenT_R_relation X R t).
  Proof.
    repeat intro; induction t; simpl in *.
    { assumption. }
    { eauto with nocore. }
  Defined.

  Global Instance flattenT_R_Reflexive {t X R} {_ : @Reflexive X R}
  : Reflexive (@flattenT_R_relation X R t)
    := flattenT_R_lift (@Reflexive) R _ _.
  Proof. lazy; eauto with nocore. Defined.

  Global Instance flattenT_R_Symmetric {t X R} {_ : @Symmetric X R}
  : Symmetric (@flattenT_R_relation X R t)
    := flattenT_R_lift (@Symmetric) R _ _.
  Proof. lazy; eauto with nocore. Defined.

  Global Instance flattenT_R_Transitive {t X R} {_ : @Transitive X R}
  : Transitive (@flattenT_R_relation X R t)
    := flattenT_R_lift (@Transitive) R _ _.
  Proof. lazy; eauto with nocore. Defined.

  Global Instance flattenT_R_relation_flip_impl_Proper {t X R}
         {H : Proper (Basics.flip R ==> R ==> Basics.flip Basics.impl)
                     R}
  : Proper (Basics.flip (flattenT_R_relation R) ==> flattenT_R_relation R ==> Basics.flip Basics.impl)
           (@flattenT_R_relation X R t)
    := @flattenT_R_lift X t (fun A R => Proper (Basics.flip R ==> R ==> Basics.flip Basics.impl) R) _ H _.
  Proof.
    unfold Proper, respectful, Basics.flip, Basics.impl, forall_relation in *; intros.
    eauto with nocore.
  Defined.

  Global Instance flattenT_eq_Reflexive {t : Telescope} {X : Type}
  : Reflexive (@flattenT_eq X t)
    := flattenT_R_Reflexive.

  Global Instance flattenT_eq_Symmetric {t : Telescope} {X : Type}
  : Symmetric (@flattenT_eq X t)
    := flattenT_R_Symmetric.

  Global Instance flattenT_eq_Transitive {t : Telescope} {X : Type}
  : Transitive (@flattenT_eq X t)
    := flattenT_R_Transitive.

  Global Instance flatten_forall_eq_relation_Reflexive {t P}
  : Reflexive (@flatten_forall_eq_relation t P).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ reflexivity | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_relation_Symmetric {t P}
  : Symmetric (@flatten_forall_eq_relation t P).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ symmetry; assumption | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_relation_Transitive {t P}
  : Transitive (@flatten_forall_eq_relation t P).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ etransitivity; eassumption | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_Reflexive {t P}
  : Reflexive (@flatten_forall_eq t P)
    := flatten_forall_eq_relation_Reflexive.

  Global Instance flatten_forall_eq_Symmetric {t P}
  : Symmetric (@flatten_forall_eq t P)
    := flatten_forall_eq_relation_Symmetric.

  Global Instance flatten_forall_eq_Transitive {t P}
  : Transitive (@flatten_forall_eq t P)
    := flatten_forall_eq_relation_Transitive.

  Global Instance flatten_forall_eq_relation_with_assumption_Reflexive {t P Q}
  : Reflexive (@flatten_forall_eq_relation_with_assumption t P Q).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ reflexivity | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_relation_with_assumption_Symmetric {t P Q}
  : Symmetric (@flatten_forall_eq_relation_with_assumption t P Q).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ symmetry; eauto with nocore | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_relation_with_assumption_Transitive {t P Q}
  : Transitive (@flatten_forall_eq_relation_with_assumption t P Q).
  Proof.
    hnf; induction t; simpl; unfold forall_relation; [ etransitivity; eauto with nocore | eauto with nocore ].
  Defined.

  Global Instance flatten_forall_eq_with_assumption_Reflexive {t P Q}
  : Reflexive (@flatten_forall_eq_with_assumption t P Q)
    := flatten_forall_eq_relation_with_assumption_Reflexive.

  Global Instance flatten_forall_eq_with_assumption_Symmetric {t P Q}
  : Symmetric (@flatten_forall_eq_with_assumption t P Q)
    := flatten_forall_eq_relation_with_assumption_Symmetric.

  Global Instance flatten_forall_eq_with_assumption_Transitive {t P Q}
  : Transitive (@flatten_forall_eq_with_assumption t P Q)
    := flatten_forall_eq_relation_with_assumption_Transitive.

  Lemma flatten_append_forall_Proper {B P Q}
  : forall f g,
      @flatten_forall_eq B P f g
      -> @flatten_append_forall B P Q f
      -> @flatten_append_forall B P Q g.
  Proof.
    induction B; simpl in *; eauto with nocore.
    intros; subst; assumption.
  Defined.

  Global Instance flattenT_unapply_Proper {t X}
  : Proper (pointwise_relation _ eq ==> flattenT_eq)
           (@flattenT_unapply t X).
  Proof.
    repeat intro; unfold pointwise_relation in *; induction t as [|?? IHt]; simpl in *;
    auto with nocore.
  Defined.

  Global Instance flattenT_apply_Proper {t X}
  : Proper (flattenT_eq ==> pointwise_relation _ eq)
           (@flattenT_apply t X).
  Proof.
    repeat intro; unfold pointwise_relation in *; induction t as [|?? IHt]; simpl in *;
    auto with nocore.
  Defined.

  Global Instance flatten_forall_unapply_Proper {t P}
  : Proper (forall_relation (fun _ => eq) ==> flatten_forall_eq)
           (@flatten_forall_unapply t P).
  Proof.
    repeat intro; unfold forall_relation in *; induction t as [|?? IHt]; simpl in *;
    auto with nocore.
  Defined.

  Global Instance flatten_forall_apply_Proper {t P}
  : Proper (flatten_forall_eq ==> forall_relation (fun _ => eq))
           (@flatten_forall_apply t P).
  Proof.
    repeat intro; unfold forall_relation in *; induction t as [|?? IHt]; simpl in *;
    auto with nocore.
  Defined.

  Global Instance flatten_forall_eq_rect_Proper {t P Q H}
  : Proper (flatten_forall_eq ==> flatten_forall_eq)
           (@flatten_forall_eq_rect t P Q H).
  Proof.
    repeat intro; unfold forall_relation in *; induction t as [|?? IHt]; simpl in *;
    auto with nocore;
    subst; simpl; reflexivity.
  Defined.
End Telescope.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import List.
Import ListNotations.
(* From RecordUpdate Require Import RecordSet. *)
(* Import RecordSetNotations. *)

Require Import theorem4.Base theorem4.Promising.

(* DRF-kernel constraint *)

Definition OwnershipMap := Address -> option TID.

Inductive rel_global_ownership : View -> OwnershipMap -> (View -> option Promise) -> OwnershipMap -> Prop :=
| GO_EMPTY : forall om lp, rel_global_ownership 0 om lp om
| GO_PULL : forall n om lp omr tid addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = None)
                (Hlp : lp (S n) = Some (PULL tid addr)),
                rel_global_ownership (S n) (update om addr (Some tid)) lp omr
| GO_PUSH : forall n om lp omr tid addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = Some tid)
                (Hlp : lp (S n) = Some (PUSH tid addr)),
                rel_global_ownership (S n) (update om addr None) lp omr
| GO_WRITE : forall n om lp omr tid val addr
                (Hlp : rel_global_ownership n om lp omr)
                (Hown : om addr = Some tid)
                (Hlp : lp (S n) = Some (WRITE tid val addr)),
                rel_global_ownership (S n) om lp omr
| GO_NONE : forall n om lp omr
                (Hlp : rel_global_ownership n om lp omr)
                (Hlp : lp (S n) = None),
                rel_global_ownership (S n) om lp omr.

(* No-barrier-misuse constraint *)

Record LocalOwnership := mkLocalOwnership{
    ownership_local : Address -> bool;
    lastbarrier_local : Address -> View
}.
(* )Instance etaLocalOwnership : Settable _ := settable! mkLocalOwnership <ownership_local; lastbarrier_local>.
 *)

Definition update_ownership_local (a : LocalOwnership) b :=
  mkLocalOwnership b (lastbarrier_local a).
Notation "a <|ownership_local := b |>" := (update_ownership_local a b) (at level 1).

Definition update_lastbarrier_local (a : LocalOwnership) b :=
  mkLocalOwnership (ownership_local a) b.
Notation "a <|lastbarrier_local := b |>" := (update_lastbarrier_local a b) (at level 1).
Definition initownership :=
    {|
        ownership_local := fun addr => false;
        lastbarrier_local := fun addr => 0
    |}.

Inductive rel_local_ownership : (View -> option Promise) -> list Event -> LocalOwnership -> Prop :=
| LO_EMPTY : forall promises, rel_local_ownership promises [] initownership
| LO_LOAD : forall promises le lo addr view reg
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true),
                rel_local_ownership promises ((LOAD addr view reg) :: le) lo
| LO_STORE : forall promises le lo addr view reg
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true),
                rel_local_ownership promises ((STORE addr view reg) :: le) lo
| LO_ACQ : forall promises le lo addr view
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = false)
                (Hview : lastbarrier_local lo addr <= view),
                rel_local_ownership promises ((ACQ view addr) :: le)
                (lo
                    <|ownership_local := update (ownership_local lo) addr true |>
                    <|lastbarrier_local := update (lastbarrier_local lo) addr view |>
                )
| LO_REL : forall promises le lo addr view
                (Hlo : rel_local_ownership promises le lo)
                (Hown : ownership_local lo addr = true)
                (Hview : lastbarrier_local lo addr <= view),
                rel_local_ownership promises ((REL view addr) :: le)
                (lo
                    <|ownership_local := update (ownership_local lo) addr false |>
                    <|lastbarrier_local := update (lastbarrier_local lo) addr view |>
                )
| LO_INTERNAL : forall promises le lo i
                (Hlo : rel_local_ownership promises le lo),
                rel_local_ownership promises ((INTERNAL i) :: le) lo
| LO_ORACLE : forall promises le lo reg val
                (Hlo : rel_local_ownership promises le lo),
                rel_local_ownership promises ((ORACLE reg val) :: le) lo.

Inductive DRF : Trace -> Prop :=
| DRF_TRACE : forall (t : Trace)  (n : View)
                (Hglobal : exists om : OwnershipMap, rel_global_ownership n om (promiselist t) (fun _ => None))
                (Hlocal : forall tid : TID, exists lo, rel_local_ownership (promiselist t) (executions t tid) lo),
                DRF t.