Require Import
  CoRN.metric2.Metric
  CoRN.model.structures.Qpossec
  Coq.QArith.QArith_base
  CoRN.model.structures.QposInf
  CoRN.metric2.UniformContinuity

  CMorphisms

  FormTopC.FormTop
  Algebra.OrderC
  Algebra.PreOrder
  Algebra.SetsC
  FormTopC.FormalSpace
  Numbers.QFacts
  Numbers.QPosFacts
  FormTopC.Cont

  Coq.QArith.Qminmax.

Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope FT.

Section Metric.
Universes A P I.

Context {MS : MetricSpace}.

Definition M@{} : Type@{A} := msp_is_setoid MS.

Definition Ball : Type@{A} := (M * Qpos)%type.

Definition lt_ball@{} (Bx By : Ball) : Type@{P} :=
  let (x, delta) := Bx in let (y, eps) := By in
  { d : Qpos | ball d x y /\ (d + delta < eps)%Qpos }.

Definition le_ball@{} (Bx By : Ball) : Type@{P} :=
  let (y, eps) := By in
  forall e : Qpos, lt_ball Bx (y, e + eps)%Qpos.

Lemma lt_ball_center : forall x (eps eps' : Qpos),
  eps < eps' -> lt_ball (x, eps) (x, eps').
Proof.
intros. unfold lt_ball.
destruct (Qpos_lt_plus H).
destruct (Qpos_smaller x0) as [x0' x0'small].
exists x0'. split. apply ball_refl.
rewrite Qplus_comm. rewrite q.
apply Qplus_lt_r. assumption.
Qed.

Instance PreO : PreO.t@{A P} le_ball.
Proof.
constructor.
- intros []. unfold le_ball. intros.
  apply lt_ball_center. apply Qpos_plus_lt_l.
- intros [] [] [] H H0. unfold le_ball in *.
  intros e.
  specialize (H (Qpos_one_half * e)%Qpos).
  specialize (H0 (Qpos_one_half * e)%Qpos).
  destruct H as (d & balld & dlt).
  destruct H0 as (d' & balld' & d'lt).
  exists (d + d')%Qpos. split. eapply ball_triangle; eassumption.
  simpl. rewrite (Qplus_comm d d'), <- Qplus_assoc.
  eapply Qlt_le_trans.
  apply Qplus_lt_r. apply dlt. simpl.
  rewrite (Qplus_comm _ q0), Qplus_assoc.
  eapply Qle_trans. apply Qplus_le_l.
  apply Qlt_le_weak. eassumption. simpl.
  apply Qeq_le.
  rewrite Qplus_comm, Qplus_assoc.
  rewrite (one_half_sum e). reflexivity.
Qed.

Existing Instance PreO.PreOrder_I.

Local Instance PreOrder_le_ball : Transitive le_ball :=
  PreOrder_Transitive.

Lemma lt_le_weak : forall a b,
  lt_ball a b -> le_ball a b.
Proof.
unfold lt_ball, le_ball.
intros [] [] (d & b & l).
intros e.
exists d. split. assumption.
eapply Qlt_le_trans. eassumption.
apply Qlt_le_weak. apply Qpos_plus_lt_l.
Qed.

Lemma lt_le_trans : forall a b c,
   lt_ball a b -> le_ball b c -> lt_ball a c.
Proof.
intros [] [] [] H H0.
unfold lt_ball, le_ball in *.
destruct H as (d & dmm0 & dqq0).
destruct (Qpos_lt_plus dqq0) as [e eprf].
specialize (H0 e%Qpos).
destruct H0 as (d' & balld' & dd').
exists (d + d')%Qpos. split.
eapply ball_triangle; eassumption.
rewrite eprf in dd'.
apply (Qplus_lt_r _ _ e).
eapply Qlt_compat. 3: apply dd'.
simpl. ring.
reflexivity.
Qed.

Lemma le_lt_trans a b c :
  le_ball a b -> lt_ball b c -> lt_ball a c.
Proof.
intros H H0. destruct a, b, c.
unfold lt_ball, le_ball in *.
destruct H0 as (d & dmm0 & dqq0).
destruct (Qpos_lt_plus dqq0) as [e eprf].
specialize (H e).
destruct H as (d' & balld' & dd').
exists (d' + d)%Qpos. split.
eapply ball_triangle; eassumption.
rewrite eprf in dqq0. rewrite eprf.
clear eprf q1.
rewrite <- Qplus_assoc. rewrite (Qplus_comm q0 e).
simpl. rewrite <- (Qplus_assoc d' d q).
rewrite Qplus_comm. rewrite <- (Qplus_assoc d q d').
apply Qplus_lt_r. rewrite Qplus_comm. assumption.
Qed.

Lemma le_ball_applies {a c} :
  le_ball a c
  -> forall x, ball (snd a) (fst a) x
  -> ball (snd c) (fst c) x.
Proof.
unfold le_ball. intros H x H0. destruct a, c.
simpl in *. apply ball_closed.
intros.
specialize (H d). destruct H as (d' & balld' & qd').
apply ball_weak_le with (d' + q)%Qpos.
apply Qlt_le_weak.
simpl. rewrite (Qplus_comm q0 d). assumption.
eapply ball_triangle. eapply ball_sym. eassumption.
assumption.
Qed.

Lemma le_ball_center : forall x (eps eps' : Qpos),
  (eps <= eps')%Q -> le_ball (x, eps) (x, eps').
Proof.
intros. simpl. intros.
destruct (Qpos_smaller e) as [e' e'prf].
exists e'. split. apply ball_refl.
apply Qplus_lt_le_compat; assumption.
Qed.

Lemma lt_ball_shrink Bx y eps :
  lt_ball Bx (y, eps)
  -> {eps' : Qpos & ((eps' < eps) * lt_ball Bx (y, eps'))%type }.
Proof.
intros H. destruct Bx. destruct H. destruct a.
destruct (@Qpos_between (x + q)%Qpos eps H0).
destruct a.
exists x0. split. assumption. simpl.
exists x.  split. assumption. assumption.
Qed.

Lemma lt_ball_grow x delta By :
  lt_ball (x, delta) By
  -> { delta' : Qpos & ((delta < delta') * lt_ball (x, delta') By)%type }.
Proof.
intros H. destruct By. destruct H as (d & balld & dlt).
destruct (Qpos_lt_plus dlt).
exists (delta + Qpos_one_half * x0)%Qpos. split.
- setoid_rewrite Qpos_plus_comm. apply Qpos_plus_lt_l.
- simpl. exists d. split.  assumption.
  rewrite q0. rewrite Qplus_assoc. apply Qplus_lt_r.
  apply Qpos_one_half_lt.
Qed.

Lemma lt_ball_radius x y (ex ey : Qpos)
  : lt_ball (x, ex) (y, ey) -> ex < ey.
Proof.
simpl. intros. destruct H as (d & bd & exey).
eapply Qadd_lt. eassumption.
Qed.

Lemma le_ball_radius {Bx By} :
  le_ball Bx By -> (snd Bx <= snd By)%Q.
Proof.
destruct Bx, By. simpl. intros H.
apply Qlt_all_Qle.
intros. destruct (H eps). destruct a.
rewrite Qplus_comm. eapply Qadd_lt.
eassumption.
Qed.

Definition IxUL@{} (x : Ball) : Set :=
  option Qpos.

Definition CUL (b : Ball) (i : IxUL b) : Subset@{A P} Ball :=
  match i with
  | None         => fun b' => lt_ball b' b
  | Some epsilon => fun b' => snd b' = epsilon
  end.

Definition MetricPO : PreOrder@{A P} :=
  {| PO_car := Ball
   ; PreOrder.le := le_ball
  |}.

Definition MetricPS@{} : PreISpace.t@{A P I} :=
  {| PreISpace.S := MetricPO
   ; PreISpace.C := CUL
  |}.

Lemma shrink_ball (b : Ball) :
  { b' : Ball & lt_ball b' b }.
Proof.
destruct b as [m q].
destruct (Qpos_smaller q) as [q' qq'].
exists (m, q'). apply lt_ball_center. assumption.
Qed.

Lemma MPos_MUniv : FormTop.gtPos MetricPS.
Proof.
apply gall_Pos. simpl. intros. destruct i.
- simpl. exists (fst a, QposMinMax.Qpos_min q (snd a)).
  split. le_down. destruct a. simpl fst.
  apply le_ball_center. apply QposMinMax.Qpos_min_lb_r.
  exists (fst a, q). reflexivity.
  apply le_ball_center. apply QposMinMax.Qpos_min_lb_l.
- destruct (shrink_ball a). exists x. split.
  le_down. apply lt_le_weak; eassumption.
  exists x. simpl. eapply lt_le_trans; eassumption.
  reflexivity.
Qed.

Set Printing Universes.

Local Instance MPos@{API'} : FormTop.gtPos MetricPS
  := MPos_MUniv@{API' API' P P P P P API' P P P P P}.

Definition Metric@{API'} : IGt@{A P I API'} :=
  {| IGS := MetricPS
  |}.

End Metric.

Arguments Ball MS : clear implicits.

Section Map.

(** In an open ball *)
Inductive o_ball {X : MetricSpace} {eps : Qpos} {a b : X} : Set :=
  In_o_ball : forall e : Qpos, e < eps -> ball e a b -> o_ball.

Arguments o_ball {X} eps a b.

Lemma o_ball_ball {X : MetricSpace} eps (a b : X)
  : o_ball eps a b -> ball eps a b.
Proof.
intros H. induction H.
eapply ball_weak_le. apply Qlt_le_weak. eassumption.
assumption.
Qed.

Lemma o_ball_shrink {X : MetricSpace} {eps : Qpos} {a b : X}
  : o_ball eps a b -> { eps' : Qpos & ((eps' < eps) * o_ball eps' a b)%type }.
Proof.
intros. destruct H.
destruct (Qpos_between q) as (mid & midl & midh).
exists mid. split. assumption. eapply In_o_ball; eassumption.
Qed.

Lemma le_ball_applies_o {X : MetricSpace} {a c : Ball X} :
  le_ball a c
  -> forall x : X, o_ball (snd a) (fst a) x
  -> o_ball (snd c) (fst c) x.
Proof.
intros H x H0.
destruct a, c. simpl in *. induction H0.
destruct (Qpos_lt_plus q1) as (diff & diffeq).
destruct (H diff) as (d & balld & dlt).
econstructor.
Focus 2. eapply ball_triangle. apply ball_sym.
eassumption. eassumption.
rewrite diffeq in dlt.
apply Qplus_lt_r with diff.
eapply Qlt_compat. 3: apply dlt.
simpl. ring. reflexivity.
Qed.

Lemma true_union S T (F : S -> Subset T) (t : T) :
  { x : S & F x t} ->
  union (fun _ => True) F t.
Proof.
intros H. destruct H. econstructor; unfold In; eauto.
Qed.

Local Open Scope Subset.

Lemma true_union' S T (F : S -> Subset T) :
  (fun t => { x : S & F x t}) ⊆
  union (fun _ => True) F.
Proof.
unfold Included, In, pointwise_rel, arrow.
apply true_union.
Qed.

Lemma o_ball_refl : forall {X : MetricSpace} (x : X) eps,
  o_ball eps x x.
Proof.
intros. destruct (Qpos_smaller eps).
econstructor. eassumption. apply ball_refl.
Qed.

Lemma o_ball_sym : forall {X : MetricSpace} (x y : X) eps,
  o_ball eps x y -> o_ball eps y x.
Proof.
intros. induction H. econstructor; eauto.
apply ball_sym; assumption.
Qed.

Lemma Qle_inv (k x y : Qpos)
  : (y <= / k * x)%Q -> (y * k <= x)%Q.
Proof.
intros H. apply <- Q.Qle_shift_div_l.
etransitivity. eassumption.
rewrite Qmult_comm. unfold Qdiv. reflexivity.
apply Qpos_prf.
Qed.

Lemma uniformly_smaller (l l' h h' : Q)
  (H : l < h) (H' : l' < h')
  : { eps : Qpos | (l + eps < h) /\ (l' + eps < h') }.
Proof.
  destruct (Qpos_lt_plus H) as [eps1 P1].
  destruct (Qpos_lt_plus H') as [eps2 P2].
  destruct (Qpos_smaller (QposMinMax.Qpos_min eps1 eps2)) as [eps P].
  exists eps. split.
  - rewrite P1. apply Qplus_lt_r.
    eapply Qlt_le_trans. eassumption.
    apply QposMinMax.Qpos_min_lb_l.
  - rewrite P2. apply Qplus_lt_r.
    eapply Qlt_le_trans. eassumption.
    apply QposMinMax.Qpos_min_lb_r.
Qed.

Section Lipschitz.

Context {X Y : MetricSpace}.

(** Yoneda embeddding of a point in its completion *)

Definition Yoneda (x : X) : Subset (Ball X) :=
  fun B => let (y, eps) := B in o_ball eps x y.

Existing Instance PreO.

Variable f : X -> Y.
Variable k : Qpos.
Definition Lipschitz : Prop := forall x x' eps, ball eps x x' -> ball (k * eps) (f x) (f x').

Hypothesis f_lip : Lipschitz.

Lemma lt_monotone : forall x x' eps eps',
  lt_ball (x, eps) (x', eps') ->
  lt_ball (f x, k * eps)%Qpos (f x', k * eps')%Qpos.
Proof.
simpl. intros.
destruct H as (d & bd & dlt).
exists (k * d)%Qpos. split. apply f_lip. assumption.
simpl. rewrite <- Qmult_plus_distr_r.
apply Qmult_lt_compat_l. apply Qpos_prf.
assumption.
Qed.

Lemma le_monotone x x' eps eps' :
  le_ball (x, eps) (x', eps')
  -> le_ball (f x, k * eps)%Qpos (f x', k * eps')%Qpos.
Proof.
intros H. unfold le_ball. intros.
apply lt_le_trans with (f x', k * (Qpos_inv k * e + eps'))%Qpos.
apply lt_monotone. apply H. apply le_ball_center.
apply Qeq_le.
simpl. rewrite Qmult_plus_distr_r.
rewrite (Qpos_inv_scale_1 k e). reflexivity.
Qed.

Definition lift : Cont.map (toPSL (IGS (@Metric X)))
   (toPSL (IGS (@Metric Y))) := fun By Bx =>
  let (x, delta) := Bx in lt_ball (f x, k * delta)%Qpos By.

Lemma lift_f_ap_lt : forall x (eps eps' : Qpos),
  eps < eps' -> lift (f x, k * eps')%Qpos (x, eps).
Proof.
intros.
simpl. destruct (Qpos_lt_plus H).
exists (k * (Qpos_one_half * x0))%Qpos. split. apply ball_refl. rewrite q.
rewrite Qplus_comm. simpl.
rewrite <- Qmult_plus_distr_r.
apply Qmult_lt_compat_l. apply Qpos_prf.
apply Qplus_lt_r.
apply Qpos_one_half_lt.
Qed.

Lemma lift_f_ap_lt' x (eps eps' : Qpos) :
  k * eps < eps' -> lift (f x, eps') (x, eps).
Proof.
intros H.
pose proof (lift_f_ap_lt x eps (Qpos_inv k * eps')%Qpos) as H0.
simpl in H0.
assert (eps < / k * eps').
apply Qmult_lt_compat_l_inv with k. apply Qpos_prf.
rewrite Qmult_assoc. rewrite Qmult_inv_r.
rewrite Qmult_1_l. assumption.
unfold not. intros.
eapply Qlt_not_eq. apply (Qpos_prf k).
symmetry; assumption.
specialize (H0 H1). clear H1.
destruct H0 as (d & balld & dlt).
exists d. split. assumption.
rewrite Qmult_assoc in dlt.
rewrite Qmult_inv_r in dlt.
rewrite Qmult_1_l in dlt. simpl. assumption.
unfold not. intros. eapply Qlt_not_eq.
apply (Qpos_prf k). symmetry; assumption.
Qed.

Lemma lift_f_le {a b u} : lift b a
  -> le_ball u a
  -> lift b u.
Proof.
intros. destruct a, b, u.
unfold lift in *. eapply le_lt_trans. apply le_monotone.
eassumption. assumption.
Qed.

Lemma lift_total (Bx : Ball X)
 : {By : Ball Y & lift By Bx }.
Proof.
destruct Bx as [m q].
exists (f m, q + k * q)%Qpos. simpl.
destruct (Qpos_smaller q).
exists x. split. apply ball_refl.
apply Qplus_lt_l. assumption.
Qed.

Arguments M : clear implicits.

Lemma lift_ball_le_helper
   (m : M X) (q : Qpos) (m0 : M Y) (q0 x : Qpos)
   (l : lt_ball (f m, (k * q)%Qpos) (m0, x))
   (x1 : Qpos)
   (q4 : (x + x1 <= q0)%Q)
   (m2 : M X) (q7 : Qpos)
   (l1 : (m2, q7) <=[PreISpace.S MetricPS] (m, q))
  : (f m2, x1) <=[PreSpace.S (toPSL (IGS Metric))]
      (m0, q0).
  Proof.
  simpl. intros. destruct l as (d & balld & dlt).
  exists (e + k * q + d)%Qpos. split. Focus 2.
  apply (Qlt_le_trans _ (e + (x + x1))). Focus 2.
  apply Qplus_le_r. assumption.
  simpl. rewrite <- !Qplus_assoc.
  apply Qplus_lt_r. rewrite Qplus_assoc.
  eapply Qplus_lt_le_compat. rewrite Qplus_comm. assumption.
  reflexivity.
  destruct (l1 (Qpos_inv k * e))%Qpos as [x4 a]. destruct a as [H H0].
  eapply ball_triangle. 2:eassumption.
  eapply ball_weak_le. 2: eapply f_lip. 2: eassumption.
  etransitivity. Focus 2. apply Qlt_le_weak.
  simpl. rewrite <- (Qpos_inv_scale_1 k e).
  rewrite <- Qmult_plus_distr_r.
  eapply Qmult_lt_compat_l. apply Qpos_prf.
  eassumption. simpl.
  rewrite Qmult_plus_distr_r.
  rewrite <- (Qplus_0_r (k * x4)) at 1.
  apply Qplus_le_r. apply Qlt_le_weak.
  apply (Qpos_prf (k * q7)%Qpos).
  Qed.

Ltac lt_ball_shrink H a b :=
  let H' := fresh in
  destruct (lt_ball_shrink _ _ _ H) as (a & b & H'); clear H; rename H' into H.

Theorem Cont : IGCont.t (toPSL (IGS Metric)) (IGS Metric) lift.
Proof.
constructor; simpl PO_car in *.
- intros a. apply FormTop.refl. apply true_union'.
  apply lift_total.
- intros a b c l l0. unfold lift in l, l0. destruct a.
  destruct b, c.
  lt_ball_shrink l x q2.
  lt_ball_shrink l0 x0 q3.
  destruct (uniformly_smaller _ _ _ _ q2 q3) as (eps & xeps & x0eps).
  destruct (Qpos_smaller eps) as [eps' Heps'].

  apply (fun U => FormTop.gle_infinity (A := MetricPS) (m, q)
  U (m, q) (Some (Qpos_inv k * eps'))%Qpos (PreO.le_refl (m, q))).
  intros u X0. destruct X0 as (l1 & P2). le_downH l1. destruct P2.
  simpl in i. unfold In in i. destruct a as [m4 x4]. simpl snd in *.
  subst. destruct u as [m2 ?].
  apply FormTop.glrefl.
  exists (f m2, eps).
  + split; le_down.
    * eapply lift_ball_le_helper; try eassumption.
      apply Qlt_le_weak. eassumption.
    * eapply lift_ball_le_helper; try eassumption.
      apply Qlt_le_weak. eassumption.
  + clear - l2 Heps'.
    pose proof (le_ball_radius l2) as H. simpl in H.
    apply lift_f_ap_lt'. eapply Qle_lt_trans.
    2: eassumption.
    rewrite Qmult_comm. apply Qle_inv. assumption.
- simpl. intros. eapply lift_f_le; eassumption.
- intros [] b c H H0. unfold lift. unfold lift in H.
    eapply lt_le_trans; eassumption.
- intros a b c ix l H.
  destruct ix; simpl in *.
  + simpl. clear c l. destruct (Qpos_smaller (Qpos_inv k * q)%Qpos).
    apply (FormTop.gle_infinity (A := MetricPS) a _ a (Some x)).
    reflexivity.
    intros. destruct X0 as (l & d0). le_downH l.
    destruct d0 as [a0 i l0].
    pose proof (lift_f_le H l) as H0. clear H l.
    destruct (Qpos_between q0) as (x0 & K). destruct K as (H1 & H2).
    unfold lift in H0.
    destruct u as [m q1].
    pose proof (lt_ball_grow _ _ _ H0) as H3.
    destruct H3 as (del' & q1del & lt_del').

    apply FormTop.glrefl.
    exists (f m, QposMinMax.Qpos_min (k * x0)%Qpos del'). unfold In.
    split. le_down.
    eapply lt_le_weak. eapply le_lt_trans. 2: eassumption.
    apply le_ball_center. apply QposMinMax.Qpos_min_lb_r.
    exists (f m, q). reflexivity.
    apply le_ball_center. etransitivity.
    apply QposMinMax.Qpos_min_lb_l. apply Qlt_le_weak.
    apply Qpos_inv_lt. assumption.

    apply lift_f_ap_lt'.
    induction (QposMinMax.Qpos_min (k * x0) del') using
       (QposMinMax.Qpos_min_case (k * x0) del'). 2: eassumption.
    apply le_ball_radius in l0. simpl in l0.

    apply Qmult_lt_compat_l_inv with (Qpos_inv k).
    apply Qpos_prf.

    unfold In in i. simpl in i. subst.
    setoid_rewrite Qpos_inv_scale_2.
    eapply Qle_lt_trans; eassumption.
  + unfold lift in H. destruct a as [m q].
    destruct (lt_ball_grow _ _ _ H) as [x [q0 l0]].
    clear H.
    apply FormTop.glrefl.
    econstructor. unfold In.
    split. le_down. apply lt_le_weak. eassumption.
    exists (f m, x). eapply lt_le_trans; eassumption.
    reflexivity.
    apply lift_f_ap_lt'. assumption.
Qed.

End Lipschitz.

(** Try to do it with maps that are only uniformly continuous,
    rather than just Lipschitz.
    I can't figure out how to do this proof. *)
Context {X Y : MetricSpace}.
Delimit Scope uc_scope with uc.
Variable f : (X --> Y)%uc.

Definition mu' (eps : Qpos) : Qpos :=
  Qpossmaller (mu f eps).

Definition mu'_cont (eps : Qpos) a b :
  ball (mu' eps) a b -> ball eps (f a) (f b).
Proof.
intros.
apply uc_prf. eapply ball_ex_weak_le.
apply Qpossmaller_prf. simpl. assumption.
Qed.

Existing Instances PreO PreO.PreOrder_I.

Definition lift_uc : Cont.map (toPSL (IGS (@Metric X)))
  (toPSL (IGS (@Metric Y))) :=
  fun By Bx => let (x, delta) := Bx in
   { eps' : Qpos &
     ((delta < mu' eps') * lt_ball (f x, eps') By)%type }.

Lemma lift_shrink {x y delta eps} :
  lift_uc (y, eps) (x, delta) ->
  { eps' : Qpos & ((eps' < eps) * lift_uc (y, eps') (x, delta))%type }.
Proof.
intros H.
destruct H as (eps' & mueps' & ltballeps').
pose proof (lt_ball_shrink _ _ _ ltballeps') as H.
destruct H as (eps'0 & eps'small & lt_ball_shrunk).
exists eps'0. split. assumption. unfold lift.
exists eps'. split. assumption. assumption.
Qed.

Theorem Cont_uc : Cont.t (toPSL (IGS (@Metric X)))
  (toPSL (IGS (@Metric Y))) lift_uc.
Proof.
Abort.

End Map.


Require Import QvecArith PerceptronDef TerminationRefinement.

Lemma inner_perceptron_correct_class: forall {n: nat} (w : Qvec (S n)) (f : Qvec n) (l : bool) (T : (list ((Qvec n)*bool))),
 inner_perceptron ((f, l):: T) w = None -> correct_class (Qvec_dot w (consb f)) l = true.
Proof.
  intros n w f l T H. inversion H.
  destruct (correct_class (Qvec_dot w (consb f)) l) eqn:H2.
    reflexivity.
    destruct (inner_perceptron T (Qvec_plus w (Qvec_mult_class l (consb f)))); inversion H1. Qed.

Lemma inner_perceptron_correct_cons : forall {n: nat} (w : Qvec (S n)) (f : Qvec n) (l : bool) (T : (list ((Qvec n)*bool))),
 inner_perceptron ((f, l) :: T) w = None -> inner_perceptron T w = None.
Proof.
  intros n w f l T H. assert (H1 := H). apply inner_perceptron_correct_class in H1.
  inversion H. rewrite H1 in H2. rewrite H1. reflexivity. Qed.

Theorem inner_perceptron_correct_classified : forall {n : nat} (T : (list ((Qvec n)*bool))) (w : Qvec (S n)),
  inner_perceptron T w = None -> correctly_classifiedP T w.
Proof.
  intros n T w H. induction T.
  { constructor. } (* base case T = nil *)
  destruct a. constructor.
  apply IHT. apply inner_perceptron_correct_cons in H. apply H.
  apply inner_perceptron_correct_class in H. apply H. Qed.

Theorem inn_perceptron_MCE_correct_classified : forall {n : nat} (T : (list ((Qvec n)*bool))) (w : Qvec (S n)),
  inner_perceptron_MCE T w = None -> correctly_classifiedP T w.
Proof.
  intros. apply inner_perceptron_correct_classified.
  apply inner_perceptron_MCE_inner_perceptron_None.
  apply H. Qed.

Theorem correct_classified_inner_perceptron : forall {n : nat} (T : (list ((Qvec n)*bool))) (w : Qvec (S n)),
  correctly_classifiedP T w -> inner_perceptron T w = None.
Proof.
  intros n T w H. induction H.
  { reflexivity. } (* base case CCnil *)
  unfold inner_perceptron.
  destruct (correct_class (Qvec_dot w (consb f)) l).
    fold (inner_perceptron T' w). apply IHcorrectly_classifiedP.
    inversion H0. Qed.

Theorem inner_perceptron_not_correct_classified : forall {n : nat} (T : (list ((Qvec n)*bool))) (w w0: Qvec (S n)),
 inner_perceptron T w0 = Some w -> ~(correctly_classifiedP T w0).
Proof.
  intros n T w w0 H. unfold not. intros H0. induction H0.
  { inversion H. } (* base case T = nil *)
  apply IHcorrectly_classifiedP. inversion H.
  destruct (correct_class (Qvec_dot w0 (consb f)) l).
    reflexivity.
    inversion H1. Qed.

Theorem not_correct_classified_inner_perceptron: forall {n : nat} (T : (list ((Qvec n)*bool))) (w w0: Qvec (S n)),
  ~(correctly_classifiedP T w0) -> exists w, inner_perceptron T w0 = Some w.
Proof.
  intros n T w w0 H. unfold not in H. induction T.
  { exfalso. apply H. constructor. }
  destruct a as [x l]. unfold inner_perceptron.
  destruct (correct_class (Qvec_dot w0 (consb x)) l) eqn:H2.
    fold (inner_perceptron T w0). apply IHT. intros H1. apply H. constructor. apply H1. apply H2.
    fold (inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb x)))).
    destruct (inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb x)))).
    exists q. reflexivity. exists (Qvec_plus w0 (Qvec_mult_class l (consb x))). reflexivity. Qed.

(***********************************************************************************************
   Soundness Proof (ie. If the Perceptron Converges to Some W then W is a linear separater of T)
   and its contrapositive. (ie If T is not linear separable then Perceptron will never
   converge on Some w (always returns None).
 ***********************************************************************************************)

Theorem perceptron_linearly_separable : forall {n : nat } (E: nat) (w0 w : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  perceptron E T w0 = Some w -> linearly_separable T.
Proof.
  intros n E. induction E; intros w0 w T H.
  { inversion H. } (* base case E = 0 *)
  unfold perceptron in H.
  destruct (inner_perceptron T w0) eqn: H1.
    fold (perceptron E T q) in H. apply IHE in H. apply H.
    apply inner_perceptron_correct_classified in H1. unfold linearly_separable.
      exists w0. apply H1. Qed.

(* alternative and stronger soudness proof *)
Theorem perceptron_sound : forall {n : nat} (E : nat) (w0 w : Qvec (S n)) (T : list ((Qvec n)*bool)),
  perceptron E T w0 = Some w -> correctly_classifiedP T w.
Proof.
  intros n E. induction E; intros w0 w T H.
  { inversion H. }
  unfold perceptron in H.
  destruct (inner_perceptron T w0) eqn: H1.
    fold (perceptron E T q) in H.
    apply (IHE _ _ _ H).
    apply inner_perceptron_correct_classified.
    inversion H; subst. apply H1. Qed.

Theorem not_linearly_seperable_perceptron : forall {n : nat} (E : nat) (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  ~(linearly_separable T) -> perceptron E T w0 = None.
Proof.
  intros n E. induction E; intros w0 T H.
  { reflexivity. } (* base case E = 0 *)
  unfold perceptron.
  destruct (inner_perceptron T w0) eqn: H1.
  fold (perceptron E T q). apply (IHE q) in H. apply H.
  unfold not in H. exfalso. apply H. apply inner_perceptron_correct_classified in H1.
  unfold linearly_separable. exists w0. apply H1. Qed.


Require Import MAP.
Require Import EQ.
Require Import ANY.

Module EqMapFacts (K : EQ) (V : ANY) (M : MAP with Definition key := K.t with Definition value := V.t).
  Lemma get_delete_Some :
    forall k k' v m,
      M.get k' (M.delete k m) = Some v ->
      M.get k' m = Some v.
  Proof.
    intros.
    destruct (K.t_eq_dec k k').
    - subst. rewrite M.get_delete_same in *. discriminate.
    - rewrite M.get_delete_diff in * by auto. auto.
  Qed.
End EqMapFacts.


Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Math.BasicPosetTheory.
Require Import DschingisKhan.Math.BasicGeneralTopology.

Module ScottTopology.

  Import MathProps MathClasses BasicPosetTheory BasicGeneralTopology DomainTheoryHelper.

  Section BUILD_SCOTT_TOPOLOGY.

  Context {D : Type} {requiresPoset : isPoset D}.

  Variant isOpen_Scott (O : ensemble D) : Prop :=
  | ScottTopologyOpen
    (UPWARD_CLOSED : forall x : D, forall y : D, << H_IN : member x O >> -> << H_LE : x =< y >> -> member y O)
    (LIMIT : forall X : ensemble D, << DIRECTED : isDirected X >> -> forall sup_X : D, << IS_SUPREMUM : isSupremumOf sup_X X >> -> << SUPREMUM_IN : member sup_X O >> -> exists x : D, member x X /\ member x O)
    : isOpen_Scott O
  .

  Local Hint Constructors isOpen_Scott : core.

  Local Instance theScottTopology
    : Topology_axiom isOpen_Scott.
  Proof with (now vm_compute; firstorder) || eauto with *.
    split.
    - econstructor; ii; desnw'; unnw...
    - ii. econstructor; ii; desnw'; unnw...
      apply in_unions_iff in SUPREMUM_IN.
      destruct SUPREMUM_IN as [X_i [sup_X_in_X_i X_i_in_Xs]].
      exploit (every_member_of_Xs_isOpen X_i X_i_in_Xs) as [? ?].
      pose proof (LIMIT X DIRECTED sup_X IS_SUPREMUM sup_X_in_X_i) as [x [x_in_X x_in_X_i]]...
    - ii. econstructor; ii; desnw'; unnw...
      apply in_intersection_iff in SUPREMUM_IN.
      destruct SUPREMUM_IN as [SUPREMUM_IN1 SUPREMUM_IN2].
      destruct XL_isOpen as [XL_UPWARD_CLOSED XL_LIMIT].
      destruct XR_isOpen as [XR_UPWARD_CLOSED XR_LIMIT].
      exploit XL_LIMIT as [x1 [x1_in_X x1_in_XL]]...
      exploit XR_LIMIT as [x2 [x2_in_X x2_in_XR]]...
      inversion DIRECTED; desnw'.
      pose proof (DIRECTED_OR_EMPTY x1 x1_in_X x2 x2_in_X) as [x3 [x3_in [x1_le_x3 x2_le_x3]]]...
    - ii; desnw'; unnw. destruct X_isOpen as [? ?]. econstructor.
      + ii; desnw'. rewrite <- X_eq_X'. eapply UPWARD_CLOSED with (x := x)...
      + ii; desnw'. unnw. exploit LIMIT as [? [? ?]]...
  Qed.

  End BUILD_SCOTT_TOPOLOGY.

  Global Instance TopologyOfDanaScott (D : Type) {requiresPoset : isPoset D} : isTopologicalSpace D :=
    { isOpen := isOpen_Scott (requiresPoset := requiresPoset)
    ; TopologicalSpace_obeysTopology_axiom := theScottTopology (requiresPoset := requiresPoset)
    }
  .

End ScottTopology.


Require Import
  HoTT.Basics
  HoTT.Types
  HoTT.HSet
  HoTT.Spaces.Nat
  HoTT.Spaces.Finite.FinNat
  HoTT.Spaces.Finite.Fin.

Local Open Scope nat_scope.

Definition fin_ind (P : forall n : nat, Fin n -> Type)
  (z : forall n : nat, P n.+1 fin_zero)
  (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k))
  {n : nat} (k : Fin n)
  : P n k.
Proof.
  refine (transport (P n) (path_fin_to_finnat_to_fin k) _).
  refine (finnat_ind (fun n u => P n (finnat_to_fin u)) _ _ _).
  - intro. apply z.
  - intros n' u c.
    refine ((path_finnat_to_fin_succ _)^ # _).
    by apply s.
Defined.

Lemma compute_fin_ind_fin_zero (P : forall n : nat, Fin n -> Type)
  (z : forall n : nat, P n.+1 fin_zero)
  (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k)) (n : nat)
  : fin_ind P z s fin_zero = z n.
Proof.
  unfold fin_ind.
  generalize (path_fin_to_finnat_to_fin (@fin_zero n)).
  induction (path_fin_to_finnat_fin_zero n)^.
  intro p.
  destruct (hset_path2 1 p).
  cbn.
  by destruct (hset_path2 1 (path_zero_finnat n leq_1_Sn)).
Defined.

Lemma compute_fin_ind_fsucc (P : forall n : nat, Fin n -> Type)
  (z : forall n : nat, P n.+1 fin_zero)
  (s : forall (n : nat) (k : Fin n), P n k -> P n.+1 (fsucc k))
  {n : nat} (k : Fin n)
  : fin_ind P z s (fsucc k) = s n k (fin_ind P z s k).
Proof.
  unfold fin_ind.
  generalize (path_fin_to_finnat_to_fin (fsucc k)).
  induction (path_fin_to_finnat_fsucc k)^.
  intro p.
  refine (ap (transport (P n.+1) p) (compute_finnat_ind_succ _ _ _ _) @ _).
  generalize dependent p.
  induction (path_fin_to_finnat_to_fin k).
  induction (path_fin_to_finnat_to_fin k)^.
  intro p.
  induction (hset_path2 p (path_finnat_to_fin_succ (fin_to_finnat k))).
  apply transport_pV.
Defined.

Definition fin_rec (B : nat -> Type)
  : (forall n : nat, B n.+1) -> (forall (n : nat), Fin n -> B n -> B n.+1) ->
    forall {n : nat}, Fin n -> B n
  := fin_ind (fun n _ => B n).

Lemma compute_fin_rec_fin_zero (B : nat -> Type)
  (z : forall n : nat, B n.+1)
  (s : forall (n : nat) (k : Fin n), B n -> B n.+1) (n : nat)
  : fin_rec B z s fin_zero = z n.
Proof.
  apply (compute_fin_ind_fin_zero (fun n _ => B n)).
Defined.

Lemma compute_fin_rec_fsucc (B : nat -> Type)
  (z : forall n : nat, B n.+1)
  (s : forall (n : nat) (k : Fin n), B n -> B n.+1)
  {n : nat} (k : Fin n)
  : fin_rec B z s (fsucc k) = s n k (fin_rec B z s k).
Proof.
  apply (compute_fin_ind_fsucc (fun n _ => B n)).
Defined.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.arrival.jitter.job
               prosa.classic.model.arrival.jitter.task_arrival
               prosa.classic.model.arrival.jitter.arrival_bounds.
Require Import prosa.classic.model.schedule.uni.workload.
Require Import prosa.classic.model.schedule.uni.jitter.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div.

(* In this file, we define the workload bound for jitter-aware FP scheduling. *)
Module WorkloadBoundFP.

  Import JobWithJitter SporadicTaskset UniprocessorScheduleWithJitter Priority Workload
         TaskArrivalWithJitter ArrivalBounds.

  (* First, we define a bound for the workload of a single task. *)
  Section SingleTask.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.
    Variable task_period: Task -> time.
    Variable task_jitter: Task -> time.

    (* Consider any task tsk to be scheduled in a given interval of length delta. *)
    Variable tsk: Task.
    Variable delta: time.

    (* Based on the maximum number of jobs of tsk that can execute in the interval, ... *)
    Definition max_jobs := div_ceil (delta + task_jitter tsk) (task_period tsk).

    (* ... we define the following workload bound for the task. *)
    Definition task_workload_bound_FP := max_jobs * task_cost tsk.

  End SingleTask.

  (* In this section, we define a bound for the workload all tasks with
     higher or equal priority. *)
  Section AllTasks.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.
    Variable task_period: Task -> time.
    Variable task_jitter: Task -> time.

    (* Assume any FP policy. *)
    Variable higher_eq_priority: FP_policy Task.

    (* Consider a task set ts... *)
    Variable ts: list Task.

    (* ...and let tsk be the task to be analyzed. *)
    Variable tsk: Task.

    (* Let delta be the length of the interval of interest. *)
    Variable delta: time.

    (* Recall the definition of higher-or-equal-priority task and
       the per-task workload bound for FP scheduling (defined above). *)
    Let is_hep_task tsk_other := higher_eq_priority tsk_other tsk.
    Let W tsk_other :=
      task_workload_bound_FP task_cost task_period task_jitter tsk_other delta.

    (* Using the sum of individual workload bounds, we define the following bound
       for the total workload of tasks of higher-or-equal priority (with respect
       to tsk) in any interval of length delta. *)
    Definition total_workload_bound_fp :=
      \sum_(tsk_other <- ts | is_hep_task tsk_other) W tsk_other.

  End AllTasks.

  (* In this section, we prove some basic lemmas about the workload bound. *)
  Section BasicLemmas.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.
    Variable task_period: Task -> time.
    Variable task_deadline: Task -> time.
    Variable task_jitter: Task -> time.

    (* Assume any FP policy. *)
    Variable higher_eq_priority: FP_policy Task.

    (* Consider a task set ts... *)
    Variable ts: list Task.

    (* ...and let tsk be any task in ts. *)
    Variable tsk: Task.
    Hypothesis H_tsk_in_ts: tsk \in ts.

    (* Recall the workload bound for uniprocessor FP scheduling. *)
    Let workload_bound :=
      total_workload_bound_fp task_cost task_period task_jitter higher_eq_priority ts tsk.

    (* In this section we prove that the workload bound in a time window of
       length (task_cost tsk) is as large as (task_cost tsk) time units.
       (This is an important initial condition for the fixed-point iteration.) *)
    Section NoSmallerThanCost.

      (* Assume that the priority order is reflexive... *)
      Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.

      (* ...and that the cost and period of task tsk are positive. *)
      Hypothesis H_cost_positive: task_cost tsk > 0.
      Hypothesis H_period_positive: task_period tsk > 0.

      (* Then, we prove that the workload bound in an interval of length (task_cost tsk)
         cannot be smaller than (task_cost tsk). *)
      Lemma total_workload_bound_fp_ge_cost:
        workload_bound (task_cost tsk) >= task_cost tsk.
      Proof.
        rename H_priority_is_reflexive into REFL.
        unfold workload_bound, total_workload_bound_fp.
        rewrite big_mkcond (big_rem tsk) /=; last by done.
        rewrite REFL /task_workload_bound_FP.
        apply leq_trans with (n := max_jobs task_period task_jitter
                                            tsk (task_cost tsk) * task_cost tsk);
          last by apply leq_addr.
        rewrite -{1}[task_cost tsk]mul1n leq_mul2r; apply/orP; right.
        apply ceil_neq0; last by done.
        by apply leq_trans with (n := task_cost tsk); last by apply leq_addr.
      Qed.

    End NoSmallerThanCost.

    (* In this section, we prove that the workload bound is monotonically non-decreasing. *)
    Section NonDecreasing.

      (* Assume that the period of every task in the task set is positive. *)
      Hypothesis H_period_positive:
        forall tsk,
          tsk \in ts ->
          task_period tsk > 0.

      (* Then, the workload bound is a monotonically non-decreasing function.
         (This is an important property for the fixed-point iteration.) *)
      Lemma total_workload_bound_fp_non_decreasing:
        forall delta1 delta2,
          delta1 <= delta2 ->
          workload_bound delta1 <= workload_bound delta2.
      Proof.
        unfold workload_bound, total_workload_bound_fp; intros d1 d2 LE.
        apply leq_sum_seq; intros tsk' IN HP.
        rewrite leq_mul2r; apply/orP; right.
        by apply leq_divceil2r; [by apply H_period_positive | by rewrite leq_add2r].
      Qed.

    End NonDecreasing.

  End BasicLemmas.

  (* In this section, we prove that any fixed point R = workload_bound R
     is indeed a workload bound for any interval of length R. *)
  Section ProofWorkloadBound.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.
    Variable task_period: Task -> time.
    Variable task_jitter: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> Task.

    (* Let ts be any task set... *)
    Variable ts: seq Task.

    (* ...with positive task periods. *)
    Hypothesis H_positive_periods:
      forall tsk, tsk \in ts -> task_period tsk > 0.

    (* Consider any job arrival sequence with consistent, duplicate-free arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arrival_sequence_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* First, let's define some local names for clarity. *)
    Let actual_arrivals := actual_arrivals_between job_arrival job_jitter arr_seq.

    (* Next, assume that all jobs come from the task set, ...*)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* ...the cost of each job is bounded by the cost of its task, ... *)
    Hypothesis H_job_cost_le_task_cost:
      forall j,
        arrives_in arr_seq j ->
        job_cost j <= task_cost (job_task j).

    (* ...and the jitter of each job is bounded by the jitter of its task. *)
    Hypothesis H_job_jitter_le_task_jitter:
      forall j,
        arrives_in arr_seq j ->
        job_jitter j <= task_jitter (job_task j).

    (* Assume that jobs arrived sporadically. *)
    Hypothesis H_sporadic_arrivals:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Then, let tsk be any task in ts. *)
    Variable tsk: Task.
    Hypothesis H_tsk_in_ts: tsk \in ts.

    (* For a given fixed-priority policy, ... *)
    Variable higher_eq_priority: FP_policy Task.

    (* ...we recall the definitions of higher-or-equal-priority workload and the workload bound. *)
    Let actual_hp_workload t1 t2 :=
      workload_of_higher_or_equal_priority_tasks job_cost job_task (actual_arrivals t1 t2)
                                                 higher_eq_priority tsk.
    Let workload_bound :=
      total_workload_bound_fp task_cost task_period task_jitter higher_eq_priority ts tsk.

    (* Next, consider any R that is a fixed point of the following equation,
       i.e., the claimed workload bound is equal to the interval length. *)
    Variable R: time.
    Hypothesis H_fixed_point: R = workload_bound R.

    (* Then, we prove that R bounds the workload of jobs of higher-or-equal-priority tasks
       with actual arrival time (including jitter) in [t, t + R). *)
    Lemma fp_workload_bound_holds:
      forall t,
        actual_hp_workload t (t + R) <= R.
    Proof.
      rename H_fixed_point into FIX, H_all_jobs_from_taskset into FROMTS,
             H_arrival_times_are_consistent into CONS, H_arrival_sequence_is_a_set into SET.
      unfold actual_hp_workload, workload_of_higher_or_equal_priority_tasks,
             valid_sporadic_job_with_jitter, valid_sporadic_job, valid_realtime_job,
             valid_sporadic_taskset, is_valid_sporadic_task in *.
      have BOUND := sporadic_task_with_jitter_arrival_bound task_period task_jitter job_arrival
                    job_jitter job_task arr_seq CONS SET.
      feed_n 2 BOUND; (try by done).
      intro t.
      rewrite {2}FIX /workload_bound /total_workload_bound_fp.
      set l := actual_arrivals_between job_arrival job_jitter arr_seq t (t + R).
      set hep := higher_eq_priority.
      apply leq_trans with (n := \sum_(tsk' <- ts | hep tsk' tsk)
                                  (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
      {
        have EXCHANGE := exchange_big_dep (fun x => hep (job_task x) tsk).
        rewrite EXCHANGE /=; last by move => tsk0 j0 HEP /eqP JOB0; rewrite JOB0.
        rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
        apply leq_sum; move => j0 /andP [IN0 HP0].
        rewrite big_mkcond (big_rem (job_task j0)) /=;
          first by rewrite HP0 andTb eq_refl; apply leq_addr.
        rewrite mem_filter in IN0; move: IN0 => /andP [_ ARR0].
        by apply in_arrivals_implies_arrived in ARR0; apply FROMTS.
      }
      apply leq_sum_seq; intros tsk0 IN0 HP0.
      apply leq_trans with (n := num_actual_arrivals_of_task job_arrival job_jitter job_task arr_seq
                                                             tsk0 t (t + R) * task_cost tsk0).
      {
        rewrite /num_actual_arrivals_of_task -sum1_size big_distrl /= big_filter.
        apply leq_sum_seq; move => j1 IN1 /eqP EQ.
        rewrite -EQ mul1n; apply H_job_cost_le_task_cost.
        rewrite mem_filter in IN1; move: IN1 => /andP [_ ARR1].
        by apply in_arrivals_implies_arrived in ARR1.
      }
      rewrite /task_workload_bound_FP leq_mul2r; apply/orP; right.
      feed (BOUND t (t + R) tsk0); first by apply H_positive_periods.
      by rewrite -addnA addKn in BOUND.
    Qed.

  End ProofWorkloadBound.

End WorkloadBoundFP.


Require Props.

Import Props.

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

Definition Reflexive {A : Type} (R : relation A) : Prop :=
  forall x : A, R x x.

Definition Symmetric {A : Type} (R : relation A) : Prop :=
  forall x y : A, R x y -> R y x.

Definition Transitive {A : Type} (R : relation A) : Prop :=
  forall x y z : A, R x y -> R y z -> R x z.

Class Equivalence {A : Type} (R : relation A) : Prop := BuildEquivalence {
  Equivalence_Reflexive : Reflexive R;
  Equivalence_Symmetric : Symmetric R;
  Equivalence_Transitive : Transitive R;
}.

Class SemiGroup {G : Type} (e : relation G) (op : G -> G -> G) : Prop := {
  sg_setoid : Equivalence e;
  sg_ass : Props.assoc op;
}.

Theorem example (G : Type) (e : relation G) (op : G -> G -> G)
  {P : SemiGroup e op} :
  forall x y z : G, e (op (op x y) z) (op (op z y) x).
Proof. destruct P. Abort.

Module principle.
Class EquivOp A := eq_op : relation A.
Class SemiGroupOp A := sg_op : A -> A -> A.
Infix "==" := eq_op (at level 70) : type_scope.
Infix "&" := sg_op (at level 50, left associativity).

Class SemiGrouped {G : Type} (e : EquivOp G) (op : SemiGroupOp G) : Prop := {
  sg_setoid : Equivalence e;
  sg_ass : Props.assoc op;
}.

Theorem exampled (G : Type) (e : EquivOp G) (op : SemiGroupOp G)
  {P : SemiGrouped e op} :
  forall x y z : G, x & y & z == z & y & x.
Proof. cbv [EquivOp SemiGroupOp] in *. destruct P. Abort.

Class MonoidZeroOp A := mon_zero : A.
Notation "'#'" := mon_zero (at level 0).

Definition id_l {G} (E : EquivOp G) (op : G -> G -> G) (id : G) : Prop :=
  forall x : G, op id x == x.

Definition id_r {G} (E : EquivOp G) (op : G -> G -> G) (id : G) : Prop :=
  forall x : G, op x id == x.

Class Monoided {G : Type} (e : EquivOp G)
  (op : SemiGroupOp G) (z : MonoidZeroOp G) : Prop := {
  mon_sg : SemiGrouped e op;
  mon_l : id_l e op #;
  mon_r : id_r e op #;
}.

Theorem something (G : Type) (e : EquivOp G)
  (op : SemiGroupOp G) (z : MonoidZeroOp G)
  {P : Monoided e op z} :
  forall x : G, x & # == # & x.
Proof.
  intros x. destruct P. destruct mon_sg0. cbv [id_l id_r] in *.
  eapply Equivalence_Transitive.
  - cbv in *. apply mon_r0.
  - cbv in *. apply Equivalence_Symmetric. apply mon_l0. Qed.
End principle.

Module LeftModule.
Record members_of {A L : Type} : Type := MembersOf {
  add : A -> A -> A;
  zero : A;
  neg : A -> A;
  ladd : L -> L -> L;
  lzero : L;
  lneg : L -> L;
  lmul : L -> L -> L;
  lone : L;
  lsmul : L -> A -> A;
}.
Arguments members_of : clear implicits.
Arguments MembersOf {_ _}.
Notation "x 'ADD' '[' mo ']' y" := (add mo x y).
Notation "'ZERO' '[' mo ']'" := (zero mo).
Notation "'NEG' '[' mo ']' x" := (neg mo x).
Notation "x 'LADD' '[' mo ']' y" := (ladd mo x y).
Notation "'LZERO' '[' mo ']'" := (lzero mo).
Notation "'LNEG' '[' mo ']' x" := (lneg mo x).
Notation "x 'LMUL' '[' mo ']' y" := (lmul mo x y).
Notation "'LONE' '[' mo ']'" := (lone mo).
Notation "a 'LSMUL' '[' mo ']' x" := (lsmul mo a x).
Record laws_of {A L : Type} (mo : members_of A L) : Prop := LawsOf {
  add_assoc : Props.assoc (add mo);
  add_id_l : Props.id_l (add mo) (zero mo);
  add_id_r : Props.id_r (add mo) (zero mo);
  add_inv_l : Props.inv_l (add mo) (zero mo) (neg mo);
  add_inv_r : Props.inv_r (add mo) (zero mo) (neg mo);
  add_comm : Props.comm (add mo);
  ladd_assoc : Props.assoc (ladd mo);
  ladd_id_l : Props.id_l (ladd mo) (lzero mo);
  ladd_id_r : Props.id_r (ladd mo) (lzero mo);
  ladd_inv_l : Props.inv_l (ladd mo) (lzero mo) (lneg mo);
  ladd_inv_r : Props.inv_r (ladd mo) (lzero mo) (lneg mo);
  ladd_comm : Props.comm (ladd mo);
  lmul_assoc : Props.assoc (lmul mo);
  lmul_id_l : Props.id_l (lmul mo) (lone mo);
  lmul_id_r : Props.id_r (lmul mo) (lone mo);
  ldist_l : Props.dist_l (ladd mo) (lmul mo);
  ldist_r : Props.dist_r (ladd mo) (lmul mo);
  lsid : Props.lsid (lone mo) (lsmul mo);
  lsassoc : Props.lsassoc (lmul mo) (lsmul mo);
  lsdist_l : Props.lsdist_l (add mo) (lsmul mo);
  lsdist_r : Props.lsdist_r (add mo) (ladd mo) (lsmul mo);
}.
End LeftModule.

Module ModuleHom.
Record members_of {A L : Type} : Type := MembersOf {
  from : LeftModule.members_of A L;
  to : LeftModule.members_of A L;
  hom : A -> A;
}.
Arguments members_of : clear implicits.
Arguments MembersOf {_ _}.
Notation "'HOM' '[' mo ']' x" := (hom mo x) (at level 42).
Record laws_of {A L : Type} (mo : members_of A L) : Prop := LawsOf {
  hom_from : LeftModule.laws_of (from mo);
  hom_to : LeftModule.laws_of (to mo);
  hom_dist : forall x y : A,
    hom mo (LeftModule.add (from mo) x y) =
    LeftModule.add (from mo) (hom mo x) (hom mo y);
  hom_lscomm : forall (a : L) (x : A),
    hom mo (LeftModule.lsmul (from mo) a x) =
    LeftModule.lsmul (to mo) a (hom mo x);
}.
End ModuleHom.

Module DiffOp.
Record members_of {A L : Type} : Type := MembersOf {
  diff : nat -> ModuleHom.members_of A L;
}.
Arguments members_of : clear implicits.
Arguments MembersOf {_ _}.
Notation "'DIFF' '[' mo ']' x" := (diff mo x) (at level 42).
Record laws_of {A L : Type} (mo : members_of A L) : Prop := LawsOf {
  zero_diff : forall n : nat, ModuleHom.laws_of (diff mo n);
  zero_square : forall (n : nat) (x : A),
    ModuleHom.hom (diff mo n) (ModuleHom.hom (diff mo (S n)) x) =
    LeftModule.zero (ModuleHom.to (diff mo n));
}.
End DiffOp.

Module ChainComplex.
Record members_of {A L : Type} : Type := MembersOf {
  mod : nat -> LeftModule.members_of A L;
  dop : DiffOp.members_of A L;
}.
Arguments members_of : clear implicits.
Arguments MembersOf {_ _}.
Record laws_of {A L : Type} (mo : members_of A L) : Prop := LawsOf {
}.
End ChainComplex.


Require Import Iron.Language.SimplePCF.Step.
Require Import Iron.Language.SimplePCF.Ty.
Require Import Iron.Language.SimplePCF.SubstExpExp.

(* If a closed, well typed expression takes an evaluation step
   then the result has the same type as before. *)
Theorem preservation
 :  forall x x' t
 ,  TYPE nil x  t
 -> STEP  x x'
 -> TYPE nil x' t.
Proof.
 intros x x' t HT HS. gen t.
 induction HS; rip; try (inverts HT; progress burn).

 - destruct H; inverts HT; burn.

 - inverts HT. inverts H3.
   burn using subst_exp_exp.

 - inverts HT.
   burn using subst_exp_exp.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the before. *)
Lemma preservation_steps
 :  forall x1 t1 x2
 ,  TYPE nil x1 t1
 -> STEPS    x1 x2
 -> TYPE nil x2 t1.
Proof.
 intros x1 t1 x2 HT HS.
 induction HS; burn using preservation.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original.
   Using the left-linearised form for the evaluation. *)
Lemma preservation_stepsl
 :  forall x1 t1 x2
 ,  TYPE nil x1 t1
 -> STEPSL   x1 x2
 -> TYPE nil x2 t1.
Proof.
 intros x1 t1 x2 HT HS.
 induction HS; burn using preservation.
Qed.


Section ml.
Variables A B C:Prop.
Theorem Ordiste: or A (and B C) <-> and (or A B) (or A C).
Proof.
    split.
    intro H0.
    split.
    elim H0.
    intro Ha; left; assumption.
    intro Hbc.
    elim Hbc; intros Hb Hc; right; assumption.
    elim H0; intro H1.
    left; assumption.
    elim H1; intros Hb Hc.
    right; assumption.
    intro H2.
    elim H2; intros H3 H4.
    elim H3.
    intro Ha; left; assumption.
    intro Hb.
    elim H4.
    intro Ha.
    left; assumption.
    intro Hc.
    right.
    split; assumption.
Qed.
End ml.

Check Ordiste.


Require Import QuickSort.
Require Import Prelude.
Require Import GHC.DeferredFix.

Require Import Coq.Lists.List.
Import ListNotations.

Inductive AlreadySorted {a} `{Ord a} : list a -> Prop :=
 | ASNil: AlreadySorted []
 | ASCons: forall x xs,
     AlreadySorted xs ->
     Forall (fun y => (op_zl__ y x) = false) xs ->
     AlreadySorted (x::xs).

Axiom unroll_deferred_fix: forall a r `{Default r} (f : (a -> r) -> (a -> r)),
  deferredFix1 f = f (deferredFix1 f).

Lemma Forall_partition:
  forall a p (xs : list a),
  Forall (fun y => (p y) = false) xs ->
  OldList.partition p xs = ([], xs).
Proof.
  intros.
  induction H.
  * reflexivity.
  * unfold OldList.partition in *.
    simpl in *. rewrite IHForall.
    unfold OldList.select.
    rewrite H. reflexivity.
Qed.

Theorem quicksort_already_sorted:
  forall a `(Ord a) (xs : list a),
  AlreadySorted xs -> quicksort xs = xs.
Proof.
  intros.
  induction H1.
  * unfold quicksort.
    rewrite unroll_deferred_fix. reflexivity.
  * change (quicksort (x :: xs) = [] ++ [x] ++ xs).
    unfold quicksort.
    rewrite unroll_deferred_fix.
    rewrite Forall_partition by assumption.
    f_equal;[|f_equal].
    + rewrite unroll_deferred_fix. reflexivity.
    + apply IHAlreadySorted.
Qed.

Require Import Coq.Sorting.Permutation.

Lemma partition_permutation:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Permutation xs (ys ++ zs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      apply Permutation_cons; [reflexivity|].
      apply IHxs.
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      apply Permutation_cons_app.
      apply IHxs.
      congruence.
Qed.

Lemma Forall_partition_l:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Forall (fun y => (p y) = true) ys.
Proof.
  induction xs; intros.
  * simpl in H. inversion H. auto.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0) eqn:?.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      constructor; try assumption.
      apply (IHxs l zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      destruct zs. try congruence.
      apply (IHxs ys zs).
      congruence.
Qed.

Lemma Forall_partition_r:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Forall (fun y => (p y) = false) zs.
Proof.
  induction xs; intros.
  * simpl in H. inversion H. auto.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0) eqn:?.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      destruct ys. try congruence.
      apply (IHxs ys zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      constructor; try assumption.
      apply (IHxs ys l0).
      congruence.
Qed.

Lemma partition_length_l:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Peano.le (length ys) (length xs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      simpl.
      apply le_n_S.
      apply (IHxs l zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      destruct zs. try congruence.
      inversion H2.
      simpl.
      rewrite (IHxs ys zs).
      omega.
      congruence.
Qed.

Lemma partition_length_r:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Peano.le (length zs) (length xs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      destruct ys. try congruence.
      inversion H2.
      simpl.
      rewrite (IHxs ys zs).
      omega.
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      simpl.
      apply le_n_S.
      apply (IHxs ys l0).
      congruence.
Qed.

Theorem quicksort_permutation:
  forall a `(Ord a) (xs : list a),
  Permutation  (quicksort xs) xs.
Proof.
  intros.
  remember (length xs) as n.
  generalize dependent xs.
  induction n using lt_wf_ind.
  intros.
  unfold quicksort.
  rewrite unroll_deferred_fix.
  destruct xs.
  * apply perm_nil.
  * destruct (OldList.partition (fun arg_1__ : a => _<_ arg_1__ a0) xs) eqn:?.
    simpl app.
    rewrite <- Permutation_middle.
    apply Permutation_cons; [reflexivity|].
    rewrite (partition_permutation _ _ _ _ _ Heqp).
    apply Permutation_app.
    - apply (H1 (length l)).
      + pose (partition_length_l _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - apply (H1 (length l0)).
      + pose (partition_length_r _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
Qed.

Require Import Coq.Sorting.Sorted.
Require Import Coq.Sets.Relations_1.
Require Import Coq.Lists.List.

Lemma Forall_app:
  forall a P (xs ys : list a),
  Forall P xs -> Forall P ys ->
  Forall P (xs ++ ys).
Proof.
  intros. induction xs; try assumption. constructor.
  inversion H; assumption.
  apply IHxs. inversion H; assumption.
Qed.

Lemma Forall_Permutation:
  forall a P (xs ys : list a),
  Forall P ys -> Permutation xs ys ->
  Forall P xs.
Proof.
  intros.
  induction H0.
  * auto.
  * constructor.
    + inversion_clear H. assumption.
    + apply IHPermutation. inversion_clear H. assumption.
  * inversion_clear H. inversion_clear H1.
    repeat (constructor; try assumption).
  * auto.
Qed.

Section sorted.
 Variable a : Type.
 Variable eq : Eq_ a.
 Variable ord : Ord a.

 Definition R x y := x < y = true.

 Variable trans : Transitive R.
 Variable total : forall a b, R a b \/ R b a.

Lemma StronglySorted_app_cons:
  forall (xs ys : list a) p,
  StronglySorted R xs ->
  StronglySorted R ys ->
  Forall (fun x => R x p) xs ->
  Forall (fun y => R p y) ys ->
  StronglySorted R (xs ++ p :: ys).
Proof.
  intros.
  induction xs.
  * simpl.
    apply SSorted_cons.
    - assumption.
    - assumption.
  * simpl. apply SSorted_cons.
    - apply IHxs.
      + inversion H; assumption.
      + inversion H1; assumption.
    - apply Forall_app.
      inversion_clear H; assumption.
      constructor.
      inversion_clear H1; assumption.
      refine (Forall_impl _ _ H2). intros.
      refine (trans _ _ _ _ H3).
      inversion_clear H1; assumption.
Qed.

Theorem quicksort_sorted:
  forall (xs : list a), StronglySorted R (quicksort xs).
Proof.
  intros.
  remember (length xs) as n.
  generalize dependent xs.
  induction n using lt_wf_ind.
  intros.
  unfold quicksort.
  rewrite unroll_deferred_fix.
  destruct xs.
  * apply SSorted_nil.
  * destruct (OldList.partition (fun arg_1__ : a => _<_ arg_1__ a0) xs) eqn:?.
    simpl app.
    apply StronglySorted_app_cons.
    - apply (H (length l)).
      + pose (partition_length_l _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - apply (H (length l0)).
      + pose (partition_length_r _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - refine (Forall_Permutation _ _ _ _ _ (quicksort_permutation _ _ _)).
      apply (Forall_partition_l _ _ _ _ _  Heqp).
    - refine (Forall_Permutation _ _ _ _ _ (quicksort_permutation _ _ _)).
      specialize (Forall_partition_r _ _ _ _ _  Heqp).
      apply Forall_impl.
      intros.
      destruct (total a0 a1); [assumption|congruence].
Qed.
End sorted.

Print Assumptions quicksort_sorted.


Require Export Iron.Language.SystemF2r.Base.

(* Kinds *)
Inductive ki : Type :=
 | KData   : ki
 | KFun    : ki -> ki -> ki.
Hint Constructors ki.

(* Kind Environments *)
Definition kienv := list ki.

(* Kind env is the same as another, but with a new element. *)
Definition keK      (k : ki)  (ke : kienv) (ke' : kienv) : Prop
 := ke :> k  = ke'.

(* Kind env is the same as another, but with a new element. *)
Definition keKi     (i : nat) (k : ki)  (ke : kienv) (ke' : kienv) : Prop
 := insert i k ke = ke'.

(* Kind is the ith element of a kind environemnt. *)
Definition keAtK    (i : nat) (ke : kienv) (k   : ki) : Prop
 := get i ke = Some k.

(* Get the size of a kind environment. *)
Definition keSize (ke : kienv) : nat
 := length ke.


Require Import Tapl.Stlc.Base.
Require Import Tapl.Stlc.Exp.
Require Import Tapl.Stlc.Typing.

(* Weakening lemma *)
Lemma type_insert_weaken : ∀ Γ i t T S,
  Γ ⊢ t ∈ T →
  (insert i S Γ) ⊢ (lift i t) ∈ T.
Proof with eauto.
  intros.
  generalize dependent i.
  induction H; intros; simpl...
  - destruct (i ?= i0) eqn:eqH.
    + apply Nat.compare_eq in eqH. rewrite <- eqH. apply Ty_Var. apply insert_shift...
    + apply Nat.compare_lt_iff in eqH. apply Ty_Var. apply insert_noshift...
    + apply Nat.compare_gt_iff in eqH. apply Ty_Var. apply insert_shift... apply Nat.lt_le_incl...
  - apply Ty_Abs. rewrite insert_rewind...
Qed.

Lemma weakening : ∀ Γ t T S,
  Γ ⊢ t ∈ T →
  (S :: Γ) ⊢ (lift 0 t) ∈ T.
Proof with eauto.
  intros.
  - assert ((insert 0 S Γ) ⊢ (lift 0 t) ∈ T).
    apply type_insert_weaken... simpl in H0... destruct Γ...
Qed.

Lemma subst_preserves_typing' : ∀ Γ S T s t i,
  get i Γ = Some S →
  Γ ⊢ t ∈ T →
  (delete i Γ) ⊢ s ∈ S →
  (delete i Γ) ⊢ substX i s t ∈ T.
Proof with eauto.
  intros.
  generalize dependent Γ. generalize dependent T.
  generalize dependent i. generalize dependent s.
  induction t; intros; inversion H0; subst; clear H0; simpl...
  - destruct (n ?= i) eqn:Heq.
    + apply Nat.compare_eq in Heq. subst. rewrite H in H4. injection H4 as H4. subst; auto.
    + apply Nat.compare_lt_iff in Heq.
      assert (get n (delete i Γ) = Some T). apply delete_lt...
      auto.
    + apply Nat.compare_gt_iff in Heq.
      destruct n.
      * apply Nat.nlt_0_r in Heq. exfalso...
      * simpl. simpl in *. assert (get n (delete i Γ) = Some T)... apply delete_gt...
  - apply Ty_Abs.
    rewrite delete_rewind.
    apply IHt... simpl. apply weakening...
Qed.

(* Substitution lemma *)
Lemma subst_preserves_typing : forall Γ S T s t,
    (S :: Γ) ⊢ t ∈ T ->
    Γ ⊢ s ∈ S ->
    Γ ⊢ substX 0 s t ∈ T.
Proof with eauto.
  intros. assert (delete 0 (S :: Γ) ⊢ (substX 0 s t) ∈ T)...
  apply subst_preserves_typing' with S...
Qed.

(* Example of substitution *)
Module SubstTest.
Parameter S T : type.
Definition Γ := T :: nil.
Definition s := tm_abs T (tm_var 1).
Definition t := tm_app (tm_var 1) (tm_var 2).
Lemma t_type : (S :: (ty_arrow T T) :: Γ) ⊢ t ∈ T.
Proof. unfold t. apply Ty_App with T; auto. Qed.
Lemma s_type : Γ ⊢ s ∈ ty_arrow T T.
Proof. unfold s. auto. Qed.
Lemma subst_st : (S :: Γ) ⊢ substX 1 (lift 0 s) t ∈ T.
Proof. simpl. eauto. Qed.

Lemma subst_st_wrong : (S :: Γ) ⊢ substX 1 s t ∈ T.
Proof. simpl. unfold s. eauto. Abort.

End SubstTest.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* This file contains two high level arguments:

  1) (DistSingle) When an adversary cannot distinguish two distributions when given one sample, then he cannot distinguish the distributions when given polynomially many samples.

  2) (RepeatCore) When an adversary cannot distinguish two distributions when given a polynomial number of samples, he cannot distinguish the distributions when given one sample from some "core" of the distributions that has polynomial size.

*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.CompFold.
Require Import FCF.RndNat.
Require Export FCF.Hybrid.

Local Open Scope list_scope.

(* An argument showing that two distributions are indistinguishable even when multiple samples are given to the adversary. *)

Section DistMult.

  Variable A B : Set.
  Hypothesis B_EqDec : EqDec B.
  Variable c1 c2 : A -> Comp B.
  Variable A_State : Set.
  Variable A1 : Comp (A * A_State).
  Variable A2 : A_State -> list B -> Comp bool.

  Variable n : nat.

  Definition DistMult_G(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    b <-$ compMap _ (fun _ => (c a)) (forNats n);
    A2 s_A b.

  Definition DistMult_Adv :=
    | Pr[DistMult_G c1] - Pr[DistMult_G c2] |.

End DistMult.

Section DistSingle_impl_Mult.

  Variable A B : Set.
  Variable A_EqDec : EqDec A.
  Variable B_EqDec : EqDec B.
  Variable c1 c2 : A -> Comp B.
  Variable A_State : Set.
  Variable A_State_EqDec : EqDec A_State.
  Variable A1 : Comp (A * A_State).
  Variable A2 : A_State -> list B -> Comp bool.

  Hypothesis c1_wf : forall a, well_formed_comp (c1 a).
  Hypothesis c2_wf : forall a, well_formed_comp (c2 a).

  (* Produce a list of length n derived from c1, and c2.  The first i values come from c1, and the rest come from c2. *)
  Definition computeHybrid(n i : nat) a : Comp (list B) :=
    b1 <-$ compMap _ (fun _ => (c1 a)) (forNats i);
    b2 <-$ compMap _ (fun _ => (c2 a)) (forNats (minus n i));
    ret (b1 ++ b2).

  Variable n : nat.
  Hypothesis n_pos : n > 0.

  Theorem hybrid_replace_c1_equiv :
    forall i x a,
      i < n ->
      evalDist
        (b <-$ (c1 a);
         hybrid <-$ computeHybrid n i a;
         ret (listReplace hybrid i b b)) x ==
      evalDist (computeHybrid n (S i) a) x.

    induction n; destruct i; intuition; try lia.
    unfold computeHybrid.
    unfold minus.
    fold minus.
    rewrite <- minus_n_O.
    unfold forNats.
    fold forNats.
    unfold compMap.
    fold compMap.
    inline_first.
    comp_skip.
    inline_first.
    comp_simp.
    comp_irr_l.
    inline_first.
    comp_skip.
    simpl.
    intuition.

    unfold computeHybrid.
    unfold minus.
    fold minus.
    unfold forNats.
    fold forNats.
    unfold compMap.
    fold compMap.

    inline_first.
    do 2 comp_at comp_inline leftc 1%nat.
    comp_swap_l.
    comp_skip.

    assert
      (evalDist
     (a1 <-$
      (lsb' <-$
       (b <-$ (c1 a);
        lsb' <-$ compMap B_EqDec (fun _ : nat => (c1 a)) (forNats i);
        ret b :: lsb'); ret x0 :: lsb');
      a2 <-$ compMap B_EqDec (fun _ : nat => (c2 a)) (forNats (n0 - S i));
      ret a1 ++ a2) x ==
       evalDist
     (ls <-$ (computeHybrid n0 (S i) a);
      ret (x0 :: ls)) x).

    unfold computeHybrid.
    unfold forNats.
    fold forNats.
    unfold compMap.
    fold compMap.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    comp_simp.
    inline_first.
    comp_skip.
    comp_simp.
    simpl.
    intuition.
    rewrite H1.
    clear H1.
    eapply eqRat_trans.
    2:{
      comp_skip.
      eapply eqRat_refl.
    }
    unfold computeHybrid.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    comp_simp.
    simpl.
    intuition.

  Qed.

  Theorem hybrid_replace_c2_equiv :
    forall i x a,
      i < n ->
      evalDist
        (b <-$ (c2 a);
         hybrid <-$ computeHybrid n i a;
         ret (listReplace hybrid i b b)) x ==
      evalDist (computeHybrid n i a) x.

    induction n; destruct i; intuition; try lia.

    unfold computeHybrid.
    unfold minus.
    unfold forNats.
    fold forNats.
    unfold compMap.
    fold compMap.
    comp_simp.
    inline_first.
    comp_skip.
    inline_first.
    comp_irr_l.
    inline_first.
    comp_skip.
    comp_simp.
    simpl.
    intuition.

    unfold computeHybrid.
    unfold minus.
    fold minus.
    unfold forNats.
    fold forNats.
    unfold compMap.
    fold compMap.
    inline_first.
    do 2 comp_at comp_inline leftc 1%nat.
    comp_swap_l.
    comp_skip.

    assert (evalDist
     (a1 <-$
      (lsb' <-$ compMap B_EqDec (fun _ : nat => (c1 a)) (forNats i);
       ret x0 :: lsb');
      a2 <-$ compMap B_EqDec (fun _ : nat => (c2 a)) (forNats (n0 - i));
      ret a1 ++ a2) x ==
            evalDist
     (ls <-$
         (a1 <-$ compMap B_EqDec (fun _ : nat => (c1 a)) (forNats i);
          a2 <-$ compMap B_EqDec (fun _ : nat => (c2 a)) (forNats (n0 - i));
          ret a1 ++ a2);
         ret (x0 :: ls)) x).

    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    comp_simp.
    rewrite app_comm_cons.
    intuition.
    rewrite H1.
    clear H1.
    eapply eqRat_trans.
    2:{
      comp_skip.
      eapply IHn0.
      lia.
      lia.
      eapply eqRat_refl.
    }
    unfold computeHybrid.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    comp_simp.
    simpl.
    intuition.
  Qed.

  Definition B1 : Comp (A * (A * A_State)) :=
    [a, s_A] <-$2 A1;
    ret (a, (a, s_A)).

  Definition B2(s : A * A_State)(b : B) : Comp bool :=
    [a, s_A] <-2 s;
    i <-$ [0 .. n);
    rndHybrid <-$ computeHybrid n i a;
    distHybrid <- listReplace rndHybrid i b b;
    A2 s_A distHybrid.

  Definition DistSingle_G1(c : A -> Comp B) :=
    [a, s_A] <-$2 B1;
    b <-$ (c a);
    B2 s_A b.

  Theorem DistSingle_G1_equiv :
      DistSingle_Adv c1 c2 B1 B2 ==
      (| Pr[DistSingle_G1 c1] - Pr[DistSingle_G1 c2] |).

    unfold DistSingle_Adv, DistSingle_G1, DistSingle_G.
    intuition.

  Qed.

  Definition DistSingle_G2(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    i <-$ [ 0  .. n);
    distHybrid <-$
               (b <-$ c a;
                rndHybrid <-$ computeHybrid n i a;
                ret (listReplace rndHybrid i b b));
    A2 s_A distHybrid.

  Theorem DistSingle_G2_equiv :
    forall c,
      Pr[DistSingle_G1 c] == Pr[DistSingle_G2 c].

    intuition.
    unfold DistSingle_G1, DistSingle_G2.
    unfold B1, B2.
    inline_first.
    comp_skip.
    comp_simp.
    comp_swap_l.
    comp_skip.
    inline_first.
    comp_skip.
    comp_inline_r.
    comp_skip.
    comp_simp.
    intuition.

  Qed.

  Definition DistSingle_G3_c2 :=
    i <-$ [ 0  .. n);
    [a, s_A] <-$2 A1;
    distHybrid <-$ computeHybrid n i a;
    A2 s_A distHybrid.

  Definition DistSingle_G3_c1 :=
    i <-$ [ 0  .. n);
    [a, s_A] <-$2 A1;
    distHybrid <-$ computeHybrid n (S i) a;
    A2 s_A distHybrid.

  Theorem DistSingle_G3_c2_equiv :
    Pr[DistSingle_G2 c2] == Pr[DistSingle_G3_c2].

    unfold DistSingle_G2, DistSingle_G3_c2.
    comp_swap_r.
    comp_skip.
    comp_simp.
    comp_skip.
    comp_skip.
    eapply hybrid_replace_c2_equiv.
    eapply RndNat_support_lt; intuition.

  Qed.

  Theorem DistSingle_G3_c1_equiv :
    Pr[DistSingle_G2 c1] == Pr[DistSingle_G3_c1].

    unfold DistSingle_G2, DistSingle_G3_c1.
    comp_swap_r.
    comp_skip.
    comp_simp.
    comp_skip.
    comp_skip.
    eapply hybrid_replace_c1_equiv.
    eapply RndNat_support_lt; intuition.

  Qed.

  Theorem compMap_computeHybrid_0_equiv :
    forall s_A a,
      Pr  [b <-$ compMap B_EqDec (fun _ : nat => (c2 a)) (forNats n); A2 s_A b ] ==
      Pr  [x <-$ computeHybrid n 0 a; A2 s_A x ].

    intuition.
    unfold computeHybrid.
    unfold forNats.
    fold forNats.
    inline_first.
    unfold compMap.
    fold compMap.
    comp_simp.
    inline_first.
    rewrite <- minus_n_O.
    comp_skip.
    comp_simp.
    simpl.
    intuition.
  Qed.

  Theorem compMap_computeHybrid_n_equiv :
    forall s_A a,
    Pr  [b <-$ compMap B_EqDec (fun _ : nat => (c1 a)) (forNats n); A2 s_A b ] ==
    Pr  [x <-$ computeHybrid n n a; A2 s_A x ].

    intuition.
    unfold computeHybrid.
    inline_first.
    comp_skip.

    inline_first.
    rewrite minus_diag.
    unfold forNats.
    unfold compMap.
    comp_simp.
    rewrite app_nil_r.
    intuition.
  Qed.

  Theorem DistSingle_impl_Mult :
    DistMult_Adv _ c1 c2 A1 A2 n <= (n / 1) * (DistSingle_Adv c1 c2 B1 B2).

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      rewrite DistSingle_G1_equiv.
      rewrite DistSingle_G2_equiv.
      rewrite DistSingle_G2_equiv.
      rewrite DistSingle_G3_c1_equiv.
      rewrite DistSingle_G3_c2_equiv.
      eapply eqRat_refl.
    }

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      unfold DistSingle_G3_c1, DistSingle_G3_c2.
      rewrite rndNat_sumList.
      rewrite rndNat_sumList.
      rewrite sumList_factor_constant_l.
      rewrite sumList_factor_constant_l.
      rewrite ratMult_ratDistance_factor_l.
      eapply eqRat_refl.
    }

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      rewrite <-ratMult_assoc.
      rewrite ratMult_eq_rat1.
      rewrite ratMult_1_l.
      rewrite ratDistance_comm.
      rewrite sumList_forNats_distance.
      eapply eqRat_refl.
    }

    unfold DistMult_Adv.
    unfold DistMult_G.
    rewrite ratDistance_comm.
    eapply eqRat_impl_leRat.
    eapply ratDistance_eqRat_compat.

    eapply evalDist_seq; intuition.
    comp_simp.

    eapply compMap_computeHybrid_0_equiv.

    eapply evalDist_seq; intuition.
    comp_simp.
    eapply compMap_computeHybrid_n_equiv.

    Unshelve.
    econstructor; intuition.

  Qed.

End DistSingle_impl_Mult.

Section RepeatCore.

  Variable A B : Set.
  Hypothesis B_EqDec : EqDec B.
  Variable P : B -> bool.
  Variable c1 c2 : A -> Comp B.

  Variable A_State : Set.
  Variable A1 : Comp (A * A_State ).
  Variable A2 : A_State -> B -> Comp bool.

  Definition RepeatCore_G(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    b <-$ Repeat (c a) P;
    A2 s_A b.

  Definition RepeatCore_Adv :=
    | Pr[RepeatCore_G c1] - Pr[RepeatCore_G c2] |.

End RepeatCore.

Section DistMult_impl_RepeatCore.

  Variable A B : Set.
  Hypothesis B_EqDec : EqDec B.
  Variable P : B -> bool.
  Variable c1 c2 : A -> Comp B.

  Variable A_State : Set.
  Variable A1 : Comp (A * A_State).
  Variable A2 : A_State -> B -> Comp bool.
  Hypothesis A1_wf : well_formed_comp A1.
  Hypothesis A2_wf : forall s_A b, well_formed_comp (A2 s_A b).

  Hypothesis c1_wf : forall a s_A, In (a, s_A) (getSupport A1) -> well_formed_comp (c1 a).
  Hypothesis c1_repeat_wf : forall a s_A, In (a, s_A) (getSupport A1) -> exists b, In b (filter P (getSupport (c1 a))).

  Hypothesis c2_wf : forall a s_A, In (a, s_A) (getSupport A1) -> well_formed_comp (c2 a).
  Hypothesis c2_repeat_wf : forall a s_A, In (a, s_A) (getSupport A1) -> exists b, In b (filter P (getSupport (c2 a))).

  Variable n : nat.

  (* Assume A1 can effectively distinguish the cores as in RepeatCore_G, construct an adversary B that can distinguish the entire distributions given multiple samples as in DistMult_G. *)

  Definition DM_RC_G1(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    p <-$ Repeat (b <-$ (c a); g <-$ (A2 s_A b); ret (b, g)) (fun p => P (fst p));
    ret (snd p).

  Theorem DM_RC_G1_equiv :
    forall c x,
      (forall a s_A, In (a, s_A) (getSupport A1) -> well_formed_comp (c a)) ->
      (forall a s_A, In (a, s_A) (getSupport A1) -> exists b, In b (filter P (getSupport (c a)))) ->
      evalDist (RepeatCore_G P A1 A2 c) x == evalDist (DM_RC_G1 c) x.

    intuition.
    unfold RepeatCore_G, DM_RC_G1.
    comp_skip.

    comp_simp.
    assert (evalDist (b0 <-$ Repeat (c a) P; A2 a0 b0) x
                      ==
                      evalDist (p <-$ (b0 <-$ Repeat (c a) P; b <-$ A2 a0 b0; ret (b0, b)); ret (snd p)) x).
    inline_first.
    comp_skip.
    inline_first.
    rewrite <- evalDist_right_ident.
    comp_skip.
    comp_simp.
    simpl.
    reflexivity.
    rewrite H2.
    comp_skip.

    eapply repeat_fission; intuition.
    eauto.
    eauto.
  Qed.

  Definition DM_RC_G2(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    p <-$ Repeat (b <-$ (c a); g <-$ (A2 s_A b); ret (b, g)) (fun p => P (fst p));
    ret (Some (snd p)).

  Theorem DM_RC_G2_equiv :
     forall c x,
       evalDist (DM_RC_G1 c) x == evalDist (DM_RC_G2 c) (Some x).

     intuition.
     unfold DM_RC_G1, DM_RC_G2.
     comp_skip.
     comp_simp.
     comp_skip.
     dist_compute.
   Qed.

  Definition DM_RC_G3(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    ls <-$ compMap _ (fun _ => b <-$ c a; g <-$ (A2 s_A b); ret (b, g)) (forNats n);
    ret hd_error (map (fun x => snd x) (filter (fun p => P (fst p)) ls)).

  Theorem DM_RC_G2_G3_close :
     forall (c : A -> Comp B) k x,
       (forall a s_A, In (a, s_A) (getSupport A1) -> well_formed_comp (c a)) ->
       (forall a s_A, In (a, s_A) (getSupport A1) -> exists b, In b (filter P (getSupport (c a)))) ->
       (forall a s_A, In (a, s_A) (getSupport A1) -> Pr[b <-$ c a; ret (negb (P b))] <= k) ->
       | evalDist (DM_RC_G2 c) x - evalDist (DM_RC_G3 c) x | <= expRat k n.

     intuition.
     unfold DM_RC_G2, DM_RC_G3.

     eapply evalDist_bind_distance; intuition.

     rewrite ratDistance_comm.
     eapply leRat_trans.

     eapply compMap_Repeat_close.
     wftac.

     edestruct H0.
     eauto.
     apply filter_In in H3.
     intuition.
     specialize (A2_wf b0 x0).
     apply well_formed_val_exists in A2_wf.
     destruct A2_wf.
     econstructor.
     eapply filter_In.
     intuition.
     eapply getSupport_In_Seq.
     eauto.
     eapply getSupport_In_Seq.
     eauto.
     simpl.
     intuition.
     simpl.
     trivial.

     eapply expRat_leRat_compat.
     eapply leRat_trans.
     2:{
      eapply H1.
      eauto.
     }
     comp_inline_l.
     comp_skip.
     inline_first.
     comp_irr_l.
     simpl.
     intuition.
  Qed.

  Definition DM_RC_G4(c : A -> Comp B) :=
     [a, s_A] <-$2 A1;
     allB <-$ compMap _ (fun _ => (c a)) (forNats n);
     allB_G <-$ compMap _ (fun b => g <-$ (A2 s_A b); ret (b, g)) allB;
     ret hd_error (map (fun x => snd x) (filter (fun p => P (fst p)) allB_G)).

  Theorem DM_RC_G4_equiv :
     forall c x,
     evalDist (DM_RC_G3 c) x == evalDist (DM_RC_G4 c) x.

     intuition.
     unfold DM_RC_G3, DM_RC_G4.
     comp_skip.
     symmetry.
     comp_simp.
     rewrite <- evalDist_assoc; intuition.
     comp_skip.
     eapply comp_spec_eq_impl_eq.
     eapply (@compMap_fission_eq _ _ _ _ _ _ _ _ _ _ _ _ eq); intuition.
     simpl.
     eapply comp_spec_eq_refl.

     subst.
     simpl.
     eapply eq_impl_comp_spec_eq.
     intuition.
     comp_at comp_inline rightc 1%nat.
     comp_swap_r.
     inline_first.
     comp_skip.
     comp_skip.
     comp_simp.
     intuition.
   Qed.

   Definition DM_RC_G5(c : A -> Comp B) :=
     [a, s_A] <-$2 A1;
     allB <-$ compMap _ (fun _ => (c a)) (forNats n);
     allG <-$ compMap _ (A2 s_A) (filter P allB);
     ret hd_error allG.

   Theorem DM_RC_G5_equiv :
     forall (c : A -> Comp B) x,
       evalDist (DM_RC_G4 c) x ==
     evalDist (DM_RC_G5 c) x.

     intuition.
     unfold DM_RC_G4, DM_RC_G5.
     comp_skip.
     comp_simp.
     comp_skip.
     symmetry.
     eapply eqRat_trans.
     comp_skip.
     eapply compMap_filter.
     intuition.
     eapply eqRat_refl.
     inline_first.
     comp_skip.

     dist_compute.
   Qed.

   Definition DM_RC_G6(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    opt_b' <-$ (
             b <-$ compMap B_EqDec (fun _ : nat => (c a)) (forNats n);
             ret head (filter P b));
    match opt_b' with
      | Some b' => A2 s_A b'
      | None => ret false
    end.

   Theorem DM_RC_G6_equiv :
     forall (c : A -> Comp B),
       evalDist (DM_RC_G5 c) (Some true) ==
     evalDist (DM_RC_G6 c) true.

     unfold DM_RC_G5, DM_RC_G6.
     intuition.
     comp_skip.
     comp_simp.
     inline_first.
     comp_skip.
     rewrite compMap_head.
     comp_simp.
     destruct (hd_error (filter P x)).
     symmetry.
     rewrite <- evalDist_right_ident.
     comp_skip.
     dist_compute.
     dist_compute.
     intuition.

     Unshelve.
     intuition.

   Qed.

   Definition DM_RC_B2 s_A (b : list B) :=
    core_b <- filter P b;
    opt_b' <- head core_b;
    match opt_b' with
        | None => ret false
        | Some b' => A2 s_A b'
    end.

  Theorem DistMult_G_equiv :
    forall c,
      Pr[DM_RC_G6 c] == Pr[DistMult_G _ A1 DM_RC_B2 n c] .

    intuition.
    unfold DistMult_G, DM_RC_G6, DM_RC_B2.
    comp_skip.
    comp_simp.
    inline_first.
    comp_skip.
  Qed.

  Variable k1 : Rat.
   Hypothesis c1_fail_prob :
     forall a s_A, In (a, s_A) (getSupport A1) -> Pr[b <-$ c1 a; ret (negb (P b))] <= k1.
   Variable k2 : Rat.
   Hypothesis c2_fail_prob :
     forall a s_A, In (a, s_A) (getSupport A1) -> Pr[b <-$ c2 a; ret (negb (P b))] <= k2.

  Theorem DistMult_impl_RepeatCore :
    RepeatCore_Adv P c1 c2 A1 A2 <=
    DistMult_Adv _ c1 c2 A1 DM_RC_B2 n +
    expRat k1 n +
    expRat k2 n.

    unfold RepeatCore_Adv, DistMult_Adv.
    repeat rewrite DM_RC_G1_equiv.
    repeat rewrite DM_RC_G2_equiv.

    eapply leRat_trans.
    eapply ratDistance_le_trans.
    eapply DM_RC_G2_G3_close; intuition.
    eauto.
    rewrite ratDistance_comm.
    eapply ratDistance_le_trans.
    eapply DM_RC_G2_G3_close; intuition.
    eauto.
    repeat rewrite DM_RC_G4_equiv.
    repeat rewrite DM_RC_G5_equiv.
    repeat rewrite DM_RC_G6_equiv.
    repeat rewrite DistMult_G_equiv.
    eapply leRat_refl.

    rewrite <- ratAdd_assoc.
    rewrite ratAdd_comm.
    rewrite <- ratAdd_assoc.
    rewrite ratDistance_comm.
    intuition.

    intuition.
    intuition.
    intuition.
    intuition.

  Qed.

End DistMult_impl_RepeatCore.

Section TrueSingle_impl_Mult.

  Variable A B : Set.
  Hypothesis B_EqDec : EqDec B.
  Variable c : A -> Comp B.
  Variable A1 : Comp A.
  Variable Q : B -> bool.

  Definition TrueSingle_G :=
    a <-$ A1;
    b <-$ c a;
    ret (Q b).

  Variable n : nat.

  Definition TrueMult_G :=
    a <-$ A1;
    bs <-$ compMap _ (fun _ => (c a)) (forNats n);
    ret (fold_left (fun b x => b || (Q x)) bs false).

  Theorem TrueSingle_impl_Mult :
    Pr[TrueMult_G] <= (n / 1) * Pr[TrueSingle_G].

    unfold TrueMult_G, TrueSingle_G.

    simpl in *.

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      eapply sumList_factor_constant_l.
    }
    eapply sumList_le.
    intuition.

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      symmetry.
      rewrite ratMult_comm.
      eapply ratMult_assoc.
    }
    eapply ratMult_leRat_compat.
    intuition.

    specialize (@compMap_Q_eq_compFold _ _ Q n (c a) false); intuition.
    rewrite H0.
    rewrite prob_sum_le_mult.
    rewrite ratMult_comm.
    eapply ratMult_leRat_compat; intuition.

    Local Transparent evalDist.
    simpl.
    reflexivity.

  Qed.

End TrueSingle_impl_Mult.

Section TrueMult_impl_Repeat.

  Variable A B : Set.
  Hypothesis eqdb : EqDec B.
  Variable A1 : Comp A.
  Hypothesis A1_wf :
    well_formed_comp A1.
  Variable c : A -> Comp B.
  Variable f P : B -> bool.

  Hypothesis c_wf :
    forall x, In x (getSupport A1) -> well_formed_comp (c x).

  Hypothesis Repeat_c_terminating :
    forall x, In x (getSupport A1) ->
              exists x1 : B, In x1 (filter P (getSupport (c x))).

  Definition TrueRepeat_G :=
    a <-$ A1;
    b <-$ Repeat (c a) P;
    ret (f b).

  Variable n : nat.
  Variable failProb : Rat.
  Hypothesis failProb_correct :
    forall (a : A),
      In a (getSupport A1) ->
      Pr[x <-$ c a; ret negb (P x)] <= failProb.

  Definition TrueRepeat_G1 :=
    a <-$ A1;
    bs <-$ compMap _ (fun _ => c a) (forNats n);
    b_opt <- hd_error (filter P bs);
    b' <-$ Repeat (c a) P;
    b <- match b_opt with
           | None => b'
           | Some x => x
         end;
    ret (f b).

   Theorem  TrueRepeat_G_G1_equiv :
     Pr[ TrueRepeat_G] == Pr[TrueRepeat_G1].

     unfold TrueRepeat_G, TrueRepeat_G1.
     inline_first.
     comp_skip.

     assert (Pr  [b <-$ Repeat (c x) P; ret f b ] ==
             Pr  [b <-$ (y <-$ compMap _ (fun _ => (c x)) (forNats n);
                   match (hd_error (filter P y)) with
                     | None => Repeat (c x) P
                     | Some z => ret z
                   end); ret f b ]).

     comp_skip.
     eapply Repeat_unroll_n.
     eauto.
     eauto.

     rewrite H0.
     clear H0.
     inline_first.
     comp_skip.
     case_eq (hd_error (filter P x0)); intuition.
     comp_irr_r.
     edestruct Repeat_c_terminating; eauto.
     eapply well_formed_Repeat.
     unfold eq_dec.
     intuition.
     eapply (EqDec_dec _).
     eauto.
     eauto.

     reflexivity.

   Qed.

   Definition TrueRepeat_G2 :=
     a <-$ A1;
     bs <-$ compMap _ (fun _ => c a) (forNats n);
     b_opt <- hd_error (filter P bs);
     b' <-$ Repeat (c a) P;
     b <- match b_opt with
           | None => b'
           | Some x => x
          end;
     ret (f b, if b_opt then false else true).

   Theorem TrueRepeat_G1_G2_equiv :
     Pr [TrueRepeat_G1] <= Pr[x <-$ TrueRepeat_G2; ret (fst x || snd x)].

     unfold TrueRepeat_G1, TrueRepeat_G2.
     repeat (inline_first; comp_skip).
     destruct (hd_error (filter P x0)).
     comp_simp.
     dist_compute.
     rewrite e in n0.
     simpl in *.
     intuition.
     eapply rat0_le_all.

     comp_simp.
     dist_compute.
     rewrite e in n0.
     simpl in *.
     intuition.
     eapply rat0_le_all.

   Qed.

   Definition TrueRepeat_G3 :=
     a <-$ A1;
     bs <-$ compMap _ (fun _ => c a) (forNats n);
     b_opt <- hd_error (filter P bs);
     b' <-$ Repeat (c a) P;
     b <- match b_opt with
           | None => b'
           | Some x => x
          end;
     ret (fold_left (fun b x => b || (f x)) bs false, if b_opt then false else true).

   Theorem TrueRepeat_G2_G3_equiv :
     Pr[x <-$ TrueRepeat_G2; ret (fst x || snd x)] <=
     Pr[x <-$ TrueRepeat_G3; ret (fst x || snd x)].

     unfold TrueRepeat_G2, TrueRepeat_G3.
     repeat (inline_first; comp_skip).
     comp_simp.
     eapply comp_spec_impl_le.
     eapply
       comp_spec_ret.
     simpl.

     case_eq ( hd_error (filter P x0)); intuition.
     rewrite orb_false_r in *.

     eapply fold_left_orb_true_in.
     eapply filter_In.

     eapply hd_error_Some_In.
     eauto.
     trivial.

   Qed.

   Definition TrueRepeat_G3_bad :=
      a <-$ A1;
     compFold _ (fun b _ => x <-$ c a; ret b && negb (P x)) true (forNats n).

   Theorem G3_TrueMult_equiv :
     Pr[x <-$ TrueRepeat_G3; ret (fst x)] ==
     Pr[TrueMult_G _ c A1 f n].

     unfold TrueRepeat_G3, TrueMult_G.
     inline_first.
     comp_skip.
     inline_first.
     comp_skip.
     inline_first.
     comp_irr_l.
     edestruct Repeat_c_terminating; eauto.
     eapply well_formed_Repeat.
     unfold eq_dec; intuition.
     eapply (EqDec_dec _).
     eauto.
     eauto.

     simpl.
     intuition.
   Qed.

   Theorem TrueRepeat_G1_bad_equiv :
      Pr  [x <-$ TrueRepeat_G3; ret snd x ] ==
      Pr[TrueRepeat_G3_bad].

     unfold TrueRepeat_G3, TrueRepeat_G3_bad.

     inline_first.
     comp_skip.

     assert(
         Pr
   [x0 <-$
    (bs <-$ compMap eqdb (fun _ : nat => c x) (forNats n);
     _ <-$ Repeat (c x) P;
     ret (fold_left (fun (b : bool) (x0 : B) => b || f x0) bs false,
         if hd_error (filter P bs) then false else true));
    ret snd x0 ]
   ==
   Pr
   [x0 <-$
    (_ <-$ Repeat (c x) P;
      bs <-$ compMap eqdb (fun _ : nat => c x) (forNats n);

     ret (fold_left (fun (b : bool) (x0 : B) => b || f x0) bs false,
         if hd_error (filter P bs) then false else true));
    ret snd x0 ]
   ).

     comp_skip.
     comp_swap_r.
     comp_skip.
     rewrite H0.
     clear H0.

     inline_first.
     comp_irr_l.
     edestruct Repeat_c_terminating.
     eauto.
     eapply well_formed_Repeat.
     unfold eq_dec; intuition.
     eapply (EqDec_dec _).
     eauto.
     eauto.

     assert (
         Pr
   [x1 <-$
    (bs <-$ compMap eqdb (fun _ : nat => c x) (forNats n);
     ret (fold_left (fun (b : bool) (x1 : B) => b || f x1) bs false,
         if hd_error (filter P bs) then false else true));
    ret snd x1 ]
   ==
   Pr
   [bs <-$ compMap eqdb (fun _ : nat => c x) (forNats n);
     ret (fold_left (fun b z => b && negb (P z)) bs true)]
   ).

     inline_first.
     comp_skip.
     eapply comp_spec_eq_impl_eq.
     simpl.
     eapply comp_spec_ret.

     eapply hd_filter_false_eq_and_false.

     rewrite H1.
     clear H1.

     symmetry.
     eapply comp_spec_eq_impl_eq.
     eapply comp_spec_eq_trans.
     eapply fold_map_fission_spec_eq.
     intros.
     eapply comp_spec_eq_refl.
     comp_skip.

     eapply compFold_ret_eq.

   Qed.

   Theorem TrueRepeat_G2_bad_small :
      Pr[TrueRepeat_G3_bad] <= expRat failProb n.

      unfold TrueRepeat_G3_bad.
      comp_irr_l.

      rewrite prob_fold_and_eq_exp.
      eapply expRat_leRat_compat.
      intuition.
    Qed.

   Theorem TrueRepeat_G3_eq_sum :
     Pr[x <-$ TrueRepeat_G3; ret (fst x || snd x)] <=
     Pr[TrueMult_G _ c A1 f n] + expRat failProb n.

     rewrite  evalDist_orb_le.
     rewrite G3_TrueMult_equiv.
     rewrite TrueRepeat_G1_bad_equiv .
     rewrite TrueRepeat_G2_bad_small.
     intuition.
   Qed.

    Theorem TrueMult_impl_Repeat :
      Pr[TrueRepeat_G] <=
      Pr[TrueMult_G _ c A1 f n] + (expRat failProb n).

      rewrite TrueRepeat_G_G1_equiv.
      rewrite TrueRepeat_G1_G2_equiv.
      rewrite TrueRepeat_G2_G3_equiv.
      eapply TrueRepeat_G3_eq_sum.

    Qed.

End TrueMult_impl_Repeat.


Require Export BoilerplateFunctions.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _  => True
    | tabs _   => True
    | prod x y => Value x ∧ Value y
    | _        => False
  end.

Inductive Match : Pat → Tm → Tm → Tm → Prop :=
  | M_Var {v t} :
      Match pvar v t (substTm sub_here v t)
  | M_Prod {p1 p2 v1 v2 t t' t''} :
      Match p2 (weakenTm v2 (bindPat p1)) t t' →
      Match p1 v1 t' t'' →
      Match (pprod p1 p2) (prod v1 v2) t t''.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm sub_here t2 t12)
  | tapptabs {T2 t11} :
      red (tapp (tabs t11) T2) (tsubstTm 0 T2 t11)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2)
  | prodl {t1 t1' t2} :
      red t1 t1' → red (prod t1 t2) (prod t1' t2)
  | prodr {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (prod t1 t2) (prod t1 t2')
  | lettp {p t1 t1' t2} :
      red t1 t1' → red (lett p t1 t2) (lett p t1' t2)
  | lettv {p t1 t3 t2} :
      Value t1 → Match p t1 t2 t3 → red (lett p t1 t2) t3.

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive PTyping (Γ: Env) : Pat → Ty → Ext → Prop :=
  | P_Var {T} (wT: wfTy Γ T) :
      PTyping Γ pvar T (exvar exempty T)
  | P_Prod {p1 p2 T1 T2 Δ1 Δ2} :
      PTyping Γ p1 T1 Δ1 →
      PTyping (extend Γ Δ1) p2 T2 Δ2 →
      PTyping Γ (pprod p1 p2) (tprod T1 T2) (append Δ1 Δ2).

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Abs {t T1 T2} (wf_T1: wfTy Γ T1) :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_Tabs {t T} :
      Typing (etvar Γ) t T → Typing Γ (tabs t) (tall T)
  | T_Tapp {t1 T12 T2} :
      Typing Γ t1 (tall T12) → wfTy Γ T2 →
      Typing Γ (tapp t1 T2) (tsubstTy 0 T2 T12)
  | T_Prod {t1 T1 t2 T2} :
      Typing Γ t1 T1 → Typing Γ t2 T2 →
      Typing Γ (prod t1 t2) (tprod T1 T2)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (extend Γ Δ) t2 T2 →
      Typing Γ (lett p t1 t2) T2.