Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From QuickChick Require Import QuickChick.
From adtind Require Import goal40.

Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq bool (lst_subset (Nil) (Nil)) (false)).
Admitted.
QuickChick lfind_hyp_test.


Require Import Source.

(* _____________________________________
                  SYNTAX
   _____________________________________ *)

Definition address : Type := nat.

(* For each component we have several procedures corresponding
to an entry point address *)
Definition entry_point : Type := address.
Definition entry_points : Type :=
  list (option (list entry_point)).

Definition dom_entry_points (E:entry_points) :
  list (option component_id) :=
  let indices := seq 0 (length E) in
  let combination := combine E indices in
  let f p :=
    match p with
    | (val,i) =>
      match val with
      | Some _ => [Some i]
      | None => [None]
      end
    end
  in
  concat (map f combination).

Definition fetch_entry_points
  (C:component_id) (P:procedure_id) (E:entry_points)
  : entry_point :=
  match (nth C E None) with
  | Some E' => nth P E' 0
  | None => 0
  end.

(* ------- Begin Definitions : Registers ------- *)

Definition register : Type := nat.

Definition nb_regs : nat := 7.
Definition r_pc : register :=
  0.
Definition r_one : register :=
  1.
Definition r_com : register :=
  2.
Definition r_aux1 : register :=
  3.
Definition r_aux2 : register :=
  4.
Definition r_ra : register :=
  5.
Definition r_sp : register :=
  6.

Definition registers : Type := list register.
Definition g_regs : registers :=
  map (fun x => 0) (seq 0 nb_regs).

(* ------- End Definitions : Registers ------- *)

Inductive LLbinop : Set :=
  | Add :  LLbinop
  | Minus : LLbinop
  | Mul : LLbinop
  | Eq : LLbinop
  | Leq : LLbinop.

Inductive instr : Type :=
  | Nop : instr
  | Const : nat -> address -> instr
  | Mov : address -> address -> instr
  | BinOp : LLbinop -> address -> address -> address -> instr
  | Load : address -> address -> instr
  | Store : address -> address -> instr
  | Jal : address -> instr
  | Jump : address -> instr
  | Call : component_id -> procedure_id -> instr
  | Return : instr
  | Bnz : address -> nat -> instr
  | Halt : instr.

Definition LLeval_binop (e : LLbinop * nat * nat) : nat :=
  match e with
  | (Add, a, b) => a+b
  | (Minus, a, b) => a-b
  | (Mul, a, b) => a*b
  | (Eq, a, b) => if beq_nat a b then 1 else 0
  | (Leq, a, b) => if ble_nat a b then 1 else 0
  end.

Definition memory : Type := list nat.
Definition global_memory : Type := list (option memory).

Definition dom_global_memory (mem:global_memory) :
  list (option component_id) :=
  let indices := seq 0 (length mem) in
  let combination := combine mem indices in
  let f p :=
    match p with
    | (val,i) =>
      match val with
      | Some _ => [Some i]
      | None => [None]
      end
    end
  in
  concat (map f combination).

Definition fetch_mem (C:component_id) (mem:global_memory)
  (a:address) : option nat :=
  match (nth a mem None) with
  | Some l => Some (nth C l 0)
  | _ => None
  end.

Definition code : Type :=
  list instr.

Definition decode (n:option nat) : option instr := admit.

Definition encode (i:instr) : option nat := admit.

Definition encode_code (c:code) : list nat := admit.

Theorem decode_encode :
  forall (i:instr), decode (encode i) = Some i.
Admitted.

Inductive protected_call : Type :=
  | PCall : component_id -> address -> protected_call.

Definition protected_callstack : Type :=
  list protected_call.

Definition component_memory : Type :=
  (code * protected_callstack * buffer).

Definition program : Type :=
  (partial_program_interfaces * global_memory * entry_points).

Definition get_interfacesLLP (P:program) :=
  match P with
  | (Is, _, _) => Is
  end.

Definition get_memLLP (P:program) :=
  match P with
  | (_, mem, _) => mem
  end.

Definition get_entrypointsLLP (P:program) :=
  match P with
  | (_, _, E) => E
  end.

(* _____________________________________
                SEMANTICS
   _____________________________________ *)

Definition state : Type :=
  (component_id *
   protected_callstack *
   global_memory *
   registers *
   address).

(* ------- Definitions : useful functions ------- *)
Definition fetch_reg (a:address) (reg:registers) : register :=
  nth a reg 0.

Fixpoint update_reg_value (a : address) (i' : option nat)
  (reg : registers) : memory :=
  match reg with
  | [] => []
  | h :: t =>
      match a with
      | 0 =>
        match i' with
        | Some v => v :: t
        | None => 0 :: t
        end
      | S n => h :: update_reg_value n i' t
      end
  end.

Definition update_reg (a:address) (i:option nat)
  (reg:registers) : registers :=
  update_reg_value a i reg.

Fixpoint clear_regs_aux (l:list nat) k (i:nat) :=
  match l with
    | [] => []
    | x :: l' =>
      let x' := if eq_nat_dec i k then x else 0 in
        x' :: (clear_regs_aux l' k (i+1))
  end.

Definition clear_regs l := clear_regs_aux l r_com 0.

Fixpoint update_mem (C:component_id) (mem:global_memory)
  (a:address) (new:nat) : global_memory :=
  match mem with
  | [] => []
  | h::t =>
    match C with
    | 0 =>
      match h with
      | Some h' => Some (update_value a new h') :: t
      | None => mem
      end
    | S C' => h::(update_mem C' mem a new)
    end
  end.

Definition call_exists (Is:partial_program_interfaces)
  (C:component_id) (P:procedure_id) : Prop :=
  match (nth C Is None) with
  | Some i =>
    let l := length Is in
    let import := get_import i in
    (ble_nat C l) && negb (beq_nat C l) = true /\ (In (C,P) import)
  | None => False
  end.

Definition boolean_call_exists (Is:partial_program_interfaces)
  (C:component_id) (P:procedure_id) : bool :=
  let l := length Is in
  match (nth C Is None) with
  | Some i =>
    let import := get_import i in
    (ble_nat C l) && negb (beq_nat C l)
      &&
    (existsb (fun x => (fst x =? C) && (snd x =? P)) import)
  | None => false
  end.

(* ------- Definitions : operational semantics ------- *)
Reserved Notation "'LOW_LEVEL' Is ; E |- s '⇒' s'" (at level 40).
Inductive step (Is:partial_program_interfaces) (E:entry_points) :
  state -> state -> Prop :=
  (* S_Nop *)
  | S_Nop : forall mem C pc i d reg,
    (fetch_mem C mem pc = i) ->
    (decode i = Some Nop) ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg,pc+1)
  (* S_Const *)
  | S_Const : forall mem C pc i r i' d reg reg',
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Const i' r)) ->
    (update_reg r (Some i') reg = reg') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg',pc+1)
  (* S_Mov *)
  | S_Mov : forall mem C pc i r1 r2 reg reg' d,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Mov r1 r2)) ->
    (update_reg r2 (Some (fetch_reg r1 reg)) reg = reg') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg',pc+1)
  (* S_BinOp *)
  | S_BinOp : forall mem C pc i r1 r2 r3 reg reg' d op,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (BinOp op r1 r2 r3)) ->
    (update_reg r3 (Some (LLeval_binop (op, (fetch_reg r1 reg), (fetch_reg r2 reg)))) reg = reg') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg',pc+1)
  (* S_Load *)
  | S_Load : forall mem C pc i r1 r2 reg reg' d i1,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Load r1 r2)) ->
    (fetch_reg r1 reg = i1) ->
    (update_reg r2 (fetch_mem C mem i1) reg = reg') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg',pc+1)
  (* S_Store *)
  | S_Store : forall mem C pc i r1 r2 reg d i1 i2 mem',
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Store r1 r2)) ->
    (fetch_reg r1 reg = i1) ->
    (fetch_reg r2 reg = i2) ->
    (update_mem C mem i1 i2 = mem') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem',reg,pc+1)
  (* S_Jal *)
  | S_Jal : forall mem C pc i i' r reg reg' d,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Jal r)) ->
    (fetch_reg r reg = i') ->
    (update_reg r_ra (Some (pc+1)) reg = reg') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg',i')
  (* S_Call *)
  | S_Call : forall mem C pc i reg d d' C' P',
    (fetch_mem C mem pc = i) ->
    call_exists Is C' P' ->
    (decode i = Some (Call C' P')) ->
    match (nth C Is None) with
    | Some i =>
      (In (C',P') (get_import i) \/ C' = C)
    | None => False \/ C' = C
    end ->
      (d' = (PCall C (pc+1))::d) ->
      LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C',d',mem,reg,fetch_entry_points C' P' E)
  (* S_Jump *)
  | S_Jump : forall mem C pc i i' r reg d,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Jump r)) ->
    (fetch_reg r reg = i') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg,i')
  (* S_Return *)
  | S_Return : forall mem C pc i i' d' reg d C',
    (fetch_mem C mem pc = i) ->
    (decode i = Some Return) ->
    (d = (PCall C' i')::d') ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C',d',mem,reg,i')
  (* S_BnzNZ *)
  | S_BnzNZ : forall mem C pc i i' r reg d,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Bnz r i')) ->
    ~(fetch_reg r reg = 0) ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg,pc+i')
  (* S_BnzZ *)
  | S_BnzZ : forall mem C pc i i' r reg d,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Bnz r i')) ->
    (fetch_reg r reg = 0) ->
    LOW_LEVEL Is;E |- (C,d,mem,reg,pc) ⇒ (C,d,mem,reg,pc+1)
  where "'LOW_LEVEL' Is ; E |- s '⇒' s'" := (step Is E s s').

(* ------- Definitions : Multi-step reduction ------- *)
Definition LV_multi_step
  (Is:partial_program_interfaces) (E:entry_points)
  (e e':state) :=
    (multi (step Is E) e e').

(* ------- Definitions : Irreducibility ------- *)
Definition state_irreducible
  (Is:partial_program_interfaces) (E:entry_points)
  (cfg:state) : Prop :=
  ~(exists cfg', (step Is E cfg cfg')).

(* ------- Definitions : Special reduction state ------- *)
Definition LL_initial_cfg_of (P:program) : state :=
  match P with
  | (Is, mem, E) =>
    let ep :=
      match (nth main_cid E None) with
      | Some E' => nth 0 E' 0
      | None => 0
      end
    in
    (main_cid, [], mem, g_regs, ep)
  end.

Inductive stuck_state :
  partial_program_interfaces -> state -> Prop :=
  (* S_DecodingError *)
  | S_DecodingError : forall Is i C d mem reg pc,
    (fetch_mem C mem pc = i) ->
    (decode i = None) -> stuck_state Is (C,d,mem,reg,pc)
  (* S_CallFail *)
  | S_CallFail : forall Is i C C' P' d mem reg pc,
    (fetch_mem C mem pc = i) ->
    (decode i = Some (Call C' P')) ->
    ~(call_exists Is C' P') ->
    stuck_state Is (C,d,mem,reg,pc)
  (* S_EmptyCallStack *)
  | S_EmptyCallStack : forall Is C mem reg pc,
    stuck_state Is (C,[],mem,reg,pc)
  (* S_Halt *)
  | S_Halt : forall Is i C d mem reg pc,
    (fetch_mem C mem pc = i) ->
    (decode i = Some Halt) ->
    stuck_state Is (C,d,mem,reg,pc).

Definition boolean_stuckstate (Is:partial_program_interfaces)
  (cfg:state) : bool :=
  match cfg with
  | (C,d,mem,reg,pc) =>
    let i := fetch_mem C mem pc in
    match (decode i) with
    (* S_Return_EmptyCallStack *)
    | Some Return =>
      if (length d =? 0) then
        true
      else
        false
    (* S_CallFail *)
    | Some (Call C' P') =>
      if (boolean_call_exists Is C' P') then
        false
      else
        true
    (* S_Halt *)
    | Some Halt => true
    (* S_DecodingError & Non-stuck states *)
    | _ => false
    end
  end.

(* _____________________________________
          EVALUATION FUNCTION
   _____________________________________ *)

Definition basic_eval_step
  (Is:partial_program_interfaces) (E:entry_points)
  (cfg:state) : state :=
  match cfg with
  | (C,d,mem,reg,pc) =>
    let i := fetch_mem C mem pc in
    match (decode i) with
    (* S_Nop *)
    | Some Nop =>
      (C,d,mem,reg,pc+1)
    (* S_Const *)
    | Some (Const i' r) =>
      let reg' := (update_reg r (Some i') reg) in
      (C,d,mem,reg',pc+1)
    (* S_Mov *)
    | Some (Mov r1 r2) =>
      let reg' := (update_reg r2 (Some (fetch_reg r1 reg)) reg) in
      (C,d,mem,reg',pc+1)
    (* S_BinOp *)
    | Some (BinOp op r1 r2 r3) =>
      let reg' := (update_reg r3 (Some (LLeval_binop
        (op, (fetch_reg r1 reg), (fetch_reg r2 reg)))) reg) in
      (C,d,mem,reg',pc+1)
    (* S_Load *)
    | Some (Load r1 r2) =>
      let i1 := (fetch_reg r1 reg) in
      let reg' := (update_reg r2 (fetch_mem C mem i1) reg) in
      (C,d,mem,reg',pc+1)
    (* S_Store *)
    | Some (Store r1 r2) =>
      let i1 := (fetch_reg r1 reg) in
      let i2 := (fetch_reg r2 reg) in
      let mem' := (update_mem C mem i1 i2) in
      (C,d,mem',reg,pc+1)
    (* S_Jal *)
    | Some (Jal r) =>
      let i' := (fetch_reg r reg) in
      let reg' := (update_reg r_ra (Some (pc+1)) reg) in
      (C,d,mem,reg',i')
    (* S_Call *)
    | Some (Call C' P') =>
      let imp :=
        match (nth C Is None) with
        | Some i => (get_import i)
        | None => []
        end
      in
      if ((boolean_call_exists Is C' P')
          &&
         (existsb (fun x => (fst x =? C') && (snd x =? P')) imp)
            ||
        beq_nat C' C) then
        let d' := (PCall C (pc+1))::d in
        (C',d',mem,reg,fetch_entry_points C' P' E)
      else
        cfg
    (* S_Jump *)
    | Some (Jump r) =>
      let i' := (fetch_reg r reg) in
      (C,d,mem,reg,i')
    (* S_Return *)
    | Some Return =>
      match d with
      | [] => cfg
      | (PCall C' i')::d' => (C',d',mem,reg,i')
      end
    (* S_BnzNZ *)
    | Some (Bnz r i') =>
      if negb (fetch_reg r reg =? 0) then
        (C,d,mem,reg,pc+i')
      else
        (C,d,mem,reg,pc+1)
    | _ => cfg
    end
  end.

Fixpoint eval_step
  (Is:partial_program_interfaces) (E:entry_points)
  (cfg:state) (limit:nat) : state :=
  match limit with
  | 0 => cfg
  | S n =>
    match cfg with
    | (C,d,mem,reg,pc) =>
      if boolean_stuckstate Is cfg then
        cfg
      else
        eval_step Is E (basic_eval_step Is E cfg) n
    end
  end.

(* _____________________________________
          PROOF : DETERMINISM
   _____________________________________ *)

Lemma in_import_eq :
  forall C' P' i,
  In (C', P') (get_import i) ->
  existsb (fun x : nat * nat =>
    (fst x =? C') && (snd x =? P')) (get_import i) = true.
Proof.
  intros.
  induction (get_import i).
  - inversion H.
  - simpl in H. destruct H.
    + rewrite H. simpl.
      assert ((C' =? C') && (P' =? P') = true) as Ha.
      rewrite <- (beq_nat_refl C').
      rewrite <- (beq_nat_refl P').
      trivial. rewrite Ha. simpl. trivial.
    + apply IHl in H. simpl. rewrite H.
      apply orb_comm.
Qed.

Lemma callexists_boolean_eq :
  forall Is C' P',
  call_exists Is C' P' -> boolean_call_exists Is C' P' = true.
Proof.
  intros. unfold call_exists in H. unfold boolean_call_exists.
  destruct (nth C' Is None).
  - destruct H. rewrite H. apply in_import_eq in H0.
    rewrite H0. trivial.
  - contradiction.
Qed.

Lemma step_eval_1step :
  forall Is E cfg1 cfg2,
  (LOW_LEVEL Is;E |- cfg1 ⇒ cfg2) -> eval_step Is E cfg1 1 = cfg2.
Proof.
  intros.
  destruct cfg1 as [[[[C1 d1] mem1] reg1] pc1].
  destruct cfg2 as [[[[C2 d2] mem2] reg2] pc2].
  induction H;
  rename H into H_fetch; rename H0 into H_decode;
  unfold eval_step; unfold boolean_stuckstate;
  rewrite H_fetch; try (rewrite H_decode); simpl;
  rewrite H_fetch; try (rewrite H_decode); simpl;
  try (subst; reflexivity).
  - rewrite H1. simpl.
    destruct (boolean_call_exists Is C' P') eqn:HD.
    + simpl. destruct (nth C Is None). destruct H2; rewrite H3.
      apply in_import_eq in H. rewrite H. simpl. reflexivity.
      rewrite H. assert (C =? C = true).
      { symmetry. apply beq_nat_refl. }
      rewrite H0. remember (existsb (fun x : nat * nat =>
      (fst x =? C) && (snd x =? P')) (get_import i0)) as t_exists.
      rewrite (orb_comm t_exists true). simpl. reflexivity.
      destruct H2. contradiction.
      rewrite H. assert (C =? C = true).
      { symmetry. apply beq_nat_refl. }
      rewrite H0. simpl. rewrite H3. reflexivity.
    + destruct (nth C Is None).
      * destruct H2; apply callexists_boolean_eq in H_decode;
        rewrite H_decode in HD; inversion HD.
      * destruct H2; apply callexists_boolean_eq in H_decode;
        rewrite H_decode in HD; inversion HD.
  - apply false_beq_nat in H1. rewrite H1. simpl. reflexivity.
  - rewrite H1. simpl. reflexivity.
Qed.

Theorem abstractmachine_determinism :
  forall Is E cfg cfg1 cfg2,
  (LOW_LEVEL Is;E |- cfg ⇒ cfg1) /\ (LOW_LEVEL Is;E |- cfg ⇒ cfg2) ->
  cfg1 = cfg2.
Proof.
  intros. destruct H as [Hcfg1 Hcfg2].
  apply step_eval_1step in Hcfg1.
  apply step_eval_1step in Hcfg2.
  rewrite <- Hcfg1. rewrite <- Hcfg2.
  reflexivity.
Qed.


(** * Computability Logic *)

(** This is an attempt at formalizing Giorgi Japaridze's Computability
    Logic based on "In the beginning was game semantics" from the book
    "Games: Unifying Logic, Language, and Philosophy".

    The approach is to replace Japaridze's "classical" definitions with
    mainly coinductive ones friendly to type theory. Currently it's
    rather experimental and certainly very broken, because he seems to
    define game operations by defining their structure and winner mutually
    at the same time. Here this would require mutual coinduction and I
    don't know how to do it properly. *)

Require Import List.
Import ListNotations.

Require Import Bool Arith FunctionalExtensionality Setoid.

Axiom LEM : forall P : Prop, P \/ ~ P.

Inductive Player : Type :=
    | Machine : Player
    | Nature : Player.

CoInductive ConstantGame : Type :=
{
    winner : Player -> Prop;
    winner_spec :
      forall p p' : Player, winner p -> winner p' -> p = p';
    winner_spec' :
      exists p : Player, winner p;
    Labmove : Type;
    who : Labmove -> Player;
    next : Labmove -> ConstantGame;
}.

Definition Win : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => True
          | Nature => False
      end;
    Labmove := Empty_set;
    who l := match l with end;
    next l := match l with end;
|}.
  destruct p, p'; firstorder.
  exists Machine. trivial.
Defined.

CoFixpoint Lose : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => False
          | Nature => True
      end;
    Labmove := Empty_set;
    who l := match l with end;
    next l := match l with end;
|}.
  destruct p, p'; firstorder.
  exists Nature. trivial.
Defined.

Definition swap (p : Player) : Player :=
match p with
    | Machine => Nature
    | Nature => Machine
end.

Definition transport
  {A : Type} (P : A -> Type) {x y : A} (p : x = y) : P x -> P y.
Proof.
  destruct p. intro. assumption.
Defined.

Lemma transport_cat :
  forall
    (A : Type) (P : A -> Type) (x y z : A) (p : x = y) (q : y = z) (u : P x),
      transport P q (transport P p u) = transport P (eq_trans p q) u.
Proof.
  destruct p, q. cbn. reflexivity.
Defined.

Lemma cat_inv :
  forall (A : Type) (x y : A) (p : x = y),
    eq_trans (eq_sym p) p = eq_refl.
Proof.
  destruct p. cbn. reflexivity.
Defined.

CoInductive sim (g1 g2 : ConstantGame) : Prop :=
{
    winners : forall p : Player, winner g1 p <-> winner g2 p;
    Labmoves : Labmove g1 = Labmove g2;
    whos :
      forall move : Labmove g1,
        who g1 move = who g2 (@transport _ id _ _ Labmoves move);
    nexts :
      forall move : Labmove g1,
        sim (next g1 move)
          (next g2 (@transport _ id _ _ Labmoves move))
}.

Axiom sim_eq :
  forall g1 g2 : ConstantGame, sim g1 g2 -> g1 = g2.

(** The axiom is fine, because replacing [sim] with [=] in the definition
    of [sim] gives exactly what HoTT tells us is the characterization of
    paths for constant games. *)

Lemma sim_refl :
  forall g : ConstantGame, sim g g.
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: reflexivity.
    all: cbn; try reflexivity.
    apply CH.
Qed.

Lemma sim_sym :
  forall g1 g2 : ConstantGame,
    sim g1 g2 -> sim g2 g1.
Proof.
  cofix CH.
  destruct 1 as [w p whos nexts].
  econstructor. Unshelve.
    4: auto.
    firstorder.
    intro. rewrite whos, transport_cat, cat_inv. cbn. reflexivity.
    intro. apply CH.
      specialize (nexts (@transport _ id _ _ (eq_sym p) move)).
      rewrite transport_cat, cat_inv in *. cbn in *.
        assumption.
Qed.

Lemma sim_trans :
  forall g1 g2 g3 : ConstantGame,
    sim g1 g2 -> sim g2 g3 -> sim g1 g3.
Proof.
  cofix CH.
  destruct 1 as [w1 p1 whos1 nexts1],
           1 as [w2 p2 whos2 nexts2].
  econstructor. Unshelve.
    4: exact (eq_trans p1 p2).
    firstorder.
    intro. rewrite whos1, whos2, transport_cat. reflexivity.
    intro. apply (CH _ (next g2 (transport id p1 move))).
      apply nexts1.
      rewrite <- transport_cat. apply nexts2.
Qed.

#[export]
Instance Equivalence_sim : Equivalence sim.
Proof.
  split; red.
    apply sim_refl.
    apply sim_sym.
    apply sim_trans.
Defined.

(** Tactics *)

#[global] Hint Constructors Player : CoL.

#[global] Hint Extern 1 =>
match goal with
    | |- exists p : Player, _ => exists Machine; cbn
end : CoL.

#[global] Hint Extern 1 =>
match goal with
    | |- exists p : Player, _ => exists Nature; cbn
end : CoL.

(** Connectives *)

Ltac des g :=
  let winner := fresh "winner" in
  let spec1 := fresh "spec1" in
  let p := fresh "p" in
  let spec2 := fresh "spec2" in
  let Labmove := fresh "Labmove" in
  let who := fresh "who" in
  let next := fresh "next" in
    destruct g as [winner spec1 [p spec2] Labmove who next]; cbn in *.

CoFixpoint Not (g : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => winner g Nature
          | Nature => winner g Machine
      end;
    Labmove := Labmove g;
    who move := swap (who g move);
    next move := Not (next g move);
|}.
  destruct g, p, p'; firstorder.
  des g. exists (swap p). destruct p; cbn; assumption.
Defined.

Definition chor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
  refine
  {|
      winner p := p = Nature;
      Labmove := bool;
      who move := Machine;
      next move := if move then g1 else g2;
  |}.
  destruct p, p'; firstorder.
  exists Nature. trivial.
Defined.

Definition chand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := p = Machine;
    Labmove := bool;
    who move := Nature;
    next move := if move then g1 else g2;
|}.
  destruct p, p'; firstorder.
  exists Machine. trivial.
Defined.

Definition chexists {A : Type} (f : A -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := p = Nature;
    Labmove := A;
    who move := Machine;
    next move := f move;
|}.
  destruct p, p'; firstorder.
  exists Nature. reflexivity.
Defined.

Definition chall {A : Type} (f : A -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := p = Machine;
    Labmove := A;
    who move := Nature;
    next move := f move;
|}.
  destruct p, p'; firstorder.
  exists Machine. reflexivity.
Defined.

CoFixpoint por (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => winner g1 Machine \/ winner g2 Machine
          | Nature => winner g1 Nature /\ winner g2 Nature
      end;
    Labmove := Labmove g1 + Labmove g2;
    who move :=
      match move with
          | inl move' => who g1 move'
          | inr move' => who g2 move'
      end;
    next move :=
      match move with
          | inl move' => por (next g1 move') g2
          | inr move' => por g1 (next g2 move')
      end
|}.
  destruct g1, g2, p, p'; firstorder.
  destruct (LEM (winner g1 Machine)).
    exists Machine. auto.
    destruct (LEM (winner g2 Machine)).
      exists Machine. auto.
      exists Nature. des g1; des g2. destruct p, p0; auto; contradiction.
Defined.

CoFixpoint pand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => winner g1 Machine /\ winner g2 Machine
          | Nature => winner g1 Nature \/ winner g2 Nature
      end;
    Labmove := Labmove g1 + Labmove g2;
    who move :=
      match move with
          | inl move' => who g1 move'
          | inr move' => who g2 move'
      end;
    next move :=
      match move with
          | inl move' => pand (next g1 move') g2
          | inr move' => pand g1 (next g2 move')
      end
|}.
  destruct g1, g2, p, p'; firstorder.
  destruct (LEM (winner g1 Nature)).
    exists Nature. auto.
    destruct (LEM (winner g2 Nature)).
      exists Nature. auto.
      exists Machine. des g1; des g2. destruct p, p0; auto; contradiction.
Defined.

CoFixpoint pexists (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => exists n : nat, winner (f n) Machine
          | Nature => forall n : nat, winner (f n) Nature
      end;
    Labmove := {n : nat & Labmove (f n)};
    who move :=
      match move with
          | existT _ n move => who (f n) move
      end;
    next move :=
      match move with
          | existT _ n move =>
              pexists (fun m : nat => if n =? m then next (f n) move else f m)
      end
|}.
  destruct p, p'; try reflexivity.
    intros [n H] H'. specialize (H' n). destruct (f n). auto.
    intros H [n H']. specialize (H n). destruct (f n). auto.
  destruct (LEM (exists n : nat, winner (f n) Machine)).
    exists Machine. assumption.
    exists Nature. intro. destruct (LEM (winner (f n) Nature)).
      assumption.
      contradict H. exists n. destruct (LEM (winner (f n) Machine)).
        assumption.
        destruct (f n), winner_spec'0 as [[] H']; cbn in *; contradiction.
Defined.

CoFixpoint pall (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p :=
      match p with
          | Machine => forall n : nat, winner (f n) Machine
          | Nature => exists n : nat, winner (f n) Nature
      end;
    Labmove := {n : nat & Labmove (f n)};
    who move :=
      match move with
          | existT _ n move => who (f n) move
      end;
    next move :=
      match move with
          | existT _ n move =>
              pall (fun m : nat => if n =? m then next (f n) move else f m)
      end
|}.
  destruct p, p'; try reflexivity.
    intros H [n H']. specialize (H n). destruct (f n). auto.
    intros [n H] H'. specialize (H' n). destruct (f n). auto.
  destruct (LEM (exists n : nat, winner (f n) Nature)).
    exists Nature. assumption.
    exists Machine. intro. destruct (LEM (winner (f n) Machine)).
      assumption.
      contradict H. exists n. destruct (LEM (winner (f n) Nature)).
        assumption.
        destruct (f n), winner_spec'0 as [[] H']; cbn in *; contradiction.
Defined.

CoFixpoint sor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner g1 p;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Machine
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => g2
          | Some move' => sor (next g1 move') g2
      end;
|}.
  all: destruct g1; auto.
Defined.

CoFixpoint sand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner g1 p;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Nature
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => g2
          | Some move' => sand (next g1 move') g2
      end;
|}.
  all: destruct g1; auto.
Defined.

CoFixpoint sexists (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner (f 0) p;
    Labmove := option (Labmove (f 0));
    who move :=
      match move with
          | None => Machine
          | Some move' => who (f 0) move'
      end;
    next move :=
      match move with
          | None => sexists (fun n : nat => f (S n))
          | Some move' =>
              sexists (fun n : nat =>
                      match n with
                          | 0 => next (f 0) move'
                          | S n' => f (S n')
                      end)
      end;
|}.
  all: destruct (f 0); auto.
Defined.

CoFixpoint sall (f : nat -> ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner (f 0) p;
    Labmove := option (Labmove (f 0));
    who move :=
      match move with
          | None => Nature
          | Some move' => who (f 0) move'
      end;
    next move :=
      match move with
          | None => sall (fun n : nat => f (S n))
          | Some move' =>
              sall (fun n : nat =>
                      match n with
                          | 0 => next (f 0) move'
                          | S n' => f (S n')
                      end)
      end;
|}.
  all: destruct (f 0); auto.
Defined.

CoFixpoint tor (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner g1 p;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Machine
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => tor g2 g1
          | Some move' => tor (next g1 move') g2
      end;
|}.
  all: destruct g1; auto.
Defined.

CoFixpoint tand (g1 g2 : ConstantGame) : ConstantGame.
Proof.
refine
{|
    winner p := winner g1 p;
    Labmove := option (Labmove g1);
    who move :=
      match move with
          | None => Nature
          | Some move' => who g1 move'
      end;
    next move :=
      match move with
          | None => tand g2 g1
          | Some move' => tand (next g1 move') g2
      end;
|}.
  all: destruct g1; auto.
Defined.

CoFixpoint texists' (f : nat -> ConstantGame) (n : nat) : ConstantGame.
Proof.
refine
{|
    winner p := winner (f n) p;
    Labmove := Labmove (f n) + nat;
    who move :=
      match move with
          | inl move' => who (f n) move'
          | inr _ => Machine
      end;
    next move :=
      match move with
          | inl move' => texists'
              (fun m : nat => if n =? m then next (f n) move' else f m) n
          | inr m => texists' f m
      end;
|}.
  all: destruct (f n); auto.
Defined.

CoFixpoint tall' (f : nat -> ConstantGame) (n : nat) : ConstantGame.
Proof.
refine
{|
    winner p := winner (f n) p;
    Labmove := Labmove (f n) + nat;
    who move :=
      match move with
          | inl move' => who (f n) move'
          | inr _ => Nature
      end;
    next move :=
      match move with
          | inl move' => tall'
              (fun m : nat => if n =? m then next (f n) move' else f m) n
          | inr m => tall' f m
      end;
|}.
  all: destruct (f n); auto.
Defined.

Definition texists (f : nat -> ConstantGame) : ConstantGame :=
  texists' f 0.

Definition tall (f : nat -> ConstantGame) : ConstantGame :=
  tall' f 0.

(** Some proofs - de Morgan laws *)

Lemma Not_Not :
  forall g : ConstantGame,
    sim (Not (Not g)) g.
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: cbn; reflexivity.
    destruct p; firstorder.
    cbn. destruct (who g move); cbn; reflexivity.
    apply CH.
Qed.

Lemma Not_chor :
  forall g1 g2 : ConstantGame,
    sim (Not (chor g1 g2)) (chand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: cbn; reflexivity.
    destruct p; firstorder congruence.
    reflexivity.
    cbn. destruct move; apply sim_refl.
Qed.

Lemma Not_chand :
  forall g1 g2 : ConstantGame,
    sim (Not (chand g1 g2)) (chor (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor; cbn; intros. Unshelve.
    4: cbn; reflexivity.
    destruct p; firstorder congruence.
    reflexivity.
    cbn. destruct move; apply sim_refl.
Qed.

Lemma Not_chexists :
  forall (A : Type) (f : A -> ConstantGame),
    sim (Not (chexists f)) (chall (fun x : A => Not (f x))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn.
      destruct p; firstorder congruence.
      reflexivity.
      intro. apply sim_refl.
Qed.

Lemma Not_chall :
  forall (A : Type) (f : A -> ConstantGame),
    sim (Not (chall f)) (chexists (fun x : A => Not (f x))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn.
      destruct p; firstorder congruence.
      reflexivity.
      intro. apply sim_refl.
Qed.

Lemma Not_por :
  forall g1 g2 : ConstantGame,
    sim (Not (por g1 g2)) (pand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      destruct p; firstorder.
      destruct move; reflexivity.
      destruct move; apply CH.
Qed.

Lemma Not_pand :
  forall g1 g2 : ConstantGame,
    sim (Not (pand g1 g2)) (por (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      destruct p; firstorder.
      destruct move; reflexivity.
      destruct move; apply CH.
Qed.

Lemma Not_pexists :
  forall f : nat -> ConstantGame,
    sim (Not (pexists f)) (pall (fun n : nat => Not (f n))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move. reflexivity.
      destruct move as [n move].
        replace (pall _) with (pall
          (fun m : nat => Not (if n =? m then next (f n) move else f m))).
          apply CH.
          f_equal. extensionality m. destruct (n =? m); reflexivity.
Qed.

Lemma Not_pall :
  forall f : nat -> ConstantGame,
    sim (Not (pall f)) (pexists (fun n : nat => Not (f n))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move. reflexivity.
      destruct move as [n move].
        replace (pexists _) with (pexists
          (fun m : nat => Not (if n =? m then next (f n) move else f m))).
          apply CH.
          f_equal. extensionality m. destruct (n =? m); reflexivity.
Qed.

Lemma Not_sor :
  forall g1 g2 : ConstantGame,
    sim (Not (sor g1 g2)) (sand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        apply CH.
        apply sim_refl.
Qed.

Lemma Not_sand :
  forall g1 g2 : ConstantGame,
    sim (Not (sand g1 g2)) (sor (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        apply CH.
        apply sim_refl.
Qed.

Lemma Not_sexists :
  forall f : nat -> ConstantGame,
    sim (Not (sexists f)) (sall (fun n : nat => Not (f n))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        replace (sall _) with (sall
          (fun n : nat => Not
          match n with
              | 0 => next (f 0) l
              | S n' => f (S n')
          end)).
          apply CH.
          f_equal. extensionality n. destruct n; reflexivity.
        apply CH.
Qed.

Lemma Not_sall :
  forall f : nat -> ConstantGame,
    sim (Not (sall f)) (sexists (fun n : nat => Not (f n))).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        replace (sexists _) with (sexists
          (fun n : nat => Not
          match n with
              | 0 => next (f 0) l
              | S n' => f (S n')
          end)).
          apply CH.
          f_equal. extensionality n. destruct n; reflexivity.
        apply CH.
Qed.

Lemma Not_tor :
  forall g1 g2 : ConstantGame,
    sim (Not (tor g1 g2)) (tand (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn.
      reflexivity.
      destruct move; reflexivity.
      destruct move; apply CH.
Qed.

Lemma Not_tand :
  forall g1 g2 : ConstantGame,
    sim (Not (tand g1 g2)) (tor (Not g1) (Not g2)).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn.
      reflexivity.
      destruct move; reflexivity.
      destruct move; apply CH.
Qed.

Lemma Not_texists' :
  forall (f : nat -> ConstantGame) (n : nat),
    sim (Not (texists' f n)) (tall' (fun n : nat => Not (f n)) n).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        2: apply CH.
        replace (tall' _ _) with (tall'
          (fun m : nat => Not (if n =? m then next (f n) l else f m)) n).
          apply CH.
          f_equal. extensionality m. destruct (n =? m); reflexivity.
Qed.

Lemma Not_tall' :
  forall (f : nat -> ConstantGame) (n : nat),
    sim (Not (tall' f n)) (texists' (fun n : nat => Not (f n)) n).
Proof.
  cofix CH.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    all: cbn; intros.
      reflexivity.
      destruct move; reflexivity.
      destruct move.
        2: apply CH.
        replace (texists' _ _) with (texists'
          (fun m : nat => Not (if n =? m then next (f n) l else f m)) n).
          apply CH.
          f_equal. extensionality m. destruct (n =? m); reflexivity.
Qed.

Lemma Not_texists :
  forall f : nat -> ConstantGame,
    sim (Not (texists f)) (tall (fun n : nat => Not (f n))).
Proof.
  intros. apply Not_texists'.
Qed.

Lemma Not_tall :
  forall f : nat -> ConstantGame,
    sim (Not (tall f)) (texists (fun n : nat => Not (f n))).
Proof.
  intros. apply Not_tall'.
Qed.

(** Connectives preserve bisimilarity *)

Lemma sim_Not :
  forall g1 g2 : ConstantGame,
    sim g1 g2 -> sim (Not g1) (Not g2).
Proof.
  cofix CH.
  destruct 1.
  econstructor. Unshelve.
    4: cbn; assumption.
    cbn. destruct p; firstorder.
    intro. cbn. f_equal. apply whos0.
    intro. cbn. apply CH. apply nexts0.
Qed.

Lemma sim_chor :
  forall g1 g1' g2 g2' : ConstantGame,
    sim g1 g1' -> sim g2 g2' -> sim (chor g1 g2) (chor g1' g2').
Proof.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    firstorder.
    auto.
    destruct move; assumption.
Qed.

Lemma sim_chand :
  forall g1 g1' g2 g2' : ConstantGame,
    sim g1 g1' -> sim g2 g2' -> sim (chand g1 g2) (chand g1' g2').
Proof.
  econstructor. Unshelve.
    4: cbn; reflexivity.
    firstorder.
    auto.
    destruct move; assumption.
Qed.

(** And so on *)

(** * Strictness *)

(** A constant game is strict if players make moves in turns. *)
CoInductive Strict (g : ConstantGame) : Prop :=
{
    strict :
      (forall move : Labmove g, who g move = Machine) \/
      (forall move : Labmove g, who g move = Nature);
    stricts :
      forall move : Labmove g, Strict (next g move);
}.

Lemma Strict_Win : Strict Win.
Proof.
  constructor; cbn.
    left. destruct move.
    destruct move.
Qed.

Lemma Strict_Lose : Strict Lose.
Proof.
  constructor; cbn.
    left. destruct move.
    destruct move.
Qed.

Lemma Strict_Not :
  forall g : ConstantGame,
    Strict g -> Strict (Not g).
Proof.
  cofix CH.
  destruct 1 as [H1 H2]. constructor.
    destruct H1 as [H1 | H1]; [right | left];
      cbn; intro; rewrite H1; reflexivity.
    intro. cbn. apply CH. apply H2.
Qed.

Lemma Strict_chor :
  forall g1 g2 : ConstantGame,
    Strict g1 -> Strict g2 -> Strict (chor g1 g2).
Proof.
  cofix CH.
  constructor; cbn.
    left. auto.
    destruct move; assumption.
Qed.

Lemma Strict_chand :
  forall g1 g2 : ConstantGame,
    Strict g1 -> Strict g2 -> Strict (chand g1 g2).
Proof.
  cofix CH.
  constructor; cbn.
    right. auto.
    destruct move; assumption.
Qed.

Lemma Strict_chexists :
  forall (A : Type) (f : A -> ConstantGame),
    (forall x : A, Strict (f x)) -> Strict (chexists f).
Proof.
  cofix CH.
  intros. constructor; cbn.
    left. auto.
    apply H.
Qed.

Lemma Strict_chall :
  forall (A : Type) (f : A -> ConstantGame),
    (forall x : A, Strict (f x)) -> Strict (chall f).
Proof.
  cofix CH.
  intros. constructor; cbn.
    right. auto.
    apply H.
Qed.

(** Parallel, sequential and toggling connectives (and therefore quantifiers)
    need not preserve strictness, because:
    - for parallel, both players can make moves
    - for sequential, one player may make moves but the other may change
    - for toggling, the same as for sequential *)

(*
Lemma Strict_sor :
  forall g1 g2 : ConstantGame,
    Strict g1 -> Strict g2 -> Strict (sor g1 g2).
Proof.
  cofix CH.
  destruct 1 as [H11 H12], 1 as [H21 H22]. constructor; cbn.
    left. destruct move.
    apply right. auto.
    destruct move; assumption.
Qed.

Lemma Strict_por :
  forall g1 g2 : ConstantGame,
    Strict g1 -> Strict g2 -> Strict (por g1 g2).
Proof.
  cofix CH.
  destruct 1 as [H11 H12], 1 as [H21 H22]. constructor.
    destruct H11 as [H11 | H11], H21 as [H21 | H21]. cbn.
      left. destruct move; auto.
      left. cbn. destruct move; auto.
Abort.
*)

(** * A game should have a winner... *)

(** Beware: a game can have two winners if it is not a static game. *)
CoInductive Winner (g : ConstantGame) (p : Player) : Prop :=
{
    Winner0 : (Labmove g -> False) -> winner g p;
    Winner1 :
      Labmove g ->
        (exists move : Labmove g,
          who g move = p /\ Winner (next g move) p) \/
        (forall move : Labmove g,
          who g move = swap p -> Winner (next g move) p);
}.

Lemma Winner_Win_Machine :
  Winner Win Machine.
Proof.
  constructor; cbn.
    auto.
    destruct 1.
Qed.

Lemma Winner_Win_not_Nature :
  ~ Winner Win Nature.
Proof.
  destruct 1; cbn in *.
  apply Winner2. destruct 1.
Qed.

Lemma Winner_Lose_Nature :
  Winner Lose Nature.
Proof.
  constructor; cbn.
    auto.
    destruct 1.
Qed.

Definition nonstatic : ConstantGame.
Proof.
refine
{|
    winner p := p = Machine;
    Labmove := bool;
    who move := if move then Machine else Nature;
    next move := if move then Win else Lose;
|}.
  destruct p, p'; congruence.
  exists Machine. reflexivity.
Defined.

Lemma Winner_not_unique :
  exists g : ConstantGame,
    Winner g Machine /\ Winner g Nature.
Proof.
  exists nonstatic. split.
    constructor; cbn.
      intro. destruct (H true).
      intros _. left. exists true. split.
        reflexivity.
        apply Winner_Win_Machine.
    constructor; cbn.
      intro. destruct (H true).
      intros _. left. exists false. split.
        reflexivity.
        apply Winner_Lose_Nature.
Qed.

Lemma Winner_spec' :
  forall g : ConstantGame, exists p : Player, Winner g p.
Proof.
  intro. destruct (LEM (Winner g Machine)).
    exists Machine. assumption.
    exists Nature. destruct g. constructor; cbn in *.
Abort.

Lemma Winner_sim :
  forall (g1 g2 : ConstantGame) (p : Player),
    sim g1 g2 -> Winner g1 p -> Winner g2 p.
Proof.
  cofix CH.
  destruct 1, 1. constructor; intro.
    apply winners0. apply Winner2. intro. apply H. congruence.
    rewrite <- Labmoves0 in X. decompose [ex or and] (Winner3 X).
      left. exists (transport id Labmoves0 x). split.
        rewrite <- whos0. assumption.
        apply CH with (next g1 x); auto.
      right. intros.
        apply CH with (next g1 (transport id (eq_sym Labmoves0) move)).
          rewrite nexts0, transport_cat, cat_inv. cbn. reflexivity.
        apply H. rewrite whos0, transport_cat, cat_inv. cbn. assumption.
Qed.

Lemma Winner_Not :
  forall (g : ConstantGame) (p : Player),
    Winner (Not g) p <-> Winner g (swap p).
Proof.
  split; revert g p.
    cofix CH. intros. destruct H; constructor; cbn in *.
      intro. specialize (Winner2 H). destruct p; auto.
      intro move. decompose [and or ex] (Winner3 move).
        left. exists x. split.
          destruct (who g x); cbn in *; subst; auto.
          apply CH. assumption.
        right. intros. apply CH, H. rewrite H0. destruct p; cbn in *; auto.
    cofix CH. intros. destruct H; constructor; cbn in *; intros move.
      specialize (Winner2 move). destruct p; auto.
      decompose [ex or and] (Winner3 move).
        left. exists x. split.
          rewrite H. destruct p; reflexivity.
          apply CH, H1.
        right. intros. apply CH, H. rewrite <- H0.
          destruct (who g move0); reflexivity.
Qed.

Lemma Winner_Not' :
  forall (g : ConstantGame) (p : Player),
    Winner g p <-> Winner (Not g) (swap p).
Proof.
  intros. rewrite Winner_Not. destruct p; reflexivity.
Qed.

Lemma Winner_chor_Machine :
  forall (g1 g2 : ConstantGame),
    Winner (chor g1 g2) Machine <-> Winner g1 Machine \/ Winner g2 Machine.
Proof.
  split; revert g1 g2.
    2: {
      destruct 1.
        revert g1 g2 H. cofix CH. intros. constructor; cbn.
          intro. destruct (H0 true).
          intros _. left. exists true. auto.
        revert g1 g2 H. cofix CH. intros. constructor; cbn.
          intro. destruct (H0 true).
          intros _. left. exists false. auto.
    }
    intros. destruct H; cbn in *. destruct (Winner3 true).
      destruct H, x, H; auto.
      specialize (H false). cbn in H.
Admitted.

Lemma Winner_chor_Nature :
  forall (g1 g2 : ConstantGame),
    Winner (chor g1 g2) Nature <-> Winner g1 Nature /\ Winner g2 Nature.
Proof.
Admitted.

Lemma Winner_chor :
  forall (g1 g2 : ConstantGame) (p : Player),
    Winner (chor g1 g2) p <->
    match p with
        | Machine => Winner g1 Machine \/ Winner g2 Machine
        | Nature => Winner g1 Nature /\ Winner g2 Nature
    end.
Proof.
  destruct p.
    apply Winner_chor_Machine.
    apply Winner_chor_Nature.
Qed.

Lemma Winner_chand :
  forall (g1 g2 : ConstantGame) (p : Player),
    Winner (chand g1 g2) p <->
    match p with
        | Machine => Winner g1 Machine /\ Winner g2 Machine
        | Nature => Winner g1 Nature \/ Winner g2 Nature
    end.
Proof.
  intros. rewrite Winner_Not'.
  assert (forall g1 g2, Not (chand g1 g2) = chor (Not g1) (Not g2)).
    intros. apply sim_eq. apply Not_chand.
  rewrite H, Winner_chor.
  destruct p; cbn; rewrite !Winner_Not; cbn; reflexivity.
Qed.

Lemma Winner_chexists :
  forall (A : Type) (f : A -> ConstantGame) (p : Player),
    Winner (chexists f) p <->
    match p with
        | Machine => exists x : A, Winner (f x) Machine
        | Nature => forall x : A, Winner (f x) Nature
    end.
Proof.
Admitted.

Lemma Winner_chall :
  forall (A : Type) (f : A -> ConstantGame) (p : Player),
    Winner (chall f) p <->
    match p with
        | Machine => forall x : A, Winner (f x) Machine
        | Nature => exists x : A, Winner (f x) Nature
    end.
Proof.
Admitted.

Lemma Winner_por_1 :
  forall g1 g2 : ConstantGame,
    Winner g1 Machine -> Winner g2 Machine -> Winner (por g1 g2) Machine.
Proof.
  cofix CH.
  intros g1 g2 H1 H2.
  decompose [Winner] H1.
  decompose [Winner] H2.
  constructor; cbn in *.
    auto.
    destruct 1.
      destruct (Winner3 l).
        destruct H as [move [H1' H2']]. left. exists (inl move). auto.
        destruct (LEM (exists move : Labmove g2, who g2 move = Machine)).
          destruct H0. destruct (Winner5 x).
            destruct H3. left. exists (inr x0). destruct H3. auto.
            right. destruct move; auto.
          right. destruct move.
            auto.
            intro. apply CH.
              assumption.
              destruct (Winner5 l0).
                destruct H4 as [move [H41 H42]]. contradiction H0.
                  exists move. assumption.
                apply H4. assumption.
      destruct (Winner5 l).
        destruct H as [move [H1' H2']]. left. exists (inr move). auto.
        destruct (LEM (exists move : Labmove g1, who g1 move = Machine)).
          destruct H0. destruct (Winner3 x).
            destruct H3. left. exists (inl x0). destruct H3. auto.
            right. destruct move; auto.
          right. destruct move.
            intro. apply CH.
              destruct (Winner3 l0).
                destruct H4 as [move [H41 H42]]. contradiction H0.
                  exists move. assumption.
                apply H4. assumption.
              assumption.
            auto.
Qed.

Lemma Winner_por :
  forall g1 g2 : ConstantGame,
    Winner (por g1 g2) Nature -> Winner g1 Nature.
Proof.
  cofix CH.
  constructor.
    intro. destruct H. cbn in *. apply Winner2. intro.
Admitted.

Lemma Winner_pand :
  forall (g1 g2 : ConstantGame) (p : Player),
    Winner (pand g1 g2) p <-> False.
Proof.
Admitted.

Lemma Winner_pexists :
  forall (f : nat -> ConstantGame) (p : Player),
    Winner (pexists f) p <-> False.
Proof.
Admitted.

Lemma Winner_pall :
  forall (f : nat -> ConstantGame) (p : Player),
    Winner (pall f) p <-> False.
Proof.
Admitted.

Lemma excluded_middle :
  forall g : ConstantGame,
    Winner (por g (Not g)) Machine.
Proof.
  intro. destruct (LEM (Winner g Machine)).
Abort.

(** * Static constant games *)

(** Insight: a game is static if it has at most one winner. *)

Definition Static (g : ConstantGame) : Prop :=
  forall p p' : Player, Winner g p -> Winner g p' -> p = p'.

Lemma Static_Not :
  forall g : ConstantGame,
    Static g -> Static (Not g).
Proof.
  unfold Static. intros.
  apply Winner_Not in H0.
  apply Winner_Not in H1.
  specialize (H _ _ H0 H1). destruct p, p'; cbn in *; congruence.
Qed.

Lemma Static_chor :
  forall g1 g2 : ConstantGame,
    Static g1 -> Static g2 -> Static (chor g1 g2).
Proof.
  unfold Static. intros.
  apply Winner_chor in H1.
  apply Winner_chor in H2.
  destruct p, p', H1, H2; auto.
Qed.

Lemma Static_chand :
  forall g1 g2 : ConstantGame,
    Static g1 -> Static g2 -> Static (chand g1 g2).
Proof.
  unfold Static. intros.
  apply Winner_chand in H1.
  apply Winner_chand in H2.
  destruct p, p', H1, H2; auto.
Qed.

Lemma Static_chexists :
  forall (A : Type) (f : A -> ConstantGame),
    (forall x : A, Static (f x)) -> Static (chexists f).
Proof.
  unfold Static. intros.
  apply Winner_chexists in H0.
  apply Winner_chexists in H1.
  destruct p, p'; auto.
    destruct H0. apply (H _ _ _ H0 (H1 x)).
    destruct H1. apply (H _ _ _ (H0 x) H1).
Qed.

Lemma Static_por :
  forall g1 g2 : ConstantGame,
    Static g1 -> Static g2 -> Static (por g1 g2).
Proof.
  unfold Static. intros.
Abort.

(** ** Static 2 *)

(** The definition of static constant games must be coinductive or
    we are doomed to fail. *)

(* This won't work. *)
(*
CoInductive Static' (g : ConstantGame) : Prop :=
{
    victor : Player;
    Static'_1 : (Labmove g -> False) -> winner g victor;
    Static'_2 :
      forall move : Labmove g,
        exists s : Static' (next g move), victor s = victor;
}.
*)

(** ** Static 3 *)

(** A game is Static' if it has exactly one winner. *)
Definition Static' (g : ConstantGame) : Prop :=
  exists p : Player, Winner g p /\ forall p' : Player, Winner g p' -> p = p'.

Lemma Static'_Not :
  forall g : ConstantGame,
    Static' g -> Static' (Not g).
Proof.
  unfold Static'.
  destruct 1 as (p & H & Heq). exists (swap p). split.
    apply Winner_Not. destruct p; cbn; assumption.
    intros. apply Winner_Not in H0. specialize (Heq _ H0).
      rewrite Heq. destruct p'; reflexivity.
Qed.

Lemma Static'_por :
  forall g1 g2 : ConstantGame,
    Static' g1 -> Static' g2 -> Static' (por g1 g2).
Proof.
  unfold Static'.
  destruct 1 as (p1 & H1 & Heq1),
           1 as (p2 & H2 & Heq2).
  destruct p1, p2.
    exists Machine. split.
      apply Winner_por_1; assumption.
      destruct p'; intro.
        reflexivity.
        destruct H. admit.
Abort.

(** Miscellaneous *)

Inductive Position (g : ConstantGame) : Type :=
    | EmptyPosition : Position g
    | ConsPosition :
        forall move : Labmove g,
          Position (next g move) -> Position g.

Arguments EmptyPosition {g}.
Arguments ConsPosition {g} _ _.

CoInductive Run (g : ConstantGame) : Type :=
{
    run :
      option {move : Labmove g & Run (next g move)}
}.

Arguments run {g}.

Definition EmptyRun (g : ConstantGame) : Run g :=
{|
    run := None;
|}.

Inductive Finite' : ConstantGame -> nat -> Prop :=
    | Finite'_Win : Finite' Win 0
    | Finite'_Lose : Finite' Lose 0
    | Finite'_move :
        forall (g : ConstantGame) (n : nat),
          (forall move : Labmove g, Finite' (next g move) n) ->
            Finite' g (S n)
    | Finite'_pump :
        forall (g : ConstantGame) (n : nat),
          Finite' g n -> Finite' g (S n).

Definition Finite (G : ConstantGame) : Prop :=
  exists n : nat, Finite' G n.

Inductive Perifinite : ConstantGame -> Prop :=
    | Perfinite_Win : Perifinite Win
    | Perfinite_Lose : Perifinite Lose
    | Perfinite_move :
        forall g : ConstantGame,
          (forall move : Labmove g, Perifinite (next g move)) ->
            Perifinite g.

Fixpoint prefix (g : ConstantGame) (p : Position g) : ConstantGame :=
match p with
    | EmptyPosition => g
    | ConsPosition move p' => prefix (next g move) p'
end.

Axioms V C : Type.

Axioms V_eqb : V -> V -> bool.

Axiom V_eqb_spec :
  forall v1 v2 : V, reflect (v1 = v2) (V_eqb v1 v2).

Definition Valuation : Type := V -> C.

Definition Game : Type := Valuation -> ConstantGame.

Definition ElementaryConstantGame (g : ConstantGame) : Prop :=
  Labmove g -> False.

Lemma ElementaryConstantGame_Win :
  ElementaryConstantGame Win.
Proof.
  red. destruct 1.
Qed.

Lemma ElementaryConstantGame_Lose :
  ElementaryConstantGame Lose.
Proof.
  red. destruct 1.
Qed.

Definition Elementary (g : Game) : Prop :=
  forall e : Valuation, ElementaryConstantGame (g e).

Definition depends (g : Game) (v : V) : Prop :=
  exists e1 e2 : Valuation,
    (forall v' : V, v' <> v -> e1 v' = e2 v') /\ g e1 <> g e2.

Lemma not_depends_ConstantGame :
  forall (g : ConstantGame) (v : V),
    ~ depends (fun _ => g) v.
Proof.
  unfold depends. intros g v [e1 [e2 [H1 H2]]]. contradiction.
Qed.

Definition Finitary (g : Game) : Prop :=
  exists l : list V,
    forall e1 e2 : Valuation,
      (Forall (fun v => e1 v = e2 v) l) -> g e1 = g e2.

(** TODO: arity *)

Inductive Term : Type :=
    | Var : V -> Term
    | Const : C -> Term.

Definition extend (e : Valuation) (t : Term) : C :=
match t with
    | Var v => e v
    | Const c => c
end.

(** TODO: various not too interesting things *)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj10synthconj1 : forall  (lv0 : natural), (@eq natural (Succ lv0) (Succ (plus Zero lv0))).
Admitted.
QuickChick conj10synthconj1.


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

(***
Modulus : 2^401 - 31
Base: 50.125
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 50 + 1/8;
    bitwidth := 64;
    s := 2^401;
    c := [(1, 31)];
    carry_chains := Some [seq 0 (pred 8); [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.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Logic.FunctionalExtensionality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.Common.
Require Import FinProof.MonadTransformers21.
Require Import FinProof.Common.
Require Import FinProof.StateMonad21.
Require Import FinProof.StateMonad21Instances.
Require Import FinProof.Types.IsoTypes.

Require Import UMLang.UrsusLib.

Require Import UrsusStdLib.Cpp.stdTypes.

Require Import UrsusTVM.Cpp.tvmTypes.
Require Import UrsusTVM.Cpp.tvmFunc.
Require Import UrsusTVM.Cpp.tvmNotations.
Require Import UrsusTVM.Cpp.tvmCells.

Require Import Project.CommonQCEnvironment.

(*Fully qualified name are mandatory in multi-contract environment*)
Require Import Contracts.Blank.DBlank.Ledger.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Local Open  Scope N_scope.

Definition LedgerDefault : LedgerLRecord  := Eval compute in default.

#[local]
Remove Hints isoid : typeclass_instances.
#[local]
Remove Hints iso_show : typeclass_instances.
#[local]
Remove Hints iso_shrink : typeclass_instances.
#[local]
Remove Hints iso_genSized : typeclass_instances.

(* ContractLRecord *)

#[global]
Instance Contract_Show: Show ContractLRecord.
refine Showprod.
Defined.

#[global]
Instance Contract_Shrink: Shrink ContractLRecord.
refine Shrinkprod.
Defined.

#[global]
Instance Contract_GenSized: GenSized ContractLRecord.
refine GenSizedprod.
Defined.

(*MessagesAndEvents*)

#[global]
Instance MessagesAndEvents_Show: Show MessagesAndEventsLRecord.
refine Showxprod.
Defined.

#[global]
Instance MessagesAndEvents_Shrink: Shrink MessagesAndEventsLRecord.
refine Shrinkxprod.
Defined.

#[global]
Instance MessagesAndEvents_GenSized: GenSized MessagesAndEventsLRecord.
refine GenSizedxprod.
Defined.

(*LocalState*)

#[global]
Instance LocalState_Show: Show LocalStateLRecord.
refine Showxprod.
Defined.

#[global]
Instance LocalState_Shrink: Shrink LocalStateLRecord.
refine Shrinkxprod.
Defined.

#[global]
Instance LocalState_GenSized: GenSized LocalStateLRecord.
refine GenSizedxprod.
Defined.

(*Ledger*)

#[global]
Instance Ledger_Show: Show LedgerLRecord | 0.
refine Showxprod.
Defined.

#[global]
Instance Ledger_Shrink: Shrink LedgerLRecord  | 0.
refine Shrinkxprod.
Defined.

#[global]
Instance Ledger_GenSized: GenSized LedgerLRecord | 0 .
refine GenSizedxprod.
Defined.

(*****************************************************)

#[global] Instance LedgerEq_Dec: forall (l1 l2: LedgerLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.

#[global] Instance ContractEq_Dec: forall (l1 l2: ContractLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.

#[global] Instance MessagesEq_Dec: forall (l1 l2: MessagesAndEventsLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.


Require Import Raft.
Require Import RaftRefinementInterface.

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

  Definition votesWithLog_term_sanity net :=
    forall t l hs h,
      In (t, l, hs) (votesWithLog (fst (nwState net h))) ->
      t <= currentTerm (snd (nwState net h)).

  Class votesWithLog_term_sanity_interface : Prop :=
    {
      votesWithLog_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votesWithLog_term_sanity net
    }.
End VotesWithLogTermSanity.


Require Export Verdi.Verdi.
Require Import VerdiRaft.RaftState.
Require Export StructTact.Fin.

Open Scope bool.

Set Implicit Arguments.

Class RaftParams (orig_base_params : BaseParams)
  := {
      N : nat ;
      input_eq_dec : forall x y : input, {x = y} + {x <> y} ;
      output_eq_dec : forall x y : output, {x = y} + {x <> y} ;
      clientId : Type ;
      clientId_eq_dec : forall x y : clientId, {x = y} + {x <> y}
    }.

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

  Definition term := nat.
  Definition logIndex := nat.
  Definition name := fin N.
  Definition nodes : list name := all_fin _.
  Definition name_eq_dec : forall x y : name, {x = y} + {x <> y} := fin_eq_dec _.

  Notation "a >? b" := (b <? a) (at level 70).
  Notation "a >=? b" := (b <=? a) (at level 70).
  Notation "a == b" := (beq_nat a b) (at level 70).
  Notation "a != b" := (negb (beq_nat a b)) (at level 70).

  Notation "a === b" := (if fin_eq_dec _ a b then true else false) (at level 42).

  Record entry := mkEntry {
                      eAt : name;
                      eClient : clientId;
                      eId : nat;
                      eIndex : logIndex;
                      eTerm : term;
                      eInput : input
                    }.

  Inductive msg : Type :=
  | RequestVote : term -> name -> logIndex -> term -> msg
  | RequestVoteReply : term -> bool -> msg
  | AppendEntries : term -> (name) -> logIndex -> term -> (list entry) -> logIndex -> msg
  | AppendEntriesReply : term -> (list entry) -> bool -> msg.

  Inductive raft_input : Type :=
  | Timeout : raft_input
  | ClientRequest : clientId -> nat -> input -> raft_input.

  Inductive raft_output : Type :=
  | NotLeader : clientId -> nat -> raft_output
  | ClientResponse : clientId -> nat -> output -> raft_output.

  Inductive serverType : Set :=
  | Follower
  | Candidate
  | Leader.

  Definition serverType_eq_dec : forall x y : serverType, {x = y} + {x <> y}.
  Proof. decide equality. Defined.

  Definition term_eq_dec : forall x y : term, {x = y} + {x <> y}.
  Proof.  apply eq_nat_dec. Defined.

  Definition entry_eq_dec : forall x y : entry, {x = y} + {x <> y}.
  Proof. decide equality; eauto using input_eq_dec, name_eq_dec, term_eq_dec, clientId_eq_dec. Defined.

  Definition msg_eq_dec : forall x y: msg, {x = y} + {x <> y}.
  Proof.
    decide equality;
      eauto using name_eq_dec, input_eq_dec, term_eq_dec, Bool.bool_dec,
                  list_eq_dec, entry_eq_dec.
  Defined.

  Definition raft_data :=
    RaftState.raft_data term name entry logIndex serverType data clientId output.

  Notation currentTerm         := (RaftState.currentTerm term name entry logIndex serverType data clientId output).
  Notation votedFor            := (RaftState.votedFor term name entry logIndex serverType data clientId output).
  Notation leaderId            := (RaftState.leaderId term name entry logIndex serverType data clientId output).
  Notation log                 := (RaftState.log term name entry logIndex serverType data clientId output).
  Notation commitIndex         := (RaftState.commitIndex term name entry logIndex serverType data clientId output).
  Notation lastApplied         := (RaftState.lastApplied term name entry logIndex serverType data clientId output).
  Notation nextIndex           := (RaftState.nextIndex term name entry logIndex serverType data clientId output).
  Notation matchIndex          := (RaftState.matchIndex term name entry logIndex serverType data clientId output).
  Notation shouldSend          := (RaftState.shouldSend term name entry logIndex serverType data clientId output).
  Notation votesReceived       := (RaftState.votesReceived term name entry logIndex serverType data clientId output).
  Notation type                := (RaftState.type term name entry logIndex serverType data clientId output).
  Notation clientCache := (RaftState.clientCache term name entry logIndex serverType data clientId output).
  Notation stateMachine := (RaftState.stateMachine term name entry logIndex serverType data clientId output).
  Notation electoralVictories := (RaftState.electoralVictories term name entry logIndex serverType data clientId output).
  Notation mkRaft_data              := (RaftState.mkRaft_data term name entry logIndex serverType data clientId output).

  Fixpoint findAtIndex (entries : list entry) (i : logIndex) : option entry :=
    match entries with
      | nil => None
      | e :: es => if eIndex e == i then
                    Some e
                  else
                    if eIndex e <? i then
                      None
                    else
                      findAtIndex es i
    end.

  Fixpoint findGtIndex (entries : list entry) (i : logIndex) : list entry :=
    match entries with
      | nil => nil
      | e :: es => if (eIndex e) >? i then
                    e :: findGtIndex es i
                  else
                    nil
    end.

  Fixpoint removeAfterIndex (entries : list entry) (i : logIndex) : list entry :=
    match entries with
      | nil => nil
      | e :: es => if leb (eIndex e) i then
                    e :: es
                  else
                    removeAfterIndex es i
    end.

  Fixpoint maxIndex (entries : list entry) : logIndex :=
    match entries with
      | nil => 0
      | e :: es => eIndex e
    end.

  Fixpoint maxTerm (entries : list entry) : term :=
    match entries with
      | nil => 0
      | e :: es => eTerm e
    end.

  Definition advanceCurrentTerm state newTerm :=
    if newTerm >? (currentTerm state) then
      {[ {[ {[ {[ state with currentTerm := newTerm ]}
               with votedFor := None ]}
            with type := Follower ]}
           with leaderId := None ]}
    else
      state.

  Definition getNextIndex state h :=
    assoc_default name_eq_dec (nextIndex state) h (maxIndex (log state)).

  Definition tryToBecomeLeader (me : name) (state : raft_data)
    : list raft_output * raft_data * list (name * msg) :=
    let t := S (currentTerm state) in
    ([], {[ {[ {[ {[ state with type := Candidate ]}
              with votedFor := (Some me) ]}
           with votesReceived := [me] ]}
        with currentTerm := t ]},
     map (fun node => (node, RequestVote t
                                        me
                                        (maxIndex (log state))
                                        (maxTerm (log state))))
         (filter (fun h => if name_eq_dec me h then
                            false
                          else
                            true)
                 nodes)
    ).

  Definition not_empty {A} (l : list A) :=
    match l with
      | [] => false
      | _ => true
    end.

  Definition haveNewEntries (state : raft_data) (entries : list entry) :=
    andb (not_empty entries) (match findAtIndex (log state) (maxIndex entries) with
                                | None => true
                                | Some e => (negb (beq_nat (maxTerm entries) (eTerm e)))
                              end).

  Definition handleAppendEntries (me : name)
             (state : raft_data) (t : term) (leaderId : name) (prevLogIndex : logIndex)
             (prevLogTerm : term) (entries : list entry) (leaderCommit : logIndex) : raft_data * msg :=
    if currentTerm state >? t then
      (state, AppendEntriesReply (currentTerm state) entries false)
    else
      if prevLogIndex == 0 then
        if (haveNewEntries state entries) then
          ({[ {[ {[ {[ (advanceCurrentTerm state t)
                    with log := entries ]}
                    with commitIndex :=
                      max (commitIndex state) (min leaderCommit (maxIndex entries))
               ]}
              with type := Follower ]} with leaderId := Some leaderId ]},
           AppendEntriesReply t entries true)
        else
          ({[ {[ (advanceCurrentTerm state t)
                 with type := Follower ]} with leaderId := Some leaderId ]},
           AppendEntriesReply t entries true)
      else
        match (findAtIndex (log state) prevLogIndex) with
          | None => (state, AppendEntriesReply (currentTerm state) entries false)
          | Some e => if negb (beq_nat prevLogTerm (eTerm e)) then
                       (state, AppendEntriesReply (currentTerm state) entries false)
                     else
                       if haveNewEntries state entries then
                         let log' := removeAfterIndex (log state) prevLogIndex in
                         let log'' := entries ++ log' in
                         ({[ {[ {[ {[ (advanceCurrentTerm state t)
                                   with log := log'' ]}
                                with commitIndex :=
                                     max (commitIndex state) (min leaderCommit (maxIndex log''))
                              ]}
                             with type := Follower ]} with leaderId := Some leaderId ]},
                          AppendEntriesReply t entries true)
                       else
                         ({[ {[ (advanceCurrentTerm state t)
                                with type := Follower ]} with leaderId := Some leaderId ]},
                          AppendEntriesReply t entries true)
        end.

  Definition handleAppendEntriesReply (me : name) state src term entries (result : bool)
  : raft_data * list (name * msg) :=
    if currentTerm state =? term then
      if result then
        let index := maxIndex entries in
        ({[ {[ state with matchIndex :=
               (assoc_set name_eq_dec (matchIndex state) src
                  (max (assoc_default name_eq_dec (matchIndex state) src 0) index))
           ]}
          with nextIndex :=
            (assoc_set name_eq_dec (nextIndex state) src
              (max (getNextIndex state src) (S index)))
          ]},
         [])
      else
        ({[ state with nextIndex :=
              (assoc_set name_eq_dec (nextIndex state) src
                         (pred (getNextIndex state src)))
          ]},
         [])
    else if currentTerm state <? term then
      (* leader behind, convert to follower *)
      (advanceCurrentTerm state term, [])
    else
      (* follower behind, ignore *)
      (state, []).

  Definition moreUpToDate t1 i1 t2 i2 := (t1 >? t2) || ((t1 == t2) && (i1 >=? i2)).

  Definition handleRequestVote (me : name) state t candidateId lastLogIndex lastLogTerm : raft_data * msg :=
    if currentTerm state >? t then
      (state, RequestVoteReply (currentTerm state) false)
    else
      let state := (advanceCurrentTerm state t) in
      if andb (if leaderId state then false else true)
              (moreUpToDate lastLogTerm lastLogIndex (maxTerm (log state)) (maxIndex (log state)))
      then
        match (votedFor state) with
          | None => ({[ state with votedFor := Some candidateId ]},
                    RequestVoteReply (currentTerm state) true)
          | Some candidateId' =>
            (state, RequestVoteReply (currentTerm state) (candidateId === candidateId'))
        end
      else
        (state, RequestVoteReply (currentTerm state) false).

  Fixpoint div2 a :=
    match a with
      | S (S n) => S (div2 n)
      | 1 => 0
      | 0 => 0
    end.

  Definition wonElection (votes : list name) : bool :=
    (S (div2 (length nodes)) <=? length votes).

  Definition handleRequestVoteReply (me : name) state src t (voteGranted : bool) : raft_data :=
    if t >? (currentTerm state) then
      {[ (advanceCurrentTerm state t) with type := Follower ]}
    else if t <? (currentTerm state) then state else
           let won := voteGranted
                        && wonElection (dedup name_eq_dec (src :: votesReceived state)) in
           match (type state) with
             | Candidate =>
               {[ {[ {[ {[ {[ state
                              with votesReceived := (if voteGranted then
                                                       [src]
                                                     else
                                                       []) ++ votesReceived state ]}
                           with type := if won then
                                          Leader         (* long live the king *)
                                        else
                                          type state ]}
                        with matchIndex := (assoc_set name_eq_dec [] me (maxIndex (log state))) ]}
                       with nextIndex := [] ]}
                  with electoralVictories :=
                    (if won then
                       [(currentTerm state, src :: votesReceived state, log state)]
                     else
                       []) ++ electoralVictories state ]}
             | _ => state
      end.

  Definition handleMessage (src : name) (me : name) (m : msg)
             (state : raft_data) : raft_data * list (name * msg) :=
    match m with
      | AppendEntries t lid prevLogIndex prevLogTerm entries leaderCommit =>
        let (st, r) :=
            handleAppendEntries me state t lid prevLogIndex prevLogTerm entries leaderCommit
        in
        (st, [(src, r)])
      | AppendEntriesReply term entries result => handleAppendEntriesReply me state src term entries result
      | RequestVote t candidateId lastLogIndex lastLogTerm =>
        let (st, r) :=
            handleRequestVote me state t src lastLogIndex lastLogTerm
        in
        (st, [(src, r)])
      | RequestVoteReply t voteGranted =>
        (handleRequestVoteReply me state src t voteGranted, [])
    end.

  Definition getLastId state client :=
    assoc clientId_eq_dec (clientCache state) client.

  Definition applyEntry st e :=
    let (out, d) := handler (eInput e) (stateMachine st) in
    ([out], {[ {[ st with clientCache := assoc_set clientId_eq_dec (clientCache st) (eClient e) (eId e, out) ]}
             with stateMachine := d ]}).

  Definition cacheApplyEntry st e :=
    match getLastId st (eClient e) with
      | Some (id, o) =>
        if eId e <? id then
          ([], st)
        else
          if eId e =? id then
            ([o], st)
          else
            applyEntry st e
      | None => applyEntry st e
    end.

  Fixpoint applyEntries h (st : raft_data) entries : (list raft_output * raft_data) :=
    match entries with
      | [] => ([], st)
      | e :: es =>
        let (out, st) := cacheApplyEntry st e in
        let out := if name_eq_dec (eAt e) h then
                     map (fun o => ClientResponse (eClient e) (eId e) o) out
                   else
                     [] in
        let (out', state) := applyEntries h st es in
        (out ++ out', state)
    end.

  Definition doGenericServer (h : name) (state : raft_data) :
    (list raft_output * raft_data * list (name * msg)) :=
    let (out, state) :=
        applyEntries h state
                     (rev (filter (fun x => andb (Nat.ltb (lastApplied state) (eIndex x))
                                                (leb (eIndex x) (commitIndex state)))
                                  (findGtIndex (log state) (lastApplied state)))) in
    (out, {[ state with lastApplied := if commitIndex state >? lastApplied state then
                                         (commitIndex state)
                                       else
                                         (lastApplied state)
              ]},
     []).

  Definition replicaMessage (state : raft_data) (me : name) (host : name) : (name * msg) :=
    let prevIndex := pred (getNextIndex state host) in
    let prevTerm := (match (findAtIndex (log state) prevIndex) with
                       | Some e => (eTerm e)
                       | None => 0
                     end) in
    let newEntries := findGtIndex (log state) prevIndex in
    (host, AppendEntries
             (currentTerm state) me prevIndex prevTerm newEntries (commitIndex state)).

  Definition haveQuorum (state : raft_data) (me : name) (N : logIndex) : bool :=
    Nat.ltb (div2 (length nodes)) (length (filter (fun h => leb N (assoc_default name_eq_dec (matchIndex state) h 0)) nodes)).

  Definition advanceCommitIndex (state : raft_data) (me : name) : raft_data :=
    let entriesToCommit :=
        filter (fun e =>
                  (currentTerm state == eTerm e) &&
                  (commitIndex state <? eIndex e) &&
                  (haveQuorum state me (eIndex e))) (findGtIndex (log state) (commitIndex state)) in
    {[ state with commitIndex := fold_left max (map eIndex entriesToCommit) (commitIndex state)]}.

  Definition doLeader (state : raft_data) (me : name) :
    (list raft_output * raft_data * list (name * msg)) :=
      match (type state) with
        | Leader => let state' := advanceCommitIndex state me in
                   if (shouldSend state') then
                     let state' := {[ state' with shouldSend := false ]} in
                     let replicaMessages := map (replicaMessage state' me)
                                                (filter (fun h => if name_eq_dec me h then
                                                                   false
                                                                 else
                                                                   true) nodes) in
                     ([], state', replicaMessages)
                   else
                     ([], state', [])
        | _ => ([], state, [])
      end.

  Definition RaftNetHandler (me : name) (src : name) (m : msg)
             (state : raft_data) :=
    let (state, pkts) := handleMessage src me m state in
    let '(leaderOut, state, leaderPkts) := doLeader state me in
    let '(genericOut, state, genericPkts) := doGenericServer me state in
    (leaderOut ++ genericOut,
     state, pkts ++ leaderPkts ++ genericPkts).

  Definition handleClientRequest (me : name) (state : raft_data) (client : clientId) (id : nat) (c : input)
  : list raft_output * raft_data * list (name * msg) :=
    match (type state) with
      | Leader => let index := S (maxIndex (log state)) in
                 ([],
                  {[ {[ {[ state with log :=
                             (mkEntry me client id index (currentTerm state) c) :: (log state) ]}
                        with matchIndex :=
                          (assoc_set name_eq_dec (matchIndex state) me index)
                      ]}
                     with shouldSend := true ]},
                  [])
      | _ => ([NotLeader client id], state, [])
    end.

  Definition handleTimeout (me : name) (state : raft_data)
  : list raft_output * raft_data * list (name * msg) :=
    match (type state) with
      | Leader => ([], {[ state with shouldSend := true ]}, []) (* we automatically heartbeat elsewhere *)
      | _ => tryToBecomeLeader me state
    end.

  Definition handleInput (me : name) (inp : raft_input) (state : raft_data) :
    list raft_output * raft_data * list (name * msg) :=
    match inp with
      | ClientRequest client id c => handleClientRequest me state client id c
      | Timeout => handleTimeout me state
    end.

  Definition RaftInputHandler (me : name) (inp : raft_input)
             (state : raft_data) :=
    let '(handlerOut, state, pkts) := handleInput me inp state in
    let '(leaderOut, state, leaderPkts) := doLeader state me in
    let '(genericOut, state, genericPkts) := doGenericServer me state in
    (handlerOut ++ leaderOut ++ genericOut,
     state, pkts ++ leaderPkts ++ genericPkts).

  Definition reboot state : raft_data :=
    mkRaft_data (currentTerm state)
                (votedFor state)
                (leaderId state)
           (log state)
           (commitIndex state)
           (lastApplied state)
           (stateMachine state)
           []
           []
           false
           []
           Follower
           (clientCache state)
           (electoralVictories state).

  Definition init_handlers (_ : name) : raft_data :=
    mkRaft_data 0
                None
                None
                []
                0
                0
                init
                []
                []
                false
                []
                Follower
                []
                [].

  Instance base_params : BaseParams :=
    {
      data := raft_data ;
      input := raft_input ;
      output := raft_output
    }.

  Instance multi_params : MultiParams _ :=
    {
      name := name ;
      msg := msg ;
      msg_eq_dec := msg_eq_dec ;
      name_eq_dec := name_eq_dec ;
      nodes := nodes ;
      all_names_nodes := all_fin_all N ;
      no_dup_nodes := all_fin_NoDup N ;
      init_handlers := init_handlers ;
      net_handlers := RaftNetHandler ;
      input_handlers := RaftInputHandler
    }.

  Instance failure_params : FailureParams _ :=
    {
      reboot := reboot
    }.

  Inductive raft_intermediate_reachable : network -> Prop :=
  | RIR_init : raft_intermediate_reachable step_async_init
  | RIR_step_failure :
      forall failed net failed' net' out,
        raft_intermediate_reachable net ->
        step_failure (failed, net) (failed', net') out ->
        raft_intermediate_reachable net'
  | RIR_handleInput :
      forall net h inp out d l ps' st',
        raft_intermediate_reachable net ->
        handleInput h inp (nwState net h) = (out, d, l) ->
        (forall h', st' h' = update name_eq_dec (nwState net) h d h') ->
        (forall p', In p' ps' -> In p' (nwPackets net) \/
                           In p' (send_packets h l)) ->
        raft_intermediate_reachable (mkNetwork ps' st')
  | RIR_handleMessage :
      forall p net xs ys st' ps' d l,
        raft_intermediate_reachable net ->
        handleMessage (pSrc p) (pDst p) (pBody p) (nwState net (pDst p)) = (d, l) ->
        nwPackets net = xs ++ p :: ys ->
        (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
        (forall p', In p' ps' -> In p' (xs ++ ys) \/
                           In p' (send_packets (pDst p) l)) ->
        raft_intermediate_reachable (mkNetwork ps' st')
  | RIR_doLeader :
      forall net st' ps' h os d' ms,
        raft_intermediate_reachable net ->
        doLeader (nwState net h) h = (os, d', ms) ->
        (forall h', st' h' = update name_eq_dec (nwState net) h d' h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h ms)) ->
        raft_intermediate_reachable (mkNetwork ps' st')
  | RIR_doGenericServer :
      forall net st' ps' os d' ms h,
        raft_intermediate_reachable net ->
        doGenericServer h (nwState net h) = (os, d', ms) ->
        (forall h', st' h' = update name_eq_dec (nwState net) h d' h') ->
        (forall p, In p ps' -> In p (nwPackets net) \/
                         In p (send_packets h ms)) ->
        raft_intermediate_reachable (mkNetwork ps' st').

  Lemma step_failure_star_raft_intermediate_reachable' :
    forall n' tr,
      step_failure_star step_failure_init n' tr ->
      raft_intermediate_reachable (snd n').
  Proof using.
    intros. find_apply_lem_hyp refl_trans_1n_n1_trace.
    remember step_failure_init as net1.
    induction H.
    - subst. simpl. constructor.
    - destruct x'; destruct x''. simpl in *.
      econstructor; eauto.
  Qed.

  Lemma step_failure_star_raft_intermediate_reachable :
    forall failed net tr,
      step_failure_star step_failure_init (failed, net) tr ->
      raft_intermediate_reachable net.
  Proof using.
    intros.
    replace net with (snd (failed, net)); [|simpl; auto].
    eapply step_failure_star_raft_intermediate_reachable'; eauto.
  Qed.

  Lemma step_failure_star_raft_intermediate_reachable_extend :
    forall f net f' net' tr,
      step_failure_star (f, net) (f', net') tr ->
      raft_intermediate_reachable net ->
      raft_intermediate_reachable net'.
  Proof using.
    intros.
    prep_induction H.
    induction H using refl_trans_1n_trace_n1_ind; intros; subst.
    - find_inversion. auto.
    - destruct x'. simpl in *.
      eapply RIR_step_failure; [|eauto].
      eauto.
  Qed.

  Definition raft_net_invariant_client_request (P : network -> Prop) :=
    forall h net st' ps' out d l client id c,
      handleClientRequest h (nwState net h) client id c = (out, d, l) ->
      P net ->
      raft_intermediate_reachable net ->
      (forall h', st' h' = update name_eq_dec (nwState net) h d h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h l)) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_timeout (P : network -> Prop) :=
    forall net h st' ps' out d l,
      handleTimeout h (nwState net h) = (out, d, l) ->
      P net ->
      raft_intermediate_reachable net ->
      (forall h', st' h' = update name_eq_dec (nwState net) h d h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                               In p' (send_packets h l)) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_append_entries (P : network -> Prop) :=
    forall xs p ys net st' ps' d m t n pli plt es ci,
      handleAppendEntries (pDst p) (nwState net (pDst p)) t n pli plt es ci = (d, m) ->
      pBody p = AppendEntries t n pli plt es ci ->
      P net ->
      raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) m) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_append_entries_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' d m t es res,
      handleAppendEntriesReply (pDst p) (nwState net (pDst p)) (pSrc p) t es res = (d, m) ->
      pBody p = AppendEntriesReply t es res ->
      P net ->
      raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         In p' (send_packets (pDst p) m)) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_request_vote (P : network -> Prop) :=
    forall xs p ys net st' ps' d m t cid lli llt,
      handleRequestVote (pDst p) (nwState net (pDst p)) t (pSrc p) lli llt  = (d, m) ->
      pBody p = RequestVote t cid lli llt ->
      P net ->
      raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                         p' = mkPacket (pDst p) (pSrc p) m) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_request_vote_reply (P : network -> Prop) :=
    forall xs p ys net st' ps' d t v,
      handleRequestVoteReply (pDst p) (nwState net (pDst p)) (pSrc p) t v = d ->
      pBody p = RequestVoteReply t v ->
      P net ->
      raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys)) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_do_leader (P : network -> Prop) :=
    forall net st' ps' d h os d' ms,
      doLeader d h = (os, d', ms) ->
      P net ->
      raft_intermediate_reachable net ->
      nwState net h = d ->
      (forall h', st' h' = update name_eq_dec (nwState net) h d' h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h ms)) ->
      P (mkNetwork ps' st').

  Definition raft_net_invariant_do_generic_server (P : network -> Prop) :=
    forall net st' ps' d os d' ms h,
      doGenericServer h d = (os, d', ms) ->
      P net ->
      raft_intermediate_reachable net ->
      nwState net h = d ->
      (forall h', st' h' = update name_eq_dec (nwState net) h d' h') ->
      (forall p, In p ps' -> In p (nwPackets net) \/
                             In p (send_packets h ms)) ->
      P (mkNetwork ps' st').

  Lemma raft_invariant_handle_message P :
    forall xs p ys net st' ps' d l,
      raft_net_invariant_append_entries P ->
      raft_net_invariant_append_entries_reply P ->
      raft_net_invariant_request_vote P ->
      raft_net_invariant_request_vote_reply P ->
      handleMessage (pSrc p) (pDst p) (pBody p) (nwState net (pDst p)) = (d, l) ->
      P net ->
      raft_intermediate_reachable net ->
      nwPackets net = xs ++ p :: ys ->
      (forall h, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p', In p' ps' -> In p' (xs ++ ys) \/
                             In p' (send_packets (pDst p) l)) ->
      P (mkNetwork ps' st').
  Proof using.
    intros.
    unfold handleMessage in *.
    break_match; repeat break_let; repeat find_inversion;
    [eapply_prop raft_net_invariant_request_vote|
     eapply_prop raft_net_invariant_request_vote_reply|
     eapply_prop raft_net_invariant_append_entries|
     eapply_prop raft_net_invariant_append_entries_reply]; eauto;
    unfold send_packets in *; simpl in *; intros; find_apply_hyp_hyp; intuition.
  Qed.

  Lemma raft_invariant_handle_input P :
    forall h inp net st' ps' out d l,
      raft_net_invariant_timeout P ->
      raft_net_invariant_client_request P ->
      handleInput h inp (nwState net h) = (out, d, l) ->
      P net ->
      raft_intermediate_reachable net ->
      (forall h', st' h' = update name_eq_dec (nwState net) h d h') ->
      (forall p', In p' ps' -> In p' (nwPackets net) \/
                         In p' (send_packets h l)) ->
      P (mkNetwork ps' st').
  Proof using.
    intros.
    unfold handleInput in *.
    break_match; repeat break_let; repeat find_inversion;
    [eapply_prop raft_net_invariant_timeout|
     eapply_prop raft_net_invariant_client_request]; eauto;
    unfold send_packets in *; simpl in *; intros; find_apply_hyp_hyp; intuition.
  Qed.

  Definition raft_net_invariant_state_same_packet_subset (P : network -> Prop) :=
    forall net net',
      (forall h, nwState net h = nwState net' h) ->
      (forall p, In p (nwPackets net') -> In p (nwPackets net)) ->
      P net ->
      raft_intermediate_reachable net ->
      P net'.

  Definition raft_net_invariant_reboot (P : network -> Prop) :=
    forall net net' d h d',
      reboot d = d' ->
      P net ->
      raft_intermediate_reachable net ->
      nwState net h = d ->
      (forall h', nwState net' h' = update name_eq_dec (nwState net) h d' h') ->
      nwPackets net = nwPackets net' ->
      P net'.

  Definition raft_net_invariant_init (P : network -> Prop) :=
    P step_async_init.

  Theorem raft_net_invariant :
    forall P net,
      raft_net_invariant_init P ->
      raft_net_invariant_client_request P ->
      raft_net_invariant_timeout P ->
      raft_net_invariant_append_entries P ->
      raft_net_invariant_append_entries_reply P ->
      raft_net_invariant_request_vote P ->
      raft_net_invariant_request_vote_reply P ->
      raft_net_invariant_do_leader P ->
      raft_net_invariant_do_generic_server P ->
      raft_net_invariant_state_same_packet_subset P ->
      raft_net_invariant_reboot P ->
      raft_intermediate_reachable net ->
      P net.
  Proof using.
    intros.
    induction H10.
    - intuition.
    -  match goal with [H : step_failure _ _ _ |- _ ] => invcs H end.
       + unfold RaftNetHandler in *. repeat break_let.
         repeat find_inversion.
         assert
           (raft_intermediate_reachable
              {|
                nwPackets := (xs ++ ys) ++ (send_packets (pDst p) l0);
                nwState := update name_eq_dec (nwState net) (pDst p) r
              |}) by (eapply RIR_handleMessage; eauto; in_crush).
         assert
           (raft_intermediate_reachable
              {|
                nwPackets := ((xs ++ ys) ++ (send_packets (pDst p) l0)) ++
                                (send_packets (pDst p) l1) ;
                nwState := (update name_eq_dec (update name_eq_dec (nwState net) (pDst p) r) (pDst p) r0)
              |}) by (eapply RIR_doLeader; eauto;
                      [simpl in *; break_if; try congruence; eauto| in_crush]).
         eapply_prop raft_net_invariant_do_generic_server. eauto.
         eapply_prop raft_net_invariant_do_leader. eauto.
         eapply raft_invariant_handle_message with (P := P); eauto using in_app_or.
         auto.
         simpl. break_if; intuition eauto.
         eauto.
         simpl. eapply in_app_or. auto.
         simpl. break_if; congruence.
         simpl. intros.
         break_if; subst;
         repeat rewrite update_same by auto;
         repeat rewrite update_neq by auto; auto.
         simpl. in_crush.
       + unfold RaftInputHandler in *. repeat break_let.
         repeat find_inversion.
         assert
           (raft_intermediate_reachable
              {|
                nwPackets := nwPackets net ++ send_packets h l0;
                nwState := update name_eq_dec (nwState net) h r |})
           by (eapply RIR_handleInput; eauto; in_crush).
         assert
           (raft_intermediate_reachable
              {|
                nwPackets := ((nwPackets net ++ send_packets h l0) ++ send_packets h l2) ;
                nwState := update name_eq_dec (update name_eq_dec (nwState net) h r) h r0
              |})  by (eapply RIR_doLeader; eauto;
                       [simpl in *; break_if; try congruence; eauto| in_crush]).
         eapply_prop raft_net_invariant_do_generic_server. eauto.
         eapply_prop raft_net_invariant_do_leader. eauto.
         eapply raft_invariant_handle_input with (P := P); eauto using in_app_or.
         auto.
         simpl. break_if; intuition eauto.
         eauto.
         simpl. eapply in_app_or.
         auto.
         simpl. break_if; congruence.
         simpl. intros.
         break_if; subst;
         repeat rewrite update_same by auto;
         repeat rewrite update_neq by auto; auto.
         simpl. unfold send_packets.  intros. in_crush.
       + match goal with
           | [ H : nwPackets ?net = _ |- _ {| nwPackets := ?ps ; nwState := ?st |} ] =>
             assert (forall p, In p (nwPackets {| nwPackets := ps ; nwState := st |}) ->
                          In p (nwPackets net)) by (intros; simpl in *; find_rewrite; in_crush)
         end.
         eapply_prop raft_net_invariant_state_same_packet_subset; [|eauto|idtac|];
         eauto.
       + match goal with
           | [ H : nwPackets ?net = _ |- _ {| nwPackets := ?ps ; nwState := ?st |} ] =>
             assert (forall p, In p (nwPackets {| nwPackets := ps ; nwState := st |}) ->
                          In p (nwPackets net)) by (intros; simpl in *; find_rewrite; in_crush)
         end.
         eapply_prop raft_net_invariant_state_same_packet_subset; [|eauto|idtac|];
         eauto.
       + auto.
       + eapply_prop raft_net_invariant_reboot; eauto;
         intros; simpl in *; repeat break_if; intuition; subst; intuition eauto.
    - eapply raft_invariant_handle_input; eauto.
    - eapply raft_invariant_handle_message; eauto.
    - eapply_prop raft_net_invariant_do_leader; eauto.
    - eapply_prop raft_net_invariant_do_generic_server; eauto.
  Qed.

  Lemma reboot_init_handlers :
    forall h, reboot (init_handlers h) = init_handlers h.
  Proof using.
    reflexivity.
  Qed.

  Lemma reboot_idem :
    forall d, reboot (reboot d) = reboot d.
  Proof using.
    reflexivity.
  Qed.
End Raft.

Notation currentTerm         := (RaftState.currentTerm term name entry logIndex serverType data clientId output).
Notation votedFor            := (RaftState.votedFor term name entry logIndex serverType data clientId output).
Notation leaderId            := (RaftState.leaderId term name entry logIndex serverType data clientId output).
Notation log                 := (RaftState.log term name entry logIndex serverType data clientId output).
Notation commitIndex         := (RaftState.commitIndex term name entry logIndex serverType data clientId output).
Notation lastApplied         := (RaftState.lastApplied term name entry logIndex serverType data clientId output).
Notation nextIndex           := (RaftState.nextIndex term name entry logIndex serverType data clientId output).
Notation matchIndex          := (RaftState.matchIndex term name entry logIndex serverType data clientId output).
Notation shouldSend          := (RaftState.shouldSend term name entry logIndex serverType data clientId output).
Notation votesReceived       := (RaftState.votesReceived term name entry logIndex serverType data clientId output).
Notation type                := (RaftState.type term name entry logIndex serverType data clientId output).
Notation clientCache := (RaftState.clientCache term name entry logIndex serverType data clientId output).
Notation stateMachine := (RaftState.stateMachine term name entry logIndex serverType data clientId output).
Notation electoralVictories := (RaftState.electoralVictories term name entry logIndex serverType data clientId output).
Notation mkRaft_data              := (RaftState.mkRaft_data term name entry logIndex serverType data clientId output).

Hint Extern 5 (@BaseParams) => apply base_params : typeclass_instances.
Hint Extern 5 (@MultiParams _) => apply multi_params : typeclass_instances.
Hint Extern 5 (@FailureParams _ _) => apply failure_params : typeclass_instances.