From Coq Require Import List.

Import ListNotations.

Require Import FutharkUtils.

Module Type FutharkSpec.

  Global Create HintDb futhark.

  Parameter map:
    forall {A B : Type} (f : A -> B) (xs : list A), list B.

  Parameter reduce:
    forall {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}
      (xs : list A), A.

  Parameter scan:
    forall {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}
      (xs : list A), list A.

  Section map_axioms.

    Context {A B : Type} (f : A -> B).

    Axiom map_nil:
      map f [] = [].

    Axiom map_cons:
      forall (x : A) (xs : list A), map f (x :: xs) = f x :: (map f xs).

  End map_axioms.

  Section reduce_axioms.

    Context {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}.

    Axiom reduce_monoid_homo_unit:
      reduce op ne [] = ne.

    Axiom reduce_cons:
      forall (a : A) (l : list A), reduce op ne (a :: l) = op a (reduce op ne l).

  End reduce_axioms.

  Section scan_axioms.

    Context {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}.

    Axiom scan_cons:
      forall (h : A) (t : list A), scan op ne (h :: t) = h :: map (op h) (scan op ne t).

    Axiom scan_nil:
      scan op ne [] = [].

  End scan_axioms.

  Hint Rewrite @map_nil                 using (exact _) : futhark.
  Hint Rewrite @map_cons                using (exact _) : futhark.
  Hint Rewrite @reduce_monoid_homo_unit using (exact _) : futhark.
  Hint Rewrite @reduce_cons             using (exact _) : futhark.
  Hint Rewrite @scan_cons               using (exact _) : futhark.
  Hint Rewrite @scan_nil                using (exact _) : futhark.

End FutharkSpec.

Module FutharkMod (F : FutharkSpec).

  Include F.

  Hint Rewrite @munit_left       using (exact _) : futhark.
  Hint Rewrite @munit_right      using (exact _) : futhark.
  Hint Rewrite <- @massoc         using (exact _) : futhark.

  Hint Rewrite app_nil_r : futhark.
  Hint Rewrite app_nil_l : futhark.
  Hint Rewrite <- app_comm_cons : futhark.

  Ltac fauto :=
    repeat progress (autorewrite with futhark; auto with futhark).

  Section map.

    Context {A B : Type} (f : A -> B).

    Theorem map_app:
      forall (xs ys : list A), map f (xs ++ ys) = map f xs ++ map f ys.
    Proof.
      intros xs *; induction xs; fauto; f_equal; assumption.
    Qed.

  End map.

  Hint Rewrite @map_app : futhark.

  Section reduce.

    Context {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}.

    Theorem reduce_monoid_homo_mult:
    forall (xs : list A) (ys : list A),
      reduce op ne (xs ++ ys) = op (reduce op ne xs) (reduce op ne ys).
    Proof.
      intros xs ys;
        induction xs as [|x xs IH];
        fauto;
        rewrite IH;
        rewrite massoc;
        reflexivity.
    Qed.

  End reduce.

  Hint Rewrite @reduce_monoid_homo_mult using (exact _) : futhark.

End FutharkMod.

Module FutharkSpecImpl : FutharkSpec.

  Definition map {A B : Type} (f : A -> B) (xs : list A) : list B :=
    List.map f xs.

  Definition reduce {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne} (xs : list A) : A :=
    fold_right op ne xs.

  Fixpoint scan {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne} (xs : list A) : list A :=
    match xs with
    | [] => []
    | y :: ys => y :: map (op y) (scan op ne ys)
    end.

  Section map_obligatons.

    Context {A B : Type} (f : A -> B).

    Theorem map_nil:
      map f [] = [].
    Proof. intros; reflexivity. Qed.

    Theorem map_cons:
      forall (x : A) (xs : list A), map f (x :: xs) = f x :: (map f xs).
    Proof. intros; reflexivity. Qed.

  End map_obligatons.

  Section reduce_obligatons.

    Context {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}.

    Theorem reduce_monoid_homo_unit:
      reduce op ne [] = ne.
    Proof. intros; reflexivity. Qed.

    Theorem reduce_cons:
      forall (a : A) (l : list A), reduce op ne (a :: l) = op a (reduce op ne l).
    Proof. intros; reflexivity. Qed.

  End reduce_obligatons.

  Section scan_obligatons.

    Context {A : Type} (op : A -> A -> A) (ne : A) `{IsMonoid A op ne}.

    Theorem scan_nil:
      scan op ne [] = [].
    Proof. intros; reflexivity. Qed.

    Theorem scan_cons:
      forall (h : A) (t : list A), scan op ne (h :: t) = h :: map (op h) (scan op ne t).
    Proof.
    Proof. intros; reflexivity. Qed.

  End scan_obligatons.

  Hint Rewrite @map_cons : futhark.
  Hint Rewrite @reduce_monoid_homo_unit using (exact _) : futhark.
  Hint Rewrite @reduce_cons             using (exact _) : futhark.
  Hint Rewrite @scan_cons               using (exact _) : futhark.
  Hint Rewrite @scan_nil                using (exact _) : futhark.

End FutharkSpecImpl.

Module FutharkImpl := FutharkMod (FutharkSpecImpl).


Section Minimal_propositional_logic.
 Variables P Q R T : Prop.

 Check ((P->Q)->(Q->R)->P->R).

 Theorem imp_trans : (P->Q)->(Q->R)->P->R.
 Proof.
  intros H H' p.
  apply H'.
  apply H.
  assumption.
 Qed.

 Print imp_trans.

 Theorem imp_trans' : (P->Q)->(Q->R)->P->R.
 Proof.
  auto.
 Qed.

 Theorem delta : (P->P->Q)->P->Q.
 Proof (fun (H:P->P->Q)(p:P) => H p p).

 Lemma apply_example : (Q->R->T)->(P->Q)->P->R->T.
 Proof.
  intros H H0 p.
  apply H.
  exact (H0 p).
 Qed.

 Theorem imp_dist : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H.
  assumption.
  apply H'.
  assumption.
 Qed.

 Print imp_dist.

 Theorem K : P->Q->P.
 Proof.
  intros p q.
  assumption.
 Qed.

 Definition f : (nat->bool)->(nat->bool)->nat->bool.
  intros f1 f2.
  assumption.
 Defined.

 Print f.

 Eval compute in (f (fun n => true)(fun n => false) 45).

 Opaque f.

 Eval compute in (f (fun n => true)(fun n => false) 45).

 Section proof_of_triple_impl.
  Hypothesis H : ((P->Q)->Q)-> Q.
  Hypothesis p : P.

  Lemma Rem : (P->Q)->Q.
  Proof (fun H0:P->Q => H0 p).

  Theorem triple_impl : Q.
  Proof (H Rem).

 End proof_of_triple_impl.

 Print triple_impl.

 Print Rem.

 Lemma then_example : P->Q->(P->Q->R)->R.
 Proof.
  intros p q H.
  apply H; assumption.
 Qed.

 Theorem triple_impl_one_shot : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
 Qed.

 Lemma compose_example : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H;[assumption | apply H'; assumption].
 Qed.

 Theorem orelse_example : (P->Q)->R->((P->Q)->R->(T->Q)->T)->T.
 Proof.
  intros H r H0.
  apply H0;(assumption || intro H1).
  Abort.

 Lemma L3 : (P->Q)->(P->R)->(P->Q->R->T)->P->T.
 Proof.
  intros H H0 H1 p.
  apply H1;[idtac | apply H | apply H0]; assumption.
 Qed.

 Lemma then_fail_example : (P->Q)->(P->Q).
 Proof.
  intro X; apply X; fail.
 Qed.

 Lemma try_example : (P->Q->R->T)->(P->Q)->(P->R->T).
 Proof.
  intros H H' p r.
  apply H; try assumption.
  apply H'; assumption.
 Qed.
 Reset imp_dist.

 Theorem imp_dist : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros.
  apply H.
  assumption.
  apply H0.
  assumption.
 Qed.

 Section proof_cut_and_paste.
  Hypothesis H : ((P->Q)->Q)->(P->Q)->R.

  Theorem  imp_dist_2 : (P->Q->R)->(P->Q)->(P->R) .
  Proof (* copy of imp_dist proof script *).
   intros.
   apply H.
  Abort.
  End proof_cut_and_paste.

 Section section_for_cut_example.
  Hypotheses (H : P->Q)
             (H0 : Q->R)
             (H1 : (P->R)->T->Q)
             (H2 : (P->R)->T).

  Lemma cut_example : Q.
  Proof.
   cut (P->R).
   intro H3.
   apply H1;[assumption | apply H2; assumption].
   intro; apply H0; apply H; assumption.
  Qed.
 Print cut_example.
 End section_for_cut_example.

 Lemma triple_impl2 : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  auto.
 Qed.

End Minimal_propositional_logic.

Print imp_dist.

Section using_imp_dist.
 Variables (P1 P2 P3 : Prop).
 Check (imp_dist P1 P2 P3).

 Check (imp_dist (P1->P2)(P2->P3)(P3->P1)).

End using_imp_dist.


Inductive natlist : Type :=
  | nil  : natlist
  | cons : nat -> natlist -> natlist.

Notation "x :: xs" := (cons x xs)
  (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Fixpoint concat (xs : natlist) (ys : natlist) :=
  match ys with
  | []  => xs
  | ys'  =>
      match xs with
      | []    => ys'
      | [x]   => x :: ys'
      | x::xs' => x :: concat xs' ys'
      end
  end.
Notation "xs ++ ys" := (concat xs ys).

Fixpoint rev (xs : natlist) :=
  match xs with
  | [] => xs
  | x::xs' => rev xs' ++ [x]
  end.

Inductive In :

Fixpoint index (xs : natlist) (t : nat) :=
  match xs with
  | [] =>

Theorem app_nil_r : forall l : natlist, l ++ [] = l.
Proof.
  intro l.
  simpl.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import List.
Require Import Bar.
Require Import OpenIndGoodRel.
Require Import Lt.
Require Import Wf_nat.

Definition DecRel (A : Set) (R : Rel A) :=
  forall x y : A, {R x y} + {~ R x y}.
(* A computational double induction rule *)

Theorem nat_double_ind_set :
 forall R : nat -> nat -> Set,
 (forall n : nat, R 0 n) ->
 (forall n : nat, R (S n) 0) ->
 (forall n m : nat, R n m -> R (S n) (S m)) -> forall n m : nat, R n m.
Proof.
simple induction n; simple induction m; auto.
Qed.

Lemma dec_lt : DecRel nat lt.
red in |- *; intros; pattern x, y in |- *.
apply nat_double_ind_set; auto with arith.
intros n; case n; auto with arith.
intros n m H'; case H'; auto with arith.
Qed.

Definition NegRel (A : Set) (R : Rel A) (x y : A) := ~ R x y.

Definition ProdRel (A B : Set) (R : Rel A) (S : Rel B)
  (x y : A * B) := R (fst x) (fst y) /\ S (snd x) (snd y).
Section Dickson.
Variable A B : Set.
Variable lt : Rel A.
Variable R : Rel B.
Variable wfgt : well_founded lt.
Variable declt : DecRel A lt.
Variable wR : WR B R.

Definition leq (a b : A) := ~ lt b a.

Definition GBarlR := GRBar (A * B) (ProdRel A B leq R).

Definition sndL := map (fun p : A * B => snd p).

Definition MinD :=
  Min (A * B) (fun p q : A * B => lt (fst p) (fst q)) (ProdRel A B leq R).

Definition prod_lt (a b : A * B) := lt (fst a) (fst b).
Require Import Inverse_Image.

Lemma WFlem1 : well_founded prod_lt.
unfold prod_lt in |- *; apply wf_inverse_image with (B := A); auto.
Qed.

Lemma lem0 :
 forall (l : list (A * B)) (a : A * B),
 ExistsL B (fun x : B => R x (snd a)) (sndL l) -> MinD l -> GBarlR (a :: l).
intros l; elim l; simpl in |- *; auto.
intros a H' H'0; inversion H'.
intros a l0 H' a0 H'0 H'1; inversion H'0.
simpl in H0; simpl in H1; simpl in H.
case (declt (fst a0) (fst a)); intros LtE.
change (GBarlR ((a0 :: nil) ++ (a :: nil) ++ l0)) in |- *; auto.
red in |- *; apply monGRBar; simpl in |- *; auto.
inversion H'1; auto.
red in |- *; red in |- *; apply Base.
apply FoundG.
apply FoundE.
unfold ProdRel in |- *; split; auto.
simpl in H0; simpl in H1; simpl in H.
change (GBarlR ((a0 :: nil) ++ (a :: nil) ++ l0)) in |- *; auto.
red in |- *; apply monGRBar; simpl in |- *; auto.
inversion H'1; simpl in |- *; auto.
apply H'; auto.
Qed.

Lemma lem1aux :
 forall l : list B,
 GoodR B R l -> forall us : list (A * B), l = sndL us -> MinD us -> GBarlR us.
intros l; elim l; auto.
intros H'; inversion H'.
intros a l0 H' H'0; inversion H'0; auto.
intros us; elim us; simpl in |- *; auto.
intros; discriminate.
intros a1 l2 H'1 H'2 H'3; inversion H'2.
apply lem0; auto.
rewrite <- H3; rewrite <- H4; auto.
inversion H'3; auto.
intros us; elim us; unfold sndL in |- *; simpl in |- *; auto.
intros; discriminate.
intros a1 l2 H'1 H'2 H'3; inversion H'2.
change (GBarlR (nil ++ (a1 :: nil) ++ l2)) in |- *.
red in |- *; apply monGRBar; simpl in |- *; auto.
apply H'; auto.
inversion H'3; auto.
Qed.

Lemma lem1 :
 forall us : list (A * B), GoodR B R (sndL us) -> MinD us -> GBarlR us.
intros us H' H'0.
apply lem1aux with (l := sndL us); auto.
Qed.

Lemma keylem :
 forall bs : list B,
 GRBar B R bs ->
 forall us : list (A * B), bs = sndL us -> MinD us -> GBarlR us.
intros bs H'; elim H'; auto.
intros l H'0 us H'1 H'2.
apply lem1; auto.
rewrite <- H'1; auto.
intros l H'0 H'1 us H'2 H'3; red in |- *.
apply OpenInd with (lt := prod_lt); auto.
exact WFlem1.
intros a H'4.
apply H'1 with (a := snd a); auto.
rewrite H'2; auto.
Qed.

Lemma keylem_cor : WR (A * B) (ProdRel A B leq R).
red in |- *; apply keylem with (bs := nil (A:=B)); auto.
red in |- *; auto.
apply nmin; auto.
Qed.
End Dickson.

(* Now we transfer this result to another  representation: *)
Require Import Monomials.

Lemma leq2le : forall a b : nat, leq nat lt a b -> a <= b.
intros.
case (le_or_lt a b).
auto.
intro.
unfold leq in H.
unfold not in H.
case (H H0).
Qed.

Definition jj : forall d : nat, mon d :=
  (fix jj (d : nat) : mon d :=
     match d as n return (mon n) with
     | O => n_0
     | S n => c_n n 0 (jj n)
     end).

Theorem jjProp1 : forall (d : nat) (m : mon d), d = 0 -> m = jj d.
intros d m; elim m.
simpl in |- *; auto.
intros d0 n m0 H' H'0; inversion H'0.
Qed.

Theorem jjProp2 : jj 0 = n_0.
simpl in |- *; auto.
Qed.

Theorem monO_n0 : forall m : mon 0, m = n_0.
intros m; rewrite <- jjProp2.
apply jjProp1; auto.
Qed.

Lemma zRV_WR : WR (mon 0) (mdiv 0).
red in |- *; red in |- *; apply Ind.
intros a; apply Ind.
intros a0; rewrite (monO_n0 a); rewrite (monO_n0 a0).
apply Base; auto.
apply FoundG; auto.
apply FoundE; auto.
apply mdiv_nil; auto.
Qed.

Definition monLift (n : nat) (p : nat * mon n) :=
  match p with
  | (x, m) => c_n n x m
  end.

Lemma monLift_lem :
 forall (n0 : nat) (b : mon (S n0)) (x : nat) (m : mon n0),
 b = c_n n0 x m -> {a : nat * mon n0 | b = monLift n0 a}.
intros.
rewrite H.
exists (x, m).
simpl in |- *.
auto.
Qed.

Lemma dicksonL : forall n : nat, WR (mon n) (mdiv n).
intro.
unfold WR in |- *.
elim n.
apply zRV_WR.
intros.
cut (WR (nat * mon n0) (ProdRel nat (mon n0) (leq nat lt) (mdiv n0)));
 [ intros | exact (keylem_cor nat (mon n0) lt (mdiv n0) lt_wf dec_lt H) ].
unfold WR in H0.
change (GRBar (mon (S n0)) (mdiv (S n0)) (map (monLift n0) nil)) in |- *.
apply subRelGRBar with (R := ProdRel nat (mon n0) (leq nat lt) (mdiv n0));
 auto.
intros a b; case a; case b; simpl in |- *; auto.
intros n1 m n2 m0 H'; inversion H'; auto.
apply mdiv_cons; auto.
apply leq2le; auto.
intros b; exists (pmon1 (S n0) b, pmon2 (S n0) b); simpl in |- *.
apply sym_eq; apply proj_ok; auto.
Qed.


From Undecidability Require Import Synthetic.simple_construction Synthetic.hypersimple Axioms.EA.

Lemma list_max_cns L:
  list_max L = 0 \/ In (list_max L) L.
Proof.
  induction L.
  - now left.
  - destruct IHL.
    + right. cbn. fold (list_max L). rewrite H. left. lia.
    + right. cbn. fold (list_max L). destruct (le_gt_dec (list_max L) a). lia.
      right. now replace (Nat.max a (list_max L)) with (list_max L) by lia.
Qed.

Lemma list_max_NoDup L n:
  NoDup L -> length L = 1 + n -> list_max L >= n.
Proof.
  intros ND H. eapply pigeonhole in ND.
  instantiate (1 := seq 0 n) in ND.
  - destruct ND as [x [H1 % list_max_in H2]]. rewrite in_seq in H2.
    lia.
  - intros x1 x2; decide (x1 = x2); eauto.
  - rewrite H, seq_length. lia.
Qed.

Lemma list_max_length_succ L:
  length L > 0 -> In (list_max L) L.
Proof.
  induction L; cbn.
  - lia.
  - intros H. fold (list_max L). destruct (le_gt_dec (list_max L) a). lia.
    right. replace (Nat.max a (list_max L)) with (list_max L) by lia.
    eapply IHL.
    destruct L; cbn in *; lia.
Qed.

Definition hyper_simple (p: nat -> Prop) : Prop
  := enumerable p /\ ~ exhaustible (compl p) /\
      ~ exists f, majorizes f (compl p).

Definition injective {X Y : Type} (f : X -> Y) := forall x1 x2 : X, f x1 = f x2 -> x1 = x2.

Section HS.
  Import  Coq.Init.Nat.

  Variable I : nat -> Prop.

  Variable E_I: nat -> nat.

  Variable E_I_injective: injective E_I.

  Variable E_I_enum: strong_enumerator E_I I.

  Variable I_undec: ~ decidable I.

  Lemma in_map_sig {X Y} (f: X -> Y) L:
    eq_dec Y -> forall y, In y (map f L) -> {x | f x = y /\ In x L}.
  Proof.
    intros DY y H.
    induction L.
    - cbn; firstorder.
    - cbn in *. decide (In y (map f L)).
      + apply IHL in i as [x IHL1]. exists x. intuition.
      + destruct (DY (f a) y).
        * exists a. intuition.
        * exfalso. destruct H; firstorder.
  Qed.

  Lemma E_I_first_n bound start:
    {x | E_I x > bound /\ x >= start}.
  Proof.
    assert (length (map E_I (seq start (bound + 2))) > length (seq 0 (bound + 1))).
    - rewrite map_length, seq_length, seq_length. lia.
    - apply pigeonhole_Sigma in H.
      + destruct H as [y [H1 H2]]. rewrite in_seq in H2. apply in_map_sig in H1 as [x [E H1]].
        exists x. rewrite E. apply in_seq in H1. lia. exact _.
      + exact _.
      + apply NoDup_map.
        * exact E_I_injective.
        * apply seq_NoDup.
  Qed.

  Definition HS x := exists y, x < y /\ E_I y < E_I x.

  (* Prooving HS to be undecidable via decidable HS -> decidable W *)

  Definition boundable n: Type
    := {x | E_I x >= n /\ compl HS x}.

  Lemma greater_el n x':
    {x | x >= x' /\ E_I x > n}.
  Proof.
    assert (NoDup (map E_I (seq x' (2+n)))).
    { apply map_NoDup; try assumption. apply seq_NoDup. }
    eapply pigeonhole_Sigma in H.
    - instantiate (1:= seq 0 (1 + n)) in H.
      destruct H as (Ex & H1 & H2).
      apply in_map_sig in H1 as [x [H1 H1']].
      + exists x. rewrite in_seq in H1', H2. split; try lia.
      + exact _.
    - exact _.
    - rewrite map_length. repeat rewrite seq_length. lia.
  Qed.

  Lemma bound_dec:
    (forall n, boundable n) -> decidable I.
  Proof.
    intros H.
    assert (forall n, {x | E_I x >= n /\ forall x0, x0 > x -> E_I x0 > E_I x}).
    { intros n. destruct (H n).
      exists x. intuition. enough (~ E_I x0 <= E_I x) by lia.
      intros E. apply H1. exists x0. intuition.
      assert (E_I x0 < E_I x \/ E_I x0 = E_I x) as [E1 | E1 % E_I_injective] by lia; lia.
    }
    assert (forall n, {x | forall x0, x0 > x -> E_I x0 > n}).
    { intros n. destruct (H0 n).
      exists x. intros x0 E; try lia.
      destruct a. specialize (H2 x0 E). lia.
    }
    apply decidable_iff. constructor.
    intros n. destruct (H1 n). decide (In n (map E_I (seq 0 (x + 1)))).
    - left. apply in_map_iff in i as [x0 H2].
      apply E_I_enum. now exists x0.
    - right. intros [n1 H2] % E_I_enum. apply n0.
      apply in_map_iff. exists n1; intuition.
      apply in_seq. enough (~ n1 > x) by lia.
      intros E % g. lia.
  Qed.

  Lemma sizerecursion {X: Type} (s: X -> nat) (p: X -> Type):
    (forall x, (forall y, s y < s x -> p y) -> p x) -> forall x, p x.
  Proof.
    intros H.
    enough (forall n x, s x < n -> p x).
    - intros x. eapply X0. eauto.
    - induction n.
      + intros x H1. lia.
      + intros x E. apply H.
        intros y E1. apply IHn. lia.
  Qed.

  Lemma wo_HS {x}:
    (exists y, x < y /\ E_I y < E_I x) -> {y | x < y /\ E_I y < E_I x}.
  Proof.
    intros H. apply mu_nat_dep in H as [y h].
    - now exists y.
    - intros y.
      destruct (lt_dec x y); destruct (lt_dec (E_I y) (E_I x)); try (left; lia); try (right; lia).
  Qed.

  Lemma inner_loop:
    (forall x, dec (HS x)) -> forall n x', boundable n + {x | x > x' /\ E_I x <= n}.
  Proof.
    intros H n x'. destruct (greater_el n x').
    revert x a.
    apply (sizerecursion E_I (fun x => x >= x' /\ E_I x > n -> boundable n + {x0 : nat | x0 > x' /\ E_I x0 <= n})).
    intros x IH x0.
    destruct (H x).
    - apply wo_HS in h as [y h].
      + specialize (IH y (proj2 h)). destruct (le_dec (E_I y) n).
        * right. exists y; lia.
        * apply IH. lia.
    - left. exists x. intuition.
  Qed.

  Lemma outer_loop step:
    (forall x, dec (HS x)) -> forall n, boundable n + {L | NoDup L /\ length L = step
                                                      /\ forall x, In x L -> E_I x <= n}.
  Proof.
    intros H n. induction step.
    - right. exists nil; firstorder. constructor.
    - destruct IHstep; try now left.
      destruct s as (L & H1 & H2 & H3).
      destruct (inner_loop H n (list_max L)); try now left.
      destruct s as (x & H4 & H5).
      right. exists (x::L); intuition.
      + eapply NoDupBoundH.
        * exact H1.
        * intros x0 E % list_max_in. now instantiate (1:= list_max L).
        * exact H4.
      + destruct H0 as [<- | E]; firstorder.
  Qed.

  Lemma all_boundable:
    (forall x, dec (HS x)) -> forall n, boundable n.
  Proof.
    intros H n.
    destruct (outer_loop (2 + n) H n).
    - exact b.
    - exfalso. destruct s as (L & H0 & H1 & H2).
      assert (incl (map E_I L) (seq 0 (n + 1))).
      { intros x [x0 [<- H4]] % in_map_iff. apply H2 in H4.
        apply in_seq. lia. }
      apply pigeonhole_length in H3.
      + rewrite seq_length, map_length in H3. lia.
      + intros x1 x2; decide(x1 = x2); firstorder.
      + now apply map_NoDup.
  Qed.

  Lemma HS_red:
    decidable HS -> decidable I.
  Proof.
    intros [H] % decidable_iff.
    apply bound_dec, all_boundable, H.
  Qed.

  Corollary HS_undec:
    ~ decidable HS.
  Proof.
    intros H % HS_red.
    now apply I_undec.
  Qed.

  (* Proving HS to be hypersimple *)

  Lemma HS_enumerable:
    enumerable HS.
  Proof.
    unfold HS.
    eapply enumerable_projection1 with (p := fun xy => (fst xy) < (snd xy) /\ E_I (snd xy) < E_I (fst xy)).
    eapply decidable_enumerable. 2: eauto.
    eapply decidable_conj.
    all: eapply decidable_iff; eauto.
  Qed.

  Lemma HS_no_majorize:
    ~ exists f, majorizes f (compl HS).
  Proof.
    intros [g H].
    assert (forall x, I x <-> In x (map E_I (seq 0 (g (1 + x) + 1)))).
    - intros x. split.
      + intros [n H1] % E_I_enum.
        apply in_map_iff. exists n. intuition.
        unfold majorizes in H. apply in_seq.
        specialize (H (1 + x)). enough (~ n > g (1 + x)) by lia.
        intros E. apply H. intros [L HL]. assert (list_max (map E_I L) >= x).
        { apply list_max_NoDup.
          - apply NoDup_map; intuition.
          - now rewrite map_length.
        }
        assert (length (map E_I L) > 0) by (rewrite map_length; lia).
        apply list_max_length_succ in H2. apply in_map_iff in H2 as [n0 E1]. intuition. apply H7 in H5 as [H5 H5'].
        apply H5'. exists n. split; try lia.
        assert (E_I n0 > E_I n \/ E_I n0 = E_I n) as [E1 | E1] by lia.
        * lia.
        * apply E_I_injective in E1. lia.
      + intros [n [H1 _]] % in_map_iff. apply E_I_enum. now exists n.
    - apply I_undec, decidable_iff. constructor.
      intros x. decide (In (x) (map E_I (seq 0 (g (1 + x) + 1)))); [left|right];firstorder.
  Qed.

  Lemma inf_help n x:
    E_I x <= n -> ~ ~ exists y, y >= x /\ compl HS y.
  Proof.
    revert x. induction n.
    - intros x H. intros H1; apply H1. exists x. split.
      + lia.
      + intros [y H2]. lia.
    - intros x E. intros H. ccase (HS x) as [H0 | H0].
      + destruct H0 as [x0 H2]. apply (IHn x0).
        * lia.
        * intros [y H1]. apply H. exists y. intuition.
      + apply H. exists x. firstorder.
  Qed.

  Lemma HS_co_infinite:
    ~ exhaustible (compl HS).
  Proof.
    apply non_finite_nat.
    intros x H. apply (@inf_help (E_I x) x).
    - lia.
    - exact H.
  Qed.

  Lemma HS_hypersimple:
    hyper_simple HS.
  Proof.
    repeat split.
    - apply HS_enumerable.
    - apply HS_co_infinite.
    - apply HS_no_majorize.
  Qed.

End HS.


Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import PL.Imp.

Module Func.

Definition add {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a + g a.

Definition sub {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a - g a.

Definition mul {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a * g a.

Definition test_eq {A: Type} (f g: A -> Z): A -> Prop :=
  fun a => f a = g a.

Definition test_le {A: Type} (f g: A -> Z): A -> Prop :=
  fun a => f a <= g a.

Definition equiv {A: Type} (f g: A -> Z): Prop :=
  forall a, f a = g a.

Definition le {A: Type} (f g: A -> Z): Prop :=
  forall a, f a <= g a.

End Func.

Module Sets.

Definition full {A: Type}: A -> Prop := fun _ => True.

Definition empty {A: Type}: A -> Prop := fun _ => False.

Definition intersect {A: Type} (X Y: A -> Prop) := fun a => X a /\ Y a.

Definition complement {A: Type} (X: A -> Prop) := fun a => ~ X a.

Definition equiv {A: Type} (X Y: A -> Prop): Prop :=
  forall a, X a <-> Y a.

End Sets.

Declare Scope func_scop.
Delimit Scope func_scope with Func.

Notation "f + g" := (Func.add f g): func_scope.
Notation "f - g" := (Func.sub f g): func_scope.
Notation "f * g" := (Func.mul f g): func_scope.

Definition constant_func {A: Type} (c: Z): A -> Z := fun _ => c.
Definition query_var (X: var): state -> Z := fun st => st X.

Fixpoint aeval (a : aexp) : state -> Z :=
  match a with
  | ANum n => constant_func n
  | AId X => query_var X
  | APlus a1 a2 => (aeval a1 + aeval a2)%Func
  | AMinus a1 a2  => (aeval a1 - aeval a2)%Func
  | AMult a1 a2 => (aeval a1 * aeval a2)%Func
  end.

Lemma Func_equiv_refl: forall A, Reflexive (@Func.equiv A).
Proof.
  intros.
  unfold Reflexive.
  unfold Func.equiv.
  intros.
  reflexivity.
Qed.

Lemma Func_equiv_sym: forall A, Symmetric (@Func.equiv A).
Proof.
  intros.
  unfold Symmetric.
  unfold Func.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Func_equiv_trans: forall A, Transitive (@Func.equiv A).
Proof.
  intros.
  unfold Transitive.
  unfold Func.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Sets_equiv_refl: forall A, Reflexive (@Sets.equiv A).
Proof.
  intros.
  unfold Reflexive.
  unfold Sets.equiv.
  intros.
  tauto.
Qed.

Lemma Sets_equiv_sym: forall A, Symmetric (@Sets.equiv A).
Proof.
  intros.
  unfold Symmetric.
  unfold Sets.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Sets_equiv_trans: forall A, Transitive (@Sets.equiv A).
Proof.
  intros.
  unfold Transitive.
  unfold Sets.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_add_equiv: forall A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Func.equiv A) Func.add.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold Func.equiv in H.
  unfold Func.equiv in H0.
  unfold Func.equiv.
  intros.
  unfold Func.add.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_sub_equiv: forall A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Func.equiv A) Func.sub.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold Func.equiv in H.
  unfold Func.equiv in H0.
  unfold Func.equiv.
  intros.
  unfold Func.sub.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_mul_equiv: forall A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Func.equiv A) Func.mul.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold Func.equiv in H.
  unfold Func.equiv in H0.
  unfold Func.equiv.
  intros.
  unfold Func.mul.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_test_eq_equiv: forall A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Sets.equiv A) Func.test_eq.
Proof.
  unfold Proper, respectful.
  unfold Func.equiv, Sets.equiv, Func.test_eq.
  intros A f1 f2 ? g1 g2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_test_le_equiv: forall A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Sets.equiv A) Func.test_le.
Proof.
  unfold Proper, respectful.
  unfold Func.equiv, Sets.equiv, Func.test_le.
  intros A f1 f2 ? g1 g2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Sets_intersect_equiv: forall A,
  Proper (@Sets.equiv A ==> @Sets.equiv A ==> @Sets.equiv A) Sets.intersect.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, Sets.intersect.
  intros A S1 S2 ? T1 T2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Sets_complement_equiv: forall A,
  Proper (@Sets.equiv A ==> @Sets.equiv A) Sets.complement.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, Sets.complement.
  intros A S1 S2 ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Sets_complement_complement: forall A (S: A -> Prop),
  Sets.equiv (Sets.complement (Sets.complement S)) S.
Proof.
  intros.
  unfold Sets.equiv, Sets.complement.
  intros.
  tauto.
Qed.

Existing Instances Func_equiv_refl
                   Func_equiv_sym
                   Func_equiv_trans
                   Func_add_equiv
                   Func_sub_equiv
                   Func_mul_equiv.

Existing Instances Sets_equiv_refl
                   Sets_equiv_sym
                   Sets_equiv_trans
                   Func_test_eq_equiv
                   Func_test_le_equiv
                   Sets_intersect_equiv
                   Sets_complement_equiv.

Fixpoint beval (b : bexp) : state -> Prop :=
  match b with
  | BTrue       => Sets.full
  | BFalse      => Sets.empty
  | BEq a1 a2   => Func.test_eq (aeval a1) (aeval a2)
  | BLe a1 a2   => Func.test_le (aeval a1) (aeval a2)
  | BNot b1     => Sets.complement (beval b1)
  | BAnd b1 b2  => Sets.intersect (beval b1 ) (beval b2)
  end.

Module Relation_Operators.

Definition id {A: Type}: A -> A -> Prop := fun a b => a = b.

Definition empty {A B: Type}: A -> B -> Prop := fun a b => False.

Definition concat {A B C: Type} (r1: A -> B -> Prop) (r2: B -> C -> Prop): A -> C -> Prop :=
  fun a c => exists b, r1 a b /\ r2 b c.

Definition filter1 {A B: Type} (f: A -> Prop): A -> B -> Prop :=
  fun a b => f a.

Definition filter2 {A B: Type} (f: B -> Prop): A -> B -> Prop :=
  fun a b => f b.

Definition union {A B: Type} (r1 r2: A -> B -> Prop): A -> B -> Prop :=
  fun a b => r1 a b \/ r2 a b.

Definition intersection {A B: Type} (r1 r2: A -> B -> Prop): A -> B -> Prop :=
  fun a b => r1 a b /\ r2 a b.

Definition omega_union {A B: Type} (rs: nat -> A -> B -> Prop): A -> B -> Prop :=
  fun st1 st2 => exists n, rs n st1 st2.

Definition test_rel {A} (X: A -> Prop): A -> A -> Prop :=
  fun st1 st2 => st1 = st2 /\ X st1.

End Relation_Operators.

Import Relation_Operators.

Module Rel.

Definition equiv {A B: Type} (r1 r2: A -> B -> Prop): Prop :=
  forall a b, r1 a b <-> r2 a b.

Definition le {A B: Type} (r1 r2: A -> B -> Prop): Prop :=
  forall a b, r1 a b -> r2 a b.

End Rel.

Lemma Rel_equiv_refl: forall A B, Reflexive (@Rel.equiv A B).
Proof.
  unfold Reflexive, Rel.equiv.
  intros.
  reflexivity.
Qed.

Lemma Rel_equiv_sym: forall A B, Symmetric (@Rel.equiv A B).
Proof.
  unfold Symmetric, Rel.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Rel_equiv_trans: forall A B, Transitive (@Rel.equiv A B).
Proof.
  unfold Transitive, Rel.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Rel_equiv_test_rel: forall A,
  Proper (@Sets.equiv A ==> @Rel.equiv A A) test_rel.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, Rel.equiv, test_rel.
  intros A X Y ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Rel_equiv_concat: forall A,
  Proper (@Rel.equiv A A ==> @Rel.equiv A A ==> @Rel.equiv A A) concat.
Proof.
  unfold Proper, respectful.
  unfold Rel.equiv, concat.
  intros A X1 X2 ? Y1 Y2 ?.
  intros a c.
  unfold iff.
  split.
  + intros [b [? ?]].
    exists b.
    rewrite <- H, <- H0.
    tauto.
  + intros [b [? ?]].
    exists b.
    rewrite H, H0.
    tauto.
Qed.

Lemma Rel_equiv_union: forall A,
  Proper (@Rel.equiv A A ==> @Rel.equiv A A ==> @Rel.equiv A A) union.
Proof.
  unfold Proper, respectful.
  unfold Rel.equiv, union.
  intros A X1 X2 ? Y1 Y2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Rel_equiv_omega_union: forall A B (r1 r2: nat -> A -> B -> Prop),
  (forall n, Rel.equiv (r1 n) (r2 n)) ->
  Rel.equiv (omega_union r1) (omega_union r2).
Proof.
  unfold Rel.equiv, omega_union.
  intros.
  unfold iff; split; intros HH;
  destruct HH as [n ?]; exists n.
  + rewrite <- H.
    exact H0.
  + rewrite H.
    exact H0.
Qed.

Lemma Rel_equiv_Rel_le: forall A B (r1 r2: A -> B -> Prop),
  Rel.equiv r1 r2 <-> Rel.le r1 r2 /\ Rel.le r2 r1.
Proof.
  unfold Rel.equiv, Rel.le.
  intros.
  unfold iff at 1.
  split; intros.
  + split; intros ? ?; rewrite H; tauto.
  + destruct H.
    unfold iff; split.
    - apply H.
    - apply H0.
Qed.

Lemma union_comm: forall A B (r1 r2: A -> B -> Prop),
  Rel.equiv (union r1 r2) (union r2 r1).
Proof.
  intros.
  unfold Rel.equiv, union.
  intros.
  tauto.
Qed.

Existing Instances Rel_equiv_refl
                   Rel_equiv_sym
                   Rel_equiv_trans
                   Rel_equiv_test_rel
                   Rel_equiv_concat
                   Rel_equiv_union.

Definition if_sem
  (b: bexp)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  union
    (concat (test_rel (beval b)) then_branch)
    (concat (test_rel (beval (BNot b))) else_branch).

Fixpoint iter_loop_body (b: bexp)
                        (loop_body: state -> state -> Prop)
                        (n: nat): state -> state -> Prop :=
  match n with
  | O =>
         test_rel (beval (BNot b))
  | S n' =>
         concat
           (test_rel (beval b))
           (concat
              loop_body
              (iter_loop_body b loop_body n'))
  end.

Definition loop_sem (b: bexp) (loop_body: state -> state -> Prop):
  state -> state -> Prop :=
  omega_union (iter_loop_body b loop_body).

Fixpoint ceval (c: com): state -> state -> Prop :=
  match c with
  | CSkip => id
  | CAss X E =>
      fun st1 st2 =>
        st2 X = aeval E st1 /\
        forall Y, X <> Y -> st1 Y = st2 Y
  | CSeq c1 c2 => concat (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
  | CWhile b c => loop_sem b (ceval c)
  end.

Lemma ceval_CSkip: ceval CSkip = id.
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CAss: forall X E,
  ceval (CAss X E) =
    fun st1 st2 =>
      st2 X = aeval E st1 /\
        forall Y, X <> Y -> st1 Y = st2 Y.
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CSeq: forall c1 c2,
  ceval (c1 ;; c2) = concat (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CIf: forall b c1 c2,
  ceval (CIf b c1 c2) = if_sem b (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CWhile: forall b c,
  ceval (While b Do c EndWhile) = loop_sem b (ceval c).
Proof. intros. simpl. reflexivity. Qed.

Arguments ceval: simpl never.

Definition aexp_equiv (a1 a2: aexp): Prop :=
  Func.equiv (aeval a1) (aeval a2).

Lemma aexp_equiv_refl: Reflexive aexp_equiv.
Proof.
  unfold Reflexive, aexp_equiv.
  intros.
  reflexivity.
Qed.

Lemma aexp_equiv_sym: Symmetric aexp_equiv.
Proof.
  unfold Symmetric, aexp_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma aexp_equiv_trans: Transitive aexp_equiv.
Proof.
  unfold Transitive, aexp_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma APlus_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) APlus.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma AMinus_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) AMinus.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma AMult_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) AMult.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Existing Instances aexp_equiv_refl
                   aexp_equiv_sym
                   aexp_equiv_trans
                   APlus_congr
                   AMinus_congr
                   AMult_congr.

Definition bexp_equiv (b1 b2: bexp): Prop :=
  Sets.equiv (beval b1) (beval b2).

Lemma bexp_equiv_refl: Reflexive bexp_equiv.
Proof.
  unfold Reflexive, bexp_equiv.
  intros.
  reflexivity.
Qed.

Lemma bexp_equiv_sym: Symmetric bexp_equiv.
Proof.
  unfold Symmetric, bexp_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma bexp_equiv_trans: Transitive bexp_equiv.
Proof.
  unfold Transitive, bexp_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BEq_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> bexp_equiv) BEq.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BLe_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> bexp_equiv) BLe.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BAnd_congr:
  Proper (bexp_equiv ==> bexp_equiv ==> bexp_equiv) BAnd.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BNot_congr: Proper (bexp_equiv ==> bexp_equiv) BNot.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv.
  intros; simpl.
  rewrite H.
  reflexivity.
Qed.

Existing Instances bexp_equiv_refl
                   bexp_equiv_sym
                   bexp_equiv_trans
                   BEq_congr
                   BLe_congr
                   BAnd_congr
                   BNot_congr.

Definition com_equiv (c1 c2: com): Prop :=
  Rel.equiv (ceval c1) (ceval c2).

Lemma com_equiv_refl: Reflexive com_equiv.
Proof.
  unfold Reflexive, com_equiv.
  intros.
  reflexivity.
Qed.

Lemma com_equiv_sym: Symmetric com_equiv.
Proof.
  unfold Symmetric, com_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma com_equiv_trans: Transitive com_equiv.
Proof.
  unfold Transitive, com_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma CAss_congr: forall (X: var),
  Proper (aexp_equiv ==> com_equiv) (CAss X).
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, com_equiv, Rel.equiv.
  intros X E E' ?.
  intros st1 st2.
  rewrite ! ceval_CAss.
  unfold Func.equiv in H.
  specialize (H st1).
  rewrite H.
  reflexivity.
Qed.

Lemma CSeq_congr: Proper (com_equiv ==> com_equiv ==> com_equiv) CSeq.
Proof.
  unfold Proper, respectful.
  unfold com_equiv.
  intros c1 c1' ? c2 c2' ?.
  rewrite ! ceval_CSeq.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma CIf_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv ==> com_equiv) CIf.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv, com_equiv.
  intros b b' ? c1 c1' ? c2 c2' ?.
  rewrite ! ceval_CIf.
  unfold if_sem.
  simpl.
  rewrite H, H0, H1.
  reflexivity.
Qed.

Lemma CWhile_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv) CWhile.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv, com_equiv.
  intros b b' ? c c' ?.
  rewrite ! ceval_CWhile.
  unfold loop_sem.
  apply Rel_equiv_omega_union.
  intros.
  induction n; simpl.
  + rewrite H.
    reflexivity.
  + rewrite IHn, H, H0.
    reflexivity.
Qed.

(* Fri Apr 3 20:44:09 CST 2020 *)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC Basic_Cons.PullBack.
Require Import Coq_Cats.Type_Cat.Type_Cat.

(** Type_Cat has pullbacks. The pullback of two functions f : a → b and g : c → b is
{(x, y) | f x = g y} *)
Section PullBack.
  Context {A B C : Type} (f : A → C) (g : B → C).

  Local Hint Extern 1 =>
  match goal with
    [x : sig _ |- _ ] =>
    let H := fresh "H" in
    destruct x as [x H]
  end.

  Program Definition Type_Cat_PullBack : @PullBack Type_Cat _ _ _ f g :=
    {|
      pullback := {x : A * B| f (fst x) = g (snd x)};
      pullback_morph_1 := fun z => (fst (proj1_sig z));
      pullback_morph_2 := fun z => (snd (proj1_sig z));
      pullback_morph_ex := fun x p1 p2 H x' => (exist _ (p1 x', p2 x') _)
    |}.

  Next Obligation.
  Proof.
    match goal with
      [|- ?A1 (?A2 ?x) = ?B1 (?B2 ?x)] =>
      match goal with
        [H : (fun w => A1 (A2 w)) = (fun w' => B1 (B2 w'))  |- _] =>
        apply (equal_f H)
      end
    end.
  Qed.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros X p1 p2 H u u' H1 H2 H3 H4.
    destruct H3; destruct H4.
    extensionality x.
    set (H1x := equal_f H1 x); clearbody H1x; clear H1.
    set (H2x := equal_f H2 x); clearbody H2x; clear H2.
    cbn in *.
    match goal with
      [|- ?A = ?B] => destruct A as [[a1 a2] Ha]; destruct B as [[b1 b2] Hb]
    end.
    cbn in *.
    apply sig_proof_irrelevance; cbn.
    rewrite H1x; rewrite H2x; trivial.
  Qed.

End PullBack.

Instance Type_Cat_Has_PullBacks : Has_PullBacks Type_Cat := fun a b c f g => Type_Cat_PullBack f g.


(* -nois for clean state *)
Inductive nat :=
| O : nat
| S : forall _ : nat, nat
.
Print Libraries.
Fail Check 2. (* No interpretation for numeral 2. *)

Goal 2+(1+1)=4.
auto.

Require Import ZArith.
Require Ring.

Local Open Scope Z_scope.

Lemma toto1 : 1 + 1 = 2.
ring.
Defined.

Lemma toto2 : 2 + 2 = 4.
ring.
Qed.

Lemma toto3 : 2 + 1 = 3.
ring.
Qed.

Hint Resolve  toto2 toto3 : mybase.
Goal 2+(1+1)=4.
auto with mybase.
Show Proof.
No more subgoals.

Unnamed_thm < Qed.
Unnamed_thm is defined


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

(*i $Id: Rfunctions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(*i Some properties about pow and sum have been made with John Harrison i*)
(*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)

(********************************************************)
(**          Definition of the sum functions            *)
(*                                                      *)
(********************************************************)
Require Export ArithRing.

Require Import Rbase.
Require Export Rpow_def.
Require Export R_Ifp.
Require Export Rbasic_fun.
Require Export R_sqr.
Require Export SplitAbsolu.
Require Export SplitRmult.
Require Export ArithProp.
Require Import Omega.
Require Import Zpower.
Open Local Scope nat_scope.
Open Local Scope R_scope.

(*******************************)
(** * Lemmas about factorial   *)
(*******************************)
(*********)
Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0.
Proof.
  intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
    assumption.
Qed.

(*********)
Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat.
Proof.
  intro; reflexivity.
Qed.

(*********)
Lemma simpl_fact :
  forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
Proof.
  intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n));
    unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *;
      rewrite (mult_INR (S n) (fact n));
        rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))).
  rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n)));
    rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n));
      apply (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1).
  apply not_O_INR; auto.
  apply INR_fact_neq_0.
Qed.

(*******************************)
(** *       Power              *)
(*******************************)
(*********)

Infix "^" := pow : R_scope.

Lemma pow_O : forall x:R, x ^ 0 = 1.
Proof.
  reflexivity.
Qed.

Lemma pow_1 : forall x:R, x ^ 1 = x.
Proof.
  simpl in |- *; auto with real.
Qed.

Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m.
Proof.
  intros x n; elim n; simpl in |- *; auto with real.
  intros n0 H' m; rewrite H'; auto with real.
Qed.

Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0.
Proof.
  intro; simple induction n; simpl in |- *.
  intro; red in |- *; intro; apply R1_neq_R0; assumption.
  intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1).
  intro; auto.
  apply H; assumption.
Qed.

Hint Resolve pow_O pow_1 pow_add pow_nonzero: real.

Lemma pow_RN_plus :
  forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m.
Proof.
  intros x n; elim n; simpl in |- *; auto with real.
  intros n0 H' m H'0.
  rewrite Rmult_assoc; rewrite <- H'; auto.
Qed.

Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n.
Proof.
  intros x n; elim n; simpl in |- *; auto with real.
  intros n0 H' H'0; replace 0 with (x * 0); auto with real.
Qed.
Hint Resolve pow_lt: real.

Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n.
Proof.
  intros x n; elim n; simpl in |- *; auto with real.
  intros H' H'0; exfalso; omega.
  intros n0; case n0.
  simpl in |- *; rewrite Rmult_1_r; auto.
  intros n1 H' H'0 H'1.
  replace 1 with (1 * 1); auto with real.
  apply Rlt_trans with (r2 := x * 1); auto with real.
  apply Rmult_lt_compat_l; auto with real.
  apply Rlt_trans with (r2 := 1); auto with real.
  apply H'; auto with arith.
Qed.
Hint Resolve Rlt_pow_R1: real.

Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m.
Proof.
  intros x n m H' H'0; replace m with (m - n + n)%nat.
  rewrite pow_add.
  pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n);
    auto with real.
  apply Rminus_lt.
  repeat rewrite (fun y:R => Rmult_comm y (x ^ n));
    rewrite <- Rmult_minus_distr_l.
  replace 0 with (x ^ n * 0); auto with real.
  apply Rmult_lt_compat_l; auto with real.
  apply pow_lt; auto with real.
  apply Rlt_trans with (r2 := 1); auto with real.
  apply Rlt_minus; auto with real.
  apply Rlt_pow_R1; auto with arith.
  apply plus_lt_reg_l with (p := n); auto with arith.
  rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto.
  rewrite plus_comm; auto with arith.
Qed.
Hint Resolve Rlt_pow: real.

(*********)
Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n.
Proof.
  simple induction n; simpl in |- *; trivial.
Qed.

(*********)
Lemma tech_pow_Rplus :
  forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
Proof.
  intros; pattern (x ^ a) at 1 in |- *;
    rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1);
      rewrite (Rmult_comm (INR n) (x ^ a));
        rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n));
          rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n);
            apply Rmult_comm.
Qed.

Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n.
Proof.
  intros; elim n.
  simpl in |- *; cut (1 + 0 * x = 1).
  intro; rewrite H0; unfold Rle in |- *; right; reflexivity.
  ring.
  intros; unfold pow in |- *; fold pow in |- *;
    apply
      (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x))
        ((1 + x) * (1 + x) ^ n0)).
  cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)).
  intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *;
    rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1);
      apply Rplus_le_compat_l; elim n0; intros.
  simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto.
  unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *;
    intro; fold (Rsqr x) in |- *;
      apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1)));
        fold (x > 0) in H;
          apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))).
  rewrite (S_INR n0); ring.
  unfold Rle in H0; elim H0; intro.
  unfold Rle in |- *; left; apply Rmult_lt_compat_l.
  rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
  assumption.
  rewrite H1; unfold Rle in |- *; right; trivial.
Qed.

Lemma Power_monotonic :
  forall (x:R) (m n:nat),
    Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
Proof.
  intros x m n H; induction  n as [| n Hrecn]; intros; inversion H0.
  unfold Rle in |- *; right; reflexivity.
  unfold Rle in |- *; right; reflexivity.
  apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))).
  apply Hrecn; assumption.
  simpl in |- *; rewrite Rabs_mult.
  pattern (Rabs (x ^ n)) at 1 in |- *.
  rewrite <- Rmult_1_r.
  rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))).
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  unfold Rgt in H.
  apply Rlt_le; assumption.
Qed.

Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
Proof.
  intro; simple induction n; simpl in |- *.
  apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
  intros; rewrite H; apply sym_eq; apply Rabs_mult.
Qed.

Lemma Pow_x_infinity :
  forall x:R,
    Rabs x > 1 ->
    forall b:R,
      exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) >= b).
Proof.
  intros; elim (archimed (b * / (Rabs x - 1))); intros; clear H1;
    cut (exists N : nat, INR N >= b * / (Rabs x - 1)).
  intro; elim H1; clear H1; intros; exists x0; intros;
    apply (Rge_trans (Rabs (x ^ n)) (Rabs (x ^ x0)) b).
  apply Rle_ge; apply Power_monotonic; assumption.
  rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)).
  intro; rewrite H3;
    apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b).
  apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus;
    assumption.
  apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b).
  apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1)));
    pattern (INR x0 * (Rabs x - 1)) at 1 in |- *;
      rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1);
        apply Rplus_lt_compat_l; apply Rlt_0_1.
  cut (b = b * / (Rabs x - 1) * (Rabs x - 1)).
  intros; rewrite H4; apply Rmult_ge_compat_r.
  apply Rge_minus; unfold Rge in |- *; left; assumption.
  assumption.
  rewrite Rmult_assoc; rewrite Rinv_l.
  ring.
  apply Rlt_dichotomy_converse; right; apply Rgt_minus; assumption.
  ring.
  cut ((0 <= up (b * / (Rabs x - 1)))%Z \/ (up (b * / (Rabs x - 1)) <= 0)%Z).
  intros; elim H1; intro.
  elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0;
    apply
      (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
  rewrite INR_IZR_INZ; apply IZR_ge; omega.
  unfold Rge in |- *; left; assumption.
  exists 0%nat;
    apply
      (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
  rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega.
  unfold Rge in |- *; left; assumption.
  omega.
Qed.

Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0.
Proof.
  simple induction n.
  simpl in |- *; auto.
  intros; elim H; reflexivity.
  intros; simpl in |- *; apply Rmult_0_l.
Qed.

Lemma Rinv_pow : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n.
Proof.
  intros; elim n; simpl in |- *.
  apply Rinv_1.
  intro m; intro; rewrite Rinv_mult_distr.
  rewrite H0; reflexivity; assumption.
  assumption.
  apply pow_nonzero; assumption.
Qed.

Lemma pow_lt_1_zero :
  forall x:R,
    Rabs x < 1 ->
    forall y:R,
      0 < y ->
      exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y).
Proof.
  intros; elim (Req_dec x 0); intro.
  exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero.
  rewrite Rabs_R0; assumption.
  inversion GE; auto.
  cut (Rabs (/ x) > 1).
  intros; elim (Pow_x_infinity (/ x) H2 (/ y + 1)); intros N.
  exists N; intros; rewrite <- (Rinv_involutive y).
  rewrite <- (Rinv_involutive (Rabs (x ^ n))).
  apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat.
  assumption.
  apply Rinv_0_lt_compat.
  apply Rabs_pos_lt.
  apply pow_nonzero.
  assumption.
  rewrite <- Rabs_Rinv.
  rewrite Rinv_pow.
  apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))).
  pattern (/ y) at 1 in |- *.
  rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1).
  apply Rplus_lt_compat_l.
  apply Rlt_0_1.
  apply Rge_le.
  apply H3.
  assumption.
  assumption.
  apply pow_nonzero.
  assumption.
  apply Rabs_no_R0.
  apply pow_nonzero.
  assumption.
  apply Rlt_dichotomy_converse.
  right; unfold Rgt in |- *; assumption.
  rewrite <- (Rinv_involutive 1).
  rewrite Rabs_Rinv.
  unfold Rgt in |- *; apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat.
  apply Rabs_pos_lt.
  assumption.
  rewrite Rinv_1; apply Rlt_0_1.
  rewrite Rinv_1; assumption.
  assumption.
  red in |- *; intro; apply R1_neq_R0; assumption.
Qed.

Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat.
Proof.
  intros r n H'.
  case (Req_dec (Rabs r) 1); auto; intros H'1.
  case (Rdichotomy _ _ H'1); intros H'2.
  generalize H'; case n; auto.
  intros n0 H'0.
  cut (r <> 0); [ intros Eq1 | idtac ].
  cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
  absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto.
  replace (Rabs (/ r) ^ S n0) with 1.
  simpl in |- *; apply Rlt_irrefl; auto.
  rewrite Rabs_Rinv; auto.
  rewrite <- Rinv_pow; auto.
  rewrite RPow_abs; auto.
  rewrite H'0; rewrite Rabs_right; auto with real rorders.
  apply Rlt_pow; auto with arith.
  rewrite Rabs_Rinv; auto.
  apply Rmult_lt_reg_l with (r := Rabs r).
  case (Rabs_pos r); auto.
  intros H'3; case Eq2; auto.
  rewrite Rmult_1_r; rewrite Rinv_r; auto with real.
  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
  generalize H'; case n; auto.
  intros n0 H'0.
  cut (r <> 0); [ intros Eq1 | auto with real ].
  cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
  absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith.
  repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real.
  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
Qed.

Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n.
Proof.
  intros; induction  n as [| n Hrecn].
  reflexivity.
  replace (2 * S n)%nat with (S (S (2 * n))).
  replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)).
  rewrite Hrecn; reflexivity.
  simpl in |- *; ring.
  ring.
Qed.

Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n.
Proof.
  intros; induction  n as [| n Hrecn].
  simpl in |- *; left; apply Rlt_0_1.
  simpl in |- *; apply Rmult_le_pos; assumption.
Qed.

(**********)
Lemma pow_1_even : forall n:nat, (-1) ^ (2 * n) = 1.
Proof.
  intro; induction  n as [| n Hrecn].
  reflexivity.
  replace (2 * S n)%nat with (2 + 2 * n)%nat by ring.
  rewrite pow_add; rewrite Hrecn; simpl in |- *; ring.
Qed.

(**********)
Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1.
Proof.
  intro; replace (S (2 * n)) with (2 * n + 1)%nat by ring.
  rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring.
Qed.

(**********)
Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1.
Proof.
  intro; induction  n as [| n Hrecn].
  simpl in |- *; apply Rabs_R1.
  replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
  rewrite Rabs_mult.
  rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r;
    rewrite Rabs_Ropp; apply Rabs_R1.
Qed.

Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
Proof.
  intros; induction  n2 as [| n2 Hrecn2].
  simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
  replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat.
  replace (S n2) with (n2 + 1)%nat by ring.
  do 2 rewrite pow_add.
  rewrite Hrecn2.
  simpl in |- *.
  ring.
  ring.
Qed.

Lemma pow_incr : forall (x y:R) (n:nat), 0 <= x <= y -> x ^ n <= y ^ n.
Proof.
  intros.
  induction  n as [| n Hrecn].
  right; reflexivity.
  simpl in |- *.
  elim H; intros.
  apply Rle_trans with (y * x ^ n).
  do 2 rewrite <- (Rmult_comm (x ^ n)).
  apply Rmult_le_compat_l.
  apply pow_le; assumption.
  assumption.
  apply Rmult_le_compat_l.
  apply Rle_trans with x; assumption.
  apply Hrecn.
Qed.

Lemma pow_R1_Rle : forall (x:R) (k:nat), 1 <= x -> 1 <= x ^ k.
Proof.
  intros.
  induction  k as [| k Hreck].
  right; reflexivity.
  simpl in |- *.
  apply Rle_trans with (x * 1).
  rewrite Rmult_1_r; assumption.
  apply Rmult_le_compat_l.
  left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
  exact Hreck.
Qed.

Lemma Rle_pow :
  forall (x:R) (m n:nat), 1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n.
Proof.
  intros.
  replace n with (n - m + m)%nat.
  rewrite pow_add.
  rewrite Rmult_comm.
  pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r.
  apply Rmult_le_compat_l.
  apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
  apply pow_R1_Rle; assumption.
  rewrite plus_comm.
  symmetry  in |- *; apply le_plus_minus; assumption.
Qed.

Lemma pow1 : forall n:nat, 1 ^ n = 1.
Proof.
  intro; induction  n as [| n Hrecn].
  reflexivity.
  simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
Qed.

Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
Proof.
  intros; induction  n as [| n Hrecn].
  right; reflexivity.
  simpl in |- *; case (Rcase_abs x); intro.
  apply Rle_trans with (Rabs (x * x ^ n)).
  apply RRle_abs.
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  right; symmetry  in |- *; apply RPow_abs.
  pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r);
    apply Rmult_le_compat_l.
  apply Rge_le; exact r.
  apply Hrecn.
Qed.

Lemma pow_maj_Rabs : forall (x y:R) (n:nat), Rabs y <= x -> y ^ n <= x ^ n.
Proof.
  intros; cut (0 <= x).
  intro; apply Rle_trans with (Rabs y ^ n).
  apply pow_Rabs.
  induction  n as [| n Hrecn].
  right; reflexivity.
  simpl in |- *; apply Rle_trans with (x * Rabs y ^ n).
  do 2 rewrite <- (Rmult_comm (Rabs y ^ n)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  assumption.
  apply Rmult_le_compat_l.
  apply H0.
  apply Hrecn.
  apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ].
Qed.

(*******************************)
(** *       PowerRZ            *)
(*******************************)
(*i Due to L.Thery i*)

Ltac case_eq name :=
  generalize (refl_equal name); pattern name at -1 in |- *; case name.

Definition powerRZ (x:R) (n:Z) :=
  match n with
    | Z0 => 1
    | Zpos p => x ^ nat_of_P p
    | Zneg p => / x ^ nat_of_P p
  end.

Infix Local "^Z" := powerRZ (at level 30, right associativity) : R_scope.

Lemma Zpower_NR0 :
  forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
Proof.
  induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
Qed.

Lemma powerRZ_O : forall x:R, x ^Z 0 = 1.
Proof.
  reflexivity.
Qed.

Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
Proof.
  simpl in |- *; auto with real.
Qed.

Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0.
Proof.
  destruct z; simpl in |- *; auto with real.
Qed.

Lemma powerRZ_add :
  forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
Proof.
  intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *;
    auto with real.
(* POS/POS *)
  rewrite nat_of_P_plus_morphism; auto with real.
(* POS/NEG *)
  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
    auto with real.
  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
  rewrite Rinv_mult_distr; auto with real.
  rewrite Rinv_involutive; auto with real.
  apply lt_le_weak.
  apply nat_of_P_lt_Lt_compare_morphism; auto.
  apply ZC2; auto.
  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
    auto with real.
  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
  apply lt_le_weak.
  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
  apply nat_of_P_gt_Gt_compare_morphism; auto.
(* NEG/POS *)
  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
    auto with real.
  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
  apply lt_le_weak.
  apply nat_of_P_lt_Lt_compare_morphism; auto.
  apply ZC2; auto.
  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
    auto with real.
  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
  rewrite Rinv_mult_distr; auto with real.
  apply lt_le_weak.
  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
  apply nat_of_P_gt_Gt_compare_morphism; auto.
(* NEG/NEG *)
  rewrite nat_of_P_plus_morphism; auto with real.
  intros H'; rewrite pow_add; auto with real.
  apply Rinv_mult_distr; auto.
  apply pow_nonzero; auto.
  apply pow_nonzero; auto.
Qed.
Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real.

Lemma Zpower_nat_powerRZ :
  forall n m:nat, IZR (Zpower_nat (Z_of_nat n) m) = INR n ^Z Z_of_nat m.
Proof.
  intros n m; elim m; simpl in |- *; auto with real.
  intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *.
  replace (Zpower_nat (Z_of_nat n) (S m1)) with
  (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
  rewrite mult_IZR; auto with real.
  repeat rewrite <- INR_IZR_INZ; simpl in |- *.
  rewrite H'; simpl in |- *.
  case m1; simpl in |- *; auto with real.
  intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto.
  unfold Zpower_nat in |- *; auto.
Qed.

Lemma Zpower_pos_powerRZ :
  forall n m, IZR (Zpower_pos n m) = IZR n ^Z Zpos m.
Proof.
  intros.
  rewrite Zpower_pos_nat; simpl.
  induction (nat_of_P m).
  easy.
  unfold Zpower_nat; simpl.
  rewrite mult_IZR.
  now rewrite <- IHn0.
Qed.

Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z.
Proof.
  intros x z; case z; simpl in |- *; auto with real.
Qed.
Hint Resolve powerRZ_lt: real.

Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z.
Proof.
  intros x z H'; apply Rlt_le; auto with real.
Qed.
Hint Resolve powerRZ_le: real.

Lemma Zpower_nat_powerRZ_absolu :
  forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m.
Proof.
  intros n m; case m; simpl in |- *; auto with zarith.
  intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith.
  intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith.
  rewrite <- mult_IZR; auto.
  intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
Qed.

Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1.
Proof.
  intros n; case n; simpl in |- *; auto.
  intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H';
    ring.
  intros p; elim (nat_of_P p); simpl in |- *.
  exact Rinv_1.
  intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
    auto with real.
Qed.

(*******************************)
(* For easy interface          *)
(*******************************)
(* decimal_exp r z is defined as r 10^z *)

Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z).

(*******************************)
(** * Sum of n first naturals  *)
(*******************************)
(*********)
Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat :=
  match n with
    | O => f 0%nat
    | S n' => (sum_nat_f_O f n' + f (S n'))%nat
  end.

(*********)
Definition sum_nat_f (s n:nat) (f:nat -> nat) : nat :=
  sum_nat_f_O (fun x:nat => f (x + s)%nat) (n - s).

(*********)
Definition sum_nat_O (n:nat) : nat := sum_nat_f_O (fun x:nat => x) n.

(*********)
Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x).

(*******************************)
(** *          Sum             *)
(*******************************)
(*********)
Fixpoint sum_f_R0 (f:nat -> R) (N:nat) : R :=
  match N with
    | O => f 0%nat
    | S i => sum_f_R0 f i + f (S i)
  end.

(*********)
Definition sum_f (s n:nat) (f:nat -> R) : R :=
  sum_f_R0 (fun x:nat => f (x + s)%nat) (n - s).

Lemma GP_finite :
  forall (x:R) (n:nat),
    sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1.
Proof.
  intros; induction  n as [| n Hrecn]; simpl in |- *.
  ring.
  rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
  intro H; rewrite H; simpl in |- *; ring.
  omega.
Qed.

Lemma sum_f_R0_triangle :
  forall (x:nat -> R) (n:nat),
    Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n.
Proof.
  intro; simple induction n; simpl in |- *.
  unfold Rle in |- *; right; reflexivity.
  intro m; intro;
    apply
      (Rle_trans (Rabs (sum_f_R0 x m + x (S m)))
        (Rabs (sum_f_R0 x m) + Rabs (x (S m)))
        (sum_f_R0 (fun i:nat => Rabs (x i)) m + Rabs (x (S m)))).
  apply Rabs_triang.
  rewrite Rplus_comm;
    rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (x i)) m) (Rabs (x (S m))));
      apply Rplus_le_compat_l; assumption.
Qed.

(*******************************)
(** *     Distance  in R       *)
(*******************************)

(*********)
Definition R_dist (x y:R) : R := Rabs (x - y).

(*********)
Lemma R_dist_pos : forall x y:R, R_dist x y >= 0.
Proof.
  intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y));
    intro l.
  unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
  trivial.
Qed.

(*********)
Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
Proof.
  unfold R_dist in |- *; intros; split_Rabs; try ring.
  generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
    rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
      intro; unfold Rgt in H; exfalso; auto.
  generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
    generalize (Rge_antisym x y H0 H); intro; rewrite H1;
      ring.
Qed.

(*********)
Lemma R_dist_refl : forall x y:R, R_dist x y = 0 <-> x = y.
Proof.
  unfold R_dist in |- *; intros; split_Rabs; split; intros.
  rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
    apply (Rminus_diag_uniq y x H).
  rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
    apply (Rminus_diag_eq y x H0).
  apply (Rminus_diag_uniq x y H).
  apply (Rminus_diag_eq x y H).
Qed.

Lemma R_dist_eq : forall x:R, R_dist x x = 0.
Proof.
  unfold R_dist in |- *; intros; split_Rabs; intros; ring.
Qed.

(***********)
Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y.
Proof.
  intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y));
    [ apply (Rabs_triang (x - z) (z - y)) | ring ].
Qed.

(*********)
Lemma R_dist_plus :
  forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
Proof.
  intros; unfold R_dist in |- *;
    replace (a + c - (b + d)) with (a - b + (c - d)).
  exact (Rabs_triang (a - b) (c - d)).
  ring.
Qed.

(*******************************)
(** *     Infinite Sum          *)
(*******************************)
(*********)
Definition infinite_sum (s:nat -> R) (l:R) : Prop :=
  forall eps:R,
    eps > 0 ->
    exists N : nat,
      (forall n:nat, (n >= N)%nat -> R_dist (sum_f_R0 s n) l < eps).

(** Compatibility with previous versions *)
Notation infinit_sum := infinite_sum (only parsing).


(* A typeclass for types that are inhabited *)

Class Inhabited (A : Type) : Prop :=
  {
    inhabitant : A
  }.

(* Inhabited provides a witness that can only be
   used when proving something in Prop -- it does
   not have computational content.
   StronglyInhabited provides a witness that can
   be used computationally.
*)

Class StronglyInhabited (A : Type) :=
  {
    strong_inhabitant : A
  }.

Instance StronglyInhabitedIsInhabited (A : Type) `{StronglyInhabited A} :
  Inhabited A :=
   {| inhabitant := strong_inhabitant |}.

(* Setof *)

Require Import SetoidClass Views.Setof.

(* Sets over any type are (strongly) inhabited
   by the empty set. *)
Section SetofInhabited.
  Context A `{A_Setoid : Setoid A}.

  Instance Setof_StronglyInhabited :
      StronglyInhabited (Setof A) :=
   {| strong_inhabitant := mkSetof (fun a => False) |}.
End SetofInhabited.
Existing Instance Setof_StronglyInhabited.

(* Equivalence classes *)
Require Import Views.EquivalenceClasses.

(* Equivalence classes on an inhabited type
   are inhabited. *)

Section ECInhabited.
  Context A `{A_Setoid : Setoid A}.
  Context `{A_Inhabited : Inhabited A}.

  (* The inhabitant of EC A is the equivalence
     class of the inhabitant of A. *)
  Instance EC_Inhabited :
     Inhabited (EC A).
   destruct A_Inhabited.
   constructor.
   apply make_EC; trivial.
  Qed.
End ECInhabited.
Existing Instance EC_Inhabited.

(* Equivalence classes on an strongly inhabited type
   are strongly inhabited. *)
Section ECStronglyInhabited.
  Context A `{A_Setoid : Setoid A}.
  Context `{A_SInhabited : StronglyInhabited A}.

  Instance EC_StronglyInhabited :
     StronglyInhabited (EC A) :=
        {| strong_inhabitant := make_EC strong_inhabitant |}.
End ECStronglyInhabited.
Existing Instance EC_StronglyInhabited.


(*******************************************)
(*                                         *)
(*          slr_seq_spe_nash.v             *)
(*                                         *)
(*           Stéphane Le Roux              *)
(*                                         *)
(*     LIP (ENS Lyon, CNRS, INRIA)         *)
(*                                         *)
(*             Coq v8.1                    *)
(*                                         *)
(*              2007/04                    *)
(*                                         *)
(*******************************************)

Require Import List.
Require Import Relations.
Require Import Peano_dec.
Require Import Lia.

Require Import slr_topo_sorting.

Set Implicit Arguments.

(* ============== *)
(* === Preliminaries === *)
(* ============== *)

Section Preliminaries.

Variable A : Type.

Lemma map_inverse : forall (B : Type)(f : A -> B) g,
(forall x, g (f x)=x) -> forall l, map g (map f l)=l.
Proof.
induction l; simpl; intros. trivial. rewrite (H a). rewrite IHl. trivial.
Qed.

Lemma map_app : forall (B : Type)l l' (f : A -> B), map f (l++l') = (map f l)++(map f l').
Proof.
induction l; simpl; trivial. intros. rewrite (IHl l'). trivial.
Qed.

Lemma sub_rel_restriction_incl : forall (B : Type)(l l' : list B) R,
incl l l' -> sub_rel (restriction R l) (restriction R l').
Proof.
unfold incl, sub_rel, restriction. intros. split. apply H. tauto. split. apply H. tauto. tauto.
Qed.

Section listforall.

Variable Q : A -> Prop.

Fixpoint listforall (l : list A) : Prop :=
match l with
| nil => True
| x::l' => Q x /\ listforall l'
end.

Lemma listforall_app :  forall l' l, listforall l -> listforall l' -> listforall (l++l').
Proof.
induction l; simpl; intros; tauto.
Qed.

Lemma listforall_appl :  forall l' l, listforall (l++l') -> listforall l.
Proof.
induction l; simpl; intros; tauto.
Qed.

Lemma listforall_appr :  forall l' l, listforall (l++l') -> listforall l'.
Proof.
induction l; simpl; intros; tauto.
Qed.

Lemma listforall_In : forall x l, In x l -> listforall l -> Q x.
Proof.
induction l; simpl; intros. tauto. destruct H. rewrite H in H0. tauto. tauto.
Qed.

End listforall.

Variable P : A -> A -> Prop.

Fixpoint rel_vector (l l' : list A) {struct l}: Prop :=
match l with
| nil => l'=nil
| x::l2 => match l' with
               | nil => False
               | x'::l2' => P x x' /\ rel_vector l2 l2'
               end
end.

Lemma rel_vector_app_cons_same_length : forall a a' m m' l l',
rel_vector (l++a::m) (l'++a'::m') -> length l=length l' -> P a a'.
Proof.
induction l; simpl; intros; destruct l'; simpl in H; simpl in H0. tauto. pose  (O_S (length l') H0).
contradiction. pose  (O_S (length l) (sym_equal H0)). contradiction.
apply IHl with l'. tauto. lia.
Qed.

Lemma rel_vector_app_cons_exists : forall a q l m,
rel_vector l (m++a::q) -> {x : A | In x l /\ P x a}.
Proof.
induction l; simpl; intros. destruct m; simpl in H; inversion H.
destruct m; simpl in H. exists a0. tauto. destruct (IHl m). tauto.
exists x. tauto.
Qed.

Lemma rel_vector_app_cons_different_length : forall l a m l' a' m',
rel_vector (l++a::m) (l'++a'::m') -> length l<>length l' ->  {x : A | (In x l \/ In x m) /\ P x a'}.
Proof.
induction l; simpl; intros. destruct l'; simpl in H0. tauto. simpl in H. destruct H.
destruct (rel_vector_app_cons_exists a' m' m l' H1). exists x. tauto. destruct l'; simpl in H.
exists a. tauto. destruct (IHl a0 m l' a' m'). tauto. simpl in H0. lia. exists x. tauto.
Qed.

Definition is_no_succ (x : A)(l : list A) := listforall (fun y => ~P x y) l.

Lemma is_no_succ_trans : forall x y l, transitive A P -> P x y -> is_no_succ x l -> is_no_succ y l.
Proof.
induction l; simpl; intros. tauto. split. intro. absurd (P x a). tauto. apply H with y; assumption. tauto.
Qed.

Lemma is_no_succ_dec :  rel_dec P -> forall x l, {is_no_succ x l}+{~is_no_succ x l}.
Proof.
induction l; simpl; intros. tauto. destruct (X x a); tauto.
Qed.

(* Choice function proved together with its properties, by induction *)
Lemma Choose_and_split : rel_dec P -> forall (l : list A)(x : A),
{triple : list A * A * list A | let (double,right):=triple in let (left,choice):=double in
 x::l=(left++(choice::right)) /\ is_no_succ choice right /\
 (forall left' choice' right', left=left'++(choice'::right') ->
 ~is_no_succ choice' (right'++(choice::right))) /\
(irreflexive P -> transitive A P -> is_no_succ choice left)}.
Proof.
induction l; intros.
(* nil case *)
exists ((nil : list A, x), (nil : list A)). simpl. repeat (split; trivial).
intros. destruct (app_eq_nil left' (choice'::right')(sym_equal H)). inversion H1.
(* cons case *)
destruct (is_no_succ_dec X x (a::l)).
(**)
exists ((nil : list A,x),a::l). repeat (split; trivial).
intros. destruct (app_eq_nil left' (choice'::right')(sym_equal H)). inversion H1.
(**)
destruct (IHl a). destruct x0. destruct p. decompose [and] y. clear y.
exists ((x::l1,a0),l0). split. rewrite H. rewrite (app_comm_cons l1 (a0::l0) x). trivial.
split. assumption. split. intros. destruct left'. simpl in H2. inversion H2.
rewrite <- H5. rewrite <- H6. rewrite <- H. assumption.
rewrite <- (app_comm_cons left' (choice'::right') a1) in H2. inversion H2. apply H0 with left'.
assumption. intros. simpl. split. intro. absurd (is_no_succ x (a::l)). assumption.
rewrite H. apply is_no_succ_trans with a0. assumption. assumption. unfold is_no_succ.
apply listforall_app. tauto. split. apply H2. assumption. tauto.
Qed.

End Preliminaries.

(* ============== *)
(* === Game Theory === *)
(* ============== *)

Section GameTheory.

(*  Outcome is a set of "end-of-the-game situations" *)
Variable Outcome : Type.
(* Agent is some set of "players" *)
Variable Agent : Type.

(* ============= *)
(* === Games === *)
(* ============= *)

(* A game *)
Inductive Game : Type :=
  | gL : Outcome -> Game
  | gN : Agent -> Game -> list Game -> Game.

(* Define an induction principle for Game *)
Section correct_Game_ind.

Variables
(P : Game -> Prop)
(Q : Game -> list Game -> Prop).

Hypotheses
(H : forall oc, P (gL oc))
(H0 : forall g, P g -> Q g nil)
(H1 : forall g , P g -> forall g' l, Q g' l -> Q g' (g::l))
(H2 : forall g l, Q g l -> forall a, P (gN a g l)).

Fixpoint Game_ind2 (g : Game) : P g :=
match g as x return P x  with
| gL oc => H oc
| gN a g' l => H2
                           ((fix G_ind2 (l' : list Game){struct l'} : Q g' l' :=
                           match l' as x return Q g' x with
                           | nil => H0 (Game_ind2 g')
                           | g3::l'' => H1 (Game_ind2 g3) (G_ind2 l'')
                           end )
                            l) a
end.

End correct_Game_ind.

(* The outcomes used to build a game *)
Fixpoint UsedOutcomes (g : Game) : list Outcome :=
match g with
| gL oc => oc::nil
| gN _ g' l =>  ((fix ListUsedOutcomes  (l' : list Game) : list Outcome :=
                         match l' with
                         | nil => nil
                         | x::m => (UsedOutcomes x)++(ListUsedOutcomes m)
                         end) (g'::l))
end.

Lemma UsedOutcomes_gN : forall a g g' l,
In g (g'::l) -> incl (UsedOutcomes g) (UsedOutcomes (gN a g' l)).
Proof.
induction l; simpl; intros. destruct H. rewrite H. rewrite <- (app_nil_end (UsedOutcomes g)).
apply incl_refl. contradiction. assert (a0=g \/ g'=g \/ In g l). tauto.
destruct H0. rewrite H0. apply incl_appr. apply incl_appl. apply incl_refl. unfold incl in *|-* .
intros. simpl in IHl. destruct (in_app_or  (UsedOutcomes g')
((fix f (l' : list Game) : list Outcome := match l' with | nil => nil (A:=Outcome) | x :: m =>
UsedOutcomes x ++ f m end) l) a1). apply IHl. assumption. assumption.
apply in_or_app. tauto. apply in_or_app. constructor 2. apply  in_or_app. tauto.
Qed.

Lemma UsedOutcomes_gN_listforall : forall a g loc l,
incl (UsedOutcomes (gN a g l)) loc -> listforall (fun g' : Game => incl (UsedOutcomes g') loc) (g::l).
Proof.
unfold incl. split. intros. apply H. simpl. apply in_or_app. tauto. induction l; simpl; intros. trivial.
split. intros. apply H. simpl. apply in_or_app. constructor 2. apply in_or_app. tauto. apply IHl.
intros. apply H. simpl in H0. destruct ((in_app_or (UsedOutcomes g)
((fix f (l' : list Game) : list Outcome := match l' with | nil => nil (A:=Outcome) |
 x :: m => UsedOutcomes x ++ f m end) l)) a1). assumption. simpl. apply in_or_app. tauto.
simpl. apply in_or_app. constructor 2. apply in_or_app. tauto.
Qed.

(* ============ *)
(* === Strategies === *)
(* ============ *)

(* A strategy *)
Inductive Strat : Type :=
  | sL : Outcome -> Strat
  | sN : Agent -> list Strat -> Strat -> list Strat -> Strat.

(* Define an induction principle for Strat *)
Section correct_Strat_ind.

Variables
(P : Strat -> Prop)
(Q : list Strat -> Strat -> list Strat -> Prop).

Hypotheses
(H : forall oc, P (sL oc))
(H0 : forall sc, P sc -> Q nil sc nil)
(H1nil : forall s , P s -> forall sc sr, Q nil sc sr -> Q nil sc (s::sr))
(H1 : forall s , P s -> forall sc sl sr, Q sl sc sr -> Q (s::sl) sc sr)
(H2 : forall sc sl sr, Q sl sc sr -> forall a, P (sN a sl sc sr)).

Fixpoint Strat_ind2 (s : Strat) : P s :=
match s as x return P x  with
| sL oc => H oc
| sN a sl sc sr => H2
                           ((fix S_ind2 (sl' : list Strat){struct sl'} : Q sl' sc sr :=
                           match sl' as x return Q x sc sr with
                           | nil =>  (fix Snil_ind2 (sr' : list Strat) : Q nil sc sr' :=
                                         match sr' as x return Q nil sc x with
                                         | nil => H0 (Strat_ind2 sc)
                                         | s'::sr'' => H1nil (Strat_ind2 s')(Snil_ind2 sr'')
                                         end) sr
                           | s'::sl'' => H1 (Strat_ind2 s') (S_ind2 sl'')
                           end ) sl) a
end.

End correct_Strat_ind.

(* The game corresponding to a strategy *)
Fixpoint s2g (s : Strat) : Game :=
match s with
| sL oc => gL oc
| sN a sl sc sr =>  match sl with
                             | nil => gN a (s2g sc) (map s2g sr)
                             | s'::sl' => gN a (s2g s') ((map s2g sl')++(s2g sc)::(map s2g sr))
                             end
end.

Lemma map_s2g_sN_s2g : forall a sl sc sr sl' sc' sr',
map s2g (sl ++ sc :: sr) = map s2g (sl' ++ sc' :: sr') ->
s2g (sN a sl sc sr) = s2g (sN a sl' sc' sr').
Proof.
intros. destruct sl; destruct sl'; simpl in H|-* ; inversion H. trivial.
rewrite H2. rewrite (map_app sl' (sc'::sr') s2g). trivial.
rewrite (map_app sl (sc::sr) s2g). trivial.
rewrite (map_app sl (sc::sr) s2g) in H2. rewrite (map_app sl' (sc'::sr') s2g) in H2.
simpl in H2. rewrite H2. trivial.
Qed.

(* The outcome of a strategy for a specific agent *)
Fixpoint InducedOutcome (s : Strat) : Outcome :=
match s with
| sL oc => oc
| sN a sl sc sr => InducedOutcome sc
end.

Lemma UsedOutcomes_sN_incl : forall a sl sc sr,
incl (UsedOutcomes (s2g sc)) (UsedOutcomes (s2g (sN a sl sc sr))).
Proof.
induction sl; intros. simpl. apply incl_appl. apply incl_refl.
destruct sl; simpl in *|-* ; apply incl_appr; apply IHsl.
Qed.

Lemma Used_Induced_Outcomes : forall s : Strat,
In (InducedOutcome s) (UsedOutcomes (s2g s)).
Proof.
intro. assert (let P:=fun s => In (InducedOutcome s) (UsedOutcomes (s2g s)) in P s).
apply Strat_ind2 with
(fun (l : list Strat) s (l' : list Strat) => In (InducedOutcome s) (UsedOutcomes (s2g s)));
try (simpl;  tauto).
intros. apply UsedOutcomes_sN_incl. assumption. simpl in H. assumption.
Qed.

Lemma map_s2g_gL_InducedOutcome : forall ls loc,
map s2g ls =map (fun y => gL y) loc -> map InducedOutcome ls = loc.
Proof.
induction ls; simpl; intros; destruct loc. trivial. inversion H. inversion H. inversion H.
rewrite (IHls loc). destruct a. inversion H1. trivial. destruct l; inversion H1. assumption.
Qed.

(* Agent Convertibility between strategies *)
Inductive Conv : Agent -> Strat -> Strat -> Prop :=
| convLeaf : forall a0 oc, Conv a0 (sL oc)(sL oc)
| convNode : forall a0 a sl sl' sc sc' sr sr',  (length sl=length sl' \/ a = a0) ->
ListConv a0 (sl++(sc::sr)) (sl'++(sc'::sr')) ->
Conv a0 (sN a sl sc sr)(sN a sl' sc' sr')
with
ListConv : Agent -> list Strat -> list Strat -> Prop :=
| lconvnil : forall a0, ListConv a0 nil nil
| lconvcons : forall a0 s s' tl tl', Conv a0 s s' -> ListConv a0 tl tl' ->
ListConv a0 (s::tl)(s'::tl').

Scheme conv_lconv_ind := Minimality for Conv Sort Prop
with lconv_conv_ind := Minimality for ListConv Sort Prop.

(* Relation between Conv, ListConv, and rel_vector *)
Lemma ListConv_rel_vector : forall a l l',
ListConv a l l' -> rel_vector (Conv a) l l'.
Proof.
induction l; intros. inversion H. simpl. trivial. destruct l'; simpl. inversion H.
inversion H. split. assumption. apply IHl. assumption.
Qed.

Lemma rel_vector_ListConv : forall a l l',
rel_vector (Conv a) l l' -> ListConv a l l' .
Proof.
induction l; intros. inversion H. constructor. destruct l'. inversion H. simpl in H.
constructor. tauto. apply IHl. tauto.
Qed.

Lemma  Conv_refl : forall a s , Conv a s s.
Proof.
intros. assert (let P:= fun s => Conv a s s in P s).
apply Strat_ind2 with  (fun sl sc sr => ListConv a (sl++(sc::sr)) (sl++(sc::sr))); simpl; intros.
constructor.
constructor 2. assumption. constructor.
inversion H0.
constructor. assumption. constructor. assumption. assumption.
constructor. assumption. assumption. constructor 2. tauto. assumption.
simpl in H. assumption.
Qed.

Lemma ListConv_refl : forall a l, ListConv a l l.
Proof.
intros. apply rel_vector_ListConv. induction l; simpl. trivial. pose (Conv_refl a a0). tauto.
Qed.

(* Agent conversion preserves the underlying game *)
Lemma Conv_s2g : forall (a : Agent)(s s' : Strat), Conv a s s' -> s2g s = s2g s'.
Proof.
intros. assert (let P:= (fun a s s' => s2g s = s2g s') in P a s s').
apply conv_lconv_ind with (fun a0 l l' => ListConv a0 l l' -> map s2g l=map s2g l'); intros.
trivial. apply map_s2g_sN_s2g. tauto. trivial. simpl. rewrite H1. rewrite H3. trivial. assumption.
assumption. simpl in H0. assumption.
Qed.

(* ============ *)
(* === Equilibria === *)
(* ============ *)

Section NE_SPE.

(* Preference *)
Variable OcPref : Agent -> relation Outcome.

Definition StratPref (a : Agent)(s s' : Strat) : Prop :=
 OcPref a (InducedOutcome s)(InducedOutcome s').

(* Definition of happiness *)
Definition Happy (s : Strat)(a : Agent) : Prop :=
  forall s', Conv a s s' -> ~StratPref a s s'.

(* Definition of Nash equilibrium *)
Definition Eq (s : Strat) : Prop := forall a, Happy s a.

(* Subgame perfect equilibrium *)
Fixpoint SPE (s : Strat) : Prop := Eq s /\
match s with
| sL oc =>  True
| sN a sl sc sr => (listforall SPE sl) /\ SPE sc /\ (listforall SPE sr)
end.

(* Subgame perfect equilibrium is equilibrium *)
Lemma SPE_is_Eq : forall s : Strat, SPE s -> Eq s.
Proof.
intros. destruct s; simpl in H; tauto.
Qed.

Lemma Eq_subEq_choice : forall a sl sc sr,
(forall s s', In s sl \/ In s sr -> Conv a s s' -> ~StratPref a sc s') ->
Eq sc -> Eq (sN a sl sc sr).
Proof.
unfold Eq, Happy. intros. intro. destruct s'; inversion H1.
unfold StratPref in H2. simpl in H2.
destruct (eq_nat_dec (length sl) (length l)). absurd (StratPref a0 sc s').
apply H0. apply  rel_vector_app_cons_same_length with Strat sr l0 sl l.
apply ListConv_rel_vector. assumption. assumption. unfold StratPref. assumption.
assert (a1=a0). tauto.
destruct (rel_vector_app_cons_different_length (Conv a0) sl sc sr l s' l0).
apply ListConv_rel_vector. assumption. assumption. rewrite H9 in H. rewrite H14 in H.
absurd (StratPref a0 sc s'). apply H with x; tauto . unfold StratPref. assumption.
Qed.

Section BI.

Hypothesis OcPref_dec : forall (a : Agent), rel_dec (OcPref a).

Lemma StratPref_dec : forall (a : Agent), rel_dec (StratPref a).
Proof.
unfold StratPref. do 3 intro. apply OcPref_dec.
Qed.

(* Definition of fast backward induction *)
Fixpoint BI (g : Game) : Strat :=
match g with
| gL oc => sL oc
| gN a g l => let (triple,_):=Choose_and_split (StratPref_dec a) (map BI l) (BI g) in
                      let (double,sr):= triple in
                      let (sl,sc):= double in
                      sN a sl sc sr
end.

Lemma BI_s2g : forall g : Game, s2g (BI g)=g.
Proof.
intro. assert (let P:= fun g => s2g (BI g) = g in P g).
apply Game_ind2 with (fun g l => s2g (BI g) = g /\ map s2g (map BI l)=l); simpl; intros.
trivial. tauto. rewrite H. rewrite (proj2 H0). tauto.
destruct (Choose_and_split  (StratPref_dec a) (map BI l) (BI g0)).
destruct x. destruct p. decompose [and] y. clear y. destruct l1; simpl in H0|-* . inversion H0.
rewrite (proj1 H). rewrite (proj2 H). trivial. inversion H0. rewrite (proj1 H). rewrite <- (proj2 H).
rewrite H6. rewrite  (map_app l1 (s::l0) s2g). simpl. trivial. simpl in H. assumption.
Qed.

Hypothesis OcPref_irrefl : forall (a : Agent), irreflexive (OcPref a).

Hypothesis OcPref_trans : forall (a : Agent), transitive Outcome (OcPref a).

Lemma StratPref_irrefl : forall (a : Agent), irreflexive (StratPref a).
Proof.
unfold StratPref. do 2 intro. apply OcPref_irrefl.
Qed.

Lemma StratPref_trans : forall (a : Agent), transitive Strat (StratPref a).
Proof.
repeat intro. unfold transitive in *|- . unfold StratPref in *|-* .
apply OcPref_trans with (InducedOutcome y); assumption.
Qed.

Lemma Leaf_Eq : forall oc : Outcome, Eq (sL oc).
Proof.
do 4 intro. destruct s'. inversion H. apply StratPref_irrefl. inversion H.
Qed.

Lemma BI_SPE :  forall loc, (forall (a : Agent), total (OcPref a) loc) ->
forall g : Game, incl (UsedOutcomes g) loc -> SPE (BI g).
Proof.
do 2 intro.
(* Slightly Change the Form of the Goal *)
assert (let P:= fun g => incl (UsedOutcomes g) loc -> SPE (BI g) in forall g, P g).
(* By Induction on Games *)
apply Game_ind2 with
(fun g l =>  listforall  (fun g' => incl (UsedOutcomes g') loc) (g::l) ->
SPE (BI g) /\ listforall SPE (map BI l)).
(* Three First Cases *)
split. apply Leaf_Eq. trivial. simpl. tauto. simpl. tauto.
(* Last Case *)
(* Explicit BI Choice *)
intros. simpl. destruct  (Choose_and_split (StratPref_dec a) (map BI l) (BI g)).
destruct x. destruct p. decompose [and] y. clear y.
(* Prove Sub-SPE *)
assert (listforall SPE (l1 ++ s :: l0)). rewrite <- H2. apply H0.
apply UsedOutcomes_gN_listforall with a. assumption.
pose (listforall_appr SPE (s::l0) l1 H5). pose (listforall_appl SPE (s::l0) l1 H5).
(** Eq, Using Lemma  Eq_subEq_choice **)
split. apply Eq_subEq_choice.
(* First Condition to Verify *)
do 4 intro.
(* Prove Sub-Eq *)
assert (Eq s0). apply SPE_is_Eq. apply listforall_In with Strat (l1++(s::l0)). apply in_or_app. simpl.
tauto. assumption.
(* Recall Two Maximalities *)
assert (~StratPref a s0 s'). apply H9. assumption.
assert (~StratPref a s s0). assert (let Q:= fun x => ~ StratPref a s x in Q s0).
destruct H7. apply listforall_In with Strat l1. assumption. apply H6. apply StratPref_irrefl.
apply StratPref_trans. apply listforall_In with Strat l0. assumption. exact H4. assumption.
(* An Outcome-List Inclusion*)
assert (incl (UsedOutcomes(s2g s0)) loc). do 2 intro. apply H1. pose UsedOutcomes_gN.
unfold incl in i. apply i with (s2g s0). rewrite <- (map_inverse BI s2g BI_s2g (g :: l)).
apply in_map. enough (map BI (g :: l)=l1 ++ s :: l0) as ->. apply in_or_app. simpl. tauto.
simpl. assumption. assumption.
(* Justify and Perform a Case Splitting on  StratPref *)
unfold StratPref in *|-* .
destruct (H a (InducedOutcome s0)(InducedOutcome s')).
apply H12. apply Used_Induced_Outcomes. apply H12. rewrite (Conv_s2g H8).
apply Used_Induced_Outcomes. contradiction.
destruct (OcPref_dec a (InducedOutcome s)(InducedOutcome s0)). contradiction.
(* Continue the Case Splitting *)
destruct H13. rewrite <- H13. assumption. intro.
absurd (OcPref a (InducedOutcome s) (InducedOutcome s0)). assumption.
apply OcPref_trans with (InducedOutcome s'); assumption.
(**)
apply SPE_is_Eq. simpl in l2. tauto. simpl in l2. tauto.
(**)
simpl in H0. assumption.
Qed.

End BI.

End NE_SPE.

Lemma Eq_order_inclusion :  forall OcPref OcPref' s,
(forall a : Agent, sub_rel (restriction (OcPref a) (UsedOutcomes (s2g s))) (OcPref' a)) -> Eq OcPref' s -> Eq OcPref s.
Proof.
unfold sub_rel, Eq, Happy, StratPref, restriction. intros. intro.
absurd (OcPref' a (InducedOutcome s) (InducedOutcome s')). apply H0. assumption.
apply H. split. apply  Used_Induced_Outcomes. split. rewrite (Conv_s2g H1).
apply  Used_Induced_Outcomes. assumption.
Qed.

 Lemma SPE_order_inclusion : forall OcPref OcPref' s,
(forall a : Agent, sub_rel (restriction (OcPref a) (UsedOutcomes (s2g s))) (OcPref' a)) -> SPE OcPref' s -> SPE OcPref s.
Proof.
do 3 intro. assert (let P:= fun s =>
(forall a : Agent, sub_rel (restriction (OcPref a) (UsedOutcomes (s2g s))) (OcPref' a)) ->
SPE OcPref' s -> SPE OcPref s in P s). apply Strat_ind2 with
(fun sl sc sr =>
(forall a : Agent, sub_rel (restriction (OcPref a) (UsedOutcomes (s2g (sN a sl sc sr)))) (OcPref' a)) ->
listforall (SPE OcPref') sl -> SPE OcPref' sc -> listforall (SPE OcPref') sr ->
listforall (SPE OcPref) sl /\ SPE OcPref sc /\ listforall (SPE OcPref) sr).

simpl. intros. split. apply Eq_order_inclusion with OcPref'; tauto. tauto.

simpl. intros. rewrite (app_nil_end (UsedOutcomes (s2g sc))) in H.
pose (H H0 H2). tauto.

intros. assert (SPE OcPref s0). apply H. intro.
apply transitive_sub_rel with  (restriction (OcPref a) (UsedOutcomes (s2g (sN a nil sc (s0 :: sr))))).
apply sub_rel_restriction_incl. simpl. apply incl_appr. apply incl_appl. apply incl_refl. apply H1.
simpl in H4. tauto. assert (True /\ SPE OcPref sc /\ listforall (SPE OcPref) sr). apply H0. intro.
apply transitive_sub_rel with (restriction (OcPref a) (UsedOutcomes (s2g (sN a nil sc (s0 :: sr))))).
apply sub_rel_restriction_incl. simpl. apply incl_app. apply incl_appl. apply incl_refl. apply incl_appr.
apply incl_appr. apply incl_refl. apply H1. trivial. assumption. simpl in H4. tauto.
simpl. tauto.

intros. simpl in H2|-* . assert (listforall (SPE OcPref) sl /\ SPE OcPref sc /\ listforall (SPE OcPref) sr). apply H0. intro.
apply transitive_sub_rel with (restriction (OcPref a) (UsedOutcomes (s2g (sN a (s0 :: sl) sc sr)))).
apply sub_rel_restriction_incl. simpl. apply incl_appr. destruct sl; simpl; apply incl_refl.
apply H1. tauto. assumption. assumption. assert (SPE OcPref s0 ). apply H. intro.
apply transitive_sub_rel with  (restriction (OcPref a) (UsedOutcomes (s2g (sN a (s0 :: sl) sc sr)))).
simpl. apply sub_rel_restriction_incl. apply incl_appl. apply incl_refl. apply H1. tauto. tauto.

intros. simpl in H1|-* . split. apply Eq_order_inclusion with OcPref'. assumption. tauto.
apply H; try tauto. destruct sl; tauto.

simpl in H. assumption.
Qed.

(* ================================ *)
(* === Equivalence Between Acyclicity, SPE, and Eq  === *)
(* ================================ *)

(* Equality is decidable on outcomes*)
Hypothesis Outcome_dec : eq_dec Outcome.

Theorem acyclic_SPE : forall OcPref,
(forall a, rel_dec (OcPref a)) ->
(forall a, irreflexive (clos_trans Outcome (OcPref a))) ->
  forall g, {s : Strat | s2g s=g /\ SPE OcPref s}.
Proof.
intros. pose  (fun a => LETS (OcPref a) (UsedOutcomes g)).
assert (forall a, rel_dec (r a)). intro. unfold r. apply LETS_dec. apply Outcome_dec.
apply X. exists (BI r X0 g). split. apply BI_s2g. apply SPE_order_inclusion with r.
intro. pose (LETS_restricted). unfold is_restricted in i. rewrite (BI_s2g r X0 g). unfold r.
apply LETS_sub_rel. apply BI_SPE with (UsedOutcomes g); unfold r; intros.

destruct (LETS_irrefl (OcPref a) (UsedOutcomes g)(eq_dec_midex Outcome_dec)).
apply H0. apply irreflexive_preserved with (clos_trans Outcome (OcPref a)).
apply clos_trans_monotonic. apply sub_rel_restriction. apply H.

apply LETS_transitive. apply LETS_total. exact (eq_dec_midex Outcome_dec).
exact (rel_dec_midex (X a)). apply incl_refl.
Qed.

Lemma SPE_Eq : forall OcPref,
(forall a, rel_dec (OcPref a)) ->
(forall g : Game, {s : Strat | s2g s=g /\ SPE OcPref s}) ->
forall g : Game, {s : Strat | s2g s=g /\ Eq OcPref s}.
Proof.
intros. destruct (X0 g). exists x. split. tauto. apply SPE_is_Eq. tauto.
Qed.

Lemma Eq_acyclic : forall OcPref,
(forall a, rel_dec (OcPref a)) ->
(forall g : Game, {s : Strat | s2g s=g /\ Eq OcPref s}) ->
forall a : Agent, irreflexive (clos_trans Outcome (OcPref a)).
Proof.
repeat intro. destruct (clos_trans_path H).

destruct x0. simpl in H0. destruct (X0 (gL x)). destruct a0. destruct x0. pose (H2 a (sL o)). apply n.
apply Conv_refl. inversion H1. unfold StratPref. simpl. assumption. destruct l; inversion H1.

destruct (X0 (gN a (gL x)  (map (fun y => gL y) (o::x0)))). destruct a0. destruct x1. inversion H1.

destruct l0.

destruct l. inversion H1. pose (H2 a0 (sN a0 (nil : list Strat) s (l++(x1::nil)))). apply n.
constructor. tauto. simpl. apply ListConv_refl. unfold StratPref. simpl. inversion H1.
rewrite <- (map_s2g_gL_InducedOutcome (l++(x1::nil)) (o::x0)) in H0. destruct s. simpl. inversion H5.
apply (path_app_elim_right (OcPref a) (InducedOutcome x1) x  (map InducedOutcome l) nil x).
rewrite (map_app l (x1::nil) InducedOutcome) in H0. simpl in H0. assumption. destruct l0; inversion H5.
rewrite (map_app l (x1::nil) s2g). assumption.

pose (H2 a0 (sN a0 (l++(x1::nil)) s l0)). apply n. constructor. tauto. rewrite (app_ass l (x1::nil) (s::l0)).
simpl. apply ListConv_refl. unfold StratPref. simpl.
destruct l. destruct x1; inversion H1. destruct s; inversion H6. simpl in H0|-* . tauto.
destruct l; inversion H8. destruct l; inversion H5.
inversion H1.
rewrite <- (map_s2g_gL_InducedOutcome (l++x1::s::l0) (o::x0)) in H0.
assert (is_path (OcPref a) (InducedOutcome x1) x (map InducedOutcome (s :: l0))).
apply path_app_elim_right with (map InducedOutcome l) x.
rewrite (map_app l (x1::s::l0) InducedOutcome) in H0. assumption. simpl in H3. tauto.
simpl. rewrite <- H6. rewrite (map_app l (x1::s::l0) s2g). tauto.
Qed.

End GameTheory.


Require Export EnumTypes.

Module Rewriting.

(** A theorem that states if n=m, then n+n=m+m.
    the proof is relatively straightforward. intros
    introduces the variables n and m, and the
    hypothesis H, into the proof context. rewrite
    rewrites the current goal (n + n = m+m) by
    replacing instances of the leftside of H with
    the write side. reflexivity simplifies both
    sides of the `=` to equal values. *)
Theorem plus_id_example : forall n m : nat,
   n = m ->
   n + n = m + m.

   Proof.
      intros n m.
      intros H.
      rewrite -> H.
      reflexivity. Qed.

(** EXERCISE [*]: Prove that for all n,m,o \in N,
    n = m implies that (m = o implies that
    n+m = m+o) *)
Theorem plus_id_exercise : forall n m o : nat,
   n = m -> m = o -> n + m = m + o.

   Proof.
      intros n m o.
      intros H1.
      intros H2.
      rewrite -> H1.
      rewrite -> H2.
      reflexivity. Qed.

(** EXERCISE [**]: Prove that for all n,m in N,
    m = S n implies that m*(1+n) = m*m *)
Theorem mult_S_1 : forall n m : nat,
   m = S n ->
   m * (1 + n) = m * m.

   Proof.
      intros n m.
      intros H.
      rewrite -> H.
      reflexivity. Qed.

End Rewriting.