From Undecidability.TM Require Import TM ProgrammingTools Code.
From Complexity.TM Require Import Code.Decode Single.DecodeTape.
From Undecidability.L Require Import MoreBase.
Require Import Lia Ring Arith Program.Wf.
Import While Mono Multi Switch If Combinators EncodeTapes.

Unset Printing Coercions.

Lemma tapes_encode_prefixInjective sig n: prefixInjective (Encode_tapes sig n).
Proof.
  unfold Encode_tapes;cbn.
  induction n.
  {cbn. intros x x'. rewrite (destruct_vector_nil x),(destruct_vector_nil x'). reflexivity. }
  intros v v'. destruct (destruct_vector_cons v) as (x&xs&->). destruct (destruct_vector_cons v') as (x'&xs'&->). cbn.
  intros t t' [= Heq].
  unshelve erewrite ( _ : (fun x : sigTape sig => sigList_X x) = Retr_f) in Heq. 1:reflexivity.
  rewrite <- !app_assoc in Heq.
  specialize (map_retract_prefix_inj Heq) as (tmp&tmp'&Htmp). eapply tape_encode_prefixInjective in Htmp as ->.
  eapply app_inv_head in Heq. now apply IHn in Heq as ->.
Qed.

Module CheckEncodesTapes.
  Section checkEncodesTapes.

    (* This actually checks for the encoding of lists of a given. *)

    Context (sig: finType).

    Context (tau:finType) `{I : Retract (sigList (sigTape sig)) tau}.

    Let I__X : Retract (sigTape sig) tau := ComposeRetract I _.

    Existing Instance I__X.
    Local Arguments ComposeRetract : simpl never.

    Local Remove Hints Retract_id : typeclass_instances.

    Let Rel n : pRel tau bool 1 := ContainsEncoding.Rel (Encode_tapes sig n) Retr_f.

    Fixpoint R_syntactic n (t: tape tau) (b:bool) t' : Prop :=
        match n with
          0   => inhabited (reflect (Option.bind Retr_g (current t) = Some sigList_nil) b) /\ t = t'
        | S n => (Option.bind Retr_g (current t) = Some sigList_cons
                 /\ exists t1 b1, ContainsEncoding.Rel_legacy (Encode_tape sig) Retr_f [|tape_move_right t|] (b1,t1)
                            /\ if b1 then R_syntactic n (tape_move_right t1[@Fin0]) b t'
                              else t1[@Fin0]=t' /\ b = false)
                \/ (Option.bind Retr_g (current t) <> Some sigList_cons /\ b = false /\ t=t')
        end .

    Fixpoint M n : pTM tau bool 1 :=
      match n with
        0 => Relabel ReadChar (fun c => match Option.bind Retr_g c with Some sigList_nil => true | _ => false end)
      | S n => If (Relabel ReadChar (fun c => match Option.bind Retr_g c with Some sigList_cons => true | _ => false end))
                 (Move Rmove;; If (CheckEncodesTape.M (I:=I__X)) (Move Rmove;;M n) (Return Nop false))
                 (Return Nop false)
      end.

    Lemma Realises_intern n: M n ⊨ (fun t '(b,t') => R_syntactic n t[@Fin0] b t'[@Fin0]).
    Proof.
      induction n.
      -cbn. eapply Realise_monotone. now TM_Correct.
       hnf. cbn. intros t (b,t') (f&Hf&->&<-). split. 2:easy. split.
       decide (Option.bind Retr_g (current t'[@Fin0]) = Some sigList_nil) as [H|H].
       {rewrite H in Hf. subst b. now constructor. }
       destruct (Option.bind Retr_g (current t'[@Fin0])) as [ [] | ]. all:subst b;constructor. all:easy.
      -cbn. eapply Realise_monotone.
       { TM_Correct. eapply Realise_monotone. now apply CheckEncodesTape.Realise.
         intros ? ? H. setoid_rewrite ContainsEncoding.legacy_iff in H. exact H. intros x';now destruct x'.
         eassumption. }
       hnf;cbn. intros t (b,t') [H|H].
       2:{ destruct H as (?&(?&Hb&->&->)&->&_&<-). right. split. 2:easy. intros H. rewrite H in Hb. easy. }
       destruct H as (?&(?&Hb&->&->)&_&tmp&Htmp&H). unfold tapes in tmp. destruct_vector. cbn in Htmp. subst h.
       decide (Option.bind Retr_g (current t[@Fin0]) = Some sigList_cons) as [Ht|Ht].
       2:now destruct Option.bind as [[]| ]. left. split. easy.
       destruct H as [(t1&Ht1&?&?&->&Rsynt)|(?&Ht'&->&_&<-)].
       2:{ eexists _,false. split. 2:easy. easy. }
       eexists _,true. split. eassumption. easy.
    Qed.

    Definition Ter n : tRel tau 1:=
      fun t k => n * ((| right t[@Fin0] |) * 4 + 9 + 7) + 1 <= k.

    Lemma iter_transitive X Y R (g:X -> Y) f s n: PreOrder R ->  (forall x, R (g (f x)) (g x)) -> R (g (nat_rect _ s (fun _ => f) n)) (g s).
    Proof.
      intros Ht HR. induction n;cbn. easy. now etransitivity.
    Qed.

    Lemma length_right_tape_move_right sig' (t : tape sig'): | right (tape_move_right t) | <= | right t |.
    Proof.
      destruct t eqn:Ht;cbn. 1-3:nia. now destruct l0;cbn;nia.
    Qed.

    Lemma Terminates n: projT1 (M n) ↓ Ter n.
    Proof.
      unfold Ter.
      induction n.
      -cbn. eapply TerminatesIn_monotone. now TM_Correct.
       intros ? ? ?. nia.
      -assert (Ht:= length_right_tape_move_right).
       cbn - [plus mult]. eapply TerminatesIn_monotone.
       {TM_Correct. now apply CheckEncodesTape.Realise. now apply CheckEncodesTape.Terminates. eassumption. }
       intros ? ? HT. set (n0:= | tape_local x[@Fin0] |) in *. cbn. infTer 5.
        2:{ intros t ? (?&->&->&<-). destruct _.
            infTer 5.  unfold CheckEncodesTape.Ter. intros ? _ Htout. rewrite !Htout. infTer 4.
            intros ? ? ?. destruct b.
            -infTer 5. intros ? ? ->.
             rewrite !Ht. cbn in *. fold n0.  destruct H as [_ (k&H)].
             rewrite H. rewrite iter_transitive with (g:=fun x => | right x |) (R:=le). 2:eauto. 2:apply Ht.
             rewrite Htout,Ht. fold n0. reflexivity.
            -nia.
            -nia.
        }
        ring_simplify. rewrite !Ht. fold n0. rewrite <- HT. ring_simplify. nia.
    Qed.

    Lemma R_syntactic__spec n t b t':
      R_syntactic n t b t'
      -> Rel n [|t|] (b,[|t'|]).
    Proof.
      subst Rel. rewrite ContainsEncoding.legacy_iff. 2:now intros []. unfold ContainsEncoding.Rel_legacy .
      unfold encode,Encode_tapes,encode_tapes. cbn.
      induction n in t |-*;cbn [R_syntactic].
      {unfold ContainsEncoding.Rel. intros [[Hb] <-]. split. 2:now eexists 0. destruct Hb.
       -destruct t;inv e. apply retract_g_inv in H0 as ->.
        eexists [| |],_,_. cbn. split. now eexists _,[]. now eexists [],_.
       -intros ? v ?. rewrite (destruct_vector_nil v);cbn.
        eexists _,_. split. easy. intros ->. cbn in n. now retract_adjoint.
      }
      intros [(Ht&t1&b1&HR&Hb1) | (Ht&->&->)].
      2:{ clear IHn. cbn in *. split. 2:now eexists 0. intros ? v ?. destruct (destruct_vector_cons v) as (t0&b'&->). cbn.
          do 3 eexists. reflexivity. intros ->. cbn in Ht. now retract_adjoint. }
      cbn. destruct HR as (HR&(k & Ht1)). destruct b1;hnf in HR.
      2:{ clear IHn. destruct Hb1 as [<- ->]. split. 2:{ exists (S k). now rewrite Ht1,nat_rect_succ_r. }
          intros ? v ?. destruct (destruct_vector_cons v) as (t0&b'&->). cbn.
          do 3 eexists. easy. intros ->. cbn in HR.
          edestruct HR with (x:=t0) as (?&?&Hhd&Henc).
          destruct (encode_tape t0) eqn:Ht0. all:inv Hhd. cbn in Henc.
          apply Henc. unfold retr_comp_f. cbn. autorewrite with list. rewrite map_map. reflexivity. }
      cbn in HR. revert Ht. destruct t as [ | | | t__L c t__R];intros [= ->%retract_g_inv].
      destruct HR as (t0&t__L'&t__R'&(x__hd&x__tl&eq__hd&Ht)&(x__init&x__last&eq__last&Ht')). rewrite Ht' in Hb1,Ht1. clear t1 Ht'.
      destruct t__R; inv Ht. cbn in Hb1. specialize IHn with (1:=Hb1);cbn in IHn.
      destruct IHn as [IHn Hres].
      split. 2:{ destruct Hres as [k' ->]. cbn. eexists (S ((S _) + _)). rewrite nat_rect_succ_r. cbn - [nat_rect plus]. rewrite nat_rect_plus.
                  cbn in Ht1. rewrite <- Ht1. rewrite nat_rect_succ_r. now cbn. } clear Hres.
      destruct b.
      -destruct IHn as (v&t__Lv&t__Rv&(x__hd'&x__tl'&eq__hd'&Ht)&(x__init'&x__last'&eq__last'&->)).
       destruct t__R' as [ |? t__R'];inv Ht. cbn in Ht1.
       eexists (t0:::v),_,_;split.
       + do 3 eexists.
        * rewrite Vector.to_list_cons. cbn. reflexivity.
        * rewrite eq__hd, eq__hd'. unfold retr_comp_f. cbn;autorewrite with list;cbn. rewrite map_map. reflexivity.
       + rewrite Vector.to_list_cons. cbn. rewrite eq__last, eq__last'. unfold retr_comp_f. cbn;autorewrite with list;cbn.
        eexists (_::_++_::_),_. split. 1:{ repeat (cbn;autorewrite with list). easy. }
        f_equal. repeat (cbn;autorewrite with list;try rewrite map_rev;try rewrite map_map). easy.
      -intros ? v ?. destruct (destruct_vector_cons v) as (t0'&b'&->). rewrite Vector.to_list_cons. cbn.
       do 3 eexists. reflexivity. intros [= <- H]. revert H. unfold retr_comp_f;autorewrite with list;rewrite map_map.
       rewrite app_comm_cons,<-(map_cons (fun a : sigTape sig => Retr_f (sigList_X a))). rewrite <- eq__hd.
       intros H. assert (H':=H).
       change (fun x : sigTape sig => Retr_f  (sigList_X x)) with (Retr_f (X:=sigTape sig) (Y:=tau)) in H'.
       eapply (f_equal (map _)) in H'. rewrite !map_app,!(surject_inject' _ NilBlank) in H'.
       change (@encode_tape sig) with (encode (X:=tape sig)) in H'.
       apply (tape_encode_prefixInjective) in H'. subst t0'.
       apply app_inv_head in H as ->.
       edestruct IHn as (?&?&?&Hneq). apply Hneq. cbn. rewrite H. cbn.
       f_equal.
    Qed.

    Lemma Realise n: M n ⊨ Rel n.
    Proof.
      eapply Realise_monotone. now apply Realises_intern. intros t [? t'] ?%R_syntactic__spec.
      unfold tapes in *. destruct_vector. easy.
    Qed.

  End checkEncodesTapes.
End CheckEncodesTapes.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg perm zmodp matrix vector.
Require Import Reals Fourier.
Require Import ssrR Reals_ext ssr_ext ssralg_ext Rbigop f2 proba.
Require Import channel_code channel binary_symmetric_channel hamming pproba.

(** * The variety of decoders *)

(** OUTLINE:
- Section minimum_distance_decoding.
- Section bounded_distance_decoding.
- Section maximum_likelihood_decoding.
- Section maximum_likelihood_decoding_prop.
- Section MD_ML_decoding.
- Section MAP_decoding.
- Section MAP_decoding_prop.
- Section MPM_condition.
*)

Reserved Notation "t .-BDD f" (at level 2, format "t  .-BDD  f").

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

Local Close Scope R_scope.
Import GRing.Theory.
Local Open Scope ring_scope.

Definition repairT (B A : finType) n := {ffun 'rV[B]_n -> option 'rV[A]_n}.

Definition oimg (A B : finType) (f : A -> option B) : {set B} :=
  [set b | [exists a, f a == Some b]].

Definition discardT (A : finType) n (M : finType) := 'rV[A]_n -> M.

Definition cancel_on n (F : finFieldType) (C : {vspace 'rV[F]_n}) {B} (e : B -> _) s :=
  forall c, c \in C -> e (s c) = c.

Lemma vspace_not_empty (F : finFieldType) n (C : {vspace 'rV[F]_n}) :
  0 < #| [set cw in C] |.
Proof. apply/card_gt0P; exists 0; by rewrite inE mem0v. Qed.

Section minimum_distance_decoding.

Variables (F : finFieldType) (n : nat) (C : {set 'rV[F]_n}).
Variable f : repairT F F n.

Local Open Scope nat_scope.

Definition MD_decoding :=
  forall y x, f y = Some x -> forall x', x' \in C -> dH x y <= dH x' y.

Local Close Scope nat_scope.

Local Open Scope min_scope.

Hypothesis c_not_empty : {c0 | c0 \in C}.

Definition MD_decoding_alt :=
  forall y x, f y = Some x ->
    dH y x = \min^ (sval c_not_empty) _(x' in C) dH y x'.

Variable f_img : oimg f \subset C.

Lemma MD_decoding_equiv : MD_decoding_alt <-> MD_decoding.
Proof.
split => [H /= y x yx x' x'C | H /= y x yx].
- move: {H}(H _ _ yx) => H.
  rewrite dH_sym H dH_sym.
  case: arg_minP; first by case: c_not_empty.
  move=> /= i ic ij; by rewrite dH_sym (dH_sym x') ij.
- move: {H}(H _ _ yx) => H.
  case: arg_minP; first by case: c_not_empty.
  move=> /= i Hi /(_ x) Ki.
  apply/eqP; rewrite eqn_leq; apply/andP; split.
  - by rewrite dH_sym (dH_sym y) H.
  - apply/Ki; move/subsetP: f_img; apply; rewrite inE.
    by apply/existsP; exists y; apply/eqP.
Qed.

End minimum_distance_decoding.

Section bounded_distance_decoding.

Variables (F : finFieldType) (n : nat) (C : {vspace 'rV[F]_n}).
Variable (f : repairT F F n).

Definition BD_decoding t :=
  forall c e, c \in C -> wH e <= t -> f (c + e) = Some c.

End bounded_distance_decoding.

Notation "t .-BDD f" := (BD_decoding (fst f) (snd f) t) : ecc_scope.

Local Open Scope proba_scope.
Local Open Scope channel_scope.

Section maximum_likelihood_decoding.

Variables (A : finFieldType) (B : finType) (W : `Ch_1(A, B)).
Variables (n : nat) (C : {vspace 'rV[A]_n}).
Variable f : decT B [finType of 'rV[A]_n] n.
Variable P : {dist 'rV[A]_n}.

Local Open Scope R_scope.

Definition ML_decoding :=
  forall y, receivable W P y ->
  exists x, f y = Some x /\
    W ``(y | x) = \rmax_(x' in C) W ``(y | x').

End maximum_likelihood_decoding.

Local Open Scope R_scope.

Section maximum_likelihood_decoding_prop.

Variables (A : finFieldType) (B : finType) (W : `Ch_1(A, B)).
Variables (n : nat) (C : {vspace 'rV[A]_n}).
Variable repair : decT B [finType of 'rV[A]_n] n.
Let P := UniformSupport.d (vspace_not_empty C).
Hypothesis ML_dec : ML_decoding W C repair P.

Local Open Scope channel_code_scope.

Lemma ML_err_rate x1 x2 y : repair y = Some x1 ->
  x2 \in C -> W ``(y | x2) <= W ``(y | x1).
Proof.
move=> Hx1 Hx2.
case/boolP : (W ``(y | x2) == 0%R) => [/eqP ->| Hcase].
  exact: DMC_ge0.
have : receivable W P y.
  apply/existsP; exists x2.
  by rewrite Hcase andbT UniformSupport.neq0 inE.
case/(ML_dec (y := y)) => x' [].
rewrite Hx1 => -[<-] ->.
rewrite -big_filter.
apply (Rle_bigRmax (fun i => W ``(y | i))).
by rewrite mem_filter /= mem_index_enum andbT.
Qed.

Variable M : finType.
Hypothesis M_not_0 : (0 < #|M|)%nat.
Variable discard : discardT A n M.
Variable enc : encT A M n.
Hypothesis enc_img : enc @: M \subset C.
Hypothesis discard_cancel : forall y x, repair y = Some x -> enc (discard x) = x.

Lemma ML_smallest_err_rate phi :
  let dec := [ffun x => omap discard (repair x)] in
  echa(W, mkCode enc dec) <= echa(W, mkCode enc phi).
Proof.
move=> dec.
apply leR_wpmul2l.
  apply/mulR_ge0 => //; exact/ltRW/invR_gt0/ltR0n.
rewrite /ErrRateCond /=.
apply (@leR_trans (\rsum_(m in M) (1 - Pr (W ``(|enc m)) [set tb | phi tb == Some m]))); last first.
  apply Req_le, eq_bigr => m _.
  rewrite [in RHS]Pr_to_cplt.
  set lhs := ~: _. set rhs := [set _ | _].
  suff -> : lhs = rhs by [].
  apply/setP => t; by rewrite !inE negbK.
apply (@leR_trans (\rsum_(m in M) (1 - Pr (W ``(|enc m)) [set tb | dec tb == Some m]))).
  apply Req_le, eq_bigr => m _.
  rewrite [LHS]Pr_to_cplt.
  set lhs := ~: _. set rhs := [set _ | _].
  suff -> : lhs = rhs by [].
  apply/setP => t; by rewrite !inE negbK.
rewrite 2!big_split /=.
apply Rplus_le_compat_l.
rewrite -2!(big_morph _ morph_Ropp oppR0) leR_oppr oppRK.
rewrite /Pr (exchange_big_dep xpredT) //= [in X in (_ <= X)%R](exchange_big_dep xpredT) //=.
apply ler_rsum => /= tb _.
apply (@leR_trans (\rsum_(m| phi tb == Some m) (W ``(tb | enc m)))).
  apply Req_le, eq_bigl => m; by rewrite inE.
apply (@leR_trans (\rsum_(m| dec tb == Some m) (W ``(tb | enc m)))); last first.
  apply Req_le, eq_bigl => m; by rewrite inE.
(* show that phi_ML succeeds more often than phi *)
case/boolP : (dec tb == None) => dectb.
  case/boolP: (receivable W P tb) => [ | Htb].
    case/ML_dec => m'.
      case=> Htmp.
      move: dectb.
      by rewrite {1}/dec {1}ffunE Htmp.
  have Htb' m : W ``(tb | enc m) = 0%R.
    apply/eqP; apply/contraR : Htb => Htb.
    apply/existsP; exists (enc m).
    rewrite Htb andbT UniformSupport.neq0 inE.
    move/subsetP : enc_img; apply.
    apply/imsetP; by exists m.
  rewrite (eq_bigr (fun=> 0)); last by move=> m _; rewrite Htb'.
  rewrite big_const iter_addR mulR0.
  apply rsumr_ge0 => ? _; exact/DMC_ge0.
case/boolP : (phi tb == None) => [/eqP ->|phi_tb].
  rewrite big_pred0 //; apply rsumr_ge0 => ? _; exact/DMC_ge0.
have [m1 Hm1] : exists m', dec tb = Some m'.
  destruct (dec tb) => //; by exists s.
have [m2 Hm2] : exists m', phi tb = Some m'.
  destruct (phi tb) => //; by exists s.
rewrite Hm1 {}Hm2.
apply (@leR_trans (\rsum_(m| m == m2) W ``(tb | enc m))).
  by apply Req_le, eq_bigl => m; rewrite eq_sym.
apply (@leR_trans (\rsum_(m| m == m1) W ``(tb | enc m))); last first.
  by apply Req_le, eq_bigl => m; rewrite eq_sym.
rewrite 2!big_pred1_eq.
apply ML_err_rate.
  move: Hm1.
  rewrite /dec ffunE.
  rewrite /Option.map.
  rewrite /obind.
  rewrite /oapp.
  move H : (repair tb) => h.
  case: h H => // a Ha [<-]; congr Some.
  by rewrite (discard_cancel Ha).
move/subsetP : enc_img; apply.
apply/imsetP; by exists m2.
Qed.

End maximum_likelihood_decoding_prop.

Section MD_ML_decoding.

Variable p : R.
Hypothesis p_01 : 0 <= p <= 1.

(* TODO: move to file on bsc? *)
Lemma bsc_prob_prop n : p < 1 / 2 ->
  forall n1 n2 : nat, (n1 <= n2 <= n)%nat ->
  ((1 - p) ^ (n - n2) * p ^ n2 <= (1 - p) ^ (n - n1) * p ^ n1)%R.
Proof.
move=> p05 d1 d2 d1d2.
case/Rle_lt_or_eq_dec: (proj1 p_01) => [Hp | <-]; last first.
  destruct d2 as [|d2].
    destruct d1 as [|d1]; [exact/leRR | by []].
  rewrite !subR0 /= !mul0R !mulR0.
  destruct d1 as [|d1] => /=.
    rewrite subn0 mulR1 pow1; fourier.
  rewrite !mul0R !mulR0; exact/leRR.
apply (@leR_pmul2l ((/ (1 - p) ^ (n - d2)) * (/ p ^ d1))%R).
  apply mulR_gt0; apply/invR_gt0/pow_lt => //; by fourier.
rewrite (mulRC ((1 - p) ^ (n - d2))) -!mulRA mulRC -!mulRA mulRV; last first.
  apply/pow_not0; rewrite subR_eq0; apply/eqP/gtR_eqF; fourier.
rewrite mulR1 -(mulRC (p ^ d1)) [in X in _ <= X]mulRC !mulRA mulVR ?mul1R; last first.
  exact/pow_not0/eqP/gtR_eqF.
rewrite -expRV; last by apply/eqP/gtR_eqF.
rewrite -expRV; last by rewrite subR_eq0; apply/eqP/gtR_eqF; fourier.
rewrite mulRC expRV; last exact/eqP/gtR_eqF.
rewrite -/(Rdiv _ _) -expRB; last 2 first.
  by case/andP : d1d2.
  exact/gtR_eqF.
rewrite expRV; last by rewrite subR_eq0; apply/eqP => ?; subst p; fourier.
rewrite -/(Rdiv _ _) -expRB; last 2 first.
  rewrite leq_sub2l //; by case/andP : d1d2.
  by apply/eqP; rewrite subR_eq0; apply/eqP => ?; subst p; fourier.
suff -> : (n - d1 - (n - d2) = d2 - d1)%nat.
  apply pow_incr; split; fourier.
rewrite -subnDA addnC subnDA subKn //.
by case/andP : d1d2.
Qed.

Let card_F2 : #| 'F_2 | = 2%nat. Proof. by rewrite card_Fp. Qed.
Let W := BSC.c card_F2 p_01.

Variables (n : nat) (C : {vspace 'rV['F_2]_n}).
Variable f : repairT [finType of 'F_2] [finType of 'F_2] n.
Variable f_img : oimg f \subset C.
Variable M : finType.
Variable discard : discardT [finType of 'F_2] n M.
Variable enc : encT [finType of 'F_2] M n.
Hypothesis compatible : cancel_on C enc discard.
Variable P : {dist 'rV['F_2]_n}.

Lemma MD_implies_ML : p < 1/2 -> MD_decoding [set cw in C] f ->
  (forall y, f y != None) -> ML_decoding W C f P.
Proof.
move=> p05 MD f_total y _ (* y_receivable *).
have codebook_not_empty : {c | c \in [set cw in C] }.
  move: (mem0v C); set x := (X in X \in C) => _.
  exists x; by rewrite inE mem0v.
have {MD}MD : MD_decoding_alt f codebook_not_empty.
  apply MD_decoding_equiv => //.
  apply/subsetP => y' Hy'.
  move/subsetP : f_img => /(_ _ Hy'); by rewrite inE.
move Hoc : (f y) => oc.
case: oc Hoc => [c|] Hc; last first.
  by move: (f_total y); rewrite Hc.
exists c; split; first by reflexivity.
(* replace  W ``^ n (y | f c) with a closed formula because it is a BSC *)
pose dH_y c := dH y c.
pose g : nat -> R := fun d : nat => (1 - p) ^ (n - d) * p ^ d.
have -> : W ``(y | c) = g (dH_y c).
  move: (DMC_BSC_prop p_01 enc (discard c) y).
  set cast_card := eq_ind_r _ _ _.
  rewrite (_ : cast_card = card_F2) //; last by apply eq_irrelevance.
  clear cast_card.
  rewrite -/W compatible //.
  move/subsetP : f_img; apply.
  rewrite inE; apply/existsP; by exists y; apply/eqP.
transitivity (\big[Rmax/R0]_(c in C) (g (dH_y c))); last first.
  apply eq_bigr => /= c' Hc'.
  move: (DMC_BSC_prop p_01 enc (discard c') y).
  set cast_card := eq_ind_r _ _ _.
  rewrite (_ : cast_card = card_F2) //; last by apply eq_irrelevance.
  by rewrite -/W compatible.
(* the function maxed over is decreasing so we may look for its minimizer,
   which is given by minimum distance decoding *)
rewrite (@big_rmax_bigminn_helper_vec _ _ _ _ _ _ _ _ _ _ codebook_not_empty) //.
- apply eq_bigl => /= i; by rewrite inE.
- by apply bsc_prob_prop.
- move=> r; rewrite /g.
  apply mulR_ge0; apply pow_le; [fourier | by case: p_01].
- rewrite inE; move/subsetP: f_img; apply.
  rewrite inE; apply/existsP; by exists y; apply/eqP.
- move=> ? _; by rewrite /dH_y max_dH.
- by rewrite /dH_y MD.
Qed.

End MD_ML_decoding.

Section MAP_decoding.

Variables (A : finFieldType) (B : finType) (W : `Ch_1(A, B)).
Variables (n : nat) (C : {vspace 'rV[A]_n}).
Variable dec : decT B [finType of 'rV[A]_n] n.
Variable P : {dist 'rV[A]_n}.

Definition MAP_decoding := forall y (Hy : receivable W P y),
  exists m, dec y = Some m /\
    P `^^ W , Hy (m | y) = \rmax_(m in C) (P `^^ W , Hy (m | y)).

End MAP_decoding.

Section MAP_decoding_prop.

Variables (A : finFieldType) (B : finType) (W : `Ch_1(A, B)).
Variables (n : nat) (C : {vspace 'rV[A]_n}).
Variable dec : decT B [finType of 'rV[A]_n] n.
Variable dec_img : oimg dec \subset C.
Let P := UniformSupport.d (vspace_not_empty C).

Lemma MAP_implies_ML : MAP_decoding W C dec P -> ML_decoding W C dec P.
Proof.
move=> HMAP.
rewrite /ML_decoding => /= tb Htb.
have Hunpos : INR 1 / INR #| [set cw in C] | > 0.
  rewrite div1R; exact/invR_gt0/ltR0n/vspace_not_empty.
move: (HMAP _ Htb) => H.
rewrite /PosteriorProbability.d in H.
unlock in H.
simpl in H.
set tmp := \rmax_(_ <- _ | _) _ in H.
rewrite /tmp -rmax_distrl in H; last first.
  apply/ltRW/invR_gt0/ltRP; rewrite ltR_neqAle; apply/andP; split; last first.
    exact/leRP/PosteriorProbability.den_ge0.
  by rewrite eq_sym -receivableE.
rewrite /P /UniformSupport.d /UniformSupport.f /= in H.
case: H => [m' [Hm' H]].
set r := index_enum _ in H.
rewrite (eq_bigr (fun i => 1 / INR #|[set cw in C]| * W ``(tb | i))) in H; last first.
  move=> i iC; by rewrite UniformSupport.E // inE.
rewrite -rmax_distrr in H; last exact/ltRW/Hunpos.
exists m'; split; first exact Hm'.
set x := PosteriorProbability.den _ _ _ in H.
have x0 : / x <> 0 by apply/eqP/invR_neq0; rewrite -receivableE.
move/(eqR_mul2r x0) in H.
rewrite /= UniformSupport.E ?inE // in H; last first.
  move/subsetP : dec_img; apply.
  rewrite inE; apply/existsP; by exists tb; apply/eqP.
move/eqR_mul2l :  H => -> //; exact: gtR_eqF.
Qed.

End MAP_decoding_prop.

Section MPM_condition.

(* in the special case of a binary code... *)
Variable W : `Ch_1('F_2, [finType of 'F_2]).
Variable n : nat.
Variable C : {vspace 'rV['F_2]_n}.
Hypothesis C_not_empty : (0 < #|[set cw in C]|)%nat.
Variable m : nat.
Variable enc : encT [finFieldType of 'F_2] [finType of 'rV['F_2]_(n - m)] n.
Variable dec : decT [finFieldType of 'F_2] [finType of 'rV['F_2]_(n - m)] n.

Local Open Scope vec_ext_scope.

Definition MPM_condition := let P := `U C_not_empty in
  forall y (Hy : receivable W P y),
  forall x, dec y = Some x ->
  forall n0,
    P '_ n0 `^^ W , Hy ((enc x) ``_ n0 | y) = \rmax_(b in 'F_2) P '_ n0 `^^ W , Hy (b | y).

End MPM_condition.


Require Export SfLib.

Module Smten.

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty         (* T -> T *)
  | TUnit  : ty                     (* Unit *)
  | TProd  : ty -> ty -> ty         (* T1 * T2 *)
  | TSum   : ty -> ty -> ty         (* T1 + T2 *)
  | TIO    : ty -> ty               (* IO T *)
  | TS     : ty -> ty               (* S T *)
  .

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TArrow"
  | Case_aux c "TUnit" | Case_aux c "TProd" | Case_aux c "TSum"
  | Case_aux c "TIO" | Case_aux c "TS" ].

Inductive tm : Type :=
  | tvar : id -> tm                 (* x *)
  | tapp : tm -> tm -> tm           (* t1 t2 *)
  | tabs : id -> ty -> tm -> tm     (* \x:T.t *)
  | tunit : tm                      (* unit *)
  | tpair : tm -> tm -> tm          (* (t1, t2) *)
  | tfst : tm -> tm                 (* fst t1 *)
  | tsnd : tm -> tm                 (* snd t1 *)
  | tinl : ty -> tm -> tm           (* inl T t *)
  | tinr : ty -> tm -> tm           (* inr T t *)
  | tcase : tm -> tm -> tm -> tm    (* case t0 t1 t2 *)
  | tfix : tm -> tm                 (* fix t *)

    (* IO space primitives *)
  | treturnIO : tm -> tm            (* return_IO t *)
  | tbindIO : tm -> tm -> tm        (* bind_IO t1 t2 *)
  | tsearchIO : tm -> tm            (* search_IO t *)

    (* Search space primitives *)
  | temptyS : ty -> tm              (* empty *)
  | tsingleS : tm -> tm             (* single t *)
  | tunionS : tm -> tm -> tm        (* union t1 t2 *)
  | tmapS : tm -> tm -> tm          (* map t1 t2 *)
  | tjoinS : tm -> tm               (* join t *)
  .

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tunit"
  | Case_aux c "tpair" | Case_aux c "tfst" | Case_aux c "tsnd"
  | Case_aux c "tinl" | Case_aux c "tinr" | Case_aux c "tcase"
  | Case_aux c "tfix"
  | Case_aux c "treturnIO" | Case_aux c "tbindIO"  | Case_aux c "tsearchIO"
  | Case_aux c "temptyS" | Case_aux c "tsingleS" | Case_aux c "tunionS"
  | Case_aux c "tmapS" | Case_aux c "tjoinS" ].

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation "'TMaybe' T" := (TSum TUnit T) (at level 20).
Notation "'tnothing' T" := (tinl T tunit) (at level 20).
Notation "'tjust' t" := (tinr TUnit t) (at level 20).

Inductive value : tm -> Prop :=
  | v_abs : forall x T t, value (tabs x T t)
  | v_unit : value tunit
  | v_pair : forall t1 t2, value (tpair t1 t2)
  | v_inl : forall T t, value (tinl T t)
  | v_inr : forall T t, value (tinr T t)
  | v_returnIO : forall t, value (treturnIO t)
  | v_bindIO : forall t1 t2, value (tbindIO t1 t2)
  | v_searchIO : forall t, value (tsearchIO t)
  | v_emptyS : forall T, value (temptyS T)
  | v_singleS : forall t, value (tsingleS t)
  | v_unionS : forall t1 t2, value (tunionS t1 t2)
  | v_mapS : forall t1 t2, value (tmapS t1 t2)
  | v_joinS : forall t, value (tjoinS t)
  .

Tactic Notation "v_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "v_abs" | Case_aux c "v_unit"
  | Case_aux c "v_pair"
  | Case_aux c "v_inl" | Case_aux c "v_inr"
  | Case_aux c "v_returnIO" | Case_aux c "v_bindIO" | Case_aux c "v_searchIO"
  | Case_aux c "v_emptyS" | Case_aux c "v_singleS" | Case_aux c "v_unionS"
  | Case_aux c "v_mapS" | Case_aux c "v_joinS"
  ].

Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' => if eq_id_dec x x' then s else t
  | tabs x' T t1 => tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 => tapp ([x:=s] t1) ([x:=s] t2)
  | tunit => tunit
  | tpair t1 t2 => tpair ([x:=s] t1) ([x:=s] t2)
  | tfst t1 => tfst ([x:=s] t1)
  | tsnd t1 => tsnd ([x:=s] t1)
  | tinl T t1 => tinl T ([x:=s] t1)
  | tinr T t1 => tinr T ([x:=s] t1)
  | tcase t1 t2 t3 => tcase ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | tfix t1 => tfix ([x:=s] t1)
  | treturnIO t1 => treturnIO ([x:=s] t1)
  | tbindIO t1 t2 => tbindIO ([x:=s] t1) ([x:=s] t2)
  | tsearchIO t1 => tsearchIO ([x:=s] t1)
  | temptyS T => temptyS T
  | tsingleS t1 => tsingleS ([x:=s] t1)
  | tunionS t1 t2 => tunionS ([x:=s] t1) ([x:=s] t2)
  | tmapS t1 t2 => tmapS ([x:=s] t1) ([x:=s] t2)
  | tjoinS t1 => tjoinS ([x:=s] t1)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t1 t2,
         (tapp (tabs x T t1) t2) ==> [x:=t2]t1
  | ST_App : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_FstPair : forall t1 t2,
      (tfst (tpair t1 t2)) ==> t1
  | ST_Fst : forall t t',
      t ==> t' ->
      tfst t ==> tfst t'
  | ST_SndPair : forall t1 t2,
      (tsnd (tpair t1 t2)) ==> t2
  | ST_Snd : forall t t',
      t ==> t' ->
      tsnd t ==> tsnd t'
  | ST_CaseInl : forall T t1 t2 t3,
      (tcase (tinl T t1) t2 t3) ==> (tapp t2 t1)
  | ST_CaseInr : forall T t1 t2 t3,
      (tcase (tinr T t1) t2 t3) ==> (tapp t3 t1)
  | ST_Case : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tcase t1 t2 t3 ==> tcase t1' t2 t3
  | ST_Fix : forall t,
      tfix t ==> tapp t (tfix t)

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App"
  | Case_aux c "ST_FstPair" | Case_aux c "ST_Fst"
  | Case_aux c "ST_SndPair" | Case_aux c "ST_Snd"
  | Case_aux c "ST_CaseInl" | Case_aux c "ST_CaseInr" | Case_aux c "ST_Case"
  | Case_aux c "ST_Fix" ].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_Unit : forall Gamma,
       Gamma |- tunit \in TUnit
  | T_Pair : forall Gamma t1 t2 T1 T2,
       Gamma |- t1 \in T1 ->
       Gamma |- t2 \in T2 ->
       Gamma |- (tpair t1 t2) \in (TProd T1 T2)
  | T_Fst : forall Gamma t T1 T2,
       Gamma |- t \in (TProd T1 T2) ->
       Gamma |- (tfst t) \in T1
  | T_Snd : forall Gamma t T1 T2,
       Gamma |- t \in (TProd T1 T2) ->
       Gamma |- (tsnd t) \in T2
  | T_Inl : forall Gamma t T1 T2,
       Gamma |- t \in T1 ->
       Gamma |- (tinl T2 t) \in (TSum T1 T2)
  | T_Inr : forall Gamma t T1 T2,
       Gamma |- t \in T2 ->
       Gamma |- (tinr T1 t) \in (TSum T1 T2)
  | T_Case : forall Gamma t1 t2 t3 T1 T2 T3,
       Gamma |- t1 \in (TSum T1 T2) ->
       Gamma |- t2 \in (TArrow T1 T3) ->
       Gamma |- t3 \in (TArrow T2 T3) ->
       Gamma |- (tcase t1 t2 t3) \in T3
  | T_Fix : forall Gamma t T,
       Gamma |- t \in (TArrow T T) ->
       Gamma |- tfix t \in T
  | T_ReturnIO : forall Gamma t T,
       Gamma |- t \in T ->
       Gamma |- treturnIO t \in (TIO T)
  | T_BindIO : forall Gamma t1 t2 T1 T2,
       Gamma |- t1 \in (TIO T1) ->
       Gamma |- t2 \in (TArrow T1 (TIO T2)) ->
       Gamma |- tbindIO t1 t2 \in (TIO T2)
  | T_SearchIO : forall Gamma t T,
       Gamma |- t \in (TS T) ->
       Gamma |- tsearchIO t \in (TIO (TMaybe T))
  | T_EmptyS : forall Gamma T,
       Gamma |- temptyS T \in (TS T)
  | T_SingleS : forall Gamma t T,
       Gamma |- t \in T ->
       Gamma |- tsingleS t \in (TS T)
  | T_UnionS : forall Gamma t1 t2 T,
       Gamma |- t1 \in (TS T) ->
       Gamma |- t2 \in (TS T) ->
       Gamma |- tunionS t1 t2 \in (TS T)
  | T_MapS : forall Gamma t1 t2 T1 T2,
       Gamma |- t1 \in (TArrow T1 T2) ->
       Gamma |- t2 \in (TS T1) ->
       Gamma |- tmapS t1 t2 \in (TS T2)
  | T_JoinS : forall Gamma t T,
       Gamma |- t \in (TS (TS T)) ->
       Gamma |- tjoinS t \in (TS T)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_Unit"
  | Case_aux c "T_Pair" | Case_aux c "T_Fst" | Case_aux c "T_Snd"
  | Case_aux c "T_Inl" | Case_aux c "T_Inr" | Case_aux c "T_Case"
  | Case_aux c "T_Fix"
  | Case_aux c "T_ReturnIO" | Case_aux c "T_BindIO" | Case_aux c "T_SearchIO"
  | Case_aux c "T_EmptyS" | Case_aux c "T_SingleS" | Case_aux c "T_UnionS"
  | Case_aux c "T_MapS" | Case_aux c "T_JoinS" ].

Hint Constructors has_type.

End Smten.


(*
  This file generalizes 'all_proof.v' further by
  adding an invariant to the claim language,
  with a similar interpretation to the "Guarantee" part
  of a Rely-Guarantee claim.

  In the specification 'until x T P', the invariant 'T'
  is a relation on configurations, 'cfg -> cfg -> Prop'
  rather than a unary predicate like 'P : T'.

  In this file, a specification only holds if in every complete
  path from x, all the steps before reaching any configuration in P
  are also included in T, in addition to no such paths getting stuck
  without reaching a state in P.
 *)

Set Implicit Arguments.

Section relations.
Variables (cfg : Set) (cstep : cfg -> cfg -> Prop).

Definition Spec : Type := cfg -> (cfg -> cfg -> Prop) -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive until (k : cfg) (T : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | rdone : P k -> until k T P
  | rstep : (exists k', cstep k k') -> (forall k', cstep k k' -> T k k' /\ until k' T P) -> until k T P.

Definition sound (Rules : Spec) : Prop :=
  forall x T P, Rules x T P -> until x T P.

Inductive step (X : Spec) (k : cfg) (T : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | sdone : P k -> step X k T P
  | sstep : (exists k', cstep k k') -> (forall k', cstep k k' -> T k k' /\ X k' T P) -> step X k T P
.

CoFixpoint stable_sound (Rules : Spec)
  (Hstable : forall x T P, Rules x T P -> step Rules x T P)
  : sound Rules := fun x T P H =>
match Hstable _ _ _ H with
    | sdone pf => rdone _ _ _ pf
    | sstep not_stuck Hsteps => rstep not_stuck (fun k' Hstep =>
        let (Hpres, Hk') := Hsteps k' Hstep
        in conj Hpres (stable_sound Hstable k' T P Hk'))
end.

Inductive trans (X : Spec) (k : cfg) (T : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | drule : X k T P -> trans X k T P
  | ddone : P k -> trans X k T P
  | dstep' : (exists k', cstep k k') ->
             (forall k', cstep k k' -> T k k') ->
             (forall k', cstep k k' -> trans X k' T P) (* split into two functions to get a better induction principle *)
             -> trans X k T P
  | dstrong : forall (T' : cfg -> cfg -> Prop),
       (forall a b, T' a b -> T a b) -> trans X k T' P -> trans X k T P
  | dtrans' : forall Q, trans X k T Q -> (forall k', Q k' -> trans X k' T P) -> trans X k T P
  .

Lemma absorb_step : forall X k T P, step (trans X) k T P -> trans X k T P.
Proof. destruct 1;constructor(solve[firstorder]). Qed.

Lemma absorb_step_inner : forall X k T P, trans (step X) k T P -> trans X k T P.
Proof. induction 1;eauto using trans.
  destruct H;constructor(solve[firstorder using drule]).
Qed.

Lemma trans_ok : forall X k T P, trans (step X) k T P -> step (trans X) k T P.
induction 1;try match goal with [H : step _ _ _ _ |- _] => destruct H end;eauto using step;
firstorder eauto using trans, absorb_step_inner.
Qed.

Lemma trans_stable (Rules : Spec) :
  (forall x T P, Rules x T P -> step (trans Rules) x T P)
  -> (forall x T P, trans Rules x T P -> step (trans Rules) x T P).
induction 2;eauto using step;
destruct IHtrans; firstorder eauto using step, trans.
Qed.

Lemma proved_sound (Rules : Spec) :
  (forall x T P, Rules x T P -> step (trans Rules) x T P)
  -> sound Rules.
unfold sound.
intros.
apply stable_sound with (trans Rules).
apply trans_stable. assumption.
apply drule. assumption.
Qed.

End relations.


Unset Implicit Arguments.

Definition compose (A:Set) (g f:A -> A) (x:A) := g (f x).

Definition thrice (A:Set) (f:A -> A) := compose A f (compose A f f).

Eval compute in (thrice _ (thrice _) S 0).

Check (thrice _ (thrice _) S 0).


Require Import String List.
Local Open Scope string.
Import ListNotations Nat.

Inductive paramTest (A:Type) (B:nat) : Type :=.
Inductive indexTest (A:Type) : nat -> bool -> Type :=.
Inductive nonUniTest (A:Type) (n:nat) : bool -> Type :=
    | C1: forall (H:nonUniTest A (S n) false), nonUniTest A n true
    | C2: forall (H:nonUniTest A n true), nonUniTest A n false.

Inductive nonUniDepTest (A:Type) (N:nat) (*non-uni:*) (xs:list A) : bool -> nat -> Type :=
    | CD1: forall (H1:nonUniDepTest A N [] false 1) (a:A) (M:nat) (H2:nonUniDepTest A N [] false 0), nonUniDepTest A N xs true N
    | CD2: forall (k:nat)
    (f:forall (a:A), nonUniDepTest A N [] true 0)
    (g:forall b, nonUniDepTest A N [] b 0)
    (h:forall n b, nonUniDepTest A N [] b n)
    (a:A)
    (HA:nonUniDepTest A N (a::xs) true 0), nonUniDepTest A N xs false 1.
    (* (HA:nonUniDepTest A N (xs ++ xs) true 0), nonUniDepTest A N xs false 1. *)

Inductive depTest (A:Type) (HA: A -> Type) : (forall a, HA a) -> Type :=.
Inductive implicitTest {n:nat} (A:Type) : Type := Impl.
Inductive guardTest :=
  G (g:nat -> guardTest).

Inductive vec (A : Type) : nat -> Type :=
	nilVec : vec A 0
  | consVec : A -> forall n : nat, vec A n -> vec A (S n).
Inductive list2 (A : Type) : Type :=
	nil2
  | cons2 (a:A) (xs:list2 A).
Inductive con (A : Type) (n:nat) : Type :=
	conB : con A n
  | conS : A -> con A n -> con A n.
  (* universe constraints in parametricity (original) *)
Inductive noRose : Prop := NoNode (xs:list nat).
Inductive rose : Prop := Node (xs:list rose).
Inductive rose2 : Prop := Node2 (xs:list rose2) | Leaf2.
Inductive roseSA (A:Type) : Prop := LeafSA (a:A).
Inductive roseA (A:Type) : Prop := LeafA (a:A) | NodeA (xs:list (roseA A)).
Inductive dNest (A:Type) : Prop := DN (n:nat) (H:vec (list2 (dNest A)) n).
Inductive dNestL (A:Type) : Prop := DNL (H:list (list (dNestL A))).
Inductive roseCon : Type := NodeCon (xs:con roseCon 0).
Inductive roseRose : Type := NodeRose (xs:roseA (roseRose)).


Require Import Coq.Setoids.Setoid.

Lemma some_ty:
  forall {T} {x x': T},
    Some x = Some x' <->
    x = x'.
Proof.
  intros.
  intuition (inversion H; eauto).
Qed.

Lemma some_prop:
  forall p p': Prop,
    Some p = Some p' <->
    p = p'.
Proof.
  intros.
  eapply some_ty.
Qed.

Lemma iff_distribute:
  forall a b c d : Prop,
    (a <-> c) ->
    (b <-> d) ->
    ((a -> b) <-> (c -> d)).
Proof.
  intros.
  erewrite H.
  erewrite H0.
  eapply iff_refl.
Qed.

Ltac revert_hyp H :=
  refine ((_ : _ -> _) H); clear H.

Ltac revert_hyps :=
  repeat match goal with
  | H: _ |- _ => revert_hyp H
  end.

Ltac revert_all :=
  repeat match goal with
  | H: ?X |- _ =>
    match X with
    | Type => fail 1
    | _ => idtac
    end;
    (revert_hyp H || clear H || revert H)
  end.

Ltac pose_all Pfs :=
  match Pfs with
  | (?Pfs', ?Pf) => pose proof Pf; pose_all Pfs'
  | _ => idtac
  end.

Section SetList.
  Require Import Coq.Lists.List.
  Variable (V: Type).
  Variable (eqb: V -> V -> bool).

  Fixpoint inb (x: V) (xs: list V) : bool :=
    match xs with
    | nil => false
    | x' :: xs' =>
      if eqb x x' then true else inb x xs'
    end.

  Fixpoint uniq (xs: list V) : list V :=
    match xs with
    | nil => nil
    | x :: xs' =>
      let r := uniq xs' in
      if inb x r then r else x :: r
    end.

End SetList.

Section AssocList.

  Require Import Coq.Lists.List.

  Variable (K V: Type).
  Variable (eqb: K -> K -> bool).

  Fixpoint find (k: K) (xs: list (K * V)) : option V :=
    match xs with
    | (k', v) :: xs' =>
      if eqb k k' then Some v else find k xs'
    | nil => None
    end.

  Definition find_all (ks: list K) (xs: list (K * V)) : list (K * V) :=
    List.fold_left (fun acc k =>
      match find k xs with
      | Some v => (k, v) :: acc
      | None => acc
      end
    ) ks xs.

  Fixpoint remove (k: K) (xs: list (K * V)) : list (K * V) :=
    match xs with
    | nil => nil
    | (k', v) :: xs' =>
      if eqb k k' then remove k xs' else (k', v) :: remove k xs'
    end.

  Definition remove_all (ks: list K) (xs: list (K * V)) : list (K * V) :=
    List.fold_left (fun xs k => remove k xs) ks xs.

  Definition assoc (k : K) (v : V) xs := (k, v) :: remove k xs.

  Definition left_union (ls: list (K * V)) (rs: list (K * V)) :=
    List.fold_left (fun xs '(k, v) => assoc k v xs) ls rs.

  Fixpoint update (k: K) (v: V) (xs: list (K * V)) : list (K * V) :=
    match xs with
    | nil => nil
    | (k', v') :: xs' =>
      if eqb k k' then (k, v) :: xs' else (k', v') :: update k v xs'
    end.

  Definition update_all (orig: list (K * V)) (new: list (K * V)) :=
    List.fold_left (fun xs '(k, v) => update k v xs) new orig.

End AssocList.

Fixpoint join {K V V' eqb} (ls: list (K * V)) (rs: list (K * V')) : list (K * (V * V')) :=
  match ls with
  | nil => nil
  | (k, v) :: ls' =>
    match find K V' eqb k rs with
    | Some v' =>
      (k, (v, v')) :: join (eqb := eqb) ls' rs
    | None => join (eqb := eqb) ls' rs
    end
  end.

Fixpoint drop_last {A} (xs: list A) : list A :=
  match xs with
  | nil => nil
  | x :: xs =>
    match xs with
    | nil => nil
    | _ => x :: drop_last xs
    end
  end.

Definition flip {A B} (xs: list (A * B)) : list (B * A) :=
  map (fun '(x, y) => (y, x)) xs.

Fixpoint map_option {A B} (f: A -> option B) (xs: list A) : list B :=
  match xs with
  | nil => nil
  | x :: xs' =>
    match f x with
    | Some y => y :: map_option f xs'
    | None => map_option f xs'
    end
  end.

Fixpoint map_option_all {A B} (f: A -> option B) (xs: list A) : option (list B) :=
  match xs with
  | nil => Some nil
  | x :: xs' =>
    match f x, map_option_all f xs' with
    | Some y, Some ys' => Some (y :: ys')
    | _, _ => None
    end
  end.

Definition o2l {A} (x: option A) :=
  match x with
  | Some x' => x' :: nil
  | None => nil
  end.

From MetaCoq.Template Require Import All.

(* Given a substitution key-value, if the LHS is a Coq variable, increment the DB indexing.
   This is useful when substituting under a product.
*)
Definition inc_subst_var {A} : term * A -> term * A := fun '(k, v) =>
  match k with
  | tRel n => (tRel (S n), v)
  | _ => (k, v)
  end.

Require Import MirrorSolve.Reflection.Core.

(* Given an environment of key-value substitutions, replace all LHS with the corresponding RHS.
   Adjusts variable DB indices in the keys as it goes (i.e. to correctly substitute under binders)
*)
Fixpoint subst_terms (env: list (term * term)) (t: term) :=
  match find _ _ Core.eq_term t env with
  | Some t' => t'
  | None =>
    match t with
    | tApp f args =>
      tApp (subst_terms env f) (map (subst_terms env) args)
    | tProd x ty bod =>
      tProd x (subst_terms env ty) (subst_terms (map inc_subst_var env) bod)
    | _ => t
    end
  end.

Definition map_with_index {A B} (f: nat -> A -> B) (xs: list A) : list B :=
  (fix rec xs acc :=
    match xs with
    | nil => nil
    | x :: xs' => f acc x :: rec xs' (S acc)
    end
  ) xs 0.

From MetaCoq.Template Require Import All Loader.
Import MCMonadNotation.
Open Scope bs.

(* Some monadic operations but for the TemplateMonad
  *)
Polymorphic Fixpoint sequence {A} (acts: list (TemplateMonad A)) : TemplateMonad (list A) :=
  match acts with
  | [] => tmReturn []
  | a :: acts' =>
    x <- a ;;
    r <- sequence acts' ;;
    tmReturn (x :: r)
  end.

Polymorphic Definition mapM {A B} (f: A -> TemplateMonad B) (xs: list A) : TemplateMonad (list B) :=
  sequence (map f xs).

Polymorphic Fixpoint validate_opts {A} (xs: list (option A)) (msg: ident) : TemplateMonad (list A) :=
  match xs with
  | nil => tmReturn nil
  | None :: _ =>
    tmPrint msg ;;
    tmFail "couldn't validate options"
  | Some x :: xs' =>
    r <- validate_opts xs' msg ;;
    tmReturn (x :: r)
  end.

Polymorphic Definition fmap {A B} (f: A -> B) (t: TemplateMonad A) : TemplateMonad B :=
  t >>= (fun x => tmReturn (f x)).

Polymorphic Definition liftM {A B} (f: A -> B) : A -> TemplateMonad B :=
  fun a => tmReturn (f a).

Polymorphic Fixpoint foldlM {A B} (f: A -> B -> TemplateMonad A) (d: A) (xs: list B) : TemplateMonad A :=
  match xs with
  | [] => tmReturn d
  | (x :: xs') =>
    r <- f d x ;;
    foldlM f r xs'
  end.


Require List Eqdep_dec Lia.
Require Import seq syntax.

(* Nothing to do here, move me *)

Lemma nat_uip : forall (m n : nat) (p q : m = n), p = q.
Proof.
intros; apply Eqdep_dec.UIP_dec.
decide equality.
Qed.

Inductive In {A} (x : A) : list A -> Type :=
| In_here : forall l, In x (cons x l)
| In_next : forall y l, In x l -> In x (cons y l).

Lemma In_app_l : forall (A : Type) (l1 l2 : list A) (x : A),
  In x l1 -> In x (app l1 l2).
Proof.
intros A l1 l2 x H; revert l2; induction H; intros l2; simpl; constructor; intuition.
Qed.

Lemma In_app_r : forall (A : Type) (l1 l2 : list A) (x : A),
  In x l2 -> In x (app l1 l2).
Proof.
induction l1; intros l2 x H; cbn in *; [assumption|].
constructor; apply IHl1, H.
Qed.

Lemma In_cons_inv : forall A (x y : A) l,
  In x (y :: l) -> (x = y) + In x l.
Proof.
intros A x y l e.
refine (
match e in In _ l return
  match l with nil => unit | cons z l => (x = z) + In x l end
with
| In_here _ _ => inl eq_refl
| In_next _ _ _ i => inr i
end).
Qed.

Lemma In_map : forall (A B : Type) (f : A -> B) (l : list A) (x : A),
  In x l -> In (f x) (List.map f l).
Proof.
induction 1; constructor; assumption.
Qed.

Lemma In_map_rev : forall (A B : Type) (f : A -> B) (l : list A) (y : B),
  In y (List.map f l) -> {x : A & prod (In x l) (y = f x)}.
Proof.
intros A B f l y H; induction l as [|x l IHl]; cbn in *; inversion H; subst.
+ repeat econstructor.
+ destruct IHl as [x' [? ?]]; [assumption|].
  exists x'; repeat constructor; assumption.
Qed.

Set Primitive Projections.

Section syntax.

Context {Sig : sig}.
Notation form := (@form Sig).

Record Theory := {
  thy_idx : Type;
  thy_axm : forall i : thy_idx, form 0;
}.

Definition lift_form {Σ : nat} (A : form Σ) : form (S Σ) :=
  subst_form (init (fun n => @var_term _ (S _) (Some n))) A.

Inductive proof (T : Theory) (Σ : nat) (Γ : list (form Σ)) : form Σ -> Type :=
| prf_exm :
  forall A, Sig.(sig_classical) = true -> proof T Σ Γ (Dsj A (Arr A Bot))
| prf_thy :
  forall (i : T.(thy_idx)),
  proof T Σ Γ (subst_form null (T.(thy_axm) i))
| prf_axm :
  forall A, In A Γ -> proof T Σ Γ A
| prf_arr_i :
  forall A B, proof T Σ (cons A Γ) B -> proof T Σ Γ (Arr A B)
| prf_arr_e :
  forall A B, proof T Σ Γ (Arr A B) -> proof T Σ Γ A -> proof T Σ Γ B
| prf_top_i : proof T Σ Γ Top
| prf_bot_e : forall A, proof T Σ Γ Bot -> proof T Σ Γ A
| prf_cnj_i : forall A B,
  proof T Σ Γ A -> proof T Σ Γ B -> proof T Σ Γ (Cnj A B)
| prf_cnj_e₁ : forall A B,
  proof T Σ Γ (Cnj A B) -> proof T Σ Γ A
| prf_cnj_e₂ : forall A B,
  proof T Σ Γ (Cnj A B) -> proof T Σ Γ B
| prf_dsj_i₁ : forall A B,
  proof T Σ Γ A -> proof T Σ Γ (Dsj A B)
| prf_dsj_i₂ : forall A B,
  proof T Σ Γ B -> proof T Σ Γ (Dsj A B)
| prf_dsj_e : forall A B C,
  proof T Σ Γ (Dsj A B) -> proof T Σ (cons A Γ) C -> proof T Σ (cons B Γ) C -> proof T Σ Γ C
| prf_frl_i :
  forall (A : form (S Σ)), proof T (S Σ) (List.map lift_form Γ) A -> proof T Σ Γ (All A)
| prf_frl_e :
  forall (A : form (S Σ)) (t : term Σ), proof T Σ Γ (All A) ->
  proof T Σ Γ (subst_form (scons t (init var_term)) A)
| prf_exs_i :
  forall (A : form (S Σ)) (t : term Σ),
  proof T Σ Γ (subst_form (scons t (init var_term)) A) -> proof T Σ Γ (Exs A)
| prf_exs_e :
  forall (A : form (S Σ)) (B : form Σ),
  proof T Σ Γ (Exs A) ->
  proof T (S Σ) (A :: List.map lift_form Γ) (lift_form B) ->
  proof T Σ Γ B
.

(* Derived rules *)

Lemma prf_wkn : forall T Σ Γ Δ A, (forall X, In X Γ -> In X Δ) -> proof T Σ Γ A -> proof T Σ Δ A.
Proof.
intros T Σ Γ Δ A Hi H; revert Δ Hi; induction H; intros Δ Hi; try (solve [econstructor; eauto]).
+ apply prf_arr_i, IHproof.
  { intros X HX; inversion HX; subst; constructor; now intuition. }
+ eapply prf_dsj_e; [apply IHproof1, Hi|apply IHproof2|apply IHproof3].
  all: intros X HX; inversion HX; subst; constructor; now intuition.
+ apply prf_frl_i, IHproof.
  { intros X HX. apply In_map_rev in HX; destruct HX as [Y [HY ->]].
    apply In_map, Hi, HY. }
+ eapply prf_exs_e; [apply IHproof1, Hi|apply IHproof2].
  { intros X HX.
    apply In_cons_inv in HX; destruct HX as [[]|HX]; [constructor|].
    apply In_map_rev in HX; destruct HX as [Y [HY ->]].
    constructor; apply In_map, Hi, HY. }
Qed.

Lemma prf_subst : forall T Σ Σ' Γ A (ρ : seq (term Σ') Σ),
  proof T Σ Γ A -> proof T Σ' (List.map (subst_form ρ) Γ) (subst_form ρ A).
Proof.
intros T Σ Σ' Γ A ρ p; revert Σ' ρ; induction p; intros Σ' ρ; try (solve [econstructor; eauto]).
+ rewrite compComp_form.
  apply prf_thy.
+ apply prf_axm, In_map; assumption.
+ cbn; apply prf_frl_i.
  specialize (IHp (S Σ') (up_term_term ρ)).
  match goal with [ _ : proof _ _ ?Γ _ |- proof _ _ ?Δ _ ] => replace Δ with Γ; [assumption|] end.
  rewrite !List.map_map; apply List.map_ext; clear; intros A.
  unfold lift_form; rewrite !compComp_form.
  f_equal; apply nth_ext; intros n.
  rewrite !nth_map, !nth_init; cbn.
  rewrite !nth_map; reflexivity.
+ cbn in *.
  rewrite compComp_form; simpl.
  specialize (IHp Σ' ρ).
  eapply prf_frl_e with (t := subst_term ρ t) in IHp.
  match goal with [ _ : proof _ _ _ ?A |- proof _ _ _ ?B ] => replace B with A; [assumption|] end.
  rewrite compComp_form; f_equal; simpl; f_equal.
  apply nth_ext; clear; intros n; rewrite !nth_map, !compComp_term, !nth_init; simpl.
  apply idSubst_term; clear; intros m; rewrite !nth_map, !nth_init; simpl; rewrite nth_init; reflexivity.
+ cbn in *; eapply prf_exs_i with (t := subst_term ρ t).
  specialize (IHp Σ' ρ).
  match goal with [ _ : proof _ _ _ ?A |- proof _ _ _ ?B ] => replace B with A; [assumption|] end.
  rewrite !compComp_form; f_equal; apply nth_ext; clear; intros [n|]; [|reflexivity].
  simpl; rewrite !nth_map, !compComp_term, !map_init; simpl.
  rewrite idSubst_term.
  2:{ clear; intros n; rewrite !nth_init; reflexivity. }
  rewrite nth_init; reflexivity.
+ cbn in *. specialize (IHp1 Σ' ρ).
  eapply prf_exs_e in IHp1; [now apply IHp1|].
  specialize (IHp2 (S Σ') (up_term_term ρ)).
  assert (e : forall A, subst_form (up_term_term ρ) (lift_form A) = lift_form (subst_form ρ A)).
  { clear; intros A; unfold up_term_term, lift_form.
    rewrite !compComp_form; f_equal; apply nth_ext; intros n.
    rewrite !nth_map, !nth_init; simpl; rewrite !nth_map; reflexivity. }
  match goal with [ _ : proof _ _ ?Γ ?A |- proof _ _ ?Δ ?B ] =>
    replace Δ with Γ; [replace B with A|]; [assumption| |]
  end.
  - rewrite e; reflexivity.
  - f_equal; rewrite !List.map_map; apply List.map_ext; intros ?; apply e.
Qed.

End syntax.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph Require Import eager_coin_spec.
From iris.prelude Require Import options.

(* Simple implementation of the eager specification. *)

Definition new_eager_coin : val :=
  λ: <>, ref (nondet_bool #()).

Definition read_eager_coin : val :=
  λ: "c", !"c".

Section proof.
  Context `{!heapGS Σ}.

  Definition eager_coin (c : val) (b : bool) : iProp Σ :=
    (∃ (l : loc), ⌜c = #l⌝ ∗ l ↦ #b).

  Lemma eager_coin_exclusive (c : val) (b1 b2 : bool) :
    eager_coin c b1 -∗ eager_coin c b2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (l1) "[% Hl1]".
    iDestruct "H2" as (l2) "[% Hl2]".
    simplify_eq.
    by iDestruct (mapsto_valid_2 with "Hl1 Hl2") as %[??].
  Qed.

  Lemma new_eager_coin_spec :
    {{{ True }}}
      new_eager_coin #()
    {{{ c b, RET c; eager_coin c b }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_lam. wp_apply nondet_bool_spec; first done.
    iIntros (r) "_". wp_alloc l as "Hl". iApply "HΦ". iExists l. by iFrame.
  Qed.

  Lemma read_eager_coin_spec c b :
    {{{ eager_coin c b }}}
      read_eager_coin c
    {{{ RET #b; eager_coin c b }}}.
  Proof.
    iIntros (Φ) "Hc HΦ". iDestruct "Hc" as (l) "[-> Hl]".
    wp_lam. wp_load. iApply "HΦ". iExists l. by iFrame.
  Qed.
End proof.

Definition eager_coin_spec_instance `{!heapGS Σ} :
  eager_coin_spec.eager_coin_spec Σ :=
  {| eager_coin_spec.new_coin_spec := new_eager_coin_spec;
     eager_coin_spec.read_coin_spec := read_eager_coin_spec;
     eager_coin_spec.coin_exclusive := eager_coin_exclusive |}.

Typeclasses Opaque eager_coin.