Require Import MSets.
Require Import SimpleUndirectedGraphs DirectedGraphs_morph.

(* If things turn out ok in this file it doesn't seem hard to
   integrate everything with maxind *)

Module independentSets (DG : SimpleUndirectedGraphs).
  Import DG.
  Module DG_Facts := DirectedGraphMorph DG.
  Module vert_prop := WProperties (Vertices).
  Module vertFacts := OrderedTypeFacts Vertices.E.

  (* Prop and bool definitions of an Independent Set with respect to a
      Graph
   *)
  Definition IndependentSet (X : Vertices.t) (G : t) :=
    forall x y, Vertices.In x X -> Vertices.In y X ->
                ~ Edges.In (buildEdge x y) (DG.enumEdges G).

  Definition independentSet (X : Vertices.t) (G : t) :=
    Vertices.for_all (fun v1 => Vertices.for_all
    (fun v2 => negb (Edges.mem (buildEdge v1 v2) (enumEdges G))) X) X.

  Lemma annoyingProperV2 :
    forall v1 G,  Proper (Vertices.E.eq ==> eq)
     (fun v2 : vertex =>
      negb (Edges.mem (buildEdge v1 v2) (enumEdges G))).
  Proof.
    intros.
    unfold Proper.
    unfold respectful.
    intros x y H.
    erewrite buildEdge_spec; try reflexivity;
    auto.
  Qed.

  Lemma proper_aux : forall x0 G y0 X, x0 =v= y0 ->
       Vertices.For_all
         (fun x : vertex =>
            negb (Edges.mem (buildEdge x0 x) (enumEdges G)) = true) X
  ->
Vertices.for_all
     (fun v2 : vertex =>
      negb (Edges.mem (buildEdge x0 v2) (enumEdges G))) X = true.

  Proof.
    intros.
    apply Vertices.for_all_spec.
    apply annoyingProperV2.
    unfold Vertices.For_all. intros.
    unfold Vertices.For_all in *; intros.
    apply H0 in H1.
    assert (buildEdge x0 x =e= buildEdge y0 x).
    apply buildEdge_spec; try reflexivity; auto.
    auto.
  Qed.

  Lemma proper_forall_helper :
    forall x0 y0 X G,
      x0 =v= y0 ->
      Vertices.for_all
        (fun v2 : vertex =>
           negb (Edges.mem (buildEdge x0 v2) (enumEdges G))) X =
      Vertices.for_all
        (fun v2 : vertex =>
           negb (Edges.mem (buildEdge y0 v2) (enumEdges G))) X.
  Proof.
    intros.
    case_eq (Vertices.for_all
               (fun v2 : vertex =>
                  negb (Edges.mem (buildEdge x0 v2) (enumEdges G)))X );
      case_eq ( Vertices.for_all
                  (fun v2 : vertex =>
                     negb (Edges.mem (buildEdge y0 v2) (enumEdges G))) X);
      intros; auto.
    apply Vertices.for_all_spec in H1.
    apply not_true_iff_false in H0.
    unfold not in H0.
    exfalso; apply H0.
    apply Vertices.for_all_spec.
    apply annoyingProperV2.
    unfold Vertices.For_all.
    intros.
    apply H1 in H2.
    assert ((buildEdge x0 x) =e= (buildEdge y0 x)).
    apply buildEdge_spec; try reflexivity; auto.
    rewrite <-  H3.
    auto.
    apply annoyingProperV2.
    apply Vertices.for_all_spec in H0.
    apply not_true_iff_false in H1.
    unfold not in H1.
    exfalso; apply H1.
    apply proper_aux with (y0 := y0); auto.
    unfold Vertices.For_all.
    intros.
    apply H0 in H2.
    assert ((buildEdge x0 x) =e= (buildEdge y0 x)).
    apply buildEdge_spec; try reflexivity;
      auto.
    rewrite H3.
    auto.
    apply annoyingProperV2.
  Qed.

  (* This was very annoying I'll try and make stuff look better later *)
  Theorem independentSet_true_iff :
    forall X G,
  reflect (IndependentSet X G) (independentSet X G).
  Proof.
    intros.
    apply iff_reflect.
    symmetry.
    unfold independentSet, IndependentSet.
    split; intros.
    intros Hnot.
    apply Vertices.for_all_spec in H.
    unfold Vertices.For_all in H.
    apply H in H0.
    apply Vertices.for_all_spec in H0.
    unfold Vertices.For_all in H0,H1.
    apply H0 in H1.
    apply Edges.mem_spec in Hnot.
    unfold negb in H1.
    rewrite Hnot in H1.
    inversion H1.
    apply annoyingProperV2.
    unfold Proper.
    unfold respectful.
    intros.
    apply proper_forall_helper.
    auto.
    apply Vertices.for_all_spec.
    unfold Proper.
    unfold respectful.
    intros.
    apply proper_forall_helper.
    auto.
    intros x1 H2.
    apply Vertices.for_all_spec.
    apply annoyingProperV2.
    intros x H1.
    rewrite negb_true_iff.
    apply H with (x := x1) (y := x) in H2; auto.
    rewrite <- Edges.mem_spec in H2.
    apply not_true_is_false in H2.
    auto.
  Qed.

  (* The set contains only those vertices that are in G *)
  Definition ValidSet (X : Vertices.t) (G : t) :=
    forall x, Vertices.In x X -> Vertices.In x (DG.enumVertices G).

  Definition validSet (X : Vertices.t) (G : t) : bool :=
    Vertices.for_all (fun x => if Vertices.mem x X then Vertices.mem x (DG.enumVertices G) else true) X.

  Lemma ProperPifProof : forall X G,  Proper (Vertices.E.eq ==> eq)
     (fun x0 : vertex =>
      if Vertices.mem x0 X
      then Vertices.mem x0 (enumVertices G)
      else true).
  Proof.
    unfold Proper.
    unfold respectful.
    intros.
    destruct (Vertices.mem x X) eqn:H3.
    destruct (Vertices.mem y X) eqn:H4.
    rewrite H.
    auto.
    rewrite <- H in H4.
    apply DG_Facts.VertProperties.P.Dec.F.not_mem_iff in H4.
    apply Vertices.mem_spec in H3.
    apply H4 in H3.
    destruct H3.
    rewrite <- H.
    rewrite H3.
    auto.
  Qed.

  Theorem validSet_true_iff : forall X G, reflect (ValidSet X G)( validSet X G).
  Proof.
    intros.
    apply iff_reflect.
    symmetry.
    unfold validSet, ValidSet.
    split; intros; auto.
    {
      apply Vertices.mem_spec.
      apply Vertices.for_all_spec in H.
      unfold Vertices.For_all in H.
      assert( Vertices.In x X) by auto.
      apply H in H0.
      apply Vertices.mem_spec in H1.
      rewrite H1 in H0.
      auto.
      {
        apply ProperPifProof.
      }
    }
    apply Vertices.for_all_spec.
    {
      apply ProperPifProof.
    }
    intros x H1.
    assert (Vertices.In x X) by auto.
    apply H in H0.
    rewrite <- Vertices.mem_spec in H1,H0.
    rewrite H1; auto.
  Qed.

  Theorem validSetRecr :
    forall x (X : Vertices.t) G,
      ValidSet (Vertices.add x X) G -> ValidSet X G.
  Proof.
    unfold ValidSet. intros.
    apply H.
    apply Vertices.add_spec.
    auto.
  Qed.

  (* An IndSet is an independent set that is valid *)
  Inductive IndSet (X : Vertices.t) (G : t) :=
  | defIndSet : ValidSet X G -> IndependentSet X G -> IndSet X G.

  Definition indSet (X : Vertices.t) (G : t) : bool :=
    validSet X G && independentSet X G.

  Theorem indSet_reflect : forall X G, reflect (IndSet X G) (indSet X G).
  Proof.
    intros.
    apply  iff_reflect.
    unfold indSet.
    assert (reflect (ValidSet X G) (validSet X G)).
    apply validSet_true_iff.
    split; try constructor; intuition.
    destruct (independentSet_true_iff X G);
      destruct (validSet_true_iff X G); auto;
    inversion H0;
    contradiction.
    apply andb_true_iff in H0.
    destruct H0.
    destruct (validSet_true_iff X G); auto.
    inversion H0.
    destruct (independentSet_true_iff X G); auto.
    apply andb_true_iff in H0.
    destruct H0. inversion H1.
  Qed.

  Theorem nilIndSet : IndSet Vertices.empty DG.empty.
  Proof.
    constructor;
      try constructor; try intros x y H; unfold ValidSet; intros;
      try apply vert_prop.Dec.F.empty_iff in H;
      try contradiction.
  Qed.

  Theorem empty_IndSet_spec : forall G, IndSet Vertices.empty G.
  Proof.
    intros.
    constructor.
    unfold ValidSet.
    intros.
    apply vert_prop.Dec.F.empty_iff in H.
    destruct H.
    unfold IndependentSet.
    intros.
    apply vert_prop.Dec.F.empty_iff in H.
    destruct H.
  Qed.

  Theorem nilIndSetAdd : forall x G, Vertices.In x (enumVertices G) ->
                       IndSet (Vertices.add x Vertices.empty) G.
  Proof.
    intros x G H.
    constructor.
    unfold ValidSet.
    intros.
    apply Vertices.add_spec in H0.
    destruct H0.
    rewrite H0.
    auto.
    apply vert_prop.Dec.F.empty_iff in H0; contradiction.
    unfold IndependentSet.
    intros.
    intros Hnot.
    rewrite Vertices.add_spec in H0,H1.
    destruct H0.
    destruct H1.
    rewrite H0 in Hnot.
    rewrite H1 in Hnot.
    apply IsEdgeEnum in Hnot.
    apply edges_irreflexive in Hnot.
    auto.
    apply vert_prop.Dec.F.empty_iff in H1; contradiction.
    apply vert_prop.Dec.F.empty_iff in H0; contradiction.
  Qed.

  Import DG_Facts.
  Add Morphism IndSet
      with signature Vertices.eq ==> EqualGraph ==> iff
        as indSet_morph.
  Proof.
    split; intros; constructor; inversion H1;
      unfold ValidSet, IndependentSet in *; intros.
    {
      intros.
      rewrite  <- H0.
      apply H2.
      rewrite H.
      auto.
    }
    {
      intros.
      rewrite <- H0.
      apply H3;
        rewrite H; auto.
    }
    {
      rewrite  H0.
      apply H2.
      rewrite <- H.
      auto.
    }
    {
      intros.
      rewrite  H0.
      apply H3; rewrite <- H; auto.
    }
    Qed.

  Lemma IndSet_add  : forall x X G, IndSet (Vertices.add x X) G -> IndSet X G.
    Proof.
      intros.
      constructor;
      inversion H.
      unfold ValidSet in *.
      intros.
      apply H0.
      apply Vertices.add_spec.
      intuition.
      unfold IndependentSet in *.
      intros.
      apply H1;
      apply Vertices.add_spec; intuition.
    Qed.

End independentSets.


Theorem t5 : (forall x:nat, S x> x)-> 2>1.
  intros.
  let H':=fresh "H'" in generalize H.
  intros H'. auto. Qed.

Theorem t5' : (forall x:nat, S x>x ) -> 2>1.
  intros H.
  let H':=fresh "H" in apply (H' 1). Qed.


(** Numbers up to @n@ **)
Require Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

(** `fin n` corresponds to "naturals less than `n`",
    i.e. a finite set of size n
 **)
Inductive fin : nat -> Type :=
| F0 : forall {n}, fin (S n)
| FS : forall {n}, fin n -> fin (S n).

Fixpoint fin_all (n : nat) : list (fin n) :=
  match n as n return list (fin n) with
    | 0 => nil
    | S n => @F0 n :: List.map (@FS _) (fin_all n)
  end%list.

Theorem fin_all_In : forall {n} (f : fin n),
  List.In f (fin_all n).
Proof.
  induction n; intros.
  inversion f.
  remember (S n). destruct f.
  simpl; firstorder.
  inversion Heqn0. subst.
  simpl. right. apply List.in_map. auto.
Qed.

Theorem fin_case : forall n (f : fin (S n)),
  f = F0 \/ exists f', f = FS f'.
Proof.
  intros. generalize (fin_all_In f). intros.
  destruct H; auto.
  eapply List.in_map_iff in H. right. destruct H.
  exists x. intuition.
Qed.

Definition fin0_elim (f : fin 0) : forall T, T :=
  match f in fin n return match n with
                            | 0 => forall T, T
                            | _ => unit
                          end with
    | F0 _ => tt
    | FS _ _ => tt
  end.

Fixpoint pf_lt (n m : nat) : Prop :=
  match n , m with
    | 0 , S _ => True
    | S n , S m => pf_lt n m
    | _ , _ => False
  end.

Fixpoint make (m n : nat) {struct m} : pf_lt n m -> fin m :=
  match n as n , m as m return pf_lt n m -> fin m with
    | 0 , 0 => @False_rect _
    | 0 , S n => fun _ => F0
    | S n , 0 => @False_rect _
    | S n , S m => fun pf => FS (make m n pf)
  end.

Notation "'##' n" := (@make _ n I) (at level 0).

Global Instance Injective_FS {n : nat} (a b : fin n)
  : Injective (FS a = FS b).
refine {| result := a = b |}.
abstract (intro ; inversion H ; eapply inj_pair2 in H1 ; assumption).
Defined.

Fixpoint fin_eq_dec {n} (x : fin n) {struct x} : fin n -> bool :=
  match x in fin n' return fin n' -> bool with
    | F0 _ => fun y => match y with
                         | F0 _ => true
                         | _ => false
                       end
    | FS n' x' => fun y : fin (S n') =>
      match y in fin n'' return (match n'' with
                                   | 0 => unit
                                   | S n'' => fin n''
                                 end -> bool) -> bool with
        | F0 _ => fun _ => false
        | FS _ y' => fun f => f y'
      end (fun y => fin_eq_dec x' y)
    end.

Global Instance RelDec_fin_eq (n : nat) : RelDec (@eq (fin n)) :=
{ rel_dec := fin_eq_dec }.

Global Instance RelDec_Correct_fin_eq (n : nat)
  : RelDec_Correct (RelDec_fin_eq n).
Proof.
  constructor.
  induction x. simpl.
  intro. destruct (fin_case y) ; subst.
  intuition.
  destruct H ; subst.
  intuition ; try congruence.
(*  inversion H.*)
  intro ; destruct (fin_case y) ; subst ; simpl.
  intuition ; try congruence.
  inversion H.
  destruct H ; subst.
  split ; intro.
  f_equal ; eauto.
  eapply IHx.
  eapply H.
  inv_all ; subst.
  apply IHx. reflexivity.
Qed.


Require Import FP.CoreData.
Require Import FP.CoreClasses.

Import FunctionNotation.
Import ProperNotation.
Import EqvNotation.

Class Applicative t :=
  { fret : forall {A}, A -> t A
  ; fapply : forall {A B}, t (A -> B) -> t A -> t B
  }.
Arguments fret {t Applicative A} _ : simpl never.
Arguments fapply {t Applicative A B} _ _ : simpl never.

Section Applicative.
  Context {t} `{! Applicative t }.

  Definition fapply_fmap {A B} : (A -> B) -> t A -> t B :=
    fapply '.' fret.
  Definition fapply_ftimes {A B} (aT:t A) (bT:t B) : t (A*B) :=
    fapply (fapply (fret pair) aT) bT.
End Applicative.
Arguments fapply_fmap {t _ A B} _ _ / .
Arguments fapply_ftimes {t _ A B} _ _ / .

Module ApplicativeNotation.
  Infix "<@>" := fapply (at level 47, left associativity).
End ApplicativeNotation.

Section ApplicativeWF.
  Context {t} `{! Applicative t ,! F_Eqv t ,! F_PER_WF t }.

  Class ApplicativeWF :=
    { Applicative_unit :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          (aT:t A) `{! Proper eqv aT },
        fapply (fret id) aT ~= aT
    ; Applicative_composition :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          {C} `{! Eqv C ,! PER_WF C }
          (fT:t (A -> B)) `{! Proper eqv fT}
          (gT:t (B -> C)) `{! Proper eqv gT}
          (aT:t A) `{! Proper eqv aT },
        fapply gT (fapply fT aT)
        ~= fapply (fapply (fapply (fret compose) gT) fT) aT
    ; Applicative_homomorphism :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          (f:A -> B) `{! Proper eqv f }
          (a:A) `{! Proper eqv a },
        fapply (fret f) (fret a) ~= fret (f a)
    (* is this derivable? necessary? *)
    ; Applicative_interchange :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          (fT:t (A -> B)) `{! Proper eqv fT }
          (a:A) `{! Proper eqv a },
        fapply fT (fret a) ~= fapply (fret (apply_to a)) fT
    ; fret_Proper :>
        forall {A} `{! Eqv A ,! PER_WF A },
        Proper eqv (fret (A:=A))
    ; fapply_Proper :>
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B },
        Proper eqv (fapply (A:=A) (B:=B))
    }.
End ApplicativeWF.
Arguments ApplicativeWF t {_ _}.
Hint Extern 9 (Proper eqv (fret (t:=?t) (A:=?A))) =>
  let H := fresh "H" in
  pose (H:=(fret_Proper (t:=t) (A:=A))) ; apply H
  : typeclass_instances.
Hint Extern 9 (Proper eqv (fapply (t:=?t) (A:=?A) (B:=?B))) =>
  let H := fresh "H" in
  pose (H:=(fapply_Proper (t:=t) (A:=A) (B:=B))) ; apply H
  : typeclass_instances.


Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.Morphisms.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.Equivalence_ext.
Require Import CertiGraph.lib.EquivDec_ext.

Definition app_sig {A B: Type} (P: A -> Prop) (f: A -> B): sig P -> B := fun a => f (proj1_sig a).

Definition guarded_pointwise_relation {A B : Type} (P: A -> Prop) (R : relation B) : relation (A -> B) :=
  respectful_relation (app_sig P) (pointwise_relation (sig P) R).

Definition is_rev_fun {A B: Type} (P: A -> Prop) (f: A -> B) (g: B -> option A) :=
  forall b,
  match g b with
  | Some a0 => P a0 /\ forall a, P a -> (f a = b <-> a = a0)
  | None => forall a, P a -> f a <> b
  end.

Definition is_guarded_inj {A B: Type} (P: A -> Prop) (f: A -> B) :=
  exists g: B -> option A, is_rev_fun P f g.
(* forall a1 a2: A, P a1 -> P a2 -> f a1 = f a2 -> a1 = a2. *)
(* This commented definition is weaker. *)

Instance guarded_pointwise_equivalence {A B : Type} (P: A -> Prop) {R : relation B} {EqR: Equivalence R}: Equivalence (guarded_pointwise_relation P R).
Proof.
  apply resp_Equivalence.
  apply pointwise_equivalence.
  auto.
Defined.

Definition guarded_pointwise_relation_spec: forall {A B : Type} (P: A -> Prop) (R : relation B) f g, guarded_pointwise_relation P R f g <-> (forall x: A, P x -> R (f x) (g x)).
Proof.
  intros.
  unfold guarded_pointwise_relation, respectful_relation, app_sig, pointwise_relation.
  split; intros.
  + specialize (H (exist P x H0)).
    exact H.
  + destruct a.
    specialize (H x p).
    exact H.
Qed.

Lemma guarded_pointwise_relation_weaken: forall {A B : Type} (P1 P2: A -> Prop) (R : relation B), Included P2 P1 -> inclusion _ (guarded_pointwise_relation P1 R) (guarded_pointwise_relation P2 R).
Proof.
  intros.
  hnf; intros.
  rewrite guarded_pointwise_relation_spec in H0 |- *.
  unfold Included, In in H.
  firstorder.
Qed.

Lemma guarded_pointwise_relation_pointwise_relation: forall {A B : Type} (P: A -> Prop) (R : relation B), inclusion _ (pointwise_relation A R) (guarded_pointwise_relation P R).
Proof.
  intros.
  hnf; intros.
  rewrite guarded_pointwise_relation_spec.
  intros.
  apply H.
Qed.

Lemma pointwise_relation_is_guarded_pointwise_relation: forall {A B : Type} (R : relation B), same_relation _ (pointwise_relation A R) (guarded_pointwise_relation (fun _ => True) R).
Proof.
  intros.
  rewrite same_relation_spec.
  hnf; intros.
  hnf; intros.
  rewrite guarded_pointwise_relation_spec.
  unfold pointwise_relation.
  firstorder.
Qed.

Instance guarded_pointwise_relation_Proper {A B : Type}: Proper (Same_set ==> eq ==> eq ==> eq ==> iff) (@guarded_pointwise_relation A B).
Proof.
  do 4 (hnf; intros); subst.
  destruct H.
  split; apply guarded_pointwise_relation_weaken; auto.
Defined.

(* surjection properties are not used now. *)
Lemma guarded_surj_Included: forall {X Y} (f: X -> Y) (PX: X -> Prop) (PY PY0: Y -> Prop),
  (forall y, PY y -> exists x, PX x /\ f x = y) ->
  (forall x, PX x -> PY0 (f x)) ->
  Included PY PY0.
Proof.
  intros.
  unfold Included, Ensembles.In.
  intros y ?.
  destruct (H _ H1) as [x [? ?]].
  subst y.
  apply (H0 x); auto.
Qed.

Lemma guarded_surj_Disjoint: forall {X Y} (f: X -> Y) (PX: X -> Prop) (PY PY0: Y -> Prop),
  (forall y, PY y -> exists x, PX x /\ f x = y) ->
  (forall x, PX x -> ~ PY0 (f x)) ->
  Disjoint Y PY PY0.
Proof.
  intros.
  rewrite Disjoint_spec.
  intros y ? ?.
  destruct (H _ H1) as [x [? ?]].
  subst y.
  apply (H0 x); auto.
Qed.

Lemma is_guarded_inj_empty {A B: Type} (f: A -> B):
  is_guarded_inj (Empty_set _) f.
Proof.
  intros.
  exists (fun v => None).
  intro b.
  intros.
  inv H.
Qed.

Lemma is_guarded_inj_single {A B: Type} {EqB: EqDec B eq} (f: A -> B) (a: A):
  is_guarded_inj (eq a) f.
Proof.
  intros.
  exists (fun b => if equiv_dec (f a) b then Some a else None).
  intro b.
  destruct_eq_dec (f a) b.
  + split; auto.
    intros; subst.
    tauto.
  + intros; subst.
    auto.
Qed.

Lemma is_guarded_inj_rev_aux {A B: Type} (P: A -> Prop) (f: A -> B) (g: B -> option A) (a: A):
  P a ->
  is_rev_fun P f g ->
  g (f a) = Some a.
Proof.
  intros.
  specialize (H0 (f a)).
  destruct (g (f a)).
  + destruct H0.
    specialize (H1 a H).
    rewrite (proj1 H1) by auto.
    auto.
  + specialize (H0 a H).
    congruence.
Qed.

Lemma is_guarded_inj_rev_aux' {A B: Type} (P1 P2: A -> Prop) (f: A -> B) (g1: B -> option A) (a: A):
  Disjoint B (image_set P1 f) (image_set P2 f) ->
  P2 a ->
  is_rev_fun P1 f g1 ->
  g1 (f a) = None.
Proof.
  intros.
  specialize (H1 (f a)).
  destruct (g1 (f a)); auto.
  destruct H1.
  specialize (H2 a0 H1).
  pose proof proj2 H2 eq_refl.

  exfalso.
  rewrite Disjoint_spec in H.
  apply (H (f a0)).
  + constructor; auto.
  + rewrite H3; constructor; auto.
Qed.

Lemma is_guarded_inj_spec {A B: Type} (P: A -> Prop) (f: A -> B):
  is_guarded_inj P f ->
  forall a1 a2: A, P a1 -> P a2 -> f a1 = f a2 -> a1 = a2.
Proof.
  intros.
  destruct H as [g ?].
  pose proof H (f a2).
  rewrite (is_guarded_inj_rev_aux P f g a2) in H3 by auto.
  destruct H3 as [_ ?].
  specialize (H3 a1 H0).
  tauto.
Qed.

Lemma is_guarded_inj_spec' {A B: Type} (P: A -> Prop) (f: A -> B):
  is_guarded_inj P f ->
  forall a1 a2: A, P a1 -> P a2 -> a1 <> a2 -> f a1 <> f a2.
Proof.
  intros.
  specialize (is_guarded_inj_spec _ _ H a1 a2 H0 H1).
  intros ? ?.
  apply H2.
  apply H3; auto.
Qed.

Lemma is_guarded_inj_disjoint_union_aux {A B: Type} (P1 P2 P: A -> Prop) (f: A -> B) (g1 g2: B -> option A):
  Prop_join P1 P2 P ->
  is_rev_fun P1 f g1 ->
  is_rev_fun P2 f g2 ->
  (forall a1 a2, P1 a1 -> P2 a2 -> f a1 <> f a2) ->
  let g := fun b => match g1 b with Some a => Some a | _ => g2 b end in
  is_rev_fun P f g.
Proof.
  intros.
  destruct H.
  intro b.
  specialize (H0 b); specialize (H1 b).
  subst g; cbv beta.
  destruct (g1 b); [| destruct (g2 b)].
  + split; [firstorder |].
    intros.
    rewrite H in H4; destruct H4.
    - apply (proj2 H0); auto.
    - pose proof proj2 (proj2 H0 a (proj1 H0)) eq_refl.
      split; intros.
      * exfalso.
        apply (H2 a a0 (proj1 H0) H4).
        congruence.
      * subst a; auto.
  + split; [firstorder |].
    intros.
    rewrite H in H4; destruct H4.
    - pose proof proj2 (proj2 H1 a (proj1 H1)) eq_refl.
      split; intros.
      * exfalso.
        apply (H2 a0 a H4 (proj1 H1)).
        congruence.
      * subst a; auto.
    - apply (proj2 H1); auto.
  + intros.
    rewrite H in H4; firstorder.
Qed.

Lemma is_guarded_inj_disjoint_union {A B: Type} (P1 P2 P: A -> Prop) (f: A -> B):
  Prop_join P1 P2 P ->
  is_guarded_inj P1 f ->
  is_guarded_inj P2 f ->
  (forall a1 a2, P1 a1 -> P2 a2 -> f a1 <> f a2) ->
  is_guarded_inj P f.
Proof.
  intros.
  destruct H0 as [g1 ?], H1 as [g2 ?].
  exists (fun b => match g1 b with Some a => Some a | _ => g2 b end).
  eapply is_guarded_inj_disjoint_union_aux; eauto.
Qed.

Lemma is_guarded_inj_proper_aux1 {A B: Type} (P: A -> Prop) (f1 f2: A -> B):
  guarded_pointwise_relation P eq f1 f2 ->
  is_guarded_inj P f1 ->
  is_guarded_inj P f2.
Proof.
  intros.
  destruct H0 as [g ?].
  exists g.
  intro b; specialize (H0 b); destruct (g b).
  + destruct H0; split; auto.
    intros; specialize (H1 a0 H2).
    rewrite guarded_pointwise_relation_spec in H.
    rewrite H in H1 by auto; auto.
  + intros; specialize (H0 a H1).
    rewrite guarded_pointwise_relation_spec in H.
    rewrite H in H0 by auto; auto.
Qed.

Instance is_guarded_inj_proper1 {A B: Type} (P: A -> Prop): Proper (guarded_pointwise_relation P eq ==> iff) (@is_guarded_inj A B P).
Proof.
  hnf; intros.
  split; apply is_guarded_inj_proper_aux1; auto.
  symmetry; auto.
Qed.

Lemma is_guarded_inj_proper_aux2 {A B: Type} (P1 P2: A -> Prop) (f: A -> B):
  Same_set P1 P2 ->
  is_guarded_inj P1 f ->
  is_guarded_inj P2 f.
Proof.
  intros.
  destruct H0 as [g ?].
  exists g.
  rewrite Same_set_spec in H.
  intro b; specialize (H0 b); destruct (g b).
  + rewrite H in H0.
    destruct H0; split; auto.
    intros; rewrite <- H in H2; auto.
  + intros; rewrite <- H in H1; auto.
Qed.

Instance is_guarded_inj_proper2 {A B: Type}: Proper (Same_set ==> eq ==> iff) (@is_guarded_inj A B).
Proof.
  do 2 (hnf; intros); subst.
  split; apply is_guarded_inj_proper_aux2; auto.
  symmetry; auto.
Qed.

Instance image_set_proper1 {A B: Type} (P: A -> Prop) : Proper (guarded_pointwise_relation P (@eq B) ==> Same_set) (image_set P).
Proof.
  hnf; intros.
  rewrite Same_set_spec.
  rewrite guarded_pointwise_relation_spec in H.
  intro z.
  rewrite !image_set_spec.
  firstorder; subst; firstorder.
Qed.


Require Import Coq.Lists.List Program NArith Lia.
From SyDPaCC.Bsml.Model Require Import Core Pid.
From SyDPaCC.Support Require Import UIP Sig List NList.

(** * A Certified Sequential Implementation of BSML *)

(** In order to check that the axiomatization of the BSML library
    makes sense, we implement the [BSML] module type using lists. *)

Open Scope N_scope.

Module Implementation (Import B : BSP_PARAMETERS) <: BSML.

  Module Bsp := B.

  Notation pid := { n : N | N.ltb n Bsp.p = true }.

  Module Import Pid := Pid.Make Bsp.

  (** ** Parallel Vectors: Implemented as Lists of Size [Bsp.p] *)
  Definition par (A:Type) := { l : list A | length l = Bsp.p }.

  Program Definition get {A:Type}(v:par A)(i:pid) : A := `(Sig.nth (`v) i).
  Next Obligation.
    destruct v as [v Hv]; simpl; rewrite Hv.
    now apply N.ltb_lt.
  Qed.

  Lemma bsp_pSMaxPid:
    exists maxPid:N, Bsp.p = N.succ maxPid.
  Proof.
    destruct Bsp.p as [| maxpid Hmaxpid] eqn:Hp using N.peano_ind.
    - set(H:=Bsp.p_spec). contradict Hp; lia.
    - exists maxpid; trivial.
  Qed.

  Program Definition pid0 : pid := 0.
  Next Obligation. pid. Qed.

  Lemma par_eq :
    forall (A:Type)(v v':par A),
    (forall (i:pid), get v i = get v' i) -> v = v'.
  Proof.
    intros A [v Hv] [v' Hv'] H. unfold get in *. simpl in H.
    assert(length v = length v') as Hlen by (clear H; now rewrite <- Hv in Hv'); subst.
    assert(v = v').
    {
      apply Sig.nth_eq with (H:=Hlen). intros pos.
      assert((`pos)<Bsp.p) as Hi by
            (destruct pos as [pos Hpos ]; pid; now rewrite Hv in Hpos).
      specialize (H (of_N' Hi)).
      match goal with
        | [ H : Sig.nth ?l1 ?pos1 = Sig.nth ?l2 ?pos2 |- _] =>
          transitivity (Sig.nth l1 pos1)
      end.
      eapply Sig.nth_pi; eauto.
      match goal with
        | [ H : Sig.nth ?l1 ?pos1 = Sig.nth ?l2 ?pos2 |- _] =>
          transitivity (Sig.nth l2 pos2); auto
      end.
      eapply Sig.nth_pi; eauto; destruct pos; pid.
    }
    subst. now replace Hv with Hv' by (apply UIP).
  Qed.

  (** ** BSML Primitives *)
  Program Definition
    mkpar {A:Type}(f: pid -> A) : par A :=
    List.map f pids.
  Next Obligation.
    pid.
  Qed.

  Lemma mkpar_spec:
    forall (A:Type)(f:pid->A)(i:pid),
      get (mkpar f) i = f i.
  Proof.
    intros A f i.
    unfold get, mkpar, pids; simpl.
    rewrite Sig.nth_map, Sig.map_nth by (intros; apply Bool.UIP).
    f_equal; apply proj1_sig_inj; simpl.
    rewrite Sig.nth_spec with (default:=0); simpl.
    rewrite seq_seq.
    replace 0 with (N.of_nat 0%nat) by auto.
    rewrite List.map_nth, seq_nth;
      destruct i; pid.
  Qed.

  Program Definition apply {A B:Type}(vf:par(A->B))(vx: par A):
    par B :=
    List.map(fun (p:((A->B)*A)) => let (f,v):=p in f v)
       (combine vf vx).
  Next Obligation.
    destruct vf as [vf H], vx as [vx H']; simpl.
    length.
  Qed.

  Lemma apply_spec:
    forall (A B:Type)(vf:par(A->B))(vx: par A)
           (i:pid),
      get(apply vf vx) i = (get vf i)(get vx i).
  Proof.
    intros A B [vf Hvf] [vx Hvx] i.
    unfold get, apply; simpl.
    assert(length vf = length vx) as Hlen by now rewrite Hvf, Hvx.
    rewrite Sig.nth_map, (Sig.nth_combine _ _ _ Hlen).
    pose(pos_f:=Sig.cast_sig (of_pid i) (Sig.lt_eq (eq_sym Hvf))).
    pose(pos_x:=Sig.cast_sig (of_pid i) (Sig.lt_eq (eq_sym Hvx))).
    rewrite Sig.nth_pi with (pos2:=pos_f) by auto.
    rewrite Sig.nth_pi with (l:=vx)(pos2:=pos_x) by auto.
    symmetry.
    rewrite Sig.nth_pi with (pos2:=pos_f) by auto.
    rewrite Sig.nth_pi with (l:=vx)(pos2:=pos_x) by auto.
    trivial.
  Qed.

  Program Definition put {A:Type}(vf: par (pid -> A)):
    par(pid -> A) :=
    List.map
      (fun (dst src:pid)=>(Sig.nth vf src) dst)
      pids.
  Next Obligation.
    destruct vf as [vf Hvf]; simpl.
    pid; intuition.
  Qed.
  Next Obligation. length. Qed.

  Lemma put_spec:
    forall(A:Type)(vf: par (pid -> A))
          (i j : pid),
      get (put vf) i j = get vf j i.
  Proof.
    intros A [vf Hvf] i j.
    unfold get, put; simpl.
    rewrite Sig.nth_map.
    set(pos:=Sig.cast_sig (of_pid j) (Sig.lt_eq (eq_sym Hvf))).
    set(pos':=Sig.cast_sig (of_pid i) (Sig.lt_eq (eq_sym pids_length))).
    rewrite Sig.nth_pi with (pos2:=pos) by auto.
    rewrite Sig.nth_pi with (l:=pids)(pos2:=pos') by auto.
    symmetry.
    rewrite Sig.nth_pi with (pos2:=pos) by auto.
    f_equal; symmetry.
    unfold pids; rewrite Sig.map_nth by (intros; apply Bool.UIP); simpl.
    apply proj1_sig_inj; simpl.
    rewrite Sig.nth_spec with (default:=p); simpl.
    rewrite seq_seq.
    destruct i, j; simpl; clear pos pos'. rewrite <- (N2Nat.id  p).
    rewrite List.map_nth, seq_nth; pid.
  Qed.

  Definition proj {A:Type}(v: par A) : pid -> A :=
    get v.

  Lemma proj_spec:
    forall(A:Type)(v:par A)(i:pid),
      (proj v) i = get v i.
    auto.
  Qed.

End Implementation.

Close Scope N_scope.


Load group_completion.
(* Load monoids_and_groups. *)

(*TODO: Make M not implicit. Use 1%nat_scope*)
Section Classifying_Space.
  Open Scope monoid_scope.
  (*Define the classifying space of a monoid as a cell complex*)

  (*The 1-skeleton of B.*)
  Definition pre_B (M : Monoid)  := @Coeq M Unit (const tt) (const tt).

  (*pre_B has one point:*)
  Global Instance ispointed_pre_B {M : Monoid} : IsPointed (pre_B M) := coeq tt.

  (*pre_B has one loop for every m : M*)
  Definition pre_B_loop {M : Monoid} : M -> point (pre_B M) = point (pre_B M) := cp.

  Definition pre_B_rec {M : Monoid}
             (P : Type)
             (bp : P)
             (l : forall m : M, bp = bp) :
    pre_B M -> P.
    srapply @Coeq_rec.
    - exact (const bp). (*intros []. exact bp.*)
    - exact l.
  Defined.

  Definition pre_B_rec_beta_l {M : Monoid}
             (P : Type)
             (bp : P)
             (l : forall m : M, bp = bp)
             (m : M):
    ap (pre_B_rec P bp l) (pre_B_loop m) = l m :=
    Coeq_rec_beta_cp P (const bp) l m.

  Definition pre_B_ind {M : Monoid}
             (P : pre_B M -> Type) (bp : P (point (pre_B M)))
             (loop' : forall (m : M), transport P (pre_B_loop m) bp = bp)
             : forall a : pre_B M, P a.
  Proof.
    srapply @Coeq_ind.
    - intros []. exact bp.
    - exact loop'.
  Defined.

  Definition pre_B_ind_beta_l {M : Monoid}
             (P : pre_B M -> Type) (bp : P (point (pre_B M)))
             (loop' : forall (m : M), transport P (pre_B_loop m) bp = bp)
             (m : M) :
    apD (pre_B_ind P bp loop') (pre_B_loop m) = loop' m
    :=
      Coeq_ind_beta_cp P _ loop' m.

  Definition looptofill (M : Monoid) (m1 m2 : M) : S1 -> pre_B M.
    refine (S1_rec (pre_B M) (point (pre_B M)) _).
    exact ((pre_B_loop m1) @ (pre_B_loop m2) @ (pre_B_loop (m1 + m2))^).
  Defined.

  Definition looptofill_curried (M : Monoid) : M*M*S1 -> pre_B M :=
    prod_curry (prod_curry (looptofill M)).

  Definition S1topre_B {M : Monoid} (m1 m2 : M) : S1 -> pre_B M :=
    looptofill M m1 m2.

  Definition collapseS1 (M : Monoid) : M*M*S1 -> M*M.
    intros [[m1 m2] x].
    exact (m1, m2).
  Defined.

  (*Construct 2-cells*)
  Definition B (M : Monoid) := pushout
                                  (looptofill_curried M)
                                  (collapseS1 M).

  Definition ispointed_MMS1 {M : Monoid} : IsPointed (M * M * S1) := (mon_id M, mon_id M, base).

  Definition pre_BtoB {M : Monoid} : pre_B M -> B M := (push o inl).

  Global Instance ispointed_B {M : Monoid} : IsPointed (B M) := pre_BtoB ispointed_pre_B.

  Definition B_loop {M : Monoid} (m : M) : point (B M) = point (B M) :=
    ap pre_BtoB (pre_B_loop m).

  Definition nullhom_S1toB {M : Monoid} (m1 m2 : M) :
    pre_BtoB o (S1topre_B m1 m2) == (fun _ : S1 => pre_BtoB (S1topre_B m1 m2 base)) .
  Proof.
    intro x.
    refine (concat (pp (m1, m2, x)) _).
    exact (pp (m1, m2, base))^. (*Weirdly enough, putting this inside the concat doesn't work. . .*)
  Defined.

  Definition const_S1toB {M : Monoid} (m1 m2 : M) :
    pre_BtoB o (S1topre_B m1 m2) = (fun _ : S1 => pre_BtoB (S1topre_B m1 m2 base)) :=
    path_forall _ _ (nullhom_S1toB m1 m2).

  Definition B_resp_mul {M : Monoid} (m1 m2: M) :
     B_loop (m1 + m2) = B_loop m1 @ B_loop m2.
  Proof.
    unfold B_loop.
    apply moveR_1M.
    refine (_ @ whiskerR (ap_pp pre_BtoB _ _) _).
    refine (_ @ whiskerL _ (ap_V pre_BtoB _)).
    refine (_ @ (ap_pp pre_BtoB _ _)).
    refine (_ @ ap02 _ (S1_rec_beta_loop _ _ _)).
    refine (_ @ (ap_compose _ _ _)).
    refine ((ap_const loop (pre_BtoB (S1topre_B m1 m2 base)))^ @ _).
    refine ((ap12 loop (const_S1toB m1 m2))^ @ _).
    change
      (S1_rec (Coeq (const tt) (const tt)) (coeq tt)
              ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)) with
    (S1topre_B m1 m2).
    assert (p : (ap10 (const_S1toB m1 m2) base) = idpath).
    { refine ((ap10_path_forall _ _ (nullhom_S1toB m1 m2) _) @ _).
      apply concat_pV. }
    refine (whiskerL _ p @ _).
    refine (concat_p1 _ @ _).
    refine (whiskerR (inverse2 p) _ @ _).
    apply concat_1p.
  Defined.

  Definition B_rec {M : Monoid}
             (C : Type)
             (c0 : C)
             (Cp : M -> c0 = c0)
             (resp_mul_C : forall m1 m2 : M, Cp (m1 + m2) = Cp m1 @ Cp m2) :
    B M -> C.
    (*B is the pushout of pre_B M and M*M*S1*)
    srapply @pushout_rec.
    - apply sum_rect.
      + (*The map defined on pre_B is given by l*)
        exact (pre_B_rec _ c0 Cp).
        (*The map on M*M*S1 is the constant map (it gives the loops that will be killed)*)
      + exact (const c0).
    - (*Show that the map is well-defined, e.g. m1@m2=m1*m2 *)
      simpl.
      intros [[m1 m2]].
      unfold const.
      unfold looptofill_curried.
      unfold prod_curry.
      simpl.
      unfold looptofill.
      srapply @S1_ind.
      + exact idpath.
      + refine (concat (transport_paths_Fl loop idpath) _).
        refine (concat_p1 _ @ _).
        unfold pre_B_rec.
        apply (inverse2 (q := idpath)).
        refine (ap_compose _ _ _ @ _).
        refine (concat (y:= ap (Coeq_rec C (const c0) Cp)
                               ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^) ) _ _).
        { apply (ap (ap _)). apply S1_rec_beta_loop. }
        refine (ap_pp _ _ _ @ _).
        refine (whiskerR (ap_pp _ _ _) _ @ _).
        refine (whiskerL _ (ap_V _ _) @ _).
        apply moveR_pV.
        refine (_ @ (concat_1p _)^).
        unfold pre_B_loop.
        refine (_ @ (Coeq_rec_beta_cp C (const c0) Cp (m1 + m2))^).
        refine (_ @ (resp_mul_C m1 m2)^).
        apply concat2; refine (Coeq_rec_beta_cp C (const c0) Cp _).
  Defined.

  Definition B_rec_beta_l {M : Monoid}
             (C : Type)
             (c0 : C)
             (Cp : M -> c0 = c0)
             (resp_mul_C : forall m1 m2 : M, Cp (m1 + m2) = Cp m1 @ Cp m2)
             (m : M):
    ap (B_rec C c0 Cp resp_mul_C) (B_loop m) = Cp m.
  Proof.
    unfold B_loop.
    refine ((ap_compose pre_BtoB _ _)^ @ _).
    apply pre_B_rec_beta_l.
  Defined.

  (*Should probably switch to lean or implement pathovers here. . .*)
  Definition B_ind {M : Monoid}
             (C : B M -> Type)
             (c0 : C (point (B M)))
             (Cp : forall (m : M), transport C (B_loop m) c0 = c0)

             (resp_mul_C : forall (m1 m2 : M),
                    transport
                      (fun pth => transport C pth c0 = c0)
                      (B_resp_mul m1 m2)
                      (Cp (m1 + m2))
                    = concat_over _ _ _ (Cp m1) (Cp m2))
             : forall a : B M, C a.
    srapply @pushout_ind.
    - apply sum_ind.
      + srapply @pre_B_ind.
        * (*Variable is basepoint*)
          exact c0.
        * (*Variable runs along B_loop*)
          intro m.
          refine (transport_compose C (push o inl) (pre_B_loop m) c0 @ _).
          exact (Cp m).
      + (*Variable is hub point*)
        intros [m1 m2].
        exact (transport C (pp (m1, m2, base)) c0).
    - intros [[m1 m2]].
      srapply @S1_ind.
      + reflexivity.
      + (*Variable runs along resp_mult (I think. . . )*)
        cbn.
        set (restriction_to_pre_B := (pre_B_ind
                                     (fun a : pre_B M => C (push (inl a))) c0
                                     (fun m : M =>
                                        transport_compose C (fun x0 : pre_B M => push (inl x0))
                                                          (pre_B_loop m) c0 @ Cp m))).
        refine (transport_paths_Fl loop idpath @ _).
        refine (concat_p1 _ @ _).
        apply (inverse2 (q:=idpath)).

        (* set (f := fun x : S1 => transport C (pp (m1, m2, x)) *)
        (*                                   (restriction_to_pre_B (looptofill_curried M (m1, m2, x)))). *)
        (* set (g := fun x : S1 => transport C (pp (m1, m2, base)) c0). *)

        transparent assert (pathtohub :
                              (forall x : S1,  pushl (m1, m2, x) = push (inr (m1, m2)) :> B M)).
        { intro x. exact (pp (m1, m2, x)). }
        unfold pushl in pathtohub. unfold looptofill_curried in pathtohub.
        unfold prod_curry in pathtohub. simpl in pathtohub.
        enough (restriction_to_pre_B oD (looptofill M m1 m2) =
                (fun x : S1 => transport C (pathtohub base @ (pathtohub x)^) c0)).
        transitivity (ap (fun x : S1 =>
                            transport C (pathtohub x)
                             ((restriction_to_pre_B oD looptofill M m1 m2) x)) loop).
        reflexivity.

        refine ((apD (fun f : (forall x : S1, C (push (inl (looptofill M m1 m2 x)))) =>
               ap (fun x : S1 => transport C (pathtohub x) (f x)) loop) X^)^ @ _).
        refine (transport_paths_FlFr X^ _ @ _).
        apply moveR_pM. refine (_ @ (concat_1p _)^). apply (moveR_Vp).
        refine (_ @ (concat_pV _)^).
        assert (forall x : S1,
                  transport C (pathtohub x)
                            (transport C (pathtohub base @ (pathtohub x)^) c0) =
                  transport C (pathtohub base) c0).
        { intro x.
          rewrite <- transport_pp. hott_simpl. }
        rewrite <- (ap12 loop (path_forall _ _ (fun x => (X0 x)^))).
        rewrite ap_const.
        rewrite concat_p1.
        apply concat_Vp.

        apply path_forall.
        srapply @S1_ind.
        * simpl.
          apply (transport2 C (p:=idpath) (concat_pV _)^ c0).
        * refine (transport_paths_FlFr_D loop _ @ _).
          rewrite (apD_composeD restriction_to_pre_B (looptofill M m1 m2)).
          apply moveR_pM.
          apply moveR_pM.
          apply moveR_1V.
          apply moveL_Mp.
          refine (concat_p1 _ @ _).
          apply inverse. hott_simpl.

          rewrite (S1_rec_beta_loop (pre_B M) (point _) ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)).

        unfold restriction_to_pre_B.

        assert (transport
                  (fun x : S1 =>
                     restriction_to_pre_B (looptofill M m1 m2 x) =
                     transport C (pathtohub base @ (pathtohub x)^) c0) loop (transport C loop idpath) = idpath).

        refine (transport_paths_FlFr_D (f := f) (g := g) loop idpath @ _). simpl.
        apply moveR_pM. refine (concat_p1 _ @ _ @ (concat_1p _)^). apply inverse2.
        refine (_ @ (apD_const g loop)^).
        refine (_ @ (whiskerL _ (ap_const loop _))^).
        unfold g. clear g. refine (_ @ (concat_p1 _)^).
        set (h := fun (x : S1) (b : C (push (inl (looptofill M m1 m2 x)))) =>
                    transport C (pp (m1, m2, x)) b).
        change f with (composeDD h (restriction_to_pre_B oD (looptofill M m1 m2))).
        clear f.
        refine (apD_composeDD h _ loop @ _). simpl.
        apply moveR_Mp.

        (* dpath_path_FlFr *)
        (* transport_paths_FlFr_D *)

        (* simpl in restriction_to_pre_B. unfold looptofill_curried. unfold prod_curry. simpl. *)

        (* refine (transport_paths_Fl loop idpath @ _). *)
        (* refine (concat_p1 _ @ _). *)
        (* apply (inverse2 (q := idpath)). *)
        (* (* set (f := fun x : S1 => *) *)
        (* (*             transport C (pp (m1, m2, x)) *) *)
        (* (*                       (restriction_to_pre_B (looptofill M m1 m2 x))). *) *)
        (* (* unfold pushr in f. unfold collapseS1 in f. *) *)
        (* transparent assert (pathtohub : *)
        (*                       (forall x : S1,  pushl (m1, m2, x) = push (inr (m1, m2)) :> B M)). *)
        (* { intro x. exact (pp (m1, m2, x)). } *)
        (* unfold pushl in pathtohub. unfold looptofill_curried in pathtohub. unfold prod_curry in pathtohub. simpl in pathtohub. *)
        (* set (p := pathtohub base). unfold looptofill in p. simpl in p. *)
        (*pathtohub base : point (B M) = push (inr (m1, m2))*)

        set (P := fun xc : {x : S1 & C (push (inl (looptofill M m1 m2 x)))} =>
                transport C (pp (m1, m2, xc.1)) xc.2 = transport C (pp (m1, m2, base)) c0).
        refine (transport_compose
                  P
                  (section_of (restriction_to_pre_B oD looptofill M m1 m2)) loop idpath @ _).
        unfold P. clear P.
        refine (transport_paths_Fl
                  (ap (section_of (restriction_to_pre_B oD looptofill M m1 m2)) loop)
                  idpath @ _).
        refine (concat_p1 _ @ _).
        apply (inverse2 (q := idpath)).
        set (f := (fun x : {a : S1 & C (push (inl (looptofill M m1 m2 a)))} =>
                     transport C (pp (m1, m2, x.1)) x.2)). unfold pushr in f. unfold collapseS1 in f.
        rewrite ap_section.
        unfold composeD.
        change (restriction_to_pre_B (looptofill M m1 m2 base)) with c0.
        refine (_ @ ap_1 (base; c0) f).
        apply (ap (ap f)).
        (* refine (path2_sigma _ _ _ _ _ _ _ _ _ @ _). *)

        (*         path2_sigma *)
        clear f.
        (*Not sure if this has done anything good. . .*)
        refine (path2_sigma (fun a : S1 => C (push (inl (looptofill M m1 m2 a))))
                           (base; c0) (base; c0)
                           loop idpath
                           (apD (fun x : S1 => restriction_to_pre_B (looptofill M m1 m2 x)) loop) idpath
                           _ _).

        rewrite (apD_composeD restriction_to_pre_B (looptofill M m1 m2)).

        simpl.

        assert (ap (looptofill M m1 m2) loop =
                ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)). apply S1_rec_beta_loop.
        rewrite X.
        rewrite (S1_rec_beta_loop (pre_B M) (point (pre_B M))
  ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)).

        assert (ap (section_of (restriction_to_pre_B oD looptofill M m1 m2)) loop =
                (path_sigma _ _ _ idpath (apD (restriction_to_pre_B oD looptofill M m1 m2)))).

        assert ((ap (fun a : S1 => (a; (restriction_to_pre_B oD looptofill M m1 m2) a)) loop) =
                path_sigma _ _ _ idpath (apD (restriction_to_pre_B oD (looptofill M m1 m2)) loop)).

        (* moveR_transport_p *)
        (*   ap01D1 *)

        (* refine (transport_composeD *)
        (*           (fun x : S1 => (restriction_to_pre_B (looptofill M m1 m2 x)) = *)
        (*                          transport C (pp (m1, m2, x))^ *)
        (*                                    (transport C (pp (m1, m2, base)) c0)) *)

        (*           (fun x => moveR_transport_p C (pp (m1, m2, x)) *)
        (*                                       (restriction_to_pre_B (looptofill M m1 m2 x)) *)
        (*                                       (transport C (pp (m1, m2, base)) c0) ) *)

        (*           (fun x b => transport C (pp (m1, m2, x)) *)
        (*                                 (restriction_to_pre_B b) = *)
        (*                       transport C (pp (m1, m2, base)) c0) *)
        (*           (fun x => looptofill M m1 m2 x) *)
        (*           loop idpath *)
        (*           @ _). *)
        (* Unshelve. *)
        (* Focus 2. *)
        (*   intros x b. *)
        (*   exact (transport C (pp (m1, m2, x))  *)
        (*                    (restriction_to_pre_B b) = *)
        (*          transport C (pp (m1, m2, base)) c0) . *)

        refine (transport_paths_Fl loop idpath  @ _).
        (*apD_const?*)
        apply moveR_Vp.
        refine (_ @ (concat_p1 _)^).

        change (fun x : S1 =>
                  transport
                    C (pp (m1, m2, x))
                    (restriction_to_pre_B (looptofill M m1 m2 x)))
               with
               (composeDD (fun x => transport C (pp (m1, m2, x)))
                          (composeD restriction_to_pre_B (looptofill M m1 m2))) .

        (* enough (ap_S1 : *)
        (*           ap (looptofill M m1 m2) loop = ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)). *)
        (* enough (ap_pre_B : *)
        (*           apD (restriction_to_pre_B oD looptofill M m1 m2) loop = *)
        (*           transport_compose _ _ _ _ @ *)
        (*              apD restriction_to_pre_B ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)). *)

        (* admit. *)
        (* apply S1_rec_beta_loop. *)

        (* refine (_ @ moveR_Vp (apD_const (composeDD (fun x : S1 => transport C (pp (m1, m2, x))) *)
        (*                                            (restriction_to_pre_B oD looptofill M m1 m2)) loop)). *)

        transitivity ((transport_const _ _)^ @
                      (apD (composeDD (fun x : S1 => transport C (pp (m1, m2, x)))
                           (restriction_to_pre_B oD looptofill M m1 m2)) loop)).
        * apply moveL_Vp.
          refine (concat_p1 _ @ _).
          apply inverse.

          refine (apD_composeDD _ _ loop @ _).
          apply moveR_Mp.

          (* transitivity (apD011 (fun x : S1 => transport C (pp (m1, m2, x))) loop *)
          (*                 (apD restriction_to_pre_B ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^)) *)
          (*                 ). *)
          (* apD_compose *)
          (*rewrite pre_B_beta?*)

          admit.
        * apply moveR_Vp.
          srapply @apD_const.
  Admitted.

(*Alternative way to write g:*)
                          (* (fun x => *)
                          (*    pre_B_ind *)
                          (*    (fun a : pre_B M => C (push (inl a))) c0 *)
                          (*    (fun m : M => *)
                          (*       transport_compose C (fun x0 : pre_B M => push (inl x0))  *)
                          (*                         (pre_B_loop m) c0 @ l m) (looptofill M m1 m2 x))). *)

        (* set (Pl := fun a : pre_B M => C (push (inl a))). *)

        (* set (f := *)
        (*        (fun x : S1 => *)
        (*           transport *)
        (*             C (pp (m1, m2, x)) *)
        (*             (pre_B_ind *)
        (*                Cl c0 *)
        (*                (fun m : M => *)
        (*                   transport_compose C (fun x0 : pre_B M => push (inl x0))  *)
        (*                                     (pre_B_loop m) c0 @ l m) (looptofill_curried M (m1, m2, x))))). *)
        (* change (fun x : S1 => *)
        (*           transport *)
        (*             C (pp (m1, m2, x)) *)
        (*             (pre_B_ind *)
        (*                Cl c0 *)
        (*                (fun m : M => *)
        (*                   transport_compose C (fun x0 : pre_B M => push (inl x0))  *)
        (*                                     (pre_B_loop m) c0 @ l m) (looptofill_curried M (m1, m2, x)))) *)
        (*        with f. *)
        (* unfold pushr in f. unfold collapseS1 in f. *)
        (* apply (cancelL (transport_const loop (f base)) _ _). *)
        (* refine (concat_p1 _ @ _). *)
        (* refine (_ @ apD_const f loop). *)
        (* apply inverse. *)

        (* Eval compute in (f base). *)

        (* assert (forall x : S1, P (pushr (m1, m2, x)) -> P (pushl (m1, m2, base))). *)
        (* { intro x. refine (_ o transport P (pp (m1, m2, x))^ ). *)
        (*   revert x. *)
        (*   srapply @S1_ind. *)
        (*     exact idmap. *)
        (*     apply path_forall. intro. *)
        (*     refine ((transport_arrow *)
        (*                (B := fun x => P (pushl (m1, m2, x))) *)
        (*                (C := fun _ => P (pushl (m1, m2, base))) loop idmap _ )@ _). *)

        (* unfold pushr in f. unfold collapseS1 in f. *)
        (* enough *)
        (*   (ap (transport P (pp (m1, m2, base))^) 1 = ap (transport P (pp (m1, m2, base))^) (ap f loop)). *)
        (* apply ((ap (transport P (pp (m1, m2, base))^))^-1 X). *)

        (* refine ((ap (transport P (pp (m1, m2, base))^))^-1 _). *)

        (* assert ((fun x : S1 => transport P (pp (m1, m2, x))^ (f x)) == *)
        (*        pre_B_ind (fun a : pre_B M => P (push (inl a))) c0 *)
        (*                 (fun m : M => *)
        (*                    transport_compose P (fun x0 : pre_B M => push (inl x0))  *)
        (*                                      (pre_B_loop m) c0 @ l m) o (looptofill M m1 m2)). *)
        (*   { intro x. *)
        (*     unfold f. refine ((transport_pp P _ _ _)^ @ _). *)
        (*     refine (transport2 P (q := idpath) (concat_pV _) _ @ _). *)
        (*     exact (transport_1 P _ ). } *)

   (*      refine (_ @ (moveR_Vp _ _ _ (apD_const _ _))). *)

   (*      apply inverse. *)

   (*      set (Pl := (fun a : pre_B M => P (push (inl a))) ). *)
   (*      change (fun a : pre_B M => P (push (inl a))) with Pl. *)
   (*      set (lm := (fun m : M => *)
   (*                  transport_compose P (fun x0 : pre_B M => push (inl x0)) (pre_B_loop m) c0 @ l m) ). *)
   (*      change (fun m : M => *)
   (*                  transport_compose P (fun x0 : pre_B M => push (inl x0)) (pre_B_loop m) c0 @ l m) with lm. *)
   (*      unfold looptofill_curried. *)
   (*      unfold prod_curry. *)
   (*      unfold looptofill. *)
   (*      simpl. *)

   (*      refine (concat *)
   (*                (ap_compose *)
   (*                   (S1_rec (pre_B M) (point (pre_B M)) *)
   (*                           ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (m1 + m2))^) ) *)
   (*                    _ loop *)
   (*                ) *)
   (*                _ ). *)

   (*      refine (ap_compose _ (transport P (pp (m1, m2, x))) loop @ _). *)

   (*  refine (pushout_ind _ _ _ _ _). *)
   (*  - apply sum_ind. *)
   (*    + refine (pre_B_ind _ _ _). *)
   (*      * exact c0. *)
   (*      * intro m. *)
   (*        refine (concat *)
   (*                  (transport_compose P (push o inl) *)
   (*                                     (pre_B_loop m) *)
   (*                                     c0 ) *)
   (*                  _ *)
   (*               ). *)
   (*        apply ident. *)
   (*    + intros [m1 m2]. *)
   (*      exact (transport P (pp (m1, m2, base)) c0). *)
   (*  - intros [[m1 m2]]. *)
   (*    refine (S1_ind _ _ _). *)
   (*    + exact idpath. *)
   (*    + cbn. *)
   (*      refine (concat *)
   (*                (transport_paths_Fl loop idpath) *)
   (*                _ *)
   (*             ). *)
   (*      apply moveR_Vp. *)
   (*      refine (concat _ (concat_p1 _)^). *)
   (*      apply inverse. *)
   (*      unfold looptofill. *)

   (*      unfold pre_B_loop. *)

   (*      refine (concat *)
   (*                (ap_compose *)
   (*                   (S1_rec (pre_B M) (point (pre_B M)) *)
   (*                           ((pre_B_loop m1 @ pre_B_loop m2) @ (pre_B_loop (multM m1 m2))^) ) *)
   (*                    _ loop *)
   (*                ) *)
   (*                _ ). *)

   (*      unfold pre_B_ind. *)

   (* Admitted. *)

(*TODO: Use ap11. ap_apply_FlFr ap_to_conjp transport2
*)

(*TODO*) (*
  Global Instance ispointed_S1 : IsPointed S1 := base.
  Definition pS1 := Build_pType S1 _.
  Definition ppre_B (M : Monoid) := Build_pType (pre_B M) _.
  Definition pB (M : Monoid) := Build_pType (B M) _.
  Definition pS1topre_B {M : Monoid} (m1 m2 : M) :=
    Build_pMap pS1 (ppre_B M) (S1topre_B m1 m2) idpath.
  Definition ppre_BtoB {M : Monoid} (m1 m2 : M) : ppre_B M ->* pB M :=
    Build_pMap (ppre_B M) (pB M) (pre_BtoB) idpath.

  Lemma pconst_S1toB `{Funext} (M : Monoid) (m1 m2 : M) :
    (ppre_BtoB m1 m2) o* (pS1topre_B m1 m2) = pconst pS1 (pB M).
  Proof.
    apply path_pmap.
    refine (Build_pHomotopy _ _).
    intro x.
    simpl.
    unfold const. unfold point. unfold ispointed_B. unfold pre_BtoB. unfold ispointed_pre_B.
    refine (concat _ (pp ispointed_MMS1)^).
    apply (constant_S1toB x).
    - cbn.
      unfold constant_S1toB.
      hott_simpl.
      apply moveR_pV.
      hott_simpl.
      unfold ispointed_MMS1.
      unfold ispointed_S1.

      apply (concat (concat_p1 _) (concat_1p _)^ ).
  Defined.

  Definition pmap_to_loops {A B : pType} (l : loops A) :
    (A ->* B) -> loops B :=
    fun f => (point_eq f)^ @ (ap f l) @ (point_eq f).

  (*TODO: Use this to make the proof below simpler?*)
*)

  Definition monid_to_idpath `{Funext} {M : Monoid} : B_loop (mon_id M) = idpath.
    apply (cancelL (B_loop (mon_id M)) _ _).
    refine (concat (ishom_MtoB _ _) _).
    refine (concat _ (concat_p1 _)^).
    apply (ap B_loop2).
    apply mon_lid.
  Defined.

  Definition trB (M : Monoid) := Tr 1 (B M).

  Global Instance ispointed_trB {M : Monoid} : IsPointed (trB M) := tr (point (B M)).

  Definition trB_loop {M : Monoid} (m : M) : point (trB M) = point (trB M) := ap tr (B_loop m).
  Definition ishom_MtotrB `{Funext} {M : Monoid} (m1 m2: M) :
    (trB_loop m1) @ (trB_loop m2) = trB_loop (m1 + m2).
    refine (concat (ap_pp tr _ _)^ _).
    apply (ap (ap tr)).
    apply ishom_MtoB.
  Defined.

  Definition monid_to_idpath `{Funext} {M : Monoid} : trB_loop (mon_id M) = idpath.
    unfold trB_loop.
    refine (concat _ (ap_1 _ tr)).
    apply (ap (ap tr)).
    apply monid_to_idpath2.
  Defined.

  Definition trB_rec {M : Monoid}
             (P : Type) (istrunc : IsTrunc 1 P)
             (c0 : P)
             (loop' : forall m : M, c0 = c0)
             (ishom : forall m1 m2 : M, loop' m1 @ loop' m2 = loop' (m1 + m2) )
              : trB M -> P.
  Proof.
    apply Trunc_rec.
    exact (B_rec P c0 loop' ishom).
  Defined.

  Definition trB_rec_beta_l {M : Monoid}
             (P : Type) (istrunc : IsTrunc 1 P)
             (c0 : P)
             (loop' : forall m : M, c0 = c0)
             (ishom : forall m1 m2 : M, loop' m1 @ loop' m2 = loop' (m1 + m2) )
             (m : M) :
    ap (trB_rec P istrunc c0 loop' ishom) (trB_loop m) = loop' m.
  Proof.
    unfold trB_rec.
    (*TODO: Trunc_rec_beta something exists?*)
  Admitted.

  Definition trB_ind {M : Monoid}
             (P : trB M -> Type) (istrunc : forall (a : trB M), IsTrunc 1 (P a))
             (c0 : P (point (trB M)))
             (l : forall (m : M), transport P (trB_loop m) c0 = c0)
             (h : forall (m1 m2 : M),
                    transport
                      (fun pth => transport P pth c0 = c0)
                      (ishom_MtotrB m1 m2)
                      (transport_pp P (trB_loop m1) (trB_loop m2) c0 @
                                    ap (transport P (trB_loop m2)) (l m1) @ (l m2))
                    = l (m1 + m2))
             : forall a : trB M, P a.
    apply Trunc_ind.
    exact istrunc.
    srapply @B_ind.
    - exact c0.
    - intro m.
      refine (_ @ l m).
      unfold B_loop2.
      refine ((transport_compose _ pre_BtoB (pre_B_loop m) c0)^ @ _).
      unfold pre_B_loop.
      unfold trB_loop.
      admit.
    - admit.
  Admitted.

  (*Computation rule that becomes unessecary when B_rec is properly defined.*)
  Definition trB_rec_beta_bp {M : Monoid}
             (P : Type) (istrunc : IsTrunc 1 P)
             (bp : P)
             (loop' : forall m : M, bp = bp)
             (ishom : forall m1 m2 : M, loop' m1 @ loop' m2 = loop' (m1 + m2) ) :
    trB_rec P istrunc bp loop' ishom (point (trB M)) = bp.
  Admitted.

  Definition trB_ind_beta_bp {M : Monoid}
             (P : trB M -> Type) (istrunc : forall (a : trB M), IsTrunc 1 (P a))
             (bp : P (point (trB M)))
             (l : forall (m : M), transport P (trB_loop m) bp = bp)
             (h : forall (m1 m2 : M),
                    transport
                      (fun pth => transport P pth bp = bp)
                      (ishom_MtotrB m1 m2)
                      (transport_pp P (trB_loop m1) (trB_loop m2) bp @
                                    ap (transport P (trB_loop m2)) (l m1) @ (l m2))
                    = l (m1 + m2)) :
    trB_ind P istrunc bp l h (point (trB M)) = bp.
  Admitted.

End Classifying_Space.

Section looptrBM_is_groupcompletion.
  Open Scope monoid_scope.
  Fixpoint iterloop (n : nat) :=
    match n with
      | O => idpath
      | S n => loop @ (iterloop n)
    end.

  (*A simple case first. . .*)
  Lemma trBN_is_S1 : S1 <~> trB nat_monoid.
  Proof.
    srapply @equiv_adjointify.
    - (*Map from S1 to trBN*)
      srapply @S1_rec.
        exact (point _).
      refine (trB_loop _). exact 1.
    - (*Map from trBN to S1*)
      srapply @trB_rec.
      + exact base.
      + exact iterloop.
      + induction m1; intro m2.
        { apply concat_1p. }
        { simpl.
          refine (concat_pp_p _ _ _ @ _).
          apply whiskerL.
          apply IHm1. }
    - (*Composition is identity on trBN*)
      srapply @trB_ind.
      simpl. exact idpath.
      +  simpl.
         intro m.
         refine
           (transport_paths_FlFr
              (f := fun a =>
                    S1_rec (trB nat_monoid) (point (trB nat_monoid))
                         (trB_loop (M := nat_monoid) (S O))
                         (trB_rec (M := nat_monoid) S1 is1type_S1 base iterloop
                                (fun m1 : nat =>
                                   nat_rect
                                     (fun m0 : nat =>
                                        forall m2 : nat, iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                     (fun m2 : nat => concat_1p (iterloop m2))
                                     (fun (m0 : nat)
                                          (IHm1 : forall m2 : nat,
                                                    iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                          (m2 : nat) =>
                                        concat_pp_p loop (iterloop m0) (iterloop m2) @
                                                    whiskerL loop (IHm1 m2)) m1) a))
            (trB_loop (M := nat_monoid) m) idpath @ _).
         simpl.
         apply moveR_pM.
         refine (concat_p1 _ @ _ @ (concat_1p _)^).
         apply inverse2.
         refine (ap_compose
                   (trB_rec (M := nat_monoid) S1 is1type_S1 base iterloop
                          (fun m1 : nat =>
                             nat_rect
                               (fun m0 : nat =>
                                  forall m2 : nat, iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                               (fun m2 : nat => concat_1p (iterloop m2))
                               (fun (m0 : nat)
                                    (IHm1 : forall m2 : nat,
                                              iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                    (m2 : nat) =>
                                  concat_pp_p loop (iterloop m0) (iterloop m2) @
                                              whiskerL loop (IHm1 m2)) m1))
                   (S1_rec (trB nat_monoid) (point (trB (nat_monoid))) (trB_loop (M := nat_monoid) (S O)))
                   (trB_loop (M := nat_monoid) m) @ _).
         transitivity
           (ap
              (S1_rec (trB nat_monoid) (point (trB nat_monoid)) (trB_loop (M := nat_monoid) 1)) (iterloop m)).
         apply (ap (ap (S1_rec (trB nat_monoid) (point (trB nat_monoid)) (trB_loop (M := nat_monoid) 1)))).
         apply trB_rec_beta_l.
         (*Something transport_const?*)
         Check (fun f : trB nat_monoid -> trB nat_monoid => ap f (trB_loop (M := nat_monoid) m)).

         induction m.
         { apply inverse. simpl.
           hott_simpl. apply (monid_to_idpath (M := nat_monoid)). }
         simpl. hott_simpl.
         refine (ap_pp (S1_rec (trB nat_monoid) (point (trB nat_monoid)) (trB_loop (M := nat_monoid) (S O)))
                       loop (iterloop m) @ _).
         rewrite IHm.
         rewrite S1_rec_beta_loop.
         srapply @ishom_MtotrB.
      + intros m1 m2.
        apply (istrunc_truncation 1).
    - (*Composition is identity on S1*)
      srapply @S1_ind.
      + exact idpath.
      + simpl.
        refine (transport_paths_FlFr
                  (f :=
                     fun x : S1 =>
                       trB_rec
                         (M := nat_monoid) S1 is1type_S1 base iterloop
                         (fun m1 : nat =>
                            nat_rect
                              (fun m0 : nat =>
                                 forall m2 : nat, iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                              (fun m2 : nat => concat_1p (iterloop m2))
                              (fun (m0 : nat)
                                   (IHm1 : forall m2 : nat,
                                             iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                   (m2 : nat) =>
                                 concat_pp_p loop (iterloop m0) (iterloop m2) @
                                             whiskerL loop (IHm1 m2)) m1)
                         (S1_rec
                            (trB nat_monoid) (point (trB nat_monoid)) (trB_loop (M := nat_monoid) (S O)) x))
                  loop idpath @ _).
        apply moveR_pM.
        refine (concat_p1 _ @ _ @ (concat_1p _)^).
        apply inverse2.
        refine (_ @ (ap_idmap loop)^).
        refine (ap_compose
                  (S1_rec (trB nat_monoid) (point (trB (nat_monoid))) (trB_loop (M := nat_monoid) (S O)))
                  (trB_rec (M := nat_monoid) S1 _ base iterloop _)
                  loop @ _).
        transitivity (ap
                        (trB_rec (M := nat_monoid) S1 is1type_S1 base iterloop
                               (fun m1 : nat =>
                                  nat_rect
                                    (fun m0 : nat =>
                                       forall m2 : nat, iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                    (fun m2 : nat => concat_1p (iterloop m2))
                                    (fun (m0 : nat)
                                         (IHm1 : forall m2 : nat,
                                                   iterloop m0 @ iterloop m2 = iterloop (m0 + m2))
                                         (m2 : nat) =>
                                       concat_pp_p loop (iterloop m0) (iterloop m2) @
                                                   whiskerL loop (IHm1 m2)) m1))
                        (trB_loop (M := nat_monoid) (S O))).
        { apply (ap _).
          apply S1_rec_beta_loop. }
        refine (trB_rec_beta_l (M := nat_monoid) S1 _ base iterloop _ (S O) @ _).
        unfold iterloop. apply concat_p1.
  Defined.

  (*Lage alternativ til apD?*)

  (*Classifying space as a pointed type*)
  Definition ptrB (M : Monoid) := Build_pType (trB M) _.

  (*trB S is an abelian group*)
  Definition looptrB_abGrp (S : Symmetric_Monoid) : Abelian_Group.
  Proof.
    refine (Build_Abelian_Group (loopGroup (ptrB S)) _).
    unfold symmetric. unfold loopGroup. simpl.
    unfold mon_mult.
    unfold symmetric.
  Admitted.

  Definition grpcplS_to_loopstrB {S : Symmetric_Monoid} : Hom (group_completion S) (loopGroup (ptrB S)) :=
    extend_to_inv
      (Build_Homomorphism S (loopGroup (ptrB S)) trB_loop monid_to_idpath
                          (fun m1 m2 => (ishom_MtotrB m1 m2)^)).

  (*Fibration over trB S with fiber groupcompletion S*)
  Definition trB_code (S : Symmetric_Monoid) : trB S -> hSet.
  Proof.
    srapply @trB_rec.
        - exact (BuildTruncType 0 (group_completion S)).
        - intro a.
          apply (ap trunctype_type)^-1.
          exact (path_universe (grp_mult_equiv (to_groupcompletion a))).
        - intros m1 m2.
          apply (equiv_inj (ap trunctype_type)).
          refine (ap_pp trunctype_type _ _ @ _).
          refine (_ @ (eisretr (ap trunctype_type) _)^).
          refine (concat2 (eisretr (ap trunctype_type) _)
                          (eisretr (ap trunctype_type) _)
                          @ _).

          refine ((path_universe_compose _ _)^ @ _).
          refine (equiv_path2_universe
                    (grp_mult_equiv (to_groupcompletion m2) oE
                                    grp_mult_equiv (to_groupcompletion m1))
                    (grp_mult_equiv (to_groupcompletion (m1 + m2)))
                    (fun m => (grp_whiskerL (preserve_mult to_groupcompletion) @ grp_assoc)^) ).
  Defined.

  Definition trB_code_beta {S : Symmetric_Monoid} (m : S) :
    ap (trB_code S) (trB_loop m) =
    (ap trunctype_type)^-1 (path_universe (grp_mult_equiv (to_groupcompletion m))).
  Proof.
    srapply @trB_rec_beta_l.
  Defined.

  Definition transport_code_is_mult {S : Symmetric_Monoid} (m : S) :
    transport (trB_code S) (trB_loop m) == fun g : (group_completion S) => g + (to_groupcompletion m).
  Proof.
    srapply @Trunc_ind.
    srapply @Coeq_ind.
    - (*Variable is fixed*)
      intros [a b].
      refine (transport_compose trunctype_type (trB_code S) (trB_loop m) (tr (coeq (a, b))) @ _).

      Check (fun p : trB_code S (point (trB S)) = trB_code S (point (trB S)) =>
               transport (fun X : hSet => trunctype_type X) p (tr (coeq (a, b)))).
      refine (transport_compose idmap (trunctype_type)
                                (ap (trB_code S) (trB_loop m)) (tr (coeq (a, b))) @ _).
      assert (trB_code_beta' : ap trunctype_type (ap (trB_code S) (trB_loop m))  =
                             path_universe (grp_mult_equiv (to_groupcompletion m))).
      { refine (ap (ap trunctype_type) (trB_code_beta m) @ _).
        apply (eisretr (ap trunctype_type)). }

      refine (ap (fun p : trunctype_type (trB_code S (point (trB S))) =
                          trunctype_type (trB_code S (point (trB S))) =>
                    transport (fun X : Type => X) p (tr (coeq (a, b)))) trB_code_beta' @ _).
      refine (ap10 (transport_idmap_path_universe (grp_mult_equiv (to_groupcompletion m))) _).
    - (*Variable runs along cp*)
      intro abs.
      apply (istrunc_truncation 0).
  Defined.

  Definition transport_code_is_mult_V {S : Symmetric_Monoid} (m : S) :
    transport (trB_code S) (trB_loop m)^ == fun g : (group_completion S) => g - (to_groupcompletion m).
  Proof.
    intro x.
    refine (moveR_transport_V (trB_code S) (trB_loop m) x _ _).
    apply inverse.
    refine (transport_code_is_mult m _ @ _).
    refine (_ @ grp_rid x).
    refine (grp_assoc^ @ _).
    refine (grp_whiskerL _).
    apply grp_linv.
  Defined.

  Definition trB_encode {S : Symmetric_Monoid} (x : trB S) :
    (point _ = x) -> trB_code S x := fun p => transport (trB_code S) p (point _).

  (*I hope this is useful for proving truncations
   Something like this is probably already implemented. . .*)
  Definition generalize_paths {X : Type} {x1 x2 : X} {p1 p2 : x1 = x2} :
    (IsTrunc 0 X) -> p1 = p2.
  Proof.
    intro H. apply H.
  Defined.

  Definition trB_decode {S : Symmetric_Monoid} (x : trB S) :
    trB_code S x -> (point _ = x).
  Proof.
    revert x.
    srapply @trB_ind.
    - (*x is point*)
      simpl.
      apply grpcplS_to_loopstrB.
    - (*x is trB_loop m*)
      intro m.
      apply path_arrow. intro x.
      refine (transport_arrow (trB_loop m) _ x @ _).
      (*This is more readable, but then it protests when writing x - m*)
      (*unfold trB_code in x. simpl in x.  *)
      refine (transport_paths_r (trB_loop m) _ @ _).
      apply moveR_pM.
      refine (ap (fun g : group_completion S => grpcplS_to_loopstrB g)
                 (transport_code_is_mult_V m x) @ _).
      refine (preserve_mult grpcplS_to_loopstrB @ _).
      refine (whiskerL (grpcplS_to_loopstrB x) _).
      refine (whiskerR monid_to_idpath (trB_loop m)^ @ _).
      apply concat_1p.
    - (*x is ishom m1 m2*)
      intros m1 m2.
      srapply @generalize_paths.
  Defined.

  Definition trB_decode_beta_bp {S : Symmetric_Monoid} :
    trB_decode (point (trB S)) = grpcplS_to_loopstrB .
  Proof.
    srapply @trB_ind_beta_bp.
  Defined.

  Definition trB_encodeisretr {S : Symmetric_Monoid} (x : trB S):
    Sect (trB_encode x) (trB_decode x).
  Proof.
    intro p.
    destruct p. simpl.
    (*This should be automatic if trB_ind was properly defined:*)
    refine (ap10 trB_decode_beta_bp (point (group_completion S)) @ _).
    unfold grpcplS_to_loopstrB. simpl.
    apply concat_pV.
  Defined.

  Definition trB_encodeissect {S : Symmetric_Monoid} (x : trB S) :
    Sect (trB_decode x) (trB_encode x).
  Proof.
    revert x.
    srapply @trB_ind.
    - intro m.
      rewrite (ap10 trB_decode_beta_bp m).
      revert m.
      srapply @Trunc_ind.
      srapply @Coeq_ind.
      + intros [a b].
        unfold trB_encode.
        simpl.
        refine (transport_pp (trB_code S) (trB_loop a) (trB_loop b)^ (point (group_completion S)) @ _).
        apply (moveR_transport_V (trB_code S)).
        refine (transport_code_is_mult a _ @ _ @ (transport_code_is_mult b _)^).
        apply (ap tr).
        refine ((cp (mon_id S + a, mon_id S + mon_id S, b))^ @ _).
        apply (ap coeq).
        apply path_prod.
        { simpl.
          refine (mon_assoc^ @ _).
          apply mon_lid. }
        { simpl.
          refine (mon_assoc ^ @ _).
          refine (mon_lid _ @ _).
          exact (mon_lid b @ (mon_rid b)^). }
      + intro abs.
        srapply @generalize_paths.
    - intros m. unfold Sect.
      apply (trunc_forall (n := -1)).
    - intros m1 m2.
      srapply @generalize_paths.
  Defined.

  Definition equiv_pathstrB_code {S : Symmetric_Monoid} (x : trB S) :
    point (trB S) = x <~> trB_code S x :=
    equiv_adjointify (trB_encode x) (trB_decode x) (trB_encodeissect x) (trB_encodeisretr x).

  Definition equiv_loopstrB_group_completion (S : Symmetric_Monoid):
       loops (ptrB S) <~> group_completion S:=
    equiv_pathstrB_code (point (trB S)).

        (*Try to simplify now, didn't become simpler. . .
        refine (transport_PequivQ
                  (fun x => equiv_moveL_transport_V
                              C (pp (m1, m2, x))
                              (restriction_to_pre_B (looptofill_curried M (m1, m2, x)))
                              _)
                  loop idpath @ _).
        apply moveR_equiv_V.
        cbn. unfold equiv_inv.
        apply moveL_Vp.
        *)

        (* refine (transport_paths_FlFr_D *)
        (*           (f := fun x => transport C (pp (m1, m2, x)) *)
        (*                                    (restriction_to_pre_B (looptofill M m1 m2 x))) *)
        (*           (g := const (transport C (pp (m1, m2, base)) c0)) *)
        (*           loop idpath @ _). *)
        (* apply moveR_pM. *)
        (* refine (_ @ (concat_1p _)^). *)

        (* apply moveR_Vp. *)
        (* transitivity (idpath (transport C (pp (m1, m2, base)) c0)). *)


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.

(* Why3 goal *)
Lemma infix_plpl_def : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)),
  ((Init.Datatypes.app l1 l2) = match l1 with
  | Init.Datatypes.nil => l2
  | (Init.Datatypes.cons x1 r1) =>
      (Init.Datatypes.cons x1 (Init.Datatypes.app r1 l2))
  end).
Proof.
now intros a a_WT [|h1 q1] l2.
Qed.

Require Import Lists.List.

(* Why3 goal *)
Lemma Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)),
  ((Init.Datatypes.app l1 (Init.Datatypes.app l2 l3)) = (Init.Datatypes.app (Init.Datatypes.app l1 l2) l3)).
Proof.
intros a a_WT l1 l2 l3.
apply app_assoc.
Qed.

(* Why3 goal *)
Lemma Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((Init.Datatypes.app l Init.Datatypes.nil) = l).
Proof.
intros a a_WT l.
apply app_nil_r.
Qed.

(* Why3 goal *)
Lemma Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)),
  ((list.Length.length (Init.Datatypes.app l1 l2)) = ((list.Length.length l1) + (list.Length.length l2))%Z).
Proof.
intros a a_WT l1 l2.
rewrite 3!Length.length_std.
now rewrite app_length, inj_plus.
Qed.

(* Why3 goal *)
Lemma mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (list.Mem.mem x
  (Init.Datatypes.app l1 l2)) <-> ((list.Mem.mem x l1) \/ (list.Mem.mem x
  l2)).
Proof.
intros a a_WT x l1 l2.
split.
intros H.
apply Mem.mem_std in H.
apply in_app_or in H.
destruct H as [H|H].
left.
now apply Mem.mem_std.
right.
now apply Mem.mem_std.
intros H.
apply Mem.mem_std.
apply in_or_app.
destruct H as [H|H].
left.
now apply Mem.mem_std.
right.
now apply Mem.mem_std.
Qed.

(* Why3 goal *)
Lemma mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (list.Mem.mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons x l2))).
Proof.
intros a a_WT x l h1.
apply in_split.
now apply Mem.mem_std.
Qed.


Require Import Program.Equality.
Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import Language
               Infra
               SubDis
               Determinism.

(* --------- lambdai -------- *)
Definition i : Set := nat.

Definition sctx : Set := list ( i * typ ).

Inductive sexp :=
  | se_i : nat -> sexp
  | se_lit : nat -> sexp
  | se_unit : sexp
  | se_abs : nat -> sexp -> sexp
  | se_app : sexp -> sexp -> sexp
  | se_merge : sexp -> sexp -> sexp.

Inductive lityp : typ -> Prop :=
  | li_int : lityp int
  | li_top : lityp top
  | li_arr : forall (A B:typ),
      lityp A ->
      lityp B ->
      lityp (arr A B)
  | li_and : forall (A B:typ),
      lityp A ->
      lityp B ->
      lityp (and A B).

Definition sbinds (x : i) (A : typ) (E : list (i * typ)) : Prop := In (x, A) E.

Fixpoint sdom (E : list (i * typ)) {struct E} : list i :=
  match E with
    | nil => nil
    | (x, A) :: E' => cons x (sdom E')
  end.

Inductive suniq : list (i * typ) -> Prop :=
  | suniq_nil :
      suniq nil
  | suniq_push : forall x A E,
      suniq E ->
      ~ In x (sdom E) ->
      suniq (cons (x, A) E).

(* from normal contexts to types *)
Fixpoint ctx_sw (E : list (i * typ)) {struct E} : typ :=
  match E with
    | nil => top
    | (x, A) :: E' => and (ctx_sw E') (rcd x A)
  end.

Inductive contains: nat -> typ -> Prop:=
  | ct_rcd : forall x A,
      contains x (rcd x A)
  | ct_andl : forall x A B,
      contains x A ->
      contains x (and A B)
  | ct_andr : forall x A B,
      contains x B ->
      contains x (and A B).

Definition fresh x A := ~ (contains x A).

Inductive styping : sctx -> sexp -> typ -> exp -> Prop :=
  | styping_lit : forall (G:sctx) (i5:i),
      suniq  G  ->
      styping G (se_lit i5) int (lit i5)
  | styping_top : forall (G:sctx),
      suniq  G  ->
      styping G se_unit top unit
  | styping_var : forall (G:sctx) (x:i) (A:typ),
      suniq G  ->
      sbinds  x A G  ->
      lityp A ->
      styping G (se_i x) A (proj  ( (ann ctx (rcd x A)) )  x)
  | styping_abs : forall (G:sctx) (x:i) (A:typ) (ee:sexp) (B:typ) (e:exp),
      styping  (cons ( x , A )  G )  ee B e ->
      lityp A ->
      lityp B ->
      styping G (se_abs x ee) (arr A B) (ann (lam wh e) (arr (rcd x A) B))
  | styping_app : forall (G:sctx) (ee1 ee2:sexp) (B:typ) (e1 e2:exp) (A:typ),
      styping G ee1 (arr A B) e1 ->
      styping G ee2 A e2 ->
      lityp A ->
      lityp B ->
      styping G (se_app ee1 ee2) B (app e1 e2)
  | styping_merge : forall (G:sctx) (ee1 ee2:sexp) (B:typ) (e1 e2:exp) (A:typ) (m:nat),
    styping G ee1 A e1 ->
    styping G ee2 B e2 ->
    lityp A ->
    lityp B ->
    disjoint A B ->
    fresh m A ->
    styping G (se_merge ee1 ee2) (and A B) (box (rec m ctx) (merge (box (proj ctx m) e1) (box (proj (ann ctx (rcd m (ctx_sw G))) m) e2)))
  | styping_sub : forall (G:sctx) (ee1 ee2:sexp) (B:typ) (e1 e2:exp) (A:typ) (m:nat),
    styping G ee1 A e1 ->
    lityp A ->
    lityp B ->
    sub A B ->
    styping G ee1 B (ann e1 B).

#[export]
Hint Constructors sexp lityp suniq contains styping: core.
(* ---------------- *)

Section ListProperties.
  Variables X : Set.
  Variables x y : X.
  Variables l l1 l2 l3 : list X.

Lemma in_one :
  List.In x [ y ] <-> x = y.
Proof. clear. simpl. intuition congruence.
Qed.

Lemma in_app :
  List.In x (l1 ++ l2) <-> List.In x l1 \/ List.In x l2.
Proof. clear. split; auto using in_or_app, in_app_or.
Qed.

Lemma in_cons:
  List.In x (cons y l) -> x = y \/ List.In x l.
Proof.
  clear. simpl. intuition congruence.
Qed.

End ListProperties.

Lemma fresh_and: forall x A B,
  fresh x (and A B) ->
  fresh x A /\ fresh x B.
Proof.
  introv Hf. unfold fresh in *.
  split*.
Qed.

Lemma fresh_rcd: forall x1 x2 A,
  fresh x1 (rcd x2 A) ->
  x1 <> x2.
Proof.
  introv Hf. unfold fresh in *. intros H. subst*.
Qed.

Lemma not_ct_dis: forall A x,
  fresh x A -> forall B,
  disjoint (rcd x B) A.
Proof.
  intros A. inductions A; introv Hnc; intros B.
  - unfold disjoint. intros Hc. eapply costs_sym in Hc.
    eapply costs_int_rcd; eauto.
  - unfold disjoint. intros Hc. eapply costs_sym in Hc.
    eapply costs_top_any; eauto.
  - forwards* (?&?): fresh_and Hnc.
    forwards* :IHA1 H B. forwards* :IHA2 H0 B.
    eapply dis_sym. eapply dis_to_inter;
    try solve [eapply dis_sym; eauto].
  - forwards*: fresh_rcd Hnc.
    unfold disjoint. intros Hc.
    forwards*: costs_rcd_rcd_neq H Hc.
  - unfold disjoint. intros Hc.
    eapply costs_arr_rcd; eauto.
Qed.

Lemma ctx_suniq: forall G ee B e,
  styping G ee B e ->
  suniq G.
Proof.
  introv Typ.
  lets Typ': Typ.
  inductions Typ; try eauto.
  - forwards~: IHTyp Typ. inverts* H1.
Qed.

Lemma notin_dis: forall x G,
  ~ In x (sdom G) -> forall A,
  disjoint (rcd x A) (ctx_sw G).
Proof.
  introv Hnot. inductions G; intros A.
  - simpl. eapply dis_sym. unfold disjoint. eapply costs_top_any.
  - simpl. simpl in Hnot. destruct a.
    assert (x <> i0) as Hin1. {
      intros Hbot. eapply Hnot. simpl. left. eauto.
    }
    assert (~ In x (sdom G)) as Hin2. {
      intros Hbot. eapply Hnot. simpl. right*.
    }
    eapply dis_sym. eapply dis_to_inter.
    eapply dis_sym. eapply IHG. eauto.
    unfold disjoint. intros Hc. eapply costs_rcd_rcd_neq; eauto. eapply costs_sym. eauto.
Qed.

Theorem encoding_complete: forall sctx A ee e,
  styping sctx ee A e ->
  has_type (ctx_sw sctx) e inf A.
Proof.
  introv Typ.
  inductions Typ; eauto.
  - econstructor; try eauto. econstructor.
    inductions G.
    + inverts* H0.
    + unfold sbinds in H0.
      forwards~ [He|Hnot]: in_cons H0.
      * simpl. subst. eauto.
      * econstructor.
        econstructor.
        simpl.
        destruct a.
        inverts H.
        forwards~: IHG H4 Hnot.
        inverts H. inverts* H2.
  - econstructor; try eauto.
    simpl in IHTyp.
    forwards~ Huq: ctx_suniq Typ.
    inverts* Huq.
    eapply dis_sym.
    eapply notin_dis.
    eauto.
  - econstructor; try eauto.
    econstructor; eauto.
    + econstructor; eauto.
    + eapply not_ct_dis. eauto.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype finfun bigop finset.
Require Import Reals Fourier.
Require Import ssrR Reals_ext Ranalysis_ext ssr_ext logb ln_facts bigop_ext.
Require Import Rbigop proba divergence log_sum variation_dist.

(** * Partition inequality (special case for distributions other sets with 2 elements) *)

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

Local Open Scope divergence_scope.

Local Notation "0" := (false).
Local Notation "1" := (true).

Section bipart_sect.

Variable A : finType.
Variable A_ : bool -> {set A}.
Hypothesis dis : A_ 0 :&: A_ 1 = set0.
Hypothesis cov : A_ 0 :|: A_ 1 = [set: A].
Variable P : dist A.

Definition bipart_pmf i := \rsum_(a in A_ i) P a.

Definition bipart : dist [finType of bool].
apply makeDist with bipart_pmf.
- move=> a; apply: rsumr_ge0. by move=> *; exact/dist_ge0.
  rewrite Set2sumE /= ?card_bool // => HX; rewrite /bipart_pmf.
  set a := Set2.a HX. set b := Set2.b HX.
  have : a <> b by apply/eqP/Set2.a_neq_b.
  wlog : a b / (a == false) && (b == true).
    move=> Hwlog b01.
    have : ((a, b) == (true, false)) || ((a, b) == (false, true)).
      move: a b b01; by case; case.
    case/orP; case/eqP => -> ->.
    - by rewrite addRC Hwlog.
    - exact: Hwlog.
  case/andP => /eqP -> /eqP -> _.
  transitivity (\rsum_(a | (a \in A_ 0 :|: A_ 1)) P a).
    by rewrite [X in _ = X](@big_union _ _ _ _ (A_ 0) (A_ 1)) // -setI_eq0 setIC dis eqxx.
  rewrite cov -(pmf1 P).
  apply eq_bigl => /= x; by rewrite in_setT inE.
Defined.

End bipart_sect.

Local Open Scope proba_scope.
Local Open Scope reals_ext_scope.

Section bipart_lem.

Variable A : finType.
Variable A_ : bool -> {set A}.
Hypothesis dis : A_ 0 :&: A_ 1 = set0.
Hypothesis cov : A_ 0 :|: A_ 1 = setT.
Variable P Q : dist A.
Hypothesis P_dom_by_Q : P << Q.

Let P_A := bipart dis cov P.
Let Q_A := bipart dis cov Q.

Lemma partition_inequality : D(P_A || Q_A) <= D(P || Q).
Proof.
have -> : D(P || Q) = \rsum_(a in A_ 0) P a * log (P a / Q a) +
                      \rsum_(a in A_ 1) P a * log (P a / Q a).
  rewrite /div -big_union //; last by rewrite -setI_eq0 setIC dis eqxx.
  apply eq_big => // a; first by rewrite cov in_set inE.
  move=> _.
  case/Rle_lt_or_eq_dec: (dist_ge0 P a) => Pa.
    case/Rle_lt_or_eq_dec: (dist_ge0 Q a) => Qa.
      rewrite /log LogM // ?LogV //; exact/invR_gt0.
    symmetry in Qa. rewrite (P_dom_by_Q Qa) in Pa. by apply ltRR in Pa.
  by rewrite -Pa 2!mul0R.
have step2 :
  (\rsum_(a in A_ 0) P a) * log ((\rsum_(a in A_ 0) P a) / \rsum_(a in A_ 0) Q a) +
  (\rsum_(a in A_ 1) P a) * log ((\rsum_(a in A_ 1) P a) / \rsum_(a in A_ 1) Q a) <=
  \rsum_(a in A_ 0) P a * log (P a / Q a) + \rsum_(a in A_ 1) P a * log (P a / Q a).
  apply leR_add; by apply log_sum.
apply: (leR_trans _ step2) => {step2}.
rewrite [X in _ <= X](_ : _ =
  P_A 0 * log ((P_A 0) / (Q_A 0)) + P_A 1 * log ((P_A 1) / (Q_A 1))) //.
rewrite /div Set2sumE ?card_bool // => B.
rewrite [P_A]lock [Q_A]lock /= -!lock.
move: (Set2.a_neq_b B).
set a := Set2.a B. set b := Set2.b B.
wlog : a b / (a == 0) && (b == 1).
  move=> Hwlog i0i1.
  have : ((a, b) == (1, 0)) || ((a, b) == (0, 1)).
    destruct a; destruct b => //.
    move: a b i0i1.
    case=> //.
      case=> // _ _.
      rewrite addRC.
      exact: Hwlog.
    case=> // _ _.
    exact: Hwlog.
case/andP => /eqP -> /eqP -> _ {a b}.
have [A0_P_neq0 | /esym A0_P_0] : {0 < P_A 0} + {0%R = P_A 0}.
  apply Rle_lt_or_eq_dec; apply: rsumr_ge0 => i _; exact/dist_ge0.
- have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}.
    apply Rle_lt_or_eq_dec; apply: rsumr_ge0 => i _; exact/dist_ge0.
  + have [A0_Q__neq0 | /esym A0_Q_0] : {0 < Q_A 0} + {0%R = Q_A 0}.
      apply Rle_lt_or_eq_dec; apply: rsumr_ge0 => i _; exact/dist_ge0.
    * rewrite /Rdiv /log LogM //; last exact/invR_gt0.
      rewrite LogV //.
      have [A1_P_neq0 | /esym A1_P_0] : {0 < P_A 1} + {0%R = P_A 1}.
        apply Rle_lt_or_eq_dec; apply: rsumr_ge0 => i _; exact/dist_ge0.
      - rewrite /log LogM //; last exact/invR_gt0.
        rewrite LogV //.
        apply Req_le; by field.
      - rewrite A1_P_0 !mul0R addR0; exact/Req_le.
    * move/prsumr_eq0P in A0_Q_0.
      have {A0_Q_0}A0_Q_0 : forall i : A, i \in A_ 0 -> P i = 0%R.
        move=> i ?; rewrite P_dom_by_Q // A0_Q_0 // => a ?; exact/pos_f_ge0.
      have Habs : P_A 0 = 0%R.
        transitivity (\rsum_(H|H \in A_ 0) 0%R).
          apply eq_big => // i Hi; by rewrite -A0_Q_0.
        by rewrite big_const iter_addR mulR0.
      move: A0_P_neq0.
      rewrite Habs; by move/ltRR.
  + have H2 : P_A 1 = 0%R.
      move/prsumr_eq0P in A1_Q_0.
      rewrite /bipart /= /bipart_pmf (eq_bigr (fun=> 0%R)).
        by rewrite big_const iter_addR mulR0.
      move=> a ?; rewrite P_dom_by_Q // A1_Q_0 // => b ?; exact/pos_f_ge0.
    rewrite H2 !mul0R !addR0.
    have H3 : Q_A 0 = 1%R.
      rewrite -[X in X = _]addR0 -[X in _ + X = _]A1_Q_0 -(pmf1 Q).
      rewrite -big_union //.
      apply eq_bigl => i; by rewrite cov in_set inE.
      by rewrite -setI_eq0 -dis setIC.
    rewrite H3 /Rdiv /log LogM // ; last by fourier.
    rewrite LogV; last by fourier.
    apply Req_le; by field.
- have H1 : P_A 1 = 1%R.
    rewrite -[X in X = _]add0R -[X in X + _ = _]A0_P_0 -(pmf1 P).
    rewrite -big_union //.
    apply eq_bigl => i; by rewrite cov in_set inE.
    by rewrite -setI_eq0 -dis setIC.
  have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}.
    apply Rle_lt_or_eq_dec; apply: rsumr_ge0 => i _; exact/dist_ge0.
  + rewrite A0_P_0 !mul0R !add0R H1 !mul1R.
    rewrite /Rdiv /log LogM; last 2 first.
      by fourier.
      exact/invR_gt0.
    rewrite /log LogV //; apply Req_le; by field.
  + (* contradiction H1 / Bi_true_Q_0 *)
    move/prsumr_eq0P in A1_Q_0.
    have : P_A 1 = 0%R.
      rewrite /bipart /= /bipart_pmf (eq_bigr (fun=> 0%R)).
      by rewrite big_const iter_addR mulR0.
      move=> a ?; rewrite P_dom_by_Q // A1_Q_0 // => b ?; exact/pos_f_ge0.
    move=> abs; rewrite abs in H1. fourier.
Qed.

End bipart_lem.