Set Warnings "-notation-overridden, -parsing".
From LF Require Export Tactics.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof.
  unfold injective. intros x y H.
  injection H as H. apply H.
Qed.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof. split; reflexivity. Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof. intros A B HA HB; split; assumption. Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m H. apply and_intro.
  - induction n as [| n' IHn'].
    + reflexivity.
    + simpl in H. discriminate H.
  - destruct m as [| m'].
    + reflexivity.
    + rewrite plus_comm in H. simpl in H. discriminate H.
Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m [H1 H2]. rewrite H1, H2. reflexivity.
Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H.
  assert (H' : n = 0).
  { apply and_exercise in H. destruct H as [Hn Hm]. assumption. }
  rewrite H'. simpl. reflexivity.
Qed.

Lemma proj1 : forall P Q : Prop, P /\ Q -> P.
Proof. intros P Q [HP HQ]; assumption. Qed.

Lemma proj2 : forall P Q : Prop, P /\ Q -> Q.
Proof. intros P Q [HP HQ]; assumption. Qed.

Theorem and_commut : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof. intros P Q [HP HQ]; split; assumption. Qed.

Theorem and_assoc : forall P Q R : Prop,
    P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]]. split.
  - split; assumption.
  - assumption.
Qed.

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  - rewrite Hn. simpl. reflexivity.
  - rewrite Hm. rewrite mult_comm. simpl. reflexivity.
Qed.

Lemma or_intro_l : forall A B : Prop, A -> A \/ B.
Proof. intros A B HA; left; assumption. Qed.

Lemma or_intro_r : forall A B : Prop, B -> A \/ B.
Proof. intros A B HB; right; assumption. Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intro n. destruct n as [| n'] eqn:E.
  - left. reflexivity.
  - right. simpl. reflexivity.
Qed.

Module MyNot.
  Definition not (P : Prop) := P -> False.

  Notation "~ x" := (not x) : type_scope.
End MyNot.

Theorem ex_falso_quodlibet : forall P : Prop,
    False -> P.
Proof. intros P HF. destruct HF. Qed.

Fact not_implies_our_not : forall P : Prop,
    ~ P -> (forall Q : Prop, P -> Q).
Proof.
  unfold not. intros Pf H Q P.
  apply H in P. destruct P.
Qed.

Notation "x <> y" := (~(x = y)).

Theorem zero_not_one : 0 <> 1.
Proof. unfold not. intro H. discriminate H. Qed.

Theorem not_False : ~ False.
Proof. unfold not. intro H. assumption. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
    ( P /\ ~P) -> Q.
Proof.
  intros P Q [H1 H2].
  unfold not in H2.
  apply H2 in H1. destruct H1.
Qed.

Theorem double_neg : forall P : Prop, P -> ~ ~ P.
Proof.
  intros P HP.
  unfold not. intro HPF. apply HPF in HP. assumption.
Qed.

Theorem contrapositive : forall P Q : Prop,
    (P -> Q) -> (~ Q -> ~ P).
Proof.
  intros P Q H.
  unfold not. intros HQF HP.
  apply H in HP. apply HQF in HP. assumption.
Qed.

Theorem not_both_true_and_false : forall P : Prop,
    ~(P /\ ~P).
Proof.
  unfold not. intros P [H1 H2]. apply H2 in H1. assumption.
Qed.

Theorem not_true_is_false : forall b : bool,
    b <> true -> b = false.
Proof.
  intros [] H.
  - unfold not in H. exfalso.
    apply H. reflexivity.
  - reflexivity.
Qed.

Lemma True_is_true : True.
Proof. apply I. Qed.

Module MyIff.
  Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

  Notation "P <-> Q" := (iff P Q)
                          (at level 95, no associativity) : type_scope.

End MyIff.

Theorem iff_sym : forall P Q : Prop, (P <-> Q) -> (Q <-> P).
Proof. intros P Q [HAB HBA]. split; assumption. Qed.

Lemma not_true_iff_false : forall b,
    b <> true <-> b = false.
Proof.
  intros b. split.
  - apply not_true_is_false.
  - intro H. rewrite H. unfold not. intro H'. discriminate H'.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
    P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  - intros [HP | [HQ HR]].
    + split; left; apply HP.
    + split; right; assumption.
  - intros [[HP | HQ] [HP' | HR]].
    + left; assumption.
    + left; assumption.
    + left; assumption.
    + right; split; assumption.
Qed.

From Coq Require Import Setoids.Setoid.

Lemma mult_O : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  intros n m. split.
  - intro H. destruct n as [| n'].
    + left. reflexivity.
    + destruct m as [| m'].
      * right. reflexivity.
      * simpl in H. discriminate H.
  - intros [Hn | Hm].
    + rewrite Hn; simpl. reflexivity.
    + rewrite Hm; rewrite mult_comm; simpl. reflexivity.
Qed.

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [HP | [HQ | HR]].
    + left; left; assumption.
    + left; right; assumption.
    + right; assumption.
  - intros [[HP | HQ] | HR].
    + left; assumption.
    + right; left; assumption.
    + right; right; assumption.
Qed.

Lemma mult_O_3 :
  forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p. rewrite mult_O. rewrite mult_O. rewrite or_assoc.
  reflexivity.
Qed.

Lemma apply_iff_example :
  forall n m : nat, n * m = 0 -> n = 0 \/ m = 0.
Proof. intros n m H. apply mult_O. apply H. Qed.

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof. exists 2. reflexivity. Qed.

Theorem exists_example_2 : forall n,
    (exists m, n = 4 + m) -> (exists o, n = 2 + o).
Proof.
  intros n [m Hm]. exists (2 + m).
  simpl in *. apply Hm.
Qed.

Theorem dist_not_exists : forall (X : Type) (P : X -> Prop),
    (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros X P H. unfold not. intros [x H'].
  apply H'. apply H.
Qed.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x = x' \/ In x l'
  end.

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof. simpl. right; right; right; left; reflexivity. Qed.

Example In_example_2 :
  forall n, In n [2; 4] -> exists n', n = 2 * n'.
Proof.
  intros n H. simpl in H. destruct H.
  - rewrite H. exists 1. reflexivity.
  - destruct H.
    + rewrite H. exists 2. reflexivity.
    + destruct H.
Qed.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l -> In (f x) (map f l).
Proof.
  intros. induction l as [| h t IHt].
  - simpl in H. destruct H.
  - simpl in H. simpl. destruct H.
    + rewrite H. left. reflexivity.
    + apply IHt in H. right. assumption.
Qed.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) -> exists x, f x = y /\ In x l.
Proof.
  intros. induction l as [| h t IHt].
  - simpl in H. destruct H.
  - simpl in H. destruct H.
    + exists h. split.
      * symmetry. apply H.
      * simpl. left. reflexivity.
    + apply IHt in H. destruct H. exists x.
      destruct H. split.
      * apply H.
      * simpl; right; assumption.
Qed.

Lemma In_app_iff : forall A l l' (a : A),
    In a (l ++ l') <-> In a l \/ In a l'.
Proof.
  intros A l l' a.
  split.
  - intro H. induction l as [| h t IH].
    + simpl in H. right. apply H.
    + simpl in H. destruct H.
      * left. simpl. left. apply H.
      * apply IH in H. simpl. destruct H.
        left. right. apply H. right. apply H.
  - intros [Hl | Hr].
    + induction l as [| h t IH].
      * inversion Hl.
      * simpl in Hl. destruct Hl.
        { rewrite <- H. simpl. left. reflexivity. }
        { simpl. right. apply IH. apply H. }
    + induction l as [| h t IH].
      * simpl. apply Hr.
      * simpl. right. apply IH.
Qed.

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop :=
  match l with
  | [] => True
  | h :: t => P h /\ All P t
  end.

Lemma All_In : forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros. split.
  - intro H. induction l as [| h t IHt].
    + reflexivity.
    + simpl. split.
      * apply H. simpl. left. reflexivity.
      * apply IHt. intros x H'. apply H. simpl; right. assumption.
  - intros H x H'. induction l as [| h t IHt].
    + simpl in H'. destruct H'.
    + simpl in H. simpl in H'. destruct H. destruct H'.
      * rewrite H1. apply H.
      * apply IHt. apply H0. apply H1.
Qed.

Definition combine_odd_even (Podd Peven : nat -> Prop)
  : nat -> Prop :=
  fun n => if oddb n then Podd n else Peven n.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros Podd Peven n H1 H2.
  unfold combine_odd_even.
  destruct (oddb n) eqn:E.
  - apply H1. reflexivity.
  - apply H2. reflexivity.
Qed.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true -> Podd n.
Proof.
  intros. unfold combine_odd_even in H.
  rewrite H0 in H. apply H.
Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  intros. unfold combine_odd_even in H.
  rewrite H0 in H. assumption.
Qed.

Lemma plus_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

Lemma in_not_nil :
  forall A (x : A) (l : list A), In x l -> l <> [].
Proof.
  intros. unfold not. intro H'. destruct l.
  - simpl in H. assumption.
  - discriminate H'.
Qed.

Lemma in_not_nil_42 :
  forall l : list nat, In 42 l -> l <> [].
Proof.
  apply (in_not_nil nat 42).
Qed.

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) -> n = 0.
Proof.
  intros n ns H.
  induction ns.
  - simpl in H. destruct H.
  - simpl in H. destruct H.
    + rewrite mult_comm in H. simpl in H. apply H.
    + apply IHns. apply H.
Qed.

Example function_equality_ex1 :
  (fun x => 3 + x) = (fun x => (pred 4) + x).
Proof. simpl. reflexivity. Qed.

Axiom functional_extensionality :
  forall {X Y : Type} {f g : X -> Y},
    (forall (x : X), f x = g x) -> f = g.

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun y => plus 1 y).
Proof.
  apply functional_extensionality. intro x.
  apply plus_comm.
Qed.

Print Assumptions function_equality_ex2.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
  intro X. apply functional_extensionality.
  intro x. induction x as [| h t IHt].
  - reflexivity.
  - simpl. unfold tr_rev.
    simpl. unfold tr_rev in IHt. rewrite <- IHt.
    assert (H : forall (X : Type) (l1 l2 : list X),
               rev_append l1 l2 = rev_append l1 [] ++ l2).
    { intros X0 l1.  induction l1.
      - simpl. reflexivity.
      - simpl. intro l2. rewrite (IHl1 [x]).
        rewrite <- app_assoc. simpl. apply IHl1.
    }
    rewrite <- H. reflexivity.
Qed.

Example even_42_bool : evenb 42 = true.
Proof. reflexivity. Qed.

Example even_42_prop : exists k, 42 = double k.
Proof. exists 21. reflexivity. Qed.

Theorem evenb_double : forall k, evenb (double k) = true.
Proof.
  intro k. induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

Theorem evenb_double_conv : forall n,
    exists k, n = if evenb n then double k else S (double k).
Proof.
  intro n. induction n as [| n' IHn'].
  - exists 0. reflexivity.
  - destruct IHn'. destruct (evenb n') eqn:E.
    + exists x. rewrite evenb_S. rewrite E.
      simpl. rewrite H. reflexivity.
    + exists (S x). rewrite evenb_S. rewrite E.
      simpl. rewrite H. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
    evenb n = true <-> exists k, n = double k.
Proof.
  intro n. split.
  - intro H. assert (H' : exists k, n = if evenb n then double k
                                        else S (double k)).
    { apply evenb_double_conv. }
    rewrite H in H'. assumption.
  - intro H. destruct H. rewrite H. apply evenb_double.
Qed.

Theorem eqb_eq : forall n1 n2 : nat,
    n1 =? n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply eqb_true.
  - intro H. rewrite H. apply eqb_refl.
Qed.

Example even_1000 : exists k, 1000 = double k.
Proof. apply even_bool_prop. reflexivity. Qed.

Lemma plus_eqb_example : forall n m p : nat,
    n =? m = true -> n + p =? m + p = true.
Proof.
  intros. rewrite eqb_eq in H. rewrite H.
  apply eqb_refl.
Qed.

Lemma andb_true_iff : forall b1 b2 : bool,
    b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2. split.
  - intro H. split.
    + apply (andb_true_elim2 b2).
      rewrite andb_commutative. assumption.
    + apply (andb_true_elim2 b1). assumption.
  - intros [H1 H2]. rewrite H1, H2. reflexivity.
Qed.

Lemma orb_true_iff : forall b1 b2,
    b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros b1 b2. split.
  - intro H. destruct b1 eqn:Eb1.
    + left. reflexivity.
    + simpl in H. right. apply H.
  - intros [H1 | H2].
    + rewrite H1. simpl. reflexivity.
    + rewrite H2. destruct b1; reflexivity.
Qed.

Theorem eqb_neq : forall x y : nat,
    x =? y = false <-> x <> y.
Proof.
  intros x y. split.
  - intro H. unfold not. rewrite <- eqb_eq.
    intro H'. rewrite H in H'. discriminate H'.
  - intro H. destruct (x =? y) eqn:E.
    + rewrite eqb_eq in E. rewrite E in H. unfold not in H.
      exfalso. apply H. reflexivity.
    + reflexivity.
Qed.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool) (l1 l2 : list A)
  : bool :=
  match l1, l2 with
  | [], [] => true
  | [], _ => false
  | _ , [] => false
  | h1 :: t1, h2 :: t2 => if eqb h1 h2 then eqb_list eqb t1 t2 else false
  end.

Lemma eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  intros A eqb H l1. induction l1 as [| h1 t1 IHt1].
  - intro l2. split.
    + intro H'. destruct l2 eqn:E.
      * reflexivity.
      * simpl in H'. discriminate H'.
    + intro H'. rewrite <- H'. reflexivity.
  - intro l2. split.
    + intro H'. destruct l2 as [| h2 t2] eqn:E.
      * simpl in H'. discriminate H'.
      * simpl in H'. destruct (eqb h1 h2) eqn:E'.
        rewrite H in E'. rewrite IHt1 in H'.
        rewrite E'. rewrite H'. reflexivity.
        discriminate H'.
    + intro H'. destruct l2 as [| h2 t2] eqn:E.
      * discriminate H'.
      * simpl. injection H'. intros. rewrite <- H in H1.
        rewrite H1. apply IHt1. apply H0.
Qed.

Check @forallb.

Theorem forallb_true_iff : forall X test (l : list X),
    forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  intros. induction l as [| h t IHt].
  - split.
    + intro H. reflexivity.
    + intro H. reflexivity.
  - split.
    + intro H. simpl in H. destruct (test h) eqn:E.
      * simpl. split. apply E. apply IHt. apply H.
      * discriminate H.
    + intro H. simpl in H. destruct H. simpl.
      rewrite H. apply IHt. apply H0.
Qed.

(** Classical vs. Constructive Logic *)

Definition excluded_middle := forall P : Prop, P \/ ~ P.

Theorem restricted_excluded_middle : forall P b,
    (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. intros constra. discriminate constra.
Qed.

Theorem restricted_excluded_middle_eq : forall n m : nat,
    n = m \/ n <> m.
Proof.
  intros n m.
  apply (restricted_excluded_middle (n = m) (n =? m)).
  rewrite eqb_eq. reflexivity.
Qed.

Theorem excluded_middle_irrefutable : forall P : Prop,
    ~~(P \/ ~P).
Proof.
  intro P. unfold not. intro H. apply H. right.
  intro H'. apply H. left. apply H'.
Qed.

Theorem not_exists_dist :
  excluded_middle ->
  forall (X : Type) (P : X -> Prop),
    ~(exists x, ~ P x) -> (forall x, P x).
Proof.
  intros. unfold excluded_middle in H.
  unfold not in H0. destruct H with (P x).
  - apply H1.
  - unfold not in H1. exfalso. apply H0. exists x. apply H1.
Qed.

Definition peirce := forall P Q : Prop, ((P -> Q) -> P) -> P.

Definition double_negation_elimination := forall P : Prop, ~~ P -> P.

Definition de_morgan_not_and_not := forall P Q : Prop,
    ~(~P /\ ~Q) -> P \/ Q.

Definition implies_to_or := forall P Q : Prop,
    (P -> Q) -> (~P \/ Q).

Theorem excluded_middle_iff_peirce : excluded_middle <-> peirce.
Proof.
  unfold excluded_middle. unfold peirce. split.
  - intros H P Q. intro H1. destruct H with P.
    + assumption.
    + apply H1. destruct H with Q.
      * intro H3. assumption.
      * intro H3. apply H0 in H3. destruct H3.
  - intros H P. apply (H (P \/ ~P) False).
    intro H1. apply excluded_middle_irrefutable in H1.
    destruct H1.
Qed.

Theorem double_negation_elimination_valid :
  excluded_middle <-> double_negation_elimination.
Proof.
  split.
  - (* -> *) intros E P.
    destruct (E P) as [H' | H'].
    + intro HP. apply H'.
    + intro HNP.
      unfold not in H'.
      unfold not in HNP.
      apply HNP in H'.
      inversion H'.
  - (* <- *) intros DNE EXM.
    apply DNE. apply excluded_middle_irrefutable.
Qed.

Theorem de_morgan_not_and_not_valid :
  excluded_middle <-> de_morgan_not_and_not.
Proof.
  split.
  - (* -> *) intros E P Q.
    destruct (E P) as [HP | HP].
    + intro H. left. apply HP.
    + destruct (E Q) as [HQ | HQ].
      * intro H. right. apply HQ.
      * intro H. exfalso. apply H. split.
        { apply HP. }
        { apply HQ. }
  - (* <- *) intros D E.
    apply D.
    unfold not.
    intros [H1 H2].
    apply H2. apply H1.
Qed.

Theorem implies_to_or_valid :
  excluded_middle <-> implies_to_or.
Proof.
  split.
  - (* -> *) intros E P Q.
    destruct (E P) as [HP | HP].
    + intro H. right. apply H. apply HP.
    + intro H. left. apply HP.
  - (* <- *) intros IO E.
    rewrite -> or_comm. apply IO. intro HE. apply HE.
Qed.


(*
 * Abstract Algebra
 *
 * (c) 2018, Marvin H. Sielenkemper
 *)

Require Import ProofIrrelevance.
Require Import EqdepFacts.
Require Import PeanoNat.
Require Import RelationClasses.
Require Import Morphisms.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require List.

Delimit Scope group_scope with group.
Local Open Scope group_scope.

Record SemiGroupSig := makeSemiGroupSig {
  carrier:> Set;
  op: carrier -> carrier -> carrier
}.

Arguments makeSemiGroupSig {carrier}.
Arguments op {s}.

Notation "x * y" := (op x y) : group_scope.

Record SemiGroupAx(sig: SemiGroupSig) := {
  associative: forall x y z: sig, (x * y) * z = x * (y * z);
}.

Arguments associative {sig}.

Record SemiGroup := {
  semiGroupSig:> SemiGroupSig;
  semiGroupAx :> SemiGroupAx semiGroupSig
}.

Record SemiGroupHom(h1 h2: SemiGroupSig) := makeSemiGroupHom {
  semiGroupHomFun:> h1 -> h2;
  isSemiGroupHom: forall x1 x2, semiGroupHomFun (x1 * x2) = semiGroupHomFun x1 * semiGroupHomFun x2
}.

Arguments isSemiGroupHom {h1 h2}.

Definition abelian(h: SemiGroupSig) := forall a b: h, a * b = b * a.

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

Record MonoidSig := {
  monoidSigIsSemiGroup:> SemiGroupSig;
  unit: monoidSigIsSemiGroup;
}.

Arguments unit {m}.

Definition makeMonoidSig{X: Set}(op: X -> X -> X)(unit: X): MonoidSig :=
  Build_MonoidSig (makeSemiGroupSig op) unit.

Record MonoidAx(sig: MonoidSig) := {
  monoidIsSemiGroupAx:> SemiGroupAx sig;
  leftUnit:  forall x: sig, unit * x = x;
  rightUnit: forall x: sig, x * unit = x
}.

Arguments leftUnit {sig}.
Arguments rightUnit {sig}.

Record Monoid := {
  monoidSig:> MonoidSig;
  monoidAx :> MonoidAx monoidSig
}.

Record MonoidHom(m1 m2: MonoidSig) := {
  monoidHomIsSemiGroupHom:> SemiGroupHom m1 m2;
  isMonoidHom: monoidHomIsSemiGroupHom unit = unit
}.

Arguments isMonoidHom {m1 m2}.

Definition makeMonoidHom{m1 m2: MonoidSig}(f: m1 -> m2):
    (forall x1 x2, f (x1 * x2) = f x1 * f x2) ->
    f unit = unit ->
    MonoidHom m1 m2 :=
  fun H1 => Build_MonoidHom m1 m2 (makeSemiGroupHom m1 m2 f H1).

Lemma unitUnique(m: Monoid): forall e: m, (forall x, x * e = x) -> e = unit.
Proof.
  intros e H.
  rewrite <- (leftUnit m e).
  apply H.
Qed.

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

Record GroupSig := {
  groupSigIsMonoidSig:> MonoidSig;
  invert: groupSigIsMonoidSig -> groupSigIsMonoidSig
}.

Arguments invert {g}.

Definition makeGroupSig{X: Set}(op: X -> X -> X)(unit: X)(invert: X -> X): GroupSig :=
  Build_GroupSig (makeMonoidSig op unit) invert.

Record GroupAx(sig: GroupSig) := {
  groupIsMonoidAx:> MonoidAx sig;
  leftInverse:  forall x: sig, invert x * x = unit;
  rightInverse: forall x: sig, x * invert x = unit
}.

Arguments leftInverse {sig}.
Arguments rightInverse {sig}.

Record Group := {
  groupSig:> GroupSig;
  groupAx :> GroupAx groupSig
}.

Record GroupHom(g1 g2: GroupSig) := {
  groupHomIsMonoidHom:> MonoidHom g1 g2;
  isGroupHom: forall x, invert (groupHomIsMonoidHom x) = groupHomIsMonoidHom (invert x)
}.

Arguments isGroupHom {g1 g2}.

Definition makeGroupHom{g1 g2: GroupSig}(f: g1 -> g2):
    (forall x1 x2, f (x1 * x2) = f x1 * f x2) ->
    f unit = unit ->
    (forall x, invert (f x) = f (invert x)) ->
    GroupHom g1 g2 :=
  fun H1 H2 => Build_GroupHom g1 g2 (makeMonoidHom f H1 H2).

Lemma makeGroupAx(sig: GroupSig):
  (forall x y z: sig, (x * y) * z = x * (y * z)) ->
  (forall x: sig, unit * x = x) ->
  (forall x: sig, invert x * x = unit) ->
  GroupAx sig.
Proof.
  intros assoc leftUnit leftInverse.
  assert (rightInverse: forall x : sig, x * invert x = unit).
  intros x.
  rewrite <- (leftUnit (x * invert x)).
  transitivity ((invert (invert x) * invert x) * (x * invert x)).
  f_equal. symmetry. apply leftInverse.
  transitivity (invert (invert x) * ((invert x * x) * invert x)).
  rewrite assoc. f_equal. symmetry. apply assoc.
  rewrite leftInverse.
  rewrite leftUnit.
  apply leftInverse.
  repeat (split; try assumption).
  intros x.
  rewrite <- (leftInverse x).
  rewrite <- assoc.
  rewrite rightInverse.
  apply leftUnit.
Qed.

Lemma inverseUnique(g: Group): forall x y: g, x * y = unit -> y = invert x.
Proof.
  intros x y H.
  rewrite <- (rightUnit g (invert x)).
  rewrite <- H.
  rewrite <- (associative g).
  rewrite (leftInverse g).
  symmetry. apply (leftUnit g).
Qed.

Lemma inverseId(g: Group): forall x: g, invert (invert x) = x.
Proof.
  intros x.
  symmetry.
  apply (inverseUnique g).
  apply (leftInverse g).
Qed.

Lemma inverseUnit(g: Group): @invert g unit = unit.
Proof.
  symmetry.
  apply (inverseUnique g).
  apply (leftUnit g).
Qed.

Lemma inverseOp(g: Group): forall a b: g, invert (a * b) = invert b * invert a.
Proof.
  intros a b.
  symmetry.
  apply (inverseUnique g).
  rewrite (associative g).
  rewrite <- (associative g b (invert b)).
  rewrite (rightInverse g).
  rewrite (leftUnit g).
  apply (rightInverse g).
Qed.

Lemma leftInjection(g: Group): forall a x y: g, a * x = a * y-> x = y.
Proof.
  intros a x y H.
  rewrite <- (leftUnit g x).
  rewrite <- (leftInverse g a).
  rewrite (associative g).
  rewrite H.
  rewrite <- (associative g).
  rewrite (leftInverse g a).
  apply (leftUnit g y).
Qed.

Lemma rightInjection(g: Group): forall a x y: g, x * a = y * a -> x = y.
Proof.
  intros a x y H.
  rewrite <- (rightUnit g x).
  rewrite <- (rightInverse g a).
  rewrite <- (associative g).
  rewrite H.
  rewrite (associative g).
  rewrite (rightInverse g a).
  apply (rightUnit g y).
Qed.

Lemma unitUnique2(g: Group): forall x y: g, x * y = x -> y = unit.
Proof.
  intros x y H.
  apply (leftInjection g x).
  rewrite (rightUnit g).
  assumption.
Qed.

Definition groupFromSemigroup(h: SemiGroup):
  h ->
  (forall a y: h, { x | a * x = y }) ->
  (forall a y: h, { x | x * a = y }) ->
  Group.

  intros b H1 H2.
  destruct (H2 b b) as [e He].
  set (inv y := proj1_sig (H2 y e)).
  exists (makeGroupSig op e inv).
  apply makeGroupAx; simpl.
  apply (associative h).
  intro a.
  destruct (H1 b a) as [a' Ha'].
  transitivity (e * (b * a')).
  f_equal. auto.
  rewrite <- (associative h).
  rewrite He. assumption.
  intro a.
  unfold inv.
  destruct (H2 a e) as [a' Ha'].
  simpl. assumption.
Defined.

Definition makeGroupHom2(g1 g2: Group)(f: g1 -> g2): (forall x1 x2, f (x1 * x2) = f x1 * f x2) -> GroupHom g1 g2.
  intro H1.
  assert (H2: f unit = unit).
  apply (unitUnique2 _ (f unit)).
  rewrite <- H1. f_equal. apply (rightUnit g1).
  refine (makeGroupHom f H1 H2 _).
  intro x.
  symmetry. apply inverseUnique.
  rewrite <- H1.
  rewrite (rightInverse g1).
  assumption.
Defined.

Definition groupHomId{g: Group}: GroupHom g g := makeGroupHom2 g g (fun a => a) (fun x y => eq_refl).

Definition groupHomComp{g1 g2 g3: Group}: GroupHom g2 g3 -> GroupHom g1 g2 -> GroupHom g1 g3.
  intros g f.
  apply (makeGroupHom2 _ _ (fun a => g (f a))).
  intros x y.
  rewrite (isSemiGroupHom f).
  rewrite (isSemiGroupHom g).
  reflexivity.
Defined.

Lemma groupAxFromHom{g1: GroupSig}{g2: Group}(f: GroupHom g1 g2): (forall x y, f x = f y -> x = y) -> GroupAx g1.
Proof.
  intro H1.
  set (H2 := isMonoidHom f).
  apply makeGroupAx; intros; apply H1; repeat rewrite (isSemiGroupHom f); try rewrite H2.
  apply (associative g2).
  apply (leftUnit g2).
  rewrite <- (isGroupHom f). apply (leftInverse g2).
Qed.

Inductive SubGroup(g: Group) :=
  makeSubGroup(P: g -> Prop): (exists a, P a) -> (forall a b, P a -> P b -> P (a * invert b)) -> SubGroup g.

Definition isIn{g: Group}(h: SubGroup g): g -> Prop := let (P, _, _) := h in P.

Lemma unitIsIn{g: Group}(h: SubGroup g): isIn h unit.
Proof.
  destruct h as [P H1 H2]. simpl.
  destruct H1 as [a Ha].
  rewrite <- (rightInverse g a).
  apply H2; assumption.
Qed.

Lemma invertIsIn{g: Group}(h: SubGroup g)(a: g): isIn h a -> isIn h (invert a).
Proof.
  set (H1 := unitIsIn h).
  destruct h as [P H2 H3]. simpl in H1 |- *.
  intro Ha.
  rewrite <- (leftUnit g (invert a)).
  apply H3; try assumption.
Qed.

Lemma opIsIn{g: Group}(h: SubGroup g)(a b: g): isIn h a -> isIn h b -> isIn h (a * b).
Proof.
  set (H1 := invertIsIn h).
  destruct h as [P H2 H3]. simpl in H1 |- *.
  intros Ha Hb.
  rewrite <- (inverseId g b).
  apply H3; try assumption.
  apply H1; try assumption.
Qed.

Definition subGroupSig{g: Group}(h: SubGroup g): GroupSig :=
    makeGroupSig (X := sig (isIn h))
      (fun x y =>
        let (x', Hx) := x in
        let (y', Hy) := y in
          exist _ (x' * y') (opIsIn h x' y' Hx Hy))
      (exist _ unit (unitIsIn h))
      (fun x =>
        let (x', Hx) := x in
          exist _ (invert x') (invertIsIn h x' Hx)).

Definition subGroupInsert{g: Group}(h: SubGroup g): forall x, isIn h x -> subGroupSig h :=
  match h as h' return (forall x, isIn h' x -> subGroupSig h') with
  | makeSubGroup _ P _ _ => exist P
  end.

Definition subGroupExtract{g: Group}(h: SubGroup g): GroupHom (subGroupSig h) g.
  set (k := subGroupSig h).
  apply (makeGroupHom (g1:=k) (g2:=g) (@proj1_sig _ _)); simpl.
  intros [x Hx] [y Hy]; simpl.
  reflexivity.
  reflexivity.
  intros [x Hx]; simpl.
  reflexivity.
Defined.

Lemma subGroupInsertUnit{g: Group}(h: SubGroup g) H: subGroupInsert h unit H = unit.
Proof.
  destruct h as [P H1 H2].
  simpl.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma subGroupInsertInvert{g: Group}(h: SubGroup g) x H1 H2: subGroupInsert h (invert x) H1 = invert (subGroupInsert h x H2).
Proof.
  destruct h as [P H3 H4].
  simpl.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma subGroupInsertOp{g: Group}(h: SubGroup g) x y H1 H2 H3:
  subGroupInsert h (op x y) H1 = op (subGroupInsert h x H2) (subGroupInsert h y H3).
Proof.
  destruct h as [P H4 H5].
  simpl.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma subGroupEmbedding{g: Group}(h: SubGroup g): forall x y, subGroupExtract h x = subGroupExtract h y -> x = y.
Proof.
  destruct h as [P H1 H2].
  intros [x Hx] [y Hy]. simpl.
  apply subset_eq_compat.
Qed.

Lemma subGroupInOut{g: Group}(h: SubGroup g) x H: subGroupExtract h (subGroupInsert h x H) = x.
Proof.
  destruct h as [P H1 H2].
  reflexivity.
Qed.

Lemma subGroupAx{g: Group}(h: SubGroup g): GroupAx (subGroupSig h).
Proof.
  apply (groupAxFromHom _ (subGroupEmbedding _)).
Qed.

Definition subGroup{g: Group}(h: SubGroup g): Group := Build_Group _ (subGroupAx h).
Coercion   subGroup: SubGroup >-> Group.

Definition subSubGroup_1{g: Group}(h: SubGroup g)(k: SubGroup h): SubGroup g.
  refine (makeSubGroup g (fun x => ex (fun H => isIn k (subGroupInsert h x H))) _ _).
  exists unit.
  exists (unitIsIn h).
  rewrite subGroupInsertUnit.
  apply (unitIsIn k).
  intros a b [Ha1 Ha2] [Hb1 Hb2].
  exists (opIsIn _ _ _ Ha1 (invertIsIn _ _ Hb1)).
  rewrite (subGroupInsertOp _ _ _ _ Ha1 (invertIsIn _ _ Hb1)).
  rewrite (subGroupInsertInvert _ _ (invertIsIn _ _ Hb1) Hb1).
  apply (opIsIn k); try assumption.
  apply (invertIsIn k); assumption.
Defined.

Definition subSubGroup_2{g: Group}(h k: SubGroup g): (forall a, isIn h a -> isIn k a) -> SubGroup k.
  destruct h as [P H1 H2]. simpl.
  intro H3.
  refine (makeSubGroup k (fun x => P (subGroupExtract k x)) _ _).
  destruct H1 as [a Pa]. exists (subGroupInsert k _ (H3 _ Pa)).
  rewrite subGroupInOut. assumption.
  intros [a Pa] [b Pb]. apply H2.
Defined.

Definition subGroupCut{g: Group}(I: Type)(hi: I -> SubGroup g): SubGroup g.
  refine (makeSubGroup g (fun x => forall i, isIn (hi i) x) _ _).
  exists unit.
  intro i; apply (unitIsIn _).
  intros a b Ha Hb i.
  apply opIsIn; try apply Ha; apply invertIsIn; apply Hb.
Defined.

Definition minimalSubGroup(g: Group): SubGroup g.
  refine (makeSubGroup g (eq unit) (ex_intro _ _ eq_refl) (fun a b => _)).
  intros [] [].
  rewrite inverseUnit.
  rewrite (rightUnit g).
  reflexivity.
Defined.

Definition maximalSubGroup(g: Group): SubGroup g :=
  makeSubGroup g (fun x => True) (ex_intro _ unit I) (fun _ _ _ _ => I).

Definition kern{g1 g2: Group}(f: GroupHom g1 g2): SubGroup g1.
  set (H1 := isSemiGroupHom f).
  set (H2 := isMonoidHom f).
  set (H3 := isGroupHom f).
  refine (makeSubGroup g1 (fun x => f x = unit) (ex_intro _ unit H2) (fun a b H4 H5 => _)).
  simpl in H4, H5.
  rewrite H1, H4.
  rewrite <- H3.
  rewrite H5.
  rewrite inverseUnit.
  apply (rightUnit g2).
Defined.

Definition image{g1 g2: Group}(f: GroupHom g1 g2): SubGroup g2.
  refine (makeSubGroup g2 (fun x => ex (fun y => f y = x)) (ex_intro _ _ (ex_intro _ _ (isMonoidHom f))) (fun a b => _)).
  intros [a' Ha] [b' Hb].
  exists (a' * invert b').
  rewrite (isSemiGroupHom f). rewrite <- (isGroupHom f), Ha, Hb.
  reflexivity.
Defined.

Definition konjugate{g: Group}(a x: g): g := a * x * invert a.

Lemma konjugate_1{g: Group}(a x: g): konjugate a x = x <-> a * x = x * a.
Proof.
  unfold konjugate.
  split; intro H; [
    apply (rightInjection g (invert a)); rewrite H |
    apply (rightInjection g a); rewrite H; f_equal
  ];
  rewrite (associative g); rewrite (rightInverse g); rewrite (rightUnit g); reflexivity.
Qed.

Lemma konjugateUnit1{g: Group}(a: g): konjugate unit a = a.
Proof.
  unfold konjugate.
  rewrite (inverseUnit g).
  rewrite (rightUnit g).
  apply (leftUnit g).
Qed.

Lemma konjugateUnit2{g: Group}(a: g): konjugate a unit = unit.
Proof.
  unfold konjugate.
  rewrite (rightUnit g).
  rewrite (rightInverse g).
  reflexivity.
Qed.

Lemma konjugateOp1{g: Group}(a b x: g): konjugate a (konjugate b x) = konjugate (a * b) x.
Proof.
  unfold konjugate.
  rewrite (inverseOp g).
  repeat rewrite <- (associative g).
  reflexivity.
Qed.

Lemma konjugateOp2{g: Group}(a x y: g): konjugate a x * konjugate a y = konjugate a (x * y).
Proof.
  unfold konjugate.
  transitivity (a * x * (invert a * a) * y * invert a).
  repeat rewrite <- (associative g).
  reflexivity.
  rewrite (leftInverse g).
  rewrite (rightUnit g).
  repeat rewrite <- (associative g).
  reflexivity.
Qed.

Lemma konjugateInvert{g: Group}(a x: g): konjugate a (invert x) = invert (konjugate a x).
Proof.
  unfold konjugate.
  repeat rewrite (inverseOp g).
  rewrite (inverseId g).
  apply (associative g).
Qed.

Lemma konjugateInjective{g: Group}(a x y: g): konjugate a x = konjugate a y -> x = y.
Proof.
  unfold konjugate.
  intro H.
  apply (leftInjection g a).
  apply (rightInjection g (invert a)).
  apply H.
Qed.

Definition centralizer(g: Group)(P: g -> Prop): SubGroup g.
  refine (makeSubGroup g (fun a => forall x, P x -> konjugate a x = x) (ex_intro _ unit _) (fun a b => _)).
  intros x H.
  apply konjugateUnit1.
  intros H1 H2 x Hx.
  rewrite <- konjugateOp1.
  rewrite <- H1; try assumption.
  f_equal. clear H1 a.
  rewrite <- (H2 x Hx) at 1.
  rewrite konjugateOp1.
  rewrite (leftInverse g).
  apply konjugateUnit1.
Defined.

Lemma centralizer_1{g: Group}(P: g -> Prop):
  forall(a: centralizer g P) x, P x -> konjugate (subGroupExtract _ a) x = x.
Proof.
  intros [a Pa]. apply Pa.
Qed.

Definition center(g: Group) := centralizer g (fun _ => True).

Lemma centerInCentralizer(g: Group)(P: g -> Prop): forall a, isIn (center g) a -> isIn (centralizer g P) a.
Proof.
  intros a Ha.
  simpl in Ha.
  intros b Hb.
  apply Ha.
  auto.
Qed.

Lemma centerAbelian(g: Group): abelian (center g).
Proof.
  intros [a Ha] [b Hb].
  apply subGroupEmbedding; simpl.
  rewrite <- konjugate_1.
  rewrite Ha; auto.
Qed.

Definition normalizer{g: Group}(h: SubGroup g): SubGroup g.
  refine (makeSubGroup g (fun a => forall x, isIn h x <-> isIn h (konjugate a x)) (ex_intro _ unit _) (fun a b => _)).
  intro x.
  rewrite konjugateUnit1.
  reflexivity.
  intros H1 H2 x.
  rewrite <- konjugateOp1.
  rewrite <- H1.
  clear H1 a.
  rewrite (H2 (konjugate (invert b) x)).
  rewrite konjugateOp1.
  rewrite (rightInverse g).
  rewrite konjugateUnit1.
  reflexivity.
Defined.

Lemma normalizer_1{g: Group}(h: SubGroup g): forall a x, isIn (normalizer h) a -> isIn h x <-> isIn h (konjugate a x).
Proof.
  simpl.
  intros a x H. apply H.
Qed.

Lemma normalizer_2{g: Group}(h: SubGroup g): forall a, isIn h a -> isIn (normalizer h) a.
Proof.
  simpl.
  intros a Ha x.
  split; intro Hx.
  repeat apply (opIsIn h); try apply (invertIsIn h); assumption.
  rewrite <- konjugateUnit1.
  rewrite <- (rightInverse g (invert a)).
  rewrite inverseId.
  rewrite <- konjugateOp1.
  apply opIsIn.
  apply opIsIn; try assumption.
  apply invertIsIn; assumption.
  repeat apply invertIsIn; assumption.
Qed.

Definition generatedSubGroup{g: Group}(P: g -> Prop): SubGroup g.
  refine (subGroupCut { h: SubGroup g | forall a: g, P a -> isIn h a } (@proj1_sig _ _)).
Defined.

Definition generatedSubGroup_2{g: Group}(P: g -> Prop): SubGroup g.
  set (reduce_1 (tx: bool * sig P) := match tx with (t, (exist _ x _)) => if t then invert x else x end).
  set (reduce_2 := List.fold_right (fun tx y => reduce_1 tx * y) unit).

  assert (H1: forall xs ys, reduce_2 (app xs ys) = reduce_2 xs * reduce_2 ys).
  intro xs.
  induction xs as [ | [t [x Hx]]]; intro ys.
  rewrite (leftUnit g). reflexivity.
  simpl. rewrite IHxs.
  symmetry; apply (associative g).

  set (invert_1 (tx: bool * sig P) := let (t, x) := tx in (negb t, x)).
  set (invert_2 txs := List.rev (List.map invert_1 txs)).

  assert (H2: forall xs, reduce_2 (invert_2 xs) = invert (reduce_2 xs)).
  intro xs.
  unfold reduce_2 at 1, invert_2.
  rewrite List.fold_left_rev_right.
  induction xs as [ | [t [x Hx]]].
  symmetry. apply (inverseUnit g).
  simpl. rewrite (inverseOp g).
  set (x' := invert (if t then invert x else x)).
  assert (x' = if negb t then invert x else x).
  destruct t; auto; apply inverseId. destruct H.
  generalize dependent x'. clear Hx x t. intro y.
  rewrite <- IHxs. clear IHxs.
  rewrite (rightUnit g).
  generalize (List.map invert_1 xs). clear xs.
  intros [ | x xs]; simpl.
  symmetry; apply (leftUnit g).
  rewrite (rightUnit g).
  generalize (reduce_1 x) as x'. clear x. intro x.
  generalize dependent y.
  generalize dependent x.
  induction xs as [ | x' xs]; auto.
  simpl. generalize (reduce_1 x') as w. clear x'.
  intros x y z.
  rewrite <- IHxs.
  rewrite <- (associative g).
  reflexivity.

  set (P' a := exists xs, reduce_2 xs = a).

  apply (makeSubGroup g P').

  exists unit.
  exists nil.
  reflexivity.

  intros a b [xas Hxa] [xbs Hxb].
  exists (xas ++ (invert_2 xbs))%list.
  rewrite H1, H2, Hxa, Hxb.
  reflexivity.
Defined.

Lemma generatedSubGroupEquiv{g: Group}(P: g -> Prop): forall a: g, isIn (generatedSubGroup P) a <-> isIn (generatedSubGroup_2 P) a.
Proof.
  intro a.
  split.

  intro H.
  simpl in H.
  refine (H (exist _ (generatedSubGroup_2 P) _)).
  intros x Hx.
  exists (cons (false, exist _ x Hx) nil).
  apply (rightUnit g).

  intros [txs H] [h Hh].
  simpl. destruct H.
  induction txs as [ | tx].
  apply (unitIsIn h).
  simpl.
  apply (opIsIn h); try assumption.
  destruct tx as [[ | ] [x Hx]]; try apply (invertIsIn h); auto.
Qed.

Definition konjugated{g: Group}(x y: g): Prop :=
  ex (fun a => x = konjugate a y).

Lemma konjugatedReflexive{g: Group}: Reflexive (konjugated (g:=g)).
Proof.
  exists unit.
  rewrite konjugateUnit1.
  reflexivity.
Qed.

Lemma konjugatedSymmetric{g: Group}: Symmetric (konjugated (g:=g)).
Proof.
  intros x y [a H].
  exists (invert a).
  rewrite H.
  rewrite konjugateOp1.
  rewrite (leftInverse g).
  rewrite konjugateUnit1.
  reflexivity.
Qed.

Lemma konjugatedTransitive{g: Group}: Transitive (konjugated (g:=g)).
Proof.
  intros x y z [a Ha] [b Hb].
  exists (a * b).
  rewrite Ha, Hb.
  apply konjugateOp1.
Qed.

Instance konjugatedEquiv{g: Group}: Equivalence (konjugated (g:=g)).
Proof.
  split; [apply konjugatedReflexive | apply konjugatedSymmetric | apply konjugatedTransitive].
Qed.

Definition innerAutomorphism{g: Group}(a: g): GroupHom g g.
  apply (makeGroupHom2 _ _ (konjugate a)).
  intros x y.
  rewrite konjugateOp2.
  reflexivity.
Defined.

Definition isNormal{g: Group}(h: SubGroup g): Prop :=
  let (P, _, _) := h in forall x a, P (konjugate a x) -> P x.

Lemma normal_1{g: Group}(h: SubGroup g): isNormal h -> forall x a, isIn h (konjugate a x) <-> isIn h x.
Proof.
  intro H1.
  assert (H2: forall x a, isIn h (konjugate a x) -> isIn h x).
  destruct h as [P H3 H4].
  apply H1.
  split; try apply H2.
  intro H3.
  apply (H2 _ (invert a)).
  rewrite konjugateOp1.
  rewrite (leftInverse g).
  rewrite konjugateUnit1.
  assumption.
Qed.

Lemma minimalIsNormal(g: Group): isNormal (minimalSubGroup g).
Proof.
  intros x a H.
  rewrite <- (konjugateUnit2 a) in H.
  apply (konjugateInjective _ _ _ H).
Qed.

Lemma maximalIsNormal(g: Group): isNormal (maximalSubGroup g).
Proof.
  intros x a H.
  auto.
Qed.

Lemma kernIsNormal{g1 g2: Group}(f: GroupHom g1 g2): isNormal (kern f).
Proof.
  set (H1 := isSemiGroupHom f).
  set (H3 := isGroupHom f).
  intros x a H4.
  unfold konjugate in H4.
  repeat rewrite H1 in H4.
  apply (leftInjection g2 (f a)).
  apply (rightInjection g2 (f (invert a))).
  rewrite H4.
  rewrite (rightUnit g2).
  rewrite <- H3.
  rewrite (rightInverse g2).
  reflexivity.
Qed.

Lemma centerIsNormal(g: Group): isNormal (center g).
Proof.
  intros x a Hx y _.
  set (H := Hx (konjugate a y) I).
  unfold konjugate in H.
  repeat rewrite (associative g) in H.  clear Hx.
  apply (leftInjection g) in H.
  repeat rewrite inverseOp in H.
  repeat rewrite <- (associative g) in H.
  apply (rightInjection g) in H.
  rewrite <- H at 2. clear H.
  unfold konjugate.
  f_equal.
  repeat rewrite (associative g).
  f_equal.
  rewrite (rightInverse g).
  rewrite (rightUnit g).
  rewrite <- (associative g).
  rewrite (leftInverse g).
  rewrite (leftUnit g).
  reflexivity.
Qed.

Lemma isNormalInNormalizer(g: Group)(h: SubGroup g): isNormal (subSubGroup_2 h (normalizer h) (normalizer_2 h)).
Proof.
  destruct h as [P H1 H2]. simpl.
  intros [x Hx] [a Ha]. simpl.
  apply Ha.
Qed.

Definition injective {A B}(f: A -> B) := forall a1 a2, f a1 = f a2 -> a1 = a2.
Definition surjective{A B}(f: A -> B) := forall a, exists x, f x = a.
Definition bijective {A B}(f: A -> B) := injective f /\ surjective f.

Inductive bij(A B: Type) := makeBij (u: A -> B)(v: B -> A): injective u -> (forall a, u (v a) = a) -> bij A B.

Definition bij2Fun{A B}(f: bij A B): A -> B := let (f', _, _, _) := f in f'.
Coercion   bij2Fun: bij >-> Funclass.

Definition bijComp{A B C}(g: bij B C)(f: bij A B): bij A C.
  refine (match g, f with
          | makeBij _ _ g g' H1 H2, makeBij _ _ f f' H3 H4 =>
              makeBij _ _ (fun a => g (f a)) (fun b => f' (g' b)) _ _
          end).
  intros a1 a2 H5.
  apply H3.
  apply H1.
  apply H5.
  intro c.
  rewrite H4.
  apply H2.
Defined.

Definition bijInvert{A B}(f: bij A B): bij B A.
  refine (match f with makeBij _ _ u v H1 H2 => makeBij _ _ v u _ _ end).
  intros b1 b2 H3.
  rewrite <- (H2 b1).
  rewrite <- (H2 b2).
  rewrite H3.
  reflexivity.
  intros a.
  apply H1.
  apply H2.
Defined.

Inductive aut(g: Group) := makeAut (u: GroupHom g g)(v: GroupHom g g): injective u -> (forall a, u (v a) = a) -> aut g.

Definition aut2hom{g}(f: aut g): GroupHom g g := let (f', _, _, _) := f in f'.
Coercion   aut2hom: aut >-> GroupHom.

Definition autId{g}: aut g.
  refine (makeAut _ groupHomId groupHomId _ _).
  intros b1 b2 H3. apply H3.
  intros a. reflexivity.
Defined.

Definition autComp{g}(f1 f2: aut g): aut g.
  refine (match f1, f2 with
          | makeAut _ f1 f1' H1 H2, makeAut _ f2 f2' H3 H4 =>
              makeAut _ (groupHomComp f1 f2) (groupHomComp f2' f1') _ _
          end).
  intros a1 a2 H5.
  apply H3.
  apply H1.
  apply H5. simpl.
  intro c.
  rewrite H4.
  apply H2.
Defined.

Definition autInvert{g}(f: aut g): aut g.
  refine (match f with makeAut _ f f' H1 H2 => makeAut _ f' f _ _ end).
  intros b1 b2 H3.
  rewrite <- (H2 b1).
  rewrite <- (H2 b2).
  rewrite H3.
  reflexivity.
  intros a.
  apply H1.
  apply H2.
Defined.

Definition autEq{g}(f1 f2: aut g): (forall x, f1 x = f2 x) -> f1 = f2.
  destruct f1 as [[[[f1 H1] H2] H3] [[[f1' H4] H5] H6] H7 H8].
  destruct f2 as [[[[f2 H9] Ha] Hb] [[[f2' Hc] Hd] He] Hf Hg].
  simpl in * |- *.
  intro Hh.
  assert (Hi: f1 = f2).
  apply (functional_extensionality f1 f2 Hh).
  assert (Hj: f1' = f2').
  apply (functional_extensionality f1' f2').
  intro x.
  apply Hf.
  rewrite Hg.
  rewrite <- Hi.
  apply H8.
  subst.
  rewrite (proof_irrelevance _ H1 H9).
  rewrite (proof_irrelevance _ H2 Ha).
  rewrite (proof_irrelevance _ H3 Hb).
  rewrite (proof_irrelevance _ H4 Hc).
  rewrite (proof_irrelevance _ H5 Hd).
  rewrite (proof_irrelevance _ H6 He).
  rewrite (proof_irrelevance _ H7 Hf).
  rewrite (proof_irrelevance _ H8 Hg).
  reflexivity.
Defined.

Definition AutSig(g: Group): GroupSig := makeGroupSig (X := aut g) autComp autId autInvert.

Definition Aut(g: Group): Group.
  exists (AutSig g).
  apply makeGroupAx; intros; apply autEq; simpl.
  destruct x, y, z; reflexivity.
  destruct x; reflexivity.
  destruct x.
  intro a. simpl.
  apply i.
  rewrite e.
  reflexivity.
Defined.

Definition foo(g: Group): GroupHom g (Aut g).
  refine (makeGroupHom2 g (Aut g)
    (fun a => makeAut g (innerAutomorphism a)
                        (innerAutomorphism (invert a))
                        (fun b1 b2 => _)
                        (fun b => _))
    (fun a1 a2 => _)).
  apply autEq.
  simpl.
  intro a3. symmetry. apply konjugateOp1.
  Unshelve.
  simpl.
  apply konjugateInjective.
  simpl.
  rewrite konjugateOp1.
  rewrite (rightInverse g).
  apply konjugateUnit1.
Defined.

Definition natMonoid: Monoid.
  exists (Build_MonoidSig (makeSemiGroupSig plus) 0).
  repeat split; simpl.
  symmetry. apply Nat.add_assoc.
  apply Nat.add_0_r.
Defined.


From Coq Require Import Arith Relations Lia.
From AlmostFull.Default Require Import AlmostFull.
From AlmostFull.Default Require Import AFConstructions.

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

(* **************************************************************
 *                                                              *
 *  af_induction principle                                      *
 *                                                              *
 ****************************************************************)

(* AfInduction *)
Theorem af_induction:
  forall (A:Type) (T : A -> A -> Prop) (R : A -> A -> Prop),
  almost_full R ->
  (forall x y, clos_trans_1n A T x y /\ R y x -> False) ->
  forall P : A -> Type,
    (forall x, (forall y, T y x -> P y) -> P x) ->
    forall a, P a.
Proof.
intros A T R AF Disj P g.
apply well_founded_induction_type with (R := T).
destruct AF as (p,HSec); apply wf_from_af with (R := R) (p := p).
apply Disj. apply HSec. apply g.
Defined.

(* A very simple test that the fixpoint combinator /indeed/ gives us a fixpoint *)
(* Fibonacci *)
Definition fib : nat -> nat.
Proof.
apply af_induction with (T := lt) (R := le).
(* (i) Prove <= is AF *)
apply leq_af.
(* (ii) Prove intersection emptyness *)
intros x y (CT,H). induction CT; try lia.
(* (iii) Give the functional *)
refine (fun x =>
  match x as w return (forall y, y < w -> nat) -> nat with
    | O => fun frec => 1
    | 1 => fun frec => 1
    | (S (S x)) => fun frec => (frec (S x) _  + frec x _)%nat
  end); firstorder.
Defined.

Eval compute in (fib 0). (* 1 *)
Eval compute in (fib 1). (* 1 *)
Eval compute in (fib 2). (* 2 *)
Eval compute in (fib 3). (* 3 *)
Eval compute in (fib 4). (* 5 *)
Eval compute in (fib 5). (* 8 *)

(* **************************************************************
 *                                                              *
 * A principle more akin to size-change-termination             *
 *                                                              *
 ****************************************************************)

(* Power of a relation *)
Fixpoint power n X (R : X -> X -> Prop) (x y:X) :=
  match n with
  | O => x = y
  | S m => exists z, R x z /\ power m R z y
  end.

(* Addition modulo k *)
Fixpoint plus_mod_aux k n (x:nat) :=
 match n with
 | O => x
 | S m => match (k - S x) with
          | O => plus_mod_aux k m O
          | _ => plus_mod_aux k m (S x)
          end
 end.

(* Interesting lemmas about addition modulo k *)
Lemma plus_mod_aux_fin k n (x:nat):
  (x < k) -> plus_mod_aux k n x < k.
Proof.
generalize dependent k. generalize dependent x.
induction n. auto. intros. simpl. destruct k. lia.
simpl. destruct (Nat.eq_dec (S k) (S x)). auto. inversion e.
rewrite Nat.sub_diag.  apply IHn. auto. lia.
assert (k - x <> O) by lia. set (k - x) as diff.
fold diff in H0. destruct diff. firstorder.
apply IHn. lia.
Defined.

Lemma plus_mod k (n:nat) (x:Finite k) : Finite k.
Proof.
inversion x.
refine (@FinIntro k (plus_mod_aux k n x0) _).
apply plus_mod_aux_fin. apply H.
Defined.

Lemma plus_mod_lt (m:nat):
  forall k n, m+n < k -> plus_mod_aux k m n = (m+n)%nat.
Proof.
induction m. firstorder. intros. simpl.
remember (k - S n) as j.
destruct j. lia.
assert (S (m + n) = (m + (S n))%nat).
2: { rewrite H0. apply IHm. lia. }
lia.
Defined.

Lemma plus_mod_gt (m:nat):
 forall k x, k > 0 -> m < k -> x < k -> k <= m+x -> plus_mod_aux k m x = m + x - k.
Proof.
induction m.
intros; lia.
intros.
simpl. remember (k - S x) as diff. destruct diff.
destruct k. lia.
assert (x = k). lia. subst x.
assert (plus_mod_aux (S k) m O = (m + O)%nat). apply plus_mod_lt. lia.
rewrite H3. lia.
destruct k. lia.
assert (plus_mod_aux (S k) m (S x) = m + (S x) - (S k)).
apply IHm. lia. lia. lia. lia.
rewrite H3. lia.
Defined.

Lemma plus_mod_diff:
 forall m k x, k > 1 -> m > 0 -> x < k -> m < k -> x <> plus_mod_aux k m x.
Proof.
intros.
destruct (le_lt_dec k (m+x)).
assert (plus_mod_aux k m x = m + x - k).
apply plus_mod_gt. lia. lia. lia. lia.
rewrite H3. lia.
assert (plus_mod_aux k m x = (m + x)%nat). apply plus_mod_lt. lia.
rewrite H3. lia.
Defined.

Lemma plus_mod_wraparound (m:nat):
 forall x n, x < m -> n > 0 ->
  plus_mod_aux (n + m) m (n + x) = x.
Proof.
induction m. intros; lia. intros. simpl.
remember (n + S m - (S (n + x))) as diff.
destruct diff.
assert (m = x). lia. rewrite H1.
assert (plus_mod_aux (n + S x) x O = (x + O)%nat). apply plus_mod_lt. lia.
lia.
assert (plus_mod_aux (S n + m) m (S n + x) = x).
apply IHm. lia. lia.
assert ((S n + m)%nat = (n + S m)%nat). lia. rewrite <- H2.
assert (S (n+x) = (S n + x)%nat). lia. rewrite H3. apply H1.
Defined.

Lemma plus_mod_suc m :
 forall x, x < m -> plus_mod_aux (S m) m (S x) = x.
Proof.
intros. assert (S m = (1 + m)%nat). firstorder. rewrite H0.
assert (S x = (1 + x)%nat). firstorder. rewrite H1.
apply plus_mod_wraparound. firstorder.
firstorder.
Defined.

Lemma ctr_from_ct X (T : X -> X -> Prop):
 forall x y,
 clos_trans_1n X T x y -> clos_refl_trans X T x y.
Proof.
intros x y CT. induction CT. constructor 1. apply H.
econstructor 3. constructor 1. apply H. apply IHCT.
Defined.

Lemma ct_from_ctr X (T : X -> X -> Prop):
 forall x y z,
  clos_trans X T x y ->
  clos_refl_trans X T y z -> clos_trans_1n X T x z.
Proof.
intros x y z Txy CTR.
induction CTR. apply clos_trans_t1n. apply clos_tn1_trans.
econstructor 2. apply H. apply clos_trans_tn1. apply Txy.
apply clos_trans_t1n. apply Txy. apply IHCTR2. apply clos_t1n_trans.
apply IHCTR1. apply Txy.
Defined.

(* Some lemmas about composing diagonally *)
Lemma diag_pow_decomp k X T:
 forall x y, k > 1 ->
 clos_trans_1n _ (@lift_diag k X T) x y ->
    exists m, m < k /\ (eq_fin (fst y) (@plus_mod k m (fst x))) /\
     ((m = O /\ clos_trans_1n _ (power k T) (snd x) (snd y)) \/
      ((m > 0 /\ exists z: Finite k * X, power m T (snd x) (snd z) /\
        clos_refl_trans _ (power k T) (snd z) (snd y)))).
Proof.
intros x y kGt.
intro CT.
induction CT.
unfold lift_diag in H. unfold next_fin in H. simpl in H.
destruct x as ((kx,Hx),x).
destruct y as ((ky,Hy),y). simpl in H.
exists 1. split. firstorder. split. destruct H. destruct H. destruct H. subst k.
unfold plus_mod. unfold fst. unfold eq_fin. auto. unfold plus_mod_aux. simpl.
rewrite Nat.sub_diag. apply H1. unfold plus_mod. unfold fst. unfold eq_fin.
auto. unfold plus_mod_aux. remember (k - S kx) as diff. destruct diff.
lia. lia. right. split. lia.
exists (@FinIntro k ky Hy, y).
split. simpl. exists y. firstorder.
simpl. apply rt_refl.
destruct IHCT as (m,(MltK,(HEqfin,G))).
destruct G. destruct H0. subst m.
destruct x as ((kx,Hx),x).
destruct y as ((ky,Hy),y).
destruct z as ((kz,Hz),z).
unfold fst in *. unfold snd in *. unfold lift_diag in H. unfold fst in *. unfold snd in *.
simpl in H. unfold next_fin in H. destruct H.
unfold plus_mod in HEqfin. unfold eq_fin in HEqfin.
exists (S O). split. lia. split. unfold plus_mod. unfold eq_fin.
destruct H. destruct H. subst ky.  simpl in HEqfin. subst kz. simpl.
remember (k - S kx) as diff. destruct diff. auto. lia. simpl.
destruct H. subst ky.  simpl in HEqfin. subst kz.
remember (k - S kx) as diff. destruct diff. lia. reflexivity.
right. split. auto.
exists (@FinIntro k ky Hy,y). split. simpl. exists y. split. apply H0. reflexivity.
apply ctr_from_ct. apply H1.
destruct H0. destruct H1. destruct H1.

destruct (eq_nat_dec k (S m)).
(* Case that we have to wrap-around *)
exists O. split. lia. split.
2: {
  left.
  assert (power k T (snd x) (snd x0)).
  subst k. simpl. exists (snd y). split. destruct H. apply H3.
  apply H1. split. reflexivity.
  eapply ct_from_ctr. 2: apply H2.
  constructor 1.
  subst k. simpl. exists (snd y). split. destruct H. apply H4. apply H1.
}
destruct x as ((kx,Hx),x).
destruct y as ((ky,Hy),y).
destruct z as ((kz,Hz),z).
unfold fst.
unfold plus_mod. simpl. unfold eq_fin. unfold fst in HEqfin.
unfold plus_mod in HEqfin. unfold eq_fin in HEqfin. subst kz. subst k.
unfold lift_diag in H. unfold fst in H. unfold snd in H. unfold next_fin in H.
simpl in H. destruct H. destruct H. destruct H. subst ky. inversion H.
assert (plus_mod_aux (S m) m O = (m + O)%nat). apply plus_mod_lt. lia.
rewrite H4. auto. destruct H. subst ky.
apply plus_mod_suc. lia.
(* No wraparound needed here *)
exists (S m). split.  lia.
split.
2: {
  right. split. lia.
  exists x0. split. simpl. exists (snd y). split. destruct H. apply H3.
  apply H1. apply H2.
}
destruct x as ((kx,Hx),x).
destruct y as ((ky,Hy),y).
destruct z as ((kz,Hz),z).
unfold fst. unfold plus_mod. unfold eq_fin. unfold plus_mod in HEqfin.
unfold fst in *. unfold snd in *. unfold eq_fin in HEqfin. subst kz.
unfold lift_diag in H. unfold fst in H. unfold snd in H. destruct H.
unfold next_fin in H. destruct H. destruct H. subst.
simpl. rewrite Nat.sub_diag. reflexivity. simpl.
destruct H. subst ky.
remember (k - S kx) as diff. destruct diff. lia. reflexivity.
Defined.

Lemma diag_pow_decomp_mod k X T:
 forall x y, k > 1 ->
 clos_trans_1n _ (@lift_diag k X T) x y ->
    clos_trans_1n X (power k T) (snd x) (snd y) /\ eq_fin (fst x) (fst y) \/
    ~ (eq_fin (fst x) (fst y)).
Proof.
intros x y kGt CT.
destruct (diag_pow_decomp kGt CT) as (m,H).
destruct H. destruct H0. destruct H1.
destruct H1. subst m. left. split. apply H2. destruct x. destruct y. unfold fst in *. unfold snd in *. simpl.
unfold plus_mod in H0. destruct f. destruct f0. unfold eq_fin in *. simpl in H0. auto.
right. destruct H1. destruct x. destruct y. unfold plus_mod in H0. unfold fst in *. unfold snd in *.
destruct f. destruct f0. unfold eq_fin in *. subst x2.
apply plus_mod_diff. firstorder. firstorder. firstorder. apply H.
Defined.

Lemma af_power_induction_non_trivial:
  forall (A:Type) k
  (T : A -> A -> Prop)
  (R : A -> A -> Prop),
  k > 1 -> almost_full R ->
 (forall x y, @clos_trans_1n _ (power k T) x y /\ R y x -> False) ->
 forall P : A -> Type,
 (forall x, (forall y, T y x -> P y) -> P x) ->
 forall x, P x.
Proof.
intros X k T R kGt afR Hct P frec.
assert (forall (x: Finite k * X), P (snd x)).
apply af_induction with (T := @lift_diag k X T) (R := @lift_pointwise k X R).
(* Almost Full condition *)
unfold lift_pointwise; apply af_intersection.
apply af_cofmap; apply af_finite. apply af_cofmap; apply afR.
(* Intersection emptyness *)
intros x y (CTxy,Tyx).
induction CTxy. unfold lift_diag in H. unfold lift_pointwise in Tyx.
unfold next_fin in H.
destruct x. destruct y. simpl in H. destruct f. destruct f0. simpl in Tyx.
destruct H. unfold eq_fin in H. unfold eq_fin in Tyx. lia.
destruct x as ((kx,Hx),x).
destruct y as ((ky,Hy),y).
destruct z as ((kz,Hz),z).
unfold lift_diag in H. unfold next_fin in H. simpl in H. destruct H as (H2,H4).
unfold lift_pointwise in Tyx. simpl in Tyx. unfold eq_fin in Tyx. destruct Tyx as (H3,H5).
assert (clos_trans_1n X (power k T) x z /\ kx = kz \/ (kx <> kz)).
assert (@clos_trans_1n (Finite k * X) (@lift_diag k X T)
                        (FinIntro (k:=k) (x:=kx) Hx, x)
                        (FinIntro (k:=k) (x:=kz) Hz, z)).
constructor 2 with (y := (@FinIntro k ky Hy,y)).
unfold lift_diag. unfold fst. unfold snd. split. unfold next_fin.
apply H2. apply H4. apply CTxy.
destruct (diag_pow_decomp_mod kGt H). simpl in H0.
destruct H0. left. split. apply H0. unfold eq_fin in H1. apply H1.
unfold eq_fin in H0. unfold fst in H0. right. apply H0.
firstorder.
(* Functional requirement *)
intros. destruct x as ((kx,Hx),x). unfold snd.
apply frec. intros.
destruct kx.
  (* kx = O *)
  assert (k-1 < k). lia.
  intros. apply (X0 (@FinIntro k (k-1) H0,y)). simpl.
  unfold lift_diag. unfold fst. unfold snd. split. unfold next_fin. lia. apply H.
  (* Now it is an (S kx) *)
  assert (kx < k). intuition auto; lia.
  intros. apply (X0 (@FinIntro k kx H0,y)). simpl. unfold lift_diag. simpl. split.
  simpl. unfold next_fin. right. intuition lia. apply H.
(* Show the goal *)
intros. apply frec. intros. apply (X0 (@FinIntro k 1 kGt, y)).
Defined.

(* AfPowerInduction *)
Lemma af_power_induction:
  forall (A:Type) k
  (T : A -> A -> Prop) (R : A -> A -> Prop),
  k >= 1 -> almost_full R ->
  (forall x y,
    clos_trans_1n A (power k T) x y /\ R y x -> False) ->
  forall P : A -> Type,
  (forall x, (forall y, T y x -> P y) -> P x) ->
  forall x, P x.
Proof.
intros.
destruct (le_lt_dec k 1). assert (k = 1). lia.
apply af_induction with (T := T) (R := R). apply H0.
intros. eapply H1. split. 2: { destruct H3. apply r. }
subst k. simpl.
destruct H3. clear H3 H H1 l. induction H2. constructor. exists y. auto.
constructor 2 with (y := y). exists y. auto. auto.
apply X.
apply af_power_induction_non_trivial with (k := k) (T := T) (R := R).
lia. assumption. assumption. assumption.
Defined.

(* **************************************************************
 *                                                              *
 * A particular mutual induction principle                      *
 *                                                              *
 ****************************************************************)

Definition lift_rel_union (A:Type) (B:Type)
                          (TA : A -> A -> Prop) (TB : B -> B -> Prop)
                          (SA : A -> B -> Prop) (SB : B -> A -> Prop)
                          (x : A + B)
                          (y : A + B) : Prop.
Proof.
destruct x as [xl|xr].
destruct y as [yl|yr]. apply (TA xl yl). apply (SA xl yr).
destruct y as [yl|yr]. apply (SB xr yl). apply (TB xr yr).
Defined.

(* AfInduction *)

Lemma af_mut_induction_aux:
   forall (A:Type) (B:Type)
          (TA : A -> A -> Prop) (SA : A -> B -> Prop)
          (TB : B -> B -> Prop) (SB : B -> A -> Prop)
          (R : A + B -> A + B -> Prop),
          almost_full R ->
          (forall x y, @clos_trans_1n (A+B) (@lift_rel_union _ _ TA TB SA SB) x y /\ R y x -> False) ->
          forall (P : A -> Type) (Q : B -> Type),
             (forall x : A, (forall y, TA y x -> P y) ->
                            (forall y, SB y x -> Q y) -> P x) ->
             (forall x : B, (forall y, TB y x -> Q y) ->
                            (forall y, SA y x -> P y) -> Q x) ->
          forall a: A+B, match a with
                         | inl l => P l
                         | inr r => Q r
                         end.
Proof.
intros A B TA SA TB SB R Raf HTrans P Q fA fB.
apply af_induction with (R := R) (T := @lift_rel_union _ _ TA TB SA SB).
apply Raf. intros. eapply HTrans. apply H. intros.
destruct x. apply fA. intros. remember (X (inl _ y)). simpl in y0. apply y0. apply H.
intros. remember (X (inr _ y)). simpl in y0. apply y0. apply H.
apply fB. intros. remember (X (inr _ y)). simpl in y0. apply y0. apply H.
intros. remember (X (inl _ y)). simpl in y0. apply y0. apply H.
Defined.

Lemma af_mut_induction : forall (A:Type) (B:Type)
 (TA : A -> A -> Prop) (SA : A -> B -> Prop)
 (TB : B -> B -> Prop) (SB : B -> A -> Prop)
 (R : A + B -> A + B -> Prop),
 almost_full R ->
 (forall x y, @clos_trans_1n (A+B) (@lift_rel_union _ _ TA TB SA SB) x y /\ R y x -> False) ->
 forall (P : A -> Type) (Q : B -> Type),
    (forall x : A, (forall y, TA y x -> P y) ->
                   (forall y, SB y x -> Q y) -> P x) ->
    (forall x : B, (forall y, TB y x -> Q y) ->
                   (forall y, SA y x -> P y) -> Q x) ->
 (forall a, P a) * (forall b, Q b).
Proof.
intros.
assert (forall a:A+B, match a with
                      | inl l => P l
                      | inr r => Q r
                      end).
eapply af_mut_induction_aux. apply H. apply H0. apply X. apply X0.
split. intros. remember (X1 (inl _ a)). auto.
intros. remember (X1 (inr _ b)). auto.
Defined.


Require Import Arith NArith Pow Compatibility Lia.
Open Scope positive_scope.
Import Monoid_def.
Require Import Recdef  Wf_transparent.

(** * Basic lemmas about positive and N *)

Definition pos_eq_dec : forall p p':positive, {p = p'}+{p <> p'}.
Proof.  decide equality. Defined.

Lemma N_0_le_n: forall n:N, (0 <= n)%N.
Proof.
 destruct n; simpl;[reflexivity | discriminate].
Qed.

Lemma Pos_to_nat_neq_0 : forall p, Pos.to_nat p <> 0%nat.
Proof.
 induction p; cbn.
  discriminate.
 rewrite Pos2Nat.inj_xO.
      simpl; lia.
  discriminate.
Qed.

#[global] Hint Resolve Pos_to_nat_neq_0 : chains.

(** ** Relationship with [nat] and [N]
*)
Lemma Npos_diff_zero : forall p, N.pos p <> 0%N.
Proof. discriminate. Qed.

Lemma Npos_gt_0 : forall p, (0 < N.pos p)%N.
Proof. reflexivity. Qed.

#[global] Hint Resolve Npos_diff_zero  Npos_gt_0 : chains.

Lemma pos2N_inj_lt : forall n p, (n < p)%positive <-> (N.pos n < N.pos p)%N.
Proof.
 intros n p; tauto.
Qed.

Lemma pos2N_inj_add : forall n p, N.pos (n + p) = (N.pos n + N.pos p)%N.
Proof. reflexivity. Qed.

Ltac pos2nat_inj_tac :=
  repeat (rewrite Pos2Nat.inj_add || rewrite Pos2Nat.inj_mul ||
          rewrite Pos2Nat.inj_lt  || rewrite Pos2Nat.inj_le).

Lemma Pos2Nat_le_1_p : forall p, (1 <= Pos.to_nat p)%nat.
intro p;  change (Pos.to_nat 1 <= Pos.to_nat p)%nat;
              rewrite <-  Pos2Nat.inj_le.
            apply Pos.le_1_l.
Qed.

Lemma N_le_1_pos : forall p, (1 <= N.pos p)%N.
Proof. destruct p; discriminate. Qed.

Lemma pos_le_mul : forall p q , (p <= p * q)%positive.
Proof.
  intros p q; replace p with (p * 1)%positive at 1
              by ( now rewrite Pos.mul_1_r).
  apply Pos.mul_le_mono_l; apply Pos.le_1_l.
Qed.

Lemma pos_lt_mul : forall p q , (1 < q -> p < p * q)%positive.
Proof.
  intros p q H; replace p with (p * 1)%positive at 1
              by ( now rewrite Pos.mul_1_r).
  apply Pos.mul_lt_mono_l; auto.
Qed.

Lemma Pos2Nat_le_n_pn :
  forall p q,
    (Pos.to_nat p <= Pos.to_nat p  * Pos.to_nat q)%nat.
Proof.
 intros p q;
 replace (Pos.to_nat p  * Pos.to_nat q)%nat with (Pos.to_nat (p * q))
 by (now rewrite Pos2Nat.inj_mul).
 apply Pos2Nat.inj_le; apply pos_le_mul.
Qed.

#[global] Hint Resolve Pos2Nat_le_1_p : chains.

(** ** Surjection from [N] into [positive]
*)

Definition N2pos (n:N) : positive :=
 match n with 0%N => xH | Npos p => p end.

Lemma N2pos_pos :
  forall i,  N2pos (Npos i) = i.
Proof. reflexivity. Qed.

Lemma N_pos_N2pos : forall n, 0%N <> n ->  n = Npos (N2pos n).
Proof.
 destruct n;[ now destruct 1 | reflexivity].
Qed.

Lemma N2pos_lt_switch : forall  n p, (0%N < n)%N ->
                                     ( (N.pos p < n)%N <-> (p < N2pos n)%positive).
Proof.
destruct n.
- split; discriminate.
-  intros;simpl;split; now  rewrite pos2N_inj_lt.
Qed.

Ltac N2pos_simpl x := simpl (N2pos (N.pos x)) in *.

Ltac N2pos_destruct t y :=
 destruct t as [| y] ; [try (discriminate || contradiction) | N2pos_simpl y].

Lemma N2pos_lt_switch2 : forall  n p, (0%N < n)%N ->
                                      ((N2pos n < p)%positive
                                       <-> (n < N.pos p)%N).
Proof.
 intros n p H;  N2pos_destruct n n;
 split; simpl;now  rewrite pos2N_inj_lt.
Qed.

Lemma pos_lt_wf : well_founded Pos.lt.
Proof.
  intros x.
  assert (H:= wf_inverse_image_transparent  _ _ Nat.lt Pos.to_nat lt_wf).
  assert (H0 : Relation_Definitions.inclusion
            positive Pos.lt
            (fun x y : positive =>
               Nat.lt (Pos.to_nat x) (Pos.to_nat y))).
  -  red;  intros x0 y0 ;  now rewrite Pos2Nat.inj_lt .
  - apply  (wf_incl_transparent positive  _ _ H0 H ).
Defined.

(** Partial exact log2 function  *)

Fixpoint  exact_log2(p:positive) : option positive :=
match p with
  | 1%positive | xI _ => None
  | 2%positive =>  Some xH
  | xO q => match exact_log2 q with
              | Some l => Some (l+1)%positive
              | _ => None
            end
end.

(**
Compute exact_log2 16.
 = Some 4
     : option positive

Compute exact_log2 10.
= None
    : option positive
*)

Lemma exact_log2xOx0 :
  forall p i, exact_log2 (xO p) = Some i ->
              exact_log2 (xO (xO p)) = Some (i+1)%positive.
Proof.
  simpl; destruct p.
  -  intro i; cbn; discriminate.
  -  destruct (exact_log2 p~0) .
     +  injection 1; intro; now subst i.
     +  discriminate.
  -  injection 1; intro; now subst i.
Qed.

Lemma exact_log2_spec :
  forall p i: positive, exact_log2 p = Some i -> p = (2 ^ i)%positive.
Proof.
  induction p.
  -  simpl; discriminate.
  - intro i; destruct p.
    + destruct p; discriminate.

    +  case_eq (exact_log2 (xO p)).
       *  intros p0 H H0; generalize (exact_log2xOx0 _ _ H); intro H1.
          generalize (IHp _ H); intro H2; rewrite H0 in H1; injection H1;
          rewrite H2;  intro; subst i.
          repeat rewrite Pos_pow_power.
          rewrite Pos2Nat.inj_add.
          rewrite power_of_plus.
          replace (2%positive ^ Pos.to_nat 1)%M with 2%positive by reflexivity.
          rewrite Pos.mul_xO_r.
          now rewrite Pos.mul_1_r.
       * cbn; destruct p.
         destruct (exact_log2 p~1);  discriminate.
         destruct (exact_log2 p~0);  discriminate.
         discriminate.

    + cbn;   injection 1;intro; now subst i.
  - discriminate.
Qed.

(** Another induction principle for positive *)

Lemma positive_4step_ind : forall P : positive -> Prop,
   P 1%positive -> P 2%positive -> P 3%positive ->
  (forall p, P p -> P (xO (xO p)) /\ P (xI (xO p)) /\ P (xO (xI p)) /\
               P (xI (xI p))) ->
  forall p, P p.
Proof.
  intros P H H0 H1 H2 p;  assert (P p /\ P (xO p) /\ P (xI p)).
  -   induction p.
      + repeat split; try tauto.
        * destruct (H2 p);tauto.
        * destruct (H2 p);tauto.
      + repeat split; try tauto.
        * destruct (H2 p);tauto.
        * destruct (H2 p);tauto.
      + repeat split;tauto.
  - tauto.
Qed.

Lemma pos_gt_3 : forall p:positive,
  p <> 1  -> p <> 3  ->  exact_log2 p = None ->  3 < p.
Proof.
 intro p;pattern p; apply  positive_4step_ind.
 -  destruct 1;auto.
 -  discriminate.
 -  destruct 2;auto.
 -  split; intros; now compute.
Qed.

#[global] Hint Resolve pos_gt_3 : chains.

(** ** Lemmas on Euclidean division
    N.pos_div_eucl (a:positive) (b:N) : N * N
*)

Lemma pos_div_eucl_quotient_pos : forall a b q r,
                                    N.pos_div_eucl a b = (q, r) ->
                                    (b <= N.pos a)%N ->
                                    b <> 0%N ->
                                    (q <> 0%N).
Proof.
  intros a b q r H H1; generalize (N.pos_div_eucl_spec a b); rewrite H.
  intros  H0 H2 H3. rewrite H3 in H0 ;   simpl in H0.
  generalize (N.pos_div_eucl_remainder a b H2);  rewrite H;  simpl;
  intro; subst r.
  destruct (N.lt_irrefl b);auto.
  apply N.le_lt_trans with (N.pos a);auto.
Qed.

Lemma pos_div_eucl_quotient_lt : forall a b q r,
                                   N.pos_div_eucl a b = (q, r) ->
                                   (1 < b)%N ->
                                   (q < N.pos a)%N.
Proof.
  intros a b q r H H1; generalize (N.pos_div_eucl_spec a b); rewrite H.
  destruct q.
  - reflexivity.
  -  intro H2; rewrite H2;  apply N.lt_le_trans with (N.pos p * b)%N.
      + replace (N.pos p)  with ((N.pos p) * 1)%N at 1
       by (now rewrite N.mul_1_r).
       apply N.mul_lt_mono_pos_l; auto with chains.
      +  apply N.le_add_r.
Qed.

Lemma N_pos_div_eucl_divides : forall i b q,
                                 N.pos_div_eucl i (N.pos b) = (q, 0%N) ->
                                 (b * N2pos q)%positive = i.
Proof.
  intros i b q H;  generalize  (N.pos_div_eucl_spec   i (N.pos b)).
  rewrite H,  N.add_0_r.
  intro H3;  destruct q ; [discriminate | ].
  rewrite Pos.mul_comm; injection H3; symmetry; assumption.
Qed.

 Lemma N_pos_div_eucl_rest : forall i b q r,
                               N.pos_div_eucl i (N.pos b) = (q,  r) ->
                               (0 < r)%N -> (0 < q)%N ->
                               (b * N2pos q + N2pos r)%positive = i.
 Proof.
   intros i b q r H H0 H1.   generalize  (N.pos_div_eucl_spec   i (N.pos b)).
   rewrite H.
   destruct r ;[discriminate | ].
   destruct q ; [discriminate | ].
   injection 1.
   cbn.
   intro H3;subst i.
   now rewrite Pos.mul_comm.
 Qed.

 Lemma N_pos_div_eucl_q0 : forall i b  r,
                             N.pos_div_eucl i (N.pos b) = (0%N,   r) ->
                             i = N2pos r.

 Proof.
   intros i b  r H;   generalize  (N.pos_div_eucl_spec   i (N.pos b)).
   rewrite H.
   simpl.
   destruct r.
   discriminate.
   injection 1;now cbn.
 Qed.

(** An auxiliary lemma *)
Lemma lt_S_2i :
forall i j:nat, (i < j -> 2 * i + 1 < 2 * j)%nat.
Proof.  intros; lia. Qed.

Lemma N_le_mul_pos  : forall q p, (q <= q * N.pos p)%N.
Proof.
  intros q p; replace q with (q * 1)%N at 1.
  apply N.mul_le_mono_nonneg_l.
  apply N_0_le_n.
  destruct p;discriminate.
  rewrite N.mul_1_r; auto.
Qed.

Ltac quotient_small div_equation H :=
  match type of div_equation with
    (N.pos_div_eucl ?a ?b = (?q,?r)) =>
    assert  (H : (q < N.pos a)%N);
    [apply (pos_div_eucl_quotient_lt _ _ _ _ div_equation); auto|]
  end.

Ltac rest_small div_equation H :=
  match type of div_equation with
    (N.pos_div_eucl ?a ?b = (?q,?r)) =>
    let H0 := fresh "H" in
    assert  (H : (r < b)%N);
    [generalize (N.pos_div_eucl_remainder a b); simpl; intro  H0;
     rewrite div_equation in H0; apply H0 ; try discriminate| ]
  end.


Require Import QArith PArith Nat.

Inductive division : Type :=
    | whole
    | half : division -> division
    | third : division -> division
  .

Notation "'Half'"     := ((half whole)) (at level 80, right associativity).
Notation "'Quarter'"  := ((half (half whole))) (at level 80, right associativity).
Notation "'Eighth'"   := ((half (half (half whole)))) (at level 80, right associativity).
Notation "'Sixteenth'"   := ((half(half (half (half whole))))) (at level 80, right associativity).
Notation "'QTriplet'"  := ((third (half (half whole)))) (at level 80, right associativity).
Notation "'ETriplet'" := ((third (half (half (half whole))))) (at level 80, right associativity).

(*This is would not be needed if Q.eqb existed to write eqb_division.*)
(* turns out, it exists Qeq_bool*)
Fixpoint fraction_inverse (x : division) : nat :=
  match x with
  | whole => 1
  | half d => 2 * fraction_inverse d
  | third d => 3 * fraction_inverse d
  end.

Definition eqb (d1 d2 : division) : bool :=
  Nat.eqb (fraction_inverse d1) (fraction_inverse d2).

Lemma unittest1 : eqb (Half) (Half) = true. Proof. auto. Qed.
Lemma unittest2 : eqb (Half) (Quarter) = false. Proof. auto. Qed.

Fixpoint fraction (x : division) : Q :=
  match x with
  | whole => 1
  | half d => ((fraction d) / 2)
  | third d => ((fraction d) / 3)
  end.

Lemma unittest3 : fraction (Half) = 1 / 2 . Proof. unfold fraction. reflexivity. Qed.
Lemma unittest4 : fraction (QTriplet) = 1 / 2 / 2 / 3 . Proof. unfold fraction. reflexivity. Qed.

Fixpoint half_count (x : division) : nat :=
  match x with
  | whole => 0
  | half d => S (half_count d)
  | third d => half_count d
  end.

Fixpoint third_count (x : division) : nat :=
  match x with
  | whole => 0
  | third d => S (third_count d)
  | half d => third_count d
  end.

Fixpoint nth_half (h : nat) (base : division) : division :=
  match h with
  | O => base
  | S n => half (nth_half n base )
  end.

Fixpoint nth_third (h : nat) (base : division) : division :=
  match h with
  | O => base
  | S n => third (nth_third n base )
  end.


Require Import Lia.
Require Import ZArith.
Open Scope Z_scope.
(* Goal transforming inequalities + transitivities. *)
Lemma gt_ge : forall m n, m > n -> m >= n + 1. lia. Qed.
Lemma gt_ge2 : forall m n, m > n -> m >=n. lia. Qed.
Lemma gt_ge3 : forall m n, m > n - 1 -> m >= n. lia. Qed.
Lemma gt_ge4 : forall m n, m > n - 1 -> m >= n. lia. Qed.

Lemma ge_gt : forall m n, m >= n + 1 <-> m > n.  lia. Qed.
Lemma ge_gt_l : forall m n, m > n -> m >= n + 1.  lia. Qed.
Lemma eq_ge: forall m n, m = n -> m >= n. lia. Qed.

Lemma gt_ge_gt: forall m n p, m > n -> n >= p -> m > p. lia. Qed.
Lemma gt_gt_gt: forall m n p, m > n -> n > p -> m > p. lia. Qed.
Lemma ge_ge_ge: forall m n p, m >= n -> n >= p -> m >= p. lia. Qed.
Lemma gt_plus : forall m n p, m > n -> m + p > n + p. lia. Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus (Succ Zero) y.


Require Export Arith.
Require Export XR_lt_INR.

Local Open Scope R_scope.

Lemma INR_lt : forall n m:nat,
  INR n < INR m ->
  (n < m)%nat.
Proof.
  intros n.
  induction n as [ | n hn ].
  {
    intros m hm.
    destruct m as [ | m ].
    {
      exfalso.
      apply Rlt_irrefl in hm.
      contradiction.
    }
    {
      unfold lt.
      apply le_n_S.
      apply le_O_n.
    }
  }
  {
    intros m hnm.
    destruct m as [ | m ].
    {
      exfalso.
      clear hn.
      apply Rlt_irrefl with R0.
      apply Rlt_trans with (INR (S n)).
      {
        replace R0 with (INR 0%nat).
        {
          apply lt_INR.
          unfold lt.
          apply le_n_S.
          apply le_O_n.
        }
        {
          simpl.
          reflexivity.
        }
      }
      {
        simpl in hnm.
        exact hnm.
      }
    }
    {
      apply lt_n_S.
      apply hn.
      apply Rplus_lt_reg_r with R1.
      rewrite <- S_INR.
      rewrite <- S_INR.
      exact hnm.
    }
  }
Qed.


Require Import Setoid Morphisms.
Require SetoidList.
Require Export Coq.Classes.Equivalence.
Open Scope equiv_scope.

Global Set Asymmetric Patterns.
Generalizable All Variables.

(** * Ordered Types

   This file corresponds to OrderedType.v in the standard FSets/FMaps
   library. It contains a formalization of types equipped with a total
   and decidable order.
   Notations on ordered types are defined in scope [compare_scope],
   delimited by key [compare].
   *)
Delimit Scope compare_scope with compare.

(** ** Strict orders : the [StrictOrder] class

   A strict order [lt] with respect to an equivalence relation [eq]
   on a type [A] is an antireflexive transitive relation, ie. it
   is a transitive relation that does not contain two congruent terms.
   We define the class [StrictOrder A lt eq] of such objects.
   *)
Class StrictOrder {A} lt eq {equiv : Equivalence eq} := {
  StrictOrder_Transitive :> Transitive lt;
  StrictOrder_Irreflexive : forall (x y : A), lt x y -> x =/= y
}.
Definition lt_StrictOrder `{StrictOrder A lt_ eq_} := lt_.

(** If [x] and [y] belong to a strict order, we define the
   notations [x >>> y] and [y <<< x]. *)
Notation " x >>> y " := (lt_StrictOrder y x)
  (at level 70, no associativity, only parsing) : compare_scope.
Notation " x <<< y " := (lt_StrictOrder x y)
  (at level 70, no associativity) : compare_scope.
Open Scope compare_scope.

(** A couple of useful basic properties about strict orders. *)
Set Implicit Arguments. Unset Strict Implicit.
Section StrictOrderProps.
  Context `{StrictOrder A}.

  Property lt_antirefl : forall x, ~x <<< x.
  Proof.
    intros; intro Hlt; apply (StrictOrder_Irreflexive x x Hlt); reflexivity.
  Qed.
  Property lt_not_eq : forall x y, x <<< y -> x =/= y.
  Proof.
    intros; apply StrictOrder_Irreflexive; auto.
  Qed.
  Property gt_not_eq : forall x y, x >>> y -> x =/= y.
  Proof.
    intros; intro abs; symmetry in abs; revert abs; apply lt_not_eq; auto.
  Qed.
  Property eq_not_lt : forall x y, x === y -> ~ x <<< y.
  Proof.
    intros; intro abs; apply (lt_not_eq abs); auto.
  Qed.
  Property eq_not_gt : forall x y, x === y -> ~ x >>> y.
  Proof.
    intros; intro abs; apply (gt_not_eq abs); auto.
  Qed.
  Property lt_not_gt : forall x y, x <<< y -> ~(x >>> y).
  Proof.
    intros; intro abs; refine (lt_not_eq _ _); shelve_unifiable.
    transitivity y; eauto. reflexivity.
  Qed.
End StrictOrderProps.
Unset Implicit Arguments.

(** ** Ordered types : the [OrderedType] class

   [OrderedType] is the class of types that enjoy decidable comparison for
   a given setoid equality and strict order relation with respect to this
   equality. An instance of [OrderedType] for a type [A] must bring :
   - the equality relation [eq]
   - a proof that [eq] is an equivalence relation
   - the order relation [lt]
   - an instance of [StrictOrder] for [lt] and [eq]
   - a comparison function [cmp : A -> A -> comparison]
   - a proof that [cmp] really implements [lt] and [eq]

   With respect to the original formalization in the FSets/FMaps library,
   the fundamental difference is that the comparison function is purely
   computational, whereas the return type of the [compare] function in
   [FSets.OrderedType] includes proofs. In that sense, this formalisation
   is more similar to [FSets.OrderedTypeAlt]. To define the specification
   that the function [cmp] must meet, unlike [OrderedTypeAlt], we use
   the following inductive view [compare_spec] :
   *)
Inductive compare_spec {A} eq lt (x y : A) : comparison -> Prop :=
| compare_spec_lt : lt x y -> compare_spec eq lt x y Lt
| compare_spec_eq : eq x y -> compare_spec eq lt x y Eq
| compare_spec_gt : lt y x -> compare_spec eq lt x y Gt.

(** [compare_spec] describes what is the correct result for a comparison
   between two elements [x] and [y] ; in particular, a suitable comparison
   function is a function that is included in this relation.

   Given these definitions, we can now define the [OrderedType] class.
   *)
Class OrderedType (A : Type) := {
  _eq : relation A;
  _lt : relation A;
  OT_Equivalence :> Equivalence _eq;
  OT_StrictOrder :> StrictOrder _lt _eq;
  _cmp : A -> A -> comparison;
  _compare_spec : forall x y, compare_spec _eq _lt x y (_cmp x y)
}.

(** If [x] and [y] belong to an ordered type [A], we can write [compare x y]
   to denote the comparison of [x] and [y], as well as the special handy
   notation [x =?= y]. *)
Definition compare `{OrderedType A} := _cmp.
Notation " x =?= y " :=
  (compare (x :>) (y :>)) (no associativity, at level 70) : compare_scope.

(** The following lemma is a convenient way to access the specification of
   the [compare] function. Its typical use is the following : if a comparison
   [x =?= y] appears in the Coq context, [destruct (compare_dec x y)] will
   create 3 branches for each result of the comparison, and add the correct
   hypothesis in each branch. It is almost as easy to work with as the
   original dependently-typed [OrderedType.compare] function.
   *)
Definition compare_dec `{H : OrderedType A} :
  forall x y, compare_spec equiv lt_StrictOrder x y (compare x y) :=
    @_compare_spec A H.

(** [compare] is made globally opaque so that case analysis can be done
   easily by destructing [compare_dec _ _]. *)
Global Opaque compare.

(** We define shortcut notations [x == y], [x << y] and [x >> y]
   for purely computational equality and ordering tests, and
   their specification as well. *)
Definition is_compare `{OrderedType A} (x y : A) c :=
  match x =?= y, c with
    | Eq, Eq | Lt, Lt | Gt, Gt => true
    | _, _ => false
  end.
Notation " x == y " :=
  (is_compare x y Eq) (no associativity, at level 70) : compare_scope.
Notation " x << y " :=
  (is_compare x y Lt) (no associativity, at level 70) : compare_scope.
Notation " x >> y " :=
  (is_compare x y Gt) (no associativity, at level 70) : compare_scope.

Property compare_1 `{OrderedType A} : forall x y, x =?= y = Lt -> x <<< y.
Proof.
  intros; destruct (compare_dec x y); auto; congruence.
Qed.
Property compare_2 `{OrderedType A} : forall x y, x =?= y = Eq -> x === y.
Proof.
  intros; destruct (compare_dec x y); auto; congruence.
Qed.
Property compare_3 `{OrderedType A} : forall x y, x =?= y = Gt -> x >>> y.
Proof.
  intros; destruct (compare_dec x y); auto; congruence.
Qed.

(** Decidability lemmas for equality and orders, specified in a way
   similar to [compare_spec]. *)
Inductive decides {A} (R : relation A) (x y : A) : bool -> Prop :=
| decides_true : R x y -> decides R x y true
| decides_false : ~(R x y) -> decides R x y false.

Property eq_dec `{OrderedType A} :
  forall (x y : A), decides equiv x y (x==y).
Proof.
  intros; unfold is_compare. destruct (compare_dec x y); constructor.
  apply lt_not_eq; auto.
  assumption.
  apply gt_not_eq; auto.
Qed.
Property lt_dec `{OrderedType A} :
  forall x y, decides lt_StrictOrder x y (x<<y).
Proof.
  intros; unfold is_compare. destruct (compare_dec x y); constructor.
  assumption.
  intro abs; apply (lt_not_eq abs); auto.
  apply lt_not_gt; auto.
Qed.
Property gt_dec `{OrderedType A} :
  forall x y, decides lt_StrictOrder y x (x>>y).
Proof.
  intros; unfold is_compare. destruct (compare_dec x y); constructor.
  apply lt_not_gt; auto.
  intro abs; apply (gt_not_eq abs); auto.
  assumption.
Qed.

(** More lemmas about ordered types, in particular the fact that
   the order relations are morphisms for equality. *)
Set Implicit Arguments. Unset Strict Implicit.
Property eq_lt `{OrderedType A} :
  forall (x x' y : A), x === x' -> x <<< y -> x' <<< y.
Proof.
  intros; destruct (compare_dec x' y); auto.
  contradiction (lt_not_eq H1); transitivity x'; auto.
  contradiction (lt_not_eq (x:=x) (y:=x')); auto; transitivity y; auto.
Qed.
Corollary eq_lt2 `{OrderedType A} :
  forall (x x' y : A), x === x' -> x' <<< y -> x <<< y.
Proof.
  intros; apply eq_lt with x'; auto; symmetry; auto.
Qed.
Property eq_gt `{OrderedType A} :
  forall (x x' y : A), x === x' -> x >>> y -> x' >>> y.
Proof.
  intros; destruct (compare_dec x' y); auto.
  contradiction (gt_not_eq (x:=x) (y:=x')); auto; transitivity y; auto.
  contradiction (gt_not_eq H1); transitivity x'; auto.
Qed.
Instance lt_m `{OrderedType A} : Proper (_eq ==> _eq ==> iff) _lt.
Proof.
  repeat intro; split; intro Hlt.
  apply (eq_lt (x:=x)); auto. apply (eq_gt (x:=x0)); auto.
  apply (eq_lt (x:=y)); try symmetry; auto.
  apply (eq_gt (x:=y0)); try symmetry; auto.
Qed.
Instance le_m `{OrderedType A} : Proper (_eq ==> _eq ==> iff) (complement _lt).
Proof.
  repeat intro; split; intro Hlt; unfold complement in  *.
  rewrite H1 in Hlt; rewrite H0 in Hlt; assumption.
  rewrite H0, H1; assumption.
Qed.

(** Shortcut lemmas for the [order] tactic *)
Section OrderLemmas.
  Context `{OrderedType A}.
  Variables x y z : A.

  Corollary lt_eq : x <<< y -> y === z -> x <<< z.
  Proof.
    intros; rewrite <- H1; assumption.
  Qed.
  Corollary le_eq : ~x <<< y -> y === z -> ~x <<< z.
  Proof.
    intros; rewrite <- H1; assumption.
  Qed.
  Corollary eq_le : x === y -> ~y <<< z -> ~x <<< z.
  Proof.
    intros; rewrite H0; assumption.
  Qed.
  Corollary neq_eq : x =/= y -> y === z -> x =/= z.
  Proof.
    intros; rewrite <- H1; assumption.
  Qed.
  Corollary eq_neq : x === y -> y =/= z -> x =/= z.
  Proof.
    intros; rewrite H0; assumption.
  Qed.

  Property le_lt_trans : ~ y <<< x -> y <<< z -> x <<< z.
  Proof.
    intros; destruct (compare_dec x z); auto.
    rewrite <- H2 in H1; contradiction.
    contradiction H0; transitivity z; auto.
  Qed.
  Property lt_le_trans : x <<< y -> ~ z <<< y -> x <<< z.
  Proof.
    intros; destruct (compare_dec x z); auto.
    rewrite <- H2 in H1; contradiction.
    contradiction H1; transitivity x; auto.
  Qed.
  Property le_neq : ~x <<< y -> x =/= y -> x >>> y.
  Proof.
    intros; destruct (compare_dec x y); auto; contradiction.
  Qed.

  Lemma elim_compare_eq : x === y -> x =?= y = Eq.
  Proof.
    intros; destruct (compare_dec x y); auto.
    contradiction (lt_not_eq H1 H0).
    contradiction (lt_not_eq H1 (symmetry H0)).
  Qed.
  Lemma elim_compare_lt : x <<< y -> x =?= y = Lt.
  Proof.
    intros; destruct (compare_dec x y); auto.
    contradiction (lt_not_eq H0 H1).
    contradiction (lt_not_gt H1 H0).
  Qed.
  Lemma elim_compare_gt : x >>> y -> x =?= y = Gt.
  Proof.
    intros; destruct (compare_dec x y); auto.
    contradiction (lt_not_gt H1 H0).
    contradiction (gt_not_eq H0 H1).
  Qed.
End OrderLemmas.
Unset Implicit Arguments.

(** The following is the adaptation of the original [order] tactic
   developed by P. Letouzey in the original library. It should
   prove exactly the same goals, with a slight decrease in performance
   due to the extra implicit instance parameters.
   *)
Ltac normalize_notations :=
  match goal with
 | H : ?R ?x ?y |- _ =>
   progress ((change (x === y) in H) || (change (x <<< y) in H) ||
     (change (x >>> y) in H)); normalize_notations
 | H : ~(?R ?x ?y) |- _ =>
   progress ((change (x =/= y) in H) || (change (~ x <<< y) in H) ||
     (change (~ y <<< x) in H)); normalize_notations
 | |- ?R ?x ?y =>
   progress (change (x === y) || change (x <<< y) || change (y <<< x))
 | |- ~?R ?x ?y =>
   progress (change (x =/= y) || change (~x <<< y) || change (~y <<< x))
 | _ => idtac
  end.

Ltac abstraction := match goal with
 | H : False |- _ => elim H
 | H : ?x <<< ?x |- _ => elim (lt_antirefl H)
 | H : ?x =/= ?x |- _ => elim (H (reflexivity x))
 | H : ?x === ?x |- _ => clear H; abstraction
 | H : ~?x <<< ?x |- _ => clear H; abstraction
 | |- ?x === ?x => reflexivity
 | |- ?x <<< ?x => elimtype False; abstraction
 | |- ~ _ => intro; abstraction
 | H1: ~?x <<< ?y, H2: ?x =/= ?y |- _ =>
     generalize (le_neq H1 H2); clear H1 H2; intro; abstraction
 | H1: ~?x <<< ?y, H2: ?y =/= ?x |- _ =>
     symmetry in H2; generalize (le_neq H1 H2);
       clear H1 H2; intro; abstraction
 | H : ?x =/= ?y |- _ => revert H; abstraction
 | H : ~?x <<< ?y |- _ => revert H; abstraction
 | H : ?x <<< ?y |- _ => revert H; abstraction
 | H : ?x === ?y |- _ => revert H; abstraction
 | _ => idtac
end.

Ltac do_eq a b EQ := match goal with
 | |- ?x <<< ?y -> _ => let H := fresh "H" in
     (intro H;
      (generalize (eq_lt EQ H); clear H; intro H) ||
      (generalize (lt_eq H EQ); clear H; intro H) ||
      idtac);
      do_eq a b EQ
 | |- ~?x <<< ?y -> _ => let H := fresh "H" in
     (intro H;
      (generalize (eq_le (symmetry EQ) H); clear H; intro H) ||
      (generalize (le_eq H EQ); clear H; intro H) ||
      idtac);
      do_eq a b EQ
 | |- ?x === ?y -> _ => let H := fresh "H" in
     (intro H;
      (generalize (transitivity (symmetry EQ) H); clear H; intro H) ||
      (generalize (transitivity H EQ); clear H; intro H) ||
      idtac);
      do_eq a b EQ
 | |- ?x =/= ?y -> _ => let H := fresh "H" in
     (intro H;
      (generalize (eq_neq (symmetry EQ) H); clear H; intro H) ||
      (generalize (neq_eq H EQ); clear H; intro H) ||
      idtac);
      do_eq a b EQ
 | |- a <<< ?y => apply eq_lt with b; [exact (symmetry EQ)|]
 | |- ?y <<< a => apply lt_eq with b; [|exact (symmetry EQ)]
 | |- a === ?y => transitivity b; [exact EQ|]
 | |- ?y === a => transitivity b; [|exact (symmetry EQ)]
 | _ => idtac
 end.

Ltac propagate_eq := abstraction; match goal with
 | |- ?a === ?b -> _ =>
     let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ);
     propagate_eq
 | _ => idtac
end.

(* Example test `{OrderedType A} : *)
(*   forall (x x' x'' x''' y a b c d e f g h : A), *)
(*     x === x -> x === x' -> x' === x'' -> *)
(*     x =/= y -> b =/= x -> *)
(*     y >>> x -> c <<< x -> *)
(*     x'' === x''' -> *)
(*     ~a >>> x -> ~d <<< x -> *)
(*     e === x -> x === e -> *)
(*     f >>> x. *)
(* Proof. *)
(*   intros. *)
(*   propagate_eq. *)

Ltac do_lt x y LT := match goal with
 | |- x <<< y -> _ => intros _; do_lt x y LT
 | |- y <<< ?z -> _ => let H := fresh "H" in
     (intro H; generalize (transitivity LT H); intro); do_lt x y LT
 | |- ?z <<< x -> _ => let H := fresh "H" in
     (intro H; generalize (transitivity H LT); intro); do_lt x y LT
 | |- _ <<< _ -> _ => intro; do_lt x y LT

 | |- ~y <<< x -> _ => intros _; do_lt x y LT
 | |- ~x <<< ?z -> _ => let H := fresh "H" in
     (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT
 | |- ~?z <<< y -> _ => let H := fresh "H" in
     (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT
 | |- ~_ <<< _ -> _ => intro; do_lt x y LT
 | _ => idtac
 end.

Definition hide_lt `{StrictOrder A lt_ eq_} := lt_StrictOrder.

Ltac propagate_lt := abstraction; match goal with
 | |- ?x <<< ?y -> _ =>
     let LT := fresh "LT" in
       (intro LT; do_lt x y LT; change (hide_lt x y) in LT);
       propagate_lt
 | _ => unfold hide_lt in *
end.

Ltac order :=
 intros;
 normalize_notations;
 abstraction;
 propagate_eq;
 propagate_lt;
 auto;
 propagate_lt;
 eauto.

Ltac false_order := elimtype False; order.

Hint Extern 0 (_eq _ _) => reflexivity.
Hint Extern 0 (_ === _) => reflexivity.
Hint Extern 2 (_eq _ _) => symmetry; assumption.
Hint Extern 2 (_ === _) => symmetry; assumption.
Hint Extern 1 (Equivalence _) => constructor; congruence.
Hint Extern 1 (Equivalence _) => apply OT_Equivalence.
Hint Extern 1 (StrictOrder _) => apply OT_StrictOrder.
Hint Extern 1 (RelationClasses.StrictOrder _) =>
  constructor; repeat intro; order.
Hint Extern 1 (Proper _ _) => apply lt_m.
Hint Extern 1 (Proper _ _) => repeat intro; intuition order.

(** ** Specific Ordered types : [OrderedType] with specific equality

   Sometimes, one wants to consider ordered types where the equality
   has to be Leibniz equality or any other specific equality. Because there
   is no 'with' construct for  typeclasses, as there is for modules, we
   define another class for these types and show that such types
   also match [OrderedType]. An alternative would be to take the equality
   relation ouf of the [OrderedType] instance and add it as a parameter.
*)
Class SpecificOrderedType
  (A : Type) (eqA : relation A) := {
  SOT_Equivalence :> Equivalence eqA ;
  SOT_lt : relation A;
  SOT_StrictOrder : StrictOrder SOT_lt eqA;
  SOT_cmp : A -> A -> comparison;
  SOT_compare_spec : forall x y, compare_spec eqA SOT_lt x y (SOT_cmp x y)
}.
Instance SOT_as_OT `{SpecificOrderedType A} : OrderedType A := {
  _eq := eqA;
  OT_StrictOrder := SOT_StrictOrder;
  _compare_spec := SOT_compare_spec
}.
Instance SOT_SO_to_SO `{SpecificOrderedType A eqA} : StrictOrder SOT_lt eqA | 4.
Proof.
  intros; apply SOT_StrictOrder.
Defined.

(** ** Usual Ordered types : [OrderedType] with Leibniz equality

   A typical case is to require an instance of [OrderedType] where the equality
   is the Leibniz equality. We define the notation [UsualOrderedType] for that
   purpose.
   *)
Notation "'UsualOrderedType' A" :=
  (SpecificOrderedType A (@eq A))(at level 30).

(** * Facts about setoid list membership

   The remainer of this file correspond to the final section
   of the [OrderedTypeFacts] functor and the [KeyOrderedType] functor.
   They are used especially in [SetList] and [MapList].
   *)
Set Implicit Arguments. Unset Strict Implicit.
Section ForNotations.
  Import SetoidList.
  Notation In:=(InA _eq).
  Notation Inf:=(lelistA _lt).
  Notation Sort:=(sort _lt).
  Notation NoDup:=(NoDupA _eq).

  Context `{Helt : OrderedType elt}.
  Implicit Types x y : elt.

  Lemma In_eq : forall l x y, x === y -> In x l -> In y l.
  Proof. apply InA_eqA; eauto with typeclass_instances. Qed.

  Lemma ListIn_In : forall l x, List.In x l -> In x l.
  Proof. apply In_InA; eauto with typeclass_instances. Qed.

  Lemma Inf_lt : forall l x y, x <<< y -> Inf y l -> Inf x l.
  Proof.
    apply InfA_ltA; constructor; repeat intro; order.
  Qed.

  Lemma Inf_eq : forall l x y, x === y -> Inf y l -> Inf x l.
  Proof.
    apply InfA_eqA; eauto with typeclass_instances.
  Qed.

  Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> a <<< x.
  Proof.
    apply SortA_InfA_InA; eauto with typeclass_instances.
  Qed.

  Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> x <<< y) -> Inf x l.
  Proof. exact (@In_InfA _ _lt). Qed.

  Lemma In_Inf : forall l x, (forall y, In y l -> x <<< y) -> Inf x l.
  Proof.
    apply InA_InfA; eauto with typeclass_instances.
  Qed.

  Lemma Inf_alt :
    forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> x <<< y)).
  Proof.
    apply InfA_alt; eauto with typeclass_instances.
  Qed.

  Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
  Proof.
    apply SortA_NoDupA; eauto with typeclass_instances.
  Qed.
End ForNotations.
Unset Implicit Arguments.
Hint Resolve @ListIn_In @Sort_NoDup @Inf_lt.
Hint Immediate @In_eq @Inf_lt.

Module KeyOrderedType.
Section KeyOrderedType.
  Import SetoidList.
  Set Implicit Arguments.
  Unset Strict Implicit.

  Variable key : Type.
  Hypothesis (key_OT : OrderedType key).
  Variable elt : Type.

  Definition eqk (p p':key*elt) := fst p === fst p'.
  Definition eqke (p p':key*elt) :=
    fst p === fst p' /\ (snd p) = (snd p').
  Definition ltk (p p':key*elt) := fst p <<< fst p'.

  Local Instance eqk_Equiv : Equivalence eqk.
  Proof.
    constructor; repeat intro; unfold eqk in *; eauto. order.
  Qed.
  Local Instance eqke_Equiv : Equivalence eqke.
  Proof.
    constructor; repeat intro; unfold eqke in *; intuition; order.
  Qed.
  Local Instance ltk_SO : RelationClasses.StrictOrder ltk.
  Proof.
    constructor; repeat intro; unfold ltk in *; intuition order.
  Qed.
  Local Instance ltk_m : Proper (eqk ==> eqk ==> iff) ltk.
  Proof.
    repeat intro; unfold ltk, eqk in *; intuition order.
  Qed.
  Ltac teauto := eauto with typeclass_instances.

  Hint Unfold eqk eqke ltk.
  Hint Extern 2 (eqke ?a ?b) => split.

  (* eqke is stricter than eqk *)
  Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
  Proof.
    unfold eqk, eqke; intuition.
  Qed.

  (* ltk ignore the second components *)
  Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e').
  Proof. auto. Qed.

  Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x.
  Proof. auto. Qed.
  Hint Immediate ltk_right_r ltk_right_l.

  (* eqk, eqke are equalities, ltk is a strict order *)
  Lemma eqk_refl : forall e, eqk e e.
  Proof. auto. Qed.

  Lemma eqke_refl : forall e, eqke e e.
  Proof. auto. Qed.

  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
  Proof. auto. Qed.

  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
  Proof. unfold eqke; intuition. Qed.

  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
  Proof.
    intros; unfold eqk in *; auto; transitivity (fst e'); auto.
  Qed.

  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
  Proof.
    unfold eqke; intuition; [ order | congruence ].
  Qed.

  Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''.
  Proof.
    intros; unfold ltk in *; auto; transitivity (fst e'); auto.
  Qed.

  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
  Proof.
    unfold eqk, ltk; auto; intros; apply lt_not_eq; auto.
  Qed.

  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
  Proof.
    unfold eqke, ltk; intuition; simpl in *; subst.
    exact (lt_not_eq H H1).
  Qed.

  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
  Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
  Hint Immediate eqk_sym eqke_sym.

  (* Additionnal facts *)

  Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'.
  Proof.
    unfold eqk, ltk; simpl; auto.
    intros; apply eq_not_lt; auto.
  Qed.

  Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''.
  Proof.
    intros; unfold ltk, eqk in *; auto; order.
  Qed.

  Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''.
  Proof.
      intros (k,e) (k',e') (k'',e'').
      unfold ltk, eqk; simpl; eauto; order.
  Qed.
  Hint Resolve eqk_not_ltk.
  Hint Immediate ltk_eqk eqk_ltk.

  Lemma InA_eqke_eqk :
     forall x m, InA eqke x m -> InA eqk x m.
  Proof.
    unfold eqke; induction 1; intuition.
  Qed.
  Hint Resolve InA_eqke_eqk.

  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
  Definition In k m := exists e:elt, MapsTo k e m.
  Notation Sort := (sort ltk).
  Notation Inf := (lelistA ltk).

  Hint Unfold MapsTo In.

  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
  Proof.
    firstorder.
    exists x; auto.
    induction H.
    destruct y.
    exists e; auto.
    destruct IHInA as [e H0].
    exists e; auto.
  Qed.

  Lemma MapsTo_eq : forall l x y e, x === y -> MapsTo x e l -> MapsTo y e l.
  Proof.
    intros; unfold MapsTo in *; apply InA_eqA with (x,e); teauto.
  Qed.

  Lemma In_eq : forall l x y, x === y -> In x l -> In y l.
  Proof.
    destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
  Qed.

  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
  Proof. apply InfA_eqA; teauto. Qed.

  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
  Proof. apply InfA_ltA; teauto. Qed.

  Hint Immediate Inf_eq.
  Hint Resolve Inf_lt.

  Lemma Sort_Inf_In :
      forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
  Proof.
    apply SortA_InfA_InA; teauto.
  Qed.

  Lemma Sort_Inf_NotIn :
      forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
  Proof.
    intros; red; intros.
    destruct H1 as [e' H2].
    elim (@ltk_not_eqk (k,e) (k,e')).
    eapply Sort_Inf_In; eauto.
    red; simpl; auto.
  Qed.

  Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
  Proof.
    apply SortA_NoDupA; teauto.
  Qed.

  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
  Proof.
   inversion 1; intros; eapply Sort_Inf_In; eauto.
  Qed.

  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
      ltk e e' \/ eqk e e'.
  Proof.
    inversion_clear 2; auto.
    left; apply Sort_In_cons_1 with l; auto.
  Qed.

  Lemma Sort_In_cons_3 :
    forall x l k e, Sort ((k,e)::l) -> In x l -> x =/= k.
  Proof.
    inversion_clear 1; red; intros.
    exact (Sort_Inf_NotIn H0 H1 (In_eq H2 H)).
  Qed.

  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> k === k' \/ In k l.
  Proof.
    inversion 1.
    inversion_clear H0; eauto.
    destruct H1; simpl in *; intuition.
  Qed.

  Lemma In_inv_2 : forall k k' e e' l,
      InA eqk (k, e) ((k', e') :: l) -> k =/= k' -> InA eqk (k, e) l.
  Proof.
   inversion_clear 1; unfold eqk in H0; simpl in H0; order.
  Qed.

  Lemma In_inv_3 : forall x x' l,
      InA eqke x (x' :: l) -> ~eqk x x' -> InA eqke x l.
  Proof.
   inversion_clear 1; compute in H0; intuition.
  Qed.

End KeyOrderedType.
Hint Unfold eqk eqke ltk.
Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
Hint Immediate eqk_sym eqke_sym.
Hint Resolve eqk_not_ltk.
Hint Immediate ltk_eqk eqk_ltk.
Hint Resolve InA_eqke_eqk.
Hint Unfold MapsTo In.
Hint Immediate Inf_eq.
Hint Resolve Inf_lt.
Hint Resolve Sort_Inf_NotIn.
Hint Resolve In_inv_2 In_inv_3.

Arguments eqk {key key_OT elt}.
Arguments eqke {key key_OT elt}.
Arguments ltk {key key_OT elt}.
Arguments MapsTo {key key_OT elt}.
Arguments In {key key_OT elt}.
End KeyOrderedType.