From Coq Require Import Arith Bool List Lia.
From Giskard Require Import structures.

Import ListNotations.

Set Implicit Arguments.

(** * Local state operations, properties, and transitions *)

(** Local state transitions capture message sending, receiving and processing
behaviors of individual nodes. Local state transitions can be defined as a
quaternary relation on:
- pre-state,
- incoming message,
- post-state, and
- outgoing message(s).

Valid Giskard local state transitions can be defined as a predicate on these relations. *)

(** ** Local state operations *)

(** The following section defines operations that transform the pre-state
to post-state in local state transitions. *)

(** Received messages are stored in the in buffer. *)
Definition received (s : NState) (m : message) : Prop :=
  In m (in_messages s).

(** Sent messages are stored in the out buffer, as history.  *)
Definition sent (s : NState) (m : message) : Prop :=
  In m (out_messages s).

Definition record (s : NState) (m : message) : NState :=
 mkNState (node_view s) (node_id s)
  (in_messages s) (counting_messages s)  (m :: out_messages s) (timeout s).

Definition record_plural (s : NState) (lm : list message) : NState :=
 mkNState (node_view s) (node_id s)
  (in_messages s) (counting_messages s)  (lm ++ out_messages s) (timeout s).

(** Broadcast messages are stored in the in buffer, awaiting processing. *)
Definition add (s : NState) (m : message) : NState :=
 mkNState (node_view s) (node_id s)
  (m :: in_messages s) (counting_messages s)  (out_messages s) (timeout s).

Definition add_plural (s : NState) (lm : list message) : NState :=
 mkNState (node_view s) (node_id s)
  (lm ++ in_messages s) (counting_messages s) (out_messages s)  (timeout s).

(** Invalid messages are removed from the in buffer, and thus unable to be processed. *)
Definition discard (s : NState) (m : message) : NState :=
 mkNState (node_view s) (node_id s)
  (remove message_eq_dec m (in_messages s)) (counting_messages s) (out_messages s)  (timeout s).

(** Processed messages are removed from the in buffer and added to the counting buffer. *)
Definition process (s : NState) (msg : message) : NState :=
 mkNState (node_view s) (node_id s)
  (remove message_eq_dec msg (in_messages s)) (msg :: counting_messages s) (out_messages s) (timeout s).

(** During a normal or abnormal view change, the view is incremented,
and the in message buffer and timeout flag reset. *)
Definition increment_view (s : NState) : NState :=
  mkNState (S (node_view s)) (node_id s) [] (counting_messages s) (out_messages s) false.

(** ** Local state properties *)

(** The following section defines properties that constitute pre- and post- conditions
for local state transitions. *)

(** A message has a valid view with respect to a local state when it is equal to the
local state's current view. Nodes only process "non-expired" messages sent in its current view. *)
Definition view_valid (s : NState) (msg : message) : Prop :=
  node_view s = get_view msg.

Definition view_validb (s : NState) (msg : message) : bool :=
  Nat.eqb (node_view s) (get_view msg).

(** *** Byzantine behavior *)

(** The primary form of Byzantine behavior Giskard considers is double voting:
sending two PrepareVote messages for two different blocks of the same height within the same view.
We call two messages equivocating if they evidence double voting behavior of their sender. *)
Definition equivocating_messages (s : NState) (msg1 msg2 : message) : Prop :=
  In msg1 (out_messages s) /\
  In msg2 (out_messages s) /\
  get_view msg1 = get_view msg2 /\
  get_message_type msg1 = PrepareVote /\
  get_message_type msg2 = PrepareVote /\
  get_block msg1 <> get_block msg2 /\
  b_height (get_block msg1) = b_height (get_block msg2).

(** Duplicate block checking for either:
- a PrepareVote message in the processed message buffer for a different block of the same height, or
- a PrepareVote or PrepareQC message in the sent message buffer for a different block of the same height. *)
Definition exists_same_height_block_old (s : NState) (b : block) : Prop :=
  (* Either PrepareBlock has been processed, but no vote has been cast *)
  (exists msg, In msg (counting_messages s) /\
          get_message_type msg = PrepareBlock /\
          b_height b = b_height (get_block msg) /\
          b <> get_block msg)
  (* Or a PrepareVote or PrepareQC has been sent *)
  \/
  (exists msg, In msg (out_messages s) /\
          (get_message_type msg = PrepareVote \/
           get_message_type msg = PrepareQC) /\
          b_height b = b_height (get_block msg) /\
          b <> get_block msg).

Definition exists_same_height_block (s : NState) (b : block) : Prop :=
  exists msg, In msg (out_messages s) /\
         get_message_type msg = PrepareVote /\
         b_height b = b_height (get_block msg) /\
         b <> get_block msg.

Definition exists_same_height_PrepareBlock (s : NState) (b : block) : Prop :=
  exists msg, In msg (counting_messages s) /\
         get_message_type msg = PrepareBlock /\
         b_height b = b_height (get_block msg) /\
         b <> get_block msg.

Definition same_height_block_msg (b : block) (msg : message) :=
 get_message_type msg = PrepareVote /\
 b_height b = b_height (get_block msg) /\
 b <> get_block msg.

Definition same_height_block_msg_dec (b : block) (msg : message) :
  { same_height_block_msg b msg }+{ ~ same_height_block_msg b msg }.
Proof.
destruct (message_type_eq_dec (get_message_type msg) PrepareVote).
- destruct (Nat.eq_dec (b_height b) (b_height (get_block msg))).
  * destruct (block_eq_dec b (get_block msg)).
    + right.
      intro.
      destruct H.
      destruct H0.
      congruence.
    + left.
      split; [assumption|].
      split; [assumption|].
      assumption.
  * right.
    unfold same_height_block_msg.
    intro.
    destruct H.
    destruct H0.
    congruence.
- right.
  unfold same_height_block_msg.
  simpl.
  intro.
  destruct H.
  congruence.
Defined.

Program Definition exists_same_height_block_dec (s : NState) (b : block) :
 { exists_same_height_block s b }+{~ exists_same_height_block s b} :=
match Exists_dec (same_height_block_msg b) (out_messages s) (same_height_block_msg_dec b) with
| left H_dec => left _
| right H_dec => right _
end.
Next Obligation.
clear Heq_anonymous.
apply Exists_exists in H_dec.
destruct H_dec.
destruct H.
destruct H0.
destruct H1.
exists x.
split; [assumption|].
split; [assumption|].
split; [assumption|].
assumption.
Defined.
Next Obligation.
clear Heq_anonymous.
intro.
contradict H_dec.
apply Exists_exists.
destruct H.
destruct H.
destruct H0.
destruct H1.
exists x.
split; [assumption|].
split; [assumption|].
split; [assumption|].
assumption.
Defined.

Definition exists_same_height_blockb : NState -> block -> bool :=
 fun s b => if exists_same_height_block_dec s b then true else false.

Lemma exists_same_height_block_correct : forall (s : NState) (b : block),
 exists_same_height_block s b <-> exists_same_height_blockb s b = true.
Proof.
intros; split; unfold exists_same_height_blockb;
  destruct (exists_same_height_block_dec _ _); congruence.
Qed.

(** *** Prepare stage definitions *)

(** Blocks in Giskard go through three stages: Prepare, Precommit and Commit.
The local definitions of these three stages are:
- a block is in prepare stage in some local state s iff it has received quorum PrepareVote messages
  or a PrepareQC message in the current view or some previous view, and
- a block is in precommit stage in some local state s iff its child block is in prepare stage in s, and
- a block is in commit stage in some local state s iff its child block is in precommit stage in s. *)

(** We can parameterize the definition of a block being in prepare stage by some view. *)

(** Processed PrepareVote messages in some view about some block: *)
Definition processed_PrepareVote_in_view_about_block (s : NState) (view : nat) (b : block) : list message :=
  filter (fun msg => message_type_eqb (get_message_type msg) PrepareVote &&
                  block_eqb (get_block msg) b &&
                  Nat.eqb (get_view msg) view)
         (counting_messages s).

Definition vote_quorum_in_view (s : NState) (view : nat) (b : block) : Prop :=
  quorum (processed_PrepareVote_in_view_about_block s view b).

Definition PrepareQC_in_view (s : NState) (view : nat) (b : block) : Prop :=
  exists msg : message,
    In msg (counting_messages s) /\
    get_view msg = view /\
    get_block msg = b /\
    get_message_type msg = PrepareQC.

Definition prepare_stage_in_view (s : NState) (view : nat) (b : block) : Prop :=
  vote_quorum_in_view s view b
  \/
  PrepareQC_in_view s view b.

Definition prepare_stage_in_viewb  (s : NState) (view : nat) (b : block) : bool :=
  quorumb (processed_PrepareVote_in_view_about_block s view b)
  ||
  existsb (fun msg => message_type_eqb (get_message_type msg) PrepareQC
                                    && Nat.eqb (get_view msg) view
                                    && block_eqb (get_block msg) b)
  (counting_messages s).

(** We use this parameterized definition to define the general version of a block being
in prepare stage: A block has reached prepare stage in some state iff it has reached prepare
stage in some view that is less than or equal to the current view. *)
Definition prepare_stage (s : NState) (b : block) :=
  exists v', v' <= node_view s /\ prepare_stage_in_view s v' b.

(** *** View change definitions *)

(** Participating nodes in Giskard vote in units of time called views. Each view has the same
fixed set of participating nodes, which consists oof one block proposer for the view, and
validators. Participating nodes take turns to be the block proposer, and the identity of
the block proposer for any given view is known to all participating nodes. A view generally
proceeds as follows: at the beginning of the view, the block proposer proposes a fixed
number of blocks, which validators vote on. If all blocks receive quorum votes, the nodes
increment their local view and wait for new block proposals in the new view. Otherwise,
a timeout occurs, and nodes exchange messages to communicate their acknowledgement of the
timeout and determine the parent block for the first block of the new view. The end of a
view for a participating node is marked by either:
- the last block proposed by the block proposer reaching prepare stage in its local state, or
- the receipt of a ViewChangeQC message following a timeout.

We call the former a normal view change, and the latter an abnormal view change.
Because we assume that all local clocks are synchronized, in the case of an abnormal
view change, all nodes timeout at once. However, because nodes process messages at
different speeds, blocks reach prepare stage at different speeds, and consequently,
in the case of a normal view change, nodes are not guaranteed to increment their
local view at the same time. *)

(** In the case of an abnormal view change, the timeout flag is simultaneously flipped
for all participating nodes, and each sends a ViewChange message containing their
local highest block at prepare stage. Nodes then enter a liminal stage in which only
three kinds of messages can be processed: PrepareQC, ViewChange and ViewChangeQC. *)

(** Nodes will ignore all block proposals and block votes during this stage. Upon
receiving quorum ViewChange messages, validator nodes increment their view and wait
for new blocks to be proposed. The new block proposer aggregates the max height
block from its received ViewChange messages, and uses it to produce new blocks
for the new view. *)

(** The following section contains definitions required for abnormal view changes. *)

(** Quorum ViewChange messages in some view: *)
Definition processed_ViewChange_in_view (s : NState) (view : nat) : list message :=
  filter (fun msg => message_type_eqb ViewChange (get_message_type msg) &&
                  Nat.eqb (get_view msg) view)
         (counting_messages s).

Lemma processed_ViewChange_in_view_correct :
  forall s view msg,
    In msg (processed_ViewChange_in_view s view) ->
    In msg (counting_messages s) /\
    get_message_type msg = ViewChange /\
    get_view msg = view.
Proof.
  intros s view msg H_in.
  apply filter_In in H_in.
  destruct H_in as [H_in H_typeview].
  apply andb_prop in H_typeview.
  destruct H_typeview as [H_type H_view].
  repeat split; try tauto. symmetry; now apply message_type_eqb_correct.
  apply Nat.eqb_eq. assumption.
Qed.

Definition view_change_quorum_in_view (s : NState) (view : nat) : Prop :=
  quorum (processed_ViewChange_in_view s view).

(** Maximum height block from all processed ViewChange messages in view: *)
Definition highest_ViewChange_block_in_view (s : NState) (view : nat) : block :=
  fold_right higher_block
             GenesisBlock
             (map (get_block) (processed_ViewChange_in_view s view)).

Definition highest_ViewChange_block_height_in_view (s : NState) (view : nat) : nat :=
  b_height (highest_ViewChange_block_in_view s view).

(** The last block of each view is identifiable to each participating node:  *)
Definition last_block (b : block) : Prop :=
  b_last b = true.

(** Because not every view is guaranteed to have a block in prepare stage,
the definition of <<highest_prepare_block_in_view>> must be able to recursively
search for the highest prepare block in all past views: *)
Fixpoint highest_prepare_block_in_view (s : NState) (view : nat) : block :=
  match view with
    | 0 => GenesisBlock
    | S view' =>
      fold_right higher_block
       (highest_prepare_block_in_view s view')
       (map get_block
         (filter (fun msg => prepare_stage_in_viewb s view (get_block msg))
          (counting_messages s)))
    end.

(** The following definition constructs the ViewChange message to be
sent by each participating node upon a timeout. *)
Definition highest_prepare_block_message (s : NState) : message :=
 mkMessage PrepareQC (node_view s) (node_id s)
  (highest_prepare_block_in_view s (node_view s)) GenesisBlock.

(** ** Message construction *)

(** In Giskard, some message types "carry" other messages:
- PrepareBlock messages for the first block in a view carry the PrepareQC
  message of its parent block, PrepareBlock messages for non-first blocks
  carry the PrepareQC of the parent block of the first block, and
- PrepareVote messages carry the PrepareQC message of its parent block, and
- ViewChange messages carry the PrepareQC message of the highest local
  prepare stage block. *)

(** We do not model this at the type level (i.e., by having inductive message
type definitions), but rather simulate this behavior using pre- and post-conditions
in our local transitions. For example, a node only processes a PrepareBlock message
in the in message buffer if the PrepareQC message that is "piggybacked" onto has also
been received, and the transition effectively processes both of these messages in one step. *)

(** PrepareBlocks are computed from either:
- the final PrepareVote/PrepareQC message of the previous round, or
- the ViewChangeQC from the previous round.

The messages in both of these cases contain the parent block for the newly proposed blocks.
Note that because blocks are proposed in sequence, only the first PrepareBlock message carries
the parent block's PrepareQC message - the remaining blocks cannot do so because their parent
blocks have not reached prepare stage yet, and therefore their PrepareQC messages cannot exist.
Therefore, all PrepareBlock messages in a view carry the same PrepareQC message: that of
the first block's parent. *)

(** Note that although all PrepareBlock messages are produced and sent together in one
single transition, this does not mean that:
- they are processed at the same time, and
- we falsely enforce the discipline that the second proposed block contains the first
  block's PrepareQC when in fact it has not reached PrepareQC. *)

Definition make_PrepareBlocks (s : NState) (previous_msg : message) : list message :=
  [(mkMessage PrepareBlock
    (node_view s)
    (node_id s)
    (generate_new_block (get_block previous_msg)) (* New block produced *)
    (get_block previous_msg) (* PrepareQC of highest block from previous round *)
   )
   ;
   (mkMessage PrepareBlock
    (node_view s)
    (node_id s)
    (generate_new_block
      (generate_new_block (get_block previous_msg))) (* New block produced *)
    (get_block previous_msg) (* PrepareQC of highest block from previous round *)
   )
   ;
   (mkMessage PrepareBlock
    (node_view s)
    (node_id s)
    (* In particular, here we produce a block that is labeled as last block for the view *)
    (generate_last_block
      (generate_new_block
         (generate_new_block (get_block previous_msg)))) (* New block produced *)
    (get_block previous_msg)
   )]. (* PrepareQC of highest block from previous round *)

Lemma make_PrepareBlocks_message_type :
  forall s msg0 msg,
  In msg (make_PrepareBlocks s msg0) ->
  get_message_type msg = PrepareBlock.
Proof.
  intros. unfold make_PrepareBlocks in H.
  simpl in H;
    destruct H as [H | [H | [H | H]]];
    subst; try easy.
Qed.

(** A <<PrepareVote>> carries the <<PrepareQC>> of its parent, and can only be sent
after parent block reaches prepare stage, which means one of its inputs must be
either a <<PrepareVote>> or <<PrepareQC>>. *)

(** <<PrepareVote>>s are also computed from <<PrepareBlock>> messages,
which means another one of its inputs must be a <<PrepareBlock>> message. *)
Definition make_PrepareVote (s : NState) (quorum_msg prepareblock_msg : message) : message :=
  mkMessage PrepareVote (* message type *)
  (node_view s) (* view number *)
  (node_id s) (* node id *)
  (get_block prepareblock_msg) (* block to vote for *)
  (get_block quorum_msg).

(** Nodes create <<PrepareVote>> messages upon receiving <<PrepareBlock>> messages
for each block, and "wait" to send it until the parent block reaches prepare stage.
This is modeled by constructing <<PrepareVote>> messages on-demand given that:
- the parent block has just reached prepare stage, and
- a <<PrepareBlock>> message exists for the child block.
*)

(** Constructing pending PrepareVote messages for child messages with existing PrepareBlocks. *)
Definition pending_PrepareVote (s : NState) (quorum_msg : message) : list message :=
  map (fun prepare_block_msg => make_PrepareVote s quorum_msg prepare_block_msg)
      (filter (fun msg => Nat.eqb (get_view msg) (get_view quorum_msg) &&
                       negb (exists_same_height_blockb s (get_block msg)) &&
                       parent_ofb (get_block msg) (get_block quorum_msg) &&
                       message_type_eqb (get_message_type msg) PrepareBlock)
              (counting_messages s)).

Lemma pending_PrepareVote_correct :
  forall s msg0 msg,
    In msg (pending_PrepareVote s msg0) ->
    get_message_type msg = PrepareVote /\
    get_sender msg = node_id s /\
    get_view msg = node_view s.
Proof.
  intros.
  unfold pending_PrepareVote in H.
  rewrite in_map_iff in H.
  destruct H as [msg' [H_type' H]].
  apply filter_In in H.
  destruct H.
  repeat (apply andb_prop in H0;
          destruct H0).
  rewrite Nat.eqb_eq in *.
  rewrite message_type_eqb_correct in H1.
  rewrite <- H_type'. unfold make_PrepareVote; repeat split; simpl; try tauto.
Qed.

(** PrepareQC messages carry nothing, and can only be sent after a quorum number of PrepareVotes,
which means its only input is a PrepareVote containing the relevant block. *)
Definition make_PrepareQC (s : NState) (msg : message) : message :=
  mkMessage PrepareQC
  (node_view s)
  (node_id s)
  (get_block msg)
  GenesisBlock.

(** ViewChange messages carry the <<PrepareQC>> message of the highest block to
reach prepare stage, and since they are triggered by timeouts, no input
message is required: *)
Definition make_ViewChange (s : NState) : message :=
  mkMessage ViewChange
  (node_view s)
  (node_id s)
  (highest_prepare_block_in_view s (node_view s))
  GenesisBlock.

(** Upon receiving quorum <<ViewChange>> messages, the block proposer for the new
view aggregates the max height block from all the <<ViewChange>> messages and
sends a <<ViewChangeQC>> containing this block, alongside a <<PrepareQC>> message
evidencing its prepare stage. *)
Definition make_ViewChangeQC (s : NState) (highest_msg : message) : message :=
  mkMessage ViewChangeQC
  (node_view s)
  (node_id s)
  (get_block highest_msg)
  GenesisBlock.

(** ** Local state transitions *)

(** Nodes are responsible for processing messages and updating their local state;
broadcasting outgoing messages is handled by the network. *)

(** In the following section, Giskard local state transitions are organized
according to the type of message being processed. *)

(** *** Message type-agnostic actions *)

(** Block proposal-related definitions: *)
Definition GenesisBlock_message (s : NState) : message :=
  mkMessage ViewChangeQC
  0
  (node_id s)
  GenesisBlock
  GenesisBlock.

Definition propose_block_init (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = record_plural s (make_PrepareBlocks s (GenesisBlock_message s)) /\
  lm = (make_PrepareBlocks s (GenesisBlock_message s)) /\
  s = NState_init (node_id s) /\
  honest_node (node_id s) /\
  is_block_proposer (node_id s) 0 /\
  timeout s = false.

(** When the timeout happens, nodes enter a liminal phase where they are only allowed
to process the following kinds of messages:
- ViewChange from other nodes
- ViewChangeQC
- PrepareQC *)

(** Upon timeout, nodes send a ViewChange message containing the highest block to reach
Prepare stage in its current view, and the PrepareQC message attesting to that block's Prepare stage. *)
(* It does not increment the view yet *)
Definition process_timeout (s : NState) (msg : message) (s' : NState) (lm : list message) :=
  s' = record_plural s [make_ViewChange s; highest_prepare_block_message s] /\
  lm = [make_ViewChange s; highest_prepare_block_message s] /\
  honest_node (node_id s) /\
  timeout s = true.

(** An expired message - discard and do not process. *)
Definition discard_view_invalid (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = discard s msg /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  ~ view_valid s msg.
(* At this point it doesn't matter whether timeout has occurred or not *)

(** *** PrepareBlock message-related actions *)

(** If a same height block has been seen - discard the message: *)
Definition process_PrepareBlock_duplicate (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = discard s msg /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareBlock /\
  view_valid s msg /\
  timeout s = false /\
  exists_same_height_PrepareBlock s (get_block msg).

(** Parent block has not reached Prepare - "add its PrepareVote to pending buffer" by simply
processing the PrepareBlock message and waiting for parent block to reach quorum: *)
Definition process_PrepareBlock_pending_vote (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = process s msg /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareBlock /\
  view_valid s msg /\
  (* PrepareBlocks cannot be processed during timeout *)
  timeout s = false /\
  ~ exists_same_height_PrepareBlock s (get_block msg) /\
  (* Parent block has not reached Prepare *)
  ~ prepare_stage s (parent_of (get_block msg)).

(** Parent block has reached QC - send PrepareVote for the block in that message and record in out buffer: *)
Definition process_PrepareBlock_vote (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = (* Record outgoing PrepareVote messages *)
       record_plural
         (process s msg)
         (pending_PrepareVote s msg) /\
  lm = (pending_PrepareVote s msg) /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareBlock /\
  view_valid s msg /\
  (* PrepareBlocks cannot be processed during timeout *)
  timeout s = false /\
  prepare_stage s (parent_of (get_block msg)).

(** *** PrepareVote message-related actions *)

(** Block has not reached prepare stage - wait to send PrepareVote messages for child: *)
Definition process_PrepareVote_wait (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = process s msg /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareVote /\
  view_valid s msg /\
  (* PrepareVotes cannot be processed during timeout *)
  timeout s = false /\
  ~ prepare_stage (process s msg) (get_block msg).

(** Block is about to reach QC - send PrepareVote messages for child block if it exists and send PrepareQC: *)
(* vote_quorum means quorum PrepareVote messages *)
Definition process_PrepareVote_vote (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = process
         (record_plural
            s
            ((make_PrepareQC s msg) :: pending_PrepareVote s msg))
         msg /\
  lm = (make_PrepareQC s msg) :: pending_PrepareVote s msg /\
  honest_node (node_id s) /\
  received s msg /\
  get_message_type msg = PrepareVote /\
  view_valid s msg /\
  (* PrepareVotes cannot be processed during timeout *)
  timeout s = false /\
  ~ exists_same_height_block s (get_block msg) /\
  vote_quorum_in_view (process s msg) (get_view msg) (get_block msg).

(** *** PrepareQC message-related actions *)

(** PrepareQC messages are considered equivalent to a quorum of PrepareVote messages.
PrepareQC messages can be processed after timeout, so we do not require that timeout
has not occurred. *)

(** The PrepareQC message suffices to directly quorum a block, even if it has not received
enough PrepareVote messages, *)

(** Last block in view for to-be block proposer undergoing normal view change process:
- increment view, and
- propose block at height <<(S n)>>. *)

Definition process_PrepareQC_last_block_new_proposer (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  (* Increment the view; propose next block *)
  s' = record_plural
         (* New state *)
         (increment_view (process s msg))
         (* All to-propose blocks *)
         (* The block generating function starts at the input block height plus one *)
         (make_PrepareBlocks (increment_view (process s msg)) msg) /\
  lm = (* Send all block proposals for the new view *)
  make_PrepareBlocks (increment_view (process s msg)) msg /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareQC /\
  view_valid s msg /\
  (* Here we don't need for timeout to be false because apparently we can still
    process PrepareQC messages in the timeout period *)
  last_block (get_block msg) /\
  is_block_proposer (node_id s) (S (node_view s)).

(** Last block in the view for to-be validator - increment view: *)
(* No child blocks can exist, so we don't need to send anything *)
Definition process_PrepareQC_last_block (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = increment_view (process s msg) /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareQC /\
  view_valid s msg /\
  (* Here we don't need for timeout to be false because apparently
     we can still process PrepareQC messages in the timeout period *)
  last_block (get_block msg) /\
  ~ is_block_proposer (node_id s) (S (node_view s)).

(** Not-the-last block in the view - send PrepareVote messages for child block and wait: *)
Definition process_PrepareQC_non_last_block (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = process (record_plural s (pending_PrepareVote s msg)) msg /\
  lm = pending_PrepareVote s msg /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = PrepareQC /\
  view_valid s msg /\
  timeout s = false /\
  ~ last_block (get_block msg).

(** *** ViewChange message-related actions *)

(** ViewChange messages can be processed after timeout, so we do not require that timeout has not occurred. *)

(** Process ViewChange at quorum for to-be block proposer:
- send highest PrepareQC message,
- send ViewChangeQC message,
- increment view, and
- propose new block according to highest block in all quorum ViewChange messages. *)
Definition higher_message (msg1 msg2 : message) : message :=
  if (block_eqb (get_block msg1) (higher_block (get_block msg1) (get_block msg2)))
  then msg1
  else msg2.

Definition highest_message_in_list (n : node) (t : message_type) (lm : list message) : message :=
  fold_right higher_message
             (mkMessage t
                        0
                        n
                        GenesisBlock
                        GenesisBlock)
             lm.

Lemma about_highest_message_in_list :
  forall n t lm msg,
    In msg lm ->
    b_height (get_block msg) <= b_height (get_block (highest_message_in_list n t lm)).
Proof.
induction lm; intros; [inversion H|].
destruct H.
- simpl.
  subst.
  unfold higher_message.
  case_eq (block_eqb (get_block msg) (higher_block (get_block msg) (get_block (highest_message_in_list n t lm)))); intros.
  * auto with arith.
  * unfold higher_block in H.
    revert H.
    case_eq (b_height (get_block msg) <? b_height (get_block (highest_message_in_list n t lm))).
    + intros Hlt Heq.
      apply Nat.ltb_lt in Hlt.
      auto with arith.
    + intros Hle.
      case (block_eq_dec (get_block msg) (get_block msg)); [|congruence].
      intro Heq.
      apply block_eqb_correct in Heq.
      congruence.
- simpl.
  unfold higher_message.
  case_eq (block_eqb (get_block msg) (higher_block (get_block msg) (get_block (highest_message_in_list n t lm)))); intros.
  * apply block_eqb_correct in H0.
    case_eq (block_eqb (get_block a) (higher_block (get_block a) (get_block (highest_message_in_list n t lm)))); intros.
    + apply block_eqb_correct in H1.
      apply IHlm in H.
      assert (b_height (get_block (highest_message_in_list n t lm)) <= b_height (get_block a)).
      -- rewrite H1.
         unfold higher_block.
         case_eq (b_height (get_block a) <? b_height (get_block (highest_message_in_list n t lm))); [lia|].
         intro Hlt.
         apply Nat.ltb_ge in Hlt.
         lia.
      -- lia.
    + apply IHlm.
      assumption.
  * case_eq (block_eqb (get_block a) (higher_block (get_block a) (get_block (highest_message_in_list n t lm)))); intros.
    + apply block_eqb_correct in H1.
      apply IHlm in H.
      assert (b_height (get_block (highest_message_in_list n t lm)) <= b_height (get_block a)).
      -- rewrite H1.
         unfold higher_block.
         case_eq ((b_height (get_block a) <? b_height (get_block (highest_message_in_list n t lm)))); [lia|].
         intro Hlt.
         apply Nat.ltb_ge in Hlt.
         lia.
      -- lia.
    + apply IHlm.
      assumption.
Qed.

Definition highest_ViewChange_message (s : NState) : message :=
  highest_message_in_list (node_id s) ViewChange (processed_ViewChange_in_view s (node_view s)).

Lemma highest_ViewChange_message_type_eq_ViewChange :
  forall s, get_message_type (highest_ViewChange_message s) = ViewChange.
Proof.
intro s.
unfold highest_ViewChange_message.
assert (forall msg, In msg (processed_ViewChange_in_view s (node_view s)) -> get_message_type msg = ViewChange).
  intros.
  apply processed_ViewChange_in_view_correct in H.
  destruct H.
  destruct H0.
  assumption.
revert H.
generalize (processed_ViewChange_in_view s (node_view s)).
generalize (node_id s).
induction l; [reflexivity|].
simpl.
intro Ht.
unfold higher_message.
destruct (block_eqb (get_block a) (higher_block (get_block a) (get_block (highest_message_in_list n ViewChange l)))).
- apply Ht; left; reflexivity.
- apply IHl.
  intros.
  apply Ht; right; assumption.
Qed.

Lemma get_view_highest_ViewChange_message_node_view :
  forall s msg, get_message_type msg = ViewChange ->
   get_view msg = node_view s ->
   In msg (counting_messages s) ->
   get_view (highest_ViewChange_message s) = node_view s.
Proof.
intros.
unfold highest_ViewChange_message.
assert (forall msg, In msg (processed_ViewChange_in_view s (node_view s)) -> get_view msg = (node_view s)).
  intros.
  apply processed_ViewChange_in_view_correct in H2.
  destruct H2.
  destruct H3.
  assumption.
assert (processed_ViewChange_in_view s (node_view s) <> []).
  clear H2.
  unfold processed_ViewChange_in_view.
  apply In_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1.
  clear H1.
  induction x.
    simpl.
    rewrite H0.
    apply eq_sym in H.
    apply message_type_eqb_correct in H.
    rewrite H.
    rewrite Nat.eqb_refl.
    simpl.
    auto with datatypes.
  simpl.
  case (message_type_eqb ViewChange (get_message_type a) && (get_view a =? node_view s)); auto with datatypes.
clear H1 H0 H.
revert H2 H3.
generalize (processed_ViewChange_in_view s (node_view s)).
generalize (node_id s).
induction l; [congruence|].
simpl.
intros.
clear H3.
unfold higher_message.
case_eq (block_eqb (get_block a) (higher_block (get_block a) (get_block (highest_message_in_list n ViewChange l)))).
  intro.
  apply H2.
  left.
  reflexivity.
unfold higher_block.
destruct l.
- simpl.
  case_eq (b_height (get_block a) <? b_height GenesisBlock).
  * rewrite Nat.ltb_lt.
    intro Hlt.
    contradict Hlt.
    apply Nat.ltb_nlt.
    apply Nat.ltb_ge.
    apply GenesisBlock_height.
  * intros.
    case (block_eq_dec (get_block a) (get_block a)); [|congruence].
    intros; apply block_eqb_correct in e; congruence.
- simpl in *.
  intros.
  apply IHl; auto with datatypes.
Qed.

Lemma get_view_highest_ViewChange_message_in_counting_messages :
  forall s msg, get_message_type msg = ViewChange ->
   get_view msg = node_view s ->
   In msg (counting_messages s) ->
   In (highest_ViewChange_message s) (counting_messages s).
Proof.
intros.
unfold highest_ViewChange_message.
assert (forall msg, In msg (processed_ViewChange_in_view s (node_view s)) -> In msg (counting_messages s)).
  intros.
  apply processed_ViewChange_in_view_correct in H2.
  destruct H2.
  destruct H3.
  assumption.
assert (processed_ViewChange_in_view s (node_view s) <> []).
  clear H2.
  unfold processed_ViewChange_in_view.
  apply In_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1.
  clear H1.
  induction x.
    simpl.
    rewrite H0.
    apply eq_sym in H.
    apply message_type_eqb_correct in H.
    rewrite H.
    rewrite Nat.eqb_refl.
    simpl.
    auto with datatypes.
  simpl.
  case (message_type_eqb ViewChange (get_message_type a) && (get_view a =? node_view s)); auto with datatypes.
clear H H0 H1.
revert H2 H3.
generalize (processed_ViewChange_in_view s (node_view s)).
generalize (node_id s).
induction l; [congruence|].
simpl.
intros.
clear H3.
unfold higher_message.
case_eq (block_eqb (get_block a) (higher_block (get_block a) (get_block (highest_message_in_list n ViewChange l)))).
  intro.
  apply H2.
  left.
  reflexivity.
unfold higher_block.
destruct l.
- simpl.
  case_eq (b_height (get_block a) <? b_height GenesisBlock).
  * rewrite Nat.ltb_lt.
    intro Hlt.
    contradict Hlt.
    apply Nat.ltb_nlt.
    apply Nat.ltb_ge.
    apply GenesisBlock_height.
  * intros.
    case (block_eq_dec (get_block a) (get_block a)); [|congruence].
    intros; apply block_eqb_correct in e; congruence.
- simpl in *.
  intros.
  apply IHl; auto with datatypes.
Qed.

Definition process_ViewChange_quorum_new_proposer
 (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = (* Record new blocks after incrementing view *)
  record_plural (increment_view (process (process s msg)
   (mkMessage PrepareQC (get_view msg) (get_sender msg)
    (get_block (highest_ViewChange_message (process s msg))) GenesisBlock)))
    (* The input has to include the current ViewChange message, just in
       case that is the one which contains the highest block *)
      ((* PrepareQC of highest block *)
        (mkMessage PrepareQC (node_view s) (node_id s)
          (get_block (highest_ViewChange_message (process s msg))) GenesisBlock) ::
       (* ViewChangeQC containing highest block *)
       (make_ViewChangeQC s (highest_ViewChange_message (process s msg))) ::
       (* New block proposals *)
       (make_PrepareBlocks (increment_view s) (highest_ViewChange_message (process s msg)))) /\
  lm = (* Send ViewChangeQC message before incrementing view to ensure the others can process it *)
  (mkMessage PrepareQC (node_view s) (node_id s)
    (get_block (highest_ViewChange_message (process s msg))) GenesisBlock) ::
  (make_ViewChangeQC s (highest_ViewChange_message (process s msg))) ::
  (* Send PrepareBlock messages *)
  (make_PrepareBlocks (increment_view s) (highest_ViewChange_message (process s msg))) /\
  received s msg /\
  (* This condition is necessary given ViewChange sending behavior *)
  received s (mkMessage PrepareQC (get_view msg) (get_sender msg)
   (get_block (highest_ViewChange_message (process s msg))) GenesisBlock) /\
  honest_node (node_id s) /\
  get_message_type msg = ViewChange /\
  view_valid s msg /\
  (* ViewChange messages can be processed during timeout *)
  (* It is important that the parameter here is (process s msg) and not simply s *)
  view_change_quorum_in_view (process s msg) (node_view s) /\
  is_block_proposer (node_id s) (S (node_view s)).

(** Process ViewChange before quorum - keep and wait for QC: *)
Definition process_ViewChange_pre_quorum (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = process s msg /\
  lm = [] /\
  received s msg /\
  honest_node (node_id s) /\
  get_message_type msg = ViewChange /\
  view_valid s msg /\
  ~ view_change_quorum_in_view (process s msg) (node_view s).

(** *** ViewChangeQC message-related actions *)

(** Process highest PrepareQC message, process ViewChangeQC, then increment view. *)

(** Critically, this is where we enforce that the PrepareQC of the max height block
is processed before view change occurs, otherwise nodes can get stuck during view change. *)
Definition process_ViewChangeQC_single (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = increment_view (process (process s
    (mkMessage PrepareQC (node_view s) (get_sender msg) (get_block msg) GenesisBlock)) msg) /\
  lm = [] /\
  received s msg /\
  received s (mkMessage PrepareQC (node_view s) (get_sender msg) (get_block msg) GenesisBlock) /\
  honest_node (node_id s) /\
  get_message_type msg = ViewChangeQC /\
  view_valid s msg.

(** *** Timeout **)

(** When timeout is triggered, send ViewChange with the highest prepare stage block.
Given the new definition of prepare stage, this block might not be from the current view at all. *)

Definition flip_timeout (s : NState) : NState :=
  mkNState (node_view s) (node_id s) (in_messages s) (counting_messages s) (out_messages s)  true.

(** *** Malicious node actions *)

(** Malicious nodes can ignore messages: *)
Definition malicious_ignore (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = discard s msg /\
  lm = [] /\
  received s msg /\
  ~ honest_node (node_id s).

(** Malicious nodes can double vote for two blocks of the same height: *)
Definition process_PrepareBlock_malicious_vote (s : NState) (msg : message) (s' : NState) (lm : list message) : Prop :=
  s' = record_plural (process s msg) (pending_PrepareVote s msg) /\
  lm = pending_PrepareVote s msg /\
  received s msg /\
  ~ honest_node (node_id s) /\
  get_message_type msg = PrepareBlock /\
  view_valid s msg /\
  exists_same_height_block s (get_block msg).

(** ** Protocol transition type definitions *)

(** Valid Giskard transitions can be defined as a finite set/type of relations on pre-state,
post-state, processed message and outgoing message(s), constrained by protocol rules. *)
Inductive NState_transition_type :=
| propose_block_init_type
| discard_view_invalid_type
| process_PrepareBlock_duplicate_type
| process_PrepareBlock_pending_vote_type
| process_PrepareBlock_vote_type
| process_PrepareVote_vote_type
| process_PrepareVote_wait_type
| process_PrepareQC_last_block_new_proposer_type
| process_PrepareQC_last_block_type
| process_PrepareQC_non_last_block_type
| process_ViewChange_quorum_new_proposer_type
| process_ViewChange_pre_quorum_type
| process_ViewChangeQC_single_type
| process_PrepareBlock_malicious_vote_type.

Definition get_transition (t : NState_transition_type) : (NState -> message -> NState -> list message -> Prop) :=
  match t with
  | propose_block_init_type => propose_block_init
  | discard_view_invalid_type => discard_view_invalid
  | process_PrepareBlock_duplicate_type => process_PrepareBlock_duplicate
  | process_PrepareBlock_pending_vote_type => process_PrepareBlock_pending_vote
  | process_PrepareBlock_vote_type => process_PrepareBlock_pending_vote
  | process_PrepareQC_last_block_new_proposer_type => process_PrepareQC_last_block_new_proposer
  | process_PrepareQC_last_block_type => process_PrepareQC_last_block
  | process_PrepareQC_non_last_block_type => process_PrepareQC_non_last_block
  | process_PrepareVote_vote_type => process_PrepareVote_vote
  | process_PrepareVote_wait_type => process_PrepareVote_wait
  | process_ViewChange_quorum_new_proposer_type => process_ViewChange_quorum_new_proposer
  | process_ViewChange_pre_quorum_type => process_ViewChange_pre_quorum
  | process_ViewChangeQC_single_type => process_ViewChangeQC_single
  | process_PrepareBlock_malicious_vote_type => process_PrepareBlock_malicious_vote
  end.

(** ** Facts about local state transitions *)

Lemma out_messages_local_monotonic :
  forall (s1 s2 : NState) (msg : message) (lm : list message) (t : NState_transition_type),
    (get_transition t) s1 msg s2 lm ->
    forall (msg0 : message),
      In msg0 (out_messages s1) ->
      In msg0 (out_messages s2).
Proof.
  intros s1 s2 msg lm t H_step msg0 H_in.
  assert (H_step_copy := H_step).
  destruct t; simpl in H_step;
    destruct H_step as [H_subst _];
    try (subst; assumption);
    try (rewrite H_subst; simpl; rewrite in_app_iff; repeat right; assumption);
    try (rewrite H_subst in *; simpl; right;
         assert (H : In msg0 (pending_messages_about_block s1 (get_block msg)) \/ In msg0 (out_messages s1)) by tauto;
          apply in_app_iff in H; assumption);
    try (destruct H_step_copy as [_ [_ [_ [H_init _]]]];
         rewrite H_init in H_in; inversion H_in);
    try (rewrite H_subst; simpl; try rewrite in_app_iff; repeat right;
         assumption).
Qed.

Lemma counting_messages_same_view_monotonic :
  forall (s1 s2 : NState) (msg : message) (lm : list message) (t : NState_transition_type),
    (get_transition t) s1 msg s2 lm ->
    node_view s1 = node_view s2 ->
    forall (msg0 : message),
      In msg0 (counting_messages s1) ->
      In msg0 (counting_messages s2).
Proof.
  intros s1 s2 msg lm t H_step H_view msg0 H_in.
  destruct t; simpl in H_step;
    destruct H_step as [H_subst _];
    simpl in H_subst;
    try (subst; assumption);
    try rewrite H_subst in *; simpl;
      try (simpl in H_view; lia);
      try (right; assert (In msg0 (pending_messages_about_block s1 (get_block msg)) \/ In msg0 (out_messages s1)) by tauto;
           apply in_app_iff in H; assumption);
      try tauto.
Qed.

Lemma counting_messages_local_monotonic :
  forall (s1 s2 : NState) (msg : message) (lm : list message) (t : NState_transition_type),
    (get_transition t) s1 msg s2 lm ->
    forall (msg0 : message),
      In msg0 (counting_messages s1) ->
      In msg0 (counting_messages s2).
Proof.
  intros s1 s2 msg lm t H_step msg0 H_in.
  assert (H_step_copy := H_step).
  destruct t; simpl in H_step;
    destruct H_step as [H_subst _];
    try (subst; assumption);
    try (rewrite H_subst; simpl; rewrite in_app_iff; repeat right; assumption);
    try (rewrite H_subst in *; simpl; right;
         assert (H : In msg0 (pending_messages_about_block s1 (get_block msg)) \/ In msg0 (out_messages s1)) by tauto;
         apply in_app_iff in H; assumption);
    try (destruct H_step_copy as [_ [_ [_ [H_init _]]]];
         rewrite H_init in H_in; inversion H_in);
    try (rewrite H_subst; simpl; try rewrite in_app_iff; repeat right;
         assumption).
Qed.

Lemma about_local_out_messages :
  forall (s1 s2 : NState) (msg : message) (lm : list message) (p : NState_transition_type),
    get_transition p s1 msg s2 lm ->
    forall (msg0 : message),
      In msg0 lm ->
      In msg0 (out_messages s2).
Proof.
  intros s1 s2 msg lm p H_step msg0 H_in.
  destruct p;
    assert (H_step_copy := H_step);
    destruct H_step as [H_update [H_out _]];
    rewrite H_out in H_in;
    (* In cases where lm = [] *)
    try (now apply in_nil in H_in);
    try (rewrite H_update; simpl;
         rewrite in_app_iff; tauto);
    try (rewrite H_update; simpl;
         inversion H_in; subst; try tauto;
         right; apply in_app_iff; tauto);
    try (rewrite H_update;
         simpl in *;
         destruct H_in as [H_in | [H_in | [H_in | H_in]]];
         tauto).
Qed.

Lemma not_prepare_stage :
  forall (s : NState) (b : block),
    ~ prepare_stage s b ->
    ~ vote_quorum_in_view s (node_view s) b /\
    forall (msg : message),
      In msg (counting_messages s) ->
      get_block msg = b ->
      get_view msg = (node_view s) ->
      get_message_type msg = PrepareQC ->
      False.
Proof.
  intros s b H_not. split.
  intros H_not2. apply H_not.
  exists (node_view s). split. lia. left. assumption.
  intros.
  apply H_not. exists (node_view s); split; try lia. right. exists msg. tauto.
Qed.

Lemma prepare_stage_record_agnostic :
  forall (s : NState) (b : block) (msg : message),
    prepare_stage (record s msg) b ->
    prepare_stage s b.
Proof.
  intros s b msg H.
  destruct H as [v' [H_past H_prepare]].
  exists v'. split. assumption.
  assumption.
Qed.

Lemma prepare_stage_record_plural_agnostic :
  forall (s : NState) (b : block) (lm : list message),
    prepare_stage (record_plural s lm) b <->
    prepare_stage s b.
Proof.
  intros s b msg; split; intro H.
  destruct H as [v' [H_past H_prepare]].
  exists v'. split. assumption.
  assumption.
  easy.
Qed.

Lemma prepare_stage_process_record_plural_agnostic :
  forall (s : NState) (b : block) (lm : list message) (msg : message),
    prepare_stage (process (record_plural s lm) msg) b <->
    prepare_stage (process s msg) b.
Proof.
  intros s b msg; split; intro H.
  destruct H as [v' [H_past H_prepare]].
  exists v'. split. assumption.
  assumption.
  easy.
Qed.


Require Export LibTactics.
Require Export Metalib.Metatheory.
Require Import Syntax_ott.
Require Import Row_inf.
Require Import Fii_inf.
Require Import Infrastructure.

Set Implicit Arguments.

Fixpoint fv_Gtx (Gtx : GContext) {struct Gtx} : vars :=
  match Gtx with
  | nil            => {}
  | cons (x, y) P' => fv_rtyp_in_rt y \u fv_Gtx P'
  end.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C3 := gather_atoms_with (fun x : stctx => dom x) in
  let C4 := gather_atoms_with (fun x : sctx => dom x) in
  let D4 := gather_atoms_with (fun x => fv_sty_in_sty x) in
  let D5 := gather_atoms_with (fun x => fv_sty_in_sexp x) in
  let D6 := gather_atoms_with (fun x => fv_sexp_in_sexp x) in
  let D8 := gather_atoms_with (fun x => fv_rtyp_in_rtyp x) in
  let D9 := gather_atoms_with (fun x => fv_rtyp_in_rlist x) in
  let D10 := gather_atoms_with (fun x => fv_rtyp_in_rt x) in
  let D11 := gather_atoms_with (fun x => fv_rexp_in_rexp x) in
  let D12 := gather_atoms_with (fun x => fv_rtyp_in_rexp x) in
  let D13 := gather_atoms_with (fun x : GContext => dom x) in
  let D14 := gather_atoms_with (fun x : PContext => dom x) in
  let D15 := gather_atoms_with (fun x => fv_rtyp_in_rt x) in
  let D16 := gather_atoms_with (fun x : TContext => dom x) in
  let D17 := gather_atoms_with (fun x : GContext => fv_Gtx x) in
  let D18 := gather_atoms_with (fun x : PContext => fv_Ptx x) in
  let D19 := gather_atoms_with (fun x : stctx => fv_stctx x) in
  constr:(A \u B \u C3 \u C4 \u D4 \u D5 \u D6 \u D8 \u D9 \u D10 \u D11 \u D12 \u D13 \u D14 \u D15 \u D16 \u D17 \u D18 \u D19).

Lemma fv_notin_open_sty_wrt_sty_rec : forall B X i A,
    X \notin fv_sty_in_sty A  ->
    X \notin fv_sty_in_sty B  ->
    X \notin fv_sty_in_sty (open_sty_wrt_sty_rec i A B).
Proof with eauto.
  intro B. inductions B; introv H1 H2; simpls...
  destruct (lt_eq_lt_dec n i); simpls...
  destruct s; simpls...
Qed.

(* ********************************************************************** *)
(** * Locally Closed *)

Lemma lc_rt_from_wfrt : forall Ttx rt,
    wfrt Ttx rt ->
    lc_rt rt
with lc_rtyp_from_wfr : forall Ttx r,
    wfr Ttx r ->
    lc_rtyp r
with lc_rlist_from_wfcl : forall Ttx R,
    wfcl Ttx R ->
    lc_rlist R.
Proof with eauto.
  -
  induction 1; constructor; auto.
  + eapply lc_rlist_from_wfcl...
  + introv.
    pick_fresh X.
    forwards ~ : H1 X.
    rewrite subst_rtyp_in_rt_intro with (r1:=r_TyVar_f a) (a1:=X)...
    apply subst_rtyp_in_rt_lc_rt...
  + eapply lc_rtyp_from_wfr...

  -
    induction 1; constructor; auto.
    eapply lc_rt_from_wfrt...

  -
    induction 1; constructor; auto.
    eapply lc_rtyp_from_wfr...
Qed.

Lemma lc_sty_from_swft : forall DD B,
    swft DD B ->
    lc_sty B.
Proof with eauto.
  induction 1...
Qed.
Hint Resolve lc_rt_from_wfrt lc_rt_from_wfrt lc_rlist_from_wfcl lc_sty_from_swft : lngen.

(* ********************************************************************** *)
(** * Wellformedness *)

Lemma wfrt_from_binds_wfc: forall Ttx Gtx x rt,
    wfc Ttx Gtx ->
    binds x rt Gtx ->
    wfrt Ttx rt.
Proof.
  introv H BD. induction H.
  false.
  apply binds_cons_1 in BD.
  destruct BD as [ [I1 I2] | I3 ];
  substs; auto.
Qed.

Ltac destruct_hypo :=
  match goal with
  | H: _ /\ _ |- _ => destruct H
  end.

Ltac invert_wfrt :=
  match goal with
  | H : wfrt _ (rt_Record _) |- _ => inverts H
  end.

Lemma cmp_regular : forall Ttx r1 r2,
    cmp Ttx r1 r2 ->
    wfr Ttx r1 /\ wfr Ttx r2
with teq_regular : forall Ttx rt1 rt2,
    teq Ttx rt1 rt2 ->
    wfrt Ttx rt1 /\ wfrt Ttx rt2
with ceq_regular : forall Ttx R1 R2,
    ceq Ttx R1 R2 ->
    wfcl Ttx R1 /\ wfcl Ttx R2.
Proof with eauto.
  -
  induction 1; repeat destruct_hypo; splits...
  + apply teq_regular in H0. destruct_hypo. repeat invert_wfrt...
  + apply teq_regular in H1. destruct_hypo. repeat invert_wfrt...
  + inversions H1...
  + inversions H1...

  -
  induction 1; repeat destruct_hypo; splits; try (solve[repeat invert_wfrt; eauto])...
  + pick fresh X and apply wfrt_All.
    apply ceq_regular in H. destruct_hypo...
    forwards ~ [? ?] : H1 X.
  + pick fresh X and apply wfrt_All.
    apply ceq_regular in H. destruct_hypo...
    forwards ~ : H3 X. destruct_hypo...
  + lets: cmp_regular H. lets: cmp_regular H0.
  repeat destruct_hypo...
  + lets: cmp_regular H. lets: cmp_regular H0.
  repeat destruct_hypo...
  constructor...
  constructor...
  + lets: cmp_regular H. repeat destruct_hypo...
  + lets: cmp_regular H. repeat destruct_hypo...

  -
  induction 1; repeat destruct_hypo; splits...
  + lets: teq_regular H0. destruct_hypo... repeat invert_wfrt...
  + lets: teq_regular H0. destruct_hypo... repeat invert_wfrt...
  + inversions H...
Qed.

Lemma cmpList_wfr: forall Ttx r R,
    cmpList Ttx r R ->
    wfr Ttx r.
Proof with eauto.
  induction 1...
Qed.

Lemma wftc_from_wfc : forall T G,
    wfc T G ->
    wftc T.
Proof with eauto.
  introv WFC.
  induction WFC; simpls...
Qed.

Lemma wftc_uniq : forall Ttx,
    wftc Ttx ->
    uniq Ttx.
Proof with eauto.
  introv WFTC.
  induction WFTC; simpls...
Qed.

Hint Resolve wftc_uniq.

Lemma empty_cmp : forall Ttx R,
    wfcl Ttx R ->
    cmpList Ttx r_Empty R.
Proof with eauto.
  introv WFCL.
  induction WFCL; simpls...
Qed.

Hint Resolve empty_cmp.

Lemma wftc_strength: forall E G,
    wftc (E ++ G) ->
    wftc G.
Proof with eauto.
  intros E.
  alist induction E; introv WFTC; simpls...
  inverts WFTC.
  eapply IHE...
Qed.

Lemma map_subst_rtyp_in_binding_id : forall G Z P,
  Z `notin` fv_Gtx G ->
  G = map (subst_rtyp_in_rt P Z) G.
Proof with eauto.
  intros G.
  induction G; intros...

  destruct a.
  rewrite map_cons.
  simpls.
  f_equal; simpls...

  rewrite subst_rtyp_in_rt_fresh_eq; simpls...
Qed.

Hint Extern 1 (wfr ?E ?t) =>
  match goal with
  | H: cmpList E t _ |- _ => apply (cmpList_wfr H)
  end.

Hint Extern 1 (wfr ?E ?t) =>
  match goal with
  | H: cmp E t _ |- _ => apply (proj1 (cmp_regular H))
  | H: cmp E _ t |- _ => apply (proj2 (cmp_regular H))
  end.

Hint Extern 1 (wfrt ?E ?t) =>
  match goal with
  | H: teq E t _ |- _ => apply (proj1 (teq_regular H))
  | H: teq E _ t |- _ => apply (proj2 (teq_regular H))
  end.

Hint Extern 1 (wfcl ?E ?t) =>
  match goal with
  | H: ceq E t _ |- _ => apply (proj1 (ceq_regular H))
  | H: ceq E _ t |- _ => apply (proj2 (ceq_regular H))
  end.

Lemma cmpList_wfcl: forall Ttx r R,
    cmpList Ttx r R ->
    wftc Ttx ->
    wfcl Ttx R.
Proof with eauto.
  introv H1 H2. inductions H1...
Qed.

Hint Extern 1 (wfcl ?E ?t) =>
  match goal with
  | H: cmpList E _ t |- _ => apply (cmpList_wfcl H)
  end.

(* ********************************************************************** *)
(** * WEAKENING *)

Scheme wfcl_ind := Induction for wfcl Sort Prop
  with wfrt_ind := Induction for wfrt Sort Prop
  with wfr_ind  := Induction for wfr Sort Prop
  with cmp_ind  := Induction for cmp Sort Prop
  with ceq_ind  := Induction for ceq Sort Prop
  with teq_ind  := Induction for teq Sort Prop.

Combined Scheme wfrt_mutind from wfcl_ind, wfrt_ind, wfr_ind, cmp_ind, ceq_ind, teq_ind.

Inductive same_tctx : TContext -> TContext -> Prop :=
| same_empty : same_tctx nil nil
| same_cons : forall X A B s1 s2,
    ceq s1 A B ->
    wfcl s1 A ->
    wfcl s2 B ->
    same_tctx s1 s2 ->  same_tctx ([(X , A)] ++ s1) ([(X , B)] ++ s2).

Lemma same_tctx_dom : forall ctxa ctxb,
    same_tctx ctxa ctxb ->
    dom ctxa [=] dom ctxb.
Proof with eauto; try fsetdec.
  induction 1; simpls...
Qed.

Lemma same_tctx_var : forall s1 s2 X A,
    same_tctx s1 s2 ->
    binds X A s1 ->
    exists B, binds X B s2.
Proof with eauto.
  introv Eq.
  gen X A.
  induction Eq; introv I.

  analyze_binds I.

  analyze_binds I...
  lets (B0 & ?) : IHEq BindsTac.

  exists B0...
Qed.

Hint Constructors same_tctx.
Lemma wf_general_weakening :
  (forall T R,
      wfcl T R ->
        forall G E F,
          T = G ++ E ->
          wftc (G ++ F ++ E) ->
          wfcl (G ++ F ++ E) R)
  /\ (
    forall T R,
      wfrt T R ->
      forall G E F,
        T = G ++ E ->
        wftc (G ++ F ++ E) ->
        wfrt (G ++ F ++ E) R)
  /\ (
    forall T R,
      wfr T R ->
      forall G E F,
          T = G ++ E ->
          wftc (G ++ F ++ E) ->
          wfr (G ++ F ++ E) R)
  /\ (
    forall T R1 R2,
      cmp T R1 R2 ->
      wfr T R1 /\ wfr T R2 /\
      forall G E F,
          T = G ++ E ->
          wftc (G ++ F ++ E) ->
          cmp (G ++ F ++ E) R1 R2)
  /\ (
    forall T R1 R2,
      ceq T R1 R2 ->
      wfcl T R1 /\ wfcl T R2 /\
      forall G E F,
          T = G ++ E ->
          wftc (G ++ F ++ E) ->
          ceq (G ++ F ++ E) R1 R2)
  /\(
    forall T R1 R2,
      teq T R1 R2 ->
      wfrt T R1 /\ wfrt T R2 /\
      forall G E F,
          T = G ++ E ->
          wftc (G ++ F ++ E) ->
          teq (G ++ F ++ E) R1 R2)
.
Proof with eauto.
  apply wfrt_mutind; intros; repeat destruct_hypo; substs; try splits;
    intros; substs;
    repeat invert_wfrt...
  -
  pick fresh X and apply wfrt_All...
  rewrite_env ((([(X, R)] ++ G) ++ F ++ E)).
  apply H0...
  simpl_env...
  - inverts H0...
  - inverts H0...
  - inverts w...
  - pick fresh X and apply wfrt_All...
    forwards ~ : H0 X.
    repeat destruct_hypo...
  - pick fresh X and apply wfrt_All...
    forwards ~ : H1 X.
    repeat destruct_hypo...
  - pick fresh X and apply teq_CongAll...
    rewrite_env ((([(X, R)] ++ G) ++ F ++ E)).
    apply H0... simpl. constructor...
    forwards ~ : H3 G E F...
    rewrite_env ((([(X, R')] ++ G) ++ F ++ E)).
    apply H1... simpl. constructor...
    forwards ~ : H3 G E F...
  - intros. subst...
    apply teq_CongMerge...
  - apply wfrt_Rec.
    constructor...
Qed.

Lemma wfcl_weakening : forall R G E F,
    wfcl (G ++ E) R ->
    wftc (G ++ F ++ E) ->
    wfcl (G ++ F ++ E) R.
Proof.
  intros.
  pose (proj1 wf_general_weakening) as I.
  eapply I; eauto.
Qed.

Lemma wfcl_weakening_head : forall R E F,
    wfcl E R ->
    wftc (F ++ E) ->
    wfcl (F ++ E) R.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply wfcl_weakening; eauto.
Qed.

Lemma wfcl_weakening_tail : forall R E G,
    wfcl G R ->
    wftc (G ++ E) ->
    wfcl (G ++ E) R.
Proof with eauto.
  intros.
  rewrite_env (G ++ E ++ nil).
  apply wfcl_weakening; simpl_env...
Qed.

Lemma wfcl_from_binds_wftc: forall Ttx a A,
  wftc Ttx ->
  binds a A Ttx ->
  wfcl Ttx A.
Proof with eauto.
  introv H BD. induction H.
  false.
  apply binds_cons_1 in BD.
  destruct BD as [ [I1 I2] | I3 ];
  substs;
  apply wfcl_weakening_head...
Qed.

Lemma wfr_weakening : forall R G E F,
    wfr (G ++ E) R ->
    wftc (G ++ F ++ E) ->
    wfr (G ++ F ++ E) R.
Proof.
  intros.
  pose (proj1 (proj2 (proj2 wf_general_weakening))) as I.
  eapply I; eauto.
Qed.

Lemma wfr_weakening_head : forall R E F,
    wfr E R ->
    wftc (F ++ E) ->
    wfr (F ++ E) R.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply wfr_weakening; eauto.
Qed.

Lemma wfr_weakening_tail : forall R E G,
    wfr G R ->
    wftc (G ++ E) ->
    wfr (G ++ E) R.
Proof with eauto.
  intros.
  rewrite_env (G ++ E ++ nil).
  apply wfr_weakening; simpl_env...
Qed.

Lemma wfrt_weakening : forall R G E F,
    wfrt (G ++ E) R ->
    wftc (G ++ F ++ E) ->
    wfrt (G ++ F ++ E) R.
Proof.
  intros.
  pose ((proj1 (proj2 wf_general_weakening))) as I.
  eapply I; eauto.
Qed.

Lemma wfrt_weakening_head : forall R E F,
    wfrt E R ->
    wftc (F ++ E) ->
    wfrt (F ++ E) R.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply wfrt_weakening; eauto.
Qed.

Lemma wfrt_weakening_tail : forall R E G,
    wfrt G R ->
    wftc (G ++ E) ->
    wfrt (G ++ E) R.
Proof with eauto.
  intros.
  rewrite_env (G ++ E ++ nil).
  apply wfrt_weakening; simpl_env...
Qed.

Lemma cmp_weakening : forall G E F A B,
    cmp (G ++ E) A B ->
    wftc (G ++ F ++ E) ->
    cmp (G ++ F ++ E) A B.
Proof.
  intros.
  pose (proj1 (proj2 (proj2 (proj2 wf_general_weakening))))  as I.
  eapply I; eauto.
Qed.

Lemma cmp_weakening_head : forall E F A B,
    cmp E A B ->
    wftc (F ++ E) ->
    cmp (F ++ E) A B.
Proof.
  intros. rewrite_env (nil ++ F ++ E).
  apply cmp_weakening; eauto.
Qed.

(* ********************************************************************** *)
(** * FV *)

Scheme rlist_ind := Induction for wfcl Sort Prop
  with rt_ind    := Induction for wfrt Sort Prop
  with rtyp_ind  := Induction for wfr  Sort Prop.
Combined Scheme rlist_rt_mutind from rlist_ind, rt_ind, rtyp_ind.

Lemma notin_fv_rtyp_in_rt_open_rt_wrt_rtyp_rec: forall A a B n,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rt A ->
    a `notin` fv_rtyp_in_rt (open_rt_wrt_rtyp_rec n B A)
with  notin_fv_rtyp_in_rlist_open_rlist_wrt_rtyp_rec: forall A a B n,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rlist A ->
    a `notin` fv_rtyp_in_rlist (open_rlist_wrt_rtyp_rec n B A)
with  notin_fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp_rec: forall A a B n,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rtyp A ->
    a `notin` fv_rtyp_in_rtyp (open_rtyp_wrt_rtyp_rec n B A).
Proof.
  -
  intro A. induction A; introv NOT1 NOT2 ; simpls; auto.
  -
  intro A. induction A; introv NOT1 NOT2 ; simpls; auto.
  -
  intro A. induction A. introv I1; introv I2 . simpl.
  destruct (lt_eq_lt_dec n n0). destruct s; simpl; auto...
  simpl; auto.

  introv I1; introv I2 . simpl; auto.
  introv I1; introv I2 . simpl; auto.
  introv I1; introv I2 . simpl; auto.
  introv I1; introv I2 . simpl; auto.
  simpl in I2.
  apply notin_union.
  apply IHA1; auto.
  apply IHA2; auto.
Qed.

Lemma notin_fv_rtyp_in_rt_open_rt_wrt_rtyp: forall A a B,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rt A ->
    a `notin` fv_rtyp_in_rt (open_rt_wrt_rtyp A B).
Proof.
  introv I1 I2.
  unfold open_rt_wrt_rtyp.
  apply notin_fv_rtyp_in_rt_open_rt_wrt_rtyp_rec; eauto.
Qed.

Lemma notin_fv_rtyp_in_rlist_open_rlist_wrt_rtyp: forall A a B,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rlist A ->
    a `notin` fv_rtyp_in_rlist (open_rlist_wrt_rtyp A B).
Proof.
  introv I1 I2.
  unfold open_rlist_wrt_rtyp.
  apply notin_fv_rtyp_in_rlist_open_rlist_wrt_rtyp_rec; eauto.
Qed.

Lemma  notin_fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp: forall A a B,
    a `notin` fv_rtyp_in_rtyp B ->
    a `notin` fv_rtyp_in_rtyp A ->
    a `notin` fv_rtyp_in_rtyp (open_rtyp_wrt_rtyp A B).
Proof.
  introv I1 I2.
  unfold open_rlist_wrt_rtyp.
  apply notin_fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp_rec; eauto.
Qed.

Lemma notin_Fv_rtyp_in_rt_open_rt_wrt_rtyp_inverse: forall A B a n,
    a `notin` fv_rtyp_in_rt (open_rt_wrt_rtyp_rec n B A) ->
    a `notin` fv_rtyp_in_rt A
with notin_Fv_rtyp_in_rlist_open_rlist_wrt_rtyp_inverse: forall A B a n,
    a `notin` fv_rtyp_in_rlist (open_rlist_wrt_rtyp_rec n B A) ->
    a `notin` fv_rtyp_in_rlist A
with notin_Fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp_inverse: forall A B a n,
    a `notin` fv_rtyp_in_rtyp (open_rtyp_wrt_rtyp_rec n B A) ->
    a `notin` fv_rtyp_in_rtyp A.
Proof with auto.
  -
    induction A; introv NOTIN; simpls...
    forwards ~ : IHA1. forwards ~ : IHA2.
    apply notin_union.
    apply notin_Fv_rtyp_in_rlist_open_rlist_wrt_rtyp_inverse with B n...
    apply IHA with B (S n)...
    apply notin_Fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp_inverse with B n...
  -
    induction A; introv NOTIN; simpls...
    apply notin_union.
    apply notin_Fv_rtyp_in_rtyp_open_rtyp_wrt_rtyp_inverse with B n...
    apply IHA with B (n)...
  -
    induction A; introv NOTIN; simpls...
    apply notin_Fv_rtyp_in_rt_open_rt_wrt_rtyp_inverse with B n...
    apply notin_union.
    apply IHA1 with B n... apply IHA2 with B n...
Qed.

Lemma wfr_fresh : forall F r a,
    wfr F r ->
    a `notin` dom F ->
    a `notin` fv_rtyp_in_rtyp r
with wfrt_fresh : forall F r a,
    wfrt F r ->
    a `notin` dom F ->
    a `notin` fv_rtyp_in_rt r
with wfcl_fresh : forall F r a,
    wfcl F r ->
    a `notin` dom F ->
    a `notin` fv_rtyp_in_rlist r.
Proof.
  -
    induction 1; introv NOTIN; simpl; auto.
    apply test_solve_notin_3. introv I. substs.
    false binds_dom_contradiction; eauto.
    apply wfrt_fresh with Ttx; auto...
  -
    induction 1; introv NOTIN; simpl; auto.
    apply notin_union. apply wfcl_fresh with Ttx; auto.
    pick_fresh X. forwards ~ : H1 X; auto.

    eapply notin_Fv_rtyp_in_rt_open_rt_wrt_rtyp_inverse. eassumption.
    apply wfr_fresh with Ttx; auto.
  -
    induction 1; introv NOTIN; simpl; auto.
    apply notin_union. apply wfr_fresh with Ttx; auto.
    apply IHwfcl; auto.
Qed.

(* ********************************************************************** *)
(** * CMP *)

Lemma cmp_from_cmpList : forall F B R r,
    cmpList F B R ->
    rtyp_in_rlist r R ->
    cmp F B r.
Proof.
  induction 1; introv Rin; simpls.
  inverts Rin.
  inverts Rin; auto.
Qed.

(* ********************************************************************** *)
(** * SUBSTITUTION *)

Lemma subst_rtyp_rtyp_in_rlist: forall r R a B,
    rtyp_in_rlist r R ->
    rtyp_in_rlist (subst_rtyp_in_rtyp B a r) (subst_rtyp_in_rlist B a R).
Proof.
  induction 1; simpls.
  apply ti_head...
  apply ti_cons; auto...
Qed.

Scheme wftc_ind1 := Induction for wftc Sort Prop
  with wfcl_ind1 := Induction for wfcl Sort Prop
  with wfrt_ind1 := Induction for wfrt Sort Prop
  with wfr_ind1 := Induction for wfr Sort Prop
  with cmp_ind1 := Induction for cmp Sort Prop
  with ceq_ind1 := Induction for ceq Sort Prop
  with teq_ind1 := Induction for teq Sort Prop.

Combined Scheme wfrt_mutind' from wftc_ind1, wfcl_ind1, wfrt_ind1, wfr_ind1, cmp_ind1, ceq_ind1, teq_ind1.

Lemma wf_general_subst :
  ( forall T,
      wftc T ->
      forall E F B a R,
        T = (E ++ [(a, R)] ++ F) ->
        cmpList F B R ->
        wfr F B ->
        wftc (map (subst_rtyp_in_rlist B a) E ++ F)
  ) /\ (
   forall T A,
    wfcl T A ->
    forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      wfcl (map (subst_rtyp_in_rlist B a) E ++ F)
           (subst_rtyp_in_rlist B a A)
  ) /\ (
    forall T A,
    wfrt T A ->
    forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      wfrt (map ( subst_rtyp_in_rlist B a ) E ++ F)
           (subst_rtyp_in_rt B a A)
  ) /\ (
    forall T A,
    wfr T A ->
    forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      wfr (map (subst_rtyp_in_rlist B a) E ++ F)
          (subst_rtyp_in_rtyp B a A)
  ) /\ (
    forall T A C,
      cmp T A C ->
      forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      cmp (map (subst_rtyp_in_rlist B a) E ++ F)
          (subst_rtyp_in_rtyp B a A)
          (subst_rtyp_in_rtyp B a C)
  ) /\ (
    forall T A C,
      ceq T A C ->
      forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      ceq (map (subst_rtyp_in_rlist B a) E ++ F)
          (subst_rtyp_in_rlist B a A)
          (subst_rtyp_in_rlist B a C)
  ) /\ (
    forall T A C,
      teq T A C ->
      forall E F B a R,
      wftc T ->
      wftc (map ( subst_rtyp_in_rlist B a ) E ++ F) ->
      T = (E ++ [(a, R)] ++ F) ->
      cmpList F B R ->
      wfr F B ->
      teq (map (subst_rtyp_in_rlist B a) E ++ F)
          (subst_rtyp_in_rt B a A)
          (subst_rtyp_in_rt B a C)
  )
.
Proof with eauto.
  apply wfrt_mutind'; try solve [intros; substs; simpl; eauto].
  - intros. false nil_neq_one_mid...
  - introv WF IH1 WF2 IH2 NEQ EQ CMP WFR; substs.
    analyze_binds EQ.
    apply one_eq_app in EQ.
    destruct EQ as [ (qs & [I1 I2]) | [I1 I2]]; substs.
    simpl. constructor...
    simpl. simpl in I2.
    invert I2. intros. substs...
  - introv WFCL IH1 IH2 IH3 WFTC1 WFTC2 EQ CMP WFR. substs.
    simpl.
    pick fresh X and apply wfrt_All...
    forwards ~ : IH3 X ([(X, R)] ++ E) B a R0...
    simpl. constructor...
    simpl... simpl in H.
    unfold open_rt_wrt_rtyp in H.
    rewrite subst_rtyp_in_rt_open_rt_wrt_rtyp_rec in H...
    rewrite subst_rtyp_in_rtyp_fresh_eq in H...
    apply lc_rtyp_from_wfr with F...
  - introv BD WFTC1 WFTC2 EQ CMP WFR. substs... simpl.
    case_if...
    eapply wfr_weakening_head...
    analyze_binds BD...
  - introv WFCL IH1 WFR IH2 BD RTY WFR1 WFR3 EQ CMP. introv WFR2. substs.
    simpl. case_if; subst.
    +
    apply binds_mid_eq in BD; auto. substs.
    apply cmp_weakening_head; auto.
    forwards ~ : cmp_from_cmpList CMP RTY.
    rewrite subst_rtyp_in_rtyp_fresh_eq; auto.
    apply wfr_fresh with F...
    apply fresh_mid_tail with R0 E...
    +
    analyze_binds BD.
    apply subst_rtyp_rtyp_in_rlist with (a:=a0) (B:=B) in RTY.
    apply binds_map_2 with(f:=subst_rtyp_in_rlist B a0) in BindsTac.
    apply cmp_Tvar with (subst_rtyp_in_rlist B a0 R)...

    apply subst_rtyp_rtyp_in_rlist with (a:=a0) (B:=B) in RTY.
    apply cmp_Tvar with (subst_rtyp_in_rlist B a0 R)...
    rewrite subst_rtyp_in_rlist_fresh_eq; auto.
    apply wfcl_fresh with F...
    eapply wfcl_from_binds_wftc...
    apply wftc_strength with (E ++ [(a0, R0)]);
    rewrite_env (E ++ [(a0, R0)] ++ F)...
    apply fresh_mid_tail with R0 E...
  - introv CMP IH1 WFRT IH2 WFTC WFTC2 EQ CMP2 WFR2. subst.
    simpl.
    apply cmp_Base with (subst_rtyp_in_rt B a rt5)...
  - introv CMP IH1 WFTC WFTC2 EQ CMP2 WFR. subst.
    apply cmp_MergeE1 with (subst_rtyp_in_rtyp B a s2)...
  - introv CMP IH1 WFTC WFTC2 EQ CMP2 WFR. subst.
    apply cmp_MergeE2 with (subst_rtyp_in_rtyp B a s1)...
  - intros. simpls. substs.
    pick fresh X and apply teq_CongAll...
    specialize (H0 X).
    forwards ~ : H0 ((X, R) :: E) F B a R0.
    constructor...
    simpls...
    constructor... forwards ~ : H H2 H3 .
    simpls...
    unfold open_rt_wrt_rtyp in H4.
    do 2 rewrite subst_rtyp_in_rt_open_rt_wrt_rtyp_rec in H4...
    rewrite subst_rtyp_in_rtyp_fresh_eq in H4...
    apply lc_rtyp_from_wfr with F...
    apply lc_rtyp_from_wfr with F...
    apply lc_rtyp_from_wfr with F...
    specialize (H1 X).
    forwards ~ : H1 ((X, R') :: E) F B a R0.
    constructor...
    simpls...
    constructor... forwards ~ : H H2 H3 .
    simpls...
    constructor... forwards ~ : H H2 H3.
    simpls...
    unfold open_rt_wrt_rtyp in H4.
    unfold open_rt_wrt_rtyp in H4.
    do 2 rewrite subst_rtyp_in_rt_open_rt_wrt_rtyp_rec in H4...
    rewrite subst_rtyp_in_rtyp_fresh_eq in H4...
    apply lc_rtyp_from_wfr with F...
    apply lc_rtyp_from_wfr with F...
    apply lc_rtyp_from_wfr with F...
  - intros. simpl... apply teq_CongMerge...
Qed.

Lemma wfrt_subst : forall A E F B a R,
    wfrt (E ++ [(a, R)] ++ F) A ->
    wftc (E ++ [(a, R)] ++ F) ->
    cmpList F B R ->
    wfr F B ->
    wfrt (map ( subst_rtyp_in_rlist B a ) E ++ F)
         (subst_rtyp_in_rt B a A).
Proof.
  intros.
  pose (proj1 (proj2 (proj2 wf_general_subst))) as I.
  eapply I; eauto.
  pose (proj1 wf_general_subst) as I2.
  eapply I2; eauto.
Qed.

Lemma wfcl_subst : forall A E F B a R,
    wfcl (E ++ [(a, R)] ++ F) A ->
    wftc (E ++ [(a, R)] ++ F) ->
    cmpList F B R ->
    wfr F B ->
    wfcl (map ( subst_rtyp_in_rlist B a ) E ++ F)
         (subst_rtyp_in_rlist B a A).
Proof.
  intros.
  pose (proj1 (proj2 wf_general_subst)) as I.
  eapply I; eauto.
  pose (proj1 wf_general_subst) as I2.
  eapply I2; eauto.
Qed.

Lemma wfc_subst_tb : forall F E Z P T B,
  wfc (F ++ Z ~ B ++ E) T ->
  wfr E P ->
  cmpList E P B ->
  wftc (map (subst_rtyp_in_rlist P Z) F ++ E) ->
  wfc (map (subst_rtyp_in_rlist P Z) F ++ E) (map (subst_rtyp_in_rt P Z) T).
Proof with eauto using wftc_from_wfc.
  introv WFC.
  remember (F ++ Z ~ B ++ E) as G.
  generalize dependent F.
  induction WFC; introv EQ WFR CMP Ok; subst; simpls...

  constructor...
  simpl_env in *.
  eapply wfrt_subst...
Qed.

Lemma wftc_subst_tb : forall Q Z P E F,
  wftc (F ++ Z ~ Q ++ E) ->
  wfr E P ->
  cmpList E P Q ->
  wftc (map (subst_rtyp_in_rlist P Z) F ++ E).
Proof with eauto.
  introv WFTC.
  alist induction F; introv WFR CMP; simpls...

  inverts WFTC...

  inverts WFTC...

  constructor...
  simpl_env in *.
  eapply wfcl_subst...
Qed.

Lemma wfc_strengthen : forall X R Ttx Gtx,
      wfc ([(X, R)] ++ Ttx) Gtx ->
      wftc Ttx ->
      wfcl Ttx R ->
      X \notin fv_Gtx Gtx ->
      wfc Ttx Gtx.
Proof with eauto.
  introv WFC WFTC WFCL NOTIN.

  rewrite_env (nil ++ [(X, R)] ++ Ttx) in WFC.
  forwards IMP : wfc_subst_tb WFC...
  simpls.
  rewrite <- map_subst_rtyp_in_binding_id in IMP...
Qed.

(* ********************************************************************** *)
(** * BINDING *)

Lemma wfp_binds : forall a R Ttx Ptx,
  binds a R Ttx ->
  wfp Ttx Ptx   ->
  exists b, binds a b Ptx.
Proof with auto.
  induction 2...
  false.
  apply binds_cons_1 in H.
  destruct H as [[I1 I2]| I3].
    subst. exists b...
    forwards ~ (? & ?) : IHwfp I3.
    exists x...
Qed.

Lemma binds_ptx_fv: forall a b Ptx,
      binds a b Ptx ->
      b `in` fv_Ptx Ptx.
Proof with eauto.
  introv BD. inductions Ptx...
  false. destruct a0. analyze_binds BD; simpl...
Qed.

Lemma wfp_binds_neq : forall Ttx Ptx a1 a2 b1 b2,
    wfp Ttx Ptx ->
    binds a1 b1 Ptx ->
    binds a2 b2 Ptx ->
    b1 <> a2.
Proof with eauto.
  induction 1; introv BD1 BD2; eauto.
  analyze_binds BD1; analyze_binds BD2.
  forwards ~ : binds_In BindsTac...
  introv I. subst. false H5...
  forwards ~ : binds_ptx_fv BindsTac.
  introv I. subst. false H3...
Qed.

Lemma wfp_binds_range_neq : forall Ttx Ptx a1 a2 b1 b2,
    wfp Ttx Ptx ->
    binds a1 b1 Ptx ->
    binds a2 b2 Ptx ->
    a1 <> a2 ->
    b1 <> b2.
Proof with eauto.
  induction 1; introv BD1 BD2 NEQ; eauto.
  analyze_binds BD1; analyze_binds BD2.
  forwards ~ : binds_ptx_fv BindsTac.
  introv I. subst. false H6...
  forwards ~ : binds_ptx_fv BindsTac.
  introv I. subst. false H6...
Qed.

Lemma wfp_uniq : forall Ttx Ptx,
  wfp Ttx Ptx ->
  uniq Ptx.
Proof.
  induction 1; eauto.
Qed.
Hint Resolve wfp_binds_neq wfp_uniq.

Lemma fv_Ptx_union : forall G P,
    fv_Ptx (G ++ P) [=] fv_Ptx G \u fv_Ptx P.
Proof with eauto.
  intros G.
  induction G; intros; simpls...

  fsetdec.

  destruct a.
  specializes IHG P.
  rewrite IHG.
  fsetdec.
Qed.

Lemma wfp_mid_inv : forall Ptx1 Ptx2 a0 b0 Ttx,
    wfp Ttx (Ptx1 ++ [(a0, b0)] ++ Ptx2) ->
    b0 \notin dom (Ptx1 ++ Ptx2) /\ b0 \notin fv_Ptx (Ptx1 ++ Ptx2 ).
Proof with eauto.
  introv WFP. inductions WFP.
  assert (binds a0 b0 nil).
  rewrite x...
  false.

  apply one_eq_app in x.
  destruct x as [ (P' & [I1 I2]) | [I1 I2]]; substs.
  forwards ~ : IHWFP.
  destruct_hypo. simpl_env in *.
  repeat rewrite fv_Ptx_union in *.
  simpls. splits...

  simpl in I2. simpl_env.
  inverts I2...
Qed.

(* ********************************************************************** *)
(** * TEQ *)

Lemma teq_record_r : forall Ttx rt r,
    teq Ttx rt (rt_Record r) ->
    exists r2, rt = rt_Record r2
with teq_record_l : forall Ttx rt r,
    teq Ttx (rt_Record r) rt ->
    exists r2, rt = rt_Record r2.
Proof with auto.
  -
    introv EQ. inductions EQ.
    + exists r...
    + forwards : teq_record_l EQ.
      destruct_exists.
      exists x...
    + forwards ~ : IHEQ2. destruct_exists.
      forwards : IHEQ1 H. destruct_exists.
      exists x0...
    + exists (r_SingleField l rt5)...
    + exists (r_Merge r1 r2)...
    + exists (r_Merge r r_Empty)...
    + exists (r_Merge r1 (r_Merge r2 r3))...
    + exists (r_Merge r1 r2)...
  -
    introv EQ. inductions EQ.
    + exists r...
    + forwards : teq_record_r EQ.
      destruct_exists.
      exists x...
    + forwards ~ : IHEQ1. destruct_exists.
      forwards : IHEQ2 H. destruct_exists.
      exists x0...
    + exists (r_SingleField l rt')...
    + exists (r_Merge r1' r2')...
    + exists (r0)...
    + exists (r_Merge (r_Merge r1 r2) r3)...
    + exists (r_Merge r2 r1)...
Qed.