From CoqMTL Require Import Control.All.
From CoqMTL Require Import Control.Monad.Class.All.

From CoqMTL Require Import Misc.Monoid.

(** [RWS W R S] is a monad which models a computation that can access
    a read-only environment, a write-only log and a single cell of
    read-write memory.

    Note that, somewhat contrary to the name, the order of arguments
    is first the log type [W], then the environment type [R] and finally
    the state type [S]. *)
Definition RWS (W : Monoid) (R S A : Type) : Type :=
  R -> S -> A * S * W.

(** We can map over such a computation by running it and applying a function
    to the result while passing along the state and log it produced. *)
Definition fmap_RWS
  {W : Monoid} {R S A B : Type}
  (f : A -> B) (m : RWS W R S A) : RWS W R S B :=
    fun r s =>
      let
        '(a, s', w) := m r s
      in
        (f a, s', w).

#[global] Hint Unfold fmap_RWS : CoqMTL.

#[refine]
#[export]
Instance Functor_RWS (W : Monoid) (R S : Type) : Functor (RWS W R S) :=
{
  fmap := @fmap_RWS W R S;
}.
Proof. all: unfold compose; monad. Defined.

(** We can inject a value into this monad without touching the state or
    writing to the log. *)
Definition pure_RWS {W : Monoid} {R S A : Type} (x : A) : RWS W R S A :=
  fun _ s => (x, s, neutr).

(** We can apply a computation to another computation by running them in
    order, applying the result function to the argument, passing along
    the state of the argument and concatenating the logs. *)
Definition ap_RWS
  {W : Monoid} {R S A B : Type}
  (mf : RWS W R S (A -> B)) (mx : RWS W R S A) : RWS W R S B :=
    fun r s =>
      let '(f, sf, wf) := mf r s in
      let '(x, sx, wx) := mx r sf in (f x, sx, op wf wx).

#[global] Hint Unfold pure_RWS ap_RWS : CoqMTL.

#[refine]
#[export]
Instance Applicative_RWS
  (W : Monoid) (R S : Type) : Applicative (RWS W R S) :=
{
  is_functor := Functor_RWS W R S;
  pure := @pure_RWS W R S;
  ap := @ap_RWS W R S;
}.
Proof. all: monad. Defined.

(** [Reader] and [Writer] have a commutative [ap], but [State] does not,
    so neither does [RWS]. *)
Lemma RWS_not_CommutativeApplicative :
  ~ (forall (W : Monoid) (R S : Type),
      CommutativeApplicative _ (Applicative_RWS W R S)).
Proof.
  intro. destruct (H (Monoid_list_app bool) unit unit).
  unfold RWS in ap_comm.
  specialize (ap_comm nat nat nat (fun _ => id)
    (fun _ _ => (42, tt, [true; false]))
    (fun _ _ => (43, tt, [false; true]))).
  compute in ap_comm. do 2 apply (f_equal (fun f => f tt)) in ap_comm.
  inv ap_comm.
Qed.

(** None of its components is [Alternative], so [RWS] is neither. *)
Lemma RWS_not_Alternative :
  forall (W : Monoid) (R S : Type),
    R -> S -> Alternative (RWS W R S) -> False.
Proof.
  destruct 3. destruct (aempty False) as [[f _] _]; assumption.
Qed.

(** We can sequence two computations by running them in order,
    applying the function to the argument, passing along the
    state of the argument and concatenating the logs. *)
Definition bind_RWS
  {W : Monoid} {R S A B : Type}
  (mx : RWS W R S A) (mf : A -> RWS W R S B) : RWS W R S B :=
    fun r s =>
      let '(x, sx, wx) := mx r s in
      let '(b, sb, wb) := mf x r sx in (b, sb, op wx wb).

#[global] Hint Unfold bind_RWS : CoqMTL.

#[refine]
#[export]
Instance Monad_RWS
  (W : Monoid) (R S : Type) : Monad (RWS W R S) :=
{
  is_applicative := Applicative_RWS W R S;
  bind := @bind_RWS W R S;
}.
Proof. all: monad. Defined.

(** [RWS W R S] has instances corresponding to all three of its effects. *)

#[refine]
#[export]
Instance MonadReader_RWS
  (W : Monoid) (R S : Type)
  : MonadReader R (RWS W R S) (Monad_RWS W R S) :=
{
  ask := fun r s => (r, s, neutr);
}.
Proof. hs. Defined.

#[refine]
#[export]
Instance MonadWriter_RWS
  (W : Monoid) (R S : Type) : MonadWriter W (RWS W R S) (Monad_RWS W R S) :=
{
  tell := fun w => fun r s => (tt, s, w);
  listen :=
    fun A m => fun r s =>
      let '(a, s, w) := m r s in (a, w, s, neutr);
}.
Proof. all: hs; monad. Defined.

#[refine]
#[export]
Instance MonadState_RWS
  (W : Monoid) (R S : Type) : MonadState S (RWS W R S) (Monad_RWS W R S) :=
{
  get := fun _ (s : S) => (s, s, neutr);
  put := fun s : S => fun _ _ => (tt, s, neutr);
}.
Proof. all: monad. Defined.


(* TODO: try to prove LEM for Set.
*)

(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
   in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show
   that the axiom of choice in equivalence classes entails
   Excluded-Middle in Type Theory [[LacasWerner99]].

   Three variants of Diaconescu's result in type theory are shown below.

   A. A proof that the relational form of the Axiom of Choice +
      Extensionality for Predicates entails Excluded-Middle (by Hugo
      Herbelin)

   B. A proof that the relational form of the Axiom of Choice + Proof
      Irrelevance entails Excluded-Middle for Equality Statements (by
      Benjamin Werner)

   C. A proof that extensional Hilbert epsilon's description operator
      entails excluded-middle (taken from Bell [[Bell93]])

   See also [[Carlström04]] for a discussion of the connection between the
   Extensional Axiom of Choice and Excluded-Middle

   [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation,
   in Proceedings of AMS, vol 51, pp 176-178, 1975.

   [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply
   the excluded middle?, preprint, 1999.

   [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical
   logic, Journal of Philosophical Logic, 22: 1-18, 1993

   [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent
   to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
*)
Require ClassicalFacts ChoiceFacts.

(**********************************************************************)
(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)

Section PredExt_RelChoice_imp_EM.

(** The axiom of extensionality for predicates *)

Definition PredicateExtensionality :=
  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

(** From predicate extensionality we get propositional extensionality
   hence proof-irrelevance *)

Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof.
  intros A B H.
  change ((fun _ => A) true = (fun _ => B) true).
  rewrite
   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
    reflexivity.
    intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof.
  apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

(** From proof-irrelevance and relational choice, we get guarded
   relational choice *)

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof.
 apply
  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

(** The form of choice we need: there is a functional relation which chooses
    an element in any non empty subset of bool *)

Import Bool.

Lemma AC_bool_subset_to_bool :
  exists R : (bool -> Prop) -> bool -> Prop,
   (forall P:bool -> Prop,
      (exists b : bool, P b) ->
       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof.
  destruct (guarded_rel_choice _ _
   (fun Q:bool -> Prop =>  exists y : _, Q y)
   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
    exact (fun _ H => H).
  exists R; intros P HP.
  destruct (HR P HP) as (y,(Hy,Huni)).
  exists y; firstorder.
Qed.

(** The proof of the excluded middle *)
(** Remark: P could have been in Set or Type *)

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Set, P + (P->False).
Proof.
intro P.

(* first we exhibit the choice functional relation R *)
destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

(* the actual "decision": is (R class_of_true) = true or false? *)
destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

(* the actual "decision": is (R class_of_false) = true or false? *)
destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false; right; assumption.
unfold class_of_true; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

(* cases where P is true *)
left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

(**********************************************************************)
(** * Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)

(** This is an adaptation of Diaconescu's theorem, exploiting the
    form of extensionality provided by proof-irrelevance *)

Section ProofIrrel_RelChoice_imp_EqEM.

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

(** Let [a1] and [a2] be two elements in some type [A] *)

Variable A :Type.
Variables a1 a2 : A.

(** We build the subset [A'] of [A] made of [a1] and [a2] *)

Definition A' := @sigT A (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

(** By proof-irrelevance, projection is a retraction *)

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof.
  intro Heq ; unfold a1', a2', A'.
  rewrite Heq.
  replace (or_introl (a2=a2) (eq_refl a2))
     with (or_intror (a2=a2) (eq_refl a2)).
  reflexivity.
  apply proof_irrelevance.
Qed.

(** But from the actual proofs of being in [A'], we can assert in the
    proof-irrelevant world the existence of relevant boolean witnesses *)

Lemma decide : forall x:A', exists y:bool ,
  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof.
  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

(** Thanks to the axiom of choice, the boolean witnesses move from the
    propositional world to the relevant world *)

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof.
  destruct
    (rel_choice A' bool
       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
    as (R,(HRsub,HR)).
    apply decide.
  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2.
    rewrite (projT1_injective H) in Ha1'b1.
    assert (false = true) by auto using Huni2.
    discriminate.
  left; assumption.
Qed.

(** An alternative more concise proof can be done by directly using
    the guarded relational choice *)

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof.
  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
  assert (guarded_rel_choice :=
          rel_choice_and_proof_irrel_imp_guarded_rel_choice
	  rel_choice
	  proof_irrelevance).
  destruct
    (guarded_rel_choice A bool
      (fun x => x=a1 \/ x=a2)
      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
      as (R,(HRsub,HR)).
      apply decide.
  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2; subst a1.
    assert (false = true) by auto using Huni2, Ha1b1.
    discriminate.
  left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

(**********************************************************************)
(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)

(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *)

Local Notation inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
  forall (A:Type) (i:inhabited A) (P:A->Prop),
  (exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Local Notation eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
  intro P.
  pose (B := fun y => y=false \/ P).
  pose (C := fun y => y=true  \/ P).
  assert (B (eps B)) as [Hfalse|HP]
    by (apply epsilon_spec; exists false; left; reflexivity).
  assert (C (eps C)) as [Htrue|HP]
    by (apply epsilon_spec; exists true; left; reflexivity).
    right; intro HP.
    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
    rewrite epsilon_extensionality with (1:=H) in Hfalse.
    rewrite Htrue in Hfalse.
    discriminate.
  auto.
  auto.
Qed.

End ExtensionalEpsilon_imp_EM.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Diagonal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Corollary Diagonal_Unique `(C : Category) {D : Category} (d : D) :
  Diagonal C d ≈[Cat] Const d ∘[Cat] one.
Proof. exists (fun _ => iso_id); simpl; intros; cat. Qed.


Require Import Streams Ascii String.
Require Import Show Functor Monad Llist.

Variable IO : Type -> Type.
Variable io_return : forall {A : Type}, A -> IO A.
Variable io_bind : forall {A : Type}, IO A ->
  forall {B:Type}, (A -> IO B) -> IO B.

Axiom io_1 : forall A (a : IO A), a = io_bind a (@io_return A).
Axiom io_2 : forall A (a : A) B (f : A -> IO B),
      f a = io_bind (io_return a) f.
Axiom io_3 : forall A (ma : IO A) B f C (g : B -> IO C),
      io_bind ma (fun x => io_bind (f x) g) = io_bind (io_bind ma f) g.
Axiom io_aux : forall A B (f g : A -> IO B) m,
  (forall x, f x = g x) -> io_bind m f = io_bind m g.

Instance IOMonad : Monad IO := {
  return_ := @io_return
  ; bind := @io_bind
  ; right_unit := io_1
  ; left_unit := io_2
  ; associativity := io_3
}.

Instance FunctorIO : Functor IO := {
  fmap A B f m := m >>= (fun x => return_ (f x))
}.
Proof.
 intros A B C f g x.
 unfold Basics.compose. simpl.
 rewrite <- io_3.
 apply io_aux. intro a. rewrite <- io_2. reflexivity.
Defined.

Variable ocaml_string : Set.
Variable implode : string -> ocaml_string.
Variable explode : ocaml_string -> string.
Variable get_lines_aux : IO (llist ocaml_string).
Variable print_aux : ocaml_string -> IO unit.
Variable println_aux : ocaml_string -> IO unit.

Definition print {A : Set} {s : Show A} (x : A) : IO unit :=
  print_aux (implode (show x)).
Definition println {A : Set} {s : Show A} (x : A) : IO unit :=
  println_aux (implode (show x)).
Definition get_lines : IO (llist string) :=
  fmap (Llist.map explode) get_lines_aux.


Require Import VerdiRaft.Raft.

Section TraceUtil.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition has_key (c : clientId) (i : nat) (e : entry) :=
    match e with
      | mkEntry _ c' i' _ _ _ => andb (if clientId_eq_dec c c' then true else false) (Nat.eqb i i')
    end.

  Definition key_in_output_list (client : clientId) (id : nat) (os : list raft_output) :=
    exists o,
      In (ClientResponse client id o) os.

  Definition is_client_response_with_key (client : clientId) (id : nat) (out : raft_output) : bool :=
    match out with
      | ClientResponse c i _ => andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i)
      | NotLeader _ _ => false
    end.

  Definition key_in_output_list_dec (client : clientId) (id : nat) (os : list raft_output) :
    {key_in_output_list client id os} + {~ key_in_output_list client id os}.
  Proof using.
    unfold key_in_output_list.
    destruct (find (is_client_response_with_key client id) os) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      unfold is_client_response_with_key in *. break_match; try discriminate.
      subst. do_bool. break_and. break_if; try discriminate. do_bool. subst. left. eauto.
    - right. intro. break_exists.
      eapply find_none in H; eauto. unfold is_client_response_with_key in *.
      find_apply_lem_hyp Bool.andb_false_elim.
      intuition; try break_if; do_bool; congruence.
  Qed.

  Definition key_in_output_trace (client : clientId) (id : nat)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
    exists os h,
      In (h, inr os) tr /\
      key_in_output_list client id os.

  Definition key_in_output_trace_dec (client : clientId) (id : nat) :
    forall tr : list (name * (raft_input + list raft_output)),
      {key_in_output_trace client id tr} + {~ key_in_output_trace client id tr}.
  Proof using.
    unfold key_in_output_trace.
    intros.
    destruct (find (fun p => match snd p with
                               | inr l => match find (is_client_response_with_key client id) l with
                                            | Some x => true
                                            | None => false
                                          end
                               | _ => false
                             end) tr) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      repeat break_match; try discriminate.
      find_apply_lem_hyp find_some. break_and.
      unfold is_client_response_with_key, key_in_output_list in *.
      break_match; try discriminate. do_bool. break_and. do_bool. break_if; try discriminate. subst.
      left. exists l, (fst p).
      find_reverse_rewrite. rewrite <- surjective_pairing.
      intuition eauto.
    - right. intro. break_exists. break_and.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. break_match; try discriminate.
      unfold key_in_output_list in *. break_exists.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. find_apply_lem_hyp Bool.andb_false_elim.
      intuition; try break_if; (do_bool; congruence).
  Qed.

  Definition in_output_list (client : clientId) (id : nat) (o : output) (os : list raft_output) :=
    In (ClientResponse client id o) os.

  Definition is_client_response (client : clientId) (id : nat) (o : output) (out : raft_output) : bool :=
    match out with
      | ClientResponse c i o' => andb (andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i))
                                     (if output_eq_dec o o' then true else false)
      | NotLeader _ _ => false
    end.

  Definition in_output_list_dec (client : clientId) (id : nat) (o : output) (os : list raft_output) :
    {in_output_list client id o os} + {~ in_output_list client id o os}.
  Proof using raft_params.
    unfold in_output_list.
    destruct (find (is_client_response client id o) os) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      unfold is_client_response in *. break_match; try discriminate.
      subst. do_bool. break_and. break_if; try congruence.
      break_if; try discriminate.
      repeat (do_bool; intuition). subst. intuition.
    - right. intro. break_exists.
      eapply find_none in H; eauto. unfold is_client_response in *.
      find_apply_lem_hyp Bool.andb_false_elim.
      repeat (do_bool; intuition); try break_if; try congruence.
  Qed.

  Definition in_output_trace (client : clientId) (id : nat) (o : output)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
    exists os h,
      In (h, inr os) tr /\
      in_output_list client id o os.

  Definition in_input_trace (client : clientId) (id : nat) (i : input)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
      exists h,
        In (h, inl (ClientRequest client id i)) tr.

  Definition is_output_with_key (client : clientId) (id : nat)
             (trace_entry : (name * (raft_input + list raft_output))) :=
    match trace_entry with
      | (_, inr os) => if key_in_output_list_dec client id os then true else false
      | _ => false
    end.

  Definition is_input_with_key (client : clientId) (id: nat)
             (trace_entry : (name * (raft_input + list raft_output))) :=
    match trace_entry with
      | (_, inl (ClientRequest c i _)) => andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i)
      | _ => false
    end.
End TraceUtil.


Require Import
        Fiat.Common.ilist
        Fiat.Common.SumType
        Fiat.Common.IterateBoundedIndex
        Fiat.Narcissus.Common.Specs.

Require Import
        Coq.Sets.Ensembles
        Bedrock.Word.

Section SumType.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnitOpt monoid bool}.

  Definition format_SumType {m}
             (types : Vector.t Type m)
             (formatrs : ilist (B := fun T => T -> CacheFormat -> Comp (B * CacheFormat)) types)
             (st : SumType types)
    : CacheFormat -> Comp (B * CacheFormat) :=
    ith formatrs (SumType_index types st) (SumType_proj types st).

  Definition encode_SumType {m}
             (types : Vector.t Type m)
             (formatrs : ilist (B := fun T => T -> CacheFormat -> (B * CacheFormat)) types)
             (st : SumType types)
    : CacheFormat -> (B * CacheFormat) :=
    ith formatrs (SumType_index types st) (SumType_proj types st).

  Lemma refine_format_SumType {m}
        (types : Vector.t Type m)
        (formats : ilist (B := fun T => T -> CacheFormat -> Comp (B * CacheFormat)) types)
        (encoders : ilist (B := fun T => T -> CacheFormat -> (B * CacheFormat)) types)
        (st : SumType types)
        (ce : CacheFormat)
    :
      Iterate_Ensemble_BoundedIndex'
        (fun idx => forall a ce,
             refine (ith formats idx a ce)
                    (ret (ith encoders idx a ce)))
      -> refine (format_SumType types formats st ce) (ret (encode_SumType types encoders st ce)).
  Proof.
    intros.
    unfold format_SumType, encode_SumType; simpl.
    remember (SumType_proj types st); clear Heqn.
    revert n ce; pattern (SumType_index types st).
    eapply Iterate_Ensemble_equiv'.
    apply H.
  Qed.

  Definition decode_SumType {m}
             (types : Vector.t Type m)
             (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
             (idx : Fin.t m)
             (b : B)
             (cd : CacheDecode)
    : Hopefully (SumType types * B * CacheDecode) :=
    `(a, b', cd') <- ith decoders idx b cd;
      Ok (inj_SumType types idx a, b', cd').

  Lemma tri_proj_eq {A C D} : forall a c d (acd : A * C * D),
      a = fst (fst acd)
      -> c = snd (fst acd)
      -> d = snd acd
      -> acd = ((a, c), d).
  Proof.
    intros; subst; intuition.
  Qed.

  Theorem SumType_decode_correct' {m}
          {P}
          (types : Vector.t Type m)
          (formatrs : ilist (B := fun T => T -> CacheFormat ->
                                           Comp (B * CacheFormat)) types)
          (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
          (invariants : forall idx, Vector.nth types idx -> Prop)
          (cache_invariants : forall idx, (CacheDecode -> Prop) -> Prop)
          (formatrs_decoders_correct : forall idx,
              cache_inv_Property P (cache_invariants idx)
              -> CorrectDecoder
                monoid
                (fun st => invariants idx st)
                (fun st => invariants idx st)
                eq
                (ith formatrs idx)
                (ith decoders idx)
                P (ith formatrs idx))
          idx
    :
      cache_inv_Property P (fun P => forall idx, cache_invariants idx P)
      -> CorrectDecoder monoid (fun st => SumType_index types st = idx /\ invariants _ (SumType_proj types st))
                        (fun st => SumType_index types st = idx /\ invariants _ (SumType_proj types st))
                        eq
                        (format_SumType types formatrs)
                        (decode_SumType types decoders idx)
                        P
                        (format_SumType types formatrs).
  Proof.
    split;
      revert types formatrs decoders invariants formatrs_decoders_correct;
      unfold CorrectDecoder, format_SumType, decode_SumType.
    { intros; intuition.
      unfold id in *;
      eapply (proj1 (formatrs_decoders_correct _ (H _))) in H2; eauto;
        destruct_ex; intuition.
      subst; setoid_rewrite H2; simpl.
      eexists _, _; intuition eauto.
      repeat f_equal.
      unfold id; rewrite inj_SumType_proj_inverse; reflexivity.
      unfold id; rewrite inj_SumType_proj_inverse; eauto.
    }
    { intros.
      destruct (ith decoders idx t env') as [ [ [? ?] ? ] | ] eqn : ? ;
        simpl in *; try discriminate; injections.
      eapply (proj2 (formatrs_decoders_correct idx (H _))) in Heqh;
        eauto; destruct Heqh as [? [? ?] ]; destruct_ex; intuition; subst.
      eexists _, _; intuition eauto; unfold id in *; eauto;
        try rewrite index_SumType_inj_inverse; eauto.
      - unfold id; pattern (SumType_index types (inj_SumType types idx n)),
        (SumType_proj types (inj_SumType types idx n)).
        eapply SumType_proj_inj; eauto.
      - unfold id;
          pattern (SumType_index types (inj_SumType types idx n)),
          (SumType_proj types (inj_SumType types idx n)).
        eapply SumType_proj_inj; eauto.
    }
  Qed.

  Theorem SumType_decode_correct {m}
          {P}
          (types : Vector.t Type m)
          (formatrs : ilist (B := fun T => T -> CacheFormat ->
                                           Comp (B * CacheFormat)) types)
          (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
          (invariants : ilist (B := fun T => Ensemble T) types)
          (cache_invariants : Vector.t (Ensemble (CacheDecode -> Prop)) m)
          (formatrs_decoders_correct :
             Iterate_Ensemble_BoundedIndex (fun idx =>
              cache_inv_Property P (Vector.nth cache_invariants idx)
              -> CorrectDecoder
                monoid
                (ith invariants idx)
                (ith invariants idx)
                eq
                (ith formatrs idx)
                (ith decoders idx)
                P
                (ith formatrs idx)))
          idx
    :
      cache_inv_Property P (fun P => Iterate_Ensemble_BoundedIndex (fun idx => Vector.nth cache_invariants idx P))
      -> CorrectDecoder monoid
                        (fun st => SumType_index types st = idx /\ (ith invariants) _ (SumType_proj types st))
                        (fun st => SumType_index types st = idx /\ (ith invariants) _ (SumType_proj types st))
                        eq
                          (format_SumType types formatrs)
                          (decode_SumType types decoders idx)
                          P
                          (format_SumType types formatrs).
  Proof.
    intros; eapply SumType_decode_correct'; eauto.
    intros.
    eapply Iterate_Ensemble_BoundedIndex_equiv in formatrs_decoders_correct; eauto.
    unfold cache_inv_Property in *; intros;
      eapply Iterate_Ensemble_BoundedIndex_equiv in H; eauto.
  Qed.

End SumType.

Arguments SumType : simpl never.