Module FiniteTypes.

Require Import ClassicalDescription.
Require Import ProofIrrelevance.
Require Import Le. Require Import Lt. Require Import Plus.
Require Import Omega.
Notation "'If' P 'then' x 'else' y" :=
  (if (excluded_middle_informative P) then x else y) (at level 200).
Ltac case_if :=
  let go P := destruct P; try solve [elimtype False; congruence] in
  match goal with
  | |- context [if ?P then _ else _] => go P
  | K: context [if ?P then _ else _] |- _ => go P
  end.
Ltac ex_mid_destruct :=
  match goal with
    | |- context [excluded_middle_informative ?P] => destruct (excluded_middle_informative P)
    | K : context [excluded_middle_informative ?P] |- _ => destruct (excluded_middle_informative P)
  end.
Lemma If_l : forall (A:Type) (P:Prop) (x y : A),
  P -> (If P then x else y) = x.
Proof. intros. case_if. auto. Qed.
Lemma If_r : forall (A:Type) (P:Prop) (x y : A),
  ~ P -> (If P then x else y) = y.
Proof. intros. case_if. auto. Qed.
Set Implicit Arguments.

Definition injection (A B : Type) (f : A -> B) :=
  forall x1 x2 : A, f x1 = f x2 -> x1 = x2.
Theorem injection_iff_neg (A B : Type) (f : A -> B) :
  injection f -> forall x1 x2 : A, f x1 <> f x2 <-> x1 <> x2.
Proof.
  intros Hinjection x1 x2. split.
  intro H. contradict H. f_equal. auto.
  intro H. contradict H. apply Hinjection. auto.
Qed.
Definition surjection (A B : Type) (f : A -> B) :=
  forall y : B, exists x : A, f x = y.
Definition bijection (A B : Type) (f : A -> B) :=
  injection f /\ surjection f.
Definition compose (A B C : Type) (f : B -> C) (g : A -> B) := fun x => f (g x).
Lemma inj_compose (A B C : Type) (f : B -> C) (g : A -> B) :
  injection f -> injection g -> injection (compose f g).
Proof.
  intros Hfinj Hginj x1 x2.
  unfold compose. intro H. apply Hfinj in H. apply Hginj. auto.
Qed.
Lemma surj_compose (A B C : Type) (f : B -> C) (g : A -> B) :
  surjection f -> surjection g -> surjection (compose f g).
Proof.
  intros Hfsurj Hgsurj y.
  unfold compose. destruct (Hfsurj y) as [z H].
  destruct (Hgsurj z) as [x H']. exists x. congruence.
Qed.
Lemma bij_compose (A B C : Type) (f : B -> C) (g : A -> B) :
  bijection f -> bijection g -> bijection (compose f g).
Proof.
  intros Hfbij Hgbij. split. apply inj_compose.
  apply Hfbij. apply Hgbij. apply surj_compose.
  apply Hfbij. apply Hgbij.
Qed.
Definition bijection' (A B : Type) (f : A -> B) :=
  forall y : B, exists! x : A, f x = y.
Hint Unfold injection surjection bijection bijection'.
Lemma bijection_alt (A B : Type) (f : A -> B) :
  bijection f <-> bijection' f.
Proof.
  split.
  repeat autounfold.
  intro Hbijection. destruct Hbijection as [Hinjection Hsurjection].
  intro y. apply unique_existence with (P := fun x => f x = y).
  split. apply Hsurjection. unfold uniqueness.
  intros x y0 H1 H2. apply Hinjection. congruence.
  repeat autounfold.
  intro Hbijection.
  assert (forall y : B, (exists x : A, f x = y) /\
    uniqueness (fun x => f x = y)).
  intro y. apply unique_existence with (P := fun x => f x = y).
  auto. unfold uniqueness in H.
  split.
  intros x1 x2 H1. apply (H (f x2)). auto. auto.
  intro y. apply (H y).
Qed.

Hint Resolve bijection_alt.

Definition inversible (A B : Type) (f : A -> B) :=
  exists g : B -> A,
    (forall x : A, g (f x) = x) /\ (forall y : B, f (g y) = y).
Hint Unfold inversible.
Lemma bijection_inversible (A B : Type) (f : A -> B) :
  bijection f <-> inversible f.
Proof.
  split.
  intro Hbijection. assert (Hbijection' : bijection' f).
  apply bijection_alt. auto.
  repeat (autounfold in *). destruct Hbijection as [Hinjection Hsurjection].
  assert (exists g : B -> A, forall y : B, f (g y) = y).
  apply unique_choice with (R := fun y x => f x = y). auto.
  destruct H as [g H]. exists g.
  split. intro x. apply Hinjection. auto. auto.
  intro Hinversible.
  repeat (autounfold in *). destruct Hinversible as [g Hinversible].
  destruct Hinversible as [Hinverseleft Hinverseright].
  split.
  intros x1 x2 H.
  rewrite <- Hinverseleft with (x := x1). rewrite <- Hinverseleft with (x := x2).
  f_equal. auto.
  intro y. exists (g y). auto.
Qed.
Lemma inv_bijection (A B : Type) :
  (exists f : A -> B, bijection f) -> (exists g : B -> A, bijection g).
Proof.
  intro H. destruct H as [f H].
  apply bijection_inversible in H. unfold inversible in H.
  destruct H as [g Hg]. destruct Hg as [Hginvleft Hginvright].
  exists g. apply bijection_inversible. eauto.
Qed.

Lemma id_bijection (A : Type) :
  bijection (fun x : A => x).
Proof.
  split. auto. eauto.
Qed.

Definition Fints (n : nat) :=
  {p : nat | p < n}.
Definition Fints_last (n : nat) : Fints (S n) :=
  exist (fun k => k < S n) n (lt_n_Sn n).

Definition cardinality (T : Type) (n : nat) :=
  exists f : T -> (Fints n), bijection f.

Lemma Fints_card (n : nat) :
  cardinality (Fints n) n.
Proof.
  exists (fun x => x). apply id_bijection.
Qed.

Definition finite (T : Type) :=
  exists n : nat, (cardinality T n).

Lemma Fints_finite (n : nat) :
  finite (Fints n).
Proof.
  exists n. apply Fints_card.
Qed.

Definition image (A B : Type) (f : A -> B) :=
  {y : B | exists x : A, f x = y}.

Notation "` x" := (proj1_sig x) (at level 0).
Definition Fints_coerce (n : nat) (m : nat) (H : n <= m) (k : Fints n) :=
  exist (fun p => p < m) `k (lt_le_trans `k n m (proj2_sig k) H).

Lemma proj1_inj (A : Type) (P : A -> Prop) :
  forall x y : (sig P), `x = `y <-> x = y.
Proof.
  intros x y. split.
  intro H. destruct x. destruct y.
  unfold "`" in H. destruct H. f_equal. apply proof_irrelevance.
  intro H. f_equal. auto.
Qed.
Lemma proj1_inj_neg (A : Type) (P : A -> Prop) :
  forall x y : (sig P), `x <> `y <-> x <> y.
Proof.
  intros x y. split.
  intro H. contradict H. apply proj1_inj. auto.
  intro H. contradict H. apply proj1_inj. auto.
Qed.

Lemma sub_bijection (T T' : Type) (P : T -> Prop) (b : T' -> T) (Hb : bijection b) :
  bijection (fun x : {x : T' | P (b x)} => exist P (b `x) (proj2_sig x)).
Proof.
  destruct Hb as [Hbinj Hbsurj].
  split.
  intros x1 x2 He. apply proj1_inj in He. simpl in He. apply Hbinj in He.
  apply proj1_inj. auto.
  intro y. destruct y as [y' Hy']. destruct (Hbsurj y').
  assert (P (b x)). congruence.
  exists (exist (fun x => P (b x)) x H0).
  apply proj1_inj. simpl. auto.
Qed.

Lemma bijection_restriction1 (n : nat) (T : Type) (b : (Fints (S n) -> T)) :
  bijection b ->
    forall k : Fints n, b (Fints_coerce (le_n_Sn n) k) <> b (Fints_last n).
Proof.
  intros Hbijection k. destruct Hbijection as [Hinjection _].
  apply injection_iff_neg. auto.
  unfold Fints_coerce. unfold Fints_last. destruct k as [k' Hk'].
  simpl. apply proj1_inj_neg. simpl. contradict Hk'. rewrite Hk'.
  apply lt_irrefl.
Qed.
Lemma bijection_restriction2 (n : nat) (T : Type) (b : (Fints (S n) -> T))
  (Hbijection : bijection b) :
  bijection (fun (k : Fints n) =>
    exist (fun p => p <> b (Fints_last n)) (b (Fints_coerce (le_n_Sn n) k))
     (bijection_restriction1 Hbijection k)).
Proof.
  destruct Hbijection as [Hinjection Hsurjection].
  split.
  intros x1 x2 H. apply proj1_inj in H. simpl in H.
  apply Hinjection in H. unfold Fints_coerce in H.
  apply proj1_inj in H. simpl in H. apply proj1_inj. auto.
  intro y. destruct y as [y' Hy']. destruct (Hsurjection y') as [x Hx].
  destruct x as [x' Hx'].
  assert (x' <> n). contradict Hy'. rewrite <- Hx. f_equal.
  destruct Hy'. unfold Fints_last. apply proj1_inj. auto.
  assert (x' < n). clear Hx. apply le_lt_or_eq in Hx'.
  destruct Hx'. apply lt_S_n. auto. injection H0. intro. contradiction.
  exists (exist (fun p => p < n) x' H0).
  apply proj1_inj. simpl. rewrite <- Hx. f_equal.
  unfold Fints_coerce. apply proj1_inj. auto.
Qed.

Definition Fink_b (n : nat) (k : Fints (S n))
  (p : {p : Fints (S n) | p <> k}) := If ``p = n then `k else ``p.
Lemma Fink_b_n (n : nat) (k : Fints (S n)) (p : {p : Fints (S n) | p <> k}) :
  Fink_b p < n.
Proof.
  unfold Fink_b. case_if.
  destruct p as [p' Hp']. simpl in e.
  assert (`k <> `p'). apply proj1_inj_neg. auto.
  rewrite e in H. destruct k as [k' Hk']. simpl in *.
  unfold "<" in Hk'. assert (k' <= n). apply le_S_n. auto.
  apply le_lt_or_eq in H0. destruct H0. auto. contradiction.
  destruct p as [p' Hp']. simpl in *. destruct p' as [p'' Hp'']. simpl in *.
  assert (p'' <= n). apply le_S_n. auto.
  apply le_lt_or_eq in H. destruct H. auto. contradiction.
Qed.

Theorem Fink (n : nat) (k : Fints (S n)) :
  cardinality {p : Fints (S n) | p <> k} n.
Proof.
  unfold cardinality.
  pose (u p := exist (fun k => k < n) (Fink_b (n := n) (k := k) p)
                     (Fink_b_n (n := n) (k := k) p) : Fints n).
  exists u. repeat autounfold. split.
  intros x1 x2 H. apply proj1_inj in H.
  unfold u in H. simpl in H. unfold Fink_b in H.
  apply proj1_inj.
  destruct x1 as [x1' Hx1']. destruct x2 as [x2' Hx2']. simpl in *.
  case_if. case_if. assert (`x1' = `x2'). transitivity n. auto. auto.
  apply proj1_inj. auto.
  apply proj1_inj in H. symmetry in H. contradiction.
  case_if. apply proj1_inj in H. contradiction.
  apply proj1_inj. auto.
  intro y. destruct y as [y' Hy']. unfold u.
  assert (exists x, Fink_b (n := n) (k := k) x = y').
  unfold Fink_b. destruct (excluded_middle_informative (y' = `k)).
  assert (n < S n). auto.
  remember (exist (fun k => k < S n) n H) as n'.
  assert (n' <> k). apply proj1_inj_neg. rewrite <- e.
  rewrite Heqn'. simpl. contradict Hy'. destruct Hy'. apply lt_irrefl.
  exists (exist (fun p => p <> k) n' H0). simpl.
  rewrite Heqn'. simpl. rewrite If_l by auto. auto.
  assert (y' < S n). auto.
  remember (exist (fun k => k < S n) y' H) as y''.
  assert (y' = `y''). rewrite Heqy''. auto. rewrite H0 in n0.
  apply proj1_inj_neg in n0.
  exists (exist (fun p => p <> k) y'' n0). simpl.
  rewrite <- H0. apply If_r. contradict Hy'. destruct Hy'. apply lt_irrefl.
  destruct H as [x H]. exists x. destruct H. f_equal.
  apply proof_irrelevance.
Qed.

Theorem cardinality_inj_n :
  forall n n' : nat, forall f : (Fints n) -> (Fints n'), (injection f) -> n' >= n.
Proof.
  simple induction n. intros. apply le_0_n.
  intros n0 H n' f Hinjection.
  remember (fun (k : Fints n0) => f (
    exist (fun p => p < (S n0)) `k (lt_S `k n0 (proj2_sig k)))) as u.
  assert (forall k : Fints n0, u k <> f (Fints_last n0)).
  intro k. rewrite Hequ. apply injection_iff_neg. auto.
  injection. destruct k as [k' Hk']. simpl. intro H1. destruct H1.
  clear H0. apply lt_irrefl in Hk'. auto.
  remember (f (Fints_last n0)) as p.
  destruct n' as [ | n''].
  destruct p as [p' Hp']. clear Heqp. clear H0. apply lt_n_0 in Hp'. contradiction.
  assert (exists z : {x : Fints (S n'') | x <> p} -> Fints n'', bijection z).
  apply Fink. destruct H1 as [z Hzbijection].
  remember (fun (k : Fints n0) =>
    z (exist (fun x => x <> p) (u k) (H0 k))) as v.
  assert (injection v).
  unfold injection. intros x1 x2 H1.
  rewrite Heqv in H1.
  destruct Hzbijection as [Hzinjection _]. apply Hzinjection in H1.
  inversion H1. rewrite Hequ in H3. apply Hinjection in H3. inversion H3.
  apply proj1_inj. auto.
  apply le_n_S. apply H with (f := v). auto.
Qed.

Theorem cardinality_inj :
  forall (T T' : Type) (n n' : nat) (f : T -> T'),
    (cardinality T n) -> (cardinality T' n') -> injection f -> n' >= n.
Proof.
  intros T T' n n' f HcardT HcardT' Hinjection.
  unfold cardinality in *. destruct HcardT as [fT HfTbij].
  destruct HcardT' as [fT' HfT'bij].
  apply bijection_inversible in HfTbij.
  destruct HfTbij as [gT HgT]. destruct HgT as [HgT1 HgT2].
  remember (fun x => fT' (f (gT x))) as u.
  apply cardinality_inj_n with (f := u).
  unfold injection. intros x1 x2 H.
  rewrite Hequ in H. destruct HfT'bij as [HfT'inj _].
  apply HfT'inj in H. apply Hinjection in H.
  assert (fT (gT x1) = fT (gT x2)). f_equal. auto.
  repeat rewrite HgT2 in H0. auto.
Qed.

Lemma cardinality_unique_u (T : Type) (n n' : nat) :
  (cardinality T n) -> (cardinality T n') -> n' >= n.
Proof.
  intros.
  apply cardinality_inj with (f := (fun (x : T) => x)).
  auto. auto. unfold injection. auto.
Qed.

Theorem cardinality_unique (T : Type) (n n' : nat) :
  (cardinality T n) -> (cardinality T n') -> n = n'.
Proof.
  intros H H'.
  assert (n' >= n). apply cardinality_unique_u with (T := T). auto. auto.
  assert (n >= n'). apply cardinality_unique_u with (T := T). auto. auto.
  apply le_antisym. auto. auto.
Qed.

Theorem card_bijection (T T' : Type) (n : nat) (b : T' -> T) (Hb : bijection b) :
  (cardinality T n) <-> (cardinality T' n).
Proof.
  split.
  intro H. destruct H as [u Hu].
  exists (compose u b). apply bij_compose. auto. auto.
  intro H. destruct H as [u Hu].
  apply bijection_inversible in Hb. destruct Hb as [b' Hb'].
  destruct Hb' as [Hb'bid Hbb'id].
  exists (compose u b'). apply bij_compose. auto. apply bijection_inversible.
  exists b. auto.
Qed.

Theorem card_subtype (T : Type) (P Q : T -> Prop) (n : nat) :
  (forall x : T, P x <-> Q x) ->
    ((cardinality {x : T | P x} n) <-> (cardinality {x : T | Q x} n)).
Proof.
  intro Heq.
  assert (forall x : {x : T | P x}, Q `x).
  intro x. destruct x as [x' Hx']. simpl. apply Heq. auto.
  assert (bijection (fun x : {x : T | P x} => exist _ `x (H x))).
  split.
  intros x1 x2 He. apply proj1_inj in He. simpl in He.
  apply proj1_inj. auto.
  intro y. destruct y as [y' Hy']. assert (P y'). apply Heq. auto.
  exists (exist _ y' H0). apply proj1_inj. auto.
  symmetry.
  apply card_bijection with (b := (fun x : {x : T | P x} => exist _ `x (H x))). auto.
Qed.

Theorem card_and (T : Type) (P Q : T -> Prop) (n : nat) :
  (cardinality {x : T | P x /\ Q x} n) <-> (cardinality {x : {x : T | P x} | Q `x} n).
Proof.
  assert (forall x : {x : T | P x /\ Q x}, P `x).
  intro x. destruct x as [x' Hx']. destruct Hx'. auto.
  assert (forall x : {x : T | P x /\ Q x}, Q (proj1_sig (exist _ `x (H x)))).
  intro x. simpl. destruct x as [x' Hx']. destruct Hx'. auto.
  assert (bijection (fun x : {x : T | P x /\ Q x} =>
    exist (fun x => Q `x) (exist _ `x (H x)) (H0 x))).
  split.
  intros x1 x2 He. apply proj1_inj in He. simpl in He.
  apply proj1_inj in He. simpl in He. apply proj1_inj. auto.
  intro y. destruct y as [y' Hy']. destruct y' as [y'' Hy'']. simpl in *.
  exists (exist _ y'' (conj Hy'' Hy')).
  apply proj1_inj. simpl. apply proj1_inj. simpl. auto.
  symmetry.
  apply card_bijection with (b := (fun x : {x : T | P x /\ Q x} =>
        exist (fun x : {x | P x} => Q `x) (exist P `x (H x)) (H0 x))). auto.
Qed.

Lemma cb_ex (n m : nat) (k : Fints (n + m)) (H : ~ (`k < n)) :
  `k - n < m.
Proof.
  destruct k as [k' Hk']. simpl in *.
  omega.
Qed.

Definition choose_bijection (T : Type) (P : T -> Prop) (n m : nat)
  (f : Fints n -> {x : T | P x}) (Hf : bijection f)
  (g : Fints m -> {x : T | ~ P x}) (Hg : bijection g) :=
  (fun k : Fints (n + m) =>
    match (excluded_middle_informative (`k < n)) with
      | left H => proj1_sig (f (exist _ `k H))
      | right H => proj1_sig (g (exist _ (`k - n) (cb_ex m k H)))
    end).
Theorem choose_bij (T : Type) (P : T -> Prop) (n m : nat)
  (f : Fints n -> {x : T | P x}) (Hf : bijection f)
  (g : Fints m -> {x : T | ~ P x}) (Hg : bijection g) :
    bijection (choose_bijection P Hf Hg).
Proof.
  unfold choose_bijection.
  apply bijection_inversible.
  apply bijection_inversible in Hf. destruct Hf as [f' Hf]. destruct Hf as [Hf Hf'].
  apply bijection_inversible in Hg. destruct Hg as [g' Hg]. destruct Hg as [Hg Hg'].
  remember (fun x =>
    match (excluded_middle_informative (P x)) with
      | left H => proj1_sig (f' (exist _ x H))
      | right H => proj1_sig (g' (exist _ x H)) + n
    end) as h'.
  assert (forall x : T, h' x < n + m).
  intro x. rewrite Heqh'.
  ex_mid_destruct.
  destruct (f' _). simpl. omega.
  destruct (g' _). simpl. omega.
  exists (fun x => exist _ (h' x) (H x)).
  split.
  intro x. destruct x as [x' Hx'].
  apply proj1_inj. simpl.
  ex_mid_destruct.
  rewrite Heqh'. remember (f _) as y. destruct y as [y' Hy']. simpl.
  ex_mid_destruct.
  assert (exist (fun x : T => P x) y' Hy' = exist (fun x : T => P x) y' p).
  apply proj1_inj. auto.
  rewrite <- H0. rewrite Heqy. rewrite Hf. auto.
  contradiction.
  rewrite Heqh'. remember (g _ ) as y. destruct y as [y' Hy']. simpl.
  ex_mid_destruct.
  contradiction.
  assert (exist (fun x : T => ~ P x) y' Hy' = exist (fun x : T => ~ P x) y' n1).
  apply proj1_inj. auto.
  rewrite <- H0. rewrite Heqy. rewrite Hg. simpl. omega.
  intro y.
  destruct (excluded_middle_informative (P y)).
  simpl in *.
  assert (h' y = proj1_sig (f' (exist P y p))).
  rewrite Heqh'. ex_mid_destruct.
  f_equal. f_equal. apply proj1_inj. auto. contradiction.
  ex_mid_destruct.
  remember (f' _) as x. destruct x as [x' Hx']. simpl in *.
  generalize l.
  rewrite H0. intro l0.
  assert (exist (fun p0 : nat => p0 < n) x' Hx' = exist (fun p0 : nat => p0 < n) x' l0).
  apply proj1_inj. auto.
  rewrite <- H1. rewrite Heqx. rewrite Hf'. auto.
  destruct (f' _). simpl in H0. omega.
  simpl.
  assert (h' y = proj1_sig (g' (exist _ y n0)) + n).
  rewrite Heqh'. ex_mid_destruct.
  contradiction. f_equal. f_equal. f_equal. apply proj1_inj. auto.
  ex_mid_destruct. omega.
  remember (g' _) as x. destruct x as [x' Hx']. simpl in *.
  assert (exist (fun p : nat => p < m) x' Hx' = exist (fun p : nat => p < m) (h' y - n)
       (cb_ex m (exist (fun p : nat => p < n + m) (h' y) (H y)) n1)).
  apply proj1_inj. simpl. omega.
  rewrite <- H1. rewrite Heqx. rewrite Hg'. auto.
Qed.

Theorem disjoint_union_cardinality (T : Type) (P : T -> Prop) :
  forall n m : nat,
    (cardinality {x : T | P x} n) -> (cardinality {x : T | ~ P x} m)
                                  -> (cardinality T (n + m)).
Proof.
  intros n m Hn Hm.
  apply inv_bijection in Hn. apply inv_bijection in Hm.
  destruct Hn as [fn Hfn]. destruct Hm as [fm Hfm].
  apply inv_bijection.
  exists (choose_bijection P Hfn Hfm). apply choose_bij.
Qed.

Theorem subtype_finite_n :
  forall (n : nat) (P : (Fints n) -> Prop), (finite {x : (Fints n) | P x}).
Proof.
  simple induction n.
  intro. exists 0. exists (fun x => `x).
  split. intros x1 x2 H. destruct x1 as [x1' Hx1'].
  destruct x1' as [x1'' Hx1'']. omega.
  intro y. destruct y as [y' Hy']. omega.
  intros n0 H P.
  destruct (H (fun x => P (Fints_coerce (le_n_Sn n0) x))) as [k H'].
  destruct H' as [b Hb]. destruct Hb as [Hbinj Hbsurj].
  destruct (classic (P (Fints_last n0))).
  exists (S k).
  assert (forall x : Fints (S n0), ~ (x = Fints_last n0) -> `x < n0).
  intros x H1. destruct x as [x' Hx']. unfold Fints_last in H1.
  apply proj1_inj_neg in H1. simpl in *. omega.
  assert (forall (x : {x : Fints (S n0) | P x}) (U : ~ (`x = Fints_last n0)),
    P (Fints_coerce (le_n_Sn n0) (exist (fun k => k < n0) ``x (H1 `x U)))).
  unfold Fints_coerce. simpl. destruct x as [x' Hx']. destruct x' as [x'' Hx''].
  simpl. intro U.
  assert (exist (fun p : nat => p < S n0) x'' Hx'' = exist (fun p : nat => p < S n0) x''
     (lt_le_trans x'' n0 (S n0)
        (H1 (exist (fun p : nat => p < S n0) x'' Hx'') U) (le_n_Sn n0))).
  apply proj1_inj. auto. rewrite <- H2. auto.
  exists (fun x =>
    match (excluded_middle_informative (`x = Fints_last n0)) with
      | left _ => Fints_last k
      | right U => Fints_coerce (le_n_Sn k) (b (exist (fun p => P (Fints_coerce (le_n_Sn n0) p)) (exist _ ``x (H1 `x U)) (H2 x U)))
    end).
  split.
  intros x1 x2 He.
  destruct (excluded_middle_informative (`x1 = Fints_last n0)).
  destruct (excluded_middle_informative (`x2 = Fints_last n0)).
  rewrite <- e0 in e. apply proj1_inj. auto.
  remember (b _) as y. destruct y. unfold Fints_last in He. unfold Fints_coerce in He.
  apply proj1_inj in He. simpl in He. omega.
  destruct (excluded_middle_informative (`x2 = Fints_last n0)).
  remember (b _) as y. destruct y. unfold Fints_last in He. unfold Fints_coerce in He.
  apply proj1_inj in He. simpl in He. omega.
  unfold Fints_coerce in He. apply proj1_inj in He. simpl in He.
  apply proj1_inj in He. apply Hbinj in He. apply proj1_inj in He. simpl in He.
  apply proj1_inj in He. simpl in He. apply proj1_inj in He. apply proj1_inj. auto.
  intro y. destruct y as [y' Hy'].
  destruct (excluded_middle_informative (y' = k)).
  exists (exist _ (Fints_last n0) H0). simpl.
  destruct (excluded_middle_informative (Fints_last n0 = Fints_last n0)).
  unfold Fints_last. apply proj1_inj. auto.
  congruence.
  assert (y' < k). omega.
  destruct (Hbsurj (exist _ y' H3)).
  destruct x as [x' Hx'].
  exists (exist _ (Fints_coerce (le_n_Sn n0) x') Hx').
  simpl.
  assert (forall U, (b
         (exist (fun p : Fints n0 => P (Fints_coerce (le_n_Sn n0) p))
            (exist (fun p : nat => p < n0) `x'
               (H1 (Fints_coerce (le_n_Sn n0) x') U))
            (H2 (exist P (Fints_coerce (le_n_Sn n0) x') Hx') U)))
           = exist _ y' H3).
  intro U. rewrite <- H4. f_equal. apply proj1_inj. simpl.
  apply proj1_inj. auto.
  match goal with [|-context[excluded_middle_informative ?P]] => destruct (excluded_middle_informative P) end.
  destruct x' as [x'' Hx'']. unfold Fints_coerce in e. unfold Fints_last in e.
  apply proj1_inj in e. simpl in e. omega.
  apply proj1_inj. unfold Fints_coerce. simpl. rewrite H5. auto.
  exists k.
  assert (forall x : {x : Fints (S n0) | P x}, ``x < n0).
  destruct x as [x' Hx']. destruct x' as [x'' Hx''].
  assert (x'' <> n0). intro. assert (Fints_last n0 = exist _ x'' Hx'').
   unfold Fints_last. apply proj1_inj. auto. rewrite H2 in H0. contradiction.
  simpl. omega.
  assert (forall x : {x : Fints (S n0) | P x}, P (Fints_coerce (le_n_Sn n0) (exist _ ``x (H1 x)))).
  intro x. destruct x as [x' Hx']. unfold Fints_coerce. simpl.
  assert (x' = exist (fun p : nat => p < S n0) `x'
     (lt_le_trans `x' n0 (S n0)
        (H1 (exist (fun x : Fints (S n0) => P x) x' Hx')) (le_n_Sn n0))).
  apply proj1_inj. auto. rewrite <- H2. auto.
  exists (fun x => b (exist (fun p => P (Fints_coerce (le_n_Sn n0) p)) (exist _ ``x (H1 x)) (H2 x))).
  split.
  intros x1 x2 He.
  apply Hbinj in He. apply proj1_inj in He. simpl in He. apply proj1_inj in He.
  simpl in He. apply proj1_inj in He. apply proj1_inj. auto.
  intro y.
  destruct (Hbsurj y) as [x Hx].
  exists (exist _ (Fints_coerce (le_n_Sn n0) `x) (proj2_sig x)).
  simpl. rewrite <- Hx. f_equal. apply proj1_inj. simpl. apply proj1_inj. auto.
Qed.

Theorem subtype_finite (T : Type) (H : finite T) (P : T -> Prop) :
  finite {x : T | P x}.
Proof.
  destruct H as [n H]. destruct H as [b Hb].
  assert (inversible b). apply bijection_inversible. auto.
  destruct H as [b' Hb']. destruct Hb' as [Hidb' Hidb].
  assert (finite {x : Fints n | P (b' x)}). apply subtype_finite_n.
  destruct H as [k H]. destruct H as [c Hc]. destruct Hc as [Hcinj Hcsurj].
  assert (forall x : {x : T | P x}, P (b' (b `x))).
  intro x. destruct x as [x' Hx']. rewrite Hidb'. auto.
  exists k. exists (fun x => c (exist (fun p => P (b' p)) (b `x) (H x))).
  split.
  intros x1 x2 He. apply Hcinj in He. apply proj1_inj in He. simpl in He.
  apply Hb in He. apply proj1_inj. auto.
  intro y. destruct (Hcsurj y) as [x Hx].
  destruct x as [x' Hx'].
  exists (exist _ (b' x') Hx'). rewrite <- Hx. f_equal.
  apply proj1_inj. simpl. auto.
Qed.

End FiniteTypes.


(* Taken from coq-bigO / Armaël Guéneau *)
Require Import Coq.Lists.List.
Import List.ListNotations.
From smpl Require Import Smpl.

Local Set Universe Polymorphism.

Fixpoint Rarrow (domain : list Type) (range : Type) : Type :=
  match domain with
    | nil => range
    | d :: ds => Rarrow ds (d -> range)
end.

Fixpoint Rtuple (domain : list Type) : Type :=
  match domain with
  | nil => unit
  | d :: nil => d
  | d :: ds => prod (Rtuple ds) d
  end.

Fixpoint Const {A : Type} (domain : list Type) (c : A) : Rarrow domain A :=
  match domain with
  | nil => c
  | d :: ds => Const ds (fun _ => c)
  end.

Lemma Const_eqn_1 : forall A (c : A),
  Const [] c = c.
Proof. intros. reflexivity. Qed.

Lemma Const_eqn_2 : forall A d ds (c : A),
  Const (d :: ds) c = Const ds (fun _ => c).
Proof. intros. reflexivity. Qed.

Hint Rewrite Const_eqn_1 : Const.
Hint Rewrite Const_eqn_2 : Const.
Opaque Const.

Fixpoint Fun' {domain : list Type} {range : Type} {struct domain}
         : (Rtuple domain -> range) -> (Rtuple domain) -> range
  :=
  match domain with
  | nil => fun body t => body tt
  | d :: ds =>
     let f := @Fun' ds range in
     match ds return
        ((Rtuple ds -> range) -> Rtuple ds -> range) ->
        ((Rtuple (d :: ds) -> range) -> Rtuple (d :: ds) -> range)
     with
     | [] => fun _ body t => body t
     | _ =>
         fun f body t =>
         let '(t', x) := t in f (fun p' => body (p', x)) t'
     end f
  end.

Lemma Fun'_eqn_1 : forall range body,
  @Fun' [] range body = (fun _ => body tt).
Proof. intros. reflexivity. Qed.

Lemma Fun'_eqn_2 : forall d range body,
  @Fun' [d] range body = body.
Proof. intros. reflexivity. Qed.

Lemma Fun'_eqn_3 : forall d d' ds range body,
  @Fun' (d :: d' :: ds) range body =
  (fun '(t', x) => @Fun' (d' :: ds) range (fun p' => body (p', x)) t').
Proof. intros. reflexivity. Qed.

Hint Rewrite Fun'_eqn_1 : Fun'.
Hint Rewrite Fun'_eqn_2 : Fun'.
Hint Rewrite Fun'_eqn_3 : Fun'.
Opaque Fun'.

Fixpoint App {domain : list Type} {range : Type} {struct domain}
         : (Rarrow domain range) -> Rtuple domain -> range
  :=
  match domain with
  | nil => fun f x => f
  | d :: ds =>
    let Apprec := @App ds (d -> range) in
    match ds return
      ((Rarrow ds (d -> range)) -> Rtuple ds -> d -> range) ->
      (Rarrow (d :: ds) range) -> Rtuple (d :: ds) -> range
    with
    | [] => fun _ f x => f x
    | _ => fun Apprec f t => Apprec f (fst t) (snd t)
    end Apprec
  end.

Lemma App_eqn_1 : forall range f x,
  @App [] range f x = f.
Proof. intros. reflexivity. Qed.

Lemma App_eqn_2 : forall d range f x,
  @App [d] range f x = f x.
Proof. intros. reflexivity. Qed.

Lemma App_eqn_3 : forall d d' ds range f x,
  @App (d :: d' :: ds) range f x = @App (d' :: ds) (d -> range) f (fst x) (snd x).
Proof. intros. reflexivity. Qed.

Hint Rewrite App_eqn_1 : App.
Hint Rewrite App_eqn_2 : App.
Hint Rewrite App_eqn_3 : App.
Opaque App.
Set Printing Universes.
Lemma Fun'_simpl : forall (domain : list Type) range body t,
  @Fun' domain range body t = body t.
Proof.
  intro. induction domain; intros; autorewrite with Fun'.
  - destruct t. reflexivity.
  - destruct domain; autorewrite with Fun'.
    + reflexivity.
    + destruct t. apply IHdomain.
Qed.

Tactic Notation "_rewrite_anywhere" uconstr(L):=
  match goal with
  | H : _ |- _ => setoid_rewrite L in H
  | _ => setoid_rewrite L
  end.

Smpl Create generic.
Smpl Add 2 _rewrite_anywhere Fun'_simpl : generic.

Lemma App_Const_simpl (domain :list Type) (range:Type):
  forall  c x,
  @App domain range (Const domain c) x = c.
Proof.
  induction domain in range|-*; intros; autorewrite with App.
  - reflexivity.
  - destruct domain; autorewrite with App.
    + reflexivity.
    + destruct x. simpl. rewrite Const_eqn_2.
      rewrite IHdomain. reflexivity.
Qed.
Smpl Add 2 _rewrite_anywhere App_Const_simpl : generic.

Definition Const' (domain : list Type) {range : Type}
           (cst : range) : Rtuple domain -> range :=
  Fun' (App (Const domain cst)).

Hint Unfold Const' : generic.

Definition Uncurry {domain : list Type} {range : Type}
           (f : Rarrow domain range) : Rtuple domain -> range :=
  Fun' (App f).

Hint Unfold Uncurry : generic.

(******************************************************************************)
(* Rewriting with [generic] *)

Smpl Create nary_prepare.

Ltac rew_generic_in_all := autounfold with generic in *;repeat smpl nary_prepare;repeat smpl generic.

(* Try to prove a goal stated using the combinators above from a lemma [L] that
   is equivalent but does not use the combinators. *)
Tactic Notation "prove_nary" uconstr(L) :=
  intros; rew_generic_in_all; eapply L; eauto.

(******************************************************************************)
(* Applying n-ary lemmas stated using the combinators above *)

Inductive Domain_goal_hint (G : Type) := Mk_domain_goal_hint : Domain_goal_hint G.
Record Domain_of_goal := Mk_domain_of_goal {
  Domain_of_goal_domain_ty : Type ;
  Domain_of_goal_domain : Domain_of_goal_domain_ty ;
 }.

Arguments Mk_domain_of_goal [Domain_of_goal_domain_ty].

Ltac mk_domain_getter tac :=
  lazymatch goal with
  | H : Domain_goal_hint ?G |- Domain_of_goal => tac G
  end.

Ltac get_domain :=
  lazymatch goal with |- ?G =>
    let packed_dom := constr:(ltac:(
                         pose proof (Mk_domain_goal_hint G);
                         typeclasses eauto with domain_of_goal
                       ) : Domain_of_goal)
    in
    let dom := constr:(Domain_of_goal_domain packed_dom) in
    let dom := eval cbv in dom in
    dom
  end.

(* Simplify the type of t (by running the [simpl] tactic), then apply it *)
Ltac simpl_apply app t :=
  let H := fresh in
  pose proof t as H;
  autounfold with generic in H;
  cbn in H;
  app H;
  clear H.

Ltac _nary_apply t L :=
  let D := get_domain in
  simpl_apply t (L D).

Tactic Notation "nary" "apply" uconstr(L) := _nary_apply ltac:(fun t => apply t) L.

Tactic Notation "nary" "simple" "apply" uconstr(L) := _nary_apply ltac:(fun t => simple apply t) L.
(******************************************************************************)
(* Utilities *)

Ltac list_of_tuple universe ty :=
  lazymatch ty with
  | prod ?A ?B =>
    let l := list_of_tuple universe A in
    constr:(cons (B:universe) l)
  | _ => constr:(cons (ty:universe) nil)
  end.


(************************************************************************)
(* Copyright (c) 2022, Gergei Bana, Rohit Chadha, Ajay Kumar Eeralla,   *)
(* Qianli Zhang                                                         *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Import Coq.micromega.Lia.
Require Export lemma26_13.
Require Export lemma26_14.
Require Export lemma26_15.
Require Export lemma26_16.
Import ListNotations.

(* AndComp should be in logical.v *)
Lemma AndComp : forall b1 b2 b3 x y,
   If b1 & b2 & b3 Then x Else y
   = If b1 Then If b2 Then If b3 Then x Else y Else y Else y.
Proof.
  intros.
  rewrite (@If_morph (fun b => If b Then x Else y)). rewrite If_false.
  rewrite (@If_morph (fun b => If b Then x Else y)). rewrite If_false.
  reflexivity.
  all : ProveContext.
Qed.

(*  *)
Lemma lemma26_helper:  forall acc0acc1 bnl0 bnl1 case0 case1 case2 case3,
    bppt acc0acc1 ->
    bppt bnl0 ->
    bppt bnl1 ->
  If acc0acc1 Then
     If bnl0
        Then If bnl1 Then case0
                     Else case1
        Else If bnl1 Then case2
                     Else case3 Else ⫠
 =
        If acc0acc1 &  bnl0 &  bnl1 Then If acc0acc1 & bnl0 &  bnl1 Then case0 Else ⫠
   Else If acc0acc1 &  bnl0 & !bnl1 Then If acc0acc1 Then case1 Else ⫠
   Else If acc0acc1 & !bnl0 &  bnl1 Then If acc0acc1 Then case2 Else ⫠
   Else If acc0acc1 & !bnl0 & !bnl1 Then If acc0acc1 Then case3 Else ⫠ Else ⫠.
Proof.
  intros.
  rewrite AndComp.
  rewrite (@If_eval (fun acc => If bnl0
       Then If bnl1 Then If acc & bnl0 & bnl1 Then case0 Else ⫠
            Else If acc & bnl0 & ! bnl1 Then If acc Then case1 Else ⫠
                 Else If acc & ! bnl0 & bnl1 Then If acc Then case2 Else ⫠ Else If acc & ! bnl0 & ! bnl1 Then If acc Then case3 Else ⫠ Else ⫠
       Else If acc & bnl0 & ! bnl1 Then If acc Then case1 Else ⫠
            Else If acc & ! bnl0 & bnl1 Then If acc Then case2 Else ⫠ Else If acc & ! bnl0 & ! bnl1 Then If acc Then case3 Else ⫠ Else ⫠)
          (fun acc => If acc & bnl0 & ! bnl1 Then If acc Then case1 Else ⫠
       Else If acc & ! bnl0 & bnl1 Then If acc Then case2 Else ⫠ Else If acc & ! bnl0 & ! bnl1 Then If acc Then case3 Else ⫠ Else ⫠)).
  repeat rewrite If_false. repeat rewrite If_true.
  rewrite (@If_eval (fun bnl0 =>If bnl1 Then  If bnl0 & bnl1 Then case0 Else ⫠ Else If bnl0 & ! bnl1 Then case1 Else If ! bnl0 & bnl1 Then case2 Else If ! bnl0 & ! bnl1 Then case3 Else ⫠)
          (fun bnl0 => If bnl0 & ! bnl1 Then case1 Else If ! bnl0 & bnl1 Then case2 Else If ! bnl0 & ! bnl1 Then case3 Else ⫠)).
  repeat rewrite If_true. repeat rewrite If_false.
  rewrite (@If_eval (fun bnl1 => If bnl1 Then case0 Else ⫠ ) (fun bnl1 => If ! bnl1 Then case1 Else ⫠)).
  repeat rewrite If_false. repeat rewrite If_true.
  rewrite (@If_eval (fun bnl1 => _ ) (fun bnl1 => If ! bnl1 Then case3 Else ⫠)).
  repeat rewrite If_false. repeat rewrite If_true.

  reflexivity.

  all : ProveboolandContext.
Qed.

(**)
Proposition lemma26 :
  (fun c0 c1 =>
     (fun enco0 enco1 =>
        (fun o1 o2 o3 =>
           [b0 c0; b1 c1;
           If (acc0 c0 c1 & acc1 c0 c1)
              Then (＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞, ＜ enco0, enco1, Do o1 o2 o3 ＞ ＞)
              Else ⫠]
        )(FGO1 c0 c1 enco0 enco1) (FGO2 c0 c1 enco0 enco1) (FGO3 c0 c1 enco0 enco1)
     ) (If (bnlcheck c0 n0 (fΦΦ3 c0 c1)) Then (enco0 c0 c1 kc0) Else ⫠) (If (bnlcheck c1 n1 (fΦΦ3 c0 c1)) Then (enco1 c0 c1 kc1) Else ⫠)
  ) (c0 lhs) (c1 lhs)
~
  (fun c0 c1 =>
     (fun enco0 enco1 =>
        (fun o1 o2 o3 =>
           [b0 c0; b1 c1;
           If (acc0 c0 c1 & acc1 c0 c1)
              Then (＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞, ＜ enco0, enco1, Do o1 o2 o3 ＞ ＞)
              Else ⫠]
        ) (FGO1 c0 c1 enco0 enco1) (FGO2 c0 c1 enco0 enco1) (FGO3 c0 c1 enco0 enco1)
     ) (If (bnlcheck c0 n0 (fΦΦ3 c0 c1)) Then (enco0 c0 c1 kc0) Else ⫠) (If (bnlcheck c1 n1 (fΦΦ3 c0 c1)) Then (enco1 c0 c1 kc1) Else ⫠)
  ) (c0 rhs) (c1 rhs).
Proof.
  intros. simpl.

(* we case analysis bnlcheck0 and bnlcheck1 before the encryptions.
   When both bnlcheck0 and bnlcheck1 are true, both encryptions will be sent out by the voter.
   When only one bnlcheck is true, the corresponding one encryption will be sent out.
   When none of the bnlcheck is true, none of the encryption will be sent out. *)

  rewrite (GuardAhead (＜ _,  _ ＞) (bnlcheck c00 n0 (fΦΦ3 c00 c01)) (bnlcheck c01 n1 (fΦΦ3 c00 c01))).
  rewrite (GuardAhead (＜ ＜ e0 c10 c11 n0, _ , _ ＞,  _ ＞) (bnlcheck c10 n0 (fΦΦ3 c10 c11)) (bnlcheck c11 n1 (fΦΦ3 c10 c11))).
  repeat rewrite (@If_eval (fun bnl1 => ＜ ＜ _ , _, _＞, ＜ _, ( If bnl1 Then _ Else ⫠) ,
                     Do (FGO1 _ _ _ (If bnl1 Then  _ Else ⫠))  (FGO2 _ _ _ (If bnl1 Then  _ Else ⫠)) (FGO3 _ _ _ (If bnl1 Then _ Else ⫠)) ＞ ＞)
           (fun bnl1 => ＜ ＜ _ , _, _＞, ＜ _, ( If bnl1 Then _ Else ⫠),
                     Do (FGO1 _ _ _ (If bnl1 Then  _ Else ⫠))  (FGO2 _ _ _ (If bnl1 Then  _ Else ⫠)) (FGO3 _ _ _ (If bnl1 Then _ Else ⫠)) ＞ ＞)).
  repeat rewrite If_true, If_false.
  repeat rewrite (@If_eval (fun bnl0 =>  If _ Then ＜ ＜ _ , _, _＞, ＜ ( If bnl0 Then _ Else ⫠), _ ,
                               Do (FGO1 _ _ ( If bnl0 Then _ Else ⫠) _)  (FGO2 _ _ ( If bnl0 Then _ Else ⫠) _) (FGO3 _ _ ( If bnl0 Then _ Else ⫠) _) ＞ ＞
                                    Else ＜ ＜ _ , _, _＞, ＜ ( If bnl0 Then _ Else ⫠), _ ,
                               Do (FGO1 _ _ ( If bnl0 Then _ Else ⫠) _)  (FGO2 _ _ ( If bnl0 Then _ Else ⫠) _) (FGO3 _ _ ( If bnl0 Then _ Else ⫠) _) ＞ ＞)
           (fun bnl0 =>  If _ Then ＜ ＜ _ , _, _＞, ＜ ( If bnl0 Then _ Else ⫠), _ ,
                               Do (FGO1 _ _ ( If bnl0 Then _ Else ⫠) _)  (FGO2 _ _ ( If bnl0 Then _ Else ⫠) _) (FGO3 _ _ ( If bnl0 Then _ Else ⫠) _) ＞ ＞
                                    Else ＜ ＜ _ , _, _＞, ＜ ( If bnl0 Then _ Else ⫠), _ ,
                               Do (FGO1 _ _ ( If bnl0 Then _ Else ⫠) _)  (FGO2 _ _ ( If bnl0 Then _ Else ⫠) _) (FGO3 _ _ ( If bnl0 Then _ Else ⫠) _) ＞ ＞)).
  repeat rewrite If_true, If_false.

(* In Lemma26_13, we proved that if both encryptions are sent out by the challenger,
   then the protocol will be indistinguishable from adversary's perspective *)

  rewrite (lemma26_helper (acc0 c00 c01 & acc1 c00 c01)).
  rewrite (lemma26_helper (acc0 c10 c11 & acc1 c10 c11)).
  apply (@IF_branch' [b0 c00; b1 c01] [b0 c10; b1 c11] _ _ _ _ _ _ ); simpl.
  repeat rewrite (AndAsso).
  pose (prop26_formula13) as c; simpl in c.
  repeat rewrite (AndAsso) in c.
  apply (@cind_funcapp (fun lx => (firstn 2 lx) ++ [Nth 3 lx; Nth 4 lx ])) in c; unfold Nth in c; simpl in c.
  apply c. clear c.
  ProveContext.

(*Lemma26_14*)

  apply (@IF_branch' [b0 c00; b1 c01; (acc0 c00 c01 & acc1 c00 c01) & bnlcheck c00 n0 (fΦΦ3 c00 c01) & bnlcheck c01 n1 (fΦΦ3 c00 c01)]
                     [b0 c10; b1 c11; (acc0 c10 c11 & acc1 c10 c11) & bnlcheck c10 n0 (fΦΦ3 c10 c11) & bnlcheck c11 n1 (fΦΦ3 c10 c11)] _ _ _ _ _ _ ); simpl.
  pose (prop26_formula14) as c; simpl in c.
  apply (@cind_funcapp (fun lx => let acc := Nth 2 lx in
                               let bnl0 := Nth 3 lx in
                               let bnl1 := Nth 4 lx in
                               let case1 := Nth 5 lx in
                          (firstn 2 lx) ++ [acc & bnl0 & bnl1; acc & bnl0 & ! bnl1 ; If acc Then case1 Else ⫠])) in c; unfold Nth in c; simpl in c.
  apply c; clear c.
  apply @cApp; ProveContext.

(*Lemma26_15*)

  apply (@IF_branch' [b0 c00; b1 c01; (acc0 c00 c01 & acc1 c00 c01) & bnlcheck c00 n0 (fΦΦ3 c00 c01) & bnlcheck c01 n1 (fΦΦ3 c00 c01);
                      (acc0 c00 c01 & acc1 c00 c01) & bnlcheck c00 n0 (fΦΦ3 c00 c01) & ! bnlcheck c01 n1 (fΦΦ3 c00 c01)]
                     [b0 c10; b1 c11; (acc0 c10 c11 & acc1 c10 c11) & bnlcheck c10 n0 (fΦΦ3 c10 c11) & bnlcheck c11 n1 (fΦΦ3 c10 c11);
                      (acc0 c10 c11 & acc1 c10 c11) & bnlcheck c10 n0 (fΦΦ3 c10 c11) & ! bnlcheck c11 n1 (fΦΦ3 c10 c11)] _ _ _ _ _ _ ); simpl.
  pose (prop26_formula15) as c; simpl in c.
  apply (@cind_funcapp (fun lx => let acc := Nth 2 lx in
                               let bnl0 := Nth 3 lx in
                               let bnl1 := Nth 4 lx in
                               let case2 := Nth 5 lx in
                          (firstn 2 lx) ++ [acc & bnl0 & bnl1; acc & bnl0 & ! bnl1 ; acc & !bnl0 & bnl1 ; If acc Then case2 Else ⫠])) in c; unfold Nth in c; simpl in c.
  apply c; clear c.
  apply @cApp; ProveContext.

(* In Lemma26_16, we proved that if none of the encryptions is sent out,
   then because of the hiding property, the protocol will still be indistinguishable *)

  pose (prop26_formula16) as c; simpl in c.
  apply (@cind_funcapp (fun lx => let acc := Nth 2 lx in
                               let bnl0 := Nth 3 lx in
                               let bnl1 := Nth 4 lx in
                               let case3 := Nth 5 lx in
                               (firstn 2 lx) ++ [acc & bnl0 & bnl1; acc & bnl0 & ! bnl1 ; acc & !bnl0 & bnl1 ; If acc & !bnl0 & !bnl1 Then If acc Then case3 Else ⫠ Else ⫠ ])) in c;
    unfold Nth in c; simpl in c.
  apply c.
  apply @cApp; ProveContext.

(**)
  all : unfold bnlcheck; unfold ncheck; unfold isin; unfold acc0, acc1; Provebool.

  1, 2: pose lemma26_bnl0_Φ3_Cnxt_rhs; pose lemma26_bnl0_bot_Φ5_Cnxt_rhs; pose lemma26_bnl0_enco1_Φ5_Cnxt_rhs; time ProveContext. (* 9.698 secs *)
  1, 2: pose lemma26_bnl0_Φ3_Cnxt_lhs; pose lemma26_bnl0_bot_Φ5_Cnxt_lhs; pose lemma26_bnl0_enco1_Φ5_Cnxt_lhs; time ProveContext. (* 9.806 secs*)
  1, 2: pose lemma26_bnl0_Φ3_Cnxt_rhs; pose lemma26_bnl1_enco0_Φ5_Cnxt_rhs; time ProveContext. (* 10.968 secs *)
  1, 2: pose lemma26_bnl0_Φ3_Cnxt_lhs; pose lemma26_bnl1_enco0_Φ5_Cnxt_lhs; time ProveContext. (* 11.148 secs *)
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              |  Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
  induction n; simpl.
  { assumption. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq x y -> eq (mem (insort z y) x) true.
Proof.
  intros.
  induction z.
  { subst. simpl. destruct (less y n).
    { simpl. rewrite eqb_refl. simpl. reflexivity. }
    { simpl. rewrite IHz. apply Bool.orb_true_r. }
  }
  { simpl. subst. lfind. Admitted.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Import AliasHierarchy.

Module Type HSet (H: Hierarchy).
  Parameter t: Type.
  Parameter bot: t.
  Parameter top: t.
  Parameter add: H.t -> t -> t.
  Parameter In: H.t -> t -> Prop.
  Axiom In_add_spec: forall x y s,
    In x (add y s) <-> x = y \/ H.above y x \/ In x s.
  (*Parameter mem: forall x s, {In x s} + {~In x s}.*)
  Definition eq (s1 s2: t): Prop := forall x, In x s1 <-> In x s2.

(*
  Axiom In_add_same: forall x s, In x (add x s).
  Axiom In_add_hierarchy: forall x y,
    H.hierarchy x y -> (forall s, In y (add x s)).
  Axiom In_add_already: forall x y s, In x s -> In x (add y s).
*)
  Definition singleton x := add x bot.
(*
  Axiom In_singleton: forall x, In x (singleton x).
  Axiom In_singleton_hierarchy: forall x y,
    H.hierarchy x y -> In y (singleton x).
*)
End HSet.


Require Import WildCat Pointed.
Require Import Groups.Group Groups.Subgroup Groups.Kernel.
Require Import Homotopy.ExactSequence Modalities.Identity.

Local Open Scope mc_scope.
Local Open Scope mc_add_scope.
Local Open Scope path_scope.

(** * Complexes of groups *)

Definition grp_cxfib {A B C : Group} {i : A $-> B} {f : B $-> C} (cx : IsComplex i f)
  : GroupHomomorphism A (grp_kernel f)
  := grp_kernel_corec _ cx.

Definition grp_iso_cxfib {A B C : Group} {i : A $-> B} {f : B $-> C}
           `{IsEmbedding i} (ex : IsExact (Tr (-1)) i f)
  : GroupIsomorphism A (grp_kernel f)
  := Build_GroupIsomorphism _ _ (grp_cxfib cx_isexact) (isequiv_cxfib ex).

(** This is the same proof as for [equiv_cxfib_beta], but giving the proof is easier than specializing the general result. *)
Proposition grp_iso_cxfib_beta {A B C : Group} {i : A $-> B} {f : B $-> C}
            `{IsEmbedding i} (ex : IsExact (Tr (-1)) i f)
  : i $o (grp_iso_inverse (grp_iso_cxfib ex)) $== subgroup_incl (grp_kernel f).
Proof.
  rapply equiv_ind.
  1: exact (isequiv_cxfib ex).
  intro x.
  exact (ap (fun y => i y) (eissect _ x)).
Defined.

Definition grp_iscomplex_trivial {X Y : Group} (f : X $-> Y)
  : IsComplex (@grp_homo_const grp_trivial X) f.
Proof.
  srapply phomotopy_homotopy_hset.
  intro x; cbn.
  exact (grp_homo_unit f).
Defined.

Local Existing Instance ishprop_phomotopy_hset.
Local Existing Instance ishprop_isexact_hset.

(** A complex 0 -> A -> B of groups is purely exact if and only if the map A -> B is an embedding. *)
Lemma equiv_grp_isexact_isembedding `{Univalence} {A B : Group} (f : A $-> B)
  : IsExact purely (@grp_homo_const grp_trivial A) f <~> IsEmbedding f.
Proof.
  srapply equiv_iff_hprop.
  - intros [cx conn] b a.
    rapply (transport IsHProp (x:= hfiber f 0)).
    + apply path_universe_uncurried; symmetry.
      apply equiv_grp_hfiber.
      exact a.
    + rapply (transport IsHProp (x:= grp_trivial)).
      apply path_universe_uncurried.
      rapply Build_Equiv.
  - intro isemb_f.
    exists (grp_iscomplex_trivial f).
    intros y; rapply contr_inhabited_hprop.
    exists tt; apply path_ishprop.
Defined.

(** A complex 0 -> A -> B is purely exact if and only if the kernel of the map A -> B is trivial. *)
Corollary equiv_grp_isexact_kernel `{Univalence} {A B : Group} (f : A $-> B)
  : IsExact purely (@grp_homo_const grp_trivial A) f
            <~> (grp_kernel f = trivial_subgroup :> Subgroup _).
Proof.
  exact ((equiv_kernel_isembedding f)^-1%equiv oE equiv_grp_isexact_isembedding f).
Defined.


Require Import POrder POrderSet TerminalDogma
                                ExtraDogma.Extensionality
                                ExtraDogma.AllDecidable.

Require Import SetFacility
                POrderFacility
                POrderInstances.

From Babel Require Import Maps.

From Coq Require Import Classical Relations Bool.

Require Import Ranko
                ExtensionalityCharacter
                IotaDescriptionCharacter
                AllDecidableCharacter
                ClassicalCharacter.

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

(** Assume universal decidability *)
Coercion decide_oracle : Sortclass >-> bool.

(** The type of state:
    partial maps from identifiers to [nat]. *)
Definition variable := string.
Definition Stt := partial_map nat.

(** Expressions *)
Definition expression := Stt -> nat.

Section Sta.
(** >>> *)
Import LeibnizEqOrder.CanonicalStruct.

Definition Sta := [poset of Stt].
End Sta.

(** >>> *)
Import FunPointwiseOrder.CanonicalStruct.
Import BoolOrder.CanonicalStruct.

(** Asn : complete lattice *)
Definition Asn := [clattice of [Sta ↦ᵐ bool]].

Definition asn_true : Asn := (fun _ => true) : Sta -> bool.
#[local] Hint Unfold asn_true : magic_book.

Definition asn_false : Asn := (fun _ => false) : Stt -> bool.
#[local] Hint Unfold asn_false : magic_book.

(** The substitution of assertions. *)
Axiom asn_substitute : forall (P : Asn) (b : variable) (e : expression), Asn.
Notation " P '[' b ':' e ']' " := (asn_substitute P b e) (at level 0, b at next level).

(** The assumption of substitution. *)
Axiom asn_sub_eq : forall (P : Asn) (s : Stt) (b : variable) (e : expression),
    (P [b : e]) s = P (b ?-> e s; s).

(** some wrapping definitions *)
Definition asn_impl_comp (P Q : Asn) : Sta -> bool := fun s => (P s ==> Q s).
Notation "P ⇒ Q" := (asn_impl_comp P Q) (at level 40).
#[local] Hint Unfold asn_impl_comp : magic_book.

Definition asn_or (P Q : Asn) : Sta -> bool := fun s => (P s || Q s).
Notation "P 'or' Q" := (asn_or P Q) (at level 40).
#[local] Hint Unfold asn_or : magic_book.

Definition asn_and (P Q : Asn) : Sta -> bool := fun s => (P s && Q s).
Notation "P 'and' Q" := (asn_and P Q) (at level 40).
#[local] Hint Unfold asn_and : magic_book.

Definition asn_not (P : Asn) : Sta -> bool := fun s => ~~ P s.
Notation "'not' P" := (asn_not P) (at level 50).
#[local] Hint Unfold asn_not : magic_book.

Definition uni_quantification (P : Asn) : Prop := forall s, P s.
Notation "⌈ P ⌉" := (uni_quantification P).
#[local] Hint Unfold uni_quantification : magic_book.

Lemma Lemma_3_1 (P Q : Asn) :
    P ⊑ Q <-> ⌈ P ⇒ Q ⌉.
Proof. ranko. Qed.

(** big exists and big forall *)
Definition EQtf (B : 𝒫(Asn)) : Asn :=
    ((fun s => exists' P ∈ B, P s) : (Sta -> bool)).
#[local] Hint Unfold EQtf : magic_book.

Lemma Lemma_3_2 (B : 𝒫(Asn)) :
    ⊔ᶜˡ B = EQtf B.
Proof. ranko. Qed.

Notation guard := (Stt -> bool).

(** program

    We can consider this idea:
        Here's a difference from [Morrise86] : we use general action with
        known wp function in substitution of assignment.

        This adopts a little taste of modularized language building. *)

Inductive specif : Type :=
| skip_
| abort_
| assign_ (b : variable) (e : expression)
| if_ (g1 g2 : guard) (s1 s2 : specif)
| seq_ (s1 s2 : specif)
| block_ (s : specif)

| prescription_ (P Q : Asn).

Notation " 'Skip' " := skip_.
Notation " 'Abort' " := abort_.
Notation " b <- e " := (assign_ b e) (at level 10).
Notation " 'If' g1 ↦ s1 □ g2 ↦ s2 'Fi'" := (if_ g1 g2 s1 s2).
Notation " s1 ⨾ s2 " := (seq_ s1 s2) (at level 15, right associativity).
Notation " [ 'Block' ; p ] " := (block_ p) (at level 0, p at next level).
Notation " P ‖ Q " := (prescription_ P Q) (at level 50).

Reserved Notation " p '{[' R ']}' " (at level 5).

Fixpoint is_program (p : specif) : bool :=
    match p with
    | p⨾ q => is_program p && is_program q
    | If g1 ↦ s1 □ g2 ↦ s2 Fi => is_program s1 && is_program s2
    | [ Block ; s ] => is_program s
    | P ‖ Q => false
    | _ => true
    end.

Fixpoint wp (p : specif) (R : Asn) :=
    match p with
    | Abort => asn_false
    | Skip => R
    | b <- e => R [ b : e ]
    | p⨾ q => p {[ q {[ R ]} ]}
    | If g1 ↦ s1 □ g2 ↦ s2 Fi =>
        (g1 or g2) and (g1 ⇒ s1{[R]}) and (g2 ⇒ s2{[R]})
    (** semantics of recursion is omitted here*)
    | [ Block ; s ] => s {[ R ]}
    | P ‖ Q => P and ((fun x => ⌈ Q ⇒ R ⌉) : Stt -> bool)
    end
    where " p {[ R ]} " := (wp p R).

(** Theorem 3.3 *)

Lemma wp_monotonicMixin (p : specif) : MonotonicFun.mixin_of (wp p).
Proof.
    rewrite /MonotonicFun.mixin_of. induction p.

    ranko.
    ranko.
    ranko. rewrite asn_sub_eq. apply H. by rewrite -asn_sub_eq.

    move => P Q HPQ.
    move : (IHp1 _ _ HPQ) (IHp2 _ _ HPQ).
    ranko 0 2 0.

    move => P Q HPQ.
    move: (IHp2 _ _ HPQ). move: (IHp1 p2 {[P]} p2 {[Q]}).
    clear IHp1 IHp2.
    ranko.

    ranko.

    (** prescription *)
    ranko.
Qed.

Axiom wp_extensionality : forall (p q : specif), wp p = wp q -> p = q.

(** Every specification s ∈ [Asn ↦ᵐ Asn] *)
Canonical wp_monotonicfun (p : specif) :=
    MonotonicFun (wp p) (@wp_monotonicMixin p).

(** embed specifications in the complete lattice *)
(**
Check wp _ : [clattice of [Asn  ↦ᵐ  Asn]].
Check wp : specif -> [clattice of [Asn  ↦ᵐ  Asn]].
Check wp : [poset of specif] -> [clattice of [Asn  ↦ᵐ  Asn]].
Check (wp   : specif -> [Asn  ↦ᵐ  Asn])
            : [[poset of specif] ↦ᵐ [clattice of [Asn  ↦ᵐ  Asn]]].

*)

Definition Spec := [clattice of [Asn  ↦ᵐ  Asn]].

Coercion wp : specif >-> Funclass.

(** Theorem 3.4 *)
Theorem Theorem_3_4a (P Q : Asn) (s : specif) :

        (P ‖ Q) ⊑{Spec} s <-> P ⊑ s{[Q]}.

Proof.
    split.
    ranko.
    apply H. ranko.

    ranko. apply H in a. move: x0 a.
    apply (MonotonicFun.class (wp s)).
    ranko.
Qed.

Theorem Theorem_3_4b (P Q : Asn) (s : specif) :

        P ⊑ s{[Q]} <-> ⌈ P ⇒ s{[Q]} ⌉.

Proof. by apply Lemma_3_1. Qed.

(** ** Properties of specifications *)

Definition specif_chance := asn_true ‖ asn_true.
Definition specif_miracle := asn_true ‖ asn_false.
Definition specif_abort1 := asn_false ‖ asn_true.
Definition specif_abort2 := asn_false ‖ asn_false.

Lemma specif_abort1_prop (R : Asn):

        specif_abort1 {[ R ]} = asn_false.

Proof. ranko. Qed.

Lemma specif_abort2_prop (R : Asn):

        specif_abort2 {[ R ]} = asn_false.

Proof. ranko. Qed.

Lemma specif_miracle_prop (R : Asn):

        specif_miracle {[ R ]} = asn_true.

Proof. ranko. Qed.

Lemma specif_chance_prop (R : Asn):

        specif_chance {[ R ]} = [monotonicfun of (fun _ => ⌈ R ⌉) : Sta -> bool].

Proof. ranko. Qed.

Lemma prog_property_1 (p : specif) (prog_p : is_program p) :

        p {[ asn_false ]} = asn_false.

Proof.
    elim: p prog_p.
    ranko.
    ranko.
    ranko.

    ranko. by apply asn_sub_eq.

    ranko 0 1 0. repeat prop_2_bool_ssr_branch.
    rewrite (H a). rewrite (H0 b).
    by case: (g1 x); case: (g2 x) => //=.

    ranko.

    ranko.

    ranko.
Qed.

Lemma prog_property_2 (s : specif) (P Q : Asn):

    s {[ P and Q ]} = s {[ P ]} and s {[ Q ]}.

Proof.
    elim: s P Q.
    - ranko.
    - ranko.
    - ranko.
        rewrite !asn_sub_eq. ranko.

    - move => g1 g2 s1 Hs1 s2 Hs2 P Q.
    move : (Hs1 P Q) (Hs2 P Q). clear Hs1 Hs2.
    ranko.
    by case: (g1 x); case: (g2 x);
    case: (s1 {[P]} x); case: (s2 {[P]} x);
    case: (s1 {[Q]} x); case: (s2 {[Q]} x) => //=.

    (** Oh my god. Ranko did this! *)
    - give_up. (* ranko. *)

    - ranko.

    - ranko.

    have t : ((∀ s : Stt, Q s ==> P0 s && Q0 s) : bool) =
    (∀ s : Stt, Q s ==> P0 s) && (∀ s : Stt, Q s ==> Q0 s).
    case E: (decide_oracle (∀ s : Stt, Q s ==> P0 s && Q0 s));
    move: E.

    * ranko.

    * ranko.

    - case: (P x); case: (Q x); case: (P0 x); case: (Q0 x) => //=.

Admitted. (* Qed. *)

Lemma prog_property_3 (p : specif) (prog_p : is_program p) (asnC : chain Asn) :

    p {[ (EQtf asnC) ]} = (EQtf (wp p [<] asnC)).

Proof.
    elim: p prog_p.

    - ranko.

    - ranko.

Abort.

(*
    - ranko. rewrite asn_sub_eq. ranko.
    case E: (ι (EQtf_iota { (x0) [(b) : e], x0 :
        monotonicfun Sta BoolOrder.clattice_type | x0 ∈ asnC }) x); move: E.
    ranko. by rewrite -asn_sub_eq.
    ranko. apply E. ranko. by rewrite asn_sub_eq.

    - ranko. rewrite (H a) (H0 b). clear H H0. ranko.
    case E: (ι (EQtf_iota { LeibnizEqOrder.fun_monotonicType
         (λ s : Stt, (g1 s || g2 s) && (g1 s ==> s1 {[x0]} s) && (g2 s ==> s2 {[x0]} s)),
       x0 : monotonicfun Sta BoolOrder.clattice_type | x0 ∈ asnC }) x); move: E.
    ranko. ranko.
    prop_2_bool_ssr.
    case: (g1 x); case: (g2 x).
    case E1: (ι
    (EQtf_iota
       { s1 {[x0]}, x0 : monotonicfun Sta BoolOrder.clattice_type |
       x0 ∈ asnC }) x);
    case E2: (ι
    (EQtf_iota
       { s2 {[x0]}, x0 : monotonicfun Sta BoolOrder.clattice_type |
       x0 ∈ asnC }) x) => //=; move: E1 E2.

Abort.
*)

(** Theorem 4.1 *)

Theorem Theorem_4_1 (P Q : Asn) :

        P ‖ Q ⊑{Spec} Skip <-> ⌈ P ⇒ Q ⌉.

Proof. ranko. apply H. ranko. Qed.

Theorem Theorem_4_2 (P Q : Asn) (b : variable) (e : expression) :

        P ‖ Q ⊑{Spec} b <- e <-> ⌈ P ⇒ Q[b : e] ⌉.

Proof. ranko. apply H. ranko.
    move: (H x0); clear H.
    rewrite !asn_sub_eq.
    move: b0. ranko.
    move: (b0 (b ?-> e x0; x0)); clear b0.
    ranko.
Qed.

Theorem Theorem_4_3 (P Q R S : Asn) :

        P ‖ Q ⊑{Spec} R ‖ S <-> (⌈ P ⇒ R ⌉ /\ ⌈ S ⇒ Q ⌉) \/ ⌈ not P ⌉.

Proof.
    rewrite Theorem_3_4a Theorem_3_4b.
    ranko.
    case : (classic (∀ s : Stt, P s = false)).
    ranko.
    ranko.
Qed.

Theorem Theorem_4_4 (P Q : Asn) (g1 g2 :guard) (s1 s2 : specif) :

        P ‖ Q ⊑{Spec} If g1 ↦ s1 □ g2 ↦ s2 Fi <->
            ⌈ P ⇒ g1 or g2 ⌉ /\
            (P and g1 ‖ Q ⊑{Spec} s1) /\
            (P and g2 ‖ Q ⊑{Spec} s2).

Proof.
    rewrite Theorem_3_4a Theorem_3_4b.
    ranko. (* wait a second *)
    - move: (H s).
    by case: (P s); case: (g1 s); case: (g2 s).
    - move: (H x0); clear H. ranko.
        move: (H a); clear a H. ranko.
        move: (b1 b); clear b1 b a b2. move: x0.
        apply (MonotonicFun.class (wp s1)). ranko.

    - move: (H x0); clear H. ranko.
        move: (H a); clear a H. ranko.
        move: (b2 b); clear b1 b a b2. move: x0.
        apply (MonotonicFun.class (wp s2)). ranko.

    - move: (a s); clear a a0 b. ranko.
        rewrite orb_true_iff. rewrite orb_true_iff in a.
        destruct a.
        + left. move: H H0. by case: (P s); case: (g1 s).
        + by right.

    - move: (a0 Q); clear a0 b. ranko.
        move: (a0 s); clear a0. ranko.
        apply a0. ranko.

    - move: (b Q); clear a0 b. ranko.
        move: (b s); clear b. ranko.
        apply b. ranko.
Qed.

Theorem Theorem_4_5 (P Q R S T U : Asn) :

        ⌈ P ⇒ R ⌉ /\ ⌈ S ⇒ T ⌉ /\ ⌈ U ⇒ Q ⌉
        -> P ‖ Q ⊑{Spec} (R ‖ S) ⨾ (T ‖ U).

Proof. ranko. Qed.

Theorem Theorem_4_6 (P Q : Asn) (s : specif) :

        P ‖ Q ⊑{Spec} s -> P ‖ Q ⊑{Spec} [ Block ; s ].

Proof. ranko. Qed.

Lemma Lemma_4_7a (P Q R S : Asn) (s : specif):

        P ‖ Q ⊑{Spec} s /\ R ‖ S ⊑{Spec} s
        -> (P and R) ‖ (Q and S) ⊑{Spec} s.

Proof. ranko 3 0 3.
    have HQ : s {[Q]} x0 = true. apply a. ranko.
    have HS : s {[S]} x0 = true. apply b. ranko.
    clear a b.

    have HQS : s {[ Q and S ]} x0 = true.
    rewrite prog_property_2. ranko. clear HQ HS a0 b0.
    move: x0 HQS.
    apply (MonotonicFun.class (wp s)). ranko.
Qed.

Lemma Lemma_4_8a (P Q : Asn) (s : specif):

        P ‖ Q ⊑{Spec} ((P ‖ s {[ Q ]}) ⨾ s).

Proof. ranko. move: s0 H.
    apply (MonotonicFun.class (wp s)). ranko.
Qed.

Lemma Lemma_4_8b (P Q : Asn) (s : specif):

        s {[ P ]} ‖ Q = s ⨾ (P ‖ Q).

Proof.
    elim: s.
    - apply wp_extensionality. ranko.
    - apply wp_extensionality. ranko.
    - move => b e. apply wp_extensionality.
        ranko. rewrite !asn_sub_eq. ranko.
    - ranko.
    - ranko.
    - ranko.
    - move => R S. apply wp_extensionality. apply poset_antisym.
        + ranko.
        + ranko.
    (** The last case is indeeded unprovable. Consider :
            R ‖ S = true ‖ false = miracle,
            P = Q = true.
    *)
Abort.

(** If we limit [s] to programs [p], the above lemma holds. *)
Lemma Lemma_4_8c (P Q : Asn) (p : specif) (Hprog : is_program p):

        p {[ P ]} ‖ Q = p ⨾ (P ‖ Q).

Proof.
    elim: p Hprog.
    - move => Hprog. apply wp_extensionality. ranko.
    - move => Hprog. apply wp_extensionality. ranko.
    - move => Hprog b e. apply wp_extensionality.
        ranko. rewrite !asn_sub_eq. ranko.
    - ranko.
    - ranko.
    - ranko.
    - ranko.
Qed.

Lemma Lemma_4_9 (P : 𝒫(Asn)) (Q : Asn) :

    ⊔ᶜˡ { (wp (Pj ‖ Q) : Spec) , Pj | Pj ∈ P } = (⊔ᶜˡ P) ‖ Q.

Proof. ranko. Qed.

(*###############################################################*)
(** An example of refinement *)

(**

Refinement of prescription : P0 ‖ Q0.

P0 : 0 <= i <= n and f = i!
Q0 : f = n!

A first attempt,

P0 ‖ Q0 ⊑ if i = n -> P0 and n = i ‖ f = i!
            □ i < n -> P0 and n < i ‖ f = i! fi

        ⊑ if i = n -> f = i! ‖ f = i!
            □ i < n -> 0 <= i < n and f = i! ‖ f = i! fi

        ⊑ if i = n -> skip
            □ i < n -> 0 <= i < n and f = i! ‖ 0 <= i <= n and f = i!;
                       0 <= i <= n and f = i! ‖ f = i! fi

        (note that

            0 <= i < n and f = i! ‖ 0 <= i <= n and f = i! ⊑ skip,

        but this will result in a unterminating program)

        ⊑ if i = n -> skip
            □ i < n -> 0 <= i < n and f = i! ‖ 0 <= i <= n and f = (i-1)!;
                       0 <= i <= n and f = (i-1)! ‖ 0 <= i <= n and f = i!;
                       0 <= i <= n and f = i! ‖ f = i! fi

        ⊑ if i = n -> skip
            □ i < n -> i := i + 1; f := f * i;
                       P0 ‖ Q0 fi

Then we consider the recursion :

        f := if i = n -> skip
            □ i < n -> i := i + 1; f := f * i; f fi.

To prove

        P0 ‖ Q0 ⊑ f

using Theorem 4.11, we need the variant function

        t := n - i.

Here's the proof :

P0 and n - i = λ ‖ Q0

    = 0 <= i <= n and f = i! and n - i = λ ‖ f = n!

    ⊑ if i = n -> P0 and n - i = λ and n = i ‖ f = i!
        □ i < n -> P0 and n - i = λ and i < n ‖ f = i! fi

    ⊑ if i = n -> skip
        □ i < n -> 0 <= i < n and n - i = λ and f = i! ‖ f = i! fi

    ⊑ if i = n -> skip
        □ i < n -> 0 <= i < n and n - i = λ and f = i! ‖ 0 <= i <= n and n - i = λ - 1 and f = (i-1)!;
                   0 <= i <= n and n - i = λ - 1 and f = (i-1)! ‖ 0 <= i <= n and n - i = λ - 1 and f = i!
                   0 <= i <= n and n - i = λ - 1 and f = i! ‖ f = i! fi

    ⊑ if i = n -> skip
        □ i < n -> i := i + 1; f := f * i;
                   P0 and n - i = λ - 1 ‖ Q0 fi

    ⊑ if i = n -> skip
        □ i < n -> i := i + 1; f := f * i;
                   P0 and n - i < λ ‖ Q0 fi
*)


Require Export Dirac.
Require Export Equival.

Definition GHZ := /√2 .* (∣0,0,0⟩) .+ /√2 .* (∣1,1,1⟩).
Definition φ (a b : C) : Vector 2 := a .* ∣0⟩ .+ b .* ∣1⟩.

Lemma ss0 :  forall (a b : C),
(M0 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩ ⊗ ∣0⟩ ⊗ φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss0 :  forall (a b : C),
super ((M0 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩  ⊗ ∣0⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss0' :  forall (a b : C),
(M0 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩ ⊗ ∣0⟩ ⊗ φ a b .
Proof.
intros.
by_den.
rewrite ss0; reflexivity.
Qed.

Lemma ss1 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩ ⊗ ∣1⟩ ⊗ φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss1 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩  ⊗ ∣1⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss1' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣0⟩ ⊗ ∣1⟩ ⊗ φ a b .
Proof.
intros.
by_den.
rewrite ss1; reflexivity.
Qed.

Lemma ss2 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss2 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩  ⊗ ∣0⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss2' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss2; reflexivity.
Qed.

Lemma ss3 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss3 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩  ⊗ ∣1⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss3' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M0 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣0⟩ ⊗ ∣1⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss3; reflexivity.
Qed.

Lemma ss4 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (M1 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss4 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (M1 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩  ⊗ ∣0⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss4' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (M1 ⊗ M0 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss4; reflexivity.
Qed.

Lemma ss5 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss5 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩  ⊗ ∣1⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss5' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M0 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣0⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss5; reflexivity.
Qed.

Lemma ss6 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss6 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩  ⊗ ∣0⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss6' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M0 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩ ⊗ ∣0⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss6; reflexivity.
Qed.

Lemma ss7 :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≡ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
unfold φ,GHZ.
operate_reduce.
Qed.

Lemma Dss7 :  forall (a b : C),
super ((I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2)) (density (φ a b ⊗ GHZ)) ≡ density (/ √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩  ⊗ ∣1⟩ ⊗ φ a b).
Proof.
intros.
unfold φ,GHZ.
Time super_reduce.
Qed.

Lemma ss7' :  forall (a b : C),
(I_2 ⊗ I_2 ⊗ I_2 ⊗ σX) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (I_2 ⊗ I_2 ⊗ I_2 ⊗ σZ) × (M1 ⊗ M1 ⊗ M1 ⊗ I_2) × (I_2 ⊗ H ⊗ H ⊗ I_2) × (XC ⊗ I_2 ⊗ I_2) × (φ a b ⊗ GHZ) ≈ / √ 2 * / 2  .* ∣1⟩ ⊗ ∣1⟩ ⊗ ∣1⟩ ⊗  φ a b .
Proof.
intros.
by_den.
rewrite ss7; reflexivity.
Qed.

(*
Finished transaction in 37.559 secs (37.375u,0.046s) (successful)
Finished transaction in 48.964 secs (48.671u,0.015s) (successful)
Finished transaction in 49.244 secs (49.015u,0.015s) (successful)
Finished transaction in 60.381 secs (60.046u,0.062s) (successful)
Finished transaction in 48.188 secs (48.078u,0.s) (successful)
Finished transaction in 57.792 secs (57.484u,0.078s) (successful)
Finished transaction in 59.737 secs (59.484u,0.015s) (successful)
Finished transaction in 70.623 secs (70.234u,0.031s) (successful) *)


(* * Library for retracts  *)

(* Author: Maximilian Wuttke *)

From Undecidability.Shared.Libs.PSL Require Import Base.

(*
 * A retraction between types [A] and [B] is a tuple of two functions,
 * [f : A -> B] (called the injection function) and [g : B -> option A] (called the retract function),
 * such that the following triangle shaped diagram commutes:
 *
 *          f
 *      A -----> B
 *      |      /
 * Some |     / g
 *      |    /
 *     \|/ |/_
 *    option A
 *
 * That informally means, that the injective function [f] can be reverted by the retract function [g].
 * Foramlly, for all values [x:A] and [y = f x], then [g y = Some x].  (Or: [forall x, g (f x) = Some x].)
 *
 * The retracts should also be "tight", which means that the retract function only reverts values in
 * the image of [f]. Foramlly this means that whenever [g y = Some x], then also [y = f x]
 *
 * Altogether, we have that [forall x y, g y = Some x <-> y = f x].
 *)

Section Retract.

  Variable X Y : Type.

  Definition retract (f : X -> Y) (g : Y -> option X) := forall x y, g y = Some x <-> y = f x.

  Class Retract :=
    {
      Retr_f : X -> Y;
      Retr_g : Y -> option X;
      Retr_retr : retract Retr_f Retr_g;
    }.

End Retract.

Arguments Retr_f { _ _ _ }.
Arguments Retr_g { _ _ _ }.

Section Retract_Properties.

  Variable X Y : Type.

  Hypothesis I : Retract X Y.

  Definition retract_g_adjoint : forall x, Retr_g (Retr_f x) = Some x.
  Proof. intros. pose proof @Retr_retr _ _ I. hnf in H. now rewrite H. Qed.

  Definition retract_g_inv : forall x y, Retr_g y = Some x -> y = Retr_f x.
  Proof. intros. now apply Retr_retr. Qed.

  Lemma retract_g_surjective : forall x, { y | Retr_g y = Some x }.
  Proof. intros x. pose proof retract_g_adjoint x. cbn in H. eauto. Defined.

  Lemma retract_f_injective : forall x1 x2, Retr_f x1 = Retr_f x2 -> x1 = x2.
  Proof.
    intros x1 x2 H.
    enough (Some x1 = Some x2) by congruence.
    erewrite <- !retract_g_adjoint.
    now rewrite H.
  Qed.

  Lemma retract_g_Some x y :
    Retr_g (Retr_f x) = Some y ->
    x = y.
  Proof. now intros H % retract_g_inv % retract_f_injective. Qed.

  Lemma retract_g_None b :
    Retr_g b = None ->
    forall a, Retr_f a <> b.
  Proof.
    intros H a <-.
    enough (Retr_g (Retr_f a) = Some a) by congruence.
    apply retract_g_adjoint.
  Qed.

End Retract_Properties.

(* This tactic replaces all occurrences of [g (f x)] with [Some x] for retracts. *)
Ltac retract_adjoint :=
  match goal with
  | [ H : context [ Retr_g (Retr_f _) ] |- _ ] => rewrite retract_g_adjoint in H
  | [   |- context [ Retr_g (Retr_f _) ]     ] => rewrite retract_g_adjoint
  end.

(*
 * We can compose retractions, as shown in the following commuting diagram
 *
 *            f1        f2
 *      A --------> B --------> C
 *      |         / |         /
 *      |        /  |Some    /
 *      |       /   |       /
 *      |      /    |      /
 * Some |     / g1  |     / g2
 *      |    /      |    /
 *     \|/ |/_     \|/ |/_
 *    option A <--- option B
 *            map g1
 *
 *
 * Where [map g1] is the function that takes an option [x : option B] and applys [Some] and [g1] if it is [Some],
 * and else returns [None].
 *
 * Now [f2 ∘ f1] and [map g1 ∘ g2] gives a retract between [A] and [C].
 *)

Section ComposeRetracts.
  Variable A B C : Type.

  Definition retr_comp_f (f1 : B -> C) (f2 : A -> B) : A -> C := fun a => f1 (f2 a).
  Definition retr_comp_g (g1 : C -> option B) (g2 : B -> option A) : C -> option A :=
    fun c => match g1 c with
          | Some b => g2 b
          | None => None
          end.

  (* No instance (outside of this section), for obvious reasons... *)
  Program Instance ComposeRetract (retr1 : Retract B C) (retr2 : Retract A B) : Retract A C :=
    {|
      Retr_f := retr_comp_f Retr_f Retr_f;
      Retr_g := retr_comp_g Retr_g Retr_g;
    |}.
  Next Obligation.
    abstract now
      unfold retr_comp_f, retr_comp_g; intros a c; split;
      [intros H; destruct (Retr_g c) as [ | ] eqn:E;
       [ apply retract_g_inv in E as ->; now apply retract_g_inv in H as ->
       | congruence
       ]
      | intros ->; now do 2 retract_adjoint
      ].
  Defined.

End ComposeRetracts.

(* We define some useful retracts. *)
Section Usefull_Retracts.

  Variable (A B C D : Type).

  (* Identity retract *)
  Global Program Instance Retract_id : Retract A A :=
    {|
      Retr_f a := a;
      Retr_g b := Some b;
    |}.
  Next Obligation. abstract now hnf; firstorder congruence. Defined.

  (* Empty retract *)
  Global Program Instance Retract_Empty : Retract Empty_set A :=
    {|
      Retr_f e := @Empty_set_rect (fun _ => A) e;
      Retr_g b := None;
    |}.
  Next Obligation. abstract now intros x; elim x. Defined.

  (* Eliminate the [Empty_set] from the source sum type *)
  Global Program Instance Retract_Empty_left `{retr: Retract A B} : Retract (A + Empty_set) B :=
    {|
      Retr_f a := match a with
                  | inl a => Retr_f a
                  | inr e => @Empty_set_rect (fun _ => B) e
                  end;
      Retr_g b := match Retr_g b with
                  | Some a => Some (inl a)
                  | None => None
                  end;
    |}.
  Next Obligation.
    abstract now intros [ a | [] ] b; split;
      [ intros H; destruct (Retr_g b) eqn:E; inv H; now apply retract_g_inv in E
      | intros ->; now retract_adjoint
      ].
  Defined.

  Global Program Instance Retract_Empty_right `{retr: Retract A B} : Retract (Empty_set + A) B :=
    {|
      Retr_f a := match a with
                  | inl e => @Empty_set_rect (fun _ => B) e
                  | inr a => Retr_f a
                  end;
      Retr_g b := match Retr_g b with
                  | Some a => Some (inr a)
                  | None => None
                  end;
    |}.
  Next Obligation.
    abstract now intros [ [] | a ] b; split;
      [ intros H; destruct (Retr_g b) eqn:E; inv H; now apply retract_g_inv in E
      | intros ->; now retract_adjoint
      ].
  Defined.

  (* We can introduce an additional [Some] and use the identity as the retract function *)
  Global Program Instance Retract_option `{retr: Retract A B} : Retract A (option B) :=
    {|
      Retr_f a := Some (Retr_f a);
      Retr_g ob := match ob with
                    | Some b => Retr_g b
                    | None => None
                    end;
    |}.
  Next Obligation.
    abstract now
      split;
      [ intros H; destruct y as [b|];
        [ now apply retract_g_inv in H as ->
        | inv H
        ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (* We can introduce an additional [inl] *)

  Definition retract_inl_f (f : A -> B) : A -> (B + C) := fun a => inl (f a).
  Definition retract_inl_g (g : B -> option A) : B+C -> option A :=
    fun x => match x with
          | inl b => g b
          | inr c => None
          end.

  Global Program Instance Retract_inl (retrAB : Retract A B) : Retract A (B + C) :=
    {|
      Retr_f := retract_inl_f Retr_f;
      Retr_g := retract_inl_g Retr_g;
    |}.
  Next Obligation.
    abstract now
      unfold retract_inl_f, retract_inl_g; hnf; intros x y; split;
      [ destruct y as [a|b]; [ now intros -> % retract_g_inv | congruence ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (* The same for [inr] *)

  Definition retract_inr_f (f : A -> B) : A -> (C + B) := fun a => inr (f a).
  Definition retract_inr_g (g : B -> option A) : C+B -> option A :=
    fun x => match x with
          | inr b => g b
          | inl c => None
          end.

  Global Program Instance Retract_inr (retrAB : Retract A B) : Retract A (C + B) :=
    {|
      Retr_f := retract_inr_f Retr_f;
      Retr_g := retract_inr_g Retr_g;
    |}.
  Next Obligation.
    abstract now
      unfold retract_inr_f, retract_inr_g; hnf; intros x y; split;
      [ destruct y as [a|b]; [ congruence | now intros -> % retract_g_inv ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (* We can map retracts over sums, similiary as we have done with inversions *)

  Section Retract_sum.

    Definition retract_sum_f (f1: A -> C) (f2: B -> D) : A+B -> C+D :=
      fun x => match x with
            | inl a => inl (f1 a)
            | inr b => inr (f2 b)
            end.

    Definition retract_sum_g (g1: C -> option A) (g2: D -> option B) : C+D -> option (A+B) :=
      fun y => match y with
            | inl c => match g1 c with
                      | Some a => Some (inl a)
                      | None => None
                      end
            | inr d => match g2 d with
                      | Some b => Some (inr b)
                      | None => None
                      end
            end.

    Local Program Instance Retract_sum (retr1 : Retract A C) (retr2 : Retract B D) : Retract (A+B) (C+D) :=
      {|
        Retr_f := retract_sum_f Retr_f Retr_f;
        Retr_g := retract_sum_g Retr_g Retr_g;
      |}.
    Next Obligation.
      abstract now
        unfold retract_sum_f, retract_sum_g; intros x y; split;
        [ intros H; destruct y as [c|d];
          [ destruct (Retr_g c) eqn:E1; inv H; f_equal; now apply retract_g_inv
          | destruct (Retr_g d) eqn:E1; inv H; f_equal; now apply retract_g_inv
          ]
        | intros ->; destruct x as [a|b]; now retract_adjoint
        ].
    Defined.

  End Retract_sum.

End Usefull_Retracts.

(* If we have a retract from [A] to [Z] and a retract from [B] to Z, in general it is not possible
 * to build a retract from [A+B] to [Z]. For example, there can be no retract from [unit+unit] to
 * [unit]. However, it is possible when the images of the injections are distint.
 *)
Section Join.

  Variable A B Z : Type.

  Variable retr1 : Retract A Z.
  Variable retr2 : Retract B Z.

  Local Arguments Retr_f {_ _} (Retract).
  Local Arguments Retr_g {_ _} (Retract).

  Definition retract_join_f s :=
    match s with
    | inl a => Retr_f retr1 a
    | inr b => Retr_f retr2 b
    end.

  Definition retract_join_g z :=
    match Retr_g retr1 z with
    | Some a => Some (inl a)
    | None =>
      match Retr_g retr2 z with
      | Some b => Some (inr b)
      | None => None
      end
    end.

  Hypothesis disjoint : forall (a : A) (b : B), Retr_f _ a <> Retr_f _ b.

  Lemma retract_join : retract retract_join_f retract_join_g.
  Proof.
    unfold retract_join_f, retract_join_g. hnf; intros s z; split.
    - destruct s as [a|b]; intros H.
      + destruct (Retr_g retr1 z) eqn:E.
        * inv H. now apply retract_g_inv in E.
        * destruct (Retr_g retr2 z) eqn:E2; inv H.
      + destruct (Retr_g retr1 z) eqn:E.
        * inv H.
        * destruct (Retr_g retr2 z) eqn:E2.
          -- inv H. now apply retract_g_inv in E2.
          -- inv H.
    - intros ->. destruct s as [a|b]; retract_adjoint. reflexivity.
      destruct (Retr_g retr1 (Retr_f retr2 b)) eqn:E.
      + exfalso. apply retract_g_inv in E. symmetry in E. now apply disjoint in E.
      + reflexivity.
  Qed.

  Local Instance Retract_join : Retract (A+B) Z := Build_Retract retract_join.

End Join.

(* More instances like [Retract_sum] for bigger sums. *)

Section MoreSums.

  Local Instance Retract_sum3 (A A' B B' C C' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') :
    Retract (A+B+C) (A'+B'+C') := Retract_sum (Retract_sum retr1 retr2) retr3.

  Local Instance Retract_sum4 (A A' B B' C C' D D' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') :
    Retract (A+B+C+D) (A'+B'+C'+D') := Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4.

  Local Instance Retract_sum5 (A A' B B' C C' D D' E E' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') :
    Retract (A+B+C+D+E) (A'+B'+C'+D'+E') := Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5.

  Local Instance Retract_sum6 (A A' B B' C C' D D' E E' F F' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') (retr6 : Retract F F') :
    Retract (A+B+C+D+E+F) (A'+B'+C'+D'+E'+F') := Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5) retr6.

  Local Instance Retract_sum7 (A A' B B' C C' D D' E E' F F' G G' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') (retr6 : Retract F F') (retr7 : Retract G G') :
    Retract (A+B+C+D+E+F+G) (A'+B'+C'+D'+E'+F'+G') := Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5) retr6) retr7.

End MoreSums.


Require Import Coq.Program.Basics Coq.Program.Tactics.
Require Import Coq.Classes.Morphisms.

Require Import Crypto.Util.Decidable.
Require Import Crypto.Algebra.Field.
Require Import Crypto.Util.Notations.

Create HintDb fsatz_lookup discriminated.

Module F.
  Section with_field.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos (BinNat.N.two))}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "-" := Fsub.
    Local Infix "*" := Fmul. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x). Local Notation "x ^ 3" := (x^2*x).

    Local Obligation Tactic := abstract (intros; fsatz).

    Program Definition eq_opp__eq_zero a : a = Fopp a -> a = 0 := _.
    Program Definition neq_opp__neq_zero a : a <> Fopp a -> a <> 0 := _.
    Program Definition twice_eq_zero a : a + a = 0 -> a = 0 := _.
    Program Definition twice_neq_zero a : a + a <> 0 -> a <> 0 := _.
    Program Definition inv_cube_eq_zero__neq_zero__absurd a : Finv (a^3) = 0 -> a <> 0 -> False := _.
    Program Definition sub_eq_zero_eq a b : a - b = 0 -> a = b := _.
    Program Definition sub_eq_zero_eq_sym a b : a - b = 0 -> b = a := _.
    Program Definition sub_neq_zero_eq a b : a - b <> 0 -> a <> b := _.
    Program Definition sub_neq_zero_eq_sym a b : a - b <> 0 -> b <> a := _.
    Program Definition mul3_nonzero_drop_mid a b c : (a * b) * c <> 0 -> a * c <> 0 := _.
    Program Definition mul_nonzero_l a b : a * b <> 0 -> a <> 0 := _.
    Program Definition mul_nonzero_r a b : a * b <> 0 -> b <> 0 := _.
    Program Definition factor_difference_of_squares a b c : a^2 - b^2 = c -> (a - b) * (a + b) = c := _.
    Program Definition expand_square_sum a b : (a + b)^2 - (a^2 + b^2) = 0 -> a * b = 0 := _.
    Program Definition expand_square_sum_neq a b : (a + b)^2 - (a^2 + b^2) <> 0 -> a * b <> 0 := _.
    Program Definition expand_square_sum_sub a b : (a + b)^2 - a^2 - b^2 = 0 -> a * b = 0 := _.
    Program Definition expand_square_sum_sub_neq a b : (a + b)^2 - a^2 - b^2 <> 0 -> a * b <> 0 := _.
    Program Definition factor_square_sum a b : a * b = 0 -> (a + b)^2 - (a^2 + b^2) = 0 := _.
    Program Definition factor_square_sum_neq a b : a * b <> 0 -> (a + b)^2 - (a^2 + b^2) <> 0 := _.
    Program Definition factor_square_sum_sub a b : a * b = 0 -> (a + b)^2 - a^2 - b^2 = 0 := _.
    Program Definition factor_square_sum_sub_neq a b : a * b <> 0 -> (a + b)^2 - a^2 - b^2 <> 0 := _.
    Program Definition mul_eq_0_r_nz a b : a * b = 0 -> a <> 0 -> b = 0 := _.
    Program Definition mul_eq_0_l_nz a b : a * b = 0 -> b <> 0 -> a = 0 := _.
    Program Definition mul_eq_0_l a b : a = 0 -> a * b = 0 := _.
    Program Definition mul_eq_0_r a b : b = 0 -> a * b = 0 := _.
    Program Definition mul_neq_0 a b : a <> 0 -> b <> 0 -> a * b <> 0 := _.
    Program Definition helper1 a b c : a + b * c = 0 -> a <> Fopp (c * b) -> False := _.
    Program Definition helper2 a b c d : a - b * c <> d -> b = 1 -> a - c <> d := _.
    Program Definition helper3 a b c d : a - b * c = d -> b = 1 -> a - c = d := _.
    Program Definition helper4 a b c d e : a - b * c * d <> e -> b = 1 -> a - c * d <> e := _.
    Program Definition helper5 a b c d e : a - b * c * d = e -> b = 1 -> a - c * d = e := _.
    Program Definition helper6 a b c d : a - b * c^2 <> d -> c = 1 -> a - b <> d := _.
    Program Definition helper7 a b c d : a - b * c^2 = d -> c = 1 -> a - b = d := _.
    Program Definition helper8 a b c d : a - b + c <> d -> b = 0 -> a + c <> d := _.
    Program Definition helper9 a b c : a - b <> c -> b = 0 -> a <> c := _.
    Program Definition helper10 a b c d : a * b + c <> d -> a = 0 -> c <> d := _.
    Program Definition helper11 a b c d : a * b + c <> d -> b = 0 -> c <> d := _.
    Program Definition helper12 a b c : a * b <> c -> a = 0 -> c <> 0 := _.
    Program Definition helper13 a b c : a * b <> c -> b = 0 -> c <> 0 := _.
    Program Definition helper14 a b c : Fopp (a * b) <> c -> a = 0 -> c <> 0 := _.
    Program Definition helper15 a b c : Fopp (a * b) <> c -> b = 0 -> c <> 0 := _.
    Program Definition helper16 a b c : a * b^3 = c -> b = 0 -> c = 0 := _.
    Program Definition helper17 a b c : a * b = c -> a = 0 -> c = 0 := _.
    Program Definition helper18 a b c : a * b - c <> 0 -> a = 0 -> c <> 0 := _.
    Program Definition helper19 a b c : a * b - c <> 0 -> b = 0 -> c <> 0 := _.
    Program Definition helper20 a b c : a * b - c = 0 -> a = 0 -> c = 0 := _.
    Program Definition helper21 a b c : a * b - c = 0 -> b = 0 -> c = 0 := _.
    Program Definition helper22 a b c : a - b * c = 0 -> c = 0 -> a = 0 := _.
    Program Definition helper23 a b c d : a * (b * b^2) - c <> d -> a * (b^3) - c <> d := _.
    Program Definition helper24 a b c d : a * (b * b^2) - c = d -> a * (b^3) - c = d := _.
    Program Definition helper25 a b c d : a - (b * b^2) * c <> d -> a - (b^3) * c <> d := _.
    Program Definition helper26 a b c d : a - (b * b^2) * c = d -> a - (b^3) * c = d := _.
    Program Definition helper27 a b : a * (b * b^2) = 0 -> b <> 0 -> a = 0 := _.
    Program Definition helper28 a b c : c <> 0 -> a * (b * c) = 0 -> a * b = 0 := _.
    Program Definition helper29 a b c : a = 0 -> a * b + c = 0 -> c = 0 := _.
    Program Definition helper30 a b c d : a * b^3 + d * c^3 = 0 -> a * (b * b^2) - c * c^2 * d = 0 -> a * b^3 = 0 := _.
    Program Definition helper31 a b c d : a * Finv (b^2) <> c * Finv (d^2) -> b <> 0 -> d <> 0 -> a * (d^2) <> c * (b^2) := _.
    Program Definition helper32 a b c d : a * Finv (b^2) = c * Finv (d^2) -> b <> 0 -> d <> 0 -> a * (d^2) = c * (b^2) := _.
    Program Definition helper33 a b c d : a * Finv (b^3) = Fopp (c * Finv (d^3)) -> b <> 0 -> d <> 0 -> a * (d^3) = Fopp (c * (b^3)) := _.
    Program Definition helper34 a b c d : a * Finv (b^3) <> Fopp (c * Finv (d^3)) -> b <> 0 -> d <> 0 -> a * (d^3) <> Fopp (c * (b^3)) := _.
    Program Definition helper35 a b c : a = Fopp (b * c) -> a - c * b = 0 -> a = 0 := _.
    Program Definition helper36 a b c : a <> Fopp (b * c) -> a - c * b = 0 -> a * b * c <> 0 := _.
    Program Definition helper37 X Y X' Y' A B C C' : Y^2 = C^3 + A * C * (X^2)^2 + B * (X^3)^2 -> Y'^2 = C'^3 + A * C' * (X'^2)^2 + B * (X'^3)^2 -> C' * X^2 - C * X'^2 = 0 -> (Y' * (X^3))^2 - ((X'^3) * Y)^2 = 0 := _.
    Program Definition helper38 X Y X' Y' A B C C' : Y^2 = C^3 + A * C * (X^2)^2 + B * (X^3)^2 -> Y'^2 = C'^3 + A * C' * (X'^2)^2 + B * (X'^3)^2 -> C' * X^2 = C * X'^2 -> (Y' * (X^3))^2 - ((X'^3) * Y)^2 = 0 := _.
    Program Definition helper39 a : a <> 0 -> Finv (a^2) = (Finv a)^2 := _.
    Program Definition helper40 a : a <> 0 -> Finv (a^3) = (Finv a)^3 := _.
    Program Definition helper41 a : a <> 0 -> Finv (Finv a) = a := _.
    Program Definition helper42 a b : (a + b)^2 - a^2 - b^2 = (1+1) * a * b := _.
    Program Definition helper42' a b : (a + b)^2 - (a^2 + b^2) = (1+1) * a * b := _.
    Program Definition helper43 a b : a * b <> 0 -> Finv (a * b) = Finv a * Finv b := _.
    Program Definition helper_zero_1 a b c : a = b * c -> b = 0 -> a = 0 := _.
    Program Definition helper44 x y z w A B C D
            (H0 : x * y^3 = A * B^3)
            (H1 : x * z^3 - B^3 * D = 0)
            (H2 : D * C^3 = w * z^3)
            (H3 : A * C^3 - y^3 * w <> 0)
            (Hz : z <> 0)
            (HB : B <> 0)
            : False := _.
    Program Definition helper45 x y z w A B C D
            (H0 : x * y^3 = A * B^3)
            (H1 : x * z^3 - B^3 * D <> 0)
            (H2 : D * C^3 = w * z^3)
            (H3 : A * C^3 - y^3 * w = 0)
            (Hy : y <> 0)
            (HC : C <> 0)
      : False := _.
    Program Definition helper46 x y z w A B C D
            (H0 : x * y^2 = A * B^2)
            (H1 : x * z^2 - D * B^2 = 0)
            (H2 : D * C^2 = w * z^2)
            (H3 : A * C^2 - w * y^2 <> 0)
            (Hz : z <> 0)
            (HB : B <> 0)
      : False := _.
    Program Definition helper47 x y z w A B C D
            (H0 : A * B^2 = x * y^2)
            (H1 : x * z^2 - D * B^2 = 0)
            (H2 : w * z^2 = D * C^2)
            (H3 : A * C^2 - w * y^2 <> 0)
            (Hz : z <> 0)
            (HB : B <> 0)
      : False := _.

    Record dyn := { ty : Prop ; lem : ty }.

    Local Notation "[ x , .. , z ]"
      := (cons {| lem := x |} .. (cons {| lem := z |} nil) .. ).

    (* grep -o 'Program Definition [^ ]*' src/Util/FsatzAutoLemmas.v  | sed s'/Program Definition /, /g' *)
    Definition all_lemmas
      := [I
          , eq_opp__eq_zero
          , neq_opp__neq_zero
          , twice_eq_zero
          , twice_neq_zero
          , inv_cube_eq_zero__neq_zero__absurd
          , sub_eq_zero_eq
          , sub_eq_zero_eq_sym
          , sub_neq_zero_eq
          , sub_neq_zero_eq_sym
          , mul3_nonzero_drop_mid
          , mul_nonzero_l
          , mul_nonzero_r
          , factor_difference_of_squares
          , expand_square_sum
          , expand_square_sum_neq
          , expand_square_sum_sub
          , expand_square_sum_sub_neq
          , factor_square_sum
          , factor_square_sum_neq
          , factor_square_sum_sub
          , factor_square_sum_sub_neq
          , mul_eq_0_r_nz
          , mul_eq_0_l_nz
          , mul_eq_0_l
          , mul_eq_0_r
          , mul_neq_0
          , helper1
          , helper2
          , helper3
          , helper4
          , helper5
          , helper6
          , helper7
          , helper8
          , helper9
          , helper10
          , helper11
          , helper12
          , helper13
          , helper14
          , helper15
          , helper16
          , helper17
          , helper18
          , helper19
          , helper20
          , helper21
          , helper22
          , helper23
          , helper24
          , helper25
          , helper26
          , helper27
          , helper28
          , helper29
          , helper30
          , helper31
          , helper32
          , helper33
          , helper34
          , helper35
          , helper36
          , helper37
          , helper38
          , helper39
          , helper40
          , helper41
          , helper42
          , helper42'
          , helper43
          , helper_zero_1
          , helper44
          , helper45
          , helper46
          , helper47
         ].
  End with_field.

  Ltac get_package_on fld :=
    let pkg := constr:(all_lemmas (field:=fld)) in
    let pkg := (eval cbv [all_lemmas] in pkg) in
    pkg.

  Ltac lookup_lemma_on pkg ty :=
    lazymatch pkg with
    | context[@Build_dyn ty ?lem] => lem
    end.

  Ltac lookup_lemma ty :=
    let fld := guess_field in
    let pkg := get_package_on fld in
    lookup_lemma_on fld ty.

  Ltac with_lemma_on pkg ty tac :=
    let H := lookup_lemma_on pkg ty in
    tac H.

  Ltac goal_exact_lemma_on pkg :=
    lazymatch goal with
    | [ |- ?G ] => with_lemma_on pkg G ltac:(fun H' => exact H')
    end.
  Ltac goal_apply_lemma_on pkg ty :=
    with_lemma_on pkg ty ltac:(fun H' => apply H').
  Ltac apply_lemma_in_on pkg H ty :=
    with_lemma_on pkg ty ltac:(fun H' => apply H' in H).
  Ltac apply2_lemma_in_on pkg H0 H1 ty :=
    with_lemma_on pkg ty ltac:(fun H' => apply H' in H0; [ | exact H1 ]).
  Ltac apply_lemma_in_on' pkg H ty preapp :=
    with_lemma_on pkg ty ltac:(fun H' => let H' := preapp H' in apply H' in H).
End F.