(* ** Reduction from PCP to semantic entailment in finite ZF *)

Require Import Undecidability.FOL.ZF.
Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Sets.ZF.
Require Undecidability.FOL.Sets.Models.HF_model.
Require Import Lia.

From Undecidability.PCP Require Import PCP Util.PCP_facts Reductions.PCPb_iff_dPCPb.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations ListAutomationHints.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* ** Reduction function *)

Local Definition BSRS := list(card bool).

Fixpoint shift n x :=
  match n with
  | O => x
  | S n => subst_term ↑ (shift n x)
  end.

Definition sing a :=
  {a; a}.

Definition opair a b :=
  {{a; a}; {a; b}}.

Definition pairing f A :=
  ∀ $0 ∈ shift 1 f → ∃ ∃ $1 ∈ shift 3 A ∧ $2 ≡ opair $1 $0.

Definition function' f A :=
  pairing f A ∧ ∀ ∃ $0 ∈ shift 2 A ∧ opair $0 $1 ∈ shift 2 f
                    ∧ ∀ opair $1 $0 ∈ shift 2f → $2 ≡ $0.

Definition function f :=
  ∀ ∀ ∀ opair $2 $1 ∈ shift 3 f → opair $2 $0 ∈ shift 3 f → $1 ≡ $0.

Definition enc_bool (x : bool) :=
  if x then {∅; ∅} else ∅.

Fixpoint prep_string (s : string bool) a :=
  match s with
  | nil => a
  | b::s => opair (enc_bool b) (prep_string s a)
  end.

Definition enc_string (s : string bool) :=
  prep_string s ∅.

Fixpoint enc_stack (B : BSRS) :=
  match B with
  | nil => ∅
  | (s,t)::B => enc_stack B ∪ sing (opair (enc_string s) (enc_string t))
  end.

Definition is_rep phi a b :=
  ∀ $0 ∈ shift 1 b ↔ ∃ $0 ∈ shift 2 a ∧ phi.

Definition comb_rel s t :=
  ∃ ∃ $2 ≡ opair $0 $1 ∧ $3 ≡ opair (prep_string s $0) (prep_string t $1).

Fixpoint combinations (B : BSRS) a b :=
  match B with
  | nil => b ≡ ∅
  | (s,t)::B => ∃ ∃ shift 2 b ≡ $0 ∪ $1 ∧ combinations B (shift 2 a) $1
                   ∧ is_rep (comb_rel s t) (shift 2 a) $0
  end.

Definition solutions (B : BSRS) f n :=
  opair ∅ (enc_stack B) ∈ f ∧ ∀ ∀ ∀ $2 ∈ shift 3 n → opair $2 $1 ∈ shift 3 f
               → combinations B $1 $0 → opair (σ $2) $0 ∈ shift 3 f.

Definition transitive t :=
  ∀ $0 ∈ shift 1 t → $0 ⊆ shift 1 t.

Definition htransitive t :=
  transitive t ∧ ∀ $0 ∈ shift 1 t → transitive $0.

Definition solvable (B : BSRS) :=
  ∃ ∃ ∃ ∃ htransitive $3 ∧ function $2 ∧ solutions B $2 $3 ∧ opair $3 $0 ∈ $2 ∧ opair $1 $1 ∈ $0.

Lemma bool_bound b n :
  bounded_t n (enc_bool b).
Proof.
  destruct b; repeat solve_bounds.
Qed.

Lemma prep_string_bound s t n :
  bounded_t n t -> bounded_t n (prep_string s t).
Proof.
  intros Ht. induction s; cbn; trivial.
  repeat solve_bounds; trivial.
  all: apply bool_bound.
Qed.

Lemma string_bound s n :
  bounded_t n (enc_string s).
Proof.
  apply prep_string_bound. solve_bounds.
Qed.

Lemma stack_bound B n :
  bounded_t n (enc_stack B).
Proof.
  induction B as [|[s t] B IH]; cbn; repeat solve_bounds; trivial.
  all: apply string_bound.
Qed.

Lemma combinations_bound (B : BSRS) n k l :
  n > 2 + l -> n > 4 + k -> bounded n (combinations B $k $l).
Proof.
  revert n k l. induction B as [|[s t] B IH]; cbn; intros n k l H1 H2; solve_bounds.
  apply IH; lia. all: apply prep_string_bound; solve_bounds.
Qed.

Lemma solvabe_bound B :
  bounded 0 (solvable B).
Proof.
  repeat solve_bounds.
  - apply stack_bound.
  - apply combinations_bound; lia.
Qed.

Import HF_model.

Section ZF.

  Context { V : Type }.
  Context { M : interp V }.

  Hypothesis M_ZF : forall rho, rho ⊫ HF.
  Hypothesis VIEQ : extensional M.

  Notation binunion_el := (@binunion_el _ _ M_ZF VIEQ).
  Notation sing_el := (@sing_el _ _ M_ZF VIEQ).
  Notation M_pair := (@M_pair _ _ M_ZF VIEQ).
  Notation opair_inj := (@opair_inj _ _ M_ZF VIEQ).
  Notation binunion_com := (@binunion_com _ _ M_ZF VIEQ).
  Notation binunion_assoc := (@binunion_assoc _ _ M_ZF VIEQ).
  Notation sigma_el := (@sigma_el _ _ M_ZF VIEQ).
  Notation sigma_eq := (@sigma_eq _ _ M_ZF VIEQ).
  Notation numeral_inj := (@numeral_inj _ _ M_ZF VIEQ).
  Notation M_ext := (@M_ext _ _ M_ZF VIEQ).
  Notation M_eset := (@M_eset _ _ M_ZF VIEQ).
  Notation numeral_htrans := (@numeral_htrans _ _ M_ZF VIEQ).
  Notation binunion_eset := (@binunion_eset _ _ M_ZF VIEQ).

  (* ** Encodings *)

  (* Encodings of booleans, strings, cards, and stacks *)

  Definition M_enc_bool (x : bool) :=
    if x then {∅; ∅} else ∅.

  Fixpoint M_prep_string (s : string bool) x :=
    match s with
    | nil => x
    | b::s => M_opair (M_enc_bool b) (M_prep_string s x)
    end.

  Definition M_enc_string (s : string bool) :=
    M_prep_string s ∅.

  Definition M_enc_card s t :=
    M_opair (M_enc_string s) (M_enc_string t).

  Fixpoint M_enc_stack (B : BSRS) :=
    match B with
    | nil => ∅
    | (s,t)::B => M_enc_stack B ∪ M_sing (M_enc_card s t)
    end.

  (* Injectivity of encodings *)

  Lemma enc_bool_inj b c :
    M_enc_bool b = M_enc_bool c -> b = c.
  Proof using M_ZF VIEQ.
    destruct b, c; trivial; cbn.
    - intros H. contradiction (@M_eset ∅).
      pattern ∅ at 2. rewrite <- H. apply M_pair; auto.
    - intros H. contradiction (@M_eset ∅).
      pattern ∅ at 2. rewrite H. apply M_pair; auto.
  Qed.

  Lemma enc_string_inj s t :
    M_enc_string s = M_enc_string t -> s = t.
  Proof using M_ZF VIEQ.
    induction s in t|-*; destruct t as [|b t]; cbn; trivial.
    - intros H. contradiction (M_eset (x:=M_sing (M_enc_bool b))).
      rewrite H. apply M_pair. now left.
    - intros H. contradiction (M_eset (x:=M_sing (M_enc_bool a))).
      rewrite <- H. apply M_pair. now left.
    - intros [H1 H2] % opair_inj. apply IHs in H2 as ->.
      apply enc_bool_inj in H1 as ->. reflexivity.
  Qed.

  (* Agreement to syntactical encodings under evaluation *)

  Lemma eval_opair rho x y :
    eval rho (opair x y) = M_opair (eval rho x) (eval rho y).
  Proof using M_ZF VIEQ.
    reflexivity.
  Qed.

  Lemma eval_enc_bool rho b :
    eval rho (enc_bool b) = M_enc_bool b.
  Proof using M_ZF VIEQ.
    destruct b; reflexivity.
  Qed.

  Lemma eval_prep_string rho s x :
    eval rho (prep_string s x) = M_prep_string s (eval rho x).
  Proof using M_ZF VIEQ.
    induction s; trivial. cbn [prep_string].
    now rewrite eval_opair, IHs, eval_enc_bool.
  Qed.

  Lemma eval_enc_string rho s :
    eval rho (enc_string s) = M_enc_string s.
  Proof using M_ZF VIEQ.
    unfold enc_string. now rewrite eval_prep_string.
  Qed.

  Lemma eval_enc_stack rho B :
    eval rho (enc_stack B) = M_enc_stack B.
  Proof using M_ZF VIEQ.
    induction B; cbn; trivial. destruct a. unfold M_enc_card.
    now rewrite <- IHB, <- !eval_enc_string with (rho:=rho), <- eval_opair.
  Qed.

  (* Auxiliary lemmas for stack encodings *)

  Lemma M_enc_stack_app A B :
    M_enc_stack (A ++ B) = M_enc_stack A ∪ M_enc_stack B.
  Proof using M_ZF VIEQ.
    induction A as [|[s t] A IH]; cbn.
    - apply binunion_eset.
    - rewrite IH. rewrite !binunion_assoc.
      now rewrite (binunion_com (M_enc_stack B) (M_sing (M_enc_card s t))).
  Qed.

  Lemma enc_stack_el' x A :
    x ∈ M_enc_stack A -> exists s t, (s, t) el A /\ x = M_enc_card s t.
  Proof using M_ZF VIEQ.
    induction A as [|[s t] A IH]; cbn.
    - now intros H % M_eset.
    - intros [H|H] % binunion_el.
      + destruct (IH H) as (u&v&H'&->). exists u, v. intuition.
      + apply sing_el in H as ->. exists s, t. intuition.
  Qed.

  Lemma enc_stack_el B s t :
    (s, t) el B -> M_enc_card s t ∈ M_enc_stack B.
  Proof using M_ZF VIEQ.
    induction B as [|[u b] B IH]; cbn; auto.
    intros [H|H]; apply binunion_el.
    - right. apply sing_el. congruence.
    - left. apply IH, H.
  Qed.

  Lemma M_prep_enc s s' :
    M_prep_string s (M_enc_string s') = M_enc_string (s ++ s').
  Proof using M_ZF VIEQ.
    induction s; cbn; trivial.
    now rewrite IHs.
  Qed.

  (* ** Preservation direction *)

  (*
     We encode the k-step solutions of a PCP instance B as a set-theoretic function M_enc_derivations.
     This function satisfies the conditions expressed in the reduction formula and
     contains a solution whenever B is solvable.
   *)

  Definition append_all A (c : card bool) :=
    map (fun p => (fst c ++ fst p, snd c ++ snd p)) A.

  Definition derivation_step B C :=
    flat_map (append_all C) B.

  Fixpoint derivations B n :=
    match n with
    | O => B
    | S n => derivation_step B (derivations B n)
    end.

  Lemma derivable_derivations B s t :
    derivable B s t -> exists n, (s, t) el derivations B n.
  Proof.
    induction 1.
    - exists 0. apply H.
    - destruct IHderivable as [n Hn]. exists (S n).
      apply in_flat_map. exists (x, y). split; trivial.
      apply in_map_iff. exists (u,v). cbn. split; trivial.
  Qed.

  Fixpoint M_enc_derivations B n :=
    match n with
    | O => M_sing (M_opair ∅ (M_enc_stack B))
    | S n => M_enc_derivations B n ∪
            M_sing (M_opair (numeral (S n)) (M_enc_stack (derivations B (S n))))
    end.

  Lemma enc_derivations_base B n :
    M_opair ∅ (M_enc_stack B) ∈ M_enc_derivations B n.
  Proof using M_ZF VIEQ.
    induction n; cbn.
    - now apply sing_el.
    - apply binunion_el. now left.
  Qed.

  Lemma enc_derivations_bound B n k x :
    M_opair k x ∈ M_enc_derivations B n -> k ∈ σ (numeral n).
  Proof using M_ZF VIEQ.
    induction n; cbn.
    - intros H % sing_el. apply opair_inj in H as [-> _].
      apply sigma_el. now right.
    - intros [H|H] % binunion_el.
      + apply sigma_el. left. apply IHn, H.
      + apply sing_el in H. apply opair_inj in H as [-> _]. apply sigma_eq.
  Qed.

  Lemma enc_derivations_fun B n :
    forall k x y, M_opair k x ∈ M_enc_derivations B n -> M_opair k y ∈ M_enc_derivations B n -> x = y.
  Proof using M_ZF VIEQ.
    induction n; cbn -[derivations]; intros k x y.
    - intros H1 % sing_el H2 % sing_el.
      rewrite <- H2 in H1. now apply opair_inj in H1.
    - intros [H1|H1 % sing_el] % binunion_el [H2|H2 % sing_el] % binunion_el.
      + now apply (IHn k x y).
      + exfalso. apply enc_derivations_bound in H1.
        destruct (opair_inj H2) as [-> _]. now apply (@numeral_wf _ _ M_ZF VIEQ (S n)).
      + exfalso. apply enc_derivations_bound in H2.
        destruct (opair_inj H1) as [-> _]. now apply (@numeral_wf _ _ M_ZF VIEQ (S n)).
      + rewrite <- H2 in H1. now apply opair_inj in H1.
  Qed.

  Lemma enc_derivations_el B n k x :
    M_opair k x ∈ M_enc_derivations B n -> exists l, k = numeral l /\ x = M_enc_stack (derivations B l).
  Proof using M_ZF VIEQ.
    induction n; cbn.
    - intros H % sing_el. exists 0. apply (opair_inj H).
    - intros [H|H] % binunion_el.
      + apply IHn, H.
      + apply sing_el in H. exists (S n). apply (opair_inj H).
  Qed.

  Lemma enc_derivations_step B n l :
    numeral l ∈ numeral n
    -> M_opair (σ (numeral l)) (M_enc_stack (derivations B (S l))) ∈ M_enc_derivations B n.
  Proof using M_ZF VIEQ.
    induction n; cbn -[derivations].
    - now intros H % M_eset.
    - intros [H|H % sing_el] % binunion_el; apply binunion_el.
      + left. apply IHn, H.
      + right. apply numeral_inj in H as ->. now apply sing_el.
  Qed.

  Lemma enc_stack_combinations B rho C x X Y :
    rho ⊨ combinations B X Y -> eval rho X = M_enc_stack C -> eval rho Y = x -> x = M_enc_stack (derivation_step B C).
  Proof using M_ZF VIEQ.
    induction B as [|[s t] B IH] in rho,C,x,X,Y |-*.
    - cbn. rewrite VIEQ. now intros -> _ <-.
    - intros [x1[x2[[H1 H2]H3]]] R1 R2; fold sat in *.
      assert (x = x2 ∪ x1) as ->. { rewrite <- R2. cbn in H1. rewrite !eval_comp in H1. apply VIEQ, H1. } clear H1.
      cbn. fold (derivation_step B C). rewrite M_enc_stack_app.
      enough (x1 = M_enc_stack (derivation_step B C)) as E1.
      + enough (x2 = M_enc_stack (append_all C (s, t))) as E2 by now rewrite E1, E2.
        apply M_ext; intros u Hu.
        * apply H3 in Hu as [v [Hv[a [b Ha]]]].
          cbn in Hv. erewrite !eval_comp, eval_ext, R1 in Hv; trivial.
          apply enc_stack_el' in Hv as (s'&t'&H&H').
          enough (u = M_enc_card (s++s') (t++t')) as ->.
          { apply enc_stack_el. apply in_map_iff. now exists (s', t'). }
          cbn in Ha. rewrite !VIEQ in Ha. destruct Ha as [D1 D2].
          rewrite D1 in H'. unfold M_enc_card in H'. apply opair_inj in H' as [-> ->].
          rewrite D2; unfold M_enc_card, M_opair; repeat f_equal.
          all: rewrite eval_prep_string; cbn. all: apply M_prep_enc.
        * apply enc_stack_el' in Hu as (s'&t'&H&->).
          unfold append_all in H. eapply in_map_iff in H as [[a b][H H']].
          cbn in H. apply H3. exists (M_enc_card a b). split.
          { cbn. erewrite !eval_comp, eval_ext, R1; trivial. now apply enc_stack_el. }
          exists (M_enc_string b), (M_enc_string a). split.
          -- cbn. apply VIEQ. reflexivity.
          -- cbn. apply VIEQ. rewrite !eval_prep_string. cbn.
             rewrite !M_prep_enc. injection H. intros -> ->. reflexivity.
      + eapply IH; eauto. unfold shift. now erewrite !eval_comp, eval_ext, R1.
  Qed.

  Lemma enc_derivations_solutions B n rho a b :
    (a .: b .: M_enc_derivations B n .: numeral n .: rho) ⊨ solutions B $2 $3.
  Proof using M_ZF VIEQ.
    cbn. split.
    - rewrite eval_enc_stack. apply enc_derivations_base.
    - intros k x x' H1 H2 H3.
      destruct (enc_derivations_el H2) as [l[-> ->]].
      specialize (enc_derivations_step B H1).
      replace (M_enc_stack (derivations B (S l))) with x'; trivial.
      apply (enc_stack_combinations H3); trivial.
  Qed.

  Lemma derivations_enc_derivations B n :
    M_opair (numeral n) (M_enc_stack (derivations B n)) ∈ M_enc_derivations B n.
  Proof using M_ZF VIEQ.
    induction n; cbn -[derivations].
    - now apply sing_el.
    - apply binunion_el. right.
      now apply sing_el.
  Qed.

  Lemma derivations_el B n s t :
    (s, t) el derivations B n -> M_enc_card s t ∈ M_enc_stack (derivations B n).
  Proof using M_ZF VIEQ.
    apply enc_stack_el.
  Qed.

  Theorem PCP_HF1 B s :
    derivable B s s -> forall rho, rho ⊨ solvable B.
  Proof using M_ZF VIEQ.
    intros H rho. destruct (derivable_derivations H) as [n Hn]. unfold solvable.
    exists (numeral n), (M_enc_derivations B n), (M_enc_string s), (M_enc_stack (derivations B n)).
    split; [split; [split; [split |] |] |].
    - apply numeral_htrans.
    - unfold function'. intros k x y H1 H2. apply VIEQ. apply (enc_derivations_fun H1 H2).
    - apply enc_derivations_solutions.
    - cbn. apply derivations_enc_derivations.
    - now apply enc_stack_el.
  Qed.

  (* ** Reflection direction *)

  (*
    Conversely, we show how to reconstruct a solution of a PCP instance B from a model
    (1) satisfying the reduction formula defined above and
    (2) containing only the standard natural numers.
    The latter seems necessary to exclude non-standard solutions the model might contain.
   *)

  Definition M_comb_rel s t :=
    fun u v => exists u1 u2, u = M_opair u1 u2 /\ v = M_opair (M_prep_string s u1) (M_prep_string t u2).

  Fixpoint M_combinations B x y :=
    match B with
    | nil => y = ∅
    | (s,t)::B => exists y1 y2, y = y2 ∪ y1 /\ M_combinations B x y1 /\ M_is_rep (M_comb_rel s t) x y2
    end.

  Lemma M_combinations_spec B rho x y a b :
    M_combinations B x y -> eval rho a = x -> eval rho b = y -> rho ⊨ combinations B a b.
  Proof using M_ZF VIEQ.
    induction B in y,a,b,rho|-*; cbn.
    - rewrite VIEQ. now intros -> _ ->.
    - destruct a0 as [s t]. intros (y1&y2&H1&H2&H3) Ha Hb. exists y1, y2. repeat split.
      + cbn. apply VIEQ. erewrite !eval_comp. unfold funcomp. cbn.
        change (eval (fun x => rho x) b) with (eval rho b). now rewrite Hb.
      + eapply (IHB _ y1); trivial. erewrite !eval_comp. unfold funcomp. cbn.
        change (eval (fun x => rho x) a) with (eval rho a). now rewrite Ha.
      + intros (u & Hu & c & d' & H) % H3. exists u. split.
        * cbn. erewrite !eval_comp. erewrite eval_ext, Ha; trivial.
        * exists d', c. cbn. rewrite !VIEQ, !eval_prep_string. apply H.
      + intros (u & Hu & c & d' & H). apply H3. exists u. split.
        * cbn in Hu. erewrite !eval_comp in Hu. rewrite <- Ha. apply Hu.
        * exists d', c. cbn in H. rewrite !VIEQ, !eval_prep_string in H. apply H.
  Qed.

  Definition M_solutions B f n :=
    M_opair ∅ (M_enc_stack B) ∈ f /\ forall k x y, k ∈ n -> M_opair k x ∈ f -> M_combinations B x y -> M_opair (σ k) y ∈ f.

  Lemma comb_rel_rep C s t :
    M_is_rep (M_comb_rel s t) (M_enc_stack C) (M_enc_stack (append_all C (s, t))).
  Proof using M_ZF VIEQ.
    intros y. split.
    - intros (u&v&H&->) % enc_stack_el'.
      unfold append_all in H. apply in_map_iff in H as [[a b][H1 H2]]. cbn in H1.
      exists (M_enc_card a b). split; try now apply enc_stack_el.
      exists (M_enc_string a), (M_enc_string b). split; trivial.
      assert (u = s++a) as -> by congruence. assert (v = t++b) as -> by congruence.
      now rewrite !M_prep_enc.
    - intros (u&H&a&b&->&->). apply enc_stack_el' in H as [u[v[H1 H2]]].
      apply opair_inj in H2 as [-> ->]. rewrite !M_prep_enc. apply enc_stack_el.
      apply in_map_iff. now exists (u, v).
  Qed.

  Lemma M_combinations_step B C :
    M_combinations B (M_enc_stack C) (M_enc_stack (derivation_step B C)).
  Proof using M_ZF VIEQ.
    induction B as [|[s t] B IH]; cbn; trivial.
    exists (M_enc_stack (derivation_step B C)), (M_enc_stack (append_all C (s, t))).
    rewrite M_enc_stack_app. split; trivial. split; trivial.
    apply comb_rel_rep.
  Qed.

  Lemma solutions_derivations B f n k :
    M_solutions B f (numeral n) -> k <= n -> M_opair (numeral k) (M_enc_stack (derivations B k)) ∈ f.
  Proof using M_ZF VIEQ.
    intros H Hk; induction k; cbn.
    - apply H.
    - assert (Hk' : k <= n) by lia. specialize (IHk Hk').
      destruct H as [_ H]. eapply H in IHk; eauto.
      + now apply numeral_lt.
      + apply M_combinations_step.
  Qed.

  Lemma derivations_derivable B n s t :
    (s, t) el derivations B n -> derivable B s t.
  Proof using M_ZF VIEQ.
    induction n in s,t|-*; cbn.
    - now constructor.
    - unfold derivation_step. intros [[u v][H1 H2]] % in_flat_map.
      unfold append_all in H2. apply in_map_iff in H2 as [[a b][H2 H3]]. cbn in H2.
      assert (s = u++a) as -> by congruence. assert (t = v++b) as -> by congruence.
      constructor 2; trivial. apply IHn, H3.
  Qed.

  Definition M_function f :=
    forall x y y', M_opair x y ∈ f -> M_opair x y' ∈ f -> y = y'.

  Lemma M_solutions_el B f k X p :
    standard M -> htrans k -> M_function f -> M_solutions B f k -> M_opair k X ∈ f
    -> p ∈ X -> exists u v, p = M_enc_card u v /\ derivable B u v.
  Proof using M_ZF VIEQ.
    intros HS HO Hf Hk HX Hp. destruct (HS k HO) as [n -> % VIEQ].
    pose proof (H := solutions_derivations Hk (le_n n)).
    rewrite (Hf _ _ _ HX H) in Hp. apply enc_stack_el' in Hp as (s&t&H'&->).
    exists s, t. split; trivial. eapply derivations_derivable; eauto.
  Qed.

  Theorem PCP_HF2 B rho :
    standard M -> rho ⊨ solvable B -> exists s, derivable B s s.
  Proof using M_ZF VIEQ.
    intros VIN (n & f & s & X & [[[[H1 H2] H3] H4] H5]).
    assert (H1' : htrans n) by apply H1. clear H1.
    assert (H4' : M_opair n X ∈ f) by apply H4. clear H4.
    assert (H5' : M_opair s s ∈ X) by apply H5. clear H5.
    assert (H2' : M_function f).
    { intros x y y' H H'. apply VIEQ. eapply H2. apply H. apply H'. } clear H2.
    assert (H3' : M_opair ∅ (M_enc_stack B) ∈ f).
    { erewrite <- eval_enc_stack. apply H3. } destruct H3 as [_ H3].
    assert (H3'' : forall k x y, k ∈ n -> M_opair k x ∈ f -> M_combinations B x y -> M_opair (σ k) y ∈ f).
    { intros k x y Hn Hk Hy. apply (H3 k x y); auto. fold sat. eapply M_combinations_spec; eauto. } clear H3.
    destruct (@M_solutions_el B f n X (M_opair s s)) as (u&v&H1&H2); trivial.
    now split. exists u. apply opair_inj in H1 as [H ->]. apply enc_string_inj in H as ->. apply H2.
  Qed.

End ZF.

(* ** Reduction Theorem *)

Theorem PCP_HF B :
  (exists V (M : interp V), extensional M /\ standard M /\ forall rho, rho ⊫ HF)
  -> PCPb B <-> entailment_HF (solvable B).
Proof.
  intros HZF. rewrite PCPb_iff_dPCPb. split; intros H.
  - clear HZF. destruct H as [s H]. intros M HM rho H1 H2. eapply PCP_HF1; eauto.
  - destruct HZF as (M & H1 & H2 & H3 & H4).
    specialize (H M H1 (fun _ => @i_func _ _ _ _ eset Vector.nil) H2 H4).
    apply PCP_HF2 in H as [s Hs]; trivial. now exists s.
Qed.


Require Import floyd.proofauto.
Require Import progs.evenodd.
Local Open Scope logic.

Inductive repr : Z -> val -> Prop :=
| mk_repr : forall z, z >= 0 -> repr z (Vint (Int.repr z)).

Lemma repr0_not_odd z n :
  repr z (Vint n) -> Int.eq n (Int.repr 0) = true -> Z.odd z = false.
Proof.
inversion 1; subst; intros A.
symmetry in A; apply binop_lemmas.int_eq_true in A.
rewrite A in H; inv H.
rewrite Int.Z_mod_modulus_eq, Zmod_divides in H0.
destruct H0 as [c H0]; rewrite H0, Z.odd_mul; auto.
unfold Int.modulus; simpl; intro Contra; inv Contra.
Qed.

Lemma repr0_even z n :
  repr z (Vint n) -> Int.eq n (Int.repr 0) = true -> Z.even z = true.
Proof.
inversion 1; subst; intros A.
symmetry in A; apply binop_lemmas.int_eq_true in A.
rewrite A in H; inv H.
rewrite Int.Z_mod_modulus_eq, Zmod_divides in H0.
destruct H0 as [c H0]; rewrite H0, Z.even_mul; auto.
unfold Int.modulus; simpl; intro Contra; inv Contra.
Qed.

Lemma repr_eq0_not0 z :
  Int.eq (Int.repr z) (Int.repr 0) = false -> z <> 0.
Proof.
intros H; generalize (Int.eq_spec (Int.repr z) (Int.repr 0)); rewrite H.
intros H2 H3; rewrite H3 in H2; apply H2; auto.
Qed.

Definition odd_spec :=
 DECLARE _odd
  WITH sh : share, z : Z, v : val
  PRE [ _n OF tuint] PROP(repr z v) LOCAL (`(eq v) (eval_id _n)) SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.odd z then Int.one else Int.zero))) retval).

Definition even_spec :=
 DECLARE _even
  WITH z : Z, v : val
  PRE [ _n OF tuint] PROP(repr z v) LOCAL (`(eq v) (eval_id _n)) SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.even z then Int.one else Int.zero))) retval).

Definition main_spec :=
 DECLARE _main
  WITH z : Z, v : val
  PRE [ ] PROP(repr 42 v) LOCAL () SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.even 42 then Int.one else Int.zero))) retval).

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=
     ltac:(with_library prog [ odd_spec; even_spec; main_spec]).

Lemma body_odd : semax_body Vprog Gprog f_odd odd_spec.
Proof.
start_function.
name n _n.
forward_if (PROP (repr z v /\ z > 0) LOCAL (`(eq v) (eval_id _n)) SEP ()).
* forward; eapply repr0_not_odd in H0; eauto; rewrite H0; entailer.
* forward; entailer; inv H.
  assert (z <> 0) by (apply repr_eq0_not0; auto); entailer.
* forward_call (z-1,Vint (Int.sub (Int.repr z) (Int.repr 1))).
  entailer; inversion H; subst z0; rewrite <-H5 in H2; inversion H2; subst n.
  entailer.
  assert (repr (z - 1) (Vint (Int.repr (z - 1)))).
  { clear -H H1. inv H. constructor. omega. }
  entailer!.
  after_call; forward.
  rewrite Z.even_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
   destruct (Z.even z); simpl; congruence.
Qed.

Lemma body_even : semax_body Vprog Gprog f_even even_spec.
Proof.
start_function.
name n _n.
forward_if (PROP (repr z v /\ z > 0) LOCAL (`(eq v) (eval_id _n)) SEP ()).
* forward. eapply repr0_even in H0; eauto; rewrite H0; entailer.
* forward; entailer; inv H.
  assert (z <> 0) by (apply repr_eq0_not0; auto); entailer.
* forward_call (Share.top,z-1,Vint (Int.sub (Int.repr z) (Int.repr 1))).
  entailer; inversion H; subst z0; rewrite <-H5 in H2; inversion H2; subst n.
  entailer.
  assert (repr (z - 1) (Vint (Int.repr (z - 1)))).
  { clear -H H1. inv H. constructor. omega. }
  entailer!.
  after_call; forward.
  rewrite Z.odd_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
   destruct (Z.even z); simpl; congruence.
Qed.

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof with (try solve[entailer!|entailer!; constructor; omega]).
start_function.
forward_call (42,Vint (Int.repr 42))... after_call.
forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_odd.
semax_func_cons body_even.
semax_func_cons body_main.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationUtil.

Lemma ofForm_valid : ofForm_obligation.
Proof.
prepare.
intros G a m ext0 H.
eapply tr_equal_formation; eauto.
eapply tr_inhabitation_formation; eauto.
Qed.

Lemma ofEq_valid : ofEq_obligation.
Proof.
prepare.
intros G a b m n ext1 ext0 Hab Hmn.
eapply tr_equal_formation; eauto.
Qed.

Lemma ofFormUniv_valid : ofFormUniv_obligation.
Proof.
prepare.
intros G a i m ext1 ext0 Ha Hm.
apply tr_equal_formation_univ; eauto.
Qed.

Lemma ofEqUniv_valid : ofEqUniv_obligation.
Proof.
prepare.
intros G a b i m n ext1 ext0 Hab Hmn.
apply tr_equal_formation_univ; eauto.
Qed.

Lemma ofIntro_valid : ofIntro_obligation.
Proof.
prepare.
intros G a m ext0 H.
auto.
Qed.

Lemma ofElim_valid : ofElim_obligation.
Proof.
prepare.
intros G a m p ext0 H.
auto.
Qed.

Lemma ofTrivialize_valid : ofTrivialize_obligation.
Proof.
prepare.
intros G a m ext0 H.
auto.
Qed.

Lemma ofExt_valid : ofExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a m p q ext1 ext0 Hp Hq.
autorewrite with prepare in * |- *.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_transitivity _ _ triv).
  {
  apply tr_equal_eta.
  apply tr_equal_elim; auto.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_symmetry.
  apply tr_equal_eta.
  apply tr_equal_elim; auto.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma ofLeft_valid : ofLeft_obligation.
Proof.
prepare.
intros G1 G2 a b p m H.
apply tr_equal_eta_hyp; auto.
Qed.

Lemma ofEquand1_valid : ofEquand1_obligation.
Proof.
prepare.
intros G a m n ext0 H.
apply (tr_transitivity _ _ n); auto.
apply tr_symmetry; auto.
Qed.

Lemma ofEquand2_valid : ofEquand2_obligation.
Proof.
prepare.
intros G a m n ext0 H.
apply (tr_transitivity _ _ m); auto.
apply tr_symmetry; auto.
Qed.


Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.
Require Import StructTact.Fin.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import Verdi.StatePacketPacketDecomposition.

Set Implicit Arguments.

Section LockServ.

  Variable num_Clients : nat.

  Definition Client_index := (fin num_Clients).

  Inductive Name :=
  | Client : Client_index -> Name
  | Server : Name.

  Definition list_Clients := map Client (all_fin num_Clients).

  Definition Name_eq_dec : forall a b : Name, {a = b} + {a <> b}.
    decide equality. apply fin_eq_dec.
  Defined.

  Definition Request_index := nat.

  Inductive Msg :=
  | Lock   : Request_index -> Msg
  | Unlock : Msg
  | Locked : Request_index -> Msg.

  Definition Msg_eq_dec : forall a b : Msg, {a = b} + {a <> b}.
    decide equality; auto using Nat.eq_dec.
  Defined.

  Definition Input := Msg.
  Definition Output := Msg.

  Record Data := mkData { queue : list (Client_index * Request_index) ; held : bool }.

  Definition set_Data_queue d q := mkData q (held d).
  Definition set_Data_held d b := mkData (queue d) b.

  Notation "{[ d 'with' 'queue' := q ]}" := (set_Data_queue d q).
  Notation "{[ d 'with' 'held' := b ]}" := (set_Data_held d b).

  Definition init_data (n : Name) : Data := mkData [] false.

  Definition Handler (S : Type) := GenHandler (Name * Msg) S Output unit.

  Definition ClientNetHandler (i : Client_index) (m : Msg) : Handler Data :=
    d <- get ;;
    match m with
      | Locked id =>
        put {[ d with held := true ]} ;;
        write_output (Locked id)
      | _ => nop
    end.

  Definition ClientIOHandler (i : Client_index) (m : Msg) : Handler Data :=
    d <- get ;;
    match m with
      | Lock id => send (Server, Lock id)
      | Unlock =>
        when (held d) (put {[ d with held := false ]} ;; send (Server, Unlock))
      | _ => nop
    end.

  Definition ServerNetHandler (src : Name) (m : Msg) : Handler Data :=
    d <- get ;;
    match m with
      | Lock id =>
        match src with
          | Server => nop
          | Client c =>
            when (null (queue d)) (send (src, Locked id)) ;;
            put {[ d with queue := queue d ++ [(c, id)] ]}
        end
      | Unlock =>
        match queue d with
          | _ :: (c, id) :: xs =>
            put {[ d with queue := (c, id) :: xs ]} ;;
            send (Client c, Locked id)
          | _ =>
            put {[ d with queue := [] ]}
        end
      | _ => nop
    end.

  Definition ServerIOHandler (m : Msg) : Handler Data := nop.

  Definition NetHandler (nm src : Name) (m : Msg) : Handler Data :=
    match nm with
      | Client c => ClientNetHandler c m
      | Server   => ServerNetHandler src m
    end.

  Definition InputHandler (nm : Name) (m : Msg) : Handler Data :=
    match nm with
      | Client c => ClientIOHandler c m
      | Server   => ServerIOHandler m
    end.

  Ltac handler_unfold :=
    repeat (monad_unfold; unfold NetHandler,
                                 InputHandler,
                                 ServerNetHandler,
                                 ClientNetHandler,
                                 ClientIOHandler,
                                 ServerIOHandler in *).

  Definition Nodes := Server :: list_Clients.

  Theorem In_n_Nodes :
    forall n : Name, In n Nodes.
  Proof using.
    intros.
    unfold Nodes, list_Clients.
    simpl.
    destruct n.
    - right.
      apply in_map.
      apply all_fin_all.
    - left.
      reflexivity.
  Qed.

  Theorem nodup :
    NoDup Nodes.
  Proof using.
    unfold Nodes, list_Clients.
    apply NoDup_cons.
    - in_crush. discriminate.
    - apply NoDup_map_injective.
      + intros. congruence.
      + apply all_fin_NoDup.
  Qed.

  Global Instance LockServ_BaseParams : BaseParams :=
    {
      data   := Data ;
      input  := Input ;
      output := Output
    }.

  Global Instance LockServ_MultiParams : MultiParams LockServ_BaseParams :=
    {
      name := Name ;
      msg  := Msg ;
      msg_eq_dec := Msg_eq_dec ;
      name_eq_dec := Name_eq_dec ;
      nodes := Nodes ;
      all_names_nodes := In_n_Nodes ;
      no_dup_nodes := nodup ;
      init_handlers := init_data ;
      net_handlers := fun dst src msg s =>
                        runGenHandler_ignore s (NetHandler dst src msg) ;
      input_handlers := fun nm msg s =>
                          runGenHandler_ignore s (InputHandler nm msg)
    }.

  (* This is the fundamental safety property of the system:
       No two different clients can (think they) hold
       the lock at once.
   *)
  Definition mutual_exclusion (sigma : name -> data) : Prop :=
    forall m n,
      held (sigma (Client m)) = true ->
      held (sigma (Client n)) = true ->
      m = n.

  (* The system enforces mutual exclusion at the server. Whenever a
     client believs it holds the lock, that client is at the head of the
     server's queue. *)
  Definition locks_correct (sigma : name -> data) : Prop :=
    forall n,
      held (sigma (Client n)) = true ->
      exists id t,
        queue (sigma Server) = (n, id) :: t.

  (* We first show that this actually implies mutual exclusion. *)
  Lemma locks_correct_implies_mutex :
    forall sigma,
      locks_correct sigma ->
      mutual_exclusion sigma.
  Proof using.
    unfold locks_correct, mutual_exclusion.
    intros.
    repeat find_apply_hyp_hyp.
    break_exists.
    find_rewrite. find_inversion.
    auto.
  Qed.

  Definition valid_unlock q h c p :=
    pSrc p = Client c /\
    (exists (id : Request_index) t, q = (c, id) :: t) /\
    h = false.

  Definition locks_correct_unlock (sigma : name -> data) (p : packet) : Prop :=
    pBody p = Unlock ->
    exists c, valid_unlock (queue (sigma Server)) (held (sigma (Client c))) c p.

  Definition valid_locked q h c p :=
      pDst p = Client c /\
      (exists (id : Request_index) t, q = (c, id) :: t) /\
      h = false.

  Definition locks_correct_locked (sigma : name -> data) (p : packet) : Prop :=
    forall id, pBody p = Locked id ->
    exists c, valid_locked (queue (sigma Server)) (held (sigma (Client c))) c p.

  Definition LockServ_network_invariant (sigma : name -> data) (p : packet) : Prop :=
    locks_correct_unlock sigma p /\
    locks_correct_locked sigma p.

  Definition LockServ_network_network_invariant (p q : packet) : Prop :=
    (pBody p = Unlock -> pBody q = Unlock -> False) /\
    (forall id, pBody p = Locked id -> pBody q = Unlock -> False) /\
    (forall id, pBody p = Unlock -> pBody q = Locked id -> False) /\
    (forall id id', pBody p = Locked id -> pBody q = Locked id' -> False).

  Lemma nwnw_sym :
    forall p q,
      LockServ_network_network_invariant p q ->
      LockServ_network_network_invariant q p.
  Proof using.
    unfold LockServ_network_network_invariant.
    intuition eauto.
  Qed.

  Lemma locks_correct_init :
    locks_correct init_handlers.
  Proof using.
    unfold locks_correct. simpl. discriminate.
  Qed.

  Lemma InputHandler_cases :
    forall h i st u out st' ms,
      InputHandler h i st = (u, out, st', ms) ->
      (exists c, h = Client c /\
                 ((exists id, i = Lock id /\ out = [] /\ st' = st /\ ms = [(Server, Lock id)]) \/
                  (i = Unlock /\ out = [] /\ held st' = false /\
                   ((held st = true /\ ms = [(Server, Unlock)]) \/
                    (st' = st /\ ms = []))))) \/
      (out = [] /\ st' = st /\ ms = []).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion;
      subst; simpl in *; subst; simpl in *.
    - left. eexists. intuition eauto.
    - left. eexists. intuition.
    - left. eexists. intuition.
    - auto.
    - auto.
  Qed.

  Lemma locks_correct_update_false :
    forall sigma st' x,
      locks_correct sigma ->
      held st' = false ->
      locks_correct (update name_eq_dec sigma (Client x) st').
  Proof using.
    unfold locks_correct.
    intuition.
    destruct (Name_eq_dec (Client x) (Client n)).
    - find_inversion. exfalso.
      rewrite_update.
      congruence.
    - rewrite_update.
      auto.
  Qed.

  Ltac set_up_input_handlers :=
    intros;
    find_apply_lem_hyp InputHandler_cases;
    intuition idtac; try break_exists; intuition idtac; subst;
    repeat find_rewrite;
    simpl in *; intuition idtac; repeat find_inversion;
    try now rewrite update_nop_ext.

  Lemma locks_correct_input_handlers :
    forall h i sigma u st' out ms,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct (update name_eq_dec sigma h st').
  Proof using.
    set_up_input_handlers; break_exists; repeat break_and;
    eauto using locks_correct_update_false.
    subst.
    unfold locks_correct in *.
    intuition.
    find_rewrite_lem update_nop_ext.
    pose proof (H0 n H).
    break_exists.
    exists x1, x2.
    rewrite update_nop_ext.
    assumption.
  Qed.

  Lemma ClientNetHandler_cases :
    forall c m st u out st' ms,
      ClientNetHandler c m st = (u, out, st', ms) ->
      ms = [] /\
      ((st' = st /\ out = [] ) \/
       (exists id, m = Locked id /\ out = [Locked id] /\ held st' = true)).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion; subst; intuition eauto.
  Qed.

  Lemma ServerNetHandler_cases :
    forall src m st u out st' ms,
      ServerNetHandler src m st = (u, out, st', ms) ->
      out = [] /\
      ((exists c, src = Client c /\
             (exists id, m = Lock id /\ queue st' = queue st ++ [(c, id)] /\
              ((exists id, queue st = [] /\ ms = [(Client c, Locked id)]) \/
               (queue st <> [] /\ ms = [])))) \/
       ((m = Unlock /\
                   queue st' = tail (queue st) /\
                   ((queue st' = [] /\ ms = []) \/
                    (exists c' id t, queue st' = (c', id) :: t /\ ms = [(Client c', Locked id)])))) \/
       ms = [] /\ st' = st).
  Proof using.
    handler_unfold.
    intros.
    repeat break_match; repeat tuple_inversion; subst.
    - find_apply_lem_hyp null_sound. find_rewrite. simpl.
      intuition. left. eexists. intuition. eexists. intuition.
      left. eexists. intuition.
    - simpl. find_apply_lem_hyp null_false_neq_nil.
      intuition. left. eexists. intuition. eexists. intuition.
    - simpl. auto.
    - simpl. destruct st; simpl in *; subst; auto.
    - simpl in *. intuition.
    - simpl in *. intuition eauto.
    - simpl. intuition.
  Qed.

  Definition at_head_of_queue sigma c := (exists id t, queue (sigma Server) = (c, id) :: t).

  Lemma at_head_of_queue_intro :
    forall sigma c id t,
      queue (sigma Server) = (c, id) :: t ->
      at_head_of_queue sigma c.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
  Qed.

  Lemma locks_correct_update_true :
    forall sigma c st',
      held st' = true ->
      at_head_of_queue sigma c ->
      locks_correct sigma ->
      locks_correct (update name_eq_dec sigma (Client c) st').
  Proof using.
    unfold locks_correct.
    intros.
    destruct (Name_eq_dec (Client c) (Client n)); rewrite_update; try find_inversion; auto.
  Qed.

  Lemma locks_correct_locked_at_head :
    forall sigma p c id,
      pDst p = Client c ->
      pBody p = Locked id ->
      locks_correct_locked sigma p ->
      at_head_of_queue sigma c.
  Proof using.
    unfold locks_correct_locked.
    firstorder.
    repeat find_rewrite. pose proof (H1 id). concludes. break_exists. unfold valid_locked in *. break_and. break_exists.
    find_rewrite. find_injection.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma all_clients_false_locks_correct_server_update :
    forall sigma st,
      (forall c, held (sigma (Client c)) = false) ->
      locks_correct (update name_eq_dec sigma Server st).
  Proof using.
    unfold locks_correct.
    intros.
    rewrite_update.
    now find_higher_order_rewrite.
  Qed.

  Lemma locks_correct_true_at_head_of_queue :
    forall sigma x,
      locks_correct sigma ->
      held (sigma (Client x)) = true ->
      at_head_of_queue sigma x.
  Proof using.
    unfold locks_correct.
    intros.
    find_apply_hyp_hyp. break_exists.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma at_head_of_nil :
    forall sigma c,
      at_head_of_queue sigma c ->
      queue (sigma Server) = [] ->
      False.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
    congruence.
  Qed.

  Lemma empty_queue_all_clients_false :
    forall sigma,
      locks_correct sigma ->
      queue (sigma Server) = [] ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intuition.
    destruct (held (sigma (Client c))) eqn:?; auto.
    exfalso. eauto using at_head_of_nil, locks_correct_true_at_head_of_queue.
  Qed.

  Lemma unlock_in_flight_all_clients_false :
    forall sigma p,
      pBody p = Unlock ->
      locks_correct_unlock sigma p ->
      locks_correct sigma ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intros.
    destruct (held (sigma (Client c))) eqn:?; auto.
    firstorder.
    find_copy_apply_lem_hyp locks_correct_true_at_head_of_queue; auto.
    unfold at_head_of_queue in *. break_exists.
    congruence.
  Qed.

  Lemma locks_correct_at_head_preserved :
    forall sigma st',
      locks_correct sigma ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update name_eq_dec sigma Server st') c) ->
      locks_correct (update name_eq_dec sigma Server st').
  Proof using.
    unfold locks_correct, at_head_of_queue.
    firstorder.
  Qed.

  Lemma snoc_at_head_of_queue_preserved :
    forall sigma st' x,
      queue st' = queue (sigma Server) ++ [x] ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update name_eq_dec sigma Server st') c).
  Proof using.
    unfold at_head_of_queue.
    intuition. break_exists.
    rewrite_update.
    find_rewrite.
    eauto.
  Qed.

  Ltac set_up_net_handlers :=
    intros;
    match goal with
      | [ H : context [ NetHandler (pDst ?p) _ _ _ ] |- _ ] =>
        destruct (pDst p) eqn:?
    end; simpl in *;
    [find_apply_lem_hyp ClientNetHandler_cases |
     find_apply_lem_hyp ServerNetHandler_cases; intuition; try break_exists ];
    intuition; subst;
    simpl in *; intuition;
    repeat find_rewrite;
    repeat find_inversion;
    simpl in *;
    try now rewrite update_nop_ext.

  Lemma locks_correct_net_handlers :
    forall p sigma u st' out ms,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      locks_correct_locked sigma p ->
      locks_correct (update name_eq_dec sigma (pDst p) st').
  Proof using.
    set_up_net_handlers; break_exists; break_and;
    eauto using
          locks_correct_update_true, locks_correct_locked_at_head,
          all_clients_false_locks_correct_server_update, empty_queue_all_clients_false,
          locks_correct_at_head_preserved, snoc_at_head_of_queue_preserved,
          all_clients_false_locks_correct_server_update, unlock_in_flight_all_clients_false.
  Qed.

  Lemma locks_correct_unlock_sent_lock :
    forall sigma p id,
      pBody p = Lock id ->
      locks_correct_unlock sigma p.
  Proof using.
    unfold locks_correct_unlock.
    intuition. congruence.
  Qed.

  Lemma locks_correct_unlock_sent_locked :
    forall sigma p id,
      pBody p = Locked id ->
      locks_correct_unlock sigma p.
  Proof using.
    unfold locks_correct_unlock.
    intuition. congruence.
  Qed.

  Lemma locks_correct_unlock_input_handlers_old :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      locks_correct_unlock (update name_eq_dec sigma h st') p.
  Proof using.
    set_up_input_handlers; break_exists; break_and; subst; try rewrite update_nop_ext; auto.
    destruct (pBody p) eqn:?.
    - eauto using locks_correct_unlock_sent_lock.
    - now erewrite unlock_in_flight_all_clients_false in * by eauto.
    - eauto using locks_correct_unlock_sent_locked.
  Qed.

  Lemma locked_in_flight_all_clients_false :
    forall sigma p id,
      pBody p = Locked id ->
      locks_correct_locked sigma p ->
      locks_correct sigma ->
      (forall c, held (sigma (Client c)) = false).
  Proof using.
    intros.
    destruct (held (sigma (Client c))) eqn:?; auto.
    find_copy_apply_lem_hyp locks_correct_true_at_head_of_queue; auto.
    unfold at_head_of_queue in *. break_exists.
    unfold locks_correct_locked in *.
    pose proof (H0 id).
    concludes.
    break_exists.
    unfold valid_locked in H3.
    break_and.
    break_exists.
    find_rewrite.
    find_injection.
    congruence.
  Qed.

  Lemma locks_correct_locked_sent_lock :
    forall sigma p id,
      pBody p = Lock id ->
      locks_correct_locked sigma p.
  Proof using.
    unfold locks_correct_locked.
    intuition. congruence.
  Qed.

  Lemma locks_correct_locked_sent_unlock :
    forall sigma p,
      pBody p = Unlock ->
      locks_correct_locked sigma p.
  Proof using.
    unfold locks_correct_locked.
    intuition. congruence.
  Qed.

  Lemma locks_correct_locked_input_handlers_old :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_locked sigma p ->
      locks_correct_locked (update name_eq_dec sigma h st') p.
  Proof using.
    set_up_input_handlers; break_exists; break_and; subst; try rewrite update_nop_ext; auto.
    destruct (pBody p) eqn:?.
    - eauto using locks_correct_locked_sent_lock.
    - eauto using locks_correct_locked_sent_unlock.
    - now erewrite locked_in_flight_all_clients_false in * by eauto.
  Qed.

  Lemma locks_correct_unlock_true_to_false :
    forall sigma p x st',
      at_head_of_queue sigma x ->
      held st' = false ->
      pSrc p = Client x ->
      locks_correct_unlock (update name_eq_dec sigma (Client x) st') p.
  Proof using.
    unfold locks_correct_unlock, valid_unlock.
    intros.
    exists x.
    intuition; now rewrite_update.
  Qed.

  Lemma locks_correct_unlock_input_handlers_new :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      In (pDst p, pBody p) ms ->
      pSrc p = h ->
      locks_correct_unlock (update name_eq_dec sigma h st') p.
  Proof using.
    set_up_input_handlers; break_exists; break_and; subst; try rewrite update_nop_ext;

    eauto using locks_correct_unlock_sent_lock,
               locks_correct_unlock_true_to_false,
               locks_correct_true_at_head_of_queue.
   unfold locks_correct_unlock.
   intro.
   exists x.
   unfold valid_unlock.
   split; auto.
   simpl in *.
   break_or_hyp; intuition.
   - find_injection.
     congruence.
   - find_injection.
     congruence.
   Qed.

  Lemma locks_correct_locked_input_handlers_new :
    forall h i sigma u st' out ms p,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      In (pDst p, pBody p) ms ->
      locks_correct_locked (update name_eq_dec sigma h st') p.
  Proof using.
    set_up_input_handlers; break_exists; break_and; subst; try rewrite update_nop_ext; auto.
    - simpl in *.
      intuition.
      find_injection.
      congruence.
    - eauto using locks_correct_locked_sent_lock, locks_correct_locked_sent_unlock.
  Qed.

  Lemma nwnw_locked_lock :
    forall p q id,
      LockServ_network_network_invariant p q ->
      pBody p = Locked id ->
      exists id', pBody q = Lock id'.
  Proof using.
    unfold LockServ_network_network_invariant.
    intros.
    destruct (pBody q); intuition; try discriminate.
    - exists r; auto.
    - pose proof (H _ H0).
      intuition.
    - pose proof (H4 _ r H0).
      congruence.
  Qed.

  Lemma nwnw_unlock_lock :
    forall p q,
      LockServ_network_network_invariant p q ->
      pBody p = Unlock ->
      exists id, pBody q = Lock id.
  Proof using.
    unfold LockServ_network_network_invariant.
    intros.
    destruct (pBody q); intuition; try discriminate.
    - exists r; auto.
    - pose proof (H2 r H0).
      congruence.
  Qed.

  Lemma locks_correct_unlock_at_head :
    forall sigma p c,
      pSrc p = Client c ->
      pBody p = Unlock ->
      locks_correct_unlock sigma p ->
      at_head_of_queue sigma c.
  Proof using.
    unfold locks_correct_unlock.
    intros.
    find_apply_hyp_hyp. clear H1.
    break_exists.
    unfold valid_unlock in *. intuition.
    break_exists.
    repeat find_rewrite. repeat find_inversion.
    eauto using at_head_of_queue_intro.
  Qed.

  Lemma locks_correct_unlock_at_head_preserved :
    forall sigma st' p,
      locks_correct_unlock sigma p ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update name_eq_dec sigma Server st') c) ->
      locks_correct_unlock (update name_eq_dec sigma Server st') p.
  Proof using.
    unfold locks_correct_unlock, valid_unlock.
    intuition.
    break_exists.
    exists x.
    intuition.
    firstorder.
  Qed.

  Lemma nil_at_head_of_queue_preserved :
    forall c sigma sigma',
      queue (sigma Server) = [] ->
      at_head_of_queue sigma c ->
      at_head_of_queue sigma' c.
  Proof using.
    unfold at_head_of_queue.
    firstorder.
    congruence.
  Qed.

  Lemma locks_correct_unlock_net_handlers_old :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma q ->
      LockServ_network_network_invariant p q ->
      locks_correct_unlock (update name_eq_dec sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers; break_exists; break_and; subst; eauto using locks_correct_unlock_sent_lock, nwnw_locked_lock,
                locks_correct_unlock_at_head_preserved, snoc_at_head_of_queue_preserved,
                nwnw_unlock_lock, nil_at_head_of_queue_preserved.
    - unfold locks_correct_unlock in *.
      intros.
      concludes.
      break_exists.
      pose proof (nwnw_locked_lock H2 H).
      break_exists.
      congruence.
    - unfold locks_correct_unlock in *.
      intros.
      concludes.
      break_exists.
      pose proof (nwnw_unlock_lock H2 H).
      break_exists.
      congruence.
    - unfold locks_correct_unlock in *.
      intros.
      concludes.
      break_exists.
      pose proof (nwnw_unlock_lock H2 H).
      break_exists.
      congruence.
  Qed.

  Lemma locks_correct_locked_at_head_preserved :
    forall sigma st' p,
      locks_correct_locked sigma p ->
      (forall c, at_head_of_queue sigma c -> at_head_of_queue (update name_eq_dec sigma Server st') c) ->
      locks_correct_locked (update name_eq_dec sigma Server st') p.
  Proof using.
    unfold locks_correct_locked, valid_locked.
    intuition.
    pose proof (H id H1).
    break_exists.
    break_and.
    break_exists.
    exists x.
    intuition.
    firstorder.
  Qed.

  Lemma locks_correct_locked_net_handlers_old :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_locked sigma q ->
      LockServ_network_network_invariant p q ->
      locks_correct_locked (update name_eq_dec sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers; break_exists; break_and; subst;
    eauto using locks_correct_locked_sent_lock, nwnw_locked_lock,
      locks_correct_locked_at_head_preserved, snoc_at_head_of_queue_preserved,
      nwnw_unlock_lock, nil_at_head_of_queue_preserved.
    - unfold locks_correct_locked in *.
      intros.
      pose proof (H1 _ H3).
      break_exists.
      pose proof (nwnw_locked_lock H2 H).
      break_exists.
      congruence.
   -  unfold locks_correct_locked in *.
      intros.
      pose proof (H1 id H3).
      break_exists.
      pose proof (nwnw_unlock_lock H2 H).
      break_exists.
      congruence.
    - unfold locks_correct_locked in *.
      intros.
      pose proof (H1 id H3).
      break_exists.
      pose proof (nwnw_unlock_lock H2 H).
      break_exists.
      congruence.
  Qed.

  Lemma locks_correct_unlock_net_handlers_new :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      In (pDst q, pBody q) ms ->
      locks_correct_unlock (update name_eq_dec sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers; break_exists; break_and; subst; intuition; break_exists; break_and; subst; simpl in *; intuition; try find_injection; try congruence.
  Qed.

  Lemma locks_correct_locked_intro :
    forall sigma p c id t st',
      pDst p = Client c ->
      held (sigma (Client c)) = false ->
      queue st' = (c, id) :: t ->
      locks_correct_locked (update name_eq_dec sigma Server st') p.
  Proof using.
    unfold locks_correct_locked, valid_locked.
    intros.
    exists c.
    intuition.
    exists id, t. now rewrite_update.
  Qed.

  Lemma locks_correct_locked_net_handlers_new :
    forall p sigma u st' out ms q,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      locks_correct_unlock sigma p ->
      In (pDst q, pBody q) ms ->
      locks_correct_locked (update name_eq_dec sigma (pDst p) st') q.
  Proof using.
    set_up_net_handlers; break_exists; break_and; intuition; break_exists; break_and; subst; simpl in *; intuition; try find_injection; try congruence.
    - eapply locks_correct_locked_intro; eauto.
      eauto using locks_correct_locked_intro,
        empty_queue_all_clients_false,
        unlock_in_flight_all_clients_false.
      rewrite H3.
      rewrite H5.
      simpl.
      eauto.
    - eapply locks_correct_locked_intro; eauto.
      eauto using locks_correct_locked_intro,
        empty_queue_all_clients_false,
        unlock_in_flight_all_clients_false.
  Qed.

  Lemma nwnw_lock :
    forall p p' id,
      pBody p = Lock id ->
      LockServ_network_network_invariant p p'.
  Proof using.
    unfold LockServ_network_network_invariant.
    intuition; simpl in *; congruence.
  Qed.

  Lemma LockServ_nwnw_input_handlers_old_new :
    forall h i sigma u st' out ms p p',
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      In (pDst p', pBody p') ms ->
      pSrc p' = h ->
      LockServ_network_network_invariant p p'.
  Proof using.
    unfold LockServ_network_invariant.
    set_up_input_handlers.
    - break_exists; break_and; subst.
      simpl in *.
      intuition.
      find_injection.
      eauto using nwnw_sym, nwnw_lock.
    - destruct (pBody p) eqn:?.
      + eauto using nwnw_lock.
      + now erewrite unlock_in_flight_all_clients_false in * by eauto.
      + now erewrite locked_in_flight_all_clients_false in * by eauto.
  Qed.

  Lemma LockServ_nwnw_input_handlers_new_new :
    forall h i sigma u st' out ms,
      InputHandler h i (sigma h) = (u, out, st', ms) ->
      distinct_pairs_and LockServ_network_network_invariant
                         (map (fun m => mkPacket h (fst m) (snd m)) ms).
  Proof using.
    set_up_input_handlers; break_exists; break_and; subst; simpl; split; intuition.
  Qed.

  Lemma nw_empty_queue_lock :
    forall sigma p,
      LockServ_network_invariant sigma p ->
      queue (sigma Server) = [] ->
      exists i, pBody p = Lock i.
  Proof using.
    unfold LockServ_network_invariant,
    locks_correct_unlock, locks_correct_locked,
    valid_unlock, valid_locked.
    intuition.
    destruct (pBody p) eqn:?; intuition; break_exists; intuition; break_exists;
    try congruence.
    - exists r; auto.
    - pose proof (H2 r (eq_refl _)).
      break_exists; break_and; break_exists.
      congruence.
  Qed.

  Lemma LockServ_nwnw_net_handlers_old_new :
    forall p sigma u st' out ms q p',
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      LockServ_network_invariant sigma q ->
      LockServ_network_network_invariant p q ->
      In (pDst p', pBody p') ms ->
      LockServ_network_network_invariant p' q.
  Proof using.
    set_up_net_handlers; break_exists; break_and; subst; intuition; break_exists; break_and; subst; simpl in *; intuition; try find_injection.
    - pose proof (nw_empty_queue_lock H2 H7).
      break_exists.
      pose proof (nwnw_lock _ p' H9).
      apply nwnw_sym.
      assumption.
    - pose proof (nwnw_unlock_lock H3 H).
      break_exists.
      pose proof (nwnw_lock _ p' H4).
      apply nwnw_sym.
      assumption.
    Qed.

  Lemma LockServ_nwnw_net_handlers_new_new :
    forall p sigma u st' out ms,
      NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
      locks_correct sigma ->
      LockServ_network_invariant sigma p ->
      distinct_pairs_and LockServ_network_network_invariant
                         (map (fun m => mkPacket (pDst p) (fst m) (snd m)) ms).
  Proof using.
    set_up_net_handlers; break_exists; break_and; intuition; break_exists; break_and; subst; simpl; intuition.
  Qed.

  Instance LockServ_Decompositition : Decomposition _ LockServ_MultiParams.
  apply Build_Decomposition with (state_invariant := locks_correct)
                                 (network_invariant := LockServ_network_invariant)
                                 (network_network_invariant := LockServ_network_network_invariant);
    simpl; intros; monad_unfold; repeat break_let; repeat find_inversion.
  - auto using nwnw_sym.
  - auto using locks_correct_init.
  - eauto using locks_correct_input_handlers.
  - unfold LockServ_network_invariant in *. intuition.
    eauto using locks_correct_net_handlers.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_input_handlers_old,
                          locks_correct_locked_input_handlers_old.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_input_handlers_new,
                          locks_correct_locked_input_handlers_new.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_net_handlers_old,
                          locks_correct_locked_net_handlers_old.
  - unfold LockServ_network_invariant in *.
    intuition eauto using locks_correct_unlock_net_handlers_new,
                          locks_correct_locked_net_handlers_new.
  - eauto using LockServ_nwnw_input_handlers_old_new.
  - eauto using LockServ_nwnw_input_handlers_new_new.
  - eauto using LockServ_nwnw_net_handlers_old_new.
  - eauto using LockServ_nwnw_net_handlers_new_new.
  Defined.

  Theorem true_in_reachable_mutual_exclusion :
    true_in_reachable step_async step_async_init (fun net => mutual_exclusion (nwState net)).
  Proof using.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *.
    intros.
    apply locks_correct_implies_mutex.
    match goal with
    | [ H : _ |- _ ] => apply H
    end.
    auto.
  Qed.

  Fixpoint last_holder' (holder : option Client_index) (trace : list (name * (input + list output))) : option Client_index :=
    match trace with
      | [] => holder
      | (Client n, inl Unlock) :: tr => match holder with
                                          | None => last_holder' holder tr
                                          | Some m => if fin_eq_dec _ n m
                                                      then last_holder' None tr
                                                      else last_holder' holder tr
                                        end

      | (Client n, inr [Locked id]) :: tr => last_holder' (Some n) tr
      | (n, _) :: tr => last_holder' holder tr
    end.

  Fixpoint trace_mutual_exclusion' (holder : option Client_index) (trace : list (name * (input + list output))) : Prop :=
    match trace with
      | [] => True
      | (Client n, (inl Unlock)) :: tr' => match holder with
                                             | Some m => if fin_eq_dec _ n m
                                                         then trace_mutual_exclusion' None tr'
                                                         else trace_mutual_exclusion' holder tr'
                                             | _ => trace_mutual_exclusion' holder tr'
                                           end
      | (n, (inl _)) :: tr' => trace_mutual_exclusion' holder tr'
      | (Client n, (inr [Locked id])) :: tr' => match holder with
                                               | None => trace_mutual_exclusion' (Some n) tr'
                                               | Some _ => False
                                             end
      | (_, (inr [])) :: tr' => trace_mutual_exclusion' holder tr'
      | (_, (inr _)) :: tr' => False
    end.

  Definition trace_mutual_exclusion (trace : list (name * (input + list output))) : Prop :=
    trace_mutual_exclusion' None trace.

  Definition last_holder (trace : list (name * (input + list output))) : option Client_index :=
    last_holder' None trace.

  Lemma cross_relation :
    forall (P : network -> list (name * (input + list output)) -> Prop),
      P step_async_init [] ->
      (forall st st' tr ev,
         step_async_star step_async_init st tr ->
         P st tr ->
         step_async st st' ev ->
         P st' (tr ++ ev)) ->
      forall st tr,
        step_async_star step_async_init st tr ->
        P st tr.
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H1.
    induction H1; intros; subst; eauto.
    eapply H3; eauto.
    - apply refl_trans_n1_1n_trace. auto.
    - apply IHrefl_trans_n1_trace; auto.
  Qed.

  Lemma trace_mutex'_no_out_extend :
    forall tr n h,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(n, inr [])]).
  Proof using.
    induction tr; intuition; unfold trace_mutual_exclusion in *; simpl in *;
    repeat break_match; subst; intuition.
  Qed.

  Lemma last_holder'_no_out_inv :
    forall tr h c n,
      last_holder' h (tr ++ [(c, inr [])]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; intuition; eauto.
  Qed.

  Lemma last_holder'_no_out_extend :
    forall tr h c n,
      last_holder' h tr = Some n ->
      last_holder' h (tr ++ [(c, inr [])]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; intuition.
  Qed.

  Lemma decomposition_reachable_nw_invariant :
    forall st tr p,
      step_async_star step_async_init st tr ->
      In p (nwPackets st) ->
      network_invariant (nwState st) p.
  Proof using.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable, reachable in *.
    intuition.
    unfold composed_invariant in *.
    apply H; eauto.
  Qed.

  Lemma trace_mutex'_locked_extend :
    forall tr h n id,
      trace_mutual_exclusion' h tr ->
      last_holder' h tr = None ->
      trace_mutual_exclusion' h (tr ++ [(Client n, inr [Locked id])]).
  Proof using.
    induction tr; intros; simpl in *.
    - subst; auto.
    - simpl in *; repeat break_match; subst; intuition.
  Qed.

  Lemma reachable_intro :
    forall a tr,
      step_async_star step_async_init a tr ->
      reachable step_async step_async_init a.
  Proof using.
    unfold reachable.
    intros. eauto.
  Qed.

  Lemma locks_correct_locked_invariant :
    forall st p,
      reachable step_async step_async_init st ->
      In p (nwPackets st) ->
      locks_correct_locked (nwState st) p.
  Proof using.
    intros.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *. apply H1; auto.
  Qed.

  Lemma locks_correct_invariant :
    forall st,
      reachable step_async step_async_init st ->
      locks_correct (nwState st).
  Proof using.
    intros.
    pose proof decomposition_invariant.
    find_apply_lem_hyp inductive_invariant_true_in_reachable.
    unfold true_in_reachable in *. apply H0; auto.
  Qed.

  Lemma mutual_exclusion_invariant :
    forall st,
      reachable step_async step_async_init st ->
      mutual_exclusion (nwState st).
  Proof using.
    intros.
    apply locks_correct_implies_mutex.
    auto using locks_correct_invariant.
  Qed.

  Lemma last_holder'_locked_some_eq :
    forall tr h c n id,
      last_holder' h (tr ++ [(Client c, inr [Locked id])]) = Some n ->
      c = n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; eauto.
    congruence.
  Qed.

  Ltac my_update_destruct :=
    match goal with
      | [H : context [ update _ _ ?x _ ?y ] |- _ ] => destruct (Name_eq_dec x y)
      | [ |- context [ update _ _ ?x _ ?y ] ] => destruct (Name_eq_dec x y)
    end.

  Lemma last_holder'_server_extend :
    forall tr h i,
      last_holder' h (tr ++ [(Server, inl i)]) = last_holder' h tr.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
  Qed.

  Lemma last_holder'_locked_extend :
    forall tr h n id,
      last_holder' h (tr ++ [(Client n, inr [Locked id])]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
  Qed.

  Lemma trace_mutual_exclusion'_extend_input :
    forall tr h c i,
      i <> Unlock ->
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Client c, inl i)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma trace_mutual_exclusion'_extend_input_server :
    forall tr h i,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Server, inl i)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma last_holder'_input_inv :
    forall tr h c i n,
      i <> Unlock ->
      last_holder' h (tr ++ [(Client c, inl i)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto; try congruence; subst; eauto.
  Qed.

  Lemma last_holder'_input_inv_server :
    forall tr h i n,
      last_holder' h (tr ++ [(Server, inl i)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto; try congruence; subst; eauto.
  Qed.

  Lemma last_holder'_input_extend :
    forall tr h c i n,
      i <> Unlock ->
      last_holder' h tr = Some n ->
      last_holder' h (tr ++ [(Client c, inl i)]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; auto.
    congruence.
  Qed.

  Lemma trace_mutex'_unlock_extend :
    forall tr h c,
      trace_mutual_exclusion' h tr ->
      trace_mutual_exclusion' h (tr ++ [(Client c, inl Unlock)]).
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition (auto; try congruence).
  Qed.

  Lemma last_holder'_unlock_none :
    forall tr h c,
      last_holder' h tr = Some c ->
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = None.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; intuition.
    congruence.
  Qed.

  Lemma last_holder_unlock_none :
    forall tr c,
      last_holder tr = Some c ->
      last_holder (tr ++ [(Client c, inl Unlock)]) = None.
  Proof using.
    intros.
    apply last_holder'_unlock_none. auto.
  Qed.

  Lemma last_holder_some_unlock_inv :
    forall tr h c n,
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = Some n ->
      last_holder' h tr = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst;
    intuition; try congruence; eauto.
  Qed.

  Lemma last_holder'_neq_unlock_extend :
    forall tr h n c,
      last_holder' h tr = Some n ->
      n <> c ->
      last_holder' h (tr ++ [(Client c, inl Unlock)]) = Some n.
  Proof using.
    induction tr; intros; simpl in *; repeat break_match; subst; try congruence; intuition.
  Qed.

  Lemma LockServ_mutual_exclusion_trace :
    forall st tr,
      step_async_star step_async_init st tr ->
      trace_mutual_exclusion tr /\
      (forall n, last_holder tr = Some n -> held (nwState st (Client n)) = true) /\
      (forall n, held (nwState st (Client n)) = true -> last_holder tr = Some n).
  Proof using.
    apply cross_relation; intros.
    - intuition.
      + red. red. auto.
      + unfold last_holder in *. simpl in *. discriminate.
      + unfold last_holder in *. simpl in *. discriminate.
    - match goal with
        | [ H : step_async _ _ _ |- _ ] => invcs H
      end; monad_unfold; repeat break_let; repeat find_inversion.
      + unfold NetHandler in *. break_match.
        * find_apply_lem_hyp ClientNetHandler_cases.
          break_and.
          { break_or_hyp.
            - intuition; subst.
              + apply trace_mutex'_no_out_extend; auto.
              + rewrite update_nop_ext.
                find_apply_lem_hyp last_holder'_no_out_inv.
                auto.
              + match goal with
                  | [ H : _ |- _ ] => rewrite update_nop in H
                end.
                find_apply_hyp_hyp.
                apply last_holder'_no_out_extend. auto.
            - intuition; subst; break_exists; break_and; subst.
              + apply trace_mutex'_locked_extend. auto.
                destruct (last_holder' None tr) eqn:?; auto.
                find_apply_hyp_hyp.
                erewrite locked_in_flight_all_clients_false in * by
                  eauto using locks_correct_locked_invariant, reachable_intro,
                              locks_correct_invariant.
                discriminate.
              + my_update_destruct; try find_inversion; rewrite_update; auto.
                find_apply_lem_hyp last_holder'_locked_some_eq. congruence.
              + my_update_destruct; try find_inversion; rewrite_update.
                * apply last_holder'_locked_extend.
                * erewrite locked_in_flight_all_clients_false in * by
                      eauto using locks_correct_locked_invariant, reachable_intro,
                                  locks_correct_invariant.
                  discriminate.
          }
        * { find_apply_lem_hyp ServerNetHandler_cases. break_and. subst.
            repeat split.
            - apply trace_mutex'_no_out_extend. auto.
            - intros. my_update_destruct; try discriminate.
              rewrite_update.
              find_apply_lem_hyp last_holder'_no_out_inv.
              auto.
            - intros. my_update_destruct; try discriminate; rewrite_update.
              apply last_holder'_no_out_extend. auto.
          }
      + unfold InputHandler in *. break_match.
        * unfold ClientIOHandler in *.
          { monad_unfold.
            repeat break_match; repeat find_inversion; intuition;
            repeat rewrite snoc_assoc in *;
            try apply trace_mutex'_no_out_extend;
            try find_apply_lem_hyp last_holder'_no_out_inv;
            try (apply last_holder'_no_out_extend; auto).
            - apply trace_mutual_exclusion'_extend_input; auto. congruence.
            - rewrite update_nop_ext.
              find_apply_lem_hyp last_holder'_input_inv; try congruence.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              apply last_holder'_input_extend; auto. congruence.
            - apply trace_mutex'_unlock_extend; auto.
            - rewrite last_holder_unlock_none in *; auto. discriminate.
            - my_update_destruct; try find_inversion; rewrite_update.
              + discriminate.
              + assert (mutual_exclusion (nwState st))
                       by eauto using mutual_exclusion_invariant, reachable_intro.
                unfold mutual_exclusion in *.
                assert (c = n) by eauto. congruence.
            - apply trace_mutex'_unlock_extend. auto.
            - rewrite update_nop.
              find_apply_lem_hyp last_holder_some_unlock_inv.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              assert (n <> c) by congruence.
              find_apply_hyp_hyp.
              apply last_holder'_neq_unlock_extend; auto.
            - apply trace_mutual_exclusion'_extend_input; auto. congruence.
            - rewrite update_nop_ext. find_apply_lem_hyp last_holder'_input_inv; try congruence.
              auto.
            - match goal with
                | [ H : _ |- _ ] => rewrite update_nop in H
              end.
              apply last_holder'_input_extend; auto. congruence.
          }
        * unfold ServerIOHandler in *.
          monad_unfold. find_inversion.
          { intuition;
            repeat rewrite snoc_assoc in *.
            - apply trace_mutex'_no_out_extend.
              apply trace_mutual_exclusion'_extend_input_server. auto.
            - find_apply_lem_hyp last_holder'_no_out_inv.
              rewrite update_nop. find_apply_lem_hyp last_holder'_input_inv_server. auto.
            - apply last_holder'_no_out_extend; auto.
              rewrite_update. unfold last_holder. rewrite last_holder'_server_extend.
              auto.
          }
  Qed.
End LockServ.


Require Import List String.
Require Import CoqCompile.Lambda.
Require Import CoqCompile.CpsK CoqCompile.Env.
Require Import ExtLib.Data.Map.FMapAList.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import ExtLib.Data.Monads.StateMonad.
Require Import ExtLib.Data.Monads.FuelMonad.
Require Import ExtLib.Data.Lists.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Programming.Show.
Require Import ZArith.
Require Import ExtLib.Data.Strings.

Set Implicit Arguments.
Set Strict Implicit.

Section CPSEVAL.
  Import CPSK.
  Import MonadNotation.
  Local Open Scope string_scope.
  Local Open Scope monad_scope.
  (** Because this version of CPS supports recursive records, as well as recursive
      functions, I've chosen to use an allocation-style semantics here, where large
      values, such as tuples and closures, are allocated on a heap.  Then, to build
      circular values, such as recursive closures or recursive tuples, we first
      allocate space for them, then initialize them with back-patching. *)

  (** Small values *)
  Inductive value : Type :=
  | Con_v : Lambda.constructor -> value
  | Int_v : Z -> value
  | Ptr_v : nat -> value
  | World_v : positive -> value.

  (** Allocated values *)
  Inductive heap_value : Type :=
  | Tuple_v : list value -> heap_value
  | Closure_v : alist (var + cont) value -> list cont -> list var -> exp -> heap_value.

  Section hiding_show.
    Import ShowNotation.
    Local Open Scope show_scope.

    Global Instance Show_value : Show value :=
    { show v :=
      match v with
        | Con_v c => "Con(" << c << ")"
        | Int_v z => show z
        | Ptr_v n => "Ptr(" << show n << ")"
        | World_v n => "World#" << show n
      end }.

    Global Instance Show_heap_value : Show heap_value :=
    { show v :=
      match v with
        | Tuple_v ls => "<" << sepBy_f show  " , " ls << ">"
        | Closure_v _ _ _ e => "<closure:" << show e << ">"
      end }.

    Definition val2str (v : value) : string := to_string v.
  End hiding_show.

  (** We'll just naively implement heaps as lists of heap values *)
  Definition heap := list heap_value.

  Definition m : Type -> Type := GFixT (stateT heap (stateT (list (mop * list value)) (sum string))).

  (** We'll be working in a combination of the state and option monads, so
     I've written various environment and other functions tailored to that
     monad. *)
  Definition lookup {A} (env:alist (var + cont) A) (x:var + cont) : m A :=
    match Maps.lookup x env with
      | None => raise ("unknown variable " ++ to_string x)
      | Some v => ret v
    end.

  Definition extend {A} (env:alist (var + cont) A) (x:var + cont) (v:A) : alist (var + cont) A :=
    Maps.add x v env.

  Fixpoint extends {A}(env:alist (var + cont) A) (xs:list (var + cont)) (vs:list A) : m (alist (var + cont) A) :=
    match xs, vs with
      | nil, nil => ret env
      | x::xs, v::vs => extends (extend env x v) xs vs
      | _, _ => raise "calling function with wrong # of arguments"
    end.

  Definition eval_op (env:alist (var + cont) value) (v:op) : m value :=
    match v with
      | Con_o c => ret (Con_v c)
      | Int_o i => ret (Int_v i)
      | Var_o x => lookup env (inl x)
      | InitWorld_o => ret (World_v 1)
    end.

  (** Find the appropriate switch arm for a given small value. *)
  Fixpoint find_arm (v:value) (arms : list (pattern * exp)) (def:option exp) : m exp :=
    match v,arms with
      | _,nil => match def with
                   | None => raise "bad pattern match"
                   | Some e => ret e
                 end
      | Con_v c, ((Con_p c',e)::rest) => if eq_dec c c' then ret e else find_arm v rest def
      | Int_v i, ((Int_p i',e)::rest) => if eq_dec i i' then ret e else find_arm v rest def
      | _,(_::rest) => find_arm v rest def
    end.

  (** Allocate a heap value and return its address as a pointer *)
  Definition malloc(v:heap_value) : m value :=
    h <- get ;;
    let _ : heap := h in
    put (List.app h (v::nil)) ;;
    ret (Ptr_v (List.length h)).

    (** Lookup the pointer [n] in the heap. *)
  Definition heap_lookup (n:nat) : m heap_value :=
    h <- get ;
    match nth_error h n with
      | None => raise "bad heap pointer"
      | Some v => ret v
    end.

  Fixpoint heap_upd (n:nat) (h:heap) (v:heap_value) : option heap :=
    match n, h with
      | 0, _::tail => ret (v::tail)
      | S n, head::tail => t <- (heap_upd n tail v) ; ret (head::t)
      | _, _ => None
    end.

  (** Update the heap value at location [n] to be the value [v]. *)
  Definition heap_set (n:nat) (v:heap_value) : m unit :=
    h <- get ;
    match heap_upd n h v with
      | None => raise "bad heap pointer"
      | Some h' => put h'
    end.

  (** Evaluate the primops given closed values *)
  Definition eval_primop (p:primop) (vs: list value) (d: decl) : m value :=
    match p, vs with
      | Eq_p, (Int_v i)::(Int_v j)::nil => ret (if eq_dec i j then (Con_v "True") else (Con_v "False"))
      | Eq_p, (Con_v i)::(Con_v j)::nil => ret (if eq_dec i j then (Con_v "True") else (Con_v "False"))
      | Neq_p, (Int_v i)::(Int_v j)::nil => ret (if eq_dec i j then (Con_v "False") else (Con_v "True"))
      | Neq_p, (Con_v i)::(Con_v j)::nil => ret (if eq_dec i j then (Con_v "False") else (Con_v "True"))
      | Lt_p, (Int_v i)::(Int_v j)::nil => ret (if Z.ltb i j then (Con_v "True") else (Con_v "False"))
      | Lte_p, (Int_v i)::(Int_v j)::nil => ret (if orb (Z.ltb i j) (eq_dec i j)
        then (Con_v "True") else (Con_v "False"))
      | Ptr_p, ((Int_v _)::nil) => ret (Con_v "False")
      | Ptr_p, ((Con_v _)::nil) => ret (Con_v "False")
      | Ptr_p, ((Ptr_v _)::nil) => ret (Con_v "True")
      | Plus_p, ((Int_v i)::(Int_v j)::nil) => ret (Int_v (i+j))
      | Minus_p, ((Int_v i)::(Int_v j)::nil) => ret (Int_v (i-j))
      | Times_p, ((Int_v i)::(Int_v j)::nil) => ret (Int_v (i*j))
          (** Note allocation here *)
      | MkTuple_p, vs => malloc (Tuple_v vs)
      | Proj_p, ((Int_v i)::(Ptr_v n)::nil) =>
          (** Lookup the pointer in the heap to get a heap value [v] *)
        v <- heap_lookup n ;
        match v with
            (** Check that [v] is a tuple *)
          | Tuple_v vs =>
            match nth_error vs (Z.abs_nat i) with
              | None => raise ("projection out of bounds: " ++ to_string d)%string
              | Some v => ret v
            end
          | _ => raise ("projection from non-tuple: " ++ to_string d)%string
        end
      | _, _ =>
        let pop := to_string p in
        let args := fold_left (fun acc v => acc ++ to_string v ++ ", ") vs "" in
        raise ("bad primitive application of: " ++ pop ++ " to " ++ args)%string
    end.

    (** Used for initializing variables to some pointer value to a dummy
       heap value in a circular set of definitions. *)
  Definition malloc_dummy (d:decl) : m ((var + cont) * value) :=
    match d with
      | Fn_d f ks _ _ => v <- malloc (Tuple_v nil) ;; ret (inl f,v)
      | Prim_d x MkTuple_p _ =>
        v <- malloc (Tuple_v nil) ;;
        ret (inl x,v)
      | _ => raise ("can not allocate non function or tuple: " ++ to_string d)
    end.

    (** Assuming we've already bound the declared variable in [d] to a pointer
        value [p], we now actually build the appropriate value under this
        extended environment.  Then we set [p] to point to the new value.
        So for instance, if we have:

        let rec x = MkTuple [x;x]

        then we first allocate a dummy empty tuple at location [p] and update
        the environment so [x] maps to [p].  Then we actually build the
        tuple, evaluating the components to closed values.  In this case,
        we'd get a [Tuple_v [p;p]].  Finally, we set [p] to point to this
        heap value.  So in the end, we have an environment that maps [x] to
        [p], and a heap that maps [p] to [Tuple_v [p;p]].

        Note that we only support recursion on functions and tuples and not,
        in general, on arbitrary declarations.  This ensures that we don't
        end up evaluating something that eliminates a pointer (e.g., projection,
        or function call) when we haven't completed initializing the expression.

        Another advantage of making this all explicit is that it's quite
        close to what we'll do at the machine level.
     *)
  Definition initialize_decl (env:alist (var + cont) value) (d: decl) : m unit :=
    match d with
      | Fn_d f ks xs e =>
        v <- lookup env (inl f) ;;
        match v with
          | Ptr_v n => heap_set n (Closure_v env ks xs e)
          | _ => raise "??"
        end
      | Prim_d x MkTuple_p vs =>
        vs' <- mapM (eval_op env) vs ;;
        v <- lookup env (inl x) ;
        match v with
          | Ptr_v n => heap_set n (Tuple_v vs')
          | _ => raise "??"
        end
      | _ => raise "??"
    end.

  Definition sideEffect (mo : mop) (ls : list value) : m unit :=
    modify (T := list (mop * list value)) (fun x => List.app x ((mo, ls) :: nil)) ;;
    ret tt.

  Fixpoint eval_decl (env:alist (var + cont) value) (d:decl) : m (alist (var + cont) value) :=
    match d with
      | Op_d x v =>
        v' <- eval_op env v ;;
        ret (extend env (inl x) v')
      | Fn_d f ks xs e =>
        p <- malloc (Closure_v env ks xs e) ;;
        ret (extend env (inl f) p)
      | Prim_d x p vs =>
        vs' <- mapM (eval_op env) vs ;;
        v <- eval_primop p vs' d ;;
        ret (extend env (inl x) v)
      | Bind_d x w m vs =>
        vs' <- mapM (eval_op env) vs ;;
        match vs' with
          | World_v n :: vs =>
            sideEffect m vs' ;;
            ret (extend (extend env (inl w) (World_v (Psucc n)))
                        (inl x) (Con_v "Tt"))
          | _ =>
            raise ("bad call to monadic op: (" ++ to_string d ++ ") args = [" ++ to_string vs' ++ "]")%string
        end
    end.

  Definition eval_cont (env:alist (var + cont) value) (k:cont) : m value :=
    v <- lookup env (inr k) ;;
    ret v.

  Definition malloc_dummyk (k_xs_e:cont * list var * exp) : m ((var + cont) * value) :=
    let '(k, _, _) := k_xs_e in
    v <- malloc (Tuple_v nil) ;;
    ret (inr k, v).

  Definition initialize_declk (env:alist (var + cont) value) (k_xs_e:cont * list var * exp) : m unit :=
    let '(k, xs, e) := k_xs_e in
    match Maps.lookup (inr k) env with
      | Some (Ptr_v n) => heap_set n (Closure_v env nil xs e)
      | _ => raise "??"
    end.

  Definition eval_exp (env:alist (var + cont) value) (e:exp) : m (list value) :=
    mfix2 _ (fun recur => fix eval_exp (env:alist (var + cont) value) (e:exp) {struct e} : m (list value) :=
      match e with
        | App_e v ks os =>
          v' <- eval_op env v ;;
          vs' <- mapM (eval_op env) os ;;
          vk' <- mapM (eval_cont env) ks ;;
          let _ : list value := vs' in
          let _ : list value := vk' in
          match v' with
            | Ptr_v z =>
              hv <- heap_lookup z ;;
              match hv with
                | Closure_v env kvs xs e =>
                  env' <- extends env (map (fun x => inl x) xs) vs' ;;
                  env' <- extends env' (map (fun x => inr x) kvs) vk' ;;
                  recur env' e
                | _ => raise ("applying non-function" ++ to_string hv)
              end
            | _ => raise "applying non-function"
          end
        | Let_e d e =>
          env' <- eval_decl env d ;;
          eval_exp env' e
        | Letrec_e ds e =>
          env' <- mapM malloc_dummy ds ;;
          let _ : alist (var + cont) value := env' in
          iterM (initialize_decl (env' ++ env)%list) ds ;;
          eval_exp (env' ++ env)%list e
        | Switch_e v arms def =>
          v' <- eval_op env v ;;
          e <- find_arm v' arms def ;;
          recur env e
        | Halt_e o w =>
          x <- eval_op env o ;;
          w <- eval_op env w ;;
          ret (x::w::nil)
        | AppK_e k os =>
          vs <- mapM (eval_op env) os ;;
          let _ : list _ := vs in
          v <- eval_cont env k ;;
          match v with
            | Ptr_v z =>
              hv <- heap_lookup z ;;
              match hv with
                | Closure_v env ks xs e =>
                  kvs <- mapM (eval_cont env) ks ;;
                  let _ : list _ := kvs in
                  env' <- extends env (map (fun x => inl x) xs) vs ;;
                  env' <- extends env' (map (fun x => inr x) ks) kvs ;;
                  recur env' e
                | _ => raise "applying non-function (continuation case)"
              end
            | _ => raise "applying non-function (continuation case)"
          end
        | LetK_e k_xs_e e =>
          env' <- mapM malloc_dummyk k_xs_e ;;
          iterM (initialize_declk (env' ++ env)%list) k_xs_e ;;
          eval_exp (env' ++ env)%list e
      end) env e.

  Definition run {A} (n:N) (c : m A) (h:heap) : string + (A * heap * list (mop * list value)) :=
    match runStateT (runStateT (runGFixT c n) h) nil with
      | inl err => inl err
      | inr (None,_,_) => inl "Out of fuel"%string
      | inr (Some x,y,z) => inr (x,y,z)
    end.

  Definition eval (n:N) (e:exp) : string + (list value * heap * list (mop * list value)) :=
    run n (eval_exp nil e) nil.

  Require Import CoqCompile.Parse.
  Require Import CoqCompile.CpsKConvert.
  Require CoqCompile.CloConvK.

  Definition evalstr (n:N) (io cc : bool) (s:string) : string * (string + (list value * heap * list (mop * list value))) :=
    match Parse.parse_topdecls s with
      | inl e => (s, inl e)
      | inr parse =>
        let cps := if io then CPS_io parse else CPS_pure parse in
        let program : string + CPSK.exp :=
          if cc then
            match CloConvK.ClosureConvert.cloconv_exp cps with
              | inl err => inl err
              | inr res =>
                inr (CPSK.Letrec_e res.(CPSK.decls) res.(CPSK.main))
            end
          else
            inr cps
        in
        match program with
          | inl err => (to_string program, inl err)
          | inr exp => (to_string program, eval n exp)
        end
    end.

  (*
    Section TEST_EVAL.
      Import LambdaNotation.
      Require Import ExtLib.Programming.Show.
      Require Import CoqCompile.CpsKConvert.
      Local Open Scope string_scope.

      Eval vm_compute in to_string (CPS_pure (gen ((\x => x) @ Z_c))).
      Eval vm_compute in eval 100 (CPS_pure (gen ((\x => x) @ Z_c))).

      Eval vm_compute in to_string (CPS_pure (gen e1)).
      Eval vm_compute in eval 100 (CPS_pure (gen e1)).

      Eval vm_compute in to_string (CPS_pure (gen e2)).
      Eval vm_compute in eval 100 (CPS_pure (gen e2)).

      Eval vm_compute in to_string (CPS_pure (gen e3)).
      Eval vm_compute in eval 100 (CPS_pure (gen e3)).

      Eval vm_compute in to_string (CPS_pure (gen e4)).
      Eval vm_compute in eval 100 (CPS_pure (gen e4)).  (** Evalutes to None in 100 steps because it diverges *)

      Eval vm_compute in to_string (CPS_pure (gen e5)).
      Eval vm_compute in eval 100 (CPS_pure (gen e5)).

      Eval vm_compute in to_string (CPS_pure (gen e6)).
      Eval vm_compute in eval 100 (CPS_pure (gen e6)).

      Eval vm_compute in to_string (CPS_pure (gen e7)).
      Eval vm_compute in eval 100 (CPS_pure (gen e7)).

      Eval vm_compute in to_string (CPS_pure (gen e8)).
      Eval vm_compute in eval 100 (CPS_pure (gen e8)).

    End TEST_EVAL.
  *)

End CPSEVAL.