(* This file implements a number of (endo?)morphisms? *)
Require Import DirectedGraphs.
Require Import Setoid Bool MSetProperties.
(* Need to make sure this doesn't pollute the definitions in bool_scope *)

Open Scope bool.

Module DirectedGraphMorph (DG : DirectedGraphs).
  (* Declare Module Import DG : DirectedGraphs. *)
  Import DG.

    Inductive EqualGraph : t -> t -> Prop :=
    | GraphEQ : forall g1 g2,
                  (enumVertices g1) =V= (enumVertices g2) ->
                  (enumEdges g1) =E= (enumEdges g2) ->
                    EqualGraph g1 g2.

    Definition equalGraph : t -> t -> bool :=
      fun G1 G2 =>
        Vertices.equal (enumVertices G1) (enumVertices G2) &&
        Edges.equal (enumEdges G1) (enumEdges G2).

    Notation "G1 =G= G2" := (EqualGraph G1 G2) (at level 60).

    Definition Respectful (A : Type) (f : t -> A) : Prop :=
      forall G1 G2, G1 =G= G2 -> f G1 = f G2.

    Lemma EqualGraphP G1 G2 : reflect (G1 =G= G2) (equalGraph G1 G2).
    Proof.
      case_eq (equalGraph G1 G2); intros H0;
      unfold equalGraph in H0; constructor;
      [apply andb_true_iff in H0 | apply andb_false_iff in H0; intros H2].
      destruct H0 as [H0 H1]; constructor;
      [apply Vertices.equal_spec | apply Edges.equal_spec]; auto.
      inversion H2. destruct H0 as [H0 | H0];
      [rewrite <- Vertices.equal_spec in H |
       rewrite <- Edges.equal_spec in H1]; congruence.
    Qed.

  (* Lemmas for weakening graph equality *)
    Lemma EqualGraph_weakVertices :
      forall G1 G2, G1 =G= G2 -> (enumVertices G1 =V= enumVertices G2).
    Proof.
      intros G1 G2 H; destruct H as [H0 H1]; auto.
    Qed.

    Lemma EqualGraph_weakEdges :
      forall G1 G2, G1 =G= G2 -> (enumEdges G1 =E= enumEdges G2).
    Proof.
      intros G1 G2 H; destruct H as [H0 H1]; auto.
    Qed.

  (* Relational proofs for easier rewriting *)
    Lemma EqualGraph_equiv : Equivalence EqualGraph.
    Proof.
      do 2 constructor;
      destruct Edges.eq_equiv as [e0 e1 e2];
      destruct Vertices.eq_equiv as [v0 v1 v2].
      apply v0. apply e0.
      destruct H as [H H']; apply v1 ; auto.
      destruct H as [H H']; apply e1 ; auto.
      destruct H as [H H']; destruct H0 as [H0 H0']; apply (v2 _ _ _ H1 H3).
      destruct H as [H H']; destruct H0 as [H0 H0']; apply (e2 _ _ _ H2 H4).
    Qed.

    Add Parametric Relation : t EqualGraph
      reflexivity proved by (Equivalence.equiv_reflexive EqualGraph_equiv)
      symmetry proved by (Equivalence.equiv_symmetric EqualGraph_equiv)
      transitivity proved by (Equivalence.equiv_transitive EqualGraph_equiv)
    as eqGraph.

    Definition destructEdge_eq1 (e1 e2 : edge): Prop :=
      fst (destructEdge e1) =v= fst (destructEdge e2).

    Definition destructEdge_eq2 (e1 e2 : edge) : Prop :=
      snd (destructEdge e1) =v= snd (destructEdge e2).

    Lemma destructEdge_eq1_r : Equivalence destructEdge_eq1.
      Proof.
        constructor;
        unfold destructEdge_eq1; intros x; try reflexivity; auto.
        intros.
        rewrite H.
        reflexivity.
        intros.
        rewrite H.
        rewrite H0.
        reflexivity.
      Qed.

   Lemma destructEdge_eq2_r : Equivalence destructEdge_eq2.
     Proof.
       constructor;
         unfold destructEdge_eq2; intros x; try reflexivity; auto.
       intros.
       rewrite H.
       reflexivity.
       intros.
       rewrite H.
       rewrite H0.
       reflexivity.
     Qed.

    Add Parametric Relation : edge  destructEdge_eq1
        reflexivity proved by (Equivalence.equiv_reflexive destructEdge_eq1_r)
        symmetry proved by (Equivalence.equiv_symmetric destructEdge_eq1_r)
        transitivity proved by (Equivalence.equiv_transitive destructEdge_eq1_r)
          as destruct_eq_r_1.

    Add Parametric Relation : edge  destructEdge_eq2
        reflexivity proved by (Equivalence.equiv_reflexive destructEdge_eq2_r)
        symmetry proved by (Equivalence.equiv_symmetric destructEdge_eq2_r)
        transitivity proved by (Equivalence.equiv_transitive destructEdge_eq2_r)
          as destruct_eq_r_2.

    Add Morphism buildEdge
        with signature Vertices.E.eq ==> Vertices.E.eq ==> Edges.E.eq
          as buildEdge_morph.
    Proof.
      intros.
      apply buildEdge_spec; auto.
    Qed.

    Add Morphism destructEdge
        with signature Edges.E.eq ==> Vertices.E.eq * Vertices.E.eq
                                  as destructEdge_morph.
    Proof.
      intros.
      split.
      apply destructEdge_spec1.
      auto.
      apply destructEdge_spec2.
      auto.
    Qed.

    Add Morphism destructEdge_eq1
        with signature destructEdge_eq1 ==> Edges.E.eq ==> iff
          as destructEdge_eq1_morph.
    Proof.
      intros; split; intros;
      unfold destructEdge_eq1 in *.
      rewrite <- H0;
      rewrite <- H1;
      symmetry.
      auto.
      rewrite H0.
      rewrite H.
      auto.
    Qed.

    Add Morphism destructEdge_eq2
        with signature destructEdge_eq2 ==> Edges.E.eq ==> iff
          as destructEdge_eq2_morph.
    Proof.
      intros; split; intros;
      unfold destructEdge_eq2 in *.
      rewrite <- H0;
      rewrite <- H1;
      symmetry.
      auto.
      rewrite H0.
      rewrite H.
      auto.
    Qed.

    Add Morphism enumVertices
      with signature EqualGraph ==> Vertices.eq
    as enumVertices_morph.
    Proof.
      intros G1 G2 H0; apply EqualGraph_weakVertices in H0; auto.
    Qed.

    Add Morphism enumEdges
      with signature EqualGraph ==> Edges.eq
    as enumEdges_morph.
    Proof.
      intros G1 G2 H0; apply EqualGraph_weakEdges in H0; auto.
    Qed.

    Add Morphism IsVertex
      with signature Vertices.E.eq ==> EqualGraph ==> iff
    as IsVertex_morph.
    Proof.
      intros v1 v2 H0 G1 G2 H1.
      destruct H1 as [H1 H2].
      do 2 rewrite IsVertexEnum.
      rewrite H0. split; intros H4;
      apply H; auto.
    Qed.

    Add Morphism IsEdge
      with signature Edges.E.eq ==> EqualGraph ==> iff
    as IsEdges_morph.
    Proof.
      intros e1 e2 H0 G1 G2 H1.
      destruct H1 as [H1 H2].
      do 2 rewrite IsEdgeEnum.
      rewrite H0. split; intros H4;
      apply H3; auto.
    Qed.

    Add Morphism addVertex
      with signature Vertices.E.eq ==> EqualGraph ==> EqualGraph
    as addVertex_morph.
    Proof.
      intros v1 v2 H0 G1 G2 H1.
      constructor; intros v.
      {
        case (Vertices.E.eq_dec v v1); intros H2.
        {
          rewrite H2. rewrite H0 at 3.
          do 2 rewrite <- IsVertexEnum;
          split; intros _; apply addVertex_spec1.
        }
        {
          do 2 rewrite <- IsVertexEnum.
          split; intros H3; apply addVertex_spec2;
          apply addVertex_spec2 in H3; auto.
          rewrite <- H0; auto. rewrite <- H1; auto.
          rewrite <- H0; auto. rewrite H1; auto.
          rewrite <- H0; auto.
        }
      }
      {
        do 2 rewrite <- IsEdgeEnum;
        do 2 rewrite <- addVertex_spec3;
        rewrite H1. split; auto.
      }
    Qed.

    Add Morphism addEdge
      with signature Edges.E.eq ==> EqualGraph ==> EqualGraph
    as addEdge_morph.
    Proof.
      intros e1 e2 H0 G1 G2 H1.
      constructor; intros e.
      {
        do 2 rewrite <- IsVertexEnum;
        do 2 rewrite <- addEdge_spec3;
        rewrite H1. split; auto.
      }
      {
        do 2 rewrite <- IsEdgeEnum.
        case (Edges.E.eq_dec e e1); intros H2.
        {
          rewrite H2. split; intros H3;
          [rewrite H0; rewrite H0 in H3 at 1 |];
          apply addEdge_spec1.
          apply Edge_exists1 in H3.
          apply addEdge_spec3 in H3.
          rewrite <- H1; auto.
          apply Edge_exists2 in H3.
          apply addEdge_spec3 in H3.
          rewrite <- H1; auto.
          apply Edge_exists1 in H3.
          apply addEdge_spec3 in H3.
          rewrite H1; auto.
          apply Edge_exists2 in H3.
          apply addEdge_spec3 in H3.
          rewrite H1; auto.
        }
        {
          split; intros H3;
          apply addEdge_spec2 in H3; auto. apply addEdge_spec2.
          rewrite <- H0; auto. rewrite <- H1; auto.
          apply addEdge_spec2; auto. rewrite <- H1 in H3; auto.
          rewrite <- H0; auto.
        }
      }
    Qed.

    (* Consider deleting *)
    Add Morphism (fun e g => IsEdge e g /\
                             IsVertex (fst (destructEdge e)) g)
      with signature Edges.E.eq ==> EqualGraph ==> iff
    as EdgeDest1.
    Proof.
      intros e1 e2 H0 G1 G2 H1.
      split; intros [H2 H3]; split.
      + rewrite <- H0, <- H1. auto.
      + rewrite H0, H1 in H2. apply Edge_exists1 in H2; auto.
      + rewrite <- H0, <- H1 in H2. auto.
      + rewrite <- H0, <- H1 in H2. apply Edge_exists1 in H2; auto.
    Qed.

    Add Morphism (fun e g => IsEdge e g /\
                             IsVertex (snd (destructEdge e)) g)
      with signature Edges.E.eq ==> EqualGraph ==> iff
    as EdgeDest2.
    Proof.
      intros e1 e2 H0 G1 G2 H1.
      split; intros [H2 H3]; split.
      + rewrite <- H0, <- H1. auto.
      + rewrite H0, H1 in H2. apply Edge_exists2 in H2; auto.
      + rewrite <- H0, <- H1 in H2. auto.
      + rewrite <- H0, <- H1 in H2. apply Edge_exists2 in H2; auto.
    Qed.

  Module Import VertProperties := OrdProperties Vertices.
  Module Import EdgeProperties := OrdProperties Edges.

Inductive GraphConst1 : t -> Type :=
  | EmptyGraph1 : GraphConst1 empty
  | AddVert1 : forall G v, (GraphConst1 G) -> GraphConst1 (addVertex v G)
  | AddEdge1 : forall G e, (GraphConst1 G) -> GraphConst1 (addEdge e G).

(* These definitions could use to be somewhere else *)
  Definition addVertices V G : t :=
    Vertices.fold (fun v g => addVertex v g) V G.

  Definition addEdges E G : t :=
    Edges.fold (fun e G => addEdge e G) E G.

(* Same for these lemmas *)
  Lemma addVertex_pres :
    forall v1 v2 G, IsVertex v1 G ->
      IsVertex v1 (addVertex v2 G).
  Proof.
    intros v1 v2 G H.
    case (Vertices.E.eq_dec v1 v2); intros H2.
    rewrite H2. apply addVertex_spec1.
    apply addVertex_spec2; auto.
  Qed.

  Lemma addVertices_pres :
    forall v V G, IsVertex v G ->
      IsVertex v  (addVertices V G).
  Proof.
    intros v V G H.
    unfold addVertices.
    apply VertProperties.P.fold_rec_weak; try (auto; fail).
    intros x a s s' H0. apply addVertex_pres; auto.
  Qed.

  Lemma addEdge_pres :
    forall e1 e2 G, IsEdge e1 G ->
      IsEdge e1 (addEdge e2 G).
  Proof.
    intros e1 e2 G H0.
    case (Edges.E.eq_dec e1 e2); intros H2.
    rewrite H2. apply addEdge_spec1.
    apply Edge_exists1. rewrite <- H2; auto.
    apply Edge_exists2. rewrite <- H2; auto.
    apply addEdge_spec2; auto.
  Qed.

  Lemma transposeAddVertex :
    transpose EqualGraph (fun (v0 : Vertices.elt) (G0 : t) => addVertex v0 G0).
  Proof.
    intros v1 v2 G. constructor.
    + intros v. do 2 rewrite <- IsVertexEnum.
      split; intros.
      case (Vertices.E.eq_dec v v2); intros.
        rewrite e. apply addVertex_spec1.
        apply addVertex_spec2; auto.
          case (Vertices.E.eq_dec v v1); intros.
          rewrite e. apply addVertex_spec1.
          apply addVertex_spec2; auto.
          do 2 apply addVertex_spec2 in H; auto.
      case (Vertices.E.eq_dec v v1); intros.
        rewrite e. apply addVertex_spec1.
        apply addVertex_spec2; auto.
          case (Vertices.E.eq_dec v v2); intros.
          rewrite e. apply addVertex_spec1.
          apply addVertex_spec2; auto.
          do 2 apply addVertex_spec2 in H; auto.
    + intros e. do 2 rewrite <- IsEdgeEnum. split; intros;
      do 2 apply addVertex_spec3 in H; do 2 apply addVertex_spec3; auto.
  Qed.

  Lemma transposeAddEdge :
    transpose EqualGraph (fun (e0 : Edges.elt) (G0 : t) => addEdge e0 G0).
  Proof.
    split. unfold Vertices.eq.
    + split; intros; try rewrite <- IsVertexEnum in *;
      try do 2 rewrite <- addEdge_spec3 in *; auto.
    + split; intros; rewrite <- IsEdgeEnum in *.
      case (Edges.E.eq_dec a y); intros.
      rewrite e in H |-*.
      - assert (IsVertex (fst (destructEdge y)) z) as H0.
          apply Edge_exists1 in H; do 2 rewrite <- addEdge_spec3 in H; auto.
        assert (IsVertex (snd (destructEdge y)) z) as H1.
          apply Edge_exists2 in H; do 2 rewrite <- addEdge_spec3 in H; auto.
        apply addEdge_spec1; apply addEdge_spec3; auto.
      - apply addEdge_spec2; auto. case (Edges.E.eq_dec a x); intros.
        rewrite e in H |-*.  apply addEdge_spec1;
        [apply Edge_exists1 in H | apply Edge_exists2 in H];
        do 2 apply addEdge_spec3 in H; auto. do 2 apply addEdge_spec2 in H; auto.
        apply addEdge_spec2; auto.
      - case (Edges.E.eq_dec a x); intros.
        rewrite e in H |-*.
        * assert (IsVertex (fst (destructEdge x)) z) as H0.
            apply Edge_exists1 in H; do 2 rewrite <- addEdge_spec3 in H; auto.
          assert (IsVertex (snd (destructEdge x)) z) as H1.
            apply Edge_exists2 in H; do 2 rewrite <- addEdge_spec3 in H; auto.
          apply addEdge_spec1; auto; apply addEdge_spec3; auto.
        * apply addEdge_spec2; auto. case (Edges.E.eq_dec a y); intros.
        rewrite e in H |-*.  apply addEdge_spec1;
        [apply Edge_exists1 in H | apply Edge_exists2 in H];
        do 2 apply addEdge_spec3 in H; auto. do 2 apply addEdge_spec2 in H; auto.
        apply addEdge_spec2; auto.
  Qed.

  Lemma addEdges_pres :
    forall e E G, IsEdge e G ->
      IsEdge e (addEdges E G).
  Proof.
    intros. unfold addEdges. apply EdgeProperties.P.fold_rec_weak;
    try solve [auto | split; auto].
    intros e1 g V H0 H1. apply addEdge_pres; auto.
  Qed.

  Lemma addEdges_spec2 :
    forall v E G, IsVertex v (addEdges E G) <-> IsVertex v G.
  Proof.
    intros v E G. unfold addEdges. apply P.fold_rec_weak.
    auto. split; auto.
    intros. rewrite <- H0. symmetry. apply addEdge_spec3.
  Qed.
(*
  Lemma addEdges_morph_aux1 :
    forall E1 E2 G, E1 =E= E2 -> addEdges E1 G =G= addEdges E2 G.
  Proof.
    intros. split.
    + intros v; split; intros H0; rewrite <- IsVertexEnum in *;
      apply addEdges_spec2 in H0; apply addEdges_spec2; auto.
    + intros e; split; intros H0; rewrite <- IsEdgeEnum in *;
      unfold addEdges in *. admit. admit.
  Admitted.
*)
  Lemma addEdges_morph_aux2 :
    forall E G1 G2, G1 =G= G2 -> addEdges E G1 =G= addEdges E G2.
  Proof.
    intros. split.
    + intros v; split; intros H0; rewrite <- IsVertexEnum in *;
      apply addEdges_spec2 in H0; apply addEdges_spec2;
      [rewrite <- H | rewrite H]; auto.
    + unfold addEdges. intros v. do 2 rewrite <- IsEdgeEnum.
      induction E using P.set_induction.
      - split; intros; rewrite P.fold_1b in *; auto;
        [rewrite <- H | rewrite H]; auto.
      - intros. rewrite (@P.fold_2 E1 E2 x); auto. rewrite (@P.fold_2 E1 E2 x); auto.
        case (Edges.E.eq_dec v x); intros.
        * rewrite e. split; intros; apply addEdge_spec1; apply addEdges_spec2;
          [apply Edge_exists1 in H2 | apply Edge_exists2 in H2 |
           apply Edge_exists1 in H2 | apply Edge_exists2 in H2];
          apply addEdge_spec3 in H2; apply addEdges_spec2 in H2;
          [rewrite <- H | rewrite <- H | rewrite H | rewrite H]; auto.
        * split; intros H2; apply addEdge_spec2; auto;
          apply addEdge_spec2 in H2; auto; apply IHE1; auto.
        * apply EqualGraph_equiv.
        * intros e1 e2 H2 Ga Gb H3. rewrite H3, H2. apply EqualGraph_equiv.
        * apply transposeAddEdge.
        * apply EqualGraph_equiv.
        * intros e1 e2 H2 Ga Gb H3. rewrite H3, H2. apply EqualGraph_equiv.
        * apply transposeAddEdge.
  Qed.

  Add Morphism addEdges
      with signature Edges.eq ==> EqualGraph ==> EqualGraph
  as addEdges_morph.
  Proof.
    intros. assert (addEdges y x0 =G= addEdges x x0) as H1.
    unfold addEdges. apply P.fold_equal. apply EqualGraph_equiv.
    intros e1 e2 H1 g1 g2 H2. rewrite H2, H1. apply EqualGraph_equiv.
    apply transposeAddEdge. symmetry. apply H. rewrite <- H1.
    apply addEdges_morph_aux2. auto.
  Qed.

 (* Is there a term for possessing the added elements? *)
  Lemma addVertices_spec1 :
    forall v V G, Vertices.In v V -> IsVertex v (addVertices V G).
  Proof.
    intros v V G. unfold addVertices.
    apply VertProperties.P.fold_rec_weak.
    intros s s' H0 H1 H2 H3. rewrite H1 in H2. apply H2; auto.
    intros H. apply Vertices.empty_spec in H; contradiction.
    intros x a s H0 H1 H2. case (Vertices.E.eq_dec v x); intros H3.
    rewrite H3; apply addVertex_spec1.
    apply addVertex_spec2; auto. apply H1. apply Vertices.add_spec in H2.
    case H2; auto. intros H4. apply H3 in H4. contradiction.
  Qed.

  Lemma addVertices_spec2 :
    forall e V G, IsEdge e (addVertices V G) <-> IsEdge e G.
  Proof.
    intros e V G.
    unfold addVertices.
    apply VertProperties.P.fold_rec_weak; try solve [auto | split; auto].
    intros s s' G1 H0 H1; auto. rewrite <- H1.
    rewrite <- addVertex_spec3; split; auto.
  Qed.

  Lemma addEdges_spec1 :
    forall E e G, (IsVertex (fst (destructEdge e)) G) ->
                (IsVertex (snd (destructEdge e)) G) ->
                Edges.In e E -> IsEdge e (addEdges E G).
  Proof.
    intros E. induction E using P.set_induction_bis.
    + intros. rewrite <- H in H2. specialize (IHE1 e G H0 H1 H2).
      assert (addEdges E1 G =G= addEdges E2 G) as H3. rewrite H.
      reflexivity. rewrite <- H. auto.
    + intros. apply Edges.empty_spec in H1. contradiction.
    + intros. unfold addEdges. rewrite P.fold_add.
      apply Edges.add_spec in H2. case H2; intros.
      - rewrite <- H3. apply addEdge_spec1; apply addEdges_spec2; auto.
      - apply (IHE _ _ H0 H1) in H3. apply addEdge_pres. auto.
      - apply EqualGraph_equiv.
      - unfold respectful. unfold Proper. intros. rewrite H3, H4.
        apply EqualGraph_equiv.
      - apply transposeAddEdge.
      - auto.
  Qed.

  (* Rebuilds the graph according to the graph const *)
  Definition rebuildGraph_GraphConst1 G : t :=
    addEdges (enumEdges G) (addVertices (enumVertices G) empty).

  Lemma addVertices_bleh :
    forall v V, Vertices.In v V -> Vertices.In v (enumVertices (addVertices V empty)).
  Proof.
    intros. rewrite <- IsVertexEnum.
    apply addVertices_spec1; auto.
  Qed.

  Lemma emptyVerts : forall G, IsEmpty G -> forall v, ~ IsVertex v G.
  Proof.

  Admitted.

  Lemma emptyEdges : forall G, IsEmpty G -> forall e, ~ IsEdge e G.
  Proof.

  Admitted.

  Lemma rebuildGraph_GraphConst1_spec1 :
    forall G, (rebuildGraph_GraphConst1 G) =G= G.
  Proof.
    intros G. constructor.
    + unfold rebuildGraph_GraphConst1. intros v.
      do 2 rewrite <- IsVertexEnum. rewrite addEdges_spec2.
      - do 2 rewrite IsVertexEnum.
        induction (enumVertices G) using VertProperties.P.set_induction.
        * unfold addVertices. rewrite VertProperties.P.fold_1b.
          generalize (Empty); intros. apply emptyVerts with (v := v) in H0.
          split; intros. rewrite <- IsVertexEnum in H1. contradiction.
          apply H in H1. contradiction. auto.
        * split; intros.
            unfold addVertices in H1.
            rewrite (@VertProperties.P.fold_2 t0_1 t0_2 x) in H1; auto.
            case (Vertices.E.eq_dec v x); intros H3. rewrite H3. apply H0.
            left. reflexivity. apply H0. right. apply IHt0_1.
            rewrite <- IsVertexEnum in H1. apply addVertex_spec2 in H1; auto.
            rewrite <- IsVertexEnum. apply H1. apply EqualGraph_equiv.
            intros a b H' c d H''. rewrite H', H''. reflexivity.
            apply transposeAddVertex. rewrite <- IsVertexEnum.
            apply addVertices_spec1. auto.
    + unfold rebuildGraph_GraphConst1.
      intros e. do 2 rewrite <- IsEdgeEnum. split.
      - intros. rewrite IsEdgeEnum.
        remember (enumEdges G).
        induction (t0) using EdgeProperties.P.set_induction.
        * unfold addEdges in H. rewrite EdgeProperties.P.fold_1b in H.
          rewrite addVertices_spec2 in H. generalize Empty; intros H1.
          apply emptyEdges with (e := e) in H1. contradiction. auto.
        * apply P.Add_Equal in H1. rewrite H1. unfold addEdges in H.
          admit. (* still needs some work *)
          (* rewrite (@EdgeProperties.P.fold_2 t1_1 t1_2 e) in H; auto.
          admit. apply EqualGraph_equiv.
          intros e1 e2 H' g1 g2 H''. rewrite H', H''. reflexivity.
          apply transposeAddEdge. *)
      - intros H. apply addEdges_spec1;
        try (apply addVertices_spec1; rewrite <- IsVertexEnum).
        apply Edge_exists1; auto. apply Edge_exists2; auto.
        rewrite <- IsEdgeEnum; auto.
  Admitted.

  Lemma rebuildGraph_GraphConst1_spec2 :
    forall G, GraphConst1 (rebuildGraph_GraphConst1 G).
  Proof.
    intros G. unfold rebuildGraph_GraphConst1, addEdges, addVertices.
    apply EdgeProperties.P.fold_rec_weak;
      try apply VertProperties.P.fold_rec_weak; try constructor; auto.
  Qed.

  Lemma ind1 (P : t -> Prop) (H0 : Respectful Prop P) :
    P empty ->
    (forall x g, P g -> P (addVertex x g)) ->
    (forall x g, P g -> P (addEdge x g)) ->
      forall g, P g.
  Proof.
    intros.
    unfold Respectful in H0.
    rewrite <- (H0 (rebuildGraph_GraphConst1 g) g).
    induction (rebuildGraph_GraphConst1_spec2 g);
    auto. apply rebuildGraph_GraphConst1_spec1.
  Qed.

  Lemma rec1 (P : t -> Set) ( H0 : Respectful _ P) :
    P empty ->
    (forall x g, P g -> P (addVertex x g)) ->
    (forall x g, P g -> P (addEdge x g)) ->
      forall g, P g.
  Proof.
    intros.
    unfold Respectful in H0.
    rewrite <- (H0 (rebuildGraph_GraphConst1 g) g).
    induction (rebuildGraph_GraphConst1_spec2 g);
    auto.
    apply rebuildGraph_GraphConst1_spec1.
  Qed.

  Lemma rect1 :
    forall (P : t -> Type) (H0 : Respectful _ P),
      P empty ->
      (forall x g, P g -> P (addVertex x g)) ->
      (forall x g, P g -> P (addEdge x g)) ->
        forall g, P g.
  Proof.
    intros.
    unfold Respectful in H0.
    rewrite <- (H0 (rebuildGraph_GraphConst1 g) g).
    induction (rebuildGraph_GraphConst1_spec2 g);
    auto.
    apply rebuildGraph_GraphConst1_spec1.
  Qed.
Module Import vOTF := OrderedTypeFacts Vertices.E.
Module Import eOTF := OrderedTypeFacts Edges.E.

  Definition neighborhood_ind : vertex -> t -> Vertices.t.
  Proof.
    intros. apply rect1.
    constructor. apply Vertices.empty.
    intros. apply X1.
    intros. apply destructEdge in x. destruct x.
    apply (if vOTF.eqb e X
                then (Vertices.add e0 X1)
                else  X1). exact X0.
  Defined.

  Print neighborhood_ind.

  Definition neighborhood_fold (v : Vertices.E.t) (G : t): Vertices.t :=
    Edges.fold (fun edge e =>
                  if vOTF.eqb (fst (destructEdge edge)) v then Vertices.add (snd (destructEdge edge)) e
                  else e) (enumEdges G) Vertices.empty.

  Definition rmvNeighbors (v : Vertices.E.t) (G : t) (l : Vertices.t) := Vertices.fold (fun v' l' =>
                        if isEdge (buildEdge v v') G then l'
                        else (Vertices.add v' l')) (enumVertices G) Vertices.empty.

  Inductive GraphConst2 : t -> Type :=
  | Empty : GraphConst2 empty
  | GrowGraph : forall G,
      GraphConst2 G ->
      forall v1 E,
        (* We require v1 to be a new vertex *)
        ~ IsVertex v1 G ->
        (* All edges in E have v1 as one of their members *)
        (forall e, Edges.In e E ->
          ((fst (destructEdge e)) =v= v1 \/
          (snd (destructEdge e)) =v= v1)) ->
        (* All edges in E have a vertex of the parent graph as a member *)
        (forall e, Edges.In e E ->
          (IsVertex (fst (destructEdge e)) G \/
           IsVertex (snd (destructEdge e)) G)) ->
       GraphConst2 (addEdges E (addVertex v1 G)).

  (* Generates the edges that need to be added to a graph GN, in order to
      satisfy GraphConst2, with the end goal of reconstructing G, given a vertex v1 *)
  Definition addEdges_GC2 (v1 : vertex) (G : t) (GN : t): Edges.t :=
    Edges.fold
      (fun (e : edge) E =>
            (* Check to see which edges have a source/sink in the graph GN *)
         if ((Vertices.mem (fst (destructEdge e)) (enumVertices GN) ||
             Vertices.mem (snd (destructEdge e)) (enumVertices GN)))
            &&
            (* Ensures that either the source/sink is equal to v1 *)
            (vOTF.eqb v1 (fst (destructEdge e)) ||
            (vOTF.eqb v1 (snd (destructEdge e))))
         then Edges.add e E
         else E)
      (enumEdges G) Edges.empty.

  Definition rebuildGraph_GraphConst2 (G : t) : t :=
    Vertices.fold (fun (v : vertex) (G0 : t) =>
                     addEdges (addEdges_GC2 v G G0) (addVertex v G0))
                  (enumVertices G) empty.

    Lemma rebuildGraph_GraphConst2_spec1 :
    forall G, (rebuildGraph_GraphConst2 G) =G= G.
  Proof.
    intros G. constructor.
    {
      constructor; intros H.
      unfold rebuildGraph_GraphConst2 in H.
      rewrite <- IsVertexEnum. rewrite <- IsVertexEnum in H.
      Admitted.

  Hint Constructors GraphConst2.

  Lemma rebuildGraph_GraphConst2_spec2 :
    forall G, GraphConst2 (rebuildGraph_GraphConst2 G).
  Proof.
    Admitted.

  Lemma ind2 (P : t -> Type) (H0 : Respectful _ P) :
    P empty ->
    (forall G, P G ->
      (forall v1 E,
        ~ IsVertex v1 G ->
          (forall e, Edges.In e E ->
            ((fst (destructEdge e)) =v= v1 \/
            (snd (destructEdge e)) =v= v1)) ->
          (forall e, Edges.In e E ->
            (IsVertex (fst (destructEdge e)) G \/
             IsVertex (snd (destructEdge e)) G)) ->
        P (addEdges E (addVertex v1 G)))) ->
     forall g, P g.
  Proof.
    intros H H1 g.
    rewrite <- (H0 (rebuildGraph_GraphConst2 g) g).
    induction (rebuildGraph_GraphConst2_spec2 g); auto.
    apply rebuildGraph_GraphConst2_spec1.
  Qed.

  Lemma ind3 (P : t -> Type) (H0 : Respectful _ P) :
    (forall G, Vertices.cardinal (enumVertices G) = 0 -> P G) ->
    (forall G n, Vertices.cardinal (enumVertices G) = n ->
      (P G) ->
      (forall G', Vertices.cardinal (enumVertices G') = S n -> P G')) ->
    forall G, P G.
  Proof.
    intros. apply ind2; auto.
    apply X. auto.
    admit.
    intros.
    specialize (X0 G0 (Vertices.cardinal (enumVertices G0))).
    apply X0; auto. admit.
  Admitted.

  Lemma ind4 (P : t -> Type) (H0 : Respectful _ P) :
    (forall G, Vertices.cardinal (enumVertices G) = 0 -> P G) ->
    (forall G G',
      (Vertices.cardinal (enumVertices G) <= Vertices.cardinal (enumVertices G')) ->
      (P G) ->
        (P G')) ->
    forall G, P G.
  Proof.
    intros. apply ind3; auto.
    intros. apply X0 with (G:= G0). rewrite H, H1; auto.
    auto.
  Qed.

End DirectedGraphMorph.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf2 : natural) : natural := Succ lf2.


Definition fact : nat -> nat.
Proof.
  fix fact 1.
  intro x.
  case x.
  apply (S 0).
  intro y.
  apply (x * fact y).
Qed.

Eval compute in fact 2.


Require Import Coq.Strings.String.

Inductive idType : Type :=
| idTerm : idType. (* Term id *)

Inductive id : idType -> Type :=
| makeId : forall (idT : idType), string -> id idT.

Definition termId := id idTerm.

Inductive type : Type :=
| tunit : type
| tarrow : type -> type -> type.

Inductive term : Type :=
| eunit : term
| evar : termId -> term
| eabs : termId -> type -> term -> term
| eapp : term -> term -> term.

Inductive context : Type :=
| cempty : context
| cextend : context -> termId -> type -> context.


Inductive ALVec (A : Type) : nat -> Type :=
| Nil  : ALVec A 0
| Cons : forall (m : nat) (h : A) {n : nat} (t : ALVec A n), ALVec A (1 + m + n).


Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finfun finset bigop.
Require Import Reals Fourier.
Require Import Reals_ext log2 ssr_ext Rbigop proba entropy aep typ_seq natbin Rssr ceiling v_source_code.

Set Implicit Arguments.
Import Prenex Implicits.

Local Open Scope tuple_ext_scope.
Local Open Scope typ_seq_scope.
Local Open Scope proba_scope.
Local Open Scope reals_ext_scope.
Local Open Scope entropy_scope.

Section Rsum_lemma.
Variable (X : finType) (n : nat).
Variable f : X -> R.
Hypothesis n_pos : (0 < n)%nat.
Variable S : {set  X}.

Lemma rsum_type_set :
  \rsum_(x in X) f(x) = \rsum_(x in [set : X]) f(x).
Proof.
by apply eq_bigl=>i; first rewrite in_setT.
Qed.

Lemma rsum_S_not_S:
  \rsum_(x| x \in [set : X]) f x =
  \rsum_(x| x \in S ) f x
                 + \rsum_(x| x \in ~: S) f x.
Proof.
apply: rsum_union; first by rewrite disjoints_subset setCS.
by apply/setP=> ?; rewrite !inE orbN.
Qed.

Lemma log_pow k:
  log(INR (n ^ k)) = (INR k) * log (INR n).
Proof.
elim: k => [| k IH].
  by rewrite mul0R expn0 log_1.
rewrite expnS -multE mult_INR log_mult; last first.
  apply lt_0_INR; apply/ltP; by rewrite expn_gt0 /orb n_pos.
  apply lt_0_INR; by apply/ltP.
by rewrite IH -addn1 plus_INR mulRDl addRC mul1R.
Qed.

End Rsum_lemma.

Section lemma_enc_dec.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : dist X.
Variable epsilon : R.
Hypothesis ep_pos : 0 < epsilon.

Lemma Xcard : 1 <= INR #|X|.
Proof.
rewrite (_ : 1 = INR 1) //.
apply le_INR.
by apply /leP; first apply (dist_support_not_empty P).
Qed.

Definition L0 := ceil (INR n * (`H P + epsilon)).

Lemma L0_pos: 0 < IZR L0.
Proof.
rewrite /L0.
apply (Rlt_le_trans _ (INR n * (`H P + epsilon))); last by apply ceil_bottom.
rewrite -(mulR0 0).
apply (Rmult_le_0_lt_compat _ _ _ _ (Rle_refl _) (Rle_refl _)).
apply lt_0_INR; by apply/ltP.
by apply (Rplus_le_lt_0_compat _ _ (entropy_pos P) ep_pos).
Qed.

Definition L1 :=  ceil (log (INR #| [set : n.-tuple X]|)).

Lemma L1_nonneg: 0 <= IZR L1.
Proof.
apply (Rle_trans _ (log (INR #|[set: n.-tuple X]|))); last by apply ceil_bottom.
rewrite -log_1.
apply (log_increasing_le Rlt_0_1).
rewrite cardsT card_tuple -INR_pow_expn.
by apply pow_R1_Rle, Xcard.
Qed.

Lemma IZR_INR_to_nat z: 0 <= IZR z -> IZR z = INR (Zabs_nat z).
Proof.
move => H.
rewrite -INR_Zabs_nat ;last by apply le_IZR.
by rewrite Zabs2Nat.abs_nat_nonneg //; first apply le_IZR.
Qed.

Lemma card_TS_le_L0 : INR #| `TS P n epsilon | <= INR #|[ set : (Zabs_nat L0).-tuple bool]|.
Proof.
apply (Rle_trans _ _ _ (TS_sup _ _ _)).
rewrite cardsT /= card_tuple /= card_bool -exp2_pow2.
apply exp2_le_increasing.
rewrite -IZR_INR_to_nat; last apply RltW, L0_pos.
by apply ceil_bottom.
Qed.

Lemma card_tuple_le_L1 : INR #| [set: n.-tuple X]| <= INR #| [set: (Zabs_nat L1).-tuple bool]|.
Proof.
rewrite /L1 cardsT card_tuple.
rewrite {1}(_ :  INR (#|X| ^ n) = exp2 (log ( INR (#|X|^n)))); last first.
  rewrite exp2_log //; last rewrite -INR_pow_expn.
  apply pow_lt.
  apply (Rlt_le_trans _ 1 _ Rlt_0_1 Xcard).
rewrite cardsT card_tuple card_bool -exp2_pow2.
apply exp2_le_increasing.
rewrite /L1 -IZR_INR_to_nat; last first.
  apply (Rle_trans _ (log (INR (#|X|^n)))); last by apply ceil_bottom.
  rewrite -log_1.
  apply log_increasing_le; first by apply Rlt_0_1.
  rewrite -INR_pow_expn.
  by apply pow_R1_Rle, Xcard.
by apply (Rle_trans _ _ _ (Rle_refl _) (ceil_bottom _)).
Qed.

End lemma_enc_dec.

Section enc_dec_def.
Local Open Scope nat_scope.

Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : dist X.
Variable epsilon : R.
Hypothesis ep_pos : (0 < epsilon)%R.

Local Notation "'L0'" := (L0 n' P epsilon).
Local Notation "'L1'" := (L1 X n').

Lemma le_n_L1_tuple :
  #|[finType of n.-tuple X] | <= #|[finType of (Zabs_nat L1).-tuple bool]|.
Proof.
rewrite -!cardsT.
by apply /leP; apply (INR_le _ _ (card_tuple_le_L1 n' P)).
Qed.

Definition not_enc_typ x := enum_val (widen_ord le_n_L1_tuple (enum_rank x)).

Lemma inj_not_enc_typ : injective not_enc_typ.
Proof.
by move=> a1 a2 [] /enum_val_inj [] /ord_inj/enum_rank_inj.
Qed.

Definition enc_typ x :=
 let i := seq.index x (enum (`TS P n epsilon))
 in Tuple (size_nat2bin i (Zabs_nat L0)).

(* Definition enc_typ x := *)
(*  let i := seq.index x (enum (`TS P n epsilon)) *)
(*  in nat2bin i (Zabs_nat L0). *)

Definition f : var_enc X n := fun x =>
  if x \in `TS P n epsilon then
    true :: enc_typ x
  else
    false :: not_enc_typ x.

Lemma f_inj : injective f.
Proof.
move=> t1 t2.
rewrite /f.
case/boolP : (t1 == t2); first by move=> /eqP.
move=> t1t2.
case: ifP => Ht1.
  case: ifP => Ht2 //.
  case => H.
  have {H}H : seq.index t1 (enum (`TS P n epsilon)) =
              seq.index t2 (enum (`TS P n epsilon)).
    apply (nat2bin_inj (Zabs_nat L0)) => //.
    apply leq_trans with #|`TS P n epsilon|.
      apply seq_index_enum_card => //; first by exact: enum_uniq.
      apply/leP.
      apply INR_le.
      move: (card_TS_le_L0 n' P ep_pos).
      by rewrite {1}cardsT card_tuple /= card_bool.
    apply leq_trans with #|`TS P n epsilon|.
      apply seq_index_enum_card => //; first by exact: enum_uniq.
      apply/leP.
      apply INR_le.
      move: (card_TS_le_L0 n' P ep_pos).
      by rewrite {1}cardsT card_tuple /= card_bool.
  rewrite -(@nth_index _ t1 t1 (enum (`TS P n epsilon))); last by rewrite mem_enum.
  rewrite -(@nth_index _ t1 t2 (enum (`TS P n epsilon))); last by rewrite mem_enum.
  by rewrite H.
case: ifP => Ht2 //.
case => H.
apply (inj_not_enc_typ t1 t2).
by apply val_inj.
Qed.

Definition phi_def : n.-tuple X.
move: (dist_support_not_empty P) => H.
move Hpick : [pick x | x \in [set: X] ] => p.
move: Hpick.
case: (pickP _).
  move=> x _ _.
  exact [tuple of nseq n x].
move=> abs H'.
suff : False by done.
move: H.
rewrite -cardsT card_gt0.
case/set0Pn => ?.
by rewrite abs.
Defined.

Definition phi y := if [ pick x | f x == y ] is Some x then x else phi_def.

Lemma phi_f x : phi (f x) = x.
Proof.
rewrite /phi.
case: (pickP _) => [x0 /eqP | H].
  by apply f_inj.
move: (H x).
by rewrite eqxx.
Qed.

Definition extension (enc : var_enc X n) (x : seq (n.-tuple X)) :=
flatten (map enc x).

Lemma uniquely_decodable : injective (extension f).
Proof.
move =>t1.
elim t1=>[t2|a la H t2].
by case t2=>[|a la] //; rewrite /extension /f /=; case: ifP.
case t2=>[|b lb]; [by rewrite /extension /f /=; case: ifP | rewrite /extension /= /f ].
case: ifP=> [ainT | aninT].
  case: ifP=> binT //.
  move /eqP.
  rewrite  -/f eqseq_cat; last by rewrite /= !/nat2bin !size_pad_seqL.
  case /andP=>[/eqP eq_ab ] /eqP /H ->.
  congr (_ :: _); by apply f_inj; rewrite /f ainT binT.
case: ifP=> bninT //.
move /eqP.
rewrite  -/f eqseq_cat; last by rewrite !size_tuple.
case /andP=>[/eqP eq_ab ] /eqP /H ->.
congr (_ :: _); by apply f_inj; rewrite /f aninT bninT.
Qed.

End enc_dec_def.

Section exp_len_cw_def.
Variable (X : finType) (n :nat).
Variable f : var_enc X n.
Variable P : dist X.

Definition exp_len_cw := `E (mkRvar (P `^ n) (fun x => INR (size (f x)))).

End exp_len_cw_def.

Section main_pre.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : dist X.
Variable epsilon:R.
Hypothesis ep_pos: 0 < epsilon.
Hypothesis aepbound : aep_bound P epsilon <= INR n.

Local Notation "'L0'" := (L0 n' P epsilon).
Local Notation "'L1'" := (L1 X n').

Lemma fdef_in x : x \in `TS P n epsilon -> INR (size (f P epsilon x)) = (IZR L0) + 1.
Proof.
move => H.
rewrite /f H /= size_pad_seqL IZR_INR_to_nat; last by apply RltW, L0_pos.
by rewrite -addn1; first rewrite plus_INR.
Qed.

Lemma fdef_notin x : x \in ~: `TS P n epsilon -> INR (size (f P epsilon x)) = (IZR L1) + 1.
Proof.
rewrite /f in_setC.
move/negbTE ->.
rewrite /= -addn1 size_tuple plus_INR.
by rewrite -IZR_INR_to_nat; last apply L1_nonneg.
Qed.

Lemma Hexp_len_cw :
  exp_len_cw (f (n':=n') P epsilon) P
  = \rsum_(x in [finType of n.-tuple X])( P`^n(x) * (INR (size (f P epsilon x)))).
Proof.
apply eq_bigr => /= x _.
by rewrite mulRC.
Qed.

Lemma f_typ_in :
  \rsum_(x| x \in `TS P n epsilon) P `^ n (x) * (INR (size (f P epsilon x)) ) =
  \rsum_(x| x \in `TS P n epsilon) P `^ n (x) * (IZR L0 + 1).
Proof.
apply eq_bigr=> i H.
apply Rmult_eq_compat_l.
by apply fdef_in.
Qed.

Lemma f_typ_notin:
  \rsum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (INR (size (f P epsilon x)) )
  = \rsum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (IZR L1 + 1) .
Proof.
apply eq_bigr=> i H.
apply Rmult_eq_compat_l.
by apply fdef_notin.
Qed.

Lemma theorem_helper : \rsum_(x| x \in (`TS P n epsilon)) P `^ n (x) * (IZR L0 + 1)
                       +  \rsum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (IZR L1 + 1)
                       <=  (IZR L0 + 1) + epsilon * (IZR L1 + 1) .
Proof.
rewrite -!(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC.
rewrite (_ : \rsum_(i | i \in ~: `TS P n epsilon) P `^ n i = 1 - \rsum_(i | i \in `TS P n epsilon) P `^ n i); last first.
  rewrite -(pmf1 P`^n) rsum_type_set (rsum_S_not_S _ (`TS P n epsilon)) ; field.
apply Rplus_le_compat.
  rewrite -[X in _ <= X]mulR1.
  apply Rmult_le_compat_l.
    apply Rplus_le_le_0_compat; by [apply RltW, L0_pos| apply Rle_0_1].
  rewrite -(pmf1 P`^ n).
  apply Rle_big_f_X_Y=> //; first move=> ?; apply pmf.
apply Rmult_le_compat_r.
  by apply (Rplus_le_le_0_compat _ _ (L1_nonneg _ P) Rle_0_1).
apply Rminus_le.
rewrite /Rminus addRC addRA.
apply Rle_minus.
rewrite addRC.
by apply Rge_le; apply Pr_TS_1.
Qed.

End main_pre.

Section main.
Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : dist X.
Variable epsilon : R.
Hypothesis ep_pos : 0 < epsilon .
Definition epsilon':= epsilon / (3 + (3 * log (INR #|X|))).
Definition n0 := maxn (Zabs_nat (ceil (INR 2 / (INR 1 + log (INR #|X|)))))
                     (maxn (Zabs_nat (ceil (8 / epsilon)))
                     (Zabs_nat (ceil (aep_sigma2 P/ epsilon' ^ 3)))).
Hypothesis n0_n : (n0 < n)%coq_nat.

Lemma n1_le_n : (Zabs_nat (ceil (INR 2 / (INR 1 + log (INR #|X|)))) < n)%coq_nat.
Proof.
move/ltP : n0_n.
rewrite /n0 gtn_max.
by case/andP => /ltP.
Qed.

Lemma n2_le_n : (Zabs_nat (ceil (8 / epsilon)) < n)%coq_nat.
Proof.
move/ltP : n0_n.
do 2 rewrite /n0 gtn_max.
case/andP=> H.
case/andP=> H1 H2.
by apply /ltP.
Qed.

Lemma n3_le_n : (Zabs_nat (ceil (aep_sigma2 P / epsilon' ^ 3 )) < n)%coq_nat.
Proof.
move/ltP : n0_n.
do 2 rewrite /n0 gtn_max.
case/andP=> H.
case/andP=> H1 H2.
by apply /ltP.
Qed.

Lemma n_non0 : INR n <> 0.
Proof.
apply nesym, Rlt_not_eq.
by apply lt_0_INR; apply/ltP.
Qed.

Lemma n0_n_helper1: 1 + log (INR #|X|) <> 0.
Proof.
apply nesym, Rlt_not_eq, Rplus_lt_le_0_compat; first by apply Rlt_0_1.
rewrite -log_1.
apply log_increasing_le; first by apply Rlt_0_1.
by apply Xcard.
Qed.

Lemma n0_n_helper2 : INR n <> 0 /\ 1 + log (INR #|X|) <> 0.
Proof.
split.
apply n_non0.
apply n0_n_helper1.
Qed.

Lemma n0_n_1 :  2 * (epsilon / (3 * (1 + log (INR #|X|)))) / INR n < epsilon / 3.
Proof.
rewrite (_ : 2 * _ / _ = epsilon * (2 /  (3 * (1 + log (INR #|X|))) / INR n)); last first.
  field; by case: n0_n_helper2.
apply Rmult_lt_compat_l; first by apply ep_pos.
apply (Rmult_lt_reg_l 3); first by fourier.
rewrite (_ : 3 * _ = 2 * 3 / 3 / (1 + log (INR #|X|)) * / INR n); last first.
  field; by case: n0_n_helper2.
rewrite /Rdiv Rinv_r_simpl_l; last by move=> ?; fourier.
apply (Rmult_lt_reg_l (INR n)); first by apply lt_0_INR; apply/ltP.
rewrite (_ : _ * _ = (2 * / (1 + log (INR #|X|)) * INR n  * / INR n)); last first.
  field; by case: n0_n_helper2.
rewrite (Rinv_r_simpl_l _ _ n_non0).
apply (Rle_lt_trans _ _ _ (ceil_bottom _)).
rewrite IZR_INR_to_nat; last first.
  apply (Rle_trans _ (2 * / (1 + log (INR #|X|)))); last by apply ceil_bottom.
  apply (Rmult_le_reg_l (1 + log (INR #|X|))); last first.
    rewrite (_ : _ * (_ * / _) =
                 2 * (1 + log (INR #|X|)) * / (1 + log (INR #|X|))); last first.
      field; exact n0_n_helper1.
    rewrite (Rinv_r_simpl_l _ _ n0_n_helper1).
    rewrite mulR0; fourier.
  apply (Rplus_lt_le_0_compat _ _ Rlt_0_1).
  rewrite -log_1.
  apply log_increasing_le; first by fourier.
  apply (Xcard P).
rewrite Rinv_r; last by move=> ?; fourier.
rewrite mulR1.
apply (lt_INR _ _ n1_le_n).
Qed.

Lemma n0_n_2 :  2 * / INR n  < epsilon / 4.
Proof.
apply (Rmult_lt_reg_l 4); first fourier.
rewrite /Rdiv (mulRC epsilon (/ 4)) mulRA mulRA Rinv_r ; last by move => ? ; fourier.
apply (Rmult_lt_reg_l (INR n)); first by apply lt_0_INR; apply /ltP.
rewrite (_ : _ * (_ * _ * / _) = 8 * INR n * / INR n); last by field; exact n_non0.
rewrite (Rinv_r_simpl_l _ _ n_non0).
apply (Rmult_lt_reg_l ( / epsilon)).
  apply (Rmult_lt_reg_l epsilon _ _ ep_pos).
  rewrite Rinv_r; first by rewrite mulR0; apply Rlt_0_1.
  by apply nesym, Rlt_not_eq, ep_pos.
rewrite mul1R (mulRC (/ epsilon) (INR n * epsilon)).
rewrite Rinv_r_simpl_l; last by apply nesym, Rlt_not_eq, ep_pos.
rewrite mulRC.
apply (Rle_lt_trans _ (IZR (ceil (8 * / epsilon))) _ (ceil_bottom _)).
rewrite IZR_INR_to_nat; first by apply lt_INR, n2_le_n.
eapply Rle_trans;  last by apply ceil_bottom.
apply (Rmult_le_reg_l epsilon _ _ ep_pos).
rewrite (mulRC 8  (/ epsilon)) mulRA Rinv_r; last by apply nesym, Rlt_not_eq, ep_pos.
rewrite mulR0; fourier.
Qed.

Lemma ep'_pos : 0 < epsilon'.
Proof.
rewrite /epsilon' /Rdiv.
rewrite -(mulR0 epsilon).
apply (Rmult_lt_compat_l _ _ _ ep_pos).
rewrite -(mul1R ( / (3 + 3 * log (INR #|X|)))).
apply (Rlt_mult_inv_pos _ _ Rlt_0_1).
apply Rplus_lt_le_0_compat; first by apply Rlt_zero_pos_plus1, Rlt_R0_R2.
apply Rmult_le_pos; first by apply Rle_zero_pos_plus1, Rle_zero_pos_plus1, Rle_0_1.
rewrite -log_1.
by apply (log_increasing_le Rlt_0_1 (Xcard P)).
Qed.

Lemma n0_n_3 : aep_bound P epsilon' <= INR n.
Proof.
rewrite /aep_bound .
eapply (Rle_trans _ _ _ (ceil_bottom _)).
rewrite IZR_INR_to_nat; last first.
  apply (Rle_trans _ (aep_sigma2 P / epsilon' ^ 3)); last by apply (ceil_bottom _).
  apply (Rmult_le_reg_l ( epsilon' ^ 3) _ _ (pow_gt0 ep'_pos 3)).
  rewrite (_ : _ * ( _ / _) = aep_sigma2 P * epsilon' ^ 3  * / (epsilon' ^ 3)); last first.
    by field; apply nesym, Rlt_not_eq, ep'_pos.
  rewrite Rinv_r_simpl_l; last by apply nesym, Rlt_not_eq, pow_gt0, ep'_pos.
  rewrite mulR0.
  by apply aep_sigma2_pos.
by apply RltW, lt_INR, n3_le_n.
Qed.

Lemma v_scode_helper : exists (f : var_enc X n) (phi : var_dec X n) ,
                         (forall x, phi (f x) = x) /\
                         (exp_len_cw f P) / (INR n) < (`H P + epsilon).
Proof.
exists (f P epsilon') .
exists (phi n' P epsilon').
split=> [ x |]; first  by apply (phi_f _ ep'_pos).
apply (Rmult_lt_reg_r (INR n)); first by apply lt_0_INR; apply /ltP.
rewrite /Rdiv -mulRA -(mulRC (INR n)).
rewrite (Rinv_r _ n_non0).
rewrite mulR1 Hexp_len_cw rsum_type_set (rsum_S_not_S _ (`TS P n epsilon')).
rewrite f_typ_notin f_typ_in; last apply ep'_pos.
eapply Rle_lt_trans.
  apply (theorem_helper _  ep'_pos).
  by apply n0_n_3.
rewrite /L0 /L1.
eapply Rle_lt_trans.
  apply Rplus_le_compat.
    by apply Rplus_le_compat; by [apply RltW, ceil_upper | apply Rle_refl].
  apply Rmult_le_compat_l; first by apply Rlt_le, ep'_pos.
  by apply Rplus_le_compat; by [apply RltW, ceil_upper | apply Rle_refl].
rewrite cardsT card_tuple.
rewrite log_pow; last by apply (dist_support_not_empty P).
rewrite (_ : _ * _ + _ + _ + _ *( _ * _ + _ + _) =
             INR n * (`H P + epsilon') + 2 +
             epsilon' * (INR n * log (INR #|X|) + 2)); last first.
  rewrite /n.
  by field.
rewrite  -(Rinv_r_simpl_l (INR n) 2); last by apply n_non0.
rewrite (_ :  _ * _ + _ * _ / _ =
              INR n * (`H P + epsilon' + 2 / INR n)) ;last first.
  field; by apply n_non0.
rewrite (_ :  _ * _ * / _ = INR n * (2  / INR n)); last first.
  field; by apply n_non0.
rewrite (_ :  INR n * _ + INR n * _ =
                (INR n * (log (INR #|X|) + (2 / INR n)))); last first.
  field; by apply n_non0.
rewrite (_ :   _ * _ + _ * _ =
               INR n * (`H P + epsilon' + 2 / INR n +  epsilon' * (log (INR #|X|) + 2 / INR n))); last first.
  field; by apply n_non0.
rewrite mulRC.
apply Rmult_lt_compat_r.
  by apply lt_0_INR; apply /ltP.
do 2 rewrite -addRA.
apply Rplus_lt_compat_l.
rewrite (_ : epsilon' * _ =
               epsilon' * (log (INR #|X|)) + epsilon' * 2 / INR n); last first.
  field; by apply n_non0.
rewrite (_ :   _ + (_ / _ + _) =
               2 / INR n +
               epsilon' * (1 + log (INR #|X|)) + epsilon' * 2 / INR n) ; last first.
  field; by apply n_non0.
rewrite (_ : _ * _ / _ = 2 * epsilon' / INR n); last first.
  field; by apply n_non0.
rewrite /epsilon'.
rewrite (_ : (3 + 3 * _ = 3 * (1 + log (INR #|X|)))); last field.
rewrite {1}(_ : epsilon / _ =
                epsilon / 3 / (1 + log (INR #|X|) )); last first.
  field; by apply n0_n_helper1.
rewrite (_ : _ / _ / _ * _ =
             epsilon  * (1 + log (INR #|X|))/ (1 + log (INR #|X|)) /3); last first.
  field; by apply n0_n_helper1.
rewrite /Rdiv (Rinv_r_simpl_l _ _ n0_n_helper1).
eapply Rle_lt_trans.
  apply Rplus_le_compat; last by apply RltW, n0_n_1.
    by apply Rplus_le_compat; by [apply RltW, n0_n_2 | apply Rle_refl].
rewrite (_ : _ / _ + _ / _ + _ / _ = epsilon * ( / 4 + / 3 + / 3)) ; last field.
rewrite -{2}(mulR1 epsilon).
apply (Rmult_lt_compat_l _ _ _ ep_pos).
fourier.
Qed.

End main.

Section variable_length_source_coding.

Variable (X : finType) (n' : nat).
Let n := n'.+1.
Variable P : dist X.
Variable epsilon : R.
Hypothesis ep_pos : 0 < epsilon .
(*Definition n0 := maxn
          (Z.to_nat (ceil (INR 2 / (INR 1 + log (INR #|X|)))))
          (maxn (Z.to_nat (ceil (8 / epsilon)))
          (Z.to_nat (ceil (aep_sigma2 P/ epsilon' ^ 3)))).*)
Local Notation "'n0'" := (n0 P epsilon).

Theorem vscode : (n0 < n)%nat ->
  exists f : var_enc X n,
    injective f /\
    exp_len_cw f P / INR n < `H P + epsilon.
Proof.
move/ltP.
case/v_scode_helper => // f [phi [fphi ccl]].
exists f.
split => //.
by apply can_inj with phi.
Qed.

End variable_length_source_coding.


Require Export LaugwitzSchmieden.

Module LSn2 <: Num_w.

Include LS.
(* Definitions in LS are available here thanks to the module type declaration for LS - see above - *)

Definition w :A := fun (n:nat) => Z_of_nat (n*n).

Lemma n_n2 : beta <A w.
unfold beta,w; unfold_intros.
exists 2%nat.
intros.
apply inj_lt.
setoid_replace n with (n*1)%nat at 1 by ring.
apply mult_lt_compat_l; omega.
Qed.

Lemma n_n2bis : forall n, (Z_of_nat n <= Z_of_nat (n*n))%Z.
Proof.
induction n.
simpl; omega.
rewrite Nat2Z.inj_mul.
setoid_replace (Z.of_nat (S n)) with (Z.of_nat (S n)* 1)%Z at 1 by ring.
apply Zmult_le_compat_l.
rewrite Nat2Z.inj_succ.
omega.
omega.
Qed.

Lemma lim_lt_w : forall a:A, lim a/\ leA 0 a -> ltA a w.
Proof.
intros.
apply lt_le_trans with beta.
apply lim_lt_beta.
assumption.
apply lt_le; apply n_n2.
Qed.

Lemma ANS3 : ~lim w.
Proof.
intro H; unfold lim in *.
elim H; clear H; intros p (Hstdp,(Hle0p,Hwp)).
unfold ltA,a0 in *.
elim Hstdp.
intros b Hb.
elim Hwp.
intros a Ha.
elim Hle0p.
intros c Hc.
(* w (p (a+b+c+1) + a + b + c + 1) = p (a+b+c+1) + a+b+c+1 *)
(* p (p (a+b+c+1) + a + b + c + 1) = p (a + b + c + 1) because p(a+b+c+1)>=0 et Hb: p is std *)
pose (px:=p (a+b+c+1)%nat).
assert (0<= px)%Z.
apply Hc.
omega.
pose (x:=((Z.abs_nat px)+a+b+c+1)%nat).
assert ((|w |) (x) < p (x))%Z.
apply Ha.
unfold px,x in *.
omega.

assert  ((|w |) (x) >= p (x))%Z.
apply Z.le_ge.
apply Z.le_trans with  (((|fun n => Z_of_nat n|) (x))%Z).
unfold absA in *.
unfold w.
unfold x.
replace (p (Z.abs_nat px + a + b + c + 1)%nat)%Z with
(p (a+b+c+1)%nat)%Z.
rewrite Z.abs_eq.
replace (Z.abs_nat px + a + b + c + 1)%nat with (Z.abs_nat (px + (Z_of_nat (a + b + c + 1))))%nat.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq.
unfold px.
omega.
omega.
rewrite Zabs_nat_Zplus.
rewrite Zabs_nat_Z_of_nat.
ring.
unfold px; apply Hc.
omega.
solve [auto with zarith].
solve [auto with zarith].
apply Hb.
omega.
omega.
unfold w, absA.
rewrite Z.abs_eq.
rewrite Z.abs_eq.
apply n_n2bis.
apply Zle_0_nat.
apply Zle_0_nat.
omega.
Qed.

Lemma Aw : 0 <A w.
Proof.
unfold ltA.
exists 0%nat.
intros;unfold a0, w.
rewrite Nat2Z.inj_mul.
setoid_replace 0%Z with (Z.of_nat n * 0)%Z by ring.
assert (0<Z.of_nat n)%Z by omega.
apply Zmult_lt_compat_l; assumption.
Qed.

Lemma div_modw2 : forall a, w*(a/w) =A a + - (a mod% w).
Proof.
intros; apply div_mod2.
left; apply Aw.
Qed.

Lemma div_modw3 : forall a, |(a mod% w)| <A w.
Proof.
intros; apply div_mod3.
apply Aw.
Qed.

End LSn2.


Require Import Coq.Logic.Classical_Pred_Type.
Require Import mathcomp.ssreflect.all_ssreflect.
Require Import mathcomp.algebra.all_algebra.
Require Import mathcomp.ssreflect.bigop.
Import GRing.Theory Num.Theory.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Filter.
Require Import Dominated.

Definition filter_nat_base : filter nat :=
  fun P => exists n0, forall n, le n0 n -> P n.

Definition mixin_filter_nat : filterMixin filter_nat_base.
Proof.
  constructor; unfold filter_nat_base.
  - exists O. eauto.
  - intros ? [? ?]. eauto.
  - { intros P1 P2 P [n1 H1] [n2 H2] I. exists (max n1 n2).
      intros. apply I.
      - apply H1. apply Max.max_lub_l with n2. eauto.
      - apply H2. apply Max.max_lub_r with n1. eauto. }
Qed.

Definition filter_nat := FilterType mixin_filter_nat.
Definition filter_nat_nat := filter_product filter_nat filter_nat.

Definition dominated_forall := dominated filter_nat_nat.

Section Hat.

Variable B : numDomainType.

Definition hat_nat (f: nat -> B): nat -> B :=
  fun n => \big[Num.max/0]_(0 <= i < n+1) f i.

Definition hat_nat_nat (f: nat * nat -> B) : nat * nat -> B :=
  fun p =>
    let (n1, n2) := p in
    \big[Num.max/0]_(0 <= i < n1+1) \big[Num.max/0]_(0 <= j < n2+1) f (i, j).

SearchAbout Num.max.

Lemma hat_nat_ge : forall f, forall n, f n <= hat_nat f n.
Proof.
  intros. unfold hat_nat. rewrite big_nat_recr.
Admitted.

(* nondecr f -> hat f = f *)

End Hat.


Require Import Grammar.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Import ListNotations.

Inductive nonterminal : Type :=
| NT : string -> nonterminal.

Inductive terminal : Type :=
| Te : string -> terminal.

Definition production : Type := terminal * list nonterminal.
Definition grammar : Type := (nonterminal -> production).

Definition a : string := "a".
Definition b : string := "b".
Definition c : string := "c".

Definition simple_grammar : grammar :=
  fun s =>
    match s with
    | NT "S" => ((Te "a"),[(NT "B");(NT "B")])
    | NT "B" => ((Te "b"),[])
    | _ => ((Te ""), [])
    end.

Fixpoint check (g : grammar) (tokens : list string) (nt : nonterminal) : bool * list string :=
  match tokens, g nt with
  | token :: ts, (Te x, []) => if string_dec token x then (true, ts) else (false, [])
  | token :: ts, (Te x, ns) =>
    if string_dec token x then
      fold_left (fun ts' nt =>
                   match ts' with
                   | (true, tmp) => check g tmp nt
                   | (false, _) => (false, [])
                   end) ns (true, ts)
    else (false, [])
  | _, _ => (false, [])
  end.


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

Set Printing Depth 1000.
Definition lfind_eval  z x:=
Cons x z.

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero Nil) (Zero).

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

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

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

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

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

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

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

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil))) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).


Require Import SF_imp.
Require Import RelDec.
Require Import List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.NArith.BinNat.
Import ListNotations.

Local Open Scope N.

Parameter T : Set.

Parameter eqb_t : T -> T -> bool.

Parameter reldec_t : @RelDec T eq.

Definition option_eq {A} (eq : A -> A -> bool) (a b : option A)  : bool :=
match a,b with
| Some a', Some b' => eq a' b'
| None, None => true
| _, _ => false
end.

Definition option_eq_t := option_eq eqb_t.

Definition prop_drop_none_keeps (l : list (option T)) (i : T) : bool :=
  Bool.eqb (existsb (option_eq_t (Some i)) l) (existsb (eqb_t i) (drop_none l)).

Definition prop_next_ranking_contains rec bal :=
match (next_ranking T _ rec bal) with
| Some (c, _) => existsb (existsb (eqb_t c)) bal
| _ => true
end.

Definition prop_next_ranking_not_eliminated rec bal :=
match (next_ranking T _ rec bal) with
| Some (c, _) => negb (eliminated T _ rec c)
| _ => true
end.

Fixpoint is_overvote (rec : record T) (b : ballot T) : bool :=
match b with
| [] :: t => is_overvote rec t
| (h :: l) :: t => if (forallb (eq_dec h) l) then
                     if false (*(eliminated T _ rec h)*) then is_overvote rec t else false
                   else true
| [] => false
end.

Definition prop_next_ranking_not_overvote rec bal :=
match (next_ranking T _ rec bal) with
| Some (c, _) => negb (is_overvote rec bal)
| _ => true
end.

Fixpoint get_first  (r : list (T * N)) (c : T) : N :=
match r with
| (c', n) :: t => if (eq_dec c c') then n else get_first t c
| nil => 0%N
end.

Definition prop_increment_get c r :=
N.eqb ((get_first r c) + 1) (get_first (increment T _ r c) c).

Fixpoint count_candidate (l : list (option T)) (c : T) :=
match l with
| Some c' :: t => if (eq_dec c c') then 1 + (count_candidate t c) else count_candidate t c
| h :: t => count_candidate t c
| nil => 0
end.

Definition prop_count_tabulate'' (l : list (option T)) (c : T) :=
N.eqb (count_candidate l c) (get_first (tabulate' T _ l) c).

Definition pair_eq {A B} (eq_a : A -> A -> bool) (eq_b : B -> B -> bool)
           (a b : (A * B))  : bool :=
match a,b with
| (a1, a2), (b1, b2) => andb (eq_a a1 b1) (eq_b a2 b2)
end.

Definition pair_eq_t_n (a b : (T * N)) : bool :=
  pair_eq eq_dec N.eqb a b.

Definition prop_option_split (l : list (option (T * N))) c n :=
let res := option_split l in
if (existsb (option_eq pair_eq_t_n (Some (c, n))) l)
then (andb (existsb (option_eq eq_dec (Some c)) (fst res)) (existsb (option_eq N.eqb (Some n)) (snd res)))
else true.

Definition prop_get_bottom_votes_correct (v : list (T * N)) c n :=
match v with
| (c', n') :: t =>
  if
    (andb (existsb (pair_eq_t_n (c, n)) v) (N.eqb n n'))
  then
    (existsb (eq_dec c) (get_bottom_votes T v))
  else true
| _ => true
end.