From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import reals classical_sets boolp.
From mathcomp Require Import zify algebra_tactics.ring.
Require Import tactics mathcomp_extras point_topo.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Open Scope classical_set_scope.
Open Scope real_scope.

Section Arrangement.
Variables R : realType.
(* d : dimension of the space.
 * n : number of hyperplanes in the arrangement. *)
Variables (d n : nat).
Hypothesis gt_d1 : d > 1.

Notation point := 'M[R]_(1, d).
(* We create the hyperplane subtype of square matrices *)
Record hplane := Hplane { M :> 'M[R]_(d, d) ; _ : \rank M == d.-1 }.
Canonical hplane_subType := [subType for M].

Lemma hplane_rank (h: hplane) : \rank h = d.-1.
Proof. by apply /eqP ; case: h. Qed.

Variables (H : n.-tuple hplane).

(* A sign represents which side of a hyperplane a point is *)
Inductive sign := Left | On | Right.

Definition I3_of_sign (s : sign) : 'I_3 :=
  match s with Left => inord 0 | On => inord 1 | Right => inord 2 end.
Definition sign_of_I3 (i : 'I_3) : sign :=
  match val i with 0 => Left | 1 => On | _ => Right end.
Lemma I3_of_signK : cancel I3_of_sign sign_of_I3.
Proof. by case ; rewrite /I3_of_sign /sign_of_I3 /= inordK. Qed.

Definition sign_eqMixin := CanEqMixin I3_of_signK.
Canonical sign_eqType := EqType sign sign_eqMixin.
Definition sign_choiceMixin := CanChoiceMixin I3_of_signK.
Canonical sign_choiceType := ChoiceType sign sign_choiceMixin.
Definition sign_countMixin := CanCountMixin I3_of_signK.
Canonical sign_countType := CountType sign sign_countMixin.
Definition sign_finMixin := CanFinMixin I3_of_signK.
Canonical sign_finType := FinType sign sign_finMixin.

Lemma rank_hplaneC (h : hplane) : \rank h^C%MS = 1.
Proof. by rewrite mxrank_compl hplane_rank ; lia. Qed.

Definition hside (x : point) (h : hplane) : sign :=
  let v := row_base h^C%MS in
  let t : R := (mulmx x v^T) ord0 ltac:(rewrite rank_hplaneC ; exact: ord0) in
  if (t == 0)%R then On
  else if (t > 0)%R then Right
  else Left.

(* The set of points in the row-space of M *)
Definition Mpoints k (M : 'M[R]_(k, d)) : set point := [set x | (x <= M)%MS ].
(* The set of points Left/On/Right of a hyperplane *)
Definition hpoints s h : set point := [set x | hside x h == s ].

Lemma hsideE x h : hside x h == On <-> (x <= h)%MS.
Proof.
  split => sub_xh ; last first.
  - remember (row_base h^C%MS) as V.
    remember ((x *m V^T) ord0 (eq_rect_r [eta ordinal] ord0 (rank_hplaneC h)))%R as t.
    suff: t = 0%R => [eq_t0|].
      by rewrite /hside ; case: ifP => // /negbT ; case: ifP => [|/negbT] ; rewrite -HeqV -Heqt eq_t0 eqxx.
Admitted.

Lemma hpoints_On h : hpoints On h = Mpoints h.
Proof. by rewrite /hpoints /Mpoints eqEsubset ; split => x /= ; rewrite hsideE. Qed.

Lemma Mpoints_id : Mpoints 1%:M = setT.
Proof. by rewrite -subTset /subset /Mpoints => x _ /= ; apply submx1. Qed.

Lemma Mpoints_cap2 (A B : 'M[R]_d) : Mpoints (A :&: B)%MS = Mpoints A `&` Mpoints B.
Proof. by rewrite /Mpoints eqEsubset ; split => x /= ; rewrite sub_capmx ; move=> /andP. Qed.

Lemma Mpoints_cap m (P : set 'I_m) (F : 'I_m -> 'M[R]_d) :
  Mpoints (\bigcap_(i in P) F i)%MS = \bigcap_(i in P) Mpoints (F i).
Proof.
  elim /finset_ind : P => [|i0 P NPi0 IH].
    under eq_bigl => i do rewrite in_set0.
    by rewrite big_pred0 // Mpoints_id ; symmetry ; rewrite -subTset /bigcap => x /=.
  rewrite bigcap_setU1 -IH -Mpoints_cap2 ; f_equal.
  rewrite (bigID (xpred1 i0)) /= ; congr (_ :&: _)%MS.
  - under eq_bigl => i. rewrite andb_idl => [|/eqP->]. over.
      by rewrite in_setE /= ; intuition.
    by rewrite big_pred1_eq.
  - have cond i : (i \in i0 |` P) && (i != i0) = (i \in P).
      apply /eqP ; rewrite eqE /= /eqb /addb ; case: ifP => [|/negbT].
      + rewrite negb_and => /orP[] ; last by rewrite negbK => /eqP->.
        by apply contra ; rewrite !in_setE /= ; intuition.
      + rewrite negbK => /andP[] ; rewrite !in_setE /= => [[->|//]].
        by rewrite eqxx.
    by under eq_bigl do rewrite cond.
Qed.

Definition face := n.-tuple sign.
Definition fpoints (f : face) : set point :=
  \bigcap_i hpoints (tnth f i) (tnth H i).
Definition clfpoints (f : face) : set point :=
  \bigcap_i (hpoints (tnth f i) (tnth H i) `|` hpoints On (tnth H i)).
Definition nempty (f : face) : Prop := fpoints f !=set0.

Lemma fpointsP f x :
  reflect (forall i, hside x (tnth H i) = tnth f i) (x \in fpoints f).
Proof.
  apply (iffP idP) ; rewrite /fpoints /bigcap in_setE /= => P i.
  - by move: (P i I) ; rewrite /hpoints /= => /eqP.
  - by rewrite /hpoints /= P.
Qed.

Lemma clfpointsP f x :
  reflect (forall i, hside x (tnth H i) = tnth f i \/ hside x (tnth H i) = On)
    (x \in clfpoints f).
Proof.
  apply (iffP idP) ; rewrite /clfpoints /bigcap in_setE /= => P i.
  - by move: (P i I) ; rewrite /hpoints /= ; move=> [/eqP->|/eqP->] ; auto.
  - by rewrite /hpoints /= ; case: (P i) => -> ; auto.
Qed.

Lemma eqEfpoints f f' : nempty f -> (f == f') = (fpoints f == fpoints f').
Proof.
  move=> [x fx].
  apply is_true_inj, propext ; split => [/eqP-> //|/eqP points_ff'].
  Search eq tnth in tuple.
  apply /eqP ; apply eq_from_tnth => i.
  move: (fx) ; rewrite -in_setE => /fpointsP /(_ i) <-.
  by apply /fpointsP ; rewrite in_setE -points_ff'.
Qed.

Definition dim f : nat := infimum 0 (mxrank @` [set M : 'M[R]_d | fpoints f `<=` Mpoints M]).

Lemma dim_led f : dim f <= d.
Proof.
  apply inf_le ; exists d => //= ; exists 1%:M%R ; last by rewrite mxrank1.
  by rewrite /Mpoints ; under eq_set do rewrite submx1 /=.
Qed.

(* This would be the most natural definition of a subface :
Definition subfaceT f g :=
  (dim g = (dim f).+1) /\ (fpoints f `<=` closure (fpoints g)).
 * And we would prove something like the following lemma to obtain a simpler definition :
Lemma clfpointsE g : nempty g -> closure (fpoints g) `<=>` clfpoints g.
 * However this definition would require us to provide a topologicalType
 * on matrices of reals, and then manipulate the closure operation,
 * which is defined with filters. *)

(* This is a more convenient definition of subface : we will only work with this one. *)
Inductive subface f g : Prop :=
  Subface of nempty f & nempty g & fpoints f `<=` clfpoints g & dim g = (dim f).+1.

Lemma face_inclP f g : nempty f ->
  reflect (fpoints f `<=` clfpoints g) [forall i, (tnth f i == On) || (tnth f i == tnth g i)].
Proof.
  move=> NE_f ; apply (iffP idP) => [/forallP P x|].
  - rewrite -in_setE => /fpointsP Hf.
    rewrite -in_setE ; apply /clfpointsP => i.
    by rewrite Hf ; case: (orP (P i)) => /eqP ; intuition.
  - move: NE_f => [x fx] /(_ x fx) Hg ; apply /forallP => i.
    move: fx ; rewrite -in_setE => /fpointsP /(_ i) Hf.
    move: Hg ; rewrite -in_setE => /clfpointsP /(_ i).
    by rewrite Hf ; move=> [->|->] ; rewrite eqxx ?orbT ?orTb.
Qed.

Lemma fpoints_onNon f :
  let P := [set i | tnth f i == On] in
  fpoints f =
    Mpoints (\bigcap_(i in P) tnth H i)%MS `&`
    \bigcap_(i in ~`P) hpoints (tnth f i) (tnth H i).
Proof.
  remember [set i | tnth f i == On] as P => /=.
  rewrite /fpoints [in LHS](bigcapID P) !setTI ; congr (_ `&` _).
  under eq_bigcapr => i do [rewrite [in P i]HeqP /= => /eqP-> ; rewrite hpoints_On].
  by rewrite Mpoints_cap.
Qed.

(* calculates the orthogonal space of M *)
(*Definition orthoM (M : 'M[R]_d) : 'M[R]_d := *)

Lemma openS_Non_hplane (h : hplane) s : s != On -> openS (hpoints s h).
Proof.
  rewrite /openS /openS_near => Non x shx.
  pose V := h^C%MS.
  move: (@add_proj_mx _ _ _ h V x) => decomp ; feed_n 2 decomp.
    by rewrite /V capmx_compl.
    by apply submx_full, addsmx_compl_full.

Admitted.

Lemma openS_Non (f : face) :
  let P := [set i | tnth f i == On] in
  openS (\bigcap_(i in ~`P) hpoints (tnth f i) (tnth H i)).
Proof. by apply openS_cap => i /= /negP ; apply openS_Non_hplane. Qed.

Lemma Mhcap_rank_lb (h : hplane) (M : 'M[R]_d) :
  \rank (M :&: h) >= \rank M - 1.
Proof. by move: (mxrank_sum_cap M h) (rank_leq_col (M + h)%MS) ; rewrite hplane_rank ; lia. Qed.

Lemma Mhcap_rank_eq (h : hplane) (M : 'M[R]_d) :
  \rank M = \rank (M :&: h) + ~~(M <= h)%MS.
Proof.
  (case E: (M <= h)%MS ; move: E) => [/idP /capmx_idPl /eqmxP /eqmx_rank->|/negbT NS_Mh] /= ; try lia.
  apply /eqP ; move: NS_Mh ; apply contraR.
  have /orP : (\rank (M :&: h) == \rank M) || (\rank (M :&: h) + 1 == \rank M).
    suff: \rank M - 1 <= \rank (M :&: h) <= \rank M ; [lia|].
    by rewrite Mhcap_rank_lb /= ; apply mxrankS, capmxSl.
  case => [rMhM _ | /eqP] ; last by lia.
  apply /capmx_idPl /eqmxP /andP ; split ; first by apply capmxSl.
  by rewrite -mxrank_leqif_sup // capmxSl.
Qed.

Lemma hplane_cap_lb (P : set 'I_n) : \rank (\bigcap_(i in P) tnth H i) >= d - #|P|.
Proof.
  elim: n P H => [|n0 IH] P0 H0.
    by rewrite big_ord0 mxrank1 ; lia.
  unlock index_enum ; rewrite /= -enumT mathcomp_extra.enum_ordS.
  rewrite -cats1 big_cat /= big_map [in X in _ <= \rank (_ :&: X)]big_mkcond big_seq1 /=.
  pose H1 := [tuple tnth H0 (widen_ord (leqnSn n0) i) | i < n0].
  have H1i i : tnth H1 i = tnth H0 (widen_ord (leqnSn n0) i).
    by rewrite /H1 tnth_mktuple.
  pose P1 := [set i | widen_ord (leqnSn n0) i \in P0].
  have P1i i : i \in P1 = (widen_ord (leqnSn n0) i \in P0).
    by apply is_true_inj ; rewrite /P1 !in_setE /= !in_setE.
  case: ifP ; [rewrite -(leqRW (Mhcap_rank_lb _ _)) | rewrite capmx1] ;
  under eq_big => [i|i Pi] do [rewrite -P1i|rewrite -H1i] ;
  move: (IH P1 H1) ; unlock index_enum ; rewrite /= -enumT => IH1 OmP0 ; rewrite -(leqRW IH1) ;
  apply eq_leq ; [rewrite -subnDA|] ; congr (_ - _) ;
  rewrite /P1 !card_set_sum big_ord_recr OmP0 /= ; [congr (_ + _) | rewrite addn0] ;
  by apply eq_big => [//|i _] ; f_equal ; apply is_true_inj ; rewrite !in_setE /= in_setE.
Qed.

Lemma submx_lin (x y : point) (l : R) (M : 'M[R]_d) :
  ((x + l%:M *m y)%R <= M)%MS -> (l > 0)%R -> (x <= M)%MS -> (y <= M)%MS.
Proof.
  move=> xlyM lt_0l xM.
  have lyM : ((l%:M *m y)%R <= M)%MS.
    rewrite -[(l%:M *m y)%R]GRing.add0r -(GRing.subrr x).
    rewrite -GRing.addrAC.
    by apply addmx_sub ; rewrite // -GRing.scaleN1r ; apply scalemx_sub.
  rewrite -[y](@GRing.scalerK _ _ l).
  - by rewrite -!mul_scalar_mx ; apply mulmx_sub.
  - by apply Num.Theory.lt0r_neq0.
Qed.

Lemma dimE f :
  nempty f -> dim f = \rank \bigcap_(i | tnth f i == On) tnth H i.
Proof.
  have cond i : (tnth f i == On) = (i \in [set i | tnth f i == On]).
    by apply is_true_inj ; rewrite in_setE /=.
  under eq_bigl do rewrite cond.
  move=> NEf.
  apply /eqP ; rewrite eqn_leq ; apply /andP ; split ; last first.
  - apply inf_ge ; last first.
      by apply image_nonempty ; exists 1%:M%R => /= ; rewrite Mpoints_id ; apply subsetT.
    move=> r /= [M points_fM <-] ; move: NEf (@openS_Non f) points_fM.
    rewrite /nempty /openS fpoints_onNon.
    remember ([set i | tnth f i == On]) as P ; rewrite -?HeqP.
    remember (\bigcap_(i in P) tnth H i)%MS as K ; rewrite -?HeqK.
    remember (\bigcap_(i in ~`P) hpoints (tnth f i) (tnth H i)) as S ; rewrite -?HeqS.
    move=> [x /= [Kx Sx]] /in_setP/(_ x Sx) O_Sx KSM ; rewrite /Mpoints /= in Kx.
    have KiM : forall i, row i K \in Mpoints M => [i|].
      move: (openS_near_scale (row i K) O_Sx) => [l lt_0l S_x_lKi].
      have K_x_lKi : (x + l%:M *m row i K)%R \in Mpoints K.
        by rewrite inE /Mpoints /= ; apply addmx_sub => // ;
        apply mulmx_sub ; apply row_sub.
      have M_x_lKi : (x + l%:M *m row i K)%R \in Mpoints M ; [|clear K_x_lKi S_x_lKi].
        rewrite -Csubset1 ; apply (@subset_trans _ (Mpoints K `&` S)) => // ; rewrite Csubset1.
        rewrite in_setI ; apply /andP ; split ; [apply K_x_lKi|rewrite inE ; apply S_x_lKi].
      have Mx : x \in Mpoints M.
        rewrite -Csubset1 ; apply (@subset_trans _ (Mpoints K `&` S)) => // ; rewrite Csubset1.
        rewrite in_setI ; apply /andP ; split ; rewrite inE ?/Mpoints //=.
      rewrite !inE /Mpoints /= in M_x_lKi Mx * ; apply (@submx_lin x _ l) => //.
    have KM : (K <= M)%MS.
      by apply /row_subP => i ; move: (KiM i) ; rewrite inE /Mpoints /=.
    by apply mxrankS.
  - apply inf_le ; rewrite fpoints_onNon.
    remember ([set i | tnth f i == On]) as P ; rewrite -?HeqP.
    remember (\bigcap_(i in P) tnth H i)%MS as K ; rewrite -?HeqK.
    by exists (\rank K) => //= ; exists K.
Qed.

Lemma fdim_lb (f : face) : nempty f -> dim f >= d - count (xpred1 On) f.
Proof.
  move=> NEf ; rewrite dimE //.
  have cond i : (tnth f i == On) = (i \in [set i | tnth f i == On]).
    by apply is_true_inj ; rewrite in_setE /=.
  under eq_bigl do rewrite cond.
  by rewrite -card_set_count hplane_cap_lb.
Qed.

Lemma subface_exist g : nempty g -> dim g > 0 -> exists f, subface f g.
Proof. Admitted.

Lemma face_Ofg_reduce f g i0 :
  let Of := [set j | (tnth f j == On) && (tnth g j != On)] in
  let Og := [set j | tnth g j == On] in
  subface f g -> i0 \in Of ->
  (\bigcap_(i in Of `|` Og) tnth H i == \bigcap_(i in i0 |` Og) tnth H i)%MS.
Proof.
  pose Of := [set j | (tnth f j == On) && (tnth g j != On)].
  pose Og := [set j | tnth g j == On].
  rewrite /= -/Og -/Of => sub_fg Of_i0.
  rewrite -(mxrank_leqif_eq _) ; last first.
    by apply mxbigcap_sub => i ; move: Of_i0 ; rewrite !in_setE /= => [+ [->|]] ; intuition.
  have -> : \rank (\bigcap_(i in Of `|` Og) tnth H i) = dim f.
    rewrite dimE ; [f_equal ; apply eq_bigl => i | by case: sub_fg].
    apply is_true_inj ; rewrite in_setE /Og /Of /= ; apply propext ; split ; last first.
      move=> -> /= ; case: (tnth g i =P On) ; intuition.
    case => [/andP[->] //|].
    case: sub_fg => NE_f _ /face_inclP /forallP Hfg _.
    by case: (orP (Hfg NE_f i)) => [|/eqP->].
  rewrite (eqmxP (mxbigcap1U _ _)) ; last first.
    by move: Of_i0 ; rewrite /Of /Og in_setE /= notin_set /= => /andP[_ /negP].
  have Rg : \rank (\bigcap_(i in Og) tnth H i)%MS = dim g.
    rewrite dimE ; [f_equal ; apply eq_bigl => i | by case: sub_fg].
    by apply is_true_inj ; rewrite in_setE /Og /=.
  suff Nsub : ~~ (\bigcap_(i in Og) tnth H i <= tnth H i0)%MS.
    move: (Mhcap_rank_eq (tnth H i0) (\bigcap_(i in Og) tnth H i)%MS).
    by rewrite Rg Nsub /= capmxC ; case: sub_fg => _ _ _ ; lia.
  move: Of_i0 ; rewrite in_setE /Of /= ; apply contraL ; rewrite negb_and negbK.
  have [x /[dup] gx] : nempty g by case: sub_fg.
  rewrite fpoints_onNon /Mpoints /= -/Og => [[sub1 _]] sub2.
  have {sub1} {sub2} /hsideE : (x <= tnth H i0)%MS by eapply submx_trans ; eauto.
  by move: gx ; rewrite -in_setE => /fpointsP /(_ i0) -> ; intuition.
Qed.

Lemma face_Ofg_sub f g :
  let Of := [set j | (tnth f j == On) && (tnth g j != On)] in
  let Og := [set j | tnth g j == On] in
  subface f g ->
  (fpoints f `<=` Mpoints (\bigcap_(i in Of `|` Og) tnth H i)%MS).
Proof.
  pose Of := [set j | (tnth f j == On) && (tnth g j != On)].
  pose Og := [set j | tnth g j == On].
  rewrite /= fpoints_onNon -/Og -/Of => sub_fg.
  have cond i : i \in Of `|` Og = (i \in [set j | tnth f j == On]).
    apply is_true_inj ; rewrite !in_setE /Of /Og /= ; apply propext ; split ; last first.
      by move=> -> /= ; case: (tnth g i =P On) ; intuition.
    case => [/andP[->] //|].
    case: sub_fg => NE_f _ /face_inclP /forallP Hfg _.
    by case: (orP (Hfg NE_f i)) => [|/eqP->].
  by under eq_bigl do rewrite cond ; apply subIsetl.
Qed.

(* With On(f) = [set i | f i = On], this lemma says that
 * the sets (On(f) \ On(g)) when f ranges over the subfaces of g are disjoint *)
Lemma subfaces_disjoint f f' g i :
  subface f g -> subface f' g ->
  tnth f i == On -> tnth f' i == On -> tnth g i != On -> f = f'.
Proof.
  move=> sub_fg sub_f'g fi f'i gi.
  pose Of := [set j | (tnth f j == On) && (tnth g j != On)].
  pose Of' := [set j | (tnth f' j == On) && (tnth g j != On)].
  pose Og := [set j | tnth g j == On].
  apply eq_from_tnth => j.
  suff: j \in Of \/ j \in Of' -> tnth f j = tnth f' j.
    (case E: ((j \in Of) || (j \in Of')) ; move: E) => [/idP /orP|/negbT] ; first by intuition.
    rewrite negb_or -!in_setC /Of /Of' => /andP [+ +] _.
    rewrite !in_setE /= => /idP + /idP ; rewrite !negb_and !negbK => /orP H1 /orP H2.
    have Hfg : (tnth f j = On) \/ (tnth f j = tnth g j).
      case: sub_fg => NE_f _ /face_inclP fiP _ ; feed fiP ; first by [].
      by move: fiP => /forallP /(_ j) /orP[|] /eqP-> ; intuition.
    have Hf'g : (tnth f' j = On) \/ (tnth f' j = tnth g j).
      case: sub_f'g => NE_f' _ /face_inclP f'iP _ ; feed f'iP ; first by [].
      by move: f'iP => /forallP /(_ j) /orP[|] /eqP-> ; intuition.
    have HhOn : tnth g j == On -> tnth f j = tnth f' j.
      move=> /eqP H3 ; rewrite H3 in Hfg Hf'g.
      by case: Hfg ; case: Hf'g => -> ->.
    case: H1 ; case: H2 ; try auto.
    move=> /eqP + /eqP ; intuition ; last by eapply eq_trans ; eauto.
  wlog : f f' sub_fg sub_f'g fi f'i @Of @Of' / (j \in Of) => [|Ofj _].
    by move=> HW [|] Hj ; [|symmetry] ; eapply HW => // ; rewrite -/Of -/Of' ; intuition.
  have [x f'x] : nempty f' by case: sub_f'g.
  suff : hside x (tnth H j) == On.
    move: Ofj ; rewrite /Of in_setE /= => /andP[/eqP-> _] /eqP.
    by move: f'x ; rewrite -in_setE => /fpointsP /(_ j) -> ->.
  have Ofi : i \in Of by rewrite /Of in_setE /= ; apply /andP.
  have Of'i : i \in Of' by rewrite /Of' in_setE /= ; apply /andP.
  move: (face_Ofg_reduce sub_fg Ofi) (face_Ofg_reduce sub_f'g Of'i) ;
    rewrite -/Of -/Of' -/Og => /andP[_ Ofg_red] /andP[Of'g_red _].
  move: (face_Ofg_sub sub_f'g) ; rewrite -/Of' -/Og /Mpoints => /(_ x f'x) /= => x_Of'g.
  have: (x <= \bigcap_(i in (Of `|` Og)) tnth H i)%MS.
    eapply submx_trans ; first apply x_Of'g.
    eapply submx_trans ; first apply Of'g_red.
    by apply Ofg_red.
  move: (Ofj) => Ofj2 ; rewrite in_setE in Ofj2 ; apply setD1K in Ofj2 ; rewrite -Ofj2 -setUA.
  rewrite (eqmxP (mxbigcap1U _ _)) ; last first.
    rewrite notin_set /= => [[[]|]] //.
    move: Ofj ; rewrite in_setE /Og /Of /= => /andP[_] /[swap] /eqP->.
    by rewrite eqxx.
  by rewrite sub_capmx => /andP[/hsideE + _].
Qed.

Definition simple := \rank (\bigcap_(i : 'I_n) tnth H i) = 0.

(* I will likely not show this theorem, see "Algorithms in Combinatorial Geometry"
 * by Edelsbrunner, Theorem 1.3. *)
Theorem nempty_face_count (k : 'I_d.+1) :
  #|[set f | (dim f == k) && `[< nempty f >]]|
    <= \sum_(i < k.+1) 'C(d-i, k-i) * 'C(n, d-i)
    ?= iff `[< simple >].
Proof. Admitted.

Section SimpleArrangement.
(* Since I only study arrangements in which all hyperplanes
 * contain the origin, a simple arrangement can only have
 * at most d hyperplanes. To simplify I also suppose that n = d. *)
Hypothesis eq_nd : n = d.
Hypothesis sH : simple.

Lemma hplane_cap_eq (P : set 'I_n) :
  \rank (\bigcap_(i in P) tnth H i) = d - #|P|.
Proof.
  elim /finset_ind_rev : P => /= [|i0 P N_Px].
    by under eq_big do [rewrite in_setT|] ; rewrite sH card_setT /= card_ord ; lia.
  rewrite set1U_disj_card // (eqmx_rank (mxbigcap1U _ _)) //.
  remember (\bigcap_(i in P) tnth H i)%MS as M ; rewrite -HeqM => IH.
  suff: \rank M <= d - #|P|.
    move: (hplane_cap_lb P) ; rewrite -HeqM => LB UB.
    by apply /eqP ; rewrite eqn_leq UB LB.
  have MHi0C : (M :&: tnth H i0 == tnth H i0 :&: M)%MS by rewrite capmxC submx_refl.
  move: (Mhcap_rank_lb (tnth H i0) M).
  move: (Nin_card_ltT N_Px) ; rewrite card_ord [n in _ < n]eq_nd => lt_Pd.
  rewrite (eqmx_rank MHi0C) IH -(leq_add2r 1) subnK.
  rewrite -addn1 subnDA subnK //.
  rewrite -(leq_add2r #|P|) subnK // ; first by apply ltnW.
  rewrite HeqM -(leqRW (hplane_cap_lb P)).
  by rewrite -(leq_add2r #|P|) subnK // ; apply ltnW.
Qed.

Theorem fdim_ub f : dim f <= d - count (xpred1 On) f.
Proof.
  rewrite /dim ; apply inf_le ; rewrite fpoints_onNon ;
  remember [set i | tnth f i == On] as P ; rewrite -HeqP ;
  remember (\bigcap_(i in P) tnth H i)%MS as M.
  exists (\rank M).
    by apply imageP ; rewrite mksetE ; apply subIsetl.
  rewrite HeqM hplane_cap_eq ; apply eq_leq.
  by congr (_ - _) ; rewrite HeqP card_set_count.
Qed.

Theorem dim_simpleE f : nempty f -> dim f = d - count (xpred1 On) f.
Proof. by move=> NEf ; apply /eqP ; rewrite eqn_leq fdim_ub fdim_lb. Qed.

Lemma size_enum_sign : size (enum sign_finType) = 3.
Proof. Admitted.

Lemma face_count : #|[set: face]| = 3 ^ d.
Proof. by rewrite card_setT /= card_tuple eq_nd cardE size_enum_sign. Qed.

Lemma factM_dvdn_fact i k : i <= k -> i`! * (k - i)`! %| k`!.
Proof. by move=> le_ik ; apply /dvdnP ; exists 'C(k, i) ; rewrite bin_fact. Qed.

Lemma binomM_eq (k : 'I_d.+1) (i : 'I_k.+1) :
  'C(d-i, k-i) * 'C(d, d-i) = 'C(d, k) * 'C(k, i).
Proof.
  case: i => /= ; case: k => /= k le_kd i le_ik.
  move: le_ik le_kd ; rewrite !ltnS.
  case: (ltnP 0 k) ; last first.
    rewrite leqn0 => /eqP->. rewrite leqn0 => /eqP-> _.
    by rewrite !subn0 !bin0 binn.
  case: (ltnP i d) ; last first => [leq_di _ le_ik le_kd|lt_id lt_0k le_ik le_kd].
    have : i = d /\ k = d by lia. move=> [-> ->].
    by rewrite !subnn !bin0 !binn.
  rewrite !bin_factd ; [| try lia ..].
  have: d - (d - i) = i by lia. move->.
  have: d - i - (k - i) = d - k by lia. move->.
  rewrite !divn_mulAC. rewrite !muln_divA. rewrite -!divnMA.
  rewrite -mulnA divnMl ?fact_gt0 //.
  rewrite [k`! * (d - k)`!]mulnC [in RHS]mulnA divnMr ?fact_gt0 //.
  congr (_ %/ _) ; lia.
  - by rewrite factM_dvdn_fact ; try lia.
  - by rewrite mulnC factM_dvdn_fact ; try lia.
  - by rewrite factM_dvdn_fact ; try lia.
  - have: d - i - (k - i) = d - k by lia. move<-.
    by rewrite factM_dvdn_fact ; try lia.
Qed.

Lemma dimk_nemptyf_count (k : 'I_d.+1) :
  #|[set f | (dim f == k) && `[< nempty f >]]| = 'C(d, k) * 2 ^ k.
Proof.
  move: sH => /asboolP ; rewrite -(nempty_face_count k) => /eqP->.
  rewrite eq_nd ; under eq_big do [|rewrite binomM_eq].
  rewrite -big_distrr /= ; congr (_ * _).
  rewrite -[2]/(1 + 1) Pascal ; apply eq_bigr => i _.
  by rewrite !exp1n !muln1.
Qed.

Lemma total_nemptyf_count : #|[set f | `[< nempty f >]]| = 3 ^ d.
Proof.
  pose F (k : 'I_d.+1) := [set f | dim f == k].
  rewrite [[set f | `[< nempty f >]]](@bigcup_decomp _ _ F).
  suff : disjointS F => [/(@disjointS_capl _ _ [set f | `[< nempty f >]]) /asboolP |].
    rewrite -card_bigcup_leif /F => /eqP ->.
    under eq_big do [|rewrite setIC -set_andb dimk_nemptyf_count].
    under eq_big => [i|i _] do [|rewrite -[2 ^ i]mul1n -{1}(exp1n (d - i))].
    by rewrite -Pascal.
  rewrite /disjointS => i j neq_ij ; apply /eqP.
  apply contraT => /set0P[f] /= [].
  by rewrite /F /= => /eqP -> /eqP /ord_inj eq_ij ; rewrite eq_ij eqxx in neq_ij.
  move=> f _ ; rewrite /bigcup /= ; exists (inord (dim f)) => //.
  by rewrite /F inordK //= ltnS dim_led.
Qed.

Lemma g_equal aT rT (f g : aT -> rT) : f = g -> forall x, f x = g x.
Proof. by move->. Qed.

Theorem all_nempty f : nempty f.
Proof.
  move: total_nemptyf_count => /eqP.
  rewrite -face_count card_setT card_leTif /= => /eqP /g_equal /= P.
  by apply /asboolP ; rewrite P.
Qed.

Lemma tuple2_count_ge m (T : eqType) (f g : m.-tuple T) a :
  (forall i, (tnth f i != tnth g i) ==> (tnth f i == a)) ->
  count (xpred1 a) f >= count (xpred1 a) g.
Proof.
  elim: m f g => [|m IH] f g Hfg.
    move: f g Hfg => [f /eqP /size0nil Sf] [g /eqP /size0nil Sg] _ /=.
    by rewrite Sf Sg /=.
  have Heqf := (tuple_eta f) ; have Heqg := (tuple_eta g).
  rewrite Heqf Heqg /= /thead.
  case: (tnth f ord0 =P tnth g ord0) => [->|/eqP].
  - by rewrite leq_add2l ; apply IH => i ; rewrite !tnth_behead Hfg.
  - move=> /(implyP (Hfg ord0)) -> /= ; apply leq_add ; first by rewrite leq_b1.
    by apply IH => i ; rewrite !tnth_behead Hfg.
Qed.

Lemma tuple_eq_intro1 m (T : eqType) (f g : m.-tuple T) a :
  (forall i, (tnth f i != tnth g i) ==> (tnth f i == a)) ->
  count (xpred1 a) f = count (xpred1 a) g -> f = g.
Proof.
  elim: m f g => [|m IH] f g /= Hfg Hcount.
    clear Hfg Hcount ; move: f g => [f Sf] [g Sg] /=.
    apply /eqP ; rewrite -val_eqE /=.
    by move: Sf Sg => /eqP/size0nil-> /eqP/size0nil->.
  move: (tuple_eta f) (tuple_eta g) => Heqf Heqg.
  rewrite Heqf Heqg ; apply /eqP ; rewrite -val_eqE /= eqseq_cons.
  case: (thead f =P thead g) ; last first => [/eqP fg0 | /= fg0].
  - have f0 : thead f == a by apply (implyP (Hfg ord0)), fg0.
    have g0 : thead g != a by rewrite -(eqP f0) eq_sym fg0.
    apply False_ind.
    move: Hcount ; rewrite Heqf Heqg /= -[thead g == a]negbK f0 g0 /= add0n.
    move: (@tuple2_count_ge _ _ (behead_tuple f) (behead_tuple g) a) => bfg_count.
    feed bfg_count => [i|]. by rewrite !tnth_behead Hfg.
    move: bfg_count => /[swap] <- /= ; lia.
  - suff: behead_tuple f = behead_tuple g by move /eqP ; rewrite -val_eqE /=.
    apply IH => [i|] ; first by rewrite !tnth_behead Hfg.
    move: Hcount ; rewrite Heqf Heqg /= -fg0.
    by case: (thead f =P a) => /= _ ; [rewrite !add1n => /succn_inj | rewrite !add0n].
Qed.

Lemma tuple_count_eq1 m (T : eqType) (f g : m.-tuple T) a :
  (exists i, [/\ tnth f i == a, tnth g i != a & forall j, j != i -> tnth f j = tnth g j]) <->
    (count (xpred1 a) f = (count (xpred1 a) g).+1 /\
    forall i, (tnth f i != tnth g i) ==> (tnth f i == a)).
Proof.
  split => [[i [fi gi fgj]] | []].
  - split ; last first => [j|].
    + apply /implyP ; case: (i =P j) => [<- //|/eqP neq_ij].
      by rewrite fgj ; [rewrite eqxx|rewrite eq_sym].
    + elim: m i f g fi gi fgj => /= [[]|m IH i] f g fi gi fgj ; first by lia.
      move: (tuple_eta f) (tuple_eta g) => Heqf Heqg.
      rewrite Heqf Heqg /= /thead ; case: (i =P ord0) => [eq_i0|/eqP neq_i0].
      * rewrite -eq_i0 fi -[tnth g i == a]negbK gi /= add0n add1n ; congr (_.+1).
        suff: [tuple of behead f] = [tuple of behead g].
          by move=> /(f_equal (@tval m T)) /= ->.
        apply /eqP ; rewrite eqEtuple ; apply /forallP => /= j.
        rewrite !tnth_behead fgj // eq_i0.
        apply contraT ; rewrite negbK => /eqP /(f_equal val) /=.
        rewrite inordK // ; case: j => /= ; lia.
      * rewrite -[in RHS]addn1 -[in RHS]addnA.
        congr (_ + _) ; first by rewrite fgj // eq_sym.
        rewrite addn1.
        have lt_i1m: i.-1 < m.
          case: i neq_i0 fi gi fgj => /= [i Hi] + _ _ _.
          rewrite -val_eqE /= ; lia.
        have i11_i: i.-1.+1 = i.
          case: i neq_i0 lt_i1m fi gi fgj => /= [i Hi] + _ _ _ _.
          rewrite -val_eqE /= ; lia.
        apply (IH (Ordinal lt_i1m)) =>[| |j neq_ji1] ; rewrite !tnth_behead ?i11_i ?inord_val //=.
        apply fgj ; clear fi gi fgj i11_i neq_i0.
        move: neq_ji1 ; rewrite -!val_eqE /=.
        case: j => /= [j Hj] ; case: i lt_i1m => /= [i Hi] _.
        by rewrite inordK ; lia.
  - elim: m f g => /= [f g Hcount|m IH f g Hcount Hfg].
      apply False_ind ; move: f g Hcount => [f /eqP /size0nil Hf] [g /eqP /size0nil Hg] /=.
      by rewrite Hf Hg /=.
      have Heqf := (tuple_eta f) ; have Heqg := (tuple_eta g).
      case: (tnth f ord0 =P tnth g ord0) ; last first => [/eqP | fg0].
    + move=> /[dup] /(implyP (Hfg ord0)) => f0 g0 ; rewrite (eqP f0) eq_sym in g0.
      exists ord0 ; split => // j neq_j0 ; move: Hcount.
      rewrite Heqf Heqg /= /thead -[tnth g ord0 == a]negbK f0 g0 /= add0n add1n => /succn_inj Hcount.
      have lt_j1m : j.-1 < m.
        by case: j neq_j0 => /= [j Hj] ; rewrite -val_eqE /= ; lia.
      remember (Ordinal lt_j1m) as j'.
      have Hjj' : j = lift ord0 j'.
        case: j neq_j0 lt_j1m j' Heqj' => [j Hj] /= neq_j0 lt_j1m [j' Hj'] /= Heqj'.
        apply /eqP ; rewrite -!val_eqE /= /bump leq0n /= in neq_j0 *.
        by move: Heqj' => /eqP ; rewrite -val_eqE /= ; lia.
      rewrite Hjj' !tnthS ; f_equal.
      by apply (@tuple_eq_intro1 _ _ _ _ a) => [i|] ; [rewrite !tnth_behead|].
    + specialize (IH (behead_tuple f) (behead_tuple g)) ; feed_n 2 IH.
      * by move: Hcount ; rewrite Heqf Heqg /thead fg0 /= ; lia.
      * by setoid_rewrite tnth_behead.
      case: IH => [i [bfi bgi bfgj]].
      exists (lift ord0 i) ; split => [| |[j Hj] /=].
      * by rewrite Heqf tnthS bfi.
      * by rewrite Heqg tnthS bgi.
      * rewrite Heqf Heqg -val_eqE /= /bump /=.
        case: j Hj => [|j] Hj.
          have /eqP j0 : Ordinal Hj == ord0 by rewrite -val_eqE /=.
          by rewrite !j0 !tnth0 /thead fg0.
        have Hj' : j < m by lia.
        have: Ordinal Hj = lift ord0 (Ordinal Hj') => [|-> neq_ji].
          by apply /eqP ; rewrite -val_eqE /= /bump /= add1n.
        rewrite !tnthS ; apply bfgj ; rewrite -val_eqE /= ; lia.
Qed.

Lemma dim_eqk f g k : dim g = dim f + k <->
  count (xpred1 On) f = count (xpred1 On) g + k.
Proof.
  rewrite !dim_simpleE ; [|by apply all_nempty ..] ; split ; last first.
  - move=> P ; rewrite P subnDA subnK //.
    have: count (xpred1 On) f <= d by rewrite -eq_nd ; apply tuple_count_size.
    by lia.
  - have: count (xpred1 On) f <= d by rewrite -eq_nd ; apply tuple_count_size.
    have: count (xpred1 On) g <= d by rewrite -eq_nd ; apply tuple_count_size.
    by lia.
Qed.

Theorem subfaceE f g : subface f g <->
  exists i, [/\ tnth f i == On, tnth g i != On & forall j, j != i -> tnth f j = tnth g j].
Proof.
  split ; last first => [Hfg | [_ _]].
  - constructor ; [by apply all_nempty .. |move=> x|].
    + case: Hfg => [i [fi gi fgj]].
      rewrite -in_setE => /fpointsP Hf.
      rewrite -in_setE ; apply /clfpointsP => j.
      case: (i =P j) => [<-|/eqP neq_ij] ; first by right ; rewrite Hf (eqP fi).
      by rewrite Hf -fgj ; [|rewrite eq_sym //] ; left.
    + rewrite -addn1 ; apply dim_eqk.
      by move: Hfg ; rewrite tuple_count_eq1 addn1 => [[-> _]].
  - rewrite -[(dim f).+1]addn1 dim_eqk => /face_inclP Hincl Hcount .
    feed Hincl ; [by apply all_nempty | do [move=> /forallP /=] in Hincl].
    apply tuple_count_eq1 ; split => [|i] ; first by rewrite -addn1.
    by rewrite implyNb orbC Hincl.
Qed.

End SimpleArrangement.

End Arrangement.


Require Import List.
Require Import Cpdt.CpdtTactics.
Require Import NatIntf ArrayIntf VerifiedNatIntf.

Set Implicit Arguments.
Import ListNotations.

(* A module type for CanonicalArrayImpl. This is necessary because the def'ns
 * of CanonicalArrayImpl's value cannot be directly exposes, as a result of it
 * being a functor. Instead, we introduce a module type that exposes the def'ns,
 * as well as other useful properties. *)
Module Type CanonicalArrayIntf (N : VerifiedNatInterface)
    <: ArrayInterface N with Definition M := list.
  Definition M := list.

  Parameter make : forall A : Type, nat -> A -> M A.
  Parameter len : forall A : Type, M A -> N.N.
  Parameter get : forall A : Type, M A -> N.N -> option A.
  Parameter set : forall A : Type, M A -> N.N -> A -> M A.
  Parameter concat : forall A : Type, M A -> M A -> M A.

  (* Expose def'ns of CanonicalArrayImpl's provided values *)
  Axiom make_def : forall A (n:nat) (x:A),
      make n x = match n with
                 | O => []
                 | S n' => x::make n' x
                 end.
  Axiom len_def : forall A (l:list A),
      len l = match l with
              | [] => N.zero
              | _::t => N.succ (len t)
              end.
  Axiom get_def : forall A (l:list A) (n:N.N),
      get l n = match l with
                | [] => None
                | h::t =>
                    match N.comp n N.zero with
                    | Lt
                    | Eq => Some h
                    | Gt => get t (N.pred n)
                    end
                end.
  Axiom set_def : forall A (l:list A) (n:N.N) (x:A),
      set l n x = match l with
                  | [] => []
                  | h::l' =>
                      match N.comp n N.zero with
                      | Lt
                      | Eq => x::l'
                      | Gt => h::set l' (N.pred n) x
                      end
                  end.
  Axiom concat_def : forall A (l l':list A), concat l l' = l ++ l'.

  (* Various correctness properties that CanonicalArrayImpl satisfies *)
  Axiom len_make : forall A (n:nat) (x:A),
      N.convert (len (make n x)) = n.

  Axiom get_set : forall A (l : list A) (n : N.N) (x : A),
      match get (set l n x) n with
      | None => True
      | Some x' => x' = x
      end.

  Axiom len_set : forall A (l : list A) (n : N.N) x,
      len (set l n x) = len l.

  Axiom concat_make : forall A (m n:nat) (x:A),
      concat (make m x) (make n x) = make (m + n) x.

  Axiom make_concat : forall A (l l':list A) (n:nat) (x:A),
      concat l l' = make n x ->
          exists m m', l = make m x /\ l' = make m' x /\ m + m' = n.

  Axiom len_concat : forall A (l l' : list A),
      len (concat l l') = N.add (len l) (len l').

  Axiom get_concat : forall A (l r : list A) (n:N.N), get (concat l r) n =
      match N.comp n (len l) with
      | Lt => get l n
      | Eq
      | Gt => get r (N.sub n (len l))
      end.

  Axiom set_concat : forall A (l l':list A) (n:N.N) (x:A), set (concat l l') n x =
      match N.comp n (len l) with
      | Lt => concat (set l n x) l'
      | Eq
      | Gt => concat l (set l' (N.sub n (len l)) x)
      end.

End CanonicalArrayIntf.

(* A canonical, nil-cons implementation of ArrayInterface *)
Module CanonicalArrayImpl (N : VerifiedNatInterface) : CanonicalArrayIntf N
    with Definition M := list.
  Definition M := list.

  Fixpoint make A (n : nat) (x : A) : list A :=
    match n with
    | O => []
    | S n' => x::make n' x
   end.

  Fixpoint len A (ls : list A) : N.N :=
    match ls with
    | [] => N.zero
    | _::t => N.succ (len t)
    end.

  Fixpoint get A (ls : list A) (index : N.N) : option A :=
    match ls with
    | [] => None
    | h::t =>
        match N.comp index N.zero with
        | Lt
        | Eq => Some h
        | Gt => get t (N.pred index)
        end
    end.

  Fixpoint set A (ls : list A) (index : N.N) (x : A) : list A :=
    match ls with
    | [] => []
    | h::ls' =>
        match N.comp index N.zero with
        | Lt
        | Eq => x::ls'
        | Gt => h::set ls' (N.pred index) x
        end
    end.

  Definition concat A (l l' : list A) : list A := l ++ l'.

  Lemma make_def : forall A (n:nat) (x:A),
      make n x = match n with
                 | O => []
                 | S n' => x::make n' x
                 end.
    intros; destruct n; auto.
  Defined.

  Lemma len_def : forall A (l:list A),
      len l = match l with
              | [] => N.zero
              | _::t => N.succ (len t)
              end.
    intros; destruct l; auto.
  Defined.

  Lemma get_def : forall A (l:list A) (n:N.N),
      get l n = match l with
                | [] => None
                | h::t =>
                    match N.comp n N.zero with
                    | Lt
                    | Eq => Some h
                    | Gt => get t (N.pred n)
                    end
                end.
    intros; destruct l; auto.
  Defined.

  Lemma set_def : forall A (l:list A) (n:N.N) (x:A),
      set l n x = match l with
                  | [] => []
                  | h::l' =>
                      match N.comp n N.zero with
                      | Lt
                      | Eq => x::l'
                      | Gt => h::set l' (N.pred n) x
                      end
                  end.
    intros; destruct l; auto.
  Defined.

  Lemma concat_def : forall A (l l':list A), concat l l' = l ++ l'.
    intros; auto.
  Defined.

  Lemma len_make : forall A (n:nat) (x:A),
      N.convert (len (make n x)) = n.
    intros A n x.
    induction n;
        simpl.
      (* 0 *)
      rewrite N.zero_commutes.
      auto.
      (* S n *)
      rewrite N.succ_commutes.
      rewrite IHn.
      auto.
  Defined.

  Lemma get_set : forall A (l : list A) n x,
      match get (set l n x) n with
      | None => True
      | Some x' => x' = x
      end.
    intros A l.
    induction l;
        intros n x; simpl;
        try trivial.
      (* a :: l *)
      simpl.
      remember (N.comp n N.zero) as cmp.
      destruct cmp;
          symmetry in Heqcmp; simpl; rewrite Heqcmp;
          try reflexivity.
        (* Gt *)
        exact (IHl (N.pred n) x).
  Defined.

  Lemma len_set : forall A (l : list A) n x,
      len (set l n x) = len l.
    intros A l.
    induction l;
        intros n x; simpl; try trivial.
      (* a :: l *)
      destruct (N.comp n N.zero); simpl; try auto.
        (* Gt *)
        rewrite (IHl (N.pred n) x); trivial.
  Defined.

  Lemma concat_make : forall A (m n:nat) (x:A),
      concat (make m x) (make n x) = make (m + n) x.
    intros A m n x.
    induction m;
        simpl.
      reflexivity.
      rewrite IHm.
      reflexivity.
  Defined.

  Lemma make_concat : forall A (l l':list A) (n:nat) (x:A),
      concat l l' = make n x ->
        exists m m', l = make m x /\ l' = make m' x /\ m + m' = n.
    intros A l l'.
    induction l;
        intros n x;
        simpl.
      (* [] *)
      intros Heq.
      refine (ex_intro _ 0 _).
      refine (ex_intro _ n _).
      auto.
      (* a::l *)
      destruct n;
          simpl.
        (* 0 *)
        congruence.
        (* S n *)
        intros Heq.
        assert (a = x) as Ha. congruence.
        rewrite Ha; clear Ha.
        assert (concat l l' = make n x) as H. congruence.
        destruct (IHl n x H) as [m H'].
        destruct H' as [m' H''].
        refine (ex_intro _ (S m) _).
        refine (ex_intro _ m' _).
        crush.
  Defined.

  Lemma len_concat : forall A (l l' : list A),
      len (concat l l') = N.add (len l) (len l').
    intros.
    induction l.
      (* [] *)
      simpl.
      rewrite (N.add_zero).
      reflexivity.
      (* a :: l *)
      simpl.
      rewrite (N.add_succ).
      rewrite IHl.
      reflexivity.
  Defined.

  Lemma get_concat : forall A (l r:list A) (n:N.N), get (concat l r) n =
      match N.comp n (len l) with
      | Lt => get l n
      | Eq
      | Gt => get r (N.sub n (len l))
      end.
    intros A l.
    induction l;
        intros r n; simpl.
      (* [] *)
      rewrite (N.sub_zero n).
      remember (N.comp n N.zero) as cmp.
      destruct cmp;
          symmetry in Heqcmp.
        (* Eq *)
        reflexivity.
        (* Lt *)
        destruct (N.comp_zero n Heqcmp).
        (* Gt *)
        reflexivity.
      (* a::l *)
      remember (N.comp n N.zero) as cmp.
      destruct cmp;
          symmetry in Heqcmp.
        (* Eq *)
        destruct (N.comp_eq n N.zero) as [ Hcmp _ ].
        rewrite (Hcmp Heqcmp).
        rewrite (N.comp_zero_succ _).
        reflexivity.
        (* Lt *)
        destruct (N.comp_zero n Heqcmp).
        (* Gt *)
        pose (IH := IHl r (N.pred n)).
        rewrite (N.sub_pred _ _) in IH.
        destruct (N.pos_succ n Heqcmp) as [ n' Hn' ].
        rewrite Hn'.
        rewrite Hn' in IH.
        rewrite (N.pred_succ _).
        rewrite (N.pred_succ _) in IH.
        rewrite N.comp_succ.
        exact IH.
  Defined.

  Lemma set_concat : forall A (l l':list A) (n:N.N) (x:A), set (concat l l') n x =
      match N.comp n (len l) with
      | Lt => concat (set l n x) l'
      | Eq
      | Gt => concat l (set l' (N.sub n (len l)) x)
      end.
    intros A l l'.
    induction l;
        intros n x; simpl.
      (* [] *)
      remember (N.comp n N.zero) as cmp.
      destruct cmp;
          symmetry in Heqcmp.
        (* Eq *)
        rewrite N.sub_zero; reflexivity.
        (* Lt *)
        destruct (N.comp_zero n Heqcmp).
        (* Gt *)
        rewrite N.sub_zero; reflexivity.
      (* a::l *)
      remember (N.comp n N.zero) as cmp.
      destruct cmp;
          symmetry in Heqcmp.
        (* Eq *)
        destruct (N.comp_eq n N.zero) as [Hcmp _].
        rewrite (Hcmp Heqcmp).
        rewrite (N.comp_zero_succ).
        auto.
        (* Lt *)
        destruct (N.comp_zero n Heqcmp).
        (* Gt *)
        pose (IH := IHl (N.pred n) x).
        destruct (N.pos_succ n Heqcmp) as [n' Hn'].
        rewrite Hn' in IH.
        rewrite Hn'.
        rewrite N.pred_succ in IH.
        rewrite N.pred_succ.
        rewrite N.comp_succ.
        rewrite N.sub_succ.
        rewrite IH.
        simpl.
        destruct (N.comp n' (len l)); auto.
  Defined.

End CanonicalArrayImpl.


Require Import Coq.micromega.Psatz.
Require Import Rdefinitions.
Require Import Ranalysis1.
Require Import Rtrigo Rtrigo_reg.
Require Import MVT.
Require Import Logic.Syntax.
Require Import Logic.Semantics.
Require Import Logic.Lib.
Require Import Logic.BasicProofRules.
Require Import Logic.RenameProofRules.
Require Import Logic.Automation.
Require Import Coq.Reals.R_sqrt.
Require Import Coq.Lists.List.

Local Open Scope HP_scope.

(* This file contains the statement and soundness
   proof of differential induction.
   Essentially, an invariant inv is a differential
   invariant of a system of differential equations
   diffeqs at some state st if
     1) inv holds at st
     2) if one takes the "syntactic derivative" of inv
        and substitutes the right hand sides of diffeqs
        into this derivative to form inv', then inv'
        holds on any state st'
   There are two important parts to this file:
     1) deriv_formula - takes syntatic derivative and
        performs the substitutions
     2) diff_ind - states the proof rules for
        differential induction and has accompanying
        soundness proof *)

(* The function deriv_formula (below) produces the
   the syntactic derivative of a Formula and substitutes
   the right hand side of the differential equations.
   The following functions are used to implement
   deriv_formula. *)

(* option map on two inputs *)
Definition option_map2 {A B C} (f:A->B->C)
  (a:option A) (b:option B) : option C :=
  match a, b with
    | Some a, Some b => Some (f a b)
    | _, _ => None
  end.

Definition lift2 {A B C D} (f:A->B->C)
  : (D->A)->(D->B)->(D->C) :=
  fun a b c => f (a c) (b c).

(** TODO: This should probably be moved to another file b/c it is used
 ** when renaming [Continuous].
 **)
(* Tries to take the derivative of a term and substitute
   in the right hand side of differential equations. If
   a variable has no corresponding differential equation
   then this procedure fails and returns None. Otherwise,
   it returns (Some d), where d is the syntatic derivative
   with RHSs of diffeqs substituted in. None can occur
   because in our specification of continuous transitions
   the evolution of variables with no differential equations
   is unspecified. *)
Fixpoint deriv_term (t:Term)
: option (state -> Term) :=
  match t with
  | VarNowT x =>
    Some (fun st => RealT (st x))
  | VarNextT _ => None
  | NatT _ => Some (fun _ => RealT R0)
  | RealT _ => Some (fun _ => RealT R0)
  | PlusT t1 t2 =>
     option_map2 (lift2 PlusT) (deriv_term t1) (deriv_term t2)
  | MinusT t1 t2 =>
     option_map2 (lift2 MinusT) (deriv_term t1) (deriv_term t2)
  | MultT t1 t2 =>
     option_map2 (lift2 PlusT)
                 (option_map (fun t st => MultT (t st) t2)
                             (deriv_term t1))
                 (option_map (fun t st => MultT t1 (t st)) (deriv_term t2))
  | InvT _ => None
  | CosT t =>
    option_map2 (lift2 MultT)
                (Some (fun _ => --sin(t)))
                (deriv_term t)
  | SinT t =>
    option_map2 (lift2 MultT)
                (Some (fun _ => cos(t)))
                (deriv_term t)
  | SqrtT t => None (*
    option_map2 (lift2 MultT)
                (Some (fun _ => MultT (InvT (RealT 2)) (InvT (SqrtT t))))
                (deriv_term t) *)
  | ArctanT t => None (*
    option_map (fun f x => InvT (f x))
               (Some (fun _ => PlusT (RealT R1) (MultT t t)))
*)
  | ExpT t =>
    option_map2 (lift2 MultT)
                (Some (fun _ => exp(t)))
                (deriv_term t)
  | MaxT _ _ => None
  | Unop _ _ => None
  | Binop _ _ _ => None
  end.

(* Takes the "derivative" of a comparison operator.
   When you take the synthetic derivative of a formula
   with a comparison operator, the operator does not
   necessarily stay the same. For example x < y becomes
   x' <= y' *)
Fixpoint deriv_comp_op (op:CompOp) : CompOp :=
  match op with
    | Gt => Ge
    | Ge => Ge
    | Lt => Le
    | Le => Le
    | Eq => Eq
  end.

(* Tries to take the syntactic derivative of a formula
   and substitute in correspond RHSs of diffeqs. This
   procedure can fail (produce FALSE) for reasons
   described in deriv_term or because I couldn't figure
   out what the derivative should be. It is always
   sound to return FALSE because this is unprovable. *)
Fixpoint deriv_formula (P:state->Formula) (F:Formula) (st:state)
  : Formula :=
  match F with
    | TRUE => TRUE
    | FALSE => FALSE
    | Comp t1 t2 op =>
      match deriv_term t1, deriv_term t2 with
        | Some t1, Some t2 =>
          Comp (t1 st) (t2 st) (deriv_comp_op op)
        | _, _ => FALSE
      end
    | And F1 F2 =>
      (deriv_formula P F1 st) //\\ (deriv_formula P F2 st)
    | Imp F1 F2 =>
      (Continuous P -->> ((F1 -->> next F1) //\\ (next F1 -->> F1)))
      //\\ (F1 -->> (deriv_formula P F2 st))
    | _ => FALSE
  end.

(* Now we have a bunch of messy lemmas that we'll use
   to prove the differential induction (diff_ind) rule.
   Perhaps some day someone will clean these up. *)

(* This lemma says that our notion of syntatic
   derivatives for terms agrees with the actual
   definition of a derivative. *)

Lemma term_deriv : forall (f : R -> state) e e'
  (r : R) is_derivable s,
  deriv_term e = Some e' ->
  { pf : _ |
    forall z,
      (R0 <= z <= r)%R ->
      let f' := (fun t x => derive (fun t => f t x) (is_derivable x) t) in
      eq (derive (fun t => eval_term e (f t) s) pf z)
         (eval_term (e' (f' z)) (f z) s) }.
Proof.
  intros.
  generalize dependent e'.
  induction e; intros; simpl in *.
    - inversion H; clear H; subst.
      simpl. exists (is_derivable v).
      auto.
    - inversion H.
    - inversion H; subst e'.
      unfold eval_term, derive.
      exists (derivable_pt_const (Raxioms.INR n)). intros.
      eapply derive_pt_const.
    - inversion H; subst e'.
      unfold eval_term, derive.
      exists (derivable_pt_const r0). intros.
      eapply derive_pt_const.
    - destruct (deriv_term e1);
      destruct (deriv_term e2);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe1 t (Logic.eq_refl _)).
      specialize (IHe2 t0 (Logic.eq_refl _)).
      destruct IHe1 as [pf1 IHe1].
      destruct IHe2 as [pf2 IHe2].
      exists (fun r => derivable_pt_plus _ _ _
                                         (pf1 r) (pf2 r)).
      intros.
      pose proof (derive_pt_plus _ _ _ (pf1 z) (pf2 z))
        as Hderiv.
      unfold derive, plus_fct in *. rewrite Hderiv.
      simpl. rewrite IHe1; auto; rewrite IHe2; auto.
    - destruct (deriv_term e1);
      destruct (deriv_term e2);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe1 t (Logic.eq_refl _)).
      specialize (IHe2 t0 (Logic.eq_refl _)).
      destruct IHe1 as [pf1 IHe1].
      destruct IHe2 as [pf2 IHe2].
      exists (fun r => derivable_pt_minus _ _ _
                                         (pf1 r) (pf2 r)).
      intros.
      pose proof (derive_pt_minus _ _ _ (pf1 z) (pf2 z))
        as Hderiv.
      unfold derive, minus_fct in *. rewrite Hderiv.
      simpl. rewrite IHe1; auto; rewrite IHe2; auto.
    - destruct (deriv_term e1);
      destruct (deriv_term e2);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe1 t (Logic.eq_refl _)).
      specialize (IHe2 t0 (Logic.eq_refl _)).
      destruct IHe1 as [pf1 IHe1].
      destruct IHe2 as [pf2 IHe2].
      exists (fun r => derivable_pt_mult _ _ _
                                         (pf1 r) (pf2 r)).
      intros.
      pose proof (derive_pt_mult _ _ _ (pf1 z) (pf2 z))
        as Hderiv.
      unfold derive, mult_fct in *. rewrite Hderiv.
      simpl. rewrite IHe1; auto; rewrite IHe2; auto.
    - discriminate.
    - destruct (deriv_term e);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe t (Logic.eq_refl _)).
      destruct IHe as [pf IHe].
      exists (fun r => derivable_pt_comp
                         _ _ _ (pf r)
                         (derivable_pt_cos
                            (eval_term e (f r) s))).
      intros.
      pose proof (derive_pt_comp _ cos _ (pf z)
                                 (derivable_pt_cos
                                    (eval_term e (f z) s)))
        as Hderiv.
      unfold derive, comp in *. rewrite Hderiv.
      simpl. rewrite IHe; auto; rewrite derive_pt_cos;
      rewrite RIneq.Rminus_0_l; auto.
    - destruct (deriv_term e);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe t (Logic.eq_refl _)).
      destruct IHe as [pf IHe].
      exists (fun r => derivable_pt_comp
                         _ _ _ (pf r)
                         (derivable_pt_sin
                            (eval_term e (f r) s))).
      intros.
      pose proof (derive_pt_comp _ sin _ (pf z)
                                 (derivable_pt_sin
                                    (eval_term e (f z) s)))
        as Hderiv.
      unfold derive, comp in *. rewrite Hderiv.
      simpl. rewrite IHe; auto. rewrite derive_pt_sin. auto.
    - (** TODO: derivative of sqrt **) inversion H.
    - (** TODO: derivative of arctan **) inversion H.
    - destruct (deriv_term e);
      simpl in *; try discriminate. inversion H; subst e'.
      specialize (IHe t (Logic.eq_refl _)).
      destruct IHe as [pf IHe].
      exists (fun r => derivable_pt_comp
                         _ _ _ (pf r)
                         (Ranalysis4.derivable_pt_exp
                            (eval_term e (f r) s))).
      intros.
      pose proof (derive_pt_comp _ exp _ (pf z)
                                 (Ranalysis4.derivable_pt_exp
                                    (eval_term e (f z) s)))
        as Hderiv.
      unfold derive, comp in *. rewrite Hderiv.
      simpl. rewrite IHe; auto.
      rewrite Ranalysis4.derive_pt_exp. auto.
    - inversion H.
    - inversion H.
    - inversion H.
Qed.

Require Import ExtLib.Tactics.
Require Import ExtLib.Data.Option.

Lemma deriv_st_term : forall t t',
  deriv_term t = Some t' ->
  is_st_term t = true /\ (forall x, is_st_term (t' x) = true).
Proof.
  induction t; simpl; auto;
  intros;
  try solve [ discriminate
            | unfold option_map2, option_map in *;
              simpl in *; forward; inv_all; subst;
              repeat match goal with
                     | H : _ |- _ => specialize (H _ eq_refl); destruct H
                     end; simpl; intuition ].
Qed.

Hint Extern 0 (forall x, is_st_term _ = true) =>
  (intros; eapply deriv_st_term; eauto) : rw_rename.

Theorem RenameDerivOk_deriv_term
: forall (r : RenameMap) (r' : state->Var->Term),
    (forall x,
        deriv_term (r x) = Some (fun st' => r' st' x)) ->
    RenameDerivOk r r'.
Proof.
  red. intros.
  assert ((forall x, is_st_term (r x) = true) /\ (forall x st', is_st_term (r' st' x) = true)).
  { generalize (fun x => @deriv_st_term _ _ (H x)); clear. firstorder. }
  destruct H0 as [ Hst1 Hst2 ].
  simpl.
  assert (forall v : Var,
             derivable (fun t : R => eval_term (r v) (f t) (f t))).
  { intros. specialize (H v).
    eapply term_deriv in H; eauto.
    destruct H. clear e. revert x.
    instantiate (2 := f).
    instantiate (1 := fun _ => R0).
    intros.
    match goal with
    | _ : derivable ?X |- derivable ?Y =>
      cutrewrite (eq Y X); eauto
    end.
    eapply FunctionalExtensionality.functional_extensionality.
    intros.
    eapply st_term_hd; eauto. }
  { exists H0. intros.
    specialize (H v).
    unfold deriv_stateF.
    eapply term_deriv in H.
    revert H. instantiate (2 := f).
    instantiate (1 := fun _ => R0).
    instantiate (1 := pf2).
    instantiate (1:=z).
    destruct 1.
    simpl in e. specialize (e z).
    rewrite st_term_hd with (s3:=fun _ : Var => 0%R).
    rewrite <- e.
    apply Ranalysis4.pr_nu_var.
    eapply FunctionalExtensionality.functional_extensionality.
    intros. apply st_term_hd.
    apply Hst1.
    psatzl R.
    apply Hst2.
    Grab Existential Variables.
    exact R0.
    auto. }
Qed.

(** TODO: Move this **)
Hint Extern 1 (RenameDerivOk _ _) => solve [ eapply RenameDerivOk_deriv_term ; is_st_term_list ] : rw_rename.

Theorem Rename_Continuous_deriv_term :
  forall (r : RenameMap) (r' : RenameMapDeriv)
         (c:Evolution),
    (forall x,
        deriv_term (r x) = Some (fun st' => r' st' x)) ->
    Continuous (fun st' => (Forall x : Var, st' x = r' st' x) //\\ Rename r (c st'))
    |-- Rename r (Continuous c).
Proof.
  intros.
  eapply Rename_Continuous; eauto using RenameDerivOk_deriv_term.
Qed.

Theorem Rename_Continuous_deriv_term' :
  forall (r : RenameMap) (r' : RenameMapDeriv)
         (c:Evolution),
    (forall x,
        deriv_term (r x) = Some (fun st' => r' st' x)) ->
    Continuous (fun st' =>
                  Forall st'' : state,
                    (Forall x : Var, st'' x = r' st' x) -->> Rename r (c st''))
    |-- Rename r (Continuous c).
Proof.
  intros.
  eapply Rename_Continuous'; eauto using RenameDerivOk_deriv_term.
Qed.

Definition deriv_term_succeed (t : Term) :=
  match deriv_term t with
  | Some t => t
  | None => fun _ => R0
  end.

Fixpoint deriv_term_RenameList (l : RenameList) : RenameMapDeriv :=
  match l with
  | nil => fun st' => st'
  | (v, t) :: l =>
    fun st' x => if String.string_dec x v
             then deriv_term_succeed t st'
             else deriv_term_RenameList l st' x
  end.

(** TODO: Don't think this is needed **)
Lemma deriv_term_list : forall (l : RenameList),
  List.forallb (fun p => match deriv_term (snd p) with
                         | None => false
                         | Some _ => true
                         end) l = true ->
  forall x,
    deriv_term (to_RenameMap l x) =
    Some (fun st' => deriv_term_RenameList l st' x).
Proof.
  induction l.
  - reflexivity.
  - simpl. destruct a. simpl.
    destruct (deriv_term t) eqn:?.
    + intros. destruct (String.string_dec x v).
      * subst. unfold deriv_term_succeed. rewrite Heqo.
        reflexivity.
      * rewrite IHl; auto.
    + inversion 1.
Qed.

(* Here are a few tactics for proving our main
   helper lemma: eval_comp_ind. It's probably
   best not to try to understand these tactics. *)

Ltac normalize_ineq_goal :=
  match goal with
    | [ |- Rgt _ _ ]
      => apply RIneq.Rminus_gt; apply RIneq.Rlt_gt
    | [ |- Rge _ _ ]
      => apply RIneq.Rminus_ge; apply RIneq.Rle_ge
    | [ |- Rlt _ _ ]
      => apply RIneq.Rminus_lt; apply RIneq.Ropp_lt_cancel;
         rewrite RIneq.Ropp_minus_distr; rewrite RIneq.Ropp_0
    | [ |- Rle _ _ ]
      => apply RIneq.Rminus_le; apply RIneq.Ropp_le_cancel;
         rewrite RIneq.Ropp_minus_distr; rewrite RIneq.Ropp_0
    | [ |- eq _ _ ]
      => apply RIneq.Rminus_diag_uniq
  end.

Ltac normalize_ineq_hyp H :=
  match type of H with
    | context [Rgt _ _] => eapply RIneq.Rgt_minus in H;
                          eapply RIneq.Rgt_lt in H
    | context [Rge _ _] => eapply RIneq.Rge_minus in H;
                          eapply RIneq.Rge_le in H
    | context [Rlt _ _] => eapply RIneq.Rlt_minus in H;
       eapply RIneq.Ropp_lt_contravar in H;
       rewrite RIneq.Ropp_minus_distr in H;
       rewrite RIneq.Ropp_0 in H
    | context [Rle _ _] => eapply RIneq.Rle_minus in H;
       eapply RIneq.Ropp_le_contravar in H;
       rewrite RIneq.Ropp_minus_distr in H;
       rewrite RIneq.Ropp_0 in H
    | context [ eq _ _ ] => apply RIneq.Rminus_diag_eq in H
  end.

Ltac ineq_trans :=
  match goal with
    | [ H : Rlt ?r1 ?r2 |- Rlt ?r1 ?r3 ]
        => apply (RIneq.Rlt_le_trans r1 r2 r3)
    | [ H : Rle ?r1 ?r2 |- Rle ?r1 ?r3 ]
        => apply (RIneq.Rle_trans r1 r2 r3)
    | [ H : Rlt ?r2 ?r3 |- Rlt ?r1 ?r3 ]
        => apply (RIneq.Rlt_le_trans r1 r2 r3)
    | [ H : Rle ?r2 ?r3 |- Rle ?r1 ?r3 ]
        => apply (RIneq.Rle_trans r1 r2 r3)
    | [ H : eq (Rminus (eval_term ?t1 _ _)
                       (eval_term ?t2 _ _)) ?r3
        |- Rle ?r3 (Rminus (eval_term ?t1 _ _)
                           (eval_term ?t2 _ _)) ]
        => rewrite <- H
    | [ H : eq (Rminus (eval_term ?t2 _ _)
                       (eval_term ?t1 _ _)) ?r3
        |- Rle ?r3 (Rminus (eval_term ?t1 _ _)
                           (eval_term ?t2 _ _)) ]
        => apply RIneq.Rminus_diag_uniq in H;
           symmetry in H; apply RIneq.Rminus_diag_eq in H;
           rewrite <- H
  end.

Ltac deriv_ineq :=
  match goal with
    | [ |- Rle (eval_term ?t1 (?f ?r1) ?s -
                eval_term ?t2 (?f _) ?s)
            (eval_term ?t1 (?f ?r2) ?s -
             eval_term ?t2 (?f _) ?s) ]
        => eapply (derive_increasing_interv_var r1 r2
                     (fun z => eval_term t1 (f z) s -
                               eval_term t2 (f z) s)%R); eauto
    | [ |- @eq R
               (Rminus (eval_term ?t1 (?f _) ?s)
                       (eval_term ?t2 (?f _) ?s))
               (Rminus (eval_term ?t1 (?f _) ?s)
                       (eval_term ?t2 (?f _) ?s))]
        => eapply (null_derivative_loc
                 (fun z => (eval_term t1 (f z) s -
                            eval_term t2 (f z) s)%R)); eauto
  end.

Ltac solve_ineq := psatzl R.

Lemma eval_next_term : forall t s1 s2 s3,
  is_st_term t = true ->
  eval_term (next_term t) s1 s2 =
  eval_term t s2 s3.
Proof.
  induction t; simpl; auto; intros;
  try discriminate;
  try (try apply andb_prop in H; intuition;
       erewrite IHt1; eauto;
       erewrite IHt2; eauto).
Qed.

Lemma is_solution_sub : forall f eqs r1 r2,
  (r1 <= r2)%R ->
  is_solution f eqs r2 ->
  is_solution f eqs r1.
Proof.
  intros f eqs r1 r2 Hr Hsol.
  unfold is_solution in *.
  destruct Hsol as [pf Hsol].
  exists pf. unfold solves_diffeqs in *.
  intros x d.
  apply Hsol; auto.
  psatzl R.
Qed.

Definition derive_stateF (f : R -> state) (is_derivable : forall x, derivable (fun t => f t x))
: R -> state :=
  fun t v => derive (fun t => f t v) (is_derivable v) t.

Lemma deriv_neg : forall f t1 t2 t1' t2' r eqs is_derivable s,
  solves_diffeqs f eqs r is_derivable ->
  deriv_term t1 = Some t1' ->
  deriv_term t2 = Some t2' ->
  forall t,
    (R0 <= t <= r)%R ->
    exists pf,
      let f' := derive_stateF f is_derivable in
      (forall st,
          (0 <= eval_term (t1' (f' t)) st s - eval_term (t2' (f' t)) st s)%R) ->
      (R0 <=
    derive_pt
      (fun z : R => eval_term t1 (f z) s -
                    eval_term t2 (f z) s)
      t pf)%R.
Proof.
  intros f t1 t2 t1' t2' r diffeqs is_derivable s Hsol
         Ht1 Ht2 t Ht.
  pose proof (term_deriv f (t1-t2) (fun st' => t1' st' - t2' st') r
                         is_derivable s) as Hderiv.
  simpl in *. rewrite Ht1 in *. rewrite Ht2 in *. simpl in *.
  specialize (Hderiv (Logic.eq_refl _)).
  destruct Hderiv as [pf Hderiv]. exists (pf t).
  unfold derive in *. rewrite Hderiv; auto.
Qed.

(* Main helper lemma for diff_ind. Basically
   establishes the base case for diff_ind. The
   proof of this lemma is a complete mess. *)
Lemma eval_comp_ind : forall Hyps Pdiff
                             t1 t2 t1' t2' op
  (Hpdiff:forall st, is_st_formula (Pdiff st)),
  deriv_term t1 = Some t1' ->
  deriv_term t2 = Some t2' ->
  is_st_formula Hyps ->
  (|-- (Hyps //\\ Continuous Pdiff) -->> next Hyps) ->
  (|-- Hyps -->> (Forall x, Pdiff x -->> Comp (t1' x) (t2' x) (deriv_comp_op op))) ->
  (|-- (Comp t1 t2 op //\\ Hyps //\\
             Continuous Pdiff) -->>
       Comp (next_term t1) (next_term t2) op).
Proof.
  intros Hyps eqs t1 t2 t1' t2' op Hpdiff Ht1 Ht2 Hst Hhyps Hind.
  breakAbstraction; unfold eval_comp in *; simpl in *.
  intros tr XX H; clear XX; destruct H as [Hbase [HhypsI Hcont] ].

  destruct Hcont as [r [f Hcont] ];
    destruct Hcont as [Hr [Hsol [? ?] ] ].
  pose proof (proj1 (deriv_st_term _ _ Ht1)).
  pose proof (proj1 (deriv_st_term _ _ Ht2)).
  repeat rewrite eval_next_term with (s3:=Stream.hd (Stream.tl tr)); auto.
  unfold is_solution in *. destruct Hsol as [pf Hsol].
  pose proof (term_deriv f (t1 - t2) (fun st' => t1' st' - t2' st')
                         r pf (Stream.hd (Stream.tl tr)))
    as Hterm1.
  pose proof (term_deriv f (t2 - t1) (fun st' => t2' st' - t1' st')
                         r pf (Stream.hd (Stream.tl tr)))
    as Hterm2.
  rewrite <- H in *.
  rewrite <- H0 in *.
  simpl in *; rewrite Ht1 in Hterm1;
  rewrite Ht1 in Hterm2; rewrite Ht2 in Hterm1;
  rewrite Ht2 in Hterm2; simpl in *.
  specialize (Hterm1 (eq_refl _)).
  specialize (Hterm2 (eq_refl _)).
  unfold derive in Hterm1. unfold derive in Hterm2.
  destruct Hterm1 as [pf1 Hterm1].
  destruct Hterm2 as [pf2 Hterm2].
  destruct op; simpl in *; try (apply RIneq.Rle_le_eq; split);
  normalize_ineq_goal; normalize_ineq_hyp Hbase;
  ineq_trans; auto;
  deriv_ineq; intros; try solve_ineq;
  (instantiate (1:=pf1) || instantiate (1:=pf2));
  (rewrite Hterm1 || rewrite Hterm2); try solve_ineq;
  try specialize (Hhyps (Stream.Cons (Stream.hd tr)
                              (Stream.Cons (f t) (Stream.tl tr))) I);
  simpl in *; try apply next_formula_tl in Hhyps; auto;
  try specialize (Hind (Stream.Cons (f t) (Stream.tl tr)) I); simpl in *;
  try specialize (Hind Hhyps); try solve_ineq;
  try (split;
        [ eapply st_formula_hd; eauto |
          exists t; exists f; repeat split; try solve_ineq; auto;
          solve [apply is_solution_sub with (r2:=r);
                  try solve_ineq; unfold is_solution; eauto]
      ]);
  specialize (Hind (fun x : Var => derive_pt (fun t0 : R => f t0 x) t (pf x t)));
  unfold solves_diffeqs in *; rewrite H0;
  assert (0 <= t <= r)%R as Ht by solve_ineq;
  specialize (Hsol t Ht);
  eapply st_formula_hd in Hsol; try apply Hind in Hsol;
  try solve_ineq; auto.
Qed.

Lemma Continuous_deriv_exists :
  forall Pdiff tr,
    (forall st, is_st_formula (Pdiff st)) ->
    eval_formula (Continuous Pdiff) tr ->
    exists st, eval_formula (Pdiff st) tr.
Proof.
  breakAbstraction. intros. destruct H0 as [r [f H0]].
  unfold is_solution, solves_diffeqs in *.
  destruct H0 as [? [ [? ?] [? ?] ] ]. eexists.
  eapply st_formula_hd with (tr1:=Stream.forever (f R0)); eauto.
  apply H1; solve_ineq.
Qed.

(* Differential induction proof rule plus soundness
   proof. *)
Lemma diff_ind : forall Hyps G cp F,
  is_st_formula G ->
  is_st_formula Hyps ->
  (F |-- Continuous cp) ->
  (forall st, is_st_formula (cp st)) ->
  ((Hyps //\\ Continuous cp) |-- next Hyps) ->
  (F |-- G) ->
  (F |-- Hyps) ->
  (Hyps |-- Forall st, cp st -->> deriv_formula cp G st) ->
  (F |-- next G).
Proof.
  Opaque Continuous.
  intros Hyps G; generalize dependent Hyps;
  induction G;
    intros Hyps cp F HstG HstH Hcont Hcp Hhyps Hbase HhypsF Hind;
    simpl in *; unfold tlaEntails in *; simpl in *; intros; trivial;
    try solve [ pose proof (Hcont tr) as Hcont2;
                eapply Continuous_deriv_exists in Hcont2; auto;
                destruct Hcont2 as [st Hcont2]; exfalso;
                eapply Hind; eauto ].
  - destruct HstG as [HstG1 HstG2].
    pose proof (HhypsF _ H) as HhypsF2. pose proof Hcont as Hcont2.
    pose proof (Hind _ HhypsF2). eapply Continuous_deriv_exists in Hcont2; eauto.
    destruct (deriv_term t) eqn:?;
             destruct (deriv_term t0) eqn:?;
    try solve [destruct Hcont2; exfalso; eapply Hind; eauto].
    pose proof (eval_comp_ind Hyps cp t t0
                              t1 t2 c Hcp Heqo Heqo0 HstH) as Hcomp.
    apply Hcomp.
    { breakAbstraction. intros. eauto. }
    { breakAbstraction. intros. eauto. }
    { breakAbstraction. auto. }
    { fold eval_formula. repeat split; eauto.
      try eapply Hbase; eauto. }
  - split.
    + eapply IHG1; eauto.
      * intuition.
      * apply Hbase; auto.
      * apply Hind; auto.
    + eapply IHG2; eauto.
      * intuition.
      * apply Hbase; auto.
      * apply Hind; auto.
  - eapply IHG2 with (Hyps:=Hyps //\\ G1) (F:=F //\\ G1); eauto;
    simpl; intuition.
    + pose proof H5 as Hcont2;
      eapply Continuous_deriv_exists in Hcont2; destruct Hcont2;
      auto; specialize (Hind tr0 H3 _ H4); apply Hind; auto.
    + specialize (Hind tr0 H4); apply Hind; auto.
    + specialize (HhypsF _ H). pose proof (Hcont _ H) as Hcont2.
      eapply Continuous_deriv_exists in Hcont2; destruct Hcont2 as [st Hcont2].
      specialize (Hind _ HhypsF _ Hcont2). apply Hind; auto. auto.
Qed.


Require Export Coq.Sets.Multiset.
Require Import SfLib.

Inductive schema_ty : Set :=
  | STyNil: schema_ty
  | STyPair: col_ty -> schema_ty -> schema_ty
with col_ty : Set :=
  | CTyNat: col_ty
  | CTyBag: schema_ty -> col_ty.

Notation " x *** " := (STyPair x STyNil) (at level 51, right associativity).
Notation " x '***' y " := (STyPair x y) (at level 51, right associativity).

(* Indicates a column within a schema. Used in the JOIN query's BY clauses. *)
Definition col := nat.

(* Provides evidence that the given column of a given schema has given attr. *)
Inductive schema_column_has_type: schema_ty -> col -> col_ty -> Prop :=
  | SCHAZero: forall (s s': schema_ty) (c: col_ty),
      s = c *** s' ->
      schema_column_has_type s O c
  | SCHASucc: forall (s s': schema_ty) (i i': col) (c c': col_ty),
      i = S(i') ->
      s = c' *** s' ->
      schema_column_has_type s' i c'.

Fixpoint schema_columns (s: schema_ty) :=
  match s with
  | STyNil => 0
  | STyPair _ s' => 1 + (schema_columns s')
  end.

(* Get the type of the supports column *)
(* TODO *)
(* Fixpoint support_idx (s: schema_ty) (c: col) (pf: c < (schema_columns s)) := ??? *)

(* The type of each tuple within a relation with the given schema. *)
Fixpoint support (s: schema_ty) : Type :=
  match s with
  | STyNil => unit
  | a *** => helper a
  | a *** s' => (helper a) * support s'
  end
with helper(c: col_ty) : Type :=
  match c with
  | CTyNat => nat
  | CTyBag s_nested => multiset (support s_nested)
  end.

(* Construct a custom equality function over the support of s. *)
Definition support_eq (s: schema_ty) (row1 row2: support s) : Prop := (row1 = row2).

Lemma support_eq_dec (s: schema_ty):
  forall (x y : support s), {(support_eq s) x y} + {~ (support_eq s) x y}.
Proof.
  intros. unfold support_eq. Admitted.

(* A multiset of all of the nat keys in the indicated column. *)
(* TODO *)
(* Fixpoint tuple_idx (s: schema_ty) (tup: support s) (c: col) : multiset n := ??? *)


Require Import Reals Psatz Omega.
From iris.program_logic Require Export weakestpre prob_adequacy.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang adequacy.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac_auth auth.
From iris.heap_lang Require Import proofmode notation par.
From mathcomp Require Import seq fintype.

Section COUNTER.
Variable MAX : nat.

Definition newcounter : val := λ: <>, ref #0.
Definition min : val :=
  λ: "x" "y", if: "x" < "y" then "x" else "y".
Definition incr : val := λ: "l",
    let: "n" := min !"l" #MAX in
    let: "b" := flip #1 ("n" + #1)  in
    if: "b" then
      FAA "l" ("n" + #1);; #()
    else
      #().

Definition read : val := λ: "l", !"l".

From discprob.idxval Require Import pival
     pival_dist ival_dist irrel_equiv idist_pidist_pair extrema pidist_post_cond.

Local Open Scope R_scope.

Lemma INRp1_prob n:
  0 <= 1 / (INR n + 1) <= 1.
Proof.
  split.
  - specialize (RinvN_pos n). intros; nra.
  - replace 1 with (1 / 1) at 3; auto; last nra.
    apply Reals_ext.Rdiv_le_compat_contra; try nra.
    specialize (pos_INR n). nra.
Qed.

From discprob.basic Require Import monad.
Opaque mret.
Opaque mbind.

(* On paper we just write this as (mret 0) U ... U (mret n). *)
Definition select_upto (n: nat) : pidist nat :=
  fold_left pidist_union (map mret (iota 1 n)) (mret O).

Definition flip_incr (n: nat) : pidist nat :=
  pidist_plus (1/(INR n + 1)) (INRp1_prob n) (mret (S n)) (mret O).

Definition approx_incr : pidist nat :=
  k ← select_upto MAX;
  flip_incr k.

Fixpoint approx_n (n: nat) (l: nat) : pidist nat :=
  match n with
  | O => mret l
  | S n' =>
    x ← approx_incr;
    approx_n n' (l + x)
  end.

Lemma select_upto_spec1 curr:
  pspec (select_upto curr) (λ x, x  <= curr)%nat.
Proof.
  rewrite /approx_incr/select_upto.
  eapply (pspec_conseq _ (λ x, x <= curr + 0)%nat); last by (intros; omega).
  generalize O.
  induction curr => //= n.
  * apply pspec_mret. omega.
  * rewrite -pidist_union_foldleft_hd.
    apply pspec_union.
    ** apply pspec_mret; auto. omega.
    ** eapply pspec_conseq; first eapply IHcurr.
       rewrite //=. intros a Hle. omega.
Qed.

Lemma approx_incr_bounded:
  pspec (approx_incr) (λ x : nat, Rabs (INR x) <= INR (S MAX)).
Proof.
  eapply (pspec_mbind _ _ (λ x, x <= MAX)%nat); first eapply select_upto_spec1.
  intros a Hle. rewrite /flip_incr.
  apply pspec_pidist_plus.
  * apply pspec_mret. rewrite Rabs_right.
    ** apply le_INR. omega.
    ** apply Rle_ge, pos_INR.
  * apply pspec_mret. rewrite S_INR //= Rabs_R0.
    specialize (pos_INR MAX); nra.
Qed.

Fixpoint approx_n_bound n curr :=
  match n with
  | O => curr
  | S n' =>
    approx_n_bound n' (curr + S MAX)%nat
  end.

Lemma approx_n_bounded_mono n curr curr':
  (curr <= curr')%nat →
  (approx_n_bound n curr <= approx_n_bound n curr')%nat.
Proof.
  revert curr curr'.
  induction n => //=.
  intros curr curr' Hle.
  eapply IHn. omega.
Qed.

Lemma approx_n_bounded n curr:
  pspec (approx_n n curr) (λ x : nat, Rabs (INR x) <= INR (approx_n_bound n curr)).
Proof.
  revert curr.
  induction n => curr.
  - apply pspec_mret => //=. rewrite Rabs_right; last apply Rle_ge, pos_INR.
    reflexivity.
  - rewrite /=.
    eapply pspec_mbind; first eapply approx_incr_bounded.
    intros a. rewrite S_INR => Hle.
    eapply pspec_conseq; first eapply IHn => //=.
    intros k => //=.
    intros. etransitivity; first eassumption. apply le_INR.
    apply approx_n_bounded_mono.
    rewrite Rabs_right in Hle; last apply Rle_ge, pos_INR.
    rewrite -S_INR in Hle. apply INR_le in Hle. omega.
Qed.

Import Rbar.

Lemma Ex_min_approx_incr:
  Ex_min INR (approx_incr) = Finite 1.
Proof.
  rewrite /approx_incr.
  apply Ex_min_bind_const.
  { apply ex_Ex_extrema_bounded_supp_fun.
    eapply pspec_bounded. exists (INR (S MAX)).
    apply approx_incr_bounded.
  }
  intros k. rewrite /flip_incr.
  rewrite ?Ex_min_pidist_plus ?Ex_min_mret // ?(S_INR) //=.
  * rewrite //= Rmult_0_r Rplus_0_r.
    specialize (INRp1_prob k); intros (?&?).
    specialize (Rcomplements.INRp1_pos k). intros.
    f_equal. field. nra.
  * apply ex_Ex_extrema_pidist_plus; apply ex_Ex_extrema_mret.
Qed.

Lemma Ex_min_approx_n (n: nat) l:
  Ex_min INR (approx_n n l) =
  Finite (INR (n + l)).
Proof.
  revert l.
  induction n => l.
  - rewrite //=. rewrite Ex_min_mret. done.
  - transitivity (Ex_min (λ x : nat, INR (n + l) + INR x) (approx_incr)).
    { rewrite Ex_min_bind_post -/approx_n.
      * apply Ex_min_eq_ext.
        intros n'. rewrite IHn.
        rewrite ?plus_INR //=.
        nra.
      * apply Ex_min_bounded_supp_fun_finite.
        apply pspec_bounded.
        eexists (INR (n + l + MAX + 1)). eapply pspec_conseq; first eapply approx_incr_bounded.
        intros a Hle.
        rewrite IHn. rewrite ?Rabs_right in Hle *; try apply Rle_ge, pos_INR.
        apply le_INR. apply INR_le in Hle. omega.
      * intros. rewrite IHn => //=.
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (approx_n_bound (S n) l)).
        eapply (approx_n_bounded (S n) l).
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (n + l + (MAX  + 1))).
        eapply pspec_conseq; first eapply approx_incr_bounded.
        intros k Hb. rewrite IHn.
        rewrite Rabs_right; last by apply Rle_ge, pos_INR.
        apply le_INR.
        rewrite Rabs_right in Hb; last by apply Rle_ge, pos_INR.
        apply INR_le in Hb. omega.
    }
    rewrite Ex_min_plus_const_l.
    rewrite ?plus_INR. rewrite S_INR.
    rewrite Ex_min_approx_incr.
    rewrite //=. f_equal.
    nra.
Qed.

Lemma Ex_max_approx_incr :
  Ex_max INR (approx_incr) = Finite 1.
Proof.
  rewrite /approx_incr.
  apply Ex_max_bind_const.
  { apply ex_Ex_extrema_bounded_supp_fun.
    eapply pspec_bounded. exists (INR (S MAX)).
    apply approx_incr_bounded.
  }
  intros k. rewrite /flip_incr.
  rewrite ?Ex_max_pidist_plus ?Ex_max_mret // ?(S_INR) //=.
  * rewrite //= Rmult_0_r Rplus_0_r.
    specialize (INRp1_prob k); intros (?&?).
    specialize (Rcomplements.INRp1_pos k). intros.
    f_equal. field. nra.
  * apply ex_Ex_extrema_pidist_plus; apply ex_Ex_extrema_mret.
Qed.

Lemma Ex_max_approx_n (n: nat) l:
  Ex_max INR (approx_n n l) =
  Finite (INR (n + l)).
Proof.
  revert l.
  induction n => l.
  - rewrite //=. rewrite Ex_max_mret. done.
  - transitivity (Ex_max (λ x : nat, INR (n + l) + INR x) (approx_incr)).
    { rewrite Ex_max_bind_post -/approx_n.
      * apply Ex_max_eq_ext.
        intros n'. rewrite IHn.
        rewrite ?plus_INR //=.
        nra.
      * apply Ex_max_bounded_supp_fun_finite.
        apply pspec_bounded.
        eexists (INR (n + l + MAX + 1)). eapply pspec_conseq; first eapply approx_incr_bounded.
        intros a Hle.
        rewrite IHn. rewrite ?Rabs_right in Hle *; try apply Rle_ge, pos_INR.
        apply le_INR. apply INR_le in Hle. omega.
      * intros. rewrite IHn => //=.
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (approx_n_bound (S n) l)).
        eapply (approx_n_bounded (S n) l).
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (n + l + (MAX  + 1))).
        eapply pspec_conseq; first eapply approx_incr_bounded.
        intros k Hb. rewrite IHn.
        rewrite Rabs_right; last by apply Rle_ge, pos_INR.
        apply le_INR.
        rewrite Rabs_right in Hb; last by apply Rle_ge, pos_INR.
        apply INR_le in Hb. omega.
    }
    rewrite Ex_max_plus_const_l.
    rewrite ?plus_INR. rewrite S_INR.
    rewrite Ex_max_approx_incr.
    rewrite //=. f_equal.
    nra.
Qed.

Class acounterG Σ :=
  ACounterG { acounter_inG :> inG Σ (frac_authR natR) }.
Definition acounterΣ : gFunctors := #[GFunctor (frac_authR natR)].
Instance subG_acounterΣ {Σ} : subG acounterΣ Σ → acounterG Σ.
Proof. solve_inG. Qed.

Section proof.
Context `{!heapG Σ, !probG Σ, !acounterG Σ, !spawnG Σ}.

Lemma min_spec E (z1 z2: Z):
  {{{ True }}}
    min #z1 #z2 @ E
  {{{ RET LitV (LitInt (Zmin z1 z2)) ; True }}}.
Proof.
  iIntros (Φ) "_ HΦ".
  iIntros. wp_let. wp_let.
  wp_op; case_bool_decide.
  * wp_if.
    rewrite Z.min_l; last by omega.
    by iApply "HΦ".
  * wp_if.
    rewrite Z.min_r; last by omega.
    by iApply "HΦ".
Qed.

(* See the "counter with contribution" example in the "counter.v" file of the heap_lang lib *)

(* We first prove an "unbundled" form of the spec, where the invariants are
     separated from the acounter permission. Then, we use these triples to prove
     a bundled spec matching the one given in the paper *)

Definition acounter_loc_inv (γl : gname) (l : loc) : iProp Σ :=
    (∃ n, own γl (●! n) ∗ l ↦ #n)%I.

Definition acounter_prob_inv (γp γv : gname): iProp Σ :=
    (∃ n1 n2, own γp (●! n1) ∗ own γv (●! n2) ∗ (own γp (◯! n1) ∨ ownProb (approx_n n1 n2)))%I.

Definition acounter (γl γp γv : gname) (q : frac) (nperm : nat) (ncontrib : nat) : iProp Σ :=
    (own γp (◯!{q} nperm) ∗ own γl (◯!{q} ncontrib) ∗ own γv (◯!{q} ncontrib))%I.

Lemma acounter_sep γl γp γv q1 q2 np1 np2 nc1 nc2 :
  acounter γl γp γv (q1 + q2) (np1 + np2) (nc1 + nc2) ⊢
           acounter γl γp γv q1 np1 nc1 ∗ acounter γl γp γv q2 np2 nc2.
Proof.
  rewrite /acounter.
  iStartProof.
  * iIntros "(Hown1&Hown2&Hown3)".
    rewrite ?frag_auth_op -?own_op.
    iDestruct "Hown1" as "(?&?)".
    iDestruct "Hown2" as "(?&?)".
    iDestruct "Hown3" as "(?&?)".
    iFrame.
Qed.

Lemma acounter_join γl γp γv q1 q2 np1 np2 nc1 nc2 :
  acounter γl γp γv q1 np1 nc1 ∗ acounter γl γp γv q2 np2 nc2 ⊢
           acounter γl γp γv (q1 + q2) (np1 + np2) (nc1 + nc2).
Proof.
  rewrite /acounter.
  iStartProof.
  * iIntros "((Hown1a&Hown2a&Hown3a)&(Hown1b&Hown2b&Hown3b))".
    iCombine "Hown1a" "Hown1b" as "Hown1".
    iCombine "Hown2a" "Hown2b" as "Hown2".
    iCombine "Hown3a" "Hown3b" as "Hown3".
    iFrame.
Qed.

Lemma incr_spec N1 N2 γl γp γv l q np nc:
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv q (S np) nc }}}
    incr (Lit $ LitLoc l)
  {{{ RET LitV LitUnit; ∃ nc' : nat, acounter γl γp γv q np nc' }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iDestruct "Hpre" as "(#Hinv1&#Hinv2&(Hγp&Hγl&Hγv))".
  rewrite /incr.
  wp_let. wp_bind (! _)%E.
  iInv N1 as (c) ">[Hγl' Hl]" "Hclose".
  wp_load.
  iMod ("Hclose" with "[Hγl' Hl]") as "_".
  { iNext; iExists c; by iFrame. }

  iModIntro.
  wp_apply min_spec; first done; iIntros "_".
  wp_let.

  wp_op.
  wp_bind (flip _ _).
  iInv N2 as (np_global nv_global) ">(Hγp'&Hγv'&Hprob)" "Hclose".
  iDestruct "Hprob" as "[Hbad|Hprob]".
  { iDestruct (own_valid_2 with "Hbad Hγp") as %?%frac_auth_frag_valid_op_1_l; done. }

  iDestruct (own_valid_2 with "Hγp' Hγp") as % ?%frac_auth_included_total%nat_included.
  destruct np_global as [|np_global]; first by omega.
  rewrite //=.

  assert (0 <= IZR 1 / IZR (Z.min c MAX + 1) ∧ IZR 1 / IZR (Z.min c MAX + 1) <= 1).
  {
    rewrite //=.
    assert (IZR (Z.min c MAX + 1) = INR (Z.to_nat (Z.min c MAX) + 1)).
    rewrite INR_IZR_INZ; f_equal.
    assert (0 ≤ Z.min c MAX).
    { apply Z.min_glb; omega. }
    replace 1%nat with (Z.to_nat 1); try auto.
    rewrite -Z2Nat.inj_add; try omega.
    { rewrite Z2Nat.id => //=. etransitivity; first eauto.
      rewrite //=.  omega.
    }
    rewrite H. destruct (INRp1_prob (Z.to_nat (Z.min c MAX))).
    split; auto; etransitivity; eauto; rewrite plus_INR //=.
  }

  unshelve (wp_flip (approx_incr)
                    (λ x y, if (x : bool) then (Z.of_nat y) = (Z.min c MAX + 1)%Z
                            else Z.of_nat y = O) b z' HR); auto.
    { rewrite /approx_incr/select_upto. eapply irrel_coupling_proper.
      { reflexivity.  }
      { setoid_rewrite pidist_union_foldleft_bind. reflexivity. }
      apply ip_irrel_coupling.
      eapply (ip_coupling_union_list _ (flip_incr (Z.to_nat (Z.min c MAX)))).
      - rewrite /flip_incr.
        apply ip_coupling_plus.
        { rewrite //=.  f_equal. rewrite plus_IZR. f_equal.
          rewrite INR_IZR_INZ. f_equal.
          rewrite Z2Nat.id; auto.
          apply Z.min_glb; omega.
        }
        * apply ip_coupling_mret.
          rewrite -Z2Nat.inj_succ;
          last (apply Z.min_glb; omega).
          rewrite Z2Nat.id; auto.
          cut (0 ≤ Z.min c MAX); intros; try (apply Z.min_glb); omega.
        * apply ip_coupling_mret.
          split; auto => //=.
      - eexists. split; last first.
        { rewrite -List.map_cons.
          eapply in_map_iff.
          exists (mret (Z.to_nat (Z.min c MAX))); split.
          * reflexivity.
          * rewrite -map_cons. eapply in_map_iff.
            exists (Z.to_nat (Z.min c MAX)); split; auto.
            replace (O :: iota 1 MAX) with (iota O (S MAX - 0)); last first.
            { rewrite //=.  }
            apply Iter.In_iota; split.
            **  omega.
            ** rewrite Z2Nat.inj_min.
               etransitivity; first apply Min.le_min_r.
               rewrite //=.
               rewrite Nat2Z.id.
               reflexivity.
        }
        setoid_rewrite pidist_left_id. reflexivity.
    }
    rewrite //= in HR. (* destruct HR as (Heqz&?); subst. *)
    destruct b.
    * iMod (own_update_2 with "Hγp' Hγp") as "[Hγp' Hγp]".
      { apply frac_auth_update, (nat_local_update _ _ (np_global) (np)); omega. }
      iMod (own_update_2 with "Hγv' Hγv") as "[Hγv' Hγv]".
      { apply frac_auth_update, (nat_local_update _ _ (nv_global + z') (nc + z')); omega. }
      iMod ("Hclose" with "[Hγp' Hγv' Hprob]").
      { iNext. iExists np_global, (nv_global + z')%nat. iFrame.
        iRight. iFrame. }

      iModIntro.
      wp_let.
      wp_if.
      wp_op.
      wp_bind (FAA _ _).
      iInv N1 as (c') ">[Hγl' Hl]" "Hclose".
      wp_faa.
      iMod (own_update_2 with "Hγl' Hγl") as "[Hγl' Hγl]".
      { apply frac_auth_update, (nat_local_update _ _ (c' + z') (nc + z')); omega. }

      iMod ("Hclose" with "[Hγl' Hl]").
      { iNext. iExists (c' + z')%nat. iFrame.
        rewrite ?Nat2Z.inj_add => //=.
        rewrite HR. rewrite Zplus_comm. done.
      }

      iModIntro. wp_let.
      iApply "HΦ".
      iExists (nc + z')%nat.
      iFrame.
    * replace (nv_global + z')%nat with (nv_global); last first.
      { apply Z_of_nat_inj. rewrite Nat2Z.inj_add HR. omega. }
      iMod (own_update_2 with "Hγp' Hγp") as "[Hγp' Hγp]".
      { apply frac_auth_update, (nat_local_update _ _ (np_global) (np)); omega. }
      iMod ("Hclose" with "[Hγp' Hγv' Hprob]").
      { iNext. iExists np_global, nv_global. iFrame. iRight. iFrame. }

      iModIntro.
      wp_let.
      wp_if.

      iApply "HΦ".
      iExists nc. iFrame.
Qed.

Lemma read_spec N1 N2 γl γp γv l nc:
  N1 ## N2 →
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv 1 0 nc }}}
    read (Lit $ LitLoc l)
  {{{ (v : nat), RET LitV $ LitInt v; ownProb (mret v) }}}.
Proof.
  iIntros (Hdisjoint Φ) "Hpre HΦ".
  iDestruct "Hpre" as "(#Hinv1&#Hinv2&(Hγp&Hγl&Hγv))".
  wp_let.
  iInv N1 as (c) ">[Hγl' Hl]" "Hclose1".
  iInv N2 as (np_global nv_global) ">(Hγp'&Hγv'&Hprob)" "Hclose2".
  iDestruct "Hprob" as "[Hbad|Hprob]".
  { iDestruct (own_valid_2 with "Hbad Hγp") as %?%frac_auth_frag_valid_op_1_l; done. }
  wp_load.
  iDestruct (own_valid_2 with "Hγp' Hγp") as % ->%frac_auth_agreeL.
  iDestruct (own_valid_2 with "Hγl' Hγl") as % ->%frac_auth_agreeL.
  iDestruct (own_valid_2 with "Hγv' Hγv") as % ->%frac_auth_agreeL.
  iMod ("Hclose2" with "[Hγp' Hγv' Hγp]").
  { iNext. iExists O, nc. iFrame. iLeft. iFrame. }

  iModIntro.
  iMod ("Hclose1" with "[Hγl' Hl]").
  { iNext. iExists nc. iFrame. }

  iModIntro. iApply "HΦ". rewrite //=.
Qed.

Lemma newcounter_spec N1 N2 n :
  {{{ ownProb (approx_n n O)}}}
    newcounter #()
  {{{ γl γp γv l, RET #l;
      inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
     acounter γl γp γv 1 n O }}}.
Proof.
  iIntros (Φ) "Hprob HΦ".
  iMod (own_alloc (●! O%nat ⋅ ◯! O%nat)) as (γl) "[Hγl' Hγl]"; first done.
  iMod (own_alloc (●! n%nat ⋅ ◯! n%nat)) as (γp) "[Hγp' Hγp]"; first done.
  iMod (own_alloc (●! O%nat ⋅ ◯! O%nat)) as (γv) "[Hγv' Hγv]"; first done.

  rewrite -wp_fupd /newcounter /=.
  wp_let. wp_alloc l as "Hl".
  iMod (inv_alloc N1 _ (acounter_loc_inv γl l) with "[Hl Hγl']").
  { iNext. iExists O. iFrame. }
  iMod (inv_alloc N2 _ (acounter_prob_inv γp γv) with "[Hγp' Hγv' Hprob]").
  { iNext. iExists n, O. iFrame. iRight. done. }

  iApply "HΦ".
  iModIntro. iFrame.
Qed.

(* Bundled versions to match cleaner formulation for paper *)
Definition Acounter γl γp γc l (q : frac) (nperm : nat) : iProp Σ :=
  (∃ N1 N2 ncontrib,
  ⌜ N1 ## N2 ⌝ ∗ inv N1 (acounter_loc_inv γl l) ∗ inv N2 (acounter_prob_inv γp γc) ∗
    own γp (◯!{q} nperm) ∗ own γl (◯!{q} ncontrib) ∗ own γc (◯!{q} ncontrib))%I.

Lemma Acounter_sep γl γp γv l q1 q2 np1 np2:
  Acounter γl γp γv l (q1 + q2) (np1 + np2) ⊢
           Acounter γl γp γv l q1 np1 ∗ Acounter γl γp γv l q2 np2.
Proof.
  iStartProof.
  * iIntros "HA".
    iDestruct "HA" as (N1 N2 nc) "(%&#Hi1&#Hi2&HA)".
    replace nc with (O + nc)%nat by auto.
    iPoseProof (acounter_sep γl γp γv q1 q2 np1 np2 O nc with "[HA]") as "(HA1&HA2)"; auto.
    iSplitL "HA1".
    ** iExists N1, N2, O. auto.
    ** iExists N1, N2, nc. auto.
Qed.

Lemma Acounter_join γl γp γv l q1 q2 np1 np2:
  Acounter γl γp γv l q1 np1 ∗ Acounter γl γp γv l q2 np2 ⊢
           Acounter γl γp γv l (q1 + q2) (np1 + np2).
Proof.
  iStartProof.
  iIntros "(HA1&HA2)".
  iDestruct "HA1" as (N1 N2 nc1) "(%&#Hi1&#Hi2&HA1)".
  iDestruct "HA2" as (N1' N2' nc2) "(%&#Hi1'&#Hi2'&HA2)".
  iCombine "HA1" "HA2" as "HA".
  rewrite acounter_join.
  iExists N1, N2, (nc1 + nc2)%nat; auto.
Qed.

Lemma newcounter_spec' n :
  {{{ ownProb (approx_n n O)}}}
    newcounter #()
  {{{ γl γp γc l, RET #l;
     Acounter γl γp γc l 1 n}}}.
Proof.
  iIntros (Φ) "Hprob HΦ".
  set (N1 := nroot .@ "N1").
  set (N2 := nroot .@ "N2").
  iApply (newcounter_spec N1 N2 n with "Hprob").
  iNext. iIntros (γl γp γv l) "(Hinv1&Hinv2&Hacounter)". iApply "HΦ".
  iExists N1, N2, O.
  iFrame. rewrite /N1/N2; eauto with *.
Qed.

Lemma incr_spec' γl γp γc l q np :
  {{{ Acounter γl γp γc l q (S np)}}}
    incr (Lit $ LitLoc l)
  {{{ RET LitV LitUnit; Acounter γl γp γc l q np }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 ncontrib) "(%&#Hinv1&#Hinv2&H)".
  iApply (incr_spec with "[H]").
  { iFrame "Hinv1 Hinv2 H". }
  iNext. iIntros "HA". iDestruct "HA" as (nc') "HA".
  iApply "HΦ".
  iExists N1, N2, nc'; iFrame; eauto.
Qed.

Lemma read_spec' γl γp γc l:
  {{{ Acounter γl γp γc l 1 0}}}
    read (Lit $ LitLoc l)
  {{{ (v : nat), RET LitV $ LitInt v; ownProb (mret v) }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 ncontrib) "(%&#Hinv1&#Hinv2&H)".
  iApply (read_spec with "[H]"); first by eauto.
  { iFrame "Hinv1 Hinv2 H". }
  done.
Qed.

Section simple_client.

Definition incr_n : val :=
  rec: "incr_n" "l" "n" :=
    if: "n" = #0 then
      #()
    else
      incr "l";;
      let: "n'" := "n" - #1 in
      "incr_n" "l" "n'".

Definition simple_client n1 n2 : expr :=
  let: "l" := newcounter #() in
  (incr_n "l" #n1  ||| incr_n "l" #n2) ;;
  read "l".

Lemma incr_n_spec N1 N2 γl γp γv q n1 n2 l:
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv q n1 n2 }}}
    (incr_n #l) #n1
  {{{ v, RET v; ∃ nc : nat, acounter γl γp γv q 0 nc }}}.
Proof.
  iIntros (Φ) "(#Hinv1&#Hinv2&Hcounter) Hwand".
  iRevert (n1 n2) "Hcounter".
  iLöb as "IH". iIntros (n1 n2) "Hcounter".
  wp_rec.
  wp_let.
  wp_op; case_bool_decide.
  * wp_if.
    assert (n1 = 0)%nat by (inversion H; auto; omega).
    subst. iApply "Hwand". iExists n2. done.
  * wp_if.
    assert (n1 ≠ 0)%nat.
    { intros Heq.  subst. rewrite //= in H. }
    destruct n1 as [| n1]; first by auto.
    wp_apply (incr_spec with "[Hcounter]"); [ iFrame "Hinv1 Hinv2"; done |].
    iIntros "Hcounter".
    iDestruct "Hcounter" as (nc) "Hcounter".
    wp_let. rewrite Zpos_P_of_succ_nat. wp_op.
    replace (Z.succ n1 - 1)%Z with (n1 : Z) by omega.
    wp_let. wp_apply ("IH" with "Hwand Hcounter").
Qed.

Lemma incr_n_spec' γl γp γc l q n1:
  {{{ Acounter γl γp γc l q n1}}}
    (incr_n #l) #n1
  {{{ v, RET v; Acounter γl γp γc l q 0 }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 nc) "(%&#Hinv1&#Hinv2&H)".
  iApply (incr_n_spec with "[H]").
  { iFrame "Hinv1 Hinv2 H". }
  iNext. iIntros (v) "HA". iDestruct "HA" as (nc') "HA".
  iApply "HΦ".
  iExists N1, N2, nc'; iFrame; eauto.
Qed.

Lemma simple_client_spec n1 n2:
  ownProb (approx_n (n1 + n2) O) ⊢
          WP (simple_client n1 n2) {{ v, ∃ (v' : nat), ownProb (mret v') ∗
                                                 ⌜ v = LitV $ LitInt v' ⌝ }}%I.
Proof.
  iIntros "Hprob". rewrite /simple_client.
  wp_bind (newcounter _).
  wp_apply (newcounter_spec' with "Hprob").
  iIntros (γl γp γv l) "Hcounter".
  rewrite -(Qp_div_2 1).
  replace 0%nat with (0 + 0)%nat by auto.
  rewrite Acounter_sep.
  iDestruct "Hcounter" as "(Hcounter1&Hcounter2)".
  wp_let. wp_apply (wp_par (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                           (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                      with "[Hcounter1] [Hcounter2]").
  - wp_apply (incr_n_spec' with "Hcounter1").
    iIntros (_); auto.
  - wp_apply (incr_n_spec' with "Hcounter2").
    iIntros (_); auto.
  - iIntros (v1 v2) "(Hpost1&Hpost2)".
    iCombine "Hpost1" "Hpost2" as "Hpost".
    rewrite Acounter_join Qp_div_2 //=.
    iNext. wp_let. wp_apply (read_spec' with "Hpost"); eauto.
Qed.
End simple_client.

Section list_client.

  (* Convert a list of Coq bools into a heap_lang tuple *)
Fixpoint l2tuple (l: list bool) : val :=
  match l with
  | [] => NONEV
  | b :: l =>
    SOMEV (#b, l2tuple l)
  end.

Definition foldLeft : val :=
  rec: "foldLeft" "f" "l" "a" :=
    match: "l" with
      NONE => "a"
    | SOME "cell" =>
      "foldLeft" "f" (Snd "cell") ("f" "a" (Fst "cell"))
    end.

(* Uses the approx counter to count the number of trues occurring in a list *)
Definition countTrue : val :=
  λ: "c" "lb",
  foldLeft (λ: <> "b", if: "b" then incr "c" else #()) "lb" #().

Definition list_client l1 l2 : expr :=
  let: "c" := newcounter #() in
  (countTrue "c" (l2tuple l1)  ||| countTrue "c" (l2tuple l2)) ;;
  read "c".

Definition lenTrue l := (List.length (List.filter (λ x, x) l)).

Lemma countTrue_spec γl γp γc l q lb:
  {{{ Acounter γl γp γc l q (lenTrue lb) }}}
    (countTrue #l) (l2tuple lb)
  {{{ v, RET v; Acounter γl γp γc l q 0 }}}.
Proof.
  iIntros (Φ) "HA Hwand".
  wp_let. wp_let. wp_let. wp_let. wp_let.
  iRevert (lb) "HA".
  iLöb as "IH". iIntros (lb) "Hcounter".
  destruct lb.
  * wp_match. iApply "Hwand"; done.
  * rewrite /l2tuple -/l2tuple.
    wp_match. wp_let. wp_proj.
    wp_let. wp_let. wp_proj. wp_let.
    destruct b.
    ** wp_if. wp_apply (incr_spec' with "Hcounter").
       iIntros "Hcounter".
       wp_let.  iApply ("IH" with "Hwand Hcounter").
    ** wp_if.
       wp_let.  iApply ("IH" with "Hwand [Hcounter]").
       rewrite //=.
Qed.

Lemma list_client_spec l1 l2:
  ownProb (approx_n (lenTrue l1 + lenTrue l2) O) ⊢
          WP (list_client l1 l2) {{ v, ∃ (v' : nat), ownProb (mret v') ∗
                                                 ⌜ v = LitV $ LitInt v' ⌝ }}%I.
Proof.
  iIntros "Hprob". rewrite /list_client.
  wp_bind (newcounter _).
  wp_apply (newcounter_spec' with "Hprob").
  iIntros (γl γp γv l) "Hcounter".
  rewrite -(Qp_div_2 1).
  replace 0%nat with (0 + 0)%nat by auto.
  rewrite Acounter_sep.
  iDestruct "Hcounter" as "(Hcounter1&Hcounter2)".
  wp_let. wp_apply (wp_par (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                           (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                      with "[Hcounter1] [Hcounter2]").
  - wp_apply (countTrue_spec with "Hcounter1").
    iIntros (_); auto.
  - wp_apply (countTrue_spec with "Hcounter2").
    iIntros (_); auto.
  - iIntros (v1 v2) "(Hpost1&Hpost2)".
    iCombine "Hpost1" "Hpost2" as "Hpost".
    rewrite Acounter_join Qp_div_2 //=.
    iNext. wp_let. wp_apply (read_spec' with "Hpost"); eauto.
Qed.
End list_client.

End proof.

Section adequate.
Let Σ : gFunctors := #[ heapΣ ; spawnΣ; acounterΣ].

Definition client_ival sch e σ k := @ivdist_tpool_stepN heap_ectxi_lang sch [e] σ k.

Lemma generic_client_adequate n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  irrel_couplingP (client_ival sch e σ k)
                  (approx_n n O)
                  (prob_adequacy.coupling_post (λ x y, x = LitV $ LitInt y)).
Proof.
  intros Hspec ?.
  eapply (heap_prob_adequacy Σ (approx_n n 0)
                             e σ (λ x y, x = LitV $ LitInt y) sch k); eauto.
  intros. iIntros "Hprob".
  iApply Hspec; done.
Qed.

Lemma generic_client_ex_Ex_ival n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  ex_Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch e σ k).
Proof.
  intros.
  intros. eapply irrel_coupling_eq_ex_Ex_supp; last first.
  { eapply pspec_bounded.  eexists. apply approx_n_bounded. }
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
Qed.

Lemma generic_client_Ex_ival n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch e σ k)
  = INR n%nat.
Proof.
  intros. replace (INR n) with (INR (n + 0)%nat) by (f_equal; omega).
  apply stochastic_order.Finite_inj.
  apply Rbar_le_antisym.
  - rewrite -Ex_max_approx_n.
    intros. apply irrel_coupling_eq_Ex_max_supp.
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
    * apply pspec_bounded. eexists. apply approx_n_bounded.
  - rewrite -Ex_min_approx_n.
    intros. apply irrel_coupling_eq_Ex_min_supp.
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
    * apply pspec_bounded. eexists. apply approx_n_bounded.
Qed.

Lemma simple_client_ex_Ex_ival (n1 n2: nat) sch σ k:
  terminates sch [([simple_client n1 n2], σ)] k →
  ex_Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (simple_client n1 n2) σ k).
Proof.
  eapply generic_client_ex_Ex_ival.
  iIntros; iApply simple_client_spec; done.
Qed.

Lemma simple_client_Ex_ival (n1 n2: nat) sch σ k:
  terminates sch [([simple_client n1 n2], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (simple_client n1 n2) σ k)
  = INR (n1 + n2)%nat.
Proof.
  apply generic_client_Ex_ival.
  iIntros; iApply simple_client_spec; done.
Qed.

Lemma list_client_Ex_ival lb1 lb2 sch σ k:
  terminates sch [([list_client lb1 lb2], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (list_client lb1 lb2) σ k)
  = INR (lenTrue lb1 + lenTrue lb2)%nat.
Proof.
  apply generic_client_Ex_ival.
  iIntros; iApply list_client_spec; done.
Qed.

End adequate.
End COUNTER.