(**************************************************************************
* TLC: A library for Coq                                                  *
* Environments for metatheory                                             *
* An attempt to generalize this by Brian Milnes.
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibOption TLC.LibList TLC.LibProd TLC.LibLogic TLC.LibReflect.
Require Import LibNotIn LibFresh LibKeyType LibValueType.

(* ********************************************************************** *)
(** * 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 *)

Module GenEnv(K : KeyType) (V : ValueType).
Import K.
Import V.

Definition env := list (key * value).

Module Type EnvOpsSig.

Section Definitions.

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

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

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

Parameter singles : list key -> list value -> env.
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 -> list key.
Parameter keys_def :
  keys = map fst.

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

Parameter fold_keys : (value -> fset key) -> env -> fset key.
Parameter fold_keys_defs :
  fold_keys = fun fv E =>
    fold_right (fun v acc => fv v \u acc) \{} (values E).

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

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

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

Parameter get : key -> env -> option value.
Fixpoint get_impl (k : key) (E : env) {struct E} : option value :=
  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.
End EnvOpsSig.

Module Export EnvOps : EnvOpsSig.
Section Concrete.

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

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

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

Definition singles (xs : list key) (vs : list value) : env :=
  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 using. reflexivity. Qed.

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

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

Definition fold_keys (fv : value -> fset key) (E : env) :=
  fold_right (fun v acc => fv v \u acc) \{} (values E).
Lemma fold_keys_defs :
  fold_keys = fun fv E => fold_right (fun v acc => fv v \u acc) \{} (values E).
Proof using. reflexivity. Qed.

Definition map (f:value -> value) (E:env) :=
  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 using. reflexivity. Qed.

Definition map_keys (f:key -> key) (E:env) :=
  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 using. reflexivity. Qed.

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

Fixpoint get_impl (k : key) (E : env) {struct E} : option value :=
  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 using. reflexivity. Qed.

End Concrete.

End EnvOps.

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

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

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

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

Notation "xs ~* vs" := (singles xs vs)
  (at level 7, 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.
End LibEnvNotations.
Import LibEnvNotations.

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

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

Section MoreDefinitions.
Implicit Types E F : env.

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

Inductive ok : env -> 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 x (E:env) :=
  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: value -> fset key) (E:env) :=
  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.

Implicit Types k x : key.
Implicit Types v : value.
Implicit Types E F G : env.
Implicit Types r : key -> key.

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

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

Lemma map_empty : forall f,
  map f empty = empty.
Proof using. intros. rew_env_defs. auto. Qed.

Lemma map_single : forall f x v,
  map f (x ~ v) = (x ~ (f v)).
Proof using. intros. rew_env_defs. auto. Qed.

Lemma map_concat : forall f E F,
  map f (E & F) = map f E & map f F.
Proof using.
  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 using. intros. rewrite map_concat, map_single. auto. Qed.

Lemma map_keys_empty : forall r,
  map_keys r empty = empty.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_keys_single : forall r x v,
  map_keys r (x ~ v) = ((r x) ~ v).
Proof using. 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 using.
  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 using. intros. rewrite map_keys_concat, map_keys_single. auto. Qed.

Lemma get_empty : forall k,
  get k empty = None.
Proof using. 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 using. 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 using.
  intros. rew_env_defs. induction F as [|(x,v)].
  auto.
  simpl. case_if~.
Qed.

Lemma dom_empty :
  dom empty = \{}.
Proof using. rew_env_defs. auto. Qed.
Lemma dom_single : forall x v,
  dom (x ~ v) = \{x}.
Proof using.
  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 using.
  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 using.
  intros. rewrite dom_concat. rewrite dom_single.
  rewrite~ union_comm.
Qed.

End Properties.

Section SinglesProperties.
Implicit Types x : key.
Implicit Types v : value.
Implicit Types xs : list key.
Implicit Types vs : list value.
Implicit Types E F : env.

Lemma singles_nil :
  nil ~* nil = empty.
Proof using. intros. rew_env_defs. auto. Qed.

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

Lemma singles_one : forall x v,
  (x::nil) ~* (v::nil) = (x ~ v).
Proof using. 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 using. 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 using.
  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 using.
  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 using.
  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 : value -> value) xs vs,
  length xs = length vs ->
  map f (xs ~* vs) = xs ~* (LibList.map f vs).
Proof using.
  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 using.
  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 using.
  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 using.
  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.

Implicit Types x : key.
Implicit Types v : value.
Implicit Types E F : env.

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

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

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

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

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

Lemma empty_concat_inv : forall E F,
  empty = E & F -> empty = E /\ empty = F.
Proof using. 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 using. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_middle_inv : forall E F x v,
  empty = E & x ~ v & F -> False.
Proof using. 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 using. 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 using. introv H. rew_env_defs. inverts~ H. Qed.

End StructProperties.

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

Section MoreProperties.

Variable K A : Type.
Implicit Types x : key.
Implicit Types v : value.
Implicit Types E F : env.

Lemma dom_map : forall (f: value -> value) E,
  dom (map f E) = dom E.
Proof using.
  induction E using env_ind.
  rewrite map_empty.
  (* Funny bug in rewrite, with A :Type it has to rewrite twice in the old. *)
  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 using.
  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 using.
  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 using. (* 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 using. (* 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 using.
  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 using.
  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 x v (E:env),
  binds x v E -> get_or_arbitrary x E = v.
Proof using. introv M. unfold get_or_arbitrary. rewrite~ M. Qed.

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

Global Instance indom_decidable : forall (E:env) x,
  Decidable (x \in dom E).
Proof using.
  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_in_star_patch ltac:(fun tt => autorewrite with rew_env_concat).
  (* 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.

Implicit Types k x : key.
Implicit Types v : value.
Implicit Types E F : env.

Lemma ok_push_inv : forall E x v,
  ok (E & x ~ v) -> ok E /\ x # E.
Proof using.
  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 using. introv H. destruct* (ok_push_inv H). Qed.

Lemma ok_concat_inv : forall E F,
  ok (E & F) -> ok E /\ ok F.
Proof using.
  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 using. introv H. lets*: ok_concat_inv H. Qed.

Lemma ok_concat_inv_r : forall E F,
  ok (E & F) -> ok F.
Proof using. 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 using.
  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 using.
  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 using. 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 using. introv H. forwards~ [_ ?]: ok_middle_inv H. Qed.

Lemma ok_remove : forall F E G,
  ok (E & F & G) -> ok (E & G).
Proof using.
  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 : value -> value),
  ok E -> ok (map f E).
Proof using.
  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 : value -> value),
  ok (E & F) -> ok (E & map f F).
Proof using.
  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 value),
  fresh key (dom E) n xs ->
  length xs = length vs ->
  ok E ->
  ok (E & xs ~* vs).
Proof using.
  introv F EQ O. gen E n vs.
  induction xs; destruct vs; destruct n; intros; tryfalse;
  try rewrite singles_nil; try rewrite~ concat_empty_r. (* change *)
  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 using. ...
  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 using.
  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 [K A E x v].
Implicit Arguments ok_concat_inv [K A E F].
Implicit Arguments ok_remove [K A F E G].
Implicit Arguments ok_map [K A E f].
Implicit Arguments ok_middle_inv_l [K A E F x v].
Implicit Arguments ok_middle_inv_r [K A E F x v].
Implicit Arguments ok_middle_inv [K 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 K A B : Type.
Implicit Types E F : env.
Implicit Types x : key.
Implicit Types v : value.

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

(** Constructor forms *)

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

Lemma binds_single_eq : forall x v,
  binds x v (x ~ v).
Proof using.
  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 using.
  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 using.
  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 using. 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 using.
  introv H. forwards [|]: binds_push_inv H. autos*. 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 using.
  introv H. forwards [|]: binds_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma binds_tail : forall x v E,
  binds x v (E & x ~ v).
Proof using. 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 using.
  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 using.
  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 : value -> value) E,
  binds x v E -> binds x (f v) (map f E).
Proof using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using.
  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 using. 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 using.
  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 using.
  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 using.
  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 using.
  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 using.
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 using.
  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 K A : Type.
Implicit Types x : key.
Implicit Types v : value.
Implicit Types E F : env.

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

Lemma extends_push : forall E x v,
  x # E -> extends E (E & x ~ v).
Proof using.
  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 using.
  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 using.
  introv D B. unfolds binds.
  lets: get_some_inv x v E. (* Difference. *)
  forwards M: get_none 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 x (v: value) (E1 E2 : env),
  binds x v (E1 & E2) ->
     (x # E2 /\ binds x v E1)
  \/ (binds x v E2).
Proof using. intros.
 lets: binds_concat_inv.
 forwards K: binds_concat_inv x v H. (* Difference. *)
 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.
*)

End GenEnv.


Require Import Arith ZArith ZifyClasses ZifyInst Lia.
From stdpp Require Import base numbers.
From iris.algebra Require Import updates csum excl agree big_op.
Set Default Proof Using "Type".

(** * Indexed Oneshot RA *)
(* This resource algebra corresponds intuitively to an indexed oneshot algebra
   with elements [pending b] and [shot b v] governed by the usual rules where
   [b] is the index. This generalization allows us to allocate [pending b] for
   all [b : nat] at once and split these in various ways, allowing a party to
   own all [pending b] such that some fact holds for [b], e.g. [even b]. *)
Definition ballot_oneshotUR (A : ofe) :=
  discrete_funUR (λ (b : nat), optionUR (csumR (exclR (unitR)) (agreeR A))).

(* For the [lia] tactic to support [Z.div], [Z.modulo], [Z.quot], and [Z.rem] *)
Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations.
(* For the [lia] tactic to support [Nat.modulo] and [Nat.div]. *)
Program Instance Op_Nat_mod : BinOp Nat.modulo :=
  {| TBOp := Z.modulo ; TBOpInj := Nat2Z_inj_mod |}.
Add Zify BinOp Op_Nat_mod.
Program Instance Op_Nat_div : BinOp Nat.div :=
  {| TBOp := Z.div ; TBOpInj := Nat2Z_inj_div |}.
Add Zify BinOp Op_Nat_div.

Section arith_lemmas.

  Lemma mod_exists b N i :
    N ≠ 0 →
    b `mod` N = i ↔ b = (b / N) * N + i.
  Proof. auto with lia. Qed.

  Lemma plus_lt_reg_r n m p : n + p < m + p -> n < m.
  Proof.
    rewrite 2!(plus_comm _ p). apply plus_lt_reg_l.
  Qed.

  Lemma mod_lowerbound_incr b b' i N :
    N ≠ 0 →
    b' `mod` N = i →
    b * N + i < b' →
    (b + 1) * N + i ≤ b'.
  Proof.
    move=> Hneq.
    rewrite mod_exists // => ->.
    have: 0 < N by lia.
    move=> Hlt /plus_lt_reg_r /(Nat.mul_lt_mono_pos_r N b _ Hlt) ?.
    apply plus_le_compat_r, Nat.mul_le_mono_r.
    lia.
  Qed.

End arith_lemmas.

Section ra.
  Context {A : ofe}.

  (* a [pending] element for all naturals *)
  Definition pending_all : ballot_oneshotUR A :=
    λ b, Some (Cinl (Excl ())).

  (* an element for every [b] in the equivalence class [i mod N] with the
     [lb] least elements removed *)
  Definition pending_class (i : nat) (N : nat) (lb : nat) : ballot_oneshotUR A :=
    λ b, if (b `mod` N =? i) && (lb * N + i <=? b) then Some (Cinl (Excl ())) else None.

  (* a single [pending] element for ballot [c] *)
  Definition pending_ballot (c : nat)  : ballot_oneshotUR A :=
    λ b, if b =? c then Some (Cinl (Excl ())) else None.

  (* the [shot] element for ballot [c] and value [a] *)
  Definition shot_ballot (c : nat) (a : A) : ballot_oneshotUR A :=
    λ b, if b =? c then Some (Cinr (to_agree a)) else None.

  Hint Rewrite leb_correct_conv using lia : natb.
  Hint Rewrite leb_correct using lia : natb.
  Hint Rewrite leb_complete using lia : natb.

  Global Instance shot_core_id b v : CoreId (shot_ballot b v).
  Proof.
    rewrite /CoreId /= /shot_ballot.
    rewrite /pcore /cmra_pcore /= /ucmra_pcore /=.
    rewrite /discrete_fun_pcore_instance.
    f_equiv. intros ?. by destruct (x =? b).
  Qed.

  Local Lemma filter_class (b N : nat) :
    N ≠ 0 →
    filter (λ y : nat, b `mod` N = y ∧ y ≤ b) (set_seq 0 N) =
    {[b `mod` N]} :> gset nat.
  Proof.
    intros HN.
    apply set_eq_subseteq; split.
    - intros x.
      rewrite elem_of_filter elem_of_set_seq elem_of_singleton /=;
              intros [[? ?] ?]; lia.
    - intros x; rewrite elem_of_filter elem_of_set_seq elem_of_singleton /=.
      intros ->; split_and!; [done| |lia|lia].
      apply Nat.mod_le; done.
  Qed.

  Lemma big_opS_apply (g : gset nat) (f : nat → ballot_oneshotUR A) (b : nat) :
    ([^op set] x ∈ g, f x) b ≡ [^op set] x ∈ g, f x b.
  Proof.
    induction g as [|z g' Hz IHg'] using set_ind_L.
    - rewrite !big_opS_empty; done.
    - assert (∀ g1 g2 : ballot_oneshotUR A, ∀ x, g1 ≡ g2 → g1 x ≡ g2 x) as Hconv.
      { intros ??? Hequiv; apply Hequiv. }
      transitivity ((f z ⋅ [^op set] x ∈ g', f x) b).
      { apply Hconv.
        rewrite big_opS_union; last set_solver.
        rewrite big_opS_singleton; done. }
      rewrite big_opS_union; last set_solver.
      rewrite big_opS_singleton.
      rewrite discrete_fun_lookup_op.
      f_equiv; done.
  Qed.

  Lemma pending_all_split_classes N :
    N ≠ 0 →
    pending_all ≡ [^op set] x ∈ set_seq 0 N, pending_class x N 0.
  Proof.
    intros HNnz.
    intros b.
    rewrite big_opS_apply.
    rewrite /pending_all.
    rewrite (big_opS_proper _ (λ x, if decide ((b `mod` N = x) ∧ (x <= b)) then
                 Some (Cinl (Excl ())) else None)); last first.
    { intros x Hx.
      rewrite /pending_class.
      destruct decide as [[? ?]|].
      - erewrite (proj2 (Nat.eqb_eq _ _)); last done.
        erewrite (proj2 (Nat.leb_le _ _)); done.
      - destruct (decide (b `mod` N = x)); destruct (decide (x ≤ b)).
        + lia.
        + erewrite (proj2 (Nat.eqb_eq _ _)); last done.
          erewrite (proj2 (Nat.leb_nle _ _)); done.
        + erewrite (proj2 (Nat.eqb_neq _ _)); last done.
          erewrite (proj2 (Nat.leb_le _ _)); done.
        + erewrite (proj2 (Nat.eqb_neq _ _)); last done.
          erewrite (proj2 (Nat.leb_nle _ _)); done. }
    rewrite -big_opS_filter' filter_class; last done.
    rewrite big_opS_singleton; done.
  Qed.

  Lemma pending_set_split i N b :
    N ≠ 0 →
    i < N →
    pending_class i N b ≡ pending_class i N (b + 1) ⋅ pending_ballot (b * N + i).
  Proof.
    rewrite /pending_class /pending_ballot.
    intros Hneq Hlt b'.
    rewrite discrete_fun_lookup_op.
    destruct ((b' `mod` N =? i) && (b * N + i <=? b')) eqn:Heq.
    - apply andb_true_iff in Heq.
      destruct Heq as [Hmod%beq_nat_true ?%leb_complete]; simpl.
      rewrite Hmod Nat.eqb_refl /=.
      destruct (b' =? b * N + i) eqn:Heq.
      { apply beq_nat_true in Heq. by autorewrite with natb. }
      apply beq_nat_false in Heq.
      assert ((b + 1) * N + i <=? b' = true) as ->; [|done].
      apply leb_correct.
      assert (b * N + i < b') as H by lia.
      by apply mod_lowerbound_incr.
    - apply andb_false_iff in Heq.
      destruct Heq as [Heq | Heq]; simpl.
      + rewrite Heq /=.
        apply beq_nat_false in Heq.
        assert (b' =? b * N + i = false) as ->; [|done].
        apply beq_nat_false_iff. intros ->.
        rewrite -{2}(Nat.mod_small _ _ Hlt) plus_comm
                    (Nat.mod_add i _ _ Hneq) // in Heq.
     + apply leb_iff_conv in Heq.
       assert ((b + 1) * N + i <=? b' = false) as ->.
       { by autorewrite with natb. }
       rewrite andb_false_r.
       assert (b' =? b * N + i = false) as ->; [|done].
       apply beq_nat_false_iff. lia.
  Qed.

  Lemma ballot_update b v :
    pending_ballot b ~~> shot_ballot b v.
  Proof.
    rewrite /pending_ballot /shot_ballot.
    move=> n [c|] + b' /=; [|by destruct (b' =? b)].
    move=> /(_ b') /=.
    rewrite !discrete_fun_lookup_op.
    destruct (b' =? b); [|done].
    destruct c as [c0|]; [|done].
    rewrite -!Some_op !Some_validN.
    have: (✓ Cinr (to_agree v))=> H; [done|].
    apply (cmra_update_exclusive _ (H _) _ (Some c0)).
  Qed.

  Lemma pending_shot_not_valid b v :
    ✓ (pending_ballot b ⋅ shot_ballot b v) → False.
  Proof.
    rewrite /pending_ballot /shot_ballot=> /(_ b).
    rewrite discrete_fun_lookup_op -beq_nat_refl //.
  Qed.

  Lemma shot_shot_valid b v1 v2:
    ✓ (shot_ballot b v1 ⋅ shot_ballot b v2) ↔ v1 ≡ v2.
  Proof.
    rewrite /shot_ballot. split.
    - move=> /(_ b).
      rewrite discrete_fun_lookup_op -beq_nat_refl.
      rewrite -Some_op -Cinr_op Some_valid Cinr_valid.
      move=> /agree_op_inv /(inj to_agree _ _) //.
    - move=> Heq b'.
      rewrite discrete_fun_lookup_op.
      destruct (b' =? b); [|done].
      rewrite -Some_op -Cinr_op Some_valid Cinr_valid.
      by apply to_agree_op_valid.
  Qed.

End ra.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export QArith_base.
Require Export Qring.
Require Export Qreduction.


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import CFML.CFLibCredits.
Require Import Dominated.
Require Import Monotonic.
Require Import CFMLBigO.

(* Ideally, we should link this file to the UF Coq development of Charguéraud &
   Pottier. For the moment, since this is a small demo example, we instead
   axiomatize part of their toplevel definitions and theorems. *)

Section UF.

Parameter (elem data : Type).

Implicit Types x : elem.
Implicit Types D : set elem.
Implicit Types R : elem -> elem.
Implicit Types V : elem -> data.

Parameter card : set elem -> Z.
Hypothesis card_nonneg : forall D, 0 <= card D.
Hint Resolve card_nonneg : zarith.

Parameter UF : set elem -> (elem -> elem) -> (elem -> data) -> hprop.

Parameter UnionFind_ml_find : func.

Parameter alpha : Z -> Z.

Hypothesis alpha_nonneg : forall (x: Z), 0 <= alpha x.
Hint Resolve alpha_nonneg : zarith.

Hypothesis alpha_monotonic : monotonic Z.le Z.le alpha.
Hint Resolve alpha_monotonic : monotonic.

Hypothesis alpha_limit : limit Z_filterType Z_filterType alpha.
Hint Resolve alpha_limit : limit.

Parameter find_spec : forall D R V x, x \in D ->
  app UnionFind_ml_find [x]
    PRE  (UF D R V \* \$(2 * alpha (card D) + 4))
    POST (fun y => UF D R V \* \[ R x = y ]).

Theorem find_specO :
  specO Z_filterType Z.le
    (fun cost =>
      (forall D R V x, x \in D ->
       app UnionFind_ml_find [x]
         PRE  (\$(cost (card D)) \* UF D R V)
         POST (fun y => UF D R V \* \[ R x = y ])))
    alpha.
Proof using alpha_limit alpha_monotonic alpha_nonneg card_nonneg.
  xspecO_refine straight_line. intros. xapply find_spec. applys~ H.
  (* workaround *) sets cD: (card D). hsimpl; piggybank: *rhs. hsimpl~.
  cleanup_cost. monotonic. dominated.
Qed.

End UF.


(**********************************************************************************

 The product via two-sided displayed categories

 By taking the displayed objects and displayed morphisms to be inhabitants of the
 unit type, we obtain the product of two categories.

 Contents
 1. Definition via two-sided displayed categories
 2. Discreteness and univalence

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration.

Local Open Scope cat.

Section ProductTwoSidedDispCat.
  Context (C₁ C₂ : category).

  (**
   1. Definition via two-sided displayed categories
   *)
  Definition prod_twosided_disp_cat_ob_mor
    : twosided_disp_cat_ob_mor C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact (λ _ _, unit).
    - exact (λ _ _ _ _ _ _ _ _, unit).
  Defined.

  Definition prod_twosided_disp_cat_id_mor
    : twosided_disp_cat_id_comp prod_twosided_disp_cat_ob_mor.
  Proof.
    simple refine (_ ,, _).
    - exact (λ _ _ _, tt).
    - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt).
  Defined.

  Definition prod_twosided_disp_cat_data
    : twosided_disp_cat_data C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact prod_twosided_disp_cat_ob_mor.
    - exact prod_twosided_disp_cat_id_mor.
  Defined.

  Definition prod_twosided_disp_cat_axioms
    : twosided_disp_cat_axioms prod_twosided_disp_cat_data.
  Proof.
    repeat split ; intro ; intros.
    - apply isapropunit.
    - apply isapropunit.
    - apply isapropunit.
    - apply isasetunit.
  Qed.

  Definition prod_twosided_disp_cat
    : twosided_disp_cat C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact prod_twosided_disp_cat_data.
    - exact prod_twosided_disp_cat_axioms.
  Defined.

  (**
   2. Discreteness and univalence
   *)
  Definition constant_twosided_disp_cat_is_iso
    : all_disp_mor_iso prod_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg.
    simple refine (_ ,, _ ,, _).
    - exact tt.
    - apply isapropunit.
    - apply isapropunit.
  Defined.

  Definition is_univalent_prod_twosided_disp_cat
    : is_univalent_twosided_disp_cat prod_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂.
    induction p₁, p₂ ; cbn.
    use isweqimplimpl.
    - intros f.
      apply isapropunit.
    - apply isasetunit.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_iso_twosided_disp.
      + intros.
        apply isapropunit.
  Qed.

  Definition discrete_prod_twosided_disp_cat
    : discrete_twosided_disp_cat prod_twosided_disp_cat.
  Proof.
    repeat split.
    - intro ; intros.
      apply isapropunit.
    - exact constant_twosided_disp_cat_is_iso.
    - exact is_univalent_prod_twosided_disp_cat.
  Qed.
End ProductTwoSidedDispCat.


From mathcomp Require Import all_ssreflect.
Require Import String.
Require Import cells.
Require Import trials.

Definition one_triangle : seq nat :=
  [:: 2; 2; 4; 4; 2; 2; 3; 5; 3; 5; 4; 4].

Definition two_triangles : seq nat :=
  [:: 1; 2; 5; 1; 1; 2; 6; 17; 5; 1; 6; 17] ++ one_triangle.

(* To exploit this computation and produce a postscript file, you should
just type the following command on a unix system, where draw.v is the name
of this file

  coqc draw.v 2>/dev/null | tail -n +2 | head -n -3 > example.ps

You can then display example.ps with a postscript viewer or convert it to
other formats. *)
Compute dtest two_triangles.


(* Raccourcis clavier de coqide *)
(* CTRL-flèche bas: avancer d'une commande *)
(* CTRL-flèche haut: revenir en arrière d'une commande *)
(* CTRL-flèche droit: avancer ou revenir en arrière jusqu'au curseur *)

(** premiers pas en Coq *)

(* Logique minimale "pure": pas de négation/contradiction *)

Section Exercices.

  Variables P Q R S T : Prop.

  (* Une Section peut contenir d'autres [sous-]Sections. C'est le bon endroit
     pour definir des hypotheses (et donc prouver des sequents avec hypotheses).

     Dans ce fichier, la section "Exercices" va jusqu'au bout *)

  Lemma imp_dist: (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof.
    intro Hpqr.
    intro Hpq.
    intro Hp.
    apply Hpqr.
    - assumption.
    - apply Hpq.
      assumption.
  Qed.

  (* Explication des tactiques utilisées: *)
  (* intro: utilisation de la regle d'introduction pour changer de but *)
  (* apply: utilisation d'une implication qui a la bonne conclusion
     (il va falloir prouver ses hypotheses) *)
  (* Note: on ne peut faire "apply" que sur une propriété déjà prouvée,
     contrairement au modus ponens des preuves en arbres *)
  (* C'est automatiquement un modus ponens: "apply Hpqr" pour prouver R
     demande à prouver P et Q *)
  (* assumption: utilisation de la regle d'hypothese *)

  Check imp_dist.  (* On voit la formule prouvée *)
  Print imp_dist.  (* Pour voir le "terme de preuve" calculé *)
  (* la syntaxe est très proche de celle de Ocaml *)

  (* exemple de preuve d'un sequent avec hypothèses *)

  Section S1.
    Hypothesis H : P -> Q.
    Hypothesis H0 : P -> Q -> R.

    Lemma L2 : P -> R.
    (* le sequent est: P->Q, P->Q->R |- P->R *)
    Proof.
      intro p.
      apply H0.
      - assumption.
      - apply H.
        assumption.
    Qed.

    Check L2. (* Les hypothèse font partie de la section *)
  End S1.

  (* Quand on ferme la section, ses hypotheses sont "exportees" sous la
     forme d'hypotheses supplementaires pour L2                         *)
  Check L2.

  Section About_cuts.
    Hypothesis H : P -> Q.
    Hypothesis H0 : P -> Q -> R.
    Hypothesis H1 : Q -> R -> S.
    Hypothesis H2 : Q -> R -> S -> T.

    (* preuve sans lemme (coupure) *)
    Lemma L3 : P -> T.
    (* QUESTION: Quel est le séquent qu'on s'apprête à prouver? *)
    (* REPONSE : (P -> Q),(P -> Q -> R),(Q -> R -> S),(Q -> R -> S -> T ) |- P -> T*)
    (* QUESTION: Faites-en une preuve papier AVANT de continuer *)
    Proof.
      intro p.
      apply H2.
      - apply H.
        assumption.
      - apply H0.
        + assumption.
        + apply H.
          assumption.
      - apply H1.
        + apply H.
          assumption.
        + apply H0.
          * assumption.
          * apply H.
          assumption.
    Qed.
    (* QUESTION: Réécrivez le script ci-dessus en introduisant des tirets
       (-, *, +) à chaque fois qu'une tactique engendre plus d'un
       sous-but *)

    (* preuve avec coupures: on prouve Q et R une seule fois chacun,
       puis on les utilise *)

     Lemma L'3 : P -> T.
     Proof.
       intro p.
       assert (q: Q). {
         apply H. assumption.
         }
       (* On a fini de prouver Q; on a maintenant une hypothèse (q:Q) *)
       assert (r: R). {
         apply H0.
         - assumption.
         - assumption.
          }
       (* Pareil: on a maintenant prouvé R, et on a gagné une hypothèse *)
       assert (s : S). {
        apply H1. assumption. assumption.
       }
       apply H2; assumption. (* sans le ; il faut trois "assumption" *)
     Qed.

     (* assert: permet d'ouvrir une nouvelle sous-preuve, *)
     (* dans laquelle on se définit un nouveau but; c'est *)
     (* une coupure. Les accolades sont optionnelles mais *)
     (* facilitent la lecture humaine                     *)

     Check L'3.

(* remarquez la différence entre les termes de preuves avec coupure et sans coupure. *)
     Print L'3.
     Print L3.
(* Les coupures deviennent des "let.. in.." similaires à ceux de Ocaml *)

  End About_cuts.

 (* Exercices

    Reprendre les exemples vus en TD, en utilisant les tactiques
    assumption, apply, assert et intro/intros.

    Remplacer chaque commande Admitted par un script correct de preuve,
    suivi de la commande Qed.

  *)

  Lemma IdP : P -> P.
  Proof.
   intro hP.
   assumption.
  Qed.

  Lemma IdPP : (P -> P) -> P -> P.
  Proof.
  intros HPP Hp.
  assumption.
  Qed.

  (* sans regarder le fichier de demo, c'est de la triche *)
  Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros Hpq Hqr Hp.
    apply Hqr.
    apply Hpq.
    assumption.
  Qed.

  Section proof_of_hyp_switch.
    Hypothesis H : P -> Q -> R.
    Lemma hyp_switch : Q -> P -> R.
    Proof.
      intros Hq Hp.
      apply H;assumption.
    Qed.
  End proof_of_hyp_switch.

  Check hyp_switch.

  Section proof_of_add_hypothesis.
    Hypothesis H : P -> R.

    Lemma add_hypothesis : P -> Q -> R.
    Proof.
      intros Hp Hq.
      apply H. assumption.
    Qed.

  End proof_of_add_hypothesis.

  (* prouver le sequent (P -> P -> Q) |- P -> Q
     (il faut l'énoncer, et faire la preuve)
      *)
  Section proof_of_remove_dup_hypothesis.
      (*TODO : (P -> P -> Q) |- P -> Q *)
      Hypothesis H: P -> P -> Q.
      Lemma my_hyp: P->Q.
      Proof.
        intro Hp.
        apply H;assumption.
      Qed.

  End proof_of_remove_dup_hypothesis.

  (* même exercice avec le séquent P->Q |- P->P->Q *)
  Section proof_of_dup_hypothesis.
        Hypothesis H: P -> Q.
        Lemma my_hyp_2: P->P->Q.
        Proof.
          intros.
          apply H;assumption.
        Qed.

  End proof_of_dup_hypothesis.

  (* meme exercice avec
     P -> Q , P -> R , Q -> R -> T |- P -> T
   *)
  Section proof_of_distrib_impl.
    Hypothesis H : P -> Q.
    Hypothesis H0: P -> R.
    Hypothesis H1: Q -> R -> T.
    Lemma hyp3:P->T .
    Proof.
      intro Hp.
      apply H1.
      - apply H.          (*but Q*)
        assumption.
      - apply H0.         (*but R*)
        assumption.
    Qed.

  End proof_of_distrib_impl.

  (* même exercice, avec
     P->Q, Q->R, (P->R)->T->Q, (P->R)->T |- Q
     (ex. 9 de la feuille "Logique minimale")
   *)
  Section proof_of_ex9.
    Hypothesis H : P->Q .
    Hypothesis H0: Q->R .
    Hypothesis H1:(P->R)->T->Q .
    Hypothesis H2:(P->R)->T  .
    Lemma trouve_q: Q.
    Proof.
      assert (Hpr: P -> R ). {   (*but P->R*)
      intro hp.
      apply H0.
      apply H;assumption.
      }
      apply H1.
      - assumption.
      - apply H2. assumption.
    Qed.

  End proof_of_ex9.

  (* exercice 10 de la feuille "Logique minimale" *)
  Section Proof_of_weak_Peirce.

    Hypothesis H: (((P->Q)->P)->P)-> Q.
    Lemma weak_Peirce : Q.
    Proof.
      apply H.
      intro.
      apply H0.
      intro.
      apply H.
      intro.
      assumption .
    Qed.

  End Proof_of_weak_Peirce.
  Check weak_Peirce.
  Print weak_Peirce. (* Pas facile à déchiffrer *)
  (* QUESTION: si vous n'aviez pas déjà fait cet exercice sur papier,
     écrivez une preuve papier du même séquent; votre script de preuve
     devrait vous aider à identifier quelle règle utiliser à chaque étape
  *)

End Exercices.


(** * dfa: Deterministic Finite Automata, decidability of language inclusion *)

Require Import comparisons positives ordinal pair lset.
Require Import monoid boolean prop sups bmx.
Set Implicit Arguments.
Unset Printing Implicit Defensive.

(** * DFA and associated language *)

(** A DFA is given by its number of states, a deterministic transition
   function, an acceptance condition, and a finite subset of the
   alphabet.

   States are represented by ordinals of the appropriate size.

   Making the finite subset of the alphabet explicit avoids us to use
   ordinals for the alphabet. *)

Record t := mk {
  n: nat;
  u: ord n;
  M: ord n -> positive -> ord n;
  v: ord n -> bool;
  vars: list positive
}.
Notation "x ^u" := (u x) (at level 2, left associativity, format "x ^u").
Notation "x ^M" := (M x) (at level 2, left associativity, format "x ^M").
Notation "x ^v" := (v x) (at level 2, left associativity, format "x ^v").

(** changing the initial state *)
Definition reroot A i := mk i A^M A^v (vars A).

Lemma reroot_id A: A = reroot A (A^u).
Proof. destruct A; reflexivity. Qed.

(** language of a DFA [A], starting from state [i] *)
Fixpoint lang A i w :=
  match w with
    | nil => is_true (A^v i)
    | cons a w => In a (vars A) /\ lang A (A^M i a) w
  end.

(** * Reduction of DFA language inclusion to DFA language emptiness  *)

Section diff.

Variables A B: t.

(** automaton for [A\B] *)
Definition diff := mk
  (pair.mk (u A) (u B))
  (fun p a => pair.mk (M A (pair.pi1 p) a) (M B (pair.pi2 p) a))
  (fun p => v A (pair.pi1 p) ⊓ ! v B (pair.pi2 p))
  (vars A).

(** specification of its language *)
Lemma diff_spec: vars A ≦ vars B ->
  forall i j, lang A i ≦ lang B j <-> lang diff (pair.mk i j) ≦ bot.
Proof.
  intro H.
  cut (forall w i j, lang A i w ≦ lang B j w <-> ~ lang diff (pair.mk i j) w).
   intros G i j. split. intros Hij w Hw. apply G in Hw as []. apply Hij.
   intros Hij w. apply G. intro Hw. elim (Hij _ Hw).
  induction w; intros i j; simpl lang; rewrite pair.pi1mk, pair.pi2mk.
   case (v A i); case (v B j); firstorder discriminate.
    split. intros Hij [HaB Hw]. apply IHw in Hw as []. intro Aw. apply Hij. now split.
    intros Hw [Ha Aw]. split. apply H, Ha. eapply IHw. 2: eassumption. tauto.
Qed.

End diff.

(** * Decidability of DFA language emptiness

   We proceed as follows:
   1. we forget all transition labels to get a directed graph whose
      nodes have an accepting status.
   2. we compute the reflexive and transitive closure of this graph
   3. we deduce the set of all states reachable from the initial state.
   4. the DFA is empty iff this set does not contain any accepting
      states.

   All these computations are straightforward, except for 2, for which
   we exploit Kleene star on Boolean matrices.

   The resulting algorithm is not efficient at all. We don't care
   because this is not the one we execute in the end: this one is just
   used to establish KA completeness. *)

Section empty_dec.

Variables A: t.

(** erased transition graph, represented as a Boolean matrix *)
Definition step: bmx (n A) (n A) := fun i j => \sup_(a\in vars A) eqb_ord (M A i a) j.

(** reflexive transitive closure of this graph *)
Definition steps := (@str bmx _ step).

Variable i: ord (n A).

(** basic properties of this closed graph *)
Lemma steps_refl: steps i i.
Proof. apply bmx_str_clot. constructor. Qed.

Lemma steps_snoc: forall j a, steps i j -> In a (vars A) -> steps i (M A j a).
Proof.
  setoid_rewrite bmx_str_clot. intros. eapply clot_snoc. eassumption.
  setoid_rewrite is_true_sup. eexists. split. eassumption. apply eqb_refl.
Qed.

(** state reached from [i] by following a word [w] in the DFA *)
Fixpoint Ms i w := match w with nil => i | cons a w => Ms (M A i a) w end.

(** each unlabelled path in the erased graph corresponds to a labelled
   path (word) in the DFA *)
Lemma steps_least: forall j, steps i j -> exists w, w ≦ vars A /\ j = Ms i w.
Proof.
  intros j H. apply bmx_str_clot in H. induction H as [i|i j k Hij _ [w [Hw ->]]].
   exists nil. split. lattice. reflexivity.
  setoid_rewrite is_true_sup in Hij. destruct Hij as [a [Ha Hij]].
  exists (a::w). split. intros b [<-|Hb]. assumption. now apply Hw.
  revert Hij. case eqb_ord_spec. 2: discriminate. now intros <-.
Qed.

(** can we reach an accepting state from [i] *)
Definition empty := \inf_(j<_) (steps i j <<< !v A j).

(* TODO: les deux lemmes suivants sont certainement simplifiables en
   prouvant directement l'équivalence *)

(** if not, all states reachable from [i] map to the empty language *)
Lemma empty_lang1 j: steps i j -> empty -> lang A j ≦ bot.
Proof.
  intros Hj He. setoid_rewrite is_true_inf in He. setoid_rewrite le_bool_spec in He.
  pose proof (fun i => He i (ordinal.in_seq _)) as H. clear He.
  intro w. revert j Hj. induction w as [|a w IH]; simpl lang; intros j Hj.
  apply (H j), negb_spec in Hj. rewrite Hj. discriminate.
  intros [Ha Hj']. apply IH in Hj' as []. now apply steps_snoc.
Qed.

(** conversely, if [i] maps to them empty language, then there is no
   reachable accepting state *)
Lemma empty_lang2: lang A i ≦ bot -> empty.
Proof.
  intro H. setoid_rewrite is_true_inf. intros j _.
  rewrite le_bool_spec. intro Hj. apply steps_least in Hj as [w [Hw ->]].
  generalize i (H w) Hw. clear. induction w; intros i Hi Hw.
   simpl in *. destruct (v A i). now elim Hi. reflexivity.
   apply IHw. intro H. elim Hi. split. apply Hw. now left. assumption.
   intros ? ?. apply Hw. now right.
Qed.

(** decidability of language emptiness follows *)
Theorem empty_dec: {lang A i ≦ bot} + {~ (lang A i ≦ bot)}.
Proof.
  case_eq empty; [left|right].
   apply (empty_lang1 _ steps_refl H).
  intro E. apply empty_lang2 in E. rewrite H in E. discriminate.
Qed.

End empty_dec.

(** * Decidability of DFA language inclusion *)

Corollary lang_incl_dec A B: vars A ≦ vars B ->
  forall i j, {lang A i ≦ lang B j} + {~(lang A i ≦ lang B j)}.
Proof. intros. eapply sumbool_iff. symmetry. now apply diff_spec. apply empty_dec. Qed.


Require Import Coq.Lists.List Coq.Logic.FunctionalExtensionality Names.

Inductive temp_name_mapping_fun : Type :=
| ch_0 : temp_name_mapping_fun
| ch_1 : name -> temp_name_mapping_fun
| ch_2 : forall x y : name, x <> y -> temp_name_mapping_fun
| fun_plus : temp_name_mapping_fun -> temp_name_mapping_fun -> temp_name_mapping_fun
| fun_remove : name -> temp_name_mapping_fun -> temp_name_mapping_fun.

Hint Constructors temp_name_mapping_fun.

Inductive in_domain (x : name) : temp_name_mapping_fun -> Prop :=
| in_domain_ch_1 : in_domain x (ch_1 x)
| in_domain_ch_2 : forall y p, in_domain x (ch_2 x y p)
| in_domain_ch_2' : forall y p, in_domain x (ch_2 y x p)
| in_domain_fun_plus_l : forall f g, in_domain x f -> in_domain x (fun_plus f g)
| in_domain_fun_plus_r : forall f g, in_domain x g -> in_domain x (fun_plus f g)
| in_domain_fun_remove : forall f y, in_domain x f -> x <> y -> in_domain x (fun_remove y f).

Hint Constructors in_domain.

Inductive is_hidden (x : name) : temp_name_mapping_fun -> Prop :=
| hidden_here : forall f, is_hidden x (fun_remove x f)
| hidden_there : forall f g, is_hidden x f -> is_hidden x (fun_plus f g).

Hint Constructors is_hidden.

Inductive in_range (x : name) : temp_name_mapping_fun -> Prop :=
| in_range_ch_2 : forall y p, in_range x (ch_2 y x p)
| in_range_fun_plus_l : forall f g, in_range x f -> in_range x (fun_plus f g)
| in_range_fun_plus_r : forall f g, in_range x g -> in_range x (fun_plus f g)
| in_range_fun_remove : forall f y, in_range x f -> x <> y -> in_range x (fun_remove y f).

Hint Constructors in_range.

Theorem in_range_in_domain : forall f x, in_range x f -> in_domain x f.
Proof.
  intros.
  induction f.
  - inversion H.
  - inversion H.
  - inversion H; subst.
    auto.
  - inversion H.
    + apply IHf1 in H1.
      auto.
    + apply IHf2 in H1.
      auto.
  - inversion H.
    apply IHf in H2.
    auto.
Qed.

Definition exclusive f1 f2 := forall x,
  (in_domain f1 x -> ~ in_domain f2 x) /\ (in_domain f2 x -> ~ in_domain f1 x).

Inductive temp_name_mapping : temp_name_mapping_fun -> name -> star -> Prop :=
| map_ch_1 : forall n, temp_name_mapping (ch_1 n) n star_bottom
| map_ch_2_n : forall n m (neq : n <> m), temp_name_mapping (ch_2 n m neq) n (star_name m)
| map_ch_2_m : forall n m (neq : n <> m), temp_name_mapping (ch_2 n m neq) m star_bottom
| map_fun_plus_l : forall f1 f2 n s, temp_name_mapping f1 n s ->
                                     s <> star_bottom ->
                                     temp_name_mapping (fun_plus f1 f2) n s
| map_fun_plus_l' : forall f1 f2 n, temp_name_mapping f1 n star_bottom ->
                                    ~ in_domain n f2 ->
                                    temp_name_mapping (fun_plus f1 f2) n star_bottom
| map_fun_plus_r : forall f1 f2 n s, ~ in_domain n f1 ->
                                     temp_name_mapping f2 n s ->
                                     temp_name_mapping (fun_plus f1 f2) n s
| map_fun_plus_r' : forall f1 f2 n s, temp_name_mapping f1 n star_bottom ->
                                      temp_name_mapping f2 n s ->
                                      temp_name_mapping (fun_plus f1 f2) n s
| map_fun_remove : forall f n m s, temp_name_mapping f n s ->
                                   n <> m ->
                                   s <> star_name m ->
                                   temp_name_mapping (fun_remove m f) n s
| map_fun_remove' : forall f n m, temp_name_mapping f n (star_name m) ->
                                  temp_name_mapping (fun_remove m f) n star_star.

Hint Constructors temp_name_mapping.

Inductive temp_name_mapping' (f : temp_name_mapping_fun) : star -> star -> Prop :=
| map_name : forall n s, temp_name_mapping f n s ->
                         temp_name_mapping' f (star_name n) s
| map_bottom : temp_name_mapping' f star_bottom star_bottom
| map_star : temp_name_mapping' f star_star star_bottom.

Hint Constructors temp_name_mapping'.

Definition Fun_comm (f1 f2 : temp_name_mapping_fun) :=
  forall x s, temp_name_mapping (fun_plus f1 f2) x s <->
              temp_name_mapping (fun_plus f2 f1) x s.

Definition Fun_prop_1 (f : temp_name_mapping_fun) :=
  forall x, ~ temp_name_mapping f x (star_name x).

Definition Fun_prop_2 (f : temp_name_mapping_fun) :=
  forall x y n, temp_name_mapping f x (star_name n) ->
                temp_name_mapping f y (star_name n) ->
                x = y.

Definition Fun_prop_3 (f : temp_name_mapping_fun) :=
  forall x s s', temp_name_mapping f x s ->
                 temp_name_mapping' f s s' ->
                 s = star_bottom.

Definition Fun_prop (f : temp_name_mapping_fun) :=
  Fun_prop_1 f /\ Fun_prop_2 f /\ Fun_prop_3 f.

Record Compatible (f1 f2 : temp_name_mapping_fun) := Build_compatible {
  Compatible_comm : Fun_comm f1 f2;
  Compatible_prop : Fun_prop (fun_plus f1 f2)
}.

Fixpoint Mutually_compatible (fs : list temp_name_mapping_fun) :=
  match fs with
    | nil => True
    | f :: fs' => Forall (Compatible f) fs' /\ Mutually_compatible fs'
  end.

Theorem fun_prop_1 : forall f, Fun_prop_1 f.
Proof.
  repeat red.
  intros.
  induction f; inversion H; subst; auto.
Qed.

Hint Resolve fun_prop_1.

Lemma fun_prop_1' : forall f x n, temp_name_mapping f x (star_name n) -> x <> n.
Proof.
  intros.
  destruct (name_dec x n).
  - subst.
    apply fun_prop_1 in H.
    auto.
  - auto.
Qed.

Hint Resolve fun_prop_1'.

Lemma mapping_in_domain : forall f x s, temp_name_mapping f x s ->
                                        in_domain x f.
Proof.
  induction f; intros.
  - inversion H.
  - inversion H; auto.
  - inversion H; subst; auto.
  - inversion H; subst.
    + specialize IHf1 with x s; auto.
    + specialize IHf1 with x star_bottom; auto.
    + specialize IHf2 with x s; auto.
    + specialize IHf2 with x s; auto.
  - inversion H; subst.
    + specialize IHf with x s; auto.
    + apply in_domain_fun_remove.
      * apply IHf with (star_name n); auto.
      * apply fun_prop_1' in H4; auto.
Qed.

Hint Resolve mapping_in_domain.

Lemma compatible_split : forall f1 f2,
                           Compatible f1 f2 ->
                           Fun_prop f1 /\ Fun_prop f2.
Proof.
  intros.
  destruct H.
  inversion_clear Compatible_prop0.
  inversion_clear H0.
  repeat (red in H).
  repeat (red in H1).
  repeat (red in H2).
  repeat split.
  - repeat red.
    intros.
    apply H with x.
    apply map_fun_plus_l; auto.
    easy.
  - repeat red; intros.
    apply H1 with (n := n); apply map_fun_plus_l; auto; easy.
  - repeat red; intros.
    apply H2 with x s'.
    + destruct (star_dec s star_bottom).
      * subst.
        red in Compatible_comm0.
        inversion_clear Compatible_comm0.

Theorem fun_comm : forall f1 f2 x s, temp_name_mapping (fun_plus f1 f2) x s ->
                                     temp_name_mapping (fun_plus f2 f1) x s.
Proof.
  induction f1; intros.
  - inversion H; subst.
    + inversion H2.
    + inversion H2.
    + apply map_fun_plus_l'; auto.
    induction f2; auto.
    + inversion H; subst; auto.

Lemma in_domain_mapping_exists : forall f x, in_domain x f ->
                                             exists s, temp_name_mapping f x s.
Proof.
  intro f.
  induction f; intros.
  - inversion H.
  - inversion H.
    exists star_bottom; auto.
  - inversion H; subst.
    + exists (star_name y); auto.
    + exists star_bottom; auto.
  - inversion H; subst.
    + apply IHf1 in H1.
      inversion H1.
      exists x0.
      constructor.

Lemma mapping_in_range : forall f x n, temp_name_mapping f x (star_name n) ->
                                       in_range n f.
Proof.
  intros.
  induction f; inversion H; subst; auto.
  apply in_range_fun_remove; auto.
  intro.
  apply H6; rewrite H0; auto.
Qed.

Hint Resolve mapping_in_range.

Theorem Fun_prop_2 : forall f x y n,
                       temp_name_mapping f x (star_name n) ->
                       temp_name_mapping f y (star_name n) ->
                       x = y.
Proof.
  induction f; intros.
  - inversion H.
  - inversion H.
  - inversion H; subst.
    inversion H0; subst.
    auto.
  - inversion H; inversion H0; subst.
    + apply (IHf1 x y n) in H3; auto.
    +
    apply IHf1 in H3; auto.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Diagram.
Require Import Diagrams.Graph.
Require Import Diagrams.Cocone.
Require Import Diagrams.DDiagram.
Require Import Colimits.Colimit.
Require Import UnivalenceImpliesFunext.

Local Open Scope path_scope.

(** * Flattening lemma *)

(** This file provide a proof of the flattening lemma for colimits. This lemma describes the type [sig E'] when [E' : colimit D -> Type] is a type family defined by recusrion on a colimit. *)
(** The flattening lemma in the case of W-types is presented in section 6.12 of the HoTT book. *)
(** A good intuition is given by the pushout's case (see above). *)

Section Flattening.
  (** ** Equifibered diagrams *)

  Context `{Univalence} {G : Graph} (D : Diagram G)
    (E : DDiagram D) `(Equifibered _ _ E).

  Let E_f {i j : G} (g : G i j) (x : D i) : E (i; x) -> E (j; (D _f g) x)
      := @arr _ E (i; x) (j; D _f g x) (g; 1).

  (** Now, given an equifibered diagram and using univalence, one can define a type family [E' : colimit D -> Type] by recusrion on the colimit. *)

  Definition E' : Colimit D -> Type.
  Proof.
    apply Colimit_rec. simple refine (Build_Cocone _ _).
    - exact (fun i x => E (i; x)).
    - intros i j g x; cbn.
      symmetry.
      serapply (path_universe (E_f _ _)).
  Defined.

  (** ** Helper lemmas *)

  Definition transport_E' {i j : G} (g : G i j)  (x : D i) (y : E (i; x))
    : transport E' (colimp i j g x) (E_f g x y) = y.
  Proof.
    refine (transport_idmap_ap _ _ _ _ _ _ @ _).
    srefine (transport2 idmap _ _ @ _).
    2: apply Colimit_rec_beta_colimp; cbn.
    apply (moveR_transport_V idmap).
    symmetry; apply transport_path_universe.
  Defined.

  Definition transport_E'_V {i j : G} (g : G i j)  (x : D i) (y : E (i; x))
    : transport E' (colimp i j g x)^ y = E_f g x y.
  Proof.
    apply moveR_transport_V.
    symmetry.
    apply transport_E'.
  Defined.

  Definition transport_E'_V_E' {i j : G} (g : G i j)  (x : D i) (y : E (i; x))
    : transport_E' g x y
      = ap (transport E' (colimp i j g x)) (transport_E'_V g x y)^
        @ transport_pV E' (colimp i j g x) y.
  Proof.
    rewrite moveR_transport_V_V, inv_V.
    symmetry; apply ap_transport_transport_pV.
  Defined.

  (** ** Main result *)

  (** We define the cocone over the sigma diagram to [sig E']. *)

  Definition cocone_E' : Cocone (diagram_sigma E) (sig E').
  Proof.
    serapply Build_Cocone; cbn.
    - intros i w.
      exists (colim i w.1); cbn.
      exact w.2.
    - intros i j g x; cbn.
      serapply path_sigma'.
      + apply colimp.
      + apply transport_E'.
  Defined.

  (** And we directly prove than it is universal. *)

  Local Opaque path_sigma ap11.

  Global Instance unicocone_cocone_E' : UniversalCocone cocone_E'.
  Proof.
    serapply Build_UniversalCocone.
    intro Z; serapply isequiv_adjointify.
    - intros [q qq]; cbn in *.
      intros [x y]; revert x y.
      serapply Colimit_ind; cbn.
      + intros i x y; exact (q i (x; y)).
      + intros i j g x; cbn.
        funext y.
        refine (transport_arrow_toconst _ _ _ @ _).
        refine (_ @ qq i j g (x; y)).
        cbn; f_ap.
        refine (path_sigma' _ 1 _); cbn.
        apply transport_E'_V.
    - intros [q qq].
      serapply path_cocone.
      + intros i x; reflexivity.
      + intros i j g [x y].
        rewrite concat_1p, concat_p1.
        cbn; rewrite ap_path_sigma.
        cbn; rewrite Colimit_ind_beta_colimp.
        rewrite ap10_path_forall.
        hott_simpl.
        refine (_ @ concat_1p _).
        refine (_ @@ 1).
        match goal with |- ap _ ?X @ _ = _ => set X end.
        assert (transport_E'_V g x y = p^).
        { subst p.
          exact (moveL_transport_V_V E' _ _ _ _)^. }
        rewrite X.
        clearbody p; clear.
        set (E_f g x y) in *.
        destruct p.
        reflexivity.
    - intro f.
      funext [x y].
      revert x y; cbn.
      serapply Colimit_ind; cbn.
      + reflexivity.
      + intros i j g x; cbn.
        funext y.
        rewrite transport_forall; cbn.
        rewrite transport_paths_FlFr.
        match goal with |- (_ @ ?pp) @ _ = _ => set pp end.
        cbn in p.
        assert (p = 1).
        { subst p.
          match goal with |- transportD E' ?C _ _ _ = _ => set (C2:=C) end.
          rewrite (transportD_is_transport _ (fun w => C2 w.1 w.2)).
          subst C2; cbn.
          rewrite transport_paths_FlFr.
          rewrite concat_p1.
          apply moveR_Vp.
          rewrite concat_p1.
          rewrite ap_path_sigma.
          cbn.
          rewrite Colimit_ind_beta_colimp.
          rewrite ap10_path_forall.
          hott_simpl.
          rewrite ap11_is_ap10_ap01.
          cbn.
          rewrite concat_1p.
          rewrite (ap_compose (fun y => (colim j ((D _f g) x); y)) f).
          cbn.
          rewrite (ap_compose (fun x0 : exists x0 : D j, E (j; x0)
            => (colim j (pr1 x0); pr2 x0)) f).
          rewrite <- !ap_pp.
          apply (ap (ap f)).
          match goal with |- _ = (ap ?ff ?pp1 @ ?pp2) @ ?pp3
            => set (p1 := pp1) end.
          assert (p1 = ap (transport E' (colimp i j g x)^)
            (transport_pV E' (colimp i j g x) y)^).
          { subst p1; clear.
            etransitivity.
            1: serapply moveL_transport_V_1.
            etransitivity.
            { serapply inverse2.
              2: serapply transport_VpV. }
            symmetry; apply ap_V. }
          rewrite X; clear X p1.
          rewrite <- ap_compose; cbn.
          rewrite (ap_path_sigma (fun x => E (j; x))
            (fun x y => (colim j x; y))).
          cbn; rewrite !concat_p1, concat_pp_p, ap_V.
          apply moveL_Vp.
          match goal with |- ?pp1 @ _ = ?pp2 @ _
            => set (p1 := pp1); set (p2 := pp2) end; cbn in *.
          assert (p1 = path_sigma' E' 1 (transport_Vp _ _ _)).
          {  subst p1.
            rewrite <- ap_existT.
            rewrite (ap_compose (transport E' (colimp i j g x)^)
              (fun v => (colim j ((D _f g) x); v))).
            f_ap; set (colimp i j g x).
            clear; symmetry.
            apply transport_VpV. }
          rewrite X; clear p1 X.
          assert (p2 = path_sigma' E' 1 (transport_E'_V _ _ _))
            by reflexivity.
          rewrite X; clear p2 X.
          rewrite <- !path_sigma_pp_pp'; f_ap.
          rewrite concat_p1, concat_pp_p.
          refine (1 @@ _).
          apply moveL_Mp.
          rewrite <- ap_V, <- ap_pp.
          srefine (_ @ _).
          - refine (ap (transport E' (colimp i j g x)) _).
            refine ((transport_E'_V _ _ _)^ @ _).
            refine (ap _ (transport_pV _ _ _)).
          - f_ap.
            refine (1 @@ _).
            apply transport_VpV.
          - set (transport E' (colimp i j g x)
              (transport E' (colimp i j g x)^ y)).
            rewrite ap_pp, <- ap_compose.
            refine (_ @ (transport_E'_V_E' _ _ _)^).
            refine (1 @@ _).
            subst e.
            refine (_ @ (transport_pVp _ _ _)^).
            rewrite ap_compose.
            f_ap; symmetry.
            apply transport_VpV. }
        rewrite X; hott_simpl.
  Defined.

  (** The flattening lemma follows by colimit unicity. *)

  Definition flattening_lemma : Colimit (diagram_sigma E) <~> sig E'.
  Proof.
    serapply colimit_unicity.
    3: apply iscolimit_colimit.
    erapply Build_IsColimit.
    apply unicocone_cocone_E'.
  Defined.

End Flattening.


Require Import XR_Rsqr.
Require Import XR_Rminus.
Require Import XR_Rsqr_minus.
Require Import XR_Rplus_comm.
Require Import XR_Rmult_assoc.
Require Import XR_Rmult_comm.
Require Import XR_Rplus_eq_compat_r.

Local Open Scope R_scope.

Lemma Rsqr_neg_minus : forall x y:R, Rsqr (x - y) = Rsqr (y - x).
Proof.
  intros x y.
  repeat rewrite Rsqr_minus.
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm y).
  unfold Rminus.
  repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  rewrite Rplus_comm.
  reflexivity.
Qed.


(*Proof (A -> (B /\ C)) -> (A -> B) *)

Theorem Ex004 (A B C : Prop): (A -> (B /\ C)) -> (A -> B).
Proof.
  intros.
  apply H in H0.
  destruct H0.
  exact H0.
Qed.


(** * Carriers of the lB-systems defined in terms of two sorts and the length function

by Vladimir Voevodsky, file created on Jan. 6, 2015 *)

Require Import UniMath.Foundations.All.
Require Import TypeTheory.Csystems.hSet_ltowers.

(** **** lB-system carriers *)

Definition lBsystem_carrier :=
  ∑ (B :  hSet_pltower)(TildeB : hSet)( dd : TildeB -> B ),
                                   forall r : TildeB , ll ( dd r ) > 0.

(** Note: the condition that the carrier of an lB-system is based on an h-set is used for the first
time in the formulation of the condition TT (later an axiom TT of the lB-systems). It is possible to avoid
the use of the h-set condition in the formulation of the TT and other axioms at the cost of making the
domains of applicability of these axioms to have a much longer description or of introducing additional
axioms to ensure that Lemma isover_T_T_2 and similar lemmas needed for the formulation of other axioms
hold. *)

Definition lBsystem_carrier_constr { B : hSet_pltower } { TildeB : hSet }
           ( dd : TildeB -> B ) ( is : forall r : TildeB, ll ( dd r ) > 0 ) : lBsystem_carrier .
Proof .
  split with B .

  split with TildeB .

  exact ( tpair _ dd is ) .

Defined.

Definition lBsystem_carrier_to_ltower : lBsystem_carrier -> ltower := fun T => pr1 ( pr1 T ) .
Coercion  lBsystem_carrier_to_ltower : lBsystem_carrier >-> ltower .

Definition lBsystem_carrier_pr1 : lBsystem_carrier -> hSet_pltower := pr1 .
Coercion  lBsystem_carrier_pr1 : lBsystem_carrier >-> hSet_pltower .

Definition Tilde : lBsystem_carrier -> UU := fun BB => pr1 ( pr2 BB ) .

Definition dd { BB : lBsystem_carrier } : Tilde BB -> BB := pr1 ( pr2 ( pr2 BB ) ) .

Definition Tilde_dd { BB : lBsystem_carrier } ( X : BB ) :=
  ∑ r : Tilde BB, dd r = X.

Definition Tilde_dd_pr1 { BB : lBsystem_carrier } { X : BB } : Tilde_dd X -> Tilde BB := pr1 .
Coercion Tilde_dd_pr1 : Tilde_dd >-> Tilde .

Definition isasetBt ( BB : lBsystem_carrier ) : isaset ( Tilde BB ) :=
  pr2 ( pr1 ( pr2 BB ) ) .

(** We can define a family BBn : nat -> UU by the formula

BBn BB := fun n => total2 ( fun X : BB => ll X = 0 )

The subobject in lBsystem_carrier defined by the condition

iscontr ( BBn BB 0 )

is equivalent to the type of type-and-term structures, i.e. presheaves on the category H
from the paper by Richard Garner, "Combinatorial structure of type dependency".

*)

Definition ll_dd { BB : lBsystem_carrier } ( r : Tilde BB ) : ll ( dd r ) > 0 :=
  pr2 ( pr2 ( pr2 BB ) ) r .

(** **** Useful lemmas *)

Definition ll_dd_geh { BB : lBsystem_carrier } ( r : Tilde BB ) : ll ( dd r ) >= 1 :=
  natgthtogehsn _ _ ( ll_dd r ) .

(** **** lBsystem carriers over an object *)

(* End of the file lB_carriers.v *)


Require Import HoTT.
Require Import HoTT.Categories.Functor.
From GR.bicategories Require Import
     general_category
     bicategory.bicategory
     bicategory.examples.full_sub
     lax_functor.lax_functor.

Section RestrictionFunctor.
  Context {C D : BiCategory}.
  Variable (F : LaxFunctor C D)
           (P : C -> hProp).

  Definition lax_restriction_d : LaxFunctor_d (full_sub C P) D.
  Proof.
    make_laxfunctor.
    - exact (fun X => Fobj F X.1).
    - intros ; simpl in *.
      exact (Fmor F X.1 Y.1).
    - intros X Y Z g f ; cbn in *.
      exact (Fcomp₁ F g f).
    - intros ; simpl.
      exact (Fid F X.1).
  Defined.

  Definition is_lax_restriction : is_lax lax_restriction_d.
  Proof.
    make_is_lax ; intros ; apply F.
  Qed.

  Definition lax_restriction : LaxFunctor (full_sub C P) D
    := Build_LaxFunctor lax_restriction_d is_lax_restriction.
End RestrictionFunctor.

Global Instance restriction_is_pseudo
           `{Univalence}
           {C D : BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           (P : C -> hProp)
  : is_pseudo (lax_restriction F P).
Proof.
  split ; intros ; cbn in * ; apply _.
Defined.

Definition pseudo_restriction
           `{Univalence}
           {C D : BiCategory}
           (F : PseudoFunctor C D)
           (P : C -> hProp)
  : PseudoFunctor (full_sub C P) D.
Proof.
  make_pseudo_functor_lax.
  - exact (lax_restriction F P).
  - exact (restriction_is_pseudo F P).
Defined.


Require Import Foundations.Generalities.uuu.
Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.
Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Lemma eq_equalities_between_pairs (A : UU)(B : A -> UU)(x y : total2 (fun x => B x))
    (p q : x == y) (H : base_paths _ _ p == base_paths _ _ q)
    (H2 : transportf (fun p : pr1 x == pr1 y =>  transportf _ p (pr2 x) == pr2 y )
         H (fiber_path p) == fiber_path q) :  p == q.
Proof.
  apply equal_equalities_between_pairs.
  set (H3 := total2_paths (B:=(fun p : pr1 x == pr1 y =>
          transportf (fun x : A => B x) p (pr2 x) == pr2 y))
          (s:=(total_paths_equiv B x y) p)
          (s':=(total_paths_equiv B x y) q) H).

  apply H3.
  assumption.
Defined.

Lemma transportf_idpath (X : UU) (P : X -> UU) (x : X)(z : P x) :
   transportf _ (idpath x) z == z.
Proof.
  unfold transportf.
  simpl.
  apply idpath.
Defined.

(** lemmas taken from the HoTT library resp. the book *)

Definition transportD {A : UU} (B : A -> UU) (C : forall a:A, B a -> UU)
  {x1 x2 : A} (p : x1 == x2) (y : B x1) (z : C x1 y)
  : C x2 (transportf _ p y).
Proof.  destruct p. exact z.
Defined.

Definition transportf_sigma {A : UU} {B : A -> UU} {C : forall a:A, B a -> UU}
  {x1 x2 : A} (p : x1 == x2) (yz : total2 (fun y : B x1 => C x1 y ))
  : transportf (fun x => total2 (fun y : B x => C x y)) p yz
    == tpair (fun y => C x2 y) (transportf _ p  (pr1 yz)) (transportD _ _ p (pr1 yz) (pr2 yz)).
Proof.
  destruct p. destruct yz. apply idpath.
Defined.

Definition transportf_dirprod (A : UU) (B B' : A -> UU) (x x' : total2 (fun a => dirprod (B a) (B' a)))
   (p : pr1 x == pr1 x') :
  transportf (fun a => dirprod (B a) (B' a)) p (pr2 x) ==
                            dirprodpair (transportf (fun a => B a) p (pr1 (pr2 x)))
                                        (transportf (fun a => B' a) p (pr2 (pr2 x))) .
Proof.
  destruct x as [t tp].
  destruct x' as [t' tp'].
  simpl in *.
  destruct p.
  simpl.
  pathvia tp.
  rewrite transportf_idpath. apply idpath.
  (* here apply transportf_idpath should work *)
  repeat rewrite transportf_idpath.
  apply tppr.
Defined.

(*
Definition transport_sigma' {A : UU} {B : A -> UU} {C : total2 (fun a => B a) -> UU}
  {x1 x2 : A} (p : x1 == x2)
  (yz : total2 (fun y : B x1 => C (tpair (fun a => B a) x1 y) ))

  : transportf (fun x => total2 (fun y : B x => C (tpair (fun a => B a) x y))) p yz
    == tpair (fun y => C (tpair _ x2 y)) (transportf _ p  (pr1 yz))
              (transportD _ _ p (pr1 yz) (pr2 yz)).
Proof.
  destruct p. destruct yz. apply idpath.
Defined.
*)


(**  non-empty lists
    - this module includes the definition and basic facts about non-empty lists
**)

Require Import Lia.
Require Import Coq.Program.Equality.
Import Decidable.
Require Import Coq.Classes.Morphisms Relation_Definitions.

Require Export ListExtra.
Require Export DecTac.

(**  Definition of non-empty lists, basic functionality and notations **)

Inductive ne_list (A : Type) : Type :=
| ne_single : A -> ne_list A
| ne_cons : A -> ne_list A -> ne_list A.

Arguments ne_single {_} _.
Arguments ne_cons {_} _ _.

Infix ":<:" := ne_cons (at level 70,right associativity).

Fixpoint ne_conc (A : Type) (l l' : ne_list A) : ne_list A :=
  match l with
  | ne_single a => a :<: l'
  | ne_cons a l => a :<: ne_conc l l'
  end.

Infix ":+:" := ne_conc (at level 50).

Definition ne_rcons (A : Type) l a : ne_list A := l :+: ne_single a.

Infix ":>:" := ne_rcons (at level 50).

Section NeList.
  Variables (A : Type).

  Fixpoint ne_front (l : ne_list A) : A
    := match l with
       | ne_single a => a
       | ne_cons a _ => a
       end.

  Fixpoint ne_back (l : ne_list A) : A
    := match l with
       | ne_single a => a
       | ne_cons _ l => ne_back l
       end.

  Fixpoint ne_to_list (l : ne_list A) : list A
    := match l with
       | ne_single a => a :: nil
       | a :<: l => a :: ne_to_list l
       end.
End NeList.

Coercion ne_to_list : ne_list >-> list.

Fixpoint ne_tl (A : Type) (l : ne_list A) : list A
  := match l with
     | ne_single _ => nil
     | _ :<: l => l
     end.

Ltac congruence' ::=
  lazymatch goal with
  | [ H : ?l ++ (?a :: ?l') = nil |- _ ] => destruct l; cbn in H; congruence
  | [ H : (?l ++ ?l') :: ?a :: ?l'' = nil |- _ ] => destruct l; cbn in H; congruence
  | [ H : ?l :r: ?a = nil |- _ ] => eapply rcons_not_nil in H; contradiction
  | [ H : ne_to_list ?l = nil |- _ ] => destruct l; cbn in H; congruence
  | [ H : nil = ?l ++ (?a :: ?l') |- _ ] => destruct l; cbn in H; congruence
  | [ H : nil = (?l ++ ?l') :: ?a :: ?l'' |- _ ] => destruct l; cbn in H; congruence
  | [ H : nil = ?l :r: ?a |- _ ] => symmetry in H; eapply rcons_not_nil in H; contradiction
  | [ H : nil = ne_to_list ?l |- _ ] => destruct l; cbn in H; congruence
  end.

Fixpoint nlcons (A : Type) (a : A) l :=
  match l with
  | nil => ne_single a
  | b :: l => a :<: (nlcons b l)
  end.

Infix ":<" := nlcons (at level 50).

Definition nl_conc (A : Type) (l : ne_list A) (ll : list A) : ne_list A :=
  match ll with
  | nil => l
  | a :: ll => l :+: (a :< ll)
  end.

Infix ":+" := nl_conc (at level 50).

Fixpoint nl_rcons (A : Type) l (a : A) : ne_list A :=
  match l with
  | nil =>  ne_single a
  | b :: l => (b :<: (nl_rcons l a))
  end.

Infix ">:" := nl_rcons (at level 50).

Section NeList.
  Variables (A B : Type).

  Lemma nlcons_to_list (a : A) l :
    a :: l = nlcons a l.
  Proof.
    revert a. induction l; cbn; eauto. rewrite IHl. reflexivity.
  Qed.

  Lemma nlconc_to_list (l : ne_list A) (l' : list A)
    : l ++ l' = l :+ l'.
  Proof.
    destruct l';cbn.
    - eauto using app_nil_end.
    - induction l;cbn;[rewrite <-nlcons_to_list|];eauto.
      rewrite IHl. reflexivity.
  Qed.

  Lemma nlcons_front (a : A) l :
    ne_front (nlcons a l) = a.
  Proof.
    induction l; cbn; eauto.
  Qed.

  Lemma nlcons_necons l :
    forall (a : A), (a :<: l) = nlcons a l.
  Proof.
    induction l; cbn; eauto. rewrite IHl. reflexivity.
  Qed.

  Lemma nlconc_neconc (l : ne_list A) l' :
    (l :+: l') = l :+ l'.
  Proof.
    intros. destruct l';cbn;eauto. rewrite nlcons_necons. reflexivity.
  Qed.

  Fixpoint ne_map (f : A -> B) (l : ne_list A) : ne_list B :=
    match l with
    | ne_single a => ne_single (f a)
    | a :<: l => (f a) :<: ne_map f l
    end.

  Lemma ne_map_nlcons (f : A -> B) (a : A) l :
    ne_map f (nlcons a l) = nlcons (f a) (map f l).
  Proof.
    revert a. induction l;intros b;cbn;firstorder.
    f_equal. eauto.
  Qed.

  Lemma nl_rcons_back (a : A) l :
    ne_back (l >: a) = a.
  Proof.
    induction l; cbn; eauto.
  Qed.

  Lemma ne_rcons_back (a : A) l :
    ne_back (l :>: a) = a.
  Proof.
    induction l; cbn; eauto.
  Qed.

  Lemma to_list_ne_map (f : A -> B) (l : ne_list A) :
    map f l = ne_map f l.
  Proof.
    intros. induction l;cbn;eauto. rewrite IHl. reflexivity.
  Qed.

  Lemma ne_back_map (f : A -> B) l :
    ne_back (ne_map f l) = f (ne_back l).
  Proof.
    induction l; firstorder.
  Qed.

  Lemma ne_to_list_inj (l l' : ne_list A) :
    ne_to_list l = ne_to_list l' -> l = l'.
  Proof.
    Set Printing Coercions.
    revert l'. induction l; induction l'; intros Heq; inversion Heq; cbn in *.
    - reflexivity.
    - exfalso. destruct l'; cbn in H1; congruence.
    - exfalso. destruct l; cbn in H1; congruence.
    - apply IHl in H1. subst l. econstructor.
      Unset Printing Coercions.
  Qed.

  Lemma ne_map_in (f:A->B) a (l:ne_list A) :
    In a l -> In (f a) (ne_map f l).
  Proof.
    intro Hin. induction l;cbn.
    - inversion Hin;[subst;tauto|contradiction].
    - cbn in Hin. destruct Hin;subst.
      + left. reflexivity.
      + right. eauto.
  Qed.

  Lemma ne_map_nl_rcons  (l : list A) a (f : A -> B)
    : ne_map f (l >: a) = (map f l) >: (f a).
  Proof.
    induction l;cbn;eauto. rewrite IHl. reflexivity.
  Qed.

  Lemma rcons_nl_rcons l (a:A) :
    l :r: a = nl_rcons l a.
  Proof.
    induction l; eauto. rewrite cons_rcons_assoc. rewrite IHl. cbn. reflexivity.
  Qed.

  Lemma ne_to_list_not_nil (l : ne_list A) :
    nil <> l.
  Proof.
    intro N. induction l; cbn in *; congruence.
  Qed.

  Lemma nercons_nlrcons l (a : A)
    : l :>: a = l >: a.
  Proof.
    induction l;cbn;eauto. rewrite <-IHl. destruct l;eauto.
  Qed.

  Lemma rcons_necons l (a : A)
    : (ne_to_list l) :r: a = l :>: a.
  Proof.
    induction l;cbn;eauto. rewrite IHl. reflexivity.
  Qed.

  Lemma ne_list_nlcons (l : ne_list A)
    : exists a l', l = a :< l'.
  Proof.
    destruct l as [a | a l'];exists a;[exists nil|exists l'];cbn;[|rewrite <-nlcons_necons];reflexivity.
  Qed.

  Lemma ne_list_nlrcons: forall (A : Type) (l : ne_list A), exists (a : A) (l' : list A), l = l' >: a.
  Proof.
    induction l.
    - exists a, nil. eauto.
    - destructH. rewrite IHl. exists a0, (a :: l'). cbn. reflexivity.
  Qed.

  Lemma neconc_app (l l' : ne_list A)
    : l ++ l' = l :+: l'.
  Proof.
    induction l;cbn;eauto.
    rewrite IHl. reflexivity.
  Qed.

  Lemma nl_cons_lr_shift (a b : A) (l : list A)
    : (a :<: (l >: b)) = ((a :< l) :>: b).
  Proof.
    revert a.
    induction l; intros; cbn ; eauto.
    fold ((ne_rcons (a :< l) b)). rewrite IHl. reflexivity.
  Qed.

  Lemma in_nlcons (l : list A) (a b : A)
    : a ∈ (b :< l) <-> a = b \/ a ∈ l.
  Proof.
    split; intro Q.
    - revert dependent b. induction l; cbn in *;intros b Q;[firstorder|].
      destruct Q;[firstorder|].
      right. specialize (IHl a0 H). firstorder.
    - revert dependent b. induction l; cbn in *;intros b Q;[firstorder|].
      destruct Q;[firstorder|].
      right. eapply IHl. firstorder.
  Qed.

  Lemma in_ne_conc (l l' : ne_list A)
    : forall a, a ∈ (l :+: l') <-> a ∈ l \/ a ∈ l'.
  Proof.
    split; revert a; induction l;intros b Q; cbn in *; firstorder 0.
  Qed.

  Lemma in_nl_conc (l : ne_list A) l' (a : A)
    : a ∈ (l :+ l') <-> a ∈ l \/ a ∈ l'.
  Proof.
    split;revert a;induction l'; intros b Q; cbn in *; [firstorder| |firstorder|].
    - eapply in_ne_conc in Q. repeat destruct Q; eauto. eapply in_nlcons in H. destruct H;eauto.
    - eapply in_ne_conc. repeat destruct Q; eauto. right. eapply in_nlcons. firstorder.
  Qed.

End NeList.

Lemma nin_tl_iff (A : Type) `{EqDec A eq} (a : A) (l : ne_list A)
  : a ∉ tl (rev l) -> a ∉ l \/ a = ne_back l.
Proof.
  intros.
  decide' (a == ne_back l);eauto.
  left. contradict H0. induction l;cbn in *;eauto.
  - destruct H0;eauto. congruence.
  - fold ((rev l) :r: a0).
    rewrite tl_rcons;[eapply In_rcons;eauto|destruct l;cbn;eauto;erewrite app_length;cbn;lia].
    destruct H0.
    + subst. eauto.
    + right. eapply IHl;eauto.
Qed.

Lemma find_some' (A : Type) (f : A -> bool) (l : list A) (x : A)
      (Hl : x ∈ l)
      (Hf : f x = true)
  : exists y, Some y = find f l.
Proof.
  induction l;cbn;[contradiction|].
  destruct Hl;subst.
  - rewrite Hf. eauto.
  - destruct (f a);eauto.
Qed.