Set Warnings "-parsing".
Require Import Real.
From mathcomp Require Import all_ssreflect.
Require Import Psatz.
Require Import Nat.
Require Import PeanoNat.

Require Import Kleene.
Require Import Reals.
Require Import RealCoqReal RealHelpers testsearch.
Set Warnings "parsing".

Section magnitude.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Lemma half_lt_one : real_1 / real_2_neq_0 < real_1.
  Proof.
    classical.
    relate.
    suff -> : (y = 2)%R by lra.
      by apply (relate_IZreal) .
  Qed.

  Definition lt_prec x n := prec n < x.

  Definition is_magnitude1 x n :=
    lt_prec x n.+2 /\ not (lt_prec x n)
  .
  (* prec n.+2 < x < prec n. *)
  Definition magnitude1 x : (real_0 < x < real_1 / real_2_neq_0)
                            -> M { n | is_magnitude1 x n }.
  Proof.
    move => [pos lt2].

    (* x < real_1_ *)
    have lt1 : x < real_1.
    have h := half_lt_one.
    apply (real_lt_lt_lt _  (real_1 / real_2_neq_0) _); auto.

    unfold is_magnitude1.
    Definition P x n := lt_prec x (n.+1).
    suff g1M : M { n : nat | P x n.+1 /\ (forall k : nat, (k < n)%coq_nat -> ~ P x k)}.
    apply (M_lift ({n : nat | P x n.+1 /\ (forall k : nat, (k < n)%coq_nat -> ~ P x k)})).
    2: { exact g1M. }
    clear g1M. intro g1.
    destruct g1 as [n H].
    exists n.
    unfold P in H.
    split.
    destruct H. auto.
    destruct H.

    destruct n.
    (* ~ lt_prec x 0 *)
    unfold lt_prec. apply real_gt_ngt. unfold prec. unfold gt. auto.

    (* ~ lt_prec x n.+1 *)
    have H0n := H0 n.
    suff lt_S : (n < n.+1)%coq_nat by auto.
      by lia.

      apply (epsilon_smallest_choose_M).
      unfold P. unfold lt_prec.
      intros.
      apply (weaken_orM_r _ (x < prec n.+1) _).
      intros.
      apply real_lt_nlt. auto.

      apply MultivalueMonad.choose.
      auto with real.
      auto with real.

      (* prec n.+2 < x \/ x < prec n.+1 *)
      destruct (real_total_order x (prec n.+1)) as [H|[H|H]].
      right. exact H.
      left. rewrite H. apply prec_S.
      left. unfold gt in H. apply (real_lt_lt_lt _ (prec n.+1) _).
      apply prec_S. exact H.

      unfold P. unfold lt_prec.
      case (ana1 x) => xr [R1 R2].
      suff : exists n,  (/ 2 ^ n.+1 < xr)%R.
    - case => n nprp.
      exists n.
      have P := (@relate_prec _ _ _   SemiDecOrderedField_Real n.+1).
      classical.
      relate.
      trivial.
      have xrpos : (0 < xr)%R.
      apply /transport_lt_inv/pos/R1/relate_constant0.
      have xrlt1 : (xr < 1)%R.
      apply /transport_lt_inv/lt1. auto.
      apply relate_constant1.

      have H := dns0_tpmn xr xrpos.
      destruct H as [n H].
      destruct n.
      have xrgt1 : (1 < xr)%R. lra.
      lra. (* contradiction between xrlt1 xrgt1 *)

      exists n. auto.
  Defined.

  Definition Zpow (x : Real) (xne0 : x <> real_0) z := match z with
                                                      | 0%Z => real_1
                                                      | Z.pos p => RealRing.pow x (Pos.to_nat p)
                                                      | Z.neg p => RealRing.pow (/ xne0) (Pos.to_nat p)
                                                      end.

  Lemma dec_x_lt_2 x : M ({x < real_2} + {real_1 < x}).
  Proof.

    pose proof ( M_split x (@IZreal K klb Real  SemiDecOrderedField_Real 3 / real_2_neq_0) (/ real_2_neq_0) d2_pos) as H.
    apply (fun p => mjoin _ _ _ p H).
    intro.
    clear H.
    destruct H0.
    right.

    - classical.
      relate.
      suff : ((3 / 2) - (/ 2) < y)%R by lra.
      rename r into H.
      rename H0 into H1.
      apply /transport_lt_inv/H/H1.
        by apply /relate_addition/relate_subtraction/relate_divison/IZreal_relator/relate_multiplication/relate_divison/IZreal_relator/IZreal_relator.
        left.
        classical.
        relate.
        have -> : (y = 2)%R by apply (relate_IZreal) .
        suff : (x0 - ( / 2) < (3 / 2))%R by lra.
        rename H0 into H1.
        rename H into H0.
        rename r into H.

          by apply /transport_lt_inv/H/relate_multiplication/relate_divison/IZreal_relator/IZreal_relator/relate_addition/relate_subtraction/relate_divison/IZreal_relator.
  Qed.

  Lemma Zpow_prec n : Zpow _ real_2_neq_0 (- Z.of_nat n) = prec n.
  Proof.
    rewrite /Zpow.
    case e :(- Z.of_nat n)%Z => [| p | p]; try by lia.
    - suff  -> : (n = 0) by auto.
      lia.
      have -> : Pos.to_nat p = n by lia.
      elim n => // n' IH /=.
      rewrite real_mult_comm.
        by apply real_eq_eq_mult_eq.
  Qed.

  Definition is_magnitude x z := Zpow _ real_2_neq_0 (z - 2) <= x <= Zpow _ real_2_neq_0 z.

  Lemma inv_neq0 (x : Real) (xneq0 : x <> real_0) : (/ xneq0) <> real_0.
  Proof.
    apply transport_neq.
    intro.
    intro.
    intro.
    intro.
    relate.
    apply Rinv_neq_0_compat.
      by apply /transport_neq_inv/xneq0/relate_constant0/Ha.
  Qed.

  Lemma Zpow_pos x xneq0 z : (0 <= z)%Z -> Zpow x xneq0 z = RealRing.pow x (Z.to_nat z).
  Proof.
    move => H.
      by case e : z => //; lia.
  Qed.

  Lemma Zpow_neg x xneq0 z : (z <= 0)%Z -> Zpow x xneq0 z = RealRing.pow (/ xneq0) (Z.to_nat (-z)).
  Proof.
    move => H.
      by case e : z => // /=; try lia.
  Qed.

  Lemma pow_plus x n1 n2 : RealRing.pow x (n1+n2) = RealRing.pow x n1 * RealRing.pow x n2.
  Proof.
    elim n2 => [| n' IH ]; first by rewrite /= Nat.add_0_r real_mult_comm real_mult_unit.
    have ->  : ((n1 + n'.+1) = ((n1+n').+1))%coq_nat by lia.
    rewrite real_mult_comm /= real_mult_assoc.
    apply real_eq_mult_eq.
      by rewrite real_mult_comm.
  Qed.

  Lemma Zpow_inv x xneq0 z : Zpow x xneq0 (-z) = Zpow (/ xneq0) (inv_neq0 _ xneq0) z.
  Proof.
    case (Z.neg_nonneg_cases z) => H.
    - rewrite Zpow_pos; try by lia.
      rewrite Zpow_neg; try by lia.
      suff -> : (/ inv_neq0 x xneq0) = x by trivial.
      apply transport_eq.
      intro.
      intro.
      intro.
      intro.

      relate.
      apply Rinv_involutive.
        by apply /transport_neq_inv/xneq0/relate_constant0/Ha0.
        rewrite Zpow_neg; try by lia.
        rewrite Zpow_pos; try by lia.
          by rewrite Z.opp_involutive.
  Qed.

  Lemma Zpow_succ x xneq0 z : Zpow x xneq0 (Z.succ z) = x * Zpow x xneq0 z.
  Proof.
    case (Z.neg_nonneg_cases z) => H;case (Z.neg_nonneg_cases (Z.succ z)) => H'; try by lia.
    - rewrite !Zpow_neg; try lia.
      have -> : (- z = -Z.succ z  + 1)%Z by lia.
      rewrite Z2Nat.inj_add; try by lia.
      have -> : (Z.to_nat (- Z.succ z) + Z.to_nat 1 = (Z.to_nat (- Z.succ z)).+1)%coq_nat by lia.
      rewrite /= -real_mult_assoc.
      assert (x * / xneq0 = real_1).
      rewrite real_mult_comm.
        by apply real_mult_inv.

      by rewrite H0 real_mult_unit.

    - have -> : (z = -1)%Z by lia.
      rewrite /=.
        by rewrite  /= -real_mult_assoc real_mult_comm real_mult_unit real_mult_comm real_mult_inv.
        rewrite !Zpow_pos; try by lia.
        rewrite Z2Nat.inj_add; try by lia.
        have -> : (Z.to_nat z + Z.to_nat 1 = (Z.to_nat z).+1)%coq_nat by lia.
          by auto.
  Qed.

  Lemma Zpow_plus x xneq0 z1 z2 : Zpow x xneq0 (z1+z2) = Zpow x xneq0 z1  * Zpow x xneq0 z2.
    move : z2.
    apply Z.bi_induction => [x0 y -> | | z] => // /=; first by rewrite Z.add_0_r real_mult_comm real_mult_unit.
    split => H.
    - have -> : (z1 + Z.succ z = Z.succ (z1+z) )%Z by lia.
      rewrite !Zpow_succ.
        by rewrite -real_mult_assoc (real_mult_comm _ x) H real_mult_assoc.
        have TT y u1 u2 : x * y = u1 * (x * u2) -> y = u1 * u2.
        clear H;intros;Holger H; Holger xneq0.
        apply transport_eq.
        intros.
        relate;nra.
        apply TT.
        rewrite -!Zpow_succ.
        have -> : (Z.succ (z1+z) = z1 + Z.succ z)%Z by lia.
        exact H.
  Qed.

  Lemma magnitude_half x z : is_magnitude (x / real_2_neq_0) z -> is_magnitude x (z+1).
  Proof.
    move => [H1 H2].
    split.
    - have -> : (z + 1 - 2 = z - 1)%Z by lia.
      move : H1.
      rewrite !Zpow_plus /= => H1.
      classical; relate.

      have -> : (x2 = 2)%R by apply (relate_IZreal).

      suff : (x1 * (/ 2 * (/ 2 * 1) ) <= y / 2)%R by lra.
      apply /transport_leq_inv/H1/relate_multiplication/relate_divison/IZreal_relator/H0.
      apply /relate_multiplication/relate_multiplication/relate_multiplication/relate_constant1/relate_divison/IZreal_relator/relate_divison/IZreal_relator.
      apply Ha.
      rewrite Zpow_plus /=.
      classical;relate.
      have -> : (x2 = 2)%R by apply (relate_IZreal).
      suff : (x0 / 2 <= x1)%R by lra.
        by apply /transport_leq_inv/H2/Ha/relate_multiplication/relate_divison/IZreal_relator/H.
  Qed.

  Lemma magnitude_fourth x z : is_magnitude (x /IZreal4neq0) z -> is_magnitude x (z+2).
  Proof.
    assert (X :(x / IZreal4neq0) = (x / real_2_neq_0 / real_2_neq_0)).
    apply transport_eq.
    intros.
    relate.
    rewrite (relate_IZreal _ _ Hb1).
    rewrite (relate_IZreal _ _ Hb0).
      by lra.
    rewrite X.
    - move => H.
      have H' := (magnitude_half _ _ (magnitude_half _ _ H)).
      have -> : (z + 2 = z + 1 + 1)%Z by lia.
      exact H'.
  Qed.

  (* first extend magnitude to numbers <= 2 *)
  Definition magnitude2 x : (real_0 < x < real_2) -> M { z | is_magnitude x z }.
  Proof.
    move => [xgt0 xle1].
    pose (y := (x / IZreal4neq0)).
    have yB : (real_0 < y < real_1 / real_2_neq_0).
    - unfold real_div; rewrite real_mult_unit/y.
      split;classical;relate;rewrite (relate_IZreal _ _ Hb).
      suff : (0 < x0)%R by lra.
      apply /transport_lt_inv/xgt0/Ha/relate_constant0.
      rewrite (relate_IZreal _ _ Ha0).
      suff : (x1 < 2)%R by lra.
        by apply /transport_lt_inv/xle1/IZreal_relator/Ha.
        have magy n : is_magnitude y n -> is_magnitude x (n+2)%Z by apply magnitude_fourth.
        suff : M { z | is_magnitude y z}.
    - apply M_lift.
      case => z zprp.
      exists (z+2)%Z.
      exact (magy _ zprp).
      (* y is less than 1/2 => magnitude1 can be used *)
      have := magnitude1 _ yB.
      apply M_lift.
      case => n nprp.
      exists (- Z.of_nat n)%Z.
      split; last by rewrite Zpow_prec; apply real_ge_le; apply real_nge_le; apply nprp.
      have -> : ((- Z.of_nat n - 2) = (- Z.of_nat (n.+2)%coq_nat))%Z by lia.
        by rewrite Zpow_prec; apply real_lt_le;apply nprp.
  Qed.

  Lemma Zpow_relate x xneq0 z xr: relate x xr -> relate (Zpow x xneq0 z) (powerRZ xr z).
  Proof.
    move => R.
    have xrneg0 : (xr <> R0)%R by Holger xneq0;relate.
    move : z.
    apply Z.bi_induction => [x0 y -> | | z] => // /=; first by apply relate_constant1.
    split => H.
    - rewrite Zpow_succ powerRZ_add /= => //.
      have ->: forall p, (p * (xr * 1) = xr * p)%R by intros;lra.
        by apply relate_multiplication.
        move : H.
        rewrite Zpow_succ powerRZ_add /= => //.
        have ->: forall p, (p * (xr * 1) = xr * p)%R by intros;lra.
        move => H.
        pose proof (relate_multiplication _ _ _ _ (relate_divison _ xneq0 _ R) H).
        move : H0.
        rewrite -real_mult_assoc -Rmult_assoc real_mult_inv real_mult_unit Rinv_l => //.
          by rewrite Rmult_1_l.
  Qed.

  Lemma magnitude_inv x (xneq0 : x<> real_0) z : is_magnitude (/ xneq0) z -> is_magnitude x (-z+2).
  Proof.
    move => [H1 H2].
    have R1 := Zpow_relate real_2 real_2_neq_0 (z-2) _ (IZreal_relator 2).
    have R2 := Zpow_relate real_2 real_2_neq_0 z _ (IZreal_relator 2).
    have R3 := Zpow_relate real_2 real_2_neq_0 (-z + 2 - 2) _ (IZreal_relator 2).
    have R4 := Zpow_relate real_2 real_2_neq_0 (-z + 2 ) _ (IZreal_relator 2).
    have P := (powerRZ_lt 2 z Rlt_0_2).
    have P2 := (powerRZ_lt 2 (z-2) Rlt_0_2).
    split; classical;relate;Holger H1;Holger H2;relate;Holger xneq0;relate.
    - have -> : (-z + 2 - 2 = -z)%Z by lia.
      rewrite powerRZ_neg; try by lra.
      rewrite powerRZ_inv; try by lra.
      rewrite -(Rinv_involutive y); try by lra.
      apply Rle_Rinv; try by lra.
      have -> : (-z + 2 = -(z-2))%Z by lia.
      rewrite powerRZ_neg; try by lra.
      rewrite powerRZ_inv; try by lra.
      rewrite -(Rinv_involutive x0); try by lra.
        by apply Rle_Rinv; try by lra.
  Qed.

  Definition magnitude x : real_0 < x -> M {z | is_magnitude x z}.
  Proof.
    move => xgt0.
    have := dec_x_lt_2 x.
    apply M_lift_dom.
    case => H; first by apply magnitude2.
    have xneg0 : (x <> real_0) by apply (real_gt_neq _ _ xgt0).
    assert (I : (real_0 < / xneg0 < real_2)).
    -
      split; classical; relate.
      apply Rinv_0_lt_compat.
        by apply /transport_lt_inv/xgt0/Ha/relate_constant0.
        rewrite (relate_IZreal _ _ H1).
        have -> : (2 = / / 2)%R by lra.
        apply Rinv_lt_contravar.
        suff : (0 < x1)%R by lra.
        apply /transport_lt_inv/xgt0/Ha/relate_constant0.
        suff : (1 < x1)%R by lra.
        apply /transport_lt_inv/H/Ha/relate_constant1.
    - have := magnitude2 _ I.
      apply M_lift.
      case => z zprp.
      exists (-z+2)%Z.
        by apply (magnitude_inv x xneg0).
      Defined.

End magnitude.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e230m27_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e141m9_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e196m15_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e198m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import ZArith.
Require Import Coq.Strings.String.
Require Import NPeano.

From QuickChick Require Import QuickChick.

Require Export Utils.
Require Export Labels.
Require Export Instructions.
Require Export Memory.
Require Export Lab4.
Require Export Indist.
Require Export Machine.

Module Lab4M <: FINLAT.
  Definition Label := Lab4.
  Definition FLat  := FiniteLattice_Lab4.
End Lab4M.

Module MachineLab4M := MachineM Lab4M.
Export MachineLab4M.

Module IndistLab4M := IndistM Lab4M.
Export IndistLab4M.

Definition pure {A : Type} (x : A) : G A := returnGen x.

(*
Fixpoint foldGen {A B : Type} (f : A -> B -> G A) (l : list B) (a : A)
: G A :=
  match l with
    | [] => returnGen a
    | (x :: xs) => bindGen (f a x) (foldGen f xs)
  end.
*)

(* Variation stuff - should be deleted -- CH: ha? it seems used *)
Inductive Variation {A : Type} :=
| Var : Lab4 -> A -> A -> Variation.

Class ShrinkV (A : Type) := { shrinkV : @Variation A -> list (@Variation A) }.
(* End of to be deleted *)

Definition validJump (st : State) (addr : Z) :=
  let '(St imem _ _ _ _) := st in
  (Z.to_nat addr) <? (List.length imem).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e336m3_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e266m3_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import RL.Utilities.Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.
Require Import RL.hr.interpretation.
Require Import RL.hr.completeness.
Require Import RL.hr.soundness.
Require Import RL.hr.can_elim.

Require Import List.

Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

(** F is a Riesz space term. *)
Definition F := (((plus_pos One One) *S HR_var 0) +S ((plus_pos One One) *S HR_covar 1)) \/S (HR_var 1 +S HR_covar 0).

(** A proof that F is positive using equational reasonning. The proof uses some lemmas defined in soundness, but the derived tree is actually quite big. *)
Lemma F_is_pos : HR_zero <== F.
Proof.
  unfold F.
  rewrite <- mul_distri_term.
  rewrite leq_pos_max_mul_l_inv; auto.
  rewrite commu_plus.
  apply zero_leq_abs.
Qed.

(** A proof that the sequent |- 1.F is derivable using the soundness of the HR and the positivity of F. *)
Lemma F_is_provable_from_soundness : HR_full (((One, F) :: nil) :: nil).
Proof.
  apply HR_le_frag with hr_frag_M_can; [ repeat split; auto | ].
  apply hr_complete; [intros  H; inversion H | ].
  simpl; rewrite mul_1; rewrite neutral_plus.
  apply F_is_pos.
Qed.

(** An other derivation for the sequent |- 1.F *)
Lemma F_is_provable : HR_full (((One, F) :: nil) :: nil).
Proof.
  change ((One, F) :: nil) with (vec (One :: nil) F ++ nil).
  unfold F.
  apply hrr_max.
  eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
  apply hrr_plus.
  apply hrr_mul.
  rewrite app_assoc.
  eapply hrr_ex_seq ; [ apply Permutation_Type_app ; [ apply Permutation_Type_app_swap | reflexivity ] | ].
  rewrite <- app_assoc.
  apply hrr_mul.
  eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
  apply hrr_plus.
  apply hrr_T with (plus_pos One One); [reflexivity | ].
  apply hrr_S.
  rewrite ? seq_mul_app.
  rewrite ? seq_mul_vec_mul_vec.
  apply hrr_ex_seq with (vec (time_pos (plus_pos One One) One :: nil) (HR_covar 0) ++ vec (time_pos (plus_pos One One) One :: nil) (HR_var 0) ++ vec (time_pos (plus_pos One One) One :: nil) (HR_covar 1) ++ vec (time_pos (plus_pos One One) One :: nil) (HR_var 1) ++ nil).
  { simpl.
    Permutation_Type_solve. }
  apply hrr_ID ; [ reflexivity | ].
  apply hrr_ID ; [ reflexivity | ].
  apply hrr_INIT.
Qed.

(** We can use the soundness of HR to have a proof that F is positive. *)
Lemma F_is_pos_from_soundness : HR_zero <== F.
Proof.
  apply leq_cong_r with (sem_hseq (((One, F) :: nil) :: nil)).
  { simpl.
    rewrite mul_1; rewrite neutral_plus; reflexivity. }
  apply hr_sound with hr_frag_full.
  apply F_is_provable.
Qed.

(** Finally, we can have a CAN-free proof of |- 1.F with the can elimination theorem. *)
Lemma F_is_provable_without_CAN : HR_T_M (((One, F) :: nil) :: nil).
Proof.
  apply hrr_can_elim.
  apply F_is_provable.
Qed.


(*
 * Progress
 *
 * This file contains problem 4.
 *)

Require Import List.
Require Import ZArith.
Require Import String.
Require Import Frap. (* For tactics *)
Require Import STLC.StructTactics. (* For tactics *)

Require Import STLC.Syntax.
Require Import STLC.Subst.
Require Import STLC.Heap.
Require Import STLC.Semantics.
Require Import STLC.Types.

(*
 * In our calculus, a number of types have canonical forms: if a
 * member of that type is a value, it must have a particular form. These
 * may be useful in proving progress.
 *)

Lemma canon_bool:
  forall env ht e,
    isValue e ->
    typed env ht e TBool ->
    exists b, e = Bool b.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

Lemma canon_int:
  forall env ht e,
    isValue e ->
    typed env ht e TInt ->
    exists i, e = Int i.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

Lemma canon_fun:
  forall env ht e tA tB,
    isValue e ->
    typed env ht e (tA ~> tB) ->
    exists x, exists b, e = \x, b.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

Lemma canon_ref:
  forall env ht e t,
    isValue e ->
    typed env ht e (TRef t) ->
    exists a, e = Addr a.
Proof.
  intros.
  inv H; inv H0; eauto.
Qed.

(*
 * PROBLEM 4 [30 points, ~90 tactics]: Prove progress for our calculus:
 * given a well-typed heap, a well-typed term either can step or is a value.
 * We've started the proof for you.
 *
 * Hint: You should familiarize yourself with the constructors of step_cbv.
 * Hint: At some point in this proof, you will destruct on can_subst from Subst.v.
 * Hint: The lemmas above about canonical forms may be useful.
 *)
Lemma progress:
  forall ht h e t,
    typed E0 ht e t ->
    heap_typed ht h ->
    (exists e' h', h; e ==> h'; e') \/ isValue e.
Proof.
  remember E0.
  induction 1; subst; intros.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 4 *)


Require Export Iron.Language.Simple.SubstExpExp.
Require Export Iron.Language.Simple.Exp.

(*******************************************************************)
(* Evaluation contexts for expressions.
   An evaluation context is an expression with a hole in any place
   that can take a step via our evaluatio rules. We represent
   the hole by the function that fills it. *)
Inductive exp_ctx : (exp -> exp) -> Prop :=
 | XcTop
   :  exp_ctx (fun x => x)

 | XcApp1
   :  forall x2
   ,  exp_ctx (fun xx => XApp xx x2)

 | XcApp2
   :  forall v1
   ,  value v1
   -> exp_ctx (fun xx => XApp v1 xx).

Hint Constructors exp_ctx.

(* Small Step evaluation *)
Inductive STEP : exp -> exp -> Prop :=

 (* Evaluation in a context. *)
 | EsContext
   :  forall C x x'
   ,  exp_ctx C
   -> STEP x x'
   -> STEP (C x) (C x')

 (* Function application. *)
 | EsLamApp
   :  forall t11 x12 v2
   ,  value v2
   -> STEP (XApp (XLam t11 x12) v2)
           (substX 0 v2 x12).

Hint Constructors STEP.

(********************************************************************)
(* Multi-step evaluation
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   EsAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : exp -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | EsStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(* Multi-step evaluation in a context.
   If an expression can be evaluated at top level, then it can
   be evaluated to the same result in any evaluation context. *)
Lemma steps_context
 :  forall C x1 x1'
 ,  exp_ctx C
 -> STEPS x1 x1'
 -> STEPS (C x1) (C x1').
Proof.
 intros C x1 x1' HC HS.
 induction HS; burn.
Qed.

(********************************************************************)
(* Left linearised multi-step evaluation
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma.*)
Inductive STEPSL : exp -> exp -> Prop :=

 | EslNone
   : forall x1
   , STEPSL x1 x1

 | EslCons
   :  forall x1 x2 x3
   ,  STEP   x1 x2 -> STEPSL x2 x3
   -> STEPSL x1 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall x1 x2 x3
 ,  STEPSL x1 x2 -> STEPSL x2 x3
 -> STEPSL x1 x3.
Proof.
 intros x1 x2 x3 HS1 HS2.
 induction HS1; burn.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions. *)
Lemma stepsl_of_steps
 :  forall x1 x2
 ,  STEPS  x1 x2
 -> STEPSL x1 x2.
Proof.
 intros x1 x2 HS.
 induction HS; burn using stepsl_trans.
Qed.


Set Implicit Arguments.

Hint Extern 4 => exact _ : core.

Ltac inv H := inversion H; subst; clear H.

Definition dec (X: Prop) : Type := {X} + {~ X}.

Coercion dec2bool P (d: dec P) := if d then true else false.
Definition is_true (b : bool) := b = true.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  is_true (Dec X) <-> X.
Proof.
  destruct d as [A|A]; cbv in *; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> is_true (Dec X).
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

(* Lemma Dec_auto_not (X: Prop) (d: dec X) : *)
(*   ~ X -> ~ Dec X. *)
(* Proof. *)
(*   destruct d as [A|A]; cbn; tauto. *)
(* Qed. *)

(* Hint Resolve Dec_auto Dec_auto_not : core. *)
Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  decide P; cbv in *; firstorder.
  congruence.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  decide P; cbv in *; firstorder.
  congruence.
Qed.

Hint Extern 4 =>
match goal with
  [ H : dec2bool (Dec ?P) = true  |- _ ] => apply Dec_true in  H
| [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_false in H
end : core.

(* Decided propositions behave classically *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

(* Propagation rules for decisions *)

Fact dec_transfer P Q :
  P <-> Q -> dec P -> dec Q.
Proof.
  unfold dec. tauto.
Qed.

Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Qed.

Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Qed.

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Qed.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Qed.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Qed.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. auto.
Qed.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. auto.
Qed.

(* Discrete types *)

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

Existing Instance eqType_dec.

Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold dec. decide equality.
Qed.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold dec. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold dec. decide equality.
Defined.

Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold dec. decide equality.
Defined.

Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold dec. decide equality.
Qed.

Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Qed.

Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Qed.


(** * Set axiom implementations with Aczel's tree type. *)
Require Import ClassicalFacts.
Require Import Setoid.
Require Import Utf8.
From ZF Require Import ZF.

(** This implementation relies on the predicate extensionality. *)
Axiom predicate_extensionality : ∀ {A : Type} (P Q : A → Prop), (∀ a, P a ↔ Q a) → P = Q.

(** The implementation of the axiom of replacement relies on the functional choice. *)
Axiom functional_choice : ∀ {A : Type} (R : A → A → Prop), (∀ x, ∃ y, R x y) → ∃ f, ∀ x, R x (f x).

Module Acz_set : ZF.

(** Preliminary lemmata *)
Lemma proof_irrelevance : ∀ (P : Prop) (p q : P), p = q.
Proof.
  apply ext_prop_dep_proof_irrel_cic. intros A B AiffB.
  assert (H: (λ _ : True, A) = (λ _ : True, B)). { apply predicate_extensionality. intro. apply AiffB. }
  apply (f_equal (λ f, f I)) in H. apply H. Qed.

Lemma exist_eq {A : Type} (P : A → Prop) a b p q : a = b → exist P a p = exist P b q.
Proof. intro aeqb. subst b. rewrite (proof_irrelevance (P a) p q). reflexivity. Qed.

(** Aczel's tree type *)
Inductive Acz : Type := acz : ∀ (J : Type), (J → Acz) → Acz.
Definition dom (a : Acz) : Type := match a with acz J _ => J end.
Definition fn (a : Acz) : dom a → Acz := match a with acz _ f => f end.

(** Equivalence *)
Fixpoint equiv (a b : Acz) : Prop :=
  (∀ i, ∃ j, equiv (fn a i) (fn b j)) ∧ (∀ j, ∃ i, equiv (fn a i) (fn b j)).

Infix "≃" := equiv (at level 70).

Lemma equiv_refl : ∀ a, a ≃ a.
Proof. intro a. induction a as [I f ind]. split; intro j; exists j; apply ind. Qed.

Lemma equiv_symm : ∀ a b, a ≃ b → b ≃ a.
Proof.
  intro a. induction a as [I f ind]. intros [J g] [i2j j2i]. split.
  - intro j. destruct (j2i j) as [i fi_eqv_gj]. exists i. apply ind, fi_eqv_gj.
  - intro i. destruct (i2j i) as [j fi_eqv_gj]. exists j. apply ind, fi_eqv_gj.
  Qed.

Lemma equiv_trans : ∀ a b c, a ≃ b → b ≃ c → a ≃ c.
Proof.
  intro a. induction a as [I f ind]. intros [J g] [K h] [i2j j2i] [j2k k2j]. split.
  - intro i. destruct (i2j i) as [j fi_eqv_gj]. destruct (j2k j) as [k gj_eqv_hk].
    exists k. apply (ind _ (g j)); [apply fi_eqv_gj | apply gj_eqv_hk].
  - intro k. destruct (k2j k) as [j gj_eqv_hk]. destruct (j2i j) as [i fi_eqv_gj].
    exists i. apply (ind _ (g j)); [apply fi_eqv_gj | apply gj_eqv_hk].
  Qed.

(** Use setoid tactics for concise proofs. *)
Add Relation Acz equiv reflexivity proved by equiv_refl
                       symmetry proved by equiv_symm
                       transitivity proved by equiv_trans as equiv_rel.

Add Parametric Morphism : equiv with signature equiv ==> eq as equiv_mor.
Proof. intros. apply predicate_extensionality. intro. rewrite H. apply iff_refl. Qed.

Lemma equiv_elem : ∀ (A B : Acz), A ≃ B → ∀ i, ∃ j, fn A i ≃ fn B j.
Proof. intros [I f] [J g] eqv. apply eqv. Qed.

(** Equivalence-based membership and subsets *)
Definition AIn (A a : Acz) : Prop := ∃ i, a ≃ (fn A i).
Notation "a ∈' A" := (AIn A a) (at level 70).

Add Parametric Morphism : AIn with signature equiv ==> equiv ==> iff as AIn_mor.
Proof.
  intros [I f] [J g] [i2j j2i] a b a_eqv_b. split.
  - intros [i a_eqv_fi]. destruct (i2j i) as [j fi_eqv_gj]. exists j.
    rewrite <- a_eqv_b, a_eqv_fi, fi_eqv_gj. reflexivity.
  - intros [j b_eqv_gj]. destruct (j2i j) as [i fi_eqv_gj]. exists i.
    rewrite a_eqv_b, b_eqv_gj, fi_eqv_gj. reflexivity.
  Qed.

Lemma elem (A : Acz) (i : dom A) : fn A i ∈' A.
Proof. exists i. reflexivity. Qed.

Definition AIncluded (A B : Acz) : Prop := ∀ i, ∃ j, fn A i ≃ fn B j.
Infix "⊂'" := AIncluded (at level 70).

(** [set] is defined as the equivalence classes. *)
Definition equiv_class (p : Acz → Prop) : Prop := ∃ a, p = equiv a.
Definition set := sig equiv_class.
Definition set_of (A : Acz) : set := exist _ (equiv A) (ex_intro _ A eq_refl).

Add Parametric Morphism : set_of with signature equiv ==> eq as set_of_mor.
Proof. intros a b a_eqv_b. apply exist_eq. rewrite a_eqv_b. reflexivity. Qed.

Tactic Notation "lower" constr(x) "as" simple_intropattern(a) :=
  let f := fresh "f" in let f_eq := fresh "f_eq" in
  destruct x as [f [a f_eq]]; subst f; fold (set_of a) in *.
Tactic Notation "lower" ident(x) := lower x as x.
Tactic Notation "lower" ident(x) ident(y) := lower x; lower y.
Tactic Notation "lower" ident(x) ident(y) ident(z) := lower x; lower y; lower z.

Lemma set_of_eq (A B : Acz) : set_of A = set_of B ↔ A ≃ B.
Proof.
  split; [|apply set_of_mor]. intros AeqB. apply (f_equal (@proj1_sig _ equiv_class)) in AeqB.
  simpl in AeqB. rewrite AeqB. reflexivity. Qed.

(** Class-preserving function is lifted to set function.
    This result will extensively be used to define set level functions. *)
Definition equiv_compat (f : Acz → Acz) : Prop := ∀ a b, a ≃ b → f a ≃ f b.

Lemma equiv_compat_class (f : Acz → Acz) (x : set) :
  equiv_compat f → equiv_class (λ b, ∃ a, proj1_sig x a ∧ b ≃ f a).
Proof.
  intro compat_f. lower x. exists (f x). apply predicate_extensionality. intro y. split.
  - intros [a [x_eqv_a y_eqv_fa]]. rewrite y_eqv_fa. apply compat_f, x_eqv_a.
  - intros fx_eqv_y. exists x. split; [simpl; reflexivity | symmetry; apply fx_eqv_y].
  Qed.

Definition Lift {f} (P : equiv_compat f) (X : set) : set := exist _ _ (equiv_compat_class f X P).

Definition equiv_compat2 (f : Acz → Acz → Acz) : Prop :=
  ∀ a a', a ≃ a' → ∀ b b', b ≃ b' → f a b ≃ f a' b'.

Lemma equiv_compat2_class (f : Acz → Acz → Acz) (x y : set) :
  equiv_compat2 f → equiv_class (λ c, ∃ a b, proj1_sig x a ∧ proj1_sig y b ∧ c ≃ f a b).
Proof.
  intro compat_f. lower x y. exists (f x y). apply predicate_extensionality. intro z. simpl. split.
  - intros [a [b [x_eqv_a [y_eqv_b z_eqv_fab]]]]. rewrite z_eqv_fab. apply compat_f; assumption.
  - intro fxy_eqv_z. exists x, y. rewrite fxy_eqv_z. repeat split; reflexivity.
  Qed.

Definition Lift2 {f} (P : equiv_compat2 f) (X Y : set) : set := exist _ _ (equiv_compat2_class f X Y P).

(** set-level membership and inclusion *)
Definition In (X x : set) := ∀ A a, proj1_sig X A → proj1_sig x a → a ∈' A.
Notation "x ∈ X" := (In X x) (at level 70).
Notation "x ∉ X" := (~ x ∈ X) (at level 70).

Definition Included (X Y : set) : Prop := ∀ x, x ∈ X → x ∈ Y.
Infix "⊂" := Included (at level 70).

Lemma set_of_in (A a : Acz) : set_of a ∈ set_of A ↔ a ∈' A.
Proof. split.
  - intros a_in_A. apply a_in_A; simpl; reflexivity.
  - intros a_in_A A' a' AeqvA' aeqva'. rewrite <- AeqvA', <- aeqva'. apply a_in_A.
  Qed.

(* Lemma set_of_in_class (a : Acz) (P : Acz → Prop) (C : equiv_class P) :
  set_of a ∈ exist _ P C ↔ ∀ A, P A → a ∈' A.
Proof. split.
  - intros a_in_class A PA. apply a_in_class; [apply PA | simpl; reflexivity].
  - intros P_imp_a_in A a' PA a_eqv_a'. rewrite <- a_eqv_a'. apply P_imp_a_in, PA.
  Qed. *)

Lemma set_of_in_class (a : Acz) (P : Acz → Prop) (C : equiv_class P) :
  (∀ A, P A → a ∈' A) → set_of a ∈ exist _ P C.
Proof. intros Pimp A a' PA a_eqv_a'. rewrite <- a_eqv_a'. apply Pimp, PA. Qed.

Lemma set_of_in_class_ex (a : Acz) (P : Acz → Prop) (C : equiv_class P) :
  set_of a ∈ exist _ P C → ∃ A, P A ∧ a ∈' A.
Proof.
  intro a_in_PC. destruct C as [A Peq]. subst P. exists A. split; [reflexivity|].
  apply set_of_in, a_in_PC. Qed.

Lemma set_of_sub (A B : Acz) : set_of A ⊂ set_of B ↔ A ⊂' B.
Proof. split.
  - intros AsubB i. apply set_of_in, AsubB, set_of_in, elem.
  - intros AsubB a a_in_A. lower a. apply set_of_in. apply set_of_in in a_in_A as [i a_eqv_Ai].
    destruct (AsubB i) as [j Ai_eqv_Bj]. exists j. rewrite a_eqv_Ai, Ai_eqv_Bj. reflexivity.
  Qed.

(** Extensionality *)
Theorem set_ext : ∀ X Y, X ⊂ Y → Y ⊂ X → X = Y.
Proof.
  intros X Y XsubY YsubX. lower X Y. apply set_of_eq. apply set_of_sub in XsubY, YsubX.
  destruct X as [I f], Y as [J g]. split; [apply XsubY|].
  intro j. destruct (YsubX j) as [i gj_eqv_fi]. exists i. symmetry. apply gj_eqv_fi.
  Qed.

(** Foundation *)
Theorem epsilon_induction : ∀ P : set → Prop, (∀ A, (∀ x, x ∈ A -> P x) -> P A) -> ∀ B, P B.
Proof.
  intros P Eind Y. lower Y. induction Y as [I f Pfi]. apply Eind. intros x x_in_B.
  lower x. apply set_of_in in x_in_B as [i x_eqv_fi]. rewrite x_eqv_fi. apply Pfi. Qed.

(** Empty set *)
Definition AEmpty : Acz := @acz False (λ a, match a with end).
Definition empty : set := set_of AEmpty.
Notation "∅" := empty.

Theorem in_empty : ∀ x : set, x ∉ ∅.
Proof. intros x x_in_E. lower x. apply set_of_in in x_in_E as []. contradiction. Qed.

(** Pairing *)
Definition APair (a b : Acz) : Acz := acz bool (λ x, if x then a else b).
Definition ASing (a : Acz) : Acz := APair a a.

Add Parametric Morphism : APair with signature equiv ==> equiv ==> equiv as APair_mor.
Proof. intros a a' a_eq_a' b b' b_eq_b'. split; intro i; exists i; destruct i; assumption. Qed.

Definition upair : set → set → set := Lift2 APair_mor.

Theorem in_upair : ∀ (a b x : set), x ∈ upair a b ↔ x = a ∨ x = b.
Proof.
  intros a b x. lower a b x. split.
  - intro x_in_ab.
    apply set_of_in_class_ex in x_in_ab as [A [[a' [b' [a_eqv_a' [b_eqv_b' A_eqv_a'b']]]] x_in_A]].
    rewrite A_eqv_a'b' in x_in_A. destruct x_in_A as [[|] x_eqv].
    + left. apply set_of_eq. rewrite x_eqv, a_eqv_a'. reflexivity.
    + right. apply set_of_eq. rewrite x_eqv, b_eqv_b'. reflexivity.
  - intros [x_eq_a | x_eq_b] A.
    + intros a' [a0 [b0 [a_eqv_a0 [b_eqv_b0 A_eqv_a0b0]]]] x_eqv_a'. rewrite A_eqv_a0b0. exists true.
      simpl in *. rewrite <- x_eqv_a', <- a_eqv_a0. apply set_of_eq, x_eq_a.
    + intros b' [a0 [b0 [a_eqv_a0 [b_eqv_b0 A_eqv_a0b0]]]] x_eqv_b'. rewrite A_eqv_a0b0. exists false.
      simpl in *. rewrite <- x_eqv_b', <- b_eqv_b0. apply set_of_eq, x_eq_b.
  Qed.

(** Unions *)
Inductive AUnion_dom (A : Acz) : Type := AUnion_ipair : ∀ i, dom (fn A i) → AUnion_dom A.
Definition AUnion_fn (A : Acz) (k : AUnion_dom A) : Acz :=
  match k with AUnion_ipair _ i j => fn (fn A i) j end.
Definition AUnion (A : Acz) : Acz := acz (AUnion_dom A) (AUnion_fn A).

Add Parametric Morphism : AUnion with signature equiv ==> equiv as AUnion_mor.
Proof.
  intros [I f] [J g] [AsubB BsubA]. split; simpl in *.
  - intros [i i2]. destruct (AsubB i) as [j fi_eqv_gj].
    destruct (equiv_elem _ _ fi_eqv_gj i2) as [j2 fii2_eqv_gjj2].
    exists (AUnion_ipair (acz J g) j j2). apply fii2_eqv_gjj2.
  - intros [j j2]. destruct (BsubA j) as [i fi_eqv_gj].
    symmetry in fi_eqv_gj. destruct (equiv_elem _ _ fi_eqv_gj j2) as [i2 gjj2_eqv_fii2].
    exists (AUnion_ipair (acz I f) i i2). symmetry. apply gjj2_eqv_fii2.
  Qed.

Definition union : set → set := Lift AUnion_mor.
Notation "⋃" := union.

Theorem in_union : ∀ F x, x ∈ ⋃ F ↔ ∃ X, X ∈ F ∧ x ∈ X.
Proof.
  intros F x. lower F x. split.
  - intro x_in_UF.
   destruct (x_in_UF (AUnion F) x) as [[i j] x_eqv_UFij]; simpl in *.
    + exists F. split; [reflexivity|]. split; intro i; exists i; reflexivity.
    + reflexivity.
    + exists (set_of (fn F i)). split; apply set_of_in; [| rewrite x_eqv_UFij]; apply elem.
  - intros [X [XinF x_in_X]]. lower X. apply set_of_in in x_in_X as [i x_eqv_Xi], XinF as [j XeqvFj].
    apply set_of_in_class. intros U [F' [FeqvF' UeqvUF']]. simpl in FeqvF'.
    destruct (equiv_elem X (fn F j) XeqvFj i) as [k Xi_eqv_Fjk].
    rewrite UeqvUF', <- FeqvF', x_eqv_Xi, Xi_eqv_Fjk.
    exists (AUnion_ipair _ j k). reflexivity.
  Qed.

(** Power sets *)
Definition APower (A : Acz) : Acz :=
  acz (dom A → Prop) (λ P, acz (sig P) (λ s, fn A (proj1_sig s))).

Add Parametric Morphism : APower with signature equiv ==> equiv as APower_mor.
Proof.
  intros [I f] [J g] [AsubB BsubA]. split; simpl in *.
  - intro p. exists (λ j, ∃ i, p i ∧ f i ≃ g j). split.
    + intros [i pi]. destruct (AsubB i) as [j fi_eq_gj].
      exists (exist _ j (ex_intro _ i (conj pi fi_eq_gj))). apply fi_eq_gj.
    + intros [j [i [pi fi_eq_gj]]]. exists (exist _ i pi). apply fi_eq_gj.
  - intro q. exists (λ i, ∃ j, q j ∧ f i ≃ g j). split.
    + intros [i [j [qj fi_eq_gj]]]. exists (exist _ j qj). apply fi_eq_gj.
    + intros [j qj]. destruct (BsubA j) as [i fi_eq_gj].
      exists (exist _ i (ex_intro _ j (conj qj fi_eq_gj))). apply fi_eq_gj.
  Qed.

Definition power : set → set := Lift APower_mor.
Definition ℙ := power.

Theorem in_power : ∀ Y X, X ∈ ℙ Y ↔ X ⊂ Y.
Proof.
  intros Y X. lower Y X. split.
  - intros XinPY. apply set_of_in_class_ex in XinPY as [P [[A [YeqvA PeqvPA]] XinP]].
    rewrite PeqvPA, <- YeqvA in XinP. apply set_of_sub. intro i. destruct XinP as [p XeqvPYp].
    destruct (equiv_elem _ _ XeqvPYp i) as [[j pj] Xi_eqv_Yj]. exists j. apply Xi_eqv_Yj.
  - intros XsubY P B [Y' [YeqvY' PeqvPY']] XeqvB. simpl in *. rewrite PeqvPY', <- XeqvB, <- YeqvY'.
    apply set_of_sub in XsubY. exists (λ j, ∃ i, fn X i ≃ fn Y j). destruct X as [I f]. split; simpl.
    + intro i. destruct (XsubY i) as [j fi_eqv_Yj].
      exists (exist _ j (ex_intro _ i fi_eqv_Yj)). apply fi_eqv_Yj.
    + intros [j [i fi_eqv_Yj]]. exists i. apply fi_eqv_Yj.
  Qed.

(** Separation *)
Definition ASep (P : set → Prop) (A : Acz) : Acz :=
  acz { i | P (set_of (fn A i)) } (λ s, fn A (proj1_sig s)).

Add Parametric Morphism (P : set → Prop) : (ASep P) with signature equiv ==> equiv as ASep_mor.
Proof.
  intros [I f] [J g] [i2j j2i]. split; simpl in *.
  - intros [i PAi]. destruct (i2j i) as [j fi_eqv_gj].
    assert (PBj: P (set_of (g j))). { rewrite <- fi_eqv_gj. apply PAi. }
    exists (exist _ j PBj). apply fi_eqv_gj.
  - intros [j PBj]. destruct (j2i j) as [i fi_eqv_gj].
    assert (PAi: P (set_of (f i))). { rewrite fi_eqv_gj. apply PBj. }
    exists (exist _ i PAi). apply fi_eqv_gj.
  Qed.

Definition sep (X : set) (P : set → Prop) : set := Lift (ASep_mor P) X.
Notation "{ a 'in' X | P }" := (sep X (λ a, P)) (format "{  a  in  X  |  P  }").

Theorem in_sep : ∀ X P x, x ∈ { a in X | P a } ↔ x ∈ X ∧ P x.
Proof.
  intros X P x. lower X x. split.
  - intro x_in_comp. apply set_of_in_class_ex in x_in_comp as [A [[X' [XeqvX' AeqvSep]] x_in_A]].
    rewrite AeqvSep, <- XeqvX' in x_in_A. destruct x_in_A as [[i PXi] x_eqv_Xi]. simpl in *. split.
    + apply set_of_in. exists i. apply x_eqv_Xi.
    + rewrite x_eqv_Xi. apply PXi.
  - intros [x_in_X Px] S x' [X' [XeqvX' SeqvSep]] x_eqv_x'. apply set_of_in in x_in_X as [i x_eqv_Xi].
    rewrite <- x_eqv_x', SeqvSep, <- XeqvX', x_eqv_Xi. rewrite x_eqv_Xi in Px.
    exists (exist _ i Px). reflexivity.
  Qed.

(** Infinity *)
Definition bin_union (A B : set) : set := ⋃ (upair A B).
Infix "∪" := bin_union (at level 50).

Definition bin_intersection (A B : set) : set := { x in A | x ∈ B }.
Infix "∩" := bin_intersection (at level 40).

Notation "{ a , }" := (upair a a) (format "{ a , }").
Notation "{ a , .. , b , c }" := ({a,} ∪ .. ({b,} ∪ {c,}) ..) (format "{  a ,  .. ,  b ,  c  }").

Fixpoint AInf_fn (n : nat) : Acz := match n with
                                    | O => AEmpty
                                    | S n => AUnion (APair (AInf_fn n) (ASing (AInf_fn n)))
                                    end.

Definition Inf_set : set := set_of (acz nat AInf_fn).

Theorem axiom_inf : ∅ ∈ Inf_set ∧ ∀ n, n ∈ Inf_set → n ∪ {n,} ∈ Inf_set.
Proof.
  split; [apply set_of_in; exists O; reflexivity|]. intros n. lower n.
  intros n_in_I J m [IsubJ JsubI] [s [[a [b [n_a [[c [d [n_c [n_d b_cd]]]] s_ab]]]] m_Us]].
  apply set_of_in in n_in_I as [k n_Ik]. simpl in *. destruct (IsubJ (S k)) as [j ISk_eqv_Jj].
  rewrite m_Us, s_ab, <- n_a, b_cd, <- n_c, <- n_d, n_Ik, ISk_eqv_Jj. apply elem.
  Qed.

(** Replacement *)
Lemma ALower (F : set → set) : ∃ f : Acz → Acz, ∀ a, F (set_of a) = set_of (f a).
Proof.
  apply (functional_choice (λ a b, F (set_of a) = set_of b)). intro a.
  lower (F (set_of a)) as b. exists b. reflexivity. Qed.

Lemma AReplace_class (f : set → set) (X : set) :
  equiv_class (λ B, ∀ y, y ∈ set_of B ↔ ∃ x, x ∈ X ∧ y = f x).
Proof.
  lower X. destruct X as [I u]. destruct (ALower f) as [f' fa_eq_f'a].
  exists (acz I (λ i, f' (u i))). apply predicate_extensionality. intros [J v]. split.
  - intro vdef. split; simpl; [intro i | intro j].
    + assert (fui_in_v: f' (u i) ∈' acz J v). {
        apply set_of_in. rewrite <- fa_eq_f'a. apply vdef. exists (set_of (u i)).
        split; [apply set_of_in, elem | reflexivity].
      }
      destruct fui_in_v as [j fui_eqv_vj]. exists j. apply fui_eqv_vj.
    + destruct (proj1 (vdef (set_of (v j))) ltac:(apply set_of_in, elem)) as [x [x_in_u vj_eq_fx]].
      lower x. apply set_of_in in x_in_u as [i x_eqv_ui]. exists i.
      apply set_of_eq. rewrite <- fa_eq_f'a, vj_eq_fx, x_eqv_ui. reflexivity.
  - intros [fXsubY YsubfX] y. simpl in fXsubY, YsubfX. lower y. split.
    + intros y_in_v. apply set_of_in in y_in_v as [j y_eqv_vj]. destruct (YsubfX j) as [i fui_eqv_vj].
      exists (set_of (u i)). split; [apply set_of_in, elem|].
      rewrite fa_eq_f'a. apply set_of_eq. rewrite fui_eqv_vj, y_eqv_vj. reflexivity.
    + intros [x [x_in_u y_eq_fx]]. lower x. apply set_of_in.
      apply set_of_in in x_in_u as [i x_eqv_ui]. destruct (fXsubY i) as [j fui_eqv_vj].
      exists j. rewrite <- fui_eqv_vj. apply set_of_eq. rewrite <- fa_eq_f'a, y_eq_fx. f_equal.
      apply set_of_eq, x_eqv_ui.
  Qed.

Definition replace (f : set → set) (X : set) : set := exist _ _ (AReplace_class f X).

Theorem axiom_replacement : ∀ f X y, y ∈ replace f X ↔ ∃ x, x ∈ X ∧ y = f x.
Proof. split.
  - lower X y. intro y_in_rfX. apply set_of_in_class_ex in y_in_rfX as [Y [Ydef y_in_Y]].
    apply Ydef, set_of_in, y_in_Y.
  - intros [x [x_in_X y_eq_fx]]. subst y. destruct (ALower f) as [f' fa_eq_f'a].
    lower X x. rewrite fa_eq_f'a. apply set_of_in_class. intros Y Ydef. apply set_of_in, Ydef.
    exists (set_of x). split; [apply x_in_X | rewrite fa_eq_f'a; reflexivity].
  Qed.

End Acz_set.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool.

(******************************************************************************)
(* This file defines two "base" combinatorial interfaces:                     *)
(*    eqType == the structure for types with a decidable equality.            *)
(*              Equality mixins can be made Canonical to allow generic        *)
(*              folding of equality predicates.                               *)
(* subType p == the structure for types isomorphic to {x : T | p x} with      *)
(*              p : pred T for some type T.                                   *)
(* The eqType interface supports the following operations:                    *)
(*          x == y <=> x compares equal to y (this is a boolean test).        *)
(*     x == y :> T <=> x == y at type T.                                      *)
(*          x != y <=> x and y compare unequal.                               *)
(*     x != y :> T <=>  "    "      "    "     at type T.                     *)
(*         x =P y  :: a proof of reflect (x = y) (x == y); this coerces       *)
(*                     to x == y -> x = y.                                    *)
(*    comparable T <-> equality on T is decidable                             *)
(*                    := forall x y : T, decidable (x = y)                    *)
(*  comparableClass compT == eqType mixin/class for compT : comparable T.     *)
(*             pred1 a == the singleton predicate [pred x | x == a].          *)
(* pred2, pred3, pred4 == pair, triple, quad predicates.                      *)
(*            predC1 a == [pred x | x != a].                                  *)
(*      [predU1 a & A] == [pred x | (x == a) || (x \in A)].                   *)
(*      [predD1 A & a] == [pred x | x != a & x \in A].                        *)
(*  predU1 a P, predD1 P a == applicative versions of the above.              *)
(*              frel f == the relation associated with f : T -> T.            *)
(*                     := [rel x y | f x == y].                               *)
(*       invariant k f == elements of T whose k-class is f-invariant.         *)
(*                     := [pred x | k (f x) == k x] with f : T -> T.          *)
(*  [fun x : T => e0 with a1 |-> e1, .., a_n |-> e_n]                         *)
(*  [eta f with a1 |-> e1, .., a_n |-> e_n] ==                                *)
(*    the auto-expanding function that maps x = a_i to e_i, and other values  *)
(*    of x to e0 (resp. f x). In the first form the `: T' is optional and x   *)
(*    can occur in a_i or e_i.                                                *)
(* Equality on an eqType is proof-irrelevant (lemma eq_irrelevance).          *)
(*   The eqType interface is implemented for most standard datatypes:         *)
(*  bool, unit, void, option, prod (denoted A * B), sum (denoted A + B),      *)
(*  sig (denoted {x | P}), sigT (denoted {i : I & T}). We also define         *)
(*   tagged_as u v == v cast as T_(tag u) if tag v == tag u, else u.          *)
(*  -> We have u == v <=> (tag u == tag v) && (tagged u == tagged_as u v).    *)
(* The subType interface supports the following operations:                   *)
(*      val == the generic injection from a subType S of T into T.            *)
(*             For example, if u : {x : T | P}, then val u : T.               *)
(*             val is injective because P is proof-irrelevant (P is in bool,  *)
(*             and the is_true coercion expands to P = true).                 *)
(*     valP == the generic proof of P (val u) for u : subType P.              *)
(* Sub x Px == the generic constructor for a subType P; Px is a proof of P x  *)
(*             and P should be inferred from the expected return type.        *)
(*  insub x == the generic partial projection of T into a subType S of T.     *)
(*             This returns an option S; if S : subType P then                *)
(*                insub x = Some u with val u = x if P x,                     *)
(*                          None if ~~ P x                                    *)
(*             The insubP lemma encapsulates this dichotomy.                  *)
(*             P should be infered from the expected return type.             *)
(*  innew x == total (non-option) variant of insub when P = predT.            *)
(* {? x | P} == option {x | P} (syntax for casting insub x).                  *)
(* insubd u0 x == the generic projection with default value u0.               *)
(*             := odflt u0 (insub x).                                         *)
(* insigd A0 x == special case of insubd for S == {x | x \in A}, where A0 is  *)
(*                a proof of x0 \in A.                                        *)
(* insub_eq x == transparent version of insub x that expands to Some/None     *)
(*               when P x can evaluate.                                       *)
(*  The subType P interface is most often implemented using one of:           *)
(*   [subType for S_val]                                                      *)
(*     where S_val : S -> T is the first projection of a type S isomorphic to *)
(*     {x : T | P}.                                                           *)
(*   [newType for S_val]                                                      *)
(*     where S_val : S -> T is the projection of a type S isomorphic to       *)
(*     wrapped T; in this case P must be predT.                               *)
(*   [subType for S_val by Srect], [newType for S_val by Srect]               *)
(*     variants of the above where the eliminator is explicitly provided.     *)
(*     Here S no longer needs to be syntactically identical to {x | P x} or   *)
(*     wrapped T, but it must have a derived constructor S_Sub statisfying an *)
(*     eliminator Srect identical to the one the Coq Inductive command would  *)
(*     have generated, and S_val (S_Sub x Px) (resp. S_val (S_sub x) for the  *)
(*     newType form) must be convertible to x.                                *)
(*     variant of the above when S is a wrapper type for T (so P = predT).    *)
(*   [subType of S], [subType of S for S_val]                                 *)
(*     clones the canonical subType structure for S; if S_val is specified,   *)
(*     then it replaces the inferred projector.                               *)
(* Subtypes inherit the eqType structure of their base types; the generic     *)
(* structure should be explicitly instantiated using the                      *)
(*   [eqMixin of S by <:]                                                     *)
(* construct to declare the Equality mixin; this pattern is repeated for all  *)
(* the combinatorial interfaces (Choice, Countable, Finite).                  *)
(*   More generally, the eqType structure can be transfered by (partial)      *)
(* injections, using:                                                         *)
(*   InjEqMixin injf == an Equality mixin for T, using an f : T -> eT where   *)
(*                      eT has an eqType structure and injf : injective f.    *)
(*    PcanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse partial function g and fK : pcancel f g.      *)
(*     CanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse function g and fK : cancel f g.               *)
(*   We add the following to the standard suffixes documented in ssrbool.v:   *)
(*  1, 2, 3, 4 -- explicit enumeration predicate for 1 (singleton), 2, 3, or  *)
(*                4 values.                                                   *)
(******************************************************************************)

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

Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).

Definition class := let: Pack _ c _ := cT return class_of cT in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation eqType := type.
Notation EqMixin := Mixin.
Notation EqType T m := (@pack T m).
Notation "[ 'eqMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T ]") : form_scope.
Notation "[ 'eqType' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'eqType'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'eqType' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'eqType'  'of'  T ]") : form_scope.
End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).

Lemma eqE T x : eq_op x = Equality.op (Equality.class T) x.
Proof. by []. Qed.

Lemma eqP T : Equality.axiom (@eq_op T).
Proof. by case: T => ? []. Qed.
Arguments eqP [T x y].

Delimit Scope eq_scope with EQ.
Open Scope eq_scope.

Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (~~ (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (~~ (x == y :> T))
  (at level 70, y at next level) : bool_scope.
Notation "x =P y" := (eqP : reflect (x = y) (x == y))
  (at level 70, no associativity) : eq_scope.
Notation "x =P y :> T" := (eqP : reflect (x = y :> T) (x == y :> T))
  (at level 70, y at next level, no associativity) : eq_scope.

Prenex Implicits eq_op eqP.

Lemma eq_refl (T : eqType) (x : T) : x == x. Proof. exact/eqP. Qed.
Notation eqxx := eq_refl.

Lemma eq_sym (T : eqType) (x y : T) : (x == y) = (y == x).
Proof. exact/eqP/eqP. Qed.

Hint Resolve eq_refl eq_sym.

Section Contrapositives.

Variables (T1 T2 : eqType).
Implicit Types (A : pred T1) (b : bool) (x : T1) (z : T2).

Lemma contraTeq b x y : (x != y -> ~~ b) -> b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraTT hyp. Qed.

Lemma contraNeq b x y : (x != y -> b) -> ~~ b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraNT hyp. Qed.

Lemma contraFeq b x y : (x != y -> b) -> b = false -> x = y.
Proof. by move=> imp /negbT; apply: contraNeq. Qed.

Lemma contraTneq b x y : (x = y -> ~~ b) -> b -> x != y.
Proof. by move=> imp; apply: contraTN => /eqP. Qed.

Lemma contraNneq b x y : (x = y -> b) -> ~~ b -> x != y.
Proof. by move=> imp; apply: contraNN => /eqP. Qed.

Lemma contraFneq b x y : (x = y -> b) -> b = false -> x != y.
Proof. by move=> imp /negbT; apply: contraNneq. Qed.

Lemma contra_eqN b x y : (b -> x != y) -> x = y -> ~~ b.
Proof. by move=> imp /eqP; apply: contraL. Qed.

Lemma contra_eqF b x y : (b -> x != y) -> x = y -> b = false.
Proof. by move=> imp /eqP; apply: contraTF. Qed.

Lemma contra_eqT b x y : (~~ b -> x != y) -> x = y -> b.
Proof. by move=> imp /eqP; apply: contraLR. Qed.

Lemma contra_eq z1 z2 x1 x2 : (x1 != x2 -> z1 != z2) -> z1 = z2 -> x1 = x2.
Proof. by move=> imp /eqP; apply: contraTeq. Qed.

Lemma contra_neq z1 z2 x1 x2 : (x1 = x2 -> z1 = z2) -> z1 != z2 -> x1 != x2.
Proof. by move=> imp; apply: contraNneq => /imp->. Qed.

Lemma memPn A x : reflect {in A, forall y, y != x} (x \notin A).
Proof.
apply: (iffP idP) => [notDx y | notDx]; first by apply: contraTneq => ->.
exact: contraL (notDx x) _.
Qed.

Lemma memPnC A x : reflect {in A, forall y, x != y} (x \notin A).
Proof. by apply: (iffP (memPn A x)) => A'x y /A'x; rewrite eq_sym. Qed.

Lemma ifN_eq R x y vT vF : x != y -> (if x == y then vT else vF) = vF :> R.
Proof. exact: ifN. Qed.

Lemma ifN_eqC R x y vT vF : x != y -> (if y == x then vT else vF) = vF :> R.
Proof. by rewrite eq_sym; apply: ifN. Qed.

End Contrapositives.

Arguments memPn [T1 A x].
Arguments memPnC [T1 A x].

Theorem eq_irrelevance (T : eqType) x y : forall e1 e2 : x = y :> T, e1 = e2.
Proof.
pose proj z e := if x =P z is ReflectT e0 then e0 else e.
suff: injective (proj y) by rewrite /proj => injp e e'; apply: injp; case: eqP.
pose join (e : x = _) := etrans (esym e).
apply: can_inj (join x y (proj x (erefl x))) _.
by case: y /; case: _ / (proj x _).
Qed.

Corollary eq_axiomK (T : eqType) (x : T) : all_equal_to (erefl x).
Proof. by move=> eq_x_x; apply: eq_irrelevance. Qed.

(* We use the module system to circumvent a silly limitation that  *)
(* forbids using the same constant to coerce to different targets. *)
Module Type EqTypePredSig.
Parameter sort : eqType -> predArgType.
End EqTypePredSig.
Module MakeEqTypePred (eqmod : EqTypePredSig).
Coercion eqmod.sort : eqType >-> predArgType.
End MakeEqTypePred.
Module Export EqTypePred := MakeEqTypePred Equality.

Lemma unit_eqP : Equality.axiom (fun _ _ : unit => true).
Proof. by do 2!case; left. Qed.

Definition unit_eqMixin := EqMixin unit_eqP.
Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin.

(* Comparison for booleans. *)

(* This is extensionally equal, but not convertible to Bool.eqb. *)
Definition eqb b := addb (~~ b).

Lemma eqbP : Equality.axiom eqb.
Proof. by do 2!case; constructor. Qed.

Canonical bool_eqMixin := EqMixin eqbP.
Canonical bool_eqType := Eval hnf in EqType bool bool_eqMixin.

Lemma eqbE : eqb = eq_op. Proof. by []. Qed.

Lemma bool_irrelevance (x y : bool) (E E' : x = y) : E = E'.
Proof. exact: eq_irrelevance. Qed.

Lemma negb_add b1 b2 : ~~ (b1 (+) b2) = (b1 == b2).
Proof. by rewrite -addNb. Qed.

Lemma negb_eqb b1 b2 : (b1 != b2) = b1 (+) b2.
Proof. by rewrite -addNb negbK. Qed.

Lemma eqb_id b : (b == true) = b.
Proof. by case: b. Qed.

Lemma eqbF_neg b : (b == false) = ~~ b.
Proof. by case: b. Qed.

Lemma eqb_negLR b1 b2 : (~~ b1 == b2) = (b1 == ~~ b2).
Proof. by case: b1; case: b2. Qed.

(* Equality-based predicates.       *)

Notation xpred1 := (fun a1 x => x == a1).
Notation xpred2 := (fun a1 a2 x => (x == a1) || (x == a2)).
Notation xpred3 := (fun a1 a2 a3 x => [|| x == a1, x == a2 | x == a3]).
Notation xpred4 :=
  (fun a1 a2 a3 a4 x => [|| x == a1, x == a2, x == a3 | x == a4]).
Notation xpredU1 := (fun a1 (p : pred _) x => (x == a1) || p x).
Notation xpredC1 := (fun a1 x => x != a1).
Notation xpredD1 := (fun (p : pred _) a1 x => (x != a1) && p x).

Section EqPred.

Variable T : eqType.

Definition pred1 (a1 : T) := SimplPred (xpred1 a1).
Definition pred2 (a1 a2 : T) := SimplPred (xpred2 a1 a2).
Definition pred3 (a1 a2 a3 : T) := SimplPred (xpred3 a1 a2 a3).
Definition pred4 (a1 a2 a3 a4 : T) := SimplPred (xpred4 a1 a2 a3 a4).
Definition predU1 (a1 : T) p := SimplPred (xpredU1 a1 p).
Definition predC1 (a1 : T) := SimplPred (xpredC1 a1).
Definition predD1 p (a1 : T) := SimplPred (xpredD1 p a1).

Lemma pred1E : pred1 =2 eq_op. Proof. by move=> x y; apply: eq_sym. Qed.

Variables (T2 : eqType) (x y : T) (z u : T2) (b : bool).

Lemma predU1P : reflect (x = y \/ b) ((x == y) || b).
Proof. by apply: (iffP orP); do [case=> [/eqP|]; [left | right]]. Qed.

Lemma pred2P : reflect (x = y \/ z = u) ((x == y) || (z == u)).
Proof. by apply: (iffP orP); do [case=> /eqP; [left | right]]. Qed.

Lemma predD1P : reflect (x <> y /\ b) ((x != y) && b).
Proof. by apply: (iffP andP)=> [] [] // /eqP. Qed.

Lemma predU1l : x = y -> (x == y) || b.
Proof. by move->; rewrite eqxx. Qed.

Lemma predU1r : b -> (x == y) || b.
Proof. by move->; rewrite orbT. Qed.

Lemma eqVneq : {x = y} + {x != y}.
Proof. by case: eqP; [left | right]. Qed.

End EqPred.

Arguments predU1P [T x y b].
Arguments pred2P [T T2 x y z u].
Arguments predD1P [T x y b].
Prenex Implicits pred1 pred2 pred3 pred4 predU1 predC1 predD1 predU1P.

Notation "[ 'predU1' x & A ]" := (predU1 x [mem A])
  (at level 0, format "[ 'predU1'  x  &  A ]") : fun_scope.
Notation "[ 'predD1' A & x ]" := (predD1 [mem A] x)
  (at level 0, format "[ 'predD1'  A  &  x ]") : fun_scope.

(* Lemmas for reflected equality and functions.   *)

Section EqFun.

Section Exo.

Variables (aT rT : eqType) (D : pred aT) (f : aT -> rT) (g : rT -> aT).

Lemma inj_eq : injective f -> forall x y, (f x == f y) = (x == y).
Proof. by move=> inj_f x y; apply/eqP/eqP=> [|-> //]; apply: inj_f. Qed.

Lemma can_eq : cancel f g -> forall x y, (f x == f y) = (x == y).
Proof. by move/can_inj; apply: inj_eq. Qed.

Lemma bij_eq : bijective f -> forall x y, (f x == f y) = (x == y).
Proof. by move/bij_inj; apply: inj_eq. Qed.

Lemma can2_eq : cancel f g -> cancel g f -> forall x y, (f x == y) = (x == g y).
Proof. by move=> fK gK x y; rewrite -{1}[y]gK; apply: can_eq. Qed.

Lemma inj_in_eq :
  {in D &, injective f} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move=> inj_f x y Dx Dy; apply/eqP/eqP=> [|-> //]; apply: inj_f. Qed.

Lemma can_in_eq :
  {in D, cancel f g} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move/can_in_inj; apply: inj_in_eq. Qed.

End Exo.

Section Endo.

Variable T : eqType.

Definition frel f := [rel x y : T | f x == y].

Lemma inv_eq f : involutive f -> forall x y : T, (f x == y) = (x == f y).
Proof. by move=> fK; apply: can2_eq. Qed.

Lemma eq_frel f f' : f =1 f' -> frel f =2 frel f'.
Proof. by move=> eq_f x y; rewrite /= eq_f. Qed.

End Endo.

Variable aT : Type.

(* The invariant of an function f wrt a projection k is the pred of points *)
(* that have the same projection as their image.                           *)

Definition invariant (rT : eqType) f (k : aT -> rT) :=
  [pred x | k (f x) == k x].

Variables (rT1 rT2 : eqType) (f : aT -> aT) (h : rT1 -> rT2) (k : aT -> rT1).

Lemma invariant_comp : subpred (invariant f k) (invariant f (h \o k)).
Proof. by move=> x eq_kfx; rewrite /= (eqP eq_kfx). Qed.

Lemma invariant_inj : injective h -> invariant f (h \o k) =1 invariant f k.
Proof. by move=> inj_h x; apply: (inj_eq inj_h). Qed.

End EqFun.

Prenex Implicits frel.

(* The coercion to rel must be explicit for derived Notations to unparse. *)
Notation coerced_frel f := (rel_of_simpl_rel (frel f)) (only parsing).

Section FunWith.

Variables (aT : eqType) (rT : Type).

CoInductive fun_delta : Type := FunDelta of aT & rT.

Definition fwith x y (f : aT -> rT) := [fun z => if z == x then y else f z].

Definition app_fdelta df f z :=
  let: FunDelta x y := df in if z == x then y else f z.

End FunWith.

Prenex Implicits fwith.

Notation "x |-> y" := (FunDelta x y)
  (at level 190, no associativity,
   format "'[hv' x '/ '  |->  y ']'") : fun_delta_scope.

Delimit Scope fun_delta_scope with FUN_DELTA.
Arguments app_fdelta _ _%type _%FUN_DELTA _ _.

Notation "[ 'fun' z : T => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z : T =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA  (fun _ => F)) ..))
  (at level 0, z ident, only parsing) : fun_scope.

Notation "[ 'fun' z => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA (fun _ => F)) ..))
  (at level 0, z ident, format
   "'[hv' [ '[' 'fun'  z  => '/ '  F ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
   ) : fun_scope.

Notation "[ 'eta' f 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun _ =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA f) ..))
  (at level 0, format
  "'[hv' [ '[' 'eta' '/ '  f ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
  ) : fun_scope.

(* Various EqType constructions.                                         *)

Section ComparableType.

Variable T : Type.

Definition comparable := forall x y : T, decidable (x = y).

Hypothesis Hcompare : comparable.

Definition compareb x y : bool := Hcompare x y.

Lemma compareP : Equality.axiom compareb.
Proof. by move=> x y; apply: sumboolP. Qed.

Definition comparableClass := EqMixin compareP.

End ComparableType.

Definition eq_comparable (T : eqType) : comparable T :=
  fun x y => decP (x =P y).

Section SubType.

Variables (T : Type) (P : pred T).

Structure subType : Type := SubType {
  sub_sort :> Type;
  val : sub_sort -> T;
  Sub : forall x, P x -> sub_sort;
  _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
  _ : forall x Px, val (@Sub x Px) = x
}.

Arguments Sub [s].
Lemma vrefl : forall x, P x -> x = x. Proof. by []. Qed.
Definition vrefl_rect := vrefl.

Definition clone_subType U v :=
  fun sT & sub_sort sT -> U =>
  fun c Urec cK (sT' := @SubType U v c Urec cK) & phant_id sT' sT => sT'.

Variable sT : subType.

CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px).

Lemma SubP u : Sub_spec u.
Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed.

Lemma SubK x Px : @val sT (Sub x Px) = x.
Proof. by case: sT. Qed.

Definition insub x :=
  if @idP (P x) is ReflectT Px then @Some sT (Sub x Px) else None.

Definition insubd u0 x := odflt u0 (insub x).

CoInductive insub_spec x : option sT -> Type :=
  | InsubSome u of P x & val u = x : insub_spec x (Some u)
  | InsubNone   of ~~ P x          : insub_spec x None.

Lemma insubP x : insub_spec x (insub x).
Proof.
by rewrite /insub; case: {-}_ / idP; [left; rewrite ?SubK | right; apply/negP].
Qed.

Lemma insubT x Px : insub x = Some (Sub x Px).
Proof.
do [case: insubP => [/SubP[y Py] _ <- | /negP// ]; rewrite SubK]  in Px *.
by rewrite (bool_irrelevance Px Py).
Qed.

Lemma insubF x : P x = false -> insub x = None.
Proof. by move/idP; case: insubP. Qed.

Lemma insubN x : ~~ P x -> insub x = None.
Proof. by move/negPf/insubF. Qed.

Lemma isSome_insub : ([eta insub] : pred T) =1 P.
Proof. by apply: fsym => x; case: insubP => // /negPf. Qed.

Lemma insubK : ocancel insub (@val _).
Proof. by move=> x; case: insubP. Qed.

Lemma valP (u : sT) : P (val u).
Proof. by case/SubP: u => x Px; rewrite SubK. Qed.

Lemma valK : pcancel (@val _) insub.
Proof. by case/SubP=> x Px; rewrite SubK; apply: insubT. Qed.

Lemma val_inj : injective (@val sT).
Proof. exact: pcan_inj valK. Qed.

Lemma valKd u0 : cancel (@val _) (insubd u0).
Proof. by move=> u; rewrite /insubd valK. Qed.

Lemma val_insubd u0 x : val (insubd u0 x) = if P x then x else val u0.
Proof. by rewrite /insubd; case: insubP => [u -> | /negPf->]. Qed.

Lemma insubdK u0 : {in P, cancel (insubd u0) (@val _)}.
Proof. by move=> x Px; rewrite /= val_insubd [P x]Px. Qed.

Definition insub_eq x :=
  let Some_sub Px := Some (Sub x Px : sT) in
  let None_sub _ := None in
  (if P x as Px return P x = Px -> _ then Some_sub else None_sub) (erefl _).

Lemma insub_eqE : insub_eq =1 insub.
Proof.
rewrite /insub_eq /insub => x; case: {2 3}_ / idP (erefl _) => // Px Px'.
by congr (Some _); apply: val_inj; rewrite !SubK.
Qed.

End SubType.

Arguments SubType [T P].
Arguments Sub [T P s].
Arguments vrefl [T P].
Arguments vrefl_rect [T P].
Arguments clone_subType [T P] U v [sT] _ [c Urec cK].
Arguments insub [T P sT].
Arguments insubT [T] P [sT x].
Arguments val_inj [T P sT].
Prenex Implicits val Sub vrefl vrefl_rect insub insubd val_inj.

Local Notation inlined_sub_rect :=
  (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px).

Local Notation inlined_new_rect :=
  (fun K K_S u => let (x) as u return K u := u in K_S x).

Notation "[ 'subType' 'for' v ]" := (SubType _ v _ inlined_sub_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'sub' 'Type' 'for' v ]" := (SubType _ v _ _ vrefl_rect)
 (at level 0, format "[ 'sub' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'subType' 'for' v 'by' rec ]" := (SubType _ v _ rec vrefl)
 (at level 0, format "[ 'subType'  'for'  v  'by'  rec ]") : form_scope.

Notation "[ 'subType' 'of' U 'for' v ]" := (clone_subType U v id idfun)
 (at level 0, format "[ 'subType'  'of'  U  'for'  v ]") : form_scope.

(*
Notation "[ 'subType' 'for' v ]" := (clone_subType _ v id idfun)
 (at level 0, format "[ 'subType'  'for'  v ]") : form_scope.
*)
Notation "[ 'subType' 'of' U ]" := (clone_subType U _ id id)
 (at level 0, format "[ 'subType'  'of'  U ]") : form_scope.

Definition NewType T U v c Urec :=
  let Urec' P IH := Urec P (fun x : T => IH x isT : P _) in
  SubType U v (fun x _ => c x) Urec'.
Arguments NewType [T U].

Notation "[ 'newType' 'for' v ]" := (NewType v _ inlined_new_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'new' 'Type' 'for' v ]" := (NewType v _ _ vrefl_rect)
 (at level 0, format "[ 'new' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'newType' 'for' v 'by' rec ]" := (NewType v _ rec vrefl)
 (at level 0, format "[ 'newType'  'for'  v  'by'  rec ]") : form_scope.

Definition innew T nT x := @Sub T predT nT x (erefl true).
Arguments innew [T nT].
Prenex Implicits innew.

Lemma innew_val T nT : cancel val (@innew T nT).
Proof. by move=> u; apply: val_inj; apply: SubK. Qed.

(* Prenex Implicits and renaming. *)
Notation sval := (@proj1_sig _ _).
Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'").

Section SigProj.

Variables (T : Type) (P Q : T -> Prop).

Lemma svalP : forall u : sig P, P (sval u). Proof. by case. Qed.

Definition s2val (u : sig2 P Q) := let: exist2 x _ _ := u in x.

Lemma s2valP u : P (s2val u). Proof. by case: u. Qed.

Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed.

End SigProj.

Prenex Implicits svalP s2val s2valP s2valP'.

Canonical sig_subType T (P : pred T) : subType [eta P] :=
  Eval hnf in [subType for @sval T [eta [eta P]]].

(* Shorthand for sigma types over collective predicates. *)
Notation "{ x 'in' A }" := {x | x \in A}
  (at level 0, x at level 99, format  "{ x  'in'  A }") : type_scope.
Notation "{ x 'in' A | P }" := {x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ x  'in'  A  |  P }") : type_scope.

(* Shorthand for the return type of insub. *)
Notation "{ ? x : T | P }" := (option {x : T | is_true P})
  (at level 0, x at level 99, only parsing) : type_scope.
Notation "{ ? x | P }" := {? x : _ | P}
  (at level 0, x at level 99, format  "{ ?  x  |  P }") : type_scope.
Notation "{ ? x 'in' A }" := {? x | x \in A}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A }") : type_scope.
Notation "{ ? x 'in' A | P }" := {? x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A  |  P }") : type_scope.

(* A variant of injection with default that infers a collective predicate *)
(* from the membership proof for the default value.                       *)
Definition insigd T (A : mem_pred T) x (Ax : in_mem x A) :=
  insubd (exist [eta A] x Ax).

(* There should be a rel definition for the subType equality op, but this *)
(* seems to cause the simpl tactic to diverge on expressions involving == *)
(* on 4+ nested subTypes in a "strict" position (e.g., after ~~).         *)
(* Definition feq f := [rel x y | f x == f y].                            *)

Section TransferEqType.

Variables (T : Type) (eT : eqType) (f : T -> eT).

Lemma inj_eqAxiom : injective f -> Equality.axiom (fun x y => f x == f y).
Proof. by move=> f_inj x y; apply: (iffP eqP) => [|-> //]; apply: f_inj. Qed.

Definition InjEqMixin f_inj := EqMixin (inj_eqAxiom f_inj).

Definition PcanEqMixin g (fK : pcancel f g) := InjEqMixin (pcan_inj fK).

Definition CanEqMixin g (fK : cancel f g) := InjEqMixin (can_inj fK).

End TransferEqType.

Section SubEqType.

Variables (T : eqType) (P : pred T) (sT : subType P).

Local Notation ev_ax := (fun T v => @Equality.axiom T (fun x y => v x == v y)).
Lemma val_eqP : ev_ax sT val. Proof. exact: inj_eqAxiom val_inj. Qed.

Definition sub_eqMixin := EqMixin val_eqP.
Canonical sub_eqType := Eval hnf in EqType sT sub_eqMixin.

Definition SubEqMixin :=
  (let: SubType _ v _ _ _ as sT' := sT
     return ev_ax sT' val -> Equality.class_of sT' in
   fun vP : ev_ax _ v => EqMixin vP
   ) val_eqP.

Lemma val_eqE (u v : sT) : (val u == val v) = (u == v).
Proof. by []. Qed.

End SubEqType.

Arguments val_eqP [T P sT x y].
Prenex Implicits val_eqP.

Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SigEqType.

Variables (T : eqType) (P : pred T).

Definition sig_eqMixin := Eval hnf in [eqMixin of {x | P x} by <:].
Canonical sig_eqType := Eval hnf in EqType {x | P x} sig_eqMixin.

End SigEqType.

Section ProdEqType.

Variable T1 T2 : eqType.

Definition pair_eq := [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)].

Lemma pair_eqP : Equality.axiom pair_eq.
Proof.
move=> [x1 x2] [y1 y2] /=; apply: (iffP andP) => [[]|[<- <-]] //=.
by do 2!move/eqP->.
Qed.

Definition prod_eqMixin := EqMixin pair_eqP.
Canonical prod_eqType := Eval hnf in EqType (T1 * T2) prod_eqMixin.

Lemma pair_eqE : pair_eq = eq_op :> rel _. Proof. by []. Qed.

Lemma xpair_eqE (x1 y1 : T1) (x2 y2 : T2) :
  ((x1, x2) == (y1, y2)) = ((x1 == y1) && (x2 == y2)).
Proof. by []. Qed.

Lemma pair_eq1 (u v : T1 * T2) : u == v -> u.1 == v.1.
Proof. by case/andP. Qed.

Lemma pair_eq2 (u v : T1 * T2) : u == v -> u.2 == v.2.
Proof. by case/andP. Qed.

End ProdEqType.

Arguments pair_eqP [T1 T2].

Prenex Implicits pair_eqP.

Definition predX T1 T2 (p1 : pred T1) (p2 : pred T2) :=
  [pred z | p1 z.1 & p2 z.2].

Notation "[ 'predX' A1 & A2 ]" := (predX [mem A1] [mem A2])
  (at level 0, format "[ 'predX'  A1  &  A2 ]") : fun_scope.

Section OptionEqType.

Variable T : eqType.

Definition opt_eq (u v : option T) : bool :=
  oapp (fun x => oapp (eq_op x) false v) (~~ v) u.

Lemma opt_eqP : Equality.axiom opt_eq.
Proof.
case=> [x|] [y|] /=; by [constructor | apply: (iffP eqP) => [|[]] ->].
Qed.

Canonical option_eqMixin := EqMixin opt_eqP.
Canonical option_eqType := Eval hnf in EqType (option T) option_eqMixin.

End OptionEqType.

Definition tag := projS1.
Definition tagged I T_ :  forall u, T_(tag u) := @projS2 I [eta T_].
Definition Tagged I i T_ x := @existS I [eta T_] i x.
Arguments Tagged [I i].
Prenex Implicits tag tagged Tagged.

Section TaggedAs.

Variables (I : eqType) (T_ : I -> Type).
Implicit Types u v : {i : I & T_ i}.

Definition tagged_as u v :=
  if tag u =P tag v is ReflectT eq_uv then
    eq_rect_r T_ (tagged v) eq_uv
  else tagged u.

Lemma tagged_asE u x : tagged_as u (Tagged T_ x) = x.
Proof.
by rewrite /tagged_as /=; case: eqP => // eq_uu; rewrite [eq_uu]eq_axiomK.
Qed.

End TaggedAs.

Section TagEqType.

Variables (I : eqType) (T_ : I -> eqType).
Implicit Types u v : {i : I & T_ i}.

Definition tag_eq u v := (tag u == tag v) && (tagged u == tagged_as u v).

Lemma tag_eqP : Equality.axiom tag_eq.
Proof.
rewrite /tag_eq => [] [i x] [j] /=.
case: eqP => [<-|Hij] y; last by right; case.
by apply: (iffP eqP) => [->|<-]; rewrite tagged_asE.
Qed.

Canonical tag_eqMixin := EqMixin tag_eqP.
Canonical tag_eqType := Eval hnf in EqType {i : I & T_ i} tag_eqMixin.

Lemma tag_eqE : tag_eq = eq_op. Proof. by []. Qed.

Lemma eq_tag u v : u == v -> tag u = tag v.
Proof. by move/eqP->. Qed.

Lemma eq_Tagged u x :(u == Tagged _ x) = (tagged u == x).
Proof. by rewrite -tag_eqE /tag_eq eqxx tagged_asE. Qed.

End TagEqType.

Arguments tag_eqP [I T_ x y].
Prenex Implicits tag_eqP.

Section SumEqType.

Variables T1 T2 : eqType.
Implicit Types u v : T1 + T2.

Definition sum_eq u v :=
  match u, v with
  | inl x, inl y | inr x, inr y => x == y
  | _, _ => false
  end.

Lemma sum_eqP : Equality.axiom sum_eq.
Proof. case=> x [] y /=; by [right | apply: (iffP eqP) => [->|[->]]]. Qed.

Canonical sum_eqMixin := EqMixin sum_eqP.
Canonical sum_eqType := Eval hnf in EqType (T1 + T2) sum_eqMixin.

Lemma sum_eqE : sum_eq = eq_op. Proof. by []. Qed.

End SumEqType.

Arguments sum_eqP [T1 T2 x y].
Prenex Implicits sum_eqP.


(** * Normalization of Call-By-Value System F *)

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import AutosubstSsr Context.

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

(** **** Definitions *)

Inductive type : Type :=
| TyVar (x : var)
| Arr   (A B : type)
| All   (A : {bind type}).

Inductive term :=
| TeVar (x : var)
| Abs   (A : type) (s : {bind term})
| App   (s t : term)
| TAbs  (s : {bind type in term})
| TApp  (s : term) (A : type).

(** **** Substitution Lemmas *)

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.

Instance SubstLemmas_type : SubstLemmas type. derive. Qed.

Instance HSubst_term : HSubst type term. derive. Defined.

Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.

Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed.
Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed.

Instance SubstLemmas_term : SubstLemmas term. derive. Qed.

(** **** Call-by value reduction *)

Inductive eval : term -> term -> Prop :=
| eval_beta (A : type) (s t u1 u2 v : term) :
    eval s (Abs A u1) -> eval t u2 -> eval u1.[u2/] v -> eval (App s t) v
| eval_tbeta (B : type) (s A v : term) :
    eval s (TAbs A) -> eval A.|[B/] v -> eval (TApp s B) v
| eval_abs (A : type) (s : term) :
    eval (Abs A s) (Abs A s)
| eval_tabs (A : term) :
    eval (TAbs A) (TAbs A).
Hint Resolve eval_abs eval_tabs.

(** **** Syntactic typing *)

Definition ctx := seq type.
Local Notation "Gamma `_ i" := (get Gamma i) (at level 2).

Inductive has_type (Gamma : ctx) : term -> type -> Prop :=
| ty_var (x : var) :
    x < size Gamma -> has_type Gamma (TeVar x) Gamma`_x
| ty_abs (A B : type) (s : term) :
    has_type (A :: Gamma) s B ->
    has_type Gamma (Abs A s) (Arr A B)
| ty_app (A B : type) (s t : term) :
    has_type Gamma s (Arr A B) ->
    has_type Gamma t A ->
    has_type Gamma (App s t) B
| ty_tabs (A : type) (s : term) :
    has_type Gamma..[ren (+1)] s A ->
    has_type Gamma (TAbs s) (All A)
| ty_tapp (A B : type) (s : term) :
    has_type Gamma s (All A) ->
    has_type Gamma (TApp s B) A.[B/].

(** **** Semantic typing *)

Definition L (P : term -> Prop) (s : term) :=
  exists2 v, eval s v & P v.

Fixpoint V (A : type) (rho : var -> term -> Prop) (v : term) {struct A} : Prop :=
  match A with
    | TyVar X => eval v v /\ rho X v
    | Arr A B => exists A' : type, exists2 s : term, v = Abs A' s &
        forall u, V A rho u -> L (V B rho) s.[u/]
    | All A => exists2 s : term, v = TAbs s &
        forall i (B : type), L (V A (i .: rho)) s.|[B/]
  end.
Notation E A rho := (L (V A rho)).

Lemma V_value A rho v : V A rho v -> eval v v.
Proof. by elim: A => [x[]|A _ B _/=[A'[s->]]|A _/=[s->]]. Qed.
Hint Resolve V_value.

Lemma V_to_E A rho v : V A rho v -> E A rho v.
Proof. exists v; eauto. Qed.
Hint Resolve V_to_E.

Lemma eq_V A rho1 rho2 v :
  (forall X v, eval v v -> (rho1 X v <-> rho2 X v)) -> V A rho1 v -> V A rho2 v.
Proof.
  elim: A rho1 rho2 v => //=.
  - move=> x rho1 rho2 v eqn [ev /eqn]. by intuition.
  - move=> A ih1 B ih2 rho1 rho2 v eqn [A' [s -> h]]. exists A'.
    exists s=>// u /ih1/h[]. by move=> X w; split; apply eqn.
    move=> w ev /ih2 ih. by exists w; eauto.
  - move=> A ih rho1 rho2 v eqn [s->h]. exists s => // P B.
    case: (h P B) => u ev /ih va. exists u => //. apply: va => -[|X] //=.
    exact: eqn.
Qed.

Lemma V_ren A rho s xi :
  V A.[ren xi] rho s <-> V A (xi >>> rho) s.
Proof.
  elim: A rho s xi => //=.
  - move=> A ih1 B ih2 rho v xi. split=> -[A'[s->h]];
     (do 2 eexists) => // t /ih1/h[u ev]/ih2 ih; by exists u.
  - move=> A ih rho s xi; asimpl.
    split=> -[s' -> h]; eexists => //; asimpl=> P B; move: {h} (h P B) => [v ev].
    + move=> /ih {ih} ih. exists v => //. by asimpl in ih.
    + move=> h. exists v => //. apply/ih. autosubst.
Qed.

Lemma E_ren A rho s xi :
  E A.[ren xi] rho s <-> E A (xi >>> rho) s.
Proof.
  split=> -[v ev /V_ren h]; by exists v.
Qed.

Lemma V_subst A rho v sigma :
  V A.[sigma] rho v <-> V A (fun x => V (sigma x) rho) v.
Proof.
  elim: A rho v sigma.
  - move=> x rho v sigma /=. split; intuition eauto.
  - move=> A ih1 B ih2 rho v sigma /=. split=> -[A' [s->h]];
      (do 2 eexists) => // t /ih1/h[u ev]/ih2 ih; by exists u.
  - move=> A ih rho v sigma. split;
      asimpl; move=> [s->{v}h]; eexists=> [//|P B].
    + move: (h P B) => [v ev /ih hv]. exists v => //.
      apply: eq_V hv => -[|X] //= u. by intuition. move=> _. asimpl. exact: V_ren.
    + move: (h P B) => [v ev hv]. exists v => //. apply/ih.
      apply: eq_V hv => -[|X] //= u. by intuition. asimpl.
      split => [p|/V_ren//]. by apply/V_ren.
Qed.

Definition VG (Gamma : ctx) (rho : var -> term -> Prop) (sigma : var -> term) :=
  forall x, x < size Gamma -> E Gamma`_x rho (sigma x).

Theorem soundness Gamma s A :
  has_type Gamma s A ->
    forall delta sigma rho, VG Gamma rho sigma -> E A rho s.|[delta].[sigma].
Proof.
  elim=> {Gamma s A} [Gamma x xe|Gamma A B s _ ih|Gamma A B s t _ ih1 _ ih2|
                      Gamma A s _ ih|Gamma A B s _ ih] delta sigma rho l.
  - exact: l.
  - eexists; first by autosubst. (do 2 eexists)=> [//|t vt]. asimpl.
    apply: ih=> -[_/=|x/l//]. exact: V_to_E.
  - case: (ih1 delta _ _ l) => {ih1} /= v ev1 [A' [u eq ih1]]; subst v.
    case: (ih2 delta _ _ l) => {ih2} v ev2 ih2.
    case: (ih1 _ ih2) => {ih1} w ev3 ih1. exists w => //.
    exact: eval_beta ev1 ev2 ev3.
  - apply: V_to_E. eexists=> [//=|P B]. asimpl. apply: ih => x /=.
    rewrite size_map => wf. rewrite get_map //. apply/E_ren. exact: l.
  - move: (ih delta _ _ l) => [v ev1 {ih} /=[s' eq ih]]; subst v.
    specialize (ih (V B rho) B.[delta]). move: ih => [v ev2 ih]. exists v.
    exact: eval_tbeta ev1 ev2. apply/V_subst. apply: eq_V ih => -[|x] //=.
    by intuition.
Qed.

(** **** Applications *)

Definition nilA : var -> term -> Prop := fun _ _ => False.

Corollary soundness_nil s A :
  has_type [::] s A -> E A nilA s.
Proof.
  move=> h. cut (E A nilA s.|[ids].[ids]). autosubst. exact: (soundness h).
Qed.

Corollary normalization s A :
  has_type [::] s A -> exists v, eval s v.
Proof.
  move=> /soundness_nil[v hv] _. by exists v.
Qed.

Corollary consistency s :
  ~has_type [::] s (All (TyVar 0)).
Proof.
  move=> /soundness_nil[v _ /= [t {s v} _ /(_ (fun _ => False) (TyVar 0))]].
  by move=> [s {t} _ []].
Qed.

(* Local Variables: *)
(* coq-load-path: (("." "Ssr")) *)
(* End: *)