(**************************************************************************
* TLC: A library for Coq                                                  *
* Environments for metatheory                                             *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibOption LibList LibProd LibLogic LibReflect.
Require Export LibVar.
Generalizable Variable A.

(* ********************************************************************** *)
(** * Definition of environments and their basic operations *)

(** To avoid definitions being unfolded by [simpl] in an uncontrollable
    manner, we use a module signature to enforce abstraction *)

(* ---------------------------------------------------------------------- *)
(** ** Abstract definitions *)

Definition env (A:Type) := list (var * A).

Module Type EnvOpsSig.

Section Definitions.
Variable A B : Type.

Parameter empty : env A.
Parameter empty_def : empty = nil.

Parameter single : var -> A -> env A.
Parameter single_def :
  single = fun x v => (x,v)::nil.

Parameter concat : env A -> env A -> env A.
Parameter concat_def :
  concat = fun E F => F ++ E.

Parameter singles : list var -> list A -> env A.
Parameter singles_def :
  singles = fun xs vs =>
    fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).

Parameter keys : env A -> list var.
Parameter keys_def :
  keys = map fst.

Parameter values : env A -> list A.
Parameter values_def :
  values = map snd.

Parameter fold_vars : (A -> vars) -> env A -> vars.
Parameter fold_vars_defs :
  fold_vars = fun fv E =>
    fold_right (fun v acc => fv v \u acc) \{} (values E).

Parameter dom : env A -> vars.
Parameter dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.

Parameter map : (A -> B) -> env A -> env B.
Parameter map_def :
  map = fun f E =>
    LibList.map (fun p => (fst p, f (snd p))) E.

Parameter map_keys : (var -> var) -> env A -> env A.
Parameter map_keys_def :
  map_keys = fun f E =>
    LibList.map (fun p => (f (fst p), snd p)) E.

Parameter get : var -> env A -> option A.
Fixpoint get_impl (k : var) (E : env A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Parameter get_def :
  get = get_impl.

End Definitions.

Implicit Arguments empty [A].

End EnvOpsSig.

(* ---------------------------------------------------------------------- *)
(** ** Concrete definitions *)

Module Export EnvOps : EnvOpsSig.

Section Concrete.
Variable A B : Type.

Definition empty : env A := nil.
Lemma empty_def : empty = nil.
Proof. reflexivity. Qed.

Definition single x v : env A := (x,v)::nil.
Lemma single_def :
  single = fun x v => (x,v)::nil.
Proof. reflexivity. Qed.

Definition concat (E F : env A) := F ++ E.
Lemma concat_def :
  concat = fun E F => F ++ E.
Proof. reflexivity. Qed.

Definition singles (xs : list var) (vs : list A) : env A :=
  fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Lemma singles_def :
  singles = fun xs vs =>
   fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Proof. reflexivity. Qed.

Definition keys : env A -> list var :=
  map fst.
Lemma keys_def :
  keys = map fst.
Proof. reflexivity. Qed.

Definition values : env A -> list A :=
  map snd.
Lemma values_def :
  values = map snd.
Proof. reflexivity. Qed.

Definition fold_vars (fv : A -> vars) (E : env A) :=
  fold_right (fun v acc => fv v \u acc) \{} (values E).
Lemma fold_vars_defs :
  fold_vars = fun fv E => fold_right (fun v acc => fv v \u acc) \{} (values E).
Proof. reflexivity. Qed.

Definition map (f:A->B) (E:env A) :=
  LibList.map (fun p => (fst p, f (snd p))) E.
Lemma map_def :
  map = fun f E => LibList.map (fun p => (fst p, f (snd p))) E.
Proof. reflexivity. Qed.

Definition map_keys (f:var->var) (E:env A) :=
  LibList.map (fun p => (f (fst p), snd p)) E.
Lemma map_keys_def :
  map_keys = fun f E => LibList.map (fun p => (f (fst p), snd p)) E.
Proof. reflexivity. Qed.

Definition dom : env A -> vars :=
  fold_right (fun p E => \{fst p} \u E) \{}.
Lemma dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.
Proof. reflexivity. Qed.

Fixpoint get_impl (k : var) (E : env A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Definition get := get_impl.
Lemma get_def :
  get = get_impl.
Proof. reflexivity. Qed.

End Concrete.

Implicit Arguments empty [A].

End EnvOps.

(* ---------------------------------------------------------------------- *)
(** ** Notations *)

(** [x ~ a] is the notation for a singleton environment mapping x to a. *)

Notation "x ~ a" := (single x a)
  (at level 27, left associativity) : env_scope.

(** [xs ~* vs] is the notation for [single_iter xs vs]. *)

Notation "xs ~* vs" := (singles xs vs)
  (at level 27, left associativity) : env_scope.

(** [E & F] is the notation for concatenation of E and F. *)

Notation "E & F" := (concat E F)
  (at level 28, left associativity) : env_scope.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Bind Scope env_scope with env.
Delimit Scope env_scope with env.
Open Scope env_scope.

(* ---------------------------------------------------------------------- *)
(** ** Additional definitions *)

Section MoreDefinitions.
Variable A : Type.
Implicit Types E F : env A.

(** Well-formed environments contains no duplicate bindings. *)

Inductive ok : env A -> Prop :=
  | ok_empty :
      ok empty
  | ok_push : forall E x v,
      ok E -> x # E -> ok (E & x ~ v).

(** An environment contains a binding from x to a iff the most recent
  binding on x is mapped to a *)

Definition binds x v E :=
  get x E = Some v.

(** Read the value associated to a bound variable *)

Definition get_or_arbitrary `{Inhab A} x (E:env A) :=
  unsome (get x E).

(** Inclusion of an environment in another one. *)

Definition extends E F :=
  forall x v, binds x v E -> binds x v F.

(** Gathering free variables contained in the values of an environment *)

Definition fv_in_values (fv:A->vars) (E:env A) :=
  fold_right (fun v L => (fv v) \u L) \{} (values E).

End MoreDefinitions.

(* ---------------------------------------------------------------------- *)
(** ** Basic Properties *)

Hint Rewrite empty_def single_def concat_def singles_def keys_def values_def
  dom_def map_def map_keys_def get_def : env_defs.

Ltac rew_env_defs := autorewrite with env_defs in *.

Section Properties.

Variable A B : Type.
Implicit Types k x : var.
Implicit Types v : A.
Implicit Types E F G : env A.
Implicit Types f : A -> B.
Implicit Types r : var -> var.

Lemma cons_to_push : forall x v E,
  (x, v) :: E = E & x ~ v.
Proof. intros. rew_env_defs. rew_app~. Qed.

Lemma env_ind : forall (P : env A -> Prop),
  (P empty) ->
  (forall E x v, P E -> P (E & x ~ v)) ->
  (forall E, P E).
Proof.
  rew_env_defs. induction E as [|(x,v)].
  auto. forwards*: H0 IHE.
Qed.

Lemma map_empty : forall f,
  map f empty = empty.
Proof. intros. rew_env_defs. auto. Qed.
Lemma map_single : forall f x v,
  map f (x ~ v) = (x ~ f v).
Proof. intros. rew_env_defs. auto. Qed.
Lemma map_concat : forall f E F,
  map f (E & F) = map f E & map f F.
Proof.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_push : forall f x v E,
  map f (E & x ~ v) = map f E & x ~ f v.
Proof. intros. rewrite map_concat, map_single. auto. Qed.

Lemma map_keys_empty : forall r,
  map_keys r (@empty A) = empty.
Proof. intros. rew_env_defs. auto. Qed.
Lemma map_keys_single : forall r x v,
  map_keys r (x ~ v) = (r x ~ v).
Proof. intros. rew_env_defs. auto. Qed.
Lemma map_keys_concat : forall r E F,
  map_keys r (E & F) = map_keys r E & map_keys r F.
Proof.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_keys_push : forall r x v E,
  map_keys r (E & x ~ v) = map_keys r E & r x ~ v.
Proof. intros. rewrite map_keys_concat, map_keys_single. auto. Qed.

Lemma get_empty : forall k,
  get k (@empty A) = None.
Proof. intros. rew_env_defs. auto. Qed.
Lemma get_single : forall k x v,
  get k (x ~ v) = If k = x
                    then Some v
                    else None.
Proof. intros. rew_env_defs. unfold get_impl. auto. Qed.
Lemma get_concat : forall k E F,
  get k (E & F) = match get k F with
                  | None => get k E
                  | Some v => Some v
                  end.
Proof.
  intros. rew_env_defs. induction F as [|(x,v)].
  auto.
  simpl. case_if~.
Qed.

Lemma dom_empty :
  dom (@empty A) = \{}.
Proof. rew_env_defs. auto. Qed.
Lemma dom_single : forall x v,
  dom (x ~ v) = \{x}.
Proof.
  intros. rew_env_defs.
  rew_list. rewrite~ union_empty_r.
Qed.
Lemma dom_concat : forall E F,
  dom (E & F) = dom E \u dom F.
Proof.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list. rewrite~ union_empty_r.
  rew_app. rewrite fold_right_cons. rewrite IHF.
   rewrite~ union_comm_assoc.
Qed.
Lemma dom_push : forall x v E,
  dom (E & x ~ v) = \{x} \u dom E.
Proof.
  intros. rewrite dom_concat. rewrite dom_single.
  rewrite~ union_comm.
Qed.

End Properties.

Section SinglesProperties.
Variable A B : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types xs : list var.
Implicit Types vs : list A.
Implicit Types E F : env A.

Lemma singles_nil :
  nil ~* nil = (@empty A).
Proof. intros. rew_env_defs. auto. Qed.

Lemma singles_cons : forall x v xs vs,
  (x::xs) ~* (v::vs) = (xs ~* vs) & (x ~ v).
Proof. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_one : forall x v,
  (x::nil) ~* (v::nil) = (x ~ v).
Proof. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_two : forall x1 x2 v1 v2,
  (x1::x2::nil) ~* (v1::v2::nil) = (x2 ~ v2 & x1 ~ v1).
Proof. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma keys_singles : forall xs vs,
  length xs = length vs ->
  keys (xs ~* vs) = xs.
Proof.
  intros. rew_env_defs. gen vs. induction xs; introv E.
  rew_list~.
  destruct vs. false. simpl. rew_env_defs. rew_list. fequals.
   rew_list in E. applys IHxs. inverts E. auto.
Qed.

Lemma values_singles : forall xs vs,
  length xs = length vs ->
  values (xs ~* vs) = vs.
Proof.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  auto.
  rew_list in E. simpl. rew_env_defs. rew_list. fequals.
   applys IHxs. inverts E. auto.
Qed.

Lemma dom_singles : forall xs vs,
  length xs = length vs ->
  dom (xs ~* vs) = from_list xs.
Proof.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  simpl. rewrite~ from_list_nil.
  simpl. rew_env_defs. rew_list. rewrite from_list_cons. fequals.
   applys IHxs. inverts~ E.
Qed.

Lemma map_singles : forall (f : A -> B) xs vs,
  length xs = length vs ->
  map f (xs ~* vs) = xs ~* (LibList.map f vs).
Proof.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma map_keys_singles : forall f xs vs,
  length xs = length vs ->
  map_keys f (xs ~* vs) = (LibList.map f xs) ~* vs.
Proof.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma concat_singles : forall xs1 xs2 vs1 vs2,
  length xs1 = length vs1 ->
  length xs2 = length vs2 ->
  (xs2 ~* vs2) & (xs1 ~* vs1) = (xs1 ++ xs2) ~* (vs1 ++ vs2).
Proof.
  introv E1 E2. rew_env_defs. gen vs1.
  induction xs1; destruct vs1; intros; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma singles_keys_values : forall E,
  E = keys E ~* values E.
Proof.
  intros. rew_env_defs. induction E as [|[x v] E'].
  auto.
  rew_list. simpl. rew_env_defs. rew_list. fequals.
Qed.

End SinglesProperties.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section StructProperties.

Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma env_case : forall E,
  E = empty \/ exists x v E', E = E' & x ~ v.
Proof. intros. induction E using env_ind; auto*. Qed.

Lemma concat_empty_r : forall E,
  E & empty = E.
Proof. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_empty_l : forall E,
  empty & E = E.
Proof. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_assoc : forall E F G,
  E & (F & G) = (E & F) & G.
Proof. intros. rew_env_defs. rew_app~. Qed.

Lemma empty_single_inv : forall x v,
  empty = x ~ v -> False.
Proof. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_concat_inv : forall E F,
  empty = E & F -> empty = E /\ empty = F.
Proof. introv H. rew_env_defs. forwards*: nil_eq_app_inv H. Qed.

Lemma empty_push_inv : forall E x v,
  empty = E & x ~ v -> False.
Proof. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_middle_inv : forall E F x v,
  empty = E & x ~ v & F -> False.
Proof. introv H. rew_env_defs. forwards* [_ ?]: nil_eq_app_inv H. false. Qed.

Lemma eq_single_inv : forall x1 x2 v1 v2,
  x1 ~ v1 = x2 ~ v2 ->
  x1 = x2 /\ v1 = v2.
Proof. introv H. rew_env_defs. inverts~ H. Qed.

Lemma eq_push_inv : forall x1 x2 v1 v2 E1 E2,
  E1 & x1 ~ v1 = E2 & x2 ~ v2 ->
  x1 = x2 /\ v1 = v2 /\ E1 = E2.
Proof. introv H. rew_env_defs. inverts~ H. Qed.

End StructProperties.

(* ---------------------------------------------------------------------- *)
(** ** More properties *)

Section MoreProperties.

Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma dom_map : forall (B:Type) (f:A->B) E,
  dom (map f E) = dom E.
Proof.
  induction E using env_ind.
  rewrite map_empty. do 2 rewrite dom_empty. auto.
  rewrite map_concat. rewrite map_single.
  rewrite_all dom_concat. rewrite_all dom_single. congruence.
Qed.

Lemma concat_assoc_map_push : forall f E F x v,
  E & (map f (F & x ~ v)) = (E & map f F) & x ~ (f v).
Proof.
  intros. rewrite map_concat. rewrite map_single.
  rewrite~ concat_assoc.
Qed.

Lemma get_push : forall k x v E,
  get k (E & x ~ v) =
    If k = x
      then Some v
      else get k E.
Proof.
  intros. rewrite get_concat. rewrite get_single. case_if~.
Qed.

Ltac simpl_dom :=
  rewrite_all dom_push in *;
  rewrite_all dom_empty in *.

Lemma get_some : forall x E,
  x \in dom E -> exists v, get x E = Some v.
(* i.e.  [x \in dom E -> exists v, binds x v E] *)
Proof. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. induction E as [|[y v] E'].
  rew_list in H. rewrite* in_empty in H.
  unfold get_impl. case_if.
    eauto.
    rew_list in H. rewrite in_union in H. destruct H as [H|H].
     rewrite in_singleton in H. simpls. false.
     forwards* [v' ?]: IHE'.
Qed.

Lemma get_some_inv : forall x v E,
  get x E = Some v -> x \in dom E.
(* i.e.  [binds x v E -> x \in dom E] *)
Proof. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. unfolds get_impl. induction E as [|[y v'] E'].
  false.
  rew_list. rewrite in_union. simpl. case_if.
    inverts H. subst. left. rewrite~ in_singleton.
    forwards*: IHE'.
Qed.

Lemma get_none : forall x E,
  x # E -> get x E = None.
Proof.
  induction E using env_ind; introv In.
  rewrite~ get_empty.
  rewrite~ get_push. case_if.
    simpl_dom. subst. notin_false.
    simpl_dom. auto.
Qed.

Lemma get_none_inv : forall x E,
  get x E = None -> x # E.
Proof.
  induction E using env_ind; introv Eq.
  simpl_dom. auto.
  rewrite get_push in Eq. case_if~.
   simpl_dom. auto.
Qed.

End MoreProperties.

Lemma binds_get_or_arbitrary : forall `{Inhab A} x v (E:env A),
  binds x v E -> get_or_arbitrary x E = v.
Proof. introv M. unfold get_or_arbitrary. rewrite~ M. Qed.

Definition indom_dec A (E:env A) x :=
  match get x E with None => false | Some _ => true end.

Global Instance indom_decidable : forall A (E:env A) x,
  Decidable (x \in dom E).
Proof.
  intros. applys decidable_make (indom_dec E x).
  unfold indom_dec. cases (get x E) as C.
    lets: (get_some_inv C). rewrite~ isTrue_true.
    lets: (get_none_inv C). rewrite~ isTrue_false.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Hints and rewriting tactics *)

Hint Constructors ok.

Hint Rewrite dom_empty dom_single dom_concat : rew_env_dom.
Hint Rewrite map_empty map_single map_concat : rew_env_map.
Hint Rewrite map_keys_empty map_keys_single
 map_keys_concat : rew_env_map_keys.
Hint Rewrite get_empty get_single get_concat : rew_evn_get.

Hint Rewrite concat_empty_r concat_empty_l concat_assoc : rew_env_concat.

Tactic Notation "rew_env_concat" :=
  autorewrite with rew_env_concat.
Tactic Notation "rew_env_concat" "in" hyp(H) :=
  autorewrite with rew_env_concat in H.
Tactic Notation "rew_env_concat" "in" "*" :=
  autorewrite with rew_env_concat in *.

Ltac simpl_dom :=
  rewrite_all dom_map in *;
  rewrite_all dom_push in *;
  rewrite_all dom_concat in *;
  rewrite_all dom_single in *;
  rewrite_all dom_empty in *.

Hint Extern 1 (_ # _) => simpl_dom; notin_solve.

(* ---------------------------------------------------------------------- *)
(** ** Properties of well-formedness and freshness *)

Section OkProperties.

Variable A B : Type.
Implicit Types k x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma ok_push_inv : forall E x v,
  ok (E & x ~ v) -> ok E /\ x # E.
Proof.
  intros. inverts H as H1 H2.
  false (empty_push_inv H1).
  destructs 3 (eq_push_inv H). subst~.
Qed.

Lemma ok_push_inv_ok : forall E x v,
  ok (E & x ~ v) -> ok E.
Proof. introv H. destruct* (ok_push_inv H). Qed.

Lemma ok_concat_inv : forall E F,
  ok (E & F) -> ok E /\ ok F.
Proof.
  induction F using env_ind; rew_env_concat; introv Ok. auto.
  destruct (ok_push_inv Ok). destruct~ IHF.
Qed.

Lemma ok_concat_inv_l : forall E F,
  ok (E & F) -> ok E.
Proof. introv H. lets*: ok_concat_inv H. Qed.

Lemma ok_concat_inv_r : forall E F,
  ok (E & F) -> ok F.
Proof. introv H. lets*: ok_concat_inv H. Qed.

Lemma ok_middle_change : forall E F x v1 v2,
  ok (E & x ~ v1 & F) -> ok (E & x ~ v2 & F).
Proof.
  induction F using env_ind; introv; rew_env_concat; introv Ok.
  destruct* (ok_push_inv Ok).
  destruct* (ok_push_inv Ok).
Qed.

Lemma ok_middle_inv : forall E F x v,
  ok (E & x ~ v & F) -> x # E /\ x # F.
Proof.
  induction F using env_ind; introv; rew_env_concat; intros Ok;
   destruct (ok_push_inv Ok).
  split~.
  forwards~ [? ?]: IHF H.
Qed.

Lemma ok_middle_inv_l : forall E F x v,
  ok (E & x ~ v & F) -> x # E.
Proof. introv H. forwards~ [? _]: ok_middle_inv H. Qed.

Lemma ok_middle_inv_r : forall E F x v,
  ok (E & x ~ v & F) -> x # F.
Proof. introv H. forwards~ [_ ?]: ok_middle_inv H. Qed.

Lemma ok_remove : forall F E G,
  ok (E & F & G) -> ok (E & G).
Proof.
  induction G using env_ind; rew_env_concat; introv Ok.
  lets*: ok_concat_inv Ok.
  lets*: ok_push_inv Ok.
Qed.

Lemma ok_map : forall E (f : A -> B),
  ok E -> ok (map f E).
Proof.
  induction E using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Ok.
  auto. destruct* (ok_push_inv Ok).
Qed.

Lemma ok_concat_map: forall E F (f : A -> A),
  ok (E & F) -> ok (E & map f F).
Proof.
  induction F using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Ok.
  auto. destruct* (ok_push_inv Ok).
Qed.

Lemma ok_singles : forall n E xs (vs:list A),
  fresh (dom E) n xs ->
  length xs = length vs ->
  ok E ->
  ok (E & xs ~* vs).
Proof.
  introv F EQ O. gen E n vs.
  induction xs; destruct vs; destruct n; intros; tryfalse.
  rewrite singles_nil. rewrite~ concat_empty_r.
  rew_length in EQ. inverts EQ.
   simpl in F. destruct F as [Fr F']. lets [? M]: (fresh_union_r F').
   rewrite singles_cons. rewrite concat_assoc. applys ok_push.
     applys~ IHxs n.
     simpl_dom. rewrite~ dom_singles. lets~: fresh_single_notin M.
Qed.

(* LATER: not used
Lemma singles_ok : forall xs vs E,
  ok E ->
  fresh (dom E) (length xs) xs ->
  ok (E & xs ~* vs).
Proof. ...
  induction xs; simpl; intros. auto.
  destruct H0. destruct Us; simpls. auto.
  rewrite iter_push_cons. rewrite* <- concat_assoc.
*)

(* LATER: not used;
   missing a precondition unless nil~*vs returns nil
Lemma ok_concat_singles : forall n xs vs E,
  ok E ->
  fresh (dom E) n xs ->
  ok (E & xs ~* vs).
Proof.
  intros. rew_env_defs. gen vs n E.
  induction xs; introv Ok Fr; destruct n; tryfalse.
  auto.
  destruct vs. simpl.
  rew_list in Fr. destruct Fr as [F Fr'].
  applys_to Fr notin_union_r...
Qed.
*)

(* LATER: not used
  Lemma ok_concat : forall E F,
    ok E -> ok F -> disjoint (dom E) (dom F) ->
    ok (E & F).
*)

End OkProperties.

Implicit Arguments ok_push_inv [A E x v].
Implicit Arguments ok_concat_inv [A E F].
Implicit Arguments ok_remove [A F E G].
Implicit Arguments ok_map [A E f].
Implicit Arguments ok_middle_inv_l [A E F x v].
Implicit Arguments ok_middle_inv_r [A E F x v].
Implicit Arguments ok_middle_inv [A E F x v].

(** Automation *)

Hint Resolve ok_middle_inv_l ok_map ok_concat_map ok_singles.

Hint Extern 1 (ok (?E & ?G)) =>
  match goal with H: ok (E & ?F & G) |- _ =>
    apply (ok_remove H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (E & _ ~ _) |- _ =>
    apply (ok_push_inv_ok H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (E & _) |- _ =>
    apply (ok_concat_inv_l H) end.

Hint Extern 1 (ok (?E)) =>
  match goal with H: ok (_ & E) |- _ =>
    apply (ok_concat_inv_r H) end.

(* not used
Hint Extern 1 (ok (_ & ?xs ~* ?vs)) =>
  match goal with H: fresh _ ?n xs |- _ =>
  match type of vs with list ?A =>
    apply (@ok_concat_singles A n)
  end end.
*)

(* ---------------------------------------------------------------------- *)
(** ** Properties of the binds relation *)

Section BindsProperties.
Variable A B : Type.
Implicit Types E F : env A.
Implicit Types x : var.
Implicit Types v : A.

Lemma binds_get : forall x v E,
  binds x v E -> get x E = Some v.
Proof. auto. Qed.

(** Constructor forms *)

Lemma binds_empty_inv : forall x v,
  binds x v empty -> False.
Proof.
  unfold binds. introv H. rewrite get_empty in H. false.
Qed.

Lemma binds_single_eq : forall x v,
  binds x v (x ~ v).
Proof.
  intros. unfold binds. rewrite get_single. case_if~.
Qed.

Lemma binds_single_inv : forall x1 x2 v1 v2,
  binds x1 v1 (x2 ~ v2) ->
  x1 = x2 /\ v1 = v2.
Proof.
  unfold binds. introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma binds_push_inv : forall x1 v1 x2 v2 E,
  binds x1 v1 (E & x2 ~ v2) ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ binds x1 v1 E).
Proof.
  introv H. unfolds binds. rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma binds_push_eq : forall x v E,
  binds x v (E & x ~ v).
Proof. intros. unfolds binds. rewrite get_push. case_if~. Qed.

Lemma binds_push_eq_inv : forall x v1 v2 E,
  binds x v1 (E & x ~ v2) -> v1 = v2.
Proof.
  introv H. forwards [|]: binds_push_inv H. auto*. intros [? _]. false.
Qed.

Lemma binds_push_neq_inv : forall x1 x2 v1 v2 E,
  binds x1 v1 (E & x2 ~ v2) -> x1 <> x2 -> binds x1 v1 E.
Proof.
  introv H. forwards [|]: binds_push_inv H.
  intros [? ?] ?. false. auto*.
Qed.

Lemma binds_tail : forall x v E,
  binds x v (E & x ~ v).
Proof. intros. unfold binds. rewrite get_push. cases_if~. Qed.

Lemma binds_push_neq : forall x1 x2 v1 v2 E,
  binds x1 v1 E -> x1 <> x2 -> binds x1 v1 (E & x2 ~ v2).
Proof.
  introv H N. unfolds binds. rewrite get_push. case_if~.
Qed.

Lemma binds_concat_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
     (binds x v E2)
  \/ (x # E2 /\ binds x v E1).
Proof.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~.
Qed.

Lemma binds_map : forall x v (f : A -> B) E,
  binds x v E -> binds x (f v) (map f E).
Proof.
  introv H. unfolds binds. rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.

(** Basic forms *)

Lemma binds_func : forall x v1 v2 E,
  binds x v1 E -> binds x v2 E -> v1 = v2.
Proof.
  introv H1 H2. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma binds_fresh_inv : forall x v E,
  binds x v E -> x # E -> False.
Proof.
  introv H F. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. case_if~. subst.
   simpl_dom; notin_false.
Qed.

(** Derived forms *)

Lemma binds_single_eq_inv : forall x v1 v2,
  binds x v1 (x ~ v2) ->
  v1 = v2.
Proof.
  introv H. unfolds binds. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma binds_concat_left : forall x v E1 E2,
  binds x v E1 ->
  x # E2 ->
  binds x v (E1 & E2).
Proof.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc. applys~ binds_push_neq.
   simpl_dom. auto.
Qed.

Lemma binds_concat_left_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  binds x v E1 ->
  binds x v (E1 & E2).
Proof.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: ok_push_inv O.
  applys~ binds_push_neq. intro_subst. applys~ binds_fresh_inv H.
Qed.

Lemma binds_concat_left_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
  x # E2 ->
  binds x v E1.
Proof.
  introv H F. lets~ [M|[? ?]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_concat_right : forall x v E1 E2,
  binds x v E2 ->
  binds x v (E1 & E2).
Proof.
  introv H. induction E2 using env_ind.
  false. applys* binds_empty_inv.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: binds_push_inv H.
    subst. applys binds_tail.
    applys~ binds_push_neq.
Qed.

Lemma binds_concat_right_inv : forall x v E1 E2,
  binds x v (E1 & E2) ->
  x # E1 ->
  binds x v E2.
Proof.
  introv H F. lets~ [?|[? M]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_middle_eq : forall x E1 E2 v,
  x # E2 ->
  binds x v (E1 & x ~ v & E2).
Proof.
  introv F. applys~ binds_concat_left. applys binds_tail.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the binds_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma binds_weaken : forall x a E F G,
  binds x a (E & G) -> ok (E & F & G) ->
  binds x a (E & F & G).
Proof.
  introv H O. lets [?|[? ?]]: binds_concat_inv H.
    applys~ binds_concat_right.
    applys~ binds_concat_left. applys~ binds_concat_left_ok.
Qed.

Lemma binds_remove : forall E2 E1 E3 x v,
  binds x v (E1 & E2 & E3) ->
  x # E2 ->
  binds x v (E1 & E3).
Proof.
  introv H F. lets [?|[? M]]: binds_concat_inv H.
    applys~ binds_concat_right.
    forwards~: binds_concat_left_inv M. applys~ binds_concat_left.
Qed.

Lemma binds_subst : forall x2 v2 x1 v1 E1 E2,
  binds x1 v1 (E1 & x2 ~ v2 & E2) ->
  x1 <> x2 ->
  binds x1 v1 (E1 & E2).
Proof. introv H N. applys~ binds_remove H. Qed.

Lemma binds_middle_eq_inv : forall x E1 E2 v1 v2,
  binds x v1 (E1 & x ~ v2 & E2) ->
  ok (E1 & x ~ v2 & E2) ->
  v1 = v2.
Proof.
  introv H O. lets [? ?]: ok_middle_inv O.
  forwards~ M: binds_concat_left_inv H.
  applys~ binds_push_eq_inv M.
Qed.

Lemma binds_middle_inv : forall x1 v1 x2 v2 E1 E2,
  binds x1 v1 (E1 & x2 ~ v2 & E2) ->
     (binds x1 v1 E2)
  \/ (x1 # E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 # E2 /\ x1 <> x2 /\ binds x1 v1 E1).
Proof.
  introv H. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. lets [N|[? N]]: (binds_concat_inv M).
      lets [? ?]: (binds_single_inv N). subst~.
      right. simpl_dom. split~.
Qed.

Lemma binds_not_middle_inv : forall x v E1 E2 E3,
  binds x v (E1 & E2 & E3) ->
  x # E2 ->
     (binds x v E3)
  \/ (x # E3 /\ binds x v E1).
Proof.
  introv H F. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. forwards~ N: (binds_concat_left_inv M).
Qed.

Lemma fv_in_values_binds : forall y fv x v E,
  binds x v E -> y \notin fv_in_values fv E -> y \notin fv v.
Proof.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. applys* binds_empty_inv.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (binds_push_inv H); subst~.
Qed.

(* unused -- requires a precondition on f
Lemma binds_keys : forall x v f E,
  binds x v E -> binds (f x) v (map_keys f E).
Proof.
Qed.
*)

(* unused
Lemma binds_concat_inv_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  binds x v (E1 & E2) ->
     (x # E2 /\ binds x v E1)
  \/ (x # E1 /\ binds x v E2).
Proof.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in O,H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply conj_dup_r.
     split.
       apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~....
Qed.
*)

End BindsProperties.

(* ---------------------------------------------------------------------- *)
(** ** Tactics *)

Hint Resolve binds_push_eq binds_push_neq
  binds_map binds_concat_left binds_concat_right.

Tactic Notation "binds_mid" :=
  match goal with H: binds ?x ?v1 (_ & ?x ~ ?v2 & _) |- _ =>
    asserts: (v1 = v2); [ apply (binds_middle_eq_inv H) | subst; clear H ]
  end.
Tactic Notation "binds_mid" "~" :=
  binds_mid; auto_tilde.
Tactic Notation "binds_mid" "*" :=
  binds_mid; auto_star.

Tactic Notation "binds_push" constr(H) :=
  match type of H with binds ?x1 ?v1 (_ & ?x2 ~ ?v2) =>
    destruct (binds_push_inv H) as [[? ?]|[? ?]]; [ subst x2 v2 | ]
  end.
Tactic Notation "binds_push" "~" constr(H) :=
  binds_push H; auto_tilde.
Tactic Notation "binds_push" "*" constr(H) :=
  binds_push H; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Properties of environment inclusion *)

Section ExtendsProperties.
Variable A : Type.
Implicit Types x : var.
Implicit Types v : A.
Implicit Types E F : env A.

Lemma extends_refl : forall E,
  extends E E.
Proof. intros_all~. Qed.

Lemma extends_push : forall E x v,
  x # E -> extends E (E & x ~ v).
Proof.
  introv Fr. intros x' v' B. unfolds binds.
  rewrite get_push. case_if~.
  lets: get_none Fr. false.
Qed.

Lemma extends_concat_l : forall E F,
  extends F (E & F).
Proof.
  introv B. unfolds binds.
  rewrite get_concat. rewrite~ B.
Qed.

Lemma extends_concat_r : forall E F,
  disjoint (dom E) (dom F) ->
  extends E (E & F).
Proof.
  introv D B. unfolds binds.
  lets: get_some_inv A B.
  forwards M: get_none A x F.
    applys~ disjoint_in_notin D.
  rewrite get_concat. rewrite~ M.
Qed.

(* not used
Lemma extends_push_reoccur : forall E x v,
  binds x v E -> extends E (E & x ~ v).
*)

End ExtendsProperties.

Hint Resolve extends_refl extends_push.

(* ********************************************************************** *)
(** ** Tactics for case analysis on binding relations *)

(** [binds_get H as EQ] produces from an hypothesis [H] of
  the form [binds x a (E & x ~ b & F)] the equality [EQ: a = b]. *)

Ltac binds_get_nosubst_base H EQ :=
  match type of H with
  | binds ?x ?v1 (?E1 & ?x ~ ?v2 & ?E2) =>
    forwards EQ: (@binds_middle_eq_inv _ x E1 E2 v1 v2 H); [ auto | ]
  (* | binds ?x1 ?v1 (?E1 & ?x2 ~ ?v2 & ?E2) =>
     forwards EQ: (@binds_middle_inv _ x1 v1 x2 v2 E1 E2); [ | auto ] *)
  end.

Tactic Notation "binds_get_nosubst" constr(H) "as" ident(EQ) :=
  binds_get_nosubst_base H EQ.
Tactic Notation "binds_get_nosubst" constr(H) :=
  let EQ := fresh "EQ" in binds_get_nosubst H as EQ.

(** [binds_get H] expects an hypothesis [H] of the form
  [binds x a (E & x ~ b & F)] and substitute [a] for [b] in the goal. *)

Ltac binds_get H :=
  let EQ := fresh in binds_get_nosubst H as EQ;
  try match type of EQ with
  | ?f _ = ?f _ => inversions EQ
  | ?x = ?y => subst x end.

(** [binds_single H] derives from an hypothesis [H] of the form
  [binds x a (y ~ b)] the equalities [x = y] and [a = b], then
  it substitutes [x] for [y] in the goal or deduce a contradiction
  if [x <> y] can be found in the context. *)

Ltac binds_single H :=
  match type of H with binds ?x ?a (?y ~ ?b) =>
    let EQ := fresh "EQ" in
    destruct (binds_single_inv H) as [? EQ];
    try discriminate; try subst y;
    try match goal with N: ?x <> ?x |- _ =>
      false; apply N; reflexivity end end.

(** [binds_case H as B1 B2] derives from an hypothesis [H] of the form
  [binds x a (E & F)] two subcases: [B1: binds x a E] (with a freshness
  condition [x # F]) and [B2: binds x a F]. *)

Lemma binds_concat_inv' : forall A, forall x (v:A) E1 E2,
  binds x v (E1 & E2) ->
     (x # E2 /\ binds x v E1)
  \/ (binds x v E2).
Proof. intros. forwards K: binds_concat_inv A H. destruct* K. Qed.

Tactic Notation "binds_case" constr(H) "as" ident(B1) ident(B2) :=
   let Fr := fresh "Fr" in
   destruct (binds_concat_inv' H) as [[Fr B1] | B2].

(** [binds_case H] makes a case analysis on an hypothesis [H] of the form
  [binds x a E] where E can be constructed using concatenation and
  singletons. It calls [binds_single] when reaching a singleton. *)

Ltac binds_cases H :=
  let go B := clear H;
    first [ binds_single B | binds_cases B | idtac ] in
  let B1 := fresh "B" in let B2 := fresh "B" in
  binds_case H as B1 B2; (*fix_env;*) [ go B1 | go B2 ].
  (* TODO: add support for binds_empty_inv *)

(* LATER: improve the above tactic using pattern matching
Ltac binds_cases_base H :=
  match H with
  | binds _ _ empty => false (binds_empty_inv H)
  | binds _ _ (_ & _) =>
     let H1 := fresh "B" in
     destruct (binds_concat_inv H) as [H1|H1];
     clear H; binds_cases_base H1
  | binds _ _ (_ ~ _) =>
  | _ => idtac
  end.
*)


Require Import Iron.Language.SystemF2Effect.Value.Relation.TyJudge.

(* Weakening Store Typing in Type Judgement. *)
Lemma typex_stenv_snoc
 :  forall ke te se sp t2 x t1 e1
 ,  ClosedT t2
 -> TypeX  ke te se         sp x t1 e1
 -> TypeX  ke te (t2 <: se) sp x t1 e1.
Proof.
 intros. gen ke te se sp t1 e1 t2.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t1 t2
      ,  ClosedT t2
      -> TypeV ke te se         sp v t1
      -> TypeV ke te (t2 <: se) sp v t1)
  ; intros; inverts_type; eauto.

 - Case "VLAM".
   eapply TvLAM.
   spec IHx H8 H. clear H8.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   auto.

 - Case "XPrivate".
   eapply TxPrivate with (t := t) (e := e); eauto.
   spec IHx H8 H. clear H8.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   auto.

 - Case "XExtend".
   eapply TxExtend; eauto.
   spec IHx H11 H. clear H11.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   eauto.
Qed.
Hint Resolve typex_stenv_snoc.

Lemma typev_stenv_snoc
 :  forall ke te se sp t2 v t1
 ,  ClosedT t2
 -> TypeV ke te se         sp v t1
 -> TypeV ke te (t2 <: se) sp v t1.
Proof.
 intros.
 have HX: (TypeX ke te se sp (XVal v) t1 (TBot KEffect)).
 eapply typex_stenv_snoc in HX.
 inverts HX; eauto.
 eauto.
Qed.
Hint Resolve typev_stenv_snoc.

Lemma typex_stenv_weaken
 :  forall ke te se1 se2 sp x t1 e1
 ,  Forall ClosedT se2
 -> TypeX  ke te  se1         sp x t1 e1
 -> TypeX  ke te (se2 >< se1) sp x t1 e1.
Proof.
 intros. gen ke te se1 sp.
 induction se2; intros.
 - burn.
 - rrwrite ((se2 :> a) >< se1 = se2 >< (a <: se1)).
   inverts H. rip.
Qed.
Hint Resolve typex_stenv_weaken.

Lemma typex_stenv_extends
 :  forall ke te se1 se2 sp x t1 e1
 ,  Forall ClosedT se2
 -> extends se2 se1
 -> TypeX ke te se1 sp x t1 e1
 -> TypeX ke te se2 sp x t1 e1.
Proof.
 intros.
 unfold extends in *.
 destruct H0 as [se3]. subst.
 eapply typex_stenv_weaken; auto.
  eauto.
Qed.
Hint Resolve typex_stenv_extends.

Lemma typev_stenv_extends
 :  forall ke te sp se1 se2 v t1
 ,  Forall ClosedT se2
 -> extends se2 se1
 -> TypeV ke te se1 sp v t1
 -> TypeV ke te se2 sp v t1.
Proof.
 intros.
 unfold extends in *.
 destruct H0 as [se3]. subst.
 assert (TypeX ke te (se3 >< se1) sp (XVal v) t1 (TBot KEffect)) as HX.
  eauto.
 inverts HX. auto.
Qed.
Hint Resolve typex_stenv_extends.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************
*  Rsa.g                                                      *
****************************************************************)
Require Import Arith.
Require Export Fermat.
Section RSA.
Variable p q : nat.
Variable prime_p : prime p.
Variable prime_q : prime q.
Variable neq_pq : p <> q.
Variable e d : nat.
Variable pq : nat.
Hypothesis pqnot_zero : pq <> 0.
Hypothesis pq_div_p : divides (p - 1) pq.
Hypothesis pq_div_q : divides (q - 1) pq.
Variable ed_inv : congruent pq (e * d) 1.

Definition encrypt (w : nat) : nat := power w e.

Definition decrypt (w : nat) : nat := power w d.

Lemma gcd_pq_SO : is_gcd p q 1.
Proof.
apply prime_gcd; auto.
red in |- *; intros H.
inversion prime_p.
case neq_pq.
apply H1; auto.
inversion prime_q; auto.
Qed.

Lemma Chinese :
 forall a b : nat,
 b <= a -> congruent p a b -> congruent q a b -> congruent (p * q) a b.
Proof.
intros a b H' H'0 H'1.
cut (divides p (a - b)); [ intros H'2; inversion_clear H'2 | idtac ].
cut (divides q (a - b)); [ intros H'3; inversion_clear H'3 | idtac ].
cut (divides p q1); [ intros H'4; inversion_clear H'4 | idtac ].
apply congruentDef with (u := 0) (v := q2); simpl in |- *.
rewrite mult_assoc.
rewrite <- H1; rewrite <- H0; rewrite <- plus_n_O; auto with arith.
apply L_Euclides with q.
apply gcd_pq_SO.
apply dividesDef with (q := q0).
rewrite (mult_comm q); rewrite <- H; auto.
apply cong_divides; auto.
apply cong_divides; auto.
Qed.

Lemma prime_2_or_more : forall r : nat, prime r -> r = 2 \/ 2 < r.
intros r; case r.
intros H'; absurd (prime 0); auto.
intros n; case n.
intros H'; absurd (prime 1); auto.
intros n0; case n0; auto with arith.
Qed.

Lemma phi_gt_SO : 1 < pq.
Proof.
elim (prime_2_or_more p); auto; intros H'1.
elim (prime_2_or_more q); auto; intros H'2.
absurd (p = q); auto.
rewrite H'2; auto.
apply lt_le_trans with (m := q - 1); auto.
apply lt_S_n; simpl in |- *; auto.
replace (S (q - 1)) with (1 + (q - 1)).
rewrite <- (le_plus_minus 1 q); auto.
apply le_trans with (m := 2); auto.
apply lt_le_weak; auto.
simpl in |- *; auto.
apply divides_le; auto.
apply lt_le_trans with (m := p - 1); auto.
apply lt_S_n; simpl in |- *; auto.
replace (S (p - 1)) with (1 + (p - 1)).
rewrite <- (le_plus_minus 1 p); auto.
apply le_trans with (m := 2); auto.
apply lt_le_weak; auto.
simpl in |- *; auto.
apply divides_le; auto.
Qed.

Theorem rsa_correct :
 forall w : nat, congruent (p * q) (decrypt (encrypt w)) w.
Proof.
unfold decrypt, encrypt in |- *.
intros; rewrite power_power.
cut (1 <= e * d); [ intros leH | idtac ].
cut (divides pq (e * d - 1)); [ intros H; inversion_clear H | idtac ].
cut (e * d = 1 + q0 * pq); [ intros Eqed | idtac ].
apply Chinese; auto with arith.
rewrite Eqed; apply power_le; auto with arith.
case (divides_dec p w); intros divPpw.
apply cong_trans with (b := 0).
apply cong_sym.
apply cong_trans with (b := power 0 (e * d)).
rewrite power_O; auto.
apply cong_ref; auto.
apply cong_pow; auto.
apply divides_cong; auto.
apply divides_cong; auto.
rewrite Eqed; simpl in |- *.
inversion_clear pq_div_p.
rewrite mult_comm; apply cong_trans with (b := power 1 (q1 * q0) * w).
apply cong_times; auto.
rewrite mult_comm.
repeat rewrite <- power_power.
apply cong_pow.
rewrite H.
repeat rewrite <- power_power.
rewrite power_SO.
apply Fermat; auto.
red in |- *; intros H'; case divPpw.
apply div_power_prime with (n := q1); auto.
rewrite power_SO; simpl in |- *; rewrite <- plus_n_O; auto.
apply cong_ref; auto.
case (divides_dec q w); intros divPpw.
apply cong_trans with (b := 0).
apply cong_sym.
apply cong_trans with (b := power 0 (e * d)).
rewrite power_O; auto.
apply cong_ref; auto.
apply cong_pow; auto.
apply divides_cong; auto.
apply divides_cong; auto.
rewrite Eqed; simpl in |- *.
inversion_clear pq_div_q.
rewrite mult_comm; apply cong_trans with (b := power 1 (q1 * q0) * w).
apply cong_times; auto.
rewrite mult_comm.
repeat rewrite <- power_power.
apply cong_pow.
rewrite H.
repeat rewrite <- power_power.
rewrite power_SO.
apply Fermat; auto.
red in |- *; intros H'; case divPpw.
apply div_power_prime with (n := q1); auto.
rewrite power_SO; simpl in |- *; rewrite <- plus_n_O; auto.
apply cong_ref; auto.
rewrite <- H0; auto.
rewrite <- le_plus_minus; auto.
apply cong_divides; auto.
apply cong1_le with pq; auto.
apply phi_gt_SO.
Qed.
End RSA.
Section RSAI.
Variable p q : nat.
Variable prime_p : prime p.
Variable prime_q : prime q.
Variable neq_pq : p <> q.
Variable e d : nat.
Variable ed_inv : congruent ((p - 1) * (q - 1)) (e * d) 1.

Theorem rsa_correct' :
 forall w : nat, congruent (p * q) (decrypt d (encrypt e w)) w.
intros w.
apply rsa_correct with (pq := (p - 1) * (q - 1)); auto.
red in |- *; intros H'.
case (mult_eqO _ _ H').
generalize (prime_2_or_more p prime_p); case p; simpl in |- *; auto.
intros H'0; elim H'0; intros H'1; inversion H'1; auto.
intros n; case n; simpl in |- *; auto.
intros H'0; elim H'0; intros H'1; auto.
inversion H'1; auto.
absurd (2 < 1); auto.
apply lt_asym; auto.
intros n0 H'0 H'1; inversion H'1.
generalize (prime_2_or_more q prime_q); case q; simpl in |- *; auto.
intros H'0; elim H'0; intros H'1; inversion H'1; auto.
intros n; case n; simpl in |- *; auto.
intros H'0; elim H'0; intros H'1; auto.
inversion H'1; auto.
absurd (2 < 1); auto.
apply lt_asym; auto.
intros n0 H'0 H'1; inversion H'1.
apply dividesDef with (q := q - 1); auto with arith.
apply dividesDef with (q := p - 1); auto with arith.
Qed.
End RSAI.


(*
vim: set fenc=utf-8 ff=unix sts=2 sw=2 et ft=coq :
*)
(*
Copyright (C) 2016-2019 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.Tactics.

Require Import Way.Nat.
Require Import Way.Preterm.

(* Replace a bound variable i with replacement u in preterm p

No shifting, lifting or other house keeping is done on the remaining de Bruijn indices.
*)
Fixpoint open (i : nat) (u p : preterm) : preterm :=
  match p with

  | free_variable _ => p

  | bound_variable b => if eq_nat_dec i b then u else p

  | product a b => product (open i u a) (open (S i) u b)

  | abstraction a b => abstraction (open i u a) (open (S i) u b)

  | application f a => application (open i u f) (open i u a)

  | type _ => p

  end.

(* Open bound variable 0 in a term with a free variable. *)
Definition open_free (a : atom) (p : preterm) : preterm :=
  open 0 (Preterm.free_variable a) p.

Hint Unfold open_free : way.

Module Examples.

Import Aliases.

Example fvar_is_unchanged :
  forall (a b : atom), open_free a (fvar b) = (fvar b).
Proof.
  infer.
Defined.

Example same_bvar_is_opened :
  forall (a : atom), open_free a (bvar 0) = (fvar a).
Proof.
  infer.
Defined.

Example different_bvar_is_unchanged :
  forall (a : atom), open_free a (bvar 1) = (bvar 1).
Proof.
  infer.
Defined.

Example prod_opens_bvar_into_annotation :
  forall (a : atom), open_free a (prod (bvar 0) (bvar 0)) = (prod (fvar a) (bvar 0)).
Proof.
  infer.
Defined.

Example prod_opens_incremented_bvar_into_body :
  forall (a : atom), open_free a (prod (bvar 1) (bvar 1)) = (prod (bvar 1) (fvar a)).
Proof.
  infer.
Defined.

Example abs_opens_bvar_into_annotation :
  forall (a : atom), open_free a (abs (bvar 0) (bvar 0)) = (abs (fvar a) (bvar 0)).
Proof.
  infer.
Defined.

Example abs_opens_incremented_bvar_into_body :
  forall (a : atom), open_free a (abs (bvar 1) (bvar 1)) = (abs (bvar 1) (fvar a)).
Proof.
  infer.
Defined.

Example app_opens_into_subterms :
  forall (a : atom), open_free a (app (bvar 0) (bvar 0)) = (app (fvar a) (fvar a)).
Proof.
  infer.
Defined.

Example type_is_unchanged :
  forall (a : atom) (n : nat), open_free a (type n) = (type n).
Proof.
  infer.
Defined.

End Examples.


Require Coq.ZArith.ZArith.

Lemma unit_eq (x y:unit) : x = y. destruct x, y; reflexivity. Qed.
Global Hint Resolve unit_eq : core.

Global Hint Extern 0 (_ = _ :> bool) => (
  match goal with
  | [H:Bool.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (Bool.eqb_true_iff _ _) H)
  | [H:Bool.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (Bool.eqb_true_iff _ _) H)
  end) : core.

Global Hint Extern 0 (_ = _ :> nat) => (
  match goal with
  | [H:Nat.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (PeanoNat.Nat.eqb_eq _ _) H)
  | [H:Nat.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (PeanoNat.Nat.eqb_eq _ _) H)
  end) : core.

Global Hint Extern 0 (_ <= _) => (
  match goal with
  | [H:Nat.ltb ?a ?b = true |- ?a < ?b ] => apply (proj1 (PeanoNat.Nat.ltb_lt _ _) H)
  end) : core.

Global Hint Extern 0 (_ <= _) => (
  match goal with
  | [H:Nat.leb ?a ?b = true |- ?a <= ?b ] => apply (proj1 (PeanoNat.Nat.leb_le _ _) H)
  end) : core.

Global Hint Extern 0 (_ = _ :> BinNums.N) => (
  match goal with
  | [H:BinNat.N.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinNat.N.eqb_eq _ _) H)
  | [H:BinNat.N.eqb ?b ?a = true |- ?a = ?b ] => symmetry; apply (proj1 (BinNat.N.eqb_eq _ _) H)
  end) : core.
Global Hint Extern 0 (_ = _ :> BinInt.Z) => (
  match goal with
  | [H:BinInt.Z.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinInt.Z.eqb_eq _ _) H)
  | [H:BinInt.Z.eqb ?a ?b = true |- ?b = ?a ] => symmetry; apply (proj1 (BinInt.Z.eqb_eq _ _) H)
  end) : core.
Global Hint Extern 0 (BinInt.Z.lt _ _) => (
  match goal with
  | [H:BinInt.Z.ltb ?a ?b = true |- BinInt.Z.lt ?a ?b ] => apply (proj1 (BinInt.Z.ltb_lt _ _) H)
  | [H:BinInt.Z.gtb ?b ?a = true |- BinInt.Z.lt ?a ?b ] => apply (proj1 (BinInt.Z.gtb_lt _ _) H)
  end) : core.
Global Hint Extern 0 (BinInt.Z.le _ _) => (
  match goal with
  | [H:BinInt.Z.leb ?a ?b = true |- BinInt.Z.le ?a ?b ] => apply (proj1 (BinInt.Z.leb_le _ _) H)
  | [H:BinInt.Z.geb ?b ?a = true |- BinInt.Z.le ?a ?b ] => apply (proj1 (BinInt.Z.geb_le _ _) H)
  end) : core.

Global Hint Extern 0 (_ = _ :> BinPos.positive) => (
  match goal with
  | [H:BinPos.Pos.eqb ?a ?b = true |- ?a = ?b ] => apply (proj1 (BinPos.Pos.eqb_eq _ _) H)
  | [H:BinPos.Pos.eqb ?a ?b = true |- ?b = ?a ] => symmetry; apply (proj1 (BinPos.Pos.eqb_eq _ _) H)
  end) : core.
Global Hint Extern 0 (BinPos.Pos.lt _ _) => (
  match goal with
  | [H:BinPos.Pos.ltb ?a ?b = true |- BinPos.Pos.lt ?a ?b ] => apply (proj1 (BinPos.Pos.ltb_lt _ _) H)
  end) : core.
Global Hint Extern 0 (BinPos.Pos.le _ _) => (
  match goal with
  | [H:BinPos.Pos.leb ?a ?b = true |- BinPos.Pos.le ?a ?b ] => apply (proj1 (BinPos.Pos.leb_le _ _) H)
  end) : core.


(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms

     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence     *)
(**************************************************************************)

(**************************************************************************)
(* Author : Mathis Bouverot-Dupuis (June 2022). *)
(**************************************************************************)

Require Import Bool.
Require Import Arith.Div2.
Require Import Lia Field.
Require Import Rbase Rbasic_fun R_sqrt Rtrigo_def.
Require Import List.
Require Import SetoidList.
Require Import Relations.
Require Import RelationPairs.
Require Import Morphisms.
Require Import Psatz.
Require Import Inverse_Image.
Require Import FunInd.
Require Import FMapFacts.
Require Import SetoidDec.

(* Helping typeclass resolution avoid infinite loops. *)
Typeclasses eauto := (bfs).

Require Import Pactole.Util.Coqlib.
Require Import Pactole.Util.Ratio.
Require Import Pactole.Spaces.R2.
Require Import Pactole.Observations.MultisetObservation.
Require Import Pactole.Core.Identifiers.
Require Import Pactole.Spaces.Similarity.

Set Implicit Arguments.

Close Scope R_scope.

Local Existing Instance R2_VS.
Local Existing Instance R2_ES.

(* Change the left hand side of a setoid-equality with a convertible term. *)
Ltac change_LHS E :=
  match goal with
  | [ |- ?LHS == ?RHS ] => change (E == RHS)
  end.

(* Change the right hand side of a setoid-equality with a convertible term. *)
Ltac change_RHS E :=
  match goal with
  | [ |- ?LHS == ?RHS ] => change (LHS == E)
  end.

(* This tactic feeds the precondition of an implication in order to derive the conclusion
  (taken from http://comments.gmane.org/gmane.science.mathematics.logic.coq.club/7013).
  Usage: feed H.
  H: P -> Q  ==becomes==>  H: P
                          ____
                          Q
  After completing this proof, Q becomes a hypothesis in the context. *)
  Ltac feed H :=
  match type of H with
  | ?foo -> _ =>
    let FOO := fresh in
    assert foo as FOO; [|specialize (H FOO); clear FOO]
  end.

(* Generalization of feed for multiple hypotheses.
  feed_n is useful for accessing conclusions of long implications.
  Usage: feed_n 3 H.
    H: P1 -> P2 -> P3 -> Q.
  We'll be asked to prove P1, P2 and P3, so that Q can be inferred. *)
Ltac feed_n n H := match constr:(n) with
  | O => idtac
  | (S ?m) => feed H ; [| feed_n m H]
  end.

(* Simplify a goal involving calculations in R2 by expanding everything.
 * This is rarely useful. *)
Ltac simplifyR2 :=
unfold Rminus ;
repeat (try rewrite mul_distr_add ;
        try rewrite <-add_morph ;
        try rewrite mul_0 ;
        try rewrite mul_1 ;
        try rewrite add_origin_l ;
        try rewrite add_origin_r ;
        try rewrite mul_opp ;
        try rewrite minus_morph ;
        try rewrite opp_opp ;
        try rewrite opp_origin ;
        try rewrite R2_opp_dist ;
        try rewrite add_opp).

Lemma contra (P Q : Prop) : (Q -> P) -> (~P -> ~Q).
Proof. intuition. Qed.

(* This inductive type inspired by mathcomp allows elegant destruction
 * of if-statements (more so than the 'destruct_match' tactic).
 * Usage : [case ifP_sumbool] will destuct the first if-statement
 * with a sumbool condition in the goal. *)
Section IfSpecSumbool.
Variables (P Q : Prop) (T : Type).
Implicit Types (u v : T).

Inductive if_spec_sumbool u v : {P} + {Q} -> T -> Prop :=
  | if_spec_sumbool_true (p : P) : if_spec_sumbool u v (left p) u
  | if_spec_sumbool_false (q : Q) : if_spec_sumbool u v (right q) v.

Lemma ifP_sumbool (c : {P} + {Q}) u v : if_spec_sumbool u v c (if c then u else v).
Proof using . case c ; constructor. Qed.

End IfSpecSumbool.

(* Usage : [case ifP_bool] will destuct the first if-statement
 * with a boolean condition in the goal. *)
Section IfSpecBool.
Variables (T : Type) (u v : T).

Inductive if_spec_bool (B NB : Prop) : bool -> T -> Prop :=
  | if_spec_bool_true : B -> if_spec_bool B NB true u
  | if_spec_bool_false : NB -> if_spec_bool B NB false v.

Lemma ifP_bool b : if_spec_bool (b = true) (b = false) b (if b then u else v).
Proof using . case b ; constructor ; reflexivity. Qed.

End IfSpecBool.

(* Lemma ifP_bool_test b : b = negb b -> (if b then b || b else false) = false.
Proof. case ifP_bool. ... *)

Section ForallTriplets.
Variable (A B C : Type).
Implicit Types (R : A -> B -> C -> Prop).

(* The proposition R holds for every triplet in the cartesian product (l1 * l2 * l3). *)
Definition ForallTriplets R l1 l2 l3 : Prop :=
  Forall (fun x => Forall (fun y => Forall (fun z => R x y z) l3) l2) l1.

Local Instance Forall_PermutationA_compat_strong {T : Type} `{Setoid T} :
  Proper ((equiv ==> iff) ==> PermutationA equiv ==> iff) (@Forall T).
Proof using .
intros P P' HP l l' Hl. elim Hl.
+ intuition.
+ intros x x' t t' Hx Ht IH. repeat rewrite Forall_cons_iff. now f_equiv ; [apply HP|].
+ intros x y t. repeat rewrite Forall_cons_iff. repeat rewrite <-and_assoc. f_equiv.
  - rewrite and_comm. now f_equiv ; auto.
  - f_equiv. intros ? ? ->. now apply HP.
+ intros t1 t2 t3 _ IH1 _ IH2. rewrite IH1, <-IH2.
  f_equiv. intros ? ? ->. symmetry. now apply HP.
Qed.

Local Instance ForallTriplets_PermutationA_compat  `{Setoid A} `{Setoid B} `{Setoid C} :
  Proper ((equiv ==> equiv ==> equiv ==> iff) ==>
    PermutationA equiv ==> PermutationA equiv ==> PermutationA equiv ==> iff) ForallTriplets.
Proof using .
intros R R' HR l1 l1' Hl1 l2 l2' Hl2 l3 l3' Hl3. unfold ForallTriplets.
repeat (f_equiv ; auto ; intros ? ? ?). now apply HR.
Qed.

(* As with Forall, ForallTriplets is decidable (provided R is decidable). *)
Lemma ForallTriplets_dec R l1 l2 l3 :
  (forall x y z, {R x y z} + {~ R x y z}) ->
  {ForallTriplets R l1 l2 l3} + {~ ForallTriplets R l1 l2 l3}.
Proof using . intros Rdec. unfold ForallTriplets. repeat (apply Forall_dec ; intros ?). now apply Rdec. Qed.

(* The equivalence between ForallTriplets and regular forall. *)
Lemma ForallTriplets_forall R l1 l2 l3 :
  (ForallTriplets R l1 l2 l3) <-> forall x y z, List.In x l1 -> List.In y l2 -> List.In z l3 -> R x y z.
Proof using .
unfold ForallTriplets. split.
+ intros H x y z Hinx Hiny Hinz.
  rewrite Forall_forall in H. specialize (H x Hinx).
  rewrite Forall_forall in H. specialize (H y Hiny).
  rewrite Forall_forall in H. specialize (H z Hinz).
  exact H.
+ intros H.
  rewrite Forall_forall. intros x Hinx.
  rewrite Forall_forall. intros y Hiny.
  rewrite Forall_forall. intros z Hinz.
  auto.
Qed.

End ForallTriplets.

Global Instance flat_map_compat_eq {A B} `{Setoid A} `{Setoid B} :
Proper ((equiv ==> PermutationA equiv) ==> eqlistA equiv ==> PermutationA equiv) (@flat_map A B).
Proof using .
intros f f' Hff' l l' Hll'. elim Hll'.
+ cbn. now reflexivity.
+ intros x x' t t' Hxx' Htt' IH. cbn. now f_equiv ; auto.
Qed.

Global Instance flat_map_compat_perm {A B} `{Setoid A} `{Setoid B} :
Proper ((equiv ==> PermutationA equiv) ==> PermutationA equiv ==> PermutationA equiv) (@flat_map A B).
Proof using .
intros f f' Hff' l l' Hll'. elim Hll'.
+ simpl. now reflexivity.
+ intros x x' t t' Hxx' Htt' IH. cbn. rewrite <-IH. f_equiv. now apply Hff'.
+ intros x y t. cbn. repeat rewrite app_assoc. f_equiv.
- rewrite PermutationA_app_comm. f_equiv ; now apply Hff'. now apply setoid_equiv.
- now f_equiv.
+ intros t t' t'' _ IH1 _ IH2. rewrite IH1, <-IH2. f_equiv.
intros x x' Hxx'. symmetry. now apply Hff'.
Qed.

Global Instance countA_occ_compat_setoid {A : Type} `{eq_dec : EqDec A} :
  Proper (equiv ==> PermutationA equiv ==> equiv) (countA_occ equiv eq_dec).
Proof using . intros x x' Hx l l' Hl. now apply countA_occ_compat ; autoclass. Qed.

Lemma countA_occ_removeA_same {A : Type} `{eq_dec : EqDec A} x l :
  countA_occ equiv eq_dec x (removeA eq_dec x l) = 0%nat.
Proof using .
induction l as [|y l IH].
+ reflexivity.
+ cbn. destruct_match.
  - now rewrite IH.
  - cbn. destruct_match ; [intuition | now rewrite IH].
Qed.

Lemma countA_occ_removeA_other {A : Type} `{eq_dec : EqDec A} x y l :
  x =/= y -> countA_occ equiv eq_dec x (removeA eq_dec y l) = countA_occ equiv eq_dec x l.
Proof using .
intros Hxy. induction l as [|z l IH].
+ reflexivity.
+ cbn. repeat destruct_match.
  - rewrite <-e in e0. symmetry in e0. intuition.
  - now rewrite IH.
  - rewrite e. cbn. destruct_match ; [|intuition]. now rewrite IH.
  - cbn. destruct_match ; [intuition|]. now rewrite IH.
Qed.

Lemma PermutationA_countA_occ {A : Type} `{eq_dec : EqDec A} l l' :
  PermutationA equiv l l' <->
  forall x, countA_occ equiv eq_dec x l == countA_occ equiv eq_dec x l'.
Proof using .
split.
+ intros Hperm x. elim Hperm.
  - now reflexivity.
  - intros x1 x2 l1 l2 Hx Hl IH. cbn.
    repeat destruct_match ; try (now rewrite IH) ;
      rewrite <-e, Hx in c ; unfold complement in c ; now intuition.
  - intros a b t. cbn. repeat destruct_match ; reflexivity.
  - intros l1 l2 l3 _ H1 _ H2. now rewrite H1, <-H2.
+ intros Hcount. remember (length l) as m. generalize l l' Heqm Hcount.
  pattern m. apply (well_founded_ind lt_wf). clear m l l' Heqm Hcount.
  intros m IH [|x l] l' Hm Hcount.
  -  cbn in *. destruct l' as [|y tl'] ; [now apply permA_nil|].
    specialize (Hcount y). revert Hcount ; cbn. destruct_match ; [|intuition]. discriminate.
  - rewrite (PermutationA_count_split _ eq_dec x l).
    rewrite (PermutationA_count_split _ eq_dec x l').
    rewrite app_comm_cons. f_equiv.
    * apply eqlistA_PermutationA. rewrite <-Hcount. cbn. destruct_match ; [|intuition].
      cbn. reflexivity.
    * eapply IH ; [|reflexivity|].
      ++apply (Nat.le_lt_trans _ (length l)) ; [apply Preliminary.removeA_length_le|].
        rewrite Hm. cbn. apply Nat.lt_succ_diag_r.
      ++intros y. case (x =?= y) as [Hxy|Hxy].
        rewrite <-Hxy. repeat rewrite countA_occ_removeA_same. reflexivity.
        repeat rewrite countA_occ_removeA_other by (symmetry ; auto).
        rewrite <-Hcount. cbn. destruct_match ; [intuition|reflexivity].
Qed.

Lemma countA_occ_le {A : Type} `{eq_dec : EqDec A} w ps ps' :
  Forall2 (fun x x' => x' == x \/ x' == w) ps ps' ->
    countA_occ equiv eq_dec w ps <= countA_occ equiv eq_dec w ps'.
Proof using .
intros HF. induction HF as [| x x' l l' Hxx' Hll' IH] ; [auto|].
cbn -[equiv]. repeat destruct_match ; intuition.
rewrite H, e in c. intuition.
Qed.

Lemma countA_occ_lt {A : Type} `{eq_dec : EqDec A} w ps ps' :
  Forall2 (fun x x' => x' == x \/ x' == w) ps ps' ->
  List.Exists (fun '(x, x') => x' =/= x) (combine ps ps') ->
    countA_occ equiv eq_dec w ps < countA_occ equiv eq_dec w ps'.
Proof using .
intros HF HE. induction HF as [| x x' l l' Hxx' Hll' IH].
+ rewrite Exists_exists in HE. destruct HE as [x [In_nil _]]. now apply in_nil in In_nil.
+ cbn -[complement equiv] in HE. rewrite Exists_cons in HE.
  destruct HE as [Dxx' | HE].
  - destruct Hxx' as [Exx' | Ex'w] ; intuition.
    rewrite Ex'w in Dxx' |- *. cbn -[equiv].
    repeat destruct_match ; intuition. apply le_lt_n_Sm. now apply countA_occ_le.
  - destruct Hxx' as [Exx' | Ex'w] ; cbn -[equiv] ; repeat destruct_match ; intuition.
    rewrite Exx', e in c. intuition.
Qed.

Lemma nth_enum i m d :
  forall Him : i < m, nth i (enum m) d = exist (fun x => x < m) i Him.
Proof.
intros Him. apply eq_proj1, Nat.le_antisymm ; cbn.
+ apply lt_n_Sm_le, firstn_enum_spec. rewrite <-(firstn_skipn (S i)) at 1.
  rewrite app_nth1 ; [apply nth_In|] ; rewrite firstn_length_le ; try rewrite enum_length ; lia.
+ apply skipn_enum_spec. rewrite <-(firstn_skipn i) at 1.
  rewrite app_nth2 ; [apply nth_In|] ; rewrite firstn_length_le by (rewrite enum_length ; lia) ; auto.
  rewrite Nat.sub_diag, skipn_length, enum_length. lia.
Qed.

Lemma combine_nil_iff {A B : Type} (l : list A) (l' : list B) :
  combine l l' = nil <-> (l = nil \/ l' = nil).
Proof.
split.
+ intros Hcom. destruct l as [|x l] ; destruct l' as [|x' l'] ; intuition.
  discriminate Hcom.
+ intros [-> | ->] ; [|rewrite combine_nil] ; reflexivity.
Qed.

Lemma combine_map {A B C : Type} l l' (f : A -> C) (f' : B -> C) :
  combine (List.map f l) (List.map f' l') = List.map (fun '(x, x') => (f x, f' x')) (combine l l').
Proof.
generalize l'. clear l'. induction l as [| x l IH] ; intros [|x' l'] ; cbn ; try reflexivity.
f_equal. apply IH.
Qed.

Lemma in_combine_id {A : Type} (a b : A) l :
  List.In (a, b) (combine l l) <-> (a = b /\ List.In a l).
Proof.
induction l as [|x l IH].
+ cbn. intuition.
+ cbn. rewrite IH. split.
  - intros [Hxx | [-> Hin]].
    * inv Hxx. intuition.
    * intuition.
  - intros [-> [-> | Hin]] ; intuition.
Qed.

Lemma in_combine_sym {A B : Type} (a : A) (b : B) l1 l2 :
  List.In (a, b) (combine l1 l2) <-> List.In (b, a) (combine l2 l1).
Proof.
cut (forall (A B : Type) (x : A) (y : B) l l',
  List.In (x, y) (combine l l') -> List.In (y, x) (combine l' l)).
{ intros H. split ; apply H. }
clear a b l1 l2 A B. intros A B a b l1.
induction l1 as [|x1 l1 IH] ; intros l2 Hin ; [now cbn in Hin|].
case l2 as [|x2 l2] ; [now cbn in Hin|]. cbn in Hin |- *.
case Hin as [Heq | Hin].
+ inv Heq. now left.
+ right. apply IH. exact Hin.
Qed.

Lemma Forall2_Forall {A B : Type} (R : A -> B -> Prop) l l' : length l = length l' ->
  (Forall2 R l l' <-> Forall (fun '(x, y) => R x y) (combine l l')).
Proof.
intros Hlen. split.
+ intros Hforall2. induction Hforall2 as [|x x' l l' Hx Hl IH] ; constructor ; auto.
+ intros Hforall. remember (combine l l') as c.
  generalize dependent l'. generalize dependent l. generalize dependent c.
  induction c as [|a c IH] ; intros Hforall l l' Hlen Hcom.
  - symmetry in Hcom. rewrite combine_nil_iff in Hcom.
    destruct Hcom as [-> | ->] ; cbn in Hlen ; [symmetry in Hlen|] ;
      apply length_0 in Hlen ; rewrite Hlen ; constructor.
  - destruct a as [y y'].
    destruct l as [|x l] ; [discriminate|].
    destruct l' as [|x' l'] ; [discriminate|].
    cbn in Hcom. inv Hcom. rewrite Forall_cons_iff in Hforall. constructor ; intuition.
Qed.

Lemma Forall2_length {A B : Type} (R : A -> B -> Prop) l1 l2 :
  Forall2 R l1 l2 -> length l1 = length l2.
Proof. intros HF2. induction HF2 ; cbn ; lia. Qed.

Lemma mul_eq0_iff (k : R) (x : R2) : (k * x == 0)%VS <-> (k == 0)%R \/ (x == 0)%VS.
Proof.
split ; intros H.
+ case (k =?= 0%R) as [Hk | Hk] ; [now left | right].
  apply mul_reg_l with k ; [intuition|].
  rewrite mul_origin. exact H.
+ destruct H as [Hk | Hx].
  - now rewrite Hk, mul_0.
  - now rewrite Hx, mul_origin.
Qed.

Lemma nth_InA {A : Type} {eqA : relation A} i l d :
  Reflexive eqA ->
  i < length l -> InA eqA (nth i l d) l.
Proof.
intros Hrefl Hi. induction l using rev_ind.
+ cbn in Hi. lia.
+ rewrite app_length in Hi. cbn in Hi.
  case (lt_dec i (length l)) as [Hi_lt | Hi_ge].
  - rewrite InA_app_iff ; left.
    rewrite app_nth1 by auto. now apply IHl.
  - assert (Hi_eq : i = length l) by lia.
    rewrite Hi_eq, nth_middle, InA_app_iff ; right.
    now apply InA_cons_hd.
Qed.

Lemma list_all_eq_or_perm {A : Type} `{Setoid A} `{EqDec A} (x0 : A) l :
  (forall x, InA equiv x l -> x == x0) \/ (exists x1 l1, PermutationA equiv l (x1 :: l1) /\ x1 =/= x0).
Proof.
case (Forall_dec (equiv x0) (equiv_dec x0) l) as [Hall_eq | HNall_eq].
+ left. intros x Hin. rewrite Forall_forall in Hall_eq.
  rewrite InA_alt in Hin. destruct Hin as [y [Hxy Hin]].
  rewrite Hxy. symmetry. now apply Hall_eq.
+ right. apply neg_Forall_Exists_neg in HNall_eq ; [|apply equiv_dec].
  rewrite Exists_exists in HNall_eq. destruct HNall_eq as [x1 [Hin Hx1]].
  apply (@In_InA _ equiv) in Hin ; autoclass.
  apply PermutationA_split in Hin ; autoclass.
  destruct Hin as [l1 Hperm].
  exists x1. exists l1. split ; [exact Hperm | symmetry ; exact Hx1].
Qed.

Lemma add_sub {A : Type} `{R : RealVectorSpace A} (x y : A) :
  (x + (y - x) == y)%VS.
Proof. now rewrite (RealVectorSpace.add_comm y), RealVectorSpace.add_assoc, add_opp, add_origin_l. Qed.

Lemma straight_path_0 p p' : straight_path p p' ratio_0 == p.
Proof. cbn -[equiv mul opp RealVectorSpace.add]. now rewrite mul_0, add_origin_r. Qed.

Lemma straight_path_same p r : straight_path p p r == p.
Proof. cbn -[equiv mul opp RealVectorSpace.add]. now rewrite add_opp, mul_origin, add_origin_r. Qed.

Lemma straight_path_end s d r :
  straight_path s d r == d <-> (s == d \/ proj_ratio r == 1%R).
Proof.
split.
+ intros Hend. cbn -[mul opp RealVectorSpace.add] in Hend.
  assert (H : ((r - 1) * (d - s) == 0)%VS).
  {
    unfold Rminus. rewrite <-add_morph, minus_morph, mul_1, opp_distr_add, opp_opp.
    rewrite (RealVectorSpace.add_comm _ s), RealVectorSpace.add_assoc, (RealVectorSpace.add_comm _ s).
    now rewrite Hend, add_opp.
  }
  rewrite mul_eq0_iff in H. case H as [H1 | H2].
  - right. cbn in H1 |- *. lra.
  - left. now rewrite R2sub_origin in H2.
+ intros [H1 | H2].
  - now rewrite H1, straight_path_same.
  - cbn -[mul opp RealVectorSpace.add equiv]. rewrite H2, mul_1.
    now rewrite add_sub.
Qed.

Lemma straight_path_similarity (f : similarity R2) x y r :
  straight_path (f x) (f y) r == f (straight_path x y r).
Proof using .
cbn -[mul opp RealVectorSpace.add].
rewrite sim_add, <-RealVectorSpace.add_assoc. f_equal.
rewrite sim_mul. unfold Rminus. rewrite <-add_morph, mul_1.
rewrite (RealVectorSpace.add_comm (f 0%VS) _), <-2 RealVectorSpace.add_assoc.
rewrite add_opp, add_origin_r.
rewrite minus_morph, <-mul_opp, <-mul_distr_add. f_equal.
rewrite sim_add, sim_opp, <-2 RealVectorSpace.add_assoc. f_equal.
change 2%R with (1 + 1)%R. rewrite <-add_morph, mul_1.
rewrite RealVectorSpace.add_comm, 2 RealVectorSpace.add_assoc.
rewrite <-add_origin_l. f_equal.
+ rewrite <-(RealVectorSpace.add_assoc (- f 0)%VS _), (RealVectorSpace.add_comm (- f 0)%VS (f 0)%VS), add_opp.
  rewrite add_origin_r, RealVectorSpace.add_comm, add_opp.
  reflexivity.
+ rewrite add_origin_l. reflexivity.
Qed.

Lemma straight_path_dist_start (s d : R2) (r : ratio) :
  dist s (straight_path s d r) == (r * dist s d)%R.
Proof.
rewrite 2 norm_dist. cbn -[norm mul opp RealVectorSpace.add equiv].
rewrite opp_distr_add, RealVectorSpace.add_assoc, add_opp, add_origin_l.
rewrite <-mul_opp, opp_distr_add, opp_opp, RealVectorSpace.add_comm.
rewrite norm_mul, Rabs_pos_eq ; [reflexivity | apply ratio_bounds].
Qed.

Lemma straight_path_dist_end (s d : R2) (r : ratio) :
  dist d (straight_path s d r) == ((1 - r) * dist s d)%R.
Proof.
rewrite 2 norm_dist. cbn -[norm mul opp RealVectorSpace.add equiv].
assert (H : (d - (s + r * (d - s)) == (r - 1) * (s - d))%VS).
{
  unfold Rminus. rewrite <-add_morph, minus_morph, mul_1, 2 opp_distr_add, opp_opp.
  rewrite (RealVectorSpace.add_comm _ (-s + d)%VS), RealVectorSpace.add_assoc.
  f_equiv.
  + now rewrite RealVectorSpace.add_comm.
  + rewrite <-mul_opp. f_equiv. now rewrite opp_distr_add, opp_opp, RealVectorSpace.add_comm.
}
rewrite H, norm_mul. f_equiv. rewrite Rabs_left1.
+ now rewrite Ropp_minus_distr.
+ generalize (ratio_bounds r). lra.
Qed.

Lemma add_ratio_ge_left (r1 r2 : ratio) : (r1 <= add_ratio r1 r2)%R.
Proof.
unfold add_ratio. destruct_match.
+ apply ratio_bounds.
+ cbn. generalize (ratio_bounds r2). lra.
Qed.

Lemma add_ratio_ge_right (r1 r2 : ratio) : (r2 <= add_ratio r1 r2)%R.
Proof.
unfold add_ratio. destruct_match.
+ apply ratio_bounds.
+ cbn. generalize (ratio_bounds r1). lra.
Qed.

Lemma colinear_exists_mul u v :
  ~ u == 0%VS -> colinear u v -> exists t, v == (t * u)%VS.
Proof.
intros Hu_n0 Hcol. destruct (colinear_decompose Hu_n0 Hcol) as [Hdecomp | Hdecomp].
+ exists (norm v / norm u)%R. rewrite Hdecomp at 1. unfold Rdiv, unitary.
  now rewrite mul_morph.
+ exists ((- norm v) / norm u)%R. rewrite Hdecomp at 1. unfold Rdiv, unitary.
  now rewrite mul_morph.
Qed.


Set Primitive Projections.

Record site := {
  ste_fun : Prop -> Prop;
  ste_top : forall A : Prop, A -> ste_fun A;
  ste_mon : forall A B : Prop, ste_fun A -> (A -> ste_fun B) -> ste_fun B;
}.

Arguments ste_fun {_}.
Arguments ste_top {_}.
Arguments ste_mon {_}.

Coercion ste_fun : site >-> Funclass.

Axiom funext : forall A (B : A -> Type) (f g : forall x, B x),
  (forall x, f x = g x) -> f = g.
Axiom pi : forall (A : Prop) (p q : A), p = q.

Ltac unwrap :=
repeat match goal with
| [ H : @ste_fun ?J ?P |- ste_fun _ ] =>
  let H' := fresh H in
  refine (ste_mon _ _ H (fun H' => _));
  replace H with (@ste_top J _ H') in * by apply pi;
  clear H; rename H' into H
end.

Record isSheaf (J : site) (A : Type) := {
  shf_elt : forall P : Prop, J P -> (P -> A) -> A;
  shf_spc : forall P (i : J P) (c : P -> A) (x : A),
    (forall p : P, x = c p) -> x = shf_elt P i c;
}.

Arguments shf_elt {_ _}.
Arguments shf_spc {_ _}.

Record isSheaf' (J : site) (A : Type) := {
  shf_elt' : forall P : Prop, J P -> (P -> A) -> A;
  shf_spc' : forall P (i : J P) (x : A), x = shf_elt' P i (fun _ => x);
}.

Lemma sig_eq : forall {A} {P : A -> Prop} (p q : @sig A P), proj1_sig p = proj1_sig q -> p = q.
Proof.
intros A P [p hp] [q hq]; cbn.
revert hq; destruct 1; f_equal; apply pi.
Qed.

Lemma sig_eq_rev : forall {A} {P : A -> Prop} (p q : @sig A P), p = q -> proj1_sig p = proj1_sig q.
Proof.
intros A P p q []; reflexivity.
Qed.

Lemma is_Sheaf_Sheaf' : forall J A, isSheaf' J A -> isSheaf J A.
Proof.
intros J A hA.
unshelve econstructor.
+ refine (fun P i x₀ => hA.(shf_elt' _ _) P i x₀).
+ cbn; intros P i x₀ x hx.
  rewrite (shf_spc' _ _ hA P i x).
  f_equal; apply funext; apply hx.
Defined.

Lemma is_Sheaf'_Sheaf : forall J A, isSheaf J A -> isSheaf' J A.
Proof.
intros J A hA.
unshelve econstructor.
+ refine (fun P i x₀ => hA.(shf_elt) P i x₀).
+ cbn; intros P i x.
  apply shf_spc; constructor.
Defined.

Lemma isSheaf_hProp : forall J A (p q : isSheaf J A), p = q.
Proof.
intros J A [f hf] [g hg].
assert (e : f = g).
+ apply funext; intros P; apply funext; intros i; apply funext; intros x.
  apply hg; intros p.
  symmetry; apply hf; intros p'.
  f_equal; apply pi.
+ revert hf hg; rewrite e; intros.
  replace hf with hg by apply pi; reflexivity.
Qed.

(** Closure under products *)

Lemma Prod_isSheaf : forall (J : site) (A : Type) (B : A -> Type),
  (forall x, isSheaf J (B x)) -> isSheaf J (forall x, B x).
Proof.
intros J A B Bε.
unshelve econstructor.
+ refine (fun P i f x => (Bε x).(shf_elt) P i (fun p => f p x)).
+ intros P i c f hf.
  (** needs funext *)
  apply funext; intros x.
  apply (Bε x).
  intros p; rewrite (hf p); reflexivity.
Defined.

Definition isSeparated (J : site) (A : Type) :=
  forall P (i : J P) (c : P -> A) (x y : A),
      (forall p : P, x = c p) -> (forall p : P, y = c p) -> x = y.

Lemma closed_diag_isSeparated : forall (J : site) A,
  isSeparated J A -> (forall x y : A, J (x = y) -> x = y).
Proof.
intros J A hA x y e.
unshelve refine (hA (x = y) e (fun _ => y) x y (fun e => e) (fun _ => eq_refl)).
Defined.

Lemma isSeparated_closed_diag : forall (J : site) A,
  (forall x y : A, J (x = y) -> x = y) -> isSeparated J A.
Proof.
intros J A hA P i c x y hx hy.
refine (hA _ _ _).
unwrap.
apply ste_top.
rewrite (hx i), (hy i); reflexivity.
Defined.

Lemma isSeparated_isSheaf : forall (J : site) A,
  isSheaf J A -> isSeparated J A.
Proof.
intros J A hA P i c x y hx hy.
rewrite (shf_spc hA P i c); [|apply hy].
rewrite <- (shf_spc hA P i c x); [|apply hx].
reflexivity.
Qed.

Definition PropJ (J : site) := {P : Prop | J P -> P}.

Definition liftJ (J : site) (P : Prop) : PropJ J.
Proof.
exists (J P).
refine (fun p => ste_mon _ _ p (fun p => p)).
Defined.

(** Sheafification à la MacLane-Moerdijk *)

Definition Sh (J : site) (A : Type) :=
  { P : A -> PropJ J | J (exists x : A, forall y, proj1_sig (P y) <-> J (x = y)) }.

Definition Sh_η (J : site) (A : Type) (x : A) : Sh J A.
Proof.
exists (fun y => liftJ J (x = y)).
apply ste_top; exists x; tauto.
Defined.

Definition Sh_bind (J : site) (A B : Type) (m : Sh J A) (f : A -> Sh J B) : Sh J B.
Proof.
destruct m as [P hP].
unshelve econstructor.
+ refine (fun y => liftJ J (exists x : A, proj1_sig (P x) /\ proj1_sig (proj1_sig (f x) y))).
+ unwrap.
  destruct hP as [x hx].
  remember (f x) as Q.
  destruct Q as [Q HQ]; cbn in *.
  unwrap.
  destruct HQ as [y hy].
  apply sig_eq_rev in HeqQ; cbn in HeqQ; subst Q.
  apply ste_top; exists y; intros y'; split; intro H.
  - refine (ste_mon _ _ H _); clear H; intros [x' [Hl Hr]].
    assert (e : J (x = x')).
    { apply hx; assumption. }
    unwrap; subst x'.
    apply hy; assumption.
  - unwrap; subst y'.
    apply ste_top; exists x; split.
    { apply hx, ste_top; reflexivity. }
    { apply hy, ste_top; reflexivity. }
Defined.

Lemma isSheaf_subobj (J : site) (A : Type) (P : A -> Prop)
  (hA : isSheaf J A) (hP : forall x, J (P x) -> P x) : isSheaf J {x : A | P x}.
Proof.
apply is_Sheaf_Sheaf'.
apply is_Sheaf'_Sheaf in hA.
unshelve econstructor.
+ intros Q j x.
  unshelve econstructor.
  - refine (hA.(shf_elt' _ _) Q j (fun q => proj1_sig (x q))).
  - apply hP.
    unshelve refine (@ste_mon J _ _ j _).
    intro j'; apply ste_top.
    replace (fun q => proj1_sig (x q)) with (fun _ : Q => proj1_sig (x j')).
    2: { apply funext; intros j''; repeat f_equal; apply pi. }
    rewrite <- (shf_spc' J A hA Q j).
    destruct (x j'); cbn; assumption.
+ intros Q j [x hx]; cbn.
  match goal with [ |- _ = exist ?P ?x ?p ] => generalize p as hx' end.
  rewrite <- shf_spc'; intros; f_equal; apply pi.
Defined.

Axiom propext : forall (A B : Prop), (A <-> B) -> A = B.

Lemma isSeparated_Sh : forall J A, isSeparated J (Sh J A).
Proof.
intros J A; apply isSeparated_closed_diag. intros [P HP] [Q HQ] H; cbn.
apply sig_eq; cbn.
apply funext; intros z. apply sig_eq; apply propext.
match goal with [ |- ?P ] => cut (J P) end.
+ clear; intros H; split; intros H';
  match goal with [ |- proj1_sig ?P ] => apply (proj2_sig P) end;
  refine (ste_mon _ _ H _); intros []; apply ste_top; tauto.
+ refine (ste_mon _ _ H _); clear H; intros H.
  apply sig_eq_rev in H; cbn in H.
  rewrite H; apply ste_top; tauto.
Defined.

Lemma PropJ_isSheaf (J : site) : isSheaf J (PropJ J).
Proof.
apply is_Sheaf_Sheaf'; unshelve econstructor.
+ intros P i f.
  unshelve econstructor.
  { refine (forall p : P, proj1_sig (f p)). }
  { intros j p.
    remember (f p) as Q; destruct Q as [Q HQ]; cbn in *.
    apply HQ.
    refine (ste_mon _ _ j _).
    intros g.
    specialize (g p).
    rewrite <- HeqQ in g; cbn in g.
    apply ste_top; assumption.
  }
+ intros P i [Q HQ]; cbn.
  apply sig_eq; cbn.
  apply propext; split; [tauto|].
  intros f. apply HQ.
  refine (ste_mon _ _ i _).
  intros p; apply ste_top; tauto.
Defined.

Lemma isSheaf_Sh : forall J A, isSeparated J A -> isSheaf J (Sh J A).
Proof.
intros J A HA.
apply isSheaf_subobj.
+ apply Prod_isSheaf; intros; apply PropJ_isSheaf.
+ intros P HP.
  refine (ste_mon _ _ HP (fun x => x)).
Defined.

Lemma Sh_bind_η : forall J A (x : Sh J A), Sh_bind J A _ x (Sh_η J A) = x.
Proof.
intros J A [P HP].
apply sig_eq; cbn.
apply funext; intros x; cbn.
apply sig_eq; cbn; apply propext.
split; intros H.
+ apply (proj2_sig (P x)).
  refine (ste_mon _ _ H _); clear H; intros [y [Hy e]].
  refine (ste_mon _ _ e _); clear e; intros ->; apply ste_top; assumption.
+ apply ste_top; exists x; split.
  - assumption.
  - apply ste_top; reflexivity.
Qed.

Lemma Sh_η_bind : forall J A B (x : A) f, Sh_bind J A B (Sh_η J A x) f = f x.
Proof.
intros J A B x f; apply sig_eq; cbn.
apply funext; intros y; cbn; apply sig_eq; cbn; apply propext; split; intros H.
+ apply (proj2_sig (proj1_sig (f x) y)).
  refine (ste_mon _ _ H _); clear H; intros [x' [e Hx]].
  refine (ste_mon _ _ e _); clear e; intros e; subst x'.
  apply ste_top; assumption.
+ apply ste_top; exists x; split.
  - apply ste_top; reflexivity.
  - assumption.
Qed.

Lemma Sh_bind_bind : forall J A B C (x : Sh J A) f g,
  Sh_bind J B C (Sh_bind J A B x f) g = Sh_bind J A C x (fun x => Sh_bind J B C (f x) g).
Proof.
intros J A B C [P HP] f g; apply sig_eq; cbn.
apply funext; intros z; apply sig_eq; cbn; apply propext; cbn; split; intros H.
+ refine (ste_mon _ _ H _); clear H; intros [y [hy hg]].
  refine (ste_mon _ _ hy _); clear hy; intros [x [hx hf]].
  apply ste_top; exists x; split; [assumption|].
  remember (f x) as Q; destruct Q as [Q HQ]; cbn.
  apply sig_eq_rev in HeqQ; cbn in HeqQ; subst Q; cbn in *.
  apply ste_top; exists y; split; [assumption|].
  assumption.
+ refine (ste_mon _ _ H _); clear H; intros [x [hx hf]].
  remember (f x) as Q; destruct Q as [Q HQ]; cbn.
  apply sig_eq_rev in HeqQ; cbn in HeqQ; subst Q; cbn in *.
  refine (ste_mon _ _ hf _); clear hf; intros [y [hy hz]].
  apply ste_top; exists y; split; [|assumption].
  apply ste_top; exists x; split; assumption.
Qed.

Lemma Sh_idempotent : forall J A (x : Sh J A),
  Sh_η J (Sh J A) x = Sh_bind J A (Sh J A) x (fun x => Sh_η J (Sh J A) (Sh_η J A x)).
Proof.
intros J A [P HP]; cbn; apply sig_eq; cbn.
apply funext; intros [Q HQ]; apply sig_eq; cbn.
apply propext; cbn; split; intros H.
+ refine (ste_mon _ _ H _); clear H; intros H.
  apply sig_eq_rev in H; cbn in H.
  subst Q; replace HQ with HP by apply pi; clear HQ.
  refine (ste_mon _ _ HP _); intros HP'.
  replace HP with (@ste_top J _ HP') by apply pi; clear HP; rename HP' into HP.
  destruct HP as [x Hx]; apply ste_top; exists x.
  split; [now apply Hx, ste_top, eq_refl|].
  apply ste_top; apply sig_eq; cbn.
  apply funext; intros x'; apply sig_eq, propext; cbn; split;
  intros; apply Hx; assumption.
+ cut (J (P = Q)).
  { clear H; intros H.
    refine (ste_mon _ _ H _); clear H; intros H.
    revert HP HQ; destruct H; intros HP HQ.
    replace HP with HQ by apply pi; apply ste_top; reflexivity. }
  refine (ste_mon _ _ H _); clear H; intros [x [Hx H]].
  refine (ste_mon _ _ H _); clear H; intros H; apply sig_eq_rev in H; cbn in H.
  rewrite <- H; clear Q HQ H.
  refine (ste_mon _ _ HP _); clear HP; intros [x' HP].
  assert (e : J (x' = x)).
  { apply HP; assumption. }
  refine (ste_mon _ _ e _); clear e; intro e; subst x'.
  apply ste_top; apply funext; intros x'; apply sig_eq; apply propext; split; intros H; cbn in *.
  - apply HP; assumption.
  - apply HP; assumption.
Qed.

Axiom choice : forall A (P : A -> Prop), (exists x, P x) -> {x : A | P x}.

Definition Sh_alg {J A} (hA : isSheaf J A) (x : Sh J A) : A.
Proof.
destruct x as [P HP].
unshelve refine (hA.(shf_elt) _ HP _).
refine (fun H => proj1_sig (choice _ _ H)).
Defined.

Lemma Sh_alg_η : forall J A (hA : isSheaf J A) (x : A),
  Sh_alg hA (Sh_η J A x) = x.
Proof.
intros J A hA x.
unfold Sh_alg; cbn.
symmetry; apply shf_spc; intros [y Hy].
destruct choice as [z Hz]; cbn.
apply closed_diag_isSeparated with J.
+ apply isSeparated_isSheaf, hA.
+ specialize (Hy x); specialize (Hz x).
  assert (i : J (y = x)).
  { apply Hy, ste_top; reflexivity. }
  assert (j : J (z = x)).
  { apply Hz, ste_top; reflexivity. }
  refine (ste_mon _ _ i (fun i => ste_mon _ _ j _)).
  intros []; apply ste_top; reflexivity.
Qed.

(** Sheafification with quotients *)
Module QuotientSh.

Axiom Quo : forall (A : Type) (R : A -> A -> Prop), Type.
Axiom quo : forall {A} R (x : A), Quo A R.
Axiom quo_eq : forall {A} {R : A -> A -> Prop} (x y : A) (e : R x y), quo R x = quo R y.

Axiom quo_rect : forall {A} {R : A -> A -> Prop} (P : Quo A R -> Type)
    (u : forall x : A, P (quo R x))
    (uε : forall (x y : A) (r : R x y), match quo_eq x y r in _ = z return P z with eq_refl => u x end = u y),
    forall q : Quo A R, P q.

Axiom quo_rect_eq : forall A R P u uε (x : A), @quo_rect A R P u uε (quo R x) = u x.

Definition quo_elim : forall {A} {R : A -> A -> Prop} (P : Type)
    (u : A -> P)
    (uε : forall (x y : A) (r : R x y), u x = u y),
    forall q : Quo A R, P.
Proof.
refine (fun A R P u uε => @quo_rect A R (fun _ => P) u _).
{ intros x y r; destruct (@quo_eq A R x y r); apply uε, r. }
Defined.

Lemma quo_elim_eq : forall A R P u uε (x : A), @quo_elim A R P u uε (quo R x) = u x.
Proof.
intros; unfold quo_elim.
refine (quo_rect_eq _ _ _ _ _ _).
Qed.

Record T (J : site) (A : Type) := {
  t_prp : Prop;
  t_prf : J t_prp;
  t_elt : (t_prp -> A);
}.

Arguments t_prp {_ _}.
Arguments t_prf {_ _}.
Arguments t_elt {_ _}.

Record Tr₀ {J A} (x y : T J A) (P : Prop) : Prop := {
  tr_prf : J P;
  tr_hom : P -> x.(t_prp) /\ y.(t_prp);
  tr_eqv : forall (p : P), x.(t_elt) (proj1 (tr_hom p)) = y.(t_elt) (proj2 (tr_hom p));
}.

Definition Tr {J A} x y := exists P, (@Tr₀ J A x y P).

Lemma Tr_refl : forall J A x, @Tr J A x x.
Proof.
intros J A x.
exists (t_prp x); unshelve econstructor.
+ tauto.
+ destruct x; tauto.
+ intros p; cbn; f_equal; apply pi.
Qed.

Lemma Tr_sym : forall J A x y, @Tr J A x y -> Tr y x.
Proof.
intros J A x y [P [i f v]].
exists P; unshelve econstructor.
+ intros; split; apply f; assumption.
+ assumption.
+ intros p; symmetry.
  specialize (v p).
  etransitivity; [|etransitivity]; [|apply v|]; f_equal; apply pi.
Qed.

Lemma Tr_trans : forall J A x y z, @Tr J A x y -> Tr y z -> Tr x z.
Proof.
intros J A x y z [P [i f v]] [Q [j g w]].
exists (P /\ Q); unshelve econstructor.
+ intros [? ?]; split; [apply f|apply g]; assumption.
+ unwrap; apply ste_top; tauto.
+ intros [p q].
  match goal with [ |- _ _ ?p = _ _ ?q ] => set (l := p); set (r := q); clearbody l r end.
  replace l with (proj1 (f p)) by apply pi.
  etransitivity; [apply v|].
  replace r with (proj2 (g q)) by apply pi.
  replace (proj2 (f p)) with (proj1 (g q)) by apply pi.
  apply w.
Qed.

Definition ShQ J A := Quo (T J A) Tr.

Lemma ShQ_eq : forall J A p q, quo Tr p = quo Tr q -> @Tr J A p q.
Proof.
intros J A p q e.
simple refine (let T := quo_rect (fun x => Prop) (fun x => Tr x q) _ (quo Tr p) in _).
{ intros x y r.
  destruct quo_eq; apply propext; split; intros;
  eapply Tr_trans; first [eassumption|apply Tr_sym; eassumption|idtac]. }
replace (Tr p q) with T; unfold T.
2:{ rewrite quo_rect_eq; reflexivity. }
rewrite e, quo_rect_eq.
apply Tr_refl.
Qed.

Definition ofSh {J A} (x : Sh J A) : ShQ J A.
Proof.
unfold ShQ.
destruct x as [Px Hx].
apply quo.
refine (Build_T _ _ _ Hx _).
intros H; apply choice in H.
destruct H as [x hx].
exact x.
Defined.

Lemma ste_iff_map : forall (J : site) A B, (A <-> B) -> (J A <-> J B).
Proof.
intros J A B [Hl Hr]; split; intros H; refine (ste_mon _ _ H _); intro; apply ste_top; intuition.
Qed.

Lemma toSh_subproof (J : site) (P : Prop) A (k : P -> A) (i : J P) :
  J (exists x : A, forall y : A, J (forall p : P, y = k p) <-> J (x = y)).
Proof.
refine (ste_mon _ _ i (fun p => _)).
apply ste_top; exists (k p); intros y.
apply ste_iff_map; split; intros H.
+ symmetry; apply H.
+ intros p'; replace p' with p by apply pi; symmetry; assumption.
Qed.

Definition toSh {J A} (x : ShQ J A) : Sh J A.
Proof.
revert x.
unshelve refine (quo_rect _ _ _).
+ intros [P i k].
  pose (join P (x : J (J P)) := @ste_mon J _ _ x (fun x => x)).
  unshelve refine (exist _ (fun x => exist _ (J (forall p, x = k p)) (join _)) _).
  apply toSh_subproof, i.
+ intros x y r; cbn.
  apply sig_eq; cbn.
  apply funext; intros z; cbn.
  apply sig_eq; cbn.
  set (e := quo_eq x y r); clearbody e.
  destruct e; cbn.
  destruct r as [P [i f e]]; cbn in *.
  destruct x as [X ix kx], y as [Y iy ky]; cbn in *.
  apply propext; split; intros H.
  - refine (ste_mon _ _ i (fun i => ste_mon _ _ H (fun H => ste_top _ _))).
    intros p; rewrite (H (proj1 (f i))), e; f_equal; apply pi.
  - refine (ste_mon _ _ i (fun i => ste_mon _ _ H (fun H => ste_top _ _))).
    intros p; rewrite (H (proj2 (f i))), <- e; f_equal; apply pi.
Defined.

Lemma toSh_ofSh : forall J A (x : Sh J A), toSh (ofSh x) = x.
Proof.
intros J A [P HP]; cbn.
apply sig_eq; cbn.
apply funext; intros x; apply sig_eq; cbn.
unfold toSh; cbn.
rewrite quo_rect_eq; cbn.
apply propext; split; intros H.
+ apply (proj2_sig (P x)).
  refine (ste_mon _ _ HP (fun HP => ste_mon _ _ H (fun H => _))).
  clear H0 HP0.
  specialize (H HP); cbn in *.
  destruct choice as [y Hy].
  subst y.
  apply ste_top, Hy, ste_top, eq_refl.
+ refine (ste_mon _ _ HP (fun HP => _)); clear HP0.
  destruct HP as [y Hy].
  assert (e : J (y = x)).
  { apply Hy; assumption. }
  refine (ste_mon _ _ e (fun e => _)); clear e0.
  subst y.
  assert (e : exists z, forall y, proj1_sig (P y) <-> J (z = y)).
  { exists x; assumption. }
  match goal with [ |- _ ?P ] => replace P with (x = proj1_sig (choice _ _ e)) end.
  2:{ apply propext; split; intros.
      + replace p with e by apply pi; assumption.
      + apply H0. }
  destruct choice as [w Hw]; cbn.
  cut (J (w = x)); [|apply Hw; assumption].
  intros Hr.
  refine (ste_mon _ _ Hr (fun Hr => ste_top _ _)); congruence.
Qed.

Lemma ofSh_toSh : forall J A (x : ShQ J A), ofSh (toSh x) = x.
Proof.
intros J A.
unshelve refine (quo_rect _ _ _).
+ intros [P i k]; cbn.
  unfold toSh; rewrite quo_rect_eq; cbn.
  apply quo_eq; cbn.
  exists ((exists x : A, forall y : A, (forall p : P, y = k p <-> x = y)) /\ P);  unshelve econstructor.
  - cbn; intros [_ p]; split; [|assumption].
    { exists (k p); intros y.
      apply ste_iff_map; split; [now intuition|].
      intros [] q; f_equal; apply pi. }
  - unwrap; apply ste_top; split; [|assumption].
    exists (k i); intros y q.
    replace q with i by apply pi; split; congruence.
  - cbn; intros [e p].
    destruct choice as [x Hx]; cbn.
    match goal with [ |- x = k ?p ] => set (q := p); clearbody q end.

    specialize (Hx (k p)).
    admit.
+ intros x y r.
  apply pi.
Abort.

Lemma isSeparated_ShQ : forall J (A : Type), isSeparated J (ShQ J A).
Proof.
intros J A R k c x y hx hy.
cut (forall p : R, x = y).
2:{ intros r; rewrite (hx r), <- (hy r); reflexivity. }
clear c hx hy.
revert x y.
unshelve refine (quo_rect _ (fun x => quo_rect _ (fun y => _) _) _).
+ intros e.
  apply quo_eq.
  destruct x as [P i x], y as [Q j y].
  (** Needs functional choice *)
  assert (eR := fun r => choice _ _ (ShQ_eq _ _ _ _ (e r))); clear e; rename eR into e.
  exists (P /\ Q /\ exists r : R, proj1_sig (e r)).
  unshelve econstructor.
  - cbn; intros [p [q r]]; split; assumption.
  - unwrap.
    set (S r := proj1_sig (e r)).
    assert (l : J (S k)); [|clearbody S; clear e].
    { clear - e; unfold S; destruct e as [? [? ? ?]]; assumption. }
    unwrap.
    apply ste_top; now intuition eauto.
  - intros [p [q [r s]]]; cbn.
    destruct e as [S [l h z]]; cbn in *; clear e.
    specialize (z s).
    etransitivity; [|etransitivity]; [|apply z|]; f_equal; apply pi.
+ intros; apply pi.
+ intros; apply pi.
Qed.

Lemma isSheaf_ShQ : forall J (A : Type), isSeparated J A -> isSheaf J (ShQ J A).
Proof.
intros J A hA.
(* assert (hShA := isSeparated_ShQ J A). *)
unshelve econstructor.
+ intros P i x.
  simple refine (let R : P -> Prop := fun p => _ in _).
  { simple refine (@quo_rect _ _ (fun _ => Prop) (fun p => J (t_prp p)) _ (x p)); cbn.
    abstract (intros [Q j y] [R k z] e; destruct quo_eq; apply propext; cbn in *; tauto). }
  apply quo.
  exists (exists p : P, R p).
  - unwrap.
    assert (j : R i).
    { unfold R. generalize (x i); clear - hA.
      simple refine (quo_rect _ _ _); cbn.
      + intros [Q j y].
        rewrite quo_rect_eq; cbn; assumption.
      + intros; apply pi. }
    apply ste_top; exists i; assumption.
  - intros H.
    assert (i' : P) by (destruct H; assumption).
    clear i; rename i' into i.
    assert (j : R i).
    { destruct H as [i' j]; replace i with i' by apply pi; assumption. }
    clear H.
    unfold R in j; clear R.
    set (H := isSheaf_ShQ_subproof J A P x i) in j; clearbody H.
    set (x' := x i) in *; clearbody x'; clear x; rename x' into x.
    revert x H j.
    simple refine (quo_rect _ _ _); cbn.
    * intros [Q j y] H; cbn.
      rewrite quo_rect_eq; cbn.

Abort.

Definition ShQ_η {J A} (x : A) : ShQ J A :=
  quo _ (Build_T _ _ True (ste_top _ I) (fun _ => x)).

(*
Lemma ShQ_univ {J A B} (hB : isSheaf J B) (f : A -> B) (x : ShQ J A) : B.
Proof.
revert x.
simple refine (quo_rect _ _ _); cbn.
+ intros [P i x].
  refine (hB.(shf_elt) P i (fun p => f (x p))).
+ intros [P i x] [Q j y] [T [k h z]]; simpl in *.
  apply hB.(shf_spc); intros q.
  match goal with [ |- (match ?p with eq_refl => _ end = _) ] => set (e := p); clearbody e end.
*)

Definition ShQ_bind {J A B} (x : ShQ J A) (f : A -> ShQ J B) : ShQ J B.
Proof.
revert x.
simple refine (quo_rect _ _ _); cbn.
+ intros [P i x].
  refine (quo _ _).
  simple refine (let R : P -> Prop := fun p => _ in _).
  { simple refine (@quo_rect _ _ (fun _ => Prop) t_prp _ (f (x p))); cbn.
    intros y z r.
    destruct quo_eq.
  (* Global choice *)
Abort.

Definition ShQ_alg {J A} (hA : isSheaf J A) (x : ShQ J A) : A.
Proof.
destruct hA as [hA eA].
revert x; simple refine (quo_rect _ _ _).
+ intros [P i x].
  apply (hA P i x).
+ intros x y e; cbn.
  apply eA; intros q.
  destruct quo_eq.
  symmetry; apply eA; intros p.
  destruct e as [R [k ? e]].
  transitivity (hA R k (fun _ => t_elt x p)).
  - apply eA; intros r.
    symmetry; etransitivity; [|etransitivity]; [|apply (e r)|]; f_equal; apply pi.
  - symmetry; apply eA; intros r; reflexivity.
Defined.

Lemma ShQ_alg_η : forall J A (hA : isSheaf J A) (x : A),
  ShQ_alg hA (ShQ_η x) = x.
Proof.
intros J A hA x.
unfold ShQ_alg, ShQ_η.
rewrite quo_rect_eq.
symmetry; apply shf_spc; intros; reflexivity.
Qed.

End QuotientSh.

Module DialogueSh.

Axiom ShD : site -> Type -> Type.
Axiom ret : forall {J A}, A -> ShD J A.
Axiom ask : forall {J : site} {A} (P : Prop) (i : J P), (P -> ShD J A) -> ShD J A.
Axiom eqn : forall (J : site) A P (i : J P) (x : ShD J A),
  ask P i (fun (_ : P) => x) = x.

Axiom ShD_rect : forall (J : site) (A : Type) (P : ShD J A -> Type)
  (ur : forall (x : A), P (ret x))
  (ua : forall (S : Prop) (i : J S) (k : S -> ShD J A),
    (forall p : S, P (k p)) -> P (ask S i k))
  (ue : forall (S : Prop) (i : J S) (x : ShD J A) (px : P x),
    match eqn J A S i x in _ = e return P e with eq_refl => ua S i (fun _ => x) (fun _ => px) end = px)
  (x : ShD J A)
,
  P x.
(* P (ask S i (fun _ => x) *)

Axiom ShD_rect_ret : forall J A P ur ua ue (x : A),
  ShD_rect J A P ur ua ue (ret x) = ur x.

Axiom ShD_rect_ask : forall (J : site) A P ur ua ue (S : Prop) (i : J S) (k : S -> ShD J A),
  ShD_rect J A P ur ua ue (ask S i k) = ua S i k (fun p => ShD_rect J A P ur ua ue (k p)).

Definition bind {J A B} (m : ShD J A) (f : A -> ShD J B) : ShD J B.
Proof.
simple refine (ShD_rect _ _ (fun _ => ShD J B) f (fun S i k r => ask S i r) _ m).
{
  cbn; intros S i x y.
  destruct eqn; apply eqn.
}
Defined.

Lemma ret_bind : forall J A B (x : A) (f : A -> ShD J B), bind (ret x) f = f x.
Proof.
intros; unfold bind; cbn.
rewrite ShD_rect_ret; reflexivity.
Qed.

Lemma bind_ret : forall J A (m : ShD J A) , bind m ret = m.
Proof.
intros; unfold bind; cbn; revert m.
simple refine (ShD_rect _ _ _ _ _ _); cbn.
+ intros x.
  rewrite ShD_rect_ret; reflexivity.
+ intros S i k e; rewrite ShD_rect_ask.
  f_equal; apply funext; intros s.
  rewrite (e s); reflexivity.
+ intros; apply pi.
Qed.

Lemma bind_assoc : forall J A B C (f : A -> ShD J B) (g : B -> ShD J C) (m : ShD J A),
  bind (bind m f) g = bind m (fun x => bind (f x) g).
Proof.
intros J A B C f g.
simple refine (ShD_rect _ _ _ _ _ _); unfold bind; cbn.
+ intros x.
  rewrite !ShD_rect_ret; cbn; reflexivity.
+ intros S i k e.
  rewrite !ShD_rect_ask; f_equal; apply funext; intros s.
  rewrite (e s).
  reflexivity.
+ intros; apply pi.
Qed.

(*

Γ ⊢ P : bool → Type
Γ ⊢ ut : P true
Γ ⊢ uf : P false
================
_ : Π b : bool, P b

Γ, b : bool ⊢ P is a type
Γ ⊢ ut : P true
Γ ⊢ uf : P false
================
_ : Π b : bool, P b

*)

(* Small elimination *)
Lemma bool_dep_elim : forall J
  (P : ShD J bool -> Type) (Pε : forall b, isSheaf J (P b))
  (ut : P (ret true))
  (uf : P (ret false))
  (b : ShD J bool),
  P b.
Proof.
intros J P Pε ut uf.
simple refine (ShD_rect _ _ _ _ _ _); [intros [|]| |].
+ apply ut.
+ apply uf.
+ refine (fun S i k r => _).
  refine ((Pε (ask S i k)).(shf_elt) S i (fun s => _)).
  replace k with (fun (_ : S) => k s).
  2: { abstract (apply funext; intros; f_equal; apply pi). }
  rewrite eqn.
  apply r.
+ intros S i x r; cbn in *.
  set (e := eqn J bool S i x); clearbody e.
  match goal with [ |- context [ shf_elt _ _ _ ?f ] ] => set (k := f) end; cbn in k.
  pose (r' := match e in _ = x' return P x' -> P (ask S i (fun _ => x)) with eq_refl => fun r => r end r).
  replace (shf_elt (Pε (ask S i (fun _ : S => x))) S i k) with r'; unfold r'; clear r'.
  2:{ apply shf_spc; intros s; unfold k.
      unfold eq_rect_r, eq_rect, eq_sym.
      set (rw := bool_dep_elim_subproof J S (fun _ : S => x) s); clearbody rw.
      assert (e' : rw = eq_refl) by apply pi.
      cbn in rw; rewrite e'.
      rewrite e; reflexivity.
      }
  clear.
  rewrite e; reflexivity.
Qed.

(** The result of sheafifying is a sheaf... *)
Lemma isSheaf_ShD J A : isSheaf J (ShD J A).
Proof.
  apply is_Sheaf_Sheaf'.
  exists ask.
  intros; symmetry ; apply eqn.
Defined.

Lemma shf_elt_ShD J A S i h : shf_elt (isSheaf_ShD J A) S i h = ask S i h.
Proof. reflexivity. Defined.

(* mu and map combinators on ShD *)

Definition mu {J A} (m : ShD J (ShD J A)) := bind m (fun x => x).

Definition map {J A B} (f : A -> B) (m : ShD J A) : ShD J B := bind m (fun x => ret (f x)).

Lemma map_ret {J A B} (f : A -> B) (x : A) : map (J:=J) f (ret x) = ret (f x).
Proof. unfold map; now rewrite ret_bind. Qed.

(* Probably the most surpising lemma of the bunch
   Equivalent to the idempotence of ShD according to nlab *)
Lemma map_ret' {J A} : forall (x : ShD J A), map ret x = ret x.
Proof.
  simple refine (ShD_rect _ _ _ _ _ _); cbn.
  - intros; now rewrite map_ret.
  - intros. unfold map, bind. rewrite ShD_rect_ask.
    set (h := fun _ => _); set (x := ret _).
    assert (h = fun _ => x) as ->; [| apply eqn].
    apply funext; intro p.
    specialize H with p.
    unfold h, x. clear h x.
    unfold map, bind in H.
    rewrite H.
    f_equal.
    symmetry.
    assert (k = fun _ => k p) as ->; [|apply eqn].
    apply funext. intros. f_equal; apply pi.
  - intros; apply pi.
Qed.

Definition map_cmp {J A B C} (f : A -> B) (g : B -> C) (m : ShD J A) :
  map g (map f m) = map (fun x=> g (f x)) m.
Proof.
  unfold map.
  rewrite bind_assoc.
  f_equal. apply funext; intros ?. rewrite ret_bind. reflexivity.
Qed.

(** Algebra structure on ShD  and lemmas *)

Definition ShD_alg {J A} (hA : isSheaf J A) : ShD J A -> A.
Proof.
  simple refine (ShD_rect _ _ _ _ _ _); [trivial| ..].
  - intros S i k h; cbn; apply (shf_elt hA S i h).
  - cbn; intros S i x px. destruct (eqn J A S i x).
    symmetry; apply shf_spc; reflexivity.
Defined.

(* ShD_alg is a two sided inverse to ret *)
Lemma ShD_alg_ret {J A} (hA : isSheaf J A) : forall x,  ShD_alg hA (ret x) = x.
Proof. intros; unfold ShD_alg; now rewrite ShD_rect_ret. Qed.

Lemma ret_ShD_alg {J A} (hA : isSheaf J A) : forall x,  ret (ShD_alg hA  x) = x.
Proof.
  intros x.
  rewrite <- map_ret.
  rewrite <- map_ret'.
  rewrite map_cmp.
  set (h := fun _ => _); assert (h = fun x => x) as ->.
  + apply funext; intros; unfold h; now rewrite ShD_alg_ret.
  + unfold map; now rewrite bind_ret.
Qed.

(* The algebra structure on a free sheave is.. free *)
Lemma ShD_alg_free {J A} : forall (m : ShD J (ShD J A)),
  ShD_alg (isSheaf_ShD J A) m = mu m.
Proof.
  simple refine (ShD_rect _ _ _ _ _ _); cbn.
  - intros. unfold mu.
    now rewrite ShD_alg_ret, ret_bind.
  - intros S i k h.
    unfold ShD_alg, mu, bind; rewrite !ShD_rect_ask, shf_elt_ShD.
    f_equal; apply funext; intro p.
    apply (h p).
  - cbn; intros. apply pi.
Qed.

(** Every map between types is an algebra homomorphism *)
Lemma ShD_homomorphism {J A B} (hA : isSheaf J A) (hB : isSheaf J B) (f : A -> B) (m : ShD J A) :
  ShD_alg hB (map f m) = f (ShD_alg hA m).
Proof.
  now rewrite <- (ret_ShD_alg hA m), map_ret, ShD_alg_ret, (ret_ShD_alg hA m).
Qed.

(** Being a sheaf is closed under dependent sum *)

(* technical lemma on eq_rect *)
Lemma rew_swap' :
  forall (A : Type) (P : A -> Type) (x1 x2 : A) (H : x1 = x2)
    (y1 : P x1) (y2 : P x2),
  eq_rect_r P y2 H = y1 -> y2 = eq_rect x1 P y1 x2 H.
Proof.
  intros ? ? ? ? h ? ? e.
  rewrite <- (rew_opp_r _ h y2).
  rewrite e.
  reflexivity.
Qed.

Lemma sigma_sheaf : forall J A (Aε : isSheaf J A)
  (B : A -> Type) (Bε : forall a, isSheaf J (B a)),
    isSheaf J { a : A & B a}.
Proof.
  intros.
  unshelve econstructor.
  - intros P i f. exists (shf_elt Aε P i (fun p => projT1 (f p))).
    apply (shf_elt (Bε _) P i).
    intro x.
    rewrite <- shf_spc with (x0:= projT1 (f x)).
    exact (projT2 (f x)).
    intro; do 2 f_equal; apply pi.
  - intros; destruct x as [x1 x2].
    simple refine (eq_existT_curried _ _ ).
    + apply shf_spc. intro p; exact (f_equal (projT1 (P:=B)) (H p)).
    + apply shf_spc; intro p.
      set (e1 := shf_spc _ _ _ _ _ _).
      set (e2 := shf_spc _ _ _ _ _ _).
      apply rew_swap'; unfold eq_rect_r; rewrite rew_compose.
      rewrite <- (projT2_eq (H p)).
      f_equal. apply pi.
Defined.

Section Complicated_bool_dep_elim.
  (**
     Another way to derive the small dependent eliminator on Bool
     using the closure of sheaves under Sigma types
     (trying to understand what is necessary to obtain this kind of elimination)

     It does not look like a good challenger for its computational content,
     even though in the (strict) setoid model it probably just works®
     (that is simpl_b (ret b) ≡ eq_refl)
   *)
  Context J
          (P : ShD J bool -> Type) (Pε : forall b, isSheaf J (P b))
          (ut : P (ret true))
          (uf : P (ret false)).

  Definition P' b := P (ret b).
  Definition Pε' b : isSheaf J (P' b) := Pε (ret b).
  Definition pack_with_pf b :=
    existT P (ret b) (if b as b0 return (P' b0) then ut else uf).

  Definition alg := ShD_alg (sigma_sheaf J (ShD J bool) (isSheaf_ShD J bool) P Pε).

  Lemma simpl_b (b : ShD J bool) : projT1 (alg (map pack_with_pf b)) = b.
  Proof.
    unfold alg; rewrite <- (ShD_homomorphism _ (isSheaf_ShD J bool)), map_cmp.
    cbn; now rewrite map_ret', ShD_alg_ret.
  Qed.

  Definition bool_dep_elim'  (b : ShD J bool) : P b :=
    eq_rect _ P (projT2 (alg (map pack_with_pf b))) b (simpl_b b).
End Complicated_bool_dep_elim.