From Hammer Require Import Hammer.

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
From IntMap Require Import Map.
From IntMap Require Import Mapaxioms.
From IntMap Require Import Mapiter.
From IntMap Require Import Fset.
From IntMap Require Import Mapsubset.
Require Import List.
From IntMap Require Import Lsort.
Require Import Peano_dec.

Section MapCard.

Variables A B : Type.

Lemma MapCard_M0 : MapCard A (M0 A) = 0.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_M0".
trivial.
Qed.

Lemma MapCard_M1 : forall (a:ad) (y:A), MapCard A (M1 A a y) = 1.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_M1".
trivial.
Qed.

Lemma MapCard_is_O :
forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = None.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_is_O".
simple induction m. trivial.
intros a y H. discriminate H.
intros. simpl in H1. elim (plus_is_O _ _ H1). intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a).
case (Nbit0 a). apply H0. assumption.
apply H. assumption.
Qed.

Lemma MapCard_is_not_O :
forall (m:Map A) (a:ad) (y:A),
MapGet A m a = Some y -> {n : nat | MapCard A m = S n}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_is_not_O".
simple induction m. intros. discriminate H.
intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (N.eqb a a0)). intro H0. split with 0.
reflexivity.
intro H0. rewrite H0 in H. discriminate H.
intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H. elim (X0 (N.div2 a) y H). intros n H3.
simpl in |- *. rewrite H3. split with (MapCard A m0 + n).
rewrite <- (plus_Snm_nSm (MapCard A m0) n). reflexivity.
intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H. elim (X (N.div2 a) y H).
intros n H3. simpl in |- *. rewrite H3. split with (n + MapCard A m1). reflexivity.
Qed.

Lemma MapCard_is_one :
forall m:Map A,
MapCard A m = 1 -> {a : ad &  {y : A | MapGet A m a = Some y}}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_is_one".
simple induction m. intro. discriminate H.
intros a y H. split with a. split with y. apply M1_semantics_1.
intros. simpl in H. elim (plus_is_one (MapCard A m0) (MapCard A m1) H).
intro H2. elim H2. intros H3 H4. elim (X0 H4). intros a H5. split with (Ndouble_plus_one a).
rewrite (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
rewrite Ndouble_plus_one_div2. exact H5.
intro H2. elim H2. intros H3 H4. elim (X H3). intros a H5. split with (N.double a).
rewrite (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
rewrite Ndouble_div2. exact H5.
Qed.

Lemma MapCard_is_one_unique :
forall m:Map A,
MapCard A m = 1 ->
forall (a a':ad) (y y':A),
MapGet A m a = Some y ->
MapGet A m a' = Some y' -> a = a' /\ y = y'.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_is_one_unique".
simple induction m. intro. discriminate H.
intros. elim (sumbool_of_bool (N.eqb a a1)). intro H2. rewrite (Neqb_complete _ _ H2) in H0.
rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (N.eqb a a')).
intro H5. rewrite (Neqb_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1.
inversion H1. rewrite <- (Neqb_complete _ _ H2). rewrite <- (Neqb_complete _ _ H5).
rewrite <- H4. rewrite <- H6. split; reflexivity.
intro H5. rewrite (M1_semantics_2 A a a' a0 H5) in H1. discriminate H1.
intro H2. rewrite (M1_semantics_2 A a a1 a0 H2) in H0. discriminate H0.
intros. simpl in H1. elim (plus_is_one _ _ H1). intro H4. elim H4. intros.
rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (Nbit0 a)).
intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3).
intros. split. rewrite <- (Ndiv2_double_plus_one a H7).
rewrite <- (Ndiv2_double_plus_one a' H8). rewrite H9. reflexivity.
assumption.
intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (N.div2 a')) in H3.
discriminate H3.
intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (N.div2 a)) in H2.
discriminate H2.
intro H4. elim H4. intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2.
elim (sumbool_of_bool (Nbit0 a)). intro H7. rewrite H7 in H2.
rewrite (MapCard_is_O m1 H6 (N.div2 a)) in H2. discriminate H2.
intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3.
rewrite (MapCard_is_O m1 H6 (N.div2 a')) in H3. discriminate H3.
intro H8. rewrite H8 in H3. elim (H H5 _ _ _ _ H2 H3). intros. split.
rewrite <- (Ndiv2_double a H7). rewrite <- (Ndiv2_double a' H8).
rewrite H9. reflexivity.
assumption.
Qed.

Lemma length_as_fold :
forall (C:Type) (l:list C),
length l = fold_right (fun (_:C) (n:nat) => S n) 0 l.
Proof. hammer_hook "Mapcard" "Mapcard.length_as_fold".
simple induction l. reflexivity.
intros. simpl in |- *. rewrite H. reflexivity.
Qed.

Lemma length_as_fold_2 :
forall l:alist A,
length l =
fold_right (fun (r:ad * A) (n:nat) => let (a, y) := r in 1 + n) 0 l.
Proof. hammer_hook "Mapcard" "Mapcard.length_as_fold_2".
simple induction l. reflexivity.
intros. simpl in |- *. rewrite H. elim a; reflexivity.
Qed.

Lemma MapCard_as_Fold_1 :
forall (m:Map A) (pf:ad -> ad),
MapCard A m = MapFold1 A nat 0 plus (fun (_:ad) (_:A) => 1) pf m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_as_Fold_1".
simple induction m. trivial.
trivial.
intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (N.double a0))).
rewrite <- (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
Qed.

Lemma MapCard_as_Fold :
forall m:Map A,
MapCard A m = MapFold A nat 0 plus (fun (_:ad) (_:A) => 1) m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_as_Fold".
intro. exact (MapCard_as_Fold_1 m (fun a0:ad => a0)).
Qed.

Lemma MapCard_as_length :
forall m:Map A, MapCard A m = length (alist_of_Map A m).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_as_length".
intro. rewrite MapCard_as_Fold. rewrite length_as_fold_2.
apply MapFold_as_fold with
(op := plus) (neutral := 0) (f := fun (_:ad) (_:A) => 1). exact plus_assoc_reverse.
trivial.
intro. rewrite <- plus_n_O. reflexivity.
Qed.

Lemma MapCard_Put1_equals_2 :
forall (p:positive) (a a':ad) (y y':A),
MapCard A (MapPut1 A a y a' y' p) = 2.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put1_equals_2".
simple induction p. intros. simpl in |- *. case (Nbit0 a); reflexivity.
intros. simpl in |- *. case (Nbit0 a). exact (H (N.div2 a) (N.div2 a') y y').
simpl in |- *. rewrite <- plus_n_O. exact (H (N.div2 a) (N.div2 a') y y').
intros. simpl in |- *. case (Nbit0 a); reflexivity.
Qed.

Lemma MapCard_Put_sum :
forall (m m':Map A) (a:ad) (y:A) (n n':nat),
m' = MapPut A m a y ->
n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_sum".
simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. right.
rewrite H0. rewrite H1. reflexivity.
intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (N.discr (Nxor a a0)). intro H2.
elim H2. intros p H3. rewrite H3 in H. rewrite H in H1.
rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. simpl in H0. right.
rewrite H0. rewrite H1. reflexivity.
intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. simpl in H0. left.
rewrite H0. rewrite H1. reflexivity.
intros. simpl in H0. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H.
elim (sumbool_of_bool (Nbit0 a)). intro H4. rewrite H4 in H.
elim
(X0 (MapPut A m1 (N.div2 a) y) (N.div2 a) y (
MapCard A m1) (MapCard A (MapPut A m1 (N.div2 a) y)) (
refl_equal _) (refl_equal _) (refl_equal _)).
intro H5. rewrite H in H1. simpl in H1. rewrite H5 in H1. rewrite <- H0 in H1. left.
assumption.
intro H5. rewrite H in H1. simpl in H1. rewrite H5 in H1.
rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)) in H1.
simpl in H1. rewrite <- H0 in H1. right. assumption.
intro H4. rewrite H4 in H.
elim
(X (MapPut A m0 (N.div2 a) y) (N.div2 a) y (
MapCard A m0) (MapCard A (MapPut A m0 (N.div2 a) y)) (
refl_equal _) (refl_equal _) (refl_equal _)).
intro H5. rewrite H in H1. simpl in H1. rewrite H5 in H1. rewrite <- H0 in H1.
left. assumption.
intro H5. rewrite H in H1. simpl in H1. rewrite H5 in H1. simpl in H1. rewrite <- H0 in H1.
right. assumption.
Qed.

Lemma MapCard_Put_lb :
forall (m:Map A) (a:ad) (y:A), MapCard A (MapPut A m a y) >= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_lb".
unfold ge in |- *. intros.
elim
(MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
(MapCard A (MapPut A m a y)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H. rewrite H. apply le_n.
intro H. rewrite H. apply le_n_Sn.
Qed.

Lemma MapCard_Put_ub :
forall (m:Map A) (a:ad) (y:A),
MapCard A (MapPut A m a y) <= S (MapCard A m).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_ub".
intros.
elim
(MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
(MapCard A (MapPut A m a y)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H. rewrite H. apply le_n_Sn.
intro H. rewrite H. apply le_n.
Qed.

Lemma MapCard_Put_1 :
forall (m:Map A) (a:ad) (y:A),
MapCard A (MapPut A m a y) = MapCard A m ->
{y : A | MapGet A m a = Some y}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_1".
simple induction m. intros. discriminate H.
intros a y a0 y0 H. simpl in H. elim (N.discr (Nxor a a0)). intro H0. elim H0.
intros p H1. rewrite H1 in H. rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H.
discriminate H.
intro H0. rewrite H0 in H. rewrite (Nxor_eq _ _ H0). split with y. apply M1_semantics_1.
intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H. elim (sumbool_of_bool (Nbit0 a)).
intro H2. rewrite H2 in H. simpl in H. elim (X0 (N.div2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H)).
intros y0 H3. split with y0. rewrite <- H3. exact (MapGet_M2_bit_0_1 A a H2 m0 m1).
intro H2. rewrite H2 in H. simpl in H.
rewrite
(plus_comm (MapCard A (MapPut A m0 (N.div2 a) y)) (MapCard A m1))
in H.
rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H.
elim (X (N.div2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H)). intros y0 H3. split with y0.
rewrite <- H3. exact (MapGet_M2_bit_0_0 A a H2 m0 m1).
Qed.

Lemma MapCard_Put_2 :
forall (m:Map A) (a:ad) (y:A),
MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = None.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_2".
simple induction m. trivial.
intros. simpl in H. elim (sumbool_of_bool (N.eqb a a1)). intro H0.
rewrite (Neqb_complete _ _ H0) in H. rewrite (Nxor_nilpotent a1) in H. discriminate H.
intro H0. exact (M1_semantics_2 A a a1 a0 H0).
intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (N.div2 a) y).
apply (fun n m p:nat => plus_reg_l m p n) with (n := MapCard A m0).
rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). simpl in H1. simpl in |- *. rewrite <- H1.
clear H1.
induction a. discriminate H2.
induction p. reflexivity.
discriminate H2.
reflexivity.
intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (N.div2 a) y).
cut
(MapCard A (MapPut A m0 (N.div2 a) y) + MapCard A m1 =
S (MapCard A m0) + MapCard A m1).
intro. rewrite (plus_comm (MapCard A (MapPut A m0 (N.div2 a) y)) (MapCard A m1))
in H3.
rewrite (plus_comm (S (MapCard A m0)) (MapCard A m1)) in H3. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H3).
simpl in |- *. simpl in H1. rewrite <- H1. induction a. trivial.
induction p. discriminate H2.
reflexivity.
discriminate H2.
Qed.

Lemma MapCard_Put_1_conv :
forall (m:Map A) (a:ad) (y y':A),
MapGet A m a = Some y -> MapCard A (MapPut A m a y') = MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_1_conv".
intros.
elim
(MapCard_Put_sum m (MapPut A m a y') a y' (MapCard A m)
(MapCard A (MapPut A m a y')) (refl_equal _) (
refl_equal _) (refl_equal _)).
trivial.
intro H0. rewrite (MapCard_Put_2 m a y' H0) in H. discriminate H.
Qed.

Lemma MapCard_Put_2_conv :
forall (m:Map A) (a:ad) (y:A),
MapGet A m a = None -> MapCard A (MapPut A m a y) = S (MapCard A m).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_2_conv".
intros.
elim
(MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
(MapCard A (MapPut A m a y)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H0. elim (MapCard_Put_1 m a y H0). intros y' H1. rewrite H1 in H. discriminate H.
trivial.
Qed.

Lemma MapCard_ext :
forall m m':Map A,
eqm A (MapGet A m) (MapGet A m') -> MapCard A m = MapCard A m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_ext".
unfold eqm in |- *. intros. rewrite (MapCard_as_length m). rewrite (MapCard_as_length m').
rewrite (alist_canonical A (alist_of_Map A m) (alist_of_Map A m')). reflexivity.
unfold eqm in |- *. intro. rewrite (Map_of_alist_semantics A (alist_of_Map A m) a).
rewrite (Map_of_alist_semantics A (alist_of_Map A m') a). rewrite (Map_of_alist_of_Map A m' a).
rewrite (Map_of_alist_of_Map A m a). exact (H a).
apply alist_of_Map_sorts2.
apply alist_of_Map_sorts2.
Qed.

Lemma MapCard_Dom : forall m:Map A, MapCard A m = MapCard unit (MapDom A m).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Dom".
simple induction m; trivial. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma MapCard_Dom_Put_behind :
forall (m:Map A) (a:ad) (y:A),
MapDom A (MapPut_behind A m a y) = MapDom A (MapPut A m a y).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Dom_Put_behind".
simple induction m. trivial.
intros a y a0 y0. simpl in |- *. elim (N.discr (Nxor a a0)). intro H. elim H.
intros p H0. rewrite H0. reflexivity.
intro H. rewrite H. rewrite (Nxor_eq _ _ H). reflexivity.
intros. simpl in |- *. elim (N.discr a). intro H1. elim H1. intros p H2. rewrite H2. case p.
intro p0. simpl in |- *. rewrite H0. reflexivity.
intro p0. simpl in |- *. rewrite H. reflexivity.
simpl in |- *. rewrite H0. reflexivity.
intro H1. rewrite H1. simpl in |- *. rewrite H. reflexivity.
Qed.

Lemma MapCard_Put_behind_Put :
forall (m:Map A) (a:ad) (y:A),
MapCard A (MapPut_behind A m a y) = MapCard A (MapPut A m a y).
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_behind_Put".
intros. rewrite MapCard_Dom. rewrite MapCard_Dom. rewrite MapCard_Dom_Put_behind.
reflexivity.
Qed.

Lemma MapCard_Put_behind_sum :
forall (m m':Map A) (a:ad) (y:A) (n n':nat),
m' = MapPut_behind A m a y ->
n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Put_behind_sum".
intros. apply (MapCard_Put_sum m (MapPut A m a y) a y n n'); trivial.
rewrite <- MapCard_Put_behind_Put. rewrite <- H. assumption.
Qed.

Lemma MapCard_makeM2 :
forall m m':Map A, MapCard A (makeM2 A m m') = MapCard A m + MapCard A m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_makeM2".
intros. rewrite (MapCard_ext _ _ (makeM2_M2 A m m')). reflexivity.
Qed.

Lemma MapCard_Remove_sum :
forall (m m':Map A) (a:ad) (n n':nat),
m' = MapRemove A m a ->
n = MapCard A m -> n' = MapCard A m' -> {n = n'} + {n = S n'}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_sum".
simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
simpl in |- *. intros. elim (sumbool_of_bool (N.eqb a a1)). intro H2. rewrite H2 in H.
rewrite H in H1. simpl in H1. right. rewrite H1. assumption.
intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
intros. simpl in H1. simpl in H. elim (sumbool_of_bool (Nbit0 a)). intro H4.
rewrite H4 in H. rewrite H in H1.
rewrite (MapCard_makeM2 m0 (MapRemove A m1 (N.div2 a))) in H1.
elim
(X0 (MapRemove A m1 (N.div2 a)) (N.div2 a) (
MapCard A m1) (MapCard A (MapRemove A m1 (N.div2 a)))
(refl_equal _) (refl_equal _) (refl_equal _)).
simpl in H0;  intro H5. rewrite H5 in H0. left. rewrite H1. exact H0.
simpl in H0; intro H5. rewrite H5 in H0.
rewrite <-
(plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (N.div2 a))))
in H0.
right. rewrite H1. exact H0.
intro H4. rewrite H4 in H. rewrite H in H1.
rewrite (MapCard_makeM2 (MapRemove A m0 (N.div2 a)) m1) in H1.
elim
(X (MapRemove A m0 (N.div2 a)) (N.div2 a) (
MapCard A m0) (MapCard A (MapRemove A m0 (N.div2 a)))
(refl_equal _) (refl_equal _) (refl_equal _)).
simpl in H0; intro H5. rewrite H5 in H0. left. rewrite H1. exact H0.
simpl in H0; intro H5. rewrite H5 in H0. right. rewrite H1. exact H0.
Qed.

Lemma MapCard_Remove_ub :
forall (m:Map A) (a:ad), MapCard A (MapRemove A m a) <= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_ub".
intros.
elim
(MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
(MapCard A (MapRemove A m a)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H. rewrite H. apply le_n.
intro H. rewrite H. apply le_n_Sn.
Qed.

Lemma MapCard_Remove_lb :
forall (m:Map A) (a:ad), S (MapCard A (MapRemove A m a)) >= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_lb".
unfold ge in |- *. intros.
elim
(MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
(MapCard A (MapRemove A m a)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H. rewrite H. apply le_n_Sn.
intro H. rewrite H. apply le_n.
Qed.

Lemma MapCard_Remove_1 :
forall (m:Map A) (a:ad),
MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = None.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_1".
simple induction m. trivial.
simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (N.eqb a a0)). intro H0.
rewrite H0 in H. discriminate H.
intro H0. rewrite H0. reflexivity.
intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1.
rewrite (MapCard_makeM2 m0 (MapRemove A m1 (N.div2 a))) in H1.
rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
intro H2. rewrite H2 in H1.
rewrite (MapCard_makeM2 (MapRemove A m0 (N.div2 a)) m1) in H1.
rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H.
rewrite
(plus_comm (MapCard A (MapRemove A m0 (N.div2 a))) (MapCard A m1))
in H1.
rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
Qed.

Lemma MapCard_Remove_2 :
forall (m:Map A) (a:ad),
S (MapCard A (MapRemove A m a)) = MapCard A m ->
{y : A | MapGet A m a = Some y}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_2".
simple induction m. intros. discriminate H.
intros a y a0 H. simpl in H. elim (sumbool_of_bool (N.eqb a a0)). intro H0.
rewrite (Neqb_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y).
intro H0. rewrite H0 in H. discriminate H.
intros. simpl in H. elim (sumbool_of_bool (Nbit0 a)). intro H0. rewrite H0 in H.
rewrite (MapCard_makeM2 m0 (MapRemove A m1 (N.div2 a))) in H.
rewrite (MapGet_M2_bit_0_1 A a H0 m0 m1). apply X0.
change
(S (MapCard A m0) + MapCard A (MapRemove A m1 (N.div2 a)) =
MapCard A m0 + MapCard A m1) in H.
rewrite
(plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (N.div2 a))))
in H.
exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H).
intro H2. rewrite H2 in H. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply X.
rewrite (MapCard_makeM2 (MapRemove A m0 (N.div2 a)) m1) in H.
change
(S (MapCard A (MapRemove A m0 (N.div2 a))) + MapCard A m1 =
MapCard A m0 + MapCard A m1) in H.
rewrite
(plus_comm (S (MapCard A (MapRemove A m0 (N.div2 a)))) (MapCard A m1))
in H.
rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H).
Qed.

Lemma MapCard_Remove_1_conv :
forall (m:Map A) (a:ad),
MapGet A m a = None -> MapCard A (MapRemove A m a) = MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_1_conv".
intros.
elim
(MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
(MapCard A (MapRemove A m a)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H0. rewrite H0. reflexivity.
intro H0. elim (MapCard_Remove_2 m a (sym_eq H0)). intros y H1. rewrite H1 in H.
discriminate H.
Qed.

Lemma MapCard_Remove_2_conv :
forall (m:Map A) (a:ad) (y:A),
MapGet A m a = Some y -> S (MapCard A (MapRemove A m a)) = MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_Remove_2_conv".
intros.
elim
(MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
(MapCard A (MapRemove A m a)) (refl_equal _) (
refl_equal _) (refl_equal _)).
intro H0. rewrite (MapCard_Remove_1 m a (sym_eq H0)) in H. discriminate H.
intro H0. rewrite H0. reflexivity.
Qed.

Lemma MapMerge_Restr_Card :
forall m m':Map A,
MapCard A m + MapCard A m' =
MapCard A (MapMerge A m m') + MapCard A (MapDomRestrTo A A m m').
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_Restr_Card".
simple induction m. simpl in |- *. intro. apply plus_n_O.
simpl in |- *. intros a y m'. elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y0 H0.
rewrite H0. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_1_conv m' a y0 y H0).
simpl in |- *. rewrite <- plus_Snm_nSm. apply plus_n_O.
intro H. rewrite H. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_2_conv m' a y H).
apply plus_n_O.
intros.
change
(MapCard A m0 + MapCard A m1 + MapCard A m' =
MapCard A (MapMerge A (M2 A m0 m1) m') +
MapCard A (MapDomRestrTo A A (M2 A m0 m1) m'))
in |- *.
elim m'. reflexivity.
intros a y. unfold MapMerge in |- *. unfold MapDomRestrTo in |- *.
elim (option_sum A (MapGet A (M2 A m0 m1) a)). intro H1. elim H1. intros y0 H2. rewrite H2.
rewrite (MapCard_Put_1_conv (M2 A m0 m1) a y0 y H2). reflexivity.
intro H1. rewrite H1. rewrite (MapCard_Put_2_conv (M2 A m0 m1) a y H1). simpl in |- *.
rewrite <- (plus_Snm_nSm (MapCard A m0 + MapCard A m1) 0). reflexivity.
intros. simpl in |- *.
rewrite
(plus_permute_2_in_4 (MapCard A m0) (MapCard A m1) (
MapCard A m2) (MapCard A m3)).
rewrite (H m2). rewrite (H0 m3).
rewrite
(MapCard_makeM2 (MapDomRestrTo A A m0 m2) (MapDomRestrTo A A m1 m3))
.
apply plus_permute_2_in_4.
Qed.

Lemma MapMerge_disjoint_Card :
forall m m':Map A,
MapDisjoint A A m m' ->
MapCard A (MapMerge A m m') = MapCard A m + MapCard A m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_disjoint_Card".
intros. rewrite (MapMerge_Restr_Card m m').
rewrite (MapCard_ext _ _ (MapDisjoint_imp_2 _ _ _ _ H)). apply plus_n_O.
Qed.

Lemma MapSplit_Card :
forall (m:Map A) (m':Map B),
MapCard A m =
MapCard A (MapDomRestrTo A B m m') + MapCard A (MapDomRestrBy A B m m').
Proof. hammer_hook "Mapcard" "Mapcard.MapSplit_Card".
intros. rewrite (MapCard_ext _ _ (MapDom_Split_1 A B m m')). apply MapMerge_disjoint_Card.
apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. apply MapDom_Split_3.
Qed.

Lemma MapMerge_Card_ub :
forall m m':Map A,
MapCard A (MapMerge A m m') <= MapCard A m + MapCard A m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_Card_ub".
intros. rewrite MapMerge_Restr_Card. apply le_plus_l.
Qed.

Lemma MapDomRestrTo_Card_ub_l :
forall (m:Map A) (m':Map B),
MapCard A (MapDomRestrTo A B m m') <= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapDomRestrTo_Card_ub_l".
intros. rewrite (MapSplit_Card m m'). apply le_plus_l.
Qed.

Lemma MapDomRestrBy_Card_ub_l :
forall (m:Map A) (m':Map B),
MapCard A (MapDomRestrBy A B m m') <= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapDomRestrBy_Card_ub_l".
intros. rewrite (MapSplit_Card m m'). apply le_plus_r.
Qed.

Lemma MapMerge_Card_disjoint :
forall m m':Map A,
MapCard A (MapMerge A m m') = MapCard A m + MapCard A m' ->
MapDisjoint A A m m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_Card_disjoint".
simple induction m. intros. apply Map_M0_disjoint.
simpl in |- *. intros. rewrite (MapCard_Put_behind_Put m' a a0) in H. unfold MapDisjoint, in_dom in |- *.
simpl in |- *. intros. elim (sumbool_of_bool (N.eqb a a1)). intro H2.
rewrite (Neqb_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1.
discriminate H1.
intro H2. rewrite H2 in H0. discriminate H0.
simple induction m'. intros. apply Map_disjoint_M0.
intros a y H1. rewrite <- (MapCard_ext _ _ (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1.
unfold MapCard at 3 in H1. rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) 0) in H1.
rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. unfold MapDisjoint, in_dom in |- *.
unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (N.eqb a a0)). intro H4.
rewrite <- (Neqb_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2.
discriminate H2.
intro H4. rewrite H4 in H3. discriminate H3.
intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H6.
unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := N.div2 a). apply le_antisym.
apply MapMerge_Card_ub.
apply (fun p n m:nat => plus_le_reg_l n m p) with
(p := MapCard A m0 + MapCard A m2).
rewrite
(plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (
MapCard A m1) (MapCard A m3)).
change
(MapCard A (M2 A (MapMerge A m0 m2) (MapMerge A m1 m3)) =
MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3))
in H3.
rewrite <- H3. simpl in |- *. apply plus_le_compat_r. apply MapMerge_Card_ub.
elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m0 m1) in H7.
unfold in_dom in |- *. rewrite H7. reflexivity.
elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m2 m3) in H7.
unfold in_dom in |- *. rewrite H7. reflexivity.
intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := N.div2 a). apply le_antisym.
apply MapMerge_Card_ub.
apply (fun p n m:nat => plus_le_reg_l n m p) with
(p := MapCard A m1 + MapCard A m3).
rewrite
(plus_comm (MapCard A m1 + MapCard A m3) (MapCard A m0 + MapCard A m2))
.
rewrite
(plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (
MapCard A m1) (MapCard A m3)).
rewrite
(plus_comm (MapCard A m1 + MapCard A m3) (MapCard A (MapMerge A m0 m2)))
.
change
(MapCard A (MapMerge A m0 m2) + MapCard A (MapMerge A m1 m3) =
MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3))
in H3.
rewrite <- H3. apply plus_le_compat_l. apply MapMerge_Card_ub.
elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m0 m1) in H7.
unfold in_dom in |- *. rewrite H7. reflexivity.
elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m2 m3) in H7.
unfold in_dom in |- *. rewrite H7. reflexivity.
Qed.

Lemma MapCard_is_Sn :
forall (m:Map A) (n:nat),
MapCard _ m = S n -> {a : ad | in_dom _ a m = true}.
Proof. hammer_hook "Mapcard" "Mapcard.MapCard_is_Sn".
simple induction m. intros. discriminate H.
intros a y n H. split with a. unfold in_dom in |- *. rewrite (M1_semantics_1 _ a y). reflexivity.
intros. simpl in H1. elim (O_or_S (MapCard _ m0)). intro H2. elim H2. intros m2 H3.
elim (H _ (sym_eq H3)). intros a H4. split with (N.double a). unfold in_dom in |- *.
rewrite (MapGet_M2_bit_0_0 A (N.double a) (Ndouble_bit0 a) m0 m1).
rewrite (Ndouble_div2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity.
intro H2. rewrite <- H2 in H1. simpl in H1. elim (H0 _ H1). intros a H3.
split with (Ndouble_plus_one a). unfold in_dom in |- *.
rewrite
(MapGet_M2_bit_0_1 A (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
m0 m1).
rewrite (Ndouble_plus_one_div2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
reflexivity.
Qed.

End MapCard.

Section MapCard2.

Variables A B : Type.

Lemma MapSubset_card_eq_1 :
forall (n:nat) (m:Map A) (m':Map B),
MapSubset _ _ m m' ->
MapCard _ m = n -> MapCard _ m' = n -> MapSubset _ _ m' m.
Proof. hammer_hook "Mapcard" "Mapcard.MapSubset_card_eq_1".
simple induction n. intros. unfold MapSubset, in_dom in |- *. intro. rewrite (MapCard_is_O _ m H0 a).
rewrite (MapCard_is_O _ m' H1 a). intro H2. discriminate H2.
intros. elim (MapCard_is_Sn A m n0 H1). intros a H3. elim (in_dom_some _ _ _ H3).
intros y H4. elim (in_dom_some _ _ _ (H0 _ H3)). intros y' H6.
cut (eqmap _ (MapPut _ (MapRemove _ m a) a y) m). intro.
cut (eqmap _ (MapPut _ (MapRemove _ m' a) a y') m'). intro.
apply MapSubset_ext with
(m0 := MapPut _ (MapRemove _ m' a) a y')
(m2 := MapPut _ (MapRemove _ m a) a y).
assumption.
assumption.
apply MapSubset_Put_mono. apply H. apply MapSubset_Remove_mono. assumption.
rewrite <- (MapCard_Remove_2_conv _ m a y H4) in H1. inversion_clear H1. reflexivity.
rewrite <- (MapCard_Remove_2_conv _ m' a y' H6) in H2. inversion_clear H2. reflexivity.
unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove B m' a) a y' a0).
elim (sumbool_of_bool (N.eqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7).
apply sym_eq. assumption.
intro H7. rewrite H7. rewrite (MapRemove_semantics _ m' a a0). rewrite H7. reflexivity.
unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove A m a) a y a0).
elim (sumbool_of_bool (N.eqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7).
apply sym_eq. assumption.
intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity.
Qed.

Lemma MapDomRestrTo_Card_ub_r :
forall (m:Map A) (m':Map B),
MapCard A (MapDomRestrTo A B m m') <= MapCard B m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapDomRestrTo_Card_ub_r".
simple induction m. intro. simpl in |- *. apply le_O_n.
intros a y m'. simpl in |- *. elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y0 H0.
rewrite H0. elim (MapCard_is_not_O B m' a y0 H0). intros n H1. rewrite H1. simpl in |- *.
apply le_n_S. apply le_O_n.
intro H. rewrite H. simpl in |- *. apply le_O_n.
simple induction m'. simpl in |- *. apply le_O_n.

intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *.
intro. simpl in |- *. apply le_n.
apply le_O_n.
intros. simpl in |- *. rewrite
(MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3))
.
apply plus_le_compat. apply H.
apply H0.
Qed.

End MapCard2.

Section MapCard3.

Variables A B : Type.

Lemma MapMerge_Card_lb_l :
forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_Card_lb_l".
unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m')).
rewrite (plus_comm (MapCard A m') (MapCard A m)).
rewrite (plus_comm (MapCard A m') (MapCard A (MapMerge A m m'))).
rewrite (MapMerge_Restr_Card A m m'). apply plus_le_compat_l. apply MapDomRestrTo_Card_ub_r.
Qed.

Lemma MapMerge_Card_lb_r :
forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapMerge_Card_lb_r".
unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m)). rewrite (MapMerge_Restr_Card A m m').
rewrite
(plus_comm (MapCard A (MapMerge A m m'))
(MapCard A (MapDomRestrTo A A m m'))).
apply plus_le_compat_r. apply MapDomRestrTo_Card_ub_l.
Qed.

Lemma MapDomRestrBy_Card_lb :
forall (m:Map A) (m':Map B),
MapCard B m' + MapCard A (MapDomRestrBy A B m m') >= MapCard A m.
Proof. hammer_hook "Mapcard" "Mapcard.MapDomRestrBy_Card_lb".
unfold ge in |- *. intros. rewrite (MapSplit_Card A B m m'). apply plus_le_compat_r.
apply MapDomRestrTo_Card_ub_r.
Qed.

Lemma MapSubset_Card_le :
forall (m:Map A) (m':Map B),
MapSubset A B m m' -> MapCard A m <= MapCard B m'.
Proof. hammer_hook "Mapcard" "Mapcard.MapSubset_Card_le".
intros. apply le_trans with (m := MapCard B m' + MapCard A (MapDomRestrBy A B m m')).
exact (MapDomRestrBy_Card_lb m m').
rewrite (MapCard_ext _ _ _ (MapSubset_imp_2 _ _ _ _ H)). simpl in |- *. rewrite <- plus_n_O.
apply le_n.
Qed.

Lemma MapSubset_card_eq :
forall (m:Map A) (m':Map B),
MapSubset _ _ m m' ->
MapCard _ m' <= MapCard _ m -> eqmap _ (MapDom _ m) (MapDom _ m').
Proof. hammer_hook "Mapcard" "Mapcard.MapSubset_card_eq".
intros. apply MapSubset_antisym. assumption.
cut (MapCard B m' = MapCard A m). intro. apply (MapSubset_card_eq_1 A B (MapCard A m)).
assumption.
reflexivity.
assumption.
apply le_antisym. assumption.
apply MapSubset_Card_le. assumption.
Qed.

End MapCard3.


(************************************************************
* Lambda-calculus with exceptions,                          *
* Syntax                                                    *
*************************************************************)

Set Implicit Arguments.
Require Export Common.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Syntax *)

(** Grammar of values and terms *)

Inductive val : Type :=
  | val_int : int -> val
  | val_clo : var -> trm -> val
  | val_err : val

with trm : Type :=
  | trm_val : val -> trm
  | trm_var : var -> trm
  | trm_abs : var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_try : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_rand : trm.

Coercion trm_val : val >-> trm.

(** Substitution *)

Fixpoint subst (x:var) (v:val) (t:trm) : trm :=
  let s := subst x v in
  match t with
  | trm_val v => t
  | trm_var y => If x = y then trm_val v else t
  | trm_abs y t3 => trm_abs y (If x = y then t3 else s t3)
  | trm_app t1 t2 => trm_app (s t1) (s t2)
  | trm_try t1 t2 => trm_try (s t1) (s t2)
  | trm_raise t1 => trm_raise (s t1)
  | trm_rand => t
  end.

(************************************************************)
(* ** Definition shared by the semantics *)

(** If [ParamDeterministic], then [rand] always reduces to zero,
    otherwise it non-deterministically reduces to any number *)

Parameter ParamDeterministic : Prop.

(** Assuming a deterministic semantics *)

Module AssumeDeterministic.
Parameter Deterministic : ParamDeterministic = True.
End AssumeDeterministic.

(** Grammar of behaviors without errors *)

Module BehaviorsWithoutErrors.

Inductive beh :=
  | beh_ret : val -> beh
  | beh_exn : val -> beh.

Coercion beh_ret : val >-> beh.

End BehaviorsWithoutErrors.

(** Grammar of behaviors, including errors *)

Module BehaviorsWithErrors.

Inductive beh :=
  | beh_ret : val -> beh
  | beh_exn : val -> beh
  | beh_err : beh.

Coercion beh_ret : val >-> beh.

End BehaviorsWithErrors.


From RDT Require Export framework.
Require Import Nat.
Require Import Relations.
Require Import Ensembles.

Set Implicit Arguments.

Module Causal_Consistency.

Module G_CC <: Ord_Gua.

Definition ordering_guarantee (h: Event_structure) (w: Witness): Prop :=
  causality h w.

End G_CC.

Module EPick.
Parameter pick : set Event -> Event.
Axiom pick_singleton :
  forall e, pick (Singleton _ e) = e.
Axiom pick_in :
  forall s, s (pick s).
End EPick.

(*
Parameter e_v : Event.

Definition pick_last (s: set Event) (ar: Rar) :=
  EPick.pick (fun w => (~(exists w, ar e_v w) /\ w = e_v) \/
                        ((exists w, s w /\ ar e_v w) /\ ar e_v w /\
                          ~(exists w', s w' /\ ar w' w))).
*)

Module Reg <: RDT.

Definition data_type := 1.
Definition Ival_type := nat.
Definition Rval_type := nat.
Definition Op_type := nat.

Definition event_type_map := Id -> Op_type.
Definition event_input_map := Id -> Ival_type.
Definition event_rval_map := Id -> option Rval_type.

Definition latest_write (w: Witness): set Event :=
  fun x => ~(exists e, (ar w) x e).

Definition writes (s: set Event) (t: event_type_map): set Event :=
  fun x => s x /\ ((t x.(id))=1).

Definition pick_last (s: set Event) (ar: Rar) :=
  EPick.pick (fun x => s x /\ ~(exists e, s e /\ ar x e)).

(** ** s: visible events of e*)
Definition Fun (s: set Event) (w: Witness) (e: Event)
            (t: event_type_map)(input: event_input_map) (rval: event_rval_map): option Rval_type :=
  match eqb (t e.(id)) 1 with
  | true => None (*write*)
  | false => rval (id (pick_last (writes s t) w.(ar)))
  end.

End Reg.

Import G_CC.
Import Reg.

Module CC_Model := CModel Reg G_CC.

End Causal_Consistency.


Require Import List.
Import ListNotations.

Require Export SystemFR.ComputableEquality.
Require Export SystemFR.TypedEquality.

Opaque reducible_values.

Lemma computable_equality_typed_equality:
  forall ρ T v1 v2,
    [ ρ ⊨ v1 ≡ v2 : T ] ->
    computable_equality ρ T ->
    wf T 0 ->
    pfv T term_var = nil ->
    valid_interpretation ρ ->
    cbv_value v1 ->
    cbv_value v2 ->
    [ v1 ≡ v2 ].
Proof.
  unfold computable_equality, computable_equality_with, equivalent_at;
    repeat step.

  unshelve epose proof
    (H8 (notype_lambda (app (app f_eq v1) (lvar 0 term_var))) _ _ _ _);
    repeat step || apply reducible_lambda || open_none;
    t_closer.

  - apply reducible_app2 with T;
      repeat step;
      eauto using reducible_value_expr.
    apply reducible_app2 with T;
      repeat step.

  - apply_any; steps; eauto using reducible_expr_value.
    apply equivalent_star_true with (app (app f_eq v1) v1).

    + eapply equivalent_square; eauto.
      * apply equivalent_star; repeat step || list_utils;
        eauto with erased wf fv.
        apply star_one.
        eapply scbv_step_same; eauto with smallstep; repeat step || open_none.
      * apply equivalent_star; repeat step || list_utils;
        eauto with erased wf fv.
        apply star_one.
        eapply scbv_step_same; eauto with smallstep; repeat step || open_none.

    + apply_any; eauto using reducible_expr_value;
        eauto using equivalent_refl with erased wf fv.
Qed.


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Proofs                     *
* Arthur Charguéraud, March 2007, Coq v8.1                                 *
***************************************************************************)

Set Implicit Arguments.
Require Import List Metatheory
  ML_Core_Definitions
  ML_Core_Infrastructure.

(* ********************************************************************** *)
(** Typing schemes for expressions *)

Definition has_scheme_vars L E t M := forall Xs,
  fresh L (sch_arity M) Xs ->
  E |= t ~: (M ^ Xs).

Definition has_scheme E t M := forall Vs,
  types (sch_arity M) Vs ->
  E |= t ~: (M ^^ Vs).

(* ********************************************************************** *)
(** Type substitution preserves typing *)

Lemma typing_typ_subst : forall F Z U E t T,
  Z \notin (env_fv E) ->
  type U ->
  E & F |= t ~: T ->
  E & (map (sch_subst Z U) F) |= t ~: (typ_subst Z U T).
Proof.
  introv. intros WVs Dis Typ. gen_eq (E & F) as G. gen F.
  induction Typ; introv EQ; subst; simpls typ_subst.
  rewrite~ sch_subst_open. apply* typing_var.
    binds_cases H0.
      apply* binds_concat_fresh.
       rewrite* sch_subst_fresh. use (fv_in_spec sch_fv B).
      auto*.
    rewrite~ sch_subst_arity. apply* typ_subst_type_list.
  apply_fresh* typing_abs as y.
   rewrite sch_subst_fold.
   apply_ih_map_bind* H1.
  apply_fresh* (@typing_let (sch_subst Z U M) (L1 \u {{Z}})) as y.
   simpl. intros Ys Fr.
   rewrite* <- sch_subst_open_vars.
   apply_ih_map_bind* H2.
  auto*.
Qed.

(* ********************************************************************** *)
(** Iterated type substitution preserves typing *)

Lemma typing_typ_substs : forall Zs Us E t T,
  fresh (env_fv E) (length Zs) Zs ->
  types (length Zs) Us ->
  E |= t ~: T ->
  E |= t ~: (typ_substs Zs Us T).
Proof.
  induction Zs; destruct Us; simpl; introv Fr WU Tt;
   destruct Fr; inversions WU;
   simpls; try solve [ auto | contradictions* ].
  inversions H2. inversions H1. clear H2 H1.
  apply* IHZs. apply_empty* typing_typ_subst.
Qed.

(* ********************************************************************** *)
(** Type schemes of terms can be instanciated *)

Lemma has_scheme_from_vars : forall L E t M,
  has_scheme_vars L E t M ->
  has_scheme E t M.
Proof.
  intros L E t [n T] H Vs TV. unfold sch_open. simpls.
  pick_freshes n Xs.
  rewrite (fresh_length _ _ _ Fr) in TV, H.
  rewrite~ (@typ_substs_intro Xs Vs T).
  unfolds has_scheme_vars sch_open_vars. simpls.
  apply* typing_typ_substs.
Qed.

(* ********************************************************************** *)
(** A term that has type T has type scheme "forall(no_var).T" *)

Lemma has_scheme_from_typ : forall E t T,
  E |= t ~: T -> has_scheme E t (Sch 0 T).
Proof.
  introz. unfold sch_open. simpls.
  rewrite* <- typ_open_type.
Qed.

(* ********************************************************************** *)
(** Typing is preserved by weakening *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H1.
  apply_fresh* (@typing_let M L1) as y. apply_ih_bind* H2.
  auto*.
Qed.

(* ********************************************************************** *)
(** Typing is preserved by term substitution *)

Lemma typing_trm_subst : forall F M E t T z u,
  E & z ~ M & F |= t ~: T ->
  has_scheme E u M ->
  term u ->
  E & F |= (trm_subst z u t) ~: T.
Proof.
  introv Typt. intros Typu Wu.
  gen_eq (E & z ~ M & F) as G. gen F.
  induction Typt; introv EQ; subst; simpl trm_subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
   rewrite* trm_subst_open_var.
   apply_ih_bind* H1.
  apply_fresh* (@typing_let M0 L1) as y.
   rewrite* trm_subst_open_var.
   apply_ih_bind* H2.
  auto*.
Qed.

(* ********************************************************************** *)
(** Preservation: typing is preserved by reduction *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; subst; inversions Red.
  pick_fresh x. rewrite* (@trm_subst_intro x).
   apply_empty* typing_trm_subst.
   apply* (@has_scheme_from_vars L1).
  apply* (@typing_let M L1).
  inversions Typ1. pick_fresh x.
   rewrite* (@trm_subst_intro x).
   apply_empty* typing_trm_subst.
   apply* has_scheme_from_typ.
  auto*.
  auto*.
Qed.

(* ********************************************************************** *)
(** Progress: typed terms are values or can reduce *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (empty:env) as E. poses Typ' Typ.
  induction Typ; intros; subst.
  inversions H0.
  left*.
  right. pick_freshes (sch_arity M) Ys.
    destructi~ (@H0 Ys) as [Val1 | [t1' Red1]].
      exists* (t2 ^^ t1).
      exists* (trm_let t1' t2).
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversion Val1. exists* (t0 ^^ t2).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrnat ssrfun eqtype choice fintype ssrbool seq.
From fcsl
Require Import ordtype.

(* This file exists because currently Coq cannot instantiate
  Parameters inside Functors while doing code extraction.
  See "Extract Constant has no effect on functors":
        https://github.com/coq/coq/issues/4749
 *)
Module Type NetAddr.
(* Needs to be finType because the global state is map from Address ->
   State and _all_ addresses (i.e. need to be able to enumerate them)
   should start with the initial state. *)

Definition half := prod 'I_1 'I_1.
Definition ip := prod half half.
Definition port := half.

Definition Address := prod ip port.
Definition Address_ordMixin := fin_ordMixin [finType of Address].
Canonical Address_ordType := Eval hnf in OrdType Address Address_ordMixin.

End NetAddr.

Module Addr <: NetAddr.
Include NetAddr.
End Addr.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ B Cprime /\ (wd_ C Cprime /\ (wd_ A B /\ (wd_ C B /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ C P /\ (wd_ B P /\ (wd_ A P /\ (col_ P Q Aprime /\ (col_ P Q Cprime /\ (col_ A B C /\ col_ B C Cprime)))))))))))))))) -> col_ A C Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Maps.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Equivalence.

Definition splTCwF_structure (C : category) : UU
:= ∑ (O : obj_ext_structure C) (TQ : term_fun_structure C O × qq_morphism_structure O),
 iscompatible_term_qq (pr1 TQ) (pr2 TQ).
Definition splTCwF : UU := ∑ C : category, splTCwF_structure C .

Section Equiv.
Context (C : category).
Definition Term_first : UU := ∑ O : obj_ext_structure C, T1 O.
Definition qq_first : UU := ∑ O : obj_ext_structure C, T2 O.

Lemma term_first_equiv : Term_first ≃ splTCwF_structure C.
Proof.
    use tpair.
    - intro a; exact (pr1 a,,((pr12 a,,pr122 a),,pr222 a)).
    - use gradth.
      -- intro a; exact (pr1 a,,(pr112 a,,(pr212 a,,pr22 a))).
      -- reflexivity.
      -- reflexivity.
Qed.

Lemma qq_first_equiv : qq_first ≃ splTCwF_structure C.
Proof.
    use tpair.
    - intro a; exact (pr1 a,,((pr122 a,,pr12 a),,pr222 a)).
    - use gradth.
      -- intro a; exact (pr1 a,,(pr212 a,,(pr112 a,,pr22 a))).
      -- reflexivity.
      -- reflexivity.
Qed.

End Equiv.

Section Coercion.

Coercion splTCwF_cat (C : splTCwF) : category := pr1 C.
Coercion structure_of_splTCwF (C : splTCwF) : splTCwF_structure C := pr2 C.
Coercion object_structure_of_splTCwF (C : splTCwF) : obj_ext_structure C := pr12 C.
Coercion term_structure_of_splTCwF (C : splTCwF) : term_fun_structure C C := pr1 (pr122 C).
Coercion qq_structure_of_splTCwF (C : splTCwF) : qq_morphism_structure C := pr2 (pr122 C).

End Coercion.

Section splTCwF.
Context {C : splTCwF}.

Section access.

Definition Ty : functor _ _ := TY C.
Definition reind_ty {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) := #Ty f A.
Notation "A ⌊ f ⌋" := (reind_ty A f) (at level 30, only parsing).
Definition ext Γ (A : Ty Γ : hSet) : C := comp_ext C Γ A.
Notation "Γ ¤ A" := (ext Γ A) (at level 30, only parsing).
Definition pi {Γ} (A : Ty Γ : hSet) : C⟦Γ¤A,Γ⟧ := π A .
Definition Tm : functor _ _ := TM C.
Definition p : nat_trans Tm Ty := pp C.
Definition tm {Γ} (A : Ty Γ : hSet) := ∑ a : Tm Γ : hSet, p _ a = A .
Coercion pr1_tm {Γ} {A : Ty Γ : hSet} (a : tm A) : Tm Γ : hSet := pr1 a.
Coercion pr2_tm {Γ} {A : Ty Γ : hSet} (a : tm A) : p _ a = A := pr2 a.
(* TODO: refactor [tm] using pre-existing [section] infrastructure? *)
Lemma ppComp1 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A) :
  p _ (# Tm f a ) = # Ty f A.
Proof.
  etrans. { apply nat_trans_ax_pshf. }
  apply maponpaths, a.
Qed.

Definition reind_tm {Γ : C} {A : Ty Γ : hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm A)
: tm (A ⌊f⌋) := #Tm f a,, ppComp1 f a .
Notation "a ⌈ f ⌉" := (reind_tm f a) (at level 30, only parsing).
Definition var' {Γ} (A : Ty Γ : hSet) : Tm (Γ¤A) : hSet := te C A.
Definition var_commut {Γ} (A : Ty Γ : hSet) : p _ (var' A) = A ⌊pi A⌋:= pp_te C A.
Definition var {Γ} (A : Ty Γ : hSet) : tm (A⌊pi A⌋) := (var' A,, var_commut A).

Definition Yo_var_commut {Γ} (A : Ty Γ : hSet)
  : (# Yo (pi A) ;; (@yy C Ty Γ) A) = ((@yy C Tm (ext Γ A)) (var A) ;; p)
  := term_fun_str_square_comm (var A).
Definition term_pullback {Γ} (A : Ty Γ : hSet)
: isPullback (Yo_var_commut A)
:= isPullback_Q_pp C A.

Definition q {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : C⟦Δ¤(A⌊f⌋),Γ¤A⟧ := qq C f A.
Definition q_eq {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : pi _ ;; f = q A f ;; pi _ := !(qq_π C f A).
Definition q_pullback {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : isPullback (q_eq A f) := qq_π_Pb C f A.
Definition compatibility_splTCwF {Γ Δ : C} (A : Ty Γ : hSet) (f : C⟦Δ, Γ⟧) : # Tm (q A f) (var A) = var (A⌊f⌋) := !(pr222 C Γ Δ A f).

End access.

Notation "A ⌊ f ⌋" := (reind_ty A f) (at level 30, only parsing).
Notation "Γ ¤ A" := (ext Γ A) (at level 30, only parsing).
Notation "a ⌈ f ⌉" := (reind_tm f a) (at level 30, only parsing).

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.
  etrans. 2: { apply yoneda_map_1_2. }
  apply pair_path_in2, isaprop_is_nat_trans, homset_property.
Qed.

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

Lemma invyonedacarac {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧) : (Yo^-1 f) = ((f :nat_trans _ _) Γ (identity Γ)).
Proof.
rewrite (!(yonedacarac _)). rewrite yonedainv ,yonedacarac. reflexivity.
Qed.

Lemma yyidentity {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: B = (@yy (pr1 C) Ty (Γ¤A) B : nat_trans _ _) (Γ¤A) (identity (Γ¤A)).
Proof.
  apply pathsinv0, functor_id_pshf.
Qed.

Lemma q_eq_yoneda {Γ Δ} (A : Ty Γ : hSet) (f : C⟦Δ,Γ⟧) : #Yo(pi _) ;; #Yo f = #Yo (q A f) ;; #Yo (pi _).
Proof.
  rewrite <- 2 functor_comp.
  apply maponpaths, q_eq.
Qed.

End Yoneda.

Section Ty_Tm_lemmas.

Lemma Ty_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Ty Γ'' : hSet)
: A ⌊f;;g⌋ =  (A ⌊ g ⌋) ⌊f⌋.
Proof.
  apply functor_comp_pshf.
Qed.

Lemma Tm_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Tm Γ'' : hSet)
: #Tm (f;;g) A = #Tm f (#Tm g A).
Proof.
  apply functor_comp_pshf.
Qed.

Lemma Ty_identity {Γ : C} (A : Ty Γ : hSet) : A = A ⌊identity Γ⌋ .
Proof.
  apply pathsinv0, functor_id_pshf.
Qed.

End Ty_Tm_lemmas.

Section term_substitution.

Lemma Subproof_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A)
  : (identity (Yo Γ) ;; (@yy C Ty Γ) A) = ((@yy C Tm Γ) a ;; p).
Proof.
  apply pathsinv0, (pathscomp0(yy_comp_nat_trans Tm Ty p Γ a)) ,pathsinv0,
  (pathscomp0(id_left _ )), ((maponpaths yy) (!(pr2 a))).
Qed.

Definition γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : (preShv C)⟦Yo Γ,Yo (Γ¤A)⟧
  := map_into_Pb (term_pullback A) (identity _) (@yy C Tm Γ a) (Subproof_γ a).

Lemma  γ_pull {Γ : C} {A : Ty Γ : hSet} (a : tm A)
  : (γ a ;; (@yy C Tm (ext Γ A)) (var A)) = (@yy C Tm Γ) a.
Proof.
  apply Pb_map_commutes_2.
Qed.

Lemma pull_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : γ a ;; #Yo (pi A) = identity _.
Proof.
  apply Pb_map_commutes_1.
Qed.

Lemma γ_pi {Γ : C} {A : Ty Γ: hSet} (a : tm A) : Yo^-1 (γ a) ;; pi A = identity _.
Proof.
  assert (Yoeq : #Yo(Yo^-1 (γ a) ;; pi A) = #Yo(identity Γ)).
  - etrans. { apply functor_comp. }
    apply pathsinv0. etrans. { apply functor_id. }
    etrans. { apply pathsinv0, (pull_γ a). }
    apply maponpaths_2, pathsinv0, invyoneda.
  - apply (maponpaths (Yo^-1) ) in Yoeq.
    rewrite yonedainv, yonedainv in Yoeq.
    exact Yoeq.
Qed.

Lemma γNat {Γ Δ : C} {A : Ty Γ : hSet} (f : C ⟦Δ,Γ⟧) (a : tm A)
: (f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ) =
  (γ (a ⌈f⌉) ;; #Yo (q A f) : nat_trans _ _) Δ (identity Δ).
Proof.
  assert (Yoγ : #Yo ((f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ)) =
  #Yo((γ (a ⌈f⌉) : nat_trans _ _) Δ (identity Δ) ;; q A f)).
  - do 2 (rewrite functor_comp; rewrite yonedacarac).
    refine (MorphismsIntoPullbackEqual (term_pullback A) _
                       (#Yo f ;; γ a) (γ (a ⌈f⌉) ;; #Yo (q A f)) _ _).
    + rewrite <- assoc.
      etrans. { apply maponpaths, pull_γ. }
      etrans. { apply id_right. }
      rewrite <- assoc.
      apply pathsinv0.
      rewrite <- functor_comp.
      rewrite (!(q_eq _ _)).
      rewrite functor_comp.
      rewrite assoc.
      rewrite pull_γ.
      apply id_left.
    + rewrite <- assoc.
      etrans. { apply maponpaths, γ_pull. }
      rewrite <- assoc.
      rewrite (!(yy_natural _ _ _ _ (q A f))).
      rewrite compatibility_splTCwF.
      rewrite γ_pull.
      apply pathsinv0, yy_natural.
  - apply (transportyo Yoγ).
Qed.

Lemma γPullback1 {Γ : C} (A : Ty Γ : hSet)
  : (@γ (ext Γ A) (reind_ty A (pi A)) (var A)
     ;; # Yo (q A (pi A))
     ;; (@yy C Tm (ext Γ A)) (var A))
    = (identity _) ;; (@yy C Tm (ext Γ A)) (var A).
Proof.
  rewrite id_left.
  assert (γ (var A) ;; yy (var (A ⌊pi A⌋)) = yy(var A)) by apply (γ_pull (var A)).
  rewrite <- assoc, <- X.
  apply maponpaths.
  rewrite X.
  rewrite (!(yy_natural _ _ (var A) _ _)).
  rewrite compatibility_splTCwF.
  reflexivity.
Qed.

Lemma  γPullback2 {Γ : C} (A : Ty Γ : hSet)
: γ (var A) ;; #Yo (q A (pi A)) ;; #Yo (pi A) = identity _;;(#Yo (pi A)).
Proof.
  rewrite <- assoc.
  etrans. { apply pathsinv0, maponpaths, q_eq_yoneda. }
  rewrite assoc.
  apply maponpaths_2, pull_γ.
Qed.

(** term wiew as sections*)
Definition tm_sec {Γ : C} (A : Ty Γ : hSet) := ∑ a : C⟦Γ,Γ¤A⟧, a ;; pi A = identity _ .

Coercion tm_sec_pr1 {Γ: C} (A : Ty Γ : hSet) : tm_sec A -> C⟦Γ,Γ¤A⟧ := pr1.

Definition tm_sec_property {Γ : C} {A : Ty Γ : hSet} (a : tm_sec A)
: a ;; pi A = identity _
:= pr2 a.

Section tm_equiv.
(**equivalence between the possible definitions of term*)
Definition tm_map_1  {Γ: C} (A : Ty Γ : hSet) : tm A -> tm_sec A.
Proof.
  intro a ; exact (Yo^-1 (γ a),,γ_pi a).
Defined.

Definition tm_map_2  {Γ: C} (A : Ty Γ : hSet) : tm_sec A -> tm A.
Proof.
  intros [a  pa]; use tpair.
  -  exact (invmap (yy) (#Yo a;; yy(var A))).
  -  abstract (set (a' := invmap (yy) (#Yo a;; yy(var A))); simpl;
     assert (eqA : @yy _ _ _ A = yy a' ;; p);
     [ apply (maponpaths (#Yo )) in pa;
        unfold a';
        rewrite homotweqinvweq;
        rewrite <- assoc;
        assert ( imp : #Yo (pi A);; yy A = yy(var A);;p)
        by exact (Yo_var_commut _);
     apply (cancel_precomposition _ _ _ _ _ _ (#Yo a)) in imp;
     rewrite assoc in imp;
     assert (simplman : # Yo (a ;; pi A) =
     # (pr1 Yo) (a ;; pi A)) by auto;
     rewrite simplman in pa;
     rewrite (pr22 Yo _ _ _ a (pi A)) in pa;
     assert (simplman2 : # Yo a =
     # (pr1 Yo) a ) by auto;
     rewrite simplman2 in imp;
     assert (simplman3 : # Yo (pi A) =
     # (pr1 Yo) (pi A) ) by auto;
     rewrite simplman3 in imp;
     apply (cancel_postcomposition _ _ (yy A)) in pa;
     assert (lem : #Yo(identity _);; yy A = # Yo a ;; (yy (var A) ;; p));
      [ apply (pathscomp0 (!pa));
        exact imp
      | apply (pathscomp0 (!(@id_left (preShv C) _ _ (yy A))));
        assert (simplman4 : identity _ ;; yy A = #Yo(identity _);; yy A);
        [ assert (simplman5 : identity (Yo Γ) = identity ((pr1 Yo) Γ)) by auto;
           apply (cancel_postcomposition _ _ (yy A)) in simplman5;
           apply (pathscomp0 simplman5);
          apply cancel_postcomposition;
          exact (!(functor_id _ _))
          | apply (pathscomp0 simplman4);
             exact lem]]
  | assert (eqa' : @yy _ _ _ (p _ a') = yy a';;p)
     by (rewrite yy_comp_nat_trans; reflexivity);
     rewrite <- eqa' in eqA;
     apply (maponpaths (invmap yy)) in eqA;
     do 2 rewrite homotinvweqweq in eqA;
     exact (!eqA)]).
Defined.

Lemma tm_map_12 {Γ: C} (A : Ty Γ : hSet) : ∏ a : tm A, tm_map_2 A (tm_map_1 A a) = a.
Proof.
intro a;
apply subtypePath.
- intro x; exact (setproperty (Ty Γ : hSet) _ _).
- assert (eqa : invmap yy (# (yoneda C) (Yo^-1 (γ a)) ;; yy (var A)) = a)
   by (rewrite invyoneda,γ_pull, homotinvweqweq; reflexivity);  exact eqa.
Qed.

Lemma tm_map_21 {Γ: C} (A : Ty Γ : hSet) : ∏ a : tm_sec A, tm_map_1 A (tm_map_2 A a) = a.
Proof.
intro a;
apply subtypePath.
- intro x; apply homset_property.
- assert (eqa : (Yo^-1 (γ (invmap yy (# (yoneda C) (pr1 a) ;; yy (var A)),,
    tm_map_2_subproof Γ A (pr1 a) (pr2 a)))) = a).
  rewrite <- (yonedainv a) ; apply maponpaths.
  refine (MorphismsIntoPullbackEqual _ _ _ _ _ _).
  + apply term_pullback.
  + etrans. { apply pull_γ. }
    etrans. 2: { apply functor_comp. }
    apply pathsinv0.
    etrans. 2: { apply functor_id. }
    apply maponpaths, tm_sec_property.
  + rewrite γ_pull.
    apply homotweqinvweq.
  + exact eqa.
Qed.

Definition tm_equiv {Γ: C} {A : Ty Γ : hSet} : tm A ≃ tm_sec A :=
  (tm_map_1 _,,
  gradth (tm_map_1 _) (tm_map_2 _) (tm_map_12 _) (tm_map_21 _)).

Coercion tm_equiv_coer {Γ: C} {A : Ty Γ : hSet} (a : tm A) : tm_sec A := tm_equiv a.

End tm_equiv.

End term_substitution.

Section splTCwF_lemmas.

Section comp_ext.

Definition comp_ext_compare
{Γ : C} {A A' : Ty Γ : hSet} (e : A = A')
: z_iso (Γ ¤ A) (Γ ¤ A')
:= idtoiso (maponpaths (ext Γ) e).

Lemma comp_ext_compare_id
{Γ : C} (A : Ty Γ : hSet)
: (comp_ext_compare (idpath A) : _ --> _) = identity (Γ¤A).
Proof.
  apply idpath.
Qed.

Lemma comp_ext_compare_id_general
{Γ : C} {A : Ty Γ : hSet} (e : A = A)
: (comp_ext_compare e : _ --> _) = identity (Γ ¤ A).
Proof.
  apply @pathscomp0 with (comp_ext_compare (idpath _)).
  - apply maponpaths, maponpaths, (setproperty (Ty Γ : hSet)).
  - apply idpath.
Qed.

Lemma comp_ext_compare_comp
{Γ : C} {A A' A'' : Ty Γ : hSet} (e : A = A') (e' : A' = A'')
: (comp_ext_compare (e @ e') : _ --> _)
= comp_ext_compare e ;; comp_ext_compare e'.
Proof.
  etrans. 2: { apply idtoiso_concat_pr. }
  unfold comp_ext_compare. apply maponpaths, maponpaths.
  apply maponpathscomp0.
Qed.

Lemma comp_ext_compare_irrelevant
{Γ : C} {A A' : Ty Γ : hSet} (e e' : A = A')
: (comp_ext_compare e : _ --> _) = comp_ext_compare e'.
Proof.
  apply maponpaths, maponpaths,(setproperty (Ty Γ : hSet)).
Qed.

End comp_ext.

Lemma q_typeeq {Γ:C}
{A A' : Ty Γ : hSet} (e : A = A')
{Δ : C} (f : C^op ⟦Γ,Δ⟧)
: comp_ext_compare (maponpaths (fun X => X ⌊f⌋) e) ;; q A' f
= q A f ;; comp_ext_compare e.
Proof.
  destruct e; cbn.
  rewrite id_right; apply id_left.
Qed.

Definition q_mapeq
{Γ Δ} {f f' : C^op ⟦Γ,Δ⟧} (e : f = f') (A : Ty Γ : hSet)
: comp_ext_compare (maponpaths _ e)
  ;; q A f'
= q A f.
Proof.
  destruct e; apply id_left.
Qed.

Definition q_q
  : ∏ Γ  Γ' Γ''  (f : C^op ⟦Γ,Γ'⟧)  (g : C^op ⟦Γ',Γ''⟧) (A : Ty Γ : hSet),
            q A (f;;g)
            =  idtoiso (maponpaths (fun b => Γ''¤b) (Ty_composition _ _ _))
               ;; q (A ⌊f⌋) g
               ;; q A f.
Proof.
  intros.
  etrans. { use qq_comp. }
  apply maponpaths_2, maponpaths_2.
  apply (maponpaths pr1), (maponpaths idtoiso), maponpaths.
  apply setproperty.
Qed.

Definition q_q'
: ∏ Γ (A : Ty Γ : hSet) Γ' (f : C^op ⟦Γ,Γ'⟧) Γ'' (g : C^op ⟦Γ',Γ''⟧),
  q (A ⌊f⌋) g ;; q A f
  = idtoiso (maponpaths (fun b => Γ''¤b) (! Ty_composition _ _ _))
    ;; q A (f;;g).
Proof.
intros. apply z_iso_inv_to_left, pathsinv0.
etrans. { apply q_q. }
repeat rewrite <- assoc; apply maponpaths_2.
etrans. 2: { apply comp_ext_compare_inv. }
apply comp_ext_compare_irrelevant.
Qed.

End splTCwF_lemmas.

Section tm_lemmas.

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.

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_transportf_idpath_gen {Γ} {A : Ty Γ : hSet} (t : tm A) (e : A = A)
: tm_transportf e t = t.
Proof.
  assert (eqe : e = idpath A) by apply (setproperty (Ty Γ : hSet)).
  rewrite eqe.
  exact (tm_transportf_idpath _).
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)
: a ⌈g ;; f⌉
= tm_transportb (Ty_composition _ _ _) (a ⌈f⌉ ⌈g⌉).
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)
: a ⌈f⌉ = tm_transportb (maponpaths (fun g => #Ty g A) e) (a ⌈f'⌉).
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)) (a ⌈g;;f⌉) = a ⌈f⌉ ⌈g⌉.
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.
Definition tm_transportb_unfold
{Γ} {A A' : Ty Γ : hSet} (e : A = A') (a : tm A')
: (tm_transportb e a : _ --> _)
= a ;; comp_ext_compare (!e).
Proof.
  induction e.
  rewrite comp_ext_compare_id_general.
  rewrite tm_transportbf.
  rewrite tm_transportf_idpath_gen.
  apply (!(id_right _)).
Qed.

Definition tm_transportb_unfold_alter
{Γ} {A A' : Ty Γ : hSet} (e : A = A') (a : tm A')
: (tm_transportb e a : _ --> _) ;; comp_ext_compare (e)
= a .
Proof.
  rewrite tm_transportb_unfold, <- assoc, (!(comp_ext_compare_comp _ _)), comp_ext_compare_id_general, id_right.
  reflexivity.
Qed.

Lemma reind_compose_tm'
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: tm_transportf (Ty_composition _ _ _) (a ⌈g;;f⌉) = a ⌈f⌉ ⌈g⌉.
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)
: a ⌈identity _⌉
= tm_transportb (functor_id_pshf _) a.
Proof.
  apply subtypePath.
  - intros x. apply setproperty.
  - apply functor_id_pshf.
Qed.

Lemma reind_id_tm' {Γ : C} {A : Ty Γ : hSet}  (a : tm A) (b : tm A)
(e : A ⌊identity Γ⌋ = A ⌊b ;; pi A⌋)
: tm_transportf e (a ⌈identity _⌉)
= tm_transportf ((Ty_identity _) @ e) a.
Proof.
  apply subtypePath.
  -  intros x. apply setproperty.
  -  apply functor_id_pshf.
Qed.

Section term_substitution_lemmas.

Definition γ_qq {Γ} {A : Ty Γ: hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm (A ⌊f⌋)) : C⟦Γ',Γ¤ A⟧ := (a ;; q A f).

Lemma γ_a  {Γ} {A : Ty Γ : hSet} (a : tm A) : #Yo a = γ a.
Proof.
  assert (eq : Yo^-1(γ a) = a) by auto.
  rewrite (!eq).
  apply invyoneda.
Qed.

Lemma Ty_γ_id {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: A ⌊pi A⌋ ⌊a⌋ = A.
Proof.
  etrans. { apply pathsinv0, Ty_composition. }
  etrans. { apply maponpaths, γ_pi. }
  apply functor_id_pshf.
Qed.

Lemma var_substitution {Γ} {A : Ty Γ : hSet} (a : tm A) : #Tm a (var A) = a.
Proof.
  assert (inter : @yy _ _ _ (#Tm a (var A)) = yy a).
  -  assert (eqa : Yo^-1 (γ a) = a ) by auto.
     rewrite (!eqa), yy_natural, invyoneda.
     apply γ_pull.
  -  apply (maponpaths (invmap yy) ) in inter.
     do 2 rewrite homotinvweqweq in inter.
     exact inter.
Qed.

Lemma reind_tm_q {Γ Δ} (f : C^op ⟦Γ,Δ⟧)
{A : Ty Γ : hSet} (a : tm A)
: a ⌈f⌉ ;; q A f = (f : C⟦Δ,Γ⟧) ;; a.
Proof.
  apply transportyo.
  use (MorphismsIntoPullbackEqual (term_pullback A)).
  - rewrite 2 functor_comp.
    do 2 rewrite <- assoc.
    rewrite (!(q_eq_yoneda _ _)).
    do 2 rewrite γ_a.
    rewrite assoc.
    do 2 rewrite pull_γ.
    rewrite id_left,id_right.
    reflexivity.
  - rewrite 2 functor_comp.
    do 2 rewrite <- assoc.
    etrans. { apply maponpaths, pathsinv0, yy_natural. }
    apply pathsinv0.
    etrans. { apply maponpaths, pathsinv0, yy_natural. }
    rewrite compatibility_splTCwF.
    rewrite var_substitution.
    etrans. { apply pathsinv0, yy_natural. }
    etrans. 2: { apply yy_natural. }
    apply maponpaths, pathsinv0, var_substitution.
Qed.

End term_substitution_lemmas.

End tm_lemmas.

Section Familly_Of_Types.

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

Lemma DepTypesType_eq {Γ : C} {A : Ty Γ : hSet} (B : Ty(Γ¤A) : hSet)
(a : tm A) : DepTypesType B a =  B ⌊a⌋.
Proof.
  reflexivity.
Qed.

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

Lemma DepTypesComp {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: p Γ (DepTypesElem_pr1 b a) = DepTypesType B a.
Proof.
  etrans. { apply nat_trans_ax_pshf. }
  cbn. apply maponpaths, 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 DepTypesElems_eq {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: DepTypesElems b a = b ⌈a⌉.
Proof.
  use subtypePath.
  -  intro x; apply (setproperty (Ty Γ : hSet)).
  - cbn.
    assert (eqγ : (yoneda_map_1 C Γ (yoneda_objects C (ext Γ A)) (γ a))
                  = Yo^-1 (γ a)) by auto;
    rewrite eqγ;
    rewrite invyonedacarac.
    reflexivity.
Qed.

Lemma DepTypesNat {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤ A) : hSet)
(f : C^op ⟦Γ,Δ⟧) (a : tm A)
: #Ty f (DepTypesType B a) = DepTypesType (#Ty (q A f) B) (reind_tm f a).
Proof.
  unfold DepTypesType, reind_tm; rewrite yy_natural, assoc.
  etrans. { apply pathsinv0, functor_comp_pshf. }
  apply (toforallpaths (maponpaths (# Ty) (γNat f a)) B).
Qed.

Lemma DepTypesNat_bis {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤ A) : hSet)
(f : C ⟦Δ,Γ⟧) (a : tm A)
: B ⌊a⌋ ⌊f⌋ = B ⌊q A f⌋ ⌊a ⌈f⌉⌋.
Proof.
  exact (DepTypesNat _ _ _).
Qed.

Lemma DepTypesEta {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: DepTypesType (B ⌊q A (pi A)⌋) (var A) = B.
Proof.
  assert (Natu : @γ (Γ¤A) (A ⌊pi A⌋) (var A) ;; yy (B ⌊q A (pi A)⌋)
  = @γ (Γ¤A) (#Ty (pi A) A) (var A) ;; #Yo (q A (pi A)) ;;
  (@yy C Ty (Γ¤A)) B).
  { etrans. 2: { apply assoc. }
    apply maponpaths, yy_natural. }
  assert (Id: @γ (Γ¤A) (# Ty (@pi Γ A) A) (var A) ;; #Yo (q A (pi A))
     = identity _).
  { apply (MorphismsIntoPullbackEqual (term_pullback A)).
       + apply γPullback2.
       + apply γPullback1. }
  rewrite Id, (id_left _) in Natu.
  unfold DepTypesType.
  etrans. 2: { exact (!(yyidentity B)). }
  refine (toforallpaths _ (identity _)).
  refine (toforallpaths _ _).
  apply maponpaths, Natu.
Qed.

Lemma DepTypesEta_bis {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: B ⌊q A (pi A)⌋ ⌊var A⌋ = B.
Proof.
  exact (DepTypesEta _).
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.

Lemma DepTypesrewrite_bis {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
(a b : tm A) (e : pr1 a = pr1 b)
: B ⌊a⌋ = B ⌊b⌋.
Proof.
  do 2 rewrite (!(DepTypesType_eq _ _)).
  exact (DepTypesrewrite _ _ _ e).
Qed.

End Familly_Of_Types.

Section Pi_structure.

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

Definition PiTypeNat (π : PiTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet),
  (π _ A B) ⌊f⌋  = π _ (A ⌊f⌋) (B ⌊q A f⌋).

Definition pi_form_struct : UU
:= ∑ pi : PiTypeFormer, PiTypeNat pi.

Definition pr1_PiFormer (π : pi_form_struct) : PiTypeFormer := pr1 π.
Coercion pr1_PiFormer : pi_form_struct >-> PiTypeFormer.

Lemma ppComp3 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) {π : PiTypeFormer}
(nπ : PiTypeNat π) {B : Ty (Γ¤A) : hSet} (c : tm (π _ A B))
: p _ (c ⌈f⌉)  = (π Δ (A ⌊f⌋) (B ⌊q A f⌋)).
Proof.
  etrans. { apply nat_trans_ax_pshf. }
  etrans. { apply maponpaths, c. }
  apply nπ.
Qed.

Definition PiAbs (π : PiTypeFormer): UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet) (b : tm B), tm (π _ A B) .

Definition PiAbsNat (π : PiTypeFormer) (nπ : PiTypeNat π) (Λ : PiAbs π)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet)
(B : Ty (Γ ¤ A) : hSet) (b : tm B), (Λ Γ A B b) ⌈f⌉ =
tm_transportf (! (! ppComp1 f (Λ Γ A B b) @ ppComp3 f nπ (Λ Γ A B b)))
(Λ Δ (A ⌊f⌋) (B ⌊q A f⌋) (b ⌈q A f⌉)).

Definition Pi_intro_struct (π : pi_form_struct) : UU
:= ∑ Λ : PiAbs π, PiAbsNat π (pr2 π) Λ.

Definition PiApp (π : PiTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (π _ A B)) (a : tm A),
tm (B ⌊a⌋).

Definition PiAppNat  (π : PiTypeFormer) (nπ : PiTypeNat π) (app : 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_bis B f a))
(app _ (A ⌊f⌋) (B ⌊q A f⌋) (tm_transportf (nπ _ _ f A B) (c ⌈f⌉)) (a ⌈f⌉))).

Definition Pi_app_struct (π : pi_form_struct) : UU
:= ∑ app : PiApp π, PiAppNat π (pr2 π) app.

Definition PiAppAbs (π : PiTypeFormer) (Λ : PiAbs π) (app : PiApp π)
:= ∏ Γ ( A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (b : tm B) (a : tm A),
app _ _ _ (Λ _ A _ b) a = b⌈a⌉.

Definition Pi_comp_struct (π : pi_form_struct)
(lam : Pi_intro_struct π) (app : Pi_app_struct π) : UU
:= PiAppAbs π (pr1 lam) (pr1 app).

Definition PiAbsAppComp (π : PiTypeFormer) (nπ : PiTypeNat π)
(Λ : PiAbs π) (app : PiApp π)
: UU
:= ∏ (Γ : C) (A : Ty Γ: hSet) (B : Ty (Γ ¤ A) : hSet) (c : tm (π Γ A B)),
c = Λ Γ A B (tm_transportf (DepTypesEta_bis B)
(app (Γ ¤ A) (A ⌊pi A⌋) (B ⌊q A (pi A)⌋)
(tm_transportf (nπ Γ (Γ ¤ A) (pi A) A B) (reind_tm (pi A) c)) (var A))).

End Pi_structure.

Section Sigma_structure.

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

Definition SigTypeNat (σ : SigTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet),
(σ _ A B) ⌊f⌋ = σ _ (A ⌊f⌋) (B  ⌊q A f⌋).

Definition SigAbs (σ : SigTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (a : tm A)
(b : tm (B ⌊a⌋) ), tm (σ _ A B).

Definition CwF_SigAbsNat (σ : SigTypeFormer) (nσ : SigTypeNat σ)
(pair : SigAbs σ)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ ¤ A) : hSet)
(a : tm A) (b : tm (B ⌊a⌋)), (pair Γ A B a b) ⌈f⌉=
tm_transportf (! nσ Γ Δ f A B)
(pair Δ (A ⌊f⌋) (B  ⌊q A f⌋) (a ⌈f⌉)
(tm_transportf (DepTypesNat B f a) (b ⌈f⌉))).

Definition SigPr1 (σ : SigTypeFormer) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c: tm (σ _ A B)), tm A.

Definition SigPr1Nat (σ : SigTypeFormer) (nσ : SigTypeNat σ) (p1 : SigPr1 σ) : UU
:= ∏ (Γ Δ : C)  (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (σ _ A B)),
(p1 _ _ _ c) ⌈f⌉=
p1 _ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ _ _ f _ _) (c ⌈f⌉)).

Definition SigPr2 (σ : SigTypeFormer) (p1 : SigPr1 σ) :UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet)
(c : tm (σ _ A B) ), tm (B ⌊(p1 _ _ _ c)⌋).

Definition SigPr2Nat (σ : SigTypeFormer) (nσ : SigTypeNat σ) (p1 : SigPr1 σ)
(np1 : SigPr1Nat σ nσ p1) (p2 : SigPr2 σ p1)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet)
(c : tm (σ Γ A B)),
(p2 Γ A B c) ⌈f⌉ = tm_transportf (! DepTypesNat B f (p1 Γ A B c))
(tm_transportf (DepTypesrewrite (B  ⌊q A f⌋)
(p1 Δ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ Γ Δ f A B) (c ⌈f⌉)))
((p1 Γ A B c) ⌈f⌉) (maponpaths pr1 (! np1 Γ Δ f A B c)))
(p2 Δ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ Γ Δ f A B) (c ⌈f⌉)))).

Definition SigAbsPr1 (σ : SigTypeFormer) (pair : SigAbs σ) (p1 : SigPr1 σ)
: UU := ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (a : tm A) (b : tm (B ⌊a⌋)),
p1 _ _ _ (pair _  _ _ a b) = a.

Definition SigAbsPr2 (σ : SigTypeFormer) (pair : SigAbs σ) (p1 : SigPr1 σ)
(p2 : SigPr2 σ p1) (Ap1 : SigAbsPr1 σ pair p1)
: UU := ∏ (Γ : C^op) (A : Ty Γ : hSet) (B : Ty (Γ ¤ A) : hSet)
(a : tm A) (b : tm (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 SigAbsPr (σ : SigTypeFormer) (pair : SigAbs σ)
(p1 : SigPr1 σ) (p2 : 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.

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

Definition IdTypeNat (id : IdTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a b : tm A),
(id _ A a b) ⌊f⌋  = id _ (A ⌊f⌋) (a ⌈f⌉) (b ⌈f⌉).

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

Definition IdReflNat (Id : IdTypeFormer) (nid : IdTypeNat Id)
(refl : IdRefl Id) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A),
(refl _ A a) ⌈f⌉ =
tm_transportf (!(nid _ _ f _ a a)) (refl _ (A ⌊f⌋) (a ⌈f⌉)).

Definition maponpathsIdForm {Id : 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 maponpaths_12; assumption.
Qed.

Definition IdBasedFam (Id : IdTypeFormer) {Γ : C} (A : Ty Γ : hSet) (a : tm A)
: Ty (Γ¤A) : hSet := Id _ _ (a ⌈pi A⌉) (var A).

Definition IdBasedFamNatural (Id : IdTypeFormer) (nid : IdTypeNat Id)
{Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
: (IdBasedFam Id A a) ⌊q A f⌋ = IdBasedFam Id _ (a ⌈f⌉).
Proof.
  unfold IdBasedFam.
  etrans.
  -  exact (nid _ _ (q A f) _ _ _).
  -  use maponpathsIdForm.
     --  refine (!(Ty_composition _ _ A) @ _).
         apply pathsinv0, (pathscomp0 (!(Ty_composition _ _ A))).
         refine (toforallpaths _ A).
         exact (maponpaths _ (q_eq _ _)).
     --  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 (!(q_eq _ _)). }
         etrans. { rewrite tm_transportbf; apply (!(tm_transportf_compose _ _ _)). }
         apply tm_transportf_irrelevant.
     --  apply subtypePath; [intro x; apply (setproperty (Ty _ : hSet))|
         rewrite tm_transportbf ;apply compatibility_splTCwF].
Qed.

Definition Id_map {Id} (nid : IdTypeNat Id) {Γ} {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
: C⟦Γ,_¤IdBasedFam Id A a⟧.
Proof.
  simple refine (γ_qq b _). unfold IdBasedFam.
  simple refine (tm_transportb _ eqab).
  abstract(
  simple refine (nid  _ _ _ _ _ _ @ _);
  use 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 var_substitution]]).
Defined.

Definition id_intro_q {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) a b (eqab : tm (Id _ A a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: (f : C⟦Δ,Γ⟧) ;; eqab
= eqab'
  ;; comp_ext_compare (!nid _ _ _ _ _ _)
  ;; q _ f.
Proof.
  etrans. { apply pathsinv0, reind_tm_q. }
  apply maponpaths_2.
  unfold eqab'.
  assert (eqnat :nid Γ Δ f A a b = !(!(nid Γ Δ f A a b)) ) by apply (!(pathsinv0inv0 _)).
  rewrite eqnat, (!(tm_transportbf _)).
  rewrite (pathsinv0inv0 _).
  apply (!(tm_transportb_unfold_alter _ _)).
Qed.

Definition Id_map_natural {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: Id_map nid (a ⌈f⌉) (b ⌈f⌉) eqab'
  ;; (comp_ext_compare (!  IdBasedFamNatural Id nid  f A a)
  ;; q (IdBasedFam Id A a) (q A f))
= (f : C⟦Δ,Γ⟧) ;; Id_map nid a b eqab.
Proof.
  unfold Id_map, γ_qq.
  repeat rewrite tm_transportb_unfold.
  etrans. 2: { apply maponpaths, assoc. }
  etrans. 2: { apply pathsinv0, assoc. }
  etrans. 2: { eapply maponpaths_2, pathsinv0, id_intro_q. }
  etrans. { apply pathsinv0, assoc. }
  etrans. { apply pathsinv0, assoc. }
  etrans. 2: { apply assoc. }
  etrans. 2: { apply assoc. }
  apply maponpaths.
  etrans.
  { apply maponpaths.
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, q_typeeq. }
  etrans. { apply assoc'. }
  apply maponpaths, q_q'.
  }
  etrans.
  2: { apply pathsinv0, maponpaths.
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, q_typeeq. }
  etrans. { apply assoc'. }
  apply maponpaths, q_q'.
  }
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, comp_ext_compare_comp. }
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, comp_ext_compare_comp. }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  etrans.
  2: { apply maponpaths.
    refine (q_mapeq _ _).
    apply pathsinv0, reind_tm_q.
  }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  apply maponpaths_2, comp_ext_compare_irrelevant.
Qed.

Definition Id_map_natural_op {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: (Id_map nid a b eqab : C^op ⟦_,_⟧ );; f =
((comp_ext_compare (! IdBasedFamNatural Id nid f A a)  ;; q (IdBasedFam Id A a) (q A f) ) : C^op ⟦_,_⟧ );;
(Id_map nid (a ⌈f⌉) (b ⌈f⌉) eqab' : C^op ⟦_,_⟧).
Proof.
  eapply pathscomp0.
  assert (eqop : (Id_map nid a b eqab : C^op ⟦_,_⟧ );; f = (f : C⟦Δ,Γ⟧) ;; Id_map nid a b eqab) by auto.
  exact (eqop @ (!(Id_map_natural _ _ _ _ _))).
  reflexivity.
Qed.

Definition IdBased_path_induction {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) := ∏ Γ (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
(b : tm A) (eqab : tm (Id _ _ a b)),
tm (#Ty (Id_map nid a b eqab) P).

Definition d' {Id} {nid : IdTypeNat Id} {refl : IdRefl Id} (nrefl : IdReflNat Id nid refl)
 {Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} {a : tm A}
{P : Ty (_ ¤ IdBasedFam Id A a) :  hSet}
(P' :  Ty (_¤ (IdBasedFam Id (A ⌊f⌋) (a ⌈f⌉))) : hSet
:= P⌊ (comp_ext_compare (!  IdBasedFamNatural Id nid  f A a) ;; q (IdBasedFam Id A a) (q A f))⌋)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
{b : tm A} (eqab : tm (Id _ _ a b)) :
tm (P' ⌊Id_map nid (a ⌈f⌉) (a ⌈f⌉) (refl _ _ (a ⌈f⌉))⌋).
Proof.
  refine ((tm_transportb _) (d ⌈f⌉)).
  unfold P'.
  apply (pathscomp0 (!Ty_composition _ _ _)).
  apply pathsinv0.
  apply (pathscomp0 (!Ty_composition _ _ _)).
  apply maponpaths.
  apply (pathscomp0 (Id_map_natural_op nid f a a (refl _ A a))).
  change (@compose (C^op)) with (fun x y z f g => @compose C z y x g f). simpl.
  apply maponpaths_2, maponpaths.
  eapply pathscomp0.
  apply maponpaths.
  apply nrefl.
  apply (pathscomp0 (!(tm_transportf_compose _ _ _))).
  apply tm_transportf_idpath_gen.
Defined.

Lemma d_type_natural {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) {Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} {a : tm A}
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet) {b : tm A} (eqab : tm (Id _ _ a b)):
 P ⌊Id_map nid a b eqab⌋ ⌊f⌋  =
   P ⌊comp_ext_compare (! IdBasedFamNatural Id nid f A a) ;; q (IdBasedFam Id A a) (q A f)⌋ ⌊Id_map nid (reind_tm f a) (reind_tm f b)
   (tm_transportf (nid Γ Δ f A a b) (reind_tm f eqab))⌋.
Proof.
  do 2 rewrite <- Ty_composition.
  apply maponpaths.
  apply Id_map_natural_op.
Qed.

Definition IdBased_path_induction_natural {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) (nrefl : IdReflNat Id nid refl)
: UU :=
∏ (J : IdBased_path_induction nid refl) (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
(b : tm A) (eqab : tm (Id _ _ a b)), (tm_transportf (d_type_natural nid refl f P eqab) ((J Γ A a P d b eqab) ⌈f⌉)) =
J Δ (A⌊f⌋) (a ⌈f⌉) (P⌊_⌋) (d' nrefl f d eqab) (b ⌈f⌉) (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)).

End Identity_Structure.

End splTCwF.


Require Import FpuKami.Definitions FpuKami.NFToIN String Kami.AllNotations FpuKami.Round.
Section FNToIN.
  Variable name: string.
  Variable szMinus2: nat.
  Variable expWidthMinus2 sigWidthMinus2: nat.
  Local Notation "^ x" := (name ++ "#" ++ x)%string (at level 100).
  Local Notation sz := (szMinus2 + 1 + 1).

  Variable expWidth_prop: expWidthMinus2 >= 2.
  Variable expWidthMinus2_plus4_gt_sigWidth: 2 ^ expWidthMinus2 + 4 > (sigWidthMinus2 + 1 + 1).

  Open Scope kami_expr.
  Definition RecFNToINMod :=
    MODULE {
        Rule ^"RecINToFN" :=
          Call inputFN: RecFN expWidthMinus2 sigWidthMinus2  <- "inputFN" ();

          Call signedOut: Bool <- "signedOut" ();
          Call roundMode: Bit 3 <- "roundMode" ();
          LET inputNF<- getNF_from_RecFN #inputFN;

          LET NFToINInput: NFToINInput expWidthMinus2 sigWidthMinus2 <-
                                       STRUCT {
                                         "inNF" ::= #inputNF;
                                         "roundingMode" ::= #roundMode;
                                         "signedOut" ::= #signedOut
                                       };
          LETA NFToIN : NFToINOutput szMinus2 <-
                                NFToIN_action szMinus2 expWidth_prop expWidthMinus2_plus4_gt_sigWidth #NFToINInput;

          Call "exceptionFlags" (#NFToIN @% "flags": _) ;
          Call "outputIN" (#NFToIN @% "outIN": _);
        Retv
      }.
  Close Scope kami_expr.

End FNToIN.

Definition RecF32ToI32 := @RecFNToINMod "fpu" 30 6 22 ltac:(lia) ltac:(simpl;lia).
Definition RecF32ToI64 := @RecFNToINMod "fpu" 62 6 22 ltac:(lia) ltac:(simpl;lia).
Definition RecF64ToI32 := @RecFNToINMod "fpu" 30 9 51 ltac:(lia) ltac:(simpl;lia).
Definition RecF64ToI64 := @RecFNToINMod "fpu" 62 9 51 ltac:(lia) ltac:(simpl;lia).
Definition RecF16ToI32 := @RecFNToINMod "fpu" 30 6 6 ltac:(lia) ltac:(simpl;lia).
Definition RecF16ToI64 := @RecFNToINMod "fpu" 62 6 6 ltac:(lia) ltac:(simpl;lia).


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Definition VerifiedRewriterAddAssocLeft : VerifiedRewriter_with_args false false true add_assoc_left_rewrite_rules_proofs.
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterAddAssocLeft.
      Let optsT := Eval hnf in optsT VerifiedRewriterAddAssocLeft.

      Definition RewriteAddAssocLeft (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterAddAssocLeft opts t.

      Lemma Wf_RewriteAddAssocLeft opts {t} e (Hwf : Wf e) : Wf (@RewriteAddAssocLeft opts t e).
      Proof. now apply VerifiedRewriterAddAssocLeft. Qed.

      Lemma Interp_RewriteAddAssocLeft opts {t} e (Hwf : Wf e) : API.Interp (@RewriteAddAssocLeft opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterAddAssocLeft. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
    Hint Resolve Wf_RewriteAddAssocLeft : wf wf_extra.
    Hint Opaque RewriteAddAssocLeft : wf wf_extra interp interp_extra rewrite.
    Hint Rewrite @Interp_RewriteAddAssocLeft : interp interp_extra.
  End Hints.
End Compilers.