(*|
============================================
Algebraic n-players Howson-Rosenthal theorem
============================================
:Auteur: Pierre Pomeret-Coquot
:Date:   RJCIA 2021

|*)

From Coq Require Import ssreflect.
From mathcomp Require Import all_ssreflect. (* .none *)
From mathcomp Require Import all_algebra. (* .none *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section GeneralLemmae.

  (*| Decidability of eqTypes |*)

  Lemma eqType_dec (T : eqType) :
    forall t1 t2 : T, t1 = t2 \/ t1 <> t2.
  Proof.
  move => t1 t2.
  case (boolP (t1 == t2)) => /eqP H.
  - exact: or_introl.
  - exact: or_intror.
  Qed.

End GeneralLemmae.

(*|
Evaluation structure
====================

Evaluation structure encapsulate domains, orders and operators for GEU:

- Utility domain U ordered by preceq_U

- Plausibility domain W ordered by preceq_W

- Valuation domain V ordered by preceq_V

- otimes and oplus operators

|*)

Section EvalStruct.

  Record eval_struct : Type :=
    { U : finType;
      W : eqType;
      V : eqType;
      V0 : V;
      preceq_U : rel U;
      preceq_W : rel W;
      preceq_V : rel V;
      oplus : Monoid.com_law V0;
      otimes : W -> U -> V;
    }.

  (*| Asymetric part of preceq |*)
  Definition prec T (preceq : rel T) : rel T :=
    fun t1 t2 => (preceq t1 t2) && ~~ (preceq t2 t1).

End EvalStruct.

(*|
Profiles
--------

A 'profile' is a dependent vector which contains a (X i) for all player i.
Typically, a strategy profile is a strategy for each player i.

We represent profiles with dependent finite-support functions (dffun)
|*)

Section Profiles.

  Implicit Type (N : finType).

  (*| Profile for classical games |*)
  Definition profile (N : finType) (X : N -> eqType) := {dffun forall i, X i}.

  (*| Finite profile |*)
  Definition fprofile N (X : N -> finType) := {dffun forall i, X i}.

  (*| Change the strategy of a given player in a given profile |*)
  Definition move N X (p : profile X) (i : N) (pi : X i) : profile X :=
    [ffun j => match boolP (i == j) with
               | AltTrue h => eq_rect _ X pi _ (eqP h)
               | AltFalse _ =>  p j
               end].

  (*| Profile for incomplete games |*)
  Definition iprofile N (T : N -> finType) (X : N -> eqType) :=
    {dffun forall i, T i -> X i}.

  (*| Transform an iprofile to a profile such as support is the set of dependent pairs (i,t_i) |*)
  Definition iprofile_flatten N (T : N -> finType) X (p : iprofile T X)
    : profile (fun it => X (projT1 it)) :=
    [ffun it => p (projT1 it) (projT2 it)].

  (*| Profile that will be played if player's types are known |*)
  Definition proj_iprofile N (T : N -> finType) X (p : iprofile T X)
    : profile T -> profile X :=
    fun theta => [ffun i => p i (theta i)]
.
  Definition proj_flatprofile N (T : N -> finType) X
             (p : profile (fun it => X (projT1 it)))
    : profile T -> profile X :=
    fun theta => [ffun i => p (existT _ i (theta i))].

  Lemma proj_iprof_flatprof N (T : N -> finType) X (p : iprofile T X) theta :
    (proj_iprofile p theta) = (proj_flatprofile (iprofile_flatten p) theta).
  Proof.
    by apply: eq_dffun => i; rewrite ffunE.
  Qed.

  Definition bmove N T X (p : iprofile T X) (i : N) ti xi
    : iprofile T X :=
    [ffun j => fun tj => match boolP (i == j) with
                         | AltTrue h =>
                           let ti' := eq_rect _ T ti _ (eqP h) in
                           if ti' == tj
                           then eq_rect i X xi j (eqP h)
                           else p j tj
                         | AltFalse _ => p j tj
                         end].

  Lemma move_bmove N T X (p : iprofile T X) (it : {i : N & T i})
        (xi : X (projT1 it)) :
    (@move _ _ (iprofile_flatten p) it xi)
    = (iprofile_flatten (bmove p (projT2 it) xi)).
  Proof.
  apply eq_dffun => it' //=.
  rewrite !ffunE.
  case (boolP (@eq_op (Finite.eqType (tag_finType T)) it it')) => H1;
                   case (boolP (projT1 it == projT1 it')) => H2 //=.
  - case (boolP ((eq_rect _ _ (projT2 it) (projT1 it')  (@elimT
      (@eq (Finite.sort N) _ _) _ eqP H2)) == (projT2 it'))) => H3.
    + rewrite (rew_map X _ (eqP H1) xi).
      by rewrite (Eqdep_dec.eq_proofs_unicity
                    (@eqType_dec N) (f_equal _ (eqP H1))(eqP H2)).
    + move/eqP in H3.
      have Hcontra := projT2_eq (eqP H1).
      by rewrite (Eqdep_dec.eq_proofs_unicity (@eqType_dec N)
           (projT1_eq (eqP H1)) (eqP H2)) in Hcontra.
  - move/eqP in H2.
    by rewrite (eqP H1) in H2.
  - case (boolP ((eq_rect _ _ (projT2 it) (projT1 it')  (@elimT
        (@eq (Finite.sort N) _ _) _ eqP H2)) == (projT2 it'))) => H3 //.
    have Hcontra := eq_sigT it it' (eqP H2) (eqP H3).
    by move/eqP in H1.
  Qed.

End Profiles.

(*|
Games
=====

Three forms of games are defined in the corresponding modules:

- Standard Normal Form Games (NFGames)

- Hypergraphical Games (HGGames)

- Incomplete Games (IGames) (i.e. generalization of Bayesian games to any plausibility distribution)

|*)

(*|
Classical SNF games
-------------------

We define simultaneous SNF games with abstract outcomes, that may be different for eaech player.
|*)

Module NFGame.

  Record game (player : finType) : Type :=
    { outcome : player -> Type;
      action : player -> finType;
      utility : forall i, profile action -> outcome i;
      preceq : forall i, rel (outcome i);
    }.

  Definition NashEqb player (g : game player)
    : pred (profile (action g)) :=
    fun p =>
    [forall i : player,
     forall ai : action g i,
        ~~ prec (@preceq _ _ _) (utility i p) (utility i (move p ai))].

  Definition NashEq player (g : game player) (p : profile (action g))
    : Prop :=
    forall (i : player) (ai : action g i),
    ~ prec (@preceq _ _ _) (utility i p) (utility i (move p ai)).

  Lemma NashEqP player (g : game player) (p : profile (action g)) :
    reflect (NashEq p) (NashEqb p).
  Proof.
  case (boolP (NashEqb p)); constructor; move: i.
  - move/forallP => H i; move: (H i).
    move/forallP => H2 ai; move: (H2 ai) => H0.
    exact: (negP H0).
  - move/forallPn => [] x.
    move/forallPn => [] y.
    move/negPn => [H Hne].
    by case: (Hne x y).
  Qed.

End NFGame.

(*|
Hypergraphical games
--------------------

Hypergraphical games are succinct representation of SNF games, where players play in some local games.
Their global utility is the (abstract) sum of their local utility.
|*)

Module HGGame.

  Record game (player : finType) : Type :=
    { local_game : finType;
      plays : local_game -> pred player;
      outcome : player -> Type;
      outcome0 : forall i, outcome i;
      oplus : forall i, Monoid.com_law (outcome0 i);
      preceq : forall i, rel (outcome i);
      action : player -> finType;
      local_utility : local_game ->
                      forall i, profile action -> outcome i;
    }.

  Definition global_utility player (g : game player) (i : player)
             (p : profile (action g)) :=
    \big[oplus g i/outcome0 g i]_(lg : local_game g | plays lg i)
     local_utility lg i p.

  Definition to_normal_form player (g : game player)
    : NFGame.game player :=
    {| NFGame.outcome := outcome g;
       NFGame.preceq := @preceq _ g;
       NFGame.action := action g;
       NFGame.utility := @global_utility _ g;
    |}.

  Definition NashEqb player (g : game player) :=
    @NFGame.NashEqb _ (to_normal_form g).

  Definition NashEq player (g : game player) :=
    @NFGame.NashEq _ (to_normal_form g).

  Lemma NashEqP player (g : game player) (p : profile (action g))
    : reflect (NashEq p) (NashEqb p).
  Proof. exact: NFGame.NashEqP. Qed.

  Lemma NashEq_HG_NFb player (g : game player) p :
    NashEqb p = @NFGame.NashEqb _ (to_normal_form g) p.
  Proof. by []. Qed.

  Lemma nashEq_HG_NF player (g : game player) p :
    NashEq p <-> @NFGame.NashEq _ (to_normal_form g) p.
  Proof. by []. Qed.

End HGGame.

(*|
Incomplete games
----------------

Incomplete games generalize Bayesian games and possibilistic games.

Players don't know perfectly the world i.e. they ignore which game they are playing.
|*)

Module IGame.

  Record game (player : finType) : Type :=
    { evalst : player -> eval_struct;
      signal : player -> finType;
      action : player -> finType;
      utility : forall i : player,
        profile action -> profile signal -> U (evalst i);
      belief : forall i : player, profile signal -> W (evalst i);
    }.

  Definition GEutility player (g : game player) (i : player) t p :=
    \big[oplus (evalst g i)/V0 (evalst g i)]_(
     theta : fprofile (signal g) | (theta i) == t)
     otimes (belief i theta) (utility i (proj_iprofile p theta) theta).

  Definition to_hggame player (g : game player) : HGGame.game _ :=
    {| HGGame.local_game := [finType of fprofile (signal g)];
       HGGame.plays := fun theta it => theta (projT1 it) == projT2 it;
       HGGame.outcome := fun it => V _;
       HGGame.outcome0 := fun it => V0 _;
       HGGame.oplus := fun it => oplus _;
       HGGame.preceq := fun it => @preceq_V _;
       HGGame.action := fun it => action g _;
       HGGame.local_utility := fun theta it p =>
           otimes (belief (projT1 it) theta)
              (utility (projT1 it) (proj_flatprofile p theta) theta);
    |}.

  Definition to_normal_form player (g : game player)
    : NFGame.game _ :=
    HGGame.to_normal_form (to_hggame g).

  Definition NashEqb player (g : game player)
    : pred (iprofile (signal g) (action g)) :=
    fun bp =>
    [forall i : player,
     forall t : signal g i,
     forall ai : action g i,
          ~~ prec (@preceq_V _) (GEutility t bp)
             (GEutility t (bmove bp t ai)) ].

  Definition NashEq player (g : game player) p : Prop :=
    forall i : player,
    forall t : signal g i,
    forall ai : action g i,
    ~ prec (@preceq_V _) (GEutility t p) (GEutility t (bmove p t ai)).

  Lemma NashEqP player (g : game player)
        (p : iprofile (signal g) (action g)) :
    reflect (NashEq p) (NashEqb p).
  Proof.
  case (boolP (NashEqb p)); constructor; move: i.
  - move/forallP => H i; move: (H i).
    move/forallP => H2 t; move: (H2 t).
    move/forallP => H3 ai; move: (H3 ai) => H0.
    exact: negP H0.
  - move/forallPn => [] x.
    move/forallPn => [] y.
    move/forallPn => [] z.
    move/negPn => H2 Hne.
    by move/(_ x y z) in Hne.
  Qed.

End IGame.

(*|
Howson-Rosenthal-like transformation
------------------------------------

We cast any incomplete game to a graphical game where players are the dependent pairs (player,signal) of the initial I-Game.

We show that erevy 'expected utility' value in the IGame is equal its corresponding 'global utility' value in the HG-Game.
Thus, Nash equilibria are in correspondance.
|*)
Section HR.

  Lemma HowsonRosenthal :
    forall player (g : IGame.game player) i t p,
    @IGame.GEutility player g i t p
    = @HGGame.global_utility _ (IGame.to_hggame g) (existT _ i t)
                             (iprofile_flatten p).
  Proof.
  rewrite /IGame.GEutility /HGGame.global_utility
          /IGame.to_hggame => player g i t p //=.
  apply eq_bigr => theta Htheta.
  by rewrite -proj_iprof_flatprof.
  Qed.

  Lemma HowsonRosenthal_NashEqb :
    forall player (g : IGame.game player),
    forall  (p : iprofile (IGame.signal g) (IGame.action g)),
    @HGGame.NashEqb _ (IGame.to_hggame g) (iprofile_flatten p)
    = IGame.NashEqb p.
  Proof.
  move => player g p.
  apply/NFGame.NashEqP /IGame.NashEqP => /=.
  - rewrite /NFGame.NashEq /IGame.NashEq => /= H i t ai.
    move : (H (existT _ i t) ai).
    by rewrite {1}/iprofile_flatten !HowsonRosenthal move_bmove.
  - rewrite /NFGame.NashEq /IGame.NashEq => /= H it ai.
    have H' := (H (projT1 it) (projT2 it) ai).
    by rewrite {1 2 3 4}(sigT_eta it) move_bmove -!HowsonRosenthal.
  Qed.

  Lemma HowsonRosenthal_NashEq :
    forall player (g : IGame.game player),
    forall  (p : iprofile (IGame.signal g) (IGame.action g)),
    @HGGame.NashEq _ (IGame.to_hggame g) (iprofile_flatten p)
    <-> IGame.NashEq p.
  Proof.
  split => H.
  - apply/IGame.NashEqP; move/HGGame.NashEqP in H.
    by rewrite -(HowsonRosenthal_NashEqb p).
  - apply/HGGame.NashEqP; move/IGame.NashEqP in H.
    by rewrite (HowsonRosenthal_NashEqb p).
  Qed.

End HR.


Set Implicit Arguments.

Require Import Aniceto.Graphs.Graph.

Section Bipartite.
Variable a_vertex:Type.
Variable b_vertex:Type.
Notation a_edge:= ((a_vertex * a_vertex) % type).
Notation b_edge:= ((b_vertex * b_vertex) % type).

Variable AB : a_vertex -> b_vertex -> Prop.
Variable BA : b_vertex -> a_vertex -> Prop.

Inductive AA : a_edge -> Prop :=
  aa :
    forall a1 b a2,
    AB a1 b ->
    BA b a2 ->
    AA (a1, a2).

Inductive BB : b_edge -> Prop :=
  bb :
    forall b1 a b2,
    BA b1 a ->
    AB a b2 ->
    BB (b1, b2).

Notation AWalk := (Walk AA).
Notation ACycle := (Cycle AA).
Notation a_walk := (list a_edge).

Notation BWalk := (Walk BB).
Notation BCycle := (Cycle BB).
Notation b_walk := (list b_edge).

Inductive bi_vertex :=
  | bi_b_vertex : b_vertex -> bi_vertex
  | bi_a_vertex : a_vertex -> bi_vertex.

Notation bi_edge := (bi_vertex * bi_vertex) % type.
Notation bi_walk := (list bi_edge) % type.
Notation ba := (fun b a => ((bi_b_vertex b), (bi_a_vertex a))).
Notation ab := (fun a b => ((bi_a_vertex a), (bi_b_vertex b))).

Inductive BAEdge : bi_edge -> Prop :=
  ba_edge :
    forall b a,
    BA b a ->
    BAEdge ((bi_b_vertex b), (bi_a_vertex a)).

Inductive ABEdge : bi_edge -> Prop :=
  ab_edge :
    forall a b,
    AB a b ->
    ABEdge ((bi_a_vertex a), (bi_b_vertex b)).

Inductive BiEdge : bi_edge -> Prop :=
  | ab_to_bi_edge:
    forall a b,
    AB a b ->
    BiEdge (ab a b)
  | ba_to_bi_edge:
    forall b a,
    BA b a ->
    BiEdge (ba b a).

Notation BiWalk := (Walk BiEdge).
Notation BiCycle := (Cycle BiEdge).

Lemma a_edge_to_bi_edge:
  forall a1 a2,
  AA (a1, a2) ->
  exists b,
  AB a1 b /\ BA b a2.
Proof.
  intros.
  inversion H.
  exists b.
  intuition.
Qed.

Lemma bi_edge_to_a_edge:
  forall a1 b a2,
  AB a1 b ->
  BA b a2 ->
  AA (a1, a2).
Proof.
  intros.
  eauto using aa.
Qed.

Lemma b_edge_to_bi_edge:
  forall b1 b2,
  BB (b1, b2) ->
  exists a,
  BA b1 a /\ AB a b2.
Proof.
  intros.
  inversion H.
  exists a.
  intuition.
Qed.

Lemma bi_edge_to_b_edge:
  forall b1 a b2,
  BA b1 a ->
  AB a b2 ->
  BB (b1, b2).
Proof.
  intros.
  eauto using bb.
Qed.

Inductive BAB (b1:b_vertex) (a:a_vertex) (b2:b_vertex) : Prop :=
  ba_ab_to_bab:
    BA b1 a ->
    AB a b2 ->
    BAB b1 a b2.

Lemma b_to_bab:
  forall b1 b2,
  BB (b1, b2) ->
  exists a,
  BAB b1 a b2.
Proof.
  intros.
  inversion H; subst; clear H.
  exists a.
  auto using ba_ab_to_bab.
Qed.

Inductive ABA (a1:a_vertex) (b:b_vertex) (a2:a_vertex) : Prop :=
  ab_ba_to_aba:
    AB a1 b ->
    BA b a2 ->
    ABA a1 b a2.

Lemma bab_to_b:
  forall b1 a b2,
  BAB b1 a b2 ->
  BB (b1, b2).
Proof.
  intros.
  destruct H.
  eauto using bi_edge_to_b_edge.
Qed.

Lemma aba_to_aa :
  forall a1 b a2,
  ABA a1 b a2 ->
  AA (a1, a2).
Proof.
  intros.
  destruct H.
  eauto using bi_edge_to_a_edge.
Qed.

Lemma a_to_aba:
  forall a1 a2,
  AA (a1, a2) ->
  exists b,
  ABA a1 b a2.
Proof.
  intros.
  inversion H; subst; exists b.
  auto using ab_ba_to_aba.
Qed.

Lemma bab_to_aba:
  forall b1 a1 b2 a2 b3,
  BAB b1 a1 b2 ->
  BAB b2 a2 b3 ->
  ABA a1 b2 a2.
Proof.
  intros.
  destruct H.
  destruct H0.
  auto using ab_ba_to_aba.
Qed.

Lemma aba_to_bab:
  forall a1 b1 a2 b2 a3,
  ABA a1 b1 a2 ->
  ABA a2 b2 a3 ->
  BAB b1 a2 b2.
Proof.
  intros.
  destruct H.
  destruct H0.
  auto using ba_ab_to_bab.
Qed.

Lemma aba_to_b:
  forall a1 a2 a3 b1 b2,
  ABA a1 b1 a2 ->
  ABA a2 b2 a3 ->
  BB (b1, b2).
Proof.
  intros.
  eauto using aba_to_bab, bab_to_b.
Qed.

Lemma bab_to_aa :
  forall b1 b2 b3 a1 a2,
  BAB b1 a1 b2 ->
  BAB b2 a2 b3 ->
  AA (a1, a2).
Proof.
  intros.
  eauto using bab_to_aba, aba_to_aa.
Qed.

Lemma aba_refl:
  forall a b,
  ABA a b a ->
  BAB b a b.
Proof.
  intros.
  eauto using aba_to_bab.
Qed.

Lemma bab_refl:
  forall b a,
  BAB b a b ->
  ABA a b a.
Proof.
  intros.
  eauto using bab_to_aba.
Qed.

Section CycleAAtoBB.

Inductive edge_a_to_b : a_edge -> a_edge -> b_edge -> Prop :=
  edge_a_to_b_def:
    forall a1 a2 a3 b1 b2,
    ABA a1 b1 a2 ->
    ABA a2 b2 a3 ->
    edge_a_to_b (a1, a2) (a2, a3) (b1, b2).

Lemma a_to_b_b_edge:
  forall e1 e2 e3,
  edge_a_to_b e1 e2 e3 ->
  BB e3.
Proof.
  intros.
  inversion H.
  subst.
  eauto using aba_to_bab, bab_to_b.
Qed.

Lemma edge_a_to_b_total:
  forall a1 a2 a3,
  AA (a1, a2) ->
  AA (a2, a3) ->
  exists b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2).
Proof.
  intros.
  apply a_edge_to_bi_edge in H.
  apply a_edge_to_bi_edge in H0.
  destruct H as (b1, (H1, H2)).
  destruct H0 as (b2, (H3, H4)).
  exists b1.
  exists b2.
  intuition.
  auto using ab_ba_to_aba, edge_a_to_b_def.
Qed.

Inductive a_to_b : a_walk -> b_walk -> Prop :=
  | a_to_b_nil:
    a_to_b nil nil
  | t_to_b_edge_nil:
    forall e,
    a_to_b (e::nil)%list nil
  | a_to_b_cons:
    forall e1 e2 e aw bw,
    a_to_b (e2 :: aw)%list bw ->
    edge_a_to_b e1 e2 e ->
    a_to_b (e1 :: e2 :: aw)%list (e :: bw).

Let a_to_b_total_nil:
  exists bw : b_walk, a_to_b nil bw /\ BWalk bw.
Proof.
  exists nil.
  intuition.
  apply a_to_b_nil.
  apply walk_nil.
Qed.

Let a_to_b_total_edge:
  forall a1 a2,
  AWalk ((a1, a2) :: nil)%list ->
  exists bw : b_walk, a_to_b ((a1, a2) :: nil)%list bw /\ BWalk bw.
Proof.
  exists nil.
  intuition.
  apply t_to_b_edge_nil.
  apply walk_nil.
Qed.

Lemma a_walk_to_edge_a_to_b:
  forall a1 a2 a3 aw,
  AWalk ((a1, a2) :: ((a2, a3) :: aw)%list) ->
  exists b1 b2, edge_a_to_b (a1, a2) (a2, a3) (b1, b2).
Proof.
  intros.
  inversion H; subst.
  inversion H2; subst.
  auto using edge_a_to_b_total.
Qed.

Lemma edge_a_to_b_inv1:
  forall a1 a2 a3 b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2) ->
  ABA a1 b1 a2.
Proof.
  intros. inversion H.
  assumption.
Qed.

Lemma edge_a_to_b_inv2:
  forall a1 a2 a3 b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2) ->
  ABA a2 b2 a3.
Proof.
  intros. inversion H.
  assumption.
Qed.

Lemma edge_a_to_b_inv3:
  forall a1 a2 a3 b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2) ->
  BAB b1 a2 b2.
Proof.
  intros. inversion H.
  eauto using aba_to_bab.
Qed.

Lemma edge_t_to_to_a_to_b:
  forall a1 a2 a3 b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2) ->
  a_to_b ((a1, a2) :: ((a2, a3) :: nil)%list)%list ((b1, b2) :: nil).
Proof.
  intros.
  inversion H.
  auto using a_to_b_cons, t_to_b_edge_nil, edge_a_to_b_def.
Qed.

Lemma b_walk_cons_trt:
  forall r0 b1 b2 a1 a2 a3 bw,
  ABA a1 r0 a2 ->
  ABA a2 b1 a3 ->
  BWalk ((b1, b2) :: bw) ->
  BWalk ((r0, b1) :: ((b1, b2) :: bw)%list).
Proof.
  intros.
  inversion H0; subst.
  apply walk_cons.
  - assumption.
  - eauto using aba_to_b.
  - compute; auto.
Qed.

Lemma a_to_b_cons_trt:
  forall a1 a2 a3 a4 aw b1 b2 b3 bw,
  ABA a1 b1 a2 ->
  ABA a2 b2 a3 ->
  a_to_b ((a2, a3) :: ((a3, a4) :: aw)%list)%list ((b2, b3) :: bw)
  ->
  a_to_b ((a1, a2) :: ((a2, a3) :: (a3, a4) :: aw)%list)%list
  ((b1, b2) :: ((b2, b3) :: bw)%list).
Proof.
  intros.
  eauto using edge_a_to_b_def, a_to_b_cons.
Qed.

Lemma a_to_b_b_walk_cons:
  forall a1 a2 a3 a4 aw b1 b2 b3 bw,
  ABA a1 b1 a2 ->
  ABA a2 b2 a3 ->
  BWalk ((b2, b3) :: bw) ->
  edge_a_to_b (a2, a3) (a3, a4) (b2, b3) ->
  a_to_b ((a2, a3) :: ((a3, a4) :: aw))%list ((b2, b3) :: bw)
  ->
  a_to_b ((a1, a2) :: ((a2, a3) :: (a3, a4) :: aw)%list)%list
  ((b1, b2) :: ((b2, b3) :: bw)%list)
  /\
  BWalk ((b1, b2) :: ((b2, b3) :: bw)%list).
Proof.
  intuition.
  + auto using a_to_b_cons_trt.
  + apply edge_a_to_b_inv1 in H2.
    eauto using b_walk_cons_trt.
Qed.

Lemma edge_a_to_b_to_b_walk:
  forall a1 a2 a3 b1 b2,
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2) ->
  BWalk ((b1, b2) :: nil).
Proof.
  intros.
  apply walk_cons.
  * apply walk_nil.
  * apply a_to_b_b_edge in H.
    assumption.
  * compute;
    auto.
Qed.

Let a_to_b_total_step:
  forall a1 a2 a3 aw bw,
  AWalk ((a1, a2) :: ((a2, a3) :: aw)%list) ->
  a_to_b ((a2, a3) :: aw)%list bw ->
  BWalk bw ->
  exists bw' : b_walk,
  a_to_b ((a1, a2) :: ((a2, a3) :: aw)%list)%list bw' /\ BWalk bw'.
Proof.
  intros.
  assert (H3: AA (a1, a2)). {
    inversion H; subst; assumption.
  }
  inversion H0.
  - (* Case 1: *)
    subst.
    edestruct a_walk_to_edge_a_to_b as (b1, (b2, Hr));
      eauto using a_walk_to_edge_a_to_b.
    exists (cons (b1, b2) nil).
    intuition.
    + auto using a_to_b_cons.
    + eauto using edge_a_to_b_to_b_walk.
  - (* Case 2: *)
    subst.
    destruct e2 as (a3', a4).
    inversion H7; subst. (* a3 = a3' *)
    destruct a_to_aba with (a1:=a1) (a2:=a2) as (b0, ?); auto.
    exists ((b0, b1) :: (b1, b2):: bw0)%list.
    auto using a_to_b_b_walk_cons.
Qed.

Lemma a_to_b_total:
  forall aw,
  AWalk aw ->
  exists bw, a_to_b aw bw /\ BWalk bw.
Proof.
  intros.
  induction aw.
  - apply a_to_b_total_nil.
  - inversion H.
    subst.
    apply IHaw in H2; clear IHaw.
    destruct H2 as (bw, (H1, H2)).
    destruct a as (a1, a2).
    destruct aw.
    + auto using a_to_b_total_edge.
    + destruct p as (a2', a3).
      (* a2 = a2' *)
      compute in H4; rewrite <- H4 in *; clear H4.
      eauto using a_to_b_total_step.
Qed.

Lemma a_to_b_step:
  forall aw b1 b2 bw,
  AWalk aw ->
  a_to_b aw ((b1,b2)::bw) ->
  BWalk ((b1,b2)::bw) ->
  exists a1 a2 a3 aw',
  (aw = ((a1,a2)::(a2,a3)::aw')%list /\
  ABA a1 b1 a2 /\ ABA a2 b2 a3).
Proof.
  intros.
  inversion H0.
  - subst.
    destruct e1 as (a1,a2).
    destruct e2 as (a2',a3).
    exists a1;
    exists a2;
    exists a3;
    exists aw0.
    intuition.
    + inversion H.
      compute in H8.
      subst.
      auto.
    + inversion H6.
      auto.
    + inversion H6.
      auto.
Qed.

Lemma a_to_b_mk_nil:
  forall a1 a2 a3 b1 b2,
  a_to_b ((a1,a2)::(a2,a3)::nil)%list ((b1,b2)::nil) ->
  (ABA a1 b1 a2 /\ ABA a2 b2 a3).
Proof.
  intros.
  inversion H.
  subst.
  inversion H6.
  subst.
  auto.
Qed.

Lemma a_to_b_nil_inv:
  forall aw b1 b2,
  a_to_b aw ((b1, b2) :: nil) ->
  exists a1 a2 a3,
  aw = ((a1, a2) :: (a2, a3) :: nil)%list /\
  edge_a_to_b (a1, a2) (a2, a3) (b1, b2).
Proof.
  intros.
  inversion H.
  subst.
  destruct e1 as (a1, a2').
  destruct e2 as (a2, a3).
  inversion H4.
  subst.
  exists a1; exists a2; exists a3.
  intuition.
  inversion H3.
  auto.
Qed.

Lemma a_to_b_end:
  forall aw bw b1 b2,
  End bw (b1,b2) ->
  a_to_b aw bw ->
  exists a1 a2 a3,
  a_to_b ((a1,a2)::(a2,a3)::nil)%list ((b1,b2)::nil) /\
  ABA a1 b1 a2 /\ ABA a2 b2 a3 /\ End aw (a2, a3).
Proof.
  intros.
  induction H0.
  - inversion H.
  - inversion H.
  - destruct bw.
    + inversion H0.
      subst.
      destruct e1 as (a1, a2'); destruct e2 as (a2, a3); destruct e as (b1', b2').
      inversion H1.
      subst.
      apply end_inv in H.
      inversion H. subst; clear H.
      exists a1; exists a2; exists a3.
      intuition.
      * auto using edge_t_to_to_a_to_b.
      * auto using end_cons, end_nil.
    + inversion H; subst; clear H.
      apply IHa_to_b in H5.
      destruct H5 as (a1, (a2, (a3, (Ha, (Hb, (Hc, Hd)))))).
      exists a1; exists a2; exists a3.
      intuition.
      auto using end_cons.
Qed.

Lemma cycle_a_to_b1:
  forall t,
  AA (t, t) ->
  exists w', BCycle w'.
Proof.
  intros.
  apply a_to_aba in H.
  destruct H as (r, H).
  apply aba_refl in H.
  apply bab_to_b in H.
  exists ((r,r) :: nil)%list.
  auto using edge_to_cycle.
Qed.

Theorem cycle_a_to_b:
  forall w,
  ACycle w ->
  exists w', BCycle w'.
Proof.
  intros.
  inversion H; subst; clear H. (* ACycle w *)
  rename v1 into a1;
  rename v2 into a2;
  rename vn into tn.
  inversion H1; subst. (* AWalk ((v1, v2) :: w0) *)
  apply a_to_b_total in H1.
  destruct H1 as (bw, (H1, H2)).
  inversion H1.
  - (* Case: (t,t)::nil *)
    subst.
    apply end_inv in H0; inversion H0; subst.
    eauto using cycle_a_to_b1.
  - (* Case: (a1,a2) :: aw *)
    subst.
    destruct e2 as (a2', a3).
    compute in H5; subst; rename a2' into a2. (* a2' = a2 *)
    destruct e as (b1, b2).
    (* Fun begins *)
    rename bw0 into bw.
    assert (Hre: exists r rn, End ((b1, b2) :: bw) (r, rn) ). {
      assert (H':= end_total (b1, b2) bw).
      destruct H' as ((rn,b1'), H').
      exists rn; exists b1'.
      assumption.
    }
    destruct Hre as (r, (rn, Hre)).
    assert (Hre' := Hre).
    apply a_to_b_end with (aw := ((a1, a2) :: ((a2, a3) :: aw)%list)%list) in Hre.
    destruct Hre as (t, (tn', (a1', (Ha, (Hb, (Hc, Hd)))))).
    apply end_det with (e:=(tn, a1)) in Hd.
    inversion Hd;  subst; clear Hd.
    rename tn' into tn; rename a1' into a1.
    assert (Hs: BAB rn a1 b1). {
      apply edge_a_to_b_inv1 in H9.
      eauto using aba_to_bab.
    }
    (* Ready to build the path *)
    exists ((rn,b1)::(b1,b2)::bw)%list.
    apply cycle_def with (vn:=r).
    apply end_cons. assumption.
    apply walk_cons. assumption.
    apply bab_to_b with (a:=a1). assumption.
    compute. trivial.
    assumption.
    assumption.
Qed.
End CycleAAtoBB.

Section CycleAtoC.

Inductive edge_a_to_c : a_edge -> bi_edge -> bi_edge -> Prop :=
  edge_a_to_c_def:
    forall a1 b a2,
    ABA a1 b a2 ->
    edge_a_to_c (a1, a2) (ab a1 b) (ba b a2).

Lemma edge_a_to_c_inv1:
  forall e1 e2 e3,
  edge_a_to_c e1 e2 e3 ->
  AA e1.
Proof.
  intros.
  inversion H.
  eauto using aba_to_aa.
Qed.

Lemma edge_a_to_c_inv2:
  forall e1 e2 e3,
  edge_a_to_c e1 e2 e3 ->
  BiEdge e2.
Proof.
  intros.
  inversion H; subst; clear H.
  destruct H0.
  auto using ab_to_bi_edge.
Qed.

Lemma edge_a_to_c_inv3:
  forall e1 e2 e3,
  edge_a_to_c e1 e2 e3 ->
  BiEdge e3.
Proof.
  intros.
  inversion H; subst; clear H.
  destruct H0.
  auto using ba_to_bi_edge.
Qed.

Inductive a_to_c : a_walk -> bi_walk -> Prop :=
  | a_to_c_nil:
    a_to_c nil nil
  | a_to_c_cons:
    forall e1 e2 e aw cw,
    a_to_c aw cw ->
    edge_a_to_c e e1 e2 ->
    a_to_c (e :: aw)%list (e1 :: e2 :: cw)%list.

Lemma aa_to_edge_a_to_c:
  forall a1 a2,
  AA (a1, a2) ->
  exists b, edge_a_to_c (a1, a2) (ab a1 b) (ba b a2).
Proof.
  intros.
  inversion H.
  subst.
  exists b.
  auto using edge_a_to_c_def, ab_ba_to_aba.
Qed.

Let a_to_c_total_1:
  forall a1 a2,
  AA (a1, a2) ->
  exists cw : bi_walk, a_to_c ((a1, a2) :: nil) cw /\ BiWalk cw.
Proof.
  intros.
  apply aa_to_edge_a_to_c in H; auto.
  destruct H as (b, H).
  exists ((ab a1 b)::(ba b a2)::nil)%list.
  intuition.
  - apply a_to_c_cons.
    + apply a_to_c_nil.
    + assumption.
  - inversion H; subst.
    destruct H1.
    apply ab_to_bi_edge in H0.
    apply ba_to_bi_edge in H1.
    auto using edge_to_walk_cons_cons_nil.
Qed.

Let a_to_c_total_2:
  forall a1 a2 a3 aw cw,
  AWalk ((a1, a2) :: ((a2, a3) :: aw)%list) ->
  a_to_c ((a2, a3) :: aw)%list cw ->
  BiWalk cw ->
  exists cw' : bi_walk,
  a_to_c ((a1, a2) :: ((a2, a3) :: aw)%list)%list cw' /\ BiWalk cw'.
Proof.
  intros.
  assert (H3: AA (a1, a2)).
  inversion H; subst; assumption.
  inversion H0.
  subst.
  assert (Hr := H).
  inversion H7; subst; clear H9. (* expand: e1 e2 *)
  apply aa_to_edge_a_to_c in H3; destruct H3 as (b1, H3).
  rename b into b2.
  exists (cons (ab a1 b1)
         (cons (ba b1 a2)
         (cons (ab a2 b2)
         (cons (ba b2 a3) cw0)))).
  intuition.
  + auto using a_to_c_cons.
  + apply walk_cons2.
    apply edge_a_to_c_inv2 in H3.
    assumption.
    apply walk_cons2.
    apply edge_a_to_c_inv3 in H3.
    assumption.
    assumption.
Qed.

Lemma a_to_c_total:
  forall aw,
  AWalk aw ->
  exists cw, a_to_c aw cw /\ BiWalk cw.
Proof.
  intros.
  induction aw.
  - exists nil.
    intuition.
    + apply a_to_c_nil.
    + apply walk_nil.
  - inversion H.
    subst.
    apply IHaw in H2; clear IHaw.
    destruct H2 as (cw, (H1, H2)).
    destruct a as (a1, a2).
    destruct aw.
    + auto using a_to_c_total_1.
    + destruct p as (a2', a3).
      (* a2 = a2' *)
      compute in H4; rewrite <- H4 in *; clear H4.
      eauto using a_to_c_total_2.
Qed.

Let cycle_a_to_c1:
  forall a,
  AA (a, a) ->
  exists w', BiCycle w'.
Proof.
  intros.
  apply a_to_aba in H.
  destruct H as (b, H).
  destruct H as (Ha, Hb).
  apply ab_to_bi_edge in Ha.
  apply ba_to_bi_edge in Hb.
  eauto using edge_to_cycle_cons_cons_nil.
Qed.

Lemma a_to_c_end:
  forall aw a1 a2 cw e,
  End aw (a1, a2) ->
  End cw e ->
  a_to_c aw cw ->
  exists b,
  a_to_c ((a1,a2)::nil)%list ((ab a1 b)::(ba b a2)::nil)%list
  /\ e = (ba b a2).
Proof.
  intros.
  induction H1.
  - inversion H0.
  - destruct cw.
    + inversion H1; subst; clear H1. (* aw = nil *)
      inversion H2; subst; clear H2. (* e0 = (a1, a2); e1 = (a1, b); e2 = (b, a2) *)
      apply end_inv in H; inversion H; subst; clear H.
      exists b.
      intuition.
      * auto using a_to_c_cons, a_to_c_nil, edge_a_to_c_def.
      * inversion H0; subst; clear H0.
        apply end_inv in H4.
        auto.
    + destruct aw.
      * inversion H1.
      * apply end_inv_cons in H.
        apply IHa_to_c in H; clear IHa_to_c.
        assumption.
        repeat (apply end_inv_cons in H0).
        assumption.
Qed.

Theorem cycle_a_to_c:
  forall w,
  ACycle w ->
  exists w', BiCycle w'.
Proof.
  intros.
  inversion H; subst; clear H. (* ACycle w *)
  rename v1 into a1;
  rename v2 into a2;
  rename vn into an.
  inversion H1; subst. (* AWalk ((v1, v2) :: w0) *)
  apply a_to_c_total in H1.
  destruct H1 as (bw, (H1, H2)).
  inversion H1;  subst; clear H1.
  destruct w0.
  - (* Case: (a,a)::nil *)
    subst.
    apply end_inv in H0; inversion H0; subst.
    eauto using cycle_a_to_c1.
  - (* Case: (a1,a2) :: aw *)
    subst.
    inversion H9; subst.
    destruct H10 as (H10, H11).
    destruct p as (a2', a3);
    compute in H5; subst; rename a2' into a2. (* a2' = a2 *)
    (* Fun begins *)
    remember ((bi_a_vertex a1, bi_b_vertex b)
        :: ((bi_b_vertex b, bi_a_vertex a2) :: cw)%list)%list as w.
    (* Hend := BiEnd w e *)
    assert (Hend: exists e, End w e).
      assert (H':= end_total (bi_a_vertex a1, bi_b_vertex b) ((bi_b_vertex b, bi_a_vertex a2) :: cw) % list).
      subst.
      assumption.
    (* Hend *)
    destruct Hend as (e, Hend).
    assert (Hatoc := Hend).
    remember ((a1, a2) :: ((a2, a3) :: w0))%list as aw.
    apply a_to_c_end with (aw:= aw) (a1:=an) (a2:=a1) in Hatoc.
    + destruct Hatoc as (bn, (Hac, Heqe)).
      destruct e. inversion Heqe; rewrite H1 in *; rewrite H5 in *; clear Heqe H1 H5.
      exists w.
      subst.
      eauto using cycle_def.
    + assumption.
    + subst; auto using a_to_c_cons.
Qed.

End CycleAtoC.
End Bipartite.
(*
Implicit Arguments a_to_c.
Implicit Arguments a_to_b.
Implicit Arguments bi_a_vertex.
Implicit Arguments bi_b_vertex.
Implicit Arguments AA.
Implicit Arguments BB.
Implicit Arguments BAB.
Implicit Arguments ABA.
*)

Lemma aa_eq_rev_bb:
  forall {A} {B} AB BA e,
  @AA A B AB BA e <-> BB BA AB e.
Proof.
  intros.
  intuition; (inversion H; eauto using bb, aa).
Qed.

Lemma walk_aa_eq_rev_bb:
  forall {A B:Type} AB BA w,
  Walk (@AA A B AB BA) w <-> Walk (BB BA AB) w.
Proof.
  intros.
  eauto using walk_eq, aa_eq_rev_bb.
Qed.

Lemma cycle_aa_eq_rev_bb:
  forall {A} {B} AB BA w,
  Cycle (@AA A B AB BA) w <-> Cycle (BB BA AB) w.
Proof.
  intros.
  auto using cycle_eq, aa_eq_rev_bb.
Qed.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype order ssrnat seq.
From Foata Require Import sseq.

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

Section Independency.
Context {disp : unit} {A : orderType disp}.
Variable (ind : rel A) (ind_irr : irreflexive ind) (ind_sym : symmetric ind).

Definition all_ind (a : A) := sall (fun x => ind x a).

Definition dep : rel A :=
  fun x y => ~~ ind x y.

Fact dep_sym : symmetric dep.
Proof. by move=>*; rewrite /dep ind_sym. Qed.

Definition has_dep (a : A) := shas (fun x => dep x a).

End Independency.

Section Traces.
Context {disp : unit} {A : orderType disp}.
Variable (ind : rel A) (ind_irr : irreflexive ind) (ind_sym : symmetric ind).

Definition string := seq A.

Inductive perm : string -> string -> Prop :=
| perm_swap a b s t of ind a b : perm (s ++ [:: a; b] ++ t) (s ++ [:: b; a] ++ t).

Inductive perm_star : string -> string -> Prop :=
| perm_refl s t of s = t : perm_star s t
| perm_cons s t u of perm s t & perm_star t u : perm_star s u.

Lemma perm_to_perm_star s t : perm s t -> perm_star s t.
Proof. by move=>H; apply: (perm_cons H); apply: perm_refl. Qed.

Lemma eq_to_perm s t : s = t -> perm_star s t.
Proof. by move/perm_refl. Qed.

Lemma perm_trans s t u : perm_star s t -> perm_star t u -> perm_star s u.
Proof.
elim=>{}s {}t; first by move=>->.
move=>w Hst _ IH /IH Htu.
by apply/perm_cons/Htu.
Qed.

Lemma perm_sym' s t : perm s t -> perm t s.
Proof.
case=>a b {}s {}t; rewrite ind_sym=>H.
by apply: perm_swap.
Qed.

Lemma perm_sym s t : perm_star s t -> perm_star t s.
Proof.
elim=>{}s {}t; first by move=>->; apply: perm_refl.
move=>w [a b {}s {}t Hab] Htw Hwt.
apply: (perm_trans Hwt).
apply: (perm_cons).
- by apply: perm_swap; rewrite ind_sym.
by apply: perm_refl.
Qed.

Lemma append_perm' s t (c : A) : perm s t -> perm (rcons s c) (rcons t c).
Proof.
case=>a b {}s {}t H.
by rewrite -!cats1 -!catA; apply: perm_swap.
Qed.

Lemma append_perm s t (c : A) : perm_star s t -> perm_star (rcons s c) (rcons t c).
Proof.
elim=>{}s {}t; first by move=>->; apply: perm_refl.
move=>w Ht _ IH.
by apply/perm_cons/IH; apply: append_perm'.
Qed.

Lemma prepend_perm' s t (c : A) : perm s t -> perm (c::s) (c::t).
Proof.
case=>a b {}s {}t H.
by rewrite -!cat_cons; apply: perm_swap.
Qed.

Lemma prepend_perm s t (c : A) : perm_star s t -> perm_star (c::s) (c::t).
Proof.
elim=>{}s {}t; first by move=>->; apply: perm_refl.
move=>w Ht _ IH.
by apply/perm_cons/IH; apply: prepend_perm'.
Qed.

Lemma perm_size' u v : perm u v -> size u = size v.
Proof.
by case=>a b {}u {}v H /=; rewrite !size_cat.
Qed.

Lemma perm_size u v : perm_star u v -> size u = size v.
Proof.
elim=>{}u {}v; first by move=>->.
by move=>w /perm_size' <-.
Qed.

Lemma perm_size2 u v : perm u v -> 2 <= size u.
Proof.
by case=>a b {}u {}v H; rewrite size_cat /= !addnS.
Qed.

Corollary perm_nil xs : ~ perm [::] xs.
Proof. by move/perm_size2. Qed.

Corollary perm_single a xs : ~ perm [::a] xs.
Proof. by move/perm_size2. Qed.

(* contribute to mathcomp? *)
Lemma rem_cat {T : eqType} (x : T) s t :
  rem x (s ++ t) = if x \in s then rem x s ++ t else s ++ rem x t.
Proof.
rewrite !remE index_cat; case: ifP=>Hx.
- rewrite !takel_cat; try by exact: index_size.
  rewrite drop_cat; case: ltnP=>Hs.
  - by rewrite catA.
  rewrite -index_mem in Hx.
  have ->: (index x s).+1 = size s by apply/eqP; rewrite eqn_leq Hx.
  by rewrite subnn !drop0 drop_size cats0.
by rewrite take_cat drop_cat !ltnNge -addnS !leq_addr /= -!addnBAC // subnn !add0n catA.
Qed.

Lemma rem_perm c x y : perm x y -> perm_star (rem c x) (rem c y).
Proof.
case=>a b {}x {}y H.
rewrite !rem_cat; case: ifP=>Hx.
- by apply/perm_to_perm_star/perm_swap.
case: ifP; rewrite !inE=>Hab.
- move: (Hab); rewrite orbC=>->.
  suff: rem c [:: a; b] = rem c [:: b; a] by move=>->; apply: perm_refl.
  by move: Hab; case/orP=>/= /eqP->; rewrite eq_refl; case: ifP=>// /eqP->.
case: ifP=>[|_]; last by apply/perm_to_perm_star/perm_swap.
by case/orP=>E; rewrite E //= orbT in Hab.
Qed.

Lemma rem_perm_star c x y : perm_star x y -> perm_star (rem c x) (rem c y).
Proof.
elim=>{}x {}y; first by move=>->; apply: perm_refl.
move=>w H _ IH; apply/perm_trans/IH.
by apply: rem_perm.
Qed.

Corollary hd_diff_perm_star a b c w z :
  perm_star [::a;b;w] [::b;c;z] -> perm_star [::a;w] [::c;z].
Proof.
move/(rem_perm_star b)=>/=; rewrite eq_refl.
by case: eqP=>//->.
Qed.

Lemma tail_perm u v c : perm (c::u) (c::v) -> perm u v.
Proof.
move=>H; case: {-1}_ {-1}_ / H (erefl (c::u)) (erefl (c::v))=>a b s t H.
case: s=>[|h s]/=; case=>->->; case.
- move=>E; rewrite E in H.
  by move: (ind_irr b); rewrite H.
by move=>->; apply: perm_swap.
Qed.

Corollary tail_perm_star u v c : perm_star (c::u) (c::v) -> perm_star u v.
Proof. by move/(rem_perm_star c)=>/=; rewrite eq_refl. Qed.

Lemma catl_perm_star s t u : perm_star s t -> perm_star (s ++ u) (t ++ u).
Proof.
elim: u=>[|h u IH] in s t *; first by rewrite !cats0.
move=>H; rewrite -cat1s !catA !cats1; apply: IH.
by apply: append_perm.
Qed.

Lemma catr_perm_star s t u : perm_star s t <-> perm_star (u ++ s) (u ++ t).
Proof.
elim: u=>[|h u IH]; first by rewrite !cat0s.
split=>/=.
- by move/IH; exact: prepend_perm.
by move/tail_perm_star/IH.
Qed.

Lemma cat_perm_star s t u v :
  perm_star s t -> perm_star u v ->
  perm_star (s ++ u) (t ++ v).
Proof.
move=>H1 H2; apply: (perm_trans (t:=s++v)).
- by move/(catr_perm_star _ _ s): H2.
by apply: catl_perm_star.
Qed.

Lemma step_perm s a : all (ind^~ a) s -> perm_star (rcons s a) (a::s).
Proof.
elim: s=>/=[_|h t IH]; first by apply: perm_refl.
case/andP=>Ha /IH /(prepend_perm h) H; apply: (perm_trans H).
rewrite (_ : [::h, a & t] = [::] ++ [::h;a] ++ t) //
        (_ : [::a, h & t] = [::] ++ [::a;h] ++ t) //.
by apply/perm_to_perm_star/perm_swap.
Qed.

(* TODO perm_eq + pairwise ind? *)

End Traces.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal84.

Set Printing Depth 1000.
Definition lfind_eval  x y:=
mult y x.

Compute lfind_eval  (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Zero) (Zero).


Require Import basic.
Require Import Sublogic.

(** In this file we show that Coq universes allows to build
   Grothendieck universes.
   We take two copies of the set type, and we embed the
   "big set" of all the "small sets" (that we call U),
   and we show that U is a Grothendieck universe.
 *)

Module BuildUniverse (L:SublogicTheory).

Import L.

Require EnsEm0.
Require EnsEm.
Module S := EnsEm0.Ensembles L. (* small sets *)
Module B := EnsEm.Ensembles L. (* big sets *)

Notation "x ∈ y" := (B.in_set x y) (at level 60).
Notation "x == y" := (B.eq_set x y) (at level 70).

(** This definition implies that the universe of indexes of small
   sets is lower than (or equal to) the universes of indexes of
   large sets (Ens0.Tlo <= Ens.Tlo)
 *)
Fixpoint injU (a:S.set) : B.set :=
  match a with
    S.sup X f => B.sup X (fun i => injU (f i))
  end.

Lemma lift_eq : forall x y, S.eq_set x y -> injU x == injU y.
intros.
revert x y H.
induction x; destruct y; simpl; intros.
destruct H0.
split; intros.
 Tdestruct (H0 i).
 Texists x.
 apply H; trivial.

 Tdestruct (H1 j).
 Texists x.
 apply H; trivial.
Qed.

Lemma down_eq : forall x y, injU x == injU y -> S.eq_set x y.
intros.
revert x y H.
induction x; destruct y; simpl; intros.
destruct H0.
split; intros.
 Tdestruct (H0 i).
 Texists x; auto.

 Tdestruct (H1 j).
 Texists x; auto.
Qed.

Lemma lift_in : forall x y, S.in_set x y -> injU x ∈ injU y.
destruct y; simpl; intros.
Tdestruct H; simpl in *.
apply lift_eq in H.
Texists x0.
assumption.
Qed.

Lemma down_in : forall x y, injU x ∈ injU y -> S.in_set x y.
destruct y; simpl; intros.
Tdestruct H.
simpl in H.
Texists x0.
apply down_eq; trivial.
Qed.

Lemma down_in_ex  x y y' :
  y == injU y' ->
  x ∈ y ->
  Tr(exists2 x', x == injU x' & S.in_set x' y').
intros.
specialize B.eq_elim with (1:=H0) (2:=H); intro.
Tdestruct H1.
destruct y' as (Y,f).
simpl in x0, H1.
Texists (f x0); trivial.
apply down_in.
apply B.eq_elim with y; trivial.
apply B.in_reg with x; trivial.
Qed.

(** Now the universe of small sets is lower than (or equal to)
   the universe of indexes of big sets (Ens0.Thi <= Ens.Tlo).
 *)
Definition U : B.set := B.sup S.set injU.

Lemma U_elim : forall x, x ∈ U -> Tr(exists x', x == injU x').
intros.
Tdestruct H.
Texists x0; trivial.
Qed.

Lemma U_intro : forall x, injU x ∈ U.
red; intros.
Texists x.
apply B.eq_set_refl.
Qed.

Lemma injU_elim : forall x y, x ∈ injU y -> x ∈ U.
destruct y; simpl; intros.
Tdestruct H.
Texists (f x0).
assumption.
Qed.

(** Equivalence of all set-theoretical constructions *)

Lemma pair_equiv : forall x y,
  B.pair (injU x) (injU y) == injU (S.pair x y).
intros.
unfold B.pair, S.pair; simpl.
split; intros.
 Texists i; destruct i; apply B.eq_set_refl.
 Texists j; destruct j; apply B.eq_set_refl.
Qed.

Lemma union_equiv : forall x, B.union (injU x) == injU (S.union x).
intros.
apply B.eq_intro; intros.
 apply B.union_ax in H.
 Tdestruct H.
 apply down_in_ex with (1:=B.eq_set_refl _) in H0.
 Tdestruct H0.
 apply down_in_ex with (1:=H0) in H; Tdestruct H.
 apply B.in_reg with (injU x2).
  apply B.eq_set_sym; trivial.
 apply lift_in.
 rewrite S.union_ax.
 Texists x1; trivial.

 rewrite B.union_ax.
 apply down_in_ex with (1:=B.eq_set_refl _) in H; Tdestruct H.
 rewrite S.union_ax in H0; Tdestruct H0.
 apply lift_in in H0.
 apply lift_in in H1.
 Texists (injU x1); trivial.
 apply B.in_reg with (injU x0); trivial.
 apply B.eq_set_sym; trivial.
Qed.

Lemma subset_equiv : forall x P Q,
  (forall x y, y == injU x -> (P x <-> Q y)) ->
  injU (S.subset x P) == B.subset (injU x) Q.
intros.
unfold S.subset, B.subset.
destruct x; simpl.
split; intros.
 destruct i as (i,spec); simpl in *.
 assert (Tr(exists2 x', injU (f i) == x' & Q x')).
  Tdestruct spec.
  Texists (injU x).
   apply lift_eq; trivial.
   rewrite <- (H x); trivial.
   apply B.eq_set_refl.
 Texists (B.mkSi (B.sup X (fun i => injU(f i))) _ i H0); simpl.
 apply B.eq_set_refl.

 destruct j as (j,h); simpl in j, h.
 assert (Tr(exists2 x', S.eq_set (f j) x' & P x')).
  Tdestruct h.
  Texists (f j).
   apply S.eq_set_refl.
   rewrite (H (f j) x); trivial.
   apply B.eq_set_sym; trivial.
 Texists (S.mkSi (S.sup X f) _ j H0); simpl.
 apply B.eq_set_refl.
Qed.

Lemma power_equiv : forall x, B.power (injU x) == injU (S.power x).
intros.
apply B.eq_intro; intros.
 rewrite B.power_ax in H.
 apply B.in_reg with (injU (S.subset x (fun x' => injU x' ∈ z))).
  apply B.eq_set_trans with (B.subset (injU x) (fun x' => x' ∈ z)).
   apply subset_equiv; intros.
   split; intros.
    apply B.in_reg with (injU x0); trivial.
    apply B.eq_set_sym; trivial.

    apply B.in_reg with y; trivial.

   apply B.eq_intro; intros.
    rewrite B.subset_ax in H0.
    destruct H0.
    Tdestruct H1.
    apply B.in_reg with x0; trivial.
    apply B.eq_set_sym; trivial.

    rewrite B.subset_ax.
    split; auto.
    Texists z0; trivial.
    apply B.eq_set_refl.

  apply lift_in.
  rewrite S.power_ax; intros.
  rewrite S.subset_ax in H0.
  destruct H0; trivial.

 rewrite B.power_ax; intros.
 specialize injU_elim with (1:=H); intro.
 apply U_elim in H1.
 Tdestruct H1.
 assert (y ∈ injU x0).
  apply B.eq_elim with z; trivial.
 specialize injU_elim with (1:=H2); intro.
 apply U_elim in H3.
 Tdestruct H3.
 apply B.in_reg with (injU x1).
  apply B.eq_set_sym; trivial.

  apply lift_in.
  assert (S.in_set x0 (S.power x)).
   apply down_in.
   apply B.in_reg with z; trivial.
  rewrite S.power_ax in H4.
  apply H4.
  apply down_in.
  apply B.in_reg with y; trivial.
Qed.

Lemma repl1_equiv : forall x f a F,
  a == injU x ->
  (forall x x', proj1_sig x' == injU (proj1_sig x) -> F x' == injU (f x)) ->
  B.repl1 a F == injU (S.repl1 x f).
destruct x; intros.
destruct a as (A,g); simpl in H.
destruct H.
split; simpl; intros.
 Tdestruct (H i).
 Texists x; simpl.
 apply H0; simpl; trivial.

 Tdestruct (H1 j).
 Texists x; simpl.
 apply H0; simpl; trivial.
Qed.

(** Closure properties of U *)

Lemma U_trans : forall x y, y ∈ x -> x ∈ U -> y ∈ U.
intros.
apply U_elim in H0; Tdestruct H0.
assert (y ∈ injU x0).
 apply B.eq_elim with x; trivial.
apply injU_elim in H1; trivial.
Qed.

Lemma U_pair : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U.
intros.
apply U_elim in H; Tdestruct H.
apply U_elim in H0; Tdestruct H0.
apply B.in_reg with (injU (S.pair x0 x1)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.pair (injU x0) (injU x1)).
  apply B.pair_morph; trivial.

  apply pair_equiv.

 apply U_intro.
Qed.

Lemma U_power : forall x, x ∈ U -> B.power x ∈ U.
intros.
apply U_elim in H; Tdestruct H.
apply B.in_reg with (injU (S.power x0)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.power (injU x0)).
  apply B.power_morph; trivial.

  apply power_equiv.

 apply U_intro.
Qed.

Lemma U_union : forall x, x ∈ U -> B.union x ∈ U.
intros.
apply U_elim in H; Tdestruct H.
apply B.in_reg with (injU (S.union x0)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.union (injU x0)).
  apply B.union_morph; trivial.

  apply union_equiv.

 apply U_intro.
Qed.

Axiom intuit : forall P, Tr P -> P.

Lemma U_repl : forall a R,
  Proper (B.eq_set==>B.eq_set==>iff) R ->
  a ∈ U ->
  (forall x y y', x ∈ a -> y ∈ U -> y' ∈ U ->
   R x y -> R x y' -> y == y') ->
  Tr(exists2 b, b ∈ U & forall y, y ∈ U ->
                         (y ∈ b <-> Tr(exists2 x, x ∈ a & R x y))).
intros.
apply U_elim in H0; Tdestruct H0.
(* replacement on small sets *)
refine (let (b,Hb) := S.intuit_repl_ax intuit
          x (fun x y => R (injU x) (injU y)) _ _ in _).
 intros.
 revert H5; apply iff_impl; apply H; apply lift_eq; trivial.

 intros.
 apply down_eq.
 apply H1 with (injU x0); trivial.
  apply B.eq_set_sym in H0.
  apply B.eq_elim with (injU x); trivial.
  apply lift_in; trivial.

  apply U_intro.

  apply U_intro.

 Texists (injU b).
  apply U_intro.

  split; intros.
   apply U_elim in H2; Tdestruct H2.
   generalize (B.in_reg _ _ _ H2 H3); intro.
   apply down_in in H4.
   rewrite Hb in H4.
   Tdestruct H4.
   Texists (injU x1); trivial.
    apply lift_in in H4.
    apply B.eq_set_sym in H0.
    apply B.eq_elim with (injU x); trivial.

    revert H5; apply iff_impl; apply H; trivial.
    apply B.eq_set_refl.
    apply B.eq_set_sym; trivial.

  Tdestruct H3.
  specialize B.eq_elim with (1:=H3) (2:=H0); intro.
  specialize injU_elim with (1:=H5); intro.
  apply U_elim in H6; Tdestruct H6.
  generalize (B.in_reg _ _ _ H6 H5); intro.
  apply down_in in H7.
  apply U_elim in H2; Tdestruct H2.
  apply B.eq_set_sym in H2.
  apply B.in_reg with (injU x2); trivial.
  apply lift_in.
  rewrite Hb.
  Texists x1; trivial.
  revert H4; apply iff_impl; apply H; trivial.
  apply B.eq_set_sym; trivial.
Qed.

(* If the small sets are closed under collection, then so
   is U. *)
Lemma U_coll : forall a R,
  Proper (B.eq_set==>B.eq_set==>iff) R ->
  a ∈ U ->
  (forall x, x ∈ a -> Tr(exists2 y, y ∈ U & R x y)) ->
  Tr(exists2 b, b ∈ U & forall x, x ∈ a -> Tr(exists2 y, y ∈ b & R x y)).
intros.
apply U_elim in H0; Tdestruct H0 as (a',?).
(* We use collection on small sets *)
destruct S.collection_ax with a' (fun x y => R (injU x) (injU y)) as (B,HB).
 do 3 red; intros.
 apply H; apply lift_eq; trivial.

 Texists (injU B).
  apply U_intro.
 intros.
 Tdestruct (H1 _ H2).
 apply down_in_ex with (1:=H0) in H2.
 Tdestruct H2.
 refine (let h := HB _ H5 _ in _).
  apply U_elim in H3; Tdestruct H3.
  Texists x2.
  revert H4; apply H; apply B.eq_set_sym; trivial.
 Tdestruct h.
 Texists (injU x2).
  apply lift_in; trivial.

  revert H7; apply H; trivial.
  apply B.eq_set_refl.
Qed.

(** Grothendieck universe *)
Record grot_univ (U:B.set) : Prop := {
  G_trans : forall x y, y ∈ x -> x ∈ U -> y ∈ U;
  G_pair : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U;
  G_power : forall x, x ∈ U -> B.power x ∈ U;
  G_union : forall x, x ∈ U -> B.union x ∈ U;
  G_repl : forall a R, Proper (B.eq_set==>B.eq_set==>iff) R ->
           a ∈ U ->
           (forall x y y', x ∈ a -> y ∈ U -> y' ∈ U -> R x y -> R x y' -> y == y') ->
           Tr(exists2 b, b ∈ U & forall y, y ∈ U -> (y ∈ b <-> Tr(exists2 x, x ∈ a & R x y))) }.

Lemma U_univ : grot_univ U.
constructor.
 apply U_trans.
 apply U_pair.
 apply U_power.
 apply U_union.
 apply U_repl.
Qed.

(** Weak Grothendieck universe: closure only under
   *functional* replacement. We still need relational replacement.
 *)
Record grot_univ1 (U:B.set) : Prop := {
  G_trans1 : forall x y, y ∈ x -> x ∈ U -> y ∈ U;
  G_pair1 : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U;
  G_power1 : forall x, x ∈ U -> B.power x ∈ U;
  G_union_repl1 : forall I F,
                 (forall x x', proj1_sig x == proj1_sig x' -> F x == F x') ->
                 I ∈ U ->
                 (forall x, F x ∈ U) ->
                 B.union (B.repl1 I F) ∈ U }.

Lemma U_univ1 : grot_univ1 U.
constructor.
 apply U_trans.
 apply U_pair.
 apply U_power.

 intros.
 apply U_elim in H0; Tdestruct H0.
 assert (forall z, S.in_set z x -> injU z ∈ I).
  intros.
  apply B.eq_set_sym in H0.
  apply B.eq_elim with (injU x); trivial.
  apply lift_in; trivial.
 (* We have F producing big sets in U, and we need a function producing
    small sets to use functional replacement on small sets. We're stuck
    again. Relational replacement does it.
  *)
 destruct S.intuit_repl_ax with x
         (fun x' y => exists h:injU x' ∈ I, F (B.eli I _ h) == injU y)
   as (B,HB).
  exact intuit.

  intros.
  destruct H6.
  assert (injU x' ∈ I).
   apply B.eq_elim with (injU x).
   2:apply B.eq_set_sym; trivial.
   apply lift_in.
   apply S.in_reg with x0; trivial.
  exists H7.
  apply lift_eq in H5.
  apply B.eq_set_trans with (2:=H5).
  apply B.eq_set_trans with (2:=H6).
  apply H; simpl.
  apply lift_eq; apply S.eq_set_sym; trivial.

  intros.
  destruct H4; destruct H5.
  apply down_eq.
  apply B.eq_set_trans with (1:=B.eq_set_sym _ _ H4).
  apply B.eq_set_trans with (2:=H5).
  apply H; simpl; apply B.eq_set_refl.

  apply B.in_reg with (injU (S.union B)).
  2:apply U_intro.
  apply B.eq_set_sym.
  apply B.eq_set_trans with (2:=union_equiv B).
  apply B.union_morph.
  apply B.eq_set_ax; split; intros.
   apply B.repl1_ax in H3; trivial.
   Tdestruct H3.
   Tdestruct (U_elim _ (H1 x0)).
   apply B.in_reg with (injU x1).
    apply B.eq_set_sym; apply B.eq_set_trans with (F x0); trivial.

    apply lift_in.
    rewrite HB.
    Tdestruct (down_in_ex _ _ _ H0 (proj2_sig x0)).
    Texists x2; trivial.
    exists (H2 _ H6).
    apply B.eq_set_trans with (2:=H4).
    apply H; simpl.
    apply B.eq_set_sym; trivial.

   apply down_in_ex with (1:=B.eq_set_refl _) in H3.
   Tdestruct H3.
   rewrite HB in H4; clear HB.
   Tdestruct H4.
   destruct H5.
   rewrite B.repl1_ax; trivial.
   Texists (B.eli I (injU x1) x2).
   apply B.eq_set_trans with (1:=H3).
   apply B.eq_set_sym; trivial.
Qed.

End BuildUniverse.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_extension.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_layoff.
Require Import ProofCheckingEuclid.lemma_layoffunique.
Require Import ProofCheckingEuclid.lemma_onray_assert.
Require Import ProofCheckingEuclid.lemma_onray_orderofpoints_any.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_BCD.
Require Import ProofCheckingEuclid.lemma_s_lt.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_bets_ABE.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_bets_AEB.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_lessthantransitive :
	forall A B C D E F,
	Lt A B C D ->
	Lt C D E F ->
	Lt A B E F.
Proof.

	intros A B C D E F.
	intros Lt_AB_CD.
	intros Lt_CD_EF.

	destruct Lt_AB_CD as (G & BetS_C_G_D & Cong_CG_AB).
	destruct Lt_CD_EF as (H & BetS_E_H_F & Cong_EH_CD).
	pose proof (lemma_betweennotequal _ _ _ BetS_E_H_F) as (_ & neq_E_H & _).
	pose proof (lemma_betweennotequal _ _ _ BetS_C_G_D) as (neq_G_D & neq_C_G & neq_C_D).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_EH_CD) as Cong_CD_EH.

	pose proof (lemma_s_onray_assert_bets_ABE _ _ _ BetS_C_G_D neq_C_G) as OnRay_CG_D.
	pose proof (lemma_s_onray_assert_bets_AEB _ _ _ BetS_C_G_D neq_C_D) as OnRay_CD_G.
	pose proof (lemma_s_onray_assert_ABB _ _ neq_C_G) as OnRay_CG_G.

	pose proof (lemma_layoff _ _ _ _ neq_E_H neq_C_G) as (K & OnRay_EH_K & Cong_EK_CG).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_EK_CG) as Cong_CG_EK.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_EK_CG Cong_CG_AB) as Cong_EK_AB.
	pose proof (lemma_onray_orderofpoints_any _ _ _ OnRay_EH_K) as BetS_E_K_H_or_eq_H_K_or_BetS_E_H_K.

	assert (BetS E K H) as BetS_E_K_H.
	destruct BetS_E_K_H_or_eq_H_K_or_BetS_E_H_K as [BetS_E_K_H|[eq_H_K|BetS_E_H_K]].
	{
		(* case BetS_E_K_H *)
		exact BetS_E_K_H.
	}
	{
		(* case eq_H_K *)
		assert (Cong C G E H) as Cong_CG_EH by (rewrite eq_H_K; exact Cong_CG_EK).

		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_CG_EH Cong_EH_CD) as Cong_CG_CD.
		pose proof (lemma_layoffunique _ _ _ _ OnRay_CG_G OnRay_CG_D Cong_CG_CD) as eq_G_D.

		contradict eq_G_D.
		exact neq_G_D.
	}
	{
		(* case BetS_E_H_K *)
		pose proof (lemma_betweennotequal _ _ _ BetS_E_H_K) as (neq_H_K & _ & _).
		pose proof (lemma_extension _ _ _ _ neq_C_D neq_H_K) as (J & BetS_C_D_J & Cong_DJ_HK).
		pose proof (lemma_s_onray_assert_bets_ABE _ _ _ BetS_C_D_J neq_C_D) as OnRay_CD_J.
		pose proof (cn_sumofparts _ _ _ _ _ _ Cong_CD_EH Cong_DJ_HK BetS_C_D_J BetS_E_H_K) as Cong_CJ_EK.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_CJ_EK Cong_EK_CG) as Cong_CJ_CG.
		pose proof (lemma_layoffunique _ _ _ _ OnRay_CD_J OnRay_CD_G Cong_CJ_CG) as eq_J_G.

		pose proof (lemma_orderofpoints_ABC_ACD_BCD _ _ _ _ BetS_C_G_D BetS_C_D_J) as BetS_G_D_J.
		pose proof (lemma_betweennotequal _ _ _ BetS_G_D_J) as (_ & _ & neq_G_J).
		pose proof (lemma_inequalitysymmetric _ _ neq_G_J) as neq_J_G.

		contradict eq_J_G.
		exact neq_J_G.
	}

	pose proof (lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_E_K_H BetS_E_H_F) as BetS_E_K_F.
	pose proof (lemma_s_lt _ _ _ _ _ BetS_E_K_F Cong_EK_AB) as Lt_AB_EF.

	exact Lt_AB_EF.
Qed.

End Euclid.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

Inductive id : Type :=
| Id: string -> id.

Definition beq_id (a b: id) : bool :=
  match a, b with
  | Id a', Id b' => if string_dec a' b' then true else false
  end.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intros [x'].
  simpl.
  destruct (string_dec x' x').
  - reflexivity.
  - destruct n. reflexivity.
Qed.

Theorem beq_id_true_iff : forall x y : id,
  beq_id x y = true <-> x = y.
Proof.
  intros [x'] [y'].
  unfold beq_id.
  destruct (string_dec x' y').
  - rewrite -> e.
    split.
    + reflexivity.
    + reflexivity.
  - split.
    + intros. inversion H.
    + intros. inversion H. destruct n. apply H1.
Qed.

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false <->
  x <> y.
Proof.
  intros.
  rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false.
  reflexivity.
Qed.

Theorem false_beq_id : forall x y : id,
   x <> y ->
   beq_id x y = false.
Proof.
  intros.
  rewrite -> beq_id_false_iff.
  apply H.
Qed.

Definition total_map (A: Type) := id -> A.

Definition t_empty {A: Type} (v: A) : total_map A :=
  fun (_ : id) => v.

Definition t_update {A: Type} (m: total_map A) (k: id) (v: A) : total_map A :=
  fun (x : id) => if beq_id k x then v else m x.

Definition examplemap :=
  t_update (t_update (t_empty false) (Id "foo") false)
           (Id "bar") true.

Example update_example1 : examplemap (Id "baz") = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id "foo") = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id "quux") = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id "bar") = true.
Proof. reflexivity. Qed.

Lemma t_apply_empty: forall A x v, @t_empty A v x = v.
Proof.
  intros.
  unfold t_empty. reflexivity.
Qed.

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  intros.
  unfold t_update.
  rewrite <- beq_id_refl.
  reflexivity.
Qed.

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros.
  apply false_beq_id in H.
  unfold t_update.
  rewrite -> H.
  reflexivity.
Qed.

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality_dep.
  intros.
  destruct (beq_id x x0).
  + reflexivity.
  + reflexivity.
Qed.

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros.
  apply iff_reflect.
  rewrite <- beq_id_true_iff.
  reflexivity.
Qed.

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality_dep.
  intros.
  destruct (beq_idP x x0).
  + rewrite -> e. reflexivity.
  + reflexivity.
Qed.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality_dep.
  intros.
  destruct (beq_idP x1 x).
  - destruct (beq_idP x2 x).
    + exfalso. apply H. rewrite e, e0. reflexivity.
    + reflexivity.
  - destruct (beq_idP x2 x).
    + reflexivity.
    + reflexivity.
Qed.

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A: Type} : partial_map A :=
  t_empty None.

Definition update {A: Type} (m: partial_map A) (k: id) (v: A) :=
  t_update m k (Some v).

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty. reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq. reflexivity.
Qed.

Lemma update_neq : forall A (m: partial_map A) x1 x2 v,
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros. unfold update. rewrite t_update_neq.
  - reflexivity.
  - apply H.
Qed.

Lemma update_shadow : forall A (m: partial_map A) x v1 v2,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros. unfold update. rewrite t_update_shadow. reflexivity.
Qed.

Lemma update_same : forall A (m: partial_map A) x v,
  m x = Some v ->
  update m x v = m.
Proof.
  intros. unfold update. rewrite <- H. rewrite t_update_same. reflexivity.
Qed.

Lemma update_permute : forall A (m: partial_map A) x1 x2 v1 v2,
  x2 <> x1 ->
  (update (update m x2 v2) x1 v1) =
  (update (update m x1 v1) x2 v2).
Proof.
  intros. unfold update. rewrite t_update_permute.
  - reflexivity.
  - apply H.
Qed.