(** Cyclic Permutations
Definition and basic properties of cyclic permutations in [Type]. *)

From Coq Require Import CMorphisms PeanoNat.
From Coq Require CPermutation.
From OLlibs Require Import List_more Permutation_Type_more funtheory.

Set Implicit Arguments.

(** * Definition *)
Inductive CPermutation_Type A : list A -> list A -> Type :=
| cperm_Type : forall l1 l2, CPermutation_Type (l1 ++ l2) (l2 ++ l1).

#[export] Instance CPermutation_Permutation_Type A :
   Proper (@CPermutation_Type A ==> @Permutation_Type A) id.
Proof.
intros l1 l2 HC.
inversion HC.
apply Permutation_Type_app_comm.
Qed.

Lemma CPermutation_Type_CPermutation A : forall l1 l2 : list A,
  CPermutation_Type l1 l2 -> CPermutation.CPermutation l1 l2.
Proof. intros l1 l2 HP; inversion HP; constructor. Qed.

(** * Properties *)

#[export] Instance CPermutation_Type_refl A : Reflexive (@CPermutation_Type A).
Proof.
intros l.
assert (CPermutation_Type (nil ++ l) (l ++ nil))
  as HC by (eapply cperm_Type).
simpl in HC.
now rewrite app_nil_r in HC.
Qed.

#[export] Instance CPermutation_Type_sym A : Symmetric (@CPermutation_Type A).
Proof.
intros l1 l2 HC.
inversion HC.
apply cperm_Type.
Qed.

#[export] Instance CPermutation_Type_trans A : Transitive (@CPermutation_Type A).
Proof.
intros l1 l2 l3 HC1 HC2.
inversion HC1 ; inversion HC2 ; subst.
apply dichot_app_inf in H1.
destruct H1 as [[l2' [Hl1 Hl2]] | [l4' [Hr1 Hr2]]] ; subst.
- rewrite <- app_assoc, app_assoc.
  apply cperm_Type.
- rewrite <- app_assoc, (app_assoc l6).
  apply cperm_Type.
Qed.

#[export] Instance CPermutation_Type_equiv A : Equivalence (@CPermutation_Type A).
Proof.
split.
- apply CPermutation_Type_refl.
- apply CPermutation_Type_sym.
- apply CPermutation_Type_trans.
Qed.

Lemma CPermutation_Type_split A : forall l1 l2 : list A,
  CPermutation_Type l1 l2 -> { n | l2 = skipn n l1 ++ firstn n l1 }.
Proof.
intros l1 l2 [l1' l2'].
exists (length l1').
rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal.
now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r.
Qed.

Lemma CPermutation_Type_skipn_firstn A : forall (l : list A) n,
  CPermutation_Type l (skipn n l ++ firstn n l).
Proof.
intros l n.
transitivity (firstn n l ++ skipn n l); [ | constructor ].
now rewrite (firstn_skipn n).
Qed.

Lemma CPermutation_Type_app A : forall l1 l2 l3 : list A,
  CPermutation_Type (l1 ++ l2) l3 -> CPermutation_Type (l2 ++ l1) l3.
Proof.
intros l1 l2 l3 HC.
refine (CPermutation_Type_trans _ HC).
apply cperm_Type.
Qed.

Theorem CPermutation_Type_app_comm A : forall l1 l2 : list A,
  CPermutation_Type (l1 ++ l2) (l2 ++ l1).
Proof. apply cperm_Type. Qed.

Lemma CPermutation_Type_app_rot A : forall (l1 : list A) l2 l3,
   CPermutation_Type (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1).
Proof.
intros l1 l2 l3.
rewrite (app_assoc l2).
apply cperm_Type.
Qed.

Lemma CPermutation_Type_cons_append A : forall (a : A) l,
  CPermutation_Type (a :: l) (l ++ a :: nil).
Proof.
intros.
rewrite <- (app_nil_l l), app_comm_cons.
apply cperm_Type.
Qed.

Lemma CPermutation_Type_swap A : forall a b : A,
  CPermutation_Type (a :: b :: nil) (b :: a :: nil).
Proof.
intros.
change (a :: b :: nil) with ((a :: nil) ++ (b :: nil)).
change (b :: a :: nil) with ((b :: nil) ++ (a :: nil)).
apply cperm_Type.
Qed.

Lemma CPermutation_Type_cons A : forall l1 (a : A) l2,
  CPermutation_Type (l1 ++ a :: nil) l2 -> CPermutation_Type (a :: l1) l2.
Proof.
intros l1 a l2 HC.
now apply (CPermutation_Type_app l1 (a :: nil)).
Qed.

Lemma CPermutation_Type_morph_cons A : forall P : list A -> Prop,
  (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->
  Proper (@CPermutation_Type A ==> Basics.impl) P.
Proof.
assert (forall P : list A -> Prop,
         (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->
         forall l1 l2, CPermutation_Type l1 l2 -> P l1 -> P l2)
  as Himp.
{ intros P HP l1 l2 HC.
  inversion HC ; subst ; clear HC.
  revert l0 ; induction l3 using rev_ind ; intros l0 HPl.
  - now rewrite app_nil_r in HPl.
  - rewrite app_assoc in HPl.
    apply HP in HPl.
    rewrite <- app_assoc, <- app_comm_cons, app_nil_l; auto. }
intros P HP l1 l2 HC H.
now apply Himp with l1.
Qed.

Lemma CPermutation_Type_nil A : forall l : list A,
  CPermutation_Type nil l -> l = nil.
Proof. now intros; apply Permutation_Type_nil, CPermutation_Permutation_Type. Qed.

Lemma CPermutation_Type_nil_cons A : forall l (a : A),
  CPermutation_Type nil (a :: l) -> False.
Proof.
intros l a HC.
apply CPermutation_Type_nil in HC.
inversion HC.
Qed.

Lemma CPermutation_Type_length_1 A : forall a b : A,
  CPermutation_Type (a :: nil) (b :: nil) -> a = b.
Proof. now intros; apply Permutation_Type_length_1, CPermutation_Permutation_Type. Qed.

Lemma CPermutation_Type_length_2 A : forall a1 a2 b1 b2 : A,
  CPermutation_Type (a1 :: a2 :: nil) (b1 :: b2 :: nil) ->
    { a1 = b1 /\ a2 = b2 } + { a1 = b2 /\ a2 = b1 }.
Proof. now intros; apply Permutation_Type_length_2, CPermutation_Permutation_Type. Qed.

Lemma CPermutation_Type_length_1_inv A : forall (a : A) l,
  CPermutation_Type (a :: nil) l -> l = a :: nil.
Proof. now intros; apply Permutation_Type_length_1_inv, CPermutation_Permutation_Type. Qed.

Lemma CPermutation_Type_length_2_inv A : forall (a : A) b l,
  CPermutation_Type (a :: b :: nil) l ->
  { l = a :: b :: nil } + { l = b :: a :: nil }.
Proof. now intros; apply Permutation_Type_length_2_inv, CPermutation_Permutation_Type. Qed.

Lemma CPermutation_Type_vs_elt_inv A : forall (a : A) l l1 l2,
  CPermutation_Type l (l1 ++ a :: l2) ->
    {'(l1',l2') | l2 ++ l1 = l2' ++ l1' & l = l1' ++ a :: l2' }.
Proof.
intros a l l1 l2 HC.
inversion HC; subst.
symmetry in H1.
dichot_elt_app_inf_exec H1; subst.
- now exists (l0 ++ l1, l); simpl; rewrite <- app_assoc.
- now exists (l4, l2 ++ l3); simpl; rewrite <- app_assoc.
Qed.

Lemma CPermutation_Type_vs_cons_inv A : forall (a : A) l l1,
  CPermutation_Type l (a :: l1) ->
    {'(l1',l2') | l1 = l2' ++ l1' & l = l1' ++ a :: l2' }.
Proof.
intros a l l1 HC.
rewrite <- (app_nil_l (a::_)) in HC.
apply CPermutation_Type_vs_elt_inv in HC.
destruct HC as [(l1',l2') H1 H2].
rewrite app_nil_r in H1 ; subst.
now exists (l1', l2').
Qed.

Lemma CPermutation_Type_vs_elt_subst A (a : A) l l1 l2 :
  CPermutation_Type l (l1 ++ a :: l2) ->
  {'(l3, l4) & forall l0, CPermutation_Type (l1 ++ l0 ++ l2) (l3 ++ l0 ++ l4) & l = l3 ++ a :: l4 }.
Proof.
intros HP.
destruct (CPermutation_Type_vs_elt_inv _ _ _ HP) as [(l', l'') Heq ->].
exists (l', l''); [ | reflexivity ].
intros l0.
etransitivity; [ apply CPermutation_Type_app_comm | ].
list_simpl; rewrite Heq, app_assoc.
constructor.
Qed.

Lemma CPermutation_Type_app_app_inv A : forall l1 l2 l3 l4 : list A,
  CPermutation_Type (l1 ++ l2) (l3 ++ l4) ->
     {'(l1',l2',l3',l4') : _ & prod
        (prod  (CPermutation_Type l1 (l1' ++ l3'))
               (CPermutation_Type l2 (l2' ++ l4')))
        (prod  (CPermutation_Type l3 (l1' ++ l2'))
               (CPermutation_Type l4 (l3' ++ l4'))) }
   + {'(l1',l2') : _ & prod (prod
        (CPermutation_Type l1 (l4 ++ l1'))
        (CPermutation_Type l3 (l2 ++ l2')))
        (CPermutation_Type l1' l2') }
   + {'(l1',l2') : _ & prod (prod
        (CPermutation_Type l2 (l4 ++ l1'))
        (CPermutation_Type l3 (l1 ++ l2')))
        (CPermutation_Type l1' l2') }
   + {'(l1',l2') : _ & prod (prod
        (CPermutation_Type l1 (l3 ++ l1'))
        (CPermutation_Type l4 (l2 ++ l2')))
        (CPermutation_Type l1' l2') }
   + {'(l1',l2') : _ & prod (prod
        (CPermutation_Type l2 (l3 ++ l1'))
        (CPermutation_Type l4 (l1 ++ l2')))
        (CPermutation_Type l1' l2') }.
Proof.
intros l1 l2 l3 l4 HC.
inversion HC as [lx ly Hx Hy].
dichot_app_inf_exec Hx; dichot_app_inf_exec Hy; subst.
- left; left; left; right; exists (l ++ l0, l0 ++ l); repeat split;
    rewrite <- ? app_assoc; apply CPermutation_Type_app_rot.
- dichot_app_inf_exec Hy0; subst.
  + left; left; left; left; exists (l, l0, lx, l5); repeat split;
      apply CPermutation_Type_refl.
  + left; right; exists (l1 ++ lx , lx ++ l1); repeat split;
      rewrite <- ? app_assoc ; apply CPermutation_Type_app_rot.
- dichot_app_inf_exec Hy1 ; subst.
  + left; left; right; exists (ly ++ l2, l2 ++ ly); repeat split;
      rewrite <- ? app_assoc; apply CPermutation_Type_app_rot.
  + left; left; left; left; exists (l, ly, l3, l0); repeat split;
      apply CPermutation_Type_refl.
- right; exists (l5 ++ l0, l0 ++ l5); repeat split;
    rewrite <- ? app_assoc; apply CPermutation_Type_app_rot.
Qed.

(** [rev], [in], [map], [Forall], [Exists], etc. *)
#[export] Instance CPermutation_Type_rev A :
  Proper (@CPermutation_Type A ==> @CPermutation_Type A) (@rev A).
Proof.
intros l; induction l; intros l' HC.
- apply CPermutation_Type_nil in HC; subst; apply CPermutation_Type_refl.
- apply CPermutation_Type_sym in HC.
  apply CPermutation_Type_vs_cons_inv in HC.
  destruct HC as [(l1 & l2) -> ->].
  now simpl; rewrite ? rev_app_distr; simpl; rewrite <- app_assoc.
Qed.

#[export] Instance CPermutation_Type_in A (a : A) :
  Proper (@CPermutation_Type A ==> Basics.impl) (In a).
Proof.
intros l l' HC Hin.
apply Permutation_Type_in with l; auto.
now apply CPermutation_Permutation_Type.
Qed.

#[export] Instance CPermutation_Type_map A B (f : A -> B) :
  Proper (@CPermutation_Type A ==> @CPermutation_Type B) (map f).
Proof.
intros l l' HC.
now inversion HC; subst; rewrite ? map_app.
Qed.

Lemma CPermutation_Type_map_inv A B : forall(f : A -> B) l1 l2,
  CPermutation_Type l1 (map f l2) ->
    { l & l1 = map f l & (CPermutation_Type l2 l) }.
Proof.
induction l1; intros l2 HP.
- exists nil; auto.
  simpl; destruct l2; auto.
  + apply CPermutation_Type_refl.
  + apply CPermutation_Type_nil in HP.
    inversion HP.
- apply CPermutation_Type_sym in HP.
  destruct (CPermutation_Type_vs_cons_inv HP) as [(l3 & l4) -> Heq2].
  decomp_map_inf Heq2; subst; simpl.
  exists (x :: l5 ++ l0).
  + now simpl; rewrite ? map_app.
  + constructor.
Qed.

#[export] Instance CPermutation_Type_Forall A (P : A -> Prop) :
  Proper (@CPermutation_Type A ==> Basics.impl) (Forall P).
Proof.
intros l1 l2 HC HF.
apply Permutation_Type_Forall with l1; auto.
now apply CPermutation_Permutation_Type.
Qed.

#[export] Instance CPermutation_Type_Exists A (P : A -> Prop) :
  Proper (@CPermutation_Type A ==> Basics.impl) (Exists P).
Proof.
intros l1 l2 HC HE.
apply Permutation_Type_Exists with l1; auto.
now apply CPermutation_Permutation_Type.
Qed.

#[export] Instance CPermutation_Type_Forall_inf A (P : A -> Type) :
  Proper (@CPermutation_Type A ==> arrow) (Forall_inf P).
Proof.
intros l1 l2 HC HF.
apply Permutation_Type_Forall_inf with l1; auto.
now apply CPermutation_Permutation_Type.
Qed.

#[export] Instance CPermutation_Type_Exists_inf A (P : A -> Type) :
  Proper (@CPermutation_Type A ==> arrow) (Exists_inf P).
Proof.
intros l1 l2 HC HE.
apply Permutation_Type_Exists_inf with l1; auto.
now apply CPermutation_Permutation_Type.
Qed.

Lemma CPermutation_Type_Forall2_inf A B (P : A -> B -> Type) :
  forall l1 l1' l2, CPermutation_Type l1 l1' -> Forall2_inf P l1 l2 ->
    { l2' & CPermutation_Type l2 l2' & Forall2_inf P l1' l2' }.
Proof.
intros l1 l1' l2 HP.
revert l2; induction HP; intros l2' HF; inversion HF; subst.
- exists nil; auto.
  + reflexivity.
  + now symmetry in H0; apply app_eq_nil in H0 as [Heq1 Heq2]; subst.
- destruct l1 ; inversion H0; subst.
  + rewrite app_nil_l in H0; subst.
    exists (y :: l').
    * reflexivity.
    * now rewrite app_nil_l in HF; simpl; rewrite app_nil_r.
  + apply Forall2_inf_app_inv_l in X0 as [(la, lb) [HF1 HF2] ->].
    exists (lb ++ y :: la).
    * rewrite app_comm_cons; constructor.
    * apply Forall2_inf_app; auto.
Qed.

Lemma CPermutation_Type_image A B : forall (f : A -> B) a l l',
  CPermutation_Type (a :: l) (map f l') -> { a' | a = f a' }.
Proof.
intros f a l l' HP.
apply Permutation_Type_image with l l'.
now apply CPermutation_Permutation_Type.
Qed.

Lemma CPermutation_Type_map_inv_inj A B : forall f : A -> B, injective f ->
  forall l1 l2, CPermutation_Type (map f l1) (map f l2) -> CPermutation_Type l1 l2.
Proof.
intros f Hi l1 l2 HP; inversion HP as [l3 l4 Heq1 Heq2].
symmetry in Heq1; symmetry in Heq2.
decomp_map_inf Heq1; decomp_map_inf Heq2; subst.
apply map_injective in Heq5; auto.
apply map_injective in Heq6; auto.
subst; constructor.
Qed.

Lemma CPermutation_Type_map_inv_inj_local A B : forall (f : A -> B) l1 l2,
  (forall x y, In x l1 -> In y l2 -> f x = f y -> x = y) ->
    CPermutation_Type (map f l1) (map f l2) -> CPermutation_Type l1 l2.
Proof.
intros f l1 l2 Hi HP; inversion HP as [l3 l4 Heq1 Heq2].
symmetry in Heq1; symmetry in Heq2.
decomp_map_inf Heq1; decomp_map_inf Heq2; subst.
symmetry in Heq5; symmetry in Heq6.
apply map_injective_in in Heq5.
2:{ intros x y Hin1 Hin2 Heq; apply Hi; auto; apply in_or_app; auto. }
apply map_injective_in in Heq6.
2:{ intros x y Hin1 Hin2 Heq; apply Hi; auto; apply in_or_app; auto. }
subst; constructor.
Qed.


Require Import VerdiRaft.Raft.
Require Import Verdi.VarD.
Require Import String.

Section VarDRaft.
  Variable n : nat.

  Instance raft_params : RaftParams vard_base_params :=
    {
      N := n;
      input_eq_dec := input_eq_dec;
      output_eq_dec := output_eq_dec;
      clientId := string;
      clientId_eq_dec := string_dec
    }.

  Definition vard_raft_base_params := base_params.
  Definition vard_raft_multi_params := multi_params.
  Definition vard_raft_failure_params := failure_params.
End VarDRaft.


Require Import VST.floyd.proofauto.
Require Import sqrt3.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition sqrt_approx_f (x: float32) : float32 :=
  Float32.of_bits
  (Int.add (Int.shru (Float32.to_bits x) (Int.repr 1))
     (Int.repr 532676608)).

Definition sqrt_approx_spec :=
   DECLARE _sqrt_approx
   WITH x: float32
   PRE [ tfloat ]
       PROP () PARAMS (Vsingle x) SEP ()
    POST [ tfloat ]
       PROP () RETURN (Vsingle (sqrt_approx_f x)) SEP ().

Definition Gprog : funspecs :=
         [sqrt_approx_spec].

Lemma body_sqrt_approx:  semax_body Vprog Gprog f_sqrt_approx sqrt_approx_spec.
Proof.
start_function.
forward.
forward.
forward.
forward.
forward.
entailer!.
Qed.


(**
  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we show example program evaluation in concurrent Core Erlang.
*)

Require Import ConcurrentFunSemantics.
Import ListNotations.
Import PeanoNat.
(*
  0 -[ 1 + 1 ]-> 1
  1 -[ 2 ]-> 3
  2 -[ 3 ]-> 3
  3 : 2 + 3 == 5
*)
Open Scope string_scope. Print LiveProcess.

Ltac ether_order_base X :=
  match X with
  | context G [@update ?ty ?i1 ?inner (@update _ ?i2 _ ?ether)] =>
    match ty with
    | PID -> list Signal =>
      match eval compute in (Nat.leb i1 i2) with
      | true  => idtac inner; ether_order_base inner; ether_order_base ether
      | false => rewrite (update_swap _ i1 i2 _ _ ether)
      end
    | list Signal =>
      match eval compute in (Nat.leb i1 i2) with
      | true  => idtac inner; ether_order_base ether
      | false => rewrite (update_swap _ i1 i2 _ _ ether)
      end
    end
  end.
Ltac ether_order :=
  match goal with
  | |- (?X, _) -[ _ ]ₙ->* (_, _) => ether_order_base X
  end.

Corollary update_noop_ether_1 :
  forall A ι2, update ι2 (@nil A) (fun _ => []) = fun _ => [].
Proof.
  intros. rewrite update_noop; reflexivity.
Qed.

Corollary update_noop_ether_2 :
  forall {T} ι1, @update (PID -> list T) ι1 (fun _ => []) (fun _ _ => []) = fun _ _ => [].
Proof.
  intros. rewrite update_noop; reflexivity.
Qed.

Ltac ether_cleanup :=
  unfold nullpool, etherAdd; cbn;
  try ether_order; try lia;
  repeat rewrite update_same;
  repeat rewrite update_noop_ether_1;
  repeat rewrite update_noop_ether_2.

Example signal_ordering :
  exists acts,
    (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF (ELit "!") [EPid 1; ELit "fst"])
                                        (EBIF (ELit "!") [EPid 2; ELit "snd"]), [], [], false) ||||
                  1 : inl ([], EReceive [(PVar, EBIF (ELit "!")
                                                       [EPid 2; EVar 0])], [], [], false) ||||
                  2 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[ acts ]ₙ->*
    (fun _ _ => [], 2 : inl ([], ELit "snd", [ELit "fst"], [], false) |||| nullpool).
Proof.
  eexists.
  (* Progress with 0 *)
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    constructor. apply step_bif. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  simpl. ether_cleanup.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 0).
  ether_cleanup.
  rewrite par_swap with (ι := 1) (ι' := 2).
  rewrite par_swap with (ι := 0) (ι' := 2).
  rewrite par_swap with (ι := 0) (ι' := 1).
  rewrite nullpool_remove. 2-4: lia.
  rewrite par_swap. 2: lia.
  (* Messages are delivered: *)
  eapply n_trans. eapply n_arrive with (ι := 1) (ι0 := 0).
    reflexivity. do 2 constructor. simpl.
  ether_cleanup.
  rewrite par_swap. 2: lia.
  eapply n_trans. eapply n_arrive with (ι := 2) (ι0 := 0).
    reflexivity. do 2 constructor. simpl.
  ether_cleanup.
  (* Progress with 2 *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
  rewrite par_swap with (ι := 2) (ι' := 1). 2: lia.
  ether_cleanup.
  (* Progress with 1 *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
    ether_cleanup.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 1).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 1).
    rewrite par_swap. 2: lia. rewrite nullpool_remove.
  (* Arrive to 2 *)
  eapply n_trans. eapply n_arrive with (ι := 2) (ι0 := 1).
    reflexivity. do 2 constructor. simpl.
    ether_cleanup.
  apply n_refl.
Qed.

Example signal_ordering_2 :
  exists acts,
    (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF (ELit "!") [EPid 1; ELit "fst"])
                                        (EBIF (ELit "!") [EPid 2; ELit "snd"]), [], [], false) ||||
                  1 : inl ([], EReceive [(PVar, EBIF (ELit "!")
                                                       [EPid 2; EVar 0])], [], [], false) ||||
                  2 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[ acts ]ₙ->*
    (fun _ _ => [], 2 : inl ([], ELit "snd", [ELit "fst"], [], false) |||| nullpool).
Proof.
  eexists.
  (* Progress with 0 *)
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    constructor. apply step_bif. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 0).
  ether_cleanup.
  rewrite par_swap with (ι := 1) (ι' := 2).
  rewrite par_swap with (ι := 0) (ι' := 2).
  rewrite par_swap with (ι := 0) (ι' := 1).
  rewrite nullpool_remove. 2-4: lia.
  rewrite par_swap. 2: lia.
  (* Messages are delivered: *)
  eapply n_trans. eapply n_arrive with (ι := 1) (ι0 := 0).
    reflexivity. do 2 constructor. simpl.
  ether_cleanup.
  rewrite par_swap. 2: lia.
  eapply n_trans. eapply n_arrive with (ι := 2) (ι0 := 0).
    reflexivity. do 2 constructor. simpl.
  ether_cleanup.
  rewrite par_swap. 2: lia.
  (* Progress with 1 *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
    ether_cleanup.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 1).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 1).
    rewrite par_swap. 2: lia. rewrite nullpool_remove.
  (* Progress with 2 *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
  eapply n_trans. eapply n_arrive with (ι := 2) (ι0 := 1).
    reflexivity. do 2 constructor. simpl.
    ether_cleanup.
  apply n_refl.
Qed.

Example signal_ordering_3 :
  exists acts,
    (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF (ELit "!") [EPid 1; ELit "fst"])
                                        (EBIF (ELit "!") [EPid 2; ELit "snd"]), [], [], false) ||||
                  1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) ||||
                  2 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[ acts ]ₙ->*
    (etherAdd 0 2 (Message (ELit "snd")) (fun _ _ => []),
                  1 : inl ([], ELit "fst", [], [], false) ||||
                  2 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool).
Proof.
  eexists.
  (* Progress with 0 *)
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    constructor. apply step_bif. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 0).
  ether_cleanup.
  rewrite par_swap with (ι := 0) (ι' := 1).
  rewrite par_swap with (ι := 0) (ι' := 2).
  rewrite nullpool_remove. 2-3: lia.
  (* Messages are delivered *)
  eapply n_trans. eapply n_arrive with (ι := 1) (ι0 := 0).
    reflexivity. do 2 constructor. simpl.
  ether_cleanup.
  (* Now 1 can progress *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
  rewrite update_noop with (x := 1) by reflexivity.
  apply n_refl.
Qed.

Example signal_ordering_4 :
  exists acts,
    (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF (ELit "!") [EPid 1; ELit "fst"])
                                        (EBIF (ELit "!") [EPid 2; ELit "snd"]), [], [], false) ||||
                  1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) ||||
                  2 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[ acts ]ₙ->*
    (etherAdd 0 1 (Message (ELit "fst")) (fun _ _ => []),
                  1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) ||||
                  2 : inl ([], ELit "snd", [], [], false) |||| nullpool).
Proof.
  eexists.
  (* Progress with 0 *)
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    constructor. apply step_bif. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor.
  ether_cleanup. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate with (ι := 0).
  ether_cleanup.
  rewrite par_swap with (ι := 0) (ι' := 1).
  rewrite par_swap with (ι := 0) (ι' := 2).
  rewrite nullpool_remove. 2-3: lia.
  rewrite par_swap with (ι := 1) (ι' := 2). 2: lia.
  (* Messages are delivered *)
  eapply n_trans. eapply n_arrive with (ι := 2) (ι0 := 0).
    reflexivity. do 2 constructor.
  ether_cleanup.
  (* Now 2 can progress too *)
  eapply n_trans. eapply n_other.
    apply p_receive; auto. simpl. reflexivity. do 2 right. left. now eexists. cbn.
    break_match_goal. 2: congruence.
  rewrite par_swap with (ι := 1) (ι' := 2). 2: lia.
  apply n_refl.
Qed.

(** Further tests: *)

Goal exists acts,
  (fun _ _ => [], 0 : inl ([], EBIF (ELit "!") [EPid 1; EBIF (ELit "+"%string) [ELit 1%Z; ELit 1%Z]], [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EBIF (ELit "!") [EPid 3;EVar 0])], [], [], false) ||||
       2 : inl ([], EBIF (ELit "!") [EPid 3;ELit 3%Z], [], [], false) ||||
       3 : inl ([], EReceive [(PVar, EReceive [(PVar, EBIF (ELit "+"%string) [EVar 0;EVar 1])])], [], [], false) |||| nullpool)
  -[ acts ]ₙ->*
  (fun _ _ => [], 0 : inl ([], ELit 2%Z, [], [], false) ||||
       1 : inl ([], ELit 2%Z, [], [], false) ||||
       2 : inl ([], ELit 3%Z, [], [], false) ||||
       3 : inl ([], ELit 5%Z, [], [], false) |||| nullpool).
Proof.
  eexists.
  (* Some steps with 0 *)
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 4 constructor. auto.
  simpl. eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  simpl.

  rewrite par_swap with (ι' := 2). rewrite par_swap with (ι' := 2). 2-3: lia.

  (* Some steps with 2 *)
  eapply n_trans. eapply n_other with (ι := 2).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 2).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 2).
    do 3 constructor. auto.
  simpl.

  rewrite par_swap with (ι' := 3). rewrite par_swap with (ι' := 3). 2-3: lia.

  eapply n_trans. eapply n_send with (ι := 2) (ι' := 3).
    constructor. constructor.
  simpl.

  rewrite par_swap with (ι' := 3). 2: lia.
  eapply n_trans. apply n_arrive with (ι0 := 2).
    reflexivity. repeat constructor.
  cbn.

  rewrite par_swap with (ι' := 0). rewrite par_swap with (ι' := 0). 2-3: lia.

  (* Again with 0 *)

  rewrite par_swap with (ι' := 1). rewrite par_swap with (ι' := 1). 2-3: lia.

  eapply n_trans. eapply n_send with (ι := 0) (ι' := 1).
  constructor. constructor. simpl.

  rewrite par_swap with (ι' := 1). 2: lia.
  eapply n_trans. apply n_arrive with (ι0 := 0).
    reflexivity. repeat constructor.
  cbn.

  (* Now with 1 *)
  eapply n_trans. eapply n_other with (ι := 1).
    apply p_receive; try reflexivity. right. right. left. eexists. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.

  cbn. break_match_goal. 2: congruence.
  rewrite par_swap with (ι' := 3). 2: lia.

  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 1) (ι' := 3).
    constructor. constructor. simpl.

  rewrite par_swap with (ι' := 3). 2: lia.

  eapply n_trans. apply n_arrive with (ι0 := 1).
    reflexivity. repeat constructor.
  cbn.

  (* Mailbox processing for 3 *)
  eapply n_trans. eapply n_other with (ι := 3).
    apply p_receive; try reflexivity. right. right. left. eexists. auto. cbn.
  break_match_goal. 2: congruence.
  eapply n_trans. eapply n_other with (ι := 3).
    apply p_receive; try reflexivity. right. right. left. eexists. auto.
    cbn. break_match_goal. 2: congruence.

  eapply n_trans. eapply n_other with (ι := 3).
    constructor. constructor. auto.
  eapply n_trans. eapply n_other with (ι := 3).
    constructor. constructor. constructor. auto.
  eapply n_trans. eapply n_other with (ι := 3).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 3).
    constructor. constructor. auto.

  rewrite par_swap with (ι' := 0). rewrite par_swap with (ι' := 0).
  rewrite par_swap with (ι' := 1). rewrite par_swap with (ι' := 2).

  repeat ether_cleanup.
  apply n_refl.
  all: lia.
Qed.

#[export]
Hint Constructors ValScoped : core.
#[export]
Hint Constructors ExpScoped : core.
(*

let X = spawn(fun() -> receive X -> X ! self() end end, [])
  in let Y = X ! self()
    in receive X -> X end

*)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF (ELit "spawn") [EFun [] (EReceive [(PVar, EBIF (ELit "!") [EVar 0; EBIF (ELit "self") []])]);
                                             ENil])
             (ELet "Y"%string (EBIF (ELit "!") [EVar 0; EBIF (ELit "self") []])
                 (EReceive [(PVar, EVar 0)]))
                  , [], [], false)
  |||| nullpool)
  -[ acts ]ₙ->*
  (fun _ _ => [], 0 : inl ([], EPid 1, [], [], false) ||||
       1 : inl ([], EPid 1, [], [], false) |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    apply p_local. apply step_bif. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 2 constructor; auto.
    do 2 constructor. intros. simpl in H.
    inversion H; subst; cbn. 2: inversion H1.
    constructor. repeat constructor. intros. simpl in H0. inversion H0.
    simpl. repeat constructor. inversion H1.
    inversion H2; subst.
    repeat constructor.
    inversion H4; subst.
    auto.
  eapply n_trans. eapply n_spawn with (ι := 0) (ι' := 1); simpl. 2: reflexivity.
    2: constructor. all: simpl; auto.

  rewrite par_swap with (ι' := 0). 2: lia.

  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  rewrite par_swap with (ι' := 1). 2: lia.

  eapply n_trans. eapply n_other with (ι := 1).
    repeat constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    repeat constructor. simpl. auto.

  rewrite par_swap with (ι' := 0). 2: lia.

  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    repeat constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0) (a := ASelf 0).
    constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0) (ι' := 1).
    constructor. constructor. simpl.
  eapply n_trans. eapply n_other with (ι := 0); cbn; try reflexivity.
    repeat constructor. simpl. auto.

  simpl.
  rewrite par_swap with (ι' := 1). 2: lia.

  eapply n_trans. apply n_arrive with (ι0 := 0).
    reflexivity. repeat constructor.
  cbn.
  eapply n_trans. eapply n_other with (ι := 1).
    apply p_receive; auto; try reflexivity. right. right. left. eexists. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 2 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1) (a := ASelf 1).
    constructor. auto.
  eapply n_trans. eapply n_send with (ι := 1) (ι' := 0).
    constructor. constructor. simpl.

  rewrite par_swap with (ι' := 0). 2: lia.

  eapply n_trans. apply n_arrive with (ι0 := 1).
    reflexivity. repeat constructor.
  eapply n_trans. eapply n_other with (ι := 0).
    apply p_receive; auto. reflexivity. right. right. left. eexists. auto. cbn.
  break_match_goal. 2: congruence.
  cbn. break_match_goal. 2: congruence.
  repeat ether_cleanup.
  apply n_refl.
Qed.

Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELit 2%Z, [], [], false) ||||
       1 : inl ([], ELit 2%Z, [], [], false) ||||
       2 : inl ([], ELit 3%Z, [], [], false) ||||
       3 : inl ([], ELit 5%Z, [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    apply p_terminate; auto. auto.
  eapply n_trans. apply n_terminate.
  simpl.

  rewrite par_swap with (ι := 0) (ι' := 1).
  rewrite par_swap with (ι := 0) (ι' := 2).
  rewrite par_swap with (ι := 0) (ι' := 3). 2-4: lia.
  eapply n_trans. eapply n_other with (ι := 1).
    apply p_terminate; auto. auto.
  eapply n_trans. apply n_terminate.
  simpl.

  rewrite par_swap with (ι := 1) (ι' := 2).
  rewrite par_swap with (ι := 1) (ι' := 3). 2-3: lia.
  eapply n_trans. eapply n_other with (ι := 2).
    apply p_terminate; auto. auto.
  eapply n_trans. apply n_terminate.
  simpl.

  rewrite par_swap with (ι := 2) (ι' := 3). 2: lia.
  eapply n_trans. eapply n_other with (ι := 3).
    apply p_terminate; auto. auto.
  eapply n_trans. apply n_terminate.
  simpl.

  repeat rewrite nullpool_remove.
  apply n_refl.
Qed.

(* trapping kill which comes from link *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF link [EPid 1])
                             (EBIF exit [kill]), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], true) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 1 : inl ([], VCons (EXIT) (VCons (EPid 0) (VCons kill ENil)), [], [0], true)
           |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_link.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    apply p_exit_self. constructor. auto.
  simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_dead.
  simpl.
  eapply n_trans. apply n_terminate.
    rewrite par_swap. rewrite nullpool_remove. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    reflexivity.
    do 2 constructor.
  cbn.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    do 2 constructor.
    eapply p_exit_convert. right. split; auto. now constructor.
  cbn.
  eapply n_trans. eapply n_other with (ι := 1).
    apply p_receive; try reflexivity. do 2 right. left. eexists. reflexivity.
  cbn. break_match_goal. 2: congruence.
  ether_cleanup.
  apply n_refl.
Qed.

(* trapping kill which comes from link, but with 2 parameter exit *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF link [EPid 1])
                             (EBIF exit [EPid 0; kill]), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], true) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 1 : inl ([], VCons (EXIT) (VCons (EPid 0) (VCons killed ENil)), [], [0], true)
           |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_link.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_exit. constructor.
  eapply n_trans. eapply n_arrive with (ι := 0) (ι0 := 0).
    cbn. reflexivity. apply p_exit_terminate. intuition.
  cbn.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_dead.
  simpl. do 4 ether_cleanup.
  eapply n_trans. apply n_terminate.
    rewrite par_swap. rewrite nullpool_remove. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    reflexivity.
    do 2 constructor.
  cbn.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    do 2 constructor.
    eapply p_exit_convert. right. split; auto. now constructor.
  cbn.
  eapply n_trans. eapply n_other with (ι := 1).
    apply p_receive; try reflexivity. do 2 right. left. eexists. reflexivity.
  cbn. break_match_goal. 2: congruence.
  do 4 ether_cleanup.
  apply n_refl.
Qed.

(* kill through link, without traps -> no conversion to killed *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF link [EPid 1])
                             (EBIF exit [kill]), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 1 : inr [(0, kill)]
           |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_link.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    apply p_exit_self. constructor. auto.
  simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_dead.
  simpl.
  eapply n_trans. apply n_terminate.
    rewrite par_swap. rewrite nullpool_remove. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    reflexivity.
    do 2 constructor.
  cbn.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    do 2 constructor.
  eapply p_exit_terminate. right. left. repeat split; auto.
    1-3: intros; try congruence. now constructor.
  cbn.
  ether_cleanup.
  apply n_refl.
Qed.

(* kill sent explicitly, converted to killed *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF link [EPid 1])
                             (ELet "X" (EBIF exit [EPid 1; kill])
                                       (EReceive [(PVar, ENil)])), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 0 : inr [(1, killed)]
           |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_link.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    apply p_exit. constructor.
  simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  simpl.
  rewrite par_swap. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    reflexivity.
    do 2 constructor.
  cbn.
  eapply n_trans. eapply n_arrive with (ι0 := 0).
    reflexivity.
    apply p_exit_terminate. auto.
  cbn.
  eapply n_trans. apply n_send.
    apply p_dead. simpl.
  eapply n_trans. apply n_terminate.
    ether_cleanup.
    rewrite par_swap with (p := None). rewrite nullpool_remove. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 1).
    reflexivity.
    apply p_exit_terminate.
    right. left. intuition; auto. congruence.
  cbn.
  repeat ether_cleanup.
  apply n_refl.
Qed.

(* trapping exits *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], EReceive [(PVar, EBIF exit [EPid 1; ELit "foo"])], [], [], false) ||||
       1 : inl ([], ELet "X" (ELet "X" (EBIF process_flag [trap_exit; tt])
                                       (EBIF send [EPid 0; ENil]))
                             (EReceive [(PVar, EVar 0)]), [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 1 : inl ([], VCons EXIT (VCons (EPid 0) (VCons (ELit "foo") ENil)), [], [], true)
           |||| nullpool).
Proof.
  eexists.
  rewrite par_swap. 2: lia.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    eapply p_set_flag. reflexivity. auto.
  cbn.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 1).
    do 3 constructor. simpl.
  eapply n_trans. eapply n_other with (ι := 1).
    do 3 constructor. auto. simpl.
  rewrite par_swap. 2: lia.
  eapply n_trans. eapply n_arrive with (ι0 := 1).
    reflexivity.
    do 2 constructor.
  cbn.
  eapply n_trans. eapply n_other.
    apply p_receive. 1-2: reflexivity. do 2 right. left. now eexists.
  cbn. break_match_goal. 2: congruence.
  eapply n_trans. eapply n_other.
    do 3 constructor. auto.
  eapply n_trans. eapply n_other.
    do 3 constructor. auto.
  eapply n_trans. eapply n_other.
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send.
    do 3 constructor. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. apply n_terminate.
  rewrite par_swap, nullpool_remove. 2: lia.
  eapply n_trans. apply n_arrive with (ι0 := 0).
    reflexivity.
    apply p_exit_convert. left. split; auto. congruence.
  cbn.
  eapply n_trans. apply n_other.
    apply p_receive. 1-2: reflexivity. do 2 right; left; now eexists.
  cbn. break_match_goal. 2: congruence.
  ether_cleanup.
  apply n_refl.
Qed.

(* explicit exit signal drop *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (EBIF exit [EPid 1; ELit "normal"])
                             (EBIF send [EPid 1; ENil]), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 0 : inl ([], ENil, [], [], false) ||||
       1 : inl ([], ENil, [], [], false) |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other with (ι := 0).
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_send with (ι := 0).
    do 3 constructor. simpl.
  rewrite par_swap. 2: lia.
  eapply n_trans. apply n_arrive with (ι0 := 0).
    do 2 constructor.
    apply p_exit_drop. left. auto.
  cbn.
  eapply n_trans. apply n_arrive with (ι0 := 0).
    do 2 constructor.
    apply p_arrive; constructor.
  cbn.
  eapply n_trans. apply n_other.
    apply p_receive. 1-2: reflexivity. do 2 right; left; now eexists.
  cbn. break_match_goal. 2: congruence.
  rewrite par_swap. 2: lia.
  ether_cleanup.
  apply n_refl.
Qed.

(* implicit exit signal drop *)
Goal exists acts,
  (fun _ _ => [], 0 : inl ([], ELet "X" (ELit 1%Z) (EVar 0), [], [], false) ||||
       1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool)
  -[acts]ₙ->*
  (fun _ _ => [], 1 : inl ([], EReceive [(PVar, EVar 0)], [], [], false) |||| nullpool).
Proof.
  eexists.
  eapply n_trans. eapply n_other.
    do 3 constructor. auto.
  eapply n_trans. eapply n_other.
    do 3 constructor. auto. simpl.
  eapply n_trans. eapply n_other.
    apply p_terminate. constructor. auto.
  eapply n_trans. eapply n_terminate.
  rewrite par_swap, nullpool_remove. 2: lia.
  (* cannot make more steps here *)
  apply n_refl.
Qed.

Close Scope string_scope.


(* This file defines a common storage format for countable types.
This format, SerializedValue, is either a unit/int/bool or a pair/list
of these. We also define Serializable as a type class capturing that a
type can be converted from and to this format. *)

Require Import Monads.
Require Import Containers.
Require Import Automation.
Require Import BoundedN.
From Coq Require Import List.
From Coq Require Import Psatz.
From Coq Require Import ZArith.
From stdpp Require countable.

Import ListNotations.

Inductive SerializedType :=
  | ser_unit : SerializedType
  | ser_int : SerializedType
  | ser_bool : SerializedType
  | ser_pair : SerializedType -> SerializedType -> SerializedType
  | ser_list : SerializedType -> SerializedType.

Module SerializedType.
  Scheme Equality for SerializedType.
  Definition eqb := SerializedType_beq.
  Definition eq_dec := SerializedType_eq_dec.

  Fixpoint eqb_spec (a b : SerializedType) :
    Bool.reflect (a = b) (eqb a b).
  Proof.
    destruct a, b; cbn in *; try (left; congruence); try (right; congruence).
    - destruct (eqb_spec a1 b1), (eqb_spec a2 b2);
        try (left; congruence); try (right; congruence).
    - destruct (eqb_spec a b); try (left; congruence); try (right; congruence).
  Qed.
End SerializedType.

Fixpoint interp_type (t : SerializedType) : Type :=
  match t with
  | ser_unit => unit
  | ser_int => Z
  | ser_bool => bool
  | ser_pair a b => interp_type a * interp_type b
  | ser_list a => list (interp_type a)
  end.

Set Primitive Projections.
Record SerializedValue :=
  build_ser_value {
    ser_value_type : SerializedType;
    ser_value : interp_type ser_value_type;
  }.
Unset Primitive Projections.

Definition extract_ser_value (t : SerializedType) (value : SerializedValue) : option (interp_type t).
Proof.
  destruct value as [ty val].
  destruct (SerializedType.eq_dec t ty).
  - subst. exact (Some val).
  - exact None.
Defined.

(* Defines that a type can be serialized into SerializedValue and deserialized from it,
   and that deserializing is a left inverse of serialziing. *)
Class Serializable (ty : Type) :=
  build_serializable {
    serialize : ty -> SerializedValue;
    deserialize : SerializedValue -> option ty;
    deserialize_serialize x : deserialize (serialize x) = Some x;
  }.

Global Opaque serialize deserialize deserialize_serialize.

Lemma serialize_injective {T : Type} `{Serializable T} x y :
  serialize x = serialize y ->
  x = y.
Proof.
  intros eq.
  enough (Some x = Some y) by congruence.
  rewrite <- 2!deserialize_serialize.
  now rewrite eq.
Qed.

Program Instance unit_serializable : Serializable unit :=
  {| serialize u := build_ser_value ser_unit u;
     deserialize := extract_ser_value ser_unit; |}.
Solve Obligations with reflexivity.

Program Instance int_serializable : Serializable Z :=
  {| serialize i := build_ser_value ser_int i;
     deserialize := extract_ser_value ser_int; |}.
Solve Obligations with reflexivity.

Program Instance bool_serializable : Serializable bool :=
  {| serialize b := build_ser_value ser_bool b;
     deserialize := extract_ser_value ser_bool; |}.
Solve Obligations with reflexivity.

Program Instance nat_serializable : Serializable nat :=
  {| serialize n := serialize (Z.of_nat n);
     deserialize z := do z' <- deserialize z; Some (Z.to_nat z'); |}.
Next Obligation.
  intros x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite Nat2Z.id.
  reflexivity.
Qed.

Program Instance N_serializable : Serializable N :=
  {| serialize n := serialize (Z.of_N n);
     deserialize z := do z' <- deserialize z; Some (Z.to_N z'); |}.
Next Obligation.
  intros x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite N2Z.id.
  reflexivity.
Qed.

Program Instance ser_positive_equivalence : Serializable positive :=
  {| serialize p := serialize (Zpos p);
     deserialize z := do z' <- deserialize z; Some (Z.to_pos z'); |}.
Next Obligation. auto. Qed.

Program Instance ser_value_equivalence : Serializable SerializedValue :=
  {| serialize v := v;
     deserialize v := Some v; |}.
Solve Obligations with reflexivity.

Program Instance BoundedN_equivalence {bound : N} : Serializable (BoundedN bound) :=
  {| serialize bn := serialize (countable.encode bn);
    deserialize v :=
      do p <- (deserialize v : option positive);
      countable.decode p |}.
Next Obligation.
  intros bound x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  now rewrite countable.decode_encode.
Qed.

(* Program Instance generates an insane amount of obligations for sums,
   so we define it by ourselves. *)
Section Sum.
  Context `{Serializable A} `{Serializable B}.

  Definition serialize_sum (v : A + B) :=
    let (is_left, ser) :=
        match v with
        | inl l => (true, serialize l)
        | inr r => (false, serialize r)
        end in
    build_ser_value (ser_pair ser_bool ser.(ser_value_type)) (is_left, ser.(ser_value)).

  Definition deserialize_sum (val : SerializedValue) : option (A + B) :=
    match val with
    | build_ser_value (ser_pair ser_bool v) (is_left, val) =>
      if is_left then
        do a <- deserialize (build_ser_value v val) : option A;
        Some (inl a)
      else
        do b <- deserialize (build_ser_value v val) : option B;
        Some (inr b)
    | _ => None
    end.

  Lemma deserialize_serialize_sum (s : A + B)
    : deserialize_sum (serialize_sum s) = Some s.
  Proof.
    unfold serialize_sum, deserialize_sum.
    destruct s as [a | b]; cbn; rewrite deserialize_serialize; reflexivity.
  Qed.

  Global Instance sum_serializable : Serializable (A + B) :=
    {| serialize := serialize_sum;
       deserialize := deserialize_sum;
       deserialize_serialize := deserialize_serialize_sum; |}.
End Sum.

Section Product.
  Context `{Serializable A} `{Serializable B}.

  Definition serialize_product (pair : A * B) : SerializedValue :=
    let (a, b) := pair in
    let (a_ty, a_val) := serialize a in
    let (b_ty, b_val) := serialize b in
    build_ser_value (ser_pair a_ty b_ty) (a_val, b_val).

  Definition deserialize_product (val : SerializedValue) : option (A * B) :=
    match val with
    | build_ser_value (ser_pair a_ty b_ty) (a_val, b_val) =>
      do a <- deserialize (build_ser_value a_ty a_val) : option A;
      do b <- deserialize (build_ser_value b_ty b_val) : option B;
      Some (a, b)
    | _ => None
    end.

  Lemma deserialize_serialize_product (p : A * B)
        : deserialize_product (serialize_product p) = Some p.
  Proof.
    unfold serialize_product, deserialize_product.
    destruct p.
    repeat rewrite deserialize_serialize.
    reflexivity.
  Qed.

  Global Instance product_serializable : Serializable (A * B) :=
    {| serialize := serialize_product;
       deserialize := deserialize_product;
       deserialize_serialize := deserialize_serialize_product; |}.
End Product.

Section List.
  Context `{Serializable A}.

  Definition serialize_list (l : list A) : SerializedValue :=
    let go a (acc : SerializedValue) :=
        let (a_ty, a_val) := serialize a in
        let (acc_ty, acc_val) := acc in
        build_ser_value (ser_pair a_ty acc_ty) (a_val, acc_val) in
    fold_right go (build_ser_value ser_unit tt) l.

  Definition deserialize_list (val : SerializedValue) : option (list A) :=
    let fix aux (ty : SerializedType) (val : interp_type ty) : option (list A) :=
        match ty, val with
        | ser_pair hd_ty tl_ty, (hd_val, tl_val) =>
          do hd <- deserialize (build_ser_value hd_ty hd_val);
          do tl <- aux tl_ty tl_val;
          Some (hd :: tl)
        | ser_unit, _ => Some []
        | _, _ => None
        end in
    let (ty, uval) := val in
    aux ty uval.

  Lemma deserialize_serialize_list (l : list A)
        : deserialize_list (serialize_list l) = Some l.
  Proof.
    unfold serialize_list, deserialize_list.
    induction l as [| hd tl IHl].
    - reflexivity.
    - cbn in *.
      rewrite IHl; clear IHl.
      rewrite deserialize_serialize.
      reflexivity.
  Qed.

  Global Instance list_serializable : Serializable (list A) :=
    {| serialize := serialize_list;
       deserialize := deserialize_list;
       deserialize_serialize := deserialize_serialize_list; |}.
End List.

Program Instance map_serializable
        `{Serializable A}
        `{countable.Countable A}
        `{Serializable B}
  : Serializable (FMap A B) :=
  {| serialize m := serialize (@FMap.elements A B _ _ m);
     deserialize val :=
       do elems <- deserialize val : option (list (A * B));
       Some (FMap.of_list elems); |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite FMap.of_elements_eq.
  reflexivity.
Qed.

Program Instance set_serializable
        `{Serializable A}
        `{countable.Countable A}
  : Serializable (FMap A unit) :=
  {| serialize s := serialize (@FMap.elements A unit _ _ s);
     deserialize val :=
       do elems <- deserialize val : option (list (A * unit));
       Some (FMap.of_list elems); |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite FMap.of_elements_eq.
  reflexivity.
Qed.

Program Instance option_serializable `{Serializable A} : Serializable (option A) :=
  {| serialize s := serialize
                      match s with
                      | None => inl tt
                      | Some s => inr s
                      end;
     deserialize s := do s <- deserialize s;
                      match s : unit + A with
                      | inl _ => Some None
                      | inr s => Some (Some s)
                      end; |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  destruct x; auto.
Qed.

Ltac make_serializer_case ty :=
  match ty with
  | ?T1 -> ?T2 =>
    let rest := make_serializer_case T2 in
    constr:(fun (f : SerializedValue -> SerializedValue) (v : T1) =>
              rest (fun (cur : SerializedValue) => f (serialize (v, cur))))
  | SerializedValue =>
    constr:(fun (f : SerializedValue -> SerializedValue) => f (serialize tt))
  end.

Ltac make_serializer_aux term tag :=
  match type of term with
  | ?T1 -> (?T2 -> ?T3) =>
    let cs := make_serializer_case T1 in
    let cs := constr:(cs (fun x => serialize (tag, x))) in
    let term := (eval hnf in (term cs)) in
    make_serializer_aux term (S tag)
  | ?T -> SerializedValue =>
    term
  end.

Ltac make_serializer eliminator :=
  let term := (eval hnf in (eliminator (fun _ => SerializedValue))) in
  let serializer := make_serializer_aux term 0 in
  eval cbn in serializer.

Ltac make_deserializer_case ty :=
  match ty with
  | ?T1 -> ?T2 =>
    let rest := make_deserializer_case T2 in
    constr:(fun builder sv =>
              do '(a, sv) <- (deserialize sv : option (T1 * SerializedValue));
              rest (builder a) sv)
  | ?T => constr:(fun (value : T) (sv : SerializedValue) => Some value)
  end.

Ltac make_deserializer_aux ctors rty :=
  match ctors with
  | (?ctor, ?tl) =>
    let ty := type of ctor in
    let cs := make_deserializer_case ty in
    let rest := make_deserializer_aux tl rty in
    constr:(
      fun tag sv =>
        match tag with
        | 0 => cs ctor sv
        | S tag => rest tag sv
        end)
  | tt => constr:(fun (tag : nat) (sv : SerializedValue) => @None rty)
  end.

Ltac get_final_type ty :=
  match ty with
  | ?T1 -> ?T2 => get_final_type T2
  | ?T => T
  end.

Ltac make_deserializer ctors rty :=
  let deser := make_deserializer_aux ctors rty in
  let deser := constr:(fun sv => do '(tag, sv) <- deserialize sv; deser tag sv) in
  eval cbn in deser.

Ltac get_ty_from_elim_ty ty :=
  match ty with
  | forall (_ : ?T -> Type), _ => T
  end.

Ltac make_serializable eliminator ctors :=
  let ser := make_serializer eliminator in
  let elim_ty := type of eliminator in
  let ty := get_ty_from_elim_ty elim_ty in
  let deser := make_deserializer ctors ty in
  exact
    {| serialize := ser;
       deserialize := deser;
       deserialize_serialize :=
         ltac:(intros []; repeat (cbn in *; try rewrite deserialize_serialize; auto)) |}.

Notation "'Derive' 'Serializable' rect" :=
  ltac:(make_serializable rect tt) (at level 0, rect at level 10, only parsing).

Notation "'Derive' 'Serializable' rect < c0 , .. , cn >" :=
  (let pairs := pair c0 .. (pair cn tt) .. in
   ltac:(
     (* This matches last-to-first so it always finds 'pairs' *)
     match goal with
     | [pairs := ?x |- _] => make_serializable rect x
     end))
    (at level 0, rect at level 10, c0, cn at level 9, only parsing).

Section Countable.
  Instance SerializedType_interp_EqDecision
           (t : SerializedType) : stdpp.base.EqDecision (interp_type t).
  Proof. induction t; typeclasses eauto. Defined.
  Instance SerializedType_interp_Countable
           (t : SerializedType) : countable.Countable (interp_type t).
  Proof. induction t; typeclasses eauto. Defined.

  Global Instance SerializedValue_EqDecision : stdpp.base.EqDecision SerializedValue.
  Proof.
    intros x y.
    destruct x as [xt xv], y as [yt yv].
    destruct (SerializedType.eq_dec xt yt) as [<-|?]; [|right; congruence].
    destruct (stdpp.base.decide (xv = yv)).
    - left.
      congruence.
    - right.
      intros eq.
      inversion eq.
      congruence.
  Defined.

  Instance SerializedType_EqDecision : stdpp.base.EqDecision SerializedType.
  Proof.
    intros x y.
    destruct (SerializedType.eq_dec x y) as [<-|?]; [left|right]; easy.
  Defined.
  Fixpoint depth st : nat :=
    match st with
    | ser_unit => 1
    | ser_int => 1
    | ser_bool => 1
    | ser_pair x y => S (max (depth x) (depth y))
    | ser_list x => S (depth x)
    end.
  Local Open Scope positive.
  Fixpoint encode_st_body (st : SerializedType) : positive :=
    match st with
    | ser_unit => countable.encode (1, 1)
    | ser_int => countable.encode (2, 1)
    | ser_bool => countable.encode (3, 1)
    | ser_pair x y => countable.encode (4, countable.encode (encode_st_body x, encode_st_body y))
    | ser_list x => countable.encode (5, encode_st_body x)
    end.
  Definition encode_st (st : SerializedType) : positive :=
    countable.encode (depth st, encode_st_body st).

  Fixpoint decode_st_body (depth : nat) (p : positive) : option SerializedType :=
    match depth with
    | 0%nat => None
    | S depth =>
      do '(tag, body) <- countable.decode p;
      match tag with
      | 1 => ret ser_unit
      | 2 => ret ser_int
      | 3 => ret ser_bool
      | 4 => do '(x, y) <- countable.decode body;
             do x <- decode_st_body depth x;
             do y <- decode_st_body depth y;
             ret (ser_pair x y)
      | 5 => do x <- decode_st_body depth body;
             ret (ser_list x)
      | _ => None
      end
    end.
  Definition decode_st (p : positive) : option SerializedType :=
    do '(depth, body) <- countable.decode p;
    decode_st_body depth body.

  Local Open Scope nat.
  Lemma decode_st_body_encode_st_body (d : nat) (st : SerializedType) :
    depth st <= d ->
    decode_st_body d (encode_st_body st) = Some st.
  Proof.
    revert st.
    induction d; intros st dle; cbn in *.
    - exfalso.
      induction st; cbn in *; lia.
    - destruct st; auto; cbn in *.
      + now rewrite !countable.decode_encode, !IHd by lia.
      + now rewrite !countable.decode_encode, !IHd by lia.
  Qed.

  Lemma decode_st_encode_st (st : SerializedType) :
    decode_st (encode_st st) = Some st.
  Proof.
    unfold decode_st, encode_st.
    rewrite countable.decode_encode; cbn.
    now apply decode_st_body_encode_st_body.
  Qed.

  Local Open Scope positive.
  Instance SerializedType_Countable : countable.Countable SerializedType :=
    {| countable.encode := encode_st;
       countable.decode := decode_st;
       countable.decode_encode := decode_st_encode_st |}.

  Definition encode_sv (sv : SerializedValue) : positive :=
    countable.encode (ser_value_type sv, countable.encode (ser_value sv)).

  Definition decode_sv (p : positive) : option SerializedValue :=
    do '(ty, p) <- countable.decode p;
    do v <- countable.decode p;
    ret {| ser_value_type := ty; ser_value := v |}.

  Lemma decode_sv_encode_sv (sv : SerializedValue) :
    decode_sv (encode_sv sv) = Some sv.
  Proof.
    unfold decode_sv, encode_sv.
    rewrite countable.decode_encode; cbn.
    rewrite countable.decode_encode; cbn.
    reflexivity.
  Qed.

  Global Instance SerializedValue_Countable : countable.Countable SerializedValue :=
    {| countable.encode := encode_sv;
       countable.decode := decode_sv;
       countable.decode_encode := decode_sv_encode_sv |}.

  Global Instance SerializableType_EqDecision
         (A : Type) `{Serializable A} : stdpp.base.EqDecision A.
  Proof.
    intros a a'.
    destruct (stdpp.base.decide (serialize a = serialize a')) as [eq|neq].
    - left.
      now apply serialize_injective.
    - right.
      intros ->.
      congruence.
  Defined.

  Definition encode_serializable_type {A : Type} `{Serializable A} (a : A) : positive :=
    countable.encode (serialize a).

  Definition decode_serializable_type {A : Type} `{Serializable A} (p : positive) : option A :=
    countable.decode p >>= deserialize.

  Lemma decode_serializable_type_encode_serializable_type
        {A : Type} `{Serializable A}
        (a : A) :
    decode_serializable_type (encode_serializable_type a) = Some a.
  Proof.
    unfold decode_serializable_type, encode_serializable_type.
    rewrite countable.decode_encode.
    cbn.
    now rewrite deserialize_serialize.
  Qed.

  Global Instance SerializableType_Countable {A : Type} `{Serializable A} :
    countable.Countable A :=
    {| countable.encode := encode_serializable_type;
       countable.decode := decode_serializable_type;
       countable.decode_encode := decode_serializable_type_encode_serializable_type; |}.
End Countable.


Require Import Category.Main.
Require Import Coq_Cats.Coq_Cat.
Require Import Essentials.HoTT_Facts.

(** The category of Types (Coq's "Type")*)

Program Definition Type_Cat : Category := Coq_Cat hSet.


(** * SHL and SHR instructions *)
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import spec SPred septac spec safe triple basic basicprog spectac.
Require Import instr instrcodec eval monad monadinst reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms.

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

Require Import Relations.
Require Import instrsyntax.

Local Open Scope instr_scope.

Require Import x86.instrrules.core.

(** Lazy man's proof *)
Lemma SmallCount : forall count, count < 32 -> toNat (n:=8) (andB #x"1f" (fromNat count)) = count.
Proof. do 32 case => //.
Qed.

Lemma SHL_RI_rule (r:Reg) (v:DWORD) (count:nat):
  count < 32 ->
  |-- basic (r~=v ** OSZCP?) (SHL r, count)
            (r~=iter count shlB v ** OSZCP?).
Proof.
  change (stateIs r) with (@DWORDorBYTEregIs true r).
  move => BOUND.
  (** We don't want to spin forever if something goes wrong, so we
      only allow [count] to be destructed 5 times.  We do it in the
      middle of the proof to reduce proof term size. *)
  do 5?[do ![ progress instrrule_triple_bazooka using sbazooka
            | progress rewrite (SmallCount BOUND)
            | progress rewrite /stateIsAny ]
       | destruct count as [|count]; rewrite /(iter 0) ?dropmsb_iter_shlB ].
Qed.

Lemma SHR_RI_rule (r:Reg) (v:DWORD) (count:nat):
  count < 32 ->
  |-- basic (r~=v ** OSZCP?) (SHR r, count)
            (r~=iter count shrB v ** OSZCP?).
Proof.
  change (stateIs r) with (@DWORDorBYTEregIs true r).
  move => BOUND.
  (** We don't want to spin forever if something goes wrong, so we
      only allow [count] to be destructed 5 times.  We do it in the
      middle of the proof to reduce proof term size. *)
  do 5?[do ![ progress instrrule_triple_bazooka using sbazooka
            | progress rewrite (SmallCount BOUND)
            | progress rewrite /stateIsAny ]
       | destruct count as [|count]; rewrite /(iter 0) ?droplsb_iter_shrB ].
Qed.


Require Import Raft.
Require Import RaftRefinementInterface.
Require Import CommonDefinitions.
Require Import RefinementCommonDefinitions.

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

  Definition every_entry_was_created (net : network) : Prop :=
    forall e t h l,
      In (t, l) (leaderLogs (fst (nwState net h))) ->
      In e l ->
      term_was_created net (eTerm e).

  Inductive in_any_log (net : network) (e : entry) : Prop :=
  | in_log : forall h, In e (log (snd (nwState net h))) ->
                  in_any_log net e
  | in_aer : forall p es, In p (nwPackets net) ->
                     mEntries (pBody p) = Some es ->
                     In e es ->
                     in_any_log net e
  | in_ll : forall h t ll, In (t, ll) (leaderLogs (fst (nwState net h))) ->
                      In e ll ->
                      in_any_log net e.

  Class every_entry_was_created_interface : Prop :=
    {
      every_entry_was_created_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          every_entry_was_created net ;

      every_entry_was_created_in_any_log_invariant :
        forall net e,
          refined_raft_intermediate_reachable net ->
          in_any_log net e ->
          term_was_created net (eTerm e)
    }.
End EveryEntryWasCreated.


Require Import Coqlib.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Op.

(*Generalizations of some lemmas from Op.v.*)
Section EVAL_INJECT.

Variable F V: Type.
Variable genv: Genv.t F V.
Variable f: meminj.
Hypothesis globals: meminj_preserves_globals genv f.
Variable sp1: block.
Variable sp2: block.
Variable delta: Z.
Hypothesis sp_inj: f sp1 = Some(sp2, delta).

Lemma eval_addressing_inject':
  forall addr vl1 vl2 v1 ofs,
  val_list_inject f vl1 vl2 ->
  eval_addressing genv (Vptr sp1 ofs) addr vl1 = Some v1 ->
  exists v2,
     eval_addressing genv (Vptr sp2 ofs) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some v2
  /\ val_inject f v1 v2.
Proof.
  intros.
  rewrite eval_shift_stack_addressing. simpl.
  eapply eval_addressing_inj with (sp1 := Vptr sp1 ofs); eauto.
  eapply symbol_address_inject; trivial.
Qed.
Lemma eval_operation_inject':
  forall op vl1 vl2 v1 m1 m2 ofs,
  val_list_inject f vl1 vl2 ->
  Mem.inject f m1 m2 ->
  eval_operation genv (Vptr sp1 ofs) op vl1 m1 = Some v1 ->
  exists v2,
     eval_operation genv (Vptr sp2 ofs) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some v2
  /\ val_inject f v1 v2.
Proof.
  intros.
  rewrite eval_shift_stack_operation. simpl.
  eapply eval_operation_inj with (sp1 := Vptr sp1 ofs) (m1 := m1); eauto.
  eapply symbol_address_inject; trivial.
  intros; eapply Mem.valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
  intros; eapply Mem.different_pointers_inject; eauto.
Qed.
End EVAL_INJECT.

Section EVAL_INJECT2.

Variable F V: Type.
Variable genv: Genv.t F V.
Variable f: meminj.
Variable sp1: val.
Variable sp2: val.
Hypothesis sp_inj: val_inject f sp1 sp2 .
Hypothesis PG: meminj_preserves_globals genv f.
Variable vl1: list val.
Variable vl2: list val.
Hypothesis VL: val_list_inject f vl1 vl2.

Lemma eval_operation_inject'':
  forall op v1 m1 m2,
  Mem.inject f m1 m2 ->
  eval_operation genv sp1 op vl1 m1 = Some v1 ->
  exists v2,
     eval_operation genv sp2 op vl2 m2 = Some v2
  /\ val_inject f v1 v2.
Proof.
  intros.
  eapply eval_operation_inj.
  eapply symbol_address_inject; trivial.
  intros; eapply Mem.valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
  intros; eapply Mem.different_pointers_inject; eauto.
  eassumption. eassumption. eassumption.
Qed.

Hypothesis SPVundef: sp1<>Vundef.
Hypothesis SPPtr: forall b ofs, sp1<>Vptr b ofs.

Lemma eval_addressing_sp_scalar:
  forall addr v1,
  eval_addressing genv sp1 addr vl1 = Some v1 ->
  exists v2, eval_addressing genv sp2 addr vl2 = Some v2
             /\ val_inject f v1 v2.
Proof.
  intros.
  destruct addr; destruct vl1; simpl in H; try inv H; simpl; trivial.
    destruct l; inv H1. inv VL. inv H3.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
    destruct l; inv H1. destruct l; inv H0. inv VL. inv H3. inv H5.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
       eapply val_add_inject; eauto.
    destruct l; inv H1. inv VL. inv H3.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
       inv H1; try econstructor.
    destruct l; inv H1. destruct l; inv H0. inv VL. inv H3. inv H5.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
       eapply val_add_inject; eauto.
       inv H2; try econstructor.
    inv VL.
       eexists; split. reflexivity.
         eapply symbol_address_inject; trivial.
    destruct l; inv H1. inv VL. inv H3.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
         eapply symbol_address_inject; trivial.
    destruct l; inv H1. inv VL. inv H3.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
         eapply symbol_address_inject; trivial.
         inv H1; try econstructor.
    inv VL.
       eexists; split. reflexivity.
       eapply val_add_inject; eauto.
Qed.
(*
Hypothesis globals: meminj_preserves_globals genv f.

Lemma eval_operation_inject'':
  forall op vl1 vl2 v1 m1 m2,
  val_list_inject f vl1 vl2 ->
  Mem.inject f m1 m2 ->
  eval_operation genv sp1 op vl1 m1 = Some v1 ->
  exists v2,
     eval_operation genv sp2 op vl2 m2 = Some v2
  /\ val_inject f v1 v2.
Proof.
  intros.
  eapply eval_operation_inj.
  eapply symbol_address_inject; trivial.
  intros; eapply Mem.valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
  intros; eapply Mem.different_pointers_inject; eauto.
  eassumption. eassumption. eassumption.
Qed.
*)
End EVAL_INJECT2.


Parameter Location : Type.
Parameter Pile : Type.
Parameter Robot : Type.
Parameter Crane : Type.
Parameter Container : Type.

Parameter adjacent : Location -> Location -> Prop.
Record RobotAtLocation (L:Location) := {robot1 :> Robot}.
Parameter NotOccupiedLocation : Type.
Axiom notOccupiedLocation : NotOccupiedLocation -> Location.
Coercion notOccupiedLocation : NotOccupiedLocation >-> Location.
Record CraneBelongingTo (L:Location) := {crane1 :> Crane}.
Record RobotLoadedWith (C:Container) := {robot2 :> Robot}.
Record EmptyCraneBelongingTo (L:Location) := {emptyCrane :> CraneBelongingTo L}.
Record CraneHolding(C:Container) := {crane2 :> Crane}.

Definition move3(from:Location)(r:RobotAtLocation from)(to:NotOccupiedLocation)
        (p1:adjacent from to):= RobotAtLocation to.

Definition unload2(c:Container)(l:Location)(k:EmptyCraneBelongingTo l)
        (r:RobotAtLocation l) := CraneHolding c.

Variable l1 : Location.
Variable l2 : NotOccupiedLocation.
Variable l1AdjacentL2 : adjacent l1 l2.
Variable r : RobotAtLocation l1.
Variable rAtTo : move3 l1 r l2 l1AdjacentL2.

Variable k2 : EmptyCraneBelongingTo l2.
Variable c : Container.
Variable kHoldingC : unload2 c l2 k2 rAtTo.

Variable kHoldingC1 : unload2 c l1 k2 rAtTo.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^256 - 4294968273
Base: 28 + 4/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 28 + 4/9;
    bitwidth := 64;
    s := 2^256;
    c := [(1, 4294968273)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.