(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Aaron Bohannon
     Arthur Charg\'eraud

   With contributions from:
     Edsko de Vries:
       uniq_reorder_1, uniq_reorder_2, binds_In_inv *)

(** remove printing ~ *)

(** A library for association lists, i.e., lists of pairs *)

Require Import Coq.FSets.FSets.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Decidable.

Require Import CoqFSetDecide.
Require Import CoqListFacts.
Require Import LibTactics.

(* *********************************************************************** *)
(** * Implementation *)

(** We implement association lists as lists of key-value pairs.  We
    use [eq] as the equality on both keys and values.  This is evident
    primarily in the definitions of [binds] and [maps].

    (Implementation note: We can generalize the implementation to
    arbitrary equivalence relations.  For now, we have chosen not to,
    in order to keep the implementation simple and to optimize for
    what we expect is the common case.)

    Note that our library has an implicit convention for the "normal
    form" of an association list.  This normal form requires that a
    list be built only from [nil] (the empty list), [one] (the
    singleton list), and [app] (concatenation).  Additionally,
    concatenations should be associated to the right and the list
    should not contain any [nil] terms, unless it is the empty list
    itself.

    This allows association lists to be written in a slightly more
    uniform manner when compared to using both [cons] and [app] to
    build them.  The downsides are that Coq's [simpl] tactic will
    simplify instances of [one] down to [cons] and that there are
    instances in which one needs to write association lists that are
    not in normal form (e.g., some concatenations will need to be
    associated to the left).  The [simpl_alist] and [rewrite_alist]
    tactics below are designed to minimize the impact of these
    downsides.

    A [Strategy] declaration can be used to prevent Coq's tactics from
    simplifying [one], if one so desires. *)

(* Implementation note (BEA, XXX): Very little support for
     - Inversion on association lists when [one] is [opaque].
     - No real support for [get].
     - No real support for [maps].
     - No support for permutations. *)

Module Make
  (X : UsualDecidableType)
  (Import KeySet : FSetInterface.WSfun X).

Module Import D := CoqFSetDecide.WDecide_fun X KeySet.
Module KeySetProperties := FSetProperties.WProperties_fun X KeySet.
Module KeySetFacts := FSetFacts.WFacts_fun X KeySet.

(* *********************************************************************** *)
(** * Basic definitions *)

(** Implicit arguments are enabled for the following definitions. *)

Set Implicit Arguments.

(** [one] constructs an association list consisting of exactly one
    binding.  We define an infix notation for it and ensure that the
    arguments to [app] are interpreted in the right scope, i.e.,
    [list_scope].

    Implementation note: The level associated with the notation gives
    it a higher precedence than the "++" notation for [app].  This
    should eliminate the need for parentheses.  See the definition
    below of [uniq], for example. *)

Definition one (C : Type) (item : C) : list C := cons item nil.

Notation "x ~ a" := (one (x, a)) (at level 50) : list_scope.

Arguments Scope app [ type_scope list_scope list_scope ].

Open Scope list_scope.

(** [dom] computes the domain of an association list, i.e., the
    set consisting of its keys. *)

Fixpoint dom
  (C : Type) (E : list (X.t*C))
  : KeySet.t :=
  match E with
    | nil => empty
    | (x, _) :: E' => add x (dom E')
  end.

(** [get] looks up a key in an association list. *)

Fixpoint get
  (C : Type) (x : X.t) (E : list (X.t*C))
  : option C :=
  match E with
    | nil => None
    | (y, c) :: F => if X.eq_dec x y then Some c else get x F
  end.

(** [binds] is a ternary predicate that holds when a key-value pair
    appears somewhere in the given association list. *)

Definition binds
  (A : Type) (x : X.t) (a : A) (E : list (X.t*A))
  : Prop :=
  List.In (x, a) E.

(** [maps] is a ternary predicate that holds when the first binding in
    the list for the given key is to the given value. *)

Definition maps
  (A : Type) (x : X.t) (a : A) (E : list (X.t*A))
  : Prop :=
  get x E = Some a.

(** [disjoint] is a binary predicate that holds when the domains of
    two association lists are disjoint. *)

Definition disjoint
  (A B : Type) (E : list (X.t*A)) (F : list (X.t*B))
  : Prop :=
  inter (dom E) (dom F) [<=] empty.

(** [map] applies a function to each of the values in an association
    list. *)

Definition map
  (A B : Type) (f : A -> B) (E : list (X.t*A))
  : list (X.t*B) :=
  List.map (fun b => match b with (x, a) => (x, f a) end) E.

(** [uniq] is unary predicate that holds if and only if each key is
    bound at most once in the given association list.  Note that
    [uniq] is defined in terms of [one], not [cons]. *)

Inductive uniq (A : Type) : list (X.t*A) -> Prop :=
  | uniq_nil :
      uniq nil
  | uniq_push : forall x a E,
      uniq E ->
      ~ In x (dom E) ->
      uniq (x ~ a ++ E).

(** Unless stated otherwise, in the remainder of this file, implicit
    arguments will not be declared by default. *)

Unset Implicit Arguments.

(* *********************************************************************** *)
(** * List properties *)

(** The following properties are used mainly for rewriting association
    lists into the normal form described above.  See the [simpl_alist]
    and [rewrite_alist] tactics below. *)

Section ListProperties.
  Variable  X : Type.
  Variables x y : X.
  Variables l l1 l2 l3 : list X.

  Lemma cons_app_one :
    cons x l = one x ++ l.
  Proof. clear. reflexivity. Qed.

  Lemma cons_app_assoc :
    (cons x l1) ++ l2 = cons x (l1 ++ l2).
  Proof. clear. reflexivity. Qed.

  Lemma app_assoc :
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
  Proof. clear. auto with datatypes. Qed.

  Lemma app_nil_1 :
    nil ++ l = l.
  Proof. clear. reflexivity. Qed.

  Lemma app_nil_2 :
    l ++ nil = l.
  Proof. clear. auto with datatypes. Qed.

  Lemma in_nil_iff :
    List.In x nil <-> False.
  Proof. clear. split; inversion 1. Qed.

  Lemma in_one_iff :
    List.In x (one y) <-> x = y.
  Proof. clear. split. inversion 1; intuition. constructor; intuition. Qed.

  Lemma in_app_iff :
    List.In x (l1 ++ l2) <-> List.In x l1 \/ List.In x l2.
  Proof. clear. split; auto using List.in_or_app, List.in_app_or. Qed.

End ListProperties.

(* *********************************************************************** *)
(** * Properties of [map] and [dom] *)

(** The following lemmas are used mainly to simplify applications of
    [map] and [dom] to association lists.  See also the [simpl_alist]
    and [rewrite_alist] tactics below. *)

Section Properties.
  Variables A B key : Type.
  Variable  f       : A -> B.
  Variable  x       : X.t.
  Variable  b       : A.
  Variables E F G   : list (X.t*A).

  Lemma map_nil :
    map f (@nil (X.t*A)) = nil.
  Proof. clear. reflexivity. Qed.

  Lemma map_one :
    map f (x ~ b) = (x ~ f b).
  Proof. clear. reflexivity. Qed.

  Lemma map_cons :
    map f ((x, b) :: E) = x ~ f b ++ map f E.
  Proof. clear. reflexivity. Qed.

  Lemma map_app :
    map f (E ++ F) = map f E ++ map f F.
  Proof. clear. unfold map. rewrite List.map_app. reflexivity. Qed.

  Lemma dom_nil :
    dom (@nil (X.t*A)) = empty.
  Proof. clear. reflexivity. Qed.

  Lemma dom_one :
    dom (x ~ b) [=] singleton x.
  Proof. clear. intros. simpl. fsetdec. Qed.

  Lemma dom_cons :
    dom ((x, b) :: E) [=] union (singleton x) (dom E).
  Proof. clear. intros. simpl. fsetdec. Qed.

  Lemma dom_app :
    dom (E ++ F) [=] union (dom E) (dom F).
  Proof. clear. intros. induction E as [ | [? ?] ]; simpl; fsetdec. Qed.

  Lemma dom_map :
    dom (map f E) [=] dom E.
  Proof. clear. intros. induction E as [ | [? ?] ]; simpl; fsetdec. Qed.

End Properties.

(* *********************************************************************** *)
(** * The [simpl_alist] tactic *)

(** Rewriting hints. *)

Hint Rewrite cons_app_one cons_app_assoc      : rewr_list.
Hint Rewrite app_assoc app_nil_1 app_nil_2    : rewr_list.
Hint Rewrite in_nil_iff in_one_iff in_app_iff : rewr_list_in.

Hint Rewrite map_nil map_one map_cons map_app         : rewr_map.
Hint Rewrite dom_nil dom_one dom_cons dom_app dom_map : rewr_dom.

(** The [simpl_alist] tactic rewrites association lists so that they
    are in the normal form described above.  Similar to the [simpl]
    tactic, we define "[in *]" and "[in H]" variants of the tactic. *)

Ltac simpl_alist :=
  autorewrite with rewr_list rewr_map rewr_dom.
Tactic Notation "simpl_alist" "in" hyp(H) :=
  autorewrite with rewr_list rewr_map rewr_dom in H.
Tactic Notation "simpl_alist" "in" "*" :=
  autorewrite with rewr_list rewr_map rewr_dom in *.

(* *********************************************************************** *)
(** * The [rewrite_alist] tactic *)

(** The tactic [(rewrite_alist E)] replaces an association list in the
    conclusion of the goal with [E].  Suitability for replacement is
    determined by whether [simpl_alist] can put [E] and the chosen
    environment in the same normal form, up to convertibility's in
    Coq.  We also define an "[in H]" variant that performs the
    replacement in a hypothesis [H].

    Implementation note: The tactic depends on appropriate morphisms
    being declared for finite set operations. *)

Tactic Notation "rewrite_alist" constr(E) :=
  match goal with
    | |- context[?x] =>
      change x with E
    | |- context[?x] =>
      replace x with E;
        [ | try reflexivity; simpl_alist; reflexivity ]
  end.

Tactic Notation "rewrite_alist" constr(E) "in" hyp(H) :=
  match type of H with
    | context[?x] =>
      change x with E in H
    | context[?x] =>
      replace x with E in H;
        [ | try reflexivity; simpl_alist; reflexivity ]
  end.

(* *********************************************************************** *)
(** * Induction *)

(** For convenience, we provide a tactic for reasoning by induction on
    the structure of an association list.  Compared to regular [list]
    induction, in the "[cons]" case, this tactic automatically
    destructs the pair at the head of the list and ensures that the
    list is formed using [one] and [app]. *)

Lemma alist_ind : forall (A : Type) (P : list (X.t * A) -> Type),
  (P nil) ->
  (forall x a xs, P xs -> P (x ~ a ++ xs)) ->
  (forall xs, P xs).
Proof.
  induction xs as [ | [x a] xs ].
  auto.
  change (P (x ~ a ++ xs)). auto.
Defined.

Tactic Notation "alist" "induction" ident(E) :=
  try (intros until E);
  let T := type of E in
  let T := eval compute in T in
  match T with
    | list (?key * ?A) => induction E using (alist_ind A)
  end.

Tactic Notation "alist" "induction" ident(E) "as" simple_intropattern(P) :=
  try (intros until E);
  let T := type of E in
  let T := eval compute in T in
  match T with
    | list (?key * ?A) => induction E as P using (alist_ind A)
  end.

(* *********************************************************************** *)
(** * Basic facts about [disjoint] *)

Section Disjoint.
  Implicit Types A B C : Type.

  Lemma disjoint_sym_1 :
    forall A B (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint E F ->
    disjoint F E.
  Proof. unfold disjoint. fsetdec. Qed.

  Lemma disjoint_sym :
    forall A B (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint E F <-> disjoint F E.
  Proof. intuition auto using disjoint_sym_1. Qed.

  Lemma disjoint_nil_1 :
    forall A B (E : list (X.t*B)),
    disjoint (@nil (X.t*A)) E.
  Proof. unfold disjoint. fsetdec. Qed.

  Lemma disjoint_one_1 :
    forall A B (x : X.t) (a : A) (F : list (X.t*B)),
    disjoint (x ~ a) F ->
    ~ In x (dom F).
  Proof. unfold disjoint. simpl. fsetdec. Qed.

  Lemma disjoint_one_2 :
    forall A B (x : X.t) (a : A) (F : list (X.t*B)),
    ~ In x (dom F) ->
    disjoint (x ~ a) F.
  Proof. unfold disjoint. simpl. fsetdec. Qed.

  Lemma disjoint_one_l :
    forall A B (x : X.t) (a : A) (E : list (X.t*B)),
    disjoint (x ~ a) E <-> ~ In x (dom E).
  Proof. unfold disjoint. simpl. split; fsetdec. Qed.

  Lemma disjoint_one_r :
    forall A B (x : X.t) (a : A) (E : list (X.t*B)),
    disjoint E (x ~ a) <-> ~ In x (dom E).
  Proof. intros. rewrite disjoint_sym. apply disjoint_one_l. Qed.

  Lemma disjoint_cons_1 :
    forall A B x a (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint ((x, a) :: E) F ->
    ~ In x (dom F).
  Proof. unfold disjoint. simpl. fsetdec. Qed.

  Lemma disjoint_cons_2 :
    forall A B x a (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint ((x, a) :: E) F ->
    disjoint E F.
  Proof. unfold disjoint. simpl. fsetdec. Qed.

  Lemma disjoint_cons_3 :
    forall A B x a (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint E F ->
    ~ In x (dom F) ->
    disjoint ((x, a) :: E) F.
  Proof. unfold disjoint. simpl. fsetdec. Qed.

  Lemma disjoint_cons_l :
    forall A B x a (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint ((x, a) :: E) F <-> ~ In x (dom F) /\ disjoint E F.
  Proof.
    split.
    eauto using disjoint_cons_1, disjoint_cons_2.
    intros [? ?]. auto using disjoint_cons_3.
  Qed.

  Lemma disjoint_cons_r :
    forall A B x a (E : list (X.t*A)) (F : list (X.t*B)),
    disjoint F ((x, a) :: E) <-> ~ In x (dom F) /\ disjoint E F.
  Proof. intros. rewrite disjoint_sym. apply disjoint_cons_l. Qed.

  Lemma disjoint_app_1 :
    forall A B (E F : list (X.t*A)) (G : list (X.t*B)),
    disjoint (E ++ F) G ->
    disjoint E G.
  Proof. unfold disjoint. intros. rewrite dom_app in *. fsetdec. Qed.

  Lemma disjoint_app_2 :
    forall A B (E F : list (X.t*A)) (G : list (X.t*B)),
    disjoint (E ++ F) G ->
    disjoint F G.
  Proof. unfold disjoint. intros. rewrite dom_app in *. fsetdec. Qed.

  Lemma disjoint_app_3 :
    forall A B (E F : list (X.t*A)) (G : list (X.t*B)),
    disjoint E G ->
    disjoint F G ->
    disjoint (E ++ F) G.
  Proof. unfold disjoint. intros. rewrite dom_app in *. fsetdec. Qed.

  Lemma disjoint_app_l :
    forall A B (E F : list (X.t*A)) (G : list (X.t*B)),
    disjoint (E ++ F) G <-> disjoint E G /\ disjoint F G.
  Proof.
    intuition eauto 2 using
      disjoint_app_1, disjoint_app_2, disjoint_app_3.
  Qed.

  Lemma disjoint_app_r :
    forall A B (E F : list (X.t*A)) (G : list (X.t*B)),
    disjoint G (E ++ F) <-> disjoint E G /\ disjoint F G.
  Proof. intros. rewrite disjoint_sym. apply disjoint_app_l. Qed.

  Lemma disjoint_map_1 :
    forall A B C (E : list (X.t*A)) (F : list (X.t*B)) (f:A->C),
    disjoint (map f E) F ->
    disjoint E F.
  Proof. unfold disjoint. intros. rewrite dom_map in *. fsetdec. Qed.

  Lemma disjoint_map_2 :
    forall A B C (E : list (X.t*A)) (F : list (X.t*B)) (f:A->C),
    disjoint E F ->
    disjoint (map f E) F.
  Proof. unfold disjoint. intros. rewrite dom_map in *. fsetdec. Qed.

  Lemma disjoint_map_l :
    forall A B C (E : list (X.t*A)) (F : list (X.t*B)) (f:A->C),
    disjoint (map f E) F <-> disjoint E F.
  Proof. intuition eauto using disjoint_map_1, disjoint_map_2. Qed.

  Lemma disjoint_map_r :
    forall A B C (E : list (X.t*A)) (F : list (X.t*B)) (f:A->C),
    disjoint F (map f E) <-> disjoint E F.
  Proof. intros. rewrite disjoint_sym. apply disjoint_map_l. Qed.

End Disjoint.

(* *********************************************************************** *)
(** * Basic facts about [uniq] *)

Section UniqProperties.
  Variables A B   : Type.
  Variables f     : A -> B.
  Variables x     : X.t.
  Variables a b   : A.
  Variables E F G : list (X.t*A).

  Lemma uniq_one_1 :
    uniq (x ~ b).
  Proof.
    clear. rewrite_alist ((x ~ b) ++ nil).
    apply uniq_push. apply uniq_nil. apply empty_1.
  Qed.

  Lemma uniq_cons_1 :
    uniq ((x, a) :: E) ->
    uniq E.
  Proof. clear. inversion 1. trivial. Qed.

  Lemma uniq_cons_2 :
    uniq ((x, a) :: E) ->
    ~ In x (dom E).
  Proof. clear. inversion 1. trivial. Qed.

  Lemma uniq_cons_3 :
    uniq E ->
    ~ In x (dom E) ->
    uniq ((x, a) :: E).
  Proof.
    clear. intros. change (uniq (x ~ a ++ E)). apply uniq_push; trivial.
  Qed.

  Lemma uniq_cons_iff :
    uniq ((x, a) :: E) <-> uniq E /\ ~ In x (dom E).
  Proof.
    clear. split.
    eauto using uniq_cons_1, uniq_cons_2.
    intros [? ?]. auto using uniq_cons_3.
  Qed.

  Lemma uniq_app_1 :
    uniq (E ++ F) -> uniq E.
  Proof.
    clear. intros J. alist induction E.
      apply uniq_nil.
      inversion J; subst. rewrite dom_app in *. apply uniq_push.
        auto.
        fsetdec.
  Qed.

  Lemma uniq_app_2 :
    uniq (E ++ F) -> uniq F.
  Proof.
    clear. intros J. alist induction E.
      auto.
      inversion J; subst. auto.
  Qed.

  Lemma uniq_app_3 :
    uniq (E ++ F) -> disjoint E F.
  Proof.
    clear. intros J. unfold disjoint. alist induction E as [ | ? ? ? IH ].
      fsetdec.
      inversion J; subst. simpl_alist in *. lapply IH.
        fsetdec.
        auto.
  Qed.

  Lemma uniq_app_4 :
    uniq E ->
    uniq F ->
    disjoint E F ->
    uniq (E ++ F).
  Proof.
    clear. intros HE HF Hd. alist induction E as [ | x1 a1 E' ].
      auto.
      inversion HE; subst. rewrite app_assoc. apply uniq_push.
        rewrite disjoint_app_l, disjoint_one_l in *. intuition.
        rewrite disjoint_app_l, disjoint_one_l, dom_app in *. fsetdec.
  Qed.

  Lemma uniq_app_iff :
    uniq (E ++ F) <-> uniq E /\ uniq F /\ disjoint E F.
  Proof.
    clear; intuition auto using
      uniq_app_1, uniq_app_2, uniq_app_3, uniq_app_4.
  Qed.

  Lemma uniq_map_1 :
    uniq (map f E) ->
    uniq E.
  Proof.
    clear. intros J. alist induction E as [ | x1 a1 E' ].
      apply uniq_nil.
      inversion J; subst. rewrite dom_map in *. apply uniq_push; auto.
  Qed.

  Lemma uniq_map_2 :
    uniq E ->
    uniq (map f E).
  Proof.
    clear. intros J. alist induction E as [ | x1 a1 E' ].
      apply uniq_nil.
      inversion J; subst. simpl_alist. apply uniq_push.
        auto.
        rewrite dom_map. trivial.
  Qed.

  Lemma uniq_map_iff :
    uniq (map f E) <-> uniq E.
  Proof. clear. intuition auto using uniq_map_1, uniq_map_2. Qed.

End UniqProperties.

(* *********************************************************************** *)
(** * Basic facts about [binds] *)

Section BindsProperties.
  Variable  A B   : Type.
  Variables f     : A -> B.
  Variables x y   : X.t.
  Variables a b   : A.
  Variables E F G : list (X.t*A).

  Lemma binds_nil_iff :
    binds x a nil <-> False.
  Proof. clear. split. inversion 1. intuition. Qed.

  Lemma binds_one_1 :
    binds x a (y ~ b) ->
    x = y.
  Proof. clear. intros H. inversion H; intuition congruence. Qed.

  Lemma binds_one_2 :
    binds x a (y ~ b) ->
    a = b.
  Proof. clear. intros H. inversion H; intuition congruence. Qed.

  Lemma binds_one_3 :
    x = y ->
    a = b ->
    binds x a (y ~ b).
  Proof. clear. unfold binds. intros. simpl. left. congruence. Qed.

  Lemma binds_one_iff :
    binds x a (y ~ b) <-> x = y /\ a = b.
  Proof.
    clear. intuition auto using binds_one_1, binds_one_2, binds_one_3.
  Qed.

  Lemma binds_cons_1 :
    binds x a ((y, b) :: E) ->
    (x = y /\ a = b) \/ binds x a E.
  Proof. clear. inversion 1 as [J | J]; try injection J; auto. Qed.

  Lemma binds_cons_2 :
    x = y ->
    a = b ->
    binds x a ((y, b) :: E).
  Proof. clear. unfold binds. simpl. left. f_equal; auto. Qed.

  Lemma binds_cons_3 :
    binds x a E ->
    binds x a ((y, b) :: E).
  Proof. clear. unfold binds. simpl. right. trivial. Qed.

  Lemma binds_cons_iff :
    binds x a ((y, b) :: E) <-> (x = y /\ a = b) \/ binds x a E.
  Proof.
    clear. intuition auto using binds_cons_1, binds_cons_2, binds_cons_3.
  Qed.

  Lemma binds_app_1 :
    binds x a (E ++ F) ->
    binds x a E \/ binds x a F.
  Proof. clear. unfold binds. rewrite in_app_iff. auto. Qed.

  Lemma binds_app_2 :
    binds x a E ->
    binds x a (E ++ F).
  Proof. clear. unfold binds. rewrite in_app_iff. auto. Qed.

  Lemma binds_app_3 :
    binds x a F ->
    binds x a (E ++ F).
  Proof. clear. unfold binds. rewrite in_app_iff. auto. Qed.

  Lemma binds_app_iff :
    binds x a (E ++ F) <-> binds x a E \/ binds x a F.
  Proof. clear. unfold binds. rewrite in_app_iff. split; auto. Qed.

  Lemma binds_map_1 :
    (forall a b, f a = f b -> a = b) ->
    binds x (f a) (map f E) ->
    binds x a E.
  Proof.
    clear. alist induction E; intros ?.
      inversion 1.
      unfold binds in *. simpl. intros [K | K].
        left. injection K. intros. f_equal; auto.
        right. auto.
  Qed.

  Lemma binds_map_2 :
    binds x a E ->
    binds x (f a) (map f E).
  Proof.
    clear. alist induction E.
      inversion 1.
      unfold binds in *. simpl. intros [? | ?].
        left. congruence.
        right. auto.
  Qed.

  Lemma binds_dom_contradiction : forall (E : list (X.t*A)),
    binds x a E ->
    ~ In x (dom E) ->
    False.
  Proof.
    clear. intros E H1 H2.
    alist induction E as [ | ? ? ? IH ].
      inversion H1.
      unfold binds in *. simpl in *. destruct H1 as [J | J].
        injection J. fsetdec.
        eapply IH. auto. fsetdec.
  Qed.

  Lemma binds_app_uniq_1 :
    uniq (E ++ F) ->
    binds x a (E ++ F) ->
    (binds x a E /\ ~ In x (dom F)) \/ (binds x a F /\ ~ In x (dom E)).
  Proof.
    clear. intros J1 J2.
    rewrite uniq_app_iff in J1. unfold disjoint in J1.
    rewrite binds_app_iff in J2.
    assert (~ In x (dom F) \/ ~ In x (dom E)) by fsetdec.
    intuition eauto using binds_dom_contradiction.
  Qed.

  Lemma binds_app_uniq_iff :
    uniq (E ++ F) ->
    (binds x a (E ++ F) <->
      (binds x a E /\ ~ In x (dom F)) \/
      (binds x a F /\ ~ In x (dom E))).
  Proof.
    clear. intuition auto using binds_app_uniq_1, binds_app_2, binds_app_3.
  Qed.

End BindsProperties.

Section BindsProperties2.
  Variable  A B   : Type.
  Variables f     : A -> B.
  Variables x y   : X.t.
  Variables a b   : A.
  Variables E F G : list (X.t*A).

  Lemma binds_cons_uniq_1 :
    uniq ((y, b) :: E) ->
    binds x a ((y, b) :: E) ->
    (x = y /\ a = b /\ ~ In x (dom E)) \/ (binds x a E /\ x <> y).
  Proof.
    clear. intros J1 J2.
    change ((y, b) :: E) with (y ~ b ++ E) in J1.
    change ((y, b) :: E) with (y ~ b ++ E) in J2.
    eapply binds_app_uniq_1 in J1; [ | eassumption ].
    destruct J1 as [[J3 ?] | [? ?]].
      unfold binds in J3. simpl in J3. destruct J3 as [J4 | ].
        injection J4. intros. subst. auto.
        intuition.
      simpl in *. right. split; [ trivial | fsetdec ].
  Qed.

  Lemma binds_cons_uniq_iff :
    uniq ((y, b) :: E) ->
    (binds x a ((y, b) :: E) <->
      (x = y /\ a = b /\ ~ In x (dom E)) \/
      (binds x a E /\ x <> y)).
  Proof.
    clear. intuition auto using binds_cons_uniq_1, binds_cons_2, binds_cons_3.
  Qed.

End BindsProperties2.

(* *********************************************************************** *)
(** * Hints *)

Hint Resolve
  @app_assoc @app_nil_2 @map_app @dom_one @dom_cons @dom_app @dom_map.

Hint Resolve
  @disjoint_sym_1 @disjoint_nil_1 @disjoint_one_2 @disjoint_cons_3
  @disjoint_app_3 @disjoint_map_2 @uniq_nil @uniq_push @uniq_one_1
  @uniq_cons_3 @uniq_app_4 @uniq_map_2.

Hint Resolve
  @binds_one_3 @binds_cons_2 @binds_cons_3 @binds_app_2 @binds_app_3
  @binds_map_2.

(* *********************************************************************** *)
(** * List properties *)

(** The following properties are an assortment of structural
    properties about association lists. *)

Section AssortedListProperties.
  Variable  X : Type.
  Variables x : X.
  Variables xs ys zs : list X.

  Lemma one_eq_app :
    one x ++ xs = ys ++ zs ->
    (exists qs, ys = x :: qs /\ xs = qs ++ zs) \/
    (ys = nil /\ zs = x :: xs).
  Proof. clear. auto using CoqListFacts.cons_eq_app. Qed.

  Lemma app_eq_one :
    ys ++ zs = one x ++ xs ->
    (exists qs, ys = x :: qs /\ xs = qs ++ zs) \/
    (ys = nil /\ zs = x :: xs).
  Proof. clear. auto using CoqListFacts.app_eq_cons. Qed.

  Lemma nil_neq_one_mid :
    nil <> xs ++ one x ++ ys.
  Proof. clear. induction xs; simpl_alist; intros J; inversion J. Qed.

  Lemma one_mid_neq_nil :
    xs ++ one x ++ ys <> nil.
  Proof. clear. intros H. symmetry in H. auto using nil_neq_one_mid. Qed.

End AssortedListProperties.

(* *********************************************************************** *)
(** * Tactic support for [disjoint] and [uniq] *)

(** [destruct_uniq] decomposes all [uniq] and [disjoint] hypotheses. *)

Ltac destruct_uniq :=
  match goal with
    | H : uniq nil |- _ =>
      clear H;
      destruct_uniq
    | H : uniq (?x ~ ?a) |- _ =>
      clear H;
      destruct_uniq
    | H : uniq ((?x, ?a) :: ?E) |- _ =>
      let J := fresh "UniqTac" in
      pose proof H as J;
      apply uniq_cons_1 in H;
      apply uniq_cons_2 in J;
      autorewrite with rewr_dom in J;
      destruct_uniq
    | H : uniq (?E ++ ?F) |- _ =>
      let J1 := fresh "UniqTac" in
      let J2 := fresh "UniqTac" in
      pose proof H as J1;
      pose proof H as J2;
      apply uniq_app_1 in H;
      apply uniq_app_2 in J1;
      apply uniq_app_3 in J2;
      destruct_uniq
    | H : uniq (map ?f ?E) |- _ =>
      apply uniq_map_1 in H;
      destruct_uniq
    | H : disjoint nil ?E |- _ =>
      clear H;
      destruct_uniq
    | H : disjoint (?x ~ ?a) ?F |- _ =>
      apply disjoint_one_1 in H;
      autorewrite with rewr_dom in H;
      destruct_uniq
    | H : disjoint ((?x, ?a) :: ?E) ?F |- _ =>
      let J := fresh "UniqTac" in
      pose proof H as J;
      apply disjoint_cons_1 in H;
      apply disjoint_cons_2 in J;
      autorewrite with rewr_dom in H;
      destruct_uniq
    | H : disjoint (?E ++ ?F) ?G |- _ =>
      let J := fresh "UniqTac" in
      pose proof H as J;
      apply disjoint_app_1 in H;
      apply disjoint_app_2 in J;
      destruct_uniq
    | H : disjoint (map ?f ?E) ?F |- _ =>
      apply disjoint_map_1 in H;
      destruct_uniq
    | H : disjoint ?E nil |- _ =>
      clear H;
      destruct_uniq
    | H : disjoint ?F (?x ~ ?a) |- _ =>
      apply disjoint_sym_1 in H;
      destruct_uniq
    | H : disjoint ?F ((?x, ?a) :: ?E) |- _ =>
      apply disjoint_sym_1 in H;
      destruct_uniq
    | H : disjoint ?G (?E ++ ?F) |- _ =>
      apply disjoint_sym_1 in H;
      destruct_uniq
    | H : disjoint ?F (map ?f ?E) |- _ =>
      apply disjoint_sym_1 in H;
      destruct_uniq
    | _ =>
      idtac
  end.

(** [solve_uniq] attempts to solve goals by first decomposing
    hypotheses about [disjoint] and [uniq] and then trying some
    simple, if perhaps slow, heuristics. *)

Ltac solve_uniq :=
  intros;
  destruct_uniq;
  repeat first [ apply uniq_push
               | apply uniq_cons_3
               | apply uniq_app_4
               | apply uniq_one_1
               | apply uniq_nil ];
  auto;
  try tauto;
  unfold disjoint in *;
  try fsetdec;
  fail "Not solvable by [solve_uniq]; try [destruct_uniq]".

(* *********************************************************************** *)
(** * Facts about [uniq] *)

Section UniqDerived.
  Variable  A     : Type.
  Variables x y   : X.t.
  Variables a b   : A.
  Variables E F G : list (X.t*A).

  Lemma uniq_insert_mid :
    uniq (G ++ E) ->
    ~ In x (dom G) ->
    ~ In x (dom E) ->
    uniq (G ++ (x ~ a) ++ E).
  Proof. clear. solve_uniq. Qed.

  Lemma uniq_remove_mid :
    uniq (E ++ F ++ G) ->
    uniq (E ++ G).
  Proof. clear. solve_uniq. Qed.

  Lemma uniq_reorder_1 :
    uniq (E ++ F) ->
    uniq (F ++ E).
  Proof. clear. solve_uniq. Qed.

  Lemma uniq_reorder_2 :
    uniq (E ++ F ++ G) ->
    uniq (F ++ E ++ G).
  Proof. clear. solve_uniq. Qed.

  Lemma uniq_map_app_l : forall (f : A -> A),
    uniq (F ++ E) ->
    uniq (map f F ++ E).
  Proof. clear. solve_uniq. Qed.

  Lemma fresh_mid_tail :
    uniq (F ++ (x ~ a) ++ E) ->
    ~ In x (dom E).
  Proof. clear. solve_uniq. Qed.

  Lemma fresh_mid_head :
    uniq (F ++ (x ~ a) ++ E) ->
    ~ In x (dom F).
  Proof. clear. solve_uniq. Qed.

End UniqDerived.

(* *********************************************************************** *)
(** * Tactic support for [binds] *)

(** [destruct_binds_hyp] and [destruct_binds_hyp_uniq] tactics
    decompose a hypotheses of the form [binds x a E], with the latter
    tactic assuming that [uniq E] holds.  The tactic [solve_uniq] is
    used for discharging any [uniq] obligations that arise.

    Implementation note (BEA, XXX): No support for [map].  I'm not
    sure what to do about the "injectivity" side condition on
    [binds_map_inv].  Perhaps just generate the extra subgoal, on the
    assumption that the condition is usually provable?  It's not as
    if I want to implement even more tactics here... *)

Ltac destruct_binds_hyp H :=
  match type of H with
    | binds ?x ?a nil =>
      inversion H
    | binds ?x ?a (?y ~ ?b) =>
      let J1 := fresh "BindsTacKey" in
      let J2 := fresh "BindsTacVal" in
      rename H into J1;
      pose proof J1 as J2;
      apply binds_one_1 in J1;
      apply binds_one_2 in J2;
      try (subst x);
      try (subst a);
      try (subst y);
      try (subst b)
    | binds ?x ?a ((?y, ?b) :: ?E) =>
      change (binds x a (y ~ b ++ E)) in H;
      destruct_binds_hyp H
    | binds ?x ?a (?E ++ ?F) =>
      let J := fresh "BindsTac" in
      apply binds_app_1 in H;
      destruct H as [J | J];
      destruct_binds_hyp J
    | _ =>
      idtac
  end.

Ltac destruct_binds_hyp_uniq H :=
  match type of H with
    | binds ?x ?a nil =>
      inversion H
    | binds ?x ?a (?y ~ ?b) =>
      let J1 := fresh "BindsTacKey" in
      let J2 := fresh "BindsTacVal" in
      rename H into J1;
      pose proof J1 as J2;
      apply binds_one_1 in J1;
      apply binds_one_2 in J2;
      try (subst x);
      try (subst a);
      try (subst y);
      try (subst b)
    | binds ?x ?a ((?y, ?b) :: ?E) =>
      change (binds x a (y ~ b ++ E)) in H;
      destruct_binds_hyp_uniq H
    | binds ?x ?a (?E ++ ?F) =>
      let J1 := fresh "BindsTacSideCond" in
      assert (J1 : uniq (E ++ F));
        [ destruct_uniq; auto
        | match type of J1 with
            | @uniq ?A _ =>
              let J2 := fresh "BindsTac" in
              destruct (@binds_app_uniq_1 A x a E F J1 H)
                as [[J2 ?] | [J2 ?]];
              clear H;
              destruct_binds_hyp_uniq J2
          end
        ]
    | _ =>
      idtac
  end.

(** An auxiliary tactic.  Not intended for use on its own. *)

Ltac analyze_binds_cleanup :=
  auto;
  try tauto;
  try discriminate;
  try match goal with
        | J : ~ In ?x ?E |- _ =>
          match E with
            | context [x] => elim J; clear; simpl_alist; auto with set
          end
      end.

(** The [analyze_binds] and [analyze_binds_uniq] tactics decompose a
    hypothesis of the form [binds x a E], with the latter assuming
    that [uniq E] holds, and then try some simple heuristics for
    solving the resulting goals. *)

Ltac analyze_binds H :=
  destruct_binds_hyp H;
  analyze_binds_cleanup.

Ltac analyze_binds_uniq H :=
  destruct_binds_hyp_uniq H;
  analyze_binds_cleanup.

(* *********************************************************************** *)
(** * Facts about [binds] *)

Section BindsDerived.
  Variables A B   : Type.
  Variables f     : A -> B.
  Variables x y   : X.t.
  Variables a b   : A.
  Variables E F G : list (X.t*A).

  Lemma binds_dec :
    (forall a b : A, {a = b} + {a <> b}) ->
    {binds x a E} + {~ binds x a E}.
  Proof.
    clear. intros. unfold binds. apply List.In_dec.
    decide equality.
    apply X.eq_dec.
  Defined.

  Lemma binds_lookup :
    {a : A | binds x a E} + (forall a, ~ binds x a E).
  Proof with intuition eauto.
    clear. intros. alist induction E as [ | x1 a1 ? [[a' J] | J] ]...
    destruct (X.eq_dec x x1)...
    right. unfold binds. intros a' [K | ?]...
    unfold X.eq in *. injection K...
  Defined.

  Lemma binds_lookup_dec :
    decidable (exists a, binds x a E).
  Proof with intuition eauto.
    clear. intros. unfold decidable.
    destruct binds_lookup as [[? ?] | ?]...
    right. intros [? ?]...
  Defined.

  Lemma binds_weaken :
    binds x a (E ++ G) ->
    binds x a (E ++ F ++ G).
  Proof. clear. intros H. analyze_binds H. Qed.

  Lemma binds_mid_eq :
    binds x a (F ++ (x ~ b) ++ E) ->
    uniq (F ++ (x ~ b) ++ E) ->
    a = b.
  Proof. clear. intros J ?. analyze_binds_uniq J. Qed.

  Lemma binds_remove_mid :
    binds x a (F ++ (y ~ b) ++ G) ->
    x <> y ->
    binds x a (F ++ G).
  Proof. clear. intros H. analyze_binds H. Qed.

  Lemma binds_In : forall x a (E : list (X.t*A)),
    binds x a E ->
    In x (dom E).
  Proof.
    clear. alist induction E as [ | y ? F ]; intros J; simpl_alist.
      analyze_binds J.
      analyze_binds J; subst; auto with set.
  Qed.

  Lemma binds_In_inv : forall x (E : list (X.t*A)),
    In x (dom E) ->
    exists a, binds x a E.
  Proof.
    clear. alist induction E as [ | y b F IH ]; intros J.
      simpl_alist in J. fsetdec.
      simpl_alist in J. apply union_1 in J. destruct J as [J | J].
        exists b. apply singleton_1 in J. auto.
        apply IH in J. destruct J. eauto.
  Qed.

  Lemma binds_unique :
    binds x a E ->
    binds x b E ->
    uniq E ->
    a = b.
  Proof.
    clear. alist induction E as [ | ? ? F IH ].
    inversion 1.
    unfold binds. simpl. intros [J1 | J1] [J2 | J2] J3.
      Case "left / left".
        congruence.
      Case "left / right".
        assert (In x (dom F)). eapply binds_In. apply J2.
        injection J1; intros; subst.
        solve_uniq.
      Case "right / left".
        assert (In x (dom F)). eapply binds_In. apply J1.
        injection J2; intros; subst.
        solve_uniq.
      Case "right / right".
        unfold binds in *.
        eapply IH; trivial.
        solve_uniq.
  Qed.

  Lemma fresh_app_l :
    uniq (F ++ E) ->
    binds x a E ->
    ~ In x (dom F).
  Proof.
    clear. intros.
    assert (In x (dom E)) by eauto using binds_In.
    solve_uniq.
  Qed.

  Lemma fresh_app_r :
    uniq (F ++ E) ->
    binds x a F ->
    ~ In x (dom E).
  Proof.
    clear. intros.
    assert (In x (dom F)) by eauto using binds_In.
    solve_uniq.
  Qed.

End BindsDerived.

(* *********************************************************************** *)
(** * Hints *)

Hint Resolve @nil_neq_one_mid @one_mid_neq_nil.

Hint Resolve @uniq_insert_mid @uniq_map_app_l.

Hint Immediate @uniq_remove_mid.

Hint Resolve @binds_weaken.

Hint Immediate @binds_remove_mid @binds_In.

End Make.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal29.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_2  := ( Cons (Succ Zero) Nil).
Definition lfind_example_3  := ( Cons Zero Nil).
Definition lfind_example_4  := ( Cons (Succ (Succ (Succ (Succ Zero))))         (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_5  := ( Cons Zero Nil).
Definition lfind_example_6  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_7  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ (Succ Zero))))            (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))).
Definition lfind_example_8  := ( Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)).
Definition lfind_example_9  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_10  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_11  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ (Succ Zero)))            (Cons (Succ Zero) (Cons (Succ Zero) Nil)))).
Definition lfind_example_12  := ( Cons Zero Nil).
Definition lfind_example_13  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_14  := ( Cons Zero         (Cons Zero            (Cons Zero               (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))))).
Definition lfind_example_15  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_16  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_19  := ( Cons Zero Nil).
Definition lfind_example_20  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_21  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_22  := ( Cons Zero Nil).
Definition lfind_example_23  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_24  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_25  := ( Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_26  := ( Cons Zero Nil).
Definition lfind_example_27  := ( Cons Zero Nil).
Definition lfind_example_28  := ( Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)))).
Definition lfind_example_29  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_31  := ( Cons Zero Nil).
Definition lfind_example_32  := ( Cons Zero Nil).
Definition lfind_example_33  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_34  := ( Cons (Succ Zero) Nil).
Definition lfind_example_35  := ( Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_36  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_37  := ( Cons Zero Nil).
Definition lfind_example_38  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_append_assoc_40_append_nil/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 lfind_example_38 .


From Equations Require Import Init.
Require Export HoTT.Basics.Overture.
Set Warnings "-notation-overridden".
Set Universe Polymorphism.

(** Fixes to the HoTT library *)

Register idpath as core.identity.refl.
Register paths_rect as core.identity.ind.
Register paths as core.identity.type.
Register inverse as core.identity.sym.

(** This allows [rewrite] to both in left-to-right and right-to left directions. *)
Definition paths_rect_r (A : Type) (x : A) (P : A -> Type) (p : P x) (y : A) (e : paths y x) : P y :=
  paths_rect A x (fun y e => P y) p y (inverse e).
Register concat as core.identity.trans.

Register ap as core.identity.congr.

(** [path_inspect x] allows to pattern-match x while retaining a propositional equality with [x] *)

Definition path_inspect {A : Type} (x : A) : { y | paths x y } := (x ; idpath).

Require Import HoTT.Types.Bool.
(* For compatibility with Coq's [induction] *)
Definition Bool_rect := Bool_ind.

(** /End of fixes to the HoTT library *)

(** The polymorphic equality type used by Equations when working with equality in Type. *)

Definition transport_r {A} (P : A -> Type) {x y : A} (e : y = x) : P x -> P y :=
  fun x => match (inverse e) with 1%path => x end.

Lemma paths_rect_dep_r {A} (x : A) (P : forall a, a = x -> Type) (p : P x 1%path)
      (y : A) (e : y = x) : P y e.
Proof. destruct e. apply p. Defined.


From Coq.Unicode Require Import Utf8.
From stdpp Require Import base.
From trace_program_logic.prelude Require Import classical.
From Coq.ssr Require Import ssreflect.

Lemma sig_eq {A} (P : A → Prop) (x y : sig P) :
  proj1_sig x = proj1_sig y → x = y.
Proof.
  destruct x as [x Px]; simpl.
  destruct y as [y Py]; simpl.
  intros ->.
  rewrite (ProofIrrelevance _ Px Py); trivial.
Qed.

Definition sig_prod_and {A B P Q} (a : {x : A | P x}) (b : {x : B | Q x}) :
    {x : A * B | P (fst x) ∧ Q (snd x)} :=
  (proj1_sig a, proj1_sig b) ↾ (conj (proj2_sig a) (proj2_sig b)).

Definition sig_prod_or_l {A P Q} (a : {x : A | P x}) :
  {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_introl (proj2_sig a)).

Definition sig_prod_or_r {A P Q} (a : {x : A | Q x}) :
    {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_intror (proj2_sig a)).

Definition sig_and {A} {P Q : A -> Prop} (a : {x : A | P x}) (HQ: Q (proj1_sig a)) :
    { x : A | P x ∧ Q x } := (proj1_sig a) ↾ (conj (proj2_sig a) (HQ)).


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.
Require Export LemmasTyping.

Record WfEnv (Γ: Env) : Prop :=
  { wfenv_covar_kind_left : ∀ c σ τ k, ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩ → ⟨ Γ ⊢ σ ∷ k ⟩;
    wfenv_covar_kind_right : ∀ c σ τ k, ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩ → ⟨ Γ ⊢ τ ∷ k ⟩;
    wfenv_tmvar_ty : ∀ x τ, ⟨ x : τ ∈ Γ ⟩ → ⟨ Γ ⊢ τ ∷ kstar ⟩
  }.

Ltac crushAgreement :=
  match goal with
    | [IH: WfEnv ?Γ → _ |- _] =>
      let H := fresh in
        assert (WfEnv Γ) as H by eauto with ws;
        specialize (IH H); clear H
    | [IH: ⟨ ?Γ ⊢ ?σ ∷ ?k ⟩ → _ |- _] =>
      let H := fresh in
        assert ⟨ Γ ⊢ σ ∷ k ⟩ as H by trivial;
        specialize (IH H); clear H
    | [ |- _ ∧ _ ] => split
  end.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
      (* repeat crushStlcSyntaxMatchH; *)
     repeat crushAgreement;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     repeat crushTypingMatchH;
     subst*;
     try discriminate;
     eauto 3 with ws;
     trivial;
     idtac
    ).

Lemma red_co {Γ γ σ τ k} :
  ⟨ Γ ⊢ γ : σ ↝ τ ∷ k ⟩ →
  ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩.
Proof. induction 1; eauto with ws. Qed.
(* Hint Resolve red_co : ws. *)

Definition cofromredstar (σ: Exp) (γs: list Exp) : Exp :=
  fold_right (fun γ2 γ1 => cotrans γ1 γ2) (corefl σ) γs.

Lemma redstar_co {Γ γs σ τ k} :
  ⟨ Γ ⊢ γs : σ ↝* τ ∷ k ⟩ →
  ⟨ Γ ⊢ cofromredstar σ γs : σ ~ τ ∷ k ⟩.
Proof. induction 1; crush; eauto using red_co. Qed.
(* Hint Resolve redstar_co : ws. *)

Section WfEnv.

  Hint Resolve wfenv_covar_kind_left : ws.
  Hint Resolve wfenv_covar_kind_right : ws.
  Hint Resolve wfenv_tmvar_ty : ws.

  Lemma WfEnv_nil : WfEnv nil.
  Proof. constructor; inversion 1. Qed.

  Lemma wfenv_snoc_tyvar {Γ} (wΓ: WfEnv Γ) : ∀ k, WfEnv (Γ ► k).
  Proof. constructor; crush. Qed.

  Lemma wfenv_snoc_tmvar {Γ} (wΓ: WfEnv Γ) :
    ∀ τ, ⟨ Γ ⊢ τ ∷ kstar ⟩ → WfEnv (Γ ▻ τ).
  Proof. constructor; crush. Qed.

  Lemma wfenv_snoc_covar {Γ} (wΓ: WfEnv Γ) :
    ∀ σ τ k, ⟨ Γ ⊢ σ ∷ k ⟩ → ⟨ Γ ⊢ τ ∷ k ⟩ → WfEnv (Γ ◅ σ ~ τ ∷ k).
  Proof. constructor; crush. Qed.

End WfEnv.

Hint Resolve WfEnv_nil : ws.
Hint Resolve wfenv_snoc_tyvar : ws.
Hint Resolve wfenv_snoc_tmvar : ws.
Hint Resolve wfenv_snoc_covar : ws.

Section Agreement.

  Hint Resolve wfenv_covar_kind_left : ws.
  Hint Resolve wfenv_covar_kind_right : ws.
  Hint Resolve wfenv_tmvar_ty : ws.

  Lemma co_agreement {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ σ ∷ k ⟩ ∧ ⟨ Γ ⊢ τ ∷ k ⟩.
  Proof. induction wγ; crush. Qed.

  Lemma co_agreement_left {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ σ ∷ k ⟩.
  Proof. eapply co_agreement; eauto with ws. Qed.
  Hint Resolve co_agreement_left : ws.

  Lemma co_agreement_right {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ τ ∷ k ⟩.
  Proof. eapply co_agreement; eauto with ws. Qed.
  Hint Resolve co_agreement_right : ws.

  Lemma tm_agreement_ty {Γ t σ} (wΓ: WfEnv Γ) (wt: ⟨ Γ ⊢ t : σ ⟩) :
    ⟨ Γ ⊢ σ ∷ kstar ⟩.
  Proof. induction wt; crush. Qed.

End Agreement.

(******************************************************************************)

Fixpoint redrefl (τ: Exp) : Exp :=
  match τ with
    | var α           => corefl (var α)
    | τabs k τ        => coτabs k (redrefl τ)
    | τapp τ1 τ2      => coτapp (redrefl τ1) (redrefl τ2)
    | arr τ1 τ2       => coarr (redrefl τ1) (redrefl τ2)
    | arrτ k τ        => coarrτ k (redrefl τ)
    | arrγ τ1 τ2 k τ3 => coarrγ (redrefl τ1) (redrefl τ2) k (redrefl τ3)
    | _ => var 0
  end.

Lemma RedRefl {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ⟨ Γ ⊢ redrefl τ : τ ↝ τ ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve RedRefl : ws.

Definition rstrans (γs1 γs2: list Exp) : list Exp :=
  List.app γs2 γs1.
Lemma RsTrans {Γ γs1 γs2 τ1 τ2 τ3 k} :
  ⟨ Γ ⊢ γs1 : τ1 ↝* τ2 ∷ k ⟩ →
  ⟨ Γ ⊢ γs2 : τ2 ↝* τ3 ∷ k ⟩ →
  ⟨ Γ ⊢ rstrans γs1 γs2 : τ1 ↝* τ3 ∷ k ⟩.
Proof. intros wγs1 wγs2; induction wγs2; crush. Qed.

Definition rsτabs (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coτabs k) γs.
Lemma RsTAbs {Γ γs σ τ k1 k2} :
  ⟨ Γ ► k1 ⊢ γs : σ ↝* τ ∷ k2 ⟩ →
  ⟨ Γ ⊢ rsτabs k1 γs : τabs k1 σ ↝* τabs k1 τ ∷ karr k1 k2 ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsτapp₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coτapp γ (redrefl τ)) γs.
Definition rsτapp₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coτapp (redrefl σ)) γs.
Definition rsτapp (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsτapp₁ σγs τ1) (rsτapp₂ σ2 τγs).

Lemma RsTApp₁ {Γ γs σ1 σ2 τ k1 k2} :
  ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ τ ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp₁ γs τ : τapp σ1 τ ↝* τapp σ2 τ ∷ k2 ⟩.
Proof. intros wγs wτ; unfold rsτapp₁; depind wγs; crush. Qed.
Lemma RsTApp₂ {Γ γs τ1 τ2 σ k1 k2} :
  ⟨ Γ ⊢ σ ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp₂ σ γs: τapp σ τ1 ↝* τapp σ τ2 ∷ k2 ⟩.
Proof. intros wσ wγs; unfold rsτapp₂; depind wγs; crush. Qed.

Lemma RsTApp {Γ σγs τγs σ1 σ2 τ1 τ2 k1 k2} :
  ⟨ Γ ⊢ σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ τ1 ∷ k1 ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp σγs σ1 σ2 τγs τ1 τ2 : τapp σ1 τ1 ↝* τapp σ2 τ2 ∷ k2 ⟩.
Proof.
  intros.
  eapply RsTrans.
  - eapply RsTApp₁; crush.
  - eapply RsTApp₂; crush.
Qed.

Definition rsarr₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coarr γ (redrefl τ)) γs.
Definition rsarr₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coarr (redrefl σ)) γs.
Definition rsarr (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsarr₁ σγs τ1) (rsarr₂ σ2 τγs).

Lemma RsArr₁ {Γ σγs σ1 σ2 τ} :
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τ ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr₁ σγs τ : arr σ1 τ ↝* arr σ2 τ ∷ kstar ⟩.
Proof. intros wσγs wτ; unfold rsarr₁; depind wσγs; crush. Qed.
Lemma RsArr₂ {Γ σ τγs τ1 τ2} :
  ⟨ Γ ⊢ σ ∷ kstar ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr₂ σ τγs: arr σ τ1 ↝* arr σ τ2 ∷ kstar ⟩.
Proof. intros wσ wτγs; unfold rsarr₂; depind wτγs; crush. Qed.

Lemma RsArr {Γ σγs σ1 σ2 τγs τ1 τ2} :
  ⟨ Γ ⊢ σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr σγs σ1 σ2 τγs τ1 τ2 : arr σ1 τ1 ↝* arr σ2 τ2 ∷ kstar ⟩.
Proof.
  intros.
  eapply RsTrans.
  - eapply RsArr₁; crush.
  - eapply RsArr₂; crush.
Qed.

Definition rsarrτ (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coarrτ k) γs.
Lemma RsArrT {Γ γs σ τ k} :
  ⟨ Γ ► k ⊢ γs : σ ↝* τ ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrτ k γs : arrτ k σ ↝* arrτ k τ ∷ kstar ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsarrγ₁ (σγs: list Exp) (τ: Exp) (k: Kind) (ν: Exp) : list Exp :=
  List.map (fun σγ => coarrγ σγ (redrefl τ) k (redrefl ν)) σγs.
Definition rsarrγ₂ (σ: Exp) (τγs: list Exp) (k: Kind) (ν: Exp) : list Exp :=
  List.map (fun τγ => coarrγ (redrefl σ) τγ k (redrefl ν)) τγs.
Definition rsarrγ₃ (σ: Exp) (τ: Exp) (k: Kind) (νγs: list Exp) : list Exp :=
  List.map (fun νγ => coarrγ (redrefl σ) (redrefl τ) k νγ) νγs.
Definition rsarrγ (σγs: list Exp) (σ σ': Exp) (τγs: list Exp) (τ τ': Exp) k (νγs: list Exp) (ν ν': Exp) : list Exp :=
  rstrans (rsarrγ₁ σγs τ k ν) (rstrans (rsarrγ₂ σ' τγs k ν) (rsarrγ₃ σ' τ' k νγs)).

Lemma RsArrG₁ {Γ σγs σ σ' τ k ν} :
  ⟨ Γ ⊢ σγs : σ ↝* σ' ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₁ σγs τ k ν : arrγ σ τ k ν ↝* arrγ σ' τ k ν ∷ kstar ⟩.
Proof. intros wσγs wτ wν; unfold rsarrγ₁; depind wσγs; crush. Qed.
Lemma RsArrG₂ {Γ σ τγs τ τ' k ν} :
  ⟨ Γ ⊢ σ ∷ k ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₂ σ τγs k ν : arrγ σ τ k ν ↝* arrγ σ τ' k ν ∷ kstar ⟩.
Proof. intros wσ wτγs wν; unfold rsarrγ₂; depind wτγs; crush. Qed.
Lemma RsArrG₃ {Γ σ τ k νγs ν ν'} :
  ⟨ Γ ⊢ σ ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ νγs : ν ↝* ν' ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₃ σ τ k νγs : arrγ σ τ k ν ↝* arrγ σ τ k ν' ∷ kstar ⟩.
Proof. intros wσ wτ wνγs; unfold rsarrγ₃; depind wνγs; crush. Qed.

Lemma RsArrG {Γ σγs σ σ' τγs τ τ' k νγs ν ν'} :
  ⟨ Γ ⊢ σ' ∷ k ⟩ →
  ⟨ Γ ⊢ σγs : σ ↝* σ' ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ τ' ∷ k ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ νγs : ν ↝* ν' ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ σγs σ σ' τγs τ τ' k νγs ν ν' : arrγ σ τ k ν ↝* arrγ σ' τ' k ν' ∷ kstar ⟩.
Proof.
  intros.
  eapply RsTrans.
  eapply RsArrG₁; crush.
  eapply RsTrans.
  eapply RsArrG₂; crush.
  eapply RsArrG₃; crush.
Qed.

Definition rsbeta (k: Kind) (σγs: list Exp) (σ σ': Exp) (τγs: list Exp) (τ τ': Exp) : list Exp :=
  cons (cobeta k (redrefl σ') (redrefl τ')) (rsτapp (rsτabs k σγs) (τabs k σ) (τabs k σ') τγs τ τ').

Lemma RsBeta {Γ σγs σ σ' τγs τ τ' k1 k2} :
  ⟨ Γ ► k1 ⊢ σ' ∷ k2 ⟩ →
  ⟨ Γ ► k1 ⊢ σγs : σ ↝* σ' ∷ k2 ⟩ →
  ⟨ Γ ⊢ τ ∷ k1 ⟩ →
  ⟨ Γ ⊢ τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsbeta k1 σγs σ σ' τγs τ τ' : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩.
Proof.
  intros. unfold rsbeta.
  econstructor.
  - eapply RsTApp; eauto.
    + constructor; auto.
    + eapply RsTAbs; eauto.
  - constructor; eauto.
    + eapply RedRefl; eauto.
    + eapply RedRefl; eauto.
Qed.

(* Definition coredstarbeta₁ (k: Kind) (γs: list Exp) (τ: Exp) : list Exp := *)
(*   List.map (fun γ => cobeta k γ (redrefl τ)) γs. *)
(* Lemma RedStarBeta₁ {Γ γsσ σ σ' γsτ τ τ' k1 k2} : *)
(*   ⟨ Γ ► k1 ⊢ γsσ : σ ↝* σ' ∷ k2 ⟩ → *)
(*   ⟨ Γ ⊢ γsτ : τ ~ τ' ∷ k1 ⟩ → *)
(*   ∃ ηs, ⟨ Γ ⊢ ηs : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩. *)
(* Proof.   *)
(*   unfold coredstarbeta₁; depind rσ; crush. *)
(* Qed. *)

(* Definition coredstarbeta₂ (σ: Exp) (γs: list Exp)  : list Exp := *)
(*   List.map (cobeta (redrefl σ)) γs. *)
(* Lemma RedStarBeta₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ coredstarbeta₂ σ γs: beta σ τ1 ↝* beta σ τ2 ∷ kstar ⟩. *)
(* Proof. unfold coredstarbeta₂; depind rτ; crush. Qed. *)

(* Definition coredstarbeta (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp := *)
(*   rstrans (coredstarbeta₁ σγs τ1) (coredstarbeta₂ σ2 τγs). *)
(* Lemma RedStarBeta {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ) *)
(*   (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩) *)
(*   (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ⟨ Γ ⊢ coredstarbeta σγs σ1 σ2 τγs τ1 τ2 : beta σ1 τ1 ↝* beta σ2 τ2 ∷ kstar ⟩. *)
(* Proof. *)
(*   eapply RsTrans. *)
(*   - eapply RedStarBeta₁; crush. *)
(*   - eapply RedStarBeta₂; crush. *)
(* Qed. *)

(*
Definition rstrans (γs1 γs2: list Exp) : list Exp :=
  List.app γs2 γs1.

Lemma RsTrans {Γ γs1 γs2 τ1 τ2 ν k} :
  ⟨ Γ ⊢ γs1 : τ1 ↝* τ2 ∷ k ⟩ →
  ⟨ Γ ⊢ γs2 : τ2 ↝* ν ∷ k ⟩ →
  ⟨ Γ ⊢ rstrans γs1 γs2 : τ1 ↝* τ3 ∷ k ⟩.
Proof. intros r q; revert τ1 r; induction q; crush. Qed.

Fixpoint redrefl (τ: Exp) : Exp :=
  match τ with
    | var α           => corefl (var α)
    | τabs k τ        => coτabs k (redrefl τ)
    | τapp τ1 τ2      => coτapp (redrefl τ1) (redrefl τ2)
    | arr τ1 τ2       => coarr (redrefl τ1) (redrefl τ2)
    | arrτ k τ        => coarrτ k (redrefl τ)
    | arrγ τ1 τ2 k τ3 => coarrγ (redrefl τ1) (redrefl τ2) k (redrefl τ3)
    | _ => var 0
  end.

Lemma RedRefl {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ⟨ Γ ⊢ redrefl τ : τ ↝ τ ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve RedRefl : ws.

Definition rsτapp₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coτapp γ (redrefl τ)) γs.
Lemma RsTApp₁ {Γ γs σ1 σ2 k1 k2} (rσ: ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩) :
  ∀ {τ}, ⟨ Γ ⊢ τ ∷ k1 ⟩ → ⟨ Γ ⊢ rsτapp₁ γs τ : τapp σ1 τ ↝* τapp σ2 τ ∷ k2 ⟩.
Proof. unfold rsτapp₁; depind rσ; crush. Qed.
Definition rsτapp₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coτapp (redrefl σ)) γs.
Lemma RsTApp₂ {Γ γs τ1 τ2 k1} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k1 ⟩) :
  ∀ {σ k2}, ⟨ Γ ⊢ σ ∷ karr k1 k2 ⟩ → ⟨ Γ ⊢ rsτapp₂ σ γs: τapp σ τ1 ↝* τapp σ τ2 ∷ k2 ⟩.
Proof. unfold rsτapp₂; depind rτ; crush. Qed.

Definition rsτapp (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsτapp₁ σγs τ1) (rsτapp₂ σ2 τγs).
Lemma RsTApp {Γ σγs τγs σ1 σ2 τ1 τ2 k1 k2} (wΓ: WfEnv Γ)
  (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩)
  (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ k1 ⟩) :
  ⟨ Γ ⊢ rsτapp σγs σ1 σ2 τγs τ1 τ2 : τapp σ1 τ1 ↝* τapp σ2 τ2 ∷ k2 ⟩.
Proof.
  eapply RsTrans.
  - eapply RsTApp₁; crush.
  - eapply RsTApp₂; crush.
Qed.

Definition rsτabs (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coτabs k) γs.
Lemma RsTAbs {Γ γs σ τ k1 k2} :
  ⟨ Γ ► k1 ⊢ γs : σ ↝* τ ∷ k2 ⟩ →
  ⟨ Γ ⊢ rsτabs k1 γs : τabs k1 σ ↝* τabs k1 τ ∷ karr k1 k2 ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsarr₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coarr γ (redrefl τ)) γs.
Lemma RsArr₁ {Γ γs σ1 σ2} (rσ: ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ kstar ⟩) :
  ∀ {τ}, ⟨ Γ ⊢ τ ∷ kstar ⟩ → ⟨ Γ ⊢ rsarr₁ γs τ : arr σ1 τ ↝* arr σ2 τ ∷ kstar ⟩.
Proof. unfold rsarr₁; depind rσ; crush. Qed.
Definition rsarr₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coarr (redrefl σ)) γs.
Lemma RsArr₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) :
  ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ rsarr₂ σ γs: arr σ τ1 ↝* arr σ τ2 ∷ kstar ⟩.
Proof. unfold rsarr₂; depind rτ; crush. Qed.

Definition rsarr (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsarr₁ σγs τ1) (rsarr₂ σ2 τγs).
Lemma RsArr {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ)
  (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩)
  (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) :
  ⟨ Γ ⊢ rsarr σγs σ1 σ2 τγs τ1 τ2 : arr σ1 τ1 ↝* arr σ2 τ2 ∷ kstar ⟩.
Proof.
  eapply RsTrans.
  - eapply RsArr₁; crush.
  - eapply RsArr₂; crush.
Qed.

(* Definition rsarrτ (k: Kind) (γs: list Exp) : list Exp := *)
(*   List.map (coarrτ k) γs. *)
(* Lemma RsArrT {Γ γs σ τ k} : *)
(*   ⟨ Γ ► k ⊢ γs : σ ↝* τ ∷ kstar ⟩ → *)
(*   ⟨ Γ ⊢ rsarrτ k γs : arrτ k σ ↝* arrτ k τ ∷ kstar ⟩. *)
(* Proof. intros wγs; depind wγs; crush. Qed. *)

(* Definition coredstarbeta₁ (k: Kind) (γs: list Exp) (τ: Exp) : list Exp := *)
(*   List.map (fun γ => cobeta k γ (redrefl τ)) γs. *)
(* Lemma RedStarBeta₁ {Γ γsσ σ σ' γsτ τ τ' k1 k2} : *)
(*   ⟨ Γ ► k1 ⊢ γsσ : σ ↝* σ' ∷ k2 ⟩ → *)
(*   ⟨ Γ ⊢ γsτ : τ ~ τ' ∷ k1 ⟩ → *)
(*   ∃ ηs, ⟨ Γ ⊢ ηs : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩. *)
(* Proof.   *)
(*   unfold coredstarbeta₁; depind rσ; crush. *)
(* Qed. *)

(* Definition coredstarbeta₂ (σ: Exp) (γs: list Exp)  : list Exp := *)
(*   List.map (cobeta (redrefl σ)) γs. *)
(* Lemma RedStarBeta₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ coredstarbeta₂ σ γs: beta σ τ1 ↝* beta σ τ2 ∷ kstar ⟩. *)
(* Proof. unfold coredstarbeta₂; depind rτ; crush. Qed. *)

(* Definition coredstarbeta (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp := *)
(*   rstrans (coredstarbeta₁ σγs τ1) (coredstarbeta₂ σ2 τγs). *)
(* Lemma RedStarBeta {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ) *)
(*   (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩) *)
(*   (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ⟨ Γ ⊢ coredstarbeta σγs σ1 σ2 τγs τ1 τ2 : beta σ1 τ1 ↝* beta σ2 τ2 ∷ kstar ⟩. *)
(* Proof. *)
(*   eapply RsTrans. *)
(*   - eapply RedStarBeta₁; crush. *)
(*   - eapply RedStarBeta₂; crush. *)
(* Qed. *)
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigop ssralg matrix zmodp div.

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

Import GRing.Theory.
Local Open Scope nat_scope.
Local Open Scope ring_scope.

Section ExtraBigOp.

Lemma sumr_add : forall (R : ringType) m n (F : 'I_(m + n) -> R),
  \sum_(i < m + n) F i = \sum_(i < m) F (lshift _ i)
  + \sum_(i < n) F (rshift _ i).
Proof.
move=> R; elim=> [|m ihm] n F.
  rewrite !big_ord0 add0r; apply: congr_big=> // [[i hi]] _.
  by rewrite /rshift /=; congr F; apply: val_inj.
rewrite !big_ord_recl ihm -addrA.
congr (_ + _); first by congr F; apply: val_inj.
congr (_ + _); by apply: congr_big=> // i _ /=; congr F; apply: val_inj.
Qed.

Lemma mxtens_index_proof m n (ij : 'I_m * 'I_n) : ij.1 * n + ij.2 < m * n.
Proof.
case: m ij=> [[[] //]|] m ij; rewrite mulSn addnC -addSn leq_add //.
by rewrite leq_mul2r; case: n ij=> // n ij; rewrite leq_ord orbT.
Qed.

Definition mxtens_index m n ij := Ordinal (@mxtens_index_proof m n ij).

Lemma mxtens_index_proof1 m n (k : 'I_(m * n)) : k %/ n < m.
Proof. by move: m n k=> [_ [] //|m] [|n] k; rewrite ?divn0 // ltn_divLR. Qed.
Lemma mxtens_index_proof2 m n (k : 'I_(m * n)) : k %% n < n.
Proof. by rewrite ltn_mod; case: n k=> //; rewrite muln0=> [] []. Qed.

Definition mxtens_unindex m n k :=
  (Ordinal (@mxtens_index_proof1 m n k), Ordinal (@mxtens_index_proof2 m n k)).

Implicit Arguments mxtens_index [[m] [n]].
Implicit Arguments mxtens_unindex [[m] [n]].

Lemma mxtens_indexK m n : cancel (@mxtens_index m n) (@mxtens_unindex m n).
Proof.
case: m=> [[[] //]|m]; case: n=> [[_ [] //]|n].
move=> [i j]; congr (_, _); apply: val_inj=> /=.
  by rewrite divnMDl // divn_small.
by rewrite modnMDl // modn_small.
Qed.

Lemma mxtens_unindexK m n : cancel (@mxtens_unindex m n) (@mxtens_index m n).
Proof.
case: m=> [[[] //]|m]. case: n=> [|n] k.
  by suff: False by []; move: k; rewrite muln0=> [] [].
by apply: val_inj=> /=; rewrite -divn_eq.
Qed.

CoInductive is_mxtens_index (m n : nat) : 'I_(m * n) -> Type :=
    IsMxtensIndex : forall (i : 'I_m) (j : 'I_n),
                   is_mxtens_index (mxtens_index (i, j)).

Lemma mxtens_indexP (m n : nat) (k : 'I_(m * n)) : is_mxtens_index k.
Proof. by rewrite -[k]mxtens_unindexK; constructor. Qed.

Lemma mulr_sum (R : ringType) m n (Fm : 'I_m -> R) (Fn : 'I_n -> R) :
  (\sum_(i < m) Fm i) * (\sum_(i < n) Fn i)
  = \sum_(i < m * n) ((Fm (mxtens_unindex i).1) * (Fn (mxtens_unindex i).2)).
Proof.
rewrite mulr_suml; transitivity (\sum_i (\sum_(j < n) Fm i * Fn j)).
  by apply: eq_big=> //= i _; rewrite -mulr_sumr.
rewrite pair_big; apply: reindex=> //=.
by exists mxtens_index=> i; rewrite (mxtens_indexK, mxtens_unindexK).
Qed.

End ExtraBigOp.

Section ExtraMx.

Lemma castmx_mul (R : ringType)
  (m m' n p p': nat) (em : m = m') (ep : p = p')
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n, p)) :
  castmx (em, ep) (M *m N) = castmx (em, erefl _) M *m castmx (erefl _, ep) N.
Proof. by case: m' / em; case: p' / ep. Qed.

Lemma mulmx_cast (R : ringType)
  (m n n' p p' : nat) (en : n' = n) (ep : p' = p)
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n', p')) :
  M *m (castmx (en, ep) N) =
  (castmx (erefl _, (esym en)) M) *m (castmx (erefl _, ep) N).
Proof. by case: n / en in M *; case: p / ep in N *. Qed.

Lemma castmx_row (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(m, n1)) (A2 : 'M_(m, n2)) :
  castmx (eq_m, eq_n12) (row_mx A1 A2) =
  row_mx (castmx (eq_m, eq_n1) A1) (castmx (eq_m, eq_n2) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_col (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(n1, m)) (A2 : 'M_(n2, m)) :
  castmx (eq_n12, eq_m) (col_mx A1 A2) =
  col_mx (castmx (eq_n1, eq_m) A1) (castmx (eq_n2, eq_m) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_block (R : Type) (m1 m1' m2 m2' n1 n2 n1' n2' : nat)
  (eq_m1 : m1 = m1') (eq_n1 : n1 = n1') (eq_m2 : m2 = m2') (eq_n2 : n2 = n2')
  (eq_m12 : (m1 + m2 = m1' + m2')%N) (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (ul : 'M[R]_(m1, n1)) (ur : 'M[R]_(m1, n2))
  (dl : 'M[R]_(m2, n1)) (dr : 'M[R]_(m2, n2)) :
  castmx (eq_m12, eq_n12) (block_mx ul ur dl dr) =
  block_mx (castmx (eq_m1, eq_n1) ul) (castmx (eq_m1, eq_n2) ur)
  (castmx (eq_m2, eq_n1) dl) (castmx (eq_m2, eq_n2) dr).
Proof.
case: _ / eq_m1 in eq_m12 *; case: _ / eq_m2 in eq_m12 *.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by rewrite !castmx_id.
Qed.

End ExtraMx.

Section MxTens.

Variable R : ringType.

Definition tensmx {m n p q : nat}
  (A : 'M_(m, n)) (B : 'M_(p, q)) : 'M[R]_(_,_) := nosimpl
  (\matrix_(i, j) (A (mxtens_unindex i).1 (mxtens_unindex j).1
                 * B (mxtens_unindex i).2 (mxtens_unindex j).2)).

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Lemma tensmxE {m n p q} (A : 'M_(m, n)) (B : 'M_(p, q)) i j k l :
  (A *t B) (mxtens_index (i, j)) (mxtens_index (k, l)) = A i k * B j l.
Proof. by rewrite !mxE !mxtens_indexK. Qed.

Lemma tens0mx {m n p q} (M : 'M[R]_(p,q)) : (0 : 'M_(m,n)) *t M = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mul0r. Qed.

Lemma tensmx0 {m n p q} (M : 'M[R]_(m,n)) : M *t (0 : 'M_(p,q)) = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mulr0. Qed.

Lemma tens_scalar_mx (m n : nat) (c : R) (M : 'M_(m,n)):
  c%:M *t M = castmx (esym (mul1n _), esym (mul1n _)) (c *: M).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i0]ord1 [j0]ord1 !castmxE !mxE /= mulr1n.
by congr (_ * M _ _); apply: val_inj.
Qed.

Lemma tens_scalar1mx (m n : nat) (M : 'M_(m,n)) :
  1 *t M = castmx (esym (mul1n _), esym (mul1n _)) M.
Proof. by rewrite tens_scalar_mx scale1r. Qed.

Lemma tens_scalarN1mx (m n : nat) (M : 'M_(m,n)) :
  (-1) *t M = castmx (esym (mul1n _), esym (mul1n _)) (-M).
Proof. by rewrite [-1]mx11_scalar /= tens_scalar_mx !mxE scaleNr scale1r. Qed.

Lemma trmx_tens {m n p q} (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (M *t N)^T = M^T *t N^T.
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma tens_col_mx {m n p q} (r : 'rV[R]_n)
  (M :'M[R]_(m, n)) (N : 'M[R]_(p, q)) :
  (col_mx r M) *t N =
  castmx (esym (mulnDl _ _ _), erefl _) (col_mx (r *t N) (M *t N)).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite !tensmxE castmxE /= cast_ord_id esymK !mxE /=.
case: splitP=> i0' /= hi0'; case: splitP=> k /= hk.
+ case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
  move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
  by congr (r _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1.
+ move: hk (ltn_ord i1); rewrite hi0'.
  by rewrite [i0']ord1 mul0n mul1n add0n ltnNge=> ->; rewrite leq_addr.
+ move: (ltn_ord k); rewrite -hk hi0' ltnNge {1}mul1n.
  by rewrite mulnDl {1}mul1n -addnA leq_addr.
case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
rewrite hi0' mulnDl -addnA=> /addnI.
 move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
by congr (M _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1.
Qed.

Lemma tens_row_mx {m n p q} (r : 'cV[R]_m) (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (row_mx r M) *t N =
  castmx (erefl _, esym (mulnDl _ _ _)) (row_mx (r *t N) (M *t N)).
Proof.
rewrite -[_ *t _]trmxK trmx_tens tr_row_mx tens_col_mx.
apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP.
by rewrite trmx_cast castmx_comp castmx_id tr_col_mx -!trmx_tens !trmxK.
Qed.

Lemma tens_block_mx {m n p q}
  (ul : 'M[R]_1) (ur : 'rV[R]_n) (dl : 'cV[R]_m)
  (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (block_mx ul ur dl M) *t N =
  castmx (esym (mulnDl _ _ _), esym (mulnDl _ _ _))
  (block_mx (ul *t N) (ur *t N) (dl *t N) (M *t N)).
Proof.
rewrite !block_mxEv tens_col_mx !tens_row_mx -!cast_col_mx castmx_comp.
by congr (castmx (_,_)); apply nat_irrelevance.
Qed.

Fixpoint ntensmx_rec {m n} (A : 'M_(m,n)) k : 'M_(m ^ k.+1,n ^ k.+1) :=
  if k is k'.+1 then (A *t (ntensmx_rec A k')) else A.

Definition ntensmx {m n} (A : 'M_(m, n)) k := nosimpl
  (if k is k'.+1 return 'M[R]_(m ^ k,n ^ k) then ntensmx_rec A k' else 1).

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Lemma ntensmx0 : forall {m n} (A : 'M_(m,n)) , A ^t 0 = 1.
Proof. by []. Qed.

Lemma ntensmx1 : forall {m n} (A : 'M_(m,n)) , A ^t 1 = A.
Proof. by []. Qed.

Lemma ntensmx2 : forall {m n} (A : 'M_(m,n)) , A ^t 2 = A *t A.
Proof. by []. Qed.

Lemma ntensmxSS : forall {m n} (A : 'M_(m,n)) k, A ^t k.+2 = A *t A ^t k.+1.
Proof. by []. Qed.

Definition ntensmxS := (@ntensmx1, @ntensmx2, @ntensmxSS).

End MxTens.

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Section MapMx.
Variables (aR rR : ringType).
Hypothesis f : {rmorphism aR -> rR}.
Local Notation "A ^f" := (map_mx f A) : ring_scope.

Variables m n p q: nat.
Implicit Type A : 'M[aR]_(m, n).
Implicit Type B : 'M[aR]_(p, q).

Lemma map_mxT A B : (A *t B)^f = A^f *t B^f :> 'M_(m*p, n*q).
Proof. by apply/matrixP=> i j; rewrite !mxE /= rmorphM. Qed.

End MapMx.

Section Misc.

Lemma tensmx_mul (R : comRingType) m n p q r s
  (A : 'M[R]_(m,n)) (B : 'M[R]_(p,q)) (C : 'M[R]_(n, r)) (D : 'M[R]_(q, s)) :
  (A *t B) *m (C *t D) = (A *m C) *t (B *m D).
Proof.
apply/matrixP=> /= i j.
case (mxtens_indexP i)=> [im ip] {i}; case (mxtens_indexP j)=> [jr js] {j}.
rewrite !mxE !mxtens_indexK mulr_sum; apply: congr_big=> // k _.
by rewrite !mxE !mxtens_indexK mulrCA !mulrA [C _ _ * A _ _]mulrC.
Qed.

(* Todo : move to div ? *)
Lemma eq_addl_mul q q' m m' d : m < d -> m' < d ->
  (q * d + m == q' * d  + m')%N = ((q, m) == (q', m')).
Proof.
move=> lt_md lt_m'd; apply/eqP/eqP; last by move=> [-> ->].
by move=> /(f_equal (edivn^~ d)); rewrite !edivn_eq.
Qed.

Lemma tensmx_unit (R : fieldType) m n (A : 'M[R]_m%N) (B : 'M[R]_n%N) :
  m != 0%N -> n != 0%N -> A \in unitmx -> B \in unitmx -> (A *t B) \in unitmx.
Proof.
move: m n A B => [|m] [|n] // A B _ _ uA uB.
suff : (A^-1 *t B^-1) *m (A *t B) = 1 by case/mulmx1_unit.
rewrite tensmx_mul !mulVmx //; apply/matrixP=> /= i j.
rewrite !mxE /=; symmetry; rewrite -natrM -!val_eqE /=.
rewrite {1}(divn_eq i n.+1) {1}(divn_eq j n.+1).
by rewrite eq_addl_mul ?ltn_mod // xpair_eqE mulnb.
Qed.

Lemma tens_mx_scalar : forall (R : comRingType)
  (m n : nat) (c : R) (M : 'M[R]_(m,n)),
  M *t c%:M = castmx (esym (muln1 _), esym (muln1 _)) (c *: M).
Proof.
move=> R0 m n c M; apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i1]ord1 [j1]ord1 !castmxE !mxE /= mulr1n mulrC.
by congr (_ * M _ _); apply: val_inj=> /=; rewrite muln1 addn0.
Qed.

Lemma tensmx_decr : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (M *t 1%:M) *m (1%:M *t N).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

Lemma tensmx_decl : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (1%:M *t N) *m (M *t 1%:M).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

End Misc.


Require Import Notation.
Require Import GeneralTactics.
Require Import TacticCombinators.

Import EqNotations.

Lemma proof_irrelevance__uip_refl :
  (forall (P: Prop) (p1 p2: P), p1 = p2) ->
  forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  intros ? *.
  assumption!.
Qed.

Module Type UipImpl.
  Axiom uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
End UipImpl.

Module UipTheory (M: UipImpl).

Lemma uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  exact M.uip_refl.
Qed.

Lemma uip : forall A (x y: A) (p q: x = y),
  p = q.
Proof using.
  intros.
  destruct q.
  apply uip_refl.
Qed.

Lemma eq_K : forall A (x: A) (P: x = x -> Type),
  P (eq_refl x) ->
  forall p: x = x, P p.
Proof using.
  intros.
  now rewrite uip_refl.
Qed.

Lemma eq_rect_eq : forall A (x: A) (P: A -> Type) (y: P x) (h: x = x),
  y = eq_rect x P y x h.
Proof using.
  intros *.
  now rewrite (uip_refl _ _ h).
Qed.

Lemma inj_pair2 :
  forall A (P: A -> Type) a (x y: P a),
    ⟨a, x⟩ = ⟨a, y⟩ ->
    x = y.
Proof using.
  intros.
  inversion_sigma.
  now find rewrite <- eq_rect_eq in.
Qed.

Notation inj_pairT2 := inj_pair2.

(* Dependent inversion tactics leveraging LEM *)

Ltac destr_sigma_eq :=
  repeat match goal with
  | H: existT _ _ _ = existT _ _ _ |- _ =>
      simple apply inj_pairT2 in H
  end.

Tactic Notation "dependent" "inv" hyp(H) :=
  inv H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "inv" hyp(H) "as" simple_intropattern(pat) :=
  inv H as pat;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) :=
  invc H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) "as" simple_intropattern(pat) :=
  invc H as pat;
  destr_sigma_eq;
  subst!.

Tactic Notation "inv!" hyp(H) :=
  env_delta (dependent inv H) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "inv!" hyp(H) "as" simple_intropattern(pat) :=
  env_delta (dependent inv H as pat) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "invc!" hyp(H) :=
  env_delta (dependent invc H) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "invc!" hyp(H) "as" simple_intropattern(pat) :=
  env_delta (dependent invc H as pat) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

(* This is a modification of injection, which behaves like `invc` in the sense
   that it clears the original, does `subst!`, and destructs sigma equalities
   with UIP *)
Ltac inject H :=
  match goal with
  | |- ?g =>
      injection H;
      try clear H;
      repeat lazymatch goal with
      | |- g => fail
      | _ => intro
      end;
      subst!;
      destr_sigma_eq;
      subst!
  end.

(* Here we give a redefinition of the JMeq construct. Unfortunately, the
   existing JMeq definition is irrevocably tied to the JMeq_eq axiom,
   which we'd rather not accept here, since it can be derived by
   UIP (and by extesion, LEM).
 *)

Unset Elimination Schemes.
Inductive JMeq (A: Type) (x : A) : forall B : Type, B -> Prop :=
  | JMeq_refl : JMeq A x A x.
Set Elimination Schemes.
Arguments JMeq {A} x {B} y.
Arguments JMeq_refl {A} x.

Notation "x ~=~ y" := (JMeq x y) (at level 70, no associativity).
Notation "x ~<>~ y" := (~ JMeq x y) (at level 70, no associativity).

Register JMeq as core.JMeq.type.
Register JMeq_refl as core.JMeq.refl.

#[global]
Hint Resolve JMeq_refl : core.

Definition JMeq_hom {A} (x y: A) := x ~=~ y.
Register JMeq_hom as core.JMeq.hom.

(* Note: this is in fact equivalent to UIP. *)
Lemma JMeq_eq : forall A (x y: A),
  x ~=~ y ->
  x = y.
Proof using.
  intros * Heq.
  now dependent inv Heq.
Qed.

Lemma eq_JMeq : forall A (x y: A),
  x = y ->
  x ~=~ y.
Proof using.
  now intros * ->.
Qed.

Lemma JMeq_is_eq : forall A (x y: A),
  x ~=~ y <-> x = y.
Proof using.
  intros *.
  split; intros ?.
  - now apply JMeq_eq.
  - now apply eq_JMeq.
Qed.

Theorem JMeq_rect : forall (A: Type) (x: A) (P : A -> Type),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  intros * ? * Heq.
  apply JMeq_eq in Heq.
  now induction Heq.
Qed.

Lemma JMeq_rec : forall (A: Type) (x: A) (P : A -> Set),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  exact JMeq_rect.
Qed.

Lemma JMeq_ind : forall (A: Type) (x: A) (P : A -> Prop),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  exact JMeq_rect.
Qed.

Register JMeq_ind as core.JMeq.ind.

Theorem JMeq_sym : forall A B (a: A) (b: B),
  a ~=~ b ->
  b ~=~ a.
Proof using.
  intros.
  follows destruct H.
Qed.

#[global]
Hint Immediate JMeq_sym : core.
Register JMeq_sym as core.JMeq.sym.

Theorem JMeq_trans : forall A B C (a: A) (b: B) (c: C),
  a ~=~ b ->
  b ~=~ c ->
  a ~=~ c.
Proof using.
  intros * [] [].
  constructor.
Qed.

Register JMeq_trans as core.JMeq.trans.

Theorem JMeq_congr : forall A (x: A) B (f: A -> B) (y: A),
  x ~=~ y ->
  f x = f y.
Proof using.
  intros * H.
  pattern y.
  follows eapply JMeq_ind.
Qed.

Register JMeq_congr as core.JMeq.congr.

Theorem f_JMequal : forall A (B: A -> Type) (f: forall a, B a) (x y: A),
  x = y ->
  f x ~=~ f y.
Proof using.
  follows intros * <-.
Qed.

Theorem JMeq_type_eq {A B} {a: A} {b: B}:
  a ~=~ b ->
  A = B.
Proof using.
  follows intros [].
Defined.

Theorem mistyped_nJMeq {A B} {a: A} {b: B}:
  A <> B ->
  a ~<>~ b.
Proof using.
  follows do 2 intro.
Qed.

Lemma rew_JMeq {A B} : forall (H: A = B) (a: A),
  rew H in a ~=~ a.
Proof using.
  intros *.
  now destruct H.
Qed.

Corollary rew_JMeq_sym {A B} : forall (H: A = B) (a: A),
  a ~=~ rew H in a.
Proof using.
  symmetry.
  apply rew_JMeq.
Qed.

Definition JMcast {A B} (H: A = B) (a: A) : {b: B | a ~=~ b} :=
  exist _ (rew H in a) (rew_JMeq_sym H a).

Theorem JMeq_by_rew_eq {A B}: forall (H: A = B) (x: A) (y: B),
  rew H in x = y ->
  x ~=~ y.
Proof using.
  intros * Heq.
  apply JMeq_trans with (b := rew H in x).
  - apply rew_JMeq_sym.
  - follows rewrite Heq.
Qed.

Theorem rew_eq_by_JMeq {A B}: forall (x: A) (y: B),
  forall h: x ~=~ y,
  rew JMeq_type_eq h in x = y.
Proof using.
  intros *.
  follows destruct h.
Qed.

Theorem JMeq_by_rew_eqr {A B}: forall (H: B = A) (x: A) (y: B),
  x = rew H in y ->
  x ~=~ y.
Proof using.
  intros * Heq.
  apply JMeq_trans with (b := rew H in y).
  - follows rewrite Heq.
  - apply rew_JMeq.
Qed.

Theorem rew_eqr_by_JMeq {A B}: forall (x: A) (y: B),
  forall h: x ~=~ y,
  x = rew eq_sym (JMeq_type_eq h) in y.
Proof using.
  intros *.
  follows destruct h.
Qed.

Theorem rew_eq_refl_cancel : forall A (x: A),
  rew eq_refl A in x = x.
Proof using.
  tedious.
Qed.

Theorem rew_cancel: forall A (H: A = A) (x: A),
  rew H in x = x.
Proof using.
  intros.
  rewrite (uip_refl _ _ H).
  apply rew_eq_refl_cancel.
Qed.

Theorem existT_eq_intro :
  forall (A: Type) (B: A -> Type) (a a': A) (b: B a) (b': B a'),
    a = a' ->
    b ~=~ b' ->
    ⟨a, b⟩ = ⟨a', b'⟩.
Proof using.
  intros * <- Heq'.
  f_equal.
  follows apply JMeq_eq.
Qed.

Lemma pair_JMeq_intro :
  forall A B C D (a: A) (b: B) (c: C) (d: D),
    a ~=~ b ->
    c ~=~ d ->
    (a, c) ~=~ (b, d).
Proof using.
  follows intros * [] [].
Qed.

(* `crush_eqs` aggressively factors out and destruct equalities by UIP *)

Ltac _crush_eqs cleanup :=
  match goal with
  | |- context[?p] =>
      match type of p with
      | _ = _ =>
          not is_var p;
          not (unify p eq_refl);
          let Heq := fresh "Heq" in
          set (Heq := p) in *;
          clearbody Heq;
          _crush_eqs (cleanup, Heq)
      end
  | _ : context[?p] |- _ =>
      match type of p with
      | _ = _ =>
          not is_var p;
          not (unify p eq_refl);
          let Heq := fresh "Heq" in
          set (Heq := p) in *;
          clearbody Heq;
          _crush_eqs (cleanup, Heq)
      end
  | _ =>
      repeat match goal with
      | Heq : ?x = ?y |- _ =>
          (rewrite (uip_refl _ x Heq) in *; try clear Heq) +
          (* destruct Heq + *)
          (let _tmp := fresh in copy Heq _tmp; destruct _tmp) +
          rewrite Heq in *
      end;
      foreach cleanup (fun H => try clear H)
  end.

Ltac crush_eqs :=
  subst!;
  _crush_eqs hnil.

End UipTheory.


Require Import type.

Lemma t_eq_dec : forall A (eq_dec : forall (x y : A), {x = y} + {x <> y}) (x y : t A),
  {x = y} + {x <> y}.
Proof.
  intros A eq_dec.
  unshelve refine (fix aux (x : t A) :=
    let aux2 (l1 : list (t A)) : forall l2, {l1 = l2} + {l1 <> l2} := _ in
    _); [|clearbody aux2].
  - decide equality.
  - decide equality.
Defined.

Fixpoint t_eq_dec' A (eq_dec : forall (x y : A), {x = y} + {x <> y}) x : forall y : t A,
  {x = y} + {x <> y}.
Proof.
  decide equality. decide equality.
Defined.


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

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependent
    interface [FSetInterface.WS] using lists without redundancy. *)

Require Import FSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** This is just a compatibility layer, the real implementation
    is now in [MSetWeakList] *)

Require Equalities FSetCompat MSetWeakList.

Module Make (X: DecidableType) <: WS with Module E := X.
 Module E := X.
 Module X' := Equalities.Update_DT X.
 Module MSet := MSetWeakList.Make X'.
 Include FSetCompat.Backport_WSets X MSet.
End Make.


Require Import MirrorSolve.FirstOrder.

Require Import MirrorSolve.BV.
Require Import MirrorSolve.SMT.
Require Import MirrorSolve.UF.

Require Import MirrorSolve.Reflection.Core.
Require Import MirrorSolve.Reflection.FM.
Require Import MirrorSolve.Reflection.Tactics.
From Hammer Require Import Hammer.

Require Import MirrorSolve.Crush.

Ltac hammer' := timeout 60 hammer.
Ltac crush' := timeout 60 crush.

Section Groups.

  Unset Universe Polymorphism.
  (* The set of the group. *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable G : Set.
  (*** MS END {"type": "definition"} *)

  (* The binary operator. *)

  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable f : G -> G -> G.
  Definition f' := f.
  (*** MS END {"type": "definition"} *)

  (* The group identity. *)
  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable e : G.
  Definition e' := e.
  (*** MS END {"type": "definition"} *)

  (* The inverse operator. *)
  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable i : G -> G.
  Definition i' := i.
  (*** MS END {"type": "definition"} *)

  (* For readability, we use infix <+> to stand for the binary operator. *)
  Infix "<+>" := f' (at level 50, left associativity).

  (* The operator [f] is associative. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom assoc : forall a b c, a <+> b <+> c = a <+> (b <+> c).
  (*** MS END {"type": "definition"} *)

  (* [e] is the right-identity for all elements [a] *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom id_r : forall a, a <+> e' = a.
  (*** MS END {"type": "definition"} *)

  (*** MS EFFORT {"type": "edit"} *)
  (* [i a] is the right-inverse of [a]. *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom inv_r : forall a, a <+> i' a = e'.
  (*** MS END {"type": "definition"} *)

  (* encoding groups in in FOL *)

  Local Declare ML Module "mirrorsolve".

  From MetaCoq.Template Require Import All Loader.
  Import MCMonadNotation.
  Require Import MirrorSolve.Config.
  Require Import Coq.Lists.List.
  Import ListNotations.
  Open Scope bs.

  Universe foo.
  MetaCoq Quote Definition typ_term := Type@{foo}.

  Notation pack x := (existT _ _ x).

  Definition fun_syms : list Config.packed := ([
      pack f'
    ; pack e'
    ; pack i'
  ])%type.

  Definition rel_syms : list Config.packed := ([
  ])%type.

  Definition prim_syms : list (Config.packed * String.string) := [
  ].

  MetaCoq Run (
    xs <- add_funs typ_term fun_syms [] ;;
    xs' <- tmQuote xs ;;
    tmMkDefinition "trans_tbl" xs'
  ).

  MetaCoq Run (
    gen_sig typ_term sorts fol_funs fol_rels
  ).
  MetaCoq Run (
    gen_interp_funs sorts interp_sorts fol_funs trans_tbl
  ).
  MetaCoq Run (
    gen_interp_rels sorts interp_sorts fol_rels trans_tbl
  ).
  Definition fm_model := Build_model sig interp_sorts interp_funs interp_rels.
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq IntLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v IntLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq BoolLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v BoolLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    add_matches sig fm_model trans_tbl
  ).
  MetaCoq Run (
    ctx <- build_printing_ctx sig sort_Prop trans_tbl prim_syms;;
    ctx' <- tmEval all ctx ;;
    rhs <- tmQuote ctx' ;;
    tmMkDefinition "fol_theory" rhs
  ).

  Require Import MirrorSolve.Reflection.Tactics.

  Transparent denote_tm.
  Require Import MirrorSolve.Axioms.

  (* We make use of the verification trick of negating the goal and checking for unsat.
    The check_unsat_neg tactic behaves like idtac if the negated goal is unsat and otherwise fails.
    *)
  Ltac check_goal_unsat :=
    match goal with
    | |- ?G => check_unsat_neg_func fol_theory G; eapply UnsoundAxioms.interp_true
    end.

  Create HintDb groups_eqns.

  Ltac prep_proof :=
    hints_foreach (fun x => pose proof x) "groups_eqns";
    Utils.revert_all;
    unfold "<->" in *.

  Scheme Equality for sorts.

  Ltac quote_reflect_groups := quote_reflect sig fm_model sorts_eq_dec match_tacs match_sorts.

  Ltac mirrorsolve :=
    timeout 60 (prep_proof;
    quote_reflect_groups;
    check_goal_unsat).

  Set MirrorSolve Solver "z3".
  (*** MS END {"type": "configuration", "config_type":"tactics"} *)

  Hint Immediate assoc : groups_eqns.
  Hint Immediate inv_r : groups_eqns.
  Hint Immediate id_r : groups_eqns.

  Hint Transparent f'.
  Hint Transparent e'.
  Hint Transparent i'.

  Hint Resolve assoc.
  Hint Resolve inv_r.
  Hint Resolve id_r.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 1} *)
  Lemma mult_both :
    forall a b c d1 d2,
      a <+> c = d1
      -> b <+> c = d2
      -> a = b
      -> d1 = d2.
  Proof.
    crush'.
    Restart.
    hammer'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Extern 100 (_ = _) =>
  match goal with
    | [ _ : True |- _ ] => fail 1
    | _ => assert True by constructor; eapply mult_both
  end.

  (*** MS LEMMA {"original": False, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma add_right :
    forall a b c,
      a <+> b = a <+> c ->
      a <+> b <+> i' b = a <+> c <+> i' c.
  Proof.
    crush'.
    Restart.
    hammer'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate add_right : groups_eqns.
  Hint Resolve add_right.

  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma unique_id :
    forall a,
      a <+> a = a ->
      a = e'.
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate unique_id : groups_eqns.
  Hint Resolve unique_id.

  (* [i a] is the left-inverse of [a]. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_l :
    forall a,
      i' a <+> a = e'.
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate inv_l : groups_eqns.
  Hint Resolve inv_l.

  (* [e] is the left-identity. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma id_l :
    forall a,
      e' <+> a = a.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate id_l : groups_eqns.
  Hint Resolve id_l.

  (*** MS LEMMA {"original": False , "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma cancel_inv_r :
    forall a b x,
      a <+> x <+> i' x = b <+> x <+> i' x
      -> a = b.
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    Set MirrorSolve Solver "z3".
    mirrorsolve.
  Qed.

  Hint Resolve cancel_inv_r.
  Hint Immediate cancel_inv_r : groups_eqns.

  (* [x] can be cancelled on the right. *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 0, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma cancel_r :
    forall a b x,
      a <+> x = b <+> x ->
      a = b.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate cancel_r : groups_eqns.
  Hint Resolve cancel_r.

  (*** MS LEMMA {"original": False , "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma cancel_inv_l :
    forall a b x,
      x <+> i' x <+> a = x <+> i' x <+> b ->
      a = b.
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Resolve cancel_inv_l.
  Hint Immediate cancel_inv_l : groups_eqns.

  (* [x] can be cancelled on the left. *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma cancel_l:
    forall a b x,
      x <+> a = x <+> b ->
      a = b.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate cancel_l : groups_eqns.
  Hint Resolve cancel_l : groups_eqns.

  (* The left identity is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma e_uniq_l :
    forall a p,
      p <+> a = a ->
      p = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate e_uniq_l : groups_eqns.
  Hint Resolve e_uniq_l.

  (* The left inverse is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_uniq_l :
    forall a b,
      a <+> b = e' ->
      a = i' b.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_uniq_l : groups_eqns.
  Hint Resolve inv_uniq_l.

  (* The right identity is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma e_uniq_r :
    forall a p,
      a <+> p = a ->
      p = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate e_uniq_r : groups_eqns.
  Hint Resolve e_uniq_r.

  (* The right inverse is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_uniq_r :
    forall a b,
      a <+> b = e' ->
      b = i' a.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_uniq_r : groups_eqns.
  Hint Resolve inv_uniq_r.

  (* The right inverse is unique. *)

  (* The inverse operator distributes over the group operator. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_distr :
    forall a b,
      i' (a <+> b) = i' b <+> i' a.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_distr : groups_eqns.
  Hint Resolve inv_distr.

  (* The inverse of an inverse produces the original element. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma double_inv :
    forall a,
      i' (i' a) = a.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate double_inv : groups_eqns.
  Hint Resolve inv_distr.

  (* The identity is its own inverse. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma id_inv :
    i' e' = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

End Groups.