(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup perm finalg matrix.
From mathcomp Require boolp.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext Ranalysis_ext ssr_ext ssralg_ext logb Rbigop.
Require Import fdist convex.

(****************************************************************************)
(* Direct formalization of the Lemma 2 from M. H. Stone. Postulates for the *)
(* barycentric calculus. Ann. Mat. Pura Appl., 29(1):25–30, 1949. The file  *)
(* convex_choice.v contains a shorter proof.                                *)
(****************************************************************************)

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

Local Open Scope fdist_scope.
Local Open Scope convex_scope.
Local Open Scope reals_ext_scope.

(* TODO: move? *)
Module S2.

Lemma generators (s : 'S_2) : s = 1%g \/ s = tperm ord0 (Ordinal (erefl (1 < 2))).
Proof.
pose s0 := s ord0. pose s1 := s (Ordinal (erefl (1 < 2))).
case/orP : (ord2 s0) => /eqP Hs0.
- case/orP : (ord2 s1) => [/eqP |/eqP ?].
  + by rewrite -Hs0 => /perm_inj /(congr1 val).
  + left; apply/permP => i.
    by case/orP: (ord2 i) => /eqP ->; rewrite perm1.
- case/orP : (ord2 s1) => [/eqP ? |/eqP].
  + right; apply/permP => i.
    by case/orP: (ord2 i) => /eqP ->; rewrite permE.
  + by rewrite -Hs0 => /perm_inj /(congr1 val).
Qed.

End S2.

(* TODO: move? *)
Module S3.

Definition p01 : 'S_3 := tperm ord0 (Ordinal (erefl (1 < 3))).
Definition p02 : 'S_3 := tperm ord0 (Ordinal (erefl (2 < 3))).
Definition p12 : 'S_3 := tperm (Ordinal (erefl (1 < 3))) (Ordinal (erefl (2 < 3))).
Definition p021 := (p01 * p02)%g.
Definition p012 := (p02 * p01)%g.

Lemma suff_generators (P : 'S_3 -> Prop) : P 1%g -> P p01 -> P p02 ->
  (forall s s', P s -> P s' -> P (s' * s)%g) -> forall s : 'S_3, P s.
Proof.
move=> H1 H2 H3 H s.
have : s = 1%g \/ s = S3.p01 \/ s = S3.p02 \/ s = S3.p12 \/ s = S3.p021 \/ s = S3.p012.
  pose s0 := s ord0. pose s1 := s (Ordinal (erefl (1 < 3))). pose s2 := s (Ordinal (erefl (2 < 3))).
  case/or3P : (ord3 s0) => [/eqP Hs0|/eqP Hs0|/eqP Hs0].
  - case/or3P : (ord3 s1) => [/eqP|/eqP Hs1|/eqP Hs1].
    + by rewrite -Hs0 => /perm_inj.
    + case/or3P : (ord3 s2) => [/eqP|/eqP Hs2|/eqP].
      * by rewrite -Hs0 => /perm_inj.
      * by move: Hs1; rewrite -Hs2 => /perm_inj.
      * left.
        apply/permP => /= i.
        case/or3P : (ord3 i) => /eqP ->; by rewrite permE //.
    + case/or3P : (ord3 s2) => [/eqP|/eqP Hs2|/eqP].
      * by rewrite -Hs0 => /perm_inj.
      * right; right; right; left.
        apply/permP => /= i.
        by case/or3P : (ord3 i) => /eqP ->; rewrite permE.
      * by rewrite -Hs1 => /perm_inj.
  - case/or3P : (ord3 s1) => [/eqP Hs1|/eqP|/eqP Hs1].
    + case/or3P : (ord3 s2) => [/eqP|/eqP|/eqP Hs2].
      * by rewrite -Hs1 => /perm_inj.
      * by rewrite -Hs0 => /perm_inj.
      * right; left.
        apply/permP => /= i.
        by case/or3P : (ord3 i) => /eqP ->; rewrite permE.
    + by rewrite -Hs0 => /perm_inj.
    + case/or3P : (ord3 s2) => [/eqP Hs2|/eqP|/eqP].
      * right; right; right; right; left.
        apply/permP => /= i.
        by case/or3P : (ord3 i) => /eqP ->; rewrite !permE //= !permE.
      * by rewrite -Hs0 => /perm_inj.
      * by rewrite -Hs1 => /perm_inj.
  - case/or3P : (ord3 s1) => [/eqP Hs1|/eqP Hs1|/eqP Hs1].
    + case/or3P : (ord3 s2) => [/eqP Hs2|/eqP Hs2|/eqP Hs2].
      * by move: Hs1; rewrite -Hs2 => /perm_inj.
      * right; right; right; right; right.
        apply/permP => /= i.
        by case/or3P : (ord3 i) => /eqP ->; rewrite !permE //= !permE.
      * by move: Hs0; rewrite -Hs2 => /perm_inj.
    + case/or3P : (ord3 s2) => [/eqP Hs2|/eqP Hs2|/eqP Hs2].
      * right; right; left.
        apply/permP => /= i.
        by case/or3P : (ord3 i) => /eqP ->; rewrite !permE //.
        by move: Hs1; rewrite -Hs2 => /perm_inj.
      * by move: Hs0; rewrite -Hs2 => /perm_inj.
      * by move: Hs0; rewrite -Hs1 => /perm_inj.
move=> -[-> // | [-> // | [-> // | ]]].
have K1 : P S3.p021 by rewrite (_ : S3.p021 = S3.p01 * S3.p02)%g //; exact/H.
have K2 : P S3.p12.
  rewrite -(_ : S3.p02 * S3.p021 = S3.p12)%g; first exact: H.
  apply/permP => i.
  case/or3P : (ord3 i) => /eqP ->; by repeat rewrite !permE /=.
have K3 : P S3.p012 by exact: H.
by move=> -[-> // | [-> // | -> //]].
Qed.

End S3.

(* TODO: move? *)
Module Sn.

Definition proj0 n (s : 'S_n.+2) (i : 'I_n.+1) : 'I_n.+1 :=
  inord (s (lift ord0 i)).-1.

Lemma proj0_inj n (s : 'S_n.+2) : s ord0 = ord0 -> injective (proj0 s).
Proof.
move=> s00 i j; rewrite /proj0 => ij.
suff : s (lift ord0 i) = s (lift ord0 j) by move/(@perm_inj _ s)/lift_inj.
apply val_inj => /=.
rewrite -[LHS]prednK ?lt0n; last first.
  suff : s (lift ord0 i) != ord0 by [].
  rewrite -[X in _ != X]s00.
  by apply/eqP => /(@perm_inj _ s).
rewrite -[RHS]prednK ?lt0n; last first.
  suff : s (lift ord0 j) != ord0 by [].
  rewrite -[X in _ != X]s00.
  by apply/eqP => /(@perm_inj _ s).
move/(congr1 val) : ij => /= ij.
rewrite inordK // in ij; last first.
  rewrite prednK ?lt0n; first by rewrite -ltnS.
  suff : s (lift ord0 i) != ord0 by [].
  rewrite -[X in _ != X]s00.
  by apply/eqP => /(@perm_inj _ s).
rewrite inordK // in ij; last first.
  rewrite prednK ?lt0n; first by rewrite -ltnS.
  suff : s (lift ord0 j) != ord0 by [].
  rewrite -[X in _ != X]s00.
  by apply/eqP => /(@perm_inj _ s).
by rewrite ij.
Qed.

Definition swap_asa n (s : 'S_n.+2) x (i : 'I_n.+1) : 'I_n.+1 :=
  if i.+1 == (s^-1 x)%g :> nat then inord (s x).-1 else inord (s (lift ord0 i)).-1.

Lemma swap_asa_inj n (s : 'S_n.+2) (K : s ord0 != ord0) : injective (swap_asa s ord0).
Proof.
move=> i j; rewrite /swap_asa.
case: ifPn => [/eqP Hi|Hi].
  case: ifPn => [/eqP Hj ?|Hj].
    move: Hi; rewrite -Hj => -[?]; exact/val_inj.
  move/(congr1 val) => /=.
  rewrite inordK //; last by rewrite prednK ?lt0n // -ltnS.
  rewrite inordK; last first.
    rewrite prednK ?lt0n; first by rewrite -ltnS.
    suff : s (lift ord0 j) != ord0 by [].
    by apply: contra Hj => /eqP <-; rewrite permK.
  move/(congr1 S).
  rewrite prednK ?lt0n // prednK ?lt0n; last first.
    apply: contra Hj => Hj.
    suff : s (lift ord0 j) = ord0 by move=> <-; rewrite permK.
    exact/eqP.
  move=> H.
  suff : s ord0 = s (lift ord0 j) by move/(@perm_inj _ s).
  exact/val_inj.
case: ifPn => Hj.
  move/(congr1 val) => /=.
  rewrite inordK; last first.
    rewrite prednK ?lt0n; first by rewrite -ltnS.
    apply: contra Hi => Hi.
    suff : s (lift ord0 i) == ord0 :> 'I_n.+2 by move=> /eqP <-; rewrite permK.
    by [].
  rewrite inordK; last by rewrite prednK ?lt0n // -ltnS.
  move/(congr1 S).
  rewrite prednK ?lt0n; last first.
    apply: contra Hi => Hi.
    suff : s (lift ord0 i) == ord0 :> 'I_n.+2 by move/eqP <-; rewrite permK.
    by [].
  rewrite prednK ?lt0n //.
  move=> Hs.
  have {Hs} : s (lift ord0 i) = s ord0 by apply/val_inj.
  by move/(@perm_inj _ s).
move/(congr1 val) => /=.
move/(congr1 S).
rewrite inordK; last first.
  rewrite prednK ?lt0n; first by rewrite -ltnS.
  apply: contra Hi => Hi.
  suff : s (lift ord0 i) == ord0 :> 'I_n.+2 by move/eqP => <-; rewrite permK.
  by [].
rewrite inordK; last first.
  rewrite prednK ?lt0n; first by rewrite -ltnS.
  apply: contra Hj => Hj.
  suff : s (lift ord0 j) == ord0 :> 'I_n.+2 by move/eqP => <-; rewrite permK.
  by [].
rewrite prednK ?lt0n //; last first.
  apply: contra Hi => Hi.
  suff : s (lift ord0 i) == ord0 :> 'I_n.+2 by move/eqP => <-; rewrite permK.
  by [].
rewrite prednK ?lt0n; last first.
  apply: contra Hj => Hj.
  suff : s (lift ord0 j) == ord0 :> 'I_n.+2 by move/eqP => <-; rewrite permK.
  by [].
move=> Hs.
have {Hs} : s (lift ord0 i) = s (lift ord0 j) by exact/val_inj.
by move /(@perm_inj _ s)/lift_inj.
Qed.

Lemma swap_asaE n (s : 'S_n.+2) (K : s ord0 != ord0) :
  s = (lift_perm ord0 ord0 (PermDef.perm (swap_asa_inj K)) * tperm (ord0) (s ord0))%g.
Proof.
apply/permP => i.
rewrite [in RHS]permE /=.
case/boolP : (i == ord0 :> 'I_n.+2) => i0.
  by rewrite (eqP i0) lift_perm_id permE.
have Hi : i = lift ord0 (inord i.-1).
  apply/val_inj => /=.
  rewrite /bump leq0n /= add1n inordK.
  by rewrite prednK // lt0n.
  by rewrite -ltnS prednK // lt0n.
rewrite {2}Hi lift_perm_lift 2!permE /= /swap_asa.
case: ifPn => /=.
  case: ifPn => /=.
    rewrite inordK; last by rewrite -ltnS prednK // lt0n.
    rewrite prednK // ?lt0n //.
    move=> si _.
    apply: (@perm_inj _ s^-1%g).
    rewrite permK; exact/eqP.
  rewrite inordK; last by rewrite -ltnS prednK // lt0n.
  rewrite prednK // ?lt0n // => si.
  move/eqP.
  move/(congr1 (s^-1%g)).
  rewrite permK => si0.
  exfalso.
  move/eqP : i0; apply.
  rewrite -si0 /=.
  apply: (@perm_inj _ s).
  rewrite permKV /=.
  apply/val_inj => /=.
  rewrite /bump leq0n add1n.
  rewrite inordK; last first.
    rewrite -ltnS prednK // lt0n -Hi.
    apply: contra si => /eqP si0'.
    apply/eqP.
    suff : i = (s^-1)%g ord0 by move/(congr1 val).
    apply: (@perm_inj _ s).
    rewrite permKV.
    exact/val_inj.
  rewrite prednK //; last first.
    rewrite lt0n -Hi.
    apply: contra si => /eqP si0'.
    apply/eqP.
    suff : i = (s^-1)%g ord0 by move/(congr1 val).
    apply: (@perm_inj _ s).
    rewrite permKV.
    exact/val_inj.
  by rewrite -Hi.
case: ifPn.
  rewrite inordK; last by rewrite -ltnS prednK // lt0n.
 rewrite prednK ?lt0n // => si.
  move=> L.
  exfalso.
  move/eqP : L; apply.
  apply/val_inj => /=.
  rewrite /bump leq0n add1n inordK; last by rewrite -ltnS // prednK // lt0n.
  by rewrite prednK // lt0n.
move=> L1 L2.
apply/val_inj => /=.
rewrite /bump leq0n add1n inordK; last first.
  rewrite -ltnS prednK // lt0n.
  apply: contra L1.
  move/eqP => L1.
  apply/eqP.
  rewrite inordK; last by rewrite -ltnS prednK // lt0n.
  rewrite prednK // ?lt0n //.
  move: L1.
  rewrite (_ : lift _ _ = i); last first.
    apply/val_inj => /=.
    by rewrite /bump leq0n add1n inordK // ?prednK // ?lt0n // -ltnS.
  move=> si.
  have : s i = ord0 by apply/val_inj.
  move/(congr1 s^-1%g).
  by rewrite permK => ->.
rewrite prednK // ?lt0n; last first.
  apply: contra L1 => /eqP L1.
  have {}L1 : s (lift ord0 (inord i.-1)) = ord0 by exact/val_inj.
  rewrite -L1 permK.
  exact/eqP.
by rewrite -Hi.
Qed.

Lemma suff_generators0 n (P : 'S_n.+2 -> Prop) :
  (forall s s', P s -> P s' -> P (s' * s)%g) ->
  (forall s : 'S_n.+2, P (tperm ord0 (s ord0))) ->
  (forall s : 'S_n.+2, s ord0 = ord0 -> P s) ->
  forall s : 'S_n.+2, P s.
Proof.
move=> H0 H1 H2 s.
case/boolP : (s ord0 == ord0 :> 'I__) => K.
  apply H2; exact/eqP.
rewrite (swap_asaE K); apply H0; first exact/H1.
apply H2; by rewrite lift_perm_id.
Qed.

Lemma decomp_swap (n : nat) (s : 'S_n.+2) (K : s ord0 != ord0) :
  tperm ord0 (s ord0) =
  ((tperm (lift ord0 ord0) (s ord0)) *
   (tperm ord0 (lift ord0 ord0)) *
   (tperm (lift ord0 ord0) (s ord0)))%g :> 'S_n.+2.
Proof.
apply /permP => /= i.
case/boolP : (i == ord0 :> 'I__) => [/eqP ->|Hi];
 first by do ! rewrite permE /=;
          have -> : (if ord0 == s ord0 then lift ord0 ord0 else ord0) = ord0
            by move => n0; rewrite ifN_eqC //=.
do ! rewrite permE /=.
rewrite ifN_eq //.
case/boolP : (i == lift ord0 ord0 :> 'I__) => [/eqP ->|Hi1].
- case/boolP : (s ord0 == lift ord0 ord0 :> 'I__) => [/eqP ->|Hs];
    first by rewrite eq_refl;
      have -> : (if lift ord0 ord0 == ord0 then lift ord0 ord0 else ord0) = ord0;
      done.
- rewrite ifN_eqC //=.
  have -> : (if s ord0 == ord0 then lift ord0 ord0 else s ord0) = s ord0 by rewrite ifN_eq.
  by rewrite ifN_eq //= eq_refl.
case/boolP : (i == s ord0 :> 'I__) => His;
first by  have -> : (if lift ord0 ord0 == lift ord0 ord0 then ord0 else lift ord0 ord0) = ord0; [by move => *; rewrite eq_refl|rewrite ifN_eqC //|done].
have -> : (if i == ord0
   then lift ord0 ord0
   else if i == lift ord0 ord0 then ord0 else i) = i by rewrite !ifN_eq.
by rewrite !ifN_eq.
Qed.

Lemma suff_generators n (P : 'S_n.+2 -> Prop) :
  (forall s s', P s -> P s' -> P (s' * s)%g) ->
  P (tperm ord0 (lift ord0 ord0)) ->
  (forall s : 'S_n.+2, s ord0 = ord0 -> P s) ->
  forall s : 'S_n.+2, P s.
Proof.
move=> H0 H1 H2 s.
case/boolP : (s ord0 == ord0 :> 'I__) => K.
  apply H2; exact/eqP.
apply suff_generators0 => // s'.
case/boolP : (s' ord0 == lift ord0 ord0 :> 'I__) => K'; first by rewrite (eqP K').
case/boolP : (s' ord0 == ord0 :> 'I__) => K''.
  by rewrite (eqP K''); apply H2; rewrite permE.
rewrite decomp_swap //.
apply H0.
  apply H2; by rewrite permE /= eq_sym (negbTE K'').
apply H0; first exact: H1.
apply H2; by rewrite permE /= eq_sym (negbTE K'').
Qed.

End Sn.

Section convex_space_prop.
Variables A : convType.
Implicit Types a b : A.
Lemma conv0 a b : a <| 0%:pr |> b = b.
Proof.
by rewrite convC (_ : _%:pr = 1%:pr) ?conv1 //=; apply val_inj; exact: onem0.
Qed.

Lemma convA0 (p q r s : prob) a b c :
  p = (r * s)%R :> R -> (s.~ = p.~ * q.~)%R ->
  a <| p |> (b <| q |> c) = (a <| r |> b) <| s |> c.
Proof.
move=> H1 H2.
case/boolP : (r == 0%:pr) => r0.
  rewrite (eqP r0) conv0 (_ : p = 0%:pr) ?conv0; last first.
    by apply/val_inj; rewrite /= H1 (eqP r0) mul0R.
  congr (_ <| _ |> _); move: H2; rewrite H1 (eqP r0) mul0R onem0 mul1R.
  move/(congr1 onem); rewrite !onemK => ?; exact/val_inj.
case/boolP : (s == 0%:pr) => s0.
  rewrite (eqP s0) conv0 (_ : p = 0%:pr) ?conv0; last first.
    by apply/val_inj; rewrite /= H1 (eqP s0) mulR0.
  rewrite (_ : q = 0%:pr) ?conv0 //.
  move: H1; rewrite (eqP s0) mulR0 => p0.
  move: H2; rewrite p0 onem0 mul1R => /(congr1 onem); rewrite !onemK => sq.
  rewrite -(eqP s0); exact/val_inj.
rewrite convA; congr ((_ <| _ |> _) <| _ |> _).
  by apply val_inj; rewrite /= s_of_pqE -H2 onemK.
by rewrite (@r_of_pq_is_r  _ _ r s).
Qed.

Lemma convA' (r s : prob) a b c : [p_of r, s] != 1%:pr ->
  a <| [p_of r, s] |> (b <| [q_of r, s] |> c) = (a <| r |> b) <| s |> c.
Proof.
move=> H; case/boolP : (s == 0%:pr) => s0.
- by rewrite (eqP s0) p_of_r0 conv0 q_of_r0 conv0 conv0.
- by rewrite convA s_of_pqK // r_of_pqK.
Qed.

Lemma convACA (x1 y1 x2 y2 : A) p q :
  (x1 <|q|> y1) <|p|> (x2 <|q|> y2) = (x1 <|p|> x2) <|q|> (y1 <|p|> y2).
Proof.
case/boolP : (p == 0%:pr) => [/eqP|] p0; first by rewrite p0 !conv0.
case/boolP : (q == 0%:pr) => [/eqP|] q0; first by rewrite q0 !conv0.
case/boolP : (p == 1%:pr) => [/eqP|] p1; first by rewrite p1 !conv1.
case/boolP : (q == 1%:pr) => [/eqP|] q1; first by rewrite q1 !conv1.
set r := [p_of q, p].
have r1 : (r != 1%:pr)%R by rewrite p_of_neq1 // -prob_gt0 -prob_lt1.
rewrite -(convA' x1 y1) //.
rewrite (convC _ y1).
set s := [q_of q, p].
set t := (s.~%:pr * q)%:pr.
have t1 : (t < 1)%R.
  rewrite -prob_lt1; apply/eqP => t1; subst t.
  have {q1} : (q < 1)%R by rewrite -prob_lt1.
  move/(congr1 Prob.p) : t1 => /= <-.
  rewrite -ltR_pdivr_mulr; last by rewrite -prob_gt0.
  rewrite divRR // /onem ltR_subr_addl ltRNge; apply.
  by rewrite -{1}(add0R 1%R) leR_add2r.
rewrite -(convA' x2); last by rewrite prob_lt1 p_of_rsC /= p_of_rsE.
rewrite -(convA' x1) //; last by rewrite p_of_rsC.
rewrite (convC _ y2 y1) /=.
congr (_ <| _ |> _); first by rewrite p_of_rsC.
congr (_ <| _ |> _).
  (* TODO: lemma? *)
  apply val_inj => /=.
  rewrite /s /onem /= !(p_of_rsE,q_of_rsE) /= !(p_of_rsE,q_of_rsE) /= /onem.
  field.
  rewrite subR_eq0 mulRC; apply/nesym/eqP; by rewrite -p_of_rsE.
congr (_ <| _ |> _).
apply val_inj => /=.
rewrite -[in RHS](onemK p); congr onem.
rewrite q_of_rsE {1}p_of_rsE /= q_of_rsE p_of_rsE /= /onem; field.
split.
  rewrite subR_eq0; apply/nesym/eqP; by rewrite -p_of_rsE.
rewrite mulRBl mul1R subRBA subRK mulRDr mulR1 mulRN addR_opp subRBA subRK.
rewrite subR_eq0 => /esym; exact/eqP.
Qed.

Lemma distribute (x y z : A) (p q : prob) :
  x <| p |> (y <| q |> z) = (x <| p |> y) <| q |> (x <| p |> z).
Proof. by rewrite -{1}(convmm q x) convACA. Qed.

Lemma Convn_fdist1 (n : nat) (j : 'I_n) (g : 'I_n -> A): <|>_(fdist1 j) g = g j.
Proof.
elim: n j g => [[] [] //|n IH j g /=].
case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb b01].
  rewrite fdist1E; case j0 : (_ == _) => /=.
    by move=> _; rewrite (eqP j0).
  by rewrite (_ : (0%:R)%R = 0%R) //; lra.
rewrite (_ : probfdist _ _ = 0%:pr) ?conv0; last first.
  apply val_inj => /=; move: b01; rewrite !fdist1E => j0.
  by case j0' : (_ == _) => //; rewrite j0' eqxx in j0.
have j0 : ord0 != j by apply: contra b01 => /eqP <-; rewrite fdist1xx.
have j0' : 0 < j by rewrite lt0n; apply: contra j0 => /eqP j0; apply/eqP/val_inj.
move=> [:H]; have @j' : 'I_n.
  by apply: (@Ordinal _ j.-1 _); abstract: H; rewrite prednK // -ltnS.
rewrite (_ : fdist_del b01 = fdist1 j'); last first.
  apply/fdist_ext => /= k.
  rewrite fdist_delE fdistD1E /= !fdist1E /= (negbTE j0) subR0 divR1.
  congr (INR (nat_of_bool _)).
  move R : (k == _) => [|].
  - apply/eqP/val_inj; rewrite /= /bump leq0n add1n.
    by move/eqP : R => -> /=; rewrite prednK // lt0n.
  - apply: contraFF R => /eqP.
    move/(congr1 val) => /=; rewrite /bump leq0n add1n => kj.
    by apply/eqP/val_inj; rewrite /= -kj.
rewrite IH /fdist_del_idx ltn0; congr g.
by apply val_inj; rewrite /= /bump leq0n add1n prednK // lt0n.
Qed.

Lemma convn1E a e : <|>_e (fun _ : 'I_1 => a) = a.
Proof.
rewrite /=; case: Bool.bool_dec => // /Bool.eq_true_not_negb H; exfalso; move/eqP: H; apply.
by apply/eqP; rewrite fdist1E1 (fdist1I1 e).
Qed.

Lemma convnE n (g : 'I_n.+1 -> A) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%R) :
  <|>_d g =
  g ord0 <| probfdist d ord0 |> <|>_(fdist_del i1) (fun x => g (fdist_del_idx ord0 x)).
Proof.
rewrite /=; case: Bool.bool_dec => /= [|/Bool.eq_true_not_negb] H.
exfalso; by rewrite (eqP H) eqxx in i1.
by rewrite (boolp.Prop_irrelevance H i1).
Qed.

Lemma convn2E (g : 'I_2 -> A) (d : {fdist 'I_2}) :
  <|>_d g = g ord0 <| probfdist d ord0 |> g (Ordinal (erefl (1 < 2))).
Proof.
case/boolP : (d ord0 == 1%R) => [|i1].
  rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1.
  rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //.
  by apply val_inj; rewrite /= fdist1xx.
rewrite convnE; congr (_ <| _ |> _).
rewrite (_ : (fun _ => _) = (fun=> g (fdist_del_idx ord0 ord0))); last first.
  by rewrite boolp.funeqE => x; rewrite (ord1 x).
by rewrite convn1E /fdist_del_idx ltnn; congr g; exact/val_inj.
Qed.

Lemma convn3E (g : 'I_3 -> A) (d : {fdist 'I_3}) (p : prob) :
  d ord0 != 1%R ->
  p = (d (lift ord0 ord0) / (1 - d ord0))%R :> R ->
  <|>_d g = g ord0 <| probfdist d ord0 |> (g (Ordinal (erefl (1 < 3)%nat)) <| p |> g (Ordinal (erefl (2 < 3)%nat))).
Proof.
move=> i1 Hp.
case/boolP : (p == 1%:pr) => p1.
  rewrite convnE; congr (_ <| _ |> _).
  rewrite convn2E /fdist_del_idx ltnn /=; congr (g _ <| _ |> g _).
  apply val_inj => /=.
  by rewrite fdist_delE fdistD1E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)) -Hp.
  exact/val_inj.
  exact/val_inj.
rewrite convnE; congr (_ <| _ |> _).
rewrite convn2E /fdist_del_idx ltnn /=; congr (g _ <| _ |> g _).
- apply val_inj => /=.
  by rewrite fdist_delE fdistD1E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)).
- exact/val_inj.
- exact/val_inj.
Qed.

Lemma convn_proj n (g : 'I_n -> A) (d : {fdist 'I_n}) i :
  d i = R1 -> <|>_d g = g i.
Proof.
elim: n g d i => [d d0|n IH g d i di1]; first by move: (fdistI0_False d0).
case/boolP : (i == ord0) => [/eqP|]i0.
  move/eqP : di1; rewrite i0 fdist1E1 => /eqP ->.
  by rewrite Convn_fdist1.
have d00 : d ord0 = R0 by move/eqP/fdist1P : di1 => -> //; rewrite eq_sym.
rewrite convnE; first by rewrite d00; apply/eqP; lra.
move=> d01.
rewrite (_ : probfdist _ _ = 0%:pr); last exact/val_inj.
rewrite conv0.
move=> [:Hj].
have @j : 'I_n.
  apply: (@Ordinal _ i.-1).
  abstract: Hj; by rewrite prednK // ?lt0n // -ltnS.
rewrite (IH _ _ j) // ?ltn0.
  congr g; apply val_inj => /=.
  by rewrite /bump leq0n add1n prednK // lt0n.
rewrite fdist_delE ltn0 fdistD1E eq_sym (negbTE (neq_lift _ _ )).
rewrite d00 subR0 divR1 -di1; congr (d _).
by apply val_inj; rewrite /= /bump leq0n add1n prednK // lt0n.
Qed.

(* goal: Conv_perm *)

Lemma Convn_perm_1 n (d : {fdist 'I_n}) (g : 'I_n -> A) :
  <|>_d g = <|>_(fdistI_perm d 1%g) (g \o (1%g : 'S_n)).
Proof.
rewrite fdistI_perm1; congr (Convn d _).
by rewrite boolp.funeqE => i /=; rewrite perm1.
Qed.

Lemma Convn_permI1 (d : {fdist 'I_1}) (g : 'I_1 -> A) (s : 'S_1) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
have s1 : s = 1%g.
  apply/permP => i; by case: (s i) => -[|//] ?; rewrite perm1 (ord1 i); exact/val_inj.
by rewrite s1 -Convn_perm_1.
Qed.

Lemma Convn_permI2 (d : {fdist 'I_2}) (g : 'I_2 -> A) (s : 'S_2) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
have [->|Hs] := S2.generators s.
  rewrite fdistI_perm1; congr Convn.
  by rewrite boolp.funeqE => i; rewrite /= perm1.
move: (FDist.ge0 d ord0); rewrite leR_eqVlt => -[/esym d00|d00].
  have d11 : d (Ordinal (erefl (1 < 2))) = 1%R.
    rewrite -(FDist.f1 d) 2!big_ord_recl big_ord0 addR0 d00 add0R; f_equal; exact/val_inj.
  have H1 : d = fdist1 (Ordinal (erefl (1 < 2))).
    rewrite -fdistI20; apply/fdist_ext => /= i.
    rewrite fdistI2E; case: ifPn => [/eqP ->//|/= i0]; rewrite onem0.
    rewrite -(FDist.f1 d) 2!big_ord_recl big_ord0 addR0 d00 add0R; congr (d _).
    by case: i i0 => -[//|] -[|//] //= i12 _; exact/val_inj.
  rewrite {1}H1 Convn_fdist1 {1}Hs.
  have H2 : fdistI_perm d (tperm ord0 (Ordinal (erefl (1 < 2)))) = fdist1 ord0.
    apply/fdist_ext => /= i; rewrite fdistI_permE fdist1E.
    case/boolP : (i == ord0 :> 'I__) => i0.
      by rewrite (eqP i0) permE /= d11.
    rewrite permE /= (negbTE i0).
    by case: ifPn => //; case: i i0 => -[|[|]].
  by rewrite H2 Convn_fdist1 /=; congr g; rewrite Hs permE /=.
case/boolP : (d (lift ord0 ord0) == 0%R :> R) => d10.
  have d01 : d ord0 = 1%R.
    rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
    by rewrite addRC -subR_eq subRR (eqP d10).
  have -> : d = fdist1 ord0 by apply/eqP; rewrite -fdist1E1; exact/eqP.
  by rewrite Convn_fdist1 {1}Hs fdistI_tperm Convn_fdist1 /= Hs permE.
rewrite convn2E.
rewrite convn2E.
rewrite /= Hs permE /= convC !permE /=; congr (_ <| _ |> _); apply val_inj => /=.
rewrite fdistI_permE permE /= /onem -(FDist.f1 d) !big_ord_recl big_ord0.
by rewrite addR0 addRC addRK; congr (d _); exact/val_inj.
Qed.

Lemma Convn_permI3_p01 (d : {fdist 'I_3}) (g : 'I_3 -> A) :
  <|>_d g = <|>_(fdistI_perm d S3.p01) (g \o S3.p01).
Proof.
have : (d ord0 + d (lift ord0 ord0) = 0 \/ d (lift ord0 ord0) + d ord_max = 0 \/
  (0 < d ord0 + d (lift ord0 ord0) /\ 0 < d (lift ord0 ord0) + d ord_max))%R.
  have : (0 <= d ord0 + d (lift ord0 ord0))%R by apply addR_ge0.
  have : (0 <= d (lift ord0 ord0) + d ord_max)%R by apply addR_ge0.
  rewrite leR_eqVlt => -[|H]; first by auto.
  rewrite leR_eqVlt => -[|H']; first by auto.
  right; right; by auto.
move=> [ H | [ H | [H1 H2] ] ].
  have /eqP d1 : d ord_max = 1%R.
    rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addR0 addRA H add0R.
    by congr (d _); exact/val_inj.
  rewrite fdist1E1 in d1.
  rewrite {1}(eqP d1) Convn_fdist1.
  by rewrite (eqP d1) fdistI_perm_fdist1 Convn_fdist1 /= permKV.
  have /eqP : d ord0 = 1%R.
    rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addR0 addRC -subR_eq subRR.
    by rewrite (_ : lift ord0 (lift _ _) = ord_max) ?H //; exact/val_inj.
  rewrite fdist1E1 => /eqP ->.
  by rewrite Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV.
have d01 : d ord0 <> 1%R.
  move=> /eqP d01.
  move: H2.
  move/fdist1P : (d01) => -> //.
  move/fdist1P : d01 => -> //.
  by rewrite add0R; move/ltRR.
move=> [:Hp].
have @p : prob.
  apply: (@Prob.mk_ (d (lift ord0 ord0) / (1 - d ord0))).
  abstract: Hp.
  split.
    apply/divR_ge0 => //.
    by rewrite subR_gt0 -fdist_lt1; exact/eqP.
  rewrite leR_pdivr_mulr ?mul1R ?subR_gt0 -?fdist_lt1; last exact/eqP.
  rewrite leR_subr_addr -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
  by rewrite addRC leR_add2l addRC -leR_subl_addr subRR.
case/boolP : (p == 1%:pr :> prob) => [/eqP |p1].
  move/(congr1 Prob.p); rewrite [in X in X -> _]/=.
  rewrite eqR_divr_mulr ?mul1R; last by apply/eqP; rewrite subR_eq0; exact/nesym.
  move=> H.
  rewrite (@convn3E _ _ 1%:pr) ?conv1; last 2 first.
    exact/eqP.
    by rewrite H divRR // subR_eq0' eq_sym; exact/eqP.
  case/boolP : (d ord0 == 0 :> R)%R => d00.
    rewrite (_ : probfdist _ _ = 0%:pr) ?conv0; last by apply val_inj => /=; exact/eqP.
    move: H; rewrite (eqP d00) subR0 => /eqP; rewrite fdist1E1 => /eqP ->.
    by rewrite fdistI_perm_fdist1 Convn_fdist1 /= permKV; congr g; exact/val_inj.
  rewrite (@convn3E _ _ 1%:pr) ?conv1; last first.
    rewrite !fdistI_permE /S3.p01 /= !permE /=.
    rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
    by rewrite H subRB subRR add0R divRR.
  rewrite /S3.p01 /= fdistI_permE permE /=.
  rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  apply: contra d00 => /eqP d001.
  move: H; rewrite d001 => /esym.
  by rewrite subR_eq addRC -subR_eq subRR => <-.
  rewrite /= /S3.p01 !permE /= convC.
  congr (g _ <| _ |> g _).
  apply/val_inj; rewrite /= fdistI_permE permE /=.
  by rewrite (_ : Ordinal _ = lift ord0 ord0) ?H //; exact/val_inj.
rewrite (@convn3E _ _ p) //; last exact/eqP.
rewrite convA.
rewrite (convC _ (g ord0)).
have H : [p_of [r_of probfdist d ord0, p].~%:pr, [s_of probfdist d ord0, p]] != 1%:pr :> R.
  apply p_of_neq1.
  rewrite s_of_pqE /=.
  rewrite onemM !onemK -subRBA -[X in (_ < _ - (_ - X) < _)%R]mul1R.
  rewrite -mulRBl -addR_opp -mulNR oppRB /Rdiv mulRCA mulRV ?mulR1; last first.
    apply/eqP; rewrite subR_eq0; by auto.
  split => //.
  rewrite ltR_neqAle; split.
    apply/eqP; apply: contra p1 => p1.
    apply/eqP/val_inj => /=.
    move: p1; rewrite eq_sym addRC -subR_eq' => /eqP <-.
    rewrite divRR // subR_eq0'; apply/eqP; by auto.
  by rewrite -(FDist.f1 d) !big_ord_recl /= big_ord0 addR0 addRA leR_addl.
rewrite -convA'; last by [].
case/boolP : (d (S3.p01 ord0) == 1 :> R)%R => ds01.
  move: (ds01); rewrite /S3.p01 permE => d01'.
  rewrite /= in d01'.
  rewrite (_ : Ordinal _ = lift ord0 ord0) in d01'; last exact/val_inj.
  rewrite fdist1E1 in d01'.
  rewrite fdist1E1 in ds01.
  rewrite [in RHS](eqP ds01) fdistI_perm_fdist1 Convn_fdist1 /= permKV.
  rewrite (_ : [p_of _, _] = 1%:pr); last first.
    apply/val_inj => /=.
    rewrite p_of_rsE /= r_of_pqE /= s_of_pqE /= (eqP d01').
    by rewrite fdist10// div0R onem0 subR0 !mul1R divR1 onemK fdist1xx.
  by rewrite conv1 /S3.p01 permE /= (_ : Ordinal _ = lift ord0 ord0) //; exact/val_inj.
move=> [:Hq].
have @q : prob.
  apply: (@Prob.mk_
    ((fdistI_perm d S3.p01) (lift ord0 ord0) / (1 - (fdistI_perm d S3.p01) ord0))).
  abstract: Hq.
  rewrite !fdistI_permE.
  split; first by apply/divR_ge0 => //; rewrite subR_gt0 -fdist_lt1.
  rewrite leR_pdivr_mulr ?mul1R; last by rewrite subR_gt0 -fdist_lt1.
  rewrite leR_subr_addr -(FDist.f1 (fdistI_perm d S3.p01)) !big_ord_recl big_ord0.
  by rewrite addR0 !fdistI_permE addRCA addRA -[X in (X <= _)%R]addR0 leR_add2l.
rewrite (@convn3E _ _ q) //; last by rewrite fdistI_permE.
congr (_ <| _ |> _).
  apply/val_inj => /=.
  rewrite fdistI_permE permE /= p_of_rsE /= r_of_pqE /=.
  rewrite s_of_pqE /= /onem.
  rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  field.
  split; first by rewrite subR_eq0; exact/nesym.
  rewrite -addR_opp oppRB -addR_opp oppRB addRC addRA subRK.
  by apply/eqP; rewrite gtR_eqF // addRC.
by rewrite /= /S3.p01 permE /=; congr g; exact/val_inj.
congr (_ <| _ |> _).
  apply val_inj => /=.
  rewrite q_of_rsE /= !fdistI_permE p_of_rsE /= r_of_pqE /= s_of_pqE.
  rewrite /= /onem !permE /=.
  rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  field.
  split.
    rewrite subR_eq0.
    apply/nesym/eqP.
    apply: contra ds01.
    rewrite /S3.p01 permE /= (_ : Ordinal _ = lift ord0 ord0) //; exact/val_inj.
  split; first by rewrite subR_eq0; exact/nesym.
  rewrite -addR_opp oppRB -addR_opp oppRB addRC addRA subRK.
  by apply/eqP; rewrite gtR_eqF // addRC.
by congr g; apply val_inj => /=; rewrite /S3.p01 permE.
by rewrite /= /S3.p01 permE.
Qed.

Lemma Convn_permI3_p02 (d : {fdist 'I_3}) (g : 'I_3 -> A) :
  <|>_d g = <|>_(fdistI_perm d S3.p02) (g \o S3.p02).
Proof.
(* TODO(rei): redundant part with Convn_perm3_p02 *)
have : (d ord0 + d (lift ord0 ord0) = 0 \/ d (lift ord0 ord0) + d ord_max = 0 \/
  (0 < d ord0 + d (lift ord0 ord0) /\ 0 < d (lift ord0 ord0) + d ord_max))%R.
  have : (0 <= d ord0 + d (lift ord0 ord0))%R by apply addR_ge0.
  have : (0 <= d (lift ord0 ord0) + d ord_max)%R by apply addR_ge0.
  rewrite leR_eqVlt => -[|H]; first by auto.
  rewrite leR_eqVlt => -[|H']; first by auto.
  right; right; by auto.
move=> [ H | [ H | [H1 H2] ] ].
  have /eqP d1 : d ord_max = 1%R.
    rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addR0 addRA H add0R; congr (d _); exact/val_inj.
  rewrite fdist1E1 in d1.
  rewrite {1}(eqP d1) Convn_fdist1.
  by rewrite (eqP d1) fdistI_perm_fdist1 Convn_fdist1 /= permKV.
  have /eqP d1 : d ord0 = 1%R.
    rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addR0 addRC -subR_eq subRR.
    rewrite (_ : lift ord0 (lift _ _) = ord_max) ?H //; exact/val_inj.
  rewrite fdist1E1 in d1.
  by rewrite (eqP d1) Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV.
have d01 : d ord0 <> 1%R.
  move=> /eqP d01.
  move: H2.
  move/fdist1P : (d01) => -> //.
  move/fdist1P : d01 => -> //.
  by rewrite add0R; move/ltRR.
move=> [:Hp].
have @p : prob.
  apply: (@Prob.mk_ (d (lift ord0 ord0) / (1 - d ord0))).
  abstract: Hp.
  split; first by apply/divR_ge0 => //; rewrite subR_gt0 -fdist_lt1; exact/eqP.
  rewrite leR_pdivr_mulr ?mul1R ?subR_gt0 -?fdist_lt1; last exact/eqP.
  rewrite leR_subr_addr -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
  by rewrite addRC leR_add2l addRC -leR_subl_addr subRR.
rewrite (@convn3E _ _ p) //; last exact/eqP.
rewrite convC.
rewrite (convC _ _ (g (Ordinal (erefl (2 < 3))))).
case/boolP : (d ord_max == 1%R :> R) => dmax1.
  move/fdist1P in dmax1.
  by move: H1; rewrite dmax1 // dmax1 // addR0 => /ltRR.
case/boolP : (d ord0 == 0 :> R)%R => d00.
  rewrite (_ : (probfdist _ _).~%:pr = 1%:pr) ?conv1; last first.
    by apply/val_inj; rewrite /= (eqP d00) onem0.
  rewrite (@convn3E _ _ 1%:pr); last 2 first.
    rewrite fdistI_permE /= !permE /=.
    rewrite (_ : Ordinal _ = ord_max) //; exact/val_inj.
    rewrite !fdistI_permE /S3.p02 !permE /=.
    rewrite (_ : Ordinal _ = ord_max) //; last exact/val_inj.
    rewrite -{2}(FDist.f1 d) !big_ord_recl big_ord0 addR0 (eqP d00) add0R.
    rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj.
    rewrite addRK divRR //.
    apply/eqP => d10.
    by move: H1; rewrite (eqP d00) d10 addR0 => /ltRR.
  rewrite /= /S3.p02 !permE /= conv1.
  congr (g _ <| _ |> _).
  apply/val_inj => /=.
  rewrite fdistI_permE permE /=.
  rewrite (_ : Ordinal _ = ord_max) //; last exact/val_inj.
  rewrite (eqP d00) subR0 divR1 /onem -(FDist.f1 d) /= !big_ord_recl big_ord0 addR0.
  rewrite (eqP d00) add0R addRC addRK; congr (d _); exact/val_inj.
have H : [p_of p.~%:pr, (probfdist d ord0).~%:pr] != 1%:pr.
  apply p_of_neq1 => /=; split.
    apply/onem_gt0; rewrite -fdist_lt1; exact/eqP.
  by rewrite ltR_subl_addr ltR_addl -fdist_gt0.
rewrite -convA'; last by [].
move=> [:Hq].
have @q : prob.
  apply: (@Prob.mk_ ((fdistI_perm d S3.p02) (lift ord0 ord0)
                     / (1 - (fdistI_perm d S3.p02) ord0))).
  abstract: Hq.
  rewrite !fdistI_permE !permE /= (_ : Ordinal _ = ord_max); last exact/val_inj.
  split.
    apply/divR_ge0 => //; first by rewrite subR_gt0 -fdist_lt1.
  rewrite leR_pdivr_mulr ?mul1R ?subR_gt0 -?fdist_lt1 //.
  rewrite leR_subr_addr -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
  by rewrite (_ : lift _ (lift _ _) = ord_max) ?leR_addr //; exact/val_inj.
rewrite (@convn3E _ _ q) //; last first.
  rewrite fdistI_permE permE /= (_ : Ordinal _ = ord_max) //; exact/val_inj.
rewrite /= !permE /=.
congr (g _ <| _ |> (_ <| _ |> _)).
  apply val_inj => /=.
  rewrite !fdistI_permE p_of_rsE /= permE /=.
  rewrite (_ : Ordinal _ = ord_max); last exact/val_inj.
  rewrite {1}/onem.
  rewrite mulRBl mul1R /Rdiv -mulRA mulVR ?mulR1; last first.
    rewrite subR_eq0' eq_sym; exact/eqP.
  rewrite /onem -subRD subR_eq -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
  rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj.
  by rewrite [in RHS]addRC -addRA.
apply val_inj => /=.
rewrite !fdistI_permE !permE /= q_of_rsE /= p_of_rsE /=.
rewrite (_ : Ordinal _ = ord_max); last exact/val_inj.
rewrite onemK.
rewrite {1 2}/Rdiv.
rewrite -2!mulRA.
rewrite [in RHS]/Rdiv.
congr (_ * _)%R.
rewrite mulRA mulVR; last first.
  rewrite subR_eq0' eq_sym; exact/eqP.
rewrite mul1R.
congr Rinv.
rewrite onemM !onemK.
rewrite addRC.
rewrite -{1}(mulR1 (d (lift ord0 ord0) / _))%R.
rewrite -subRBA.
rewrite -mulRBr.
rewrite -addR_opp.
rewrite -mulRN.
rewrite oppRB.
rewrite /Rdiv.
rewrite -mulRA.
rewrite mulVR ?mulR1; last first.
  rewrite subR_eq0' eq_sym; exact/eqP.
apply/esym; rewrite subR_eq -(FDist.f1 d) !big_ord_recl big_ord0 addR0.
rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj.
by rewrite addRA.
Qed.

Lemma Convn_permI3 (d : {fdist 'I_3}) (g : 'I_3 -> A) (s : 'S_3) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
move: s d g.
apply: S3.suff_generators; last first.
  move=> s s' Hs Hs' d g.
  rewrite Hs Hs' fdistI_permM; congr (Convn _ _).
  by rewrite boolp.funeqE => i /=; rewrite permE.
exact: Convn_permI3_p02.
exact: Convn_permI3_p01.
exact: Convn_perm_1.
Qed.

Lemma Convn_perm_projection n (d : {fdist 'I_n.+2})
  (g : 'I_n.+2 -> A) (s : 'S_n.+2) (H : s ord0 = ord0) (dmax1 : d ord0 != 1%R)
  (m : nat) (nm : n.+1 < m) (IH : forall n : nat, n < m -> forall (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n),
    <|>_d g = <|>_(fdistI_perm d s) (g \o s)) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
transitivity (g ord0 <| probfdist d ord0 |> (<|>_(fdist_del dmax1) (fun x => g (fdist_del_idx ord0 x)))).
  by rewrite convnE.
set s' : 'S_n.+1 := PermDef.perm (Sn.proj0_inj H).
transitivity (g ord0 <| probfdist d ord0 |> (<|>_(fdistI_perm (fdist_del dmax1) s') ((fun x => g (fdist_del_idx ord0 x)) \o s'))).
  by rewrite -IH.
transitivity (g (s ord0) <| probfdist d ord0 |> (<|>_(fdistI_perm (fdist_del dmax1) s') ((fun x => g (fdist_del_idx ord0 x)) \o s'))).
  by rewrite H.
rewrite [in RHS]convnE //.
  by rewrite fdistI_permE H.
move=> K.
congr (_ <| _ |> _).
  apply val_inj => /=; by rewrite fdistI_permE H.
congr (Convn _ _).
  apply/fdist_ext => /= j.
  rewrite !fdistI_permE !fdist_delE !fdistD1E !fdistI_permE.
  rewrite /s' /=.
  rewrite permE.
  rewrite /f /=.
  rewrite H; congr (_ / _)%R.
  congr (d _).
  apply val_inj => /=.
  rewrite /bump leq0n add1n /=.
  rewrite inordK //; last first.
    rewrite prednK //.
      by rewrite -ltnS.
    rewrite lt0n.
    suff : s (lift ord0 j) != ord0 by [].
    rewrite -[in X in _ != X]H.
    by apply/eqP => /(@perm_inj _ s).
  rewrite prednK // lt0n.
  suff : s (lift ord0 j) != ord0 by [].
  rewrite -[in X in _ != X]H.
  by apply/eqP => /(@perm_inj _ s).
rewrite boolp.funeqE => j /=.
rewrite /fdist_del_idx /= /s' permE /f /=.
congr g.
apply val_inj => /=.
rewrite /bump leq0n add1n /=.
rewrite inordK //; last first.
  rewrite prednK //.
    by rewrite -ltnS.
  rewrite lt0n.
  suff : s (lift ord0 j) != ord0 by [].
  rewrite -[X in _ != X]H.
  by apply/eqP => /(@perm_inj _ s).
rewrite prednK // lt0n.
suff : s (lift ord0 j) != ord0 by [].
rewrite -[X in _ != X]H.
by apply/eqP => /(@perm_inj _ s).
Qed.

Lemma Convn_perm_tperm (n : nat) (d : {fdist 'I_n.+3})
  (g : 'I_n.+3 -> A) (s : 'S_n.+3) (H : s = tperm ord0 (lift ord0 ord0)) (dmax1 : d ord0 != 1%R)
  (m : nat) (nm : n.+3 < m.+1) (IH : forall n : nat, n < m ->
       forall (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n),
       <|>_d g = <|>_(fdistI_perm d s) (g \o s)) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
case/boolP : (d (lift ord0 ord0) == 1 - d ord0 :> R)%R => K.
  case/boolP : (d (lift ord0 ord0) == 1%R :> R) => [|d11].
    by rewrite fdist1E1 => /eqP ->; rewrite fdistI_perm_fdist1 !Convn_fdist1 /= permKV.
  rewrite convnE.
  rewrite [in RHS]convnE.
    by rewrite fdistI_permE H permE.
  move=> K'.
  rewrite (_ : <|>_ _ _ = g (lift ord0 ord0)); last first.
    have /eqP : (fdist_del dmax1) ord0 = 1%R.
      by rewrite fdist_delE fdistD1E /= (eqP K) divRR // subR_eq0' eq_sym.
    rewrite fdist1E1 => /eqP ->.
    by rewrite Convn_fdist1.
  rewrite (_ : <|>_ _ _ = g ord0); last first.
    have /eqP : (fdist_del K') ord0 = 1%R.
      rewrite fdist_delE fdistD1E /= !fdistI_permE H !permE /=.
      rewrite (eqP K) subRB subRR add0R divRR //.
      apply/eqP => d00.
      move: K; by rewrite d00 subR0 (negbTE d11).
    by rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1 /= H !permE /=.
  rewrite convC /= H permE /=; congr (_ <| _ |> _).
  by apply val_inj => /=; rewrite fdistI_permE /= permE /= (eqP K).
case/boolP : (d (lift ord0 ord0) == 1%R :> R) => [|K1].
  by rewrite fdist1E1 => /eqP ->; rewrite fdistI_perm_fdist1 !Convn_fdist1 /= permKV.
(* TODO: isolate this construction? *)
pose D' : {ffun 'I_3 -> R} := [ffun x => [eta (fun=>R0) with
  ord0 |-> d ord0,
  lift ord0 ord0 |-> d (lift ord0 ord0),
  ord_max |-> (\sum_(i < n.+3 | (2 <= i)%nat) d i)%R] x].
have D'0 : (forall i, 0 <= D' i)%R.
  move=> i; rewrite /D' ffunE /=; case: ifPn => _ //.
  by case: ifPn => _ //; case: ifPn => _; [exact: sumR_ge0 | exact/leRR].
have D'1 : (\sum_(i < 3) (D' i) = 1)%R.
  rewrite !big_ord_recr big_ord0 /= add0R.
  rewrite /D' !ffunE /= -(FDist.f1 d).
  apply/esym.
  rewrite 2!big_ord_recl addRA; congr (_ + _)%R.
  apply/esym.
  set h : 'I_n.+1 -> 'I_n.+3 := fun i => lift ord0 (lift ord0 i).
  set h' : 'I_n.+3 -> 'I_n.+1 := fun i => inord (i.-2).
  rewrite (reindex_onto h h'); last first.
    move=> j /= j1.
    rewrite /h /h'.
    apply val_inj => /=.
    rewrite /bump /bump !leq0n !add1n inordK //; last first.
      rewrite prednK; last by rewrite -subn1 subn_gt0.
      by rewrite -subn1 leq_subLR add1n -ltnS.
    rewrite prednK; last by rewrite -subn1 subn_gt0.
    by rewrite prednK // (leq_trans _ j1).
  apply eq_big => //= i.
  rewrite /h' /h.
  by apply/eqP/val_inj => /=; rewrite inordK.
set D := FDist.make D'0 D'1.
have H1 : (fdist_del dmax1) ord0 != 1%R.
  rewrite fdist_delE fdistD1E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)).
  apply/eqP.
  rewrite eqR_divr_mulr ?mul1R; first exact/eqP.
  by apply/eqP; rewrite subR_eq0; exact/nesym/eqP.
pose G : 'I_3 -> A := [eta (fun=>g ord0) with
  ord0 |-> g ord0,
  lift ord0 ord0 |-> g (lift ord0 ord0),
  ord_max |-> <|>_(fdist_del H1) (fun i : 'I_n.+1 => g (lift ord0 (lift ord0 i)))].
transitivity (Convn D G).
  erewrite convn3E.
  rewrite convnE.
  congr (_ <| _ |> _).
  by apply/val_inj => /=; rewrite ffunE.
  rewrite convnE.
  rewrite /G.
  congr (_ <| _ |> _).
  by rewrite ffunE.
  by rewrite /= !ffunE fdist_delE fdistD1E.
rewrite (Convn_permI3 _ _ S3.p01).
pose q' := (d ord0 / (1 - d (lift ord0 ord0)))%R.
move=> [:Hq].
have @q : prob.
  apply: (@Prob.mk_ q').
  abstract: Hq.
  split; first by apply/divR_ge0 => //; rewrite subR_gt0 -fdist_lt1.
  rewrite leR_pdivr_mulr.
  rewrite mul1R.
  rewrite leR_subr_addr -(FDist.f1 d).
  rewrite 2!big_ord_recl addRA leR_addl.
  apply: sumR_ge0 => i _ //.
  by rewrite subR_gt0 -fdist_lt1.
rewrite (@convn3E _ _ q); last 2 first.
  rewrite fdistI_permE permE /= (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  by rewrite /D' ffunE /=.
  rewrite /= !fdistI_permE /= !permE /= (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  by rewrite !ffunE.
rewrite convnE.
  by rewrite fdistI_permE H !permE.
move=> K2.
congr (_ <| _ |> _).
  apply val_inj => /=.
  rewrite !fdistI_permE !permE /= (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj.
  by rewrite ffunE H !permE.
by rewrite /= /G /= permE /= H permE /=.
rewrite convnE.
  rewrite fdist_delE fdistD1E !fdistI_permE H !permE /=.
  apply/eqP.
  rewrite eqR_divr_mulr ?mul1R.
    move/esym.
    rewrite subR_eq; apply/eqP.
    apply: contra K => /eqP ->.
    by rewrite addRC addRK.
  by rewrite subR_eq0' eq_sym.
move=> K3.
congr (_ <| _ |> _).
  apply val_inj => /=.
  by rewrite !fdist_delE !fdistD1E /= !fdistI_permE H !permE.
by rewrite /= /G /= !permE /= /fdist_del_idx ltnn H permE /=.
pose s' : 'S_n.+1 := 1%g.
rewrite (@IH _ _ _ _ s') //; last by rewrite -ltnS ltnW.
transitivity (<|>_(fdist_del H1) (fun i : 'I_n.+1 => g (lift ord0 (lift ord0 i)))).
  by rewrite /G [in LHS]/= !permE [in LHS]/=.
congr (Convn _ _).
  apply/fdist_ext => j.
  rewrite !(fdist_delE,fdistI_permE,fdistD1E).
  rewrite H !permE /=.
  field.
  split.
    rewrite subR_eq0; by apply/nesym/eqP.
  split.
    apply/eqP; apply: contra K => /eqP.
    rewrite subR_eq0 => <-.
  by rewrite subRB subRR add0R.
by rewrite subR_eq0; apply/nesym/eqP.
by rewrite boolp.funeqE => j; rewrite /= permE H permE.
Qed.

Lemma Convn_perm (n : nat) (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n) :
  <|>_d g = <|>_(fdistI_perm d s) (g \o s).
Proof.
move: d g s.
elim: n.+1 {-2}n (ltnSn n) => {n} // m IH n nm d g s.
destruct n as [|n]; first by move: (fdistI0_False d).
destruct n as [|n]; first exact: Convn_permI1.
destruct n as [|n]; first exact: Convn_permI2.
destruct n as [|n]; first exact: Convn_permI3.
move: m IH nm d g.
apply (@Sn.suff_generators _ (fun s => forall m : nat,
  (forall n0, n0 < m ->
   forall (d : {fdist 'I_n0}) (g : 'I_n0 -> A) (s0 : 'S_n0),
   <|>_d g = <|>_(fdistI_perm d s0) (g \o s0)) ->
  n.+4 < m.+1 ->
  forall (d : {fdist 'I_n.+4}) (g : 'I_n.+4 -> A),
  <|>_d g = <|>_(fdistI_perm d s) (g \o s))).
- move=> s1 s2 H1 H2 m IH nm d g.
  rewrite (H1 m) // (H2 m) // fdistI_permM; congr (Convn _ _).
  by rewrite boolp.funeqE => i; rewrite /= permM.
- move=> m IH nm d g.
  case/boolP : (d ord0 == 1%R :> R) => [|dmax1].
    rewrite fdist1E1 => /eqP ->.
    by rewrite Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV.
  by apply Convn_perm_tperm with m.
- move=> {}s H.
  move=> m IH nm d g.
  case/boolP : (d ord0 == 1%R :> R) => [|dmax1].
    rewrite fdist1E1 => /eqP ->.
    by rewrite Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV.
  by apply Convn_perm_projection with m.
Qed.

End convex_space_prop.

Section affine_function_prop0.
Lemma affine_function_Sum (A B : convType) (f : {affine A -> B}) (n : nat)
    (g : 'I_n -> A) (e : {fdist 'I_n}) :
  f (<|>_e g) = <|>_e (f \o g).
Proof.
elim: n g e => [g e|n IH g e]; first by move: (fdistI0_False e).
case/boolP : (e ord0 == 1%R :> R) => [|e01].
  by rewrite fdist1E1 => /eqP ->; rewrite 2!Convn_fdist1.
by rewrite 2!convnE affine_conv IH.
Qed.
End affine_function_prop0.

Section convn_convnfdist.
Variable A : finType.

Lemma convn_convnfdist n (g : 'I_n -> fdist A) (d : {fdist 'I_n}) :
  <|>_d g = fdist_convn d g.
Proof.
elim: n g d => /= [g d|n IH g d]; first by move: (fdistI0_False d).
case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb] H.
  apply/fdist_ext => a.
  rewrite fdist_convnE big_ord_recl H mul1R big1 ?addR0 //= => j _.
  by move/eqP/fdist1P : H => -> //; rewrite ?mul0R.
apply/fdist_ext => a.
rewrite fdist_convE fdist_convnE /= big_ord_recl; congr (_ + _)%R.
rewrite IH fdist_convnE big_distrr /=; apply eq_bigr => i _.
rewrite fdist_delE fdistD1E eq_sym (negbTE (neq_lift _ _)).
by rewrite /Rdiv mulRAC mulRC -mulRA mulVR ?mulR1 //; exact/onem_neq0.
Qed.

End convn_convnfdist.


Require Import OrderedType.
Require Import OrderedTypeEx.
Require Import Store.
Require Import ClassDatatypesIface.
Require Import BasicMachineTypes.
Require Import AnnotationIface.
Require Import List.
Require Import ZArith.
Require Import Arith.
Require Import RelationUtils.
Require Omega.

Module MkClassDatatypes (B : BASICS) (A : ANNOTATION B)
                      : CLASSDATATYPES B A.

(* Constants *)
Inductive double_constant : Set := d0 | d1 : double_constant.
Inductive float_constant : Set := f0 | f1 | f2 : float_constant.
Inductive long_constant : Set := l0 | l1 : long_constant.

(* Comparison operations *)
Inductive acmp : Set := acmp_eq | acmp_ne : acmp.
Inductive cmp : Set := cmp_eq | cmp_ne | cmp_lt | cmp_ge | cmp_gt | cmp_le : cmp.
Inductive float_cmp_opt : Set := fcmp_l | fcmp_g : float_cmp_opt.

(* Arithmetic operations *)
Inductive integer_bop : Set :=
 iadd | idiv | iand | imul | ior | irem | ishl | ishr | isub | iushr | ixor : integer_bop.

Inductive integer_uop : Set :=
 ineg : integer_uop.

Inductive float_bop : Set :=
 fadd | fdiv | fmul | frem | fsub : float_bop.

Inductive float_uop : Set :=
 fneg : float_uop.

Inductive array_type : Set :=
 aty_boolean | aty_char | aty_float | aty_double | aty_byte | aty_short | aty_int | aty_long : array_type.

Inductive stack_type : Set :=
 sty_int | sty_long | sty_double | sty_float | sty_addr.

Inductive opcode : Set :=
(* Arithmetic *)
| op_iarithb : integer_bop -> opcode
| op_iarithu : integer_uop -> opcode
| op_larithb : integer_bop -> opcode
| op_larithu : integer_uop -> opcode
| op_iinc    : nat -> B.Int32.t -> opcode
| op_darithb : float_bop -> opcode
| op_darithu : float_uop -> opcode
| op_farithb : float_bop -> opcode
| op_farithu : float_uop -> opcode

(* Stack Operations *)
| op_dup     : opcode
| op_dup_x1  : opcode
| op_dup_x2  : opcode
| op_dup2    : opcode
| op_dup2_x1 : opcode
| op_dup2_x2 : opcode
| op_nop     : opcode
| op_pop     : opcode
| op_pop2    : opcode
| op_swap    : opcode

(* Local Variables *)
| op_load   : stack_type -> nat -> opcode
| op_store  : stack_type -> nat -> opcode

(* OO *)
| op_instanceof      : B.ConstantPoolRef.t -> opcode
| op_invokeinterface : B.ConstantPoolRef.t -> opcode
| op_invokespecial   : B.ConstantPoolRef.t -> opcode
| op_invokestatic    : B.ConstantPoolRef.t -> opcode
| op_invokevirtual   : B.ConstantPoolRef.t -> opcode
| op_aconst_null     : opcode
| op_checkcast       : B.ConstantPoolRef.t -> opcode
| op_getfield        : B.ConstantPoolRef.t -> opcode
| op_getstatic       : B.ConstantPoolRef.t -> opcode
| op_new             : B.ConstantPoolRef.t -> opcode
| op_putfield        : B.ConstantPoolRef.t -> opcode
| op_putstatic       : B.ConstantPoolRef.t -> opcode

(* Comparisons and flow control *)
| op_if_acmp : acmp -> Z -> opcode
| op_if_icmp : cmp -> Z -> opcode
| op_if      : cmp -> Z -> opcode
| op_ifnonnull : Z -> opcode
| op_ifnull  : Z -> opcode
| op_goto    : Z -> opcode
| op_valreturn : stack_type -> opcode
| op_return  : opcode
| op_athrow  : opcode
| op_dcmp    : float_cmp_opt -> opcode
| op_fcmp    : float_cmp_opt -> opcode
| op_lcmp    : opcode
| op_lookupswitch : Z -> Z -> list (Z * Z) -> opcode
| op_tableswitch : Z -> Z -> Z -> list Z -> opcode

(* Arrays *)
| op_iaload  : opcode
| op_iastore : opcode
| op_aaload  : opcode
| op_aastore : opcode
| op_anewarray : B.ConstantPoolRef.t -> opcode
| op_arraylength : opcode
| op_baload  : opcode
| op_bastore : opcode
| op_caload  : opcode
| op_castore : opcode
| op_daload  : opcode
| op_dastore : opcode
| op_faload  : opcode
| op_fastore : opcode
| op_laload  : opcode
| op_lastore : opcode
| op_multianewarray : B.ConstantPoolRef.t -> nat -> opcode
| op_newarray : array_type -> opcode
| op_saload  : opcode
| op_sastore : opcode

(* Constants *)
| op_iconst : B.Int32.t -> opcode
| op_dconst : double_constant -> opcode
| op_fconst : float_constant -> opcode
| op_lconst : long_constant -> opcode
| op_ldc    : B.ConstantPoolRef.t -> opcode
| op_ldc2   : B.ConstantPoolRef.t -> opcode

(* Concurrency *)
| op_monitorenter : opcode
| op_monitorexit  : opcode

(* Conversions *)
| op_i2b    : opcode
| op_i2c    : opcode
| op_i2d    : opcode
| op_i2f    : opcode
| op_i2l    : opcode
| op_i2s    : opcode
| op_d2f    : opcode
| op_d2i    : opcode
| op_d2l    : opcode
| op_f2d    : opcode
| op_f2i    : opcode
| op_f2l    : opcode
| op_l2d    : opcode
| op_l2f    : opcode
| op_l2i    : opcode.

Definition pc_plus_offset : nat -> Z -> option nat :=
  fun pc offset =>
  match (Z_of_nat pc + offset)%Z with
  | Z0 => Some 0%nat
  | Zpos p => Some (nat_of_P p)
  | Zneg _ => None
  end.

(* Java types, equality and an ordering upon them *)

Inductive java_type : Set :=
| ty_byte
| ty_char
| ty_double
| ty_float
| ty_int
| ty_long
| ty_boolean
| ty_short : java_type
| ty_ref : java_ref_type -> java_type
with java_ref_type : Set :=
| ty_obj : B.Classname.t -> java_ref_type
| ty_arr : java_type -> java_ref_type.

Scheme java_type_ref_typeP := Induction for java_type Sort Prop
  with java_ref_type_typeP := Induction for java_ref_type Sort Prop.

Scheme java_type_ref_typeT := Induction for java_type Sort Type
  with java_ref_type_typeT := Induction for java_ref_type Sort Type.

Module JavaType_as_UOT : UsualOrderedType with Definition t := java_type.

Definition t := java_type.

Definition ref_eq := (@eq java_ref_type).
Definition eq := (@eq java_type).

Definition eq_refl := (@refl_equal java_type).
Definition eq_sym := (@sym_eq java_type).
Definition eq_trans := (@trans_eq java_type).

Fixpoint lt (a:java_type) (b:java_type) {struct a} : Prop :=
 match a with
 | ty_byte =>
    match b with
    | ty_byte => False
    | _       => True
    end
 | ty_char =>
    match b with
    | ty_byte | ty_char => False
    | _ => True
    end
 | ty_double =>
    match b with
    | ty_byte | ty_char | ty_double => False
    | _ => True
    end
 | ty_long =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long => False
    | _ => True
    end
 | ty_int =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long | ty_int => False
    | _ => True
    end
 | ty_float =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long | ty_int | ty_float => False
    | _ => True
    end
 | ty_boolean =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long | ty_int | ty_float | ty_boolean => False
    | _ => True
    end
 | ty_short =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long | ty_int | ty_float | ty_boolean | ty_short => False
    | _ => True
    end
 | ty_ref rt1 =>
    match b with
    | ty_byte | ty_char | ty_double | ty_long | ty_int | ty_float | ty_boolean | ty_short => False
    | ty_ref rt2 => lt_ref rt1 rt2
    end
 end
with lt_ref (a:java_ref_type) (b:java_ref_type) {struct a} : Prop :=
 match a with
 | ty_obj nm1 =>
    match b with
    | ty_obj nm2 => B.Classname.lt nm1 nm2
    | ty_arr _   => True
    end
 | ty_arr t1 =>
    match b with
    | ty_obj _ => False
    | ty_arr t2 => lt t1 t2
    end
 end.

Lemma lt_trans : transitive _ lt.
unfold transitive.
intro x.
elim x using (java_type_ref_typeP (fun x => forall y z, lt x y -> lt y z -> lt x z)
                                  (fun x => forall y z, lt_ref x y -> lt_ref y z -> lt_ref x z)); intros;
first [ destruct y; destruct z; simpl; intuition eauto; fail
      | inversion H0
      | destruct y; try (inversion H0); destruct z; try (inversion H1); simpl in *; intuition eauto
      ].
Save.

Lemma lt_not_eq : forall j1 j2, lt j1 j2 -> ~eq j1 j2.
intro j1.
elim j1 using (java_type_ref_typeP (fun j1 => forall j2, lt j1 j2 -> ~eq j1 j2)
                                   (fun j1 => forall j2, lt_ref j1 j2 -> j1<>j2));
destruct j2; simpl; intuition; try discriminate.
inversion H1. eauto.
inversion H0. apply (B.Classname.lt_not_eq H H2).
inversion H1. eauto.
Save.

Lemma java_type_eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
intros. unfold eq in H. subst. assumption.
Save.

Lemma java_type_lt_eq : forall x y z, eq x y -> lt z y -> lt z x.
unfold eq. intros. subst. assumption.
Save.

Hint Unfold symmetric reflexive transitive lt eq lt_ref ref_eq.
Hint Immediate eq_sym.
Hint Resolve eq_refl eq_trans lt_trans lt_not_eq java_type_lt_eq java_type_eq_lt.
Hint Constructors Compare.

Definition compare : forall x y, Compare lt eq x y.
intro x.
elim x using (java_type_ref_typeT (fun x => forall y, Compare lt eq x y)
                                  (fun x => forall y, Compare lt_ref ref_eq x y));
 destruct y; intuition eauto.
 destruct (H j0); intuition eauto. apply EQ. rewrite r. apply eq_refl.
 destruct (B.Classname.compare t0 t1); unfold B.Classname.eq in *; subst; intuition eauto.
 destruct (H j0); intuition eauto. apply EQ. rewrite e. unfold ref_eq. reflexivity.
Defined.

Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
Proof.
  intros; elim (compare x y); intro H; [ right | left | right ]; auto using lt_not_eq.
  assert (~ eq y x); auto using lt_not_eq, eq_sym.
Defined.

End JavaType_as_UOT.

Inductive value_category : Set := category1 | category2.

Definition java_type_category : java_type -> value_category :=
  fun ty => match ty with
  | ty_byte => category1
  | ty_char => category1
  | ty_short => category1
  | ty_boolean => category1
  | ty_int => category1
  | ty_float => category1
  | ty_ref _ => category1
  | ty_double => category2
  | ty_long => category2
  end.

Definition stack_type_category : stack_type -> value_category :=
  fun ty => match ty with
  | sty_int => category1
  | sty_float => category1
  | sty_double => category2
  | sty_addr => category1
  | sty_long => category2
  end.

Record descriptor : Set := mkDescriptor
 { descriptor_ret_type : option java_type
 ; descriptor_arg_types : list java_type
 }.

Module Descriptor_as_UOT <: UsualOrderedType with Definition t := descriptor.

Definition t := descriptor.

Module OJT : UsualOrderedType with Definition t := option java_type := OptionUsualOrderedType JavaType_as_UOT.
Module LJT : UsualOrderedType with Definition t := list java_type := ListUsualOrderedType JavaType_as_UOT.
Module OJTFacts := OrderedTypeFacts OJT.

Definition eq := @eq descriptor.
Definition eq_refl := @refl_equal descriptor.
Definition eq_sym := @sym_eq descriptor.
Definition eq_trans := @trans_eq descriptor.

Hint Unfold OJT.eq.
Hint Resolve OJT.lt_trans OJT.eq_trans LJT.lt_trans.

Definition lt (d1 d2:descriptor) :=
 match d1, d2 with
 | mkDescriptor rt1 at1, mkDescriptor rt2 at2 =>
    OJT.lt rt1 rt2 \/ OJT.eq rt1 rt2 /\ LJT.lt at1 at2
 end.

Lemma lt_trans : transitive _ lt.
unfold transitive. destruct x. destruct y. destruct z. simpl. intuition eauto.
Save.

Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
destruct x. destruct y. simpl. intuition eauto.
 unfold eq in H0. inversion H0. apply (OJT.lt_not_eq _ _ H1 H2).
 unfold eq in H0. inversion H0. apply (LJT.lt_not_eq _ _ H2 H4).
Save.

Hint Immediate eq_sym.
Hint Resolve eq_refl eq_trans lt_trans lt_not_eq.
Hint Unfold eq lt OJT.eq LJT.eq.
Hint Constructors Compare.

Definition compare : forall x y, Compare lt eq x y.
destruct x. destruct y.
destruct (OJT.compare descriptor_ret_type0 descriptor_ret_type1);
destruct (LJT.compare descriptor_arg_types0 descriptor_arg_types1);
 intuition eauto 6.
 apply EQ. unfold OJT.eq in e. unfold LJT.eq in e0. subst. unfold eq. reflexivity.
Defined.

Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
Proof.
  intros; elim (compare x y); intro H; [ right | left | right ]; auto using lt_not_eq.
  assert (~ eq y x); auto using lt_not_eq, eq_sym.
Defined.

End Descriptor_as_UOT.

Record exception_handler : Set := mkExcHandler
  { exc_start_pc : nat
  ; exc_end_pc   : nat
  ; exc_handler_pc : nat
  ; exc_catch_type : option B.ConstantPoolRef.t
  }.

(* for checking if the current program counter is in the range of an exception handler *)
Definition is_within : forall (s e p:nat), ({p >= s /\ p < e} + {p < s \/ p >= e})%nat.
intros. destruct (le_lt_dec s p).
 destruct (le_lt_dec e p).
  right. omega.
  left. omega.
 right. omega.
Defined.

Record precode : Type := mkPreCode
  { precode_max_stack       : nat
  ; precode_max_lvars       : nat
  ; precode_code            : list opcode            (* FIXME: need a better representation than lists *)
  ; precode_exception_table : list exception_handler
  ; precode_annot           : A.code_annotation
  }. (* + certificate *)

Record code : Set := mkCode
  { code_max_stack       : nat
  ; code_max_lvars       : nat
  ; code_code            : list opcode
  ; code_exception_table : list exception_handler
  }. (* + certificate *)

Record premethod : Type := mkPreMethod
  { premethod_name         : B.Methodname.t
  ; premethod_descriptor   : descriptor
  ; premethod_public       : bool
  ; premethod_protected    : bool
  ; premethod_private      : bool
  ; premethod_abstract     : bool (* if this is false, and the code does not exist, then the method is native *)
  ; premethod_static       : bool
  ; premethod_final        : bool
  ; premethod_synchronized : bool
  ; premethod_strict       : bool
  ; premethod_code         : option precode
  ; premethod_annot        : A.method_annotation
  }. (* + attributes *)

Record method : Type := mkMethod
  { method_name         : B.Methodname.t
  ; method_descriptor   : descriptor
  ; method_public       : bool
  ; method_protected    : bool
  ; method_private      : bool
  ; method_abstract     : bool (* if this is false, and the code does not exist, then the method is native *)
  ; method_static       : bool
  ; method_final        : bool
  ; method_synchronized : bool
  ; method_strict       : bool
  ; method_code         : option code
  ; method_annot        : A.method_annotation
  }. (* + attributes *)

Module MethodDesc := PairUsualOrderedType B.Methodname Descriptor_as_UOT.
Module Method.
Definition t := method.
End Method.
Module MethodList := MkStore MethodDesc Method.

Record field : Set := mkField
  { field_name      : B.Fieldname.t
  ; field_type      : java_type
  ; field_public    : bool
  ; field_private   : bool
  ; field_protected : bool
  ; field_static    : bool
  ; field_final     : bool
  ; field_volatile  : bool
  ; field_transient : bool
  }. (* + attributes (ConstantValue) *)

Module FieldDesc := PairOrderedType B.Fieldname JavaType_as_UOT.
Module Field.
Definition t := field.
End Field.
Module FieldList := MkStore FieldDesc Field.

Inductive constantpool_entry : Set :=
| cpe_methodref : B.Classname.t -> B.Methodname.t -> descriptor -> constantpool_entry
| cpe_interfacemethodref : B.Classname.t -> B.Methodname.t -> descriptor -> constantpool_entry
| cpe_fieldref  : B.Classname.t -> B.Fieldname.t -> java_type -> constantpool_entry
| cpe_int       : B.Int32.t -> constantpool_entry
| cpe_classref  : B.Classname.t -> constantpool_entry
| cpe_other     : constantpool_entry.

Module ConstantPoolEntry.
Definition t := constantpool_entry.
End ConstantPoolEntry.
Module ConstantPool := MkStore B.ConstantPoolRef ConstantPoolEntry.

Record preclass : Type := mkPreClass
  { preclass_name         : B.Classname.t
  ; preclass_super_name   : option B.Classname.t
  ; preclass_super_interfaces : list B.Classname.t
  ; preclass_public       : bool
  ; preclass_final        : bool
  ; preclass_super        : bool
  ; preclass_interface    : bool
  ; preclass_abstract     : bool
  ; preclass_methods      : list premethod
  ; preclass_fields       : FieldList.t
  ; preclass_constantpool : ConstantPool.t
  ; preclass_annotation   : A.class_annotation
  }. (* + attributes *)

(*Module CP := FinitePoset.FinitePoset B.Classname.*)

Record class : Type := mkClass
  { class_name         : B.Classname.t
  ; class_super_class  : option B.Classname.t
  ; class_interfaces   : list B.Classname.t
  ; class_public       : bool
  ; class_final        : bool
  ; class_super        : bool
  ; class_interface    : bool
  ; class_abstract     : bool
  ; class_methods      : MethodList.t
  ; class_fields       : FieldList.t
  ; class_constantpool : ConstantPool.t
  }. (* + attributes *)

Inductive has_premethod : list premethod -> B.Methodname.t * descriptor -> premethod -> Prop :=
| has_premethod_cons_1 : forall nm d public protected private abstract static final synchronized strict code annot meths,
   has_premethod (mkPreMethod nm d public protected private abstract static final synchronized strict code annot::meths)
                 (nm,d)
                 (mkPreMethod nm d public protected private abstract static final synchronized strict code annot)
| has_premethod_cons_2 : forall nm d public protected private abstract static final synchronized strict code annot meths nm' d' m,
   has_premethod meths (nm',d') m ->
   (nm <> nm' \/ d <> d') ->
   has_premethod (mkPreMethod nm d public protected private abstract static final synchronized strict code annot::meths)
                 (nm',d')
                 m.

Definition descriptor_eq_dec : forall (d d':descriptor), {d=d'}+{d<>d'}.
intros. destruct (Descriptor_as_UOT.compare d d').
 right. apply Descriptor_as_UOT.lt_not_eq. apply l.
 left. apply e.
 right. unfold not. intros. symmetry in H. generalize H. apply Descriptor_as_UOT.lt_not_eq. apply l.
Save.

Definition mdesc_eq_dec : forall (d d' : B.Methodname.t * descriptor), {d=d'}+{d<>d'}.
decide equality. apply descriptor_eq_dec. apply B.Methodname.eq_dec.
Save.

Definition has_premethod_dec : forall ms mdesc,
 (exists m, has_premethod ms mdesc m)\/(forall m, ~has_premethod ms mdesc m).
intros ms mdesc.
induction ms.
 (* ms -> nil *)
 right. unfold not. intros. inversion H.
 (* ms -> a::ms *)
 destruct a as [a b c d e f g h i j k l]. destruct mdesc as [a' b'].
 destruct (B.Methodname.eq_dec a a'); subst.
  destruct (descriptor_eq_dec b b'); subst.
   left. exists (mkPreMethod a' b' c d e f g h i j k l). constructor.
   destruct IHms as [[m ms_m] | not_ms_m].
    left. exists m. constructor; intuition.
    right. unfold not. intros. inversion H.
     contradiction.
     apply (not_ms_m _ H16).
  destruct IHms as [[m ms_m] | not_ms_m].
   left. exists m. constructor; intuition.
   right. unfold not. intros. inversion H.
    contradiction.
    apply (not_ms_m _ H16).
Save.

Lemma has_premethod_functional : forall ms mdesc mA mB,
 has_premethod ms mdesc mA ->
 has_premethod ms mdesc mB ->
 mA = mB.
induction ms; intros.
 inversion H.
 destruct a. inversion H; subst.
  inversion H0; subst.
   reflexivity.
   elimtype False. destruct H18; apply H1; reflexivity.
  inversion H0; subst.
   elimtype False. destruct H17; apply H1; reflexivity.
   eauto.
Save.

Lemma has_premethod_in : forall ms m,
  has_premethod ms (premethod_name m, premethod_descriptor m) m ->
  In m ms.
Proof.
  intros.
  induction H.
   simpl. left. reflexivity.
   simpl. right. assumption.
Qed.

Lemma has_premethod_name : forall ms md m,
  has_premethod ms md m -> md = (premethod_name m, premethod_descriptor m).
Proof.
  intros.
  induction H. reflexivity. assumption.
Qed.

End MkClassDatatypes.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffExcept.
Require Import Arith.
Require Import Exception.
Require Import ESoundE.

Open Scope string_scope.

Section Test_Section.

  Definition D := AType.

  Definition E := Arith :+: ExceptE D.

  Definition V := StuckValue :+: BotValue :+: NatValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.

  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Exception_ME : Exception ME unit}.
  Context {Fail_ME : FailMonad ME}.

  Context {ME_eq_dec : forall (A : Set) (mte : ME A),
    (exists a, mte = return_ a) \/ (mte = fail) \/ (mte = throw tt)}.
  Context {Reasonable_ME : Reasonable_Monad ME}.
  Context {fail_neq_throw : forall (A B C : Set) (ma : ME A) (mb : ME B),
    (ma >>= fun _ => fail (M := ME)) <> mb >>= fun _ => throw (A := C) tt}.

  Definition WFV := (WFValue_VI V D unit).
  Definition WFVM := (WFValueM_base D V MT ME unit WFV) ::+:: (WFValueM_Except D V MT ME unit).

  Instance eq_DType_eq_alg : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D)).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance eq_DType_neq_alg : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D)).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T : Set, FAlgebra EvalName T (evalMR V ME) E.
  Proof.
    intros; eauto with typeclass_instances.
    apply FAlgebra_Plus; eauto with typeclass_instances.
  Defined.

  Lemma eval_Sound :
    forall (e : Exp E) (T : DType D),
      fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
      (exists v : Value V,
        evalM V E ME (proj1_sig e) = return_ (M := ME) v /\
        WFValueC D V _ WFV tt v T) \/
      exists t, evalM V E ME (proj1_sig e) = throw (M := ME) t.
  Proof.
    apply eval_Except_Sound with (WFVM' := WFVM);
      eauto 10 with typeclass_instances.
    intros; repeat apply @P2Algebra_Plus.
    eapply Arith_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Except_eval_soundness'';
      eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Soundness for 'Arith :+: Exceptions' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export computation_mark.

Lemma computes_to_val_like_iff_hasvalue_like {o} :
  forall lib (t : @NTerm o),
    hasvalue_like lib t <=> {v : NTerm & computes_to_val_like lib t v}.
Proof.
  introv; unfold hasvalue_like, computes_to_val_like, reduces_to, computes_to_val_like_in_max_k_steps;
  split; intro k; exrepnd.
  - exists v k; sp.
  - exists v; sp.
    exists k; sp.
Qed.

Lemma isvalue_like_isvalue {o} :
  forall t : @NTerm o,
    isvalue t -> isvalue_like t.
Proof.
  introv isv.
  inversion isv; subst; eauto with slow.
Qed.
Hint Resolve isvalue_like_isvalue : slow.

Lemma hasvalue_like_if_hasvalue {o} :
  forall lib (t : @NTerm o),
    hasvalue lib t
    -> hasvalue_like lib t.
Proof.
  introv hv.
  unfold hasvalue in hv; exrepnd.
  unfold computes_to_value in hv0; repnd.
  exists t'; dands; eauto with slow.
Qed.
Hint Resolve hasvalue_like_if_hasvalue : slow.

Lemma hasvalue_like_if_raises_exception {o} :
  forall lib (t : @NTerm o),
    raises_exception lib t
    -> hasvalue_like lib t.
Proof.
  introv hv.
  unfold raises_exception in hv; exrepnd.
  unfold computes_to_exception in hv1; repnd.
  eexists; dands; eauto with slow.
Qed.
Hint Resolve hasvalue_like_if_raises_exception : slow.

(*
Lemma reduces_in_atmost_k_steps_implies_marks {p} :
  forall lib (a b : @NTerm p) k,
    reduces_in_atmost_k_steps lib a b k
    -> ismrk lib b
    -> isprogram b
    -> marks lib a.
Proof.
  introv r ism isp.
  apply ismrk_implies in ism; auto; exrepnd; subst.
  exists s.
  unfold computes_to_marker, reduces_to.
  exists k; auto.
Qed.
*)

(*
Lemma marker_in_atmost_k_steps_alpha {p} :
  forall lib (t1 t2 : @NTerm p),
    alpha_eq t1 t2
    -> forall k m,
         computes_to_marker_in_max_k_steps lib t1 m k
         -> computes_to_marker_in_max_k_steps lib t2 m k.
Proof.
  introv Hal.
  introv.
  revert m t1 t2 Hal.
  induction k as [| k Hind]; introv aeq comp;
  allunfold @computes_to_marker_in_max_k_steps; repnd; dands; auto.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    apply alpha_eq_marker in aeq; exrepnd; subst; auto.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    eapply compute_step_alpha in comp0; eauto; exrepnd.
    pose proof (Hind m u t2') as h.
    repeat (autodimp h hyp); repnd; GC.
    eexists; dands; eauto.
Qed.

Theorem compute_to_marker_alpha {p} :
  forall lib (t1 t2 : @NTerm p) m,
    alpha_eq t1 t2
    -> computes_to_marker lib t1 m
    -> computes_to_marker lib t2 m.
Proof.
  introv aeq comp.
  allunfold @computes_to_marker; allunfold @reduces_to; exrepnd.
  pose proof (marker_in_atmost_k_steps_alpha lib t1 t2 aeq k m) as h.
  unfold computes_to_marker_in_max_k_steps in h.
  autodimp h hyp; repnd.
  eexists; dands; eauto.
Qed.
 *)

Lemma reduces_to_if_split2 {p} :
  forall lib (t : @NTerm p) u v,
  compute_step lib t = csuccess u
  -> reduces_to lib u v
  -> reduces_to lib t v.
Proof.
  unfold reduces_to; sp; exists (S k).
  rw @reduces_in_atmost_k_steps_S.
  exists u; sp.
Qed.

Lemma reduces_to_if_split3 {p} :
  forall lib (t : @NTerm p) u v,
  computes_in_1step lib t u
  -> reduces_to lib u v
  -> reduces_to lib t v.
Proof.
  introv c r.
  inversion c; subst; clear c.
  - eapply reduces_to_if_split2; eauto.
  - eapply reduces_to_if_split2; eauto.
Qed.

(*
Lemma computes_in_kstep_alpha_implies_mrk {p} :
  forall lib k (t : @NTerm p) m,
    is_mrk lib m
    -> computes_in_kstep_alpha lib k t (mk_marker m)
    -> computes_to_marker lib t m.
Proof.
  induction k as [ | k Hind]; introv ism Hcka; unfolds_base; dands; auto.
  - invertsn Hcka.
    apply alpha_eq_sym in Hcka; apply alpha_eq_marker in Hcka; exrepnd; subst.
    apply reduces_to_symm.
  - inverts Hcka as HH HHH.
    apply Hind in HHH; auto.
    invertsn HH; repnd.
    apply (compute_to_marker_alpha _ _ x) in HHH; auto.
    allunfold @computes_to_marker; repnd.
    eapply reduces_to_if_split3; eauto.
Qed.

Lemma compute_to_marker_mrk {o} :
  forall (lib : @library o) m,
    is_mrk lib m -> computes_to_marker lib (mk_marker m) m.
Proof.
  introv ism; unfold computes_to_marker; dands; auto.
  exists 0.
  rw @reduces_in_atmost_k_steps_0; auto.
Qed.

Lemma computes_to_marker_alpha {p} :
  forall lib (t1 t2 : @NTerm p) m,
    alpha_eq t1 t2
    -> computes_to_marker lib t1 m
    -> computes_to_marker lib t2 m.
Proof.
  introv aeq comp.
  unfold computes_to_marker, reduces_to in comp; exrepnd.
  unfold computes_to_marker; dands; auto.
  exists k.
  revert dependent t2.
  revert dependent t1.
  induction k; introv r aeq.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    allrw @alpha_eq_marker; subst; auto.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    eapply compute_step_alpha in r1; eauto; exrepnd.
    exists t2'; dands; auto.
    eapply IHk; eauto.
Qed.

Lemma reduces_to_computes_to_marker {p} :
  forall lib a b m,
    @reduces_to p lib a b
    -> computes_to_marker lib b m
    -> computes_to_marker lib a m.
Proof.
  introv redto compex.
  allunfold @computes_to_marker; repnd; dands; auto.
  eapply reduces_to_trans; eauto.
Qed.

Lemma reduces_to_marker_eq {p} :
  forall lib (t u : @NTerm p) m,
    computes_to_marker lib t m
    -> reduces_to lib t u
    -> computes_to_marker lib u m.
Proof.
  unfold computes_to_marker; introv Hcv Hcr; repnd; dands; auto.
  apply @reduces_to_or with (u := u) in Hcv0; auto.
  repndors; tcsp.
  apply reduces_to_marker in Hcv0; auto; subst.
  apply reduces_to_symm.
Qed.

Lemma exception_doesnt_mark {o} :
  forall lib a (e : @NTerm o) m,
    computes_to_marker lib (mk_exception a e) m -> False.
Proof.
  introv comp.
  unfold computes_to_marker, reduces_to in comp; exrepnd.
  induction k.
  - allrw @reduces_in_atmost_k_steps_0; ginv.
  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp1; allsimpl; ginv; sp.
Qed.
*)

Definition mk_vid {p} (v : NVar) : @NTerm p := mk_lam v (mk_var v).

Lemma reduces_in_atmost_k_steps_apply_vid {o} :
  forall lib (t : @NTerm o) v u k,
    isvalue_like u
    -> reduces_in_atmost_k_steps lib (mk_apply (mk_vid v) t) u k
    -> {n : nat
        & k = S n
        # reduces_in_atmost_k_steps lib t u n }.
Proof.
  introv isv r.
  destruct k.

  - rw @reduces_in_atmost_k_steps_0 in r; subst.
    apply isvalue_like_ncan in isv; sp.

  - rw @reduces_in_atmost_k_steps_S in r; exrepnd.
    exists k; dands; auto.
    csunf r1; allsimpl; ginv.
    unfold apply_bterm, lsubst in r0; allsimpl; boolvar; auto.
Qed.

Lemma reduces_in_atmost_k_steps_vbot {o} :
  forall lib v (u : @NTerm o) k,
    isvalue_like u
    -> reduces_in_atmost_k_steps lib (mk_vbot v) u k
    -> False.
Proof.
  introv isv r.
  induction k as [k ind] using comp_ind_type.
  destruct k.

  - rw @reduces_in_atmost_k_steps_0 in r; subst.
    apply isvalue_like_ncan in isv; sp.

  - rw @reduces_in_atmost_k_steps_S in r; exrepnd.
    csunf r1; simpl in r1; ginv; auto; fold_terms.
    destruct k.

    + rw @reduces_in_atmost_k_steps_0 in r0; subst.
      apply isvalue_like_ncan in isv; sp.

    + apply reduces_in_atmost_k_steps_apply_vid in r0; exrepnd; ginv; auto.
      apply ind in r1; auto.
Qed.

Lemma reduces_to_vbot_if_isvalue_like {o} :
  forall lib v (u : @NTerm o),
    isvalue_like u
    -> reduces_to lib (mk_vbot v) u
    -> False.
Proof.
  introv isv r.
  unfold reduces_to in r; exrepnd.
  apply reduces_in_atmost_k_steps_vbot in r0; sp.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/")
*** End:
*)


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export static_sem_lemmas.
Require Export US.

Lemma lookup_func_uniform_substitution_restriction_term_in :
  forall s (t :Term) f n,
    In (SymbolFunction f n) (term_signature t)
    -> lookup_func (uniform_substitution_restriction_term s t) f n
       = lookup_func s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  rewrite uniform_substitution_entry_in_term_eq.
  destruct a; auto; try (complete (apply IHs; auto)).
  unfold in_signature.
  repeat (dest_cases w; GC);
    unfold lookup_func; simpl;
      repeat (dest_cases w; subst; GC);
      try (complete (pose proof (IHs t f0 n) as q;
                     unfold lookup_func in q; simpl in q;
                     rewrite <- Heqw0 in q;
                     try (rewrite <- Heqw in q; auto)));
      try (complete (pose proof (IHs t f n) as q;
                     unfold lookup_func in q; simpl in q;
                     rewrite <- Heqw0 in q;
                     try (rewrite <- Heqw in q; auto))).
Qed.

Lemma lookup_pred_uniform_substitution_restriction_term_in :
  forall s (t :Term) f n,
    In (SymbolPredicate f n) (term_signature t)
    -> lookup_pred (uniform_substitution_restriction_term s t) f n
       = lookup_pred s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_pred; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f n) as q;
                   unfold lookup_pred in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; subst;
                   dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_quant_uniform_substitution_restriction_term_in :
  forall s (t :Term) f,
    In (SymbolQuantifier f) (term_signature t)
    -> lookup_quant (uniform_substitution_restriction_term s t) f
       = lookup_quant s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_quant; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_quant in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_const_uniform_substitution_restriction_term_in :
  forall s (t :Term) f,
    In (SymbolProgramConst f) (term_signature t)
    -> lookup_const (uniform_substitution_restriction_term s t) f
       = lookup_const s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_const; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_const in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_func_uniform_substitution_restriction_formula_in :
  forall s t f n,
    In (SymbolFunction f n) (formula_signature t)
    -> lookup_func (uniform_substitution_restriction_formula s t) f n
       = lookup_func s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_func; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f n) as q;
                   unfold lookup_func in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; subst;
                   dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_pred_uniform_substitution_restriction_formula_in :
  forall s t f n,
    In (SymbolPredicate f n) (formula_signature t)
    -> lookup_pred (uniform_substitution_restriction_formula s t) f n
       = lookup_pred s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_pred; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f n) as q;
                   unfold lookup_pred in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; subst;
                   dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_quant_uniform_substitution_restriction_formula_in :
  forall s t f,
    In (SymbolQuantifier f) (formula_signature t)
    -> lookup_quant (uniform_substitution_restriction_formula s t) f
       = lookup_quant s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_quant; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_quant in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_const_uniform_substitution_restriction_formula_in :
  forall s t f,
    In (SymbolProgramConst f) (formula_signature t)
    -> lookup_const (uniform_substitution_restriction_formula s t) f
       = lookup_const s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_const; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_const in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_func_uniform_substitution_restriction_program_in :
  forall s t f n,
    In (SymbolFunction f n) (program_signature t)
    -> lookup_func (uniform_substitution_restriction_program s t) f n
       = lookup_func s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_func; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f n) as q;
                   unfold lookup_func in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; subst;
                   dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_pred_uniform_substitution_restriction_program_in :
  forall s t f n,
    In (SymbolPredicate f n) (program_signature t)
    -> lookup_pred (uniform_substitution_restriction_program s t) f n
       = lookup_pred s f n.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_pred; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f n) as q;
                   unfold lookup_pred in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; subst;
                   dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_quant_uniform_substitution_restriction_program_in :
  forall s t f,
    In (SymbolQuantifier f) (program_signature t)
    -> lookup_quant (uniform_substitution_restriction_program s t) f
       = lookup_quant s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_quant; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_quant in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.

Lemma lookup_const_uniform_substitution_restriction_program_in :
  forall s t f,
    In (SymbolProgramConst f) (program_signature t)
    -> lookup_const (uniform_substitution_restriction_program s t) f
       = lookup_const s f.
Proof.
  induction s; introv h; simpl in *; auto.
  unfold lookup_const; simpl.
  repeat (dest_cases w; simpl); ginv;
    try (complete (pose proof (IHs t f) as q;
                   unfold lookup_const in q; simpl in q;
                   rewrite <- Heqw0 in q;
                   try (rewrite <- Heqw2 in q; auto);
                   try (rewrite <- Heqw1 in q; auto)));
    try (complete (destruct a; allsimpl; ginv; dest_cases w; ginv; dest_cases w));
    try (complete (destruct a; allsimpl; unfold in_signature in *;
                   ginv; repeat (dest_cases w); ginv)).
Qed.