From Coq Require Import ssreflect.
From mathcomp Require Import all_ssreflect. (* .none *)
From mathcomp Require Import all_algebra. (* .none *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing GRing.Theory.
Import Num.Theory.

Local Open Scope ring_scope.

(******************************************************************************)
(**
    General lemmas which are useful but which are not specially about BelGames
    and HRtransforms

    DECIDABILITY OF EQTYPES:

     Lemma eqType_dec_prop :
       forall (T : eqType) (t1 t2 : T), t1 = t2 \/ t1 <> t2.
     Lemma eqType_dec :
       forall (T : eqType) (t1 t2 : T), {t1 = t2} + {t1 <> t2}.

    PICK:

     Definition pick_nonemptyset :
       forall (X : finType) (B : {set X}), B != set0 -> X.
     Definition pick_nonemptyset_sig :
       forall (X : finType) (B : {set X}),
       B != set0 -> {x : X | x \in B}.

    SUBSET LEMMAS:

     Lemma subset_set0 :
       forall (T : finType) (A B : {set T}),
       (A \subset B) && (A \subset ~: B) = (A == set0).
     Lemma subsetF :
       forall (T : finType) (A B : {set T}),
       A \subset B ->
       A \subset ~: B -> forall t : T, t \in A -> Logic.False.
     Lemma subset_disjoint :
       forall (T : finType) (A B : {set T}),
       [disjoint A & B] ->
       forall B0 : {set T},
       B0 != set0 -> B0 \subset A -> ~~ (B0 \subset B).

    EXISTS LEMMAS:

     Lemma exists_l :
       forall (T : Type) (P Q : T -> Prop),
       (exists x : T, P x /\ Q x) -> exists x : T, P x.
     Lemma exists_r :
       forall (T : Type) (P Q : T -> Prop),
       (exists x : T, P x /\ Q x) -> exists x : T, Q x.
     Lemma existsb_l :
       forall (T : finType) (P Q : pred T),
       [exists x, P x && Q x] -> [exists x, P x].
     Lemma existsb_r :
       forall (T : finType) (P Q : pred T),
       [exists x, P x && Q x] -> [exists x, Q x].
     Lemma set0_existsF :
       forall (X : finType) (B : {set X}),
       (B == set0) = ~~ [exists x, x \in B].

    SIG_BIG_DEP ON SIGS (NOT ON SIGTS):

     Definition osig :
       forall (X : finType) (P : pred X), X -> {? x | P x}.
     Lemma osig_bij :
       forall (X : finType) (P : pred X) (x : X),
       P x -> omap ((@sval) X (fun x0 : X => P x0)) (osig P x) = Some x.
     Lemma sig_big_dep2 :
       forall (R : Type) (idx : R) (op : Monoid.com_law idx)
         (X : finType) (P : pred X) (f : forall x : X, P x -> R),
       \big[op/idx]_s f (tag s) (tagged s) =
       \big[op/idx]_(x | P x)
          match boolP (P x) with
          | @AltTrue _ _ h => f x h
          | @AltFalse _ _ _ => idx
          end.
     Lemma sig_big :
       forall (R : Type) (idx : R) (op : Monoid.com_law idx)
         (X : finType) (P : pred X) (f : X -> R),
       \big[op/idx]_s f (tag s) = \big[op/idx]_(x | P x) f x.
     Definition set1_oinv : forall X : finType, {set X} -> option X.

    BIG LEMMAS:

     Lemma big_card1 :
       forall (R : Type) (idx : R) (op : Monoid.com_law idx)
         (X : finType) (f : {set X} -> R),
       \big[op/idx]_(A | #|A| == 1) f A = \big[op/idx]_x f [set x].
     Lemma big_setI_distrl :
       forall (R : Type) (zero : R) (times : Monoid.mul_law zero)
         (plus : Monoid.add_law zero times) (T : finType)
         (P : pred {set T}) (h : {set T} -> {set T})
         (f g : {set T} -> R),
       \big[plus/zero]_(A | P (h A)) times (g A) (f (h A)) =
       \big[plus/zero]_(B | P B)
          times (\big[plus/zero]_(A | h A == B) g A) (f B).

    NUM LEMMAS:

     Context {R : numFieldType}.
     Lemma mulr_ll :
       forall x y z : R, y = z -> x * y = x * z.
     Lemma mulr_rr :
       forall x y z : R, y = z -> y * x = z * x.
     Lemma neq01 : (0 : R) != 1.
     Lemma addr_gte0 :
       forall x y : R, 0 < x -> 0 <= y -> 0 < x + y.
     Lemma sum_ge0 :
       forall (X : finType) (P : pred X) (f : X -> R),
       (forall x : X, P x -> 0 <= f x) -> 0 <= \sum_(x | P x) f x.
     Lemma sum_ge0_eq0E :
       forall (X : finType) (P : pred X) (f : X -> R),
       (forall x : X, P x -> 0 <= f x) ->
       \sum_(x | P x) f x = 0 <-> (forall x : X, P x -> f x = 0).
     Lemma sum_ge0_neq0E :
       forall (X : finType) (P : pred X) (f : X -> R),
       (forall x : X, P x -> 0 <= f x) ->
       \sum_(x | P x) f x != 0 -> exists x : X, P x && (0 < f x).
     Lemma sum_div :
       forall (X : finType) (P : pred X) (cst : R)
         (f : X -> R),
       \sum_(x | P x) f x / cst = (\sum_(x | P x) f x) / cst.
     Lemma sum_div_eq1 :
       forall (X : finType) (P : pred X) (cst : R),
       cst != 0 ->
       forall f : X -> R,
       (\sum_(x | P x) f x / cst == 1) = (\sum_(x | P x) f x == cst).
   End

 *)
(******************************************************************************)
Section SomeLemmas.

  (* Not used *)
  Lemma nat_split012 (n : nat) :
    (n == 0)%N || (n == 1)%N || (n > 1)%N.
  Proof. by case n => // ; case => //. Qed.

  (** Decidability of eqTypes **)
  Lemma eqType_dec_prop (T : eqType) (t1 t2 : T) :
    t1 = t2 \/ t1 <> t2.
  Proof.
  case (boolP (t1 == t2)) => /eqP H.
  - exact: or_introl.
  - exact: or_intror.
  Qed.

  Lemma eqType_dec (T : eqType) (t1 t2 : T) :
    {t1 = t2} + {t1 <> t2}.
  Proof.
  case (boolP (t1 == t2)) => /eqP Ht.
  - by left.
  - by right.
  Qed.

  Lemma pick_set1E (T : finType) (x0 : T) : [pick x in [set x0]] = Some x0.
  Proof.
    case: pickP.
    - by move=> x; rewrite inE; move/eqP=>->.
    - by move/(_ x0); rewrite inE eqxx.
  Qed.

  Definition pick_nonemptyset {X : finType} (B : {set X}) (HB : B != set0) : X.
  case (pickP [pred x in B]) => [x _ | H0].
  - exact: x.
  - by rewrite (cards0_eq (eq_card0 H0)) eqxx in HB.
  Defined.

  Definition pick_nonemptyset_sig {X : finType} (B : {set X}) (HB : B != set0) : {x : X | x \in B}.
  exists (pick_nonemptyset HB).
  rewrite /pick_nonemptyset => //=.
  case (pickP [pred x in B]) => //= H0.
  have HB' := HB.
  by rewrite (cards0_eq (eq_card0 H0)) eqxx in HB'.
  Defined.

  Lemma pick_set1 {X : finType} (x : X) A (HA : A = [set x]) (Hx : A != set0) :
    pick_nonemptyset Hx = x.
  Proof.
  rewrite /pick_nonemptyset.
  case pickP => /= [y|H].
  - by rewrite HA in_set1 => /eqP ->.
  - have := H x => /= ; by rewrite {1}HA in_set1 eqxx.
  Qed.

  (** The only subset of B and B^c is set0 **)
  Lemma subset_set0 {T : finType} (A B : {set T}) :
    (A \subset B) && (A \subset ~:B) = (A == set0).
  Proof.
  case (boolP (A == set0)) => [/eqP -> | /set0Pn [x Hx]].
  - by rewrite !sub0set.
  - case (boolP (A \subset B)) ; case (boolP (A \subset ~:B)) => //.
    rewrite !subsetE => /pred0P H1 /pred0P H2.
    have := H2 x.
    have := H1 x.
    rewrite /= Hx !andbT.
    move => Hx1 /negP/negP Hx2.
    by rewrite -in_setC setCK Hx2 in Hx1.
  Qed.

  Lemma subsetF {T : finType} (A B : {set T}) :
    A \subset B -> A \subset ~:B -> forall t, t \in A -> Logic.False.
  Proof.
  move => H1 H2 t Ht.
  have HA : A = set0. by apply/eqP ; rewrite -(subset_set0 _ B) H1 H2.
  by rewrite HA in_set0 in Ht.
  Qed.

  Lemma subset_disjoint {T : finType} (A B : {set T}) :
    [disjoint A & B] ->
    forall B0 : {set T},
    B0 != set0 ->
    B0 \subset A -> ~~ (B0 \subset B).
  Proof.
  move => HAB B0 Hb0 /subsetP /= H.
  apply /subsetPn.
  have [x Hx] := pick_nonemptyset_sig Hb0.
  exists x => //.
  by rewrite (disjointFr HAB (H x Hx)).
  Qed.

  (** Split 'exists' predicates **)
  Lemma exists_l (T : Type) (P Q : T -> Prop) :
    (exists x, P x /\ Q x) -> (exists x, P x).
  Proof.
  case => x [H _] ; by exists x.
  Qed.

  Lemma exists_r (T : Type) (P Q : T -> Prop) :
    (exists x, P x /\ Q x) -> (exists x, Q x).
  Proof.
  case => x [_ H] ; by exists x.
  Qed.

  (* The only one used *)
  Lemma existsb_l (T : finType) (P Q : pred T) :
    [exists x, P x && Q x] -> [exists x, P x].
  Proof.
  move => /existsP ; case => x /andP [H _].
  apply/existsP ; by exists x.
  Qed.

  Lemma existsb_r (T : finType) (P Q : pred T) :
    [exists x, P x && Q x] -> [exists x, Q x].
  Proof.
  move => /existsP ; case => x /andP [_ H].
  apply/existsP ; by exists x.
  Qed.

  Lemma set0_existsF (X : finType) (B : {set X}) :
    (B == set0) = (~~ [exists x, x \in B]).
  Proof.
  case (boolP [exists x, x \in B]) => /existsP/set0Pn => [H|-> //].
  by rewrite (negbTE H).
  Qed.

  Section SigBigDep2.
    (** Proof of a version of sig_big_dep about 'sig' (but not about 'sigT') **)

    (* Projection from 'X' into 'option {x : X | P x}' -- needed for sig_big_dep2 *)
    Definition osig (X : finType) (P : pred X) : X -> option {x : X | P x}
      := (fun x => match boolP (P x) with AltTrue h => Some (exist P x h) | _ => None end).

    Lemma osig_bij (X : finType) (P : pred X) : forall x : X, P x -> omap sval (osig P x) = Some x.
    move => x Hx.
    rewrite/omap/obind/oapp/osig => //=.
    case (boolP (P x)) => [Hx' //|] ; by rewrite Hx.
    Qed.

    Lemma sig_big_dep2 {R} {idx : R} {op : Monoid.com_law idx} {X : finType} (P : pred X) f :
      \big[op/idx]_(s : {x : X | P x}) f (tag s) (tagged s) = \big[op/idx]_(x : X | P x) match boolP (P x) with AltTrue h => f x h | _ => idx end.
    Proof.
    rewrite (reindex_omap (op:=op) (sval) (osig P) (@osig_bij _ P)).
    apply eq_big => [[x Hx]|[x Hx] _] /=.
    - rewrite /osig ; case (boolP (P x)) => [Hx'|] ; last by rewrite Hx.
        by rewrite (Eqdep_dec.eq_proofs_unicity (@eqType_dec_prop _ ) Hx Hx') eqxx.
    - case (boolP (P x)) => [Hx'|] ; last by rewrite Hx.
        by rewrite (Eqdep_dec.eq_proofs_unicity
                    (@eqType_dec_prop _ ) ((ssrfun.svalP (exist (fun x0 : X => P x0) x Hx)))).
    Qed.

    (* Not used *)
    Lemma sig_big R (idx : R) (op : Monoid.com_law idx) (X : finType) (P : pred X) f :
      \big[op/idx]_(s : {x : X | P x}) f (tag s) = \big[op/idx]_(x : X | P x) f x.
    Proof.
    rewrite (sig_big_dep2 (fun x _ => f x)).
    apply eq_bigr => x Hx.
    case (boolP (P x)) => [//|] ; by rewrite Hx.
    Qed.

  End SigBigDep2.

  Section Set1_inverse.
    (** option-inverse of (set1 : X -> {set X}) **)
    (* not used *)

    (* Projection from '{set X}' into 'option X' -- o-inverse of set1 -- neede for big_card1 *)
    Definition set1_oinv {X : finType} : {set X} -> option X
      := fun A => match boolP (#|A| > 0)%N with
                  | AltTrue h => if (#|A| == 1)%N
                                 then let (x,_,_) := eq_bigmax_cond (fun=>0%N) h in Some x
                                 else None
                  | _ => None
                  end.

    Lemma set1_ocancel {X : finType} :
      ocancel (@set1_oinv X) set1.
    Proof.
    move => A.
    rewrite /oapp /set1_oinv.
    case (boolP (#|A| > 0)%N) => H //.
    destruct (eq_bigmax_cond (fun=>0%N) H) as [x Hx _].
    case (boolP (#|A| == 1)%N) => // /cards1P [y Hy].
    rewrite Hy in_set1 in Hx.
    by rewrite Hy (eqP Hx).
    Qed.

    Lemma set1_oinv_pcancel {X : finType} :
      pcancel (@set1 X) set1_oinv.
    Proof.
    move => x.
    rewrite /set1_oinv.
    case (boolP (#|[set x]| > 0)%N) => [Hx|] ; last by rewrite cards1.
    rewrite cards1 eqxx //.
    destruct (eq_bigmax_cond (fun=>0%N) Hx) as [y Hy _].
    rewrite in_set1 in Hy.
    by rewrite (eqP Hy).
    Qed.

    Lemma set1_oinv_omap {X : finType} (A : {set X}) (HA : #|A| == 1%N):
      omap set1 (set1_oinv A) = Some A.
    Proof.
    rewrite /omap/obind/oapp/set1_oinv.
    case (boolP (0 < #|A|)%N) => H0 ; case (boolP (#|A| == 1)%N) => H1.
    - destruct (eq_bigmax_cond (fun=>0%N) H0) as [w Hw _].
      destruct (cards1P H1) as [w' Hw'].
      rewrite Hw' in_set1 in Hw.
      by rewrite Hw' (eqP Hw).
    - by rewrite (eqP HA) in H1.
    - by rewrite -eqn0Ngt (eqP H1) in H0.
    - by rewrite (eqP HA) in H1.
    Qed.

  (* Bigop on singletons *)
  Lemma big_card1 R (idx : R) (op : Monoid.com_law idx) (X : finType) (f : {set X} -> R) :
    \big[op/idx]_(A : {set X} | #|A| == 1%N) f A = \big[op/idx]_(x : X) f [set x].
  Proof.
  rewrite (reindex_omap set1 set1_oinv) => [|A HA].
  - apply: eq_bigl => x.
    by rewrite set1_oinv_pcancel cards1 !eqxx.
  - rewrite /omap /obind /oapp /set1_oinv.
    case (boolP (0 < #|A|)%N) => [Hcard|] ; last by rewrite (eqP HA).
    rewrite HA.
    destruct (eq_bigmax_cond (fun=>0%N) Hcard) as [x Hx _].
    move: HA => /cards1P [y Hy].
    rewrite Hy in_set1 in Hx.
    by rewrite Hy (eqP Hx).
  Qed.

  End Set1_inverse.

  (** Similar to partition_big + big_distrl **)
  Lemma big_setI_distrl {R} {zero : R} {times : Monoid.mul_law zero} {plus : Monoid.add_law zero times} {T : finType} (P : pred {set T}) (h : {set T} -> {set T}) (f g : {set T} -> R) :
    \big[plus/zero]_(A : {set T} | P (h A)) times (g A) (f (h A))
    =
    \big[plus/zero]_(B : {set T} | P B) times (\big[plus/zero]_(A : {set T} | h A == B) g A) (f B).
  Proof.
  under [RHS]eq_bigr do rewrite big_distrl /=.
  rewrite [LHS](partition_big h P) => //.
  apply: eq_bigr => B HB ; apply: eq_big => [A | A /andP [_ HA2]].
  - case (boolP (h A == B)) => H ; last by rewrite (negbTE H) andbF.
    by rewrite H (eqP H) HB.
  - by rewrite (eqP HA2).
  Qed.

  (** Split a commutative bigop according to a predicate P **)
  (* From theories.common *)
  Lemma split_big {R} {idx : R} {op : Monoid.com_law idx} {I} [r : seq I] P Q f :
    \big[op/idx]_(i <- r | P i) f i =
    op (\big[op/idx]_(i <- r | P i && Q i) f i)
       (\big[op/idx]_(i <- r | P i && ~~ Q i) f i).
  Proof.
  exact: bigID.
  Qed.

End SomeLemmas.

Section NumLemmas.

  Context {R : numFieldType}.
  Implicit Type X : finType.

  Lemma mulr_ll (x y z : R) :
    y = z -> x * y = x * z.
  Proof. by move => ->. Qed.

  Lemma mulr_rr (x y z : R) :
    y = z -> y * x = z * x.
  Proof. by move => ->. Qed.

  Lemma neq01 : ((0:R) != 1).
  Proof.
  have := ltr01 (R:=R) ; by rewrite lt0r eq_sym => /andP [H _].
  Qed.

  Lemma addr_gte0 [x y : R] : 0 < x -> 0 <= y -> 0 < x + y.
  Proof.
  rewrite le0r => Hx /orP ; case => [/eqP ->| Hy].
  - by rewrite addr0.
  - exact: addr_gt0.
  Qed.

  Lemma sum_ge0 {X} (P : pred X) (f : X -> R) :
    (forall x, P x -> f x >= 0) -> \sum_(x | P x) f x >= 0.
  Proof.
  move => H ; apply big_ind => // ; exact: addr_ge0.
  Qed.

  Lemma prod_ge0 {X} (P : pred X) (f : X -> R) :
    (forall x, P x -> f x >= 0) -> \prod_(x | P x) f x >= 0.
  Proof.
  move => H ; apply big_ind => //= ; first by rewrite ler01.
  exact: mulr_ge0.
  Qed.

  Lemma sum_ge0_eq0E {X} (P : pred X) (f : X -> R) :
    (forall x, P x -> f x >= 0) -> \sum_(x | P x) f x = 0 <-> forall x, P x -> f x = 0.
  Proof.
  move => Hge0 ; split => [Hsum x Hx | Heq0].
  - apply/eqP/negP => /negP Hcontra.
    rewrite (bigD1 x) //= in Hsum.
    have Hge0' : forall y, P y && (y != x) -> 0 <= f y. move => y /andP [Hy _] ; exact: Hge0.
    have Hgt0 : f x > 0. by rewrite lt0r Hge0 // Hcontra.
    have := addr_gte0 Hgt0 (sum_ge0 Hge0').
    by rewrite Hsum lt0r eqxx andFb.
  - by rewrite (eq_bigr (fun=>0)) // big1.
  Qed.

  Lemma sum_ge0_neq0E {X} (P : pred X) (f : X -> R) :
    (forall x, P x -> f x >= 0) -> \sum_(x | P x) f x != 0 -> exists x : X, P x && (f x > 0).
  Proof.
  move => Hge0 Hsum.
  have Hsum2 : \sum_(x | P x) f x > 0. by rewrite lt0r Hsum sum_ge0 //.
  have Hex : exists x : X, ~~ ~~ (P x && (f x != 0)).
  apply/forallPn/negP => /forallP Hcontra.
  have Hcontra2 : \sum_(x | P x) f x = 0. apply sum_ge0_eq0E => // x Hx.
  move: (Hcontra x) ; by rewrite Hx andTb Bool.negb_involutive => /eqP ->.
  move: Hsum2 ; by rewrite Hcontra2 lt0r eqxx andFb.
  destruct Hex as [x Hx].
  exists x.
  have [Hx1 Hx2] := andP (negPn Hx).
  by rewrite lt0r Hx1 Hx2 Hge0.
  Qed.

  Lemma sum_div {X} (P : pred X) (cst : R) (f : X -> R) :
    \sum_(x : X | P x) f x / cst = (\sum_(x : X | P x) f x) / cst.
  Proof. by rewrite big_distrl.
  Qed.

  Lemma sum_div_eq1 {X} (P : pred X) (cst : R) (Hcst : cst != 0) (f : X -> R) :
    (\sum_(x : X | P x) f x / cst == 1) = (\sum_(x : X | P x) f x == cst).
  Proof.
  rewrite -(divr1 1) sum_div eqr_div //.
  - by rewrite mulr1 mul1r.
  - by rewrite eq_sym neq01.
  Qed.

  (* Lemma big_partitionS {X} (f : {set X} -> X -> R) : *)
  Lemma big_partitionS [Y] (idx : Y) (op : Monoid.com_law idx) [X] (f : {set X} -> X -> Y) :
    \big[op/idx]_(A : {set X}) (\big[op/idx]_(x in A) f A x) = \big[op/idx]_(x : X) \big[op/idx]_(A : {set X} | x \in A) f A x.
  Proof.
  set pair_sig : finType := [finType of {p : {set X} * X | p.2 \in p.1}].
  set f1 : pair_sig -> {set X} := fun s => (val s).1.
  set f2 : pair_sig -> X := fun s => (val s).2.
  - have proof1 :
      \big[op/idx]_x \big[op/idx]_(A : {set X} | x \in A) f A x =
      \big[op/idx]_x \big[op/idx]_(s : pair_sig | (f2 s) == x) f (f1 s) (f2 s).
    apply eq_bigr => x _.
    set f1inv : {set X} -> option pair_sig := fun A => match (boolP (x \in A)) with AltTrue h => Some (exist _ (A,x) h) | _ => None end.
    rewrite (reindex_omap f1 f1inv) => /=.
    + apply eq_big => /= s ;  destruct s as [[A y] Hy] ; simpl in Hy.
      * rewrite /f1/f1inv/f2 => /=.
        case (boolP (x \in A)) => Hx /=.
        - case (boolP (y == x)) => H0 //=.
          + apply/eqP ; apply f_equal.
            have H :  (@sval) ({set X} * X) (fun a : {set X} * X => a.2 \in a.1) (exist (fun x0 : {set X} * X => x0.2 \in x0.1) (A, x) Hx) =
                      (@sval) ({set X} * X) (fun a : {set X} * X => a.2 \in a.1) (exist (fun p : {set X} * X => p.2 \in p.1) (A, y) Hy).
            by simpl ; rewrite (eqP H0).
            apply (eq_sig _ _ H) => //=.
            exact: (Eqdep_dec.eq_proofs_unicity (@eqType_dec_prop bool_eqType)).
          + by apply/eqP ; case => /eqP ; rewrite eq_sym (negbTE H0).
        - symmetry ; apply/eqP => Hcontra.
          by rewrite -Hcontra Hy in Hx.
      * rewrite /f1/f2 => /= /andP [Hx Hinv].
        move: Hinv ; rewrite /f1inv.
        case (boolP (x\in A)) => H ; last by rewrite Hx in H.
        by move/eqP ; case => ->.
    + rewrite /omap/obind/oapp/f1inv => A Hx.
      by case (boolP (x \in A)) => // ; rewrite Hx.
  - have proof2 :
      \big[op/idx]_(A : {set X}) (\big[op/idx]_(x in A) f A x) =
      \big[op/idx]_(A : {set X}) (\big[op/idx]_(s : pair_sig | f1 s == A) f (f1 s) (f2 s)).
    apply eq_bigr => A _.
    set f2inv : X -> option pair_sig := fun x => match (boolP (x \in A)) with AltTrue h => Some (exist _ (A,x) h) | _ => None end.
    rewrite (reindex_omap f2 f2inv) => /=.
    + apply eq_big => /= s ;  destruct s as [[B x] HB] ; simpl in HB.
      * rewrite /f1/f2inv/f2 => /=.
        case (boolP (x \in A)) => HA /=.
        - case (boolP (B == A)) => H0 //=.
          + apply/eqP ; apply f_equal.
            have H :  (@sval) ({set X} * X) (fun a : {set X} * X => a.2 \in a.1) (exist (fun x0 : {set X} * X => x0.2 \in x0.1) (A, x) HA) =
                      (@sval) ({set X} * X) (fun a : {set X} * X => a.2 \in a.1) (exist (fun p : {set X} * X => p.2 \in p.1) (B, x) HB).
            by simpl ; rewrite (eqP H0).
            apply (eq_sig _ _ H) => //=.
            exact: (Eqdep_dec.eq_proofs_unicity (@eqType_dec_prop bool_eqType)).
          + by apply/eqP ; case => /eqP ; rewrite eq_sym (negbTE H0).
        - symmetry ; apply/eqP => Hcontra.
          by rewrite -Hcontra HB in HA.
      * rewrite /f1/f2 => /= /andP [Hx Hinv].
        move: Hinv ; rewrite /f2inv.
        case (boolP (x\in A)) => H ; last by rewrite Hx in H.
        by move/eqP ; case => ->.
    + rewrite /omap/obind/oapp/f2inv => x Hx.
      by case (boolP (x \in A)) => // ; rewrite Hx.
  - rewrite proof2 proof1.
    rewrite -[LHS](partition_big f1 (P:=predT) predT) => //.
    rewrite -[RHS](partition_big f2 (P:=predT) predT) => //.
  Qed.

  Lemma sum_of_sumE {X : finType} (f : {set X} -> R) (P : pred {set X}):
    \sum_(x : X) \sum_(A : {set X} | P A && (x \in A)) f A = \sum_(A | P A) \sum_(w in A) f A.
  Proof.
  rewrite !pair_big_dep /=.
  rewrite (reindex (fun p => (p.2,p.1))) //=.
  exists (fun p => (p.2,p.1)) ; by case.
  Qed.

  Lemma sum_cardiv {X : finType} (A : {set X}) (H : (#|A| > 0)%N):
    \sum_(w in A) #|A|%:R^-1 = (1 : R).
  Proof.
  rewrite big_const iter_addr addr0 /=.
  rewrite -(mulr_natl #|A|%:R^-1 #|A|) divff //=.
  by rewrite pnatr_eq0 -lt0n.
  Qed.

End NumLemmas.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import vars.
Require Import env.
Require Import tactics.
Require Import qualifiers.
Require Import lambda_star.

Require Import examples_infra.
Require Import NatSets.
Require Import setfacts.
Import NatSet.F.

Import OpeningNotations.
Open Scope opening.

Import QualNotations.
Local Open Scope qualifiers.

(* ### Examples ### *)

Notation " { a | b } ==> { c | d }"  := (TFun b d a c)
(at level 10, format "'[' '[hv' '{' a  '/' '|'  b '}' ']' '/  '  '==>'  '[hv' '{' c  '/' '|'  d '}' ']' ']'").

Section Warmup.

  (* identity fun *)
  Example idfun      := (tabs #0).

  (* example context with three bindings a b c (0 1 2) *)
  Context (Γ012 := [(TUnit,∅); (TUnit,∅); (TUnit,∅)]).
  (* example context filter, including 0 1 2. *)
  Context (φ012 := ($$0 ⊔ $$1 ⊔ $$2)).

  (** Γ012|Σ |-ᵠ⁰¹² λx. x : ( x:T1^{} -> T1^{x} )^{} *)
  Example idfun_typing : forall T1 Σ,
      closed_ty 0 3 (length Σ) T1 ->
      has_type Γ012 φ012 Σ idfun ({T1 | ∅} ==> {T1 | ##0}) ∅.
    intros. unfold φ012. unfold Γ012. unfold idfun. compute.
    apply t_abs; ccrush.
    T_VAR; ccrush.
  Qed.

  (** Γ|Σ ⊢ᵠ⁰¹² λx.x : ((a : A^{}) -> A^a)^d1 *)
  Example idfun_ht : forall Γ φ Σ d1 A ,
      closed_qual 0 (length Γ) (length Σ) φ ->
      closed_qual 0 (length Γ) (length Σ) d1 ->
      closed_ty 0 (length Γ) (length Σ) A ->
      saturated Γ Σ d1 ->
      d1 ⊑ φ ->
      has_type Γ φ Σ idfun ({A | ∅} ==> {A | ##0}) d1.
    intros. unfold idfun. compute.
    apply t_abs; ccrush.
    T_VAR; ccrush.
  Qed.

  (** Γ012|Σ ⊢ᵠ⁰¹² λx.x : ((x : A^a,b) -> A^a,b+x)^∅ cannot be typed this way. A function's qualifier should contain all its free variables and
    their qualifiers.  *)
  Example idfun_nt :
    let q := $$0 ⊔ $$1 in
      forall Σ A, has_type Γ012 φ012 Σ idfun ({A | q} ==> {A | q ⊔ ##0}) ∅.
    intros. subst q. unfold idfun.
    apply t_abs; ccrush.
    2 : { T_VAR; ccrush.
          2 : { simpl. intuition. admit. (* contradiction: {0,1,3} ⊈ {3} *)  }
  Abort.

  (** Church encodings *)
  Section Church.
    (* Church true, respectively pi1: λa.λb.a *)
    Example church_true := (tabs (tabs #1)).
    (* Type scheme for pi1 := (a:A^{}) -> ((b:B^{}) -> A^{a})^{a}. *)
    Example church_true_T A B := {A | ∅} ==> {{B | ∅} ==> {A | ##1} | ##0}.
    (* Church false, respectively pi2: λa.λb.b  *)
    Example church_false := (tabs (tabs #0)).
    (* Type scheme for pi2 := (a:A^{}) -> ((b:B^{}) -> B^{b})^{}. *)
    Example church_false_T A B := {A | ∅} ==> {{B | ∅} ==> {B | ##0} | ∅}.

    (* Church pairs *)
    Example pair := (tabs (tabs (tabs (tapp (tapp #0 #2) #1)))).

    (* Pair[A,B]^q_X := ((a : A^{}) -> ((b : B^{}) -> X^q)^q⊔{a})^{} -> X^q *)
    Example TPair A B X q := {{A | ∅} ==> {{B | ∅} ==> {X | q} | q ⊔ ##0} | ∅} ==> {X | q}.

    (* Pair destructors *)
    Example fst := (tabs (tapp #0 church_true)).
    Example snd := (tabs (tapp #0 church_false)).

    Variables (Γ : tenv) (φ : qual) (Σ : senv) (A B : ty).
    Context (phiwf : closed_qual 0 (length Γ) (length Σ) φ)
            (Awf   : closed_ty 0 (length Γ) (length Σ) A)
            (Bwf   : closed_ty 0 (length Γ) (length Σ) B).

    (** Γ|Σ ⊢ᵠ λa.λb.a : ((a:A^{}) -> ((b:B^{}) -> A^{a})^{a})^{} *)
    Example church_true_ht : has_type Γ φ Σ church_true (church_true_T A B) ∅.
      intros. unfold church_true. unfold church_true_T.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      T_VAR; ccrush.
    Qed.

    (** Γ|Σ ⊢ᵠ λa.λb.b : ((a:A^{}) -> ((b:B^{}) -> B^{b})^{})^{} *)
    Example church_false_ht : has_type Γ φ Σ church_false (church_false_T A B) ∅.
      intros. unfold church_false. unfold church_false_T.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      T_VAR; ccrush.
    Qed.

    (* Γ|Σ ⊢ᵠ pair : ( (a : A^{}) -> ((b : B^{}) -> (Pair[A,B]^q_X)^q⊔{a,b})^q⊔{a} )^q *)
    Example t_pair : forall {X q},
      closed_ty 0 (length Γ) (length Σ) X ->
      closed_qual 0 (length Γ) (length Σ) q ->
      saturated Γ Σ q ->
      q ⊑ φ ->
      has_type Γ φ Σ pair ({A | ∅} ==> {{B | ∅} ==> {TPair A B X q | (q ⊔ ##0 ⊔ ##1) } | q ⊔ ##0}) q.
      intros. unfold pair. unfold TPair.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      replace q with (openq $$(S (length Γ)) q) at 4; try solve [opening].
      apply t_app with (T1:=B) (df:=q⊔$$(length Γ)); ccrush.
      * replace (q ⊔ $$ (length Γ))
        with (openq $$(length Γ) (q ⊔ ##0)) at 2; try solve [opening; auto].
        apply t_app with (T1:=A) (df:=$$(S (S (length Γ)))); ccrush.
        + T_VAR; ccrush.
        + T_VAR; ccrush.
      * T_VAR; ccrush.
    Qed.

    (** These Church encodings cannot be applied to arguments, unless there is a form of dependent function application that
        permits "deep" dependency in the type, or abstraction with function self qualifiers. The standard application rule
        t_app forbids general dependency on the argument in a function's codomain. *)
    Variable (a b: tm).
    Context (a_ht : has_type Γ φ Σ a A ∅) (b_ht : has_type Γ φ Σ b B ∅).
    Example church_true_use_bad : exists S q, has_type Γ φ Σ (tapp church_true a) S q.
      eexists. eexists. eapply t_app with (T1:=A) (df:=∅) (d1:=∅). cleanup.
      eapply church_true_ht. eapply a_ht.
      (* This condition states that the codomain of church_true should not be dependent on the argument (zero bound variables).
         However, there is a dangling bound variable in the codomain's qualifier, and we cannot proceed. *)
      admit.
    Abort.

  End Church.

End Warmup.

(** Derived Syntax and Typing Rules *)
(** Sequential composition *)
Definition seq (t1 t2 : tm): tm := (tapp (tapp (tabs (tabs #0)) t1) t2).

Lemma t_seq : forall Γ φ Σ t1 T1 q1 t2 T2 q2,
    has_type Γ φ Σ t1 T1 q1 ->
    has_type Γ φ Σ t2 T2 q2 ->
    saturated Γ Σ q1 ->
    saturated Γ Σ q2 ->
    has_type Γ φ Σ (seq t1 t2) T2 q2.
  intros. unfold seq.
  replace q2 with (openq q2 ##0); try solve [opening; auto].
  eapply t_app with (T1:=T2) (df:=(openq q1 ∅)); eauto; crush.
  * qual_destruct. eapply t_app with (T1:=T1) (df:=∅); ccrush.
    + apply t_abs; ccrush.
      apply t_abs; ccrush.
      T_VAR; ccrush.
Qed.

(** val/let bindings  *)
Definition val (t1 t2 : tm): tm := (tapp (tabs t2) t1).

Lemma t_val : forall Γ φ df Σ t1 T1 q1 t2 T2 q2,
    closed_tm 1 (length Γ) (length Σ) t2 ->
    closed_ty 0 (length Γ) (length Σ) T2 ->
    closed_qual 1 (length Γ) (length Σ) q2 ->
    closed_qual 0 (length Γ) (length Σ) df ->
    has_type Γ φ Σ t1 T1 q1 ->
    df ⊑ φ ->
    saturated Γ Σ (openq ∅ q2) ->
    saturated Γ Σ q1 ->
    saturated Γ Σ df ->
    has_type ((T1, df ⋒ q1) :: Γ) (df ⊔ $$(length Γ)) Σ (open_tm' Γ t2) (open_ty' Γ T2) (openq' Γ q2) ->
    has_type Γ φ Σ (val t1 t2) T2 (openq q1 q2).
  intros. unfold val. specialize (has_type_closed H3). intuition.
  eapply t_app with (df:=df); eauto; crush.
  apply t_abs; ccrush.
  apply has_type_filter in H8. eapply unopen_subqual; eauto.
  unfold_open in H8. unfold_open. eapply subqual_trans; eauto. ccrush.
Qed.

Lemma open_val : forall {k t t1 t2}, open_rec_tm k t (val t1 t2) = (val (open_rec_tm k t t1) (open_rec_tm (S k) t t2)).
  intros. unfold val. simpl. auto.
Qed.

(** Functional Abstraction (Sec. 2.2) *)
Section FunAbs.
  Variables (Σ : senv) (φ  : qual).

  Section IntroEx.
    Variables (q  : qual).
    Context (qwf : closed_qual 0 0 (length Σ) q)
            (satq : saturated [] Σ q)
            (phiwf: closed_qual 0 1 (length Σ) φ)
            (qwfphi : q ⊑ φ)
            (c := 0)
            (cvisible : $c ∈ᵥ φ).

    (** val c = ...                   // : Ref[Int] ^ q+c
        def deref(x : Unit) = { ! c } // : (Unit => Unit) ^ q+c   *)
    Example deref := (tabs (! $0)).
    Example deref_ty : has_type [(TRef TUnit, q)] φ Σ deref ({TUnit | ∅} ==> {TUnit | ∅}) (q ⊕ c).
      intros. unfold deref. subst c.
      apply t_abs; ccrush.
      apply t_deref with (d:=q ⊕ 0).
      T_VAR; ccrush.
    Qed.

    (** deref(unit) // : Unit *)
    Example deref_app : has_type [(TRef TUnit, q)] φ Σ (tapp deref tunit) TUnit ∅.
      intros. replace (∅) with (openq ∅ ∅); try solve [opening; auto].
      eapply t_app with (df:=q ⊕ c); crush. rewrite qglb_empty_right.
      apply deref_ty.
    Qed.

  End IntroEx.

  (** Function Arguments (Sec. 2.2.1) *)
  Section FunArgs.
      Context (phiwf: closed_qual 0 2 (length Σ) φ)
              (c1 := 0)
              (c2 := 1)
              (c1visible : $c1 ∈ᵥ φ)
              (c2visible : $c2 ∈ᵥ φ)
              (Γ12 := [(TRef TUnit, ∅);(TRef TUnit, ∅)]).

      (**
          Note: this version of λ* lacks a ⊥ qualifier (and base type other than Unit).
          We replace the example shown in the paper by an equivalent one, which is typeable in this version.

          def addRef(c : Ref[Unit]^{}) = { !c1; !c } // : // (Ref[Unit]^{} => Unit)^{c1}
      *)
      Example addRef := (tabs (seq (! $c1) (! #0))).
      Example addRef_ty : has_type Γ12 φ Σ addRef ({TRef TUnit | ∅} ==> {TUnit | ∅}) $$c1.
        unfold addRef.
        apply t_abs; ccrush.
        eapply t_seq with (T1:=TUnit) (q1:=∅); crush.
        * apply t_deref with (d:=$$c1); crush.
          T_VAR; crush.
        * apply t_deref with (d:=$$2); crush.
          T_VAR; crush.
      Qed.

      (**
          The application addRef(c2) is legal, since c1 and c2 are different and hence do not overlap.
      *)
      Example addRef_app_ok : has_type Γ12 φ Σ (tapp addRef $c2) TUnit ∅.
        replace (∅) with (openq $$c2 ∅); try solve [opening; auto].
        apply t_app with (T1:=(TRef TUnit)) (df:=$$c1); ccrush.
        * apply addRef_ty.
        * T_VAR; crush.
      Qed.

      (* With the addRef_ty type assignment above, it is impossible to type the application addRef(c1), as expected. *)
      Example addRef_app_bad : exists S q, has_type Γ12 φ Σ (tapp addRef $c1) S q.
        eexists. eexists. (* note the (minimal!) qualifiers of addRef and $c1, which are both just c1. *)
        eapply t_app with (d1:=$$c1) (df:=$$c1); cleanup.
        (* The type of addRef above enforces strict separation between the function and its argument (i.e., the domain qualifier is ∅),
           but both addRef and $c1 contain $c1 in their qualifiers. Note that we end up needing to type addRef with the singleton set {c1} in the domain's qualifier.
           However, due to contravariance, no possible subsumption step could ever eliminate {c1}.  *)
        Abort.

      (* The paper shows the following alternative typing for addRef that would permit overlapping with $c1, and thus
         permit addRef_app_bad. *)
      Example addRef_alt_ty : has_type Γ12 φ Σ addRef ({TRef TUnit | $$c1} ==> {TUnit | ∅}) $$c1.
        unfold addRef.
        apply t_abs; ccrush.
        eapply t_seq with (T1:=TUnit) (q1:=∅); crush.
        * apply t_deref with (d:=$$c1); crush.
          T_VAR; crush.
        * apply t_deref with (d:=($$c1) ⊕ 2); crush.
          T_VAR; ccrush.
      Qed.

      Example addRef_alt_app_c1: has_type Γ12 φ Σ (tapp addRef $c1) TUnit ∅.
        replace (∅) with (openq $$c1 ∅); try solve [opening; auto].
        apply t_app with (T1:=(TRef TUnit)) (df:=$$c1); ccrush.
        * apply addRef_alt_ty.
        * T_VAR; crush.
      Qed.

  End FunArgs.

  (** Function Return Values (Sec. 2.2.2) *)
  Section FunRet.
    Context (Γ0 := [(TRef TUnit, ∅)])
            (phiwf: closed_qual 0 (length Γ0) (length Σ) φ)
            (c0 := 0)
            (c0visible : $c0 ∈ᵥ φ).

    (** def retunEnv(x) = { !c0; c0 } // : (Unit => Ref[Unit]^{c0})^{c0} *)
    Example returnEnv : has_type Γ0 φ Σ (tabs (seq ! ($c0) $c0)) ({TUnit | ∅} ==> {TRef TUnit | $$c0}) $$c0.
      subst c0. apply t_abs; ccrush.
      apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      * apply t_deref with (d:=$$0).
        T_VAR; crush.
      * T_VAR; crush.
    Qed.

    (** def returnArg(x) = { !x; x } // : ((x : Ref[Unit]^∅) => Ref[Unit]^{x})^∅  *)
    Example returnArg : has_type Γ0 φ Σ (tabs (seq !(#0) #0)) ({TRef TUnit | ∅} ==> {TRef TUnit | ##0}) ∅.
      apply t_abs; ccrush.
      apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      * apply t_deref with (d:=$$1).
        T_VAR; ccrush.
      * T_VAR; ccrush.
    Qed.

    (** Lacking the ⊥ qualifier for base types, this version of λ* cannot type the general reference allocation (tref t) for t of arbitrary type.
        Otherwise, reduction steps of the form (tref t) -> (tref t') could violate type preservation, i.e.,
        it is not clear if the argument is a non-reference type without adding further mechanisms (such as the ⊥ qualifier).
        Therefore, we adopt a limited reference allocation that enforces the type of reference is exactly Ref[Unit], then we can type the example:

           def returnFresh(x) = { val y = new Ref(x); !y; y } // : Unit => Ref[Unit]^∅
     *)
    Example returnFresh : has_type Γ0 φ Σ (tabs (val (tref #0) (seq !(#0) #0))) ({TUnit | ∅} ==> {TRef TUnit | ∅}) ∅.
      apply t_abs; ccrush.
      replace (∅) with (openq ∅ ##0); try solve [opening;ccrush].
      eapply t_val; ccrush.
      * eapply t_ref; ccrush.
        T_VAR; ccrush.
      * apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      - apply t_deref with (d:=$$2).
        T_VAR; ccrush.
      - T_VAR; ccrush.
    Qed.

  End FunRet.
End FunAbs.

(** Escaping Closures (Sec. 2.3) *)
Section Escaping.
  Variables (Γ : tenv) (Σ : senv) (φ : qual).
  Context (phiwf : closed_qual 0 (length Γ) (length Σ) φ).

  (** The type of the closure

          val y = ...; { () => new Ref(unit) }

      at the point of its occurrence is

          (Unit => Ref[Unit]^∅)^∅.
   *)
  Example fresh_ty_internal : has_type Γ φ Σ (tabs (tref tunit)) ({TUnit | ∅} ==> {TRef TUnit | ∅}) ∅.
    apply t_abs; ccrush.
    apply t_ref with (d:=∅).
    apply t_base; crush.
  Qed.

  (** When escaping the lexical scope, the type of the closure

          val c = { val y = ...; { () => new Ref(unit) } }

      remains

          (Unit => Ref[Unit]^∅)^∅.
    *)
  Example fresh_ty_external : has_type Γ φ Σ (val tunit (tabs (tref tunit))) ({TUnit | ∅} ==> {TRef TUnit | ∅}) ∅.
    replace (∅) with (openq ∅ ∅); try solve [opening;crush].
    eapply t_val with (df:=∅); ccrush.
    apply t_abs; ccrush.
    apply t_ref with (d:=∅). apply t_base. crush.
  Qed.

  Context (y := length Γ).

  (** The type of the closure in

           val y = new Ref(unit); { () => !y }

      at the point of its occurrence is

           (Unit => Unit)^{y}.
   *)
  Example closure_deref_internal : has_type (((TRef TUnit),∅) :: Γ) (φ ⊔ (just_fv y)) Σ (tabs !($y)) ({TUnit | ∅} ==> {TUnit | ∅}) $$y.
    subst y.
    apply t_abs; ccrush.
    apply t_deref with ($$(length Γ)); ccrush.
    T_VAR; ccrush.
  Qed.

  (** When escaping the lexical scope, the type of the closure

          val c = { val y = new Ref(unit); { () => !y } }

      becomes

          (Unit => Unit)^∅.
   *)
  Example closure_deref_external : has_type Γ φ Σ (val (tref tunit) (tabs !(#1))) ({TUnit | ∅} ==> {TUnit | ∅}) ∅.
    replace (∅) with (openq ∅ ##0); try solve [opening;crush].
    eapply t_val with (df:=∅); ccrush.
    apply t_ref with (d:=∅). apply t_base. crush.
    apply t_abs; ccrush.
    apply t_deref with ($$(length Γ)); ccrush.
    T_VAR; ccrush.
  Qed.

  (** The type of the closure in

           val y = new Ref(unit); { () => y }

      at the point of its occurrence is

           (Unit => Ref[Unit]^{y})^{y}.
   *)
  Example closure_ret_internal : has_type (((TRef TUnit),∅) :: Γ) (φ ⊔ $$y) Σ (tabs $y) ({TUnit | ∅} ==> {TRef TUnit | $$y}) $$y.
    subst y.
    apply t_abs; ccrush.
    T_VAR; ccrush.
  Qed.

  (** In order to assign a type to the escaping closure

          val c = { val y = new Ref(unit); { () => y } }

      we need abstraction by function self qualifiers.
  *)
  Example closure_escape := (val (tref tunit) (tabs #1)).
  (**
      This example also explains why the dependent function application in λ* is restricted, so that the argument variable may
      only occur in the function codomain's qualifier, but not within the codomain type:

      Using the standard encoding of let/val, we may desugar the above code into a function application:

          { val y = new Ref(unit); { () => y } } ~> ({ y => { () => y } })(new Ref(unit))

      where

          { y => { () => y } } : (y : Ref[Unit]^∅) => (Unit => Ref[Unit]^{y})^{y}
          new Ref(unit) :  Ref[Unit]^∅

      If we freely permitted applications of functions with dependency in the codomain type, then we would obtain

          ({ y => { () => y } })(new Ref(unit)) : ((Unit => Ref[Unit]^{y})^{y})[y ↦ ∅] = (Unit => Ref[Unit]^{∅})^{∅}

      But this is wrong! We would not be able to distinguish between this example and

          { val y = ...; { () => new Ref(unit) } }

      where the closure always returns a fresh reference. The solution is introducing function self-qualifiers.
  *)

End Escaping.

(** Key Higher-Order Programming Patterns (Sec. 2.4) *)
Section HigherOrder.

  (** Non-Interference (Sec. 2.4.2) *)
  Section NonInterference.
    (** For simplicity, we define par as a sequential execution of two thunks. *)
    Example par := (tabs (tabs (seq (tapp #1 tunit) (tapp #0 tunit)))).
    (** par inhabits the type shown in the paper, i.e.,

        par : ((a : (Unit => Unit)^{}) => ((b : (Unit => Unit)^{}) => Unit)^{a})^{}
     *)
    Example t_par : forall {Γ Σ φ}, closed_qual 0 (length Γ) (length Σ) φ ->
      has_type Γ φ Σ par ({{TUnit | ∅} ==> {TUnit | ∅} | ∅} ==> {{{TUnit | ∅} ==> {TUnit | ∅} | ∅} ==> {TUnit | ∅} | ##0}) ∅.
      intros. unfold par. apply t_abs; ccrush. apply t_abs; ccrush. eapply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      * replace (∅) with (openq ∅ ∅); try solve [opening;crush].
        eapply t_app with (df:=$$(length Γ)); ccrush; intuition.
        - T_VAR; ccrush.
        - apply t_base; ccrush.
      * replace (∅) with (openq ∅ ∅); try solve [opening;crush].
        eapply t_app with (df:=$$(S (length Γ))); ccrush; intuition.
        - T_VAR; ccrush.
        - apply t_base; ccrush.
    Qed.

    Variables (Γ : tenv) (Σ : senv) (φ : qual).
    Context (phiwf : closed_qual 0 (length Γ) (length Σ) φ).

    (**
        OK use of par:
        val c1 = new Ref(unit); val c2 = new Ref(unit); par { !c1 } { ! c2 }
    *)
    Example noninterfering := (val (tref tunit)
                                  (val (tref tunit)
                                      (tapp (tapp par (tabs !(#2))) (tabs !(#1))))).

    Example noninterfering_ty : has_type Γ φ Σ noninterfering TUnit ∅.
      unfold noninterfering. replace (∅) with (openq ∅ ∅); try solve [opening;crush].
      eapply t_val with (T1:=TRef TUnit) (df:=∅); crush.
      apply t_ref with (d:=∅). apply t_base. crush.
      unfold open_tm'. repeat rewrite open_val. replace (openq' Γ ∅) with (openq ∅ ∅); try solve [opening; crush].
      eapply t_val with (df:=$$(length Γ)) (T1:=TRef TUnit); ccrush.
      * eapply t_ref; ccrush. apply t_base; ccrush.
      * replace (∅) with (openq $$(S (length Γ)) ∅) at 3; try solve [opening;crush].
          eapply t_app with (T1:=({TUnit | ∅} ==> {TUnit | ∅})) (df:=$$(length Γ)); ccrush.
          + replace ($$(length Γ)) with (openq $$(length Γ) ##0); try solve [opening;crush].
            eapply t_app with (df:=∅); ccrush.
            ** fold (seq (tapp #1 tunit) (tapp #0 tunit)). fold par. eapply t_par; ccrush.
            ** apply t_abs; ccrush. eapply t_deref with (d:=$$(length Γ)); T_VAR; ccrush.
          + apply t_abs; ccrush. eapply t_deref with (d:=$$(S (length Γ))); T_VAR; ccrush.
        Unshelve. all : apply 0.
    Qed.

    (**
        Bad use of par:
        val c1 = new Ref(unit); val c2 = new Ref(unit); par { !c1; !c2 } { !c1; !c2 }
    *)
    Example interfering := (val (tref tunit)
                               (val (tref tunit)
                                   (tapp (tapp par (tabs (seq !(#2) !(#1)))) (tabs (seq !(#2) !(#1)))))).

    (** first, let's type the following subterm: *)
    Example aux1 : has_type [(TRef TUnit, ∅) ; (TRef TUnit, ∅)] ($$0 ⊔ $$1) [] (tabs (seq !($0) !($1))) ({TUnit | ∅} ==> {TUnit | ∅}) ($$0 ⋓ $$1).
      apply t_abs; ccrush. eapply t_seq with (q1:=∅); ccrush.
      * eapply t_deref. T_VAR; ccrush.
      * eapply t_deref. T_VAR; ccrush.
    Qed.

    (** now, show that interfering can't be typed *)
    Example interfering_bad : exists S q, has_type [(TRef TUnit, ∅) ; (TRef TUnit, ∅)] ($$0 ⊔ $$1) []
                                          (tapp (tapp par (tabs (seq !($0) !($1)))) (tabs (seq !($0) !($1)))) S q.
      eexists. eexists. eapply t_app. 2: eapply aux1.
      eapply t_app. 2: eapply aux1.
      (* from t_par we know 1) df = ∅ and 2) d20 = ##0, and
         3) openq ($$ (0) ⊔ $$ (1)) ?d20 ⋒ ($$ (0) ⊔ $$ (1)) = ∅.

         However, 2), and 3) together are unsatisfiable:
      *)
      assert (((openq ($$ (0) ⊔ $$ (1)) ##0) ⋒ ($$ (0) ⊔ $$ (1))) = ($$ (0) ⊔ $$ (1))). {
        opening. simpl. qdec.
      }
    Abort.

  End NonInterference.

  (** Non-Escaping (Sec. 2.4.3) *)
  Section NonEscape.
    (** Assume a Nothing type, a.k.a. the empty type, being a subtype of all types: *)
    Variable (Nothing : ty).
    Context (s_nothing : forall Γ Σ T q1 q2, qstp Γ Σ q1 q2 -> stp Γ Σ Nothing q1 T q2)
            (cl_nothing : closed_ty 0 0 0 Nothing).
    (** Assume an effects as capabilities model. The capability type for throwing (Unit-valued) exceptions is a function Unit => Nothing: *)
    Context (CanThrow := (TFun ∅ ∅ TUnit Nothing))
            (cl_canthrow : closed_ty 0 0 0 CanThrow).
    (** Assume we can allocate fresh capabilities for throwing exceptions: *)
    Variable (mkThrow : tm).
    Context (t_mkThrow : forall Γ φ Σ, closed_qual 0 (length Γ) (length Σ) φ -> has_type Γ φ Σ mkThrow CanThrow ∅).

    (** The try combinator, this one allocates a fresh capability and passes it to the given block:

           def try_(block) = val throw = mkThrow; block(throw)
     *)
    Example try_ := (tabs (val mkThrow (tapp #1 #0))).

    (** The type of the try combinator, encoding polymorphism as metalevel quantification.

            try : forall A. ((CanThrow^∅ => A^∅)^∅ => A^∅)^∅
       *)
    Example try_ty : forall A Γ φ Σ,
        closed_qual 0 (length Γ) (length Σ) φ ->
        closed_ty 0 (length Γ) (length Σ) A ->
        has_type Γ φ Σ try_ ({{CanThrow | ∅} ==> {A | ∅} | ∅} ==> {A | ∅}) ∅.
      intros. unfold try_. specialize (t_mkThrow _ _ _ H) as H'.
      apply t_abs; ccrush. replace (∅) with (openq ∅ ∅) at 4; try solve [opening].
      eapply t_val with (df:=$$(length Γ)); ccrush.
      * apply t_mkThrow; ccrush.
      * replace (∅) with (openq $$(S (length Γ)) ∅) at 5; try solve [opening].
        eapply t_app with (T1:=CanThrow) (df:=$$(length Γ)); ccrush.
        - T_VAR; ccrush.
        - T_VAR; ccrush.
    Qed.

    Variable (Σ : senv).
    Context (c1 := 0) (Γ := [(TRef TUnit,∅)]).
    (** This block

           { throw => !c1 ; throw () }

       demonstrates a legal use of capabilities. *)
    Example nonescaping := (tabs (seq !($c1) (tapp #0 tunit))).

    (** Using the nonescaping block with try is indeed well-typed. *)
    Example nonescaping_ok : has_type Γ $$c1 Σ (tapp try_ nonescaping) TUnit ∅.
      unfold nonescaping. subst c1.
      replace (∅) with (openq $$0 ∅); try solve [opening; auto].
      assert (Hf : closed_qual 0 (length Γ) (length Σ) $$0); crush. apply t_mkThrow in Hf.
      eapply t_app with (df:=∅); ccrush.
      * eapply try_ty; crush.
      * subst Γ. apply t_abs; ccrush.
        apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
        + apply t_deref with (d:=$$0); ccrush.
          T_VAR; ccrush.
        + replace (∅) with (openq ∅ ∅) at 3; try solve [opening; auto].
          eapply t_app with (T1:=TUnit) (df:=$$1); ccrush.
          - apply t_sub with (T1:=CanThrow) (d1:=$$1); ccrush.
            ** subst CanThrow. T_VAR; ccrush.
            ** subst CanThrow. repeat (constructor; ccrush).
          - apply t_base; ccrush.
    Qed.

    (** In constrast, this block

            { throw => !c1 ; { () => throw () } }

       returns a closure over the capability, which is rejected by try. *)
    Example escaping := (tabs (seq !($c1) (tabs (tapp #1 tunit)))).
    (** First, the type of escaping indeed leaks the capability:

            escaping : ((c: CanThrow^{}) => (Unit => Unit)^{c})^{c1}
      *)
    Example escaping_ty : has_type Γ $$c1 Σ escaping ({CanThrow | ∅} ==> {{TUnit | ∅} ==> {TUnit | ∅} | ##0}) $$c1.
      unfold escaping. subst c1. subst Γ.
      apply t_abs; ccrush.
      apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      * apply t_deref with (d:=$$0); ccrush.
        T_VAR; ccrush.
      * apply t_abs; ccrush. replace (∅) with (openq ∅ ∅) at 4; try solve [opening; auto].
        eapply t_app with (T1:=TUnit) (df:=$$1); ccrush.
        + apply t_sub with (T1:=CanThrow) (d1:=$$1); ccrush.
          - T_VAR; ccrush.
          - unfold CanThrow. repeat (constructor; ccrush).
        + apply t_base; ccrush.
    Qed.
    (** Now suppose we could type the following application: *)
    Example escaping_bad : exists S q, has_type Γ $$c1 Σ (tapp try_ escaping) S q.
      eexists. eexists. eapply t_app with (df:=∅). 2: eapply escaping_ty. cleanup.
      * (* We have a typing mismatch: *)
        Fail eapply try_ty.
        (* try_ requires that the block `escaping` returns a disjoint function, but the type of `escaping` is
           dependent on its capability argument.  *)
    Abort.

  End NonEscape.

  (** Non-Accessibility (Sec. 2.4.4) *)
  Section NonAccess.
    (** Assume primitives for doing IO effects via a (global) capability. *)
    Variables (CanIO : ty) (doIO : tm).
    Context (cl_CanIO : closed_ty 0 0 0 CanIO)
            (t_doio  : forall Γ φ Σ, has_type Γ φ Σ doIO ({CanIO | ∅} ==> {TUnit | ∅}) ∅)
            (cl_doIO : closed_tm 0 0 0 doIO).

    Example withoutIO := (tabs (tabs (tapp #0 tunit))).
    (** The type of the withoutIO combinator, encoding polymorphism as metalevel quantification.

            withoutIO : forall A. ((cap: CanIO^∅) => ((block : (Unit => A^∅)^∅) => A^∅))^{cap})^∅
      *)
    Example t_withoutIO : forall A Γ φ Σ,
        closed_qual 0 (length Γ) (length Σ) φ ->
        closed_ty 0 (length Γ) (length Σ) A ->
        has_type Γ φ Σ withoutIO ({CanIO | ∅} ==> {{{TUnit | ∅} ==> {A | ∅} | ∅} ==> {A | ∅}| ##0}) ∅.
      intros. unfold withoutIO.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      replace (∅) with (openq ∅ ∅) at 5; try solve [opening; auto].
      apply t_app with (T1:=TUnit) (df:=$$(S (length Γ))); ccrush.
      * T_VAR; ccrush.
      * apply t_base; ccrush.
    Qed.

    #[local] Hint Unfold just_fv : core.

    (* Γ := canIO : CanIO^{canIO}; c1 : Ref[Unit]^{c1} *)
    Context (canIO := 0)
            (c1 := 1)
            (Γ := [(TRef TUnit, ∅); (CanIO, ∅)])
            (φ := $$canIO ⊔ $$c1)
            (Σ : senv).
    (** An OK use of withoutIO.

            withoutIO(canIO) { !c1 }
      *)
    Example withoutIO_ok  := (tapp (tapp withoutIO $canIO) (tabs !($c1))).
    Example withoutIO_ok_ty : has_type Γ φ Σ withoutIO_ok TUnit ∅.
      unfold withoutIO_ok. subst c1. subst canIO. subst Γ. subst φ.
      replace (∅) with (openq $$1 ∅) at 3; try solve [opening; auto].
      apply t_app with (T1:=({TUnit | ∅} ==> {TUnit | ∅})) (df:=$$0); ccrush.
      * replace ($$0) with (openq $$0 ##0); try solve [opening; auto].
        apply t_app with (T1:=CanIO) (df:=∅); ccrush.
        + apply t_withoutIO; ccrush.
        + T_VAR; ccrush.
      * apply t_abs; ccrush.
        eapply t_deref. T_VAR; ccrush.
    Qed.

    (** A bad use of withoutIO.

            withoutIO(canIO) { !c1; doIO(canIO) }
      *)
    Example withoutIO_bad := (tapp (tapp withoutIO $canIO) (tabs (seq !($c1) (tapp doIO $canIO)))).
    (* First, consider the block's type
           { !c1; doIO(canIO) } : (Unit => Unit)^{c1,canIO} *)
    Example withoutIO_bad_block_ty : has_type [(TRef TUnit, ∅); (CanIO, ∅)] ($$0 ⊔ $$1) Σ (tabs (seq !($1) (tapp doIO $0))) ({TUnit | ∅} ==> {TUnit | ∅}) ($$0 ⊔ $$1).
      apply t_abs; ccrush. apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
      * eapply t_deref. T_VAR; ccrush.
      * replace (∅) with (openq $$0 ∅) at 4; try solve [opening; auto].
        eapply t_app with (df:=∅); ccrush.
        T_VAR; ccrush.
    Qed.
    (* then, suppose we can assign a type to withoutIO_bad: *)
    Example withoutIO_bad_ty : exists S q, has_type Γ φ Σ withoutIO_bad S q.
      specialize withoutIO_bad_block_ty as Hblk. eexists. eexists.
      unfold withoutIO_bad.
      eapply t_app. eapply t_app.
      (* first, let's type these subexpressions, which is easy: *)
      2: T_VAR; ccrush. 5: apply withoutIO_bad_block_ty.
      (* matching against t_withoutIO, we have
         1) df = ∅, 2) d20 = ##0, and 3) openq (∅ ⊕ canIO) ?d20 ⋒ ($$ (0) ⋓ $$ (1)) = ∅
         However, these constraints are unsatisfiable, i.e., the overlap is not disjoint
      *)
      assert (openq  (∅ ⊕ canIO) ##0 ⋒ ($$ (0) ⊔ $$ (1)) = $$canIO). {
        subst canIO. opening. ccrush. unfold just_fv. f_equal. fnsetdec.
      }
    Abort.

  End NonAccess.

  (** Borrowing (Sec. 2.4.5) *)
  Section Borrowing.
    (**
        borrow[A,B] : ((x : A^∅) => ((block: (A^∅ => B^∅)^∅) => B^∅)^{x})^∅
     *)
    Example borrow := (tabs (tabs (tapp #0 #1))).
    Example TBorrow A B := ({A | ∅} ==> {{{A | ∅} ==> {B | ∅} | ∅} ==> {B | ∅} | ##0}).
    Example t_borrow : forall {Γ φ Σ A B},
      closed_qual 0 (length Γ) (length Σ) φ ->
      closed_ty 0 (length Γ) (length Σ) A ->
      closed_ty 0 (length Γ) (length Σ) B ->
      has_type Γ φ Σ borrow (TBorrow A B) ∅.
      intros. unfold borrow. unfold TBorrow.
      apply t_abs; ccrush.
      apply t_abs; ccrush.
      replace (∅) with (openq $$(length Γ) ∅) at 5; try solve [opening; ccrush; auto].
      eapply t_app with (T1:=A) (df:=$$(S (length Γ))); ccrush.
      * T_VAR; ccrush.
      * T_VAR; ccrush.
    Qed.

    (* Γ = c1 : Ref[Unit]^{c1} *)
    Context (c1 := 0)
            (Γ := [(TRef TUnit, ∅)])
            (φ := (just_fv c1))
            (Σ : senv).

    (** An OK use of borrow:

            borrow(c1) { c2 => !c2 }
      *)
    Example borrow_ok  := (tapp (tapp borrow $c1) (tabs !(#0))).
    Example borrow_ok_ty : has_type Γ φ Σ borrow_ok TUnit ∅.
      unfold borrow_ok. subst c1. subst Γ. subst φ.
      replace (∅) with (openq ∅ ∅) at 2; try solve [opening; auto].
      apply t_app with (T1:=({(TRef TUnit) | ∅} ==> {TUnit | ∅})) (df:=$$0); ccrush; intuition.
      * replace $$0 with (openq $$0 ##0) at 2; try solve [opening; ccrush; auto].
        apply t_app with (T1:=(TRef TUnit)) (df:=∅); ccrush.
        + apply t_borrow; ccrush.
        + T_VAR; ccrush.
      * apply t_abs; ccrush.
        eapply t_deref; ccrush.
        T_VAR; ccrush.
    Qed.

    (** A bad use of borrow:

            borrow(c1) { c2 => !c1 } // error c1 not directly accessible
      *)
    Example borrow_bad := (tapp (tapp borrow $c1) (tabs !($c1))).
    (* first, consider the type of the block : *)
    Example borrow_bad_block_ty : has_type Γ φ Σ (tabs !($c1)) ({TRef TUnit | ∅} ==> {TUnit | ∅}) $$c1.
      subst c1. subst Γ. subst φ.
      apply t_abs; ccrush.
      eapply t_deref.
      T_VAR; ccrush.
    Qed.
    (* now suppose this is typable: *)
    Example borrow_bad_ty : exists S q, has_type Γ φ Σ borrow_bad S q.
      eexists. eexists. unfold borrow_bad.
      (* both the function and argument of the application alias c1... *)
      apply t_app with (T1:={(TRef TUnit) | ∅} ==> {TUnit | ∅}) (df:=$$c1) (d1:=$$c1). (* ... which means the block function expected by borrow(c1) must alias c1 too *)
      2 : eapply borrow_bad_block_ty.
      replace $$c1 with (openq $$c1 ##0) at 3; try solve [opening; auto].
      eapply t_app with (T1:=TRef TUnit) (df:=$$c1).
      2 : T_VAR; ccrush. cleanup.
      (* However, instantiating borrow's type reveals that the block parameter needs to be separate (i.e. it is empty).*)
      specialize @t_borrow with (A:=(TRef TUnit)) (B:=TUnit) as HBorrow.
      unfold TBorrow in HBorrow. cleanup.
      (* Thus we cannot assign borrow's type (and neither use subsumption, due to the negative occurrence of c1) *)
      Fail eapply HBorrow.
    Abort.

  End Borrowing.

End HigherOrder.

(** Lightweight Reachability Polymorphism (Sec. 3.4) *)
Section LightweightPoly.

  (** Since this version of the calculus lacks numbers, we
      demonstrate reachability polymorphism on an equivalent example:

          def inclike(x) = { x := !x; x }
   *)
  Example inclike := (tabs (seq (tassign (#0) !(#0)) #0)).
  (** inclike : ((x : Ref[Unit])^∅) => Ref[Unit]^{x})^∅ *)
  Example inclike_ty : forall Γ φ Σ,
      closed_qual 0 (length Γ) (length Σ) φ ->
      has_type Γ φ Σ inclike ({TRef TUnit | ∅} ==> {TRef TUnit | ##0}) ∅.
    intros. unfold inclike.
    apply t_abs; ccrush.
    eapply t_seq with (q1:=∅); ccrush.
    * eapply t_assign.
      T_VAR.
      eapply t_deref. T_VAR; ccrush.
    * T_VAR; ccrush.
  Qed.

  (** Γ := a : Ref[Unit]^{a} ; b : Ref[Unit]^{b} ; c1 : Ref[Unit]^{a,b,c1} ; c2 : Ref[Unit]^{a,b,c1,c2} *)
  Context (a := 0) (b := 1) (c1 := 2) (c2 := 3)
          (Γ := [(TRef TUnit, ($$a ⊔ $$b ⊔ $$c1)) ;
                 (TRef TUnit, ($$a ⊔ $$b)) ;
                 (TRef TUnit, ∅) ;
                 (TRef TUnit, ∅)] )
          (φ := ($$a ⊔ $$b ⊔ $$c1 ⊔ $$c2)).
  Variable (Σ : senv).

  Lemma saturated_abc1 : saturated Γ Σ ($$a ⊔ $$b ⊔ $$c1).
    replace ($$ (a) ⊔ $$ (b) ⊔ $$ (c1)) with (($$ (a) ⊔ $$ (b)) ⊕ c1).
    eapply saturated_qplus; ccrush. ccrush.
  Qed.
  #[local] Hint Resolve saturated_abc1 : core.

  Lemma saturated_phi : saturated Γ Σ ($$a ⊔ $$b ⊔ $$c1 ⊔ $$c2).
    replace ($$ (a) ⋓ $$ (b) ⋓ $$ (c1) ⋓ $$ (c2)) with (($$ (a) ⋓ $$ (b) ⋓ $$ (c1)) ⊕ c2).
    eapply saturated_qplus; ccrush. ccrush.
  Qed.
  #[local] Hint Resolve saturated_phi : core.

  (** inclike(b) : Ref[Unit]^{b} *)
  Example inc1 : has_type Γ φ Σ (tapp inclike $b) (TRef TUnit) $$b.
    intros. replace $$b with (openq $$b ##0); try solve [opening; auto].
    eapply t_app with (df:=∅); ccrush.
    * apply inclike_ty; crush.
    * T_VAR; ccrush.
  Qed.

  (** inclike(c1) : Ref[Unit]^{a,b,c1} *)
  Example inc2 : has_type Γ φ Σ (tapp inclike $c1) (TRef TUnit) ($$a ⊔ $$b ⊔ $$c1).
    intros. replace ($$a ⊔ $$b ⊔ $$c1) with (openq (($$a ⊔ $$b) ⊔ $$c1) ##0);
              try solve [opening;crush].
    eapply t_app with (df:=∅); ccrush.
    * apply inclike_ty; crush.
    * T_VAR; ccrush.
  Qed.

  (** inclike(c2) :  Ref[Unit]^{a,b,c1,c2} *)
  Example inc3 : has_type Γ φ Σ (tapp inclike $c2) (TRef TUnit) ($$a ⊔ $$b ⊔ $$c1 ⊔ $$c2).
    intros. replace ($$a ⊔ $$b ⊔ $$c1 ⊔ $$c2)
            with (openq (($$a ⊔ $$b ⊔ $$c1) ⊔ $$c2) ##0);
              try solve [opening;crush].
    eapply t_app with (df:=∅); ccrush.
    * apply inclike_ty; crush.
    * T_VAR; ccrush.
  Qed.

End LightweightPoly.


Require Import MathClasses.interfaces.abstract_algebra.

Section MonoidalRestriction.
  Context A {Ae : Equiv A}.

  (* Predicate on type [A] *)
  Class SgPred A := sg_P: A → Prop.

  (* Restriction of monoid operator and unit values *)
  Class MonRestriction {Aop : SgOp A} {Aunit : MonUnit A} {Apred: SgPred A}: Prop :=
    { rmonoid_unit_P: sg_P mon_unit
      ; rmonoid_plus_closed: forall a b, sg_P a -> sg_P b -> sg_P (a & b)
    }.

  Class RMonoid {Aop : SgOp A} {Aunit : MonUnit A} {Apred: SgPred A} :=
    {  sg_setoid :> Setoid A
       ; mon_restriction :> MonRestriction
       ; rsg_op_proper :> Proper ((=) ==> (=) ==> (=)) (&)

       ; rmonoid_ass: forall x y z,
           sg_P x -> sg_P y -> sg_P z -> x & (y & z) = (x & y) & z
       ; rmonoid_left_id : forall y, sg_P y -> mon_unit & y = y
       ; rmonoid_right_id : forall x, sg_P x -> x & mon_unit = x
    }.

  Class CommutativeRMonoid {Aop Aunit Ares} : Prop :=
    {
      comrmonoid_rmon :> @RMonoid Aop Aunit Ares
      ; rcommutativity: forall x y, sg_P x -> sg_P y -> x & y = y & x
    }.

  Global Instance ATT: SgPred A := fun _ => True.

  Global Instance ATT_proper:
    Proper (equiv ==> impl) ATT.
  Proof.
    intros x y E.
    unfold ATT, impl.
    tauto.
  Qed.

  (* A regular [CommutativeMonoid] with predicate which is always [True]
     is a [CommutativeRMonoid] *)
  Global Instance Monoid2CommutativeRMonoid
         `{@CommutativeMonoid _ _ Aop Aunit}:
    @CommutativeRMonoid Aop Aunit ATT.
  Proof.
    split.
    -
      split.
      + apply H.
      +
        split.
        cbv; tauto.
        intros a b _ _.
        cbv; tauto.
      +
        apply H.
      +
        intros x y z _ _ _.
        apply sg_ass, H.
      +
        intros y _.
        apply monoid_left_id, H.
      +
        intros y _.
        apply monoid_right_id, H.
    -
      intros x y H0 H1.
      apply commutativity.
  Qed.

End MonoidalRestriction.

Arguments rsg_op_proper {A Ae Aop Aunit Apred RMonoid}.


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

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

Print Assumptions square.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable sQ_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable rE_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.

Variable lemma_squareparallelogram_1 : (forall A B C D : Universe, (sQ_ A B C D -> pG_ A B C D)).
Variable defsquare_2 : (forall A B C D : Universe, (sQ_ A B C D -> (cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))))).
Variable defsquare2_3 : (forall A B C D : Universe, ((cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))) -> sQ_ A B C D)).
Variable lemma_PGrectangle_4 : (forall A B C D : Universe, ((pG_ A C D B /\ per_ B A C) -> rE_ A C D B)).

Theorem lemma_squarerectangle_5 : (forall A B C D : Universe, (sQ_ A B C D -> rE_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Category.
Require Export Category.Theory.Isomorphism.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* A Groupoid is a category where all morphisms are isomorphisms, and morphism
   equivalence is equivalence of isomorphisms. *)

Program Definition Groupoid (C : Category) : Category := {|
  obj     := @obj C;
  hom     := @Isomorphism C;
  homset  := @isomorphism_setoid C;
  id      := @iso_id C;
  compose := @iso_compose C
|}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

Variable defcollinear_1 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_2 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_3 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_4 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_5 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_6 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_7 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable axiom_betweennesssymmetry_8 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).

Theorem lemma_collinear2_9 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Proof.
  time tac.
Qed.

End FOFProblem.


From HTTP2.HPACK Require Import HPACKTypes HPACKTables.
From Coq Require Import BinNat List Logic String Ascii Basics Recdef.
Import ListNotations.
Require Coq.Program.Tactics.
Require Coq.Program.Wf.
Open Scope list_scope.
Open Scope N_scope.
Open Scope program_scope.

(* https://tools.ietf.org/html/rfc7541#section-5.1

   encodes an unsigned integer i with a prefix of n bits.
   Returns a list of bools. This could be changed in the future,
   but for now since the result varies in length depending on
   the value of i, this might be the best approach.

   Pseudocode to represent an integer I is as follows:

   if I < 2^N - 1, encode I on N bits
   else
       encode (2^N - 1) on N bits
       I = I - (2^N - 1)
       while I >= 128
            encode (I % 128 + 128) on 8 bits
            I = I / 128
       encode I on 8 bits *)
Fixpoint encode_N_help (i:N) (n:nat) : list bool :=
  match n with
  | O => []
  | S n' =>
    (if (N.shiftr_nat i n') mod 2 =? 0 then false else true) :: encode_N_help i n'
  end.

Function encode_N_help_rec (i:N) {wf (N.lt) i } : list bool :=
  match i <? 128 with
  | true => encode_N_help i 8
  | _ =>
    encode_N_help ((i mod 128) + 128) 8
                  ++ encode_N_help_rec (i / 128)
  end.
Proof.
  intros.
  pose proof (N.ltb_lt i 128); pose proof not_iff_compat; apply H0 in H;
    assert ((i <? 128) <> true).
    intros contra; rewrite contra in teq; inversion teq.
    rewrite H in H1. rewrite N.nlt_ge in H1; apply N.div_lt;
      try (compute; reflexivity); eapply (N.lt_le_trans _ 128);
        eauto; compute; reflexivity.
  apply N.lt_wf_0.
Defined.

(* Encodes as list of bools (binary number in msb) *)
Fixpoint encode_N (i:N) (n:nat) : list bool :=
  if i <? 2^(N.of_nat n)-1
  then encode_N_help i n
  else encode_N_help (2^(N.of_nat n) - 1) n
       ++ encode_N_help_rec (i - (2^(N.of_nat n) - 1)).

(* https://tools.ietf.org/html/rfc7541#section-5.2 *)
(* Convert string to list of bools (binary number in msb) *)
Fixpoint string_to_bool_list (s:string) : list bool :=
  match s with
  | EmptyString => []
  | String (Ascii b7 b6 b5 b4 b3 b2 b1 b0) s' =>
    b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: string_to_bool_list s'
  end.

Fixpoint huffman_string (s:string) : list bool :=
  match s with
  | EmptyString => []
  | String a s' =>
    match find (fun x => BinNatDef.N.eqb (N_of_ascii a) (fst x)) huffman_table with
    | None => [] (* Unreachable *)
    | Some l => snd l
    end ++ huffman_string s'
  end.

(* Encodes as list of bools (binary number in msb) *)
Definition encode_string (H:bool) (s:string) : list bool :=
  H ::
    if H then
      let y := huffman_string s in
      let x := N.of_nat (List.length y) in
      let len := x / 8 in
      encode_N (len + 1) 7 ++ y ++
               if x mod 8 =? 0 then repeat true (N.to_nat 8)
               else repeat true (N.to_nat (8 - (x mod 8)))
    else encode_N (N.of_nat (length s)) 7 ++ string_to_bool_list s.

(* https://tools.ietf.org/html/rfc7541#section-6.1 *)
Definition encode_IndexedHF (i:N) : list bool :=
  true :: encode_N i 7.

(* https://tools.ietf.org/html/rfc7541#section-6.2.1 *)
Definition encode_LHFIncrementIndexedName (i1:N) (H:bool) (s2:string) : list bool :=
  false :: true :: encode_N i1 6
        ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.2.1 *)
Definition encode_LHFIncrementNewName (H:bool) (s1:string)
           (s2:string) : list bool :=
  encode_N 64 8 ++ encode_string H s1 ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.2.2 *)
Definition encode_LHFWithoutIndexIndexedName (i1:N) (H:bool) (s2:string) : list bool :=
  false :: false :: false :: false :: encode_N i1 4
        ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.2.2 *)
Definition encode_LHFWithoutIndexNewName (H:bool) (s1:string)
           (s2:string) : list bool :=
  encode_N 0 8 ++ encode_string H s1 ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.2.3 *)
Definition encode_LHFNeverIndexIndexedName (i1:N) (H:bool) (s2:string) : list bool :=
  false :: false :: false :: true :: encode_N i1 4
        ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.2.3 *)
Definition encode_LHFNeverIndexNewName (H:bool) (s1:string)
           (s2:string) : list bool :=
  encode_N 16 8 ++ encode_string H s1 ++ encode_string H s2.

(* https://tools.ietf.org/html/rfc7541#section-6.3 *)
Definition encode_DTableSizeUpdate (i:N) : list bool :=
  false :: false :: true :: encode_N i 5.

Fixpoint pack_list_bool (b:list bool) : string :=
  match b with
  | b7 :: b6 :: b5 :: b4 :: b3 :: b2 :: b1 :: b0 :: tl =>
    String (Ascii b0 b1 b2 b3 b4 b5 b6 b7) (pack_list_bool tl)
  | _ => ""
  end.

(* https://tools.ietf.org/html/rfc7541#section-6 *)
(* H corresponds to whether huffman encoding is being used *)
Definition encode_HFR (H:bool) (hfr:HeaderFieldRepresentation) : string :=
  pack_list_bool (match hfr with
                  | IndexedHF i => encode_IndexedHF i
                  | LHFIncrementIndexedName i s2 =>
                    encode_LHFIncrementIndexedName i H s2
                  | LHFIncrementNewName s1 s2 =>
                    encode_LHFIncrementNewName H s1 s2
                  | LHFWithoutIndexIndexedName i s2 =>
                    encode_LHFWithoutIndexIndexedName i H s2
                  | LHFWithoutIndexNewName s1 s2 =>
                    encode_LHFWithoutIndexNewName H s1 s2
                  | LHFNeverIndexIndexedName i s2 =>
                    encode_LHFNeverIndexIndexedName i H s2
                  | LHFNeverIndexNewName s1 s2 =>
                    encode_LHFNeverIndexNewName H s1 s2
                  | DTableSizeUpdate i => encode_DTableSizeUpdate i
                  end).

(* H corresponds to whether huffman encoding is being used *)
Definition encode_HB  (H:bool) (hb: HeaderBlock) : string :=
  fold_left String.append (map (encode_HFR H) hb) "".


Require Import Coq.Init.Prelude.

Fixpoint fnd (n : nat) : Prop :=
  match n with
  | O => True
  | S n => True /\ fnd n
  end.

Goal fnd 1000. Time repeat econstructor. Time Qed.
(*
Finished transaction in 1.187 secs (1.128u,0.051s) (successful)
Finished transaction in 1.671 secs (1.659u,0.003s) (successful)
*)


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo123 : prime 8574079.
Proof.
 apply (Pocklington_refl
         (Pock_certif 8574079 3 ((62131, 1)::(2,1)::nil) 1)
        ((Pock_certif 62131 2 ((5, 1)::(3, 1)::(2,1)::nil) 26) ::
         (Proof_certif 5 prime5) ::
         (Proof_certif 3 prime3) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e480m2e240m1_8limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_parallelflip_1 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_crisscross_2 : (forall A B C D : Universe, ((par_ A C B D /\ ~(cR_ A B C D)) -> cR_ A D B C)).
Variable defcross_3 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_4 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable axiom_betweennesssymmetry_5 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_Playfairhelper2_6 : (forall A B C D E : Universe, ((par_ A B C D /\ (par_ A B C E /\ cR_ A D B C)) -> col_ C D E)).

Theorem lemma_Playfair_7 : (forall A B C D E : Universe, ((par_ A B C D /\ par_ A B C E) -> col_ C D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import SMlib.
Require Import Coq.Lists.List.
Import ListNotations.

(* 2.1.1 *)
Definition Tau (A : N) : N :=
  (Sbox ((land A (255 <<< 24)) >>> 24)) <<< 24 +
  (Sbox ((land A (255 <<< 16)) >>> 16)) <<< 16 +
  (Sbox ((land A (255 <<< 8)) >>> 8)) <<< 8 +
  (Sbox (land A 255)).

(* 2.1.2 *)
Definition L (B : N) : N :=
  B $ B <<< 2 $ B <<< 10 $ B <<< 18 $ B <<< 24.

(* 4(1) *)
Definition L' (B : N) : N :=
  B $ B <<< 13 $ B <<< 23.

Definition T (A : N) : N := L (Tau A).
Definition T' (A : N) : N := L' (Tau A).

Definition F (A : N) (B : N) (C : N) (D : N) (E : N) : N :=
  A $ (T (B $ C $ D $ E)).

Definition X_list_init (x : N) : list N :=
  [(shiftr x (word_size * 0)) /\ mask_ws;
  (shiftr x (word_size * 1)) /\ mask_ws;
  (shiftr x (word_size * 2)) /\ mask_ws;
  (shiftr x (word_size * 3)) /\ mask_ws].

Definition X_list_aux (i : nat)(acc : list N)(rk : nat -> N) : list N :=
  (F (List.nth 3 acc 0) (List.nth 2 acc 0) (List.nth 1 acc 0) (List.nth 0 acc 0) (rk i)) :: acc.
Fixpoint X_list (i : nat)(init : nat)(acc : list N)(rk : nat -> N) :=
  match i with
  | O => acc
  | S i' => X_list i' init (X_list_aux (init - i)%nat acc rk) rk
  end.

Definition List4toN (l : list N) : N :=
  (shiftl (hd 0 l) (word_size * 3)) \/
  (shiftl (nth 1 l 0) (word_size * 2)) \/
  (shiftl (nth 2 l 0) word_size) \/
  (nth 3 l 0).

Definition SM4_enc (i : nat)(x : N) (rk : nat->N) : N :=
  List4toN (firstn 4 (X_list i i (X_list_init x) rk)).

Definition SM4_dec (i : nat)(y : N)(rk : nat -> N) : N :=
  SM4_enc i y (fun (j : nat) => rk(Nat.sub 31 j)).

Definition K_list_init (MK : N) : list N :=
  [(mask_44 MK) $ (FK 3); (mask_34 MK) $ (FK 2);
  (mask_24 MK) $ (FK 1); (mask_14 MK) $ (FK 0)].

Definition K_list_aux (i : nat)(acc : list N) : list N :=
  (nth 3 acc 0) $ (T' ((nth 2 acc 0) $ (nth 1 acc 0)
  $ (nth 0 acc 0) $ (CK (of_nat i))) ) :: acc.

Fixpoint K_list_rec (i : nat)(init : nat)(acc : list N) : list N :=
  match i with
  | O => acc
  | S i' => K_list_rec i' init (K_list_aux (init - i) acc)
  end.

Definition K_list (i : nat)(MK : N) :=
  K_list_rec i i (K_list_init MK).

Definition rk_ext (MK : N) (i : nat) : N := hd 0 (K_list (i + 1) MK).
(*

Definition plain := HexString.to_N("0x0123456789abcdeffedcba9876543210"%string).
Definition key := HexString.to_N("0x0123456789abcdeffedcba9876543210"%string).

Definition cyphertext:= HexString.of_N (SM4_enc 32 plain (rk_ext  key)).
Definition decypheredtext := HexString.of_N (SM4_dec 32 (HexString.to_N cyphertext) (rk_ext key)).
Definition expCypherText := "0x681edf34d206965e86b3e94f536e4246"%string.
Compute cyphertext.
Compute decypheredtext.

Example self_test : expCypherText = cyphertext.
Proof. reflexivity. Qed.
*)


From AC Require Import expression.
From AC Require Import small_step_semantics.
Require Import String.

(*NOTATION*)
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition n : string := "n".
Definition fun0: string := "fun0".
Definition prod5: string := "prod5".

Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.

(*SMALL STEP SEMANTICS*)

Lemma smallstep_pred_succ:forall (n:nat),<{pred (succ n)}> -->* <{n}>.
Proof.
intro n. eapply multi_step. apply ST_pred_step. apply ST_succ. auto.
eapply multi_step. apply ST_pred. simpl. auto. apply multi_refl.
Qed.

(*Test of val*)
Lemma smallstep_val: <{val n = (5*5) ; n * 2}> -->* 50.
Proof.
apply multi_step with (y := <{val n = 25 ; n * 2}>).
apply ST_Let1. apply ST_prod. reflexivity.
eapply multi_step. apply ST_LetValue. apply v_nat.
simpl. apply multi_single. apply ST_prod. reflexivity.
Qed.

Check <{5}>.

(*Test of fun*)
Lemma smallstep_fun: <{fun prod5 [x:Nat] {x * 5} 5}> -->* 25.
Proof.
apply multi_step with (y := <{5*5}>).
- apply ST_AppAbs. apply v_nat.
- apply multi_single. apply ST_prod. reflexivity.
Qed.


Require Import MyTacs HoTT.
Require Import equivalence lemmas nat_lemmas Peano colimit.

Context `{fs : Funext}.
Context `{ua : Univalence}.

Section hProduct.
  Definition a:nat := 12.
  Fixpoint hProduct (Y:Type) (n:nat) : Type :=
    match n with
      |0 => Unit
      |S m => Y /\ (hProduct Y m)
    end.

  Definition proj_hProduct (Y:Type) (n:nat) (P:hProduct Y n) : {p:nat & p < n} -> Y.
    induction n.
    - intros [p H]. apply not_lt_0 in H. destruct H.
    - intros [p H]. simpl in P.
      induction p.
      + exact (fst P).
      + apply le_pred in H. simpl in H.
        exact (IHn (snd P) (p;H)).
  Defined.

  Definition forget_hProduct (Y:Type) (n:nat) (P:hProduct Y (S n)) : {p:nat & p <= n} -> hProduct Y n.
    induction n.
    - intros [p H]. exact tt.
    - intros [p H]. simpl in P.
      induction p.
      + simpl. exact (fst (snd P), snd (snd P)).
      + apply le_pred in H. simpl in H.
        exact (fst P, (IHn (fst (snd P),snd (snd P)) (p;H))).
  Defined.
End hProduct.

Section hPullback.

  Definition char_hPullback {X Y:Type} (f:Y -> X) (n:nat) (P : hProduct Y (S n))
  : Type.
    induction n.
    - exact Unit.
    - simpl in P.
      exact ((f (fst P) = f (fst (snd P))) /\ (IHn (snd P))).
  Defined.

  Definition char_hPullback_inv  {X Y:Type} (f:Y -> X) (n:nat) (P : hProduct Y (S n))
  : Type.
    induction n.
    - exact Unit.
    - simpl in P.
      exact ((IHn (snd P)) /\ (f (fst P) = f (fst (snd P)))).
  Defined.

  Definition forget_char_hPullback {X Y:Type} (f:Y -> X) (n:nat)
             (x : hProduct Y (S (S n)))
             (P : (char_hPullback f (S n) x))
  : forall p:{p:nat & p <= n.+1}, (char_hPullback f n (forget_hProduct Y (S n) x p)).
    intros [p Hp].
    induction (decidable_paths_nat 0 p) as [| a].
    { destruct a0. simpl in *.
      exact (snd P). }

    induction (decidable_paths_nat (S n) p) as [| b].
    { destruct a0. simpl in *.
      induction n.
      simpl in *. exact tt.
      simpl in *.
      split. exact (fst P).
      apply IHn. exact (snd P).
      apply succ_not_0. }

    apply neq_symm in a.
    apply neq_0_succ in a.
    destruct a as [p' Hp'].
    (* destruct Hp'. *)
    assert (l := le_neq_lt _ _ (neq_symm _ _ b) Hp).
    assert (l0 := le_pred _ _ l). simpl in l0. clear b l. simpl in *.
    generalize dependent n. generalize dependent p. generalize dependent p'. induction p'; intros.
    - simpl in *.
      destruct Hp'.
      assert (k := gt_0_succ n l0); destruct k as [k Hk]. destruct Hk. simpl in *.
      split.
      exact (fst P @ (fst (snd P))).
      exact (snd (snd P)).
    - simpl in *.
      destruct Hp'.
      assert (n' := ge_succ_succ (S p') _ l0).
      destruct n' as [n' Hn']. destruct Hn'.
      specialize (IHp' (p'.+1) idpath n' (snd x) (snd P)). simpl. split.
      exact (fst P).
      apply IHp'.
      exact (le_pred _ _ l0).
  Defined.

  (* Definition 7*)
  Definition hPullback {X Y:Type} (f:Y -> X) (n:nat)
  : Type.
    induction n.
    - exact Unit.
    - exact {P : hProduct Y (S n) & (char_hPullback f n P)}.
  Defined.

  Definition proj_pullback {X Y:Type} (f:Y -> X) (n:nat) (P : hPullback f n) : forall p:{p:nat & p < n}, Y.
    apply proj_hProduct.
    induction n. exact P. simpl in *. exact P.1.
  Defined.

  (* This defines the canonical projections between the n+1-pullback of X to the n-pullback of X*)
  Definition forget_hPullback {X Y:Type} (f:Y -> X) (n:nat) (P : hPullback f (S n)) : forall p:{p:nat & p <= n}, hPullback f n.
    intros [p Hp].
    induction n. exact tt.
    exists (forget_hProduct Y (S n) P.1 (p;Hp)).
    apply forget_char_hPullback.
    exact P.2.
  Defined.

End hPullback.

Section Cech_Nerve.

  (* Definition 8*)
  Definition Cech_nerve_graph : graph.
    refine (Build_graph _ _).
    exact nat.
    intros m n.
    exact ((S n = m) /\ (nat_interval m)).
  Defined.

  Definition Cech_nerve_diagram {X Y:Type} (f: Y -> X) : diagram (Cech_nerve_graph).
    refine (Build_diagram _ _ _).
    intro n.
    exact (hPullback f (S n)).
    intros i j.
    intros [p q] a.
    destruct p.
    apply forget_hPullback.
    exact a.
    exact q.
  Defined.

  Definition Cech_nerve_commute {X Y:Type} (f: Y -> X)
  : forall i, (Cech_nerve_diagram f) i -> X.
    intro i. simpl. intro P.
    exact (f (fst P.1)).
  Defined.

  Definition Cech_nerve_pp {X Y:Type} (f: Y -> X)
  : forall i j, forall (g : Cech_nerve_graph i j), forall (x : (Cech_nerve_diagram f) i),
      (Cech_nerve_commute f) _ (diagram1 (Cech_nerve_diagram f) g x) = (Cech_nerve_commute f ) _ x.
    intros i j g x. simpl in *.
    unfold Cech_nerve_commute. simpl.
    destruct g as [p [q Hq]]. destruct p. simpl.
    destruct q; [exact (fst (x.2))^ | reflexivity].
  Defined.

End Cech_Nerve.