Require Import List  ListSet Bool FinFun Omega Ring.
Import ListNotations.

Lemma empty_list_not_equal_app (A: Type):
  forall (l1 l2: list A) (a: A), [] <> l1 ++ a :: l2.
Proof.
  induction l1; simpl.
  discriminate.
  intros H; inversion H; intros a0; discriminate.
Qed.

Section hd_error.
  Lemma hd_error_nil: forall A (l: list A), hd_error l = None <-> l = [].
  Proof.
    intros A l.
    compute; destruct l; split; auto; intros H; contradict H; discriminate.
  Qed.

  Lemma hd_error_cons (A: Type): forall l1 (a : A),
      hd_error l1 = Some a <-> exists l2, l1 = a :: l2.
  Proof.
    intros l1 a.
    split.
    - unfold hd_error.
      destruct l1; intros H; auto.
      contradict H; discriminate.
      inversion H; rewrite <- H1; exists l1; reflexivity.
    - intros H; destruct H as [l2 l2_def]; rewrite l2_def; simpl; reflexivity.
  Qed.
End hd_error.

Section In.

  Lemma in_singleton: forall (B: Type) (a b: B), In a [b] <-> a = b.
  Proof.
    split; simpl; intros H; destruct H; auto; tauto.
  Qed.

  Lemma in_not_exists_in_empty_list (A: Type): ~ (exists a : A, In a []).
  Proof.
    intros NonEmpty.
    destruct NonEmpty as [q NonEmpty]; apply in_nil in NonEmpty; auto.
  Qed.

  Lemma in_concat : forall A (l1 l2 : list A) (a b : A),
      In a (l1 ++ l2) -> In a (l1 ++ b :: l2).
  Proof.
    intros A l1 l2 a b.
    induction l1; simpl; intros H; auto.
    destruct H; [left | apply IHl1 in H]; auto.
  Qed.

  Lemma in_not_append (A: Type): forall (l1 l2: list A) a,
      ~ In a l1 -> ~ In a l2 -> ~ In a (l1 ++ l2).
  Proof.
    induction l1; intros l2 b a_not_in_l1 a_not_in_l2.
    - simpl; auto.
    - intros b_in_list.
      apply in_app_or in b_in_list.
      destruct b_in_list as [b_first | b_rest]; auto.
  Qed.

  Lemma in_shuffle : forall A (l1 l2 : list A) (a b : A),
      In a (l1 ++ b :: l2) <-> In a (b :: l1 ++ l2).
    intros A l1 l2 a b.
    induction l1.
    simpl; reflexivity.
    simpl.
    split.
    intros H.
    destruct H; [right; left | auto]; auto.
    rewrite IHl1 in H.
    simpl in H.
    destruct H; auto.
    intros Q.
    destruct Q.
    right; rewrite IHl1, H; simpl; auto.
    destruct H; auto.
    rewrite IHl1.
    right; simpl; right; assumption.
  Qed.
End In.

Section filter.

  Lemma filter_length_equiv: forall (A: Type) g h (l': list A),
      (forall a, g a = h a) -> length (filter g l') = length (filter h l').
  Proof.
    intros B g h l' fn_equiv; induction l'; simpl; auto.
    replace (g a) with (h a); [ | rewrite fn_equiv; reflexivity ].
    destruct (h a); simpl; rewrite IHl'; auto.
  Qed.

  Lemma filter_NotIn : forall (A: Type) f x (l : list A),
      ~In x l -> ~In x (filter f l).
  Proof.
    intros A f x.
    induction l.
    (* base case *)
    simpl; auto.
    (* inductive case *)
    rewrite not_in_cons.
    simpl; destruct (f a); simpl.
    intros [x_not_a H].
    unfold not.
    intros H2.
    destruct H2; auto.
    apply IHl; auto.
    intros [x_not_a H].
    apply IHl; assumption.
  Qed.

  Lemma filter_NoDup :
    forall  (A: Type) f (l: list A), NoDup l -> NoDup (filter f l).
  Proof.
    induction l; auto.
    simpl; auto.
    intros NoDupeList.
    replace (NoDup (a :: l)) with (NoDup ([] ++ a :: l)) in NoDupeList.
    apply NoDup_remove in NoDupeList; simpl in NoDupeList.
    destruct NoDupeList as [NoDup_l a_not_in_l].
    simpl.
    destruct (f a).
    apply NoDup_cons.
    apply filter_NotIn; assumption.
    1-2: apply IHl; assumption.
    simpl; reflexivity.
  Qed.

  (* this makes the next proof slightly nicer ;) *)
  Lemma true_dec : forall b, {b = true} + {b = false}.
    intros b.
    destruct (bool_dec b true); auto.
    apply not_true_is_false in n; auto.
  Qed.

  (* random filter lemmas since the standard lib doesn't have much *)
  Lemma filter_empty_head: forall (A: Type) f (l: list A) a, filter f (a :: l) = [] -> f a <> true.
    intros A f l a.
    intros Filter.
    unfold filter in Filter.
    destruct (bool_dec (f a) true) in Filter.
    rewrite e in Filter; contradict Filter; congruence.
    assumption.
  Qed.

  Lemma filter_empty_rest: forall (A: Type) f (l: list A) a, filter f (a :: l) = [] -> filter f l = [].
    intros A f l a Filter.
    unfold filter in Filter; destruct (f a) in Filter.
    contradict Filter; congruence.
    fold filter in Filter; assumption.
  Qed.

  Lemma filter_head : forall (A: Type) f a (l: list A), f a = true -> filter f (a :: l) = a :: filter f l.
    intros A f a l fa_true.
    unfold filter.
    rewrite fa_true.
    reflexivity.
  Qed.

  Lemma filter_cons : forall (A: Type) f (l1 l2: list A), filter f (l1 ++ l2) = (filter f l1) ++ (filter f l2).
    intros A f.
    induction l1; intros l2.
    repeat rewrite app_nil_r; reflexivity.
    unfold filter.
    destruct (true_dec (f a)) as [Q | Q];
      rewrite <- app_comm_cons;
      rewrite Q;
      fold (filter f (l1 ++ l2));
      fold (filter f l1);
      fold (filter f l2).
    rewrite <- app_comm_cons; congruence.
    congruence.
  Qed.

  Lemma filter_empty: forall (A: Type) f (l: list A), filter f l = [] -> forall a, In a l -> f a <> true.
    intros A f l Filter a.
    intros I.
    apply in_split in I.
    destruct I as [l1 [l2 Q]].
    rewrite Q in Filter.
    rewrite filter_cons in Filter.
    apply app_eq_nil in Filter.
    destruct Filter as [_ filter_fa_nil].
    apply filter_empty_head in filter_fa_nil; assumption.
  Qed.

  Lemma filter_inv : forall A f (l1 l2: list A) a, filter f l1 = a :: l2 -> f a = true. (* /\ l1 = a :: l3 /\ filter f l3 = l2.*)
    intros A f l1 l2 a Filter.
    induction l1.
    (* base case *)
    contradict Filter.
    simpl; congruence.
    (* induction step *)
    simpl in Filter.
    destruct (true_dec (f a0)) as [f_a0_true | f_a0_false] in Filter.
    rewrite f_a0_true in Filter.
    inversion Filter as [e].
    rewrite <- e.
    assumption.
    rewrite f_a0_false in Filter.
    apply IHl1; assumption.
  Qed.

  Lemma filter_bounded (A: Type) (l: list A) f :
    length (filter f l) <= length l.
  Proof.
    induction l; simpl.
    * omega.
    * destruct (f a); simpl; omega.
  Qed.

  Lemma filter_negb (A: Type) (l: list A) f :
    length (filter (fun x => negb (f x)) l) = length l - length (filter f l).
  Proof.
    induction l.
    simpl; reflexivity.
    simpl.
    destruct (true_dec (negb (f a))).
    rewrite negb_true_iff in e.
    rewrite e.
    simpl.
    rewrite IHl.
    fold filter.
    remember (filter_bounded _ l f).
    destruct Heql0.
    destruct (length (filter f l)); omega.
    rewrite e.
    rewrite negb_false_iff in e.
    rewrite e.
    rewrite IHl.
    remember (filter_bounded _ l f).
    destruct Heql0.
    simpl.
    reflexivity.
  Qed.

  Lemma filter_eq (A: Type) (f g: A -> bool) :
    forall l, (forall a, f a = g a) -> filter f l = filter g l.
  Proof.
    induction l; intros fg_equiv; simpl.
    - reflexivity.
    - rewrite fg_equiv, IHl; auto.
  Qed.

  Lemma filter_split: forall (A: Type) (l l': list A) f b,
      filter f l = b :: l' -> exists l2 l3, l = l2 ++ b :: l3 /\ forall b, In b l2 -> f b = false.
  Proof.
    induction l; intros l' f b; simpl; intro filter_eq.
    contradict filter_eq; discriminate.
    destruct (bool_dec (f a) true) as [fa_true | fa_false].
    rewrite fa_true in filter_eq.
    inversion filter_eq as [a_eq_b].
    exists []; exists l; simpl; split; [reflexivity | intros b' H'; contradict H'].
    apply not_true_is_false in fa_false.
    rewrite fa_false in filter_eq.
    apply IHl in filter_eq.
    destruct filter_eq as [l2 [l3 [l_eq l_not_contains]]].
    exists (a :: l2), l3.
    split; [rewrite l_eq; reflexivity | simpl; intros c].
    intros [a_eq_c | c_in_l2]; [rewrite <- a_eq_c | apply l_not_contains]; assumption.
  Qed.
End filter.

Section ListFunctions.
  (* We will use ListInjective rather than Injective for NoDup equality *)

  Definition ListInjective (A B: Type) (f: A -> B) (l: list A) :=
    (forall x y: A, In x l -> In y l -> f x = f y -> x = y).

  Global Arguments ListInjective [A] [B] _ _.

  Lemma injective_implies_listinjective (A B: Type):
    forall (f: A -> B) l, Injective f -> ListInjective f l.
  Proof.
    intros f l Injective.
    unfold ListInjective.
    intros; apply Injective; auto.
  Qed.

  Lemma listinjective_cons (A B: Type):
    forall (f: A -> B) l a, ListInjective f (a::l) -> ListInjective f l.
  Proof.
    intros.
    unfold ListInjective in H.
    unfold ListInjective.
    intros x y x_in y_in.
    apply H; simpl; auto.
  Qed.

  Definition ListSurjective (A B: Type) (f: A -> B) (l: list B) (l': list A) :=
    (forall x: B, In x l -> exists y, In y l' /\ f y = x).

  Global Arguments ListSurjective [A] [B] _ _.

  Lemma listsurjective_cons (A B: Type):
    forall (f: A -> B) l l' a, ListSurjective f (a::l) l' -> ListSurjective f l l'.
  Proof.
    intros.
    unfold ListSurjective in H.
    unfold ListSurjective; intros; apply H; simpl; auto.
  Qed.

  Lemma listsurjective_cons2 (A B: Type):
    forall (f: A -> B) l l' a, ListSurjective f (f a :: l) l' -> ListSurjective f l l'.
  Proof.
    intros f l l' a H.
    unfold ListSurjective.
    intros c c_in.
    apply (H c).
    simpl; auto.
  Qed.

  Lemma listsurjective_incl1 (A B: Type):
    forall (f: A -> B) l xs ys, incl ys xs -> ListSurjective f l ys -> ListSurjective f l xs.
  Proof.
    intros f l xs ys list_incl ys_surjective.
    unfold ListSurjective.
    intros d.
    intros.
    destruct (ys_surjective d) as [q [q_in_y def_q]]; auto.
    exists q.
    split; auto.
  Qed.

  Lemma listsurjective_shows_incl (A B: Type):
    forall (f: A -> B) l1 l2, ListSurjective f l2 l1 -> incl l2 (map f l1).
  Proof.
    intros f l1 l2 Surjective.
    intros d.
    rewrite in_map_iff.
    intros d_in.
    apply (Surjective d) in d_in.
    destruct d_in as [q [def_q q_in]].
    exists q.
    auto.
  Qed.

  Definition ListIsomorphism (A B: Type) (f: A -> B) (l1: list A) (l2: list B) :=
    ListInjective f l1 /\ ListSurjective f l2 l1 /\
    (forall d, In d l1 -> In (f d) l2).

  Global Arguments ListSurjective [A] [B] _ _.
  Global Arguments ListIsomorphism [A] [B] _ _.

End ListFunctions.

Section NoDup.

  Lemma NoDup_append: forall (A: Type) (l1 l2: list A),
      NoDup l1 -> NoDup l2 -> (forall a, In a l1 -> ~ In a l2) -> NoDup (l1 ++ l2).
  Proof.
    intros A.
    induction l1; intros l2 l1_NoDup l2_NoDup NotInL2; simpl; auto.
    apply NoDup_cons; apply NoDup_cons_iff in l1_NoDup;
      destruct l1_NoDup;
      [ apply in_not_append, NotInL2 | apply IHl1 ]; simpl; auto.
    intros; apply NotInL2; apply in_cons; auto.
  Qed.

  Lemma NoDup_cons_reduce (A: Type): forall (l: list A) a, NoDup (a :: l) -> NoDup l.
  Proof.
    intros l a.
    rewrite NoDup_cons_iff; tauto.
  Qed.

  Lemma NoDup_listinjection_length_lte : forall A B (l1: list A) (l2: list B) f,
      NoDup l1 ->
      NoDup l2 ->
      ListInjective f l1 ->
      (forall c, In c l1 -> In (f c) l2) ->
      length l1 <= length l2.
  Proof.
    intros A B; induction l1; intros l2 f NoDup_l1 NoDup_l2 f_Injective Injection.
    auto with arith.
    remember (in_eq a l1) as Q.
    destruct HeqQ.
    apply (Injection a) in Q.
    apply in_split in Q.
    destruct Q as [l1' [l3' l2_def]].
    rewrite l2_def.
    replace (length (l1' ++ f a :: l3')) with (S (length (l1' ++ l3'))).
    simpl.
    apply le_n_S.
    apply (IHl1 (l1' ++ l3') f).
    apply NoDup_cons_iff in NoDup_l1; destruct NoDup_l1; auto.
    rewrite l2_def in NoDup_l2; apply NoDup_remove in NoDup_l2.
    destruct NoDup_l2; auto.
    apply (listinjective_cons _ _ _ _ a); auto.
    2: autorewrite with list; simpl; auto with arith.
    (* show if c in l1, then f c is in l1' ++ l3'.  required to apply IH *)
    intros c.
    intros c_in_l1.
    assert (In (f c) l2) as fc_in_l2.
    apply Injection, in_cons; assumption.
    rewrite l2_def in fc_in_l2.
    rewrite in_shuffle in fc_in_l2.
    destruct (in_inv fc_in_l2); [|assumption].
    (* this scenario is impossible because f is injective *)
    apply f_Injective in H; simpl; auto.
    rewrite <- H in c_in_l1.
    apply NoDup_cons_iff in NoDup_l1; destruct NoDup_l1; contradict H0; auto.
  Qed.

  Lemma listsurjective_NoDup_bounds_length (A B: Type):
    forall (f: A -> B) l1 l2, ListSurjective f l2 l1 -> NoDup l2 -> length l2 <= length l1.
  Proof.
    intros f l1 l2 l2_NoDup Surjective.
    replace (length l1) with (length (map f l1)) by apply map_length.
    apply NoDup_incl_length; [ | apply listsurjective_shows_incl]; auto.
  Qed.

  Lemma listisomorphism_NoDup_same_length (A B: Type):
    forall (f: A -> B) l1 l2,
      ListIsomorphism f l1 l2 ->
      NoDup l1 ->
      NoDup l2 ->
      length l1 = length l2.
  Proof.
    intros f l1 l2 [f_Injective [f_Surjective f_Covers]] l1_NoDup l2_NoDup.
    assert (length l1 <= length l2).
    apply (NoDup_listinjection_length_lte _ _ l1 l2 f); auto.
    assert (length l2 <= length l1).
    apply (listsurjective_NoDup_bounds_length _ _ f l1 l2); auto.
    omega.
  Qed.

End NoDup.

Section partition.

  Theorem partition_ind_fst:
    forall (A: Type) f (P : list A -> Prop),
      P [] ->
      (forall a l, f a = true -> P l -> P (a :: l)) ->
      forall l, P (fst (partition f l)).
  Proof.
    intros A f P P_empty P_ind_first.
    induction l; [apply P_empty | auto].
    simpl.
    destruct (partition f l).
    destruct (true_dec (f a)); rewrite e; [apply P_ind_first | auto]; assumption.
  Qed.

  Theorem partition_ind_snd (A: Type) f (P : list A -> Prop) :
      P [] ->
      (forall a l, f a = false -> P l -> P (a :: l)) ->
      forall l, P (snd (partition f l)).
  Proof.
    intros P_empty P_ind_snd.
    induction l; [apply P_empty | auto].
    simpl.
    destruct (partition f l).
    destruct (true_dec (f a)); rewrite e; [auto | apply P_ind_snd]; assumption.
  Qed.

  Lemma partition_fst (A: Type)  (f: A -> bool) (a : A) l :
    In a (fst (partition f l)) -> f a = true.
  Proof.
    apply partition_ind_fst.
    intros in_fst; contradict in_fst; auto.
    intros a0 l0 f_a0 In_a_l0; simpl.
    intros [a_first | a_rest]; [rewrite <- a_first | apply In_a_l0]; assumption.
  Qed.

  Lemma partition_snd (A: Type)  (f: A -> bool) (a : A) l :
    In a (snd (partition f l)) -> f a = false.
  Proof.
    apply partition_ind_snd.
    intros in_snd; contradict in_snd; auto.
    intros a0 l0 f_a0 In_a_l0; simpl.
    intros [a_first | a_rest]; [rewrite <- a_first | apply In_a_l0]; assumption.
  Qed.

End partition.

Section fold_set_add.

  Lemma fold_set_add_in (A: Type) (l: list A) (eq_dec: forall (x y : A), {x = y} + {x <> y}):
    forall c, In c (fold_right (set_add eq_dec) (empty_set A) l) <-> In c l.
  Proof.
    induction l; intros c.
    - simpl; tauto.
    - simpl.
      rewrite set_add_iff.
      split; intros Q; destruct Q; auto; right; apply IHl; auto.
  Qed.

  Lemma fold_set_NoDup (A: Type) (l: list A) (eq_dec: forall (x y : A), {x = y} + {x <> y}):
    NoDup (fold_right (set_add eq_dec) (empty_set A) l).
  Proof.
    induction l.
    - unfold empty_set; simpl; apply NoDup_nil.
    - simpl; apply set_add_nodup; auto.
  Qed.

End fold_set_add.

Section concat.

  Lemma length_concat: forall (B: Type) (l1: list (list B)) m,
      (forall l2, In l2 l1 -> length l2 = m) ->
      length (concat l1) = m * length l1.
  Proof.
    intros B l1 m len_proof.
    induction l1; simpl; auto.
    autorewrite with list.
    rewrite IHl1.
    rewrite len_proof.
    rewrite Nat.mul_succ_r; auto with arith.
    simpl; left; auto.
    intros l0 l0_in_l1; apply len_proof.
    simpl; right; auto.
  Qed.

End concat.

Section concat_map.

  Lemma in_concat_map: forall (A B: Type) (f: A -> list B) b (l: list A),
      In b (concat (map f l)) <-> exists a, In b (f a) /\ In a l.
  Proof.
    intros A B f b.
    induction l; simpl; split.
    - intros H; contradict H; auto.
    - intros H; destruct H; tauto.
    - intros In_b.
      apply in_app_or in In_b.
      destruct In_b as [b_in_f_a | b_in_rest];
        [exists a | apply IHl in b_in_rest; destruct b_in_rest as [d def_d]; exists d];
        tauto.
    - intros [a0 [H1 H2]].
      apply in_or_app.
      destruct H2 as [a_first | a_rest];
        [left; rewrite a_first | right; apply IHl; exists a0]; auto.
  Qed.

End concat_map.

Section fn_partitions.

  Variable (A: Type).
  Variable (f: A -> A).
  Variable (l: list A).
  Variable eq_dec: forall (x y: A), {x = y} + {x <> y}.

  (* TODO: try out a list-based partition, might be less annoying *)
  Inductive fn_partition n :=
  | fn_partition_intro:
      Listing l ->
      (* not sure how to name this condition *)
      (forall x, In x (map f l) -> f x = x) ->
      (forall x, f x = x -> length (filter (fun y => if eq_dec (f y) x then true else false) l) = n) ->
      fn_partition n.

  Definition partition_reprs := fold_right (set_add eq_dec) (empty_set A) (map f l).
  Definition partition_elems a := (filter (fun x => if eq_dec (f x) a then true else false) l).

  Lemma partition_reprs_NoDup: NoDup partition_reprs.
  Proof.
    unfold partition_reprs.
    induction l.
    - unfold empty_set; simpl; apply NoDup_nil.
    - simpl; apply set_add_nodup; auto.
  Qed.

  Lemma partition_reprs_in : forall a, Listing l -> In (f a) partition_reprs.
  Proof.
    intros a Listing.
    unfold partition_reprs.
    rewrite fold_set_add_in.
    apply in_map, Listing.
  Qed.

  Lemma partition_reprs_in2 n: forall d,
      fn_partition n -> In d partition_reprs -> f d = d.
  Proof.
    intros d.
    unfold partition_reprs.
    rewrite fold_set_add_in.
    intros Partition; apply Partition.
  Qed.

  Lemma partition_elems_in : forall a b, In b (partition_elems a) -> f b = a.
  Proof.
    intros a b.
    unfold partition_elems.
    rewrite filter_In.
    destruct (eq_dec (f b) a); auto.
    intros [_ C]; contradict C; congruence.
  Qed.

  Lemma partition_elems_in2: forall a, Listing l -> In a (partition_elems (f a)).
  Proof.
    intros a Listing.
    unfold partition_elems.
    rewrite filter_In.
    split; [apply Listing | destruct (eq_dec (f a) (f a)) ]; auto.
  Qed.

  Lemma partition_elems_NoDup n: forall a, fn_partition n -> NoDup (partition_elems a).
  Proof.
    intros a Partition; apply filter_NoDup.
    apply Partition.
  Qed.

  Lemma partition_elems_length n:
    fn_partition n ->
    forall a, f a = a -> length (partition_elems a) = n.
  Proof.
    intros [_ _ Partition] a.
    unfold partition_elems.
    intros fa_eq_a.
    rewrite <- (Partition a); auto.
  Qed.

  Definition expand_partition :=
    flat_map (fun x => list_prod [x] (partition_elems x)) partition_reprs.

  Definition concat_map_list_prod: forall (B: Type) (l': list B) (f: B -> list B),
      (forall x, NoDup (f x)) -> NoDup l' ->
      NoDup (concat (map (fun x => list_prod [x] (f x)) l')).
  Proof.
    intros B l2 g l1_NoDup l2_NoDup.
    induction l2.
    simpl; apply NoDup_nil.
    simpl.
    autorewrite with list.
    apply NoDup_append.
    - apply Injective_map_NoDup; [intros x y H; inversion H; reflexivity | apply l1_NoDup].
    - apply NoDup_cons_reduce in l2_NoDup; apply IHl2; auto.
    - intros q q_in_map.
      (* first show q has the form (a, d) *)
      (* then use nodup in l2_NoDup *)
      rewrite in_map_iff in q_in_map.
      destruct q_in_map as [d [q_form q_in_ga]].
      rewrite in_concat_map.
      intros [t [t_in_map t_in_l2]].
      rewrite app_nil_r in t_in_map.
      rewrite in_map_iff in t_in_map.
      destruct t_in_map as [u [u_form u_in_gt]].
      rewrite <- u_form in q_form.
      inversion q_form.
      rewrite NoDup_cons_iff in l2_NoDup.
      rewrite H0 in l2_NoDup.
      tauto.
  Qed.

  Theorem expand_partition_NoDup n:
    fn_partition n ->
    NoDup (expand_partition).
  Proof.
    intros Partition.
    unfold expand_partition.
    rewrite flat_map_concat_map.
    apply concat_map_list_prod.
    intros x; apply (partition_elems_NoDup n); auto.
    apply partition_reprs_NoDup.
  Qed.

  Theorem expand_partition_in:
    Listing l ->
    forall c, In c expand_partition <-> (exists d, c = (f d, d)).
  Proof.
    intros Listing c.
    unfold expand_partition.
    rewrite flat_map_concat_map.
    rewrite in_concat_map.
    split.
    - intros [a [a_in_c a_in_reprs]].
      destruct c as (r, s).
      rewrite in_prod_iff in a_in_c.
      elim a_in_c.
      rewrite (in_singleton _ r a).
      intros r_is_a s_in_elem_a.
      apply partition_elems_in in s_in_elem_a.
      exists s.
      rewrite r_is_a, s_in_elem_a.
      reflexivity.
    - intros [d c_has_form].
      exists (f d).
      split; [ | apply partition_reprs_in ]; auto.
      rewrite c_has_form, in_prod_iff.
      split; [ apply in_singleton | apply partition_elems_in2 ]; auto.
  Qed.

  Theorem expand_partition_isomorphism:
    Listing l ->
    ListIsomorphism snd expand_partition l.
  Proof.
    intros Listing.
    try repeat split.
    - unfold ListInjective.
      simple destruct x; simple destruct y; simpl.
      intros a1 a2 H0 H1 H2.
      rewrite <- H2 in H1.
      rewrite expand_partition_in in H0; auto.
      rewrite expand_partition_in in H1; auto.
      (* this is dumb *)
      destruct H0.
      destruct H1.
      inversion H.
      inversion H0.
      rewrite <- H6, <- H4, <- H2.
      reflexivity.
    - unfold ListSurjective.
      intros d d_in_seq.
      exists (pair (f d) d).
      simpl.
      rewrite expand_partition_in; auto.
      split; try exists d; auto.
    - simple destruct d; simpl; intros; apply Listing.
  Qed.

  Theorem expand_partition_same_size n:
    fn_partition n ->
    length expand_partition = length l.
  Proof.
    intros Partition.
    apply (listisomorphism_NoDup_same_length _ _ snd _ l); try apply Partition.
    apply expand_partition_isomorphism; apply Partition.
    apply (expand_partition_NoDup n); auto.
  Qed.

  Theorem expand_partition_length n:
      fn_partition n ->
      length expand_partition = length partition_reprs * n.
  Proof.
    intros Partition.
    unfold expand_partition.
    rewrite flat_map_concat_map.
    rewrite (length_concat _ _ n); auto.
    rewrite map_length; auto with arith.
    intros l2.
    rewrite in_map_iff.
    intros [d [d_form d_in_list]].
    rewrite <- d_form.
    rewrite prod_length.
    rewrite (partition_elems_length n).
    auto with arith.
    apply Partition.
    apply Partition.
    apply (partition_reprs_in2 n) in d_in_list; auto.
    rewrite <- d_in_list.
    apply in_map, Partition.
  Qed.

End fn_partitions.

Section nth_error.

  Lemma nth_error_step (A: Type): forall n (l: list A) a h,
      nth_error (a :: l) (n + 1) = Some h <-> nth_error l n = Some h.
  Proof.
    induction n; induction l; intros b h; simpl.
    * tauto.
    * tauto.
    * destruct n; simpl; tauto.
    * rewrite IHn; tauto.
  Qed.

  Theorem nth_error_Some2 : forall (A: Type) (l : list A) (n : nat) b,
      nth_error l n = Some b -> n < length l.
  Proof.
    intros A l n b.
    remember (nth_error_Some l n) as OtherLemma.
    intros H.
    apply OtherLemma; rewrite H; discriminate.
  Qed.

  Lemma nth_error_seq : forall len start m,
      m < len -> nth_error (seq start len) m = Some (start + m).
  Proof.
    induction len.
    intros start m; omega.
    intros start m m_lt_Slen.
    simpl.
    destruct m.
    simpl; auto.
    simpl.
    apply lt_S_n, (IHlen (S start) m) in m_lt_Slen.
    rewrite m_lt_Slen, Nat.add_succ_comm; auto.
  Qed.

End nth_error.

Section combine.

  Lemma combine_nil :forall (C D: Type) (l': list C), combine l' (@nil D) = [].
  Proof.
    induction l'; auto.
  Qed.

  Lemma combine_nil2 :forall (C D: Type) (l': list C), combine (@nil D) l' = [].
  Proof.
    induction l'; auto.
  Qed.

  Lemma combine_seq: forall (C: Type) l m (b : C) len,
      len > 0 ->
      combine (seq m len) (b :: l) = (m, b) :: (combine (seq (m + 1) (len - 1)) l).
  Proof.
    intros C; induction l; intros m b len; simpl.
    rewrite combine_nil; simpl.
    destruct len;
      [intros; omega |
       simpl; rewrite combine_nil; intros; reflexivity].
    intros len_gt_0.
    destruct len.
    contradict len_gt_0; omega.
    simpl.
    replace (len - 0) with len by omega.
    replace (S m) with (m + 1) by omega.
    reflexivity.
  Qed.

  Lemma combine_seq2 (B: Type): forall (l: list B) start len p l2,
      combine (seq start len) l = p :: l2 ->
      fst p = start /\
      combine (seq (start + 1) (len - 1)) (tl l) = l2.
  Proof.
    induction l; intros start len p l2.
    rewrite combine_nil; intros CombineEq; contradict CombineEq; discriminate.
    intros CombineEq.
    assert (~(len = 0)) as LengthNotZero.
    intros Not; rewrite Not in CombineEq;
      simpl in CombineEq; contradict CombineEq; discriminate.
    rewrite combine_seq in CombineEq; [| omega].
    inversion CombineEq as [[hd l']]; simpl; tauto.
  Qed.

  Lemma seq_step: forall start len,
      len > 0 ->
      seq start len = start :: seq (start + 1) (len - 1).
  Proof.
    intros start; destruct len.
    intros H; contradict H; omega.
    intros H; simpl; replace (start + 1) with (S start) by omega; rewrite Nat.sub_0_r; reflexivity.
  Qed.

  Lemma combine_seq_map_l (B: Type): forall (l: list B) start len,
      length l = len ->
      seq start len = map fst (combine (seq start len) l).
  Proof.
    induction l; intros start len; simpl.
    rewrite combine_nil; intros H; symmetry in H; rewrite H; simpl; reflexivity.
    intros H.
    rewrite combine_seq; simpl; [|omega].
    rewrite <- (IHl (start + 1) (len - 1)), <- seq_step; [reflexivity|omega|omega].
  Qed.

  Lemma combine_seq_bound (A: Type):
    forall l' (l: list A) p start len,
      combine (seq start len) l = p :: l' ->
      (forall p', In p' l' -> fst p < fst p').
  Proof.
    induction len.
    simpl.
    intros H; contradict H; discriminate.
    intros CombineEq.
    simpl in CombineEq.
    destruct l.
    * contradict CombineEq; discriminate.
    * inversion CombineEq as [[start_eq_p combine_eq]].
      intros p' In_p'; destruct p' as [n b].
      apply in_combine_l, in_seq in In_p'; simpl; omega.
  Qed.

  Lemma combine_seq_length (A: Type):
    forall l2 (l: list A)  start len (p: nat * A) l3,
      combine (seq start len) l = l2 ++ p :: l3 -> length l2 = fst p - start.
  Proof.
    induction l2; intros l start len p l3; simpl.
    - intros H; apply combine_seq2 in H; destruct H as [start_eq _];
        rewrite start_eq; auto with arith.
    - intros H.
      assert (combine (seq start len) l = a :: l2 ++ p :: l3) as H' by assumption.
      cut (fst a < fst p).
      intros Cut.
      apply combine_seq2 in H'; destruct H' as [start_eq combine_rest].
      apply IHl2 in combine_rest; rewrite combine_rest.
      omega.
      apply (combine_seq_bound A (l2 ++ p :: l3) l a start len H p).
      rewrite in_app_iff; right; simpl; left; reflexivity.
  Qed.

  (* ugly proof *)
  Theorem combine_nth_error (A B: Type): forall n (l1: list A) (l2: list B) h j,
      (nth_error l1 n = Some h /\ nth_error l2 n = Some j) <->
      nth_error (combine l1 l2) n = Some (h, j).
  Proof.
    induction n; simpl; intros l1 l2 h j; split.
    intros [nth_l1 nth_l2]; destruct l1; destruct l2; simpl; try discriminate.
    inversion nth_l1; inversion nth_l2; auto.
    intros l1_l2_combine; destruct l1; destruct l2;
      try rewrite combine_nil in l1_l2_combine;
      try rewrite combine_nil2 in l1_l2_combine;
      [ | | | simpl in l1_l2_combine; inversion l1_l2_combine; tauto];
      contradict l1_l2_combine; discriminate.
    intros [nth_l1 nth_l2]; destruct l1; destruct l2; simpl; try discriminate.
    apply IHn; tauto.
    intros l1_l2_combine.
    destruct l1; destruct l2;
      try rewrite combine_nil in l1_l2_combine;
      try rewrite combine_nil2 in l1_l2_combine;
      [ | | | simpl in l1_l2_combine; inversion l1_l2_combine; apply IHn ; tauto];
      contradict l1_l2_combine; discriminate.
  Qed.

  Theorem combine_nth_error2 (A B: Type): forall (l1: list A) (l2: list B) h j,
      In (h, j) (combine l1 l2) -> exists n, nth_error l1 n = Some h /\ nth_error l2 n = Some j.
  Proof.
    induction l1; induction l2; intros h j in_hj.
    * rewrite combine_nil in in_hj; contradict in_hj.
    * rewrite combine_nil2 in in_hj; contradict in_hj.
    * rewrite combine_nil in in_hj; contradict in_hj.
    * simpl in in_hj.
      destruct in_hj as [n_eq_0 | n_in_rest].
      - exists 0; inversion n_eq_0 as [[rew1 rew2]].
        rewrite <- rew1, <- rew2; simpl; tauto.
      - apply IHl1 in n_in_rest.
        destruct n_in_rest as [m [rew1 rew2]].
        exists (m + 1).
        split; simpl; rewrite nth_error_step; assumption.
  Qed.

  Lemma filter_combine: forall (A: Type) (l: list A) f m len,
      forall j q, In (j, q) (filter f (combine (seq m len) l)) -> m <= j.
  Proof.
    intros A; induction l; intros f m len j q in_jq.
    rewrite combine_nil in in_jq; contradict in_jq.
    assert (len > 0) as len_gt_0.
    destruct len;
      [simpl in in_jq; contradict in_jq; discriminate | omega].
    rewrite combine_seq in in_jq; auto.
    simpl in in_jq.
    destruct (bool_dec (f (m, a)) true) as [fma | fma];
      [ | apply not_true_is_false in fma]; rewrite fma in in_jq.
    simpl in in_jq.
    destruct in_jq as [ma_first | in_rest];
      [inversion ma_first | apply (IHl f (m + 1)) in in_rest]; omega.
    apply IHl in in_jq; omega.
  Qed.

End combine.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*                     Abelian group structure                         *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

Require Import ssreflect ssrbool ssrfun ssrnat.
Require Import eqtype seq fintype finset.
Require Import groups div bigops.

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

Import GroupScope.

(*
Structure theorem for abelian finite groups. The development involves:
- definition of "base" (may be replaced by the one in pgroups).
- a functional (from finGroupType to nat) representation for combination
  of elements in an abelian setting.
- a reflection lemma relating generated groups to the above functional
  representation.
- the main result: every abelian finite group has a base.
- a few lemmas that are presumably useful for working with abelian finite
  groups.
Note: there is room for cleaning and improvment.
*)

(* Definitions about functions *)

Section Function_Misc_Def.

Variables (gT : finGroupType) (f g : gT -> nat).
Variables (x : gT) (n : nat) (A : {set gT}).

Definition addf f g := fun y : gT => f y + g y.

Definition peak y := if y == x then n else 0.

Definition force y := if y == x then n else f y.

Definition support := forallb y, (0 < f y) ==> (y \in A).

End Function_Misc_Def.

(* Lemmas involving the above definitions, predU1, predD1 and foldr *)

Section Function_Pred_Misc_Prop.

Variables (gT : finGroupType) (f h : gT -> nat) (x : gT).
Variables (n m : nat) (A B : {set gT}).

Lemma eq_force : force f x (f x) =1 f.
Proof.
by move=> y; rewrite/force; case yx: (y == x) => //; move/eqP: yx ->.
Qed.

Lemma force_peak : addf (force f x n) (peak x m) =1 force f x (n + m).
Proof.
by move=> y; rewrite/addf/peak/force; case: (y == x).
Qed.

Lemma neq_force : forall y, y <> x -> force f x n y = f y.
Proof.
by move=> y xy; rewrite/force; case yx: (y == x) => //; move/eqP: yx xy.
Qed.

Lemma supP : forall g (C : {set gT}),
  reflect (forall y, 0 < g y -> y \in C) (support g C).
Proof.
by move=> g C; apply: (iffP forallP); move=> H y; move/implyP: (H y).
Qed.

Lemma sup0P : forall g (C : {set gT}),
  reflect (forall y, y \notin C -> g y = 0) (support g C).
Proof.
move=> g C; apply: (iffP (supP _ _)) => insupp y => [nCy | gy_gt0].
  by apply/eqP; apply/idPn; rewrite -lt0n => gy_gt0; rewrite insupp in nCy.
by apply/idPn=> nCy; rewrite insupp in gy_gt0.
Qed.

Lemma sup_sub : A \subset B -> support f A -> support f B.
Proof.
move/subsetP=> AB; move/supP => supA.
by apply/supP => y fy; apply: AB; apply: supA.
Qed.

Lemma eq_sup : A =i B -> support f A = support f B.
Proof.
by move=> AB; apply/supP/supP=> insupp y; move/(_ y): insupp; rewrite AB.
Qed.

Lemma sup_addf : support f A && support h A = support (addf f h) A.
Proof.
apply/andP/supP=> [[inf inh y]|infh].
  rewrite addn_gt0; case/orP; [exact: (supP _ _ inf) | exact: (supP _ _ inh)].
by split; apply/supP=> y fy_gt0; rewrite infh // addn_gt0 fy_gt0 ?orbT.
Qed.

Lemma sup_peak : (x \in A) || (n == 0) = support (peak x n) A.
Proof.
apply: eq_true_iff_eq; rewrite/peak; split.
  move=> Axn; apply/supP => /= y; case: (y =P x) Axn => // -> Axn n_gt0.
  by rewrite eqn0Ngt n_gt0 orbF in Axn.
by move/supP; move/(_ x); rewrite eqxx orbC; case: n => // ? ->.
Qed.

Lemma sup_force : x \in A -> support f A = support (force f x n) A.
Proof.
by rewrite/force; move=> Ax; apply: eq_true_iff_eq; split;
move/supP => H; apply/supP => y; [| move: (H y)];
case yx: (y == x); try done; try exact: H; move/eqP: yx ->.
Qed.

Lemma sup_predU1_force : support f (x |: A) = support (force f x 0) A.
Proof.
rewrite/force; apply/idP/idP; move/supP => H; apply/supP => y;
  by move/(_ y): H; rewrite !inE; case: (y == x).
Qed.

Lemma predU1_sub : (x |: B) \subset A -> B \subset A /\ x \in A.
Proof. by rewrite subUset sub1set andbC; move/andP. Qed.

Lemma predU1_super : A \subset (x |: A).
Proof. by apply/subsetP => y Ay; rewrite inE Ay orbT. Qed.

Lemma predD1E : x \in A -> A = x |: A :\ x.
Proof.
by move=> Ax; apply/setP=> y; rewrite !inE; case: (y =P x) => //= ->.
Qed.

Lemma eq_foldr : forall (f1 f2 : gT -> gT -> gT)(s : seq gT),
  (forall y z, y \in s -> f1 y z = f2 y z) -> foldr f1 1 s = foldr f2 1 s.
Proof.
move=> f1 f2; elim => //= y s Hind H.
rewrite Hind; first by apply: H; rewrite inE eqxx.
by move=> z p sz; apply: H; rewrite inE sz orbT.
Qed.

End Function_Pred_Misc_Prop.

(* Definition of and lemmas on combinations of elements by exponentiation
   according to a function and multiplication along a sequence.
   "esums" stands for sum of exponents along the sequence.
   "ems" stands for exponentiation and multiplication along the sequence *)

Section Combo_Sequence.

Variable (gT : finGroupType).

Definition esums (f : gT -> nat) (s : seq gT) :=
  foldr (fun x n => (f x) + n) 0 s.

Definition ems (f : gT -> nat) (s : seq gT) :=
  foldr (fun x y => x ^+ (f x) * y) 1 s.

Lemma eq_esums : forall (f g : gT -> nat), f =1 g ->
forall s, esums f s = esums g s.
Proof.
by move=> f g fg; elim => //= x s ->; rewrite (fg x).
Qed.

Lemma esums_addf : forall (f g : gT -> nat),
forall s, esums (addf f g) s =  esums f s + esums g s.
Proof.
by move=> f g; elim => //= x s Hind; rewrite/addf Hind /=
!addnA -(addnA _ (g x)) (addnC (g x)) addnA.
Qed.

Lemma esums_peak : forall (y : gT) n s,
  esums (peak y n) s = (n * count (pred1 y) s)%N.
Proof.
move=> y n; elim => //= x s ->; rewrite/peak eq_sym muln_addr.
by case yx: (y == x) => //=; [rewrite muln1 | rewrite muln0].
Qed.

Lemma eq_ems : forall (f g : gT -> nat), f =1 g -> ems f =1 ems g.
Proof.
by move => f g fg; elim => //= x s ->; rewrite fg.
Qed.

Lemma ems1 : forall s, ems (fun _ => 0) s = 1.
Proof.
elim => //= x s ->; gsimpl.
Qed.

Lemma ems_peak : forall (y : gT) n s,
  ems (peak y n) s = y ^+ (n * count (pred1 y) s).
Proof.
rewrite/peak; move=> y n; elim => //=; first by rewrite muln0 /=; gsimpl.
move=> x s ->; rewrite eq_sym muln_addr expgn_add.
by case yx: (y == x) => //=; [rewrite (eqP yx) muln1 | rewrite muln0].
Qed.

Lemma ems_not1 : forall (f : gT -> nat) s,
  ems f s <> 1 -> exists2 x, x \in s & 0 < f x.
Proof.
move => f; elim => //= x s Hind.
case xfx: (x ^+ (f x) == 1).
  move/eqP: xfx ->; gsimpl => emsf.
  by case: (Hind emsf) => y sy fy; exists y => //; rewrite inE sy orbT.
move=> _; exists x; first by rewrite inE eqxx.
by case fx: (f x) xfx => //; rewrite eqxx.
Qed.

Lemma ems1_not1 : forall (f : gT -> nat) s x,
  uniq s -> ems f s = 1 -> x \in s -> x ^+ (f x) <> 1 ->
  exists2 y, y <> x & 0 < f y.
Proof.
move=> f; elim => //= y s Hind x.
case/andP; move/negP=> notsy us yemsf; case/predU1P=> [-> yfy|sx xfx].
  case: (@ems_not1 f s) => [emsf | z sz fz].
    by rewrite -yemsf emsf mulg1 in yfy.
  by exists z => // zy; rewrite zy in sz.
case: (y ^+ (f y) =P 1) => [yfy | nyfy].
  by rewrite yfy mul1g in yemsf; exact: Hind.
by exists y => [yx|]; [rewrite -yx in sx | case: (f y) nyfy].
Qed.

End Combo_Sequence.

(* Definition of and lemmas on combinations of elements by exponentiation
   according to a function and multiplication along the enum sequence
   (the carrier of the underlying finGroupType). "esum" stands for
    sum of exponents. "em" stands for exponentiation and multiplication *)

Section Combo_Enum.

Variable (gT : finGroupType).

Definition esum (f : gT -> nat) := esums f (enum gT).

Definition em (f : gT -> nat) := ems f (enum gT).

Lemma eq_esum : forall (f g : gT -> nat), f =1 g -> esum f = esum g.
Proof.
move=> f g fg; exact: eq_esums.
Qed.

Lemma esum_addf : forall (f g : gT -> nat),
esum (addf f g) =  esum f + esum g.
Proof.
move=> f g; exact: esums_addf.
Qed.

Lemma esum_peak : forall (y : gT) n, esum (peak y n) = n.
Proof.
move=> y n; have:= esums_peak y n (enum gT).
rewrite /esum count_uniq_mem; last exact: enum_uniq.
by rewrite mem_enum /= muln1.
Qed.

Lemma esum_leq : forall (f : gT -> nat) x, f x <= esum f.
Proof.
by move=> f x; rewrite -(eq_esum (eq_force f x)) -(add0n (f x))
-(eq_esum (force_peak _ _ _ _)) esum_addf esum_peak leq_add2r.
Qed.

Lemma esum_force : forall (f : gT -> nat) x n ,
esum (force f x n) = esum f + n - f x.
Proof.
move=> f x n; apply: (@addIn (f x)); rewrite subnK; last first.
  by apply: (leq_trans (esum_leq _ _)); apply: leq_addr.
rewrite -(eq_esum (eq_force f x)) -{1}(esum_peak x (f x)).
rewrite -{2}(esum_peak x n) -!esum_addf !(eq_esum (force_peak _ _ _ _)).
by rewrite addnC.
Qed.

Lemma eq_em : forall (f g : gT -> nat), f =1 g -> em f = em g.
Proof.
move => f g fg; exact: eq_ems.
Qed.

Lemma em1 : em (fun _ => 0) = 1.
Proof.
exact: ems1.
Qed.

Lemma em_peak : forall (y : gT) n, em (peak y n) = y ^+ n.
Proof.
move=> y n; rewrite/em ems_peak count_uniq_mem;
last exact (enum_uniq gT). by rewrite mem_enum /= muln1.
Qed.

Lemma em_not1 : forall (f : gT -> nat), em f <> 1 -> exists x, 0 < f x.
Proof.
by rewrite/em; move=> f emsf; case: (ems_not1 emsf) => x; exists x.
Qed.

Lemma em1_not1 : forall (f : gT -> nat) x, em f = 1 -> x ^+ (f x) <> 1 ->
exists2 y, y <> x & 0 < f y.
Proof.
rewrite/em; move=> f x emsf xfx; apply: (@ems1_not1 gT f (enum gT)) => //;
[exact: enum_uniq | exact: mem_enum].
Qed.

End Combo_Enum.

(* Definition of and lemmas on
   abelian sets and combinations in abelian sets *)

Section Abelian.

Variable (gT : finGroupType).
Variable (A : {set gT}) (abelA : abelian A).

Lemma asub : forall B : {set gT}, B \subset A -> abelian B.
Proof.
by move=> B BA; apply/centsP => x Bx y By;
move/subsetP: BA => BA; move/centsP: abelA; apply; apply: BA.
Qed.

Lemma aems_com : forall (f : gT -> nat) x n,
   x \in A -> support f A ->
   forall s, (x ^+ n) * ems f s = ems f s * (x ^+ n).
Proof.
move=> f x n Ax fA; elim => /=; first by gsimpl. move=> y s Hind;
rewrite -mulgA -{}Hind !mulgA -commuteX //; apply: commute_sym.
case fy: (f y); first exact: commute1.
apply: commuteX; apply: (centsP abelA) => //.
by apply: (supP _ _ fA); rewrite fy.
Qed.

Lemma aems_addf : forall f g : gT -> nat,
  support f A -> support g A ->
  forall s, ems (addf f g) s = ems f s * ems g s.
Proof.
move=> f g fA gA; rewrite/ems/addf; elim => /=; try move=> x s ->; gsimpl.
congr (_ * _); rewrite expgn_add -!mulgA; congr (_ * _).
case gx: (g x); first by rewrite mulg1 mul1g.
by apply: aems_com => //; apply: (supP _ _ gA); rewrite gx.
Qed.

Lemma aem_addf : forall f g : gT -> nat,
  support f A -> support g A -> em (addf f g) = em f * em g.
Proof. move=> f g fA gA; exact: aems_addf. Qed.

Lemma aem_force : forall f x n,
  x \in A -> support f A ->
  em (force f x n) = em f * (x ^+ n) * (x ^+ (f x))^-1.
Proof.
move=> f x n Ax fA; apply: (mulIg (x ^+ (f x))); gsimpl.
by rewrite -(eq_em (eq_force f x)) -!(em_peak) -!aem_addf;
first rewrite !(eq_em (force_peak _ _ _ _)) addnC;
try rewrite -sup_peak Ax; try rewrite -sup_force .
Qed.

Lemma aem_force0 :  forall f x, x \in A -> support f A ->
  em f = em (force f x 0) * x ^+ (f x).
Proof. by move=> f x Ax fA; rewrite aem_force; rewrite // mulg1 mulgKV. Qed.

End Abelian.

(* Definition of and lemmas on sets that are generated
   by multiplication of cyclic groups along the enum sequence
   The "m" in "mgen" stands for "multiplication" *)

Section Generated_Sequence.

Variable (gT : finGroupType).

(*
Definition mgens s : set gT :=
foldr (fun x Y => (<[x]>) :*: Y) [set 1] s.
*)

Definition mgen (A : {set gT}) : {set gT} := \prod_(x \in A) <[x]>.

Lemma mgenP : forall A x,
  reflect (exists2 f, support f A & em f = x) (x \in mgen A).
Proof.
move=> A x; rewrite /mgen /em /index_enum -enumT.
elim: {+}(enum _) x (enum_uniq gT) => /= [x _ | y s IHs x].
  rewrite big_nil inE; apply: (iffP eqP) => [->|[]//].
  exists (fun _ : gT => 0) => //=; exact/supP.
case/andP=> nsy; move/IHs=> {IHs}IHs; rewrite big_cons.
case Ay: (y \in A); last first.
  apply: (iffP (IHs x)); case=> f Af <-; exists f => //;
    by rewrite (sup0P _ _ Af) (Ay, mul1g).
apply: (iffP mulsgP) => [[x1 x2] | [f Af <-{x}]].
  case/cycleP=> i ->{x1}; case/IHs=> f Af <- -> {x x2}.
  exists (force f y i); first by rewrite -sup_force.
  rewrite /force eqxx; congr (_ * _).
  by apply: eq_foldr => x z sx; case: eqP => // eqxy; rewrite -eqxy sx in nsy.
exists (y ^+ (f y)) (ems f s) => //; first by apply/cycleP; exists (f y).
apply/IHs; exists (force f y 0); first by rewrite -sup_force.
apply: eq_foldr => x z sx.
by rewrite /force; case: eqP => // eqxy; rewrite -eqxy sx in nsy.
Qed.

Lemma mgen_super : forall A : {set gT}, A \subset mgen A.
Proof.
move=> A; apply/subsetP => x Ax.
apply/mgenP; exists (peak x 1); first by rewrite -sup_peak Ax.
by rewrite em_peak expg1.
Qed.

Lemma mgen_sub : forall (A : {set gT}) (G : {group gT}),
  A \subset G -> mgen A \subset G.
Proof.
move=> A G sAG; rewrite /mgen; elim: index_enum  => /= [| x s IHs].
  by rewrite big_nil sub1set.
rewrite big_cons; case Ax: (x \in A) => //=.
apply/subsetP=> y; case/mulsgP=> y1 y2.
case/cycleP => i ->; move/(subsetP IHs)=> sy2 ->.
by rewrite groupMr // groupX // (subsetP sAG).
Qed.

(* This result -- abelian sets generate abelian groups -- is not *)
(* used in the main theorem. *)

Lemma amgen : forall A : {set gT}, abelian A -> abelian (mgen A).
Proof.
move=> A abelA.
suff comgen: forall B C : {set gT}, B \subset 'C(C) -> B \subset 'C(mgen C).
  apply: (comgen); rewrite centsC; exact: comgen.
move=> B C; rewrite !(centsC B); exact: mgen_sub.
Qed.

End Generated_Sequence.

(* Coincidence of the combinations of elements of a given set and
   the group that is generated by the given set, and a reflection lemma *)

Section Generated_Abelian.

Variable (gT : finGroupType) (A : {set gT}) (abelA : abelian A).

Lemma amgen_group_set : group_set (mgen A).
Proof.
apply/andP; split.
  apply/mgenP; exists (fun _ : gT => 0); first by apply/supP.
  by rewrite/em; elim: enum => //= x s ->; rewrite mulg1.
apply/subsetP=> xy; case/mulsgP=> x y.
case/mgenP => f Af <-; case/mgenP => g Ag <- -> {x y xy}.
apply/mgenP; exists (addf f g); first by rewrite -sup_addf Af.
by apply: (aem_addf abelA).
Qed.

Canonical Structure amgen_group := Group amgen_group_set.

Lemma amgen_gen : <<A>> = mgen A.
Proof.
by apply/eqP; rewrite eqEsubset gen_subG mgen_super mgen_sub // subset_gen.
Qed.

Lemma agen : abelian <<A>>.
Proof. rewrite amgen_gen; exact: amgen. Qed.

Lemma agenP : forall x,
  reflect (exists2 f, support f A & em f = x) (x \in <<A>>).
Proof. rewrite amgen_gen; exact: mgenP. Qed.

End Generated_Abelian.

(* Definition of and lemmas on freeness *)

Section Free.

Variable (gT : finGroupType).

Definition Free (B : {set gT}) :=
    1 \notin B
 /\ forall f g, support f B -> support g B -> em f = em g ->
    forall x, x ^+ (f x) = x ^+ (g x).

Definition free (B : {set gT}) :=
  1 \notin B /\ forall f, support f B -> em f = 1 -> forall x, x ^+ (f x) = 1.

Lemma Free_set0 : Free set0.
Proof.
by split=> [|f g f0 g0 _ x]; rewrite ?(sup0P  _ _ f0, sup0P  _ _ g0) ?inE.
Qed.

Lemma Free_free : forall B, Free B -> free B.
Proof.
move=> B [nB1 frB]; split=> // f fB emf x.
rewrite (frB f (fun _ => 0)) => //; first by apply/supP.
by rewrite em1 emf.
Qed.

Lemma afree_Free : forall B, abelian B -> free B -> Free B.
Proof.
move=> B abelB; case=> nB1 frB; split=> // f g Bf Bg emfg.
have: (em g)^-1 \in << B >> by rewrite groupV; apply/agenP=> //; exists g.
case/agenP=> // h Bh; move/(congr1 (mulg^~ (em g))); rewrite mulVg => hg.
have hf: em h * em f = 1 by rewrite emfg.
move: hg; rewrite -(aem_addf abelB Bh Bg) => emhg.
move: hf; rewrite -(aem_addf abelB Bh Bf) => emhf.
have Bhg: support (addf h g) B by rewrite -sup_addf Bh Bg.
have Bhf: support (addf h f) B by rewrite -sup_addf Bh Bf.
have Hf := frB _ Bhf emhf; have Hg := frB _ Bhg emhg.
move=> x; apply: (mulgI (x ^+ (h x))).
by rewrite -!expgn_add; rewrite Hf Hg.
Qed.

Lemma free_predU1 : forall B x, x != 1 -> abelian (x |: B) ->
  <[x]> :&: << B >> = 1 -> free B -> free (x |: B).
Proof.
move=> B x nx1 abelxB xB1 [nB1 frB].
split=> [|f xBf]; first by rewrite !inE negb_or eq_sym nx1.
rewrite (@aem_force0 _ _ abelxB f x _ xBf); last by rewrite setU11.
move/(canRL (mulgK _)); rewrite mul1g; set z := _^-1 => def_z.
have xz: z \in <[x]> by rewrite groupV; apply: groupX; exact: cycle_id.
have genBz: z \in << B >>.
  rewrite -def_z; apply/agenP; first by rewrite (asub abelxB) ?predU1_super.
  by exists (force f x 0) => //; rewrite -sup_predU1_force.
have{xz genBz} z1: z = 1 by apply/set1P; rewrite -[[set 1]]xB1 inE xz.
move=> y; case: (y =P x) => [->|nyx]; first by apply: invg_inj; rewrite invg1.
by rewrite -(neq_force f 0 nyx) frB ?{}def_z // -sup_predU1_force.
Qed.

(*
Fixpoint sfreeb (s : seq gT) : bool :=
if s is x::s'
then (x != 1) && sfreeb s' && subset (<[x]> :&: << s' >>) [set 1]
else true.

Definition freeb (B : pred gT) := sfreeb (enum B).

Lemma freeb1 : forall B, freeb B -> ~B 1.
Proof.
move=> B. rewrite/freeb -(filter_enum B).
elim: (enum gT) => //= x s Hind.
case Bx: (B x) => //=. case/andP; case/andP; move/negP => notx1 Hfree _.
case/orP => //=; exact: Hind. exact: Hind.
Qed.

Lemma freeb_free : forall B, freeb B -> free B.
Proof.
rewrite/free/freeb/em; move=> B sfB; split; first exact: freeb1.
move=> f; rewrite -(eq_sup f (filter_enum B));
elim: (enum gT) (enum_uniq gT) f sfB => /= [_ f _ f0 _ x | x s Hind];
first by case fx: (f x) => //; move/forallP: f0; move/(_ x); rewrite fx.
case/andP => notsx us; case Bx: (B x) => /=; last first.
- move=> f freeB fB; case fx: (f x) => /=; gsimpl; first exact: Hind.
  by move: (supP _ _ fB x); rewrite mem_filter Bx fx; move/implyP.
- move=> f; case/andP; case/andP => _ sfB Inter fB.
  rewrite -{2}(mulgV (x ^+ f x)); move/mulgI => xfx.
  have xfx1:  x ^+ f x = 1. apply: sym_eq; apply/set1P;
  apply: (subsetP Inter); apply/setIP; split; first by apply/cycleP;
  exists (f x). rewrite -groupV -xfx; clear Hind sfB Inter xfx.
  elim: s f x Bx notsx fB us => /= [* | y s Hind f x Bx]; first exact: group1.
    rewrite negb_or; case/andP; move/negP => ynotx notsx; case By: (B y);
    last first.
  + move=> fB; case/andP => notsy us; case fy: (f y) => /=; first by gsimpl;
    apply: (Hind _ x). by move/implyP: (supP _ _ fB y);
    rewrite /= fy eq_sym (mem_filter B s y) By /= orbF.
  + move=> fB; case/andP => sy us; apply: groupM; first by apply: groupX;
    apply: (subsetP (subset_generated _)); rewrite /= eq_refl.
    have: subset << filter B s >> << y :: filter B s >>. by apply: sub_gen;
    apply/subsetP => z /= ->; rewrite orbT. move/subsetP; apply.
    rewrite (@eq_foldr gT (fun a b => (a ^+ f a) * b)
    (fun a b => (a ^+ force f x 0 a) * b) s);
    first by apply: (Hind _ y) => //; rewrite -sup_predU1_force.
    by move=> a b sa; rewrite neq_force => // ax; rewrite ax in sa;
    apply: (negP notsx).
  move=> y; case xy: (x == y); first by move/eqP: xy <-.
  rewrite -!(@neq_force gT f x 0); last by move=> yx;
  rewrite yx eq_refl in xy. apply: Hind => //=;
  first by rewrite -sup_predU1_force.
  rewrite -(@eq_foldr gT (fun a b => (a ^+ f a) * b)
  (fun a b => (a ^+ (force f x 0 a)) * b)); first by rewrite xfx xfx1;
  gsimpl. by move=> a b sa; rewrite neq_force => // ax; rewrite ax in sa;
  apply: (negP notsx).
Qed.
*)

(*
Lemma free_freeb : forall B, abelian B -> free B -> freeb B.
Proof.
move=> B abelB; case => notB1 H; rewrite/free/freeb/em.
elim: (enum gT) (enum_uniq gT) => //= x s Hind. case/andP => notsx us.
case Bx: (B x) => /=; last exact: Hind. apply/andP. split.
- apply/andP. split; last by exact: Hind.
  by  apply/negP; move/eqP=> x1; rewrite x1 in Bx.
- apply/subsetP => y. case/setIP. case/cycleP => n. move/eqP <-.
  case/agenP; first by apply: (@asub _ B _) => //; apply/subsetP => z;
  rewrite mem_filter; case/andP. move=> f fB. emxn. apply

rewrite/free/freeb/em; move=> B; case => notB1.
elim: (enum gT) (enum_uniq gT) => //= x s Hind. case/andP => notsx us H.
case Bx: (B x) => /=; last by apply: Hind => // f fB H2;
apply: H => //; rewrite (sup0P _ _ fB x) /=; gsimpl; rewrite Bx.
apply/andP. split.
- apply/andP. split; last first. apply: Hind => //.

by exact: Hind.
  by  apply/negP; move/eqP=> x1; rewrite x1 in Bx.
- apply/subsetP => y. case/setIP. case/cycleP => n. move/eqP <-.
*)

End Free.

(* Definition of and lemmas on bases *)

Section Base.

Variable (gT : finGroupType).

Definition base (E B : {set gT}) := free B /\ <<B>> = E.

Lemma base1 : base 1 set0.
Proof. split; [apply: Free_free; exact: Free_set0 | exact: gen0]. Qed.

End Base.

Section StructureTheorems.

(* Every abelian finite group has a base. Lemma + theorem *)

Variable (gT : finGroupType).

Lemma abelian_base_aux : forall E : {set gT}, abelian E ->
  exists2 B : seq gT, #|B| < #|E|.+1 & base <<E>> [set x \in B].
Proof.
move=> E; elim: {E}_.+1 {-2 4}E (ltnSn #|E|) => // n IHn E cardE abelE.
case: (pickP (mem E)) => /= [z Ez | E0]; last first.
  exists ([::] : seq gT); first by rewrite card0.
  rewrite (_ : E = set0) ?gen0; first exact: base1.
  apply/setP=> x; rewrite inE; exact: E0.
case E1: (1 \in E); last move/idPn: E1 => notE1.
  rewrite -(@genD1 gT E 1 _) ?group1 //.
  case: (IHn (E :\ 1)); first by rewrite (cardsD1 1 E) E1 /= in cardE.
    by apply: (asub abelE); apply/subsetP => x; rewrite inE; case/andP.
  by move=> B; move/(ltn_addl 1) => cardB baseB; exists B.
have{Ez} [f []]: exists f, [/\ support f E, em f = 1 & 0 < f z].
  exists (peak z #[z]); split; first by rewrite -sup_peak Ez.
    by rewrite em_peak expg_order.
  by rewrite /peak eqxx order_gt0.
move: {-4 6}E cardE notE1 (erefl << E >>).
elim: {f z}_.+1 {-2}f {-2}z (ltnSn (f z)) => // m mind f.
elim: {f}_.+1 {-2}f (ltnSn (esum f)) => // M Mind f esumf.
move=> x fxm1 X cardX notX1 XE fX emf fx0.
have abelX: abelian <<X>> by rewrite XE; apply: agen.
have Xx: x \in X by exact: (supP _ _ fX).
have genXx: x \in <<X>> by apply: mem_gen.
have fgenX: support f <<X>> by apply: (sup_sub (subset_gen X)).
have sXxX: X :\ _ \subset X.
  by move=> y; apply/subsetP=> z; rewrite inE; case/andP.
have sxX: [set x] \subset X by rewrite sub1set.
case: (x ^+ (f x) =P 1) => [xfx1 | xfx].
  case: (<[x]> :&: << X :\ x >> =P 1) => [X1x|].
    case: (IHn (X :\ x)) => [|| B cardB [FreeB BXx]].
    - by rewrite (cardsD1 x X) (supP _ _ fX x fx0) in cardX.
    - apply: (asub abelX); exact: subset_trans (subset_gen X).
    exists (x :: B).
      rewrite -cardsE set_cons cardsU1 ltnS inE cardsE.
      by rewrite (leq_trans _ cardB) // -add1n leq_add2r leq_b1.
    split; last first; rewrite set_cons.
      by rewrite -XE; apply: genDU; rewrite ?sub1set.
    apply: free_predU1 => //=; last by rewrite BXx.
      by apply/eqP=> x1; rewrite -x1 Xx in notX1.
    by apply: (asub abelX); rewrite -gen_subG (@genDU _ _ _ X).
  move/eqP; case/trivgPn=> y; case/setIP; case/cycleP => k ->{y}.
  rewrite (divn_eq k (f x)) expgn_add mulnC expgn_mul xfx1 exp1gn.
  rewrite mul1g -groupV; case/agenP=> [|g gX emg xknot1].
    by apply: (asub abelX); rewrite -gen_subG genS // subsetDr.
  apply: (mind (force g x (k %% f x)) x _ X) => //.
  - by rewrite /force eqxx (leq_trans _ (fxm1 : f x <= m)) // ltn_mod.
  - rewrite -sup_force => //; exact: sup_sub gX.
  - rewrite (aem_force abelX) //; last first.
      by apply: (sup_sub _ gX); rewrite -gen_subG genS // subsetDr.
    rewrite (sup0P _ _ gX x) /=; last by rewrite !inE eqxx Xx.
    by rewrite emg; gsimpl; apply: invg1.
  rewrite /force eqxx lt0n; apply: contra xknot1.
  by move/eqP=> ->; rewrite eqxx.
case: (em1_not1 emf xfx) => y ynotx fy0.
have Xy: y \in X by exact: supP fX _ _.
have genXy: y \in <<X>> by rewrite mem_gen.
have xyyx: commute x y by exact: (centsP abelX).
have notxyx: x * y != x.
  apply/eqP; move/(canRL (mulKg _)); rewrite mulVg => y1.
  by rewrite -y1 Xy in notX1.
have notxyy: x * y != y.
  apply/eqP; move/(canRL (mulgK _)); rewrite mulgV => x1.
  by rewrite -x1 Xx in notX1.
case Xxy: (x * y \in X).
  case: (IHn (X :\ x * y)) => [||B cardB [FreeB genB]].
  - by rewrite -(ltn_add2l (x * y \in X)) -cardsD1 Xxy.
  - apply: (asub abelX); exact: subset_trans (subset_gen X).
  exists B; first exact: (ltn_trans cardB).
  split=> //; rewrite genB -XE; apply: genD1.
  by rewrite groupMl mem_gen // !inE eq_sym; exact/andP.
case: (ltnP (f y) (f x)) => fxfy.
  apply: (mind f y _ X) => //; exact: leq_trans fxfy _.
case: (x * y =P 1) => [xy1 | xynot1].
  case: (IHn (X :\ y)) => [||B cardB [FreeB genB]].
  - by rewrite (cardsD1 y) (supP _ _ fX) in cardX.
  - by apply: (asub abelX); apply: subset_trans (subset_gen X).
  exists B; [exact: ltnW | split => //].
  rewrite genB -XE; apply: genD1; rewrite -{1}(mulKg x y) xy1 mulg1 groupV.
  apply: mem_gen; rewrite !inE Xx andbT eq_sym; exact/eqP.
pose f' := force (force (force f x 0) (x * y) (f x)) y (f y - f x).
pose X' := x * y |: (X :\ x).
apply: (Mind f' _ (x * y) _ X') => //; last 1 first.
- by rewrite /f' /force (negPf notxyx) (negPf notxyy) eqxx.
- rewrite !esum_force /force (negPf notxyx) eq_sym (negPf notxyy).
  rewrite (introF eqP ynotx) (sup0P _ _ fX (x * y)) ?Xxy //.
  rewrite addn0 subn0 -addnA (subnKC fxfy) addnK.
  by rewrite -[M](subn1 M.+1) -leq_subS (esum_leq, leq_sub2) //.
- by rewrite /f' /force eqxx (negPf notxyy).
- by rewrite cardsU1 inE Xxy andbF -[~~ _]Xx -cardsD1.
- by rewrite !inE eq_sym (introF eqP xynot1) (negPf notX1) andbF.
- rewrite -XE; apply/setP; apply/subset_eqP; apply/andP.
  split; rewrite gen_subG; apply/subsetP => t.
    rewrite 3!inE; case/predU1P=> [->|].
      by apply: groupM; apply: mem_gen.
    case/andP=> _; exact: mem_gen.
  case tx: (t == x) => Xt; last first.
    by apply: mem_gen; rewrite !inE Xt tx orbT.
  rewrite {t tx Xt}(eqP tx) -(mulgK y x).
  by rewrite groupMl ?groupV mem_gen // !inE ?eqxx // Xy orbC; case: eqP.
- rewrite -sup_force; last by rewrite !inE Xy orbC; case: eqP.
  rewrite -sup_force; last by rewrite setU11.
  rewrite -sup_predU1_force; apply/supP => t ft /=.
  by rewrite !inE (supP _ _ fX t ft); case (t == x); rewrite ?orbT.
rewrite !(aem_force abelX) /force => //; first 1 last; first exact: groupM.
- by apply/supP => t; case tx: (t == x) => // ft; exact: (supP _ _ fgenX).
- apply/supP => t; case: eqP => [-> _ | _]; first exact: groupM.
  by case: eqP => // _; apply: (supP _ _ fgenX).
rewrite emf !mul1g expMgn // mulKg (negPf notxyx) eq_sym (negPf notxyy).
rewrite (introF eqP ynotx) (sup0P _ _ fX (x * y)) ?Xxy // invg1 mulg1.
by rewrite -expgn_add subnKC ?mulgV.
Qed.

Theorem abelian_base : forall G : {group gT},
  abelian G -> exists B, base G B.
Proof.
by move=> G; case/abelian_base_aux=> B _; rewrite genGid; exists [set x \in B].
Qed.

End StructureTheorems.


(* https://coq-math-problems.github.io/Problem2/ *)

Require Import PeanoNat.
Require Import Arith.Compare_dec.

Require Hack.CMP.Arith.
Require Import Hack.CMP.Decr.
Require Import Hack.CMP.Translation.

(* The iff's different directions are handled in quite different ways:
   - infvalley_LPO constructs an auxillary recursive function describing a
     falling edge at the first true value. (Think: aux(n):=~(f(0)\/..\/f(n)))
   - LPO_infvalley notices that decr f is bounded and then uses the LPO to
     scan the tail of the function to check if it has an infvalley or not,
     if it hasn't the bound must eventually decrease. *)

Definition LPO :=
  forall f : nat -> bool,
  (exists x, f x = true) \/ (forall x, f x = false).

Definition infvalley(f : nat -> nat)(x : nat) := forall y, x <= y -> f y = f x.

Fixpoint aux (f: nat -> bool) (n: nat): nat :=
  if f n then 0 else match n with
  | 0 => if f n then 0 else 1
  | S m => aux f m
  end.

Lemma infvalley_LPO_aux_prop: forall f: nat -> bool,
  forall n,
  (aux f n = 1 /\ (forall x, x <= n -> f x = false))
  \/ (aux f n = 0 /\ (exists x, f x = true)).
Proof.
  intro f.
  induction n.
  - case_eq (f 0).
    -- intro H. compute. rewrite H. right.
       refine (conj (eq_refl _) _).
       refine (ex_intro _ 0 _).
       assumption.
    -- intro H. compute. rewrite H. left.
       refine (conj (eq_refl _) _).
       intros x G.
       rewrite (proj1 (Nat.le_0_r _) G).
       assumption.
  - case_eq (f (S n)).
    -- intro H. compute. rewrite H. right.
       refine (conj (eq_refl _) _).
       refine (ex_intro _ (S n) _).
       assumption.
    -- intro H. compute. rewrite H.
       case IHn.
       ++ intro G. left. destruct G as [G0 G1].
          refine (conj G0 _).
          intros x F.
          case (Arith.leq_and_not _ _ F).
          +++ intro I. rewrite I. assumption.
          +++ exact (G1 x).
       ++ apply or_intror.
Qed.

Lemma infvalley_LPO_aux_decr: forall f, decr (aux f).
Proof.
  intros f n.
  compute.
  case (f (S n)).
  - exact (le_0_n _).
  - exact (le_n _).
Qed.

Theorem infvalley_LPO : (forall f, decr f -> exists x, infvalley f x) -> LPO.
Proof.
  intro H.
  intro f.
  destruct (H (aux f) (infvalley_LPO_aux_decr f)) as [n pn].
  case_eq (aux f n =? 1).
  + intro G1.
    right.
    intro x.
    unfold infvalley in pn.
    case_eq (le_ge_dec x n).
    -- intros l _.
       case (infvalley_LPO_aux_prop f n).
       ++ intro F.
          destruct F as [_ F].
          exact (F x l).
       ++ intro F.
          destruct F as [F _].
          rewrite (proj1 (Nat.eqb_eq _ _) G1) in F.
          discriminate.
    -- intros ge _.
       case (infvalley_LPO_aux_prop f x).
       ++ intro F.
          destruct F as [_ F].
          exact (F x (le_n _)).
       ++ intro F.
          destruct F as [F _].
          rewrite (pn x ge) in F.
          rewrite (proj1 (Nat.eqb_eq _ _) G1) in F.
          discriminate.
  + intro Gn1.
    left.
    case (infvalley_LPO_aux_prop f n).
    -- intro F.
       destruct F as [F _].
       rewrite (proj2 (Nat.eqb_eq _ _) F) in Gn1.
       discriminate.
    -- intro F.
       destruct F as [_ F].
       assumption.
Qed.

Lemma f_at_level:
  forall f: nat -> nat, forall x, exists g: nat -> bool,
  forall n, (f n = x /\ g n = false) \/ (f n <> x /\ g n = true).
Proof.
  intros f x.
  refine (ex_intro _ (fun n => negb (f n =? x)) _).
  intro n.
  case (Nat.eq_dec (f n) x).
  + intro H.
    left.
    refine (conj H _).
    rewrite (proj2 (Nat.eqb_eq _ _) H).
    trivial.
  + intro H.
    right.
    refine (conj H _).
    case_eq (f n =? x).
    - intro G; contradiction (proj1 (Nat.eqb_eq _ _) G).
    - trivial.
Qed.

Lemma infvalley_if_bounded_by_0: forall f,
  (forall x, f x <= 0) -> exists x, infvalley f x.
Proof.
  intros f B0.
  refine (ex_intro _ 0 _).
  unfold infvalley.
  intros y _.
  transitivity 0.
  - exact (proj1 (Nat.le_0_r _) (B0 y)).
  - symmetry.
    exact (proj1 (Nat.le_0_r _) (B0 0)).
Qed.

Lemma LPO_infvalley_aux:
  LPO -> forall m f, decr f ->
  (forall x, f x <= m) ->
  exists x, infvalley f x.
Proof.
  intro LPO.
  induction m.
  -- intros f D.
     exact (infvalley_if_bounded_by_0 f).
  -- intros f D BSm.
     destruct (f_at_level f (S m)) as [g pg].
     case (LPO g).
     + intro T.
       destruct T as [x px].
       case (pg x).
       - intro H.
         rewrite px in H.
         destruct H.
         discriminate.
       - intro H.
         destruct H as [G _].
         pose (q := Arith.leq_and_not' _ _ (BSm x) G).
         destruct (translate f x) as [f' tr].
         pose (D' := decr_translation f f' x D tr).
         pose (f'Bm := decr_translation_estimate f f' x m D tr q).
         destruct (IHm f' D' f'Bm) as [n pn].
         refine (ex_intro _ (n + x) _).
         intros y I.
         rewrite (tr n).
         rewrite <- (pn (y - x) (Arith.le_sub _ _ _ I)).
         rewrite <- (tr (y - x)).
         apply f_equal_nat.
         exact (Arith.le_sub_ident _ _ _ I).
     + intros F.
       refine (ex_intro _ 0 _).
       unfold infvalley.
       intros y _.
       transitivity (S m).
       - case (pg y).
         * apply proj1.
         * intro H.
           pose (q := F y).
           rewrite (proj2 H) in q.
           discriminate.
       - symmetry.
         case (pg 0).
         * apply proj1.
         * intro H.
           pose (q := F 0).
           rewrite (proj2 H) in q.
           discriminate.
Qed.

Theorem LPO_infvalley : LPO -> forall f, decr f -> exists x, infvalley f x.
Proof.
  intros LPO f D.
  assert (forall y, f y <= f 0) as B.
  - intro y.
    exact (decr_estimate f D 0 y (le_0_n _)).
  - exact (LPO_infvalley_aux LPO (f 0) f D B).
Qed.


(** A library of Bellantoni-Cook functions on bitstrings without numerical interpretation *)

Require Import Bool Arith Coq.Arith.Even List.
Require Import BellantoniCook.Lib BellantoniCook.Bitstring BellantoniCook.BC.

(** * Swapping of two arguments

  - arities: (2, 0)
*)

Definition inv_e (e : BC) : BC :=
  comp 2 0 e (proj 2 0 1 :: proj 2 0 0 :: nil) nil.

(** * Conversion from arities (1, 1) to (2, 0) *)

Definition from_11_to_20 (e : BC) : BC :=
  comp 2 0 e (proj 2 0 0 :: nil) (proj 2 0 1 :: nil).

Lemma from_11_to_20_correct e v1 v2 :
  sem e [v1] [v2] = sem (from_11_to_20 e) [v1 ; v2] nil.
Proof.
 intros; simpl; trivial.
Qed.

(** * Concatenation of bitstrings

  - arities: (1, 1)
*)

Definition app_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 (succ false) nil ((proj 1 2 1) :: nil))
      (comp 1 2 (succ true) nil ((proj 1 2 1) :: nil)).

Lemma app_correct v1 v2 :
  sem app_e [v1] [v2] = v1 ++ v2.
Proof.
 induction v1; simpl in *; trivial.
 intros; rewrite IHv1.
 case a; trivial.
Qed.

(** * constant function *)

Program Fixpoint constant (v:bs) : { e : BC | arities e = ok_arities 0 0 /\ sem e nil nil = v } :=
  match v with
  | nil => BC.zero
  | b :: v' => BC.comp 0 0 (BC.succ b) nil [constant v']
  end.

Next Obligation.
simpl.
tauto.
Qed.

Next Obligation.
simpl.
intros bs_to_BC v b v' Hv.
subst v.
destruct (bs_to_BC v') as [e [H1 H2] ].
simpl.
rewrite H1, H2.
tauto.
Defined.

(** * Recursion on the length of a bitstring, i.e., ignoring the value 0 or 1 of bits *)

Definition rec2 g h := rec g h h.

Lemma rec2_correct v1 v2 g h0 h1 :
  unary (hd nil v1) = true ->
  sem (rec g h0 h1) v1 v2 = sem (rec2 g h1) v1 v2.
Proof.
 intros; simpl; revert H.
 induction (hd nil v1); simpl; trivial; intros.
 rewrite andb_true_iff in H.
 decompose [and] H; clear H.
 destruct a.
 rewrite IHl; trivial; tauto.
 unfold id in H0; discriminate.
Qed.

Lemma rec2_simpl g h i z l1 l2 :
  sem (rec2 g h) ((i :: z) :: l1) l2 = sem h (z :: l1) (sem_rec (sem g) (sem h) (sem h) z l1 l2 :: l2).
Proof. intros; simpl; case i; trivial. Qed.

Lemma rec2_sem_rec g h z l1 l2 :
  sem (rec2 g h) (z :: l1) l2 = sem_rec (sem g) (sem h) (sem h) z l1 l2.
Proof.  intros; simpl; trivial. Qed.

Definition cond2 n s x g h0 h1 : BC :=
  comp n s
    cond nil [
      x;
      g;
      comp n s h0
        (map (proj n 0) (seq 0 n))
        (comp n s pred nil [x] :: map (proj n s) (seq n s));
      comp n s h1
        (map (proj n 0) (seq 0 n))
        (comp n s pred nil [x] :: map (proj n s) (seq n s))
    ].

Lemma arities_cond2 n s x g h0 h1
  (Hx : arities x = ok_arities n s)
  (Hg : arities g = ok_arities n s)
  (Hh0 : arities h0 = ok_arities n (S s))
  (Hh1 : arities h1 = ok_arities n (S s)) :
  arities (cond2 n s x g h0 h1) = ok_arities n s.
Proof.
simpl.
rewrite Hx, Hg, Hh0, Hh1.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
do 2 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H2
end.
simpl.
do 2 rewrite <- beq_nat_refl.
reflexivity.
rewrite forallb_forall_conv in H2.
destruct H2 as [e [H2 H3] ].
rewrite in_map_iff in H2.
destruct H2 as [p [H2 H4] ].
rewrite in_seq_iff in H4.
subst e.
simpl in H3.
case_eq (n + s).
intro H5.
contradict H5.
omega.
intros q H5.
rewrite H5 in H3.
case_eq (leb p q); intro H6.
rewrite H6 in H3.
simpl in H3.
do 2 rewrite <- beq_nat_refl in H3.
discriminate H3.
rewrite leb_iff_conv in H6.
contradict H6.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [p [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (n + 0).
intro H4.
contradict H4.
omega.
intros q H4.
rewrite H4 in H2.
case_eq (leb p q); intro H5.
rewrite H5 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H5.
contradict H5.
omega.
Qed.

Definition cond2_correct n s x g h0 h1 vnl vsl :
  length vnl = n ->
  length vsl = s ->
  sem (cond2 n s x g h0 h1) vnl vsl =
  match sem x vnl vsl with
  | nil => sem g vnl vsl
  | true  :: _ => sem h0 vnl (tl (sem x vnl vsl) :: vsl)
  | false :: _ => sem h1 vnl (tl (sem x vnl vsl) :: vsl)
  end.
Proof.
intros Hn Hs.
simpl.
destruct (sem x vnl vsl) as [ | [ | ] v]; simpl.
reflexivity.
rewrite map_proj_seq_normal.
rewrite map_proj_seq_safe.
f_equal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite map_proj_seq_normal.
rewrite map_proj_seq_safe.
f_equal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
Qed.

(** * Recursion with one function [h] taking [i] instead of two function [h]_[i] *)

Definition rec1 n s g h :=
  rec
    g
    (comp (S n) (S s) h
      (comp (S n) 0 (succ false) nil [proj (S n) 0 0] ::
       map (proj (S n) 0)     (seq 1     n))
      (map (proj (S n) (S s)) (seq (S n) (S s))))
    (comp (S n) (S s) h
      (comp (S n) 0 (succ true) nil [proj (S n) 0 0] ::
       map (proj (S n) 0)     (seq 1     n))
      (map (proj (S n) (S s)) (seq (S n) (S s)))).

Lemma sem_rec_false g h0 h1 vnl vsl v :
  sem (rec g h0 h1) ((false :: v) :: vnl) vsl =
  sem h0 (v :: vnl) (sem (rec g h0 h1) (v :: vnl) vsl :: vsl).
Proof.
reflexivity.
Qed.

Lemma sem_rec_true g h0 h1 vnl vsl v :
  sem (rec g h0 h1) ((true :: v) :: vnl) vsl =
  sem h1 (v :: vnl) (sem (rec g h0 h1) (v :: vnl) vsl :: vsl).
Proof.
reflexivity.
Qed.

Lemma rec1_arities n s g h
  (Hg : arities g = ok_arities n s)
  (Hh : arities h = ok_arities (S n) (S s)) :
  arities (rec1 n s g h) = ok_arities (S n) s.
Proof.
simpl.
rewrite Hg, Hh.
simpl.
do 2 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
case_eq (n + S s).
intro H2.
contradict H2.
omega.
intros p H2.
case_eq (leb n p); intro H3.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H4
end.
do 4 rewrite <- beq_nat_refl.
simpl.
reflexivity.
rewrite forallb_forall_conv in H4.
destruct H4 as [e [H4 H5] ].
rewrite in_map_iff in H4.
destruct H4 as [q [H4 H6] ].
rewrite in_seq_iff in H6.
subst e.
simpl in H5.
case_eq (leb q (n + S s)); intro H7.
rewrite H7 in H5.
simpl in H5.
do 2 rewrite <- beq_nat_refl in H5.
discriminate H5.
rewrite leb_iff_conv in H7.
contradict H7.
omega.
rewrite leb_iff_conv in H3.
contradict H3.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [q [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (leb q (n+0)); intro H4.
rewrite H4 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H4.
contradict H4.
omega.
Qed.

Fixpoint sem_rec1
  (g h:BC)(v : bs)(vnl vsl : list bs) {struct v} :=
  match v with
    | nil => sem g vnl vsl
    | _::v' => sem h (v::vnl) (sem_rec1 g h v' vnl vsl :: vsl)
  end.

Lemma rec1_correct n s g h vnl vsl :
  length vnl = S n ->
  length vsl = s ->
  sem (rec1 n s g h) vnl vsl =
  sem_rec1 g h (hd nil vnl) (tl vnl) vsl.
Proof.
intros Hn Hs.
destruct vnl as [ | v vnl].
reflexivity.
simpl in Hn.
induction v as [ | b v IH].
reflexivity.
simpl sem_rec1.
simpl hd in IH.
simpl tl in IH.
rewrite <- IH.
clear IH.
unfold rec1.
case b.
rewrite sem_rec_true.
match goal with
| |- context [sem (rec ?g ?h0 ?h1) ?vnl ?vsl] =>
    set (e0 := sem (rec g h0 h1) vnl vsl)
end.
rewrite sem_comp, map_map.
f_equal.
rewrite map_cons.
f_equal.
replace (S n) with (n+1) by omega.
rewrite map_proj_seq_normal_gen by (simpl; omega).
erewrite firstn_map_nth by (simpl; omega).
instantiate (1:=nil).
rewrite <- seq_shift, map_map; simpl.
apply map_nth_seq.
omega.
rewrite <- (
  map_map
    (proj (S n) (S s))
    (fun e => sem e (v :: vnl) (e0 :: vsl))
);rewrite map_proj_seq_safe; simpl.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite sem_rec_false.
match goal with
| |- context [sem (rec ?g ?h0 ?h1) ?vnl ?vsl] =>
    set (e0 := sem (rec g h0 h1) vnl vsl)
end.
rewrite sem_comp, map_map.
f_equal.
rewrite map_cons.
f_equal.
replace (S n) with (n+1) by omega.
rewrite map_proj_seq_normal_gen by (simpl; omega).
erewrite firstn_map_nth by (simpl; omega).
instantiate (1:=nil).
rewrite <- seq_shift, map_map; simpl.
apply map_nth_seq.
omega.
rewrite <- (
  map_map
    (proj (S n) (S s))
    (fun e => sem e (v :: vnl) (e0 :: vsl))
);rewrite map_proj_seq_safe; simpl.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
Qed.

(** * Recursion on the result of the function [x],
      with one function [h] taking [i] instead of two function [h]_[i] *)

Definition rec3 n s x g h : BC :=
  comp n s
    (rec1 n s g h)
    (x ::
     map (proj n 0) (seq 0 n))
    (map (proj n s) (seq n s)).

Lemma arities_rec3 n s x g h
  (Hx : arities x = ok_arities n 0)
  (Hg : arities g = ok_arities n s)
  (Hh : arities h = ok_arities (S n) (S s)) :
  arities (rec3 n s x g h) = ok_arities n s.
Proof.
simpl.
rewrite Hx, Hg, Hh.
simpl.
do 4 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
case_eq (n + S s).
intro H2.
contradict H2.
omega.
intros p H2.
case_eq (leb n p); intro H3.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H4
end.
do 4 rewrite <- beq_nat_refl.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H5
end.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H6
end.
simpl.
reflexivity.
rewrite forallb_forall_conv in H6.
destruct H6 as [e [H6 H7] ].
rewrite in_map_iff in H6.
destruct H6 as [q [H6 H8] ].
rewrite in_seq_iff in H8.
subst e.
simpl in H7.
case_eq (n+s).
intro H9.
contradict H8.
omega.
intros r H9.
rewrite H9 in H7.
case_eq (leb q r); intro H10.
rewrite H10 in H7.
simpl in H7.
do 2 rewrite <- beq_nat_refl in H7.
discriminate H7.
rewrite leb_iff_conv in H10.
contradict H10.
omega.
rewrite forallb_forall_conv in H5.
destruct H5 as [e [H5 H6] ].
rewrite in_map_iff in H5.
destruct H5 as [q [H5 H7] ].
rewrite in_seq_iff in H7.
subst e.
simpl in H6.
case_eq (n+0).
intro H8.
contradict H7.
omega.
intros r H8.
rewrite H8 in H6.
case_eq (leb q r); intro H9.
rewrite H9 in H6.
simpl in H6.
rewrite <- beq_nat_refl in H6.
discriminate H6.
rewrite leb_iff_conv in H9.
contradict H9.
omega.
rewrite forallb_forall_conv in H4.
destruct H4 as [e [H4 H5] ].
rewrite in_map_iff in H4.
destruct H4 as [q [H4 H6] ].
rewrite in_seq_iff in H6.
subst e.
simpl in H5.
case_eq (n+S s).
intro H7.
contradict H6.
omega.
intros r H7.
rewrite H7 in H5.
case_eq (leb q (S r)); intro H8.
rewrite H8 in H5.
simpl in H5.
do 2 rewrite <- beq_nat_refl in H5.
discriminate H5.
rewrite leb_iff_conv in H8.
contradict H8.
omega.
rewrite leb_iff_conv in H3.
contradict H3.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [q [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (leb q (n+0)); intro H4.
rewrite H4 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H4.
contradict H4.
omega.
Qed.

Lemma rec3_correct n s x g h vnl vsl :
  length vnl = n ->
  length vsl = s ->
  sem (rec3 n s x g h) vnl vsl =
  sem_rec1 g h (sem x vnl nil) vnl vsl.
Proof.
intros Hn Hs.
unfold rec3.
rewrite sem_comp, rec1_correct; simpl.
f_equal.
rewrite map_proj_seq_normal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
rewrite map_proj_seq_safe.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite map_length, map_length, seq_length; reflexivity.
rewrite map_length, map_length, seq_length; reflexivity.
Qed.

(** * True

  - with any arities (n, s)
*)

Definition true_e (n s:nat) : BC :=
  comp n s (comp 0 0 (succ true) nil (zero :: nil)) nil nil.

Lemma true_correct n s l1 l2:
 bs2bool (sem (true_e n s) l1 l2) = true.
Proof.
 intros; simpl; trivial.
Qed.

Lemma true_correct_nat n s l1 l2:
 bs2nat (sem (true_e n s) l1 l2) = 1.
Proof.
 intros; simpl; trivial.
Qed.

(** * False

  - with any arities (n, s)
*)

Definition false_e (n s:nat) : BC :=
  comp n s (comp 0 0 (succ false) nil (zero :: nil)) nil nil.

Lemma false_correct n s l1 l2:
 bs2bool (sem (false_e n s) l1 l2) = false.
Proof.
 intros; simpl; trivial.
Qed.

Lemma false_correct_nat n s l1 l2:
 bs2nat (sem (false_e n s) l1 l2) = 0.
Proof.
 intros; simpl; trivial.
Qed.

(** * Parity

  - arities: (0, 1)
*)

Definition parity_e : BC := (* 0 1 *)
  comp 0 1 cond nil [proj 0 1 0; false_e 0 1; true_e 0 1; false_e 0 1].

Lemma parity_correct_even v :
  bs2bool (sem parity_e nil [v]) = false ->
  even (bs2nat v).
Proof.
  destruct v; simpl; intros.
  apply even_O.
  destruct b; simpl in *.
  discriminate.
  cutrewrite (bs2nat v + (bs2nat v + 0) = 2 * (bs2nat v)).
  auto with arith.
  ring.
Qed.

Lemma parity_correct_odd v :
  bs2bool (sem parity_e nil [v]) = true ->
  odd (bs2nat v).
Proof.
  destruct v; simpl; intros.
  discriminate.
  cutrewrite (bs2nat v + (bs2nat v + 0) = (2 * (bs2nat v))).
  destruct b.
  apply odd_S.
  auto with arith.
  simpl in H; discriminate.
  omega.
Qed.

(** * Functions P, P', Y and I as defined by Bellantoni and Cook

  - arities of P: (1, 1)

  - arities of P': (2, 0)

  - arities of Y: (2, 1)

  - arities of I: (2, 1)
*)

Definition P (x:bs)(y:bs) : bs := skipn (length x) y.

Lemma P_nil : forall x, P x nil = nil.
Proof.
 intro x; case x; trivial.
Qed.

Definition P_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 pred nil [proj 1 2 1])
      (comp 1 2 pred nil [proj 1 2 1]).

Lemma P_correct x y :
  sem P_e [x] [y] = P x y.
Proof.
 unfold P; induction x; simpl in *; trivial.
 intros; case a.
 rewrite IHx; clear IHx.
 induction (length x); simpl; trivial.
 rewrite <- IHn; clear IHn.
 revert y.
 induction n; simpl; trivial; intros.
 case y; simpl; trivial.
 case y; simpl; trivial; intros.
 rewrite IHx; clear IHx.
 induction (length x); simpl; trivial.
 rewrite <- IHn; clear IHn.
 revert y.
 induction n; simpl; trivial; intros.
 case y; simpl; trivial.
 case y; simpl; trivial; intros.
Qed.

Global Opaque P_e.

Definition P'_e := from_11_to_20 P_e.

Definition Y (z w y:bs) : bs :=
  P (P z w) y.

Definition Y_e : BC :=
  comp 2 1 P_e
  [comp 2 0 P'_e [proj 2 0 0; proj 2 0 1] nil]
  [proj 2 1 2].

Lemma Y_correct z w y :
  sem Y_e [z;w] [y] = Y z w y.
Proof.
 intros; simpl.
 rewrite P_correct, P_correct.
 trivial.
Qed.

Lemma Y_skipn z w y :
  Y z w y = skipn (length w - length z) y.
Proof.
 unfold Y, P; intros.
 rewrite length_skipn.
 trivial.
Qed.

Global Opaque Y_e.

Lemma Y_nth x y z :
 hd false (Y x y z) = nth (length y - length x) z false.
Proof.
 unfold Y, P; intros.
 rewrite length_skipn.
 remember (length y - length x) as n.
 revert x y z Heqn.
 induction n; simpl; intros.
 case z; trivial.
 destruct z; simpl in *; trivial.
 apply IHn with (x:=true::x) (y:=y).
 simpl.
 omega.
Qed.

Lemma Y_nil x y : Y x y nil = nil.
Proof.
  intros; unfold Y, P.
  case (length (skipn (length x) y)); simpl; trivial.
Qed.

Lemma Y_refl x y : Y x x y = y.
Proof.
 intros; unfold Y, P.
 rewrite length_skipn, minus_diag; simpl; trivial.
Qed.

Lemma Y_nil_length x y z :
  Y x y z = nil ->
  length z <= length y - length x.
Proof.
 intros.
 unfold Y, P in H.
 rewrite length_skipn in H.
 apply skipn_nil_length; trivial.
Qed.

Lemma Y_hd_same x y z i1 i2: Y (i1 :: x) y z = Y (i2 :: x) y z.
Proof.
 intros; unfold Y, P.
 simpl; trivial.
Qed.

Lemma Y_le : forall u w y , length u <= length w ->
   length (Y u w y) <= length (Y w w y).
 intros.
 repeat rewrite Y_skipn.
 repeat rewrite skipn_length.
 omega.
Qed.

Definition I_e : BC :=
  comp 2 1 parity_e nil
  [comp 2 1 Y_e
    [comp 2 0 (succ true) nil [proj 2 0 0]; proj 2 0 1]
    [proj 2 1 2] ].

Lemma I_correct (z w y : bs) :
  sem I_e [z;w] [y] = [nth (length w - S (length z)) y false].
Proof.
 simpl; intros.
 rewrite Y_correct.
 case_eq (Y (true :: z) w y); intros.
 apply Y_nil_length in H; simpl in H.
 rewrite nth_overflow; trivial.
 replace (S (length z)) with (length (true :: z)).
 rewrite <- Y_nth.
 rewrite H; simpl; trivial.
 destruct b; trivial.
 simpl; trivial.
Qed.

Lemma I_Y_property j z w y :
  length z < length w ->
  length w - S (length z) < length y ->
  Y (j :: z) w y = [nth (length w - S (length z)) y false] ++ Y z w y.
Proof.
 intros; simpl.
 rewrite Y_skipn.
 rewrite Y_skipn.
 simpl.
 rewrite skipn_hd with (d := false).
 f_equal.
 f_equal.
 omega.
 trivial.
Qed.

Global Opaque I_e.


(*
 Axioms v4
*)

Require Import Arith.

(* Helper lemmas *)

Lemma less_or_equal (n m : nat):
  n <= m <-> (n < m \/ n = m).
Proof.
  split.
  intros.
  induction H.
  right.
  reflexivity.
  left.
  assert (m < S m).
  auto.
  firstorder.
  intros.
  destruct H as [H1 | H2].
  induction H1.
  auto.
  auto.
  induction H2.
  auto.
Qed.

(* Oracle function: Description -> nat *)
Parameter O : nat -> nat.

(* Oracle equivalence relation: Description x Description -> bool *)
Parameter R : nat -> nat -> Prop.
Axiom reflexive:  forall r     : nat, R r r.
Axiom symmetric:  forall r s   : nat, R r s -> R s r.
Axiom transitive: forall r s t : nat, R r s -> R s t -> R r t.

(* Nescience function: Description -> Nescience *)
Parameter N : nat -> nat.

(* Axioms *)

(* Axiom: non-negativity of nescience *)
Axiom non_negativity: forall d : nat, N(d) >= 0.

(* Axiom of surfeit *)
Axiom surfeit: forall s t : nat, R s t /\ O s <= O t /\ Nat.log2 s < Nat.log2 t -> N s < N t.

(* Axiom of inaccuracy *)
Axiom inaccuracy: forall s t : nat, R s t /\ O s < O t /\ Nat.log2 s <= Nat.log2 t -> N s < N t.

(* Axiom of equality *)
Axiom equality: forall s t : nat, R s t /\ O s = O t /\ Nat.log2 s = Nat.log2 t -> N s = N t.

(* Axiom perfect_knowledge *)
Axiom perfect_knowledge: forall s : nat, N s = 0 <-> ( O s = 0 )
  /\ ( ~ exists t : nat, s <> t /\ R s t /\ O t = 0 /\ Nat.log2 t < Nat.log2 s ).

(* zero uknown *)
Axiom zero_unknown: forall s : nat, exists t : nat, R s t /\ N t = 0.

Lemma zero_inaccuracy (d : nat) :
  N d = 0 -> O d = 0.
Proof.
  intros.
  apply perfect_knowledge.
  assumption.
  Qed.

(* l(s) < l(t) & O(s) < O(t) => N(s) < N(t) *)
Lemma property_ll:
  forall s t : nat, R s t -> Nat.log2 s < Nat.log2 t -> O s < O t -> N s < N t.
Proof.
  intros s t H1 H2 H3.
  apply surfeit.
  split.
  assumption.
  split.
  apply less_or_equal.
  left.
  apply H3.
  apply H2.
Qed.

(* l(s) < l(t) & O(s) = O(t) => N(s) < N(t) *)
Lemma property_le:
  forall s t : nat, R s t -> Nat.log2 s < Nat.log2 t -> O s = O t -> N s < N t.
Proof.
  intros s t H1 H2 H3.
  apply surfeit.
  split.
  assumption.
  split.
  apply less_or_equal.
  right.
  apply H3.
  apply H2.
Qed.

(* l(s) = l(t) & O(s) < O(t) => N(s) < N(t) *)
Lemma property_el:
  forall s t : nat, R s t -> Nat.log2 s = Nat.log2 t -> O s < O t -> N s < N t.
Proof.
  intros s t H1 H2 H3.
  apply inaccuracy.
  split.
  assumption.
  split.
  assumption.
  apply less_or_equal.
  right.
  apply H2.
Qed.

(* l(s) = l(t) & O(s) = O(t) => N(s) = N(t) *)
(* axiom equality *)

(* l(s) = l(t) & O(s) > O(t) => N(s) > N(t) *)
Lemma property_eg:
  forall s t : nat, R s t -> Nat.log2 s = Nat.log2 t -> O s > O t -> N s > N t.
Proof.
  intros s t H1 H2 H3.
  apply property_el.
  apply symmetric.
  assumption.
  auto.
  auto.
Qed.

(* l(s) > l(t) & O(s) = O(t) => N(s) > N(t) *)
Lemma property_ge:
  forall s t : nat, R s t -> Nat.log2 s > Nat.log2 t -> O s = O t -> N s > N t.
Proof.
  intros s t H1 H2 H3.
  apply property_le.
  apply symmetric.
  assumption.
  auto.
  auto.
  Qed.

(* l(s) > l(t) & O(s) > O(t) => N(s) > N(t) *)
Lemma property_gg:
  forall s t : nat, R s t -> Nat.log2 s > Nat.log2 t -> O s > O t -> N s > N t.
Proof.
  intros s t H1 H2 H3.
  apply property_ll.
  apply symmetric.
  assumption.
  auto.
  auto.
  Qed.

(* l(s) < l(t) & O(s) > O(t) => unknown *)
(* l(s) > l(t) & O(s) < O(t) => unknown *)


Set Implicit Arguments.
Unset Strict Implicit.

Require Import qtemp.
Require Import aac.
Require Export nnum_base.

Module qEmbed.
Import QTemp.
Import Ordered_lci.
Import Pow.
Import nNum_ring.

Definition qNat n := pow qPlus q0 q1 n.

Lemma qNat_inc : forall n, inc n nNum -> inc (qNat n) qNum.
Proof.
ap pow_inc. ap qPlus_monoid. ap q1_inc.
Qed.

Lemma qNat_pos : forall n, inc n nNum -> qLeq q0 (qNat n).
Proof.
ap nNum_rect;uf qNat;ir.
rw pow_0. ap qLeq_refl;qSolve.
rw pow_S;au.
assert (qLeq (qPlus q0 q0) (qPlus q1 (pow qPlus q0 q1 n))).
ap qLeq_qPlus_compat;qSolve.
ap qNat_inc. am.
rwi qPlus_0_l H1;au. ap q0_inc.
Qed.

Lemma qNat_nonzero : forall n, inc n nNum -> n<>n0 -> qNat n <> q0.
Proof.
ir. apply nNum_destruct in H. nin H. subst.
nin H0;tv.
nin H;ee;subst.
uf qNat.
uhg;ir. rwi pow_S H1;qSolve.
ap q0_q1_neq. ap qLeq_antisym;qSolve.
rw qLeq_qOpp;qSolve. rw qOpp_q0.
replace (qOpp q1) with (pow qPlus q0 q1 x).
ap qNat_pos. am.
apply qPlus_reg_l with q1;qSolve.
ap qNat_inc;am.
rw qOpp_r;au. ap q1_inc.
Qed.

Lemma qNat_nPlus : forall n, inc n nNum -> forall m, inc m nNum ->
qNat (nPlus n m) = qPlus (qNat n) (qNat m).
Proof.
eapply pow_nPlus. ap qPlus_monoid. ap q1_inc.
Qed.

Lemma qNat_unicity : forall n, inc n nNum -> forall m, inc m nNum ->
qNat n = qNat m -> n=m.
Proof.
pose (p := fun n => forall m : E, (m ∈ ω) -> qNat n = qNat m -> n = m).
assert (forall n, inc n nNum -> p n);try am.
ap nNum_rect;uf p;uf qNat;ir.
rwi pow_0 H0.
apply nNum_destruct in H. nin H;ee;subst. tv.
nin H;ee;subst.
destruct qNat_nonzero with (oS x).
ap oS_nNum;am. uhg;ir.
apply emptyset_empty with x. ufi n0 H1. wr H1. rw oS_inc. au.
au.
apply nNum_destruct in H1. nin H1. subst.
rwi pow_0 H2. apply qNat_nonzero in H2.
elim H2.
ap oS_nNum;am. uhg;ir.
apply emptyset_empty with n. ufi n0 H1. wr H1. rw oS_inc. au.
nin H1;ee;subst. ap uneq.
ap H0. am.
rwi pow_S H2;au. rwi pow_S H2;au.
apply qPlus_reg_l with q1;qSolve;ap qNat_inc;am.
Qed.

Definition qNat_back x := unique_choose (fun n => inc n nNum & x = qNat n).

Lemma qNat_back_pr : forall n, inc n nNum -> (inc (qNat_back (qNat n)) nNum & qNat n = qNat (qNat_back (qNat n))).
Proof.
ir;uf qNat_back. ap unique_choose_pr.
exists n;ee;au.
uhg;ir. ee.
ap qNat_unicity. am. am. transitivity (qNat n);au.
Qed.

Lemma qNat_back_qNat : forall n, inc n nNum -> qNat_back (qNat n) = n.
Proof.
ir.
cp (qNat_back_pr H).
ee.
ap qNat_unicity;au.
Qed.

Lemma qNat_back_Im : forall x, inc x (Im qNat nNum) -> (inc (qNat_back x) nNum &
x = qNat (qNat_back x)).
Proof.
ir. Im_nin H. subst.
ap qNat_back_pr. am.
Qed.

Lemma qNat_back_inc : forall x, inc x (Im qNat nNum) -> inc (qNat_back x) nNum.
Proof.
ir;ap qNat_back_Im;am.
Qed.

Definition qEmbedder0 x := if P_dec (inc x (Im qNat nNum))
then qNat_back x
else x.

Lemma qEmbedder0_injects : Transformation.injects qNum qEmbedder0.
Proof.
uhg;ir.
ufi qEmbedder0 H1.
 destruct (P_dec (inc x (Im qNat nNum))); destruct (P_dec (inc y (Im qNat nNum))).
apply Im_ex in i. apply Im_ex in i0.
nin i;nin i0. ee. subst.
ap uneq.
rwi qNat_back_qNat H1;au. rwi qNat_back_qNat H1;au.
apply Im_ex in i;nin i;ee;subst.
apply qNum_nNum_neq in H0. elim H0.
ap qNat_back_pr. am.
subst. apply qNum_nNum_neq in H.
elim H. ap qNat_back_inc. am.
am.
Qed.

Definition qEmbedder := L qNum qEmbedder0.

Definition qEmbed := Im qEmbedder0 qNum.

Lemma qEmbedder_bij : bijective qNum qEmbed qEmbedder.
Proof.
ap map_of_bijective.
uhg;ee. uhg;ir.
ap Im_inc;am.
ap qEmbedder0_injects.
uhg;ir. Im_nin H.
subst. exists x;ee;au.
Qed.

Definition nEmbedder := inverse (qEmbedder).

Lemma nEmbedder_bij : bijective qEmbed qNum nEmbedder.
Proof.
ap bijective_inverse_bijective. ap qEmbedder_bij.
Qed.

Lemma qEmbedder_inv : are_inverse qNum qEmbed qEmbedder nEmbedder.
Proof.
ap bijective_inverse_of. ap qEmbedder_bij.
Qed.

Lemma nNum_sub_qEmbed : sub nNum qEmbed.
Proof.
uhg;ir.
ap Im_show_inc. exists (qNat a);ee. ap qNat_inc;am.
uf qEmbedder0. rw P_dec_if.
symmetry. ap qNat_back_qNat. am.
ap Im_inc;am.
Qed.

Lemma nEmbedder_nat : forall n, inc n nNum -> ev nEmbedder n = qNat n.
Proof.
ir.
assert (ev qEmbedder (ev nEmbedder n) = n).
ap qEmbedder_inv. ap nNum_sub_qEmbed. am.
ap qEmbedder_bij. eapply trans_of_map. ap nEmbedder_bij.
ap nNum_sub_qEmbed. am.
ap qNat_inc;am.
rw H0.
uf qEmbedder. rw create_ev. uf qEmbedder0.
rw P_dec_if. symmetry. ap qNat_back_qNat. am.
ap Im_inc;am. ap qNat_inc;am.
Qed.

Definition qEPlus x y := ev qEmbedder (qPlus (ev nEmbedder x) (ev nEmbedder y)).
Definition qEMult x y := ev qEmbedder (qMult (ev nEmbedder x) (ev nEmbedder y)).

Lemma qEPlus_lci : is_lci qEPlus qEmbed.
Proof.
uhg;ir.
uf qEPlus. eapply trans_of_map. ap qEmbedder_bij.
ap qPlus_lci. eapply trans_of_map;[ap nEmbedder_bij | am].
eapply trans_of_map;[ap nEmbedder_bij | am].
Qed.

Lemma qEMult_lci : is_lci qEMult qEmbed.
Proof.
uhg;ir.
uf qEMult. eapply trans_of_map. ap qEmbedder_bij.
ap qMult_lci. eapply trans_of_map;[ap nEmbedder_bij | am].
eapply trans_of_map;[ap nEmbedder_bij | am].
Qed.

Lemma qEPlus_comm : commutative qEPlus qEmbed.
Proof.
uhg;ir.
uf qEPlus.
ap uneq. ap qPlus_comm.
eapply trans_of_map;[ap nEmbedder_bij | am].
eapply trans_of_map;[ap nEmbedder_bij | am].
Qed.

Lemma qEMult_comm : commutative qEMult qEmbed.
Proof.
uhg;ir.
uf qEMult.
ap uneq. ap qMult_comm.
eapply trans_of_map;[ap nEmbedder_bij | am].
eapply trans_of_map;[ap nEmbedder_bij | am].
Qed.

Lemma qEmbed_0 : ev qEmbedder q0 = n0.
Proof.
uf qEmbedder. rw create_ev;qSolve.
uf qEmbedder0. rw P_dec_if.
replace q0 with (qNat n0). ap qNat_back_qNat;nSolveS.
uf qNat. ap pow_0.
apply Im_show_inc. exists n0;ee. ap n0_inc.
symmetry. ap pow_0.
Qed.

Lemma nEmbed_0 : ev nEmbedder n0 = q0.
Proof.
wr qEmbed_0. ap qEmbedder_inv. ap q0_inc.
Qed.

Lemma qEmbed_1 : ev qEmbedder q1 = n1.
Proof.
uf qEmbedder;uf qEmbedder0.
rw create_ev;qSolve.
replace q1 with (qNat n1).
rw P_dec_if. ap qNat_back_qNat. ap n1_inc.
ap Im_inc. ap n1_inc. uf qNat;uf n1.
rw pow_S;nSolveS. rw pow_0. ap qPlus_0_r;qSolve.
Qed.

Lemma nEmbed_1 : ev nEmbedder n1 = q1.
Proof.
wr qEmbed_1. ap qEmbedder_inv. ap q1_inc.
Qed.

Lemma qEmbed_plus_morph : forall x, inc x qNum -> forall y, inc y qNum ->
ev qEmbedder (qPlus x y) = qEPlus (ev qEmbedder x) (ev qEmbedder y).
Proof.
ir.
uf qEPlus. ap uneq2. tv. ap uneq2;symmetry;ap qEmbedder_inv;am.
Qed.

Lemma qEmbed_mult_morph : forall x, inc x qNum -> forall y, inc y qNum ->
ev qEmbedder (qMult x y) = qEMult (ev qEmbedder x) (ev qEmbedder y).
Proof.
ir.
uf qEMult. ap uneq2. tv. ap uneq2;symmetry;ap qEmbedder_inv;am.
Qed.

Lemma qEmbed_rw : qEmbed = Im (ev qEmbedder) qNum.
Proof.
ap extensionality;uhg;ir;Im_nin H;subst;ap Im_show_inc;exists x;ee;au.
symmetry. ap create_ev;am.
ap create_ev;am.
Qed.

Lemma nEmbed_plus_morph : forall x, inc x qEmbed -> forall y, inc y qEmbed ->
ev nEmbedder (qEPlus x y) = qPlus (ev nEmbedder x) (ev nEmbedder y).
Proof.
ir. rwi qEmbed_rw H;rwi qEmbed_rw H0.
 Im_nin H. Im_nin H0. subst.
wr qEmbed_plus_morph.
etransitivity. ap qEmbedder_inv. ap qPlus_lci;am.
ap uneq2;symmetry;ap qEmbedder_inv;am. am. am.
Qed.

Lemma nEmbed_mult_morph : forall x, inc x qEmbed -> forall y, inc y qEmbed ->
ev nEmbedder (qEMult x y) = qMult (ev nEmbedder x) (ev nEmbedder y).
Proof.
ir. rwi qEmbed_rw H;rwi qEmbed_rw H0.
 Im_nin H. Im_nin H0. subst.
wr qEmbed_mult_morph.
etransitivity. ap qEmbedder_inv. ap qMult_lci;am.
ap uneq2;symmetry;ap qEmbedder_inv;am. am. am.
Qed.

Lemma qEPlus_assoc : associative qEPlus qEmbed.
Proof.
uhg;ir.
uf qEPlus.
ap uneq.
cp qEmbedder_inv. uh H2;ee.
uh H4;ee.
rw H4. rw H4.
ap qPlus_assoc;eapply trans_of_map;am.
qSolve;eapply trans_of_map;am.
qSolve;eapply trans_of_map;am.
Qed.

Lemma qEMult_assoc : associative qEMult qEmbed.
Proof.
uhg;ir.
uf qEMult.
ap uneq.
cp qEmbedder_inv. uh H2;ee.
uh H4;ee.
rw H4. rw H4.
ap qMult_assoc;eapply trans_of_map;am.
qSolve;eapply trans_of_map;am.
qSolve;eapply trans_of_map;am.
Qed.

Lemma qEPlus_0_l : forall x, inc x qEmbed -> qEPlus n0 x = x.
Proof.
ir. uf qEPlus.
rw nEmbed_0. rw qPlus_0_l. ap qEmbedder_inv. am.
eapply trans_of_map. ap nEmbedder_bij. am.
Qed.

Lemma qEPlus_0_r : forall x, inc x qEmbed -> qEPlus x n0 = x.
Proof.
ir. etransitivity. ap qEPlus_comm. am. ap nNum_sub_qEmbed. ap n0_inc.
ap qEPlus_0_l;am.
Qed.

Lemma qEPlus_neutre : is_neutre qEPlus qEmbed n0.
Proof.
uhg;ee. ap nNum_sub_qEmbed. ap n0_inc.
ap qEPlus_0_r. ap qEPlus_0_l.
Qed.

Lemma qEMult_1_l : forall x, inc x qEmbed -> qEMult n1 x = x.
Proof.
ir. uf qEMult.
rw nEmbed_1. rw qMult_1_l. ap qEmbedder_inv. am.
eapply trans_of_map. ap nEmbedder_bij. am.
Qed.

Lemma qEMult_1_r : forall x, inc x qEmbed -> qEMult x n1 = x.
Proof.
ir. etransitivity. ap qEMult_comm. am. ap nNum_sub_qEmbed. ap n1_inc.
ap qEMult_1_l;am.
Qed.

Lemma qEMult_neutre : is_neutre qEMult qEmbed n1.
Proof.
uhg;ee. ap nNum_sub_qEmbed. ap n1_inc.
ap qEMult_1_r. ap qEMult_1_l.
Qed.

Lemma qEMult_0_l : forall x, inc x qEmbed -> qEMult n0 x = n0.
Proof.
ir.
uf qEMult. rw nEmbed_0.
rw qMult_0_l. ap qEmbed_0.
eapply trans_of_map. ap nEmbedder_bij.
am.
Qed.

Lemma qEMult_0_r : forall x, inc x qEmbed -> qEMult x n0 = n0.
Proof.
ir.
uf qEMult. rw nEmbed_0.
rw qMult_0_r. ap qEmbed_0.
eapply trans_of_map. ap nEmbedder_bij.
am.
Qed.

Definition qEmbed_nEmbed := and_Q (and_Q (and_Q qEmbedder_inv)).
Definition nEmbed_qEmbed := and_P (and_Q (and_Q qEmbedder_inv)).

Lemma qEPlus_inversible : forall x, inc x qEmbed -> inversible qEPlus qEmbed n0 x.
Proof.
ir.
rwi qEmbed_rw H. Im_nin H;subst.
exists (ev qEmbedder (qOpp x0)).
uhg;dj. eapply trans_of_map. ap qEmbedder_bij. am.
eapply trans_of_map. ap qEmbedder_bij. qSolve.
uf qEPlus. rw nEmbed_qEmbed;qSolve.
rw nEmbed_qEmbed;qSolve. rw qOpp_r;qSolve. ap qEmbed_0.
wr H2. ap qEPlus_comm;au.
Qed.

Lemma qEPlus_monoid : is_monoid qEPlus qEmbed n0.
Proof.
uhg;ee. ap qEPlus_lci. ap qEPlus_neutre. ap qEPlus_assoc.
Qed.

Lemma qEPlus_group : is_group qEPlus qEmbed n0.
Proof.
uhg;ee;try ap qEPlus_monoid. ap qEPlus_inversible.
Qed.

Lemma qEMult_monoid : is_monoid qEMult qEmbed n1.
Proof.
uhg;ee. ap qEMult_lci. ap qEMult_neutre. ap qEMult_assoc.
Qed.

Lemma qEMult_distrib_l : distrib_l qEPlus qEMult qEmbed.
Proof.
uhg;ir.
uf qEPlus;uf qEMult.
rw nEmbed_qEmbed;qSolve.
rw nEmbed_qEmbed;qSolve. rw nEmbed_qEmbed;qSolve.
ap uneq. ap qMult_distrib_l.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
apply (bijective_of_map nEmbedder_bij); am.
Qed.

Lemma qEMult_distrib_r : distrib_r qEPlus qEMult qEmbed.
Proof.
uhg;ir.
rw qEMult_comm. rw qEMult_distrib_l.
ap uneq2;ap qEMult_comm;am.
am. am. am. ap qEPlus_lci;am. am.
Qed.

Lemma qEMult_distributes : distributes qEPlus qEMult qEmbed.
Proof.
uhg;ee. ap qEMult_distrib_l. ap qEMult_distrib_r.
Qed.

Lemma qEmbed_ring : is_ring qEPlus qEMult qEmbed n0 n1.
Proof.
uhg;ee. ap qEPlus_group. ap qEPlus_comm. ap qEMult_monoid.
 ap qEMult_distributes.
Qed.

Lemma qEMult_inversible : forall x, inc x qEmbed -> x<>n0 ->
inversible qEMult qEmbed n1 x.
Proof.
ir.
rwi qEmbed_rw H. Im_nin H.
subst.
assert (x0<>q0).
uhg;ir;subst. ap H0. ap qEmbed_0.
exists (ev qEmbedder (qInv x0)).
uhg;dj.
ap (bijective_of_map qEmbedder_bij).
am.
ap (bijective_of_map qEmbedder_bij).
qSolve.
uf qEMult.
rw nEmbed_qEmbed;qSolve. rw nEmbed_qEmbed;qSolve.
rw qInv_r;qSolve. ap qEmbed_1.
wr H4. ap qEMult_comm;au.
Qed.

Lemma qEmbed_field : is_field qEPlus qEMult qEmbed n0 n1.
Proof.
uhg;ee. ap qEmbed_ring. ap qEMult_inversible.
Qed.

Definition qEmbed_tbij := bijective_of_map qEmbedder_bij.
Definition nEmbed_tbij := bijective_of_map nEmbedder_bij.

Definition qELeq x y := qLeq (ev nEmbedder x) (ev nEmbedder y).

Lemma qELeq_refl : reflexiveT qELeq qEmbed.
Proof.
uhg;ir.
ap qLeq_refl. ap nEmbed_tbij. am.
Qed.

Lemma qELeq_antisym : antisymmetricT qELeq qEmbed.
Proof.
uhg;ir.
uh H1;uh H2.
ap nEmbed_tbij;au.
ap qLeq_antisym;au;ap nEmbed_tbij;am.
Qed.

Lemma qELeq_trans : transitiveT qELeq qEmbed.
Proof.
uhg;ir.
eapply qLeq_trans. Focus 3. am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
am.
Qed.

Lemma qELeq_order : is_order qELeq qEmbed.
Proof.
uhg;ee. ap qELeq_refl. ap qELeq_antisym. ap qELeq_trans.
Qed.

Lemma qELeq_total : is_total qELeq qEmbed.
Proof.
uhg;ir.
ap qLeq_total;ap nEmbed_tbij;am.
Qed.

Lemma qELeq_qEPlus_compat : is_compatible qELeq qEPlus qEmbed.
Proof.
uhg;ir.
uf qEPlus;uf qELeq.
rw nEmbed_qEmbed.
rw nEmbed_qEmbed.
ap qLeq_qPlus_compat;try am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
ap qPlus_lci;ap nEmbed_tbij;am.
ap qPlus_lci;ap nEmbed_tbij;am.
Qed.

Import Ordered_ring.

Lemma qELeq_qEMult_preserves : order_preserves qELeq qEMult qEmbed n0.
Proof.
uhg;ir.
uhg. rw nEmbed_0.
uh H0;uh H2. rwi nEmbed_0 H0. rwi nEmbed_0 H2.
uf qEMult.
rw nEmbed_qEmbed;qSolve.
ap qLeq_qMult_preserves.
ap nEmbed_tbij;am.
am. ap nEmbed_tbij;am. am.
ap nEmbed_tbij;am.
ap nEmbed_tbij;am.
Qed.

Lemma qEPlus_ordered : is_ordered_group qELeq qEPlus qEmbed n0.
Proof.
uhg;ee. ap qELeq_order. ap qEPlus_group.
ap qELeq_qEPlus_compat.
Qed.

Lemma qEmbed_ordered : is_ordered_field qEPlus qEMult qELeq qEmbed n0 n1.
Proof.
uhg;ee. ap qEmbed_field. ap qELeq_order. ap qELeq_qEPlus_compat.
uhg. rw nEmbed_0. rw nEmbed_1.
qSolve.
ap qELeq_qEMult_preserves.
Qed.

Lemma qEPlus_nPlus_eq : forall n, inc n nNum -> forall m, inc m nNum ->
qEPlus n m = nPlus n m.
Proof.
ir. uf qEPlus.
rw nEmbedder_nat;nSolveS. rw nEmbedder_nat;nSolveS.
wr qNat_nPlus;nSolveS. wr nEmbedder_nat;nSolveS.
ap qEmbed_nEmbed. ap nNum_sub_qEmbed;nSolveS.
Qed.

Lemma qEMult_nMult_eq : forall n, inc n nNum -> forall m, inc m nNum ->
qEMult n m = nMult n m.
Proof.
intros n Hn. ap nNum_rect.
fold n0. rw nMult_0. ap qEMult_0_r.
ap nNum_sub_qEmbed;am.
ir.
rw nMult_S;nSolveS.
replace (oS n2) with (qEPlus n2 n1).
rw qEMult_distrib_l.
rw H0. rw qEMult_1_r.
ap qEPlus_nPlus_eq;nSolveS.
ap nNum_sub_qEmbed;nSolveS.
ap nNum_sub_qEmbed;nSolveS.
ap nNum_sub_qEmbed;nSolveS.
ap nNum_sub_qEmbed;nSolveS.
rw qEPlus_nPlus_eq. uf n1. rw nPlus_S;nSolveS.
rw nPlus_0;nSolveS. am. nSolveS.
Qed.

Lemma qNat_qLeq : forall n, inc n nNum -> forall m, inc m nNum -> nLeq n m ->
qLeq (qNat n) (qNat m).
Proof.
ir. rwi nLeq_rw H1;au. nin H1;ee;subst.
apply qLeq_qPlus_reg_l with (qOpp (qNat n));qSolve;try ap qNat_inc;au.
rw qNat_nPlus;au.
cp qNat_inc.
rw qPlus_assoc;qSolve;au.
rw qOpp_l;au. rw qPlus_0_l;au.
ap qNat_pos. am.
Qed.

Lemma qELeq_nLeq_eq : forall n, inc n nNum -> forall m, inc m nNum ->
qELeq n m = nLeq n m.
Proof.
ir;ap iff_eq;ir.
uh H1.
rwi nEmbedder_nat H1;au. rwi nEmbedder_nat H1;au.
rw (leq_not_lt nLeq_to);au.
uhg;ir. nin H2.
cp H2. apply qNat_qLeq in H4;au.
ap H3. ap qNat_unicity;au.
ap qLeq_antisym;au;ap qNat_inc;am.

uhg.
rw nEmbedder_nat;au. rw nEmbedder_nat;au.
ap qNat_qLeq;am.
Qed.

End qEmbed.

Module QETemp.
Import qEmbed.
Import Ordered_lci.
Import Pow.
Import nNum_ring.

Inductive is_fraction : EP :=
  | nat_fraction : forall n, inc n nNum -> is_fraction n
  | opp_fraction : forall x, is_fraction x -> is_fraction (inverse_of qEPlus qEmbed n0 x)
  | div_fraction : forall x, is_fraction x -> forall y, is_fraction y -> n0<>y ->
       is_fraction (qEMult x (inverse_of qEMult qEmbed n1 y))
.

Definition qNum := Z qEmbed is_fraction.

Lemma nNum_qNum : sub nNum qNum.
Proof.
uhg;ir. ap Z_inc. ap nNum_sub_qEmbed. am.
constructor. am.
Qed.

Lemma q0_inc : inc n0 qNum.
Proof.
ap nNum_qNum;nSolveS.
Qed.

Lemma q1_inc : inc n1 qNum.
Proof.
ap nNum_qNum;nSolveS.
Qed.

Definition qPlus := qEPlus.

Definition qMult := qEMult.

Definition qLeq := qELeq.
(*???*)
Lemma qPlus_lci : is_lci qPlus qNum.
Proof.
uhg;ir. apply Z_all in H;apply Z_all in H0. ee.
ap Z_inc. ap qEPlus_lci.
am. am.

Qed.

End QETemp.