(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* Finite sets library.
 * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
 * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
 *              91405 Orsay, France *)

(* $Id$ *)

Require Import Bool.
Require Import NArith Ndigits Ndec Nnat.
Require Import Allmaps.
Require Import OrderedType.
Require Import OrderedTypeEx.
Require Import FMapInterface FMapList.

Set Implicit Arguments.

(** * An implementation of [FMapInterface.S] based on [IntMap] *)

(** Keys are of type [N]. The main functions are directly taken from
  [IntMap]. Since they have no exact counterpart in [IntMap], functions
  [fold], [map2] and [equal] are for now obtained by translation
  to sorted lists. *)

(** [N] is an ordered type, using not the usual order on numbers,
   but lexicographic ordering on bits (lower bit considered first). *)

Module NUsualOrderedType <: UsualOrderedType.
  Definition t:=N.
  Definition eq:=@eq N.
  Definition eq_refl := @refl_equal t.
  Definition eq_sym := @sym_eq t.
  Definition eq_trans := @trans_eq t.

  Definition lt p q:= Nless p q = true.

  Definition lt_trans := Nless_trans.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros; intro.
  rewrite H0 in H.
  red in H.
  rewrite Nless_not_refl in H; discriminate.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
  intros x y.
  destruct (Nless_total x y) as [[H|H]|H].
  apply LT; unfold lt; auto.
  apply GT; unfold lt; auto.
  apply EQ; auto.
  Qed.

  Definition eq_dec := N_as_OT.eq_dec.

End NUsualOrderedType.

(** The module of maps over [N] keys based on [IntMap] *)

Module MapIntMap <: S with Module E:=NUsualOrderedType.

  Module E:=NUsualOrderedType.
  Module ME:=OrderedTypeFacts(E).
  Module PE:=KeyOrderedType(E).

  Definition key := N.

  Definition t := Map.

  Section A.
  Variable A:Type.

  Definition empty : t A := M0 A.

  Definition is_empty (m : t A) : bool :=
    MapEmptyp _ (MapCanonicalize _ m).

  Definition find (x:key)(m: t A) : option A := MapGet _ m x.

  Definition mem (x:key)(m: t A) : bool :=
    match find x m with
     | Some _ => true
     | None => false
    end.

  Definition add (x:key)(v:A)(m:t A) : t A := MapPut _ m x v.

  Definition remove (x:key)(m:t A) : t A := MapRemove _ m x.

  Definition elements (m : t A) : list (N*A) := alist_of_Map _ m.

  Definition cardinal (m : t A) : nat := MapCard _ m.

  Definition MapsTo (x:key)(v:A)(m:t A) := find x m = Some v.

  Definition In (x:key)(m:t A) := exists e:A, MapsTo x e m.

  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.

  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').

  Definition eq_key_elt (p p':key*A) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').

  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
  Proof.
  unfold Empty, MapsTo.
  intuition.
  generalize (H a).
  destruct (find a m); intuition.
  elim (H0 a0); auto.
  rewrite H in H0; discriminate.
  Qed.

  Section Spec.
  Variable  m m' m'' : t A.
  Variable x y z : key.
  Variable e e' : A.

  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros; rewrite <- H; auto. Qed.

  Lemma find_1 : MapsTo x e m -> find x m = Some e.
  Proof. unfold MapsTo; auto. Qed.

  Lemma find_2 : find x m = Some e -> MapsTo x e m.
  Proof. red; auto. Qed.

  Lemma empty_1 : Empty empty.
  Proof.
  rewrite Empty_alt; intros; unfold empty, find; simpl; auto.
  Qed.

  Lemma is_empty_1 : Empty m -> is_empty m = true.
  Proof.
  unfold Empty, is_empty, find; intros.
  cut (MapCanonicalize _ m = M0 _).
  intros; rewrite H0; simpl; auto.
  apply mapcanon_unique.
  apply mapcanon_exists_2.
  constructor.
  red; red; simpl; intros.
  rewrite <- (mapcanon_exists_1 _ m).
  unfold MapsTo, find in *.
  generalize (H a).
  destruct (MapGet _ m a); auto.
  intros; generalize (H0 a0); destruct 1; auto.
  Qed.

  Lemma is_empty_2 : is_empty m = true -> Empty m.
  Proof.
  unfold Empty, is_empty, MapsTo, find; intros.
  generalize (MapEmptyp_complete _ _ H); clear H; intros.
  rewrite (mapcanon_exists_1 _ m).
  rewrite H; simpl; auto.
  discriminate.
  Qed.

  Lemma mem_1 : In x m -> mem x m = true.
  Proof.
  unfold In, MapsTo, mem.
  destruct (find x m); auto.
  destruct 1; discriminate.
  Qed.

  Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof.
  unfold In, MapsTo, mem.
  intros.
  destruct (find x0 m0); auto; try discriminate.
  exists a; auto.
  Qed.

  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
  Proof.
  unfold MapsTo, find, add.
  intro H; rewrite H; clear H.
  rewrite MapPut_semantics.
  rewrite Neqb_correct; auto.
  Qed.

  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
  unfold MapsTo, find, add.
  intros.
  rewrite MapPut_semantics.
  rewrite H0.
  generalize (Neqb_complete x y).
  destruct (Neqb x y); auto.
  intros.
  elim H; auto.
  apply H1; auto.
  Qed.

  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
  unfold MapsTo, find, add.
  rewrite MapPut_semantics.
  intro H.
  generalize (Neqb_complete x y).
  destruct (Neqb x y); auto.
  intros; elim H; auto.
  apply H0; auto.
  Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
  Proof.
  unfold In, MapsTo, find, remove.
  rewrite MapRemove_semantics.
  intro H.
  rewrite H; rewrite Neqb_correct.
  red; destruct 1; discriminate.
  Qed.

  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
  unfold MapsTo, find, remove.
  rewrite MapRemove_semantics.
  intros.
  rewrite H0.
  generalize (Neqb_complete x y).
  destruct (Neqb x y); auto.
  intros; elim H; apply H1; auto.
  Qed.

  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
  unfold MapsTo, find, remove.
  rewrite MapRemove_semantics.
  destruct (Neqb x y); intros; auto.
  discriminate.
  Qed.

  Lemma alist_sorted_sort : forall l, alist_sorted A l=true -> sort lt_key l.
  Proof.
  induction l.
  auto.
  simpl.
  destruct a.
  destruct l.
  auto.
  destruct p.
  intros; destruct (andb_prop _ _ H); auto.
  Qed.

  Lemma elements_3 : sort lt_key (elements m).
  Proof.
  unfold elements.
  apply alist_sorted_sort.
  apply alist_of_Map_sorts.
  Qed.

  Lemma elements_3w : NoDupA eq_key (elements m).
  Proof.
  change eq_key with (@PE.eqk A).
  apply PE.Sort_NoDupA; apply elements_3; auto.
  Qed.

  Lemma elements_1 :
     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
  unfold MapsTo, find, elements.
  rewrite InA_alt.
  intro H.
  exists (x,e).
  split.
  red; simpl; unfold E.eq; auto.
  rewrite alist_of_Map_semantics in H.
  generalize H.
  set (l:=alist_of_Map A m); clearbody l; clear.
  induction l; simpl; auto.
  intro; discriminate.
  destruct a; simpl; auto.
  generalize (Neqb_complete a x).
  destruct (Neqb a x); auto.
  left.
  injection H0; auto.
  intros; f_equal; auto.
  Qed.

  Lemma elements_2 :
     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
  generalize elements_3.
  unfold MapsTo, find, elements.
  rewrite InA_alt.
  intros H ((e0,a),(H0,H1)).
  red in H0; simpl in H0; unfold E.eq in H0; destruct H0; subst.
  rewrite alist_of_Map_semantics.
  generalize H H1; clear H H1.
  set (l:=alist_of_Map A m); clearbody l; clear.
  induction l; simpl; auto.
  intro; contradiction.
  intros.
  destruct a0; simpl.
  inversion H1.
  injection H0; intros; subst.
  rewrite Neqb_correct; auto.
  assert (InA eq_key (e0,a) l).
  rewrite InA_alt.
  exists (e0,a); split; auto.
  red; simpl; auto; red; auto.
  generalize (PE.Sort_In_cons_1 H H2).
  unfold PE.ltk; simpl.
  intros H3; generalize (E.lt_not_eq H3).
  generalize (Neqb_complete a0 e0).
  destruct (Neqb a0 e0); auto.
  destruct 2.
  apply H4; auto.
  inversion H; auto.
  Qed.

  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. exact (@MapCard_as_length _). Qed.

  Definition Equal m m' := forall y, find y m = find y m'.
  Definition Equiv (eq_elt:A->A->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb (cmp: A->A->bool) := Equiv (Cmp cmp).

  (** unfortunately, the [MapFold] of [IntMap] isn't compatible with
   the FMap interface. We use a naive version for now : *)

  Definition fold (B:Type)(f:key -> A -> B -> B)(m:t A)(i:B) : B :=
    fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.

  Lemma fold_1 :
	forall (B:Type) (i : B) (f : key -> A -> B -> B),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. auto. Qed.

  End Spec.

  Variable B : Type.

  Fixpoint mapi_aux (pf:N->N)(f : N -> A -> B)(m:t A) { struct m }: t B :=
    match m with
      | M0 => M0 _
      | M1 x y => M1 _ x (f (pf x) y)
      | M2 m0 m1 =>  M2 _ (mapi_aux (fun n => pf (Ndouble n)) f m0)
                                         (mapi_aux (fun n => pf (Ndouble_plus_one n)) f m1)
    end.

  Definition mapi := mapi_aux (fun n => n).

  Definition map (f:A->B) := mapi (fun _ => f).

  End A.

  Lemma mapi_aux_1 : forall (elt elt':Type)(m: t elt)(pf:N->N)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f (pf y) e) (mapi_aux pf f m).
  Proof.
  unfold MapsTo; induction m; simpl; auto.
  inversion 1.

  intros.
  exists x; split; [red; auto|].
  generalize (Neqb_complete a x).
  destruct (Neqb a x); try discriminate.
  injection H; intros; subst; auto.
  rewrite H1; auto.

  intros.
  exists x; split; [red;auto|].
  destruct x; simpl in *.
  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
  rewrite Hy in Hy'; simpl in Hy'; auto.
  destruct p; simpl in *.
  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
  rewrite Hy in Hy'; simpl in Hy'; auto.
  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
  rewrite Hy in Hy'; simpl in Hy'; auto.
  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
  rewrite Hy in Hy'; simpl in Hy'; auto.
  Qed.

  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof.
  intros elt elt' m; exact (mapi_aux_1 (fun n => n)).
  Qed.

  Lemma mapi_aux_2 : forall (elt elt':Type)(m: t elt)(pf:N->N)(x:key)
        (f:key->elt->elt'), In x (mapi_aux pf f m) -> In x m.
  Proof.
  unfold In, MapsTo.
  induction m; simpl in *.
  intros pf x f (e,He); inversion He.
  intros pf x f (e,He).
  exists a0.
  destruct (Neqb a x); try discriminate; auto.
  intros pf x f (e,He).
  destruct x; [|destruct p]; eauto.
  Qed.

  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.
  Proof.
  intros elt elt' m. exact (@mapi_aux_2 _ elt' m (fun n => n)).
  Qed.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof.
  unfold map; intros.
  destruct (@mapi_1 _ _ m x e (fun _ => f)) as (e',(_,H0)); auto.
  Qed.

  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.
  Proof.
  unfold map; intros.
  eapply mapi_2; eauto.
  Qed.

  Module L := FMapList.Raw E.

  (** Not exactly pretty nor perfect, but should suffice as a first naive implem.
    Anyway, map2 isn't in Ocaml...
  *)

  Definition anti_elements (A:Type)(l:list (key*A)) := L.fold (@add _) l (empty _).

  Definition map2 (A B C:Type)(f:option A->option B -> option C)(m:t A)(m':t B) : t C :=
    anti_elements (L.map2 f (elements m) (elements m')).

  Lemma add_spec : forall (A:Type)(m:t A) x y e,
    find x (add y e m) = if E.eq_dec x y then Some e else find x m.
  Proof.
  intros.
  destruct (E.eq_dec x y).
  apply find_1.
  eapply MapsTo_1 with y; eauto.
  red; auto.
  apply add_1; auto.
  red; auto.
  case_eq (find x m); intros.
  apply find_1.
  apply add_2; unfold E.eq in *; auto.
  case_eq (find x (add y e m)); auto; intros.
  rewrite <- H; symmetry.
  apply find_1; auto.
  apply (@add_3 _ m y x a e); unfold E.eq in *; auto.
  Qed.

  Lemma anti_elements_mapsto_aux : forall (A:Type)(l:list (key*A)) m k e,
    NoDupA (eq_key (A:=A)) l ->
    (forall x, L.PX.In x l -> In x m -> False) ->
    (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m).
  Proof.
  induction l.
  simpl; auto.
  intuition.
  inversion H2.
  simpl; destruct a; intros.
  inversion_clear H.
  rewrite IHl; clear IHl; auto.
  intuition.
  red in H3.
  rewrite add_spec in H3; auto.
  destruct (E.eq_dec k0 k).
  inversion_clear H3; subst; auto.
  right; apply find_2; auto.
  inversion_clear H3; auto.
  compute in H; destruct H.
  subst; right; apply add_1; auto.
  red; auto.
  destruct (E.eq_dec k0 k) as [H|H].
  subst.
  destruct (H0 k); eauto.
  red; eauto.
  right; apply add_2; unfold E.eq in *; auto.
  (* proof of precondition of IHl *)
  intros.
  assert (~E.eq x k).
   contradict H1.
   destruct H.
   apply InA_eqA with (x,x0); eauto with *.
  apply (H0 x).
  destruct H; exists x0; auto.
  revert H3.
  unfold In.
  intros (e',He').
  exists e'; apply (@add_3 _ m k x e' a); unfold E.eq; auto.
  Qed.

  Lemma anti_elements_mapsto : forall (A:Type) l k e, NoDupA (eq_key (A:=A)) l ->
    (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l).
  Proof.
  intros.
  unfold anti_elements.
  rewrite anti_elements_mapsto_aux; auto; unfold empty; auto.
  intuition.
  inversion H1.
  inversion 2.
  inversion H2.
  Qed.

  Lemma find_anti_elements : forall (A:Type)(l: list (key*A)) x, sort (@lt_key _) l ->
    find x (anti_elements l) = L.find x l.
  Proof.
  intros.
  case_eq (L.find x l); intros.
  apply find_1.
  rewrite anti_elements_mapsto; auto using L.PX.Sort_NoDupA, L.find_2.
  case_eq (find x (anti_elements l)); auto; intros.
  rewrite <- H0; symmetry.
  apply L.find_1; auto.
  rewrite <- anti_elements_mapsto; auto using L.PX.Sort_NoDupA, find_2.
  Qed.

  Lemma find_elements : forall (A:Type)(m: t A) x,
    L.find x (elements m) = find x m.
  Proof.
  intros.
  case_eq (find x m); intros.
  apply L.find_1.
  apply elements_3; auto.
  red; apply elements_1.
  apply find_2; auto.
  case_eq (L.find x (elements m)); auto; intros.
  rewrite <- H; symmetry.
  apply find_1; auto.
  apply elements_2.
  apply L.find_2; auto.
  Qed.

  Lemma elements_in : forall (A:Type)(s:t A) x, L.PX.In x (elements s) <-> In x s.
  Proof.
   intros.
   unfold L.PX.In, In.
   firstorder.
   exists x0.
   red; rewrite <- find_elements; auto.
   apply L.find_1; auto.
   apply elements_3.
   exists x0.
   apply L.find_2.
   rewrite find_elements; auto.
  Qed.

  Lemma map2_1 : forall (A B C:Type)(m: t A)(m': t B)(x:key)
    (f:option A->option B ->option C),
    In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m').
  Proof.
  unfold map2; intros.
  rewrite find_anti_elements; auto.
  rewrite <- find_elements; auto.
  rewrite <- find_elements; auto.
  apply L.map2_1; auto.
  apply elements_3; auto.
  apply elements_3; auto.
  do 2 rewrite elements_in; auto.
  apply L.map2_sorted; auto.
  apply elements_3; auto.
  apply elements_3; auto.
  Qed.

  Lemma map2_2 : forall (A B C:Type)(m: t A)(m': t B)(x:key)
      (f:option A->option B ->option C),
    In x (map2 f m m') -> In x m \/ In x m'.
  Proof.
  unfold map2; intros.
  do 2 rewrite <- elements_in.
  apply L.map2_2 with (f:=f); auto.
  apply elements_3; auto.
  apply elements_3; auto.
  destruct H.
  exists x0.
  rewrite <- anti_elements_mapsto; auto.
  apply L.PX.Sort_NoDupA; auto.
  apply L.map2_sorted; auto.
  apply elements_3; auto.
  apply elements_3; auto.
  Qed.

  (** same trick for [equal] *)

  Definition equal (A:Type)(cmp:A -> A -> bool)(m m' : t A) : bool :=
    L.equal cmp (elements m) (elements m').

  Lemma equal_1 :
    forall (A:Type)(m: t A)(m': t A)(cmp: A -> A -> bool),
    Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
  unfold equal, Equivb, Equiv, Cmp.
  intros.
  apply L.equal_1.
  apply elements_3.
  apply elements_3.
  unfold L.Equivb.
  destruct H.
  split; intros.
  do 2 rewrite elements_in; auto.
  apply (H0 k);
    red; rewrite <- find_elements; apply L.find_1; auto;
    apply elements_3.
  Qed.

  Lemma equal_2 :
    forall (A:Type)(m: t A)(m': t A)(cmp: A -> A -> bool),
    equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
  unfold equal, Equivb, Equiv, Cmp.
  intros.
  destruct (L.equal_2 (elements_3 m) (elements_3 m') H); clear H.
  split.
  intros; do 2 rewrite <- elements_in; auto.
  intros; apply (H1 k);
    apply L.find_2; rewrite find_elements;auto.
  Qed.

End MapIntMap.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Properties of [abs] and [sgn] *)

Require Import ZMulOrder.

(** Since we already have [max], we could have defined [abs]. *)

Module GenericAbs (Import Z : ZAxiomsMiniSig')
                  (Import ZP : ZMulOrderProp Z) <: HasAbs Z.
 Definition abs n := max n (-n).
 Lemma abs_eq : forall n, 0<=n -> abs n == n.
 Proof.
  intros. unfold abs. apply max_l.
  apply le_trans with 0; auto.
  rewrite opp_nonpos_nonneg; auto.
 Qed.
 Lemma abs_neq : forall n, n<=0 -> abs n == -n.
 Proof.
  intros. unfold abs. apply max_r.
  apply le_trans with 0; auto.
  rewrite opp_nonneg_nonpos; auto.
 Qed.
End GenericAbs.

(** We can deduce a [sgn] function from a [compare] function *)

Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare.
Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare.

Module Type GenericSgn (Import Z : ZDecAxiomsSig')
                       (Import ZP : ZMulOrderProp Z) <: HasSgn Z.
 Definition sgn n :=
  match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end.
 Lemma sgn_null : forall n, n==0 -> sgn n == 0.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_pos : forall n, 0<n -> sgn n == 1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_neg : forall n, n<0 -> sgn n == -1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
End GenericSgn.

(** Derived properties of [abs] and [sgn] *)

Module Type ZSgnAbsProp (Import Z : ZAxiomsSig')
                        (Import ZP : ZMulOrderProp Z).

Ltac destruct_max n :=
 destruct (le_ge_cases 0 n);
  [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto].

Instance abs_wd : Proper (eq==>eq) abs.
Proof.
 intros x y EQ. destruct_max x.
 rewrite abs_eq; trivial. now rewrite <- EQ.
 rewrite abs_neq; try order. now rewrite opp_inj_wd.
Qed.

Lemma abs_max : forall n, abs n == max n (-n).
Proof.
 intros n. destruct_max n.
 rewrite max_l; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonpos_nonneg; auto.
 rewrite max_r; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonneg_nonpos; auto.
Qed.

Lemma abs_neq' : forall n, 0<=-n -> abs n == -n.
Proof.
 intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos.
Qed.

Lemma abs_nonneg : forall n, 0 <= abs n.
Proof.
 intros n. destruct_max n; auto.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n.
Proof.
 split; try apply abs_eq. intros EQ.
 rewrite <- EQ. apply abs_nonneg.
Qed.

Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0.
Proof.
 split; try apply abs_neq. intros EQ.
 rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg.
Qed.

Lemma abs_opp : forall n, abs (-n) == abs n.
Proof.
 intros. destruct_max n.
 rewrite (abs_neq (-n)), opp_involutive. reflexivity.
 now rewrite opp_nonpos_nonneg.
 rewrite (abs_eq (-n)). reflexivity.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_0 : abs 0 == 0.
Proof.
 apply abs_eq. apply le_refl.
Qed.

Lemma abs_0_iff : forall n, abs n == 0 <-> n==0.
Proof.
 split. destruct_max n; auto.
 now rewrite eq_opp_l, opp_0.
 intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl.
Qed.

Lemma abs_pos : forall n, 0 < abs n <-> n~=0.
Proof.
 intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ].
 intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0).
 assert (LE : 0 <= abs n) by apply abs_nonneg.
 rewrite lt_eq_cases in LE; destruct LE; auto.
 elim NEQ; auto with relations.
Qed.

Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n.
Proof.
 intros. destruct_max n; auto with relations.
Qed.

Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n.
Proof.
 intros. destruct_max n; rewrite ? opp_involutive; auto with relations.
Qed.

Lemma abs_involutive : forall n, abs (abs n) == abs n.
Proof.
 intros. apply abs_eq. apply abs_nonneg.
Qed.

Lemma abs_spec : forall n,
  (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n).
Proof.
 intros. destruct (le_gt_cases 0 n).
 left; split; auto. now apply abs_eq.
 right; split; auto. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_case_strong :
  forall (P:t->Prop) n, Proper (eq==>iff) P ->
    (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n).
Proof.
 intros. destruct_max n; auto.
Qed.

Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P ->
 P n -> P (-n) -> P (abs n).
Proof. intros. now apply abs_case_strong. Qed.

Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m.
Proof.
 intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn].
 rewrite EQn, EQ. apply abs_eq_or_opp.
 rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp.
Qed.

Lemma abs_lt : forall a b, abs a < b <-> -b < a < b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_neg_pos; order.
 rewrite opp_lt_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
Qed.

Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
 rewrite opp_le_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply le_trans with 0. order. apply opp_nonpos_nonneg; order.
Qed.

(** Triangular inequality *)

Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m.
Proof.
 intros. destruct_max n; destruct_max m.
 rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 rewrite abs_neq, opp_add_distr. apply le_refl.
 now apply add_nonpos_nonpos.
Qed.

Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m).
Proof.
 intros.
 rewrite le_sub_le_add_l, add_comm.
 rewrite <- (sub_simpl_r n m) at 1.
 apply abs_triangle.
Qed.

(** Absolute value and multiplication *)

Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m.
Proof.
 assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m).
  intros. destruct_max m.
  rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg.
  rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos .
 intros. destruct_max n. now apply H.
 rewrite <- mul_opp_opp, H, abs_opp. reflexivity.
 now apply opp_nonneg_nonpos.
Qed.

Lemma abs_square : forall n, abs n * abs n == n * n.
Proof.
 intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square.
Qed.

(** Some results about the sign function. *)

Ltac destruct_sgn n :=
 let LT := fresh "LT" in
 let EQ := fresh "EQ" in
 let GT := fresh "GT" in
 destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]];
 [rewrite (sgn_pos n) by auto|
  rewrite (sgn_null n) by auto with relations|
  rewrite (sgn_neg n) by auto].

Instance sgn_wd : Proper (eq==>eq) sgn.
Proof.
 intros x y Hxy. destruct_sgn x.
 rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto.
 rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations.
 rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto.
Qed.

Lemma sgn_spec : forall n,
  0 < n /\ sgn n == 1 \/
  0 == n /\ sgn n == 0 \/
  0 > n /\ sgn n == -1.
Proof.
 intros n.
 destruct_sgn n; [left|right;left|right;right]; auto with relations.
Qed.

Lemma sgn_0 : sgn 0 == 0.
Proof.
 now apply sgn_null.
Qed.

Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n.
Proof.
 split; try apply sgn_pos. destruct_sgn n; auto.
 intros. elim (lt_neq 0 1); auto. apply lt_0_1.
 intros. elim (lt_neq (-1) 1); auto.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
Qed.

Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0.
Proof.
 split; try apply sgn_null. destruct_sgn n; auto with relations.
 intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0.
Proof.
 split; try apply sgn_neg. destruct_sgn n; auto with relations.
 intros. elim (lt_neq (-1) 1); auto with relations.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto with relations.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_opp : forall n, sgn (-n) == - sgn n.
Proof.
 intros. destruct_sgn n.
 apply sgn_neg. now rewrite opp_neg_pos.
 setoid_replace n with 0 by auto with relations.
  rewrite opp_0. apply sgn_0.
 rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg.
Qed.

Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n.
Proof.
 split.
 destruct_sgn n; intros.
 now apply lt_le_incl.
 order.
 elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1.
  now rewrite <- opp_nonneg_nonpos.
 rewrite lt_eq_cases; destruct 1.
 rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1.
 rewrite sgn_null by auto with relations. apply le_refl.
Qed.

Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0.
Proof.
 intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg.
Qed.

Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m.
Proof.
 intros. destruct_sgn n; nzsimpl.
 destruct_sgn m.
  apply sgn_pos. now apply mul_pos_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_neg. now apply mul_pos_neg.
 apply sgn_null. rewrite eq_mul_0; auto with relations.
 destruct_sgn m; try rewrite mul_opp_opp; nzsimpl.
  apply sgn_neg. now apply mul_neg_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_pos. now apply mul_neg_neg.
Qed.

Lemma sgn_abs : forall n, n * sgn n == abs n.
Proof.
 intros. symmetry.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl.
 apply abs_eq. now apply lt_le_incl.
 rewrite abs_0_iff; auto with relations.
 apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_sgn : forall n, abs n * sgn n == n.
Proof.
 intros.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto.
 apply abs_eq. now apply lt_le_incl.
 rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x.
Proof.
 intros.
 destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
 apply sgn_pos, lt_0_1.
 now apply sgn_null.
 apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1.
Qed.

End ZSgnAbsProp.


Variables A B C : Prop.
Lemma ex5 : (A -> B -> C) -> ((A /\ B) -> C).
Proof.
  intro Ha_implies_Hb_implies_Hc.
  intro Ha_and_Hb.
  destruct Ha_and_Hb as [Ha Hb].
  apply Ha_implies_Hb_implies_Hc.
    +
      assumption.
    +
      assumption.
Qed.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  x0 * x3 * (0 - x0 + x1 + x2 - x3 + x4 + x5)
  + x1 * x4 * (x0 - x1 + x2 + x3 - x4 + x5)
  + x2 * x5 * (x0 + x1 - x2 + x3 + x4 - x5) - x1 * x2 * x3 - x0 * x2 * x4
  - x0 * x1 * x5 - x3 * x4 * x5.

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 4/1) * (63504/10000 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 4/1) * (63504/10000 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 4/1) * (63504/10000 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 4/1) * (63504/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 4/1) * (63504/10000 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 4/1) * (63504/10000 - x5).

Theorem p_nonneg (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  p x0 x1 x2 x3 x4 x5 >= 0.
Proof.
unfold b1, b2, b3, b4, b5, b6, p.
validsdp.
Qed.


Require Import Frap Pset1Sig.

Theorem another_important_theorem : length [1; 2; 3] = 1 + length [4; 5].
Proof.
simplify.
equality.
Qed.

Theorem length_concat : forall A (xs ys : list A),
    length (xs ++ ys) = length xs + length ys.
Proof.

 intros A.
 induction xs.
 intros ys.
 simplify.
 equality.
 intros ys.
 simplify.
 rewrite IHxs.
 equality.
Qed.

Theorem length_rev : forall A (xs : list A),
    length xs = length (rev xs).
Proof.
 induction xs; simpl; auto.
 rewrite length_concat.
 rewrite IHxs.
 simplify.
 intuition.
Qed.


Definition N := 19.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


Require Import ssr.
Require Import lib.
Require Import withzero.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope dnat_scope.

Module Type GALOIS.

  (* -------------------------------------------------------------------------- *)
  (*  Rings                                                                     *)
  (* -------------------------------------------------------------------------- *)

   Section Ring.

    Section Axioms.

      Variable d' : eqType.
      Notation d := (withzeroData d').
      Notation "0" := (@Zero _).

      Definition lift_opp (f:d'->d') x :=
        match x with
          | Zero => 0
          | Nz x => Nz (f x)
        end.

      Definition lift_add (add:d'->d'->d) x y :=
        match x, y with
          | Zero, _ => y
          | _, Zero => x
          | Nz x, Nz y => add x y
        end.

      Definition lift_mul (mul:d'->d'->d) x y :=
        match x, y with
          | Nz x, Nz y => mul x y
          | _, _ => 0
        end.

      Variable addr' : d'->d'->d.
      Variable mulr' : d'->d'->d.
      Variable oppr' : d'->d'.
      Variable oner' : d'.

      Notation "x1 + x2" := (lift_add addr' x1 x2).
      Notation "x1 * x2" := (lift_mul mulr' x1 x2).
      Notation "- x" := (lift_opp oppr' x).
      Notation "1" := (Nz oner').

      Structure ring_axioms : Type := Ring_axioms {
        addC'    : forall x1 x2, x1 + x2 = x2 + x1;
        addA'    : forall x1 x2 x3, x1 + (x2 + x3) = (x1 + x2) + x3;
        oppL'    : forall x,  - x + x = 0;
        mulC'    : forall x1 x2, x1 * x2 = x2 * x1;
        mulA'    : forall x1 x2 x3, x1 * (x2 * x3) = x1 * x2 * x3;
        mul1r'   : forall x, 1 * x = x;
        distPM'  : forall x1 x2 x3, (x1 + x2) * x3 = x1 * x3 + x2 * x3;
        distMP'  : forall x1 x2 x3, x1 * (x2 + x3) = x1 * x2 + x1 * x3
      }.

    End Axioms.

    Structure ring : Type := Ring {
      rbase'    : eqType;
      addr'     : rbase' -> rbase' -> withzero rbase';
      oppr'     : rbase' -> rbase';
      oner'     : rbase';
      mulr'     : rbase' -> rbase' -> withzero rbase';
      axioms    : ring_axioms addr' mulr' oppr' oner'
    }.

    Definition rbase r := withzeroData (rbase' r).
    Coercion rbase : ring >-> eqType.

    Variable r:ring.

    Definition addr (x y:r) := lift_add (@addr' r) x y.
    Definition mulr (x y:r) := lift_mul (@mulr' r) x y.
    Definition oppr (x:r)   := lift_opp (@oppr' r) x.
    Definition oner         := Nz (oner' r).

    Notation "x1 + x2" := (addr x1 x2).
    Notation "x1 * x2" := (mulr x1 x2).
    Notation "- x"     := (oppr x).
    Notation "x - y"   := (x + (- y)).
    Notation "1"       := (oner).
    Notation "0"       := (@Zero _).

    Definition divides (a b:r) := exists a', a * a' = b.
    Notation "x |` y" := (divides x y) (at level 55).

    CoInductive gcd (f g d:r) : Type :=
      Gcd : (d |` f) -> (d |` g) ->
      (forall d', (d' |` f) -> (d' |` g) -> (d' |` d)) -> gcd f g d.

    Definition unit (x:r) := exists x', (x * x' = 1).

    Definition associates x y := exists u : r, unit u /\ x = u * y.

    Definition irreducible p := forall x y, x * y = p -> (unit x \/ unit y).

    Definition prime (p:r) := ~ (unit p) /\ irreducible p.

    Definition rel_prime x y := forall d:r, gcd x y d -> unit d.

    Fixpoint pow (x:r) (n:nat) {struct n} : r :=
      if n is S n' then x * pow x n' else 1.

    Fixpoint cmul (n:nat) (a:r) {struct n} : r :=
      if n is S n' then a + cmul n' a else 1.

    Fixpoint dot (s1 s2:seq r) {struct s1} : r :=
      match s1,s2 with
        | seq0, seq0 => 1
        | Adds h1 t1, Adds h2 t2 => h1 * h2 + dot t1 t2
        | _, _ => 0
      end.

  End Ring.

  Notation "x1 + x2" := (addr x1 x2)         : ring_scope.
  Notation "x1 * x2" := (mulr x1 x2)         : ring_scope.
  Notation "- x"     := (oppr x)             : ring_scope.
  Notation "0"       := (@Zero _)            : ring_scope.
  Notation "1"       := (oner _)             : ring_scope.
  Notation "x - y"   := (x + oppr y)         : ring_scope.
  Notation addrr   := (fun x y => y + x).
  Notation mulrr   := (fun x y => y * x).
  Open Scope ring_scope.

  (* -------------------------------------------------------------------------- *)
  (*  Domains                                                                   *)
  (* -------------------------------------------------------------------------- *)

  Section Domain.

    Structure domain : Type := Domain {
      dbase    :> ring;
      domainP  : forall x1 x2:rbase' dbase, mulr' x1 x1 <> 0
    }.

  End Domain.

  (* -------------------------------------------------------------------------- *)
  (*  Fields                                                                    *)
  (* -------------------------------------------------------------------------- *)

  Section Field.

    Structure field : Type := Field {
      fbase :> domain;
      invr' : rbase' fbase -> rbase' fbase;
      unitPL0 : forall x, mulr' x (invr' x) = 1
    }.

    Definition invr (f:field) (x:f) := if x is Nz x' then Nz(invr' x') else 0.

  End Field.

  Notation "x '^-1'" := (invr x) (at level 9, format "x '^-1'") : ring_scope.

  (* -------------------------------------------------------------------------- *)
  (*  Subrings                                                                  *)
  (* -------------------------------------------------------------------------- *)

  Section Subring.

    Variable u:ring.

    Structure subring : Type := Subring {
      srbase :> set u;
      zeroP  : srbase 0;
      oneP   : srbase 1;
      addP   : forall x y, srbase x -> srbase y -> srbase (x + y);
      mulP   : forall x y, srbase x -> srbase y -> srbase (x * y);
      oppP   : forall x, srbase x -> srbase (- x)
    }.

  End Subring.

  (* -------------------------------------------------------------------------- *)
  (*  Subfields                                                                 *)
  (* -------------------------------------------------------------------------- *)

  Section Subfield.

    Variable f:field.

    Structure subfield : Type := Subfield {
      sfbase :> subring f;
      invP   : forall x, sfbase x -> sfbase (invr x)
    }.

  End Subfield.

  (* -------------------------------------------------------------------------- *)
  (*  Homomorphisms                                                             *)
  (* -------------------------------------------------------------------------- *)

  Section Homomorphism.

    Variable u v:ring.
    Variable r:subring u.
    Variable s:subring v.

    Structure homo : Type := Homo {
      hbase    :> u->v;
      homoP    : forall x, r x -> s (hbase x);
      homoAddP : forall x y, r x -> r y -> hbase (x + y) = hbase x + hbase y;
      homoMulP : forall x y, r x -> r y -> hbase (x * y) = hbase x * hbase y;
      homoJunk : forall x, ~ (r x) -> hbase x = 0
    }.

    Definition kernel (h:homo) := fun x => r x && (h x == 0).

    Structure iso : Type := Iso {
      isbase :> homo;
      imonoP : forall x y, r x -> r y -> isbase x = isbase y -> x = y;
      iontoP : surj r s isbase
    }.

  End Homomorphism.

  (* -------------------------------------------------------------------------- *)
  (*  Ideals                                                                    *)
  (* -------------------------------------------------------------------------- *)

  Section Ideal.

    Variable u:ring.
    Variable r:subring u.

    Structure ideal : Type := Ideal {
      idbase :> set u;
      id_ss  : sub_set idbase r;
      id0    : idbase 0;
      id_add : forall x y, idbase x -> idbase y -> idbase (x + y);
      idPL   : forall x y, idbase x -> r y -> idbase (x * y);
      idPR   : forall x y, r x -> idbase y -> idbase (x * y)
    }.

    Parameter ring_to_ideal : forall r:subring u, ideal.

    Variable i:ideal.

    Definition maximal_ideal :=
      i <> ring_to_ideal r /\
      forall j : ideal, sub_set i j -> j = i \/ j = ring_to_ideal r.

    Parameter principle_ideal : forall a:u, ideal.

    Definition pid := forall i:ideal, exists a, i = principle_ideal a.

  End Ideal.

  (* -------------------------------------------------------------------------- *)
  (*  Quotients                                                                 *)
  (* -------------------------------------------------------------------------- *)

  Section Quotient.

    Variable U:ring.
    Variable R:subring U.
    Variable I:ideal R.

    Definition coset_pred (s:set U) :=
      exists a, s a /\ forall x, s x <-> exists i, I i /\ x = a + i.

    Structure coset : Type := Coset {
      cosetS :> set U;
      coset_mem : coset_pred cosetS
    }.

    Definition eqcoset (c1 c2:coset) := Pb (forall x, cosetS c1 x == cosetS c2 x).
    Axiom eqcosetPx : reflect_eq eqcoset.
    Canonical Structure cosetData := EqType eqcosetPx.

    Parameter elem_of_coset : coset -> U.
    Parameter coset_of_elem : U -> coset.

    Definition addq c1 c2 := coset_of_elem ((elem_of_coset c1) + (elem_of_coset c2)).
    Definition mulq c1 c2 := coset_of_elem ((elem_of_coset c1) * (elem_of_coset c2)).
    Definition oppq c     := coset_of_elem (- (elem_of_coset c)).
    Definition zeroq      := coset_of_elem 0.
    Definition oneq       := coset_of_elem 1.

    Notation "x1 +` x2" := (addq x1 x2) (at level 50).
    Notation "x1 *` x2" := (mulq x1 x2) (at level 40).
    Notation "-` x"     := (oppq x) (at level 35).

    Axiom addqC    : forall c1 c2:cosetData, c1 +` c2 = c2 +` c1.
    Axiom addqA    : forall c1 c2 c3, c1 +` (c2 +` c3) = c1 +` c2 +` c3.
    Axiom addq0    : forall c, c +` zeroq = c.
    Axiom oppqL    : forall c, -` c +` c = zeroq.
    Axiom mulqC    : forall x y, x *` y = y *` x.
    Axiom mulqA    : forall c1 c2 c3, c1 *` (c2 *` c3) = c1 *` c2 *` c3.
    Axiom mul1q    : forall x, oneq *` x = x.
    Axiom distqPM  : forall x1 x2 x3, (x1 +` x2) *` x3 = x1 *` x3 +` x2 *` x3.
    Axiom distqMP  : forall x1 x2 x3, x1 *` (x2 +` x3) = x1 *` x2 +` x1 *` x3.

    Canonical Structure quotient := Ring (Ring_axioms addqC addqA oppqL mulqC mulqA mul1q distqPM distqMP).
  End Quotient.

  (* -------------------------------------------------------------------------- *)
  (*  Polynomials                                                               *)
  (* -------------------------------------------------------------------------- *)

  Section Poly.

    Variable r:domain_z.

    Inductive polyz : Type := Lc (c:rbase_z r) | Pcons (h:r) (t:polyz).

    Notation "h :: t" := (Pcons h t) (at level 70).

    Fixpoint eqpolyz (p1 p2:polyz) {struct p1} : bool :=
      match p1, p2 with
        | Lc c1, Lc c2 => c1 == c2
        | c1::t1, c2::t2 => (c1 == c2) && eqpolyz t1 t2
        | _, _ => false
      end.

    Axiom eqpolyzPx : reflect_eq eqpolyz.

    Canonical Structure polyzData := EqType eqpolyzPx.

    Definition poly := (withzeroData polyzData).

    Definition onep := Lc (oner_z _).

    Notation "1" := onep.

    Definition const c := if c is Nz c' then Nz (Lc c') else Zero.

    Definition X := Nz(0::onep).

    Definition horner c p := if p is Nz p' then Nz (c::p') else const c.

    Fixpoint addpz (p1 p2:polyz) {struct p2} : poly :=
      match p1, p2 with
        | h::t, Lc c => Nz (addrz h (Nz c) :: t)
        | Lc c, h::t => Nz (addrz (Nz c) h :: t)
        | Lc c1, Lc c2 => const (addr_z c1 c2)
        | h1 :: t1, h2 :: t2 => horner (h1 + h2) (addpz t1 t2)
      end.

    Definition addp (p1 p2:poly) : poly := lift_add addpz p1 p2.

    Fixpoint cmulpz (c:rbase_z r) (p:polyz) {struct p} : polyz :=
      match p with
        | Lc c' => Lc (if mulr_z c c' is Nz c'' then c'' else c')
        | h :: t => (mulrz (Nz c) h)::(cmulpz c t)
      end.

    Definition cmulp (c:r) (p:poly) : poly :=
      match c, p with
        | Zero, _ => Zero
        | _, Zero => Zero
        | Nz c', Nz p' => Nz (cmulpz c' p')
      end.

    Definition mulpz_aux (c:r) p : poly := if c is Nz c' then Nz (cmulpz c' p) else Zero.

    Fixpoint mulpz (p1 p2 : polyz) {struct p1} : poly :=
      match p1 with
        | Lc c => Nz (cmulpz c p2)
        | h :: t =>
          addp (mulpz_aux h p2) (horner Zero (mulpz t p2))
      end.

    Definition mulp (p1 p2:poly) : poly := lift_mul mulpz p1 p2.

    Fixpoint opppz (p:polyz) {struct p} : polyz :=
      match p with
        | h::t => - h::opppz t
        | Lc c => Lc (oppr_z c)
      end.

    Definition oppp (p:poly) : poly := if p is Nz p' then Nz(opppz p') else Zero.

    Fixpoint coefz (p:polyz) (i:nat) {struct i} : r :=
      match p, i with
        | h::t, S n => coefz t n
        | h::t, O => h
        | Lc c, O => Nz c
        | Lc c, S n => 0
      end.

    Definition coef (p:poly) i : r := if p is Nz p' then coefz p' i else 0.

    Notation "x1 + x2" := (addp x1 x2).
    Notation "x1 * x2" := (mulp x1 x2).
    Notation "- x"     := (oppp x).
    Notation "x - y"   := (x + (- y)).
    Notation "0"       := (Zero).
    Notation "1"       := (Nz onep).
    Notation "x <= y"  := (nati.leq x y).
    Notation "x < y"   := (nati.lt x y).

    Axiom poly_indh : forall (P:poly->Prop),
      P Zero -> (forall c p, P p -> P (horner c p)) -> (forall p, P p).

    Axiom opppL     : forall p, - p + p = Zero.
    Axiom addpA     : forall p1 p2 p3, p1 + (p2 + p3) = p1 + p2 + p3.
    Axiom addpC     : forall p1 p2, p1 + p2 = p2 + p1.
    Axiom mul1p     : forall p, 1 * p = p.
    Axiom distpMP   : forall p1 p2 p3, p1 * (p2 + p3) = p1 * p2 + p1 * p3.
    Axiom distpPM   : forall p1 p2 p3, (p1 + p2) * p3 = p1 * p3 + p2 * p3.
    Axiom mulp1     : forall p, p * 1 = p.
    Axiom mulpA     : forall p1 p2 p3, p1 * (p2 * p3) = p1 * p2 * p3.
    Axiom mulpC     : forall p1 p2, p1 * p2 = p2 * p1.

    Canonical Structure poly_ring := Ring_z (Ringz_axioms opppL addpA addpC mul1p mulp1 mulpA distpPM distpMP mulpC).

    Fixpoint degpz (p:polyz) {struct p} : nat :=
      if p is h::t then S (degpz t) else O.

    Definition degp p := if p is Nz p' then Nat (degpz p') else -oo.

    Definition constant p    := degp p = Nat O \/ degp p = -oo.
    Definition linear p      := degp p = Nat 1.
    Definition quadratic p   := degp p = Nat 2.
    Definition cubic p       := degp p = Nat 3.
    Definition quartic p     := degp p = Nat 4.
    Definition quintic p     := degp p = Nat 5.

    Axiom degp_const       : forall c, degp (const c) = if c is Nz _ then Nat O else -oo.
    Axiom degp_add_unevenL : forall p1 p2, degp p2 < degp p1 -> degp (p1 + p2) = degp p1.
    Axiom degp_add_unevenR : forall p1 p2, degp p1 < degp p2 -> degp (p1 + p2) = degp p2.
    Axiom degp_inf         : forall p, degp p = -oo -> p = 0.
    Axiom degp_add         : forall p q:poly, nati.leq (degp (p + q)) (maxi (degp p) (degp q)).
    Axiom degp_opp         : forall p, degp (- p) = degp p.

    Fixpoint lcz (p:polyz) {struct p} : rbase_z r :=
      match p with
        | Lc c => c
        | h::t => lcz t
      end.

    Definition lc (p:poly) : r := if p is Nz p' then Nz (lcz p') else 0.

    Definition monic p := lc p = (@onerz _).

    Definition irreduciblep p := forall p1 p2, p = p1 * p2 -> degp p1 = Nat O \/ degp p2 = Nat O.

  End Poly.

  Notation "h :: t" := (Pcons h t) (at level 70) : ring_scope.

  (* -------------------------------------------------------------------------- *)
  (*  Field Extensions                                                          *)
  (* -------------------------------------------------------------------------- *)

  Section Fields.

    Variable U:field.
    Variable K F : subfield U.

    Definition extension (K F : subfield U) := sub_set F K.

    Structure lcomb (vs' : seq U) (x : U) : Prop := Lcomb {
      fs' : seq U;
      fsP' : all F fs';
      leP : dot fs' vs' = x
    }.

    Structure lcomb_ext (vs' : seq U) (x : U) : Prop := Lcomb_ext {
      fs0 : seq U;
      fsP0 : all F fs0;
      leP0 : dot fs0 vs' = x;
      leP1 : size fs0 = size vs'
    }.

    Axiom lcomb_extend : forall vs x, lcomb vs x <-> lcomb_ext vs x.

    Definition span vs := fun x => Pb (lcomb vs x).

    Fixpoint linind (vs : seq U) : bool :=
      if vs is Adds v vs' then ~~ (span vs' v) && linind vs' else true.

    Structure lindep (vs : seq U) : Prop := Linind_spec {
      fs : seq U;
      nz : U;
      nzP : nz != 0;
      nzM : fs nz;
      fsP : all F fs;
      fvP : (size fs) <= (size vs);
      depP : dot fs vs = 0
    }.

    Definition basis bs := linind bs && Pb (span bs = srbase K).

    Definition finD := exists b, basis b.

    Axiom inhabit : inhabited (seq U).

    Definition index := if Pb finD then Nat(size(epsilon inhabit basis)) else -oo.

    Definition finite_ext := extension K F /\ finD.

    Structure splits_def (K F : subfield U) (p : poly U) (sseq : seq (polyData U)) : Prop := Splits_def {
      sseqP      : all F p;
      sseq_lin   : all (@linear U) sseq;
      sseq_k     : all (all K \o (@coefs _)) sseq;
      sseq_mul   : foldr (@mul (poly_idom U)) 1 sseq = p
    }.

    Definition splits K F p := exists s, splits_def K F p s.

    Structure splitting_field (K F : subfield U) (p : poly U) : Prop := Splitting_field {
      sfQ    : all F p;
      sf_spl : splits K F p;
      sfP    : forall K' : subfield U, extension K K' -> splits K' F p -> K = K'
    }.

    Structure min_poly (F : subfield U) (p : poly U) (a : U) : Prop := Minp {
      minpQ      : all F p;
      minp_monic : monic p;
      minpP      : root a p;
      minpH      : forall (p' : poly U), all F p' -> root a p' -> degp p <= degp p'
    }.

    Structure algebraic (F : subfield U) (a : U) : Prop := Algebraic_spec {
      algp : poly U;
      algP : all F algp;
      anz  : algp <> 0;
      art  : root a algp
    }.

  (* Note!  one is not a galois automorphism if K is not an extension of F,
     so take the fixed field to be the intersection of F,K *)
    Definition galois_auto (a : auto_ty K) := Pb (forall x, F x -> K x -> auto a x = x).

    Definition galois_fauto := fun (K F : subfield U) (Ekf : finite_ext K F) =>
      let (_, T) := finite_finite Ekf in
        FinType (proj2 T).

    Definition galois_group (K F : subfield U) : finGroupType.

      Canonical Structure galois_group := Subgroup galois_mul galois_inv galois1.

      Pb(forall a, H a -> (auto a) x = x).

      Definition fixed_ring (H : subgroup(auto_group U)) : subring U.
   (* {{{ *)
move=> H.
exists (fixed H).
- abstract(
  apply/PbP; move=> a Ha /=;
  rewrite /auto;
  exact: homo0 (autoP a)).
- abstract(
  apply/PbP; move=> a Ha /=;
  exact: iso1 (autoP a)).
- abstract(
  move=> x y Hx Hy;
  move/PbP: (Hx) => Hx';
  move/PbP: (Hy) => Hy';
  apply/PbP; move=> a Ha;
  rewrite (homoAddP (autoP a)); eauto;
  rewrite Hx'; eauto;
  by rewrite Hy'; eauto).
- abstract(
  move=> x y Hx Hy;
  move/PbP: (Hx) => Hx';
  move/PbP: (Hy) => Hy';
  apply/PbP; move=> a Ha;
  rewrite (homoMulP (autoP a)); eauto;
  rewrite Hx'; eauto;
  by rewrite Hy'; eauto).
abstract(
move=> x Hx;
move/PbP: (Hx) => Hx'; apply/PbP;
move=> a Ha;
rewrite (homoOpp (autoP a)); eauto;
by rewrite Hx';eauto).
 (* }}} *)
    Defined.

    Definition fixed_field (H : subgroup(auto_group U)) : subfield U.
   (* {{{ *)
move=> H;exists (fixed_ring H).
abstract(
move=> x Hx; move/PbP: (Hx) => Hx'; apply/PbP;
move=> a Ha;
move: Hx; rewrite /= => Hx;
(case H0 : (x == 0); first by move/eqP: H0 => ->;rewrite inv0 (homo0 (autoP a)));
move/eqP: H0 => H0;
rewrite (inv_iso (autoP a)) => //;
by rewrite (Hx' a Ha)).
 (* }}} *)
  Defined.

  Definition normal_ext := fixed_field galois_group = F.

  End Fields.


(** A formalization of denumerable sets. *)
(** by Florian Hatat, ENS-Lyon *)

From Coq Require Import Ensembles  Arith ArithRing (* Even Div2 *)
     Wellfounded Relations  Wf_nat  Finite_sets
     Logic.Epsilon  Sets.Image Lia.

From hydras Require Import MoreEpsilonIota PartialFun  GRelations
     Prelude.More_Arith.

Import Nat.

Set Implicit Arguments.

Arguments rel_injection {A B}.
Arguments rel_surjection {A B}.

Section Countable.

  Section Definitions.
    Variable U : Type.
    Variable A : Ensemble U.
    Let Dnat : Ensemble nat := Full_set nat.

    (** Predicate for relations which number the elements of A.

  These relations map each element of A to at least one integer, but they
  are not required to be functional (injectivity is only needed to ensure that
  A is countable). *)

    Definition rel_numbers (R: GRelation U nat) := rel_injection A Dnat R.

    (** Predicate for relations which enumerate A. *)
    Definition rel_enumerates (R : GRelation nat U) := rel_surjection Dnat A R.

     (** A is countable if there exists an injection from [A] to
        [Full_set nat]. *)

    Definition countable : Prop := exists R, rel_numbers R.

    Section Equivalence_with_surjection.

      Theorem countable_surj :
        countable <-> exists R, rel_enumerates R.
      Proof.
        split.
        - intros   (R, R_enum).
          exists (rel_inv A Dnat R).
          red; apply R_inv_surj; trivial.
        - destruct 1 as [R R_surj].
        exists (rel_inv Dnat A R); red;  apply R_inv_inj; trivial.
      Qed.
    End Equivalence_with_surjection.

  End Definitions.

  Variable U : Type.

  (** [Union _ A B] is countable if [A] and [B] are countable. *)

  Section Countable_union.

    Section Countable_union_lemmas.

      Variables E F : Ensemble U.
      Variables RE RF : U -> nat -> Prop.

      Hypothesis RE_enum : rel_numbers E RE.
      Hypothesis RF_enum : rel_numbers F RF.

      Inductive R_union (x : U) : nat -> Prop :=
        from_E : forall n : nat, In E x -> RE x n -> R_union x (double n)
      | from_F : forall n : nat, In F x -> RF x n -> R_union x (S (double n)).

      Lemma R_union_domain : rel_domain (Union U E F) R_union.
      Proof.
        intros a aInUnion.
        induction aInUnion.
        - red in RE_enum; destruct RE_enum as (Hdomain, _, _).
          destruct (Hdomain x).
          + assumption.
          + exists (double x0); apply from_E; assumption.
         - destruct RF_enum as (Hdomain, _ , _);  destruct (Hdomain x).
           + assumption.
           + exists (S (double x0)); apply from_F; assumption.
      Qed.

      Lemma R_union_codomain :
        rel_codomain (Union U E F) (Full_set nat) R_union.
      Proof.
        split.
      Qed.

      Remark R_union_double:
        forall (x : U) (n : nat), R_union x (double n) -> RE x n.
      Proof.
        intros x n R_x_2n; inversion R_x_2n.
        - replace n with n0; trivial.
          apply double_inj; assumption.
        - destruct (not_double_is_s_double _ _ H).
      Qed.

      Remark R_union_S_double :
        forall (x : U) (n : nat), R_union x (S (double n)) -> RF x n.
      Proof.
        intros x n R_x_s2n; inversion R_x_s2n.
        - symmetry in H;  case (not_double_is_s_double _ _ H).
        - replace n with n0.
         + assumption.
         + apply double_inj; assumption.
      Qed.

      Lemma R_union_inj : rel_inj (Union U E F) R_union.
      Proof.
        intros a a' b a_In_Union a'_In_Union a_R_b a'_R_b.
        inversion a_R_b as [na a_In_E a_RE_na dna_b |
                            na a_In_F a_RF_na sdna_b].
        - inversion a'_R_b as
            [na' a'_In_E a'_RE_na' dna'_b |
             na' a'_In_F a'_RF_na' sdna'_b].
          + destruct RE_enum as (_, _, RE_inj);
              apply RE_inj with na'; try assumption.
            replace na' with na; try assumption.
            apply double_inj.
            symmetry in dna'_b; transitivity b; assumption.
          + rewrite <- dna_b in sdna'_b.
            case not_double_is_s_double with na' na; assumption.
        - inversion a'_R_b as
              [na' a'_In_E a'_RE_na' dna'_b |
               na' a'_In_F a'_RF_nb sdna'_b].
          + rewrite <- sdna_b in dna'_b.
            symmetry in dna'_b.
            case not_double_is_s_double with na na'; assumption.
          + destruct RF_enum as (_, _, RF_inj).
            apply RF_inj with na'; try assumption.
            replace na' with na; try assumption.
            apply double_inj.
            symmetry in sdna'_b;  rewrite <- sdna_b in sdna'_b.
            injection sdna'_b; trivial.
      Qed.

      Lemma R_union_enumerates : rel_numbers (Union U E F) R_union.
      Proof.
        split.
        - apply R_union_domain.
        - apply R_union_codomain.
        - apply R_union_inj.
      Qed.

    End Countable_union_lemmas.

    Theorem countable_union (E : Ensemble U) (F : Ensemble U) :
      countable E -> countable F -> countable (Union U E F).
    Proof.
      intros E_den F_den;  destruct E_den as (RE, RE_enum);
       destruct F_den as (RF, RF_enum).
      exists (R_union E F RE RF); apply R_union_enumerates; assumption.
    Qed.

  End Countable_union.

  Section Countable_inclusion.

    Variables E F : Ensemble U.

    Section Countable_inclusion_lemmas.

      Variable RE : U -> nat -> Prop.
      Hypothesis RE_enum : rel_numbers E RE.
      Hypothesis F_in_E : Included _ F E.

      Lemma R_inclusion_domain : rel_domain F RE.
      Proof.
        intros a a_In_F; destruct RE_enum as (RE_domain, _, _).
        apply RE_domain, F_in_E; assumption.
      Qed.

      Lemma R_inclusion_codomain : rel_codomain F (Full_set nat) RE.
      Proof.
        split.
      Qed.

      Lemma R_inclusion_inj : rel_inj F RE.
      Proof.
        intros a a' b a_In_F a'_In_F a_R_B a_'R_b;
        destruct RE_enum as (_, _, RE_inj);
        apply (RE_inj a a' b); try apply F_in_E; assumption.
      Qed.

      Lemma R_inclusion_enumerates : rel_numbers F RE.
      Proof.
        split.
        - apply R_inclusion_domain.
        - apply R_inclusion_codomain.
        - apply R_inclusion_inj.
      Qed.

    End Countable_inclusion_lemmas.

    Theorem countable_inclusion :
      countable E -> Included _ F E -> countable F.
    Proof.
      intros E_denum F_in_E; destruct E_denum as (RE, RE_enum).
      exists RE; apply R_inclusion_enumerates; assumption.
    Qed.

  End Countable_inclusion.

  (* Union of all sets B with B in A. *)
  Section Infinite_union.

    Variable A : Ensemble (Ensemble U).

    Definition Infinite_union (x : U) : Prop :=
      exists b, In A b /\ In b x.

    Section Infinite_union_lemmas.

      Variable R : Ensemble U -> nat -> Prop.
      Variable R_n : nat -> U -> nat -> Prop.

      Hypothesis R_enums : rel_numbers A R.
      Hypothesis R_n_enums :
        forall n : nat, forall b : Ensemble U,
	    In A b -> R b n -> rel_numbers b (R_n n).

      Fixpoint K (n : nat) : nat * nat :=
        match n with
          0 => (0, 0)
        | S n => match K n with
                   (0, m) => (S m, 0)
                 | (S n, m) => (n, S m)
                 end
        end.

      Definition K_1 : nat * nat -> nat :=
        fun couple =>
          let (p, q) := couple in
          div2 ((p+q+1)*(p+q)) + q.

      Let K_rel (p1 : nat*nat) (p2 : nat*nat) : Prop :=
        let (p, q) := p1 in
        let (p', q') := p2 in
        (p + q < p' + q') \/ (p + q = p' + q' /\ p' < p).

      Let f : nat * nat -> sigT (fun _ : nat => nat) :=
        fun cpl =>
          let (p, q) := cpl in
          existT (fun _ : nat => nat) (p + q) q.

      Let R_K :=
        (fun x y => (lexprod _ (fun _ => nat) lt (fun _ => lt)) (f x) (f y)).

      Lemma lexof_wf :
        well_founded R_K.
      Proof.
        unfold R_K;
        apply wf_inverse_image with
            (R := lexprod _ (fun _ => nat) lt (fun _ => lt)).
        apply wf_lexprod; intros; apply Wf_nat.lt_wf.
      Qed.

      Lemma K_rel_wf :  well_founded K_rel.
      Proof.
        apply wf_incl with R_K.
        - intros (p, q) (p', q') HK_rel.
          case HK_rel.
          + intros Hin; unfold R_K; unfold f; apply left_lex; assumption.
          + intros (Hdiag, Hin).
            unfold R_K, f; rewrite Hdiag; apply right_lex.
            case (le_lt_dec q' q).
            * intros Hqin; case (lt_irrefl (p + q)).
              pattern (p + q) at 1; rewrite Hdiag.
              apply Nat.add_lt_le_mono ; assumption.
            * trivial.
        - apply lexof_wf.
      Qed.

      Remark double_K_1 :
        forall p q, double (K_1 (p, q)) = ((p+q+1)*(p+q)) + double q.
      Proof.
        intros p q; unfold K_1. (* Here *)

        rewrite double_plus.  f_equal.
        rewrite div2_of_Even; trivial.
        apply even_prod.
      Qed.

      Lemma K_bij :
        forall p q, K (K_1 (p, q)) = (p, q).
      Proof.
        intros p q;  generalize (p, q);
        intros p0; pattern p0; apply (well_founded_ind K_rel_wf).
        clear p q p0; intros (p, q) IH.
        induction q.
        - induction p.
          + trivial.
          + replace (K_1 (S p, 0)) with (S (K_1 (0, p))).
            simpl K; replace (K (div2 ((p + 1) * p) + p)) with (0, p).
            trivial.
            symmetry; unfold K_1 in IH; apply (IH (0, p)).
            left; auto with arith.
            apply double_inj.
            rewrite (double_S (K_1 (0, p))).
            rewrite (double_K_1 0 p).
            rewrite (double_K_1 (S p) 0).
            rewrite <- (plus_n_O (S p)).
            rewrite (plus_O_n p).
            unfold double.
            rewrite (plus_O_n 0); rewrite <- (plus_n_O ((S p + 1) * S p)).
            replace (S p) with (p + 1).
            rewrite (plus_2 ((p + 1) * p + (p + p))).
            ring.
            lia.
        - replace (K_1 (p, S q)) with (S (K_1 (S p, q))).
          unfold K; fold K.
          replace (K (K_1 (S p, q))) with (S p, q).
          + trivial.
          + symmetry; apply IH.
            right; split; lia.
          + apply double_inj.
            rewrite (double_S (K_1 (S p, q))).
            rewrite (double_K_1 (S p) q).
            rewrite (double_K_1 p (S q)).
            rewrite (plus_2 ((S p + q + 1) * (S p + q) + double q)).
            replace (S q) with (q + 1).
            replace (S p) with (p + 1).
            unfold double.
            ring.
            lia.
            lia.
      Qed.

      Lemma K_rel_dec :
        forall x y, {K_rel x y} + {x = y} + {K_rel y x}.
      Proof.
        intros (p, q) (p', q').
        case lt_eq_lt_dec with (p + q) (p' + q').
        - intros Hcp; case Hcp.

        (* p + q < p' + q' *)
        + intros Hlt; repeat left; assumption.

        (* p + q = p' + q' *)
        + intros Heq; case lt_eq_lt_dec with p p'.
          intros Hcpp; case Hcpp.
          intros Hlt; repeat right; split; [symmetry |]; assumption.
          intros Heqp; left; right; apply injective_projections; compute.
          assumption.
          erewrite <- (Nat.add_cancel_l _ _ p').
          rewrite Heqp in Heq; assumption.
          intros Hlt; left; left; right; split; assumption.

        (* p' + q' < p + q *)
        - intros Hlt; right; left; assumption.
      Qed.

      Remark K_S_O :
        forall n, K (S n) <> (0, 0).
      Proof.
        intros n Heq; simpl in Heq; symmetry in Heq.
        case_eq (K n); intros p q Kn_pq.
        rewrite Kn_pq in Heq.
        case_eq p.
        (* p = 0 *)
        - intros p_eq; rewrite p_eq in Heq.
          case O_S with q.
          replace 0 with (fst (0, 0)); replace (S q) with (fst (S q, 0));
          try (compute; trivial; fail).
          apply (f_equal (fst (A := nat) (B := nat))); assumption.

        (* p = S r *)
        - intros r p_eq; rewrite p_eq in Heq.
          case O_S with q.
          replace 0 with (snd (0, 0)); replace (S q) with (snd (r, S q));
          try (compute; trivial; fail).
          apply (f_equal (snd (A := nat) (B := nat))); assumption.
      Qed.

      Lemma K_inj :
        forall n m, K n = K m -> n = m.
      Proof.
        intros n m; pattern n, m.
        apply nat_double_ind; clear n m.
        - intros n Heq; simpl in Heq; case_eq n.
        (* n = 0 *)
          + trivial.
        (* n = S m *)
          + intros m n_Sm; rewrite n_Sm in Heq; symmetry in Heq;
              case K_S_O with m; assumption.

        - intros n Heq; simpl in Heq; case K_S_O with n; assumption.
        - intros n m Hin Heq; apply eq_S; apply Hin.
          case_eq (K n); case_eq (K m).
          intros p' q' Km p q Kn.
          simpl in Heq; rewrite Km in Heq; rewrite Kn in Heq.
          case_eq p; case_eq p'.
        (* p = 0 ; p' = 0 *)
          + intros p'_eq p_eq; rewrite p_eq in Heq; rewrite p'_eq in Heq.
            apply injective_projections; compute; auto.
            injection Heq; auto.

        (* p = 0 ; p' = S r *)
          + intros r p'_eq p_eq; rewrite p_eq in Heq; rewrite p'_eq in Heq.
            case O_S with q'.
            replace 0 with (snd (S q, 0));
              replace (S q') with (snd (r, S q'));
          try (compute; trivial; fail).
            apply (f_equal (snd (A := nat) (B := nat))); assumption.

        (* p = S r ; p' = 0 *)
          + intros p'_eq r p_eq; rewrite p_eq in Heq; rewrite p'_eq in Heq.
            case O_S with q;  symmetry;  replace 0 with (snd (S q', 0));
              replace (S q) with (snd (r, S q));
              try (compute; trivial; fail).
            apply (f_equal (snd (A := nat) (B := nat))); assumption.

        (* p = S r ; p' = S r' *)
          + intros r' p'_eq r p_eq; rewrite p_eq in Heq;
              rewrite p'_eq in Heq.
        injection Heq; auto.
      Qed.

      Definition R_union_qcq (x : U) (n : nat) :=
        match K n with
	  (p, q) => exists b, (In A b /\ R b p) /\ (In b x /\ R_n p x q)
        end.

      Lemma R_union_qcq_domain :
        rel_domain Infinite_union R_union_qcq.
      Proof.
        intros a a_In_Union; elim a_In_Union.
        intros b (b_In_A, a_In_b).
        assert (ex_p: exists p, R b p).
        { destruct R_enums as (R_domain, _, _).
          now apply R_domain.
        }
        elim ex_p; intros p b_R_p.

        assert (ex_q : exists q, R_n p a q).  {
          destruct (R_n_enums b_In_A b_R_p) as (R_n_domain, _, _).
          apply R_n_domain.
          assumption...
        }
        elim ex_q; intros q a_Rn_q.
        exists (K_1 (p, q)).
        red; replace (K (K_1 (p, q))) with (p, q).
        exists b.
        repeat split; assumption...
        symmetry; apply K_bij...
      Qed.

      Lemma R_union_qcq_codomain :
        rel_codomain Infinite_union (Full_set nat) R_union_qcq.
      Proof.
        split.
      Qed.

      Lemma R_union_qcq_inj :
        rel_inj Infinite_union R_union_qcq.
      Proof.
        intros a a' n a_In_Union a'_In_Union a_Ru_n a'_Ru_n.
        red in a_Ru_n; generalize a_Ru_n; case_eq (K n).
        intros p q K_eq ex_b.
        red in a'_Ru_n; generalize a'_Ru_n; case_eq (K n).
        intros p' q' K'_eq.
        assert (p_eq : p = p').
        { transitivity (fst (K n));
          [rewrite K_eq | rewrite K'_eq]; compute; trivial.
        }
        assert (q_eq : q = q'). {
          transitivity (snd (K n));
          [rewrite K_eq | rewrite K'_eq]; compute; trivial.
        }
        rewrite <- p_eq; rewrite <- q_eq.
        intro ex_b';elim ex_b;
          intros b ((b_In_A, b_R_p), (b_In_a, a_Rnp_q)).
        elim ex_b'; intros b' ((b'_In_A, b'_R_p), (b'_In_a', a'_Rnp_q)).
        assert (b_eq : b = b'). {
          destruct R_enums as (_, _, R_inj).
          apply R_inj with p; assumption.
        }
        rewrite <- b_eq in b'_In_a'.
        destruct (R_n_enums b_In_A b_R_p) as (_, _, Rn_inj).
        apply Rn_inj with q; assumption.
      Qed.

      Lemma R_union_qcq_numbers :
        rel_numbers Infinite_union R_union_qcq.
      Proof.
        split.
        - apply R_union_qcq_domain.
        - apply R_union_qcq_codomain.
        - apply R_union_qcq_inj.
      Qed.

    End Infinite_union_lemmas.

    Section Indexed_union_lemmas_2.

      Variable R : GRelation (Ensemble U) nat.
      Hypothesis R_enum : rel_numbers A R.
      Hypothesis all_b_denum : forall b : Ensemble U, In A b -> countable b.

      Remark inh_U_sets : inhabited (Ensemble U).
      Proof inhabits  (Empty_set U).

      Let b_n (n : nat) :=
        epsilon inh_U_sets (fun b => In A b /\ R b n).

      Remark bn_R_n :
        forall n, (exists b, In A b /\ R b n) -> R (b_n n) n.
      Proof.
        intros n ex_b; pattern (b_n n); epsilon_elim.
        intros a (_, a_R_n); assumption.
      Qed.

      Remark inh_grel_U_nat : inhabited (GRelation U nat).
      Proof inhabits  (fun (u:U)(n:nat) => True).

      Let R_b (b : Ensemble U) :=
        epsilon inh_grel_U_nat (fun R => rel_numbers b R).

      Remark Rb_numbers_b :
        forall b, In A b -> rel_numbers b (R_b b).
      Proof.
        intros b b_In_A;
        pattern (R_b b);  epsilon_elim.
        apply all_b_denum.
        assumption.
      Qed.

      Let R_n (n : nat) (x : U) (m : nat) :=
        (exists b, R b n) /\ R_b (b_n n) x m.

      Remark Rn_numbers_bn :
        forall n : nat, In A (b_n n) -> R (b_n n) n ->
                        rel_numbers (b_n n) (R_n n).
      Proof.
        intros n bn_In_A; split.
        intros x x_In_b.
        destruct (Rb_numbers_b bn_In_A) as (Rb_dom, _, _).
        - elim (Rb_dom x); try assumption.
          intros m x_Rb_m; exists m.
          split; [exists (b_n n) | idtac]; assumption.
        - split.
        - intros x x' m x_In_bn x'_In_bn (ex_b, x_Rb_m) (_, x'_Rb_m).
          destruct (Rb_numbers_b bn_In_A) as (_, _, Rb_inj).
          apply Rb_inj with m; assumption.
      Qed.

      Let b_p (b : Ensemble U) :=
        epsilon (inhabits 0) (fun p => b = b_n p).

      Remark b_is_nth :
        forall b : Ensemble U, In A b -> b = b_n (b_p b).
      Proof.
        intros b b_In_A;  pattern (b_p b); epsilon_elim.
        destruct R_enum as (R_dom, _, R_inj); elim (R_dom b b_In_A).
        intros p b_R_p; exists p; pattern (b_n p); epsilon_elim.
        exists b; split; assumption.
        intros a (a_In_A, a_R_p); apply R_inj with p; assumption.
      Qed.

      Lemma all_b_relation :
        exists R_n : nat -> U -> nat -> Prop,
        forall n : nat, forall b : Ensemble U,
            In A b -> R b n -> rel_numbers b (R_n n).
      Proof.
        exists R_n; intros n b b_In_A b_R_n.
        assert (b = b_n n). {
          pattern (b_n n); epsilon_elim.
          exists b; split; assumption.
          destruct R_enum as (_, _, R_inj).
          intros a (a_In_A, a_R_p).
          apply R_inj with n; assumption.
        }
        rewrite H; rewrite H in b_In_A; rewrite H in b_R_n.
        apply Rn_numbers_bn; assumption.
      Qed.

    End Indexed_union_lemmas_2.

    Theorem countable_union_qcq :
      countable A ->
      (forall b : Ensemble U, In A b -> countable b) ->
      countable Infinite_union.
    Proof.
      intros A_denum all_b_denum; elim A_denum; intros R R_enum.
      elim all_b_relation with R; try assumption.
      intros R_n R_n_enum; exists (R_union_qcq R R_n).
      apply R_union_qcq_numbers; assumption.
    Qed.

  End Infinite_union.

  Section Countable_empty.

    Lemma countable_empty :
      countable (Empty_set U).
    Proof.
      (* Any relation would fit here... *)
      pose (R := fun (_ : U) (_ : nat) => False).
      exists R; split.
      - intros x; destruct 1.
      -  split.
      - intros x x' n x_In_empty; case x_In_empty.
    Qed.

  End Countable_empty.

  Section Countable_singleton.

    Variable x : U.

    Lemma countable_singleton :
      countable (Singleton _ x).
    Proof.
      pose (R := fun (y : U) (n : nat) => y = x).
      exists R; split.
      - intros y y_In_s; exists 0.
        inversion y_In_s.
        rewrite <- H; unfold R; reflexivity.
      - split.
      - intros y y' n y_In_s y'_In_s _ _.
        inversion y_In_s.
        inversion y'_In_s.
        subst y; auto.
    Qed.

  End Countable_singleton.

  Section Countable_seq_range.

    Definition seq_range (f : nat -> U) : Ensemble U :=
      image (Full_set nat) f.

    Lemma seq_range_countable :
      forall f, countable (seq_range f).
    Proof.
      intros f; pose (R := fun (x : U) (n : nat) => f n = x).
      exists R; split.
      - intros x; destruct 1.
        exists x0; unfold R. tauto.
      - split.
      -  intros x x' n x_In_sr x'_In_sr x_R_n x'_R_n.
         unfold R in x_R_n.
         unfold R in x'_R_n.
         subst x; auto.
    Qed.

  End Countable_seq_range.

  Section Countable_bijection.

    Variable V : Type.

    Variable A : Ensemble U.
    Variable B : Ensemble V.
    Variable g : U -> V.

    Hypothesis g_bij : fun_bijection A B g.

    Lemma countable_bij_fun :
      countable A -> countable B.
    Proof.
      intro A_denum; red in A_denum.
      elim A_denum; intros Ru Ru_num.
      pose (Rv := fun (y : V) (n : nat) =>
                    exists x : U, In A x /\ g x = y /\ Ru x n).
      exists Rv.
      split.
      - intros y y_In_B; destruct Ru_num as (Ru_dom, _, _).
        unfold Rv; destruct g_bij as (_, g_onto, _).
        elim g_onto with y; try assumption.
        intros x (x_In_A, gx_eq_y).
        elim Ru_dom with x; try assumption.
        intros b x_Ru_b.
        exists b; exists x; repeat split; assumption.
      - split.
      - intros y y' n y_In_B y'_In_B y_Rv_n y'_Rv_n.
        unfold Rv in y_Rv_n; unfold Rv in y'_Rv_n.
        elim y_Rv_n; intros x (x_In_A, (gx_eq_y, x_Ru_n)).
        elim y'_Rv_n; intros x' (x'_In_A, (gx'_eq_y', x'_Ru_n)).
        assert (x_eq : x = x'). {
          destruct Ru_num as (_, _, Ru_inj).
          apply Ru_inj with n; assumption.
        }
        rewrite <- gx_eq_y; rewrite x_eq; assumption.
    Qed.

    Lemma countable_bij_funR :
      countable B -> countable A.
    Proof.
      intro B_denum; elim B_denum; intros Rv Rv_num.
      pose (Ru := fun (x : U) (n : nat) => Rv (g x) n).
      exists Ru; split.
      - intros x x_In_A; unfold Ru.
        destruct Rv_num.
        apply H.
        destruct g_bij.
        apply H2; assumption.
      - split.
      - intros x x' n x_In_A x'_In_A x_Ru_n x'_Ru_n.
        unfold Ru in x_Ru_n; unfold Ru in x'_Ru_n.
        destruct Rv_num.
        destruct g_bij; auto.
        apply H4; auto.
        apply H1 with n; auto.
    Qed.

  End Countable_bijection.

  Section Countable_finite.

    Variable A : Ensemble U.
    Hypothesis A_finite : Finite _ A.

    Theorem countable_finite : countable A.
    Proof.
      elim A_finite.
      - apply countable_empty.
      - intros A0 A0_finite A0_denum x x_nIn_A0.
        unfold Add; apply countable_union.
        assumption.
        apply countable_singleton.
    Qed.

  End Countable_finite.

End Countable.

Lemma countable_image : forall (U V:Type)(DA : Ensemble U)(f:U->V),
    countable DA -> countable (image DA f).
Proof.
  intros U V DA f H; case H; intros R HR.
  case HR; intros H0 H1 H2.
  exists (fun y n => exists x, DA x /\ R x n /\ f x = y).
  split.
  -   intros a (a0,(Ha0,H'a0)); case (H0 a0).
      auto.
      intros; exists x.
      exists a0;auto.
  - split.
  -  intros a a' b (a0,(Ha0,H'a0)) (a1,(Ha1,H'a1)) (x,(Hx,(H'x,H''x)))
         (y,(Hy,(H'y,H''y))).
     generalize (H2 x y b Hx Hy H'x H'y);auto.
     intro;subst y.
     transitivity (f x);auto.
Qed.


(* (c) Copyright ? *)

(*****************************************************************************
  Verification of formula deductions in the appendix of paper "Exact-Wiberg
  Algorithm for Matrix Factorization with Missing Data" (ECCV 2014 submission)

  Main definitions:
            sym A == A^T + A. A must be a square matrix.
  mupinv_core u A == A^T *m A + u *ml: I
           A ^- u == (mupinv_core u A)^^-1 *m A^T
                  == (A^T *m A + u *ml: I)^^-1 *m A^T
                     The mu-pseudoinverse.
           pinv A == A ^- 0

  Main results:
        dm_mupinv :
        \\d (A^-u) = 0 - A^-u *ml \\d A *mr A^-u + (A^T *m A + u *ml: I)^-1
                     *ml (\\d A)^T *mr (I - A *m A^-u)
                     The first result in Appendix A.
      dm_AmupinvA :
   \\d (A *m A^-u) = sym ((I - A *m A^-u) *ml \\d A *mr A^-u)
                     The second result in Appendix A.

  All results are under the assumption: invertible (mupinv_core u A)).
  Sometimes I write (0 - a *m b) instead of (- a *m b) because the unary minus
  sign binds tighter than *m, which I find counter-intuitive.

******************************************************************************)

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

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice fintype.
Require Import finfun bigop prime binomial.

Require Import matrix.
Require Import ssralg.
Import GRing.Theory.
Open Local Scope ring_scope.

Require Import mxutil.
Import Notations.
Require Import bimodule.
Require Import derivation.
Require Import mxmodule.
Import Notations.
Require Import mxdiff.

Section Sym.

Variable V : zmodType.
Variable n : nat.
Implicit Types A : 'M[V]_n.

Definition sym A := A^T + A.

Lemma fold_sym A : A^T + A = sym A.
Proof. by []. Qed.

End Sym.

Section MuPseudoinverse.

Variable R : ringType.
(* invmx requires comRing *)
Variable E : unitComAlgType R.

Implicit Types u : R.
Variable m n : nat.
Implicit Types A : 'M[E]_(m, n).
Implicit Types B : 'M[E]_m.

Definition mupinv_core u A := A^T *m A + u *ml: I.
Definition mupinv_def u A := (mupinv_core u A)^^-1 *m A^T.
Fact mupinv_key : unit. by []. Qed.
Definition mupinv := locked_with mupinv_key mupinv_def.
Canonical mupinv_unlockable := [unlockable fun mupinv].

Local Notation "A ^- u" := (mupinv u A) : ring_scope.

Lemma fold_mupinv u A : (A^T *m A + u *ml: I)^^-1 *m A^T = A^-u.
Proof. by rewrite unlock. Qed.

Lemma fold_mupinvT u A : A *m (A^T *m A + u *ml: I)^^-1 = (A^-u)^T.
Proof.
  set goal := LHS.
  by rewrite unlock trmx_mul trmxK trmx_inv linearD /= trmx_mul trmxK trmx_lscalemx trmx1.
Qed.

End MuPseudoinverse.

Local Notation "A ^- u" := (mupinv u A) : ring_scope.

Section Appendix.

(* Scalar type *)
Variable R : ringType.
(* Element type *)
Variable E : unitComAlgType R.
Variable D : comBimodType E.
Variable der : {linearDer E -> D}.
Notation "\d" := (LinearDer.apply der).
Notation "\\d" := (map_mx \d).

Variable m n' : nat.
Local Notation n := n'.+1.
Implicit Types A : 'M[E]_(m, n).
Implicit Types B : 'M[E]_n.

Variable A : 'M[E]_(m, n).
Variable u : R.

Hypothesis h_invertible : invertible (mupinv_core u A).

Lemma AmupinvA_sym : (A *m A^-u)^T = A *m A^-u.
Proof. by rewrite trmx_mul -fold_mupinvT -fold_mupinv mulmxA. Qed.

Lemma dm_mupinv : \\d (A^-u) = 0 - A^-u *ml \\d A *mr A^-u + (A^T *m A + u *ml: I)^-1 *ml (\\d A)^T *mr (I - A *m A^-u).
Proof.
  set goal := RHS.
  rewrite unlock dmM /mupinv_core /=.
  rewrite !invmx_inv (derV _ h_invertible) /mupinv_core -!invmx_inv /= rmulNmx -sub0r scale_lmul rscale_rmul.
  rewrite raddfD /= dmcs dmI lscalemx0 addr0 dmM /=.
  rewrite -rmulmxA fold_mupinv lmulmxDr rmulmxDl lrmulmxA lmulmxA opprD addrA.
  by rewrite fold_mupinv sub0r [in - _ - _]addrC -addrA [in - _ + (_ *ml \\d _)](addrC) -rmulmxA -rmulmx1Br -map_trmx -sub0r.
Qed.

Lemma dm_AmupinvA : \\d (A *m A^-u) = sym ((I - A *m A^-u) *ml \\d A *mr A^-u).
Proof.
  set goal := RHS.
  rewrite dmM /=.
  rewrite dm_mupinv sub0r !(lmulmxDr A) lmulmxN !addrA !lrmulmxA !lmulmxA.
  rewrite fold_mupinvT.
  rewrite !rmulmxDr rmulmx1 rmulmxN !rmulmxA !addrA.
  rewrite -trmx_rmulmx -rmulmxA -[in _ *mr (A *m _) ]AmupinvA_sym -trmx_lmulmx -addrA -raddfB /= lrmulmxA addrC fold_sym.
  by rewrite -lrmulmxA /= -(lmulmx1Br (A *m _)) lrmulmxA.
Qed.

End Appendix.

Lemma mover {V : zmodType} (a b c : V) : a + b = c -> a = c - b.
Proof.
  by move => h; apply (addIr b); rewrite addrNK.
Qed.

Lemma moveinvmx {R : comUnitRingType} m n A (B : 'M[R]_(m,n)) C : invertible A -> A *m B = C -> B = A^^-1 *m C.
Proof.
  by move => hi h; rewrite -h (mulKmx hi).
Qed.

Ltac right_first name :=
  match goal with
    | |- _ /\ ?R => have name: R; [ | split; [ | auto ] ]
  end.

Lemma Schur_complement {R : comUnitRingType} m1 m2 n (A : 'M[R]_m1) B BT (C : 'M_m2) (x : 'M_(m1, n)) y a b :
  block_mx A B BT C *m col_mx x y = col_mx a b ->
  invertible C ->
  BT = B^T ->
  (A - B *m C^^-1 *m B^T) *m x = a - B *m C^^-1 *m b /\
  y = C^^-1 *m (b - B^T *m x).
Proof.
  move => h hi hb.
  subst.
  rewrite mul_block_col in h.
  apply eq_col_mx in h.
  move: h => [h1 h2].
  right_first hy.
  rewrite addrC in h2.
  apply mover in h2.
  by apply (moveinvmx hi).
  set goal := _ = _.
  move: h1.
  rewrite hy !mulmxA !mulmxBr !mulmxA [in _ - _] addrC addrA -mulmxBl.
  by apply mover.
Qed.

Module Notations.

Notation "A ^- u" := (mupinv u A) : ring_scope.

End Notations.


Require Export Coq.Classes.RelationClasses.

Set Default Goal Selector "all".

Class Ordered(A : Set) :=
  { lt : A -> A -> Prop;
    lt_strict :> StrictOrder lt
  }.

Class OrderedKeyed (A K : Set) :=
  { keyof : A -> K;
    OA :> Ordered A
  }.

Class KeyOrdered (A K : Set) :=
  { getkey : A -> K;
    OK :> Ordered K
  }.

Definition KOlt{A K : Set}`{KeyOrdered A K}(a b : A) : Prop := lt (getkey a) (getkey b).

Instance KOisO A K `{KeyOrdered A K} : Ordered A.
Proof.
  destruct (_:KeyOrdered A K) as [gk [ltk [SOI SOT]]]. unshelve eexists.
  - intros a b. exact (ltk (gk a) (gk b)).
  - split.
    + unfold Irreflexive, Reflexive, complement in *. intro. apply SOI.
    + unfold Transitive in *. intros x y z. apply SOT.
Defined.

Instance KOisOK A K `{KeyOrdered A K} : OrderedKeyed A K :=
  { keyof := getkey }.

Class ComparableKeyed (A K : Set) :=
  { OKOK :> OrderedKeyed A K;
    compare : K -> K -> comparison;
    compare_spec x y: CompareSpecT (eq x y)
                                   (forall (a b : A), x = keyof a -> y = keyof b -> lt a b)
                                   (forall (a b : A), x = keyof a -> y = keyof b -> lt b a)
                                   (compare x y);
    lt_same_keys w x y z: lt w y -> keyof x = keyof w -> keyof z = keyof y -> lt x z
  }.

Require Coq.Init.Nat.
Require Coq.Arith.PeanoNat.

Module Test.

  Import Nat.
  Import PeanoNat.

  Open Scope nat_scope.

  Context {A : Set}.
  Context {Ord : Ordered A}.

  Record OK : Set := { val : A; key : nat }.

  Definition OKlt (a b : OK) : Prop := a.(key) < b.(key).

  Lemma le_Sn_n : forall n, S n <= n -> False.
  Proof.
    induction n as [|? IHn]. intro H.
    - inversion H.
    - apply IHn. apply le_S_n. assumption.
  Qed.

  Lemma OKlt_strict : StrictOrder OKlt.
  Proof.
    eexists. red.
    - red. red. intros [v k]. cbv. apply le_Sn_n.
    - intros [? ?] [? ykey] [? ?]. unfold OKlt, key. transitivity ykey. assumption.
  Qed.

  Instance OKOrd : Ordered OK := { lt := OKlt; lt_strict := OKlt_strict }.

  Lemma OKOrd_compare_spec (x y:nat) :
    CompareSpecT (eq x y)
                 (forall (a b : OK), x = a.(key) -> y = b.(key) -> OKlt a b)
                 (forall (a b : OK), x = a.(key) -> y = b.(key) -> OKlt b a)
                 (Nat.compare x y).
  Proof.
    destruct (CompareSpec2Type (Nat.compare_spec x y)). constructor.
    - assumption.
    - intros ? ? -> -> . assumption.
    - intros ? ? -> -> . assumption.
  Qed.

  Lemma OKOrd_lt_same_keys w x y z :
    OKlt w y -> x.(key) = w.(key) -> z.(key) = y.(key) -> OKlt x z.
  Proof.
    unfold OKlt. intros H -> -> . assumption.
  Qed.

  Instance OKnat : OrderedKeyed OK nat := { keyof := key }.

  Instance CKnat : ComparableKeyed OK nat :=
    { compare := Nat.compare;
      compare_spec := OKOrd_compare_spec;
      lt_same_keys := OKOrd_lt_same_keys
    }.

End Test.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Naturals -- TODO: use typeclasses                                       *
**************************************************************************)

Set Implicit Arguments.
Require Export Arith Div2 Omega.
Require Import LibTactics LibReflect LibBool LibOperation LibRelation LibOrder.
Require Export LibOrder.
Global Close Scope positive_scope.

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Instance nat_inhab : Inhab nat.
Proof. intros. apply (prove_Inhab 0). Qed.

Fixpoint nat_compare (x y : nat) :=
  match x, y with
  | O, O => true
  | S x', S y' => nat_compare x' y'
  | _, _ => false
  end.

Instance nat_comparable : Comparable nat.
Proof.
  applys (comparable_beq nat_compare).
  induction x; destruct y; simpl.
  auto*.
  auto_false.
  auto_false.
  asserts_rewrite ((S x = S y) = (x = y)).
    extens. iff; omega.
  auto*.
Qed.

(* ********************************************************************** *)
(** * Order on natural numbers *)

Instance le_nat_inst : Le nat := Build_Le Peano.le.

(* ---------------------------------------------------------------------- *)
(** ** Relation to Peano, for tactic [omega] *)

Lemma le_peano : le = Peano.le.
Proof. extens*. Qed.

Global Opaque le_nat_inst.

Lemma lt_peano : lt = Peano.lt.
Proof.
  extens. rew_to_le. rewrite le_peano.
  unfold strict. intros. omega.
Qed.

Lemma ge_peano : ge = Peano.ge.
Proof.
  extens. rew_to_le. rewrite le_peano.
  unfold flip. intros. omega.
Qed.

Lemma gt_peano : gt = Peano.gt.
Proof.
  extens. rew_to_le. rewrite le_peano.
  unfold strict, flip. intros. omega.
Qed.

Hint Rewrite le_peano lt_peano ge_peano gt_peano : rew_nat_comp.
Ltac nat_comp_to_peano :=
  autorewrite with rew_nat_comp in *.

(** [nat_math] calls [omega] after basic pre-processing
    ([intros] and [split]) and after replacing comparison
    operators with the ones defined in [Peano] library. *)

Ltac nat_math_setup :=
  intros;
  try match goal with |- _ /\ _ => split end;
  try match goal with |- _ = _ :> Prop => apply prop_ext; iff end;
  nat_comp_to_peano.

Ltac nat_math :=
  nat_math_setup; omega.

(* ********************************************************************** *)
(** * Operations *)

Definition div (n q : nat) :=
  match q with
  | 0 => 0
  | S predq =>
  let aux := fix aux (m r : nat) {struct m} :=
    match m,r with
    | 0, _ => 0
    | S m',0 => (1 + aux m' predq)%nat
    | S m', S r' => aux m' r'
    end in
  aux n predq
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | 0 => 1
  | S n' => n * (factorial n')
  end.

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

Lemma peano_induction :
  forall (P:nat->Prop),
    (forall n, (forall m, m < n -> P m) -> P n) ->
    (forall n, P n).
Proof.
  introv H. cuts* K: (forall n m, m < n -> P m).
  nat_comp_to_peano.
  induction n; introv Le. inversion Le. apply H.
  intros. apply IHn. nat_math.
Qed.

Lemma measure_induction :
  forall (A:Type) (mu:A->nat) (P:A->Prop),
    (forall x, (forall y, mu y < mu x -> P y) -> P x) ->
    (forall x, P x).
Proof.
  introv IH. intros x. gen_eq n: (mu x). gen x.
  induction n using peano_induction. introv Eq. subst*.
Qed.

(* ********************************************************************** *)
(** * Simplification lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Lemma plus_zero_r : forall n,
  n + 0 = n.
Proof. nat_math. Qed.
Lemma plus_zero_l : forall n,
  0 + n = n.
Proof. nat_math. Qed.
Lemma minus_zero : forall n,
  n - 0 = n.
Proof. nat_math. Qed.

Hint Rewrite plus_zero_r plus_zero_l minus_zero : rew_nat.

(* ---------------------------------------------------------------------- *)
(** ** Comparison *)

Section CompProp.
Implicit Types a b c n m : nat.

Lemma le_SS : forall n m, (S n <= S m) = (n <= m).
Proof. nat_math. Qed.
Lemma ge_SS : forall n m, (S n >= S m) = (n >= m).
Proof. nat_math. Qed.
Lemma lt_SS : forall n m, (S n < S m) = (n < m).
Proof. nat_math. Qed.
Lemma gt_SS : forall n m, (S n > S m) = (n > m).
Proof. nat_math. Qed.

Lemma plus_le_l : forall a b c,
  (a + b <= a + c) = (b <= c).
Proof. nat_math. Qed.
Lemma plus_ge_l : forall a b c,
  (a + b >= a + c) = (b >= c).
Proof. nat_math. Qed.
Lemma plus_lt_l : forall a b c,
  (a + b < a + c) = (b < c).
Proof. nat_math. Qed.
Lemma plus_gt_l : forall a b c,
  (a + b > a + c) = (b > c).
Proof. nat_math. Qed.

Lemma plus_le_r : forall a b c,
  (b + a <= c + a) = (b <= c).
Proof. nat_math. Qed.
Lemma plus_ge_r : forall a b c,
  (b + a >= c + a) = (b >= c).
Proof. nat_math. Qed.
Lemma plus_lt_r : forall a b c,
  (b + a < c + a) = (b < c).
Proof. nat_math. Qed.
Lemma plus_gt_r : forall a b c,
  (b + a > c + a) = (b > c).
Proof. nat_math. Qed.

End CompProp.

(* todo: negation *)

(* ---------------------------------------------------------------------- *)
(** ** Simplification tactic *)

(** [rew_nat] performs some basic simplification on
    expressions involving natural numbers *)

Hint Rewrite le_SS ge_SS lt_SS gt_SS : rew_nat.
Hint Rewrite plus_le_l plus_ge_l plus_lt_l plus_gt_l : rew_nat.
Hint Rewrite plus_le_r plus_ge_r plus_lt_r plus_gt_r : rew_nat.

Tactic Notation "rew_nat" :=
  autorewrite with rew_nat.
Tactic Notation "rew_nat" "~" :=
  rew_nat; auto_tilde.
Tactic Notation "rew_nat" "*" :=
  rew_nat; auto_star.
Tactic Notation "rew_nat" "in" "*" :=
  autorewrite with rew_nat in *.
Tactic Notation "rew_nat" "~" "in" "*" :=
  rew_nat in *; auto_tilde.
Tactic Notation "rew_nat" "*" "in" "*" :=
  rew_nat in *; auto_star.
Tactic Notation "rew_nat" "in" hyp(H) :=
  autorewrite with rew_nat in H.
Tactic Notation "rew_nat" "~" "in" hyp(H) :=
  rew_nat in H; auto_tilde.
Tactic Notation "rew_nat" "*" "in" hyp(H) :=
  rew_nat in H; auto_star.

(* ********************************************************************** *)
(** * Other lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Div2 *)

Lemma div2_lt : forall n m, m <= n -> n > 0 -> div2 m < n.
Proof.
  nat_comp_to_peano.
  induction n using peano_induction. introv Le Gt.
(* todo: fix this proof that broken when migrating to v8.3
  do 2 (destruct n; try solve [omega]).
  do 2 (destruct m; try solve [omega]).
  do 2 destruct~ m. simpl. cuts~: (div2 m < S n). apply H.
  nat_math. nat_math. auto.
*) skip.
Qed.

Lemma div2_grows : forall n m, m <= n -> div2 m <= div2 n.
Proof.
  nat_comp_to_peano.
  induction n using peano_induction. introv Le.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  simpl. rew_nat. apply~ H. nat_math. nat_math.
Qed.


(* begin hide *)
Set Implicit Arguments.
Set Asymmetric Patterns.
Require Import Cpdt.CpdtTactics.
Require Import List.
(* end hide *)

(* 06. FROM DATA STRUCT *)

(* Some of the type family definitions and associated functions from this chapter are dupli-
cated in the DepList module of the book source. Some of their names have been changed to
be more sensible in a general context. *)

(*
1. Define a tree analogue of hlist. That is, define a parameterized type of binary trees with
data at their leaves, and define a type family htree indexed by trees. The structure of
an htree mirrors its index tree, with the type of each data element (which only occur
at leaves) determined by applying a type function to the corresponding element of the
index tree. *)

Section htree.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive tree (T : Type) : Type :=
  | Leaf : T -> tree T
  | Node : tree T -> tree T -> tree T.

  Inductive htree : tree A -> Type :=
  | HLeaf : forall (x : A), B x -> htree (Leaf x)
  | HNode : forall (tr1 : tree A) (tr2 : tree A), htree tr1 ->
                                                  htree tr2 ->
                                                  htree (Node tr1 tr2).

(* Define a type standing for all possible paths from the root of a tree to
leaves and use it to implement a function tget for extracting an element of an htree
by path. *)

 Variable elm : A.

 Inductive membert : tree A -> Type :=
 | HThis : membert (Leaf elm)
 | HLeft : forall tr1 tr2, membert tr1 -> membert (Node tr1 tr2)
 | HRight : forall tr1 tr2, membert tr2 -> membert (Node tr1 tr2).

 Print Empty_set.
(*
Fixpoint tget tr (mtr : htree tr) : membert tr -> B elm :=
  match mtr with
  | HLeaf _ bx => fun mem => (match mem in membert (Leaf h) return (B h -> B elm) with
                             | HThis => fun x => x
                             | _ => fun x => x
                             end) bx
  | HNode t1 t2 Ht1 Ht2 => fun mem => match mem in membert tr' return (match tr' with
                                                                      | Leaf _ => unit
                                                                      | Node lt rt =>
                                                                        (membert lt -> B elm) ->
                                                                        (membert rt -> B elm) ->
                                                                        B elm
                                                                      end) with
                                      | HThis => tt
                                      | HLeft _ _ meml => tget t1 _ Ht1
                                      | HRight _ _ memr => tget t2 _ Ht2
                                      end
  end.
*)
End htree.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).
  (* получает
     ls - список эл-в типа A (ANat | ABool)
     mls : hlist ls
     возвращает (B elm) - элемент типа nat, 3, например *)

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => match

End hlist.

(* Example of HList by Adam Chlipala, from the book *)
Arguments HNil {A B}.
Arguments HCons {A B x ls}.
Arguments HFirst {A elm ls}.
Arguments HNext {A elm x ls}.

Definition someTypes : list Set := nat :: bool :: nil.
Example someValues : hlist (fun T : Set => T) someTypes := HCons 5 (HCons true HNil).

Eval simpl in hget someValues HFirst.
Eval simpl in hget someValues (HNext HFirst).

Example somePairs : hlist (fun T : Set => T * T)%type someTypes := HCons (1,2) (HCons (true, false)HNil).

(* Example of hlist by Natasha*)
Inductive atype := ANat | ABool. (*  elements of type A  *)

Definition b_type : atype -> Type := (*  function B  *)
  fun x => match x with
           | ANat => nat
           | ABool => bool
           end.

Check HCons.
Check (@HCons atype b_type ANat nil 3 (@HNil atype b_type)).
Check @HCons atype b_type ABool (ANat :: nil) true (@HCons atype b_type ANat nil 3 (@HNil atype b_type)).

(* Define a function htmap2 for "mapping over two trees in parallel." That is,
htmap2 takes in two htrees with the same index tree, and it forms a new htree with
the same index by applying a binary function pointwise.
Repeat this process so that you implement each definition for each of the three defini-
tion styles covered in this chapter: inductive, recursive, and index function.
 *)