(*
Copyright © 2020 Vincent Semeria

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*)

(*
   This is an implementation of Errett Bishop and Henry Cheng's article,
   "Constructive Measure Theory". By its many applications and concrete
   nature, measure theory and probability theory are expected to be
   constructive. Indeed they are, and this formalization shows exactly how.

   All measure theories (Riemann, Lebesgue, Daniell and here constructive)
   follow the same pattern :
   1) Observe that the rectangles of Rn [a1,b1] \times ... \times [an,bn]
      have an obvious measure, which is the product (b1-a1)...(bn-an).
   2) Define a notion of limit, to measure more complicated domains
      by rectangle approximations.

   For example this is how Archimedes computed the length of a circle
   2000 years ago. Nowadays the classical measure theory is that of
   Lebesgue, and its limit notion is the sigma-algebra generated by
   the rectangles, aka the Borel sets of Rn. This classically defines
   a gigantic set of measurable parts, but it is not constructive,
   because there is no way to effectively compute which rectangles
   approximate an arbitrary Borel set. It is therefore not surprising
   that the associated tool, Caratheodory's extension theorem,
   extends measures from rectangles to Borel sets in a non-constructive
   manner: by using infimums of arbitrary bounded subsets of R.

   Bishop and Cheng's measure theory is the constructive expression
   of Daniell's measure theory. Instead of starting with rectangles
   as subsets of Rn, this theory considers elementary real-valued
   functions, for example piecewise-constant functions. Those two
   concepts are almost the same, because the graph of a
   piecewise-constant function is a finite union of rectangles.
   But by starting with functions, we get a very simple notion of limit
   between a function f and a sequence of elementary functions fn:
   f(x) = lim fn(x), for all x's such as the real sequence fn(x) converges.
   This resolves the objection above, because the approximating sequence fn
   of rectangles is now the very definition of an integrable function f.
   This restricts the theory to constructively integrable functions,
   which is precisely what we want.

   In the constructive definition, fn is not required to converge at every x.
   This allows to integrate more functions f, but takes the risk of badly
   approximating their integrals, by ignoring what f does outside
   of the domain of convergence of fn. To make sure that the sequence fn
   converges on a subset with full measure, we require that the integrals
   of the absolute values of fn converge. Roughly speaking, if the |fn|
   converged to positive infinity on a subset with positive measure,
   it would contradict the finite integral limit. This condition also
   makes the integrals of fn converge, which defines the integral of f.

   Another characteristic of constructive real functions is worth stressing:
   all total constructive functions R -> R are continuous. So a
   constructive function R -> R must either be undefined at a point of
   discontinuity x, or be defined on a topological subspace of R,
   such as the disconnection of x by taking [x, +\infty[ to be open.
   In the last 2 cases we will declare the function to be partially
   defined on R, see PartialFunction below.
 *)

Require Import QArith.
Require Import ConstructiveReals.
Require Import ConstructiveAbs.
Require Import ConstructiveMinMax.
Require Import ConstructiveSum.
Require Import ConstructiveLimits.
Require Import ConstructivePartialFunctions.

Local Open Scope ConstructiveReals.

(* A Riesz space is a vector space with a lattice structure
   compatible with the vectorial structure. An important example
   for measure theory is when vectors are real-valued functions,
   which allows to define an integral as a linear and
   non-decreasing functional. *)
Structure FunctionRieszSpace :=
  {
    (* A superset of the domains. Typically, X will be R or R^n,
       and the functions will be defined almost-everywhere on X.
       Bishop generalizes to a setoid, to be able to consider
       functions on quotient spaces ; we do not do it for now,
       because most of the time the domain is plain R^n.*)
    X : Set;

    RealT : ConstructiveReals;

    (* We use Set instead of Prop, to destruct the witness in the integral
       function later. In the example of piecewise-linear functions, the
       Prop would be "there exists a finite list of angular points";
       here the type is a sig with this finite list, and a proof that
       the function is linear between these points. *)
    L : @PartialFunction RealT X -> Type;

    (* The integration spaces are usually provably extensional,
       so we avoid using the functional extensionality axiom. *)
    Lext : forall f g : PartialFunction X,
        PartialFunExtEq f g -> L f -> L g;

    LplusStable : forall f g : PartialFunction X,
        L f -> L g -> L (Xplus f g);

    LabsStable : forall (f : PartialFunction X),
        L f -> L (Xabs f);

    LminOneStable : forall (f : PartialFunction X),
        L f -> L (XminConst f 1);

    LscaleStable : forall (a : CRcarrier RealT) (f : PartialFunction X),
        L f -> L (Xscale a f);
  }.

(* LminOneStable seems redundant, because the minimum can be built from plus,
   minus and abs. However the constant function one is not L most of the time :
   its integral is infinite when the domain X is R or R^n. *)

Lemma LminusStable
  : forall {Elem : FunctionRieszSpace}
      (f g : PartialFunction (X Elem))
      (fL : L Elem f)
      (gL : L Elem g),
    L Elem (Xminus f g).
Proof.
  intros. unfold Xminus. apply LplusStable. assumption.
  apply LscaleStable. assumption.
Defined.

Lemma LposPartStable
  : forall {Elem : FunctionRieszSpace}
      (f : PartialFunction (X Elem))
      (fL : L Elem f),
    L Elem (XposPart f).
Proof.
  intros. unfold XposPart. apply LscaleStable. apply LplusStable.
  assumption. apply LabsStable. assumption.
Defined.

Lemma LnegPartStable
  : forall {Elem : FunctionRieszSpace}
      (f : PartialFunction (X Elem))
      (fL : L Elem f),
    L Elem (XnegPart f).
Proof.
  intros. unfold XnegPart. apply LscaleStable. apply LminusStable.
  apply LabsStable. assumption. assumption.
Defined.

Lemma LminStable
  : forall {Elem : FunctionRieszSpace}
      (f g : PartialFunction (X Elem))
      (fL : L Elem f)
      (gL : L Elem g),
    L Elem (Xmin f g).
Proof.
  intros.
  apply LminusStable. assumption. apply LnegPartStable.
  apply LminusStable. assumption. assumption.
Qed.

Lemma LmaxStable
  : forall {Elem : FunctionRieszSpace}
      (f g : PartialFunction (X Elem))
      (fL : L Elem f)
      (gL : L Elem g),
    L Elem (Xmax f g).
Proof.
  intros.
  apply LplusStable. assumption. apply LposPartStable.
  apply LminusStable. assumption. assumption.
Qed.

Lemma LsumStable
  : forall {Elem : FunctionRieszSpace}
      (fn : nat -> PartialFunction (X Elem))
      (fnL : forall n:nat, L Elem (fn n)),
    forall n:nat, L Elem (Xsum fn n).
Proof.
  induction n. simpl. apply fnL. simpl.
  apply (LplusStable Elem). exact IHn. apply fnL.
Defined.

Lemma LminConstStable
  : forall {E : FunctionRieszSpace}
      (a : CRcarrier (RealT E)) (f : PartialFunction (X E)),
    0 < a
    -> L E f
    -> L E (XminConst f a).
Proof.
  intros.
  apply (Lext _ _ _ (XminMultPosDistribOne f a H)).
  apply LscaleStable. apply LminOneStable. apply LscaleStable. assumption.
Defined.

(* Include the zero case *)
Lemma LminIntStable
  : forall {E : FunctionRieszSpace}
      (n : nat) (f : PartialFunction (X E)),
    L E f
    -> L E (XminConst f (INR n)).
Proof.
  intros E n f H. destruct n.
  - apply (Lext _ (Xscale (-(1)) (XnegPart f))).
    2: apply LscaleStable, LnegPartStable, H.
    split. split.
    + intros x xd. destruct f; apply xd.
    + intros x xd. destruct f; split; apply xd.
    + intros. rewrite applyXscale, applyXminConst.
      simpl in xD, xG.
      rewrite (DomainProp (XnegPart f) x _ (xG, xG)).
      rewrite (applyXnegPartMin f x xG), <- CRopp_mult_distr_l.
      rewrite CRmult_1_l, CRopp_involutive, CRmin_sym.
      apply CRmin_morph. reflexivity. reflexivity.
  - apply LminConstStable.
    apply CR_of_Q_lt. reflexivity. exact H.
Qed.

Lemma invSuccRealPositive : forall {R : ConstructiveReals} (n : nat),
    0 < CR_of_Q R (1# Pos.of_nat (S n)).
Proof.
  intros R n. apply CR_of_Q_lt. reflexivity.
Qed.

Definition ElemIntegralContinuous
           {E : FunctionRieszSpace}
           (I : forall f : PartialFunction (X E), (L E) f -> CRcarrier (RealT E))
  : Type
  := forall (f : PartialFunction (X E))
       (fn : nat -> PartialFunction (X E))
       (fL : (L E) f)
       (fnL : forall n:nat, (L E) (fn n)),
    (forall n:nat, nonNegFunc (fn n))
    -> series_cv_lim_lt (fun n => I (fn n) (fnL n))
                       (I f fL)
    -> { x : CommonPointFunSeq _ f fn
             & series_cv_lim_lt (fun n => partialApply (fn n) _ (cpxFn _ _ _ x n))
                                (partialApply f _ (cpxF _ _ _ x)) }.

Record IntegrationSpace :=
  {
    ElemFunc : FunctionRieszSpace;

    (* The integrals of the elementary functions.
       The argument L f is in sort Set, but lemma IExtensional
       below proves that I does not use it to produce different
       values. *)
    I : forall f : PartialFunction (X ElemFunc),
        (L ElemFunc) f -> CRcarrier (RealT ElemFunc);

    Iadditive : forall (f g : PartialFunction (X ElemFunc))
                       (fL : L ElemFunc f)
                       (gL : L ElemFunc g),
        I (Xplus f g) (LplusStable ElemFunc f g fL gL)
        == I f fL + I g gL;

    Ihomogeneous : forall (a : CRcarrier (RealT ElemFunc))
                          (f : PartialFunction (X ElemFunc))
                          (fL : L ElemFunc f),
        I (Xscale a f) (LscaleStable ElemFunc a f fL)
        == a * (I f fL);

    Ione : PartialFunction (X ElemFunc);
    IoneL : L ElemFunc Ione;
    IoneInt : I Ione IoneL == 1;

    (*
      Now the usual majoration of integrals :
         (forall x, f(x) <= g(x)) -> I f <= I g.
      See lemma INonDecreasing below for the detailed formulation.
      Because x is in the intersection of the domains of f and g,
      it implies that L-functions are defined almost everywhere,
      ie the abscissas outside any of their domains don't affect integrals.

      Moreover we require the existential contrapositive, which is
      constructively stronger :
         I g < I f -> { x | g(x) < f(x) }.

      Finally we want the integral to be sigma-linear (the countable
      limit of Iadditive and Ihomogeneous), so we take g to be a
      countable sum of nonnegative functions fn. This gives an
      non-decreasing sequence of functions, as in the monotone
      convergence theorem (that we will prove later).

      The function f is actually optional. If the integrals of fn
      converge towards a limit l, we can take f = (l+1) * Ione.
      This means that the convergence on the integrals of fn
      proves that the pointwise limit of fn has a non-empty domain
      (which will later be proved to have full measure in X ElemFunc).
     *)
    Icontinuous : ElemIntegralContinuous I;

    Ilimit : forall (f : PartialFunction (X ElemFunc)) (fL : L ElemFunc f),
        prod (CR_cv _ (fun n => I (XminConst f (INR n))
                               (LminIntStable n f fL))
                    (I f fL))
             (CR_cv _ (fun n => I (XminConst (Xabs f) (CR_of_Q _ (1# Pos.of_nat (S n))))
                               (LminConstStable (CR_of_Q _ (1# Pos.of_nat (S n))) (Xabs f)
                                                (invSuccRealPositive n)
                                                (LabsStable ElemFunc f fL)))
                    0)
  }.

(* Shortcut for the integral of the absolute value,
   will be used a lot. *)
Definition Iabs {IS : IntegrationSpace}
           (f : PartialFunction (X (ElemFunc IS)))
           (fL : L (ElemFunc IS) f)
  := I IS (Xabs f) (LabsStable _ f fL).

Lemma Iminus : forall {IS : IntegrationSpace}
                 (f g : PartialFunction (X (ElemFunc IS)))
                 (fL : L (ElemFunc IS) f)
                 (gL : L (ElemFunc IS) g),
    I IS (Xminus f g) (LminusStable f g fL gL)
    == I IS f fL - I IS g gL.
Proof.
  intros. unfold Xminus. unfold LminusStable.
  rewrite Iadditive. apply CRplus_morph. reflexivity.
  rewrite Ihomogeneous. rewrite <- CRopp_mult_distr_l, CRmult_1_l. reflexivity.
Qed.

Lemma IadditiveIterate : forall {IS : IntegrationSpace}
                           (fn : nat -> PartialFunction (X (ElemFunc IS)))
                           (fnL : forall n:nat, L (ElemFunc IS) (fn n))
                           (N : nat),
    I IS (Xsum fn N) (LsumStable fn fnL N)
    == CRsum (fun n : nat => I IS (fn n) (fnL n)) N.
Proof.
  induction N.
  - reflexivity.
  - simpl. rewrite Iadditive. rewrite IHN. reflexivity.
Qed.

Definition Izero (IS : IntegrationSpace)
  := Xscale 0 (Ione IS).

Lemma Izero_is_L : forall (IS : IntegrationSpace),
    L (ElemFunc IS) (Izero IS).
Proof.
  intros IS. unfold Izero. apply LscaleStable. apply IoneL.
Defined.

Lemma Izero_nonNeg : forall (IS : IntegrationSpace),
    nonNegFunc (Izero IS).
Proof.
  intros IS x xdf. unfold Izero.
  rewrite applyXscale, CRmult_0_l. apply CRle_refl.
Qed.

Lemma Izero_is_zero : forall (IS : IntegrationSpace),
    I IS (Izero IS) (Izero_is_L IS) == 0.
Proof.
  intros. unfold Izero. unfold Izero_is_L. rewrite Ihomogeneous.
  rewrite CRmult_0_l. reflexivity.
Qed.

Lemma applyIzero : forall (IS : IntegrationSpace)
                     (x : X (ElemFunc IS))
                     (xD : Domain (Izero IS) x),
    partialApply (Izero IS) x xD == 0.
Proof.
  intros. unfold Izero. rewrite applyXscale, CRmult_0_l.
  reflexivity.
Qed.

(* This usual property of integrals also proves that the domains of
   L-functions are full sets.
   The majoration f <= g is defined on the intersection of the domains
   of f and g, and it is enough to imply that I f <= I g.
   It proves that the difference between the domains of g and f is a
   null set : g can have arbitrary large negative values on it
   without breaking the integral majoration. *)
Lemma INonDecreasing : forall {IS : IntegrationSpace}
                         (f g : PartialFunction (X (ElemFunc IS)))
                         (fL : L (ElemFunc IS) f)
                         (gL : L (ElemFunc IS) g),
    (forall (x : X (ElemFunc IS)) (xF : Domain f x) (y : Domain g x),
        partialApply f x xF <= partialApply g x y)
    -> I IS f fL <= I IS g gL.
Proof.
  intros. intro abs.
  destruct (Icontinuous IS (Xminus f g)
                        (fun n:nat => Izero IS)
                        (LminusStable f g fL gL)
                        (fun n:nat => Izero_is_L IS)
                        (fun n:nat => Izero_nonNeg IS))
    as [[x xdminus xdfn] [l [H1 H0]]].
  - exists 0. split.
    + intros n. exists O. intros.
      rewrite CRabs_right.
      rewrite sum_eq_R0. unfold CRminus.
      rewrite CRplus_opp_r.
      apply CR_of_Q_le. discriminate.
      intro k. apply Izero_is_zero. unfold CRminus.
      rewrite CRopp_0, CRplus_0_r.
      rewrite sum_eq_R0. apply CRle_refl.
      intro k. apply Izero_is_zero.
    + unfold Xminus. unfold LminusStable. rewrite Iadditive. rewrite Ihomogeneous.
      rewrite <- (CRopp_mult_distr_l 1). rewrite CRmult_1_l.
      rewrite <- (CRplus_opp_r (I IS g gL)).
      apply CRplus_lt_compat_r. exact abs.
  - unfold cpxF in H0. destruct xdminus.
    rewrite (applyXminus f g) in H0. simpl in H0.
    assert (series_cv (fun n : nat => partialApply (Izero IS) x (xdfn n)) 0).
    { apply (CR_cv_eq _ (fun n => 0)). 2: apply CR_cv_const.
      intro n. rewrite sum_eq_R0. reflexivity.
      intro k. apply applyIzero. }
    assert (l == 0).
    { apply (series_cv_unique (fun n : nat => partialApply (Izero IS) x (xdfn n))).
      apply H1. apply H2. }
    rewrite H3 in H0. clear H1 H2 H3 l.
    rewrite <- (CRplus_opp_r (partialApply g x d0)) in H0.
    apply CRplus_lt_reg_r in H0.
    exact (H x _ _ H0).
Qed.

(* Again, the extensionality is simplified because f and g are defined
   almost everywhere. This lemma is rigorously a statement about the
   intersection of the domains of f and g.
   In particular, the lemma shows that I does not depend on the L arguments. *)
Lemma IExtensional : forall {IS : IntegrationSpace}
                       (f g : PartialFunction (X (ElemFunc IS)))
                       (fL : L (ElemFunc IS) f)
                       (gL : L (ElemFunc IS) g),
    (forall (x : X (ElemFunc IS)) (xF : Domain f x) (y : Domain g x),
        partialApply f x xF == partialApply g x y)
    -> I IS f fL == I IS g gL.
Proof.
  split.
  + apply INonDecreasing. intros. rewrite (H x y xF). apply CRle_refl.
  + apply INonDecreasing. intros. rewrite (H x xF y). apply CRle_refl.
Qed.

(* When we have an integration space, we only need to
   check stabilities to create smaller spaces. *)
Definition SubIntegrationSpace
           (IS : IntegrationSpace)
           (Lsub : PartialFunction (X (ElemFunc IS)) -> Set)
  : (forall f:PartialFunction (X (ElemFunc IS)), Lsub f -> L _ f)
    -> (forall f g : PartialFunction (X (ElemFunc IS)),
             PartialFunExtEq f g -> Lsub f -> Lsub g)
    -> Lsub (Ione IS)
    -> (forall f g : PartialFunction (X (ElemFunc IS)),
        (Lsub f -> Lsub g -> Lsub (Xplus f g)))
    -> (forall f : PartialFunction (X (ElemFunc IS)),
          Lsub f -> Lsub (Xabs f))
    -> (forall f : PartialFunction (X (ElemFunc IS)),
          Lsub f -> Lsub (XminConst f 1))
    -> (forall (a:CRcarrier (RealT (ElemFunc IS)))
         (f : PartialFunction (X (ElemFunc IS))),
          Lsub f -> Lsub (Xscale a f))
    -> IntegrationSpace.
Proof.
  intros.
  pose (Build_FunctionRieszSpace
          (X (ElemFunc IS)) (RealT (ElemFunc IS)) Lsub X1 X2 X3 X4 X5) as ElemSub.
  pose (fun f fLsub => I _ f (X0 f fLsub)) as Isub.
  assert (forall (f g : PartialFunction (X (ElemFunc IS)))
            (fL : Lsub f)
            (gL : Lsub g),
             Isub (Xplus f g) (LplusStable ElemSub f g fL gL)
             == Isub f fL + Isub g gL).
  { intros. unfold Isub.
    apply (CReq_trans _ (I IS (Xplus f g)
                           (LplusStable (ElemFunc IS) f g (X0 f fL) (X0 g gL)))).
    2: apply Iadditive. apply IExtensional. intros.
    destruct f,g,xF,y; simpl.
    apply CRplus_morph. apply DomainProp. apply DomainProp0. }
  assert (forall (a : CRcarrier (RealT (ElemFunc IS)))
            (f : PartialFunction (X (ElemFunc IS)))
            (fL : Lsub f),
        Isub (Xscale a f) (LscaleStable ElemSub a f fL)
        == a * (Isub f fL)).
  { intros. unfold Isub.
    apply (CReq_trans _ (I IS (Xscale a f)
                           (LscaleStable (ElemFunc IS) a f (X0 f fL)))).
    2: apply Ihomogeneous. apply IExtensional. intros.
    destruct f; simpl. apply CRmult_morph. reflexivity. apply DomainProp. }
  apply (Build_IntegrationSpace
           ElemSub Isub H0 H1 (Ione IS) H).
  - unfold Isub. transitivity (CR_of_Q (RealT (ElemFunc IS)) 1).
    rewrite <- (IoneInt IS).
    apply IExtensional. intros.
    destruct (Ione IS); simpl. apply DomainProp. reflexivity.
  - intros f fn fL fnL. intros. simpl in fL, fnL.
    apply (Icontinuous IS f fn (X0 f fL)
                       (fun n => X0 (fn n) (fnL n)) H2 H3).
  - intros. pose proof (Ilimit IS f (X0 f fL)).
    split.
    apply (CR_cv_eq _ (fun n : nat =>
          I IS (XminConst f (INR n))
            (@LminIntStable (ElemFunc IS) n f (X0 f fL)))).
    2: apply H2. intro n. apply IExtensional. intros.
    apply DomainProp.
    apply (CR_cv_eq _ (fun n : nat =>
          I IS
            (XminConst (Xabs f) (CR_of_Q _ (1# Pos.of_nat (S n))))
            (@LminConstStable (ElemFunc IS) (CR_of_Q _ (1# Pos.of_nat (S n)))
               (Xabs f) (invSuccRealPositive n)
               (LabsStable (ElemFunc IS) f (X0 f fL))))).
    2: apply H2. intro n. apply IExtensional. intros.
    apply DomainProp.
Defined.

Lemma IabsHomogeneous : forall {IS : IntegrationSpace}
                          (a : CRcarrier (RealT (ElemFunc IS)))
                          (f : PartialFunction (X (ElemFunc IS)))
                          (fL : L (ElemFunc IS) f),
    Iabs (Xscale a f) (LscaleStable (ElemFunc IS) a f fL)
    == (CRabs _ a) * Iabs f fL.
Proof.
  intros. unfold Iabs. rewrite <- Ihomogeneous.
  apply IExtensional. intros. destruct f; simpl.
  rewrite CRabs_mult. apply CRmult_morph. reflexivity.
  rewrite (DomainProp x xF y). reflexivity.
Qed.

Lemma integralPositive : forall (IS : IntegrationSpace)
                           (f : PartialFunction (X (ElemFunc IS)))
                           (fL : L (ElemFunc IS) f),
    nonNegFunc f
    -> 0 <= I IS f fL.
Proof.
  intros. apply (CRle_trans 0 (I IS (Izero IS) (Izero_is_L IS))).
  unfold Izero. unfold Izero_is_L. rewrite Ihomogeneous. rewrite CRmult_0_l.
  apply CRle_refl. apply INonDecreasing. intros. rewrite applyIzero.
  apply H.
Qed.

(* The usual triangular inequality of integrals : the absolute value of an integral
   is lower than the integral of the absolute value. *)
Lemma integralAbsMaj : forall {IS : IntegrationSpace}
                         (f : PartialFunction (X (ElemFunc IS)))
                         (fL : L (ElemFunc IS) f),
    CRabs _ (I IS f fL) <= Iabs f fL.
Proof.
  (* Because integral is increasing and  I f <= I |f| and -I f <= I |f| *)
  intros. apply CRabs_le. split.
  + unfold Iabs. rewrite <- (CRmult_1_l (I IS (Xabs f) (LabsStable (ElemFunc IS) f fL))).
    rewrite (CRopp_mult_distr_l 1). rewrite <- Ihomogeneous.
    apply INonDecreasing. intros. rewrite applyXscale.
    rewrite <- (CRopp_mult_distr_l 1). rewrite CRmult_1_l.
    destruct f; simpl.
    rewrite <- (CRopp_involutive (partialApply x y)).
    rewrite (DomainProp x xF y). rewrite <- CRabs_opp.
    apply CRopp_ge_le_contravar. apply CRle_abs.
  + apply INonDecreasing. intros. destruct f; simpl.
    rewrite (DomainProp x xF y). apply CRle_abs.
Qed.

Lemma IAbsSumMaj : forall {IS : IntegrationSpace}
                     (fn : nat -> PartialFunction (X (ElemFunc IS)))
                     (fnL : forall n:nat, L (ElemFunc IS) (fn n))
                     (n : nat),
    Iabs (Xsum fn n) (LsumStable fn fnL n)
    <= CRsum (fun n0 : nat => Iabs (fn n0) (fnL n0)) n.
Proof.
  induction n.
  - simpl. apply CRle_refl.
  - simpl. apply (CRle_trans _
                            (I IS
     (Xplus (Xabs (Xsum fn n))
            (Xabs (fn (S n))))
     (LplusStable (ElemFunc IS)
                  (Xabs (Xsum fn n))
                  (Xabs (fn (S n)))
                  (LabsStable (ElemFunc IS)
                              (Xsum fn n)
                              (LsumStable fn fnL n))
                  (LabsStable (ElemFunc IS) (fn (S n)) (fnL (S n)))))).
    + clear IHn. apply INonDecreasing. intros.
      destruct (fn (S n)), (Xsum fn n), xF, y ; simpl.
      apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_compat.
      rewrite (DomainProp0 x d d1). apply CRle_refl.
      rewrite (DomainProp x d0 d2). apply CRle_refl.
    + rewrite Iadditive. apply CRplus_le_compat. apply IHn.
      apply CRle_refl.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import QArith String Ascii.

(*The computable state representation is an FMap over
  player indices, represented as positive.*)
Require Import Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Import Structures.Orders NArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import OUVerT.strings compile OUVerT.orderedtypes
        OUVerT.dyadic OUVerT.numerics OUVerT.dist games.

Definition upd {A : finType} {T : Type}
           (a : A) (t : T) (s : {ffun A -> T}) :=
  finfun (fun b => if a==b then t else s b).

Module Index.
Section index.
  Variable n : N.t.
  Variable n_gt0 : (0 < N.to_nat n)%N.

  Record t : Type :=
    mk { val : N.t;
         pf : (N.to_nat val < N.to_nat n)%N }.

  Program Definition pred (i : t) : t :=
    @mk (N.pred (val i)) _.
  Next Obligation.
    move: (pf i); rewrite N2Nat.inj_pred.
    move: (N.to_nat (val i)) => n0 => H.
    apply/leP; apply: le_lt_trans; first by apply/leP; apply: leq_pred.
    by apply/leP.
  Qed.

  Program Definition max : t := @mk (N.pred n) _.
  Next Obligation.
    rewrite N2Nat.inj_pred; apply/ltP.
    move: (ltP n_gt0) => H.
    omega.
  Qed.
End index.
End Index.

(** Unnormalized functional weight distributions efficiently supporting:
    - sampling
    - weight update *)

Module AM.
Record t (A : Type) : Type :=
  mk {
      size : N.t;

      map :> M.t A;
            (* [wmap]: a map from positive indices in range
                       [0, size) to values [a] *)
      pf :
        forall i : N.t,
          (N.to_nat i < N.to_nat size)%nat ->
          exists a, M.find i map = Some a
    }.

Fixpoint Nlength (A : Type) (l : list A) : N.t :=
  match l with
  | nil => 0
  | _ :: l' => N.succ (Nlength l')
  end.

Section functions0.
  Variable A : Type.

  Program Definition init (a : A) : t A :=
    @mk _ 1 (M.add N0 a (M.empty _)) _.
  Next Obligation.
    exists a.
    rewrite Pos2Nat.inj_1 in H.
    have H2: i = N0.
    { case: i H => //.
      move => p; rewrite positive_N_nat => H.
      have H2: Pos.to_nat p = 0%nat.
      { move: H; move: (Pos.to_nat p) => n.
        elim: n => //. }
      apply: N2Nat.inj.
      rewrite positive_N_nat H2 //. }
    rewrite {}H2 MProps.F.add_eq_o //.
  Qed.

  Fixpoint map_from_list (l : list A) : N.t * M.t A :=
    List.fold_left
      (fun acc a =>
         let (i, m) := (acc : N.t * M.t A) in
         (N.succ i, M.add i a m))
      l
      (N0, M.empty _).

  Fixpoint map_from_keylist (l : list (M.key * A)) : M.t A :=
    match l with
    | nil => M.empty _
    | (i, a) :: l' => M.add i a (map_from_keylist l')
    end.

  Lemma map_from_list_fold_right l :
    map_from_list l =
    List.fold_right
      (fun a acc =>
         let (i, m) := (acc : N.t * M.t A) in
         (N.succ i, M.add i a m))
      (N0, M.empty _)
      (List.rev l).
  Proof.
    rewrite fold_left_rev_right.
    rewrite /map_from_list.
    elim: l => //.
  Qed.

  Fixpoint seq_upto (n : nat) : list N.t :=
    match n with
    | O => nil
    | S n' => rcons (seq_upto n') (N.of_nat n')
    end.

  Lemma seq_upto_length n : seq.size (seq_upto n) = n.
  Proof. by elim: n => // n /=; rewrite size_rcons => ->. Qed.

  Lemma seq_upto_nth (n m : nat) :
    (m < n)%nat ->
    nth N0 (seq_upto n) m = N.of_nat m.
  Proof.
    elim: n m => // n IH m H /=; rewrite nth_rcons.
    case H2: (m < seq.size (seq_upto n))%N.
    { rewrite IH => //.
      by rewrite seq_upto_length in H2. }
    case H3: (_ == _).
    { move: (eqP H3) => ->.
      by rewrite seq_upto_length. }
    rewrite seq_upto_length in H2, H3.
    elimtype False.
    move: {H}(ltP H); move/lt_n_Sm_le/le_lt_or_eq; case.
    { by move/ltP; rewrite H2. }
    by move => H4; subst m; rewrite eq_refl in H3.
  Qed.

  (** WORK-IN-PROGRESS:
  Lemma map_from_list_keylist l i :
    M.find i (snd (map_from_list l)) =
    M.find i (map_from_keylist (zip (seq_upto (seq.size l)) l)).
  Proof.
    rewrite map_from_list_fold_right.
    rewrite /map_from_keylist.
    move: (M.empty A) i 0%num.
    elim: l => // a l IH m i n /=.
    rewrite fold_right_app /= IH /=.
    (** NoDupA !!! *)
  Abort.

  Lemma map_from_list_index_gt l (n n' : N.t) m m' :
    List.fold_right
      (fun a acc =>
         let (i, m) := (acc : N.t * M.t A) in
         (N.succ i, M.add i a m))
      (n, m)
      l = (n', m') ->

  Lemma map_from_list_fold_right'_aux l (n : N.t) m :
    List.fold_right
      (fun a acc =>
         let (i, m) := (acc : N.t * M.t A) in
         (N.succ i, M.add i a m))
      (n, m)
      (List.rev l) =
    List.fold_right
      (fun a acc =>
         let (i, m) := (acc : N.t * M.t A) in
         (N.pred i, M.add i a m))
      (n + Nlength l, m)%num
      l.
  Proof.
    elim: l n m => /=.
    { by move => n m; rewrite N.add_0_r. }
    move => a l IH n m; rewrite fold_right_app /= IH.
    have ->: (N.succ n + Nlength l = n + N.succ (Nlength l))%num.
    { rewrite N.add_succ_l; symmetry; rewrite [(n + _)%num]N.add_comm N.add_succ_l.
      by rewrite [(Nlength l + _)%num]N.add_comm. }

    case: (fold_right
     (fun (a0 : A) (acc : N.t * M.t A) =>
      let (i, m0) := acc in (N.pred i, M.add i a0 m0))
     ((n + N.succ (Nlength l))%num, M.add n a m) l) => //.

    rewrite IH.

    rewrite fold_left_rev_right.
    rewrite /map_from_list.
    elim: l => //.
  Qed.

  Lemma map_from_list_domain_default l (i : N.t) (a : A) :
    (i < fst (map_from_list l))%nat ->
    M.find i (snd (map_from_list l)) = Some (List.nth (N.to_nat i) l a).
  Proof.
    rewrite map_from_list_fold_right.
    elim: (List.rev l) i => // ax l' IH i /= H.
    move: H IH; case: (fold_right _ (0%num, M.empty A) l') => a0 b /= H IH.

    case H2: (N.eq_dec a0 i) => [Hx|Hx].
    { subst i; move {H2 H}.
      rewrite MProps.F.add_eq_o => //.
    have H3: (i < a0)%N.
    { rewrite nat_of_bin_succ in H.
      apply/ltP; move: (ltP H) => H3. clear - H3 Hx.
      have H4: nat_of_bin a0 <> nat_of_bin i.
      { by move => H4; apply: Hx; apply: nat_of_bin_inj. }
      omega. }
    case: (IH _ H3) => x H4; exists x.
    rewrite MProps.F.add_neq_o => //.
  Qed.
  *)

  Lemma map_from_list_domain l (i : N.t) :
    (i < fst (map_from_list l))%nat ->
    exists a, M.find i (snd (map_from_list l)) = Some a.
  Proof.
    rewrite map_from_list_fold_right; elim: (List.rev l) i => // a l' IH i /= H.
    move: H IH; case: (fold_right _ (0%num, M.empty A) l') => a0 b /= H IH.
    case H2: (N.eq_dec a0 i) => [Hx|Hx].
    { subst i; move {H2 H}.
      by rewrite MProps.F.add_eq_o => //; exists a. }
    have H3: (i < a0)%N.
    { rewrite nat_of_bin_succ in H.
      apply/ltP; move: (ltP H) => H3. clear - H3 Hx.
      have H4: nat_of_bin a0 <> nat_of_bin i.
      { by move => H4; apply: Hx; apply: nat_of_bin_inj. }
      omega. }
    case: (IH _ H3) => x H4; exists x.
    rewrite MProps.F.add_neq_o => //.
  Qed.

  Program Definition from_list (l : list A) : t A :=
    @mk _ (fst (map_from_list l)) (snd (map_from_list l)) _.
  Next Obligation.
    apply: map_from_list_domain.
    by apply: N2Nat_lt.
  Qed.

  Definition empty : t A := from_list nil.
End functions0.

Section functions.
  Variable A : Type.
  Variable w : t A.

  Definition index : Type := Index.t (size w).
  Definition index_key : index -> M.key := @Index.val (size w).
  Definition index_nat : index -> nat := @Index.val (size w).

  Definition ordinal_of_index (i : index) : 'I_(N.to_nat (size w)) :=
    Ordinal (Index.pf i).

  Coercion index_key : index >-> M.key.

  Program Definition lookup (i : index) : A :=
    match M.find i (map w) with
    | None => _
    | Some a => a
    end.
  Next Obligation.
    move: (Index.pf i) => H.
    move: (pf H) => H2.
    elimtype False.
    by case: H2 => x H3; rewrite H3 in Heq_anonymous.
  Qed.

  Program Definition update
          (i : index)
          (a': A)
    : t A :=
    @mk
      _
      (size w)
      (M.add i a' (map w))
      _.
  Next Obligation.
    case (N.eqb_spec (index_key i) i0).
    { move => H2; subst i0; exists a'.
      rewrite MProps.F.add_eq_o => //. }
    move => Hneq; rewrite MProps.F.add_neq_o => //.
    by apply pf.
  Qed.

  Program Definition bump (n : N.t) : Index.t (N.succ n) :=
    @Index.mk _ n _.
  Next Obligation.
    rewrite N2Nat.inj_succ; apply/ltP; omega.
  Qed.

  (* Append [a] at the end of array map [w]. *)
  Program Definition add (a : A) : t A :=
    @mk
      A
      (N.succ (size w))
      (M.add (Index.val (bump (size w))) a (map w))
      _.
  Next Obligation.
    case: (N.eqb_spec (size w) i).
    { move => H2; subst i.
      exists a; rewrite MProps.F.add_eq_o //. }
    move => H2; rewrite MProps.F.add_neq_o => //.
    apply pf.
    have H3: N.to_nat (size w) <> N.to_nat i.
    { by rewrite N2Nat.inj_iff. }
    rewrite N2Nat.inj_succ in H.
    move: H H3; move: (N.to_nat (size w)) => x; move: (N.to_nat i) => y.
    move/ltP => H H3; apply/ltP; omega.
  Qed.

  (** Add [a] at level [i], regardless whether [i] is already
      present in the array map. If [i >= size], then this operation
      may require the addition of a new array cell at index [size]. *)

  Program Definition update_add (i : N.t) (a : A) : t A :=
    (match N.ltb i (size w) as o return _ = o -> _ with
     | true => fun pf => update (@Index.mk _ i _) a
     | false => fun _ => add a
     end) erefl.
  Next Obligation.
    move: pf0; rewrite N.ltb_lt => H.
    apply/ltP; rewrite /N.lt N2Nat.inj_compare in H.
    by rewrite nat_compare_lt.
  Qed.

  Program Definition swap (i j : index) : t A :=
    let a := lookup i in
    let b := lookup j in
    @mk
      _
      (size w)
      (M.add i b (M.add j a (map w)))
      _.
  Next Obligation.
    case: (N.eqb_spec (index_key i) i0).
    { move => H2; subst i0; exists (lookup j).
      rewrite MProps.F.add_eq_o => //. }
    move => H2.
    case: (N.eqb_spec (index_key j) i0).
    { move => H3; subst i0; exists (lookup i).
      rewrite MProps.F.add_neq_o => //.
      rewrite MProps.F.add_eq_o => //. }
    move => H3.
    rewrite MProps.F.add_neq_o => //.
    rewrite MProps.F.add_neq_o => //.
    by apply pf.
  Qed.

  Definition split_aux
             (f : M.key -> A -> bool) : list A * list A :=
    M.fold
      (fun i a (p : list A * list A) =>
         match p with
         | (trues, falses) =>
           if f i a then (a :: trues, falses)
           else (trues, a :: falses)
         end)
      (map w)
      (nil, nil).

  Definition split (f : M.key -> A -> bool) : (t A * t A) :=
    let (trues, falses) := split_aux f in
    (from_list trues, from_list falses).

  Program Definition fmapi
             (B : Type)
             (f : M.key -> A -> B)
             (f_pf : forall (x y : M.key) (e : A), N.eq x y -> f x e = f y e)
    : t B :=
    @mk
      _
      (size w)
      (M.mapi f (map w))
      _.
  Next Obligation.
    rewrite MFacts.mapi_o => //.
    case: (pf H) => x ->; exists (f i x) => //.
  Qed.

  Program Definition fmap
             (B : Type)
             (f : A -> B)
    : t B := @fmapi _ (fun (_ : M.key) (a : A) => f a) _.

  Definition fold
             (B : Type)
             (f : N.t -> A -> B -> B)
             (acc : B)
    : B := M.fold f (map w) acc.

  Definition to_list : list (M.key * A) := M.elements (map w).
End functions.

(** Representation invariant wrt. functions of type {ffun 'I_size -> A} *)

Section rep.
  Variable A : Type.

  Definition rep (w : t A) (f : {ffun 'I_(N.to_nat (size w)) -> A}) : Prop :=
    forall (i : index w), lookup i = f (ordinal_of_index i).

  Variable w : t A.
  Variable f : {ffun 'I_(N.to_nat (size w)) -> A}.
  Hypothesis w_rep : rep f.

  Lemma lookup_ok : forall i : index w, lookup i = f (ordinal_of_index i).
  Proof. apply: w_rep. Qed.

  (** WIP Lemma empty_ok : *)
End rep.
End AM.

Module DIST.
Record row (A : Type) : Type :=
  mkRow { row_weight : D;
          row_max : D;
          row_arraymap : AM.t (A*D) }.

Record t (A : Type) : Type :=
  mk {
      cpmf :> M.t (row A)
           (* [cpmf]: a map from
                - LEVEL 1: weight level i = [2^i, 2^{i+1})
                - LEVEL 2: weight array containing weights (a,d)
                           in the range of weight level i, along
                           with the total probability mass for that level *)
    }.

Section functions.
  Variable A : Type.

  Definition empty : t A := mk (M.empty _).

  (** We assume all weights are between 0 and 1. *)

  Definition level_of (d : D) : N.t :=
    match d with
    | Dmake (Zpos x) y => N.sub (N.pos y) (N.log2 (N.pos x))
    | Dmake 0 _ => 0
    | Dmake (Zneg _) _ => 0
    end.

  Compute level_of (Dmake 1 1). (*=1*)
  Compute level_of (Dmake 1 2). (*=2*)
  (* level_of spec: forall d, 2^{-(level_of d)} <= d < 2^{-(level_of d) - 1}*)

  Program Definition add_weight (a : A) (d : D) (w : t A) : t A :=
    let r :=
        match M.find (level_of d) w with
        | None => mkRow 0%D 0%D (AM.empty _)
        | Some m => m
        end
    in
    let r' :=
        mkRow (Dadd d r.(row_weight))
              (Dmax d r.(row_max))
              (AM.add r.(row_arraymap) (a,d))
    in mk (M.add (level_of d) r' (cpmf w)).

  Fixpoint add_weights
             (l : list (A*D))
             (w : t A)
    : t A :=
    match l with
    | nil => w
    | (a,d) :: l' => add_weights l' (add_weight a d w)
    end.

  Definition sum_weights (m : AM.t (A*D)) : D :=
    AM.fold m
      (fun _ (p : A*D) acc => let (a,d') := p in Dadd acc d')
      0%D.

  Definition max_weight (m : AM.t (A*D)) : D :=
    AM.fold m
      (fun _ (p : A*D) acc => let (a,d') := p in Dmax acc d')
      0%D.

  (** Updates [w] according to [f], returning the new array map
      together with any pairs (a,d) that are now mis-leveled (stored
      in the proj2 array map). *)
  Definition update_level
             (f : A -> D -> D)
             (level : N.t)
             (m : row A)
    : (row A * AM.t (A*D)) :=
    (* w': the updated weights *)
    let w' := AM.fmap m.(row_arraymap) (fun p : (A*D) => let (a,d) := p in (a, f a d)) in
    (* split the entries that are now mis-leveled *)
    let g := fun i (p : (A*D)) => let (a,d') := p in N.eqb (level_of d') level in
    let (stay, go) := AM.split w' g in
    (mkRow (sum_weights stay) (max_weight stay) stay, go).

  Lemma update_level_pf f (x y : M.key) w :
    N.eq x y -> update_level f x w = update_level f y w.
  Proof. by move => ->. Qed.

  Definition update_weights
             (f : A -> D -> D)
             (w : M.t (row A))
    : t A :=
    let w'':= M.mapi (update_level f) w in
    let w' := M.map fst w'' in
    let removed := M.fold (fun i p l0 => AM.to_list (snd p) ++ l0) w'' nil in
    add_weights
      (List.map snd removed) (mk w').

  (** The distribution's total weight *)
  Definition weight (w : t A) : D :=
    M.fold (fun i r d0 => Dadd r.(row_weight) d0) w D0.
End functions.
End DIST.

Section sampling.
  Variable T : Type. (* randomness oracle state *)
  Variable rand : T -> D*T.
  Variable rand_range : T -> N.t -> N.t*T. (* generate a random integer in range *)
  Hypothesis rand_range_ok :
    forall t n,
      let (n', t') := rand_range t n in
      (N.to_nat n' < N.to_nat n)%N.

  Fixpoint cdf_sample_aux
           (A : Type) (a0 : A)
           (acc r : D) (l : list (D*A))
    : (D * A) :=
    match l with
    | nil => (D0, a0) (*should never occur*)
    | (w, a) :: l' =>
      if Dle_bool acc r && Dle_bool r (Dadd acc w) then
        (w, a)
      else cdf_sample_aux a0 (Dadd acc w) r l'
    end.

  (** Use inverse transform sampling to select row. *)
  Definition cdf_sample_row
             (A : Type)
             (w : DIST.t A)
             (t : T)
    : (DIST.row A * T) :=
    let sum := DIST.weight w in
    let (r, t') := rand t in
    let r' := Dmult r sum in
    let w := cdf_sample_aux
               (DIST.mkRow D0 D0 (AM.empty _))
               D0
               r'
               (map (fun (p : M.key * DIST.row A) =>
                       let (_, r) := p in
                       (r.(DIST.row_weight), r))
                    (M.elements (DIST.cpmf w))) in
    (snd w, t').

  (** Sample a value in range [0..size-1] *)
  Program Definition sample_index
             (t : T)
             (size : N.t)
    : (Index.t size * T) :=
    (@Index.mk size (fst (rand_range t size)) _, snd (rand_range t size)).
  Next Obligation.
    move: (rand_range_ok t size).
    case: (rand_range t size) => //.
  Qed.

  (** Rejection-sample within row. *)
  Fixpoint rejection_sample_row_aux
             (A : Type)
             (a0 : A)
             (r : DIST.row A)
             (t : T)
             (n : nat)
    : (A * T) :=
    let w_max := r.(DIST.row_max) in
    let w := r.(DIST.row_arraymap) in
    let size := w.(AM.size) in
    match n with
    | O => (a0, t)
    | S n' =>
      let (i, t2) := sample_index t size in
      let (a, d) := AM.lookup i in
      let (u, t') := rand t2 in
      if Dle_bool (Dmult u w_max) d then
        (a, t')
      else rejection_sample_row_aux a0 r t' n'
    end.

  Definition rejection_sample_row
             (A : Type)
             (a0 : A)
             (r : DIST.row A)
             (t : T)
    : (A * T) :=
    rejection_sample_row_aux a0 r t 1000.

  (** The overall sampling procedure. *)
  Definition sample
             (A : Type)
             (a0 : A)
             (w : DIST.t A)
             (t : T)
    : (A * T) :=
    let (r, t2) := cdf_sample_row w t in
    rejection_sample_row a0 r t2.

  Fixpoint prod_sample_aux
           (A : Type)
           (a0 : A)
           (acc : M.t A * T)
           (n : nat)
           (p : nat -> DIST.t A)
    : (M.t A * T) :=
    match n with
    | O => acc
    | S n' =>
      let (a, t) := sample a0 (p n') (snd acc) in
      prod_sample_aux a0 (M.add (N.of_nat n') a (fst acc), t) n' p
    end.

  Definition prod_sample
             (num_players : nat)
             (A : Type)
             (a0 : A)
             (p : nat -> DIST.t A)
             (t : T)
    : (M.t A * T) :=
    prod_sample_aux a0 (M.empty _, t) num_players p.
End sampling.

Axiom rand_state : Type.
Extract Constant rand_state => "unit".
Axiom init_rand_state : rand_state.
Extract Constant init_rand_state => "()".

Axiom rand : rand_state -> (D*rand_state). (*in range [0,1]*)
Extract Constant rand =>
 "fun _ ->
  let _ = Random.self_init () in
  let d = Random.int 256 in
  let zn = Big.of_int d in
  let peight = Big.of_int 8 in
  let q = { num = zn; den = peight }
  in
  Printf.eprintf ""Generated random r = %d"" d; prerr_newline ();
  (q, ())".

(** PRECONDITION: [rand_range t n]: n is Npos p for some p *)
Axiom rand_range : rand_state -> N.t -> (N.t*rand_state). (*in range [0,size-1]*)
Extract Constant rand_range =>
 "fun _ size ->
  let _ = Random.self_init () in
  let d = Random.int (Big.to_int size)
  in
  Printf.eprintf ""Generated in-range random i = %d"" d; prerr_newline ();
  (Big.of_int d, ())".

Axiom rand_range_ok :
  forall t n,
    let (n', t') := rand_range t n in
    (N.to_nat n' < N.to_nat n)%N.

Definition rsample A (a0 : A) (c : DIST.t A) : A :=
  fst (sample rand rand_range_ok a0 c init_rand_state).

Definition rprod_sample A (a0 : A) (num_players : nat) (p : nat -> DIST.t A) : M.t A :=
  fst (prod_sample rand rand_range_ok num_players a0 p init_rand_state).

Section rsample_cost.
  Context {A : Type} (a0 : A) {num_players : nat}.
  Context `{CCostInstance : CCostClass num_players A}.

  Definition rsample_ccost (i : N.t) (a : A) (p : nat -> DIST.t A) : D :=
    let m := rprod_sample a0 num_players p in
    ccost i (M.add i a m).
End rsample_cost.

Section expected_rsample_cost.
  Context {A : finType} {Aeq : A -> A -> bool}.
  (*Aeq: not necessarily the equality associated with A's eqType instance.*)
  Context (a0 : A) {num_players : nat}.
  Context `{CGameInstance : cgame num_players A}.

  Variable (p : nat -> DIST.t A).
  Variable (f : {ffun 'I_num_players -> dist A rat_realFieldType}).
  (* TO BE UPDATED:
  Hypothesis dists_match : forall i : 'I_num_players, dist_cdist_match Aeq (p i) (f i).

  Axiom rsample_ccost_expected :
    forall (i : 'I_num_players) (a : A),
      D_to_Q (rsample_ccost a0 (N.of_nat i) a p) =
      rat_to_Q (expectedValue (prod_dist f) (fun x => cost i (upd i a x))).*)
End expected_rsample_cost.

(* Definition fun_of_t *)
(*            (A : Type) *)
(*            (Aeq : A -> A -> bool) *)
(*            (c : t A) : A -> Q := *)
(*   fun a => *)
(*     match findA (Aeq a) c with  *)
(*     | None => 0 *)
(*     | Some d => D_to_Q d *)
(*     end. *)

(* Definition dist_t_match *)
(*            (A : finType) *)
(*            (Aeq : A -> A -> bool)            *)
(*            (c : t A) *)
(*            (d : dist A rat_realFieldType)            *)
(*   : Prop := *)
(*   pmf d = finfun (fun a => Q_to_rat (fun_of_t Aeq c a)). *)


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
Import Nat.
From Coq Require Import Lia.
From Coq Require Import Omega.
From Coq Require Import Lists.List.
From Coq Require Import String.
Open Scope string_scope.
Import ListNotations.
From TFT Require Import Maps.

Definition peer := string.

Definition hist := list (peer * bool).
Print eqb_string.
Lemma eqb_reflect : forall x y, reflect (x = y) (eqb_string x y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply eqb_string_true_iff.
Qed.

Hint Resolve eqb_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Ltac inv H := inversion H; clear H; subst.

Fixpoint get (h:hist) (p:peer) : bool :=
  match h with
  | [] => false
  | (p', val)::t => if eqb_string p' p then val else get t p
  end.

Definition join_hist := hist.
Definition left_hist := hist.
Definition sent_hist := hist.
Definition holds_hist := hist.
Definition state := (join_hist * left_hist * sent_hist * holds_hist)%type.

Definition eqb_bool (b1 b2:bool) : bool :=
  match b1, b2 with
    | true, true => true
    | true, false => false
    | false, true => false
    | false, false => true
  end.

Definition joined (s:state) : join_hist :=
  match s with
  | (h, _, _, _) => h
  end.

Definition has_left (s:state) : left_hist :=
  match s with
  | (_, h, _, _) => h
  end.

Definition has_sent (s:state) : sent_hist :=
  match s with
  | (_, _, h, _) => h
  end.

Definition holds (s:state) : holds_hist :=
  match s with
  | (_, _, _, h) => h
  end.

Definition relation (X : Type) := X -> X -> Prop.

Reserved Notation " t '-->' t' " (at level 40).
Inductive action : state -> state -> Prop :=
  | A_Send : forall st p1 p2,
    get (holds st) p1 = true /\
    get (holds st) p2 = false /\
    get (joined st) p1 = true /\
    get (joined st) p2 = true  ->
    st --> ((joined st), (has_left st), ((p1, true)::(has_sent st)), ((p2, true)::(holds st)))
  | A_Join_Without : forall st p,
    get (joined st) p = false /\
    get (has_left st) p = false /\
    (exists q, get (joined st) q = true) ->
    st --> ( ((p, true)::(joined st)), (has_left st), (has_sent st), ((p, false)::(holds st)))
  | A_Join_With : forall st p,
    get (joined st) p = false /\
    get (has_left st) p = false /\
    (exists q, get (joined st) q = true) ->
    st --> ( ((p, true)::(joined st)), (has_left st), (has_sent st), ((p, true)::(holds st)))
  | A_Leave : forall st p,
    get (joined st) p = true /\
    get (has_left st) p = false /\
    ( get (has_sent st) p = true \/
      ( forall q, ( get (joined st) q = true ->
                    ( get (holds st) q = true /\ get (has_sent st) q = false)
                  )
      )
    ) ->
    st --> ( ((p, false)::(joined st)), ((p, true)::(has_left st)),
                        has_sent st, holds st)
where " st '-->' st' " := (action st st').

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R y z ->
                    multi R x y ->
                    multi R x z.

Notation " st '-->*' st' " := (multi action st st') (at level 40).

Definition initial (st: state) :=
  (forall p, get (has_left st) p = false /\ get (has_sent st) p = false) /\
  (exists seeder, get (joined st) seeder = true /\ get (holds st) seeder = true).

Definition Init (init: state -> Prop) (inv: state -> Prop) :=
  forall i, init i -> inv i.

Definition Inductive (inv: state -> Prop) :=
  forall st st',
  st --> st' -> inv st -> inv st'.

Definition Inv (init: state -> Prop) (inv: state -> Prop) :=
  forall i st,
  init i ->
  inv i /\ (i -->* st -> inv st).

Theorem Safe_Inductive (init inv : state -> Prop):
  Init init inv /\ Inductive inv -> Inv init inv.
Proof.
  unfold Init. unfold Inductive. unfold Inv.
  intros.
  destruct H.
  split.
  - apply H. auto.
  - intros.
    induction H2.
    + apply H. auto.
    + apply H1 with y.
      * auto.
      * auto.
Qed.

Definition prepared_cannot_send_inv (st:state) :=
  forall p, get (joined st) p = false /\ get (has_left st) p = false ->
            get (has_sent st) p = false.

Theorem prepared_cannot_send_init: Init initial prepared_cannot_send_inv.
Proof.
  unfold Init. unfold initial. unfold prepared_cannot_send_inv.
  intros.
  inv H. inv H0. inv H2. inv H0. apply H1.
Qed.

Theorem prepared_cannot_send_inductive: Inductive prepared_cannot_send_inv.
Proof.
  unfold Inductive. unfold prepared_cannot_send_inv.
  intros. inv H1.
  induction H;  try(inv H; simpl in H2; simpl in H3; inv H4; inv H5; simpl).
  - bdestruct (eqb_string p1 p). inv H5. rewrite H2 in H4. inv H4.
    auto.
  - bdestruct (eqb_string p0 p). inv H2.
    apply H0. split; auto.
  - apply H0; split; auto.
    bdestruct (eqb_string p0 p). inv H2.
    auto.
  - bdestruct (eqb_string p0 p). inv H3.
    apply H0; auto.
  - bdestruct (eqb_string p0 p). inv H3.
    apply H0; auto.
Qed.

Theorem prepared_cannot_send_invariant: Inv initial prepared_cannot_send_inv.
Proof.
  apply (Safe_Inductive initial prepared_cannot_send_inv).
  split. apply prepared_cannot_send_init. apply prepared_cannot_send_inductive.
Qed.

Definition sent_holds_inv (st: state) :=
  forall p, get (has_sent st) p = true -> get (holds st) p = true.

Theorem sent_holds_init: Init initial sent_holds_inv.
Proof.
  unfold Init. unfold initial. unfold sent_holds_inv. intros.
  destruct H. destruct H1. destruct H1.
  destruct (H p). rewrite H0 in H4. inversion H4.
Qed.

Theorem sent_holds_invariant: Inv initial sent_holds_inv.
Proof.
  unfold Inv. intros.
  split.
  - apply sent_holds_init; auto.
  - intros.
    unfold sent_holds_inv.
    intros.
    induction H0.
    + unfold initial in H. inv H. inv H2. inv H. destruct (H0 p).
      rewrite H1 in H4. inv H4.
    + induction H0; try(inv H0; simpl in H1; inv H4; inv H5; simpl);
      try(bdestruct (eqb_string p2 p); auto);
      try(bdestruct (eqb_string p1 p); auto);
      try(bdestruct (eqb_string p0 p); auto).
      * inv H0. simpl in H1. inv H4. rewrite H3. auto.
      * inv H5.
        assert(Ha: get (has_sent st) p = false).
        apply (prepared_cannot_send_invariant x st); auto.
        rewrite H1 in Ha. inv Ha.
Qed.

Definition remaining_holds_inv (st: state) :=
    forall p,
    (get (has_sent st) p = true /\ get (joined st) p = true) ->
    (exists q, get (holds st) q = true /\
               get (has_sent st) q = false /\
               get (joined st) q = true
    ).

Theorem remaining_holds_init: Init initial remaining_holds_inv.
Proof.
  unfold Init. unfold initial.
  unfold remaining_holds_inv.
  intros.
  inv H0.
  inv H. inv H3.
  exists x. inv H. split; auto.
  split. apply H0. auto.
Qed.

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros.
  unfold not. intros.
  apply H in H1. unfold not in H0. auto.
Qed.

Theorem remaining_holds_invariant: Inv initial remaining_holds_inv.
Proof.
  unfold Inv.
  intros. split. apply remaining_holds_init; auto.
  intros.
  induction H0.
  - apply remaining_holds_init; auto.
  - assert(Hinit: initial x); auto.
    apply IHmulti in H.
    induction H0;
    try(inv H0; inv H3; inv H4; unfold remaining_holds_inv; simpl; intros);
    try(unfold remaining_holds_inv in H).
    + apply (sent_holds_invariant x st) in Hinit.
      inv Hinit.
      apply H7 in H1. unfold sent_holds_inv in H1.
      assert(get (has_sent st) p2 = true -> get (holds st) p2 = true); auto.
      apply contrapositive in H8.
      apply not_true_iff_false in H8.

      bdestruct (eqb_string p1 p); auto. inv H4;
      try(exists p2; bdestruct (eqb_string p2 p2); bdestruct (eqb_string p p2); try(repeat(split; auto))).
      * inv H9.  rewrite H2 in H0.  inv H0.
      * unfold not in H4. assert (p2 = p2); auto. apply H4 in H12. inv H12.
      * exists p2.
        try(bdestruct (eqb_string p2 p2); bdestruct (eqb_string p1 p2); try(repeat(split; auto))).
        inv H11. rewrite H2 in H0; auto.
        unfold not in H10. assert (p2 = p2); auto. apply H10 in H12. inv H12.
      * apply not_true_iff_false. auto.
    + bdestruct (eqb_string p p0).
      inv H4.
      apply (prepared_cannot_send_invariant x st) in Hinit.
      inv Hinit.
      apply H5 in H1.
      unfold prepared_cannot_send_inv in H1.
      assert (get (has_sent st) p0 = false). apply H1; auto.
      rewrite H6 in H8; inv H8.
      apply H in H4. inv H4. inv H6. inv H7.
      exists x1.
      bdestruct (eqb_string p x1). split.
      inv H7. rewrite H2 in H8; inv H8.
      split; auto.
      split; auto.
    + bdestruct (eqb_string p p0). inv H4.
      apply (prepared_cannot_send_invariant x st) in Hinit.
      inv Hinit.
      apply H5 in H1.
      unfold prepared_cannot_send_inv in H1.
      assert (get (has_sent st) p0 = false). apply H1; auto.
      rewrite H6 in H8; inv H8.
      apply H in H4. inv H4. inv H6. inv H7.
      exists x1.
      bdestruct (eqb_string p x1). split.
      inv H7. rewrite H2 in H8; inv H8.
      split; auto.
      split; auto.
    + bdestruct (eqb_string p p0); auto. inv H4; inv H7. inv H4.
      assert(get (has_sent st) p = true /\ get (joined st) p = true); auto.
      apply H in H4. repeat(try(inv H4)). inv H8. inv H9.
      exists x0.
      split; auto.
      split; auto.
      bdestruct (eqb_string p x0); auto. inv H9. rewrite H3 in H8; inv H8.
    + bdestruct (eqb_string p p0); auto. inv H4; inv H7. inv H4.
      apply H3 in H7. inv H7. rewrite H6 in H8; inv H8.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Different definitions of pathes in a directed graph.                 *)

(* The following notions are defined :                                  *)
(*      - D_walk : list of vertices joined one by one by arcs,          *)
(*                constructors : DW_null, DW_step;                      *)
(*      - D_trail : walk without repetition of arcs,                    *)
(*              constructors : DT_null, DT_step;                        *)
(*      - D_path : trail without repetition of inner vertices,          *)
(*              constructors : DP_null, DP_step;                        *)
(*      - D_closed_walk, D_closed_trail, D_cycle.                       *)

Require Export Digraphs.

Section DIRECTED_PATHES.

Variable A:Type.
Variable v : @V_set A.
Variable a : @A_set A.

Inductive D_walk : @Vertex A-> @Vertex A-> @V_list A-> @A_list A-> Prop :=
  | DW_null : forall x : Vertex, v x -> D_walk x x V_nil A_nil
  | DW_step :
      forall (x y z : Vertex) (vl : V_list) (al : A_list),
      D_walk y z vl al ->
      v x -> a (A_ends x y) -> D_walk x z (y :: vl) (A_ends x y :: al).

Definition D_closed_walk :=
  forall (x : Vertex) (vl : V_list) (al : A_list), D_walk x x vl al.

Inductive D_trail : @Vertex A-> @Vertex A-> @V_list A-> @A_list A-> Prop :=
  | DT_null : forall x : Vertex, v x -> D_trail x x V_nil A_nil
  | DT_step :
      forall (x y z : Vertex) (vl : V_list) (al : A_list),
      D_trail y z vl al ->
      v x ->
      a (A_ends x y) ->
      ~ In (A_ends x y) al -> D_trail x z (y :: vl) (A_ends x y :: al).

Definition D_closed_trail :=
  forall (x : Vertex) (vl : V_list) (al : A_list), D_trail x x vl al.

Inductive D_path : @Vertex A-> @Vertex A-> @V_list A-> @A_list A-> Prop :=
  | DP_null : forall x : Vertex, v x -> D_path x x V_nil A_nil
  | DP_step :
      forall (x y z : Vertex) (vl : V_list) (al : A_list),
      D_path y z vl al ->
      v x ->
      a (A_ends x y) ->
      x <> y ->
      ~ In y vl ->
      (In x vl -> x = z) ->
      ~ In (A_ends x y) al -> D_path x z (y :: vl) (A_ends x y :: al).

Definition D_cycle :=
  forall (x : Vertex) (vl : V_list) (al : A_list), D_path x x vl al.

Lemma D_trail_isa_walk :
 forall (x y : Vertex) (vl : V_list) (al : A_list) (t : D_trail x y vl al),
 D_walk x y vl al.
Proof.
        intros x y vl al t; elim t; intros.
        apply DW_null; trivial.

        apply DW_step; trivial.
Qed.

Lemma D_path_isa_trail :
 forall (x y : Vertex) (vl : V_list) (al : A_list) (p : D_path x y vl al),
 D_trail x y vl al.
Proof.
        intros x y vl al p; elim p; intros.
        apply DT_null; trivial.

        apply DT_step; trivial.
Qed.

Lemma D_path_isa_walk :
 forall (x y : Vertex) (vl : V_list) (al : A_list) (p : D_path x y vl al),
 D_walk x y vl al.
Proof.
   intros. apply D_trail_isa_walk. apply D_path_isa_trail; auto.
Qed.

Lemma DW_iny_vl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al -> vl <> V_nil -> In y vl.
Proof.
        intros x y vl al d; elim d; intros.
        absurd (V_nil = @V_nil A); auto.

        inversion H.
        simpl in |- *; auto.

        rewrite H9; simpl in |- *; right.
        apply H0; rewrite <- H9; discriminate.
Qed.

Lemma DW_endx_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list), D_walk x y vl al -> v x.
Proof.
        intros x y vl el d; elim d; auto.
Qed.

Lemma DW_endy_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list), D_walk x y vl al -> v y.
Proof.
        intros x y vl el d; elim d; auto.
Qed.

Lemma DW_invl_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al -> forall z : Vertex, In z vl -> v z.
Proof.
        intros x y vl al d; elim d; intros.
        inversion H0.

        inversion H3; subst; auto.
        apply (DW_endx_inv _ _ _ _ H).
Qed.

Lemma DW_inel_ina :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> a (A_ends x' y').
Proof.
        intros x y vl el d; elim d; intros.
        inversion H0.

        inversion H3; auto.
        inversion H4; subst; auto.
Qed.

Lemma DW_inxyel_inxvl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> In x' (x :: vl).
Proof.
        intros x y vl al d; elim d; intros.
        inversion H0.

        inversion H3.
          inversion H4.
          simpl in |- *; auto.

          simpl in |- *; right.
          apply (H0 x' y'); auto.
Qed.

Lemma DW_inxyel_inyvl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> In y' (x :: vl).
Proof.
        intros x y vl el d; elim d; intros.
        inversion H0.

        inversion H3.
          inversion H4.
          simpl in |- *; auto.

          simpl in |- *; right.
          apply (H0 x' y'); auto.
Qed.

Lemma DW_backstep :
 forall (x y z : Vertex) (vl : V_list) (al : A_list),
 D_walk x z (y :: vl) al ->
   exists al' : A_list, D_walk y z vl al' /\ (al = (A_ends x y) ::al').
Proof.
        intros; inversion H.
        split with al0. split; auto.
Qed.

Lemma DW_neq_ends_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk x y vl al -> x <> y -> vl <> V_nil /\ al <> A_nil.
Proof.
        intros; inversion H; subst; auto.
          split; intro J; inversion J.
Qed.

Lemma DW_Vnil_inv :
 forall (x y : Vertex) (al : A_list),
 D_walk x y V_nil al -> x = y /\ al = A_nil.
Proof.
        intros; inversion H; subst; auto.
Qed.

Lemma DW_Anil_inv :
 forall (x y : Vertex) (vl : V_list),
 D_walk x y vl A_nil -> x = y /\ vl = V_nil.
Proof.
        intros; inversion H; subst; auto.
Qed.

Lemma DP_iny_vl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al -> vl <> V_nil -> In y vl.
Proof.
        intros x y vl al d; elim d; intros.
        absurd (V_nil = @V_nil A); auto.

        inversion H.
          simpl in |- *; auto.

          rewrite H17; simpl in |- *; right.
          apply H0; rewrite <- H17; discriminate.
Qed.

Lemma DP_endx_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list), D_path x y vl al -> v x.
Proof.
        intros x y vl el d; elim d; auto.
Qed.

Lemma DP_endy_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list), D_path x y vl al -> v y.
Proof.
        intros x y vl el d; elim d; auto.
Qed.

Lemma DP_invl_inv :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al -> forall z : Vertex, In z vl -> v z.
Proof.
        intros x y vl al d; elim d; intros.
        inversion H0.

        inversion H7; subst; auto.
        apply (DP_endx_inv _ _ _ _ H).
Qed.

Lemma DP_inel_ina :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> a (A_ends x' y').
Proof.
        intros x y vl el d; elim d; intros.
        inversion H0.

        inversion H7; subst; auto.
        inversion H8; subst; auto.
Qed.

Lemma DP_inxyel_inxvl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> In x' (x :: vl).
Proof.
        intros x y vl al d; elim d; intros.
        inversion H0.

        inversion H7.
          inversion H8; subst.
          simpl in |- *; auto.

          simpl in |- *; right.
          apply (H0 x' y'); auto.
Qed.

Lemma DP_inxyel_inyvl :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al ->
 forall x' y' : Vertex, In (A_ends x' y') al -> In y' (x :: vl).
Proof.
        intros x y vl el d; elim d; intros.
        inversion H0.

        inversion H7.
          inversion H8; subst.
          simpl in |- *; auto.

          simpl in |- *; right.
          apply (H0 x' y'); auto.
Qed.

Lemma DP_endx_ninV :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path x y vl al -> x <> y -> ~ In x vl.
Proof.
  intros x y vl el d Hneq. inversion d; subst; simpl; auto.
  intro J.
  destruct J as [J | J]; subst; auto.
Qed.

Lemma DP_backstep :
 forall (x y z : Vertex) (vl : V_list) (al : A_list),
 D_path x z (y :: vl) al -> exists al' : A_list, D_path y z vl al'.
Proof.
        intros; inversion H.
        split with al0; trivial.
Qed.

Lemma DP_prefix_no_head:  forall (y z : Vertex) (vl : V_list) (al : A_list)
 (H: D_path y z vl al),
 vl = V_nil \/ (exists vl', vl = vl' ++ z::nil /\ ~ In z vl').
Proof.
  intros.
  induction H; auto.
    right.
    destruct IHD_path as [J | [vl' [J1 J2]]]; subst.
      inversion H; subst.
      exists nil. split; auto.

      exists (y::vl').
      split; auto.
        simpl.
        intro J.
        destruct J as [J | J]; subst; auto.
          apply H3. apply in_or_app; simpl; auto.
Qed.

End DIRECTED_PATHES.

Implicit Arguments D_walk [A].
Implicit Arguments DW_backstep [A].
Implicit Arguments D_path [A].
Implicit Arguments DP_backstep [A].
Implicit Arguments DP_endx_inv [A].
Implicit Arguments DP_inxyel_inxvl [A].

Require Export Paths.

Section DEXTRACTED.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Variable v : @V_set A.
Variable a : @A_set A.

Lemma DW_extract :
 forall (x y z : Vertex) (vl : V_list) (al : A_list),
 D_walk v a y z vl al ->
 In x (y :: vl) ->
 exists al' : A_list, D_walk v a x z (V_extract eq_a_dec x (y :: vl)) al'.
Proof.
        intros x y z vl; generalize y; elim vl; simpl in |- *; intros.
        split with al.
        replace x with y0; auto.
        case (V_in_dec eq_a_dec y0 nil); auto.

        tauto.

        elim (DW_backstep _ _ _ _ _ _ _ H0); intros.
        destruct H2 as [H2 Heq]; subst.
        case (V_in_dec eq_a_dec x (a0 :: l)). intros.
        apply (H a0 x0); auto.

        simpl in |- *. intros.
        split with (A_ends y0 a0 :: x0).
        replace x with y0.
          trivial.

          tauto.
Qed.

Lemma DW_cut :
 forall (y z: Vertex) (vl : V_list) (al : A_list),
 D_walk v a y z vl al -> vl <> V_nil ->
 forall x w,
 In x (y :: vl) ->
 In w (y :: vl) ->
 x <> y -> w <> y -> x <> w ->
    exists al1 : A_list, exists al2 : A_list, exists vl1 : V_list,
    exists vl2 : V_list,
      (D_walk v a y x vl1 al1 /\ D_walk v a x z vl2 al2 /\
       (al1 ++ al2 = al) /\ (vl1 ++ vl2 = vl) /\ ~ In w (y::vl1)) \/
      (D_walk v a y w vl1 al1 /\ D_walk v a w z vl2 al2 /\
       (al1 ++ al2 = al) /\ (vl1 ++ vl2 = vl) /\ ~ In x (y::vl1)).
Proof.
  induction 1; simpl in *; intros.
    congruence.

    destruct H3 as [H3 | H3]; try congruence; subst.
    destruct H4 as [H4 | H4]; try congruence; subst.
    destruct vl.
      inversion H; subst.
      destruct H3 as [H3 | H3]; try solve [inversion H3]; subst.
      destruct H4 as [H4 | H4]; try solve [inversion H4]; subst.
      congruence.

      destruct (V_eq_dec eq_a_dec y w); subst.
        exists (A_ends x w::nil). exists al. exists (w::nil). exists (v0::vl).
        right.
        split. constructor; auto. constructor; auto. apply DW_endx_inv in H; auto.
        split; auto.
        split; auto.
        split; auto.
          intro J.
          destruct J as [J | J]; subst.
            congruence.
            simpl in J.
            destruct J as [J | J]; subst; auto.

      destruct (V_eq_dec eq_a_dec y x0); subst.
        exists (A_ends x x0::nil). exists al. exists (x0::nil). exists (v0::vl).
        left.
        split. constructor; auto. constructor; auto. apply DW_endx_inv in H; auto.
        split; auto.
        split; auto.
        split; auto.
          intro J.
          destruct J as [J | J]; subst.
            congruence.
            simpl in J.
            destruct J as [J | J]; subst; auto.

          eapply IHD_walk in H3; eauto.
            clear IHD_walk.
            destruct H3 as [al1 [al2 [vl1 [vl2
              [[J1 [J2 [J3 [J4 J5]]]]|[J1 [J2 [J3 [J4 J5]]]]]]]]]; subst.
              exists (A_ends x y::al1). exists al2. exists (y::vl1). exists vl2.
              right. rewrite <- J4.
              split. constructor; auto.
              split; auto.
              split; auto.
              split; auto.
                intro J.
                destruct J as [J | J]; subst.
                  congruence.
                  apply J5. simpl in J. auto.

              exists (A_ends x y::al1). exists al2. exists (y::vl1). exists vl2.
              left. rewrite <- J4.
              split. constructor; auto.
              split; auto.
              split; auto.
              split; auto.
                intro J.
                destruct J as [J | J]; subst.
                  congruence.
                  apply J5. simpl in J. auto.
            intro J. inversion J.
Qed.

Lemma DW_split :
 forall (x y z : Vertex) (vl : V_list) (al : A_list),
 D_walk v a y z vl al ->
 In x (y :: vl) ->
    exists al1 : A_list, exists al2 : A_list, exists vl1 : V_list,
    exists vl2 : V_list,
      D_walk v a y x vl1 al1 /\ D_walk v a x z vl2 al2 /\
      (al1 ++ al2 = al) /\ (vl1 ++ vl2 = vl).
Proof.
  intros.
  induction H.
    assert (x0 = x) as EQ.
      simpl in H0.
      destruct H0 as [H0 | H0]; inversion H0; auto.
    clear H0. subst.
    exists A_nil. exists A_nil. exists V_nil. exists V_nil.
    repeat split; try solve [auto | constructor; auto].

    destruct (V_eq_dec eq_a_dec x x0); subst.
      exists A_nil. exists (A_ends x0 y :: al). exists V_nil. exists (y::vl).
      repeat split; try solve [auto | constructor; auto].

      assert (In x (y::vl)) as Hin.
        simpl in H0.
        destruct H0 as [H0 | H0]; auto; try congruence.
      clear H0.
      apply IHD_walk in Hin.
      destruct Hin as [al1 [al2 [vl1 [vl2 [J1 [J2 [J3 J4]]]]]]]; subst.
      exists (A_ends x0 y::al1). exists al2. exists (y::vl1). exists vl2.
      repeat split; try solve [auto | constructor; auto].
Qed.

Lemma DP_extract :
 forall (x y z : Vertex) (vl : V_list) (al : A_list),
 D_path v a y z vl al ->
 In x (y :: vl) ->
 exists al' : A_list,  D_path v a x z (V_extract eq_a_dec x (y :: vl)) al'.
Proof.
        intros x y z vl; generalize y; elim vl; simpl in |- *; intros.
        split with al.
        replace x with y0; auto.
        case (V_in_dec eq_a_dec y0 nil); auto.

        tauto.

        elim (DP_backstep _ _ _ _ _ _ _ H0); intros.
        case (V_in_dec eq_a_dec x (a0 :: l)). intros.
        apply (H a0 x0); auto.

        simpl in |- *. intros. split with al. replace x with y0.
        trivial.

        tauto.
Qed.

Remark DP_when_cycle :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_path v a x y vl al -> In x vl -> x = y.
Proof.
        intros x y vl al H; inversion H; intros.
        trivial.

        inversion H11.
        absurd (x = y0); auto.

        auto.
Qed.

Lemma DP_split :
 forall v a (x y z : Vertex) (vl : V_list) (al : A_list)
 (H: D_path v a y z vl al),
 In x (y :: vl) ->
    exists al1 : A_list, exists al2 : @A_list A, exists vl1 : V_list,
    exists vl2 : V_list,
      D_path v a y x vl1 al1 /\ D_path v a x z vl2 al2 /\
      (al1 ++ al2 = al) /\ (vl1 ++ vl2 = vl).
Proof.
  intros.
  induction H; intros.
    assert (x0 = x) as EQ.
      simpl in H0.
      destruct H0 as [H0 | H0]; inversion H0; auto.
    clear H0. subst.
    exists A_nil. exists A_nil. exists V_nil. exists V_nil.
    repeat split; try solve [auto | constructor; auto].

    destruct (V_eq_dec eq_a_dec x x0); subst.
      exists A_nil. exists (A_ends x0 y :: al). exists V_nil. exists (y::vl).
      repeat split; try solve [auto | constructor; auto].

      assert (In x (y::vl)) as Hin.
        simpl in H0.
        destruct H0 as [H0 | H0]; auto; try congruence.
      clear H0.
      apply IHD_path in Hin; auto.
      destruct Hin as [al1 [al2 [vl1 [vl2 [J1 [J2 [J3 J4]]]]]]]; subst.
      exists (A_ends x0 y::al1). exists al2. exists (y::vl1). exists vl2.
      repeat split; try solve [auto | constructor; auto].
      constructor; auto.
        intro J. apply H4. apply in_or_app. auto.

        intro J.
        assert (In x0 (vl1++vl2)) as Hin.
          apply in_or_app. auto.
        apply H5 in Hin. subst.
        assert (J2':=J2).
        apply DP_prefix_no_head in J2'.
        destruct J2' as [EQ | [vl' [EQ Hnotin]]]; subst.
          inversion J2; subst; auto.

          apply DP_prefix_no_head in H.
          destruct H as [EQ | [v2' [EQ Hnotin']]]; subst.
            assert (In z V_nil) as G.
              rewrite <- EQ.
              apply in_or_app. right. apply in_or_app; simpl; auto.
            inversion G.

            rewrite app_assoc in EQ.
            apply app_inj_tail in EQ.
            destruct EQ; subst.
            contradict Hnotin'.
            apply in_or_app; auto.

        intro J. apply H6. apply in_or_app. auto.
Qed.

Lemma DWalk_to_dpath' :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk v a x y vl al ->
 exists vl0 : V_list, exists al0 : A_list,
    D_path v a x y vl0 al0 /\
    (forall vx, In vx vl0 -> In vx vl).
Proof.
  intros x y vl al w; elim w; intros.
    split with V_nil; split with A_nil.
    split; auto.
     apply DP_null; trivial.

    elim H0; clear H0; intros vl' H0.
    elim H0; clear H0; intros al' H0.
    destruct H0 as [H0 Hinv].
    case (V_in_dec eq_a_dec x0 (y0 :: vl')); intros.
      elim (DP_extract _ _ _ _ _ H0 i); intros.
      split with (V_extract eq_a_dec x0 (y0 :: vl')); split with x1.
      split; auto.
        intros vx Hinvx.
        apply V_extract_spec'' in Hinvx.
        simpl in *.
        destruct Hinvx; auto.

      case (V_in_dec eq_a_dec y0 vl'); intros.
        split with (y0 :: V_nil); split with (A_ends x0 y0 :: A_nil).
        split; try solve [
           intros vx Hinvx; simpl in Hinvx; simpl; destruct Hinvx;
           try solve [auto | tauto]
        ].
        apply DP_step.
          replace z with y0.
            apply DP_null; apply (DP_endx_inv _ _ _ _ _ _ H0).

            apply (DP_when_cycle _ _ _ _ H0); auto.

          trivial.

          trivial.

          red in |- *; intros; elim n; subst; simpl in |- *; auto.

          tauto.

          simpl in |- *. tauto.

          tauto.

        split with (y0 :: vl'); split with (A_ends x0 y0 :: al').
        split; try solve [
           intros vx Hinvx; simpl in Hinvx; simpl; destruct Hinvx; auto
        ].
        apply DP_step.
          trivial.

          trivial.

          trivial.

          red in |- *; intros; elim n; subst; simpl in |- *; auto.

          trivial.

          intros; absurd (In x0 vl').
            red in |- *; intros; elim n; simpl in |- *; auto.

            trivial.

            red in |- *; intros.
            elim n; inversion w; apply (DP_inxyel_inxvl _ _ _ _ _ _ H0 x0 y0); auto.
Qed.

Lemma DWalk_to_dpath :
 forall (x y : Vertex) (vl : V_list) (al : A_list),
 D_walk v a x y vl al ->
 exists vl0 : V_list, exists al0 : A_list, D_path v a x y vl0 al0.
Proof.
  intros.
  apply DWalk_to_dpath' in H.
  destruct H as [? [? [? ?]]]; eauto.
Qed.

End DEXTRACTED.

Implicit Arguments D_trail [A].

Section DPATH_EQ.

Variable A:Type.

Lemma DWalk_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (al : A_list),
 D_walk v a x y vl al -> v = v' -> a = a' -> D_walk v' a' x y vl al.
Proof.
        intros; elim H; intros.
        apply DW_null.
        rewrite <- H0; trivial.

        apply DW_step.
        trivial.

        rewrite <- H0; trivial.

        rewrite <- H1; trivial.
Qed.

Lemma DTrail_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (al : A_list),
 D_trail v a x y vl al -> v = v' -> a = a' -> D_trail v' a' x y vl al.
Proof.
        intros; elim H; intros.
        apply DT_null.
        rewrite <- H0; trivial.

        intros; apply DT_step.
        trivial.

        rewrite <- H0; trivial.

        rewrite <- H1; trivial.

        trivial.
Qed.

Lemma DPath_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (al : A_list),
 D_path v a x y vl al -> v = v' -> a = a' -> D_path v' a' x y vl al.
Proof.
        intros; elim H; intros.
        apply DP_null.
        rewrite <- H0; trivial.

        intros; apply DP_step.
        trivial.

        rewrite <- H0; trivial.

        rewrite <- H1; trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

End DPATH_EQ.

Section APPEND_DWALKS.

Variable A:Type.
Variable v : @V_set A.
Variable a : @A_set A.

Lemma DWalk_append :
 forall (x y z : Vertex) (vl vl' : V_list) (al al' : A_list),
 D_walk v a x y vl al ->
 D_walk v a y z vl' al' -> D_walk v a x z (vl ++ vl') (al ++ al').
Proof.
        intros x y z vl vl' al al' Hw; elim Hw; simpl in |- *; intros.
        trivial.

        apply DW_step; auto.
Qed.

End APPEND_DWALKS.

Lemma D_walk_iff: forall A v1 a1 x y vl al v2 a2
  (H1: forall x, v2 x <-> v1 x)
  (H2: forall x, a2 x <-> a1 x),
  @D_walk A v1 a1 x y vl al <->
  D_walk v2 a2 x y vl al.
Proof.
  intros.
  split; intro J.
    induction J; constructor; auto.
      apply H1; auto.
      apply H1; auto.
      apply H2; auto.
    induction J; constructor; auto.
      apply H1; auto.
      apply H1; auto.
      apply H2; auto.
Qed.

Lemma D_walk_sub: forall A x y vl al (v1 v2:@V_set A) (a1 a2:@A_set A)
  (H1: forall x, v2 x -> v1 x)
  (H2: forall x, a2 x -> a1 x)
  (J: @D_walk A v2 a2 x y vl al),
  D_walk v1 a1 x y vl al.
Proof.
  intros.
  induction J; constructor; auto.
Qed.

Require Import Metatheory.
Require Import util.
Require Import vellvm_tactics.

Lemma DW_last_split: forall (A:Type)
  v a vl v1 v2 (al : @A_list A)
  (Hw : D_walk v a v2 v1 (vl ++ v1::nil) al),
  exists v1', exists al',
    D_walk v a v2 v1' vl al' /\
    D_walk v a v1' v1 (v1::nil) (A_ends v1' v1::nil) /\
    al = al' ++ (A_ends v1' v1::nil).
Proof.
  induction vl; intros.
  (*base*)
    assert (v v1) as J.
      apply DW_endy_inv in Hw; auto.
    inversion Hw; subst. inversion H1; subst.
    exists v2. exists nil.
    split.
      constructor; auto.
    split; auto.
  (*ind*)
    inversion Hw; subst.
    apply IHvl in H1; auto.
    destruct H1 as [v1' [al2 [Hw1 [Hw2 EQ]]]]; subst.
    exists v1'. exists (A_ends v2 a0::al2).
    split; auto.
      constructor; auto.
Qed.

Lemma DW_head_inversion :
 forall A v a (z: Vertex) (vl : @V_list A) (x: Vertex) (al : @A_list A)
 (Hw: D_walk v a x z vl al) (Hnnil: vl <> nil),
 exists y, exists vl', exists al',
   D_walk v a x y vl' al' /\
   vl = vl' ++ (z::nil) /\
   al = al' ++ (A_ends y z::nil) /\
   a (A_ends y z) /\ v y.
Proof.
  intros.
  apply nnil_inv in Hnnil.
  destruct Hnnil as [vl' [v' EQ]]; subst.
  generalize dependent x.
  generalize dependent al.
  induction vl'; intros.
  (*base*)
    assert (v z) as J.
      apply DW_endy_inv in Hw; auto.
    inversion Hw; subst. inversion H1; subst.
    exists x. exists nil. exists nil.
    split.
      constructor; auto.
    split; auto.
  (*ind*)
    inversion Hw; subst.
    apply IHvl' in H1; auto.
    destruct H1 as [v1' [vl2 [al2 [Hw1 [Hw2 [EQ1 [EQ2 J]]]]]]]; subst.
    exists v1'. exists (a0::vl2). exists (A_ends x a0::al2).
    split. constructor; auto.
    split. simpl_env. rewrite Hw2. auto.
    split; auto.
Qed.

Lemma DW_Forall_head: forall A v (a:@A_set A) v1 v2 vl al P
  (Hw: D_walk v a v1 v2 vl al)
  (Hforall: Forall P (v1 :: vl)), P v2.
Proof.
  intros.
  apply Forall_forall with (x:=v2) in Hforall; auto.
  assert (Hw':=Hw).
  inversion Hw; subst.
    simpl; auto.

    apply DW_iny_vl in Hw'.
      simpl in *. tauto.

      intro J. inversion J.
Qed.

Lemma DW_split' :
 forall A v a (x z : Vertex) vl1 vl2 (vl : @V_list A) (al : @A_list A)
 (y: Vertex),
 D_walk v a y z vl al ->
 vl = vl2 ++ x :: vl1 ->
    exists al1 : A_list, exists al2 : A_list,
      D_walk v a x z vl1 al1 /\ D_walk v a y x (vl2 ++ [x]) al2 /\
      (al2 ++ al1 = al).
Proof.
  induction vl2; intros; subst.
  Case "base".
    inversion H; subst.
    exists al0. exists [A_ends y x].
    split; auto.
    split; auto.
      constructor; auto.
      constructor; auto.
        apply DW_endx_inv in H2; auto.
  Case "ind".
    simpl_env in H.
    inversion H; subst.
    apply IHvl2 in H2; auto.
    destruct H2 as [al1 [al2 [Hw1 [Hw2 EQ]]]]; subst.
    exists al1. exists (A_ends y a0::al2).
    split; auto.
    split; auto.
      simpl_env. simpl. constructor; auto.
Qed.

Lemma DW_split'' :
 forall A v a (x z : Vertex) (vl : @V_list A) (al : @A_list A)
 (y: Vertex) (Hw: D_walk v a y z vl al) (Hin: In x vl),
 exists vl2, exists vl1, exists al1 : A_list, exists al2 : A_list,
   vl = vl2 ++ x :: vl1 /\
   D_walk v a x z vl1 al1 /\ D_walk v a y x (vl2 ++ [x]) al2 /\
   (al2 ++ al1 = al).
Proof.
  intros.
  apply in_split in Hin.
  destruct Hin as [vl2 [vl1 EQ]].
  exists vl2. exists vl1.
  eapply DW_split' in Hw; eauto.
  destruct Hw as [al1 [al2 [Hw1 [Hw2 EQ']]]].
  exists al1. exists al2. auto.
Qed.

Lemma DW_chunk :
 forall A v a (x z : Vertex) vl1 vl3 vl2 (vl : @V_list A) (al : @A_list A)
 (y: Vertex) (Hw: D_walk v a y z vl al)
 (EQ: y :: vl = vl2 ++ x :: vl3 ++ x :: vl1),
 exists al3 : A_list, D_walk v a x x (vl3 ++ [x]) al3.
Proof.
  intros.
  destruct vl2; inversion EQ; subst.
  Case "base".
    eapply DW_split' in Hw; eauto.
    destruct Hw as [al1 [al2 [Hw1 [Hw2 EQ']]]]; subst. eauto.
  Case "ind".
    eapply DW_split' in Hw; eauto.
    destruct Hw as [al1 [al2 [Hw1 [Hw2 EQ']]]]; subst.
    eapply DW_split' in Hw1; eauto.
    destruct Hw1 as [al11 [al12 [Hw11 [Hw12 EQ']]]]; subst. eauto.
Qed.

Lemma D_walk_weakening: forall A x y vl al (v1 v2:@V_set A) (a1 a2:@A_set A)
  (H1: forall z, In z (x::vl) -> v1 z)
  (H2: forall z, In z al -> a1 z)
  (J: @D_walk A v2 a2 x y vl al),
  D_walk v1 a1 x y vl al.
Proof.
  intros.
  induction J; constructor.
    apply H1; simpl; auto.
    apply IHJ.
      intros. apply H1. simpl; auto.
      intros. apply H2. simpl; auto.
    apply H1; simpl; auto.
    apply H2; simpl; auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 P C1 C2 : Universe, ((wd_ P C1 /\ (wd_ B1 B2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 A2 P /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ A1 C1 C2 /\ col_ A2 C1 C2)))))))))) -> col_ C1 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.
Require Import present.
Require Import task001to214.
Require Import task215to234.
Require Import task235to282.
Require Import task283to302.
Require Import task303to322.
Require Import task323to485.
Require Import task486to506.
Require Import task507to541.
Require Import task542to588.
Require Import task589to633.

Lemma the_reducibility : reducibility.
Proof.
rewrite /reducibility; apply cat_reducible_range with 322.
  CatReducible red000to214 red214to234 red234to282 red282to302 red302to322.
CatReducible red322to485 red485to506 red506to541 red541to588 red588to633.
(* CatReducible red000to214 red214to234 red234to282 red282to302 red302to322
             red322to485 red485to506 red506to541 red541to588 red588to633.
             *)
Qed.