(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* ZDivides.v, by Vince Barany *)

Require Export CoRN.model.Zmod.ZBasics.

(**
* The Divides-function over Z
In this section the function Zdivides will be defined. Various facts
on this Zdivides will then be proved.
*)

Definition Zdivides (a b : Z) : Prop := exists q : Z, (q * a)%Z = b.

(* <Warning> : Grammar is replaced by Notation *)

(* <Warning> : Syntax is discontinued *)

Section zdivides.

Lemma Zdivides_ref : forall a : Z, Zdivides a a.
Proof.
 intro.
 exists 1%Z.
 auto with zarith.
Qed.

Lemma Zdivides_trans :
 forall a b c : Z, Zdivides a b -> Zdivides b c -> Zdivides a c.
Proof.
 intros.
 unfold Zdivides in H; elim H; intros.
 unfold Zdivides in H0; elim H0; intros.
 exists (x0 * x)%Z.
 rewrite <- H2.
 rewrite <- H1.
 auto with zarith.
Qed.

Lemma Zdivides_zero_rht : forall z : Z, Zdivides z 0.
Proof.
 intro.
 exists 0%Z.
 auto with zarith.
Qed.

Lemma Zdivides_zero_lft : forall z : Z, Zdivides 0 z -> z = 0%Z.
Proof.
 intro z.
 intro Hdiv; elim Hdiv.
 auto with zarith.
Qed.

Lemma Zdivides_one : forall z : Z, Zdivides 1 z.
Proof.
 intro.
 exists z.
 auto with zarith.
Qed.

(* Zdivides_antysym see below *)

Lemma Zdivides_mult_intro_lft :
 forall a b c : Z, Zdivides (a * b) c -> Zdivides b c.
Proof.
 intros a b c H.
 unfold Zdivides in H; elim H; intros q H_.
 exists (q * a)%Z.
 rewrite <- Zmult_assoc.
 assumption.
Qed.

Lemma Zdivides_mult_intro_rht :
 forall a b c : Z, Zdivides (a * b) c -> Zdivides a c.
Proof.
 intros a b c H.
 unfold Zdivides in H; elim H; intros q H_.
 exists (q * b)%Z.
 rewrite <- Zmult_assoc.
 rewrite (Zmult_comm b a).
 assumption.
Qed.

Lemma Zdivides_mult_lft : forall a b : Z, Zdivides b (a * b).
Proof.
 intros.
 exists a.
 auto with zarith.
Qed.

Lemma Zdivides_mult_rht : forall a b : Z, Zdivides a (a * b).
Proof.
 intros.
 exists b.
 auto with zarith.
Qed.

Lemma Zdivides_mult_elim_lft :
 forall a b c : Z, Zdivides a c -> Zdivides a (b * c).
Proof.
 intros.
 apply (Zdivides_trans a c (b * c)).
  assumption.
 apply Zdivides_mult_lft.
Qed.

Lemma Zdivides_mult_elim_rht :
 forall a b c : Z, Zdivides a b -> Zdivides a (b * c).
Proof.
 intros.
 apply (Zdivides_trans a b (b * c)).
  assumption.
 apply Zdivides_mult_rht.
Qed.

Lemma Zdivides_mult_cancel_lft :
 forall a b c : Z, Zdivides a b -> Zdivides (c * a) (c * b).
Proof.
 intros.
 unfold Zdivides in H; elim H; intros.
 exists x.
 rewrite <- H0.
 rewrite Zmult_assoc.
 rewrite Zmult_assoc.
 rewrite (Zmult_comm x c).
 reflexivity.
Qed.

Lemma Zdivides_mult_cancel_rht :
 forall a b c : Z, Zdivides a b -> Zdivides (a * c) (b * c).
Proof.
 intros.
 unfold Zdivides in H; elim H; intros.
 exists x.
 rewrite <- H0.
 auto with zarith.
Qed.

Let Zdiv_one_is_one : forall a : Z, (a > 0)%Z -> Zdivides a 1 -> a = 1%Z.
Proof.
 intros a H0 H1.
 unfold Zdivides in H1; elim H1; intros q H1_.
 apply Zle_antisymm.
  auto with zarith.
 rewrite <- (Zplus_0_l a).
 rewrite <- H1_.
 rewrite <- (Zmult_1_l (0 + a)).
 rewrite (Zplus_0_l a).
 apply (Zmult_pos_mon_le_rht q 1 a). 2: auto with zarith.
 cut (q > 0)%Z. auto with zarith.
 rewrite Zmult_comm in H1_.
 apply (Zdiv_pos_pos a); auto with zarith.
Defined.

Lemma Zdivides_antisymm :
 forall a b : Z,
 (a > 0)%Z -> (b > 0)%Z -> Zdivides a b -> Zdivides b a -> a = b.
Proof.
 intros a b H01 H02 H1 H2.
 unfold Zdivides in H1; elim H1; intros q1 H1_.
 unfold Zdivides in H2; elim H2; intros q2 H2_.
 generalize H2_; intro H12_.
 rewrite <- H1_ in H12_.
 rewrite Zmult_assoc in H12_.
 rewrite Zmult_comm in H12_.
 rewrite <- H1_.
 rewrite <- (Zmult_1_l a).
 assert (Zdivides q1 1).
  replace 1%Z with (q2 * q1)%Z.
   apply Zdivides_mult_elim_lft.
   apply Zdivides_ref.
  apply (Zunit_eq_one (q2 * q1) a).
   auto with zarith.
  assumption.
 replace q1 with 1%Z.
  auto with zarith.
 symmetry  in |- *.
 rewrite Zmult_comm in H1_; rewrite <- H1_ in H02.
 apply Zdiv_one_is_one; auto.
 apply (Zdiv_pos_pos a); auto.
Qed.

Lemma Zdivides_plus_elim :
 forall a b c : Z, Zdivides a b -> Zdivides a c -> Zdivides a (b + c).
Proof.
 intros a b c H1 H2.
 unfold Zdivides in H1; elim H1; intros q1 H1_.
 unfold Zdivides in H2; elim H2; intros q2 H2_.
 exists (q1 + q2)%Z.
 rewrite Zmult_plus_distr_l.
 auto with zarith.
Qed.

Lemma Zdivides_opp_elim_lft :
 forall a b : Z, Zdivides a b -> Zdivides (- a) b.
Proof.
 intros a b H.
 unfold Zdivides in H; elim H; intros q H_.
 exists (- q)%Z.
 rewrite Zmult_opp_opp.
 assumption.
Qed.

Lemma Zdivides_opp_elim_rht :
 forall a b : Z, Zdivides a b -> Zdivides a (- b).
Proof.
 intros a b H.
 unfold Zdivides in H; elim H; intros q H_.
 exists (- q)%Z.
 rewrite Zopp_mult_distr_l_reverse.
 auto with zarith.
Qed.

Lemma Zdivides_opp_elim :
 forall a b : Z, Zdivides a b -> Zdivides (- a) (- b).
Proof.
 intros.
 apply Zdivides_opp_elim_lft.
 apply Zdivides_opp_elim_rht.
 assumption.
Qed.

Lemma Zdivides_opp_intro_lft :
 forall a b : Z, Zdivides (- a) b -> Zdivides a b.
Proof.
 intros a b H.
 rewrite <- (Z.opp_involutive a).
 apply (Zdivides_opp_elim_lft _ _ H).
Qed.

Lemma Zdivides_opp_intro_rht :
 forall a b : Z, Zdivides a (- b) -> Zdivides a b.
Proof.
 intros a b H.
 rewrite <- (Z.opp_involutive b).
 apply (Zdivides_opp_elim_rht _ _ H).
Qed.

Lemma Zdivides_opp_intro :
 forall a b : Z, Zdivides (- a) (- b) -> Zdivides a b.
Proof.
 intros.
 apply Zdivides_opp_intro_lft.
 apply Zdivides_opp_intro_rht.
 assumption.
Qed.

Lemma Zdivides_minus_elim :
 forall a b c : Z, Zdivides a b -> Zdivides a c -> Zdivides a (b - c).
Proof.
 intros.
 unfold Zminus in |- *.
 apply Zdivides_plus_elim.
  assumption.
 apply Zdivides_opp_elim_rht.
 assumption.
Qed.

Lemma Zdivides_mult_elim :
 forall a b c d : Z, Zdivides a b -> Zdivides c d -> Zdivides (a * c) (b * d).
Proof.
 intros a b c d H1 H2.
 unfold Zdivides in H1; elim H1; intros q1 H1_.
 unfold Zdivides in H2; elim H2; intros q2 H2_.
 exists (q1 * q2)%Z.
 rewrite <- H1_.
 rewrite <- H2_.
 rewrite Zmult_assoc.
 rewrite Zmult_assoc.
 rewrite <- (Zmult_assoc q1 q2 a).
 rewrite (Zmult_comm q2 a).
 rewrite Zmult_assoc.
 reflexivity.
Qed.

Lemma Zdivides_mult_ll :
 forall a b c d : Z,
 (a * b)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d Heq Ha Hdiv.
 elim Hdiv; intros x Hx.
 rewrite <- Hx in Heq.
 exists x.
 apply (Zmult_intro_lft a).
  assumption.
 rewrite Heq.
 rewrite Zmult_assoc.
 rewrite (Zmult_comm x a).
 auto.
Qed.

Lemma Zdivides_mult_lr :
 forall a b c d : Z,
 (a * b)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d; rewrite (Zmult_comm d c); apply Zdivides_mult_ll.
Qed.

Lemma Zdivides_mult_rl :
 forall a b c d : Z,
 (b * a)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d; rewrite (Zmult_comm b a); apply Zdivides_mult_ll.
Qed.

Lemma Zdivides_mult_rr :
 forall a b c d : Z,
 (b * a)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
 intros a b c d; rewrite (Zmult_comm b a); rewrite (Zmult_comm d c); apply Zdivides_mult_ll.
Qed.

Lemma Zdivides_abs_elim_lft :
 forall a b : Z, Zdivides a b -> Zdivides (Z.abs a) b.
Proof.
 intros a b.
 case a; simpl in |- *; auto.
 intros p H.
 generalize (Zdivides_opp_elim_lft (Zneg p) b H).
 simpl in |- *; auto.
Qed.

Lemma Zdivides_abs_elim_rht :
 forall a b : Z, Zdivides a b -> Zdivides a (Z.abs b).
Proof.
 intros a b.
 case b; simpl in |- *; auto.
 intros p H.
 generalize (Zdivides_opp_elim_rht a (Zneg p) H).
 simpl in |- *; auto.
Qed.

Lemma Zdivides_abs_elim :
 forall a b : Z, Zdivides a b -> Zdivides (Z.abs a) (Z.abs b).
Proof.
 intros.
 apply Zdivides_abs_elim_lft.
 apply Zdivides_abs_elim_rht.
 assumption.
Qed.

Lemma Zdivides_abs_intro_lft :
 forall a b : Z, Zdivides (Z.abs a) b -> Zdivides a b.
Proof.
 intros a b.
 case a; simpl in |- *; auto.
 intros p; apply (Zdivides_opp_intro_lft (Zneg p) b).
Qed.

Lemma Zdivides_abs_intro_rht :
 forall a b : Z, Zdivides a (Z.abs b) -> Zdivides a b.
Proof.
 intros a b.
 case b; simpl in |- *; auto.
 intros p; apply (Zdivides_opp_intro_rht a (Zneg p)).
Qed.

Lemma Zdivides_abs_intro :
 forall a b : Z, Zdivides (Z.abs a) (Z.abs b) -> Zdivides a b.
Proof.
 intros.
 apply Zdivides_abs_intro_lft.
 apply Zdivides_abs_intro_rht.
 assumption.
Qed.

Lemma Zdivisor_pos_le :
 forall a b : Z, (a > 0)%Z -> Zdivides b a -> (a >= b)%Z.
Proof.
 unfold Zdivides in |- *.
 intros.
 elim H0.
 intros.
 rewrite <- H1.
 rewrite Zmult_comm.
 apply Zmult_pos_mon.
 rewrite Zmult_comm.
 rewrite H1.
 assumption.
Qed.

Lemma Zdivisor_small :
 forall a b : Z, Zdivides b a -> (Z.abs a < b)%Z -> a = 0%Z.
Proof.
 intros a b Hdiv Hlt.
 generalize (Zdivides_abs_elim_rht _ _ Hdiv); intro Hdivabs.
 set (A := a). assert (HA : A = a). auto. generalize HA.
 case A.
   auto.
  intros p Hp.
  assert (Hfalse : (b < b)%Z).
   apply (Z.le_lt_trans b (Z.abs a) b).
    apply Z.ge_le.
    apply (Zdivisor_pos_le (Z.abs a) b).
     rewrite <- Hp; simpl in |- *; auto with zarith.
    assumption.
   assumption.
  elim (Z.lt_irrefl b Hfalse).
 intros p Hp.
 assert (Hfalse : (b < b)%Z).
  apply (Z.le_lt_trans b (Z.abs a) b).
   apply Z.ge_le.
   apply (Zdivisor_pos_le (Z.abs a) b).
    rewrite <- Hp; simpl in |- *.
    auto with zarith.
   assumption.
  assumption.
 elim (Z.lt_irrefl b Hfalse).
Qed.

Lemma Zmodeq_small :
 forall a b c : Z,
 (0 <= a < c)%Z -> (0 <= b < c)%Z -> Zdivides c (a - b) -> a = b.
Proof.
 intros a b c Ha Hb Hc.
 cut ((a - b)%Z = 0%Z); auto with zarith.
 apply (Zdivisor_small (a - b) c).
  assumption.
 apply Zabs_lt_elim; auto with zarith.
Qed.

Lemma Zdiv_remainder_unique :
 forall a b q1 r1 q2 r2 : Z,
 a = (q1 * b + r1)%Z ->
 (0 <= r1 < b)%Z -> a = (q2 * b + r2)%Z -> (0 <= r2 < b)%Z -> r1 = r2.
Proof.
 intros a b q1 r1 q2 r2 Hq1 Hr1 Hq2 Hr2.
 apply (Zmodeq_small r1 r2 b).
   assumption.
  assumption.
 assert ((r1 - r2)%Z = ((q2 - q1) * b)%Z).
  rewrite Hq1 in Hq2.
  rewrite BinInt.Zmult_minus_distr_r.
  auto with zarith.
 rewrite H.
 apply Zdivides_mult_elim_lft.
 apply Zdivides_ref.
Qed.

Lemma Zdiv_quotient_unique :
 forall a b q1 r1 q2 r2 : Z,
 a = (q1 * b + r1)%Z ->
 (0 <= r1 < b)%Z -> a = (q2 * b + r2)%Z -> (0 <= r2 < b)%Z -> q1 = q2.
Proof.
 intros a b q1 r1 q2 r2 Hq1 Hr1 Hq2 Hr2.
 assert (Hr : r1 = r2).
  apply (Zdiv_remainder_unique a b q1 r1 q2 r2); assumption.
 rewrite Hr in Hq1.
 rewrite Hq1 in Hq2.
 assert (Hb0 : b <> 0%Z).
  assert (Hbpos : (0 < b)%Z).
   apply (Z.le_lt_trans 0 r1 b).
    tauto.
   tauto.
  auto with zarith.
 assert (Hb : (q1 * b)%Z = (q2 * b)%Z).
  auto with zarith.
 apply (Zmult_intro_rht _ _ _ Hb0 Hb).
Qed.

Lemma Zmod0_Zopp :
 forall a b : Z, b <> 0%Z -> (a mod b)%Z = 0%Z -> (a mod - b)%Z = 0%Z.
Proof.
 intros a b.
 generalize (Z_mod_lt (Z.abs a) (Z.abs b)).
 case a.
   case b; unfold Z.abs, Z.opp, Zmod, Z.div_eucl in |- *; auto with zarith.
  case b; unfold Z.abs, Z.opp, Zmod, Z.div_eucl in |- *.
    auto with zarith.
   intros p q.
   elim (Zdiv_eucl_POS q (Zpos p)); intros Q R.
   intros Hlt Hp HR; rewrite HR; auto with zarith.
  intros p q.
  elim (Zdiv_eucl_POS q (Zpos p)); intros Q R.
  case R.
    auto with zarith.
   intro r'; intros H0 H1 H2.
   enough (Zpos r' = Zpos p) by auto with zarith.
   fold (- Zpos p)%Z in H2.
   auto with zarith.
  intro r'; intros H0 H1 H2.
  elim H0; auto with zarith.
 case b; unfold Z.abs, Z.opp, Zmod, Z.div_eucl in |- *.
   auto with zarith.
  intros p q.
  elim (Zdiv_eucl_POS q (Zpos p)); intros Q R.
  case R; intros r' H0; intros; try (cut (Zpos r' = Zpos p); elim H0); auto with zarith.
 intros p q.
 elim (Zdiv_eucl_POS q (Zpos p)); intros Q R.
 case R; intros; try discriminate; try tauto.
Qed.

Lemma Zdiv_Zopp :
 forall a b : Z, (a mod b)%Z = 0%Z -> (a / - b)%Z = (- (a / b))%Z.
Proof.
 intros a b.
 unfold Zmod, Z.div, Z.div_eucl in |- *.
 case a.
   auto.
  intro A.
  case b; unfold Z.opp in |- *.
    auto.
   intro B.
   elim (Zdiv_eucl_POS A (Zpos B)); intros q r.
   intro Hr; rewrite Hr; auto.
  intro B.
  generalize (Z_mod_lt (Zpos A) (Zpos B)).
  unfold Zmod, Z.div_eucl in |- *.
  elim (Zdiv_eucl_POS A (Zpos B)); intros q r.
  case r.
    intros _ HR; fold (- q)%Z in |- *; fold (- - q)%Z in |- *; rewrite Z.opp_involutive; auto.
   intros R Hlt HR.
   assert (H : Zpos R = Zpos B).
    rewrite <- (Zplus_0_r (Zpos B)); rewrite <- HR; rewrite Zplus_assoc; fold (- Zpos B)%Z in |- *.
    auto with zarith.
   rewrite H in Hlt.
   elim Hlt; auto with zarith.
  intros R Hlt HR.
  elim Hlt; auto with zarith; intro Hfalse; elim Hfalse; auto with zarith.
 intro A.
 case b; unfold Z.opp in |- *.
   auto.
  intro B.
  generalize (Z_mod_lt (Zpos A) (Zpos B)).
  unfold Zmod, Z.div_eucl in |- *.
  elim (Zdiv_eucl_POS A (Zpos B)); intros q r.
  case r.
    intros _ HR; fold (- q)%Z in |- *; fold (- - q)%Z in |- *; rewrite Z.opp_involutive; auto.
   intros R Hlt HR.
   assert (H : Zpos R = Zpos B).
    rewrite <- (Zplus_0_r (Zpos R)); rewrite <- HR; unfold Zminus in |- *;
      rewrite Zplus_assoc; auto with zarith.
   rewrite H in Hlt.
   elim Hlt; auto with zarith.
  intros R Hlt HR.
  elim Hlt; auto with zarith; intro Hfalse; elim Hfalse; auto with zarith.
 intro B.
 generalize (Z_mod_lt (Zpos A) (Zpos B)).
 unfold Zmod, Z.div_eucl in |- *.
 elim (Zdiv_eucl_POS A (Zpos B)); intros q r.
 case r.
   intros _ HR; fold (- q)%Z in |- *; auto.
  intros; discriminate.
 intros; discriminate.
Qed.

Lemma Zmod0_Zdivides_pos :
 forall a b : Z, (b > 0)%Z -> Zdivides b a -> (a mod b)%Z = 0%Z.
Proof.
 intros a b Hb Hdiv.
 elim Hdiv; intros q Hq.
 rewrite (Z_div_mod_eq_full a b) in Hq.
  rewrite <- (Zplus_0_r (q * b)) in Hq.
  symmetry  in |- *.
  apply (Zdiv_remainder_unique (q * b + 0) b q 0 (a / b) (a mod b)).
     reflexivity.
    auto with zarith.
   rewrite (Zmult_comm (a / b) b); exact Hq.
  apply Z_mod_lt; auto with zarith.
Qed.

Lemma Zdivides_Zmod0_pos :
 forall a b : Z, (a mod b)%Z = 0%Z -> Zdivides b a.
Proof.
 intros a b Hmod.
 rewrite (Z_div_mod_eq_full a b).
  rewrite (Zmult_comm b (a / b)); rewrite Hmod; rewrite Zplus_0_r.
  exists (a / b)%Z.
  reflexivity.
Qed.

Lemma Zmod0_Zdivides :
 forall a b : Z, b <> 0%Z -> Zdivides b a -> (a mod b)%Z = 0%Z.
Proof.
 intros a b.
 case b.
   tauto.
  intros p _; apply Zmod0_Zdivides_pos; auto with zarith.
 intros p _.
 generalize (Zmod0_Zdivides_pos a (Zpos p)); intro H.
 fold (- Zpos p)%Z in |- *.
 intro Hdiv.
 apply Zmod0_Zopp.
  intro; discriminate.
 apply H.
  auto with zarith.
 rewrite <- (Z.opp_involutive (Zpos p)).
 apply Zdivides_opp_elim_lft.
 assumption.
Qed.

Lemma Zdivides_Zmod0 :
 forall a b : Z, b <> 0%Z -> (a mod b)%Z = 0%Z -> Zdivides b a.
Proof.
 intros a b.
 case b.
   tauto.
  intros p _; apply Zdivides_Zmod0_pos; auto with zarith.
 intros p _.
 generalize (Zdivides_Zmod0_pos a (Zpos p)); intro H.
 fold (- Zpos p)%Z in |- *.
 intro Hmod.
 apply Zdivides_opp_elim_lft.
 apply H.
  auto with zarith.
 rewrite <- (Z.opp_involutive (Zpos p)).
 apply Zmod0_Zopp.
  simpl in |- *; intros; discriminate.
 assumption.
Qed.

Lemma Zmod_mult_cancel_lft : forall a b : Z, ((a * b) mod a)%Z = 0%Z.
Proof.
 intros a b.
 case a.
   auto with zarith.
  intro p.
  apply Zmod0_Zdivides_pos.
   auto with zarith.
  apply Zdivides_mult_elim_rht.
  apply Zdivides_ref.
 intro p.
 apply Zmod0_Zdivides.
  auto with zarith.
 apply Zdivides_mult_elim_rht.
 apply Zdivides_ref.
Qed.

Lemma Zmod_mult_cancel_rht : forall a b : Z, ((a * b) mod b)%Z = 0%Z.
Proof.
 intros a b.
 rewrite Zmult_comm.
 apply Zmod_mult_cancel_lft.
Qed.

Lemma Zdiv_mult_cancel_lft : forall a b : Z, a <> 0%Z -> (a * b / a)%Z = b.
Proof.
 intros a b.
 case a.
   auto with zarith.
  intros p _.
  apply (Zdiv_quotient_unique (Zpos p * b) (Zpos p) (Zpos p * b / Zpos p)
    ((Zpos p * b) mod Zpos p) b 0).
     rewrite (Zmult_comm (Zpos p * b / Zpos p) (Zpos p)).
     apply Z_div_mod_eq_full.
    apply Z_mod_lt; auto with zarith.
   rewrite Zplus_0_r; auto with zarith.
  auto with zarith.
 intros p _.
 fold (- Zpos p)%Z in |- *.
 rewrite Zdiv_Zopp.
  cut ((- Zpos p * b / Zpos p)%Z = (- b)%Z); auto with zarith.
  unfold Z.opp in |- *; fold (- b)%Z in |- *.
  apply (Zdiv_quotient_unique (Zneg p * b) (Zpos p) (Zneg p * b / Zpos p)
    ((Zneg p * b) mod Zpos p) (- b) 0).
     rewrite (Zmult_comm (Zneg p * b / Zpos p) (Zpos p)).
     apply Z_div_mod_eq_full.
    apply Z_mod_lt; auto with zarith.
   rewrite Zplus_0_r; rewrite Zmult_opp_comm; fold (- Zpos p)%Z in |- *; auto with zarith.
  auto with zarith.
 rewrite Zmult_opp_comm.
 apply Zmod_mult_cancel_lft.
Qed.

Lemma Zdiv_mult_cancel_rht : forall a b : Z, b <> 0%Z -> (a * b / b)%Z = a.
Proof.
 intros a b.
 rewrite Zmult_comm.
 apply Zdiv_mult_cancel_lft.
Qed.

Lemma Zdiv_plus_elim :
 forall a b d : Z,
 Zdivides d a -> Zdivides d b -> ((a + b) / d)%Z = (a / d + b / d)%Z.
Proof.
 intros a b d Ha Hb.
 case (Zdec d).
  intro Hd; rewrite Hd; case (a + b)%Z; case a; case b; simpl in |- *; auto.
 intro Hd.
 elim Ha; clear Ha; intros x Ha; rewrite <- Ha.
 elim Hb; clear Hb; intros y Hb; rewrite <- Hb.
 rewrite <- Zmult_plus_distr_l.
 repeat rewrite Zdiv_mult_cancel_rht; auto.
Qed.

Lemma Zdiv_elim :
 forall a b d : Z,
 d <> 0%Z -> Zdivides d a -> Zdivides d b -> (a / d)%Z = (b / d)%Z -> a = b.
Proof.
 intros a b d Hd Ha Hb.
 elim Ha; clear Ha; intros x Ha; rewrite <- Ha.
 elim Hb; clear Hb; intros y Hb; rewrite <- Hb.
 repeat rewrite Zdiv_mult_cancel_rht; auto.
 intro Hxy; rewrite Hxy; auto.
Qed.

Lemma Zabs_div_lft : forall a : Z, (Z.abs a / a)%Z = Z.sgn a.
Proof.
 intro a.
 rewrite Zmult_sgn_eq_abs.
 case (Zdec a).
  intro Ha. rewrite Ha. simpl in |- *. auto with zarith.
  apply Zdiv_mult_cancel_rht.
Qed.

Lemma Zabs_div_rht : forall a : Z, (a / Z.abs a)%Z = Z.sgn a.
Proof.
 intro a.
 set (A := Z.abs a).
 set (sa := Z.sgn a).
 replace a with (Z.abs a * Z.sgn a)%Z.
  unfold sa in |- *; clear sa.
  case (Zdec A).
   unfold A in |- *; intro HA.
   cut (a = 0%Z); auto with zarith.
   intro Ha; rewrite Ha; auto with zarith.
  unfold A in |- *; apply Zdiv_mult_cancel_lft.
 rewrite Zmult_comm.
 auto with zarith.
Qed.

Lemma Zdiv_same : forall a : Z, a <> 0%Z -> (a / a)%Z = 1%Z.
Proof.
 intros a.
 case a.
   tauto.
  intros; apply Z_div_same; auto with zarith.
 intros A HA.
 fold (- Zpos A)%Z in |- *.
 rewrite Zdiv_Zopp.
  simpl in |- *.
  replace (Zpos A) with (Z.abs (Zneg A)); auto.
  rewrite Zabs_div_rht.
  auto.
 replace (- Zpos A)%Z with (-1 * Zpos A)%Z; auto with zarith.
 apply Zmod_mult_cancel_rht.
Qed.

Lemma Zmult_div_simpl_1 :
 forall a b c d : Z,
 (a * b)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d Heq Ha Hdiv.
 elim Hdiv; intros x Hx.
 rewrite <- Hx in Heq.
 rewrite (Zmult_comm x a) in Heq.
 rewrite <- Zmult_assoc in Heq.
 exists x.
 apply (Zmult_intro_lft a); auto.
Qed.

Lemma Zmult_div_simpl_2 :
 forall a b c d : Z,
 (a * b)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d; rewrite (Zmult_comm d c); apply Zmult_div_simpl_1.
Qed.

Lemma Zmult_div_simpl_3 :
 forall a b c d : Z,
 (b * a)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
Proof.
 intros a b c d; rewrite (Zmult_comm b a); apply Zmult_div_simpl_1.
Qed.

Lemma Zmult_div_simpl_4 :
 forall a b c d : Z,
 (b * a)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b.
 intros a b c d; rewrite (Zmult_comm b a); rewrite (Zmult_comm d c); apply Zmult_div_simpl_1.
Qed.

Lemma Zdivides_dec : forall a b : Z, {Zdivides a b} + {~ Zdivides a b}.
Proof.
 intros a b.
 case (Zdec b).
  intro Hb.
  rewrite Hb.
  left.
  apply Zdivides_zero_rht.
 intro Hb.
 case (Zdec a).
  intro Ha.
  rewrite Ha.
  right.
  intro H0.
  rewrite (Zdivides_zero_lft b H0) in Hb.
  elim Hb.
  auto.
 intro Ha.
 generalize (Zdivides_Zmod0 b a Ha).
 generalize (Zmod0_Zdivides b a Ha).
 case (Zdec (b mod a)); auto.
Qed.

End zdivides.

#[global]
Hint Resolve Zdivides_zero_lft: zarith.
#[global]
Hint Resolve Zdivides_zero_rht: zarith.
#[global]
Hint Resolve Zdivides_one: zarith.
#[global]
Hint Resolve Zdivides_ref: zarith.
#[global]
Hint Resolve Zdivides_trans: zarith.
#[global]
Hint Resolve Zdivides_mult_intro_lft: zarith.
#[global]
Hint Resolve Zdivides_mult_intro_rht: zarith.
#[global]
Hint Resolve Zdivides_mult_lft: zarith.
#[global]
Hint Resolve Zdivides_mult_rht: zarith.
#[global]
Hint Resolve Zdivides_mult_elim_lft: zarith.
#[global]
Hint Resolve Zdivides_mult_elim_rht: zarith.
#[global]
Hint Resolve Zdivides_mult_cancel_lft: zarith.
#[global]
Hint Resolve Zdivides_mult_cancel_rht: zarith.
#[global]
Hint Resolve Zdivides_antisymm: zarith.
#[global]
Hint Resolve Zdivides_plus_elim: zarith.
#[global]
Hint Resolve Zdivides_opp_elim_lft: zarith.
#[global]
Hint Resolve Zdivides_opp_elim_rht: zarith.
#[global]
Hint Resolve Zdivides_opp_elim: zarith.
#[global]
Hint Resolve Zdivides_opp_intro_lft: zarith.
#[global]
Hint Resolve Zdivides_opp_intro_rht: zarith.
#[global]
Hint Resolve Zdivides_opp_intro: zarith.
#[global]
Hint Resolve Zdivides_minus_elim: zarith.
#[global]
Hint Resolve Zdivides_mult_elim: zarith.
#[global]
Hint Resolve Zdivides_mult_ll: zarith.
#[global]
Hint Resolve Zdivides_mult_lr: zarith.
#[global]
Hint Resolve Zdivides_mult_rl: zarith.
#[global]
Hint Resolve Zdivides_mult_rr: zarith.
#[global]
Hint Resolve Zdivides_abs_elim_lft: zarith.
#[global]
Hint Resolve Zdivides_abs_elim_rht: zarith.
#[global]
Hint Resolve Zdivides_abs_elim: zarith.
#[global]
Hint Resolve Zdivides_abs_intro_lft: zarith.
#[global]
Hint Resolve Zdivides_abs_intro_rht: zarith.
#[global]
Hint Resolve Zdivides_abs_intro: zarith.
#[global]
Hint Resolve Zdivisor_pos_le: zarith.
#[global]
Hint Resolve Zdivisor_small: zarith.
#[global]
Hint Resolve Zmodeq_small: zarith.
#[global]
Hint Resolve Zdiv_remainder_unique: zarith.
#[global]
Hint Resolve Zdiv_quotient_unique: zarith.
#[global]
Hint Resolve Zmod0_Zopp: zarith.
#[global]
Hint Resolve Zdiv_Zopp: zarith.
#[global]
Hint Resolve Zmod0_Zdivides: zarith.
#[global]
Hint Resolve Zdivides_Zmod0: zarith.
#[global]
Hint Resolve Zmod_mult_cancel_lft: zarith.
#[global]
Hint Resolve Zmod_mult_cancel_rht: zarith.
#[global]
Hint Resolve Zdiv_mult_cancel_lft: zarith.
#[global]
Hint Resolve Zdiv_mult_cancel_rht: zarith.
#[global]
Hint Resolve Zdiv_plus_elim: zarith.
#[global]
Hint Resolve Zdiv_elim: zarith.
#[global]
Hint Resolve Zabs_div_lft: zarith.
#[global]
Hint Resolve Zabs_div_rht: zarith.
#[global]
Hint Resolve Zdiv_same: zarith.
#[global]
Hint Resolve Zmult_div_simpl_1: zarith.
#[global]
Hint Resolve Zmult_div_simpl_2: zarith.
#[global]
Hint Resolve Zmult_div_simpl_3: zarith.
#[global]
Hint Resolve Zmult_div_simpl_4: zarith.
#[global]
Hint Resolve Zdivides_dec: zarith.

Section ineq.

Lemma Zmod_POS_nonNEG :
 forall a b p : positive, (Zpos a mod Zpos b)%Z <> Zneg p.
Proof.
 intros a b p.
 generalize (Z_mod_lt (Zpos a) (Zpos b)).
 intro H.
 elim H.
  intros H0 H1.
  intro Hfalse.
  rewrite Hfalse in H0.
  elim H0.
  auto with zarith.
 auto with zarith.
Qed.

Lemma Zdiv_POS :
 forall a b : positive, (Zpos b * (Zpos a / Zpos b) <= Zpos a)%Z.
Proof.
 intros a b.
 rewrite <- (Zplus_0_r (Zpos b * (Zpos a / Zpos b))).
 set (lhs := (Zpos b * (Zpos a / Zpos b) + 0)%Z) in *.
 rewrite (Z_div_mod_eq_full (Zpos a) (Zpos b)).
  unfold lhs in |- *.
  apply Zplus_le_compat_l.
  auto with zarith.
  generalize (Z_mod_lt (Zpos a) (Zpos b)).
  intro H.
  elim H.
   auto with zarith.
  auto with zarith.
Qed.

Lemma Zmod_lt_POS :
 forall a b : positive, (Zpos a < Zpos b)%Z -> (Zpos a mod Zpos b)%Z = Zpos a.
Proof.
 intros a b Hlt.
 apply (Zdiv_remainder_unique (Zpos a) (Zpos b) (Zpos a / Zpos b)
   (Zpos a mod Zpos b) 0 (Zpos a)); auto with zarith.
  rewrite Zmult_comm.
  apply Z_div_mod_eq_full.
 apply Z_mod_lt; auto with zarith.
Qed.

Lemma Zdiv_lt_POS :
 forall a b : positive, (Zpos a < Zpos b)%Z -> (Zpos a / Zpos b)%Z = 0%Z.
Proof.
 intros a b Hlt.
 apply (Zdiv_quotient_unique (Zpos a) (Zpos b) (Zpos a / Zpos b)
   (Zpos a mod Zpos b) 0 (Zpos a)); auto with zarith.
  rewrite Zmult_comm.
  apply Z_div_mod_eq_full.
 apply Z_mod_lt; auto with zarith.
Qed.

End ineq.

#[global]
Hint Resolve Zmod_POS_nonNEG: zarith.
#[global]
Hint Resolve Zdiv_POS: zarith.
#[global]
Hint Resolve Zmod_lt_POS: zarith.
#[global]
Hint Resolve Zdiv_lt_POS: zarith.


Require Import Lang.Syntax.

Set Implicit Arguments.
Implicit Types V : Set.

(** If we can change the representation of a variable from [A] to [B],
then we can change the representation of a variable from [inc A] to
[inc B]. *)
Definition map_inc V1 V2 (f : V1 → V2) : inc V1 → inc V2 :=
  λ v, match v with
  | VZ    => VZ
  | VS v' => VS (f v')
  end.

(** Change the variable representation type [V] to [V']. *)
Fixpoint V_map_val
V V' (f : V → V')
(v : val V) {struct v} : val V' :=
match v with
| val_var x => val_var (f x)
| val_unit => val_unit
| val_bool b => val_bool b
| val_real r => val_real r
| val_fun e => val_fun (V_map_exp (map_inc f) e)
| val_fix e => val_fix (V_map_exp (map_inc f) e)
| val_pair v1 v2 => val_pair (V_map_val f v1) (V_map_val f v2)
| val_unif => val_unif
| val_query e => val_query (V_map_exp f e)
end
with V_map_exp
V V' (f : V → V')
(e : exp V) {struct e} : exp V' :=
match e with
| exp_val v => exp_val (V_map_val f v)
| exp_app e1 e2 => exp_app (V_map_exp f e1) (V_map_exp f e2)
| exp_let e1 e2 => exp_let (V_map_exp f e1) (V_map_exp (map_inc f) e2)
| exp_binop op e1 e2 => exp_binop op (V_map_exp f e1) (V_map_exp f e2)
| exp_proj e b => exp_proj (V_map_exp f e) b
| exp_if e1 e2 e3 => exp_if (V_map_exp f e1) (V_map_exp f e2) (V_map_exp f e3)
| exp_sample e => exp_sample (V_map_exp f e)
| exp_score e => exp_score (V_map_exp f e)
| exp_exn => exp_exn
end
.

Notation V_shift_val := (V_map_val (@VS _)).
Notation V_shift_exp := (V_map_exp (@VS _)).

(** Syntactic objects that do not contain free variables can be used
in any context that binds free variables. *)
Notation V_open_val := (V_map_val ∅→).
Notation V_open_exp := (V_map_exp ∅→).

(** If we have a substitution function of form [V → val V'],
then we can turn it into one of form [inc V → val (inc V')]. *)
Definition V_lift_inc V V' (f : V → val V') : inc V → val (inc V') :=
λ x, match x with
| VZ   => val_var VZ
| VS β => V_shift_val (f β)
end.

(** Apply the substitution function [f : V → val V'] *)
Fixpoint V_bind_val
V V' (f : V → val V')
(v : val V) {struct v} : val V' :=
match v with
| val_var x => f x
| val_unit => val_unit
| val_bool b => val_bool b
| val_real r => val_real r
| val_fun e => val_fun (V_bind_exp (V_lift_inc f) e)
| val_fix e => val_fix (V_bind_exp (V_lift_inc f) e)
| val_pair v1 v2 => val_pair (V_bind_val f v1) (V_bind_val f v2)
| val_unif => val_unif
| val_query e => val_query (V_bind_exp f e)
end
with V_bind_exp
V V' (f : V → val V')
(e : exp V) {struct e} : exp V' :=
match e with
| exp_val v => exp_val (V_bind_val f v)
| exp_app e1 e2 => exp_app (V_bind_exp f e1) (V_bind_exp f e2)
| exp_let e1 e2 => exp_let (V_bind_exp f e1) (V_bind_exp (V_lift_inc f) e2)
| exp_binop op e1 e2 => exp_binop op (V_bind_exp f e1) (V_bind_exp f e2)
| exp_proj e b => exp_proj (V_bind_exp f e) b
| exp_if e1 e2 e3 => exp_if (V_bind_exp f e1) (V_bind_exp f e2) (V_bind_exp f e3)
| exp_sample e => exp_sample (V_bind_exp f e)
| exp_score e => exp_score (V_bind_exp f e)
| exp_exn => exp_exn
end
.

(** Substitution functions for one free variable. *)
Definition V_substfun V (v : val V) : inc V → val V :=
λ x, match x with
| VZ   => v
| VS y => val_var y
end.

(** Substitution functions for one free variable. Innermost bound variable is
substituted by [v2]. *)
Definition V2_substfun V (v1 v2 : val V) : inc (inc V) → val V :=
λ x, match x with
| VZ        => v2
| VS VZ     => v1
| VS (VS y) => val_var y
end.

Notation V_subst_val v := (V_bind_val (V_substfun v)).
Notation V_subst_exp v := (V_bind_exp (V_substfun v)).


Require Import
  Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.

Definition Comp (A : Type) := A -> Prop.

#[export]
Program Instance Comp_Functor : Functor Comp := {
  fmap := fun A B f (x : Comp A) b => exists a : A, x a /\ f a = b
}.

#[export]
Program Instance Comp_Applicative : Applicative Comp := {
  pure := fun _ x a => x = a;
  ap   := fun A B mf mx r => exists f x, mf f /\ mx x /\ f x = r
}.

#[export]
Program Instance Comp_Alternative : Alternative Comp := {
  empty  := fun A _ => False;
  choose := fun A x y s => x s \/ y s (* jww (2016-01-28): right? *)
}.

#[export]
Program Instance Comp_Monad : Monad Comp := {
  join := fun A m r => exists t : Comp A, t r /\ m t
}.

Require Import FunctionalExtensionality.

Module CompLaws.

Import MonadLaws.

Axiom prop_ext : forall (P Q : Prop), (P <-> Q) -> P = Q.

Ltac shatter :=
  unfold comp, id in *;
  repeat
    match goal with
    | [ H : _ = _           |- _               ] => subst
    | [ H : and _ _         |- _               ] => destruct H
    | [ H : exists _ : _, _ |- _               ] => destruct H
    | [                     |- exists _ : _, _ ] => eexists
    | [                     |- and _ _         ] => split
    end;
  simpl in *.

Ltac simplify_comp :=
  repeat let x := fresh "x" in extensionality x;
  try (apply prop_ext; split; intros);
  repeat (simpl; shatter; try constructor; eauto).

Local Obligation Tactic := simpl; intros; simplify_comp.

#[export]
Program Instance Comp_FunctorLaws     : FunctorLaws Comp.
#[export]
Program Instance Comp_ApplicativeLaws : ApplicativeLaws Comp.
#[export]
Program Instance Comp_MonadLaws       : MonadLaws Comp.

End CompLaws.

Definition comp `(f : A -> Prop) : Comp A := f.

Definition computes_to {A : Type} (ca : Comp A) (a : A) : Prop := ca a.

Notation "c ↝ v" := (computes_to c v) (at level 40).


Require Export Nat Arith.EqNat.

(* assignments *)

Parameter D : Set.
Definition assignment := nat -> D.

Definition update (theta : assignment) (i : nat) (d : D) : assignment :=
  fun j : nat => if j =? i then d else theta j.

Axiom outside_data_exists :
  forall theta : assignment, exists d : D, forall i, theta i <> d.

Axiom outside_data_exists' :
  forall theta theta': assignment, exists d : D,
    (forall i, theta i <> d) /\ (forall i, theta' i<> d).

(* guard *)

Definition guard := nat -> Prop.  (* a subset of nat *)

(* note: b_is_empty_or_not can be proved under the classical logic. *)
Axiom b_is_empty_or_not :
  forall b : guard, (forall i, ~ b i) \/ exists i, b i.

(* equivalence relations *)

Inductive register :=
  | X  (i : nat)
  | X' (i : nat).

Definition Rel := register -> register -> Prop.

Definition is_reflexive  (phi : Rel) : Prop := forall x, phi x x.
Definition is_symmetric  (phi : Rel) : Prop := forall x y, phi x y -> phi y x.
Definition is_transitive (phi : Rel) : Prop :=
  forall x y z, phi x y /\ phi y z -> phi x z.
Definition is_equiv_rel   (phi : Rel) : Prop :=
  is_reflexive phi /\ is_symmetric phi /\ is_transitive phi.

Definition lat (phi : Rel) : Rel :=
  fun xi xj : register =>
    match xi, xj with
    | (X i), (X j) => phi (X' i) (X' j)
    | x, y => x = y
    end.

Definition former (phi : Rel) : Rel :=
  fun xi xj : register =>
    match xi, xj with
    | (X i), (X j) => phi (X i) (X j)
    | x, y => x = y
    end.

Definition inv (phi : Rel) (i : nat) : guard :=
  fun l : nat => phi (X l) (X' i).

Definition after (gamma : Rel) (b : guard) (i : nat) : Rel :=
  fun xj xl : register =>
    match xj, xl with
    | (X j), (X l) => if j =? i then b l \/ l = i else
                      if l =? i then b j          else gamma (X j) (X l)
    | x, y => x = y
    end.

Definition afterR (phi : Rel) (b : guard) (i : nat) : Rel -> Prop :=
  fun phi' : Rel =>
    former phi' = former phi /\
    lat phi' = after (lat phi) b i /\
    (forall j l, (phi (X j) (X' l) /\ b l -> phi' (X j) (X' i)) /\
              (~ (phi (X j) (X' l) <-> b l) -> ~ phi' (X j) (X' i))) /\
    (forall j l, l <> i -> (phi (X j) (X' l) <-> phi' (X j) (X' l))) /\
    (forall j l, phi' (X j) (X' l) <-> phi' (X' l) (X j)).

Definition afterL (phi : Rel) (i : nat) : Rel :=
  fun xl xj : register =>
    match xl, xj with
    | (X  l), (X  j) => (after (former phi) (inv phi i) i) xl xj
    | (X' l), (X' j) => phi xl xj
    | (X  l), (X' j) => if l =? i then phi (X' i) (X' j) else phi xl xj
    | (X' l), (X  j) => if j =? i then phi (X' i) (X' l) else phi xl xj
    end.

Definition rel_between (theta1 theta2 : assignment) : Rel :=
  fun xi xj : register =>
    match xi, xj with
    | (X  i), (X  j) => theta1 i = theta1 j
    | (X  i), (X' j) => theta1 i = theta2 j
    | (X' i), (X  j) => theta2 i = theta1 j
    | (X' i), (X' j) => theta2 i = theta2 j
    end.

(* an equivalence relation over (X i)'s *)
Definition is_simpl_rel (phi : Rel) :=
  forall xi xj : register,
    match xi, xj with
    | (X i), (X j) => True
    | x, y => phi x y <-> x = y
    end.

Axiom rel_extensionality :
  forall phi phi' : Rel,
    (forall x y, phi x y <-> phi' x y) -> phi = phi'.

(* models *)

Class Models (A B : Type) := models : A -> B -> Prop.
Notation "S '|=' T" := (models S T) (at level 59).

Instance rel_models_guard : Models Rel guard :=
  { models phi b := forall i, b i ->
                    forall j, b j <-> phi (X i) (X j) }.
Instance assignment_models_rel : Models assignment Rel :=
  { models theta phi := is_simpl_rel phi /\
                        forall i j, theta i = theta j <-> phi (X i) (X j) }.
Instance assignmentD_models_guard : Models (assignment * D) guard :=
  { models theta_d b :=
      match theta_d with
      | (theta, d) => forall i, theta i = d <-> b i
      end }.
Instance two_assignments_model_rel : Models (assignment * assignment) Rel :=
  { models pair phi :=
      match pair with
      | (theta, theta') =>
          forall i j, (theta  i = theta  j <-> phi (X  i) (X  j)) /\
                      (theta' i = theta' j <-> phi (X' i) (X' j)) /\
                      (theta  i = theta' j <-> phi (X  i) (X' j)) /\
                      (theta' i = theta  j <-> phi (X' i) (X  j))
      end }.

(* grammar *)

Local Open Scope type_scope.

Parameter V : Set.  (* nonterminals *)
Definition V' := V * Rel.

Parameter ruleG :
  V' -> (option (guard * nat)) -> (option nat) -> V' -> Prop.

Axiom ruleG_is_normal_form :
  forall A B gamma gamma' jj,
    (ruleG (A, gamma) None jj (B, gamma') -> gamma = gamma') /\
    (forall b i,
     ruleG (A, gamma) (Some (b, i)) jj (B, gamma') ->
       gamma |= b /\ gamma' = after gamma b i).

Definition ruleG' (v1 : V') (gg : option (guard * nat)) (jj : option nat)
                  (v2 : V') : Prop :=
  match v1, v2 with
  | (A, phi), (B, phi') =>
    match gg with
    | Some (b, j) =>
        ruleG (A, lat phi) None (Some j) (B, lat phi') /\
           b = inv phi j /\
        phi' = afterL phi j /\
          jj = Some j
    | None =>
       (ruleG (A, lat phi) None None (B, lat phi') /\
        phi' = phi /\ jj = None) \/
       (exists b i,
        ruleG (A, lat phi) (Some (b, i)) None (B, lat phi') /\
        afterR phi b i phi' /\ jj = None)
    end
  end.

Definition config := V' * assignment.

Definition derivG (c1 : config) (dd : option D) (c2 : config) : Prop :=
  match c1, c2 with
  | ((A, gamma), theta), ((B, gamma'), theta') =>
    match dd with
    | Some d =>
        exists j,
        ruleG (A, gamma) None (Some j) (B, gamma') /\
        theta = theta' /\ d = theta j
    | None =>
       (ruleG (A, gamma) None None (B, gamma') /\
        theta = theta')
        \/
       (exists b i d,
        ruleG (A, gamma) (Some (b, i)) None (B, gamma') /\
        (theta, d) |= b /\ theta' = update theta i d)
    end
  end.

Definition derivG' (c1 : config) (dd : option D) (c2 : config) : Prop :=
  match c1, c2 with
  | ((A, phi), theta), ((B, phi'), theta') =>
    match dd with
    | Some d' =>
        exists b i j d,
        ruleG' (A, phi) (Some (b, i)) (Some j) (B, phi') /\
        (theta, d) |= b /\
        theta' = update theta i d /\
        d' = theta' j
    | None =>
        ruleG' (A, phi) None None (B, phi') /\
        theta = theta'
    end
  end.

Local Close Scope type_scope.


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 A B C D : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ C D /\ (col_ A C D /\ col_ B C D)))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Definitions related to pseudoradom functions.  This file copies some items from ConstructedFunc.v, so we probably need to refactor this in the future. *)

Set Implicit Arguments.
Require Import FCF.
Require Import CompFold.
Require Export Array.

Local Open Scope list_scope.
Local Open Scope array_scope.

Definition oracleMap(D R S: Set)(eqds : EqDec S)(eqdr : EqDec R)(oracle : S  -> D -> Comp (R * S))(s : S)(ds : list D) :=
  compFold _
  (fun acc d => [rs, s] <-2 acc; [r, s] <-$2 oracle s d; ret (rs ++ r :: nil, s))
  (nil, s) ds.

Theorem oracleMap_wf :
  forall (D R S : Set)(eqds : EqDec S)(eqdr : EqDec R) (oracle : S -> D -> Comp (R * S))ds s,
  (forall s x, well_formed_comp (oracle s x)) ->
  well_formed_comp (@oracleMap D R S _ _ oracle s ds).

  intuition.
  unfold oracleMap.
  eapply compFold_wf; intuition.
  wftac.

Qed.

Section RandomFunc.

  Variable D R : Set.
  Variable RndR : Comp R.

  Hypothesis EqDec_D : EqDec D.
  Instance EqDec_R : EqDec R.
    eapply comp_EqDec.
    eauto.
  Qed.

  Hypothesis RndR_wf : well_formed_comp RndR.

    (* A random function *)
  Definition randomFunc (f : (list (D * R))) (d : D) : Comp (R * list (D * R)) :=
      match (arrayLookup _ f d) with
        | None => (r <-$ RndR; ret (r, (d, r) :: f))
        | Some r => ret (r, f)
      end.

  Lemma randomFunc_wf : forall f d,
    well_formed_comp (randomFunc f d).

    intuition.
    unfold randomFunc.
    case_eq (f#d); intuition; wftac.

  Qed.

  Hint Resolve randomFunc_wf : wftac.

  (* Eager random functions with finite domain *)
  Definition RndFunc(lsd : list D) : Comp (list (D * R)) :=
    compFold _ (fun f d => r <-$ RndR; ret (d, r)::f) nil lsd.

End RandomFunc.

Local Open Scope type_scope.
Local Open Scope comp_scope.

Section PRF_concrete.

  Variable D R Key : Set.
  Variable RndKey : Comp Key.
  Variable RndR : Comp R.
  Variable f : Key -> D -> R.

  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Definition RndR_func : (list (D * R) -> D -> Comp (R * list (D * R))) :=
    (randomFunc RndR _).

  Section PRF_NA_concrete.
  (* A PRF that is secure against a non-adaptive adversary. *)

    Variable State : Set.
    Variable A1 : Comp (list D * State).
    Variable A2 : State -> list R -> Comp bool.

    Definition PRF_NA_G_A : Comp bool :=
      [lsD, s_A] <-$2 A1;
      lsR <-$ (k <-$ RndKey; ret (map (f k) lsD));
      A2 s_A lsR.

    Definition PRF_NA_G_B : Comp bool :=
      [lsD, s_A] <-$2 A1;
      [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD;
      A2 s_A lsR.

    Definition PRF_NA_Advantage :=
    | Pr[PRF_NA_G_A] - Pr[PRF_NA_G_B] |.

  End PRF_NA_concrete.

  Section PRF_NAI_concrete.

    Variable A_state : Set.
    Variable A1 : Comp ((list (list D)) * A_state).
    Variable A2 : A_state -> list (list R) -> Comp bool.

    Definition PRF_NAI_G0 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => k <-$ RndKey; ret (map (f k) lsD)) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_G1 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_Advantage :=
    | Pr[PRF_NAI_G0] - Pr[PRF_NAI_G1] |.

  Section PRF_NA_impl_NAI.

    Require Export Hybrid.

    Variable maxLists : nat.
    Hypothesis maxLists_correct :
      forall ls s_A,
        In (ls, s_A) (getSupport A1) ->
        (length ls <= maxLists)%nat.

    Hypothesis A_state_EqDec : EqDec A_state.
    Hypothesis RndR_wf : well_formed_comp RndR.
    Hypothesis RndKey_wf : well_formed_comp RndKey.

    Variable maxDistance : Rat.
    Hypothesis maxDistance_correct :
      forall i,
      PRF_NA_Advantage (B1 nil _ _ A1 i) (B2 (fun lsD => k <-$ RndKey; ret (map (f k) lsD))
              (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR)
              _ A2) <= maxDistance.

    Theorem PRF_NA_impl_NAI :
      PRF_NAI_Advantage <= (maxLists / 1 * maxDistance)%rat.

      Theorem PRF_NAI_Advantage_eq_Hybrid:
        PRF_NAI_Advantage == ListHybrid_Advantage
                               (fun lsD => k <-$ RndKey; ret (map (f k) lsD))
                               (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR)
                               _ A1 A2.

        reflexivity.

      Qed.

      rewrite PRF_NAI_Advantage_eq_Hybrid.
      rewrite Single_impl_ListHybrid.
      reflexivity.

      intuition.
      wftac.

      intuition.
      wftac.
      eapply oracleMap_wf.
      intuition.
      eapply randomFunc_wf; intuition.
      intuition.

      intuition.

      assert (DistSingle_Adv (fun lsD : list D => k <-$ RndKey; ret map (f k) lsD)
     (fun lsD : list D =>
      z <-$
      oracleMap (list_EqDec (pair_EqDec D_EqDec R_EqDec)) R_EqDec RndR_func
        nil lsD; [lsR, _]<-2 z; ret lsR)
     (B1 nil (list_EqDec D_EqDec) A_state_EqDec A1 i)
     (B2 (fun lsD : list D => k <-$ RndKey; ret map (f k) lsD)
        (fun lsD : list D =>
         z <-$
         oracleMap (list_EqDec (pair_EqDec D_EqDec R_EqDec)) R_EqDec
           RndR_func nil lsD; [lsR, _]<-2 z; ret lsR)
        (list_EqDec R_EqDec) A2)
     ==
     PRF_NA_Advantage
                          (B1 nil (list_EqDec D_EqDec) A_state_EqDec A1 i)
                          (B2
                             (fun lsD : list D =>
                              k <-$ RndKey; ret map (f k) lsD)
                             (fun lsD : list D =>
                              z <-$
                              oracleMap
                                (list_EqDec (pair_EqDec D_EqDec R_EqDec))
                                R_EqDec RndR_func nil lsD;
                              [lsR, _]<-2 z; ret lsR)
                             (list_EqDec R_EqDec) A2)
                          ).
      unfold DistSingle_Adv, PRF_NA_Advantage, DistSingle_G, PRF_NA_G_A, PRF_NA_G_B.
      eapply ratDistance_eqRat_compat;
        repeat (try comp_skip; try reflexivity; comp_simp; inline_first).
      rewrite H.
      clear H.
      intuition.
    Qed.

  End PRF_NA_impl_NAI.

  End PRF_NAI_concrete.

  Section PRF_Full_concrete.

    Variable A : OracleComp D R bool.

    Definition f_oracle(k : Key)(x : unit)(d : D) :=
      ret (f k d, tt).

    Definition PRF_G_A : Comp bool :=
      k <-$ RndKey;
      [b, _] <-$2 A _ _ (f_oracle k) tt;
      ret b.

    Definition PRF_G_B : Comp bool :=
      [b, _] <-$2 A _ _ (RndR_func) nil;
      ret b.

    Definition PRF_Advantage :=
    | Pr[PRF_G_A] - Pr[PRF_G_B] |.

  End PRF_Full_concrete.

  Section PRF_Finite_concrete.

    Variable dom : list D.
    Variable def : R.
    Variable A : (D -> R) -> Comp bool.

    Definition PRF_Fin_G_A : Comp bool :=
      k <-$ RndKey;
      A (f k).

    Definition PRF_Fin_G_B : Comp bool :=
      f <-$ @RndFunc D R RndR _ dom;
      A (fun d => arrayLookupDef _ f d def).

    Definition PRF_Fin_Advantage :=
    | Pr[PRF_Fin_G_A] - Pr[PRF_Fin_G_B] |.

  End PRF_Finite_concrete.

End PRF_concrete.

Require Import Asymptotic.
Require Import Admissibility.

Section PRF.

  Variable D R Key : DataTypeFamily.
  Variable RndKey : forall n, Comp (Key n).
  Variable RndR : forall n, Comp (R n).
  Variable f : forall n, Key n -> D n -> R n.

  Hypothesis D_EqDec : forall n, EqDec (D n).
  Hypothesis R_EqDec : forall n, EqDec (R n).

  Section PRF_NA.
    Variable admissible_A1 : pred_comp_fam.
    Variable admissible_A2 : pred_comp_func_2_fam.

    Definition PRF_NA :=
      forall (State : DataTypeFamily) A1 A2,
        admissible_A1 _ A1 ->
        admissible_A2 State _ _ A2 ->
        negligible (fun n => PRF_NA_Advantage (RndKey n) (RndR n) (@f n) _ _ (A1 n) (@A2 n)).
  End PRF_NA.

  Section PRF_Full.
    Variable admissible_A : pred_oc_fam.

    Definition PRF :=
      forall (A : forall n, OracleComp (D n) (R n) bool),
        admissible_A _ _ _ A ->
        negligible (fun n => PRF_Advantage (RndKey n) (RndR n) (@f n) _ _ (A n)).
  End PRF_Full.

End PRF.


Require Import Setoid CMorphisms.
(* Require Import Relations Morphisms. *)
Require Import Coq.Classes.CRelationClasses.
Require Import FunctionalExtensionality.

(* Local Unset Elimination Schemes. *)

Notation "'∏'  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.

Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity).

Record total2 { T: Type } ( P: T -> Type ): Type :=
  tpair
  { pr1 : T;
    pr2 : P pr1
  }.

Arguments tpair {_} _ _ _.
Arguments pr1 {_ _} _.
Arguments pr2 {_ _} _.

Notation "{ x ; .. ; y ; z }" := (tpair _ x .. (tpair _ y z) ..).

Notation "'∑'  x .. y , P" := (total2 (fun x => .. (total2 (fun y => P)) ..))
(at level 200, x binder, y binder, right associativity) : type_scope.

Inductive Id {A: Type}: A -> A -> Type :=
  refl: forall a, Id a a.

Arguments refl {A a} , [A] a.

(* Scheme Id_ind := Induction for Id Sort Type.
Arguments Id_ind [A] P f y y0 i.
Scheme Id_rec := Minimality for Id Sort Type.
Arguments Id_rec [A] P f y y0 i.
Definition Id_rect := Id_ind.
 *)

Notation " R ===> R' " := (@CMorphisms.respectful _ _ (R%signature) (R'%signature))
(right associativity, at level 70) : signature_scope.

(*
Instance all_iff_morphism (A : Type) (x y: A) :
         CMorphisms.Proper (@Id A ===> @Id A) (@Id A).
 *)
Lemma is_refl_id: forall {A: Type} {a: A}, Id a a.
Proof. intros. easy. Defined.

Lemma is_sym_id: forall {A: Type} {a b: A}, Id a b -> Id b a.
Proof. intros. now induction X. Defined.

Lemma is_trans_id: forall {A: Type} {a b c: A}, Id a b -> Id b c -> Id a c.
Proof. intros. now induction X. Defined.

Global Instance transitive_paths {A} : Transitive (@Id A).
Proof. unfold Transitive. intros. exact( @is_trans_id A x y z X X0). Defined.

Definition dirprod (A B : Type): Type := ∑ a: A, B.
Definition dppr1 {A B : Type} := pr1: dirprod A B -> A.
Definition dppr2 {A B : Type} := pr2: dirprod A B -> B.

Notation "C × D ":= (@dirprod C D) (at level 40, left associativity).

Reserved Notation "x '~>' y" (at level 70, y at next level).
Reserved Notation "x '==' y" (at level 70).
Reserved Notation "x 'o' y" (at level 69).

Definition compose {A B C: Type} (f: A -> B) (g: B -> C): (A -> C).
Proof. intro a. now apply g, f. Defined.

Definition ap {A B: Type} {a b: A} (f: A -> B): Id a b -> Id (f a) (f b).
Proof. intro p. now induction p. Defined.

Definition concat {A: Type} {a b c: A}: Id a b -> Id b c -> Id a c.
Proof. intros p q. now induction p. Defined.

Definition homotopy {A: Type} {P: A -> Type} (f g: (∏ a: A, P a)): Type :=
  ∏ a: A, Id (f a) (g a).

Definition qinv {A B: Type} (f: A -> B): Type :=
  ∑ (g: B -> A), (dirprod (homotopy (compose g f) (@id B))
                          (homotopy (compose f g) (@id A))).

Definition isequiv {A B: Type} (f: A -> B): Type :=
  dirprod (∑ (g: B -> A),(homotopy (compose g f) (@id B)))
          (∑ (h: B -> A),(homotopy (compose f h) (@id A))).

Definition ishae {A B: Type} (f: A -> B) :=
  ∑ g: B -> A,
    ∑ eta: (homotopy (compose f g) (@id A)),
    ∑ eps: (homotopy (compose g f) (@id B)),
      ∏ x: A, Id (ap f (eta x)) (eps (f x)).

Definition Id_eql: ∏ {A: Type} (a b: A), Id a b -> a = b.
Proof. intros A a b p. now induction p. Defined.

Definition Id_eqr: ∏ {A: Type} (a b: A), a = b -> Id a b.
Proof. intros A a b p. now rewrite p. Defined.

Example h249_i: ∏ {A B: Type} {f: A -> B}, qinv f -> isequiv f.
Proof. intros A B f eq.
       destruct eq as (g, (pd1, pd2)).
       unshelve econstructor.
       - exists g. exact pd1.
       - exists g. exact pd2.
Defined.

Example h249_ii: ∏  {A B: Type} {f: A -> B}, isequiv f -> qinv f.
Proof. intros A B f eq.
       destruct eq as ((g, alpha), (h, beta)).
       unshelve econstructor.
       - exact g.
       - unshelve econstructor.
         + exact alpha.
         + intro a. compute in *.
           pose proof beta as beta'.
           specialize (beta (g (f a))).
           apply Id_eql in beta.
           specialize (alpha (f a)).
           apply Id_eql in alpha.
           rewrite alpha in beta.
           now rewrite <- beta.
Defined.

Definition inverse {A: Type} {a b: A}: Id a b -> Id b a.
Proof. intro p. now induction p. Defined.

Lemma ap_refl: ∏ {A B: Type} {a: A} (f: A -> B), Id (ap f (refl a)) (refl (f a)).
Proof. intros. now cbn. Defined.

Lemma app_id: ∏ {A: Type} {a b: A} (p: Id a b), Id (ap id p) p.
Proof. intros. now induction p. Defined.

Lemma l_concat_refl: ∏ {A: Type} (a b: A) (p: Id a b),
  Id (concat (refl a) p) p.
Proof. intros. now induction p. Defined.

Lemma r_concat_refl: ∏ {A: Type} (a b: A) (p: Id a b),
  Id (concat p (refl b)) p.
Proof. intros. now induction p. Defined.

(* Lemma concat_assoc: ∏ {A: Type} {a b c d: A} (p: Id a b) (q: Id b c) (r: Id c d),
  Id (concat p (concat q r)) (concat (concat p q) r).
Proof. intros.
       induction p; induction q; induction r.
       simpl.
       apply refl.
Qed. *)

Lemma l_concat_remove: ∏ {A: Type} {a b c: A} (p: Id a b) (q r: Id b c),
  Id (concat p q) (concat p r) -> Id q r.
Proof. intros until r. intro H.
       apply Id_eql in H.
       induction p.
       specialize (@l_concat_refl A a c q); intros H0.
       apply Id_eql in H0. rewrite H0 in H.
       specialize (@l_concat_refl A a c r); intros H1.
       apply Id_eql in H1. rewrite H1 in H.
       now subst.
Defined.

Lemma r_concat_remove: ∏ {A: Type} {a b c: A} (p q: Id a b) (r: Id b c),
  Id (concat p r) (concat q r) -> Id p q.
Proof. intros until r. intro H.
       apply Id_eql in H.
       induction r.
       specialize (@r_concat_refl A a a0 p); intros H0.
       apply Id_eql in H0. rewrite H0 in H.
       specialize (@r_concat_refl A a a0 q); intros H1.
       apply Id_eql in H1. rewrite H1 in H.
       now subst.
Defined.

Lemma h243: ∏ {A B: Type} {a b: A} (f g: A -> B) (p: Id a b) (H: homotopy f g),
  Id (concat (H a) (ap g p)) (concat (ap f p) (H b)).
Proof. intros until p. induction p. intro H.
       specialize (@ap_refl A B a f); intros H0.
       apply Id_eql in H0. rewrite H0.
       specialize (@ap_refl A B a g); intros H1.
       apply Id_eql in H1. rewrite H1.
       now destruct H.
Defined.

Corollary h244: ∏ {A: Type} {a: A} (f: A -> A) (H: homotopy f (@id A)),
  Id (H (f a)) (ap f (H a)).
Proof. intros.
       specialize (@h243 _ A  _ _ f id (H a) H); intros Hk.
       pose proof Hk as Hkk.
       apply Id_eql in Hk. unfold id in *.
       assert ((ap (λ a : A, a) (H a) = (H a))).
       {  specialize (@app_id A _ _ (H a)); intros.
          now apply Id_eql in X.  }
       rewrite H0 in Hk. unfold homotopy in H.
       apply Id_eqr in Hk.
       apply (@r_concat_remove A (f (f a)) (f a) a (H (f a)) (ap f (H a)) (H a) Hk).
Defined.

Lemma concat_assoc: ∏ {A: Type} (a b c d: A) (p: Id a b) (q: Id b c)
  (r: Id c d), Id (concat p (concat q r)) (concat (concat p q) r).
Proof. intros. now induction p, q, r. Defined.

Lemma concat_inverse_l: ∏ {A: Type} (a b: A) (p: Id a b), Id (concat (inverse p) p) refl.
Proof. intros. now induction p. Defined.

Lemma concat_inverse_r: ∏ {A: Type} (a b: A) (p: Id a b), Id (concat p (inverse p)) refl.
Proof. intros. now induction p. Defined.

Lemma help: ∏ {A B: Type} (a: A) (f: A -> B) (g: B -> A) (p: Id (g (f a)) a),
Id (ap f (ap (λ a0 : A, g (f a0)) p)) (ap (λ a0 : A, f (g (f a0))) p).
Proof. intros. induction p. now cbn. Defined.

Lemma h243_2: ∏ {A B: Type} (x y: A) (p: Id x y) (f g: A -> B) (H: ∏a: A, Id (f a) (g a)),
  Id  (concat (ap f p) (H y)) (concat (H x) (ap g p)).
Proof. intros. apply inverse. apply h243. Defined.

Lemma qinv_ishae: ∏ {A B: Type} (f: A -> B), qinv f -> ishae f.
Proof. intros A B f e.
       destruct e as (g, (eps, eta)).
       unshelve econstructor.
       - exact g.
       - exists eta.
         unshelve econstructor.
         unfold homotopy, compose, id in *.
         intro b.
         exact ( concat (inverse (eps (f (g b)))) (concat (ap f (eta (g b))) (eps b)) ).
         intro a.
         cbn.
         specialize (@h244 ); intro Hc.
         unfold homotopy, compose, id in *.
         specialize (@Hc A a (compose f g) eta). cbn in *.
         unfold compose in *.

         assert (Hd: Id (ap f (eta (g (f a)))) (ap f (ap (compose f g) (eta a))) ).
         { unfold compose. now induction Hc. }
         assert (He: Id (concat (ap f (eta (g (f a)))) (eps (f a)))
                        (concat (ap f (ap (compose f g) (eta a))) (eps (f a))) ).
         { now induction Hd. }
         assert (Hf: Id (concat (ap f (ap (compose f g) (eta a))) (eps (f a)))
                        (concat (eps (f (g (f a)))) (ap f (eta a)) )).

         { specialize (@h243_2 A B _ _ ( (eta a)) (compose f (compose g f)) f ); intro HH.
           unfold compose in *.
           specialize (HH (fun a => eps (f a))). cbn in *.
           apply Id_eql in HH. rewrite <- HH.
           apply Id_eqr. f_equal.
           specialize (@help A B a f g (eta a)); intro HHH.
           apply Id_eql in HHH. now rewrite HHH.
         }
         unfold compose in *.
         apply Id_eql in He. rewrite He.
         apply Id_eql in Hf. rewrite Hf.
         specialize (@concat_assoc _ _ _ _ _ (inverse (eps (f (g (f a)))))
           (eps (f (g (f a))))  (ap f (eta a))); intro Hca.
         apply Id_eql in Hca. rewrite Hca.
         specialize (@concat_inverse_l _ _ _ (eps (f (g (f a))))); intros Hci.
         apply Id_eql in Hci. rewrite Hci.
         specialize (@l_concat_refl _ _ _ (ap f (eta a))); intro Hcl.
         apply Id_eql in Hcl.
         now rewrite Hcl.
Defined.

Lemma ishae_qinv: ∏ {A B: Type} {f: A -> B}, ishae f -> qinv f.
Proof. intros A B f e.
       destruct e as (finv, (eta, (eps, cc))).
       unshelve econstructor.
       - exact finv.
       - split; easy.
Defined.

Lemma isequiv_ishae: ∏ {A B: Type} (f: A -> B), isequiv f -> ishae f.
Proof. intros A B f e.
       apply h249_ii in e.
       now apply qinv_ishae.
Defined.

Lemma ishae_isequiv: ∏ {A B: Type} (f: A -> B), ishae f -> isequiv f.
Proof. intros A B f e.
       apply ishae_qinv in e.
       now apply h249_i.
Defined.

Definition transport {A: Type} (P: A -> Type) {a b: A} (p: Id a b): P a -> P b.
Proof. now induction p. Defined.

Definition Equiv (A B: Type): Type := (∑ f: A -> B, isequiv f).

Definition idtoeqv: ∏ {A B: Type}, Id A B -> Equiv A B.
Proof. intros A B p.
       exists (transport (@id Type) p).
       apply h249_i.
       unshelve econstructor.
       + exact (transport _ (inverse p)).
       + now induction p.
Defined.

Definition happly {A: Type} {B: A -> Type} (f g: ∏x: A, B x): (Id f g) -> homotopy f g.
Proof. intros p a. now induction p. Defined.

Definition funext_def_qinv:= ∏  (A: Type) (B: A -> Type) (f g: ∏ x: A, B x),
  qinv (@happly A B f g).
Axiom FE: funext_def_qinv.

Definition funext {A: Type} {B: A -> Type} {f g: ∏ x: A, B x}: (∏ x: A, Id (f x) (g x)) -> Id f g.
Proof. destruct (FE A B f g) as (inv_happly, cc2).
       exact inv_happly.
Defined.

Definition funext_happly {A: Type} {B: A -> Type} {f g: ∏ x: A, B x}
                         (p: Id f g): Id (funext (happly _ _ p)) p.
Proof. unfold funext.
       destruct (FE A B f g) as (inv_happly, cc).
       destruct cc as (cc1, cc2).
       unfold homotopy, compose, id in cc2.
       exact (cc2 p).
Defined.

Definition happly_funext {A: Type} {B: A -> Type} {f g: ∏ x:A, B x}
                         (h: ∏ x:A, Id (f x) (g x)): Id (happly _ _ (funext h)) h.
Proof. unfold funext.
       destruct (FE A B f g) as (inv_happly, cc).
       destruct cc as (cc1, cc2).
       unfold homotopy, compose, id in cc2.
       exact (cc1 h).
Defined.

Definition Equiv_ishae (A B: Type): Type := (∑ f: A -> B, ishae f).

Definition idtoeqv_ishae: ∏ {A B: Type}, Id A B -> Equiv_ishae A B.
Proof. intros A B p.
       exists (transport (@id Type) p).
       apply qinv_ishae.
       unshelve econstructor.
       + exact (transport _ (inverse p)).
       + now induction p.
Defined.

Definition UA_def_ishae: Type := ∏ (A B: Type), ishae (@idtoeqv_ishae A B).
Axiom UA_ishae: UA_def_ishae.

Definition ua_ishae {A B : Type}: (Equiv_ishae A B) -> (Id A B).
Proof. destruct (UA_ishae A B) as (eqvtoid, cc).
        exact eqvtoid.
Defined.

Definition UA_def: Type := ∏ (A B: Type), isequiv (@idtoeqv A B).
Axiom UA: UA_def.

Definition isContr  (A: Type): Type := ∑ a: A, ∏ x: A, Id a x.

Definition linv {A B: Type} (f: A -> B) :=
  ∑ g: B -> A, homotopy (compose f g) (@id A).

Definition rinv {A B: Type} (f: A -> B) :=
  ∑ g: B -> A, homotopy (compose g f) (@id B).

Definition lcoh {A B: Type} (f: A -> B) (l: linv f) :=
  let (g, eta) := l in
  ∑ eps: homotopy (compose g f) (@id B), ∏y: B, Id (ap g (eps y)) (eta (g y)).

Definition rcoh {A B: Type} (f: A -> B) (r: rinv f) :=
  let (g, eps) := r in
  ∑ eta: homotopy (compose f g) (@id A), ∏x: A, Id (ap f (eta x)) (eps (f x)).

Definition fiber  {A B: Type} (f: A -> B) (y: B): Type := ∑ x: A, Id (f x) y.
Definition isContrf {A B: Type} (f: A -> B): Type := ∏ y: B, isContr (fiber f y).

Lemma h428_i: ∏ {A B C: Type} (f: A -> B), qinv f ->
  qinv (λ g: B -> C, compose f g).
Proof. intros A B C f e.
        destruct e as (g, (p, q)).
        unshelve econstructor.
          exact (λ (h: A -> C) (b: B), h (g b)).
        - split.
          + intro h. compute.
            unfold homotopy, compose, id in *.
            apply funext.
            intro x.
            specialize (q x).
            now induction q.
          + intro h. compute.
            unfold homotopy, compose, id in *.
            apply funext.
            intro x.
            specialize (p x).
            now induction p.
Defined.

Lemma h428_ii: ∏ {A B C: Type} (f: A -> B), qinv f ->
  qinv (λ g: C -> A, compose g f).
Proof. intros A B C f e.
        destruct e as (g, (p, q)).
        unshelve econstructor.
          exact (λ (h: C -> B) (c: C), g (h c)).
        - split;
            intro h; compute;
            unfold homotopy, compose, id in *;
            apply funext;
            intro x; easy.
Defined.

Lemma h429_l_i: ∏ {A B: Type} (f: A -> B),
  (linv f) -> (∑ g: B -> A, Id (compose f g) (@id A)).
Proof. intros A B f (g, p).
        unshelve econstructor.
        - exact g.
        - now apply funext in p.
Defined.

Lemma h429_l_ii: ∏ {A B: Type} (f: A -> B),
  (∑ g: B -> A, Id (compose f g) (@id A)) -> (linv f).
Proof. intros A B f (g, p).
        unshelve econstructor.
        - exact g.
        - now apply happly in p.
Defined.

Lemma h429_l: ∏ {A B: Type} (f: A -> B),
  Equiv (linv f) (∑ g: B -> A, Id (compose f g) (@id A)).
Proof. intros.
        unshelve econstructor.
        - apply h429_l_i.
        - unshelve econstructor.
          + unshelve econstructor.
            ++ apply h429_l_ii.
            ++ cbn.
                unfold h429_l_i, h429_l_ii in *.
                intros (g, p).
                specialize (@funext_happly _ _ _ _ p); intro H.
                unfold compose, homotopy, id in *.
                apply Id_eql in H. now rewrite H.
           + unshelve econstructor.
             ++ intros (g, p).
                unfold linv.
                exists g.
                now apply happly in p.
             ++ cbn.
                intros (g, p).
                specialize (@happly_funext _ _ _ _ p); intro H.
                apply Id_eql in H.
                unfold compose, homotopy, id, h429_l_i in *.
                cbn in *. apply Id_eqr. f_equal. easy.
Defined.

Require Import Equality.

Lemma h425_i: ∏ {A B: Type} (f: A -> B) (y: B) (a b: fiber f y),
  (Id a b) ->
  (∑ gamma: Id (pr1 a) (pr1 b), Id (concat (ap f gamma) (pr2 b)) (pr2 a)).
Proof. intros A B f y (x, p) (x', p') q.
        cbn.
        unshelve econstructor.
        - now inversion q.
        - cbn. inversion q.
          subst. apply Eqdep.EqdepTheory.inj_pair2 in H2.
          subst. dependent destruction q.
          cbn.  now destruct p'.
Defined.

Lemma h425_ii: ∏ {A B: Type} (f: A -> B) (y: B) (a b: fiber f y),
  (∑ gamma: Id (pr1 a) (pr1 b), Id (concat (ap f gamma) (pr2 b)) (pr2 a)) ->
  (Id a b).
Proof. intros A B f y (x, p) (x', p') (gamma, q).
        inversion q. cbn in *.
        induction gamma.
        specialize (@ap_refl A B a1 f); intros.
        apply Id_eql in X.
        rewrite X in H0.
        specialize (@l_concat_refl _ _ _ p'); intros.
        apply Id_eql in X0.
        rewrite X0 in H0.
        now rewrite H0.
Defined.

Lemma h426: ∏ {A B: Type} (f: A -> B), ishae f -> isContrf f.
Proof. intros A B f e.
        unfold isContrf.
        intro y.
        destruct e as (g, (eta, (eps, tau))).
        unshelve econstructor.
        - unfold fiber.
          exists (g y). apply eps.
        - intros (x, p).
           unfold compose, homotopy, id in *.
           apply h425_ii.
           cbn.
           unshelve econstructor.
           + clear tau. specialize (eta x).
             now induction p.
           + dependent destruction p. cbn.
             specialize (@r_concat_refl _ _ _ (ap f (eta x))); intros.
             apply Id_eql in X. rewrite X.
             apply tau.
Defined.

Lemma h436_ii: ∏ {A B: Type} (e: Equiv A B), isContr B -> isContr A.
Proof. intros A B e alpha.
        destruct alpha as (b, P).
        destruct e as (f, iseqf).
        unshelve econstructor.
        + exact (pr1 (pr2 iseqf) b).
        + intro a.
          destruct iseqf as ((g, Hg), (h, Hh)).
          cbn.
          unfold homotopy, compose, id in *.
          specialize (P (f a)).
          specialize (Hh a).
          apply Id_eql in P.
          now rewrite P in *.
Defined.

Lemma h429_linv: ∏ {A B: Type} (f: A -> B), qinv f -> isContr (linv f).
Proof. intros A B f e.
        specialize (@h429_l A B f); intros e2.
        specialize (@h428_i A B A f e); intros e3.
        apply qinv_ishae in e3.
        apply h426 in e3.
        unfold isContrf, fiber in e3.
        specialize (e3 id).
        apply h436_ii in e2; easy.
Defined.

Lemma h429_r_i: ∏ {A B: Type} (f: A -> B),
  (rinv f) -> (∑ g: B -> A, Id (compose g f) (@id B)).
Proof. intros A B f (g, p).
        unshelve econstructor.
        - exact g.
        - now apply funext in p.
Defined.

Lemma h429_r_ii: ∏ {A B: Type} (f: A -> B),
  (∑ g: B -> A, Id (compose g f) (@id B)) -> (rinv f).
Proof. intros A B f (g, p).
        unshelve econstructor.
        - exact g.
        - now apply happly in p.
Defined.

Lemma h429_r: ∏ {A B: Type} (f: A -> B),
  Equiv (rinv f) (∑ g: B -> A, Id (compose g f) (@id B)).
Proof. intros.
        unshelve econstructor.
        - apply h429_r_i.
        - unshelve econstructor.
          + unshelve econstructor.
            ++ apply h429_r_ii.
            ++ cbn.
                unfold h429_r_i, h429_r_ii in *.
                intros (g, p).
                specialize (@funext_happly _ _ _ _ p); intro H.
                unfold compose, homotopy, id in *.
                apply Id_eql in H. now rewrite H.
           + unshelve econstructor.
             ++ intros (g, p).
                unfold linv.
                exists g.
                now apply happly in p.
             ++ cbn.
                intros (g, p).
                specialize (@happly_funext _ _ _ _ p); intro H.
                apply Id_eql in H.
                unfold compose, homotopy, id, h429_r_i in *.
                cbn in *. apply Id_eqr. f_equal. easy.
Defined.

Lemma h429_rinv: ∏ {A B: Type} (f: A -> B), qinv f -> isContr (rinv f).
Proof. intros A B f e.
        specialize (@h429_r A B f); intros e2.
        specialize (@h428_ii A B B f e); intros e3.
        apply qinv_ishae in e3.
        apply h426 in e3.
        unfold isContrf, fiber in e3.
        specialize (e3 id).
        apply h436_ii in e2; easy.
Defined.

Lemma ishae_rcoh: ∏ {A B: Type} (f: A -> B),
  Equiv (ishae f) (∑u: rinv f, rcoh f {pr1 u; pr2 u}).
Proof. intros.
        unshelve econstructor.
        - intro e. destruct e as (g, (eps, (eta, p))).
          unshelve econstructor.
          + unfold rinv. exists g.
            easy.
          + cbn. exists eps. easy.
        - apply h249_i.
          unshelve econstructor.
          + intros ((g, Hg), H).
            unshelve econstructor.
            * exact g.
            * cbn in *.
              unfold homotopy, compose, id in *.
              unshelve econstructor.
              ++ intro a. now destruct H.
              ++ cbn. destruct H as (p, q).
                  exists Hg. easy.
          + split.
            * cbn. unfold compose, homotopy, id.
              intro H. destruct H as ((r, Hr), (eta, H)). cbn in *.
              easy.
            * cbn. unfold compose, homotopy, id.
              intro H. destruct H as (g, (eta, (eps, p))).
              easy.
Defined.

Definition ua_f {A B : Type} (f: A-> B): (isequiv f) -> (Id A B).
Proof. intro e.
       destruct (h249_ii (UA A B)) as (eqvtoid, cc).
       apply eqvtoid.
       exists f. exact e.
Defined.

Lemma h442: ∏ {A B X: Type} (e: Equiv A B), Equiv (X -> A) (X -> B).
Proof. intros A B X (f, e).
        unshelve econstructor.
        - exact (λ (a: (X -> A)) (x: X), f (a x)).
        - assert (H: ∑p: Id A B, Id {f; e} (idtoeqv p)).
          { unshelve econstructor.
             + apply ua_f in e. exact e.
             + cbn. unfold ua_f.
               destruct (h249_ii (UA A B)).
               destruct pr4 as (c, d).
               unfold compose, homotopy, id in *.
               specialize (c ({f; e})). easy.
          }
         destruct H as (p, q).
         induction p. apply Id_eql in q.
         inversion q. rewrite H0.
         unshelve econstructor.
         + exists id. now compute.
         + exists id. now compute.
Defined.

Corollary h432c: ∏ {A B: Type} (f: A -> B) (e: isequiv f) (x x':A) (y: B),
  dirprod (Id (f x) y) (Id (f x') y) -> Id x x'.
Proof. intros A B f e x x' y (p, q).
        apply h249_ii in e.
        destruct e as (g, (cc0, cc1)).
        unfold homotopy, compose, id in *.
        apply Id_eql in p. apply Id_eql in q.
        pose proof cc1 as cc2.
        specialize (cc1 x).
        specialize (cc2 x').
        assert (g (f x)  = g y) by now rewrite p.
        assert (g (f x') = g y) by now rewrite q.
        apply Id_eql in cc1. apply Id_eql in cc2.
        rewrite cc2 in H0.
        rewrite cc1 in H.
        rewrite <- H in H0.
        now rewrite H0.
Qed.

Corollary h432d: ∏ {A B: Type} (f: A -> B) (e: isequiv f) (y: B)
  (a b: ∑x: A, Id (f x) y), Id a b.
Proof. intros.
        destruct a as (a, p).
        destruct b as (b, q).
        specialize (@h432c A B f e a b y); intro H.
        assert (H0: dirprod (Id (f a) y) (Id (f b) y) ) by easy.
        specialize (H H0). induction H.
        dependent destruction p.
        dependent destruction q. easy.
Defined.

Lemma h432_i: ∏ {A B: Type} (f: A -> B), isequiv f -> isContrf f.
Proof. intros A B f e.
        unfold isContrf. intro y.
        specialize (@h432d A B f e y); intro H.
        unshelve econstructor.
        - unfold fiber.
          apply h249_ii in e.
          destruct e as (g, (cc0, cc1)).
          unfold homotopy, compose, id in *.
          exists (g y). easy.
        - cbn. destruct (h249_ii e), pr4. cbn.
          intro a. specialize (H a).
          specialize (H {pr3 y; pr4 y}). easy.
Defined.

Lemma h432_ii: ∏ {A B: Type} (f: A -> B), isContrf f -> isequiv f.
Proof. unfold isContrf.
        intros A B f e.
        apply h249_i.
        unshelve econstructor.
        - intro y.
          specialize (e y).
          destruct e as (fib, cc).
          destruct fib as (x, p).
          exact x.
        - compute. unshelve econstructor.
          + intro a. destruct (e a).
            destruct pr3. easy.
          + intro a. destruct (e (f a)) as ((x, p), cc).
            specialize (e (f a)).
            destruct e as (g, cc0).
            destruct g as (b, q).
            specialize (cc {a; refl}).
            apply Id_eql in cc.
            now inversion cc.
Defined.

Lemma h432: ∏ {A B: Type} (f: A -> B),
  dirprod ((isContrf f) -> (isequiv f))
          ((isequiv f) -> (isContrf f)) .
Proof. intros. split. apply h432_ii. apply h432_i. Defined.

Lemma h434: ∏ {A: Type} (P: A -> Type) {a: A},
  Equiv (fiber (@pr1 A P) a) (P a).
Proof. intros.
       unshelve econstructor.
       - intros Hf. destruct Hf as ((y, t), q).
         inversion q. subst. cbn. exact t.
       - apply h249_i.
         unshelve econstructor.
         + intro p.
           unfold fiber.
           unshelve econstructor.
           exists a. exact p.
           now cbn.
         + split.
           * unfold homotopy, compose, id.
             intro p. now cbn.
           * unfold homotopy, compose, id.
             intro p. destruct p as ((y, t), q).
             compute in *. now induction q.
Qed.

Corollary h443: ∏ {A: Type} (P: A -> Type) (p: ∏ x : A, isContr (P x)),
  Equiv (A -> ∑ x: A, P x) (A -> A).
Proof. intros A P p.
        apply h442.
        unshelve econstructor.
        + exact pr1.
        + apply h432. unfold isContrf.
          specialize (@h434 A P); intro H.
          intro a.
          specialize (@h436_ii _ _ (H a)); intro HH.
          apply HH. easy.
Defined.

Definition wfunext_def: Type := ∏  (A: Type) (P: A -> Type),
  (∏x: A, isContr (P x)) -> isContr (∏x: A, P x).

Definition retract (A B: Type) := ∑ r: A -> B, ∑ s: B -> A, ∏ y: B, Id (r (s y)) y.

Lemma h437: ∏ {A B: Type} (re: retract A B), isContr A -> isContr B.
Proof. intros A B e alpha.
        destruct alpha as (a, P).
        destruct e as (r, (s, eps)).
        unshelve econstructor.
        - exact (r a).
        - intro y.
          specialize (P (s y)).
          apply Id_eql in P. rewrite P. easy.
Defined.

Theorem h444: wfunext_def.
Proof. unfold wfunext_def.
        intros A P p.
        specialize (pr2 (h443 P p)); intros uf_equiv; cbn in uf_equiv.
        apply h432 in uf_equiv.
        unfold isContrf in uf_equiv; cbn in uf_equiv.
        specialize (uf_equiv id).
        assert (R: retract (fiber (λ (a : A -> ∑ x : A, P x) (x : A), pr1 (a x)) id)
                           (∏ x : A, P x)).
        { unshelve econstructor.
          - intro X.
            destruct X as (g, q).
            exact (λ x, @transport A P _ _ ((@happly _ _ _ _ q) x) (pr2 (g x))).
          - cbn. unshelve econstructor.
            + intro f. cbn in *.
              exact ({λ x: A, {x; (f x)}; refl}).
            + intros. cbn. easy.
        }
        specialize (@h437 _ _ R); intros HH. apply HH.
        easy.
Defined.

Lemma rcoh_r_contr: ∏ {A B: Type} (f: A -> B) (a: rinv f)
 (e: ishae f)
 (eta : homotopy (compose f (pr1 a)) id), isContr (∏ x : A, Id (ap f (eta x)) (pr2 a (f x))).
Proof. intros. apply h444.
       intro x. destruct a as (g, eps). cbn in *.
       pose proof e as d.
       pose proof e as c.
       apply ishae_rcoh in e.
       destruct e as (u, Hu). cbn in Hu.
       pose proof u as v.
       destruct u as (u, eps_u). cbn in Hu.
       destruct Hu as (eta_u, Hu).
       apply ishae_qinv in d.
       apply ishae_qinv in c.
       apply h429_rinv in d.
       apply h429_linv in c.

       destruct d as (d, Hd).
       pose proof Hd as Hd2.
       specialize (Hd  {u; eps_u}).
       specialize (Hd2  {g; eps}).
       assert (u = g).
       { apply Id_eql in Hd.
         apply Id_eql in Hd2.
         rewrite Hd in Hd2.
         now inversion Hd2.
       } subst.
       assert (eps = eps_u).
       { apply Id_eql in Hd.
         apply Id_eql in Hd2.
         rewrite Hd in Hd2.
         inversion Hd2.
         now apply Eqdep.EqdepTheory.inj_pair2 in H0.
       } subst.

       destruct c as (c, Hc).
       pose proof Hc as Hc2.
       specialize (Hc  {g; eta_u}).
       specialize (Hc2  {g; eta}).
       assert (eta = eta_u).
       { apply Id_eql in Hc.
         apply Id_eql in Hc2.
         rewrite Hc in Hc2.
         inversion Hc2.
         now apply Eqdep.EqdepTheory.inj_pair2 in H0.
       } subst.
       specialize (Hu x).
       induction Hu.
       unshelve econstructor.
       - easy.
       - intro x0. dependent destruction x0. easy.
Defined.

Lemma rcoh_contr: ∏ {A B: Type} (f: A -> B),
  ishae f ->  isContr (∑ u : rinv f, rcoh f {pr1 u; pr2 u}).
Proof. intros A B f e.

       pose proof e as d.
       pose proof e as c.
       pose proof e as b.
       apply ishae_rcoh in e.
       destruct e as (u, Hu).
       unshelve econstructor.
       exists u. easy.
       intro x.
       destruct x as (v, Hv). cbn in *.
       apply ishae_qinv in d.
       apply h429_rinv in d.
       assert (Id u v).
       { destruct d as (d, Hd).
         pose proof Hd as Hd2.
         specialize (Hd u).
         specialize (Hd2 v).
         now induction Hd.
       } induction X.

       apply ishae_qinv in c.
       apply h429_linv in c.
       destruct Hu as (eta_u, Hu).
       destruct Hv as (eta_v, Hv).
       destruct c as (c, Hc).
       unfold linv in c.
       pose proof Hc as Hc2.
       specialize (Hc  {pr1 a; eta_u}).
       specialize (Hc2 {pr1 a; eta_v}).
       assert (Id eta_u eta_v).
       { apply Id_eql in Hc.
         apply Id_eql in Hc2.
         rewrite Hc in Hc2.
         inversion Hc2.
         apply Eqdep.EqdepTheory.inj_pair2 in H0.
         rewrite H0. easy.
       } induction X.
       specialize (@rcoh_r_contr A B f a b a0); intros.
       destruct X as (p, q).
       pose proof q as k.
       specialize (q Hu).
       specialize (k Hv).
       induction q, k. easy.
Defined.

Lemma rcoh_contr_isequiv: ∏ {A B: Type} (f: A -> B),
  isequiv f ->  isContr (∑ u : rinv f, rcoh f {pr1 u; pr2 u}).
Proof. intros A B f e.
       apply isequiv_ishae in e.
       apply rcoh_contr. easy.
Defined.

Lemma ishae_contr: ∏ {A B: Type} (f: A -> B), ishae f -> isContr (ishae f).
Proof. intros A B f e.
       specialize (@ishae_rcoh A B f); intro H.
       apply h436_ii in H. easy.
       apply rcoh_contr. easy.
Defined.

Definition isProp (A: Type): Type :=  ∏ (x y: A), Id x y.

Lemma h35_i:∏ {A: Type}, (isProp A) -> (A -> isContr A).
Proof. intros A p a.
        unshelve econstructor.
        - exact a.
        - intro x. now specialize (p a x).
Defined.

Lemma h35_ii:∏ {A: Type}, (A -> isContr A) -> (isProp A).
Proof. intros A p a b.
        specialize (p a).
        destruct p as (c, p).
        pose proof p as q.
        specialize (p a).
        now induction p.
Defined.

Lemma h35: ∏ {A: Type}, Equiv (isProp A) (A -> isContr A).
Proof. intros.
        unshelve econstructor.
        - exact h35_i.
        - apply h249_i.
          unshelve econstructor.
          + exact h35_ii.
          + split.
            * unfold h35_i, h35_ii.
              unfold homotopy, compose, id.
              intro a. compute.
              apply funext.
              intro x.
              destruct (a x) as (b, p).
              destruct (p x). cbn.
              easy.
           * unfold homotopy, compose, id.
              intro a.
              apply funext.
              intro x.
              compute.
              induction (a x x).
              easy.
Defined.

Lemma ishae_isProp: ∏ {A B: Type} (f: A -> B), isProp (ishae f).
Proof. intros.
        specialize @h35; intros.
        specialize @ishae_contr; intros.
        specialize (X0 A B f). unfold isContr in X0.
        unfold isProp. intros.
        specialize (X0 x). destruct X0.
        pose proof pr4 as pr5.
        specialize (pr4 x).
        specialize (pr5 y).
        now induction pr4.
Defined.


(* Copyright Théo Zimmermann 2015
 * This Source Code Form is subject to the terms of the Mozilla Public License, v.2.0.
 * If a copy of the MPL was not distributed with this file, You can obtain one at
 * http://mozilla.org/MPL/2.0/.
 *)

From Coq Require Import Program.Basics CMorphisms.
Require Import Transfer CRespectful.

Set Warnings "-notation-overridden".
Local Notation " A <-> B " := (iffT A B) : type_scope.
Set Warnings "default".

Generalizable Variables A B.

(** * Totality declarations *)

(** Surjectivity, i.e. right-totality *)
Definition righttotal `(R : A -> B -> Type) := ((R ##> impl) ##> impl) all all.

(** Left-totality *)
Definition lefttotal `(R : A -> B -> Type) := ((R ##> flip impl) ##> flip impl) all all.

(** Both right and left-totality *)
Definition bitotal `(R : A -> B -> Type) := ((R ##> iff) ##> iff) all all.

(** * Uniqueness declarations *)

(** Functionality, i.e. right-uniqueness *)
Definition rightunique `(R : A -> B -> Type) := (R ##> R ##> impl) eq eq.

(** Injectivity, i.e. left-uniqueness *)
Definition leftunique `(R : A -> B -> Type) := (R ##> R ##> flip impl) eq eq.

(** Both right and left-unique *)
Definition biunique `(R : A -> B -> Type) := (R ##> R ##> iff) eq eq.

(** Definition of "bounded forall" *)
Definition ball `(subType : A -> Type) (predicate : A -> Prop) :=
  forall x, subType x -> predicate x.

(** ** Ltac to solve automatically some goals which just need reordering of hypotheses *)

Ltac apply_hyp :=
  match goal with
    [ H : _ |- _ ] => apply H
  end.

Ltac intro_and_apply :=
  apply_hyp + (intros ? * ; intro_and_apply).

Ltac flipdecl :=
  lazy beta delta;
  repeat (
      repeat split;
      repeat intro_and_apply
    ).

(** * Totality declarations *)

(** ** Straightforward properties *)

Lemma fliptotal `(R : A -> B -> Type) :
  righttotal (flip R) <-> lefttotal R.
Proof. flipdecl. Qed.

Lemma flipbitotal `(R : A -> B -> Type) :
  bitotal (flip R) <-> bitotal R.
Proof. flipdecl. Qed.

Lemma bitotal_from_right_and_left_total `(R : A -> B -> Type) :
  righttotal R -> lefttotal R -> bitotal R.
Proof. flipdecl. Qed.

(** ** More complex properties *)

Theorem righttotal_decl `(R : A -> B -> Type) :
  (forall x' : B, { x : A & R x x'}) -> righttotal R.
Proof.
  lazy delta zeta.
  intros Hsurj p p' Hp Hall x'.
  destruct (Hsurj x') as [x Rx].
  now apply (Hp x _).
Qed.

Theorem lefttotal_decl `(R : A -> B -> Type) :
  (forall x : A, { x' : B & R x x'}) -> lefttotal R.
Proof.
  intro.
  apply fliptotal.
  apply righttotal_decl.
  assumption.
Qed.

Theorem bitotal_decl `(R : A -> B -> Type) :
  (forall x' : B, { x : A & R x x'}) ->
  (forall x : A, { x' : B & R x x'}) ->
  bitotal R.
Proof.
  intros righttotal lefttotal.
  apply righttotal_decl in righttotal.
  apply lefttotal_decl in lefttotal.
  now apply bitotal_from_right_and_left_total.
Qed.

(* ? Lemma righttotal_from_bitotal : bitotal R -> righttotal R. *)

(** * Uniqueness declarations *)

(** ** Straightforward properties *)

Lemma flipunique `(R : A -> B -> Type) :
  rightunique (flip R) <-> leftunique R.
Proof. flipdecl. Qed.

Lemma flipbiunique `(R : A -> B -> Type) :
  biunique (flip R) <-> biunique R.
Proof. flipdecl. Qed.

Lemma biunique_from_right_and_left_unique `(R : A -> B -> Type) :
  rightunique R -> leftunique R -> biunique R.
Proof. flipdecl. Qed.

Lemma rightunique_from_biunique `(R : A -> B -> Type) :
  biunique R -> rightunique R.
Proof. flipdecl. Qed.

Lemma leftunique_from_biunique `(R : A -> B -> Type) :
  biunique R -> leftunique R.
Proof. flipdecl. Qed.

(** ** More complex properties *)

Theorem rightunique_decl `(R : A -> B -> Type) :
  (forall x x' y', R x x' -> R x y' -> x' = y') <-> rightunique R.
Proof.
  split.
  - intros functional x x' relx y y' rely eq.
    apply (functional x); trivial.
    now rewrite eq.
  - intros rightunique x **.
    generalize (eq_refl x).
    now apply rightunique.
Qed.

Theorem leftunique_decl `(R : A -> B -> Type) :
  (forall x y y', R x y' -> R y y' -> x = y) <-> leftunique R.
Proof.
  eapply iffT_Transitive; [ | exact (flipunique _) ].
  eapply iffT_Transitive; [ | exact (rightunique_decl _) ].
  flipdecl.
Qed.

Theorem biunique_decl `(R : A -> B -> Type) :
  (forall x x' y', R x x' -> R x y' -> x' = y') ->
  (forall x y y', R x y' -> R y y' -> x = y) ->
  biunique R.
Proof.
  intros.
  apply biunique_from_right_and_left_unique.
  - now apply rightunique_decl.
  - now apply leftunique_decl.
Qed.

Theorem biunique_decl_recip1 `(R : A -> B -> Type) :
  biunique R -> forall x x' y', R x x' -> R x y' -> x' = y'.
Proof.
  intro biunique.
  apply rightunique_decl.
  apply rightunique_from_biunique.
  assumption.
Qed.

Theorem biunique_decl_recip2 `(R : A -> B -> Type) :
  biunique R -> forall x y y', R x y' -> R y y' -> x = y.
Proof.
  intros biunique *.
  apply flipbiunique in biunique.
  now apply biunique_decl_recip1 with (1 := biunique).
Qed.

Lemma generic_right_covered_decl `(R : A -> B -> Type) :
  ((R ##> impl) ##> impl) all (fun P' => forall y, { x : A & R x y } -> P' y).
Proof.
  lazy beta delta.
  intros P P' Prel HP x' (x & xrel).
  apply (Prel _ _ xrel).
  apply HP.
Qed.

Lemma generic_left_covered_decl `(R : A -> B -> Type) :
  ((R ##> flip impl) ##> flip impl) (fun P => forall x, { y : B & R x y } -> P x) all.
Proof.
  pose (H := @generic_right_covered_decl B A (flip R)).
  lazy beta delta.
  intros P P' Prel HP x' (x & xrel).
  apply (Prel _ _ xrel).
  apply HP.
Qed.

(** *** Generic property for non-total relations *)

Theorem generic_covered_decl `(R : A -> B -> Type) :
  let coveredA := fun x => { y : B & R x y } in
  let coveredB := fun y => { x : A & R x y } in
  ((R ##> iff) ##> iff) (ball coveredA) (ball coveredB).
Proof.
  lazy beta delta zeta.
  intros P P' relP.
  split.
  - apply generic_right_covered_decl.
    firstorder.
  - apply generic_left_covered_decl.
    firstorder.
Qed.

(** ** More complex properties *)

Theorem righttotal_predicate `(R : A -> B -> Type) :
  rightunique R -> righttotal (R ##> iff).
Proof.
  intros rightunique.
  apply righttotal_decl.
  intros P'.
  exists (fun x => forall x', R x x' -> P' x').
  split; unfold arrow; firstorder.
  erewrite rightunique; eauto.
Qed.

Theorem lefttotal_predicate `(R : A -> B -> Type) :
  leftunique R -> lefttotal (R ##> iff).
Proof.
  intros leftunique.
  apply lefttotal_decl.
  intros P.
  exists (fun x' => forall x, R x x' -> P x).
  split; unfold arrow; firstorder.
  erewrite leftunique; eauto.
Qed.

Theorem total_predicate `(R : A -> B -> Type) :
  biunique R -> bitotal (R ##> iff).
Proof.
  intro biunique.
  apply bitotal_from_right_and_left_total;
    [ apply righttotal_predicate;
      apply rightunique_from_biunique
    | apply lefttotal_predicate;
      apply leftunique_from_biunique ];
    exact biunique.
Qed.

(** Instances *)

Instance bitotal_from_bitotal `(R : A -> B -> Type) :
  Related ((R ##> iffT) ##> iffT) forall_def forall_def ->
  Related ((R ##> iff) ##> iff) all all.
Proof.
  unfold Related.
  intros.
  apply Respectful.bitotal_decl.
  now apply bitotal_decl_recip1.
  now apply bitotal_decl_recip2.
Qed.

Instance bitotal_predicate_rule `(R : A -> B -> Type) :
  Related (R ##> R ##> iff) eq eq ->
  Related (((R ##> iff) ##> iff) ##> iff) all all.
Proof.
  unfold Related.
  intros.
  now apply total_predicate.
Qed.