Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
Set Implicit Arguments.

Section PACO1.

Variable T0 : Type.

(** ** Signatures *)

Record sig1T  :=
  exist1T {
      proj1T0: @T0;
    }.
Definition uncurry1  (R: rel1 T0): rel1 sig1T :=
  fun x => R (proj1T0 x).
Definition curry1  (R: rel1 sig1T): rel1 T0 :=
  fun x0 => R (@exist1T x0).

Lemma uncurry_map1 r0 r1 (LE : r0 <1== r1) : uncurry1 r0 <1== uncurry1 r1.
Proof. intros [] H. apply LE. apply H. Qed.

Lemma uncurry_map_rev1 r0 r1 (LE: uncurry1 r0 <1== uncurry1 r1) : r0 <1== r1.
Proof.
  red; intros. apply (LE (@exist1T x0) PR).
Qed.

Lemma curry_map1 r0 r1 (LE: r0 <1== r1) : curry1 r0 <1== curry1 r1.
Proof.
  red; intros. apply (LE (@exist1T x0) PR).
Qed.

Lemma curry_map_rev1 r0 r1 (LE: curry1 r0 <1== curry1 r1) : r0 <1== r1.
Proof.
  intros [] H. apply LE. apply H.
Qed.

Lemma uncurry_bij1_1 r : curry1 (uncurry1 r) <1== r.
Proof. unfold le1. intros. apply PR. Qed.

Lemma uncurry_bij2_1 r : r <1== curry1 (uncurry1 r).
Proof. unfold le1. intros. apply PR. Qed.

Lemma curry_bij1_1 r : uncurry1 (curry1 r) <1== r.
Proof. intros [] H. apply H. Qed.

Lemma curry_bij2_1 r : r <1== uncurry1 (curry1 r).
Proof. intros [] H. apply H. Qed.

Lemma uncurry_adjoint1_1 r0 r1 (LE: uncurry1 r0 <1== r1) : r0 <1== curry1 r1.
Proof.
  apply uncurry_map_rev1. eapply le1_trans; [apply LE|]. apply curry_bij2_1.
Qed.

Lemma uncurry_adjoint2_1 r0 r1 (LE: r0 <1== curry1 r1) : uncurry1 r0 <1== r1.
Proof.
  apply curry_map_rev1. eapply le1_trans; [|apply LE]. apply uncurry_bij2_1.
Qed.

Lemma curry_adjoint1_1 r0 r1 (LE: curry1 r0 <1== r1) : r0 <1== uncurry1 r1.
Proof.
  apply curry_map_rev1. eapply le1_trans; [apply LE|]. apply uncurry_bij2_1.
Qed.

Lemma curry_adjoint2_1 r0 r1 (LE: r0 <1== uncurry1 r1) : curry1 r0 <1== r1.
Proof.
  apply uncurry_map_rev1. eapply le1_trans; [|apply LE]. apply curry_bij1_1.
Qed.

(** ** Predicates of Arity 1
*)

Definition paco1(gf : rel1 T0 -> rel1 T0)(r: rel1 T0) : rel1 T0 :=
  curry1 (paco (fun R0 => uncurry1 (gf (curry1 R0))) (uncurry1 r)).

Definition upaco1(gf : rel1 T0 -> rel1 T0)(r: rel1 T0) := paco1 gf r \1/ r.
Arguments paco1 : clear implicits.
Arguments upaco1 : clear implicits.
Hint Unfold upaco1.

Definition monotone1 (gf: rel1 T0 -> rel1 T0) :=
  forall x0 r r' (IN: gf r x0) (LE: r <1= r'), gf r' x0.

Definition _monotone1 (gf: rel1 T0 -> rel1 T0) :=
  forall r r'(LE: r <1= r'), gf r <1== gf r'.

Lemma monotone1_eq (gf: rel1 T0 -> rel1 T0) :
  monotone1 gf <-> _monotone1 gf.
Proof. unfold monotone1, _monotone1, le1. split; intros; eapply H; eassumption. Qed.

Lemma monotone1_map (gf: rel1 T0 -> rel1 T0)
      (MON: _monotone1 gf) :
  _monotone (fun R0 => uncurry1 (gf (curry1 R0))).
Proof.
  red; intros. apply uncurry_map1. apply MON; apply curry_map1; assumption.
Qed.

Lemma monotone1_compose (gf gf': rel1 T0 -> rel1 T0)
      (MON1: monotone1 gf)
      (MON2: monotone1 gf'):
  monotone1 (compose gf gf').
Proof.
  red; intros. eapply MON1. apply IN.
  intros. eapply MON2. apply PR. apply LE.
Qed.

Lemma monotone1_union (gf gf': rel1 T0 -> rel1 T0)
      (MON1: monotone1 gf)
      (MON2: monotone1 gf'):
  monotone1 (gf \2/ gf').
Proof.
  red; intros. destruct IN.
  - left. eapply MON1. apply H. apply LE.
  - right. eapply MON2. apply H. apply LE.
Qed.

Lemma _paco1_mon_gen (gf gf': rel1 T0 -> rel1 T0) r r'
    (LEgf: gf <2= gf')
    (LEr: r <1= r'):
  paco1 gf r <1== paco1 gf' r'.
Proof.
  apply curry_map1. red; intros. eapply paco_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma paco1_mon_gen (gf gf': rel1 T0 -> rel1 T0) r r' x0
    (REL: paco1 gf r x0)
    (LEgf: gf <2= gf')
    (LEr: r <1= r'):
  paco1 gf' r' x0.
Proof.
  eapply _paco1_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma paco1_mon_bot (gf gf': rel1 T0 -> rel1 T0) r' x0
    (REL: paco1 gf bot1 x0)
    (LEgf: gf <2= gf'):
  paco1 gf' r' x0.
Proof.
  eapply paco1_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upaco1_mon_gen (gf gf': rel1 T0 -> rel1 T0) r r' x0
    (REL: upaco1 gf r x0)
    (LEgf: gf <2= gf')
    (LEr: r <1= r'):
  upaco1 gf' r' x0.
Proof.
  destruct REL.
  - left. eapply paco1_mon_gen; [apply H | apply LEgf | apply LEr].
  - right. apply LEr, H.
Qed.

Lemma upaco1_mon_bot (gf gf': rel1 T0 -> rel1 T0) r' x0
    (REL: upaco1 gf bot1 x0)
    (LEgf: gf <2= gf'):
  upaco1 gf' r' x0.
Proof.
  eapply upaco1_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Section Arg1.

Variable gf : rel1 T0 -> rel1 T0.
Arguments gf : clear implicits.

Theorem _paco1_mon: _monotone1 (paco1 gf).
Proof.
  red; intros. eapply curry_map1, _paco_mon; apply uncurry_map1; assumption.
Qed.

Theorem _paco1_acc: forall
  l r (OBG: forall rr (INC: r <1== rr) (CIH: l <1== rr), l <1== paco1 gf rr),
  l <1== paco1 gf r.
Proof.
  intros. apply uncurry_adjoint1_1.
  eapply _paco_acc. intros.
  apply uncurry_adjoint1_1 in INC. apply uncurry_adjoint1_1 in CIH.
  apply uncurry_adjoint2_1.
  eapply le1_trans. eapply (OBG _ INC CIH).
  apply curry_map1.
  apply _paco_mon; try apply le1_refl; apply curry_bij1_1.
Qed.

Theorem _paco1_mult_strong: forall r,
  paco1 gf (upaco1 gf r) <1== paco1 gf r.
Proof.
  intros. apply curry_map1.
  eapply le1_trans; [| eapply _paco_mult_strong].
  apply _paco_mon; intros [] H; apply H.
Qed.

Theorem _paco1_fold: forall r,
  gf (upaco1 gf r) <1== paco1 gf r.
Proof.
  intros. apply uncurry_adjoint1_1.
  eapply le1_trans; [| apply _paco_fold]. apply le1_refl.
Qed.

Theorem _paco1_unfold: forall (MON: _monotone1 gf) r,
  paco1 gf r <1== gf (upaco1 gf r).
Proof.
  intros. apply curry_adjoint2_1.
  eapply _paco_unfold; apply monotone1_map; assumption.
Qed.

Theorem paco1_acc: forall
  l r (OBG: forall rr (INC: r <1= rr) (CIH: l <1= rr), l <1= paco1 gf rr),
  l <1= paco1 gf r.
Proof.
  apply _paco1_acc.
Qed.

Theorem paco1_mon: monotone1 (paco1 gf).
Proof.
  apply monotone1_eq.
  apply _paco1_mon.
Qed.

Theorem upaco1_mon: monotone1 (upaco1 gf).
Proof.
  red; intros.
  destruct IN.
  - left. eapply paco1_mon. apply H. apply LE.
  - right. apply LE, H.
Qed.

Theorem paco1_mult_strong: forall r,
  paco1 gf (upaco1 gf r) <1= paco1 gf r.
Proof.
  apply _paco1_mult_strong.
Qed.

Corollary paco1_mult: forall r,
  paco1 gf (paco1 gf r) <1= paco1 gf r.
Proof. intros; eapply paco1_mult_strong, paco1_mon; [apply PR|..]; intros; left; assumption. Qed.

Theorem paco1_fold: forall r,
  gf (upaco1 gf r) <1= paco1 gf r.
Proof.
  apply _paco1_fold.
Qed.

Theorem paco1_unfold: forall (MON: monotone1 gf) r,
  paco1 gf r <1= gf (upaco1 gf r).
Proof.
  intro. eapply _paco1_unfold; apply monotone1_eq; assumption.
Qed.

End Arg1.

Arguments paco1_acc : clear implicits.
Arguments paco1_mon : clear implicits.
Arguments upaco1_mon : clear implicits.
Arguments paco1_mult_strong : clear implicits.
Arguments paco1_mult : clear implicits.
Arguments paco1_fold : clear implicits.
Arguments paco1_unfold : clear implicits.

Global Instance paco1_inst  (gf : rel1 T0->_) r x0 : paco_class (paco1 gf r x0) :=
{ pacoacc    := paco1_acc gf;
  pacomult   := paco1_mult gf;
  pacofold   := paco1_fold gf;
  pacounfold := paco1_unfold gf }.

End PACO1.

Global Opaque paco1.

Hint Unfold upaco1.
Hint Resolve paco1_fold.
Hint Unfold monotone1.


Require Import List.

Import ListNotations.

Set Implicit Arguments.

Module Gamma.
  Definition t := list Type.
End Gamma.

Module Env.
  Inductive t : Gamma.t -> Type :=
  | nil : t nil
  | cons : forall T G, T -> t G -> t (T :: G).

  Fixpoint get G (e : t G) (n : nat) : List.nth n G unit :=
    match e with
    | nil =>
      match n with
      | O => tt
      | S _ => tt
      end
    | cons x e =>
      match n with
      | O => x
      | S n => get e n
      end
    end.
End Env.

Inductive M (G : Gamma.t) (A : Type) : Type :=
| new : (Env.t G -> A + {T : Type & T & M (T :: G) A}) -> M G A.

Definition open G A (x : M G A) :=
  match x with
  | new x' => x'
  end.

Definition next A G T (x : T) (k : M (T :: G) A) : {T : Type & T & M (T :: G) A} :=
  existT2 (fun T => T) _ T x k.

Fixpoint eval G A (x : M G A) (e : Env.t G) : A :=
  match open x e with
  | inl x => x
  | inr (existT2 _ _ _ t x) => eval x (Env.cons t e)
  end.

Definition eval_closed A (x : M [] A) : A :=
  eval x Env.nil.

Definition test1 :=
  let x := 12 in
  let y := 23 in
  x + y.

Compute test1.

Definition test1' : M [] nat :=
  new (fun _ => inr (
  next 12 (new (fun _ => inr (
  next 23 (new (fun (e : Env.t [nat : Type; nat : Type]) => inl (
  Env.get e 0 + Env.get e 1)))))))).

Compute eval_closed test1'.

Definition test2 :=
  let f := fun n => n + 2 in
  f 12.

Compute test2.

Definition test2' : M [] nat :=
  new (fun (_ : Env.t []) => inr (
  next ((fun n => new (fun (e : Env.t [nat : Type]) =>
    inl 0)) : nat -> M [nat : Type] nat) (new (fun (e : Env.t [nat -> M [nat : Type] nat]) =>
  inl 0)))).


Require Import
  List ListSet Coq.Vectors.Fin
  Arith.Compare_dec Lia
  Program
  .
Import ListNotations.
From CasperCBC
  Require Import
    Preamble ListExtras ListSetExtras FinExtras
    VLSM.Common VLSM.Equivocation
    VLSM.Equivocators.Common VLSM.Equivocators.Projections
    .

(** * VLSM Merging of Projections *)

Section trace_mixer.

Context
  {message : Type}
  (X : VLSM message)
  (equivocator_vlsm := equivocator_vlsm X)
  (MachineDescriptor := MachineDescriptor X)
  .

(** ** Reconstructing equivocator traces from projections

In this section we show that any set of protocol traces of the original
machine can be combined into a protocol trace for the [equivocator_vlsm]
having them as its projections.
*)

(** First, let us (re)define the projection of a trace segment.
In addition to [equivocator_vlsm_trace_project], this projection also
tracks the starting state of the trace segment and produces a starting
state for the corresponding projection.
*)
Definition preloaded_protocol_equivocator_vlsm_trace_oproject
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (nj : Fin.t (S (projT1 (finite_trace_last is btr))))
  : option (vstate X * list (vtransition_item X))
  :=
  let (j, _) := to_nat nj in
  match equivocator_vlsm_trace_project _ btr (Existing _ j false) with
  | Some (trx, NewMachine _ sn) => Some (sn, trx)
  | Some (trx, Existing _ i _) =>
    match (le_lt_dec (S (projT1 is)) i) with
    | left _ => None
    | right Hi => Some (projT2 is (of_nat_lt Hi), trx)
    end
  | _ => None
  end.

(** We define the type of all projectors such as the one above.
*)
Definition equivocator_vlsm_projector_type
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  : Type
  :=
  forall
    (nj : Fin.t (S (projT1 (finite_trace_last is btr)))),
    option (vstate X * list (vtransition_item X)).

(** We define an update operation on such projectors.  This will
allow to swap an existing projection for a user provided trace.
*)
Definition equivocator_projection_update
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (projector : equivocator_vlsm_projector_type is btr)
  (ni : Fin.t (S (projT1 (finite_trace_last is btr))))
  (ni_trace : option (vstate X * list (vtransition_item X)))
  (nj : Fin.t (S (projT1 (finite_trace_last is btr))))
  : option (vstate X * list (vtransition_item X))
  :=
  if Fin.eq_dec ni nj then ni_trace else projector nj.

(** The update operation specialized to
[preloaded_protocol_equivocator_vlsm_trace_oproject]
*)
Definition preloaded_protocol_equivocator_vlsm_trace_oproject_update
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (ni : Fin.t (S (projT1 (finite_trace_last is btr))))
  (isi : vstate X)
  (tri : list (vtransition_item X))
  : equivocator_vlsm_projector_type is btr
  :=
  equivocator_projection_update is btr
    (preloaded_protocol_equivocator_vlsm_trace_oproject is btr)
    ni (Some (isi, tri)).

(** Given a projector, compute the list of all projections of a trace.
*)
Definition projection_traces
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (projector : equivocator_vlsm_projector_type is btr)
  (n := projT1 (finite_trace_last is btr))
  : list (vstate X * list (vtransition_item X))
  :=
  map_option projector (fin_t_listing (S n)).

(** [projection_traces] specialized to
[preloaded_protocol_equivocator_vlsm_trace_oproject_update]
(swapping one projection with the provided one)
*)
Definition projection_traces_replace_one
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (ni : Fin.t (S (projT1 (finite_trace_last is btr))))
  (isi : vstate X)
  (tri : list (vtransition_item X))
  : list (vstate X * list (vtransition_item X))
  :=
  projection_traces is btr
    (preloaded_protocol_equivocator_vlsm_trace_oproject_update is btr ni isi tri).

(**
No traces are lost in the projection process described above.
*)
Lemma projection_traces_replace_one_length
  (is : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (Hbtr : finite_protocol_trace (pre_loaded_with_all_messages_vlsm equivocator_vlsm) is btr)
  (n := projT1 (finite_trace_last is btr))
  (ni : Fin.t (S n))
  (isi : vstate X)
  (tri : list (vtransition_item X))
  : length (projection_traces_replace_one is btr ni isi tri) = S n.
Proof.
  unfold projection_traces_replace_one.
  unfold projection_traces.
  rewrite map_option_length; [apply fin_t_listing_length|].
  apply Forall_forall.
  intros nj Hnj.
  unfold preloaded_protocol_equivocator_vlsm_trace_oproject_update.
  unfold equivocator_projection_update.
  destruct (Fin.eq_dec ni nj).
  - rewrite eq_dec_if_true by assumption.
    congruence.
  - rewrite eq_dec_if_false by assumption.
    unfold preloaded_protocol_equivocator_vlsm_trace_oproject.
    destruct (to_nat nj) as [j Hj] eqn:Heqnj.
    pose proof (ptrace_add_last
      (base_prop:=@finite_protocol_trace_from) (proj1 Hbtr) (eq_refl _)).
    destruct
      (preloaded_equivocator_vlsm_project_protocol_trace _ _ _ _ H _ Hj false)
      as [trX [di [Hproject Hdi]]].
    rewrite Hproject.
    destruct di as [sn | i fi].
    + congruence.
    + destruct Hdi as [Hi [HtrX]].
      destruct (le_lt_dec (S (projT1 is)) i); [lia|].
      congruence.
Qed.

Context
  (goal_state : vstate equivocator_vlsm)
  (n := projT1 goal_state)
  (traces : list (vstate X * list (vtransition_item X)))
  (Hn : length traces = S n)
  (Htraces : Forall
    (fun trace =>
      finite_protocol_trace (pre_loaded_with_all_messages_vlsm X) (fst trace) (snd trace)
    )
    traces)
  (Hne_traces : Forall (fun trace => snd trace <> []) traces)
  (Hs
    : forall i : Fin.t (S n),
      let (ni, _) := to_nat i in
      match nth ni traces (proj1_sig (vs0 X), []) with (isi, tri) =>
        finite_trace_last isi tri = projT2 goal_state i
      end
  )
  .

Definition lift_first_trace_to_equivocator
  (tri : list (vtransition_item X))
  : list (vtransition_item equivocator_vlsm)
  :=
  fold_right
  (fun lab tr =>
    match lab with {| l := lx; input := iom; output := oom; destination := sx |} =>
      {| l := mk_label _ lx  (Existing _ 0 false); input := iom; output := oom; destination := mk_singleton_state _ sx |}
      :: tr
    end)
  [] tri.

Definition lift_trace_to_equivocator
  (start : vstate equivocator_vlsm)
  (i := projT1 start)
  (isi : vstate X)
  (tri : list (vtransition_item X))
  : list (vtransition_item equivocator_vlsm)
  :=
  match tri with
  | [] => []
  | {| l := lx; input := iom; output := oom; destination := sx |} :: tri' =>
    {| l := mk_label _ lx (NewMachine _ isi); input := iom; output := oom; destination := equivocator_state_extend _ start sx |}
    :: fold_right
      (fun lab tr =>
        match lab with {| l := lx; input := iom; output := oom; destination := sx |} =>
          {| l := mk_label _ lx  (Existing _ (S i) false); input := iom; output := oom; destination := equivocator_state_extend _ start sx |}
          :: tr
        end)
      [] tri
  end.

Definition lift_traces_to_equivocator
  : option (vstate equivocator_vlsm * list (vtransition_item equivocator_vlsm))
  :=
  match traces with
  | [] => None
  | (is0, tr0) :: traces =>
    let tr := lift_first_trace_to_equivocator tr0 in
    Some (mk_singleton_state _ is0, tr ++
      fst
        (fold_left
          (fun rez tracei =>
            let isxi := fst tracei in
            let trxi := snd tracei in
            match rez with (tr, s) =>
              let tri := lift_trace_to_equivocator s isxi trxi in
              (tr ++ tri, finite_trace_last s tri)
            end
          ) traces ([], proj1_sig (vs0 equivocator_vlsm))
        ))
  end.

End trace_mixer.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra bigenough.
(* ------- *) Require Import finmap boolp reals.
(* ------- *) Require (*--*) Setoid.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Num.Theory BigEnough.

Local Open Scope ring_scope.
Local Open Scope real_scope.

(* -------------------------------------------------------------------- *)
Section ToBeEventuallyMovedToBoolP.

Context {T : Type} {P Q : T -> Prop}.

Lemma asboolb (b : bool) : `[< b >] = b.
Proof. by apply/asboolP/idP. Qed.

(* TODO : add its friends... *)
Lemma neg_or (A B : Prop) : ~ (A \/ B) <-> ~ A /\ ~ B.
Proof.
split; last by case=> [nA nB]; case.
by move=> nAoB; split => ?; apply: nAoB; [left| right].
Qed.

Lemma existsNP : ~ (exists x, P x) -> forall x, ~ P x.
Proof. by move/asboolPn/forallp_asboolPn. Qed.

Lemma exists2NP : ~ (exists2 x, P x & Q x) -> forall x, ~ P x \/ ~ Q x.
Proof.
apply: contrapR; case/asboolPn/existsp_asboolPn=> [x].
by case/neg_or => /contrapT Px /contrapT Qx; exists x.
Qed.

End ToBeEventuallyMovedToBoolP.

(* -------------------------------------------------------------------- *)

Section ProofIrrelevantChoice.

Context {T : choiceType}.

Lemma existsP  (P : T -> Prop) : (exists x, P x) -> {x : T | P x}.
Proof.
move/asboolP/exists_asboolP=> h; have/asboolP hxh := (xchooseP h).
by exists (xchoose h).
Qed.

Lemma existsTP (P : T -> Prop) : { x : T | P x } + (forall x, ~ P x).
Proof.
case: (boolP `[<exists x : T, P x>]) => [/exists_asboolP | /asboolPn] h.
  by case/existsP: h => w Pw; left; exists w; apply/asboolP.
by right=> x Px; apply/h; exists x.
Qed.

End ProofIrrelevantChoice.

(* -------------------------------------------------------------------- *)
Section PredSubtype.
Section Def.
Variable T : Type.
Variable E : pred T.

Record pred_sub : Type :=
  PSubSub { rsval : T; rsvalP : rsval \in E }.

Coercion rsval : pred_sub >-> T.

Canonical pred_sub_subType := Eval hnf in [subType for rsval].
End Def.

Definition pred_sub_eqMixin (T : eqType) (E : pred T) :=
  Eval hnf in [eqMixin of pred_sub E by <:].
Canonical pred_sub_eqType (T : eqType) (E : pred T) :=
  Eval hnf in EqType (@pred_sub T E) (pred_sub_eqMixin E).

Definition pred_sub_choiceMixin (T : choiceType) (E : pred T) :=
  Eval hnf in [choiceMixin of pred_sub E by <:].
Canonical pred_sub_choiceType (T : choiceType) (E : pred T) :=
  Eval hnf in ChoiceType (@pred_sub T E) (pred_sub_choiceMixin E).

Definition pred_sub_countMixin (T : countType) (E : pred T) :=
  Eval hnf in [countMixin of pred_sub E by <:].
Canonical pred_sub_countType (T : countType) (E : pred T) :=
  Eval hnf in CountType (@pred_sub T E) (pred_sub_countMixin E).
End PredSubtype.

Notation "[ 'psub' E ]" := (@pred_sub _ E)
  (format "[ 'psub'  E ]").

(* -------------------------------------------------------------------- *)
Section PIncl.
Variables (T : Type) (E F : pred T) (le : {subset E <= F}).

Definition pincl (x : [psub E]) : [psub F] :=
  PSubSub (le (valP x)).
End PIncl.

(* -------------------------------------------------------------------- *)
Section Countable.
Variable (T : Type) (E : pred T).

CoInductive countable : Type :=
  Countable
    (rpickle : [psub E] -> nat)
    (runpickle : nat -> option [psub E])
    of pcancel rpickle runpickle.

Definition rpickle (c : countable) :=
  let: Countable p _ _ := c in p.

Definition runpickle (c : countable) :=
  let: Countable _ p _ := c in p.

Lemma rpickleK c: pcancel (rpickle c) (runpickle c).
Proof. by case: c. Qed.
End Countable.

(* -------------------------------------------------------------------- *)
Section CountableTheory.
Lemma countable_countable (T : countType) (E : pred T) : countable E.
Proof. by exists pickle unpickle; apply/pickleK. Qed.

Section CanCountable.
Variables (T : Type) (U : countType) (E : pred T).
Variables (f : [psub E] -> U) (g : U -> [psub E]).

Lemma can_countable : cancel f g -> countable E.
Proof.
pose p := pickle \o f; pose u n := omap g (unpickle n).
move=> can_fg; apply (@Countable _ E p u) => x.
by rewrite {}/u {}/p /= pickleK /= can_fg.
Qed.
End CanCountable.

Section CountType.
Variables (T : eqType) (E : pred T) (c : countable E).

Definition countable_countMixin  := CountMixin (rpickleK c).
Definition countable_choiceMixin := CountChoiceMixin countable_countMixin.

Definition countable_choiceType :=
  ChoiceType [psub E] countable_choiceMixin.

Definition countable_countType :=
  CountType countable_choiceType countable_countMixin.
End CountType.
End CountableTheory.

Notation "[ 'countable' 'of' c ]" := (countable_countType c)
  (format "[ 'countable'  'of'  c ]").

(* -------------------------------------------------------------------- *)
Section Finite.
Variables (T : eqType).

CoInductive finite (E : pred T) : Type :=
| Finite s of uniq s & {subset E <= s}.
End Finite.

(* -------------------------------------------------------------------- *)
Section FiniteTheory.
Context {T : choiceType}.

Lemma finiteP (E : pred T) : (exists s : seq T, {subset E <= s}) -> finite E.
Proof.
case/existsP=> s sEs; exists (undup s); first by rewrite undup_uniq.
by move=> x; rewrite mem_undup; exact: sEs.
Qed.

Lemma finiteNP (E : pred T): (forall s : seq T, ~ {subset E <= s}) ->
  forall n, exists s : seq T, [/\ size s = n, uniq s & {subset s <= E}].
Proof.
move=> finN; elim=> [|n [s] [<- uq_s sE]]; first by exists [::].
have [x sxN xE]: exists2 x, x \notin s & x \in E.
  apply: contrapR (finN (filter (mem E) s)) => /exists2NP finE x Ex.
  move/or_asboolP: (finE x).
  by rewrite !asbool_neg !asboolb negbK Ex mem_filter orbF [(mem E) x]Ex.
exists (x :: s) => /=; rewrite sxN; split=> // y.
by rewrite in_cons => /orP[/eqP->//|/sE].
Qed.

End FiniteTheory.

(* -------------------------------------------------------------------- *)
Section FiniteCountable.
Variables (T : eqType) (E : pred T).

Lemma finite_countable : finite E -> countable E.
Proof.
case=> s uqs Es; pose t := pmap (fun x => (insub x : option [psub E])) s.
pose f x := index x t; pose g i := nth None [seq Some x | x <- t] i.
apply (@Countable _ E f g) => x; rewrite {}/f {}/g /=.
have x_in_t: x \in t; first case: x => x h.
  by rewrite {}/t mem_pmap_sub /= Es.
by rewrite (nth_map x) ?index_mem ?nth_index.
Qed.
End FiniteCountable.

(* -------------------------------------------------------------------- *)
Section CountSub.
Variables (T : eqType) (E F : pred T).

Lemma countable_sub: {subset E <= F} -> countable F -> countable E.
Proof.
move=> le_EF [f g fgK]; pose f' (x : [psub E]) := f (pincl le_EF x).
pose g' x := obind (insub (sT := [subType of [psub E]])) (omap val (g x)).
by exists f' g' => x; rewrite /f' /g' fgK /= valK.
Qed.
End CountSub.

(* -------------------------------------------------------------------- *)
Section CountableUnion.
Variables (T : eqType) (E : nat -> pred T).

Hypothesis cE : forall i, countable (E i).

Lemma cunion_countable : countable [pred x | `[exists i, x \in E i]].
Proof.
pose S := { i : nat & [countable of cE i] }; set F := [pred x | _].
have H: forall (x : [psub F]), exists i : nat, val x \in E i.
  by case=> x /= /existsbP[i] Eix; exists i.
have G: forall (x : S), val (tagged x) \in F.
  by case=> i [x /= Eix]; apply/existsbP; exists i.
pose f (x : [psub F]) : S := Tagged (fun i => [psub E i])
  (PSubSub (xchooseP (H x))).
pose g (x : S) := PSubSub (G x).
by have /can_countable: cancel f g by case=> x hx; apply/val_inj.
Qed.
End CountableUnion.


Require Import List String.
Import ListNotations.

Inductive value :=
  | Number : nat -> value
  | String : string -> value
  | Array : list value -> value
  | Object : list (string * value) -> value
  | Null : value
  | Undefined : value
  .

Class Serializable A := {
  to_json : A -> value;
  from_json : value -> option A;
  roundtrip : forall (x : A), from_json (to_json x) = Some x
}.

Notation S := Serializable.

Instance Serializable_unit : S unit := {
  to_json _ := Object [];
  from_json _ := Some tt;
}.
intro x. case x. exact eq_refl.
Defined.

Instance Serializable_prod {A B} {_ : S A} {_ : S B} : S (A * B) := {
  to_json p := let (x, y) := p in Array [ to_json x; to_json y ];
  from_json v :=
    match v with
    | Array [ x; y ] =>
      match from_json x, from_json y with
      | Some x1, Some y1 => Some (x1, y1)
      | _, _ => None
      end
    | _ => None
    end
}.
(* roundtrip *)
intro p.
destruct p.
rewrite roundtrip.
rewrite roundtrip.
reflexivity.
Defined.

Instance S_nat : S nat := {
  to_json := Number;
  from_json v :=
    match v with
    | Number x => Some x
    | _ => None
    end
}.
intro. auto.
Defined.

Eval compute in to_json (1, tt, 5, 6).

Record foo := mk_foo { bar : nat; baz : nat }.

Definition foo1 : foo := {| bar := 1; baz := 1 |}.

Record Heap := {
  m : Set -> Set; (* monad for heap operations *)
  ref : Set -> Set;
  read_ref : forall {a}, ref a -> m a
  ...
}
Axiom unsafePerformIO : forall {a}, (forall {h : Heap}, { x : m h a | ... }) -> a.

Module Type Heap_Sig.
  Parameter m : Set -> Set.
  Parameter ref : Set -> Set.
  Parameter read_ref : forall {a}, ref a -> m a.
  (* ... *)
End Heap_Sig.

Module App(Heap : Heap_Sig).
  Inductive dynamic := ... (Heap.ref ...)
End App.

Module PureHeap.