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 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) "".


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 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.


Set Implicit Arguments.

Require Import Coq.Structures.DecidableType.
Require Import Coq.FSets.FMapInterface.

Module WFacts_fun (E:DecidableType)(Import M:WSfun E).

  Require Import Coq.FSets.FMapFacts.

  Module Import P := WProperties_fun E M.
  Import F.

  Section Elt.

    Variable elt:Type.

    Implicit Types m : t elt.
    Implicit Types x y z k : key.
    Implicit Types e v : elt.
    Implicit Types ls : list (key * elt).

    Notation eqke := (@eq_key_elt elt).
    Notation eqk := (@eq_key elt).

    Definition to_map := of_list.

    Definition keys m := List.map (@fst _ _) (elements m).

    Definition find_list k := findA (B := elt) (eqb k).

    Require Import Bedrock.Platform.Cito.GeneralTactics.
    Require Import Bedrock.Platform.Cito.GeneralTactics2.

    Definition NoDupKey := NoDupA eqk.
    Definition InPair := InA eqke.

    Require Import Bedrock.Platform.Cito.Option.

    Lemma NoDup_cons : forall ls k1 v1 k2 v2, NoDupKey ((k1, v1) :: ls) -> InPair (k2, v2) ls -> ~ E.eq k1 k2.
      unfold InPair.
      intros.
      inversion H; subst.
      not_not.
      eapply InA_eqA.
      eapply eqk_equiv.
      Focus 2.
      eapply InA_eqke_eqk.
      2 : eauto.
      eauto.
      unfold eq_key.
      eauto.
      Grab Existential Variables.
      eauto.
    Qed.

    Lemma update_with_empty : forall m, update m (@empty _) = m.
      unfold update; intros.
      rewrite fold_1.
      rewrite elements_empty.
      reflexivity.
    Qed.

    Lemma In_find_list_Some_left : forall k v ls, NoDupKey ls -> InPair (k, v) ls -> find_list k ls = Some v.
    Proof.
      induction ls; simpl; intros.
      eapply InA_nil in H0; intuition.
      inversion H0; subst.
      unfold find_list in *; destruct a; simpl in *.
      destruct H2; simpl in *.
      subst.
      unfold eqb.
      destruct (eq_dec k k0).
      eauto.
      intuition.
      destruct a; simpl in *.
      generalize H2; eapply NoDup_cons in H2; eauto; intro.
      eapply IHls in H1.
      unfold find_list in *; simpl in *.
      unfold eqb in *.
      destruct (eq_dec k k0); intuition.
      eapply E.eq_sym in e0.
      intuition.
      inversion H; subst.
      eauto.
    Qed.

    Lemma In_find_list_Some_right : forall ls k v, NoDupKey ls -> find_list k ls = Some v -> InPair (k, v) ls.
    Proof.
      induction ls; simpl; intros.
      unfold find_list in *; simpl in *.
      discriminate.
      unfold find_list in *; destruct a; simpl in *.
      unfold eqb in *.
      destruct (eq_dec k k0); intuition.
      injection H0; intros; subst.
      left.
      econstructor; simpl; eauto.
      right.
      eapply IHls.
      inversion H; subst.
      eauto.
      eauto.
    Qed.

    Lemma In_find_list_Some : forall ls k v, NoDupKey ls -> (InPair (k, v) ls <-> find_list k ls = Some v).
      split; intros.
      eapply In_find_list_Some_left; eauto.
      eapply In_find_list_Some_right; eauto.
    Qed.

    Lemma In_find_Some : forall k v m, InPair (k, v) (elements m) <-> find k m = Some v.
      split; intros.
      eapply find_1.
      eapply elements_2; eauto.
      eapply find_2 in H.
      eapply elements_1 in H; eauto.
    Qed.

    Lemma None_not_Some : forall a, a = None <-> ~ exists v, a = Some v.
      split; intros.
      intuition.
      openhyp.
      subst.
      discriminate.
      destruct (option_dec a); eauto.
      destruct s.
      contradict H.
      eexists; eauto.
    Qed.

    Lemma option_univalence : forall A a b, a = b <-> forall (v : A), a = Some v <-> b = Some v.
      split; intros.
      subst; split; eauto.
      destruct (option_dec a).
      destruct s.
      subst.
      symmetry.
      eapply H; eauto.
      subst.
      destruct (option_dec b).
      destruct s.
      subst.
      eapply H; eauto.
      eauto.
    Qed.

    Lemma find_list_elements : forall m k, find_list k (elements m) = find k m.
      intros.
      eapply option_univalence.
      intros.
      split; intros.
      eapply In_find_Some.
      eapply In_find_list_Some in H.
      eauto.
      eapply elements_3w.
      eapply In_find_Some in H.
      eapply In_find_list_Some.
      eapply elements_3w.
      eauto.
    Qed.

    Lemma In_find_list_not_None_left : forall ls k, InA E.eq k (List.map (@fst _ _) ls) -> find_list k ls <> None.
    Proof.
      induction ls; simpl; intros.
      eapply InA_nil in H; intuition.
      inversion H; subst.
      unfold find_list in *; destruct a; simpl in *.
      unfold eqb in *.
      destruct (eq_dec k k0); intuition.
      discriminate.
      eapply IHls in H1.
      unfold find_list in *; destruct a; simpl in *.
      destruct (eqb k k0); intuition.
      discriminate.
    Qed.

    Lemma In_find_list_not_None_right : forall ls k, find_list k ls <> None -> InA E.eq k (List.map (@fst _ _) ls).
    Proof.
      induction ls; simpl; intros.
      intuition.
      unfold find_list in *; destruct a; simpl in *.
      unfold eqb in *.
      destruct (eq_dec k k0); intuition.
    Qed.

    Lemma In_find_list_not_None : forall ls k, InA E.eq k (List.map (@fst _ _) ls) <-> find_list k ls <> None.
      intros.
      split.
      eapply In_find_list_not_None_left.
      eapply In_find_list_not_None_right.
    Qed.

    Lemma ex_up : forall A (e : option A),
                    (e = None -> False)
                    -> exists (v : A), e = Some v.
      destruct e; intuition eauto.
    Qed.

    Lemma In_find_not_None : forall k m, find k m <> None <-> In k m.
      unfold In.
      split; intros.
      eapply ex_up in H.
      openhyp.
      eapply find_2 in H.
      eexists; eauto.

      openhyp.
      eapply find_1 in H.
      rewrite H.
      intuition.
      discriminate.
    Qed.

    Lemma In_In_keys : forall k m, In k m <-> InA E.eq k (keys m).
      split; intros.
      eapply In_find_not_None in H.
      eapply In_find_list_not_None.
      rewrite find_list_elements.
      eauto.
      eapply In_find_not_None.
      unfold keys in *.
      eapply In_find_list_not_None in H.
      rewrite find_list_elements in H.
      eauto.
    Qed.

    Lemma add_4 : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m.
      intros.
      eapply option_univalence.
      split; intros.
      eapply find_1.
      eapply add_3; eauto.
      eapply find_2; eauto.
      eapply find_1.
      eapply add_2; eauto.
      eapply find_2; eauto.
    Qed.

    Lemma map_3 : forall B (f : elt -> B) k m, In k m -> In k (map f m).
      intros; eapply map_in_iff; eauto.
    Qed.

    Lemma map_4 : forall B (f : elt -> B) k m, In k (map f m) -> In k m.
      intros; eapply map_in_iff; eauto.
    Qed.

    Lemma find_map : forall B (f : elt -> B) k v m, find k m = Some v -> find k (map f m) = Some (f v).
      intros.
      eapply find_2 in H.
      eapply find_1.
      eapply map_1; eauto.
    Qed.

    Lemma MapsTo_In : forall k v m, MapsTo k v m -> In k m.
      intros; eexists; eauto.
    Qed.

  End Elt.

End WFacts_fun.

Definition sumbool_to_bool A B (x : {A} + {B}) := if x then true else false.

Require Import Bedrock.Platform.Cito.SetoidListFacts.

Require Import Coq.Structures.DecidableTypeEx.

Module UWFacts_fun (E : UsualDecidableType) (Import M : WSfun E).

  Module Import WFacts := WFacts_fun E M.
  Import P.
  Import F.

  Section Elt.

    Variable elt:Type.

    Implicit Types m : t elt.
    Implicit Types x y z k : key.
    Implicit Types e v : elt.
    Implicit Types ls : list (key * elt).

    Notation eqke := (@eq_key_elt elt).
    Notation eqk := (@eq_key elt).

    Require Import Bedrock.Platform.Cito.GeneralTactics.
    Require Import Bedrock.Platform.Cito.GeneralTactics2.

    Lemma eqke_eq : equiv_2 eqke eq.
      split; intros.
      unfold eq_key_elt in *.
      openhyp.
      destruct a; destruct b; simpl in *; subst; eauto.
      subst.
      unfold eq_key_elt in *.
      eauto.
    Qed.

    Lemma InA_eqke_InA_eq : equiv_2 (InA eqke) (InA eq).
      intros; eapply equiv_InA; eapply eqke_eq.
    Qed.

    Lemma InA_eqke_In : forall ls p, InA eqke p ls <-> List.In p ls.
      intros; eapply equiv_2_trans.
      eapply InA_eqke_InA_eq.
      unfold equiv_2; intros; eapply InA_eq_In_iff.
    Qed.

    Notation fst := (@fst _ _).

    Lemma In_fst_elements_In : forall m k, List.In k (List.map fst (elements m)) <-> In k m.
      split; intros.
      eapply InA_eq_In_iff in H.
      eapply In_In_keys in H; eauto.
      eapply InA_eq_In_iff.
      specialize In_In_keys; intros; unfold keys in *; eapply H0; eauto.
    Qed.

    Lemma InA_eqk_elim : forall ls k v, InA eqk (k, v) ls -> exists v', InA eqke (k, v') ls.
      induction ls; simpl; intros.
      eapply InA_nil in H; intuition.
      destruct a; simpl in *.
      inversion H; subst.
      unfold eq_key in *; simpl in *.
      subst.
      eexists.
      econstructor.
      unfold eq_key_elt; simpl in *.
      eauto.
      eapply IHls in H1.
      openhyp.
      eexists.
      econstructor 2.
      eauto.
    Qed.

    Lemma NoDupKey_NoDup_fst : forall ls, NoDupKey ls <-> NoDup (List.map fst ls).
      induction ls; simpl; intros.
      split; intros; econstructor.
      destruct a; simpl in *.
      split; intros.
      inversion H; subst.
      econstructor.
      intuition.
      contradict H2.
      eapply in_map_iff in H0.
      openhyp.
      destruct x; simpl in *.
      subst.
      eapply InA_eqke_eqk.
      eauto.
      eapply InA_eqke_In.
      eauto.
      eapply IHls.
      eauto.

      inversion H; subst.
      econstructor.
      intuition.
      contradict H2.
      eapply InA_eqk_elim in H0.
      openhyp.
      eapply InA_eqke_In in H0.
      eapply in_map_iff.
      eexists.
      split.
      2 : eauto.
      eauto.
      eapply IHls; eauto.
    Qed.

    Lemma MapsTo_to_map : forall k v ls, NoDupKey ls -> List.In (k, v) ls -> MapsTo k v (to_map ls).
      unfold to_map; intros.
      eapply of_list_1.
      eauto.
      eapply InA_eqke_In; eauto.
    Qed.

    Lemma MapsTo_to_map_elim : forall k v ls, NoDupKey ls -> MapsTo k v (to_map ls) -> List.In (k, v) ls.
      unfold to_map; intros.
      eapply InA_eqke_In; eauto.
      eapply of_list_1.
      eauto.
      eauto.
    Qed.

    Definition InKey k ls := List.In k (List.map fst ls).

    Lemma In_to_map : forall ls k, In k (to_map ls) <-> InKey k ls.
      unfold to_map.
      unfold InKey.
      induction ls; simpl; intros.
      eapply empty_in_iff.
      unfold uncurry in *.
      destruct a; simpl in *.
      split; intros.
      eapply add_in_iff in H.
      openhyp.
      eauto.
      right.
      eapply IHls; eauto.
      eapply add_in_iff.
      openhyp.
      eauto.
      right.
      eapply IHls; eauto.
    Qed.

    Lemma NoDupKey_unapp1 : forall ls1 ls2, NoDupKey (ls1 ++ ls2) -> NoDupKey ls1.
      induction ls1; simpl; intuition.
      econstructor.
      econstructor.
      inversion H; subst.
      not_not.
      intuition.
      eapply InA_app_iff; eauto.
      eapply IHls1.
      inversion H; subst; eauto.
    Qed.

    Lemma NoDupKey_unapp2 : forall ls1 ls2, NoDupKey (ls1 ++ ls2) -> NoDupKey ls2.
      induction ls1; simpl; intuition.
      eapply IHls1.
      inversion H; subst; eauto.
    Qed.

    Lemma inkey_app_or : forall k ls1 ls2, InKey k (ls1 ++ ls2) <-> InKey k ls1 \/ InKey k ls2.
      unfold InKey.
      split; intros.
      eapply in_map_iff in H.
      openhyp.
      eapply in_app_or in H0.
      openhyp.
      left.
      eapply in_map_iff; eexists; eauto.
      right.
      eapply in_map_iff; eexists; eauto.
      openhyp.
      eapply in_map_iff in H.
      openhyp.
      subst.
      eapply in_map_iff; eexists; intuition.
      eapply in_map_iff in H.
      openhyp.
      subst.
      eapply in_map_iff; eexists; intuition.
    Qed.

    Definition DisjointKey ls1 ls2 := forall k, ~ (InKey k ls1 /\ InKey k ls2).

    Lemma NoDupKey_app : forall ls1 ls2, NoDupKey ls1 -> NoDupKey ls2 -> DisjointKey ls1 ls2 -> NoDupKey (ls1 ++ ls2).
      unfold DisjointKey.
      induction ls1; simpl; intros.
      eauto.
      econstructor.
      intuition.
      eapply InA_app in H2.
      openhyp.
      inversion H; subst.
      contradiction.
      destruct a; simpl in *.
      eapply H1.
      unfold InKey.
      simpl.
      split; eauto.
      eapply InA_eqk_elim in H2.
      openhyp.
      eapply InA_eqke_In in H2.
      eapply in_map_iff.
      eexists; intuition.
      2 : eauto.
      eauto.
      eauto.
      eapply IHls1.
      inversion H; subst.
      eauto.
      eauto.
      intros.
      firstorder.
    Qed.

    Definition InKey_dec k ls : {InKey k ls} + {~ InKey k ls}.
      unfold InKey.
      eapply in_dec.
      eapply E.eq_dec.
    Defined.

    Definition diff_map ls1 ls2 :=
      let f p := negb (sumbool_to_bool (InKey_dec (fst p) ls2)) in
      List.filter f ls1.

    Lemma diff_NoDupKey : forall ls1 ls2, NoDupKey ls1 -> NoDupKey (diff_map ls1 ls2).
      unfold diff_map.
      induction ls1; simpl; intros.
      eauto.
      unfold sumbool_to_bool in *.
      destruct a; simpl in *.
      destruct (InKey_dec k ls2) in *.
      simpl in *.
      eapply IHls1; inversion H; subst; eauto.
      simpl in *.
      econstructor.
      2 : eapply IHls1; inversion H; subst; eauto.
      intuition.
      inversion H; subst.
      contradict H3.
      eapply filter_InA in H0.
      openhyp.
      eauto.
      eauto.
      unfold Proper; unfold respectful; intros.
      destruct x; destruct y; unfold eq_key in *; simpl in *; subst; eauto.
    Qed.

    Lemma diff_In : forall ls1 ls2 x, InKey x (diff_map ls1 ls2) -> InKey x ls1 /\ ~ InKey x ls2.
      unfold InKey.
      unfold diff_map.
      intros.
      eapply in_map_iff in H.
      openhyp.
      subst.
      eapply filter_In in H0.
      openhyp.
      split.
      eapply in_map_iff.
      eexists; eauto.
      unfold sumbool_to_bool in *.
      destruct (InKey_dec _ _); simpl in *.
      intuition.
      intuition.
    Qed.

    Lemma diff_DisjointKey : forall ls1 ls2, DisjointKey (diff_map ls1 ls2) ls2.
      unfold DisjointKey.
      intros.
      intuition.
      eapply diff_In in H0.
      openhyp.
      intuition.
    Qed.

    Definition Equal_map ls1 ls2 := forall k, find_list k ls1 = find_list k ls2.

    Lemma NoDupKey_diff_union : forall ls1 ls2, NoDupKey ls1 -> NoDupKey ls2 -> NoDupKey (diff_map ls1 ls2 ++ ls2).
      intros.
      eapply NoDupKey_app.
      eapply diff_NoDupKey.
      eauto.
      eauto.
      eapply diff_DisjointKey.
    Qed.

    Lemma In_of_list : forall k ls, NoDupKey ls -> (In k (of_list ls) <-> InKey k ls).
      unfold InKey, In.
      split; intros.
      openhyp.
      eapply of_list_1 in H0; eauto.
      eapply InA_eqke_In in H0.
      eapply in_map_iff.
      eexists; intuition.
      2 : eauto.
      eauto.
      eapply in_map_iff in H0.
      openhyp.
      subst.
      destruct x; simpl in *.
      eapply InA_eqke_In in H1.
      eapply of_list_1 in H1; eauto.
    Qed.

    Lemma of_list_app : forall ls1 ls2, NoDupKey (ls1 ++ ls2) -> Equal (of_list (ls1 ++ ls2)) (update (of_list ls1) (of_list ls2)).
      induction ls1; simpl; intros.
      unfold Equal.
      intros.
      eapply option_univalence.
      split; intros.
      eapply find_1.
      eapply update_mapsto_iff.
      left.
      eapply find_2; eauto.
      eapply find_2 in H0.
      eapply update_mapsto_iff in H0.
      openhyp.
      eapply find_1; eauto.
      eapply empty_mapsto_iff in H0.
      intuition.
      unfold uncurry.
      destruct a; simpl in *.
      unfold Equal.
      intros.
      destruct (eq_dec y k).
      subst.
      erewrite add_eq_o; eauto.
      symmetry.
      eapply find_1.
      eapply update_mapsto_iff.
      right.
      split.
      eapply add_1; eauto.
      inversion H; subst.
      not_not.
      eapply In_of_list in H0.
      unfold InKey in *.
      eapply in_map_iff in H0.
      openhyp.
      subst.
      destruct x; simpl in *.
      eapply InA_eqke_eqk; eauto.
      eapply InA_eqke_In.
      instantiate (1 := e0).
      intuition.
      eapply NoDupKey_unapp2; eauto.
      erewrite add_neq_o; eauto.
      erewrite IHls1.
      eapply option_univalence.
      split; intros.
      eapply find_2 in H0.
      eapply update_mapsto_iff in H0.
      eapply find_1.
      openhyp.
      eapply update_mapsto_iff.
      eauto.
      eapply update_mapsto_iff.
      right.
      split; eauto.
      eapply add_2; eauto.
      eapply find_2 in H0.
      eapply update_mapsto_iff in H0.
      eapply find_1.
      openhyp.
      eapply update_mapsto_iff.
      eauto.
      eapply update_mapsto_iff.
      right.
      split; eauto.
      eapply add_3 in H0; eauto.
      inversion H; subst; eauto.
    Qed.

    Lemma of_list_diff : forall ls1 ls2, NoDupKey ls1 -> NoDupKey ls2 -> Equal (of_list (diff_map ls1 ls2)) (diff (of_list ls1) (of_list ls2)).
      induction ls1; simpl; intros.
      unfold Equal.
      intros.
      rewrite empty_o.
      symmetry.
      eapply not_find_in_iff.
      intuition.
      eapply diff_in_iff in H1.
      openhyp.
      eapply empty_in_iff; eauto.
      unfold sumbool_to_bool.
      unfold uncurry.
      destruct (InKey_dec (fst a) ls2); simpl.
      erewrite IHls1; eauto.
      Focus 2.
      inversion H; subst; eauto.
      destruct a; simpl in *.
      unfold Equal.
      intros.
      eapply option_univalence.
      split; intros.
      eapply find_2 in H1.
      generalize H1; intro.
      eapply MapsTo_In in H1.
      eapply diff_in_iff in H1.
      openhyp.
      destruct (eq_dec y k).
      subst.
      inversion H; subst.
      contradict H6.
      unfold In in H1.
      openhyp.
      eapply of_list_1 in H1; eauto.
      eapply InA_eqke_eqk; eauto.
      eapply find_1.
      eapply diff_mapsto_iff in H2.
      openhyp.
      eapply diff_mapsto_iff.
      split.
      2 : eauto.
      eapply add_2.
      intuition.
      eauto.
      eapply find_2 in H1.
      eapply diff_mapsto_iff in H1.
      openhyp.
      eapply add_mapsto_iff in H1.
      openhyp.
      subst.
      contradict H2.
      eapply In_of_list; eauto.
      eapply find_1.
      eapply diff_mapsto_iff.
      eauto.
      unfold uncurry.
      unfold Equal.
      intros.
      destruct a; simpl in *.
      destruct (eq_dec y k).
      subst.
      erewrite add_eq_o; eauto.
      symmetry.
      eapply find_1.
      eapply diff_mapsto_iff.
      split.
      eapply add_1; eauto.
      not_not.
      eapply In_of_list; eauto.
      erewrite add_neq_o; eauto.
      erewrite IHls1; eauto.
      eapply option_univalence.
      split; intros.
      eapply find_2 in H1.
      generalize H1; intro.
      eapply diff_mapsto_iff in H1.
      openhyp.
      eapply find_1.
      eapply diff_mapsto_iff.
      split; eauto.
      eapply add_2; eauto.
      eapply find_2 in H1.
      eapply diff_mapsto_iff in H1.
      openhyp.
      eapply add_3 in H1; eauto.
      eapply find_1.
      eapply diff_mapsto_iff; eauto.
      inversion H; subst; eauto.
    Qed.

    Lemma diff_union : forall ls1 ls2, NoDupKey ls1 -> NoDupKey ls2 ->  incl ls2 ls1 -> Equal_map (diff_map ls1 ls2 ++ ls2) ls1.
      unfold Equal_map.
      intros.
      unfold find_list.
      erewrite <- of_list_1b.
      erewrite <- of_list_1b.
      2 : eauto.
      2 : eapply NoDupKey_diff_union; eauto.
      erewrite of_list_app.
      2 : eapply NoDupKey_diff_union; eauto.
      eapply option_univalence.
      split; intros.
      eapply find_2 in H2.
      eapply update_mapsto_iff in H2.
      openhyp.
      eapply of_list_1 in H2; eauto.
      eapply find_1.
      eapply of_list_1; eauto.
      eapply InA_eqke_In in H2.
      eapply InA_eqke_In.
      eauto.
      eapply find_1 in H2.
      rewrite of_list_diff in H2; eauto.
      eapply find_2 in H2.
      eapply diff_mapsto_iff in H2.
      openhyp.
      eapply find_1.
      eauto.
      eapply find_1.
      eapply update_mapsto_iff.
      destruct (In_dec (of_list ls2) k).
      unfold In in i.
      openhyp.
      generalize H3; intro.
      eapply of_list_1 in H3; eauto.
      eapply InA_eqke_In in H3.
      eapply H1 in H3.
      eapply InA_eqke_In in H3.
      eapply of_list_1 in H3; eauto.
      eapply find_1 in H3.
      rewrite H3 in H2.
      injection H2; intro; subst.
      eauto.
      right.
      split.
      2 : eauto.
      eapply find_2.
      rewrite of_list_diff; eauto.
      eapply find_1.
      eapply diff_mapsto_iff.
      eapply find_2 in H2.
      eauto.
    Qed.

    Lemma InKey_InA_eqk : forall k v ls, InKey k ls <-> InA eqk (k, v) ls.
      unfold InKey.
      split; intros.
      eapply in_map_iff in H.
      openhyp.
      subst.
      destruct x; simpl in *.
      eapply InA_eqke_In in H0.
      eapply InA_eqke_eqk; eauto.
      eapply InA_eqk_elim in H.
      openhyp.
      eapply InA_eqke_In in H.
      eapply in_map_iff.
      eexists; intuition.
      2 : eauto.
      eauto.
    Qed.

    Lemma NoDupKey_app_DisjointKey : forall ls1 ls2, NoDupKey (ls1 ++ ls2) -> DisjointKey ls1 ls2.
      unfold DisjointKey.
      unfold InKey.
      induction ls1; simpl; intuition.
      subst.
      simpl in *.
      inversion H; subst.
      contradict H3.
      eapply InKey_InA_eqk.
      unfold InKey.
      rewrite map_app.
      eapply in_or_app.
      eauto.
      eapply IHls1.
      inversion H; subst; eauto.
      eauto.
    Qed.

    Lemma NoDup_app_find_list : forall ls1 ls2 k v, NoDupKey (ls1 ++ ls2) -> find_list k ls1 = Some v -> find_list k (ls1 ++ ls2) = Some v.
      unfold find_list.
      intros.
      erewrite <- of_list_1b.
      erewrite <- of_list_1b in H0.
      erewrite of_list_app; eauto.
      eapply find_1.
      eapply find_2 in H0.
      eapply update_mapsto_iff.
      right.
      split; eauto.
      generalize H; intros.
      eapply NoDupKey_app_DisjointKey in H.
      unfold DisjointKey in *.
      intuition.
      eapply In_of_list in H2.
      eapply MapsTo_In in H0.
      eapply In_of_list in H0.
      eauto.
      eapply NoDupKey_unapp1; eauto.
      eapply NoDupKey_unapp2; eauto.
      eapply NoDupKey_unapp1; eauto.
      eauto.
    Qed.

    Lemma NoDup_app_find_list_2 : forall ls1 ls2 k v, NoDupKey (ls1 ++ ls2) -> find_list k ls2 = Some v -> find_list k (ls1 ++ ls2) = Some v.
      unfold find_list.
      intros.
      erewrite <- of_list_1b; eauto.
      erewrite <- of_list_1b in H0.
      erewrite of_list_app; eauto.
      eapply find_1.
      eapply find_2 in H0.
      eapply update_mapsto_iff.
      eauto.
      eapply NoDupKey_unapp2; eauto.
    Qed.

    Lemma find_list_neq : forall ls k v k', NoDupKey ls -> ~ E.eq k' k -> find_list k' ls = find_list k' (ls ++ (k, v) :: nil).
      unfold E.eq.
      unfold find_list.
      unfold eqb.
      induction ls; simpl; intuition.
      destruct (eq_dec _ _); intuition.
      destruct (eq_dec _ _); eauto.
      eapply IHls; eauto.
      inversion H; subst; eauto.
    Qed.

  End Elt.

End UWFacts_fun.